2a6be76 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Include position info in RedefinedModule errors

commit2a6be76c2a7ac400b002cf19b0a7f2794b72e784 authorGary Burgess <gary.burgess@gmail.com> dateMon 17 Aug 2015, 02:12 (11 years ago) parent7583c86

27 files changed+177−164

compare with golang

unifiedsplit

hierarchy/Main.hs+2−2

@@ -2,7 +2,7 @@

22--

33-- Module : Main

44-- Copyright : (c) Hardy Jones 2014

5−-- License : MIT

5+-- License : MIT (http://opensource.org/licenses/MIT)

66--

77-- Maintainer : Hardy Jones <jones3.hardy@gmail.com>

88-- Stability : experimental

@@ -65,7 +65,7 @@ compile (HierarchyOptions inputGlob mOutput) = do

6565 case modules of

6666 Left errs -> hPutStr stderr (P.prettyPrintMultipleErrors False errs) >> exitFailure

6767 Right ms -> do

68− for_ ms $ \(P.Module _ moduleName decls _) ->

68+ for_ ms $ \(P.Module _ _ moduleName decls _) ->

6969 let name = runModuleName moduleName

7070 tcs = filter P.isTypeClassDeclaration decls

7171 supers = sort . nub . filter (not . null) $ fmap superClasses tcs

psc/Main.hs+4−4

@@ -1,8 +1,8 @@

11-----------------------------------------------------------------------------

22--

33-- Module : Main

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

5+-- License : MIT (http://opensource.org/licenses/MIT)

66--

77-- Maintainer : Phil Freeman <paf31@cantab.net>

88-- Stability : experimental

@@ -66,7 +66,7 @@ compile (PSCMakeOptions inputGlob inputForeignGlob outputDir opts usePrefix) = d

6666 Right ((ms, foreigns), warnings) -> do

6767 when (P.nonEmpty warnings) $

6868 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

7070 makeActions = buildMakeActions outputDir filePathMap foreigns usePrefix

7171 e <- runMake opts $ P.make makeActions (map snd ms)

7272 case e of

@@ -168,7 +168,7 @@ options = P.Options <$> noTco

168168 <*> verboseErrors

169169 <*> (not <$> comments)

170170 <*> requirePath

171−

171+

172172pscMakeOptions :: Parser PSCMakeOptions

173173pscMakeOptions = PSCMakeOptions <$> many inputFile

174174 <*> many inputForeignFile

psci/Completion.hs+1−1

@@ -216,7 +216,7 @@ dctorNames = nubOnFst . concatMap go . P.exportedDeclarations

216216 go _ = []

217217

218218moduleNames :: [P.Module] -> [String]

219−moduleNames ms = nub [show moduleName | P.Module _ moduleName _ _ <- ms]

219+moduleNames ms = nub [show moduleName | P.Module _ _ moduleName _ _ <- ms]

220220

221221directivesFirst :: Completion -> Completion -> Ordering

222222directivesFirst (Completion _ d1 _) (Completion _ d2 _) = go d1 d2

psci/PSCi.hs+9−9

@@ -1,8 +1,8 @@

11-----------------------------------------------------------------------------

22--

33-- Module : PSCi

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

5+-- License : MIT (http://opensource.org/licenses/MIT)

66--

77-- Maintainer : Phil Freeman <paf31@cantab.net>

88-- Stability : experimental

@@ -67,7 +67,7 @@ supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"]

6767supportModule :: P.Module

6868supportModule =

6969 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

7171 _ -> error "Support module could not be parsed"

7272 where

7373 code :: String

@@ -215,7 +215,7 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi

215215 mainDecl = P.ValueDeclaration (P.Ident "main") P.Public [] $ Right mainValue

216216 decls = if exec then [itDecl, mainDecl] else [itDecl]

217217 in

218− P.Module [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing

218+ P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing

219219

220220

221221-- |

@@ -227,7 +227,7 @@ createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBin

227227 moduleName = P.ModuleName [P.ProperName "$PSCI"]

228228 itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ

229229 in

230− P.Module [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing

230+ P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing

231231

232232-- |

233233-- Makes a volatile module to execute the current imports.

@@ -237,7 +237,7 @@ createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =

237237 let

238238 moduleName = P.ModuleName [P.ProperName "$PSCI"]

239239 in

240− P.Module [] moduleName (importDecl `map` imports) Nothing

240+ P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName (importDecl `map` imports) Nothing

241241

242242importDecl :: ImportedModule -> P.Declaration

243243importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ

@@ -308,7 +308,7 @@ handleShowLoadedModules = do

308308 psciIO $ readModules loadedModules >>= putStrLn

309309 return ()

310310 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

312312

313313-- |

314314-- Show the imported modules in psci.

@@ -399,7 +399,7 @@ handleBrowse moduleName = do

399399 case env of

400400 Left errs -> printErrors errs

401401 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)

403403 then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."

404404 else printModuleSignatures moduleName env'

405405

@@ -485,7 +485,7 @@ whenFileExists :: FilePath -> (FilePath -> PSCI ()) -> PSCI ()

485485whenFileExists filePath f = do

486486 absPath <- psciIO $ expandTilde filePath

487487 exists <- psciIO $ doesFileExist absPath

488− if exists

488+ if exists

489489 then f absPath

490490 else PSCI . outputStrLn $ "Couldn't locate: " ++ filePath

491491

src/Language/PureScript/AST/Declarations.hs+6−6

@@ -1,8 +1,8 @@

11-----------------------------------------------------------------------------

22--

33-- Module : Language.PureScript.AST.Declarations

5−-- License : MIT

5+-- License : MIT (http://opensource.org/licenses/MIT)

66--

77-- Maintainer : Phil Freeman <paf31@cantab.net>

88-- Stability : experimental

@@ -38,11 +38,11 @@ import Language.PureScript.Environment

3838-- a list of declarations, and a list of the declarations that are

3939-- explicitly exported. If the export list is Nothing, everything is exported.

4040--

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)

4242

4343-- | Return a module's name.

4444getModuleName :: Module -> ModuleName

45−getModuleName (Module _ name _ _) = name

45+getModuleName (Module _ _ name _ _) = name

4646

4747-- |

4848-- An item in a list of explicit imports or exports

@@ -172,10 +172,10 @@ data TypeInstanceBody

172172 -- | This is a regular (explicit) instance

173173 | ExplicitInstance [Declaration]

174174 deriving (Show, D.Data, D.Typeable)

175−

175+

176176mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody

177177mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)

178−

178+

179179-- | A traversal for TypeInstanceBody

180180traverseTypeInstanceBody :: (Applicative f) => ([Declaration] -> f [Declaration]) -> TypeInstanceBody -> f TypeInstanceBody

181181traverseTypeInstanceBody _ DerivedInstance = pure DerivedInstance

src/Language/PureScript/AST/Exported.hs+1−1

@@ -23,7 +23,7 @@ import Language.PureScript.Names

2323-- instances will be incorrectly removed in some cases.

2424--

2525exportedDeclarations :: Module -> [Declaration]

26−exportedDeclarations (Module _ _ decls exps) = go decls

26+exportedDeclarations (Module _ _ _ decls exps) = go decls

2727 where

2828 go = flattenDecls

2929 >>> filter (isExported exps)

src/Language/PureScript/AST/SourcePos.hs+6−3

@@ -1,8 +1,8 @@

11-----------------------------------------------------------------------------

22--

33-- Module : Language.PureScript.AST.SourcePos

5−-- License : MIT

5+-- License : MIT (http://opensource.org/licenses/MIT)

66--

77-- Maintainer : Phil Freeman <paf31@cantab.net>

88-- Stability : experimental

@@ -65,7 +65,7 @@ displayStartEndPos sp =

6565displaySourceSpan :: SourceSpan -> String

6666displaySourceSpan sp =

6767 spanName sp ++ " " ++

68− displayStartEndPos sp

68+ displayStartEndPos sp

6969

7070instance A.ToJSON SourceSpan where

7171 toJSON SourceSpan{..} =

@@ -73,3 +73,6 @@ instance A.ToJSON SourceSpan where

7373 , "start" .= spanStart

7474 , "end" .= spanEnd

7575 ]

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 @@

11-----------------------------------------------------------------------------

22--

33-- Module : Language.PureScript.CodeGen.Externs

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

5+-- License : MIT (http://opensource.org/licenses/MIT)

66--

77-- Maintainer : Phil Freeman <paf31@cantab.net>

88-- Stability : experimental

@@ -36,8 +36,8 @@ import Language.PureScript.Types

3636-- Generate foreign imports for all declarations in a module

3737--

3838moduleToPs :: Module -> Environment -> String

39−moduleToPs (Module _ _ _ Nothing) _ = error "Module exports were not elaborated in moduleToPs"

40−moduleToPs (Module _ moduleName ds (Just exts)) env = intercalate "\n" . execWriter $ do

39+moduleToPs (Module _ _ _ _ Nothing) _ = error "Module exports were not elaborated in moduleToPs"

40+moduleToPs (Module _ _ moduleName ds (Just exts)) env = intercalate "\n" . execWriter $ do

4141 let exps = listExports exts

4242 tell ["module " ++ runModuleName moduleName ++ (if null exps then "" else " (" ++ exps ++ ")") ++ " where"]

4343 mapM_ declToPs ds

src/Language/PureScript/CoreFn/Desugar.hs+4−4

@@ -1,8 +1,8 @@

11-----------------------------------------------------------------------------

22--

33-- Module : Language.PureScript.CoreFn.Desugar

5−-- License : MIT

5+-- License : MIT (http://opensource.org/licenses/MIT)

66--

77-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

88-- Stability : experimental

@@ -40,9 +40,9 @@ import qualified Language.PureScript.AST as A

4040-- Desugars a module from AST to CoreFn representation.

4141--

4242moduleToCoreFn :: Environment -> A.Module -> Module Ann

43−moduleToCoreFn _ (A.Module _ _ _ Nothing) =

43+moduleToCoreFn _ (A.Module _ _ _ _ Nothing) =

4444 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)) =

4646 let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls

4747 exps' = nub $ concatMap exportToCoreFn exps

4848 externs = nub $ mapMaybe externToCoreFn decls

src/Language/PureScript/Docs/Convert.hs+1−1

@@ -25,7 +25,7 @@ import Language.PureScript.Docs.Types

2525-- Convert a single Module.

2626--

2727convertModule :: P.Module -> Module

28−convertModule m@(P.Module coms moduleName _ _) =

28+convertModule m@(P.Module _ coms moduleName _ _) =

2929 Module (show moduleName) comments (declarations m)

3030 where

3131 comments = convertComments coms

src/Language/PureScript/Docs/ParseAndDesugar.hs+2−2

@@ -103,9 +103,9 @@ fileInfoToString (Local fn) = fn

103103fileInfoToString (FromDep _ fn) = fn

104104

105105addDefaultImport :: 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) =

107107 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

109109 where

110110 isExistingImport (P.ImportDeclaration mn' _ _) | mn' == toImport = True

111111 isExistingImport (P.PositionedDeclaration _ _ d) = isExistingImport d

src/Language/PureScript/Errors.hs+5−4

@@ -66,7 +66,7 @@ data SimpleErrorMessage

6666 | MultipleFixities Ident

6767 | OrphanTypeDeclaration Ident

6868 | OrphanFixityDeclaration String

69− | RedefinedModule ModuleName

69+ | RedefinedModule ModuleName [SourceSpan]

7070 | RedefinedIdent Ident

7171 | OverlappingNamesInLet

7272 | UnknownModule ModuleName

@@ -180,7 +180,7 @@ errorCode em = case unwrapErrorMessage em of

180180 (MultipleFixities _) -> "MultipleFixities"

181181 (OrphanTypeDeclaration _) -> "OrphanTypeDeclaration"

182182 (OrphanFixityDeclaration _) -> "OrphanFixityDeclaration"

183− (RedefinedModule _) -> "RedefinedModule"

183+ (RedefinedModule _ _) -> "RedefinedModule"

184184 (RedefinedIdent _) -> "RedefinedIdent"

185185 OverlappingNamesInLet -> "OverlappingNamesInLet"

186186 (UnknownModule _) -> "UnknownModule"

@@ -434,8 +434,9 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

434434 line $ "Orphan type declaration for " ++ show nm

435435 goSimple (OrphanFixityDeclaration op) =

436436 line $ "Orphan fixity declaration for " ++ show op

437− goSimple (RedefinedModule name) =

438− line $ "Module " ++ show name ++ " has been defined multiple times"

437+ goSimple (RedefinedModule name filenames) =

438+ paras $ [ line $ "Module " ++ show name ++ " has been defined multiple times:"

439+ ] ++ map (indent . line . displaySourceSpan) filenames

439440 goSimple (RedefinedIdent name) =

440441 line $ "Name " ++ show name ++ " has been defined multiple times"

441442 goSimple (UnknownModule mn) =

src/Language/PureScript/Linter.hs+3−3

@@ -1,8 +1,8 @@

11-----------------------------------------------------------------------------

22--

33-- Module : Language.PureScript.Linter

5−-- License : MIT

5+-- License : MIT (http://opensource.org/licenses/MIT)

66--

77-- Maintainer : Phil Freeman <paf31@cantab.net>

88-- Stability : experimental

@@ -36,7 +36,7 @@ import Language.PureScript.Linter.Exhaustive as L

3636-- |

3737-- | Right now, this pass only performs a shadowing check.

3838lint :: 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

4040 where

4141 moduleNames :: S.Set Ident

4242 moduleNames = S.fromList (nub (mapMaybe getDeclIdent ds))

src/Language/PureScript/Linter/Exhaustive.hs+11−11

@@ -1,8 +1,8 @@

11-----------------------------------------------------------------------------

22--

33-- Module : Language.PureScript.Exhaustive

5−-- License : MIT

5+-- License : MIT (http://opensource.org/licenses/MIT)

66--

77-- Maintainer : Phil Freeman <paf31@cantab.net>

88-- Stability : experimental

@@ -13,13 +13,13 @@

1313-- | The algorithm analyses the clauses of a definition one by one from top

1414-- | to bottom, where in each step it has the cases already missing (uncovered),

1515-- | and it generates the new set of missing cases.

16−--

16+--

1717-----------------------------------------------------------------------------

1818

1919{-# LANGUAGE FlexibleContexts #-}

2020{-# LANGUAGE ScopedTypeVariables #-}

2121

22−module Language.PureScript.Linter.Exhaustive

22+module Language.PureScript.Linter.Exhaustive

2323 ( checkExhaustive

2424 , checkExhaustiveModule

2525 ) where

@@ -207,7 +207,7 @@ isExhaustiveGuard (Left gs) = not . null $ filter (\(g, _) -> isOtherwise g) gs

207207 isOtherwise (TypedValue _ (BooleanLiteral True) _) = True

208208 isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) _) = True

209209 isOtherwise _ = False

210−isExhaustiveGuard (Right _) = True

210+isExhaustiveGuard (Right _) = True

211211

212212-- |

213213-- Returns the uncovered set of case alternatives

@@ -217,7 +217,7 @@ missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAl

217217

218218missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Maybe Bool)

219219missingAlternative env mn ca uncovered

220− | isExhaustiveGuard (caseAlternativeResult ca) = mcases

220+ | isExhaustiveGuard (caseAlternativeResult ca) = mcases

221221 | otherwise = ([uncovered], snd mcases)

222222 where

223223 mcases = missingCases env mn uncovered ca

@@ -227,7 +227,7 @@ missingAlternative env mn ca uncovered

227227-- Starting with the set `uncovered = { _ }` (nothing covered, one `_` for each function argument),

228228-- it partitions that set with the new uncovered cases, until it consumes the whole set of clauses.

229229-- Then, returns the uncovered set of case alternatives.

230−--

230+--

231231checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> [CaseAlternative] -> m ()

232232checkExhaustive env mn cas = makeResult . first nub $ foldl' step ([initial], (pure True, [])) cas

233233 where

@@ -243,7 +243,7 @@ checkExhaustive env mn cas = makeResult . first nub $ foldl' step ([initial], (p

243243 initial :: [Binder]

244244 initial = initialize numArgs

245245 where

246− numArgs = length . caseAlternativeBinders . head $ cas

246+ numArgs = length . caseAlternativeBinders . head $ cas

247247

248248 makeResult :: ([[Binder]], (Maybe Bool, [[Binder]])) -> m ()

249249 makeResult (bss, (_, bss')) =

@@ -255,7 +255,7 @@ checkExhaustive env mn cas = makeResult . first nub $ foldl' step ([initial], (p

255255

256256-- |

257257-- Exhaustivity checking over a list of declarations

258−--

258+--

259259checkExhaustiveDecls :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> ModuleName -> [Declaration] -> m ()

260260checkExhaustiveDecls env mn ds =

261261 let (f, _, _) = everywhereOnValuesTopDownM return checkExpr return

@@ -279,7 +279,7 @@ checkExhaustiveDecls env mn ds =

279279

280280-- |

281281-- Exhaustivity checking over a single module

282−--

282+--

283283checkExhaustiveModule :: 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

285285

src/Language/PureScript/Make.hs+14−14

@@ -1,8 +1,8 @@

11-----------------------------------------------------------------------------

22--

33-- Module : Make

5−-- License : MIT

5+-- License : MIT (http://opensource.org/licenses/MIT)

66--

77-- Maintainer : Phil Freeman <paf31@cantab.net>

88-- Stability : experimental

@@ -28,7 +28,7 @@ module Language.PureScript.Make

2828 , MakeActions(..)

2929 , Externs()

3030 , make

31−

31+

3232 -- * Implementation of Make API using files on disk

3333 , Make(..)

3434 , runMake

@@ -92,7 +92,7 @@ renderProgressMessage (CompilingModule mn) = "Compiling " ++ runModuleName mn

9292-- This type exists to make two things abstract:

9393--

9494-- * The particular backend being used (Javascript, C++11, etc.)

95−--

95+--

9696-- * The details of how files are read/written etc.

9797--

9898data MakeActions m = MakeActions {

@@ -148,7 +148,7 @@ make :: forall m. (Functor m, Applicative m, Monad m, MonadReader Options m, Mon

148148 -> m Environment

149149make MakeActions{..} ms = do

150150 (sorted, graph) <- sortModules $ map importPrim ms

151− toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do

151+ toRebuild <- foldM (\s (Module _ _ moduleName' _ _) -> do

152152 inputTimestamp <- getInputTimestamp moduleName'

153153 outputTimestamp <- getOutputTimestamp moduleName'

154154 return $ case (inputTimestamp, outputTimestamp) of

@@ -167,12 +167,12 @@ make MakeActions{..} ms = do

167167 go env ((False, m) : ms') = do

168168 (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m

169169 go env' ms'

170− go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do

171− lift . progress $ CompilingModule moduleName'

172− (checked@(Module _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule Nothing m

170+ go env ((True, m@(Module ss coms moduleName' _ exps)) : ms') = do

171+ lift . progress $ CompilingModule moduleName'

172+ (checked@(Module _ _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule Nothing m

173173 checkExhaustiveModule env' checked

174174 regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated

175− let mod' = Module coms moduleName' regrouped exps

175+ let mod' = Module ss coms moduleName' regrouped exps

176176 corefn = CF.moduleToCoreFn env' mod'

177177 [renamed] = renameInModules [corefn]

178178 exts = moduleToPs mod' env'

@@ -181,15 +181,15 @@ make MakeActions{..} ms = do

181181

182182 rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]

183183 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

185185 let deps = fromMaybe [] $ moduleName' `M.lookup` graph

186186 toRebuild' = toRebuild `S.union` S.fromList deps

187187 (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'

188− rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do

188+ rebuildIfNecessary graph toRebuild (Module _ _ moduleName' _ _ : ms') = do

189189 (path, externs) <- readExterns moduleName'

190190 externsModules <- fmap (map snd) . alterErrors $ parseModulesFromFiles id [(path, externs)]

191191 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'

193193 _ -> throwError . errorMessage . InvalidExternsFile $ path

194194 where

195195 alterErrors = flip catchError $ \(MultipleErrors errs) ->

@@ -207,9 +207,9 @@ reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]

207207-- Add an import declaration for a module if it does not already explicitly import it.

208208--

209209addDefaultImport :: ModuleName -> Module -> Module

210−addDefaultImport toImport m@(Module coms mn decls exps) =

210+addDefaultImport toImport m@(Module ss coms mn decls exps) =

211211 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

213213 where

214214 isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True

215215 isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d

src/Language/PureScript/ModuleDependencies.hs+3−3

@@ -1,8 +1,8 @@

11-----------------------------------------------------------------------------

22--

33-- Module : Language.PureScript.ModuleDependencies

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

5+-- License : MIT (http://opensource.org/licenses/MIT)

66--

77-- Maintainer : Phil Freeman <paf31@cantab.net>

88-- Stability : experimental

@@ -42,7 +42,7 @@ type ModuleGraph = [(ModuleName, [ModuleName])]

4242--

4343sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleGraph)

4444sortModules 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

4646 ms' <- mapM toModule $ stronglyConnComp verts

4747 let moduleGraph = map (\(_, mn, deps) -> (mn, deps)) verts

4848 return (ms', moduleGraph)

src/Language/PureScript/Parser/Declarations.hs+10−5

@@ -1,8 +1,8 @@

11-----------------------------------------------------------------------------

22--

33-- Module : Language.PureScript.Parser.Declarations

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

5+-- License : MIT (http://opensource.org/licenses/MIT)

66--

77-- Maintainer : Phil Freeman <paf31@cantab.net>

88-- Stability : experimental

@@ -230,7 +230,7 @@ parseTypeInstanceDeclaration = do

230230 indented *> reserved "where"

231231 mark (P.many (same *> positioned parseValueDeclaration))

232232 return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty (ExplicitInstance members)

233−

233+

234234parseDerivingInstanceDeclaration :: TokenParser Declaration

235235parseDerivingInstanceDeclaration = do

236236 reserved "derive"

@@ -277,19 +277,24 @@ parseLocalDeclaration = positioned (P.choice

277277parseModule :: TokenParser Module

278278parseModule = do

279279 comments <- C.readComments

280+ start <- P.getPosition

280281 reserved "module"

281282 indented

282283 name <- moduleName

283284 exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef

284285 reserved "where"

285286 decls <- mark (P.many (same *> parseDeclaration))

286− return $ Module comments name decls exports

287+ end <- P.getPosition

288+ let ss = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end)

289+ return $ Module ss comments name decls exports

290+ where

291+ toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos)

287292

288293-- |

289294-- Parse a collection of modules

290295--

291296parseModulesFromFiles :: forall m k. (MonadError MultipleErrors m, Functor m) =>

292− (k -> String) -> [(k, String)] -> m [(k, Module)]

297+ (k -> FilePath) -> [(k, String)] -> m [(k, Module)]

293298parseModulesFromFiles toFilePath input = do

294299 modules <- parU input $ \(k, content) -> do

295300 let filename = toFilePath k

src/Language/PureScript/Sugar/BindingGroups.hs+4−4

@@ -1,8 +1,8 @@

11-----------------------------------------------------------------------------

22--

33-- Module : Language.PureScript.BindingGroups

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

5+-- License : MIT (http://opensource.org/licenses/MIT)

66--

77-- Maintainer : Phil Freeman <paf31@cantab.net>

88-- Stability : experimental

@@ -42,13 +42,13 @@ import Language.PureScript.Errors

4242-- Replace all sets of mutually-recursive declarations in a module with binding groups

4343--

4444createBindingGroupsModule :: (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

4646

4747-- |

4848-- Collapse all binding groups in a module to individual declarations

4949--

5050collapseBindingGroupsModule :: [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

5252

5353createBindingGroups :: (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration]

5454createBindingGroups moduleName = mapM f <=< handleDecls

src/Language/PureScript/Sugar/CaseDeclarations.hs+4−4

@@ -1,8 +1,8 @@

11-----------------------------------------------------------------------------

22--

33-- Module : Language.PureScript.CaseDeclarations

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

5+-- License : MIT (http://opensource.org/licenses/MIT)

66--

77-- Maintainer : Phil Freeman <paf31@cantab.net>

88-- Stability : experimental

@@ -45,9 +45,9 @@ isLeft (Right _) = False

4545-- Replace all top-level binders in a module with case expressions.

4646--

4747desugarCasesModule :: (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) ->

4949 rethrow (onErrorMessages (ErrorInModule name)) $

50− Module coms name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps

50+ Module ss coms name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps

5151

5252desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

5353desugarAbs = flip parU f

src/Language/PureScript/Sugar/DoNotation.hs+3−3

@@ -1,8 +1,8 @@

11-----------------------------------------------------------------------------

22--

33-- Module : Language.PureScript.Sugar.DoNotation

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

5+-- License : MIT (http://opensource.org/licenses/MIT)

66--

77-- Maintainer : Phil Freeman <paf31@cantab.net>

88-- Stability : experimental

@@ -36,7 +36,7 @@ import Control.Monad.Supply.Class

3636-- and all @DoNotationLet@ constructors with let expressions.

3737--

3838desugarDoModule :: 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

4040

4141desugarDo :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration

4242desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (rethrowWithPosition pos $ desugarDo d)

src/Language/PureScript/Sugar/Names.hs+30−26

@@ -1,8 +1,8 @@

11-----------------------------------------------------------------------------

22--

33-- Module : Language.PureScript.Sugar.Names

5−-- License : MIT

5+-- License : MIT (http://opensource.org/licenses/MIT)

66--

77-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

88-- Stability : experimental

@@ -49,9 +49,13 @@ type ExportEnvironment = M.Map ModuleName Exports

4949data Exports = Exports

5050 {

5151 -- |

52+ -- The filename of the module these exports are for

53+ --

54+ moduleSourceSpan :: SourceSpan

55+ -- |

5256 -- The types exported from each module

5357 --

54− exportedTypes :: [(ProperName, [ProperName])]

58+ , exportedTypes :: [(ProperName, [ProperName])]

5559 -- |

5660 -- The classes exported from each module

5761 --

@@ -102,11 +106,11 @@ updateExportedModule env mn update = do

102106-- |

103107-- Adds an empty module to an ExportEnvironment.

104108--

105−addEmptyModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> m ExportEnvironment

106−addEmptyModule env name =

107− if name `M.member` env

108− then throwError . errorMessage $ RedefinedModule name

109− else return $ M.insert name (Exports [] [] [] []) env

109+addEmptyModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> SourceSpan -> m ExportEnvironment

110+addEmptyModule env name ss =

111+ case name `M.lookup` env of

112+ Just m -> throwError . errorMessage $ RedefinedModule name [moduleSourceSpan m, ss]

113+ Nothing -> return $ M.insert name (Exports ss [] [] [] []) env

110114

111115-- |

112116-- Adds a type belonging to a module to the export environment.

@@ -164,9 +168,9 @@ desugarImports modules = do

164168 mapM (renameInModule' unfilteredExports exports) modules'

165169 where

166170 moduleReexports :: Module -> Module

167− moduleReexports (Module coms mn decls exps) =

171+ moduleReexports (Module ss coms mn decls exps) =

168172 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)

170174 where

171175 imports :: [Declaration]

172176 imports = filter isImportDecl decls

@@ -174,7 +178,7 @@ desugarImports modules = do

174178 findImports' = go <$> modules

175179 where

176180 go :: Module -> Maybe (Declaration, Module)

177− go m@(Module _ mn' _ (Just exps'))

181+ go m@(Module _ _ mn' _ (Just exps'))

178182 | any isModExport exps', Just d <- find ((== mn') . importedModName) imports = Just (d, m)

179183 where

180184 importedModName :: Declaration -> ModuleName

@@ -183,14 +187,14 @@ desugarImports modules = do

183187 importedModName _ = error "Not an import decl"

184188 go _ = Nothing

185189 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'))) =

187191 case nonHiddenRefs of

188192 [] -> []

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))

190194 where

191195 nonHiddenRefs :: [DeclarationRef]

192196 nonHiddenRefs = filter isModExport exps' \\ filter isModExport refs

193− reexports (ImportDeclaration _ ty qual, Module _ _ _ (Just exps')) =

197+ reexports (ImportDeclaration _ ty qual, Module _ _ _ _ (Just exps')) =

194198 let ty' = case ty of

195199 Explicit _ -> Explicit []

196200 _ -> ty

@@ -199,7 +203,7 @@ desugarImports modules = do

199203 go :: DeclarationRef -> Maybe ModuleName

200204 go (ModuleRef mn') = Just mn'

201205 go _ = Nothing

202− reexports (PositionedDeclaration _ _ d, m@(Module _ _ _ (Just _))) = reexports (d, m)

206+ reexports (PositionedDeclaration _ _ d, m@(Module _ _ _ _ (Just _))) = reexports (d, m)

203207 reexports _ = []

204208

205209 isModExport :: DeclarationRef -> Bool

@@ -210,7 +214,7 @@ desugarImports modules = do

210214 -- exported members remain. If the module does not explicitly export anything, everything is

211215 -- exported.

212216 filterModuleExports :: ExportEnvironment -> Module -> m ExportEnvironment

213− filterModuleExports env (Module _ mn _ (Just exps))

217+ filterModuleExports env (Module _ _ mn _ (Just exps))

214218 | any isSelfModuleExport exps, Just exps' <- M.lookup mn env =

215219 let moduleNames = filter (/= mn) $ (\(ModuleRef mn') -> mn') <$> filter isModExport exps

216220 in return $ M.insert mn (exps' {exportedModules = moduleNames}) env

@@ -219,13 +223,13 @@ desugarImports modules = do

219223 isSelfModuleExport (ModuleRef mn') | mn' == mn = True

220224 isSelfModuleExport (PositionedDeclarationRef _ _ ref) = isSelfModuleExport ref

221225 isSelfModuleExport _ = False

222− filterModuleExports env (Module _ mn _ (Just exps)) = filterExports mn exps env

226+ filterModuleExports env (Module _ _ mn _ (Just exps)) = filterExports mn exps env

223227 filterModuleExports env _ = return env

224228

225229 -- Rename and check all the names within a module. We tweak the global exports environment so

226230 -- the module has access to an unfiltered list of its own members.

227231 renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> m Module

228− renameInModule' unfilteredExports exports m@(Module _ mn _ _) =

232+ renameInModule' unfilteredExports exports m@(Module _ _ mn _ _) =

229233 rethrow (onErrorMessages (ErrorInModule mn)) $ do

230234 let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports

231235 let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports

@@ -237,7 +241,7 @@ desugarImports modules = do

237241-- as it will also make all data constructor exports explicit.

238242--

239243elaborateExports :: 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 $

241245 map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (exportedTypes exps) ++

242246 map TypeClassRef (exportedTypeClasses exps) ++

243247 map ValueRef (exportedValues exps) ++

@@ -248,7 +252,7 @@ elaborateExports exps (Module coms mn decls _) = Module coms mn decls (Just $

248252-- This ensures transitive instances are included when using a member from a module.

249253--

250254elaborateImports :: 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

252256 where

253257 decls' :: [Declaration]

254258 decls' =

@@ -265,8 +269,8 @@ elaborateImports (Module coms mn decls exps) = Module coms mn decls' exps

265269-- qualified names are valid.

266270--

267271renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ImportEnvironment -> ExportEnvironment -> Module -> m Module

268−renameInModule imports exports (Module coms mn decls exps) =

269− Module coms mn <$> parU decls go <*> pure exps

272+renameInModule imports exports (Module ss coms mn decls exps) =

273+ Module ss coms mn <$> parU decls go <*> pure exps

270274 where

271275 (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS

272276

@@ -372,14 +376,14 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri

372376 where

373377

374378 -- 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) [] [] []

376380 where

377381 mkTypeEntry (Qualified _ name) = (name, [])

378382

379383 -- Add all of the exported declarations from a module to the global export environment

380384 addModule :: ExportEnvironment -> Module -> m ExportEnvironment

381− addModule env (Module _ mn ds _) = do

382− env' <- addEmptyModule env mn

385+ addModule env (Module ss _ mn ds _) = do

386+ env' <- addEmptyModule env mn ss

383387 rethrow (onErrorMessages (ErrorInModule mn)) $ foldM (addDecl mn) env' ds

384388

385389 -- Add a declaration from a module to the global export environment

@@ -475,7 +479,7 @@ findImports = foldl (findImports' Nothing) M.empty

475479-- Constructs a local environment for a module.

476480--

477481resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> Module -> m ImportEnvironment

478−resolveImports env (Module _ currentModule decls _) =

482+resolveImports env (Module _ _ currentModule decls _) =

479483 foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)

480484 where

481485

src/Language/PureScript/Sugar/ObjectWildcards.hs+3−3

@@ -1,8 +1,8 @@

11-----------------------------------------------------------------------------

22--

33-- Module : Language.PureScript.Sugar.ObjectWildcards

5−-- License : MIT

5+-- License : MIT (http://opensource.org/licenses/MIT)

66--

77-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

88-- Stability : experimental

@@ -32,7 +32,7 @@ import Language.PureScript.Errors

3232import Language.PureScript.Names

3333

3434desugarObjectConstructors :: 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

3636 where

3737

3838 desugarDecl :: Declaration -> m Declaration

src/Language/PureScript/Sugar/Operators.hs+7−7

@@ -1,8 +1,8 @@

11-----------------------------------------------------------------------------

22--

33-- Module : Language.PureScript.Sugar.Operators

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

5+-- License : MIT (http://opensource.org/licenses/MIT)

66--

77-- Maintainer : Phil Freeman <paf31@cantab.net>

88-- Stability : experimental

@@ -57,7 +57,7 @@ rebracket ms = do

5757 mapM (rebracketModule opTable) ms

5858

5959removeSignedLiterals :: 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

6161 where

6262 (f', _, _) = everywhereOnValues id go id

6363

@@ -65,9 +65,9 @@ removeSignedLiterals (Module coms mn ds exts) = Module coms mn (map f' ds) exts

6565 go other = other

6666

6767rebracketModule :: (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) =

6969 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

7171

7272removeParens :: Declaration -> Declaration

7373removeParens =

@@ -78,7 +78,7 @@ removeParens =

7878 go val = val

7979

8080collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)]

81−collectFixities (Module _ moduleName ds _) = concatMap collect ds

81+collectFixities (Module _ _ moduleName ds _) = concatMap collect ds

8282 where

8383 collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]

8484 collect (PositionedDeclaration pos _ (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]

@@ -152,7 +152,7 @@ matchOp op = do

152152 guard $ ident == op

153153

154154desugarOperatorSections :: 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

156156 where

157157

158158 goDecl :: Declaration -> m Declaration

src/Language/PureScript/Sugar/TypeClasses.hs+4−4

@@ -1,8 +1,8 @@

11-----------------------------------------------------------------------------

22--

33-- Module : Language.PureScript.Sugar.TypeClasses

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

5+-- License : MIT (http://opensource.org/licenses/MIT)

66--

77-- Maintainer : Phil Freeman <paf31@cantab.net>

88-- Stability : experimental

@@ -54,9 +54,9 @@ desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError Multi

5454desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

5555

5656desugarModule :: (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

5858 (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)

6060 where

6161 classesFirst :: Declaration -> Declaration -> Ordering

6262 classesFirst d1 d2

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+29−29

@@ -42,17 +42,17 @@ import qualified Language.PureScript.Constants as C

4242

4343-- | Elaborates deriving instance declarations by code generation.

4444deriveInstances :: (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

4646

47−-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,

47+-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,

4848-- elaborates that into an instance declaration via code generation.

4949deriveInstance :: (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)

5151 | className == Qualified (Just dataGeneric) (ProperName C.generic)

5252 , Just (Qualified mn' tyCon) <- unwrapTypeConstructor ty

5353 , mn == fromMaybe mn mn'

5454 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon

55−deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)

55+deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)

5656 = throwError . errorMessage $ CannotDerive className tys

5757deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d

5858deriveInstance _ _ e = return e

@@ -90,7 +90,7 @@ findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType

9090mkSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr

9191mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args

9292 where

93− prodConstructor :: Expr -> Expr

93+ prodConstructor :: Expr -> Expr

9494 prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd")))

9595

9696 recordConstructor :: Expr -> Expr

@@ -100,10 +100,10 @@ mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorCl

100100 mkCtorClause (ctorName, tys) = do

101101 idents <- replicateM (length tys) (fmap Ident freshName)

102102 return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))

103− where

104− caseResult idents =

105− App (prodConstructor (StringLiteral . runProperName $ ctorName))

106− . ArrayLiteral

103+ where

104+ caseResult idents =

105+ App (prodConstructor (StringLiteral . runProperName $ ctorName))

106+ . ArrayLiteral

107107 $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys

108108

109109 toSpineFun :: Expr -> Type -> Expr

@@ -118,15 +118,15 @@ mkSpineFunction _ _ = error "mkSpineFunction: expected DataDeclaration"

118118mkSignatureFunction :: ModuleName -> Declaration -> Expr

119119mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map mkProdClause args

120120 where

121− mkSigProd :: [Expr] -> Expr

121+ mkSigProd :: [Expr] -> Expr

122122 mkSigProd = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) . ArrayLiteral

123123

124− mkSigRec :: [Expr] -> Expr

124+ mkSigRec :: [Expr] -> Expr

125125 mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral

126−

126+

127127 proxy :: Type -> Type

128128 proxy = TypeApp (TypeConstructor (Qualified (Just dataGeneric) (ProperName "Proxy")))

129−

129+

130130 mkProdClause :: (ProperName, [Type]) -> Expr

131131 mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (runProperName ctorName))

132132 , ("sigValues", ArrayLiteral . map mkProductSignature $ tys)

@@ -147,24 +147,24 @@ mkSignatureFunction _ _ = error "mkSignatureFunction: expected DataDeclaration"

147147mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr

148148mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)

149149 where

150− mkJust :: Expr -> Expr

150+ mkJust :: Expr -> Expr

151151 mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just")))

152152

153− mkNothing :: Expr

153+ mkNothing :: Expr

154154 mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing"))

155−

156− prodBinder :: [Binder] -> Binder

155+

156+ prodBinder :: [Binder] -> Binder

157157 prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd"))

158158

159− recordBinder :: [Binder] -> Binder

159+ recordBinder :: [Binder] -> Binder

160160 recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))

161−

161+

162162 mkAlternative :: (ProperName, [Type]) -> m CaseAlternative

163163 mkAlternative (ctorName, tys) = do

164164 idents <- replicateM (length tys) (fmap Ident freshName)

165165 return $ CaseAlternative [ prodBinder [ StringBinder (runProperName ctorName), ArrayBinder (map VarBinder idents)]]

166− . Right

167− $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))

166+ . Right

167+ $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))

168168 (zipWith fromSpineFun (map (Var . (Qualified Nothing)) idents) tys)

169169

170170 addCatch :: [CaseAlternative] -> [CaseAlternative]

@@ -172,19 +172,19 @@ mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch

172172 where

173173 catchAll = CaseAlternative [NullBinder] (Right mkNothing)

174174

175− fromSpineFun e r

176− | Just rec <- objectType r

175+ fromSpineFun e r

176+ | Just rec <- objectType r

177177 = App (lamCase "r" [ mkRecCase (decomposeRec rec)

178178 , CaseAlternative [NullBinder] (Right mkNothing)

179− ])

179+ ])

180180 (App e (mkPrelVar "unit"))

181181

182182 fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit"))

183−

184− mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)

183+

184+ mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)

185185 ]

186− ]

187− . Right

186+ ]

187+ . Right

188188 $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs)

189189

190190 mkRecFun :: [(String, Type)] -> Expr

@@ -226,4 +226,4 @@ mkGenVar s = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]

226226decomposeRec :: Type -> [(String, Type)]

227227decomposeRec = sortBy (comparing fst) . go

228228 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 @@

11-----------------------------------------------------------------------------

22--

33-- Module : Language.PureScript.Sugar.TypeDeclarations

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

5+-- License : MIT (http://opensource.org/licenses/MIT)

66--

77-- Maintainer : Phil Freeman <paf31@cantab.net>

88-- Stability : experimental

@@ -35,9 +35,9 @@ import Language.PureScript.Traversals

3535-- Replace all top level type declarations in a module with type annotations

3636--

3737desugarTypeDeclarationsModule :: (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) ->

3939 rethrow (onErrorMessages (ErrorInModule name)) $

40− Module coms name <$> desugarTypeDeclarations ds <*> pure exps

40+ Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps

4141

4242-- |

4343-- 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

278278-- required by exported members are also exported.

279279--

280280typeCheckModule :: Maybe ModuleName -> Module -> Check Module

281−typeCheckModule _ (Module _ _ _ Nothing) = error "exports should have been elaborated"

282−typeCheckModule mainModuleName (Module coms mn decls (Just exps)) = rethrow (onErrorMessages (ErrorInModule mn)) $ do

281+typeCheckModule _ (Module _ _ _ _ Nothing) = error "exports should have been elaborated"

282+typeCheckModule mainModuleName (Module ss coms mn decls (Just exps)) = rethrow (onErrorMessages (ErrorInModule mn)) $ do

283283 modify (\s -> s { checkCurrentModule = Just mn })

284284 decls' <- typeCheckAll mainModuleName mn exps decls

285285 forM_ exps $ \e -> do

286286 checkTypesAreExported e

287287 checkClassMembersAreExported e

288288 checkClassesAreExported e

289− return $ Module coms mn decls' (Just exps)

289+ return $ Module ss coms mn decls' (Just exps)

290290 where

291291

292292 checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> Check ()