summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-11-24 17:31:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-11-24 17:31:00 (GMT)
commit006fb5f4e9b1a956a896606949b3e028847183f9 (patch)
treec7657d3725a71473e146c6037f4580c0e43c6aed
parenta1cc4a093cf938a1d8a20046e88141543df18ec9 (diff)
version 0.6.1.20.6.1.2
-rw-r--r--examples/failing/TypeSynonyms4.purs8
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript/AST/Binders.hs2
-rw-r--r--src/Language/PureScript/AST/Declarations.hs8
-rw-r--r--src/Language/PureScript/AST/SourcePos.hs25
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs2
-rw-r--r--src/Language/PureScript/Errors.hs6
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs36
-rw-r--r--src/Language/PureScript/Sugar/Names.hs20
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs6
-rw-r--r--src/Language/PureScript/TypeChecker.hs8
11 files changed, 78 insertions, 45 deletions
diff --git a/examples/failing/TypeSynonyms4.purs b/examples/failing/TypeSynonyms4.purs
new file mode 100644
index 0000000..42c60a8
--- /dev/null
+++ b/examples/failing/TypeSynonyms4.purs
@@ -0,0 +1,8 @@
+module TypeSynonyms4 where
+
+type F x y = x -> y
+
+type G x = F x
+
+f :: G String String -> String
+f k = k "Done"
diff --git a/purescript.cabal b/purescript.cabal
index 59662dd..c5d4c3d 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.6.1.1
+version: 0.6.1.2
cabal-version: >=1.8
build-type: Simple
license: MIT
diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs
index 50c1a62..dd06b45 100644
--- a/src/Language/PureScript/AST/Binders.hs
+++ b/src/Language/PureScript/AST/Binders.hs
@@ -68,7 +68,7 @@ data Binder
-- |
-- A binder with source position information
--
- | PositionedBinder SourcePos Binder deriving (Show, D.Data, D.Typeable)
+ | PositionedBinder SourceSpan Binder deriving (Show, D.Data, D.Typeable)
-- |
-- Collect all names introduced in binders in an expression
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 8a9d163..0266908 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -57,7 +57,7 @@ data DeclarationRef
-- |
-- A declaration reference with source position information
--
- | PositionedDeclarationRef SourcePos DeclarationRef
+ | PositionedDeclarationRef SourceSpan DeclarationRef
deriving (Show, D.Data, D.Typeable)
instance Eq DeclarationRef where
@@ -147,7 +147,7 @@ data Declaration
-- |
-- A declaration with source position information
--
- | PositionedDeclaration SourcePos Declaration
+ | PositionedDeclaration SourceSpan Declaration
deriving (Show, D.Data, D.Typeable)
-- |
@@ -324,7 +324,7 @@ data Expr
-- |
-- A value with source position information
--
- | PositionedValue SourcePos Expr deriving (Show, D.Data, D.Typeable)
+ | PositionedValue SourceSpan Expr deriving (Show, D.Data, D.Typeable)
-- |
-- An alternative in a case statement
@@ -359,4 +359,4 @@ data DoNotationElement
-- |
-- A do notation element with source position information
--
- | PositionedDoNotationElement SourcePos DoNotationElement deriving (Show, D.Data, D.Typeable)
+ | PositionedDoNotationElement SourceSpan DoNotationElement deriving (Show, D.Data, D.Typeable)
diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs
index dc9ee44..bc48f19 100644
--- a/src/Language/PureScript/AST/SourcePos.hs
+++ b/src/Language/PureScript/AST/SourcePos.hs
@@ -23,13 +23,9 @@ import qualified Data.Data as D
--
data SourcePos = SourcePos
{ -- |
- -- Source name
- --
- sourceName :: String
- -- |
-- Line number
--
- , sourcePosLine :: Int
+ sourcePosLine :: Int
-- |
-- Column number
--
@@ -37,4 +33,21 @@ data SourcePos = SourcePos
} deriving (D.Data, D.Typeable)
instance Show SourcePos where
- show sp = sourceName sp ++ " line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)
+ show sp = "line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)
+
+data SourceSpan = SourceSpan
+ { -- |
+ -- Source name
+ --
+ spanName :: String
+ -- |
+ -- Start of the span
+ --
+ , spanStart :: SourcePos
+ -- End of the span
+ --
+ , spanEnd :: SourcePos
+ } deriving (D.Data, D.Typeable)
+
+instance Show SourceSpan where
+ show sp = spanName sp ++ " " ++ show (spanStart sp) ++ " - " ++ show (spanEnd sp) \ No newline at end of file
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index 8efba66..8490730 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -97,7 +97,7 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite
exportToPs (TypeInstanceRef ident) = do
let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =
- fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find ((== Qualified (Just moduleName) ident) . tcdName) $ M.elems $ typeClassDictionaries env
+ fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find (\tcd -> tcdName tcd == Qualified (Just moduleName) ident && tcdType tcd == TCDRegular) $ M.elems $ typeClassDictionaries env
let constraintsText = case fromMaybe [] deps of
[] -> ""
cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 7b43e00..4ced126 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -56,7 +56,7 @@ data CompileError
-- |
-- Optional source position information
--
- , compileErrorPosition :: Maybe SourcePos
+ , compileErrorPosition :: Maybe SourceSpan
}
deriving (Show)
@@ -109,7 +109,7 @@ showError (CompileError msg (Just (TypeError ty)) _) = "Error in type " ++ prett
mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack
mkErrorStack msg t = ErrorStack [CompileError msg t Nothing]
-positionError :: SourcePos -> ErrorStack
+positionError :: SourceSpan -> ErrorStack
positionError pos = ErrorStack [CompileError "" Nothing (Just pos)]
-- |
@@ -121,7 +121,7 @@ rethrow f = flip catchError $ \e -> throwError (f e)
-- |
-- Rethrow an error with source position information
--
-rethrowWithPosition :: (MonadError ErrorStack m) => SourcePos -> m a -> m a
+rethrowWithPosition :: (MonadError ErrorStack m) => SourceSpan -> m a -> m a
rethrowWithPosition pos = rethrow (positionError pos <>)
-- |
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 0b7c371..1ddf92f 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -48,10 +48,15 @@ import qualified Text.Parsec.Expr as P
-- |
-- Read source position information
--
-sourcePos :: P.Parsec s u SourcePos
-sourcePos = toSourcePos <$> P.getPosition
+withSourceSpan :: (SourceSpan -> a -> a) -> P.Parsec s u a -> P.Parsec s u a
+withSourceSpan f p = do
+ start <- P.getPosition
+ x <- p
+ end <- P.getPosition
+ let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end)
+ return $ f sp x
where
- toSourcePos p = SourcePos (P.sourceName p) (P.sourceLine p) (P.sourceColumn p)
+ toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos)
kindedIdent :: P.Parsec String ParseState (String, Maybe Kind)
kindedIdent = (, Nothing) <$> identifier
@@ -165,11 +170,11 @@ parseImportDeclaration = do
parseDeclarationRef :: P.Parsec String ParseState DeclarationRef
-parseDeclarationRef = PositionedDeclarationRef <$> sourcePos <*>
- (ValueRef <$> parseIdent
- <|> do name <- properName
- dctors <- P.optionMaybe $ parens (lexeme (P.string "..") *> pure Nothing <|> Just <$> commaSep properName)
- return $ maybe (TypeClassRef name) (TypeRef name) dctors)
+parseDeclarationRef = withSourceSpan PositionedDeclarationRef $
+ ValueRef <$> parseIdent
+ <|> do name <- properName
+ dctors <- P.optionMaybe $ parens (lexeme (P.string "..") *> pure Nothing <|> Just <$> commaSep properName)
+ return $ maybe (TypeClassRef name) (TypeRef name) dctors
parseTypeClassDeclaration :: P.Parsec String ParseState Declaration
parseTypeClassDeclaration = do
@@ -203,7 +208,7 @@ parseTypeInstanceDeclaration = do
return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members
positioned :: P.Parsec String ParseState Declaration -> P.Parsec String ParseState Declaration
-positioned d = PositionedDeclaration <$> sourcePos <*> d
+positioned d = withSourceSpan PositionedDeclaration d
-- |
-- Parse a single declaration
@@ -222,10 +227,10 @@ parseDeclaration = positioned (P.choice
]) P.<?> "declaration"
parseLocalDeclaration :: P.Parsec String ParseState Declaration
-parseLocalDeclaration = PositionedDeclaration <$> sourcePos <*> P.choice
+parseLocalDeclaration = positioned (P.choice
[ parseTypeDeclaration
, parseValueDeclaration
- ] P.<?> "local declaration"
+ ] P.<?> "local declaration")
-- |
-- Parse a module header and a collection of declarations
@@ -374,10 +379,10 @@ parseDoNotationElement = P.choice
-- Parse a value
--
parseValue :: P.Parsec String ParseState Expr
-parseValue = PositionedValue <$> sourcePos <*>
+parseValue = withSourceSpan PositionedValue
(P.buildExpressionParser operators
- . C.buildPostfixParser postfixTable2
- $ indexersAndAccessors) P.<?> "expression"
+ . C.buildPostfixParser postfixTable2
+ $ indexersAndAccessors) P.<?> "expression"
where
indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom
postfixTable1 = [ parseAccessor
@@ -439,8 +444,7 @@ parseIdentifierAndBinder = do
-- Parse a binder
--
parseBinder :: P.Parsec String ParseState Binder
-parseBinder = PositionedBinder <$> sourcePos <*>
- P.buildExpressionParser operators parseBinderAtom P.<?> "expression"
+parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators parseBinderAtom P.<?> "expression")
where
operators = [ [ P.Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) P.AssocRight ] ]
parseBinderAtom :: P.Parsec String ParseState Binder
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 1891586..917d563 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -198,7 +198,7 @@ renameInModule imports exports (Module mn decls exps) =
where
(go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS
- updateDecl :: (Maybe SourcePos, [Ident]) -> Declaration -> Either ErrorStack ((Maybe SourcePos, [Ident]), Declaration)
+ updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Declaration)
updateDecl (_, bound) d@(PositionedDeclaration pos _) = return ((Just pos, bound), d)
updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =
(,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)
@@ -216,7 +216,7 @@ renameInModule imports exports (Module mn decls exps) =
(,) (pos, name : bound) <$> (ExternDeclaration fit name js <$> updateTypesEverywhere pos ty)
updateDecl s d = return (s, d)
- updateValue :: (Maybe SourcePos, [Ident]) -> Expr -> Either ErrorStack ((Maybe SourcePos, [Ident]), Expr)
+ updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Expr)
updateValue (_, bound) v@(PositionedValue pos' _) = return ((Just pos', bound), v)
updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
updateValue (pos, bound) (Let ds val') =
@@ -234,12 +234,12 @@ renameInModule imports exports (Module mn decls exps) =
updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)
updateValue s v = return (s, v)
- updateBinder :: (Maybe SourcePos, [Ident]) -> Binder -> Either ErrorStack ((Maybe SourcePos, [Ident]), Binder)
+ updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Binder)
updateBinder (_, bound) v@(PositionedBinder pos _) = return ((Just pos, bound), v)
updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)
updateBinder s v = return (s, v)
- updateCase :: (Maybe SourcePos, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourcePos, [Ident]), CaseAlternative)
+ updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourceSpan, [Ident]), CaseAlternative)
updateCase (pos, bound) c@(CaseAlternative bs _) = return ((pos, concatMap binderNames bs ++ bound), c)
letBoundVariable :: Declaration -> Maybe Ident
@@ -247,10 +247,10 @@ renameInModule imports exports (Module mn decls exps) =
letBoundVariable (PositionedDeclaration _ d) = letBoundVariable d
letBoundVariable _ = Nothing
- updateTypesEverywhere :: Maybe SourcePos -> Type -> Either ErrorStack Type
+ updateTypesEverywhere :: Maybe SourceSpan -> Type -> Either ErrorStack Type
updateTypesEverywhere pos0 = everywhereOnTypesM (updateType pos0)
where
- updateType :: Maybe SourcePos -> Type -> Either ErrorStack Type
+ updateType :: Maybe SourceSpan -> Type -> Either ErrorStack Type
updateType pos (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos
updateType pos (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys
updateType pos (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t
@@ -269,7 +269,7 @@ renameInModule imports exports (Module mn decls exps) =
-> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))
-> (Exports -> a -> Bool)
-> Qualified a
- -> Maybe SourcePos
+ -> Maybe SourceSpan
-> Either ErrorStack (Qualified a)
update t getI checkE qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imports', mn') of
(Just qname', _) -> return qname'
@@ -385,7 +385,7 @@ filterExports mn exps env = do
-- Finds the imports within a module, mapping the imported module name to an optional set of
-- explicitly imported declarations.
--
-findImports :: [Declaration] -> M.Map ModuleName (Maybe SourcePos, ImportDeclarationType, Maybe ModuleName)
+findImports :: [Declaration] -> M.Map ModuleName (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)
findImports = foldl (findImports' Nothing) M.empty
where
findImports' pos result (ImportDeclaration mn typ qual) = M.insert mn (pos, typ, qual) result
@@ -403,10 +403,10 @@ resolveImports env (Module currentModule decls _) =
-- A Map from module name to the source position for the import, the list of imports from that
-- module (where Nothing indicates everything is to be imported), and optionally a qualified name
-- for the module
- scope :: M.Map ModuleName (Maybe SourcePos, ImportDeclarationType, Maybe ModuleName)
+ scope :: M.Map ModuleName (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)
scope = M.insert currentModule (Nothing, Unqualified, Nothing) (findImports decls)
- resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourcePos, ImportDeclarationType, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment
+ resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment
resolveImport' imp (mn, (pos, typ, impQual)) = do
modExports <- positioned $ maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env
positioned $ resolveImport currentModule mn modExports imp impQual typ
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 8b63595..fb2cfe8 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -76,15 +76,15 @@ removeParens =
go (Parens val) = val
go val = val
-collectFixities :: Module -> [(Qualified Ident, SourcePos, Fixity)]
+collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)]
collectFixities (Module moduleName ds _) = concatMap collect ds
where
- collect :: Declaration -> [(Qualified Ident, SourcePos, Fixity)]
+ collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]
collect (PositionedDeclaration pos (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]
collect FixityDeclaration{} = error "Fixity without srcpos info"
collect _ = []
-ensureNoDuplicates :: [(Qualified Ident, SourcePos)] -> Either ErrorStack ()
+ensureNoDuplicates :: [(Qualified Ident, SourceSpan)] -> Either ErrorStack ()
ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
where
go [] = return ()
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 55cfe8b..d0e06b1 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -53,6 +53,7 @@ addDataType moduleName dtype name args dctors ctorKind = do
addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
addDataConstructor moduleName dtype name args dctor tys = do
env <- getEnv
+ mapM_ checkTypeSynonyms tys
let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
let dctorTy = foldr function retTy tys
let polyType = mkForAll args dctorTy
@@ -61,6 +62,7 @@ addDataConstructor moduleName dtype name args dctor tys = do
addTypeSynonym :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Type -> Kind -> Check ()
addTypeSynonym moduleName name args ty kind = do
env <- getEnv
+ checkTypeSynonyms ty
putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)
, typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }
@@ -107,6 +109,12 @@ checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkT
checkTypeClassInstance _ ty = throwError $ mkErrorStack "Type class instance head is invalid." (Just (TypeError ty))
-- |
+-- Check that type synonyms are fully-applied in a type
+--
+checkTypeSynonyms :: Type -> Check ()
+checkTypeSynonyms = void . replaceAllTypeSynonyms
+
+-- |
-- Type check all declarations in a module
--
-- At this point, many declarations will have been desugared, but it is still necessary to