git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Include position info in RedefinedModule errors
2a6be76Gary Burgess
hierarchy/Main.hs+2−2
compare with golang
unifiedsplit
@@ -2,7 +2,7 @@
2--
2--
3-- Module : Main
3-- Module : Main
4-- Copyright : (c) Hardy Jones 2014
4-- Copyright : (c) Hardy Jones 2014
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Hardy Jones <jones3.hardy@gmail.com>
7-- Maintainer : Hardy Jones <jones3.hardy@gmail.com>
8-- Stability : experimental
8-- Stability : experimental
@@ -65,7 +65,7 @@ compile (HierarchyOptions inputGlob mOutput) = do
65 case modules of
65 case modules of
66 Left errs -> hPutStr stderr (P.prettyPrintMultipleErrors False errs) >> exitFailure
66 Left errs -> hPutStr stderr (P.prettyPrintMultipleErrors False errs) >> exitFailure
67 Right ms -> do
67 Right ms -> do
68− for_ ms $ \(P.Module _ moduleName decls _) ->
68+ for_ ms $ \(P.Module _ _ moduleName decls _) ->
69 let name = runModuleName moduleName
69 let name = runModuleName moduleName
70 tcs = filter P.isTypeClassDeclaration decls
70 tcs = filter P.isTypeClassDeclaration decls
71 supers = sort . nub . filter (not . null) $ fmap superClasses tcs
71 supers = sort . nub . filter (not . null) $ fmap superClasses tcs
psc/Main.hs+4−4
@@ -1,8 +1,8 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2--
2--
3-- Module : Main
3-- Module : Main
4−-- Copyright : (c) Phil Freeman 2013
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
8-- Stability : experimental
@@ -66,7 +66,7 @@ compile (PSCMakeOptions inputGlob inputForeignGlob outputDir opts usePrefix) = d
66 Right ((ms, foreigns), warnings) -> do
66 Right ((ms, foreigns), warnings) -> do
67 when (P.nonEmpty warnings) $
67 when (P.nonEmpty warnings) $
68 hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)
68 hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)
69− let filePathMap = M.fromList $ map (\(fp, P.Module _ mn _ _) -> (mn, fp)) ms
69+ let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, fp)) ms
70 makeActions = buildMakeActions outputDir filePathMap foreigns usePrefix
70 makeActions = buildMakeActions outputDir filePathMap foreigns usePrefix
71 e <- runMake opts $ P.make makeActions (map snd ms)
71 e <- runMake opts $ P.make makeActions (map snd ms)
72 case e of
72 case e of
@@ -168,7 +168,7 @@ options = P.Options <$> noTco
168 <*> verboseErrors
168 <*> verboseErrors
169 <*> (not <$> comments)
169 <*> (not <$> comments)
170 <*> requirePath
170 <*> requirePath
171−
171+
172pscMakeOptions :: Parser PSCMakeOptions
172pscMakeOptions :: Parser PSCMakeOptions
173pscMakeOptions = PSCMakeOptions <$> many inputFile
173pscMakeOptions = PSCMakeOptions <$> many inputFile
174 <*> many inputForeignFile
174 <*> many inputForeignFile
psci/Completion.hs+1−1
@@ -216,7 +216,7 @@ dctorNames = nubOnFst . concatMap go . P.exportedDeclarations
216 go _ = []
216 go _ = []
217
217
218moduleNames :: [P.Module] -> [String]
218moduleNames :: [P.Module] -> [String]
219−moduleNames ms = nub [show moduleName | P.Module _ moduleName _ _ <- ms]
219+moduleNames ms = nub [show moduleName | P.Module _ _ moduleName _ _ <- ms]
220
220
221directivesFirst :: Completion -> Completion -> Ordering
221directivesFirst :: Completion -> Completion -> Ordering
222directivesFirst (Completion _ d1 _) (Completion _ d2 _) = go d1 d2
222directivesFirst (Completion _ d1 _) (Completion _ d2 _) = go d1 d2
psci/PSCi.hs+9−9
@@ -1,8 +1,8 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2--
2--
3-- Module : PSCi
3-- Module : PSCi
4−-- Copyright : (c) Phil Freeman 2013
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
8-- Stability : experimental
@@ -67,7 +67,7 @@ supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"]
67supportModule :: P.Module
67supportModule :: P.Module
68supportModule =
68supportModule =
69 case P.parseModulesFromFiles id [("", code)] of
69 case P.parseModulesFromFiles id [("", code)] of
70− Right [(_, P.Module cs _ ds exps)] -> P.Module cs supportModuleName ds exps
70+ Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps
71 _ -> error "Support module could not be parsed"
71 _ -> error "Support module could not be parsed"
72 where
72 where
73 code :: String
73 code :: String
@@ -215,7 +215,7 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi
215 mainDecl = P.ValueDeclaration (P.Ident "main") P.Public [] $ Right mainValue
215 mainDecl = P.ValueDeclaration (P.Ident "main") P.Public [] $ Right mainValue
216 decls = if exec then [itDecl, mainDecl] else [itDecl]
216 decls = if exec then [itDecl, mainDecl] else [itDecl]
217 in
217 in
218− P.Module [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing
218+ P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing
219
219
220
220
221-- |
221-- |
@@ -227,7 +227,7 @@ createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBin
227 moduleName = P.ModuleName [P.ProperName "$PSCI"]
227 moduleName = P.ModuleName [P.ProperName "$PSCI"]
228 itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ
228 itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ
229 in
229 in
230− P.Module [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing
230+ P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing
231
231
232-- |
232-- |
233-- Makes a volatile module to execute the current imports.
233-- Makes a volatile module to execute the current imports.
@@ -237,7 +237,7 @@ createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =
237 let
237 let
238 moduleName = P.ModuleName [P.ProperName "$PSCI"]
238 moduleName = P.ModuleName [P.ProperName "$PSCI"]
239 in
239 in
240− P.Module [] moduleName (importDecl `map` imports) Nothing
240+ P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName (importDecl `map` imports) Nothing
241
241
242importDecl :: ImportedModule -> P.Declaration
242importDecl :: ImportedModule -> P.Declaration
243importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ
243importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ
@@ -308,7 +308,7 @@ handleShowLoadedModules = do
308 psciIO $ readModules loadedModules >>= putStrLn
308 psciIO $ readModules loadedModules >>= putStrLn
309 return ()
309 return ()
310 where readModules = return . unlines . sort . nub . map toModuleName
310 where readModules = return . unlines . sort . nub . map toModuleName
311− toModuleName = N.runModuleName . (\ (P.Module _ mdName _ _) -> mdName) . snd
311+ toModuleName = N.runModuleName . (\ (P.Module _ _ mdName _ _) -> mdName) . snd
312
312
313-- |
313-- |
314-- Show the imported modules in psci.
314-- Show the imported modules in psci.
@@ -399,7 +399,7 @@ handleBrowse moduleName = do
399 case env of
399 case env of
400 Left errs -> printErrors errs
400 Left errs -> printErrors errs
401 Right env' ->
401 Right env' ->
402− if moduleName `notElem` (nub . map ((\ (P.Module _ modName _ _ ) -> modName) . snd)) (psciLoadedModules st)
402+ if moduleName `notElem` (nub . map ((\ (P.Module _ _ modName _ _ ) -> modName) . snd)) (psciLoadedModules st)
403 then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."
403 then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."
404 else printModuleSignatures moduleName env'
404 else printModuleSignatures moduleName env'
405
405
@@ -485,7 +485,7 @@ whenFileExists :: FilePath -> (FilePath -> PSCI ()) -> PSCI ()
485whenFileExists filePath f = do
485whenFileExists filePath f = do
486 absPath <- psciIO $ expandTilde filePath
486 absPath <- psciIO $ expandTilde filePath
487 exists <- psciIO $ doesFileExist absPath
487 exists <- psciIO $ doesFileExist absPath
488− if exists
488+ if exists
489 then f absPath
489 then f absPath
490 else PSCI . outputStrLn $ "Couldn't locate: " ++ filePath
490 else PSCI . outputStrLn $ "Couldn't locate: " ++ filePath
491
491
src/Language/PureScript/AST/Declarations.hs+6−6
@@ -1,8 +1,8 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2--
2--
3-- Module : Language.PureScript.AST.Declarations
3-- Module : Language.PureScript.AST.Declarations
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
8-- Stability : experimental
@@ -38,11 +38,11 @@ import Language.PureScript.Environment
38-- a list of declarations, and a list of the declarations that are
38-- a list of declarations, and a list of the declarations that are
39-- explicitly exported. If the export list is Nothing, everything is exported.
39-- explicitly exported. If the export list is Nothing, everything is exported.
40--
40--
41−data Module = Module [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)
41+data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)
42
42
43-- | Return a module's name.
43-- | Return a module's name.
44getModuleName :: Module -> ModuleName
44getModuleName :: Module -> ModuleName
45−getModuleName (Module _ name _ _) = name
45+getModuleName (Module _ _ name _ _) = name
46
46
47-- |
47-- |
48-- An item in a list of explicit imports or exports
48-- An item in a list of explicit imports or exports
@@ -172,10 +172,10 @@ data TypeInstanceBody
172 -- | This is a regular (explicit) instance
172 -- | This is a regular (explicit) instance
173 | ExplicitInstance [Declaration]
173 | ExplicitInstance [Declaration]
174 deriving (Show, D.Data, D.Typeable)
174 deriving (Show, D.Data, D.Typeable)
175−
175+
176mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
176mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
177mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)
177mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)
178−
178+
179-- | A traversal for TypeInstanceBody
179-- | A traversal for TypeInstanceBody
180traverseTypeInstanceBody :: (Applicative f) => ([Declaration] -> f [Declaration]) -> TypeInstanceBody -> f TypeInstanceBody
180traverseTypeInstanceBody :: (Applicative f) => ([Declaration] -> f [Declaration]) -> TypeInstanceBody -> f TypeInstanceBody
181traverseTypeInstanceBody _ DerivedInstance = pure DerivedInstance
181traverseTypeInstanceBody _ DerivedInstance = pure DerivedInstance
src/Language/PureScript/AST/Exported.hs+1−1
@@ -23,7 +23,7 @@ import Language.PureScript.Names
23-- instances will be incorrectly removed in some cases.
23-- instances will be incorrectly removed in some cases.
24--
24--
25exportedDeclarations :: Module -> [Declaration]
25exportedDeclarations :: Module -> [Declaration]
26−exportedDeclarations (Module _ _ decls exps) = go decls
26+exportedDeclarations (Module _ _ _ decls exps) = go decls
27 where
27 where
28 go = flattenDecls
28 go = flattenDecls
29 >>> filter (isExported exps)
29 >>> filter (isExported exps)
src/Language/PureScript/AST/SourcePos.hs+6−3
@@ -1,8 +1,8 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2--
2--
3-- Module : Language.PureScript.AST.SourcePos
3-- Module : Language.PureScript.AST.SourcePos
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
8-- Stability : experimental
@@ -65,7 +65,7 @@ displayStartEndPos sp =
65displaySourceSpan :: SourceSpan -> String
65displaySourceSpan :: SourceSpan -> String
66displaySourceSpan sp =
66displaySourceSpan sp =
67 spanName sp ++ " " ++
67 spanName sp ++ " " ++
68− displayStartEndPos sp
68+ displayStartEndPos sp
69
69
70instance A.ToJSON SourceSpan where
70instance A.ToJSON SourceSpan where
71 toJSON SourceSpan{..} =
71 toJSON SourceSpan{..} =
@@ -73,3 +73,6 @@ instance A.ToJSON SourceSpan where
73 , "start" .= spanStart
73 , "start" .= spanStart
74 , "end" .= spanEnd
74 , "end" .= spanEnd
75 ]
75 ]
76+
77+internalModuleSourceSpan :: String -> SourceSpan
78+internalModuleSourceSpan name = SourceSpan name (SourcePos 0 0) (SourcePos 0 0)
src/Language/PureScript/CodeGen/Externs.hs+4−4
@@ -1,8 +1,8 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2--
2--
3-- Module : Language.PureScript.CodeGen.Externs
3-- Module : Language.PureScript.CodeGen.Externs
4−-- Copyright : (c) Phil Freeman 2013
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
8-- Stability : experimental
@@ -36,8 +36,8 @@ import Language.PureScript.Types
36-- Generate foreign imports for all declarations in a module
36-- Generate foreign imports for all declarations in a module
37--
37--
38moduleToPs :: Module -> Environment -> String
38moduleToPs :: Module -> Environment -> String
39−moduleToPs (Module _ _ _ Nothing) _ = error "Module exports were not elaborated in moduleToPs"
39+moduleToPs (Module _ _ _ _ Nothing) _ = error "Module exports were not elaborated in moduleToPs"
40−moduleToPs (Module _ moduleName ds (Just exts)) env = intercalate "\n" . execWriter $ do
40+moduleToPs (Module _ _ moduleName ds (Just exts)) env = intercalate "\n" . execWriter $ do
41 let exps = listExports exts
41 let exps = listExports exts
42 tell ["module " ++ runModuleName moduleName ++ (if null exps then "" else " (" ++ exps ++ ")") ++ " where"]
42 tell ["module " ++ runModuleName moduleName ++ (if null exps then "" else " (" ++ exps ++ ")") ++ " where"]
43 mapM_ declToPs ds
43 mapM_ declToPs ds
src/Language/PureScript/CoreFn/Desugar.hs+4−4
@@ -1,8 +1,8 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2--
2--
3-- Module : Language.PureScript.CoreFn.Desugar
3-- Module : Language.PureScript.CoreFn.Desugar
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
7-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8-- Stability : experimental
8-- Stability : experimental
@@ -40,9 +40,9 @@ import qualified Language.PureScript.AST as A
40-- Desugars a module from AST to CoreFn representation.
40-- Desugars a module from AST to CoreFn representation.
41--
41--
42moduleToCoreFn :: Environment -> A.Module -> Module Ann
42moduleToCoreFn :: Environment -> A.Module -> Module Ann
43−moduleToCoreFn _ (A.Module _ _ _ Nothing) =
43+moduleToCoreFn _ (A.Module _ _ _ _ Nothing) =
44 error "Module exports were not elaborated before moduleToCoreFn"
44 error "Module exports were not elaborated before moduleToCoreFn"
45−moduleToCoreFn env (A.Module coms mn decls (Just exps)) =
45+moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
46 let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls
46 let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls
47 exps' = nub $ concatMap exportToCoreFn exps
47 exps' = nub $ concatMap exportToCoreFn exps
48 externs = nub $ mapMaybe externToCoreFn decls
48 externs = nub $ mapMaybe externToCoreFn decls
src/Language/PureScript/Docs/Convert.hs+1−1
@@ -25,7 +25,7 @@ import Language.PureScript.Docs.Types
25-- Convert a single Module.
25-- Convert a single Module.
26--
26--
27convertModule :: P.Module -> Module
27convertModule :: P.Module -> Module
28−convertModule m@(P.Module coms moduleName _ _) =
28+convertModule m@(P.Module _ coms moduleName _ _) =
29 Module (show moduleName) comments (declarations m)
29 Module (show moduleName) comments (declarations m)
30 where
30 where
31 comments = convertComments coms
31 comments = convertComments coms
src/Language/PureScript/Docs/ParseAndDesugar.hs+2−2
@@ -103,9 +103,9 @@ fileInfoToString (Local fn) = fn
103fileInfoToString (FromDep _ fn) = fn
103fileInfoToString (FromDep _ fn) = fn
104
104
105addDefaultImport :: P.ModuleName -> P.Module -> P.Module
105addDefaultImport :: P.ModuleName -> P.Module -> P.Module
106−addDefaultImport toImport m@(P.Module coms mn decls exps) =
106+addDefaultImport toImport m@(P.Module ss coms mn decls exps) =
107 if isExistingImport `any` decls || mn == toImport then m
107 if isExistingImport `any` decls || mn == toImport then m
108− else P.Module coms mn (P.ImportDeclaration toImport P.Implicit Nothing : decls) exps
108+ else P.Module ss coms mn (P.ImportDeclaration toImport P.Implicit Nothing : decls) exps
109 where
109 where
110 isExistingImport (P.ImportDeclaration mn' _ _) | mn' == toImport = True
110 isExistingImport (P.ImportDeclaration mn' _ _) | mn' == toImport = True
111 isExistingImport (P.PositionedDeclaration _ _ d) = isExistingImport d
111 isExistingImport (P.PositionedDeclaration _ _ d) = isExistingImport d
src/Language/PureScript/Errors.hs+5−4
@@ -66,7 +66,7 @@ data SimpleErrorMessage
66 | MultipleFixities Ident
66 | MultipleFixities Ident
67 | OrphanTypeDeclaration Ident
67 | OrphanTypeDeclaration Ident
68 | OrphanFixityDeclaration String
68 | OrphanFixityDeclaration String
69− | RedefinedModule ModuleName
69+ | RedefinedModule ModuleName [SourceSpan]
70 | RedefinedIdent Ident
70 | RedefinedIdent Ident
71 | OverlappingNamesInLet
71 | OverlappingNamesInLet
72 | UnknownModule ModuleName
72 | UnknownModule ModuleName
@@ -180,7 +180,7 @@ errorCode em = case unwrapErrorMessage em of
180 (MultipleFixities _) -> "MultipleFixities"
180 (MultipleFixities _) -> "MultipleFixities"
181 (OrphanTypeDeclaration _) -> "OrphanTypeDeclaration"
181 (OrphanTypeDeclaration _) -> "OrphanTypeDeclaration"
182 (OrphanFixityDeclaration _) -> "OrphanFixityDeclaration"
182 (OrphanFixityDeclaration _) -> "OrphanFixityDeclaration"
183− (RedefinedModule _) -> "RedefinedModule"
183+ (RedefinedModule _ _) -> "RedefinedModule"
184 (RedefinedIdent _) -> "RedefinedIdent"
184 (RedefinedIdent _) -> "RedefinedIdent"
185 OverlappingNamesInLet -> "OverlappingNamesInLet"
185 OverlappingNamesInLet -> "OverlappingNamesInLet"
186 (UnknownModule _) -> "UnknownModule"
186 (UnknownModule _) -> "UnknownModule"
@@ -434,8 +434,9 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
434 line $ "Orphan type declaration for " ++ show nm
434 line $ "Orphan type declaration for " ++ show nm
435 goSimple (OrphanFixityDeclaration op) =
435 goSimple (OrphanFixityDeclaration op) =
436 line $ "Orphan fixity declaration for " ++ show op
436 line $ "Orphan fixity declaration for " ++ show op
437− goSimple (RedefinedModule name) =
437+ goSimple (RedefinedModule name filenames) =
438− line $ "Module " ++ show name ++ " has been defined multiple times"
438+ paras $ [ line $ "Module " ++ show name ++ " has been defined multiple times:"
439+ ] ++ map (indent . line . displaySourceSpan) filenames
439 goSimple (RedefinedIdent name) =
440 goSimple (RedefinedIdent name) =
440 line $ "Name " ++ show name ++ " has been defined multiple times"
441 line $ "Name " ++ show name ++ " has been defined multiple times"
441 goSimple (UnknownModule mn) =
442 goSimple (UnknownModule mn) =
src/Language/PureScript/Linter.hs+3−3
@@ -1,8 +1,8 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2--
2--
3-- Module : Language.PureScript.Linter
3-- Module : Language.PureScript.Linter
4−-- Copyright : (c) Copyright 2015 PureScript
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
8-- Stability : experimental
@@ -36,7 +36,7 @@ import Language.PureScript.Linter.Exhaustive as L
36-- |
36-- |
37-- | Right now, this pass only performs a shadowing check.
37-- | Right now, this pass only performs a shadowing check.
38lint :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Module -> m ()
38lint :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Module -> m ()
39−lint (Module _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ lintDeclaration ds
39+lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ lintDeclaration ds
40 where
40 where
41 moduleNames :: S.Set Ident
41 moduleNames :: S.Set Ident
42 moduleNames = S.fromList (nub (mapMaybe getDeclIdent ds))
42 moduleNames = S.fromList (nub (mapMaybe getDeclIdent ds))
src/Language/PureScript/Linter/Exhaustive.hs+11−11
@@ -1,8 +1,8 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2--
2--
3-- Module : Language.PureScript.Exhaustive
3-- Module : Language.PureScript.Exhaustive
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
8-- Stability : experimental
@@ -13,13 +13,13 @@
13-- | The algorithm analyses the clauses of a definition one by one from top
13-- | The algorithm analyses the clauses of a definition one by one from top
14-- | to bottom, where in each step it has the cases already missing (uncovered),
14-- | to bottom, where in each step it has the cases already missing (uncovered),
15-- | and it generates the new set of missing cases.
15-- | and it generates the new set of missing cases.
16−--
16+--
17-----------------------------------------------------------------------------
17-----------------------------------------------------------------------------
18
18
19{-# LANGUAGE FlexibleContexts #-}
19{-# LANGUAGE FlexibleContexts #-}
20{-# LANGUAGE ScopedTypeVariables #-}
20{-# LANGUAGE ScopedTypeVariables #-}
21
21
22−module Language.PureScript.Linter.Exhaustive
22+module Language.PureScript.Linter.Exhaustive
23 ( checkExhaustive
23 ( checkExhaustive
24 , checkExhaustiveModule
24 , checkExhaustiveModule
25 ) where
25 ) where
@@ -207,7 +207,7 @@ isExhaustiveGuard (Left gs) = not . null $ filter (\(g, _) -> isOtherwise g) gs
207 isOtherwise (TypedValue _ (BooleanLiteral True) _) = True
207 isOtherwise (TypedValue _ (BooleanLiteral True) _) = True
208 isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) _) = True
208 isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) _) = True
209 isOtherwise _ = False
209 isOtherwise _ = False
210−isExhaustiveGuard (Right _) = True
210+isExhaustiveGuard (Right _) = True
211
211
212-- |
212-- |
213-- Returns the uncovered set of case alternatives
213-- Returns the uncovered set of case alternatives
@@ -217,7 +217,7 @@ missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAl
217
217
218missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Maybe Bool)
218missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Maybe Bool)
219missingAlternative env mn ca uncovered
219missingAlternative env mn ca uncovered
220− | isExhaustiveGuard (caseAlternativeResult ca) = mcases
220+ | isExhaustiveGuard (caseAlternativeResult ca) = mcases
221 | otherwise = ([uncovered], snd mcases)
221 | otherwise = ([uncovered], snd mcases)
222 where
222 where
223 mcases = missingCases env mn uncovered ca
223 mcases = missingCases env mn uncovered ca
@@ -227,7 +227,7 @@ missingAlternative env mn ca uncovered
227-- Starting with the set `uncovered = { _ }` (nothing covered, one `_` for each function argument),
227-- Starting with the set `uncovered = { _ }` (nothing covered, one `_` for each function argument),
228-- it partitions that set with the new uncovered cases, until it consumes the whole set of clauses.
228-- it partitions that set with the new uncovered cases, until it consumes the whole set of clauses.
229-- Then, returns the uncovered set of case alternatives.
229-- Then, returns the uncovered set of case alternatives.
230−--
230+--
231checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> [CaseAlternative] -> m ()
231checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> [CaseAlternative] -> m ()
232checkExhaustive env mn cas = makeResult . first nub $ foldl' step ([initial], (pure True, [])) cas
232checkExhaustive env mn cas = makeResult . first nub $ foldl' step ([initial], (pure True, [])) cas
233 where
233 where
@@ -243,7 +243,7 @@ checkExhaustive env mn cas = makeResult . first nub $ foldl' step ([initial], (p
243 initial :: [Binder]
243 initial :: [Binder]
244 initial = initialize numArgs
244 initial = initialize numArgs
245 where
245 where
246− numArgs = length . caseAlternativeBinders . head $ cas
246+ numArgs = length . caseAlternativeBinders . head $ cas
247
247
248 makeResult :: ([[Binder]], (Maybe Bool, [[Binder]])) -> m ()
248 makeResult :: ([[Binder]], (Maybe Bool, [[Binder]])) -> m ()
249 makeResult (bss, (_, bss')) =
249 makeResult (bss, (_, bss')) =
@@ -255,7 +255,7 @@ checkExhaustive env mn cas = makeResult . first nub $ foldl' step ([initial], (p
255
255
256-- |
256-- |
257-- Exhaustivity checking over a list of declarations
257-- Exhaustivity checking over a list of declarations
258−--
258+--
259checkExhaustiveDecls :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> ModuleName -> [Declaration] -> m ()
259checkExhaustiveDecls :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> ModuleName -> [Declaration] -> m ()
260checkExhaustiveDecls env mn ds =
260checkExhaustiveDecls env mn ds =
261 let (f, _, _) = everywhereOnValuesTopDownM return checkExpr return
261 let (f, _, _) = everywhereOnValuesTopDownM return checkExpr return
@@ -279,7 +279,7 @@ checkExhaustiveDecls env mn ds =
279
279
280-- |
280-- |
281-- Exhaustivity checking over a single module
281-- Exhaustivity checking over a single module
282−--
282+--
283checkExhaustiveModule :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> Module -> m ()
283checkExhaustiveModule :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> Module -> m ()
284−checkExhaustiveModule env (Module _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds
284+checkExhaustiveModule env (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds
285
285
src/Language/PureScript/Make.hs+14−14
@@ -1,8 +1,8 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2--
2--
3-- Module : Make
3-- Module : Make
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
8-- Stability : experimental
@@ -28,7 +28,7 @@ module Language.PureScript.Make
28 , MakeActions(..)
28 , MakeActions(..)
29 , Externs()
29 , Externs()
30 , make
30 , make
31−
31+
32 -- * Implementation of Make API using files on disk
32 -- * Implementation of Make API using files on disk
33 , Make(..)
33 , Make(..)
34 , runMake
34 , runMake
@@ -92,7 +92,7 @@ renderProgressMessage (CompilingModule mn) = "Compiling " ++ runModuleName mn
92-- This type exists to make two things abstract:
92-- This type exists to make two things abstract:
93--
93--
94-- * The particular backend being used (Javascript, C++11, etc.)
94-- * The particular backend being used (Javascript, C++11, etc.)
95−--
95+--
96-- * The details of how files are read/written etc.
96-- * The details of how files are read/written etc.
97--
97--
98data MakeActions m = MakeActions {
98data MakeActions m = MakeActions {
@@ -148,7 +148,7 @@ make :: forall m. (Functor m, Applicative m, Monad m, MonadReader Options m, Mon
148 -> m Environment
148 -> m Environment
149make MakeActions{..} ms = do
149make MakeActions{..} ms = do
150 (sorted, graph) <- sortModules $ map importPrim ms
150 (sorted, graph) <- sortModules $ map importPrim ms
151− toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do
151+ toRebuild <- foldM (\s (Module _ _ moduleName' _ _) -> do
152 inputTimestamp <- getInputTimestamp moduleName'
152 inputTimestamp <- getInputTimestamp moduleName'
153 outputTimestamp <- getOutputTimestamp moduleName'
153 outputTimestamp <- getOutputTimestamp moduleName'
154 return $ case (inputTimestamp, outputTimestamp) of
154 return $ case (inputTimestamp, outputTimestamp) of
@@ -167,12 +167,12 @@ make MakeActions{..} ms = do
167 go env ((False, m) : ms') = do
167 go env ((False, m) : ms') = do
168 (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
168 (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
169 go env' ms'
169 go env' ms'
170− go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do
170+ go env ((True, m@(Module ss coms moduleName' _ exps)) : ms') = do
171− lift . progress $ CompilingModule moduleName'
171+ lift . progress $ CompilingModule moduleName'
172− (checked@(Module _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule Nothing m
172+ (checked@(Module _ _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule Nothing m
173 checkExhaustiveModule env' checked
173 checkExhaustiveModule env' checked
174 regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
174 regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
175− let mod' = Module coms moduleName' regrouped exps
175+ let mod' = Module ss coms moduleName' regrouped exps
176 corefn = CF.moduleToCoreFn env' mod'
176 corefn = CF.moduleToCoreFn env' mod'
177 [renamed] = renameInModules [corefn]
177 [renamed] = renameInModules [corefn]
178 exts = moduleToPs mod' env'
178 exts = moduleToPs mod' env'
@@ -181,15 +181,15 @@ make MakeActions{..} ms = do
181
181
182 rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
182 rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
183 rebuildIfNecessary _ _ [] = return []
183 rebuildIfNecessary _ _ [] = return []
184− rebuildIfNecessary graph toRebuild (m@(Module _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
184+ rebuildIfNecessary graph toRebuild (m@(Module _ _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
185 let deps = fromMaybe [] $ moduleName' `M.lookup` graph
185 let deps = fromMaybe [] $ moduleName' `M.lookup` graph
186 toRebuild' = toRebuild `S.union` S.fromList deps
186 toRebuild' = toRebuild `S.union` S.fromList deps
187 (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
187 (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
188− rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do
188+ rebuildIfNecessary graph toRebuild (Module _ _ moduleName' _ _ : ms') = do
189 (path, externs) <- readExterns moduleName'
189 (path, externs) <- readExterns moduleName'
190 externsModules <- fmap (map snd) . alterErrors $ parseModulesFromFiles id [(path, externs)]
190 externsModules <- fmap (map snd) . alterErrors $ parseModulesFromFiles id [(path, externs)]
191 case externsModules of
191 case externsModules of
192− [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
192+ [m'@(Module _ _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
193 _ -> throwError . errorMessage . InvalidExternsFile $ path
193 _ -> throwError . errorMessage . InvalidExternsFile $ path
194 where
194 where
195 alterErrors = flip catchError $ \(MultipleErrors errs) ->
195 alterErrors = flip catchError $ \(MultipleErrors errs) ->
@@ -207,9 +207,9 @@ reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
207-- Add an import declaration for a module if it does not already explicitly import it.
207-- Add an import declaration for a module if it does not already explicitly import it.
208--
208--
209addDefaultImport :: ModuleName -> Module -> Module
209addDefaultImport :: ModuleName -> Module -> Module
210−addDefaultImport toImport m@(Module coms mn decls exps) =
210+addDefaultImport toImport m@(Module ss coms mn decls exps) =
211 if isExistingImport `any` decls || mn == toImport then m
211 if isExistingImport `any` decls || mn == toImport then m
212− else Module coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
212+ else Module ss coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
213 where
213 where
214 isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
214 isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
215 isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
215 isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
src/Language/PureScript/ModuleDependencies.hs+3−3
@@ -1,8 +1,8 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2--
2--
3-- Module : Language.PureScript.ModuleDependencies
3-- Module : Language.PureScript.ModuleDependencies
4−-- Copyright : (c) Phil Freeman 2013
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
8-- Stability : experimental
@@ -42,7 +42,7 @@ type ModuleGraph = [(ModuleName, [ModuleName])]
42--
42--
43sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleGraph)
43sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleGraph)
44sortModules ms = do
44sortModules ms = do
45− let verts = map (\m@(Module _ _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms
45+ let verts = map (\m@(Module _ _ _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms
46 ms' <- mapM toModule $ stronglyConnComp verts
46 ms' <- mapM toModule $ stronglyConnComp verts
47 let moduleGraph = map (\(_, mn, deps) -> (mn, deps)) verts
47 let moduleGraph = map (\(_, mn, deps) -> (mn, deps)) verts
48 return (ms', moduleGraph)
48 return (ms', moduleGraph)
src/Language/PureScript/Parser/Declarations.hs+10−5
@@ -1,8 +1,8 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2--
2--
3-- Module : Language.PureScript.Parser.Declarations
3-- Module : Language.PureScript.Parser.Declarations
4−-- Copyright : (c) Phil Freeman 2013
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
8-- Stability : experimental
@@ -230,7 +230,7 @@ parseTypeInstanceDeclaration = do
230 indented *> reserved "where"
230 indented *> reserved "where"
231 mark (P.many (same *> positioned parseValueDeclaration))
231 mark (P.many (same *> positioned parseValueDeclaration))
232 return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty (ExplicitInstance members)
232 return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty (ExplicitInstance members)
233−
233+
234parseDerivingInstanceDeclaration :: TokenParser Declaration
234parseDerivingInstanceDeclaration :: TokenParser Declaration
235parseDerivingInstanceDeclaration = do
235parseDerivingInstanceDeclaration = do
236 reserved "derive"
236 reserved "derive"
@@ -277,19 +277,24 @@ parseLocalDeclaration = positioned (P.choice
277parseModule :: TokenParser Module
277parseModule :: TokenParser Module
278parseModule = do
278parseModule = do
279 comments <- C.readComments
279 comments <- C.readComments
280+ start <- P.getPosition
280 reserved "module"
281 reserved "module"
281 indented
282 indented
282 name <- moduleName
283 name <- moduleName
283 exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef
284 exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef
284 reserved "where"
285 reserved "where"
285 decls <- mark (P.many (same *> parseDeclaration))
286 decls <- mark (P.many (same *> parseDeclaration))
287+ end <- P.getPosition
288+ let ss = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end)
286− return $ Module comments name decls exports
289+ return $ Module ss comments name decls exports
290+ where
291+ toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos)
287
292
288-- |
293-- |
289-- Parse a collection of modules
294-- Parse a collection of modules
290--
295--
291parseModulesFromFiles :: forall m k. (MonadError MultipleErrors m, Functor m) =>
296parseModulesFromFiles :: forall m k. (MonadError MultipleErrors m, Functor m) =>
292− (k -> String) -> [(k, String)] -> m [(k, Module)]
297+ (k -> FilePath) -> [(k, String)] -> m [(k, Module)]
293parseModulesFromFiles toFilePath input = do
298parseModulesFromFiles toFilePath input = do
294 modules <- parU input $ \(k, content) -> do
299 modules <- parU input $ \(k, content) -> do
295 let filename = toFilePath k
300 let filename = toFilePath k
src/Language/PureScript/Sugar/BindingGroups.hs+4−4
@@ -1,8 +1,8 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2--
2--
3-- Module : Language.PureScript.BindingGroups
3-- Module : Language.PureScript.BindingGroups
4−-- Copyright : (c) Phil Freeman 2013
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
8-- Stability : experimental
@@ -42,13 +42,13 @@ import Language.PureScript.Errors
42-- Replace all sets of mutually-recursive declarations in a module with binding groups
42-- Replace all sets of mutually-recursive declarations in a module with binding groups
43--
43--
44createBindingGroupsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
44createBindingGroupsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
45−createBindingGroupsModule = mapM $ \(Module coms name ds exps) -> Module coms name <$> createBindingGroups name ds <*> pure exps
45+createBindingGroupsModule = mapM $ \(Module ss coms name ds exps) -> Module ss coms name <$> createBindingGroups name ds <*> pure exps
46
46
47-- |
47-- |
48-- Collapse all binding groups in a module to individual declarations
48-- Collapse all binding groups in a module to individual declarations
49--
49--
50collapseBindingGroupsModule :: [Module] -> [Module]
50collapseBindingGroupsModule :: [Module] -> [Module]
51−collapseBindingGroupsModule = map $ \(Module coms name ds exps) -> Module coms name (collapseBindingGroups ds) exps
51+collapseBindingGroupsModule = map $ \(Module ss coms name ds exps) -> Module ss coms name (collapseBindingGroups ds) exps
52
52
53createBindingGroups :: (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration]
53createBindingGroups :: (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration]
54createBindingGroups moduleName = mapM f <=< handleDecls
54createBindingGroups moduleName = mapM f <=< handleDecls
src/Language/PureScript/Sugar/CaseDeclarations.hs+4−4
@@ -1,8 +1,8 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2--
2--
3-- Module : Language.PureScript.CaseDeclarations
3-- Module : Language.PureScript.CaseDeclarations
4−-- Copyright : (c) Phil Freeman 2013
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
8-- Stability : experimental
@@ -45,9 +45,9 @@ isLeft (Right _) = False
45-- Replace all top-level binders in a module with case expressions.
45-- Replace all top-level binders in a module with case expressions.
46--
46--
47desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
47desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
48−desugarCasesModule ms = forM ms $ \(Module coms name ds exps) ->
48+desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) ->
49 rethrow (onErrorMessages (ErrorInModule name)) $
49 rethrow (onErrorMessages (ErrorInModule name)) $
50− Module coms name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
50+ Module ss coms name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
51
51
52desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
52desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
53desugarAbs = flip parU f
53desugarAbs = flip parU f
src/Language/PureScript/Sugar/DoNotation.hs+3−3
@@ -1,8 +1,8 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2--
2--
3-- Module : Language.PureScript.Sugar.DoNotation
3-- Module : Language.PureScript.Sugar.DoNotation
4−-- Copyright : (c) Phil Freeman 2013
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
8-- Stability : experimental
@@ -36,7 +36,7 @@ import Control.Monad.Supply.Class
36-- and all @DoNotationLet@ constructors with let expressions.
36-- and all @DoNotationLet@ constructors with let expressions.
37--
37--
38desugarDoModule :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
38desugarDoModule :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
39−desugarDoModule (Module coms mn ds exts) = Module coms mn <$> parU ds desugarDo <*> pure exts
39+desugarDoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds desugarDo <*> pure exts
40
40
41desugarDo :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration
41desugarDo :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration
42desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (rethrowWithPosition pos $ desugarDo d)
42desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (rethrowWithPosition pos $ desugarDo d)
src/Language/PureScript/Sugar/Names.hs+30−26
@@ -1,8 +1,8 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2--
2--
3-- Module : Language.PureScript.Sugar.Names
3-- Module : Language.PureScript.Sugar.Names
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
7-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8-- Stability : experimental
8-- Stability : experimental
@@ -49,9 +49,13 @@ type ExportEnvironment = M.Map ModuleName Exports
49data Exports = Exports
49data Exports = Exports
50 {
50 {
51 -- |
51 -- |
52+ -- The filename of the module these exports are for
53+ --
54+ moduleSourceSpan :: SourceSpan
55+ -- |
52 -- The types exported from each module
56 -- The types exported from each module
53 --
57 --
54− exportedTypes :: [(ProperName, [ProperName])]
58+ , exportedTypes :: [(ProperName, [ProperName])]
55 -- |
59 -- |
56 -- The classes exported from each module
60 -- The classes exported from each module
57 --
61 --
@@ -102,11 +106,11 @@ updateExportedModule env mn update = do
102-- |
106-- |
103-- Adds an empty module to an ExportEnvironment.
107-- Adds an empty module to an ExportEnvironment.
104--
108--
105−addEmptyModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> m ExportEnvironment
109+addEmptyModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> SourceSpan -> m ExportEnvironment
106−addEmptyModule env name =
110+addEmptyModule env name ss =
107− if name `M.member` env
111+ case name `M.lookup` env of
108− then throwError . errorMessage $ RedefinedModule name
112+ Just m -> throwError . errorMessage $ RedefinedModule name [moduleSourceSpan m, ss]
109− else return $ M.insert name (Exports [] [] [] []) env
113+ Nothing -> return $ M.insert name (Exports ss [] [] [] []) env
110
114
111-- |
115-- |
112-- Adds a type belonging to a module to the export environment.
116-- Adds a type belonging to a module to the export environment.
@@ -164,9 +168,9 @@ desugarImports modules = do
164 mapM (renameInModule' unfilteredExports exports) modules'
168 mapM (renameInModule' unfilteredExports exports) modules'
165 where
169 where
166 moduleReexports :: Module -> Module
170 moduleReexports :: Module -> Module
167− moduleReexports (Module coms mn decls exps) =
171+ moduleReexports (Module ss coms mn decls exps) =
168 let importedMods = catMaybes findImports'
172 let importedMods = catMaybes findImports'
169− in (Module coms mn (decls ++ (concatMap reexports importedMods)) exps)
173+ in (Module ss coms mn (decls ++ (concatMap reexports importedMods)) exps)
170 where
174 where
171 imports :: [Declaration]
175 imports :: [Declaration]
172 imports = filter isImportDecl decls
176 imports = filter isImportDecl decls
@@ -174,7 +178,7 @@ desugarImports modules = do
174 findImports' = go <$> modules
178 findImports' = go <$> modules
175 where
179 where
176 go :: Module -> Maybe (Declaration, Module)
180 go :: Module -> Maybe (Declaration, Module)
177− go m@(Module _ mn' _ (Just exps'))
181+ go m@(Module _ _ mn' _ (Just exps'))
178 | any isModExport exps', Just d <- find ((== mn') . importedModName) imports = Just (d, m)
182 | any isModExport exps', Just d <- find ((== mn') . importedModName) imports = Just (d, m)
179 where
183 where
180 importedModName :: Declaration -> ModuleName
184 importedModName :: Declaration -> ModuleName
@@ -183,14 +187,14 @@ desugarImports modules = do
183 importedModName _ = error "Not an import decl"
187 importedModName _ = error "Not an import decl"
184 go _ = Nothing
188 go _ = Nothing
185 reexports :: (Declaration, Module) -> [Declaration]
189 reexports :: (Declaration, Module) -> [Declaration]
186− reexports (ImportDeclaration _ (Hiding refs) _, (Module coms' mn' ds' (Just exps'))) =
190+ reexports (ImportDeclaration _ (Hiding refs) _, (Module ss' coms' mn' ds' (Just exps'))) =
187 case nonHiddenRefs of
191 case nonHiddenRefs of
188 [] -> []
192 [] -> []
189− _ -> reexports (ImportDeclaration mn' Implicit Nothing, Module coms' mn' ds' (Just nonHiddenRefs))
193+ _ -> reexports (ImportDeclaration mn' Implicit Nothing, Module ss' coms' mn' ds' (Just nonHiddenRefs))
190 where
194 where
191 nonHiddenRefs :: [DeclarationRef]
195 nonHiddenRefs :: [DeclarationRef]
192 nonHiddenRefs = filter isModExport exps' \\ filter isModExport refs
196 nonHiddenRefs = filter isModExport exps' \\ filter isModExport refs
193− reexports (ImportDeclaration _ ty qual, Module _ _ _ (Just exps')) =
197+ reexports (ImportDeclaration _ ty qual, Module _ _ _ _ (Just exps')) =
194 let ty' = case ty of
198 let ty' = case ty of
195 Explicit _ -> Explicit []
199 Explicit _ -> Explicit []
196 _ -> ty
200 _ -> ty
@@ -199,7 +203,7 @@ desugarImports modules = do
199 go :: DeclarationRef -> Maybe ModuleName
203 go :: DeclarationRef -> Maybe ModuleName
200 go (ModuleRef mn') = Just mn'
204 go (ModuleRef mn') = Just mn'
201 go _ = Nothing
205 go _ = Nothing
202− reexports (PositionedDeclaration _ _ d, m@(Module _ _ _ (Just _))) = reexports (d, m)
206+ reexports (PositionedDeclaration _ _ d, m@(Module _ _ _ _ (Just _))) = reexports (d, m)
203 reexports _ = []
207 reexports _ = []
204
208
205 isModExport :: DeclarationRef -> Bool
209 isModExport :: DeclarationRef -> Bool
@@ -210,7 +214,7 @@ desugarImports modules = do
210 -- exported members remain. If the module does not explicitly export anything, everything is
214 -- exported members remain. If the module does not explicitly export anything, everything is
211 -- exported.
215 -- exported.
212 filterModuleExports :: ExportEnvironment -> Module -> m ExportEnvironment
216 filterModuleExports :: ExportEnvironment -> Module -> m ExportEnvironment
213− filterModuleExports env (Module _ mn _ (Just exps))
217+ filterModuleExports env (Module _ _ mn _ (Just exps))
214 | any isSelfModuleExport exps, Just exps' <- M.lookup mn env =
218 | any isSelfModuleExport exps, Just exps' <- M.lookup mn env =
215 let moduleNames = filter (/= mn) $ (\(ModuleRef mn') -> mn') <$> filter isModExport exps
219 let moduleNames = filter (/= mn) $ (\(ModuleRef mn') -> mn') <$> filter isModExport exps
216 in return $ M.insert mn (exps' {exportedModules = moduleNames}) env
220 in return $ M.insert mn (exps' {exportedModules = moduleNames}) env
@@ -219,13 +223,13 @@ desugarImports modules = do
219 isSelfModuleExport (ModuleRef mn') | mn' == mn = True
223 isSelfModuleExport (ModuleRef mn') | mn' == mn = True
220 isSelfModuleExport (PositionedDeclarationRef _ _ ref) = isSelfModuleExport ref
224 isSelfModuleExport (PositionedDeclarationRef _ _ ref) = isSelfModuleExport ref
221 isSelfModuleExport _ = False
225 isSelfModuleExport _ = False
222− filterModuleExports env (Module _ mn _ (Just exps)) = filterExports mn exps env
226+ filterModuleExports env (Module _ _ mn _ (Just exps)) = filterExports mn exps env
223 filterModuleExports env _ = return env
227 filterModuleExports env _ = return env
224
228
225 -- Rename and check all the names within a module. We tweak the global exports environment so
229 -- Rename and check all the names within a module. We tweak the global exports environment so
226 -- the module has access to an unfiltered list of its own members.
230 -- the module has access to an unfiltered list of its own members.
227 renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> m Module
231 renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> m Module
228− renameInModule' unfilteredExports exports m@(Module _ mn _ _) =
232+ renameInModule' unfilteredExports exports m@(Module _ _ mn _ _) =
229 rethrow (onErrorMessages (ErrorInModule mn)) $ do
233 rethrow (onErrorMessages (ErrorInModule mn)) $ do
230 let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports
234 let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports
231 let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports
235 let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports
@@ -237,7 +241,7 @@ desugarImports modules = do
237-- as it will also make all data constructor exports explicit.
241-- as it will also make all data constructor exports explicit.
238--
242--
239elaborateExports :: Exports -> Module -> Module
243elaborateExports :: Exports -> Module -> Module
240−elaborateExports exps (Module coms mn decls _) = Module coms mn decls (Just $
244+elaborateExports exps (Module ss coms mn decls _) = Module ss coms mn decls (Just $
241 map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (exportedTypes exps) ++
245 map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (exportedTypes exps) ++
242 map TypeClassRef (exportedTypeClasses exps) ++
246 map TypeClassRef (exportedTypeClasses exps) ++
243 map ValueRef (exportedValues exps) ++
247 map ValueRef (exportedValues exps) ++
@@ -248,7 +252,7 @@ elaborateExports exps (Module coms mn decls _) = Module coms mn decls (Just $
248-- This ensures transitive instances are included when using a member from a module.
252-- This ensures transitive instances are included when using a member from a module.
249--
253--
250elaborateImports :: Module -> Module
254elaborateImports :: Module -> Module
251−elaborateImports (Module coms mn decls exps) = Module coms mn decls' exps
255+elaborateImports (Module ss coms mn decls exps) = Module ss coms mn decls' exps
252 where
256 where
253 decls' :: [Declaration]
257 decls' :: [Declaration]
254 decls' =
258 decls' =
@@ -265,8 +269,8 @@ elaborateImports (Module coms mn decls exps) = Module coms mn decls' exps
265-- qualified names are valid.
269-- qualified names are valid.
266--
270--
267renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ImportEnvironment -> ExportEnvironment -> Module -> m Module
271renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ImportEnvironment -> ExportEnvironment -> Module -> m Module
268−renameInModule imports exports (Module coms mn decls exps) =
272+renameInModule imports exports (Module ss coms mn decls exps) =
269− Module coms mn <$> parU decls go <*> pure exps
273+ Module ss coms mn <$> parU decls go <*> pure exps
270 where
274 where
271 (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS
275 (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS
272
276
@@ -372,14 +376,14 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri
372 where
376 where
373
377
374 -- The exported types from the Prim module
378 -- The exported types from the Prim module
375− primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] [] []
379+ primExports = Exports (internalModuleSourceSpan "<Prim>") (mkTypeEntry `map` M.keys primTypes) [] [] []
376 where
380 where
377 mkTypeEntry (Qualified _ name) = (name, [])
381 mkTypeEntry (Qualified _ name) = (name, [])
378
382
379 -- Add all of the exported declarations from a module to the global export environment
383 -- Add all of the exported declarations from a module to the global export environment
380 addModule :: ExportEnvironment -> Module -> m ExportEnvironment
384 addModule :: ExportEnvironment -> Module -> m ExportEnvironment
381− addModule env (Module _ mn ds _) = do
385+ addModule env (Module ss _ mn ds _) = do
382− env' <- addEmptyModule env mn
386+ env' <- addEmptyModule env mn ss
383 rethrow (onErrorMessages (ErrorInModule mn)) $ foldM (addDecl mn) env' ds
387 rethrow (onErrorMessages (ErrorInModule mn)) $ foldM (addDecl mn) env' ds
384
388
385 -- Add a declaration from a module to the global export environment
389 -- Add a declaration from a module to the global export environment
@@ -475,7 +479,7 @@ findImports = foldl (findImports' Nothing) M.empty
475-- Constructs a local environment for a module.
479-- Constructs a local environment for a module.
476--
480--
477resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> Module -> m ImportEnvironment
481resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> Module -> m ImportEnvironment
478−resolveImports env (Module _ currentModule decls _) =
482+resolveImports env (Module _ _ currentModule decls _) =
479 foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
483 foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
480 where
484 where
481
485
src/Language/PureScript/Sugar/ObjectWildcards.hs+3−3
@@ -1,8 +1,8 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2--
2--
3-- Module : Language.PureScript.Sugar.ObjectWildcards
3-- Module : Language.PureScript.Sugar.ObjectWildcards
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
7-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8-- Stability : experimental
8-- Stability : experimental
@@ -32,7 +32,7 @@ import Language.PureScript.Errors
32import Language.PureScript.Names
32import Language.PureScript.Names
33
33
34desugarObjectConstructors :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
34desugarObjectConstructors :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
35−desugarObjectConstructors (Module coms mn ds exts) = Module coms mn <$> mapM desugarDecl ds <*> pure exts
35+desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> mapM desugarDecl ds <*> pure exts
36 where
36 where
37
37
38 desugarDecl :: Declaration -> m Declaration
38 desugarDecl :: Declaration -> m Declaration
src/Language/PureScript/Sugar/Operators.hs+7−7
@@ -1,8 +1,8 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2--
2--
3-- Module : Language.PureScript.Sugar.Operators
3-- Module : Language.PureScript.Sugar.Operators
4−-- Copyright : (c) Phil Freeman 2013
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
8-- Stability : experimental
@@ -57,7 +57,7 @@ rebracket ms = do
57 mapM (rebracketModule opTable) ms
57 mapM (rebracketModule opTable) ms
58
58
59removeSignedLiterals :: Module -> Module
59removeSignedLiterals :: Module -> Module
60−removeSignedLiterals (Module coms mn ds exts) = Module coms mn (map f' ds) exts
60+removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts
61 where
61 where
62 (f', _, _) = everywhereOnValues id go id
62 (f', _, _) = everywhereOnValues id go id
63
63
@@ -65,9 +65,9 @@ removeSignedLiterals (Module coms mn ds exts) = Module coms mn (map f' ds) exts
65 go other = other
65 go other = other
66
66
67rebracketModule :: (Applicative m, MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> m Module
67rebracketModule :: (Applicative m, MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> m Module
68−rebracketModule opTable (Module coms mn ds exts) =
68+rebracketModule opTable (Module ss coms mn ds exts) =
69 let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return
69 let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return
70− in Module coms mn <$> (map removeParens <$> parU ds f) <*> pure exts
70+ in Module ss coms mn <$> (map removeParens <$> parU ds f) <*> pure exts
71
71
72removeParens :: Declaration -> Declaration
72removeParens :: Declaration -> Declaration
73removeParens =
73removeParens =
@@ -78,7 +78,7 @@ removeParens =
78 go val = val
78 go val = val
79
79
80collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)]
80collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)]
81−collectFixities (Module _ moduleName ds _) = concatMap collect ds
81+collectFixities (Module _ _ moduleName ds _) = concatMap collect ds
82 where
82 where
83 collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]
83 collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]
84 collect (PositionedDeclaration pos _ (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]
84 collect (PositionedDeclaration pos _ (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]
@@ -152,7 +152,7 @@ matchOp op = do
152 guard $ ident == op
152 guard $ ident == op
153
153
154desugarOperatorSections :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
154desugarOperatorSections :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
155−desugarOperatorSections (Module coms mn ds exts) = Module coms mn <$> mapM goDecl ds <*> pure exts
155+desugarOperatorSections (Module ss coms mn ds exts) = Module ss coms mn <$> mapM goDecl ds <*> pure exts
156 where
156 where
157
157
158 goDecl :: Declaration -> m Declaration
158 goDecl :: Declaration -> m Declaration
src/Language/PureScript/Sugar/TypeClasses.hs+4−4
@@ -1,8 +1,8 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2--
2--
3-- Module : Language.PureScript.Sugar.TypeClasses
3-- Module : Language.PureScript.Sugar.TypeClasses
4−-- Copyright : (c) Phil Freeman 2013
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
8-- Stability : experimental
@@ -54,9 +54,9 @@ desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError Multi
54desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
54desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
55
55
56desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> Desugar m Module
56desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> Desugar m Module
57−desugarModule (Module coms name decls (Just exps)) = do
57+desugarModule (Module ss coms name decls (Just exps)) = do
58 (newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps)
58 (newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps)
59− return $ Module coms name (concat declss) $ Just (exps ++ catMaybes newExpss)
59+ return $ Module ss coms name (concat declss) $ Just (exps ++ catMaybes newExpss)
60 where
60 where
61 classesFirst :: Declaration -> Declaration -> Ordering
61 classesFirst :: Declaration -> Declaration -> Ordering
62 classesFirst d1 d2
62 classesFirst d1 d2
src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+29−29
@@ -42,17 +42,17 @@ import qualified Language.PureScript.Constants as C
42
42
43-- | Elaborates deriving instance declarations by code generation.
43-- | Elaborates deriving instance declarations by code generation.
44deriveInstances :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m) => Module -> m Module
44deriveInstances :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m) => Module -> m Module
45−deriveInstances (Module coms mn ds exts) = Module coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts
45+deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts
46
46
47−-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,
47+-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,
48-- elaborates that into an instance declaration via code generation.
48-- elaborates that into an instance declaration via code generation.
49deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration
49deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration
50−deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)
50+deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)
51 | className == Qualified (Just dataGeneric) (ProperName C.generic)
51 | className == Qualified (Just dataGeneric) (ProperName C.generic)
52 , Just (Qualified mn' tyCon) <- unwrapTypeConstructor ty
52 , Just (Qualified mn' tyCon) <- unwrapTypeConstructor ty
53 , mn == fromMaybe mn mn'
53 , mn == fromMaybe mn mn'
54 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon
54 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon
55−deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
55+deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
56 = throwError . errorMessage $ CannotDerive className tys
56 = throwError . errorMessage $ CannotDerive className tys
57deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
57deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
58deriveInstance _ _ e = return e
58deriveInstance _ _ e = return e
@@ -90,7 +90,7 @@ findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType
90mkSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
90mkSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
91mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args
91mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args
92 where
92 where
93− prodConstructor :: Expr -> Expr
93+ prodConstructor :: Expr -> Expr
94 prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd")))
94 prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd")))
95
95
96 recordConstructor :: Expr -> Expr
96 recordConstructor :: Expr -> Expr
@@ -100,10 +100,10 @@ mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorCl
100 mkCtorClause (ctorName, tys) = do
100 mkCtorClause (ctorName, tys) = do
101 idents <- replicateM (length tys) (fmap Ident freshName)
101 idents <- replicateM (length tys) (fmap Ident freshName)
102 return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
102 return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
103− where
103+ where
104− caseResult idents =
104+ caseResult idents =
105− App (prodConstructor (StringLiteral . runProperName $ ctorName))
105+ App (prodConstructor (StringLiteral . runProperName $ ctorName))
106− . ArrayLiteral
106+ . ArrayLiteral
107 $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys
107 $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys
108
108
109 toSpineFun :: Expr -> Type -> Expr
109 toSpineFun :: Expr -> Type -> Expr
@@ -118,15 +118,15 @@ mkSpineFunction _ _ = error "mkSpineFunction: expected DataDeclaration"
118mkSignatureFunction :: ModuleName -> Declaration -> Expr
118mkSignatureFunction :: ModuleName -> Declaration -> Expr
119mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map mkProdClause args
119mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map mkProdClause args
120 where
120 where
121− mkSigProd :: [Expr] -> Expr
121+ mkSigProd :: [Expr] -> Expr
122 mkSigProd = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) . ArrayLiteral
122 mkSigProd = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) . ArrayLiteral
123
123
124− mkSigRec :: [Expr] -> Expr
124+ mkSigRec :: [Expr] -> Expr
125 mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral
125 mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral
126−
126+
127 proxy :: Type -> Type
127 proxy :: Type -> Type
128 proxy = TypeApp (TypeConstructor (Qualified (Just dataGeneric) (ProperName "Proxy")))
128 proxy = TypeApp (TypeConstructor (Qualified (Just dataGeneric) (ProperName "Proxy")))
129−
129+
130 mkProdClause :: (ProperName, [Type]) -> Expr
130 mkProdClause :: (ProperName, [Type]) -> Expr
131 mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (runProperName ctorName))
131 mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (runProperName ctorName))
132 , ("sigValues", ArrayLiteral . map mkProductSignature $ tys)
132 , ("sigValues", ArrayLiteral . map mkProductSignature $ tys)
@@ -147,24 +147,24 @@ mkSignatureFunction _ _ = error "mkSignatureFunction: expected DataDeclaration"
147mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
147mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
148mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)
148mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)
149 where
149 where
150− mkJust :: Expr -> Expr
150+ mkJust :: Expr -> Expr
151 mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just")))
151 mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just")))
152
152
153− mkNothing :: Expr
153+ mkNothing :: Expr
154 mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing"))
154 mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing"))
155−
155+
156− prodBinder :: [Binder] -> Binder
156+ prodBinder :: [Binder] -> Binder
157 prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd"))
157 prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd"))
158
158
159− recordBinder :: [Binder] -> Binder
159+ recordBinder :: [Binder] -> Binder
160 recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))
160 recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))
161−
161+
162 mkAlternative :: (ProperName, [Type]) -> m CaseAlternative
162 mkAlternative :: (ProperName, [Type]) -> m CaseAlternative
163 mkAlternative (ctorName, tys) = do
163 mkAlternative (ctorName, tys) = do
164 idents <- replicateM (length tys) (fmap Ident freshName)
164 idents <- replicateM (length tys) (fmap Ident freshName)
165 return $ CaseAlternative [ prodBinder [ StringBinder (runProperName ctorName), ArrayBinder (map VarBinder idents)]]
165 return $ CaseAlternative [ prodBinder [ StringBinder (runProperName ctorName), ArrayBinder (map VarBinder idents)]]
166− . Right
166+ . Right
167− $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))
167+ $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))
168 (zipWith fromSpineFun (map (Var . (Qualified Nothing)) idents) tys)
168 (zipWith fromSpineFun (map (Var . (Qualified Nothing)) idents) tys)
169
169
170 addCatch :: [CaseAlternative] -> [CaseAlternative]
170 addCatch :: [CaseAlternative] -> [CaseAlternative]
@@ -172,19 +172,19 @@ mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch
172 where
172 where
173 catchAll = CaseAlternative [NullBinder] (Right mkNothing)
173 catchAll = CaseAlternative [NullBinder] (Right mkNothing)
174
174
175− fromSpineFun e r
175+ fromSpineFun e r
176− | Just rec <- objectType r
176+ | Just rec <- objectType r
177 = App (lamCase "r" [ mkRecCase (decomposeRec rec)
177 = App (lamCase "r" [ mkRecCase (decomposeRec rec)
178 , CaseAlternative [NullBinder] (Right mkNothing)
178 , CaseAlternative [NullBinder] (Right mkNothing)
179− ])
179+ ])
180 (App e (mkPrelVar "unit"))
180 (App e (mkPrelVar "unit"))
181
181
182 fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit"))
182 fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit"))
183−
183+
184− mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)
184+ mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)
185 ]
185 ]
186− ]
186+ ]
187− . Right
187+ . Right
188 $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs)
188 $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs)
189
189
190 mkRecFun :: [(String, Type)] -> Expr
190 mkRecFun :: [(String, Type)] -> Expr
@@ -226,4 +226,4 @@ mkGenVar s = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]
226decomposeRec :: Type -> [(String, Type)]
226decomposeRec :: Type -> [(String, Type)]
227decomposeRec = sortBy (comparing fst) . go
227decomposeRec = sortBy (comparing fst) . go
228 where go (RCons str typ typs) = (str, typ) : decomposeRec typs
228 where go (RCons str typ typs) = (str, typ) : decomposeRec typs
229− go _ = []
229+ go _ = []
src/Language/PureScript/Sugar/TypeDeclarations.hs+4−4
@@ -1,8 +1,8 @@
1-----------------------------------------------------------------------------
1-----------------------------------------------------------------------------
2--
2--
3-- Module : Language.PureScript.Sugar.TypeDeclarations
3-- Module : Language.PureScript.Sugar.TypeDeclarations
4−-- Copyright : (c) Phil Freeman 2013
4+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5−-- License : MIT
5+-- License : MIT (http://opensource.org/licenses/MIT)
6--
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
8-- Stability : experimental
@@ -35,9 +35,9 @@ import Language.PureScript.Traversals
35-- Replace all top level type declarations in a module with type annotations
35-- Replace all top level type declarations in a module with type annotations
36--
36--
37desugarTypeDeclarationsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
37desugarTypeDeclarationsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
38−desugarTypeDeclarationsModule ms = forM ms $ \(Module coms name ds exps) ->
38+desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->
39 rethrow (onErrorMessages (ErrorInModule name)) $
39 rethrow (onErrorMessages (ErrorInModule name)) $
40− Module coms name <$> desugarTypeDeclarations ds <*> pure exps
40+ Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps
41
41
42-- |
42-- |
43-- Replace all top level type declarations with type annotations
43-- Replace all top level type declarations with type annotations
src/Language/PureScript/TypeChecker.hs+3−3
@@ -278,15 +278,15 @@ typeCheckAll mainModuleName moduleName exps ds = mapM go ds <* mapM_ checkOrphan
278-- required by exported members are also exported.
278-- required by exported members are also exported.
279--
279--
280typeCheckModule :: Maybe ModuleName -> Module -> Check Module
280typeCheckModule :: Maybe ModuleName -> Module -> Check Module
281−typeCheckModule _ (Module _ _ _ Nothing) = error "exports should have been elaborated"
281+typeCheckModule _ (Module _ _ _ _ Nothing) = error "exports should have been elaborated"
282−typeCheckModule mainModuleName (Module coms mn decls (Just exps)) = rethrow (onErrorMessages (ErrorInModule mn)) $ do
282+typeCheckModule mainModuleName (Module ss coms mn decls (Just exps)) = rethrow (onErrorMessages (ErrorInModule mn)) $ do
283 modify (\s -> s { checkCurrentModule = Just mn })
283 modify (\s -> s { checkCurrentModule = Just mn })
284 decls' <- typeCheckAll mainModuleName mn exps decls
284 decls' <- typeCheckAll mainModuleName mn exps decls
285 forM_ exps $ \e -> do
285 forM_ exps $ \e -> do
286 checkTypesAreExported e
286 checkTypesAreExported e
287 checkClassMembersAreExported e
287 checkClassMembersAreExported e
288 checkClassesAreExported e
288 checkClassesAreExported e
289− return $ Module coms mn decls' (Just exps)
289+ return $ Module ss coms mn decls' (Just exps)
290 where
290 where
291
291
292 checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> Check ()
292 checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> Check ()