summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-04-02 20:03:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-04-02 20:03:00 (GMT)
commit69b8aa4a107f098bb7b5ca80ea52ecfdd8ac43c4 (patch)
treeb3dc8ee572000cfc46f06a2469fd4194775addae
parenta63d5c3b5570b2d5db174a8f7e07fb051c4915b7 (diff)
version 0.4.120.4.12
-rw-r--r--purescript.cabal4
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs1
-rw-r--r--src/Language/PureScript/Declarations.hs17
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs9
-rw-r--r--src/Language/PureScript/Sugar/Names.hs139
5 files changed, 105 insertions, 65 deletions
diff --git a/purescript.cabal b/purescript.cabal
index 1036097..4ec3812 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.4.11.1
+version: 0.4.12
cabal-version: >=1.8
build-type: Custom
license: MIT
@@ -19,7 +19,7 @@ data-dir: ""
library
build-depends: base >=4 && <5, cmdtheline -any, containers -any,
- directory -any, filepath -any, mtl -any, parsec -any, syb -any,
+ directory >= 1.2, filepath -any, mtl -any, parsec -any, syb -any,
transformers -any, utf8-string -any,
pattern-arrows >= 0.0.2 && < 0.1,
monad-unify >= 0.2.1 && < 0.3,
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index 02bdf8e..9908770 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -49,6 +49,7 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite
fixityToPs _ = return ()
exportToPs :: DeclarationRef -> Writer [String] ()
+ exportToPs (PositionedDeclarationRef _ r) = exportToPs r
exportToPs (TypeRef pn dctors) = do
case Qualified (Just moduleName) pn `M.lookup` types env of
Nothing -> error $ show pn ++ " has no kind in exportToPs"
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index fd6da3e..9d4cfaf 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -69,7 +69,7 @@ data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable
-- |
-- A module declaration, consisting of a module name, a list of declarations, and a list of the
--- declarations that are explicitly imported. If the export list is Nothing, everything is exported.
+-- declarations that are explicitly exported. If the export list is Nothing, everything is exported.
--
data Module = Module ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)
@@ -93,7 +93,20 @@ data DeclarationRef
-- A type class instance, created during typeclass desugaring (name, class name, instance types)
--
| TypeInstanceRef Ident
- deriving (Show, Eq, D.Data, D.Typeable)
+ -- |
+ -- A declaration reference with source position information
+ --
+ | PositionedDeclarationRef SourcePos DeclarationRef
+ deriving (Show, D.Data, D.Typeable)
+
+instance Eq DeclarationRef where
+ (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'
+ (ValueRef name) == (ValueRef name') = name == name'
+ (TypeClassRef name) == (TypeClassRef name') = name == name'
+ (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'
+ (PositionedDeclarationRef _ r) == r' = r == r'
+ r == (PositionedDeclarationRef _ r') = r == r'
+ _ == _ = False
-- |
-- The data type of declarations
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 1683a9f..18ed2bc 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -135,10 +135,11 @@ parseImportDeclaration = do
return $ ImportDeclaration moduleName' idents (Just asQ)
parseDeclarationRef :: P.Parsec String ParseState DeclarationRef
-parseDeclarationRef = 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 = 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)
parseTypeClassDeclaration :: P.Parsec String ParseState Declaration
parseTypeClassDeclaration = do
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index d95d0ea..9276de5 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -19,7 +19,6 @@ module Language.PureScript.Sugar.Names (
import Data.Data
import Data.Maybe (fromMaybe, isJust, mapMaybe)
import Data.Monoid ((<>))
-import Data.Generics (extM, mkM, everywhereM)
import Data.Generics.Extras (mkS, extS, everywhereWithContextM')
import Control.Applicative (Applicative(..), (<$>), (<*>))
@@ -177,6 +176,7 @@ renameInModule imports exports (Module mn decls exps) =
Module mn <$> mapM go decls <*> pure exps
where
go :: Declaration -> Either ErrorStack Declaration
+ go (PositionedDeclaration pos d) = rethrowWithPosition pos $ PositionedDeclaration pos <$> go d
go (DataDeclaration name args dctors) =
rethrow (strMsg ("Error in data declaration " ++ show name) <>) $
DataDeclaration <$> pure name <*> pure args <*> updateAll dctors
@@ -186,28 +186,32 @@ renameInModule imports exports (Module mn decls exps) =
rethrow (strMsg ("Error in type synonym " ++ show name) <>) $
TypeSynonymDeclaration <$> pure name <*> pure ps <*> updateType' ty
go (TypeInstanceDeclaration name cs cn ts ds) =
- TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> updateType' ts <*> mapM go ds
+ TypeInstanceDeclaration name <$> updateConstraints Nothing cs <*> updateClassName cn Nothing <*> updateType' ts <*> mapM go ds
go (ExternInstanceDeclaration name cs cn ts) =
- ExternInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> updateType' ts
+ ExternInstanceDeclaration name <$> updateConstraints Nothing cs <*> updateClassName cn Nothing <*> updateType' ts
go (ValueDeclaration name nameKind [] Nothing val) = do
- val' <- everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val
+ val' <- everywhereWithContextM' (Nothing, []) (mkS bindFunctionArgs `extS` bindBinders) val
rethrow (strMsg ("Error in declaration " ++ show name) <>) $
ValueDeclaration name nameKind [] Nothing <$> updateAll val'
where
- bindFunctionArgs bound (Abs (Left arg) val') = return (arg : bound, Abs (Left arg) val')
- bindFunctionArgs bound (Let ds val') = let args = mapMaybe letBoundVariable ds in
- return (args ++ bound, Let ds val')
- bindFunctionArgs bound (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =
- (,) bound <$> (Var <$> updateValueName name')
- bindFunctionArgs bound (Var name'@(Qualified (Just _) _)) =
- (,) bound <$> (Var <$> updateValueName name')
- bindFunctionArgs bound (BinaryNoParens name'@(Qualified Nothing ident) v1 v2) | ident `notElem` bound =
- (,) bound <$> (BinaryNoParens <$> updateValueName name' <*> pure v1 <*> pure v2)
- bindFunctionArgs bound (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =
- (,) bound <$> (BinaryNoParens <$> updateValueName name' <*> pure v1 <*> pure v2)
- bindFunctionArgs bound other = return (bound, other)
- bindBinders :: [Ident] -> CaseAlternative -> Either ErrorStack ([Ident], CaseAlternative)
- bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)
+ bindFunctionArgs :: (Maybe SourcePos, [Ident]) -> Value -> Either ErrorStack ((Maybe SourcePos, [Ident]), Value)
+ bindFunctionArgs (_, bound) v@(PositionedValue pos' _) = return ((Just pos', bound), v)
+ bindFunctionArgs (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
+ bindFunctionArgs (pos, bound) (Let ds val') =
+ let args = mapMaybe letBoundVariable ds
+ in return ((pos, args ++ bound), Let ds val')
+ bindFunctionArgs (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =
+ (,) (pos, bound) <$> (Var <$> updateValueName name' pos)
+ bindFunctionArgs (pos, bound) (Var name'@(Qualified (Just _) _)) =
+ (,) (pos, bound) <$> (Var <$> updateValueName name' pos)
+ bindFunctionArgs (pos, bound) (BinaryNoParens name'@(Qualified Nothing ident) v1 v2) | ident `notElem` bound =
+ (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)
+ bindFunctionArgs (pos, bound) (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =
+ (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)
+ bindFunctionArgs pb other = return (pb, other)
+
+ bindBinders :: (Maybe SourcePos, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourcePos, [Ident]), CaseAlternative)
+ bindBinders (pos, bound) c@(CaseAlternative bs _ _) = return ((pos, binderNames bs ++ bound), c)
letBoundVariable :: Declaration -> Maybe Ident
letBoundVariable (ValueDeclaration ident _ _ _ _) = Just ident
@@ -217,34 +221,37 @@ renameInModule imports exports (Module mn decls exps) =
go (ExternDeclaration fit name js ty) =
rethrow (strMsg ("Error in declaration " ++ show name) <>) $
ExternDeclaration <$> pure fit <*> pure name <*> pure js <*> updateType' ty
- go (BindingGroupDeclaration decls') = do
- BindingGroupDeclaration <$> mapM go' decls'
+ go (BindingGroupDeclaration decls') = BindingGroupDeclaration <$> mapM go' decls'
where
- go' = \(name, nk, value) ->
- rethrow (strMsg ("Error in declaration " ++ show name) <>) $
- (,,) <$> pure name <*> pure nk <*> updateAll value
- go (PositionedDeclaration pos d) = PositionedDeclaration pos <$> go d
+ go' (name, nk, value) = rethrow (strMsg ("Error in declaration " ++ show name) <>) $
+ (,,) <$> pure name <*> pure nk <*> updateAll value
go d = updateAll d
updateAll :: Data d => d -> Either ErrorStack d
- updateAll = everywhereM (mkM updateType `extM` updateValue `extM` updateBinder)
-
- updateValue (Constructor name) = Constructor <$> updateDataConstructorName name
- updateValue v = return v
-
- updateBinder (ConstructorBinder name b) = ConstructorBinder <$> updateDataConstructorName name <*> pure b
- updateBinder v = return v
-
- updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name
- updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys
- updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints cs <*> pure t
- updateType t = return t
+ updateAll = everywhereWithContextM' Nothing (mkS updateType `extS` updateValue `extS` updateBinder)
+
+ updateValue :: Maybe SourcePos -> Value -> Either ErrorStack (Maybe SourcePos, Value)
+ updateValue _ v@(PositionedValue pos _) = return (Just pos, v)
+ updateValue pos (Constructor name) = (,) <$> pure pos <*> (Constructor <$> updateDataConstructorName name pos)
+ updateValue pos v = return (pos, v)
+
+ updateBinder :: Maybe SourcePos -> Binder -> Either ErrorStack (Maybe SourcePos, Binder)
+ updateBinder _ v@(PositionedBinder pos _) = return (Just pos, v)
+ updateBinder pos (ConstructorBinder name b) = (,) <$> pure pos <*> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)
+ updateBinder pos v = return (pos, v)
+
+ updateType :: Maybe SourcePos -> Type -> Either ErrorStack (Maybe SourcePos, Type)
+ updateType pos (TypeConstructor name) = (,) <$> pure pos <*> (TypeConstructor <$> updateTypeName name pos)
+ updateType pos (SaturatedTypeSynonym name tys) = (,) <$> pure pos <*> (SaturatedTypeSynonym <$> updateTypeName name pos <*> updateType' tys)
+ updateType pos (ConstrainedType cs t) = (,) <$> pure pos <*> (ConstrainedType <$> updateConstraints pos cs <*> pure t)
+ updateType pos t = return (pos, t)
+
updateType' :: Data d => d -> Either ErrorStack d
- updateType' = everywhereM (mkM updateType)
+ updateType' = everywhereWithContextM' Nothing (mkS updateType)
- updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)
+ updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> pure ts)
- updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` (exportedTypes mes)))
+ updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))
updateClassName = update "type class" importedTypeClasses (flip elem . exportedTypeClasses)
updateValueName = update "value" importedValues (flip elem . exportedValues)
updateDataConstructorName = update "data constructor" importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))
@@ -254,16 +261,21 @@ renameInModule imports exports (Module mn decls exps) =
update :: (Ord a, Show a) => String
-> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))
-> (Exports -> a -> Bool)
- -> (Qualified a)
+ -> Qualified a
+ -> Maybe SourcePos
-> Either ErrorStack (Qualified a)
- update t getI checkE qname@(Qualified mn' name) = case (M.lookup qname (getI imports), mn') of
+ update t getI checkE qname@(Qualified mn' name) pos = case (M.lookup qname (getI imports), mn') of
(Just qname', _) -> return qname'
(Nothing, Just mn'') -> do
modExports <- getExports mn''
if checkE modExports name
then return qname
- else throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show (qname) ++ "'") Nothing
- _ -> throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show name ++ "'") Nothing
+ else positioned $ throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing
+ _ -> positioned $ throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show name ++ "'") Nothing
+ where
+ positioned err = case pos of
+ Nothing -> err
+ Just pos' -> rethrowWithPosition pos' err
-- Gets the exports for a module, or an error message if the module doesn't exist
getExports :: ModuleName -> Either ErrorStack Exports
@@ -283,7 +295,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri
-- Add all of the exported declarations from a module to the global export environment
addModule :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment
- addModule env m@(Module mn ds _) = do
+ addModule env (Module mn ds _) = do
env' <- addEmptyModule env mn
rethrow (strMsg ("Error in module " ++ show mn) <>) $ foldM (addDecl mn) env' ds
@@ -307,7 +319,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri
filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either ErrorStack ExportEnvironment
filterExports mn exps env = do
let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)
- moduleExports' <- filterModule moduleExports
+ moduleExports' <- rethrow (strMsg ("Error in module " ++ show mn) <>) $ filterModule moduleExports
return $ M.insert mn moduleExports' env
where
@@ -322,6 +334,7 @@ filterExports mn exps env = do
-- Ensure the exported types and data constructors exist in the module and add them to the set of
-- exports
filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either ErrorStack [(ProperName, [ProperName])]
+ filterTypes expTys result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterTypes expTys result r
filterTypes expTys result (TypeRef name expDcons) = do
dcons <- maybe (throwError $ mkErrorStack ("Cannot export undefined type '" ++ show name ++ "'") Nothing) return $ name `lookup` expTys
dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons
@@ -337,6 +350,7 @@ filterExports mn exps env = do
-- Ensure the exported classes exist in the module and add them to the set of exports
filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either ErrorStack [ProperName]
+ filterClasses exps' result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterClasses exps' result r
filterClasses exps' result (TypeClassRef name) =
if name `elem` exps'
then return $ name : result
@@ -345,6 +359,7 @@ filterExports mn exps env = do
-- Ensure the exported values exist in the module and add them to the set of exports
filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either ErrorStack [Ident]
+ filterValues exps' result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterValues exps' result r
filterValues exps' result (ValueRef name) =
if name `elem` exps'
then return $ name : result
@@ -360,12 +375,12 @@ type ExplicitImports = [DeclarationRef]
-- 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 ExplicitImports, Maybe ModuleName)
-findImports = foldl findImports' M.empty
+findImports :: [Declaration] -> M.Map ModuleName (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)
+findImports = foldl (findImports' Nothing) M.empty
where
- findImports' result (ImportDeclaration mn expl qual) = M.insert mn (expl, qual) result
- findImports' result (PositionedDeclaration _ d) = findImports' result d
- findImports' result _ = result
+ findImports' pos result (ImportDeclaration mn expl qual) = M.insert mn (pos, expl, qual) result
+ findImports' _ result (PositionedDeclaration pos d) = findImports' (Just pos) result d
+ findImports' _ result _ = result
-- |
-- Constructs a local environment for a module.
@@ -374,12 +389,21 @@ resolveImports :: ExportEnvironment -> Module -> Either ErrorStack ImportEnviron
resolveImports env (Module currentModule decls _) =
foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
where
- -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported
- scope :: M.Map ModuleName (Maybe ExplicitImports, Maybe ModuleName)
- scope = M.insert currentModule (Nothing, Nothing) (findImports decls)
- resolveImport' imp (mn, (explImports, impQual)) = do
- modExports <- maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env
- resolveImport currentModule mn modExports imp impQual explImports
+
+ -- 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, Maybe ExplicitImports, Maybe ModuleName)
+ scope = M.insert currentModule (Nothing, Nothing, Nothing) (findImports decls)
+
+ resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourcePos, Maybe ExplicitImports, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment
+ resolveImport' imp (mn, (pos, explImports, 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 explImports
+ where
+ positioned err = case pos of
+ Nothing -> err
+ Just pos' -> rethrowWithPosition pos' err
-- |
-- Extends the local environment for a module by resolving an import of another module.
@@ -397,6 +421,7 @@ resolveImport currentModule importModule exps imps impQual = maybe importAll (fo
-- Import something explicitly
importExplicit :: ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment
+ importExplicit imp (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ importExplicit imp r
importExplicit imp (ValueRef name) = do
_ <- checkImportExists "value" values name
values' <- updateImports (importedValues imp) name
@@ -444,6 +469,6 @@ resolveImport currentModule importModule exps imps impQual = maybe importAll (fo
checkImportExists t exports item =
if item `elem` exports
then return item
- else throwError $ mkErrorStack ("Unable to find " ++ t ++ " '" ++ show (Qualified (Just importModule) item) ++ "'") Nothing
+ else throwError $ mkErrorStack ("Cannot import unknown " ++ t ++ " '" ++ show item ++ "' from '" ++ show importModule ++ "'") Nothing