688fc66 · rowtype-yoga/purescript-native

psci/PSCi.hs+3−3

compare with golang

unifiedsplit

@@ -71,7 +71,7 @@ supportModule :: P.Module

71supportModule =

72 case P.parseModulesFromFiles id [("", code)] of

73 Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps

74− _ -> error "Support module could not be parsed"

74+ _ -> P.internalError "Support module could not be parsed"

75 where

76 code :: String

77 code = unlines

@@ -390,7 +390,7 @@ printModuleSignatures moduleName env =

390 findType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)

391 showType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> String

392 showType (mIdent, Just (mType, _, _)) = show mIdent ++ " :: " ++ P.prettyPrintType mType

393− showType _ = error "The impossible happened in printModuleSignatures."

393+ showType _ = P.internalError "The impossible happened in printModuleSignatures."

394

395-- |

396-- Browse a module and displays its signature (if module exists).

@@ -482,7 +482,7 @@ handleCommand (KindOf typ) = handleKindOf typ

482handleCommand (BrowseModule moduleName) = handleBrowse moduleName

483handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules

484handleCommand (ShowInfo QueryImport) = handleShowImportedModules

485−handleCommand QuitPSCi = error "`handleCommand QuitPSCi` was called. This is a bug."

485+handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."

486

487whenFileExists :: FilePath -> (FilePath -> PSCI ()) -> PSCI ()

488whenFileExists filePath f = do

purescript.cabal+1

@@ -79,6 +79,7 @@ library

79 Language.PureScript.AST.Traversals

80 Language.PureScript.AST.Exported

81 Language.PureScript.Bundle

82+ Language.PureScript.Crash

82 Language.PureScript.Externs

83 Language.PureScript.Externs

83 Language.PureScript.CodeGen

84 Language.PureScript.CodeGen

84 Language.PureScript.CodeGen.JS

85 Language.PureScript.CodeGen.JS

src/Language/PureScript.hs+1

@@ -26,6 +26,7 @@ module Language.PureScript

26import Data.Version (Version)

27

28import Language.PureScript.AST as P

29+import Language.PureScript.Crash as P

29import Language.PureScript.Comments as P

30import Language.PureScript.Comments as P

30import Language.PureScript.Environment as P

31import Language.PureScript.Environment as P

31import Language.PureScript.Errors as P hiding (indent)

32import Language.PureScript.Errors as P hiding (indent)

src/Language/PureScript/AST/Operators.hs+3−1

@@ -21,6 +21,8 @@ import qualified Data.Data as D

21import Data.Aeson ((.=))

22import qualified Data.Aeson as A

23

24+import Language.PureScript.Crash

25+

24-- |

26-- |

25-- A precedence level for an infix operator

27-- A precedence level for an infix operator

26--

28--

@@ -40,7 +42,7 @@ readAssoc :: String -> Associativity

40readAssoc "infixl" = Infixl

42readAssoc "infixl" = Infixl

41readAssoc "infixr" = Infixr

43readAssoc "infixr" = Infixr

42readAssoc "infix" = Infix

44readAssoc "infix" = Infix

43−readAssoc _ = error "readAssoc: no parse"

45+readAssoc _ = internalError "readAssoc: no parse"

44

46

45instance A.ToJSON Associativity where

47instance A.ToJSON Associativity where

46 toJSON = A.toJSON . showAssoc

48 toJSON = A.toJSON . showAssoc

src/Language/PureScript/CodeGen/JS.hs+3−2

@@ -38,6 +38,7 @@ import Control.Monad (replicateM, forM)

38import Control.Monad.Reader (MonadReader, asks)

39import Control.Monad.Supply.Class

40

41+import Language.PureScript.Crash

41import Language.PureScript.AST.SourcePos

42import Language.PureScript.AST.SourcePos

42import Language.PureScript.CodeGen.JS.AST as AST

43import Language.PureScript.CodeGen.JS.AST as AST

43import Language.PureScript.CodeGen.JS.Common as Common

44import Language.PureScript.CodeGen.JS.Common as Common

@@ -272,7 +273,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do

272 go (v:vs) done' (b:bs) = do

273 go (v:vs) done' (b:bs) = do

273 done'' <- go vs done' bs

274 done'' <- go vs done' bs

274 binderToJs v done'' b

275 binderToJs v done'' b

275− go _ _ _ = error "Invalid arguments to bindersToJs"

276+ go _ _ _ = internalError "Invalid arguments to bindersToJs"

276

277

277 failedPatternError :: [String] -> JS

278 failedPatternError :: [String] -> JS

278 failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral errorMessage) (JSArrayLiteral $ zipWith valueError names vals)]

279 failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral errorMessage) (JSArrayLiteral $ zipWith valueError names vals)]

@@ -322,7 +323,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do

322 js <- binderToJs argVar done'' binder

323 js <- binderToJs argVar done'' binder

323 return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)

324 return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)

324 binderToJs _ _ ConstructorBinder{} =

325 binderToJs _ _ ConstructorBinder{} =

325− error "binderToJs: Invalid ConstructorBinder in binderToJs"

326+ internalError "binderToJs: Invalid ConstructorBinder in binderToJs"

326 binderToJs varName done (NamedBinder _ ident binder) = do

327 binderToJs varName done (NamedBinder _ ident binder) = do

327 js <- binderToJs varName done binder

328 js <- binderToJs varName done binder

328 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)

329 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)

src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs+2−1

@@ -17,6 +17,7 @@ module Language.PureScript.CodeGen.JS.Optimizer.Common where

17

18import Data.Maybe (fromMaybe)

19

20+import Language.PureScript.Crash

20import Language.PureScript.CodeGen.JS.AST

21import Language.PureScript.CodeGen.JS.AST

21

22

22applyAll :: [a -> a] -> a -> a

23applyAll :: [a -> a] -> a -> a

@@ -63,7 +64,7 @@ targetVariable :: JS -> String

63targetVariable (JSVar var) = var

64targetVariable (JSVar var) = var

64targetVariable (JSAccessor _ tgt) = targetVariable tgt

65targetVariable (JSAccessor _ tgt) = targetVariable tgt

65targetVariable (JSIndexer _ tgt) = targetVariable tgt

66targetVariable (JSIndexer _ tgt) = targetVariable tgt

66−targetVariable _ = error "Invalid argument to targetVariable"

67+targetVariable _ = internalError "Invalid argument to targetVariable"

67

68

68isUpdated :: String -> JS -> Bool

69isUpdated :: String -> JS -> Bool

69isUpdated var1 = everythingOnJS (||) check

70isUpdated var1 = everythingOnJS (||) check

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

@@ -21,6 +21,7 @@ import qualified Data.Map as M

21

22import Control.Arrow (second, (***))

23

24+import Language.PureScript.Crash

24import Language.PureScript.AST.SourcePos

25import Language.PureScript.AST.SourcePos

25import Language.PureScript.AST.Traversals

26import Language.PureScript.AST.Traversals

26import Language.PureScript.CoreFn.Ann

27import Language.PureScript.CoreFn.Ann

@@ -41,7 +42,7 @@ import qualified Language.PureScript.AST as A

41--

42--

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

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

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

44moduleToCoreFn _ (A.Module _ _ _ _ Nothing) =

44− error "Module exports were not elaborated before moduleToCoreFn"

45+ internalError "Module exports were not elaborated before moduleToCoreFn"

45moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

46moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

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

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

47 exps' = nub $ concatMap exportToCoreFn exps

48 exps' = nub $ concatMap exportToCoreFn exps

@@ -98,7 +99,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

98 exprToCoreFn ss com ty (A.Abs (Left name) v) =

99 exprToCoreFn ss com ty (A.Abs (Left name) v) =

99 Abs (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)

100 Abs (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)

100 exprToCoreFn _ _ _ (A.Abs _ _) =

101 exprToCoreFn _ _ _ (A.Abs _ _) =

101− error "Abs with Binder argument was not desugared before exprToCoreFn mn"

102+ internalError "Abs with Binder argument was not desugared before exprToCoreFn mn"

102 exprToCoreFn ss com ty (A.App v1 v2) =

103 exprToCoreFn ss com ty (A.App v1 v2) =

103 App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2)

104 App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2)

104 exprToCoreFn ss com ty (A.Var ident) =

105 exprToCoreFn ss com ty (A.Var ident) =

@@ -193,7 +194,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

193 numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env

194 numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env

194 typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)

195 typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)

195 typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)

196 typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)

196− typeConstructor _ = error "Invalid argument to typeConstructor"

197+ typeConstructor _ = internalError "Invalid argument to typeConstructor"

197

198

198-- |

199-- |

199-- Find module names from qualified references to values. This is used to

200-- Find module names from qualified references to values. This is used to

src/Language/PureScript/Crash.hsnew file+9

@@ -0,0 +1,9 @@

1+module Language.PureScript.Crash where

2+

3+-- | Exit with an error message and a crash report link.

4+internalError :: String -> a

5+internalError =

6+ error

7+ . ("An internal error ocurred during compilation: " ++)

8+ . (++ "\nPlease report this at https://github.com/purescript/purescript/issues")

9+ . show

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

@@ -157,7 +157,7 @@ convertDeclaration (P.TypeClassDeclaration _ args implies ds) title =

157 convertClassMember (P.TypeDeclaration ident' ty) =

158 ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty)

159 convertClassMember _ =

160− error "Invalid argument to convertClassMember."

160+ P.internalError "convertDeclaration: Invalid argument to convertClassMember."

161convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =

162 Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))

163 where

src/Language/PureScript/Docs/RenderedCode/Render.hs+3−2

@@ -22,6 +22,7 @@ import Data.Maybe (fromMaybe)

22import Control.Arrow ((<+>))

23import Control.PatternArrows

24

25+import Language.PureScript.Crash

25import Language.PureScript.Names

26import Language.PureScript.Names

26import Language.PureScript.Types

27import Language.PureScript.Types

27import Language.PureScript.Kinds

28import Language.PureScript.Kinds

@@ -163,7 +164,7 @@ renderKind = kind . prettyPrintKind

163--

164--

164renderTypeAtom :: Type -> RenderedCode

165renderTypeAtom :: Type -> RenderedCode

165renderTypeAtom =

166renderTypeAtom =

166− fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . preprocessType defaultRenderTypeOptions

167+ fromMaybe (internalError "Incomplete pattern") . pattern matchTypeAtom () . preprocessType defaultRenderTypeOptions

167

168

169

169-- |

170-- |

@@ -181,4 +182,4 @@ defaultRenderTypeOptions = RenderTypeOptions { prettyPrintObjects = True }

181

182

182renderTypeWithOptions :: RenderTypeOptions -> Type -> RenderedCode

183renderTypeWithOptions :: RenderTypeOptions -> Type -> RenderedCode

183renderTypeWithOptions opts =

184renderTypeWithOptions opts =

184− fromMaybe (error "Incomplete pattern") . pattern matchType () . preprocessType opts

185+ fromMaybe (internalError "Incomplete pattern") . pattern matchType () . preprocessType opts

src/Language/PureScript/Environment.hs+2−1

@@ -25,6 +25,7 @@ import qualified Data.Map as M

25import qualified Data.Text as T

26import qualified Data.Aeson as A

27

28+import Language.PureScript.Crash

28import Language.PureScript.Kinds

29import Language.PureScript.Kinds

29import Language.PureScript.Names

30import Language.PureScript.Names

30import Language.PureScript.TypeClassDictionaries

31import Language.PureScript.TypeClassDictionaries

@@ -252,7 +253,7 @@ primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star

252--

253--

253lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident])

254lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident])

254lookupConstructor env ctor =

255lookupConstructor env ctor =

255− fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors env

256+ fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env

256

257

257-- |

258-- |

258-- Checks whether a data constructor is for a newtype.

259-- Checks whether a data constructor is for a newtype.

src/Language/PureScript/Errors.hs+37−39

@@ -41,6 +41,7 @@ import Control.Applicative ((<$>), (<*>), Applicative, pure)

41import Control.Monad.Trans.State.Lazy

42import Control.Arrow(first)

43

44+import Language.PureScript.Crash

44import Language.PureScript.AST

45import Language.PureScript.AST

45import Language.PureScript.Pretty

46import Language.PureScript.Pretty

46import Language.PureScript.Types

47import Language.PureScript.Types

@@ -105,7 +106,6 @@ data SimpleErrorMessage

105 | CycleInTypeSynonym (Maybe ProperName)

106 | CycleInTypeSynonym (Maybe ProperName)

106 | CycleInModules [ModuleName]

107 | CycleInModules [ModuleName]

107 | NameIsUndefined Ident

108 | NameIsUndefined Ident

108− | NameNotInScope Ident

109 | UndefinedTypeVariable ProperName

110 | PartiallyAppliedSynonym (Qualified ProperName)

111 | EscapedSkolem (Maybe Expr)

@@ -130,7 +130,7 @@ data SimpleErrorMessage

130 | CannotApplyFunction Type Expr

131 | TypeSynonymInstance

132 | OrphanInstance Ident (Qualified ProperName) [Type]

133− | InvalidNewtype

133+ | InvalidNewtype ProperName

134 | InvalidInstanceHead Type

135 | TransitiveExportError DeclarationRef [DeclarationRef]

136 | ShadowedName Ident

@@ -241,7 +241,6 @@ errorCode em = case unwrapErrorMessage em of

241 CycleInTypeSynonym{} -> "CycleInTypeSynonym"

242 CycleInModules{} -> "CycleInModules"

243 NameIsUndefined{} -> "NameIsUndefined"

244− NameNotInScope{} -> "NameNotInScope"

245 UndefinedTypeVariable{} -> "UndefinedTypeVariable"

244 UndefinedTypeVariable{} -> "UndefinedTypeVariable"

246 PartiallyAppliedSynonym{} -> "PartiallyAppliedSynonym"

245 PartiallyAppliedSynonym{} -> "PartiallyAppliedSynonym"

247 EscapedSkolem{} -> "EscapedSkolem"

246 EscapedSkolem{} -> "EscapedSkolem"

@@ -266,7 +265,7 @@ errorCode em = case unwrapErrorMessage em of

266 CannotApplyFunction{} -> "CannotApplyFunction"

265 CannotApplyFunction{} -> "CannotApplyFunction"

267 TypeSynonymInstance -> "TypeSynonymInstance"

266 TypeSynonymInstance -> "TypeSynonymInstance"

268 OrphanInstance{} -> "OrphanInstance"

267 OrphanInstance{} -> "OrphanInstance"

269− InvalidNewtype -> "InvalidNewtype"

268+ InvalidNewtype{} -> "InvalidNewtype"

270 InvalidInstanceHead{} -> "InvalidInstanceHead"

269 InvalidInstanceHead{} -> "InvalidInstanceHead"

271 TransitiveExportError{} -> "TransitiveExportError"

270 TransitiveExportError{} -> "TransitiveExportError"

272 ShadowedName{} -> "ShadowedName"

271 ShadowedName{} -> "ShadowedName"

@@ -403,18 +402,13 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

403 renderSimpleErrorMessage (ErrorParsingFFIModule path) =

402 renderSimpleErrorMessage (ErrorParsingFFIModule path) =

404 paras [ line "Unable to parse foreign module:"

403 paras [ line "Unable to parse foreign module:"

405 , indent . line $ path

404 , indent . line $ path

406− , line "Ensure that all foreign modules contain a single module header at the start of a line, as follows:"

407− , indent $ line "// module A.B.C"

408 ]

405 ]

409 renderSimpleErrorMessage (ErrorParsingModule err) =

406 renderSimpleErrorMessage (ErrorParsingModule err) =

410 paras [ line "Unable to parse module: "

407 paras [ line "Unable to parse module: "

411 , prettyPrintParseError err

408 , prettyPrintParseError err

412 ]

409 ]

413 renderSimpleErrorMessage (MissingFFIModule mn) =

410 renderSimpleErrorMessage (MissingFFIModule mn) =

414− paras [ line $ "The foreign module implementation for module " ++ runModuleName mn ++ " is missing."

411+ line $ "The foreign module implementation for module " ++ runModuleName mn ++ " is missing."

415− , line $ "Provide your foreign module implementation using the --ffi command line option, and ensure that your module contains the following module header:"

416− , indent . line $ "// module " ++ runModuleName mn

417− ]

418 renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =

412 renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =

419 paras [ line $ "An unnecessary foreign module implementation was provided for module " ++ runModuleName mn ++ ": "

413 paras [ line $ "An unnecessary foreign module implementation was provided for module " ++ runModuleName mn ++ ": "

420 , indent . line $ path

414 , indent . line $ path

@@ -423,8 +417,6 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

423 renderSimpleErrorMessage (MultipleFFIModules mn paths) =

417 renderSimpleErrorMessage (MultipleFFIModules mn paths) =

424 paras [ line $ "Multiple foreign module implementations have been provided for module " ++ runModuleName mn ++ ": "

418 paras [ line $ "Multiple foreign module implementations have been provided for module " ++ runModuleName mn ++ ": "

425 , indent . paras $ map line paths

419 , indent . paras $ map line paths

426− , line "Foreign modules are identified by a unique module name, as follows:"

427− , indent $ line "// module A.B.C"

428 ]

420 ]

429 renderSimpleErrorMessage InvalidDoBind =

421 renderSimpleErrorMessage InvalidDoBind =

430 line "The last statement in a 'do' block must be an expression, but this block ends with a binder."

422 line "The last statement in a 'do' block must be an expression, but this block ends with a binder."

@@ -451,7 +443,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

451 , indent . paras $ map (line . displaySourceSpan) filenames

443 , indent . paras $ map (line . displaySourceSpan) filenames

452 ]

444 ]

453 renderSimpleErrorMessage (RedefinedIdent name) =

445 renderSimpleErrorMessage (RedefinedIdent name) =

454− line $ "The name " ++ showIdent name ++ " has been defined multiple times"

446+ line $ "The value " ++ showIdent name ++ " has been defined multiple times"

455 renderSimpleErrorMessage (UnknownModule mn) =

447 renderSimpleErrorMessage (UnknownModule mn) =

456 line $ "Unknown module " ++ runModuleName mn

448 line $ "Unknown module " ++ runModuleName mn

457 renderSimpleErrorMessage (UnknownType name) =

449 renderSimpleErrorMessage (UnknownType name) =

@@ -465,15 +457,21 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

465 renderSimpleErrorMessage (UnknownDataConstructor dc tc) =

457 renderSimpleErrorMessage (UnknownDataConstructor dc tc) =

466 line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc

458 line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc

467 renderSimpleErrorMessage (UnknownImportType mn name) =

459 renderSimpleErrorMessage (UnknownImportType mn name) =

468− line $ "The type " ++ runProperName name ++ " is not exported by the module " ++ runModuleName mn

460+ paras [ line $ "Cannot import the type " ++ runProperName name ++ " from module " ++ runModuleName mn

461+ , line "It either does not exist or the module does not export it."

462+ ]

469 renderSimpleErrorMessage (UnknownExportType name) =

463 renderSimpleErrorMessage (UnknownExportType name) =

470 line $ "Cannot export unknown type " ++ runProperName name

464 line $ "Cannot export unknown type " ++ runProperName name

471 renderSimpleErrorMessage (UnknownImportTypeClass mn name) =

465 renderSimpleErrorMessage (UnknownImportTypeClass mn name) =

472− line $ "The type class " ++ runProperName name ++ " is not exported by the module " ++ runModuleName mn

466+ paras [ line $ "Cannot import the type class " ++ runProperName name ++ " from module " ++ runModuleName mn

467+ , line "It either does not exist or the module does not export it."

468+ ]

473 renderSimpleErrorMessage (UnknownExportTypeClass name) =

469 renderSimpleErrorMessage (UnknownExportTypeClass name) =

474 line $ "Cannot export unknown type class " ++ runProperName name

470 line $ "Cannot export unknown type class " ++ runProperName name

475 renderSimpleErrorMessage (UnknownImportValue mn name) =

471 renderSimpleErrorMessage (UnknownImportValue mn name) =

476− line $ "The value " ++ showIdent name ++ " is not exported by the module " ++ runModuleName mn

472+ paras [ line $ "Cannot import the value " ++ showIdent name ++ " from module " ++ runModuleName mn

473+ , line "It either does not exist or the module does not export it."

474+ ]

477 renderSimpleErrorMessage (UnknownExportValue name) =

475 renderSimpleErrorMessage (UnknownExportValue name) =

478 line $ "Cannot export unknown value " ++ showIdent name

476 line $ "Cannot export unknown value " ++ showIdent name

479 renderSimpleErrorMessage (UnknownExportModule name) =

477 renderSimpleErrorMessage (UnknownExportModule name) =

@@ -481,7 +479,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

481 , line "It either does not exist or has not been imported by the current module."

479 , line "It either does not exist or has not been imported by the current module."

482 ]

480 ]

483 renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =

481 renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =

484− line $ "The data constructor " ++ runProperName dcon ++ " (for type " ++ runProperName tcon ++ ") is not exported by the module " ++ runModuleName mn

482+ line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon

485 renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =

483 renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =

486 line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ ", as it has not been declared."

484 line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ ", as it has not been declared."

487 renderSimpleErrorMessage (ConflictingImport nm mn) =

485 renderSimpleErrorMessage (ConflictingImport nm mn) =

@@ -510,10 +508,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

510 renderSimpleErrorMessage (DuplicateValueExport nm) =

508 renderSimpleErrorMessage (DuplicateValueExport nm) =

511 line $ "Duplicate export declaration for value " ++ showIdent nm

509 line $ "Duplicate export declaration for value " ++ showIdent nm

512 renderSimpleErrorMessage (CycleInDeclaration nm) =

510 renderSimpleErrorMessage (CycleInDeclaration nm) =

513− paras [ line $ "The declaration of " ++ showIdent nm ++ " contains a cycle."

514− , line $ "The value of " ++ showIdent nm ++ " may not be defined here, so this reference is not allowed."

511+ line $ "The value of " ++ showIdent nm ++ " is undefined here, so this reference is not allowed."

515− , line "You might be able to evaluate this expression lazily, using something like Control.Lazy.fix"

516− ]

517 renderSimpleErrorMessage (CycleInModules mns) =

512 renderSimpleErrorMessage (CycleInModules mns) =

518 line $ "There is a cycle in the module dependencies: " ++ intercalate ", " (map runModuleName mns)

513 line $ "There is a cycle in the module dependencies: " ++ intercalate ", " (map runModuleName mns)

519 renderSimpleErrorMessage (CycleInTypeSynonym name) =

514 renderSimpleErrorMessage (CycleInTypeSynonym name) =

@@ -524,9 +519,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

524 , line "Consider using a 'newtype' instead."

519 , line "Consider using a 'newtype' instead."

525 ]

520 ]

526 renderSimpleErrorMessage (NameIsUndefined ident) =

521 renderSimpleErrorMessage (NameIsUndefined ident) =

527− line $ "The name " ++ showIdent ident ++ " is undefined."

522+ line $ "The value " ++ showIdent ident ++ " is undefined."

528− renderSimpleErrorMessage (NameNotInScope ident) =

529− line $ "The name " ++ showIdent ident ++ " may not be defined in the current scope."

530 renderSimpleErrorMessage (UndefinedTypeVariable name) =

523 renderSimpleErrorMessage (UndefinedTypeVariable name) =

531 line $ "The type variable " ++ runProperName name ++ " is undefined."

524 line $ "The type variable " ++ runProperName name ++ " is undefined."

532 renderSimpleErrorMessage (PartiallyAppliedSynonym name) =

525 renderSimpleErrorMessage (PartiallyAppliedSynonym name) =

@@ -539,21 +532,21 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

539 , indent $ prettyPrintValue expr

532 , indent $ prettyPrintValue expr

540 ]) binding

533 ]) binding

541 renderSimpleErrorMessage (TypesDoNotUnify t1 t2)

534 renderSimpleErrorMessage (TypesDoNotUnify t1 t2)

542− = paras [ line "The type"

535+ = paras [ line "Could not match expected type"

543 , indent $ typeAsBox t1

536 , indent $ typeAsBox t1

544− , line "cannot be made equal to the type"

537+ , line "with actual type"

545 , indent $ typeAsBox t2

538 , indent $ typeAsBox t2

546 ]

539 ]

547 renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =

540 renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =

548− paras [ line "The kind"

541+ paras [ line "Could not match expected kind"

549 , indent $ line $ prettyPrintKind k1

542 , indent $ line $ prettyPrintKind k1

550− , line "cannot be made equal to the kind"

543+ , line "with actual kind"

551 , indent $ line $ prettyPrintKind k2

544 , indent $ line $ prettyPrintKind k2

552 ]

545 ]

553 renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) =

546 renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) =

554− paras [ line "The constrained type"

547+ paras [ line "Could not match the constrained type"

555 , indent $ typeAsBox t1

548 , indent $ typeAsBox t1

556− , line "cannot be made equal to the kind"

549+ , line "with type"

557 , indent $ typeAsBox t2

550 , indent $ typeAsBox t2

558 ]

551 ]

559 renderSimpleErrorMessage (OverlappingInstances nm ts (d : ds)) =

552 renderSimpleErrorMessage (OverlappingInstances nm ts (d : ds)) =

@@ -563,8 +556,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

563 ]

556 ]

564 , line "The following instances were found:"

557 , line "The following instances were found:"

565 , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds)

558 , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds)

559+ , line "Overlapping type class instances can lead to different behavior based on the order of module imports, and for that reason are not recommended."

560+ , line "They may be disallowed completely in a future version of the compiler."

566 ]

561 ]

567− renderSimpleErrorMessage OverlappingInstances{} = error "OverlappingInstances: empty instance list"

562+ renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list"

568 renderSimpleErrorMessage (NoInstanceFound nm ts) =

563 renderSimpleErrorMessage (NoInstanceFound nm ts) =

569 paras [ line "No type class instance was found for"

564 paras [ line "No type class instance was found for"

570 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

565 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

@@ -587,7 +582,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

587 renderSimpleErrorMessage (CannotFindDerivingType nm) =

582 renderSimpleErrorMessage (CannotFindDerivingType nm) =

588 line $ "Cannot derive a type class instance, because the type declaration for " ++ runProperName nm ++ " could not be found."

583 line $ "Cannot derive a type class instance, because the type declaration for " ++ runProperName nm ++ " could not be found."

589 renderSimpleErrorMessage (DuplicateLabel l expr) =

584 renderSimpleErrorMessage (DuplicateLabel l expr) =

590− paras $ [ line $ "The duplicate label " ++ show l ++ " appears in a row type." ]

585+ paras $ [ line $ "The label " ++ show l ++ " appears more than once in a row type." ]

591 <> foldMap (\expr' -> [ line "Relevant expression: "

586 <> foldMap (\expr' -> [ line "Relevant expression: "

592 , indent $ prettyPrintValue expr'

587 , indent $ prettyPrintValue expr'

593 ]) expr

588 ]) expr

@@ -622,7 +617,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

622 renderSimpleErrorMessage (PropertyIsMissing prop row) =

617 renderSimpleErrorMessage (PropertyIsMissing prop row) =

623 paras [ line "The row type"

618 paras [ line "The row type"

624 , indent $ prettyPrintRowWith '(' ')' row

619 , indent $ prettyPrintRowWith '(' ')' row

625− , line $ "lacks the required property " ++ show prop

620+ , line $ "lacks the required label " ++ show prop

626 ]

621 ]

627 renderSimpleErrorMessage (CannotApplyFunction fn arg) =

622 renderSimpleErrorMessage (CannotApplyFunction fn arg) =

628 paras [ line "A function of type"

623 paras [ line "A function of type"

@@ -641,11 +636,14 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

641 , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."

636 , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."

642 , line "Consider moving the instance, if possible, or using a newtype wrapper."

637 , line "Consider moving the instance, if possible, or using a newtype wrapper."

643 ]

638 ]

644− renderSimpleErrorMessage InvalidNewtype =

639+ renderSimpleErrorMessage (InvalidNewtype name) =

640+ paras [ line $ "The newtype " ++ runProperName name ++ " is invalid."

645− line "Newtypes must define a single constructor with a single argument."

641+ , line "Newtypes must define a single constructor with a single argument."

642+ ]

646 renderSimpleErrorMessage (InvalidInstanceHead ty) =

643 renderSimpleErrorMessage (InvalidInstanceHead ty) =

647− paras [ line "An invalid type appears in a type class instance head:"

644+ paras [ line "Type class instance head is invalid due to the use of the type"

648 , indent $ typeAsBox ty

645 , indent $ typeAsBox ty

646+ , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form."

649 ]

647 ]

650 renderSimpleErrorMessage (TransitiveExportError x ys) =

648 renderSimpleErrorMessage (TransitiveExportError x ys) =

651 paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")

649 paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")

@@ -697,9 +695,9 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

697 renderHint (NotYetDefined names) =

695 renderHint (NotYetDefined names) =

698 line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"

696 line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"

699 renderHint (ErrorUnifyingTypes t1 t2) =

697 renderHint (ErrorUnifyingTypes t1 t2) =

700− paras [ lineWithLevel "while trying to make the type "

698+ paras [ lineWithLevel "while trying to match the type "

701 , indent $ typeAsBox t1

699 , indent $ typeAsBox t1

702− , line "equal to the type"

700+ , line "with the type"

703 , indent $ typeAsBox t2

701 , indent $ typeAsBox t2

704 ]

702 ]

705 renderHint (ErrorInExpression expr) =

703 renderHint (ErrorInExpression expr) =

@@ -712,7 +710,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

712 renderHint (ErrorInSubsumption t1 t2) =

710 renderHint (ErrorInSubsumption t1 t2) =

713 paras [ lineWithLevel "checking that the type"

711 paras [ lineWithLevel "checking that the type"

714 , indent $ typeAsBox t1

712 , indent $ typeAsBox t1

715− , line "is more general than the type"

713+ , line "is at least as general as the type"

716 , indent $ typeAsBox t2

714 , indent $ typeAsBox t2

717 ]

715 ]

718 renderHint (ErrorInInstance nm ts) =

716 renderHint (ErrorInInstance nm ts) =

src/Language/PureScript/Externs.hs+4−3

@@ -38,6 +38,7 @@ import Data.Aeson.TH

38

39import qualified Data.Map as M

40

41+import Language.PureScript.Crash

41import Language.PureScript.AST

42import Language.PureScript.AST

42import Language.PureScript.Environment

43import Language.PureScript.Environment

43import Language.PureScript.Names

44import Language.PureScript.Names

@@ -152,7 +153,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar

152

153

153-- | Generate an externs file for all declarations in a module

154-- | Generate an externs file for all declarations in a module

154moduleToExternsFile :: Module -> Environment -> ExternsFile

155moduleToExternsFile :: Module -> Environment -> ExternsFile

155−moduleToExternsFile (Module _ _ _ _ Nothing) _ = error "moduleToExternsFile: module exports were not elaborated"

156+moduleToExternsFile (Module _ _ _ _ Nothing) _ = internalError "moduleToExternsFile: module exports were not elaborated"

156moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

157moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

157 where

158 where

158 efVersion = showVersion Paths.version

159 efVersion = showVersion Paths.version

@@ -181,7 +182,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

181 toExternsDeclaration (PositionedDeclarationRef _ _ r) = toExternsDeclaration r

182 toExternsDeclaration (PositionedDeclarationRef _ _ r) = toExternsDeclaration r

182 toExternsDeclaration (TypeRef pn dctors) =

183 toExternsDeclaration (TypeRef pn dctors) =

183 case Qualified (Just mn) pn `M.lookup` types env of

184 case Qualified (Just mn) pn `M.lookup` types env of

184− Nothing -> error "toExternsDeclaration: no kind in toExternsDeclaration"

185+ Nothing -> internalError "toExternsDeclaration: no kind in toExternsDeclaration"

185 Just (kind, TypeSynonym)

186 Just (kind, TypeSynonym)

186 | Just (args, synTy) <- Qualified (Just mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ]

187 | Just (args, synTy) <- Qualified (Just mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ]

187 Just (kind, ExternData) -> [ EDType pn kind ExternData ]

188 Just (kind, ExternData) -> [ EDType pn kind ExternData ]

@@ -190,7 +191,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}

190 | dctor <- fromMaybe (map fst tys) dctors

191 | dctor <- fromMaybe (map fst tys) dctors

191 , (dty, _, ty, args) <- maybeToList (M.lookup (Qualified (Just mn) dctor) (dataConstructors env))

192 , (dty, _, ty, args) <- maybeToList (M.lookup (Qualified (Just mn) dctor) (dataConstructors env))

192 ]

193 ]

193− _ -> error "toExternsDeclaration: Invalid input"

194+ _ -> internalError "toExternsDeclaration: Invalid input"

194 toExternsDeclaration (ValueRef ident)

195 toExternsDeclaration (ValueRef ident)

195 | Just (ty, _, _) <- (mn, ident) `M.lookup` names env

196 | Just (ty, _, _) <- (mn, ident) `M.lookup` names env

196 = [ EDValue ident ty ]

197 = [ EDValue ident ty ]

src/Language/PureScript/Linter.hs+2−1

@@ -30,6 +30,7 @@ import Control.Applicative

30#endif

31import Control.Monad.Writer.Class

32

33+import Language.PureScript.Crash

33import Language.PureScript.AST

34import Language.PureScript.AST

34import Language.PureScript.Names

35import Language.PureScript.Names

35import Language.PureScript.Errors

36import Language.PureScript.Errors

@@ -50,7 +51,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl

50 getDeclIdent (ValueDeclaration ident _ _ _) = Just ident

51 getDeclIdent (ValueDeclaration ident _ _ _) = Just ident

51 getDeclIdent (ExternDeclaration ident _) = Just ident

52 getDeclIdent (ExternDeclaration ident _) = Just ident

52 getDeclIdent (TypeInstanceDeclaration ident _ _ _ _) = Just ident

53 getDeclIdent (TypeInstanceDeclaration ident _ _ _ _) = Just ident

53− getDeclIdent (BindingGroupDeclaration _) = error "lint: binding groups should not be desugared yet."

54+ getDeclIdent (BindingGroupDeclaration _) = internalError "lint: binding groups should not be desugared yet."

54 getDeclIdent _ = Nothing

55 getDeclIdent _ = Nothing

55

56

56 lintDeclaration :: Declaration -> m ()

57 lintDeclaration :: Declaration -> m ()

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

@@ -38,6 +38,7 @@ import Control.Applicative

38import Control.Arrow (first, second)

39import Control.Monad.Writer.Class

40

41+import Language.PureScript.Crash

41import Language.PureScript.AST.Binders

42import Language.PureScript.AST.Binders

42import Language.PureScript.AST.Declarations

43import Language.PureScript.AST.Declarations

43import Language.PureScript.Environment

44import Language.PureScript.Environment

@@ -92,7 +93,7 @@ getConstructors env defmn n = extractConstructors lnte

92

93

93 extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName, [Type])]

94 extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName, [Type])]

94 extractConstructors (Just (_, DataType _ pt)) = pt

95 extractConstructors (Just (_, DataType _ pt)) = pt

95− extractConstructors _ = error "Data name not in the scope of the current environment in extractConstructors"

96+ extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors"

96

97

97-- |

98-- |

98-- Replicates a wildcard binder

99-- Replicates a wildcard binder

@@ -197,7 +198,7 @@ missingCasesMultiple env mn = go

197 where

198 where

198 (miss1, pr1) = missingCasesSingle env mn x y

199 (miss1, pr1) = missingCasesSingle env mn x y

199 (miss2, pr2) = go xs ys

200 (miss2, pr2) = go xs ys

200− go _ _ = error "Argument lengths did not match in missingCasesMultiple."

201+ go _ _ = internalError "Argument lengths did not match in missingCasesMultiple."

201

202

202-- |

203-- |

203-- Guard handling

204-- Guard handling

src/Language/PureScript/Make.hs+8−7

@@ -72,6 +72,7 @@ import System.Directory

72import System.FilePath ((</>), takeDirectory)

73import System.IO.Error (tryIOError)

74

75+import Language.PureScript.Crash

75import Language.PureScript.AST

76import Language.PureScript.AST

76import Language.PureScript.Externs

77import Language.PureScript.Externs

77import Language.PureScript.Environment

78import Language.PureScript.Environment

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

166 barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar)

167 barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar)

167

168

168 for_ sorted $ \m -> fork $ do

169 for_ sorted $ \m -> fork $ do

169− let deps = fromMaybe (error "make: module not found in dependency graph.") (lookup (getModuleName m) graph)

170+ let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup (getModuleName m) graph)

170 buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted)

171 buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted)

171

172

172 -- Wait for all threads to complete, and collect errors.

173 -- Wait for all threads to complete, and collect errors.

@@ -176,7 +177,7 @@ make MakeActions{..} ms = do

176 unless (null errors) $ throwError (mconcat errors)

177 unless (null errors) $ throwError (mconcat errors)

177

178

178 -- Bundle up all the externs and return them as an Environment

179 -- Bundle up all the externs and return them as an Environment

179− (warnings, externs) <- unzip . fromMaybe (error "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd)

180+ (warnings, externs) <- unzip . fromMaybe (internalError "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd)

180 tell (mconcat warnings)

181 tell (mconcat warnings)

181 return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs

182 return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs

182

183

@@ -205,7 +206,7 @@ make MakeActions{..} ms = do

205 -- We need to wait for dependencies to be built, before checking if the current

206 -- We need to wait for dependencies to be built, before checking if the current

206 -- module should be rebuilt, so the first thing to do is to wait on the

207 -- module should be rebuilt, so the first thing to do is to wait on the

207 -- MVars for the module's dependencies.

208 -- MVars for the module's dependencies.

208− mexterns <- fmap unzip . sequence <$> mapM (readMVar . fst . fromMaybe (error "make: no barrier") . flip lookup barriers) deps

209+ mexterns <- fmap unzip . sequence <$> mapM (readMVar . fst . fromMaybe (internalError "make: no barrier") . flip lookup barriers) deps

209

210

210 outputTimestamp <- getOutputTimestamp moduleName

211 outputTimestamp <- getOutputTimestamp moduleName

211 dependencyTimestamp <- maximumMaybe <$> mapM (fmap shouldExist . getOutputTimestamp) deps

212 dependencyTimestamp <- maximumMaybe <$> mapM (fmap shouldExist . getOutputTimestamp) deps

@@ -247,8 +248,8 @@ make MakeActions{..} ms = do

247 where

248 where

248 markComplete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m ()

249 markComplete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m ()

249 markComplete externs errors = do

250 markComplete externs errors = do

250− putMVar (fst $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) externs

251+ putMVar (fst $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) externs

251− putMVar (snd $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) errors

252+ putMVar (snd $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) errors

252

253

253 maximumMaybe :: (Ord a) => [a] -> Maybe a

254 maximumMaybe :: (Ord a) => [a] -> Maybe a

254 maximumMaybe [] = Nothing

255 maximumMaybe [] = Nothing

@@ -257,7 +258,7 @@ make MakeActions{..} ms = do

257 -- Make sure a dependency exists

258 -- Make sure a dependency exists

258 shouldExist :: Maybe UTCTime -> UTCTime

259 shouldExist :: Maybe UTCTime -> UTCTime

259 shouldExist (Just t) = t

260 shouldExist (Just t) = t

260− shouldExist _ = error "make: dependency should already have been built."

261+ shouldExist _ = internalError "make: dependency should already have been built."

261

262

262 decodeExterns :: B.ByteString -> Maybe ExternsFile

263 decodeExterns :: B.ByteString -> Maybe ExternsFile

263 decodeExterns bs = do

264 decodeExterns bs = do

@@ -324,7 +325,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

324

325

325 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))

326 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))

326 getInputTimestamp mn = do

327 getInputTimestamp mn = do

327− let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap

328+ let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap

328 e1 <- traverseEither getTimestamp path

329 e1 <- traverseEither getTimestamp path

329 fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns

330 fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns

330 return $ fmap (max fPath) e1

331 return $ fmap (max fPath) e1

src/Language/PureScript/ModuleDependencies.hs+2−1

@@ -25,6 +25,7 @@ import Data.Graph

25import Data.List (nub)

26import Data.Maybe (fromMaybe, mapMaybe)

27

28+import Language.PureScript.Crash

28import Language.PureScript.AST

29import Language.PureScript.AST

29import Language.PureScript.Names

30import Language.PureScript.Names

30import Language.PureScript.Types

31import Language.PureScript.Types

@@ -43,7 +44,7 @@ sortModules ms = do

43 ms' <- mapM toModule $ stronglyConnComp verts

44 ms' <- mapM toModule $ stronglyConnComp verts

44 let (graph, fromVertex, toVertex) = graphFromEdges verts

45 let (graph, fromVertex, toVertex) = graphFromEdges verts

45 moduleGraph = do (_, mn, _) <- verts

46 moduleGraph = do (_, mn, _) <- verts

46− let v = fromMaybe (error "sortModules: vertex not found") (toVertex mn)

47+ let v = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn)

47 deps = reachable graph v

48 deps = reachable graph v

48 toKey i = case fromVertex i of (_, key, _) -> key

49 toKey i = case fromVertex i of (_, key, _) -> key

49 return (mn, filter (/= mn) (map toKey deps))

50 return (mn, filter (/= mn) (map toKey deps))

src/Language/PureScript/Pretty/JS.hs+3−2

@@ -30,6 +30,7 @@ import Control.Monad.State

30import Control.PatternArrows

31import qualified Control.Arrow as A

32

33+import Language.PureScript.Crash

33import Language.PureScript.CodeGen.JS.AST

34import Language.PureScript.CodeGen.JS.AST

34import Language.PureScript.CodeGen.JS.Common

35import Language.PureScript.CodeGen.JS.Common

35import Language.PureScript.Pretty.Common

36import Language.PureScript.Pretty.Common

@@ -251,13 +252,13 @@ prettyStatements sts = do

251-- Generate a pretty-printed string representing a Javascript expression

252-- Generate a pretty-printed string representing a Javascript expression

252--

253--

253prettyPrintJS1 :: JS -> String

254prettyPrintJS1 :: JS -> String

254−prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'

255+prettyPrintJS1 = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'

255

256

256-- |

257-- |

257-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level

258-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level

258--

259--

259prettyPrintJS :: [JS] -> String

260prettyPrintJS :: [JS] -> String

260−prettyPrintJS = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements

261+prettyPrintJS = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements

261

262

262-- |

263-- |

263-- Generate an indented, pretty-printed string representing a Javascript expression

264-- Generate an indented, pretty-printed string representing a Javascript expression

src/Language/PureScript/Pretty/Kinds.hs+2−1

@@ -22,6 +22,7 @@ import Data.Maybe (fromMaybe)

22import Control.Arrow (ArrowPlus(..))

23import Control.PatternArrows

24

25+import Language.PureScript.Crash

25import Language.PureScript.Kinds

26import Language.PureScript.Kinds

26import Language.PureScript.Pretty.Common

27import Language.PureScript.Pretty.Common

27

28

@@ -47,7 +48,7 @@ funKind = mkPattern match

47

48

48-- | Generate a pretty-printed string representing a Kind

49-- | Generate a pretty-printed string representing a Kind

49prettyPrintKind :: Kind -> String

50prettyPrintKind :: Kind -> String

50−prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()

51+prettyPrintKind = fromMaybe (internalError "Incomplete pattern") . pattern matchKind ()

51 where

52 where

52 matchKind :: Pattern () Kind String

53 matchKind :: Pattern () Kind String

53 matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)

54 matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)

src/Language/PureScript/Pretty/Types.hs+3−2

@@ -27,6 +27,7 @@ import Data.Maybe (fromMaybe)

27import Control.Arrow ((<+>))

28import Control.PatternArrows

29

30+import Language.PureScript.Crash

30import Language.PureScript.Types

31import Language.PureScript.Types

31import Language.PureScript.Names

32import Language.PureScript.Names

32import Language.PureScript.Kinds

33import Language.PureScript.Kinds

@@ -136,14 +137,14 @@ forall_ = mkPattern match

136 match _ = Nothing

137 match _ = Nothing

137

138

138typeAtomAsBox :: Type -> Box

139typeAtomAsBox :: Type -> Box

139−typeAtomAsBox = fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders

140+typeAtomAsBox = fromMaybe (internalError "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders

140

141

141-- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses

142-- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses

142prettyPrintTypeAtom :: Type -> String

143prettyPrintTypeAtom :: Type -> String

143prettyPrintTypeAtom = render . typeAtomAsBox

144prettyPrintTypeAtom = render . typeAtomAsBox

144

145

145typeAsBox :: Type -> Box

146typeAsBox :: Type -> Box

146−typeAsBox = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders

147+typeAsBox = fromMaybe (internalError "Incomplete pattern") . pattern matchType () . insertPlaceholders

147

148

148-- | Generate a pretty-printed string representing a Type

149-- | Generate a pretty-printed string representing a Type

149prettyPrintType :: Type -> String

150prettyPrintType :: Type -> String

src/Language/PureScript/Pretty/Values.hs+2−1

@@ -25,6 +25,7 @@ import Data.List (intercalate)

25

26import Control.Arrow (second)

27

28+import Language.PureScript.Crash

28import Language.PureScript.AST

29import Language.PureScript.AST

29import Language.PureScript.Names

30import Language.PureScript.Names

30import Language.PureScript.Pretty.Common

31import Language.PureScript.Pretty.Common

@@ -103,7 +104,7 @@ prettyPrintDeclaration (BindingGroupDeclaration ds) =

103 where

104 where

104 toDecl (nm, t, e) = ValueDeclaration nm t [] (Right e)

105 toDecl (nm, t, e) = ValueDeclaration nm t [] (Right e)

105prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d

106prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d

106−prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"

107+prettyPrintDeclaration _ = internalError "Invalid argument to prettyPrintDeclaration"

107

108

108prettyPrintCaseAlternative :: CaseAlternative -> Box

109prettyPrintCaseAlternative :: CaseAlternative -> Box

109prettyPrintCaseAlternative (CaseAlternative binders result) =

110prettyPrintCaseAlternative (CaseAlternative binders result) =

src/Language/PureScript/Sugar/BindingGroups.hs+6−5

@@ -35,6 +35,7 @@ import Control.Monad.Error.Class (MonadError(..))

35

36import qualified Data.Set as S

37

38+import Language.PureScript.Crash

38import Language.PureScript.AST

39import Language.PureScript.AST

39import Language.PureScript.Names

40import Language.PureScript.Names

40import Language.PureScript.Types

41import Language.PureScript.Types

@@ -145,13 +146,13 @@ usedProperNames moduleName =

145getIdent :: Declaration -> Ident

146getIdent :: Declaration -> Ident

146getIdent (ValueDeclaration ident _ _ _) = ident

147getIdent (ValueDeclaration ident _ _ _) = ident

147getIdent (PositionedDeclaration _ _ d) = getIdent d

148getIdent (PositionedDeclaration _ _ d) = getIdent d

148−getIdent _ = error "Expected ValueDeclaration"

149+getIdent _ = internalError "Expected ValueDeclaration"

149

150

150getProperName :: Declaration -> ProperName

151getProperName :: Declaration -> ProperName

151getProperName (DataDeclaration _ pn _ _) = pn

152getProperName (DataDeclaration _ pn _ _) = pn

152getProperName (TypeSynonymDeclaration pn _ _) = pn

153getProperName (TypeSynonymDeclaration pn _ _) = pn

153getProperName (PositionedDeclaration _ _ d) = getProperName d

154getProperName (PositionedDeclaration _ _ d) = getProperName d

154−getProperName _ = error "Expected DataDeclaration"

155+getProperName _ = internalError "Expected DataDeclaration"

155

156

156-- |

157-- |

157-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).

158-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).

@@ -185,7 +186,7 @@ toBindingGroup moduleName (CyclicSCC ds') =

185 cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds

186 cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds

186 cycleError (ValueDeclaration n _ _ (Right _)) [] = throwError . errorMessage $ CycleInDeclaration n

187 cycleError (ValueDeclaration n _ _ (Right _)) [] = throwError . errorMessage $ CycleInDeclaration n

187 cycleError d ds@(_:_) = rethrow (addHint (NotYetDefined (map getIdent ds))) $ cycleError d []

188 cycleError d ds@(_:_) = rethrow (addHint (NotYetDefined (map getIdent ds))) $ cycleError d []

188− cycleError _ _ = error "Expected ValueDeclaration"

189+ cycleError _ _ = internalError "Expected ValueDeclaration"

189

190

190toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration

191toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration

191toDataBindingGroup (AcyclicSCC d) = return d

192toDataBindingGroup (AcyclicSCC d) = return d

@@ -203,6 +204,6 @@ isTypeSynonym _ = Nothing

203

204

204fromValueDecl :: Declaration -> (Ident, NameKind, Expr)

205fromValueDecl :: Declaration -> (Ident, NameKind, Expr)

205fromValueDecl (ValueDeclaration ident nameKind [] (Right val)) = (ident, nameKind, val)

206fromValueDecl (ValueDeclaration ident nameKind [] (Right val)) = (ident, nameKind, val)

206−fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"

207+fromValueDecl ValueDeclaration{} = internalError "Binders should have been desugared"

207fromValueDecl (PositionedDeclaration _ _ d) = fromValueDecl d

208fromValueDecl (PositionedDeclaration _ _ d) = fromValueDecl d

208−fromValueDecl _ = error "Expected ValueDeclaration"

209+fromValueDecl _ = internalError "Expected ValueDeclaration"

src/Language/PureScript/Sugar/CaseDeclarations.hs+3−2

@@ -23,6 +23,7 @@ module Language.PureScript.Sugar.CaseDeclarations (

23 desugarCasesModule

24) where

25

26+import Language.PureScript.Crash

26import Data.Maybe (catMaybes)

27import Data.Maybe (catMaybes)

27import Data.List (nub, groupBy)

28import Data.List (nub, groupBy)

28

29

@@ -112,7 +113,7 @@ toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs =

112 fromVarBinder (VarBinder name) = return name

113 fromVarBinder (VarBinder name) = return name

113 fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b

114 fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b

114 fromVarBinder (TypedBinder _ b) = fromVarBinder b

115 fromVarBinder (TypedBinder _ b) = fromVarBinder b

115− fromVarBinder _ = error "fromVarBinder: Invalid argument"

116+ fromVarBinder _ = internalError "fromVarBinder: Invalid argument"

116toDecls ds@(ValueDeclaration ident _ bs result : _) = do

117toDecls ds@(ValueDeclaration ident _ bs result : _) = do

117 let tuples = map toTuple ds

118 let tuples = map toTuple ds

118 unless (all ((== length bs) . length . fst) tuples) $

119 unless (all ((== length bs) . length . fst) tuples) $

@@ -129,7 +130,7 @@ toDecls ds = return ds

129toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr)

130toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr)

130toTuple (ValueDeclaration _ _ bs result) = (bs, result)

131toTuple (ValueDeclaration _ _ bs result) = (bs, result)

131toTuple (PositionedDeclaration _ _ d) = toTuple d

132toTuple (PositionedDeclaration _ _ d) = toTuple d

132−toTuple _ = error "Not a value declaration"

133+toTuple _ = internalError "Not a value declaration"

133

134

134makeCaseDeclaration :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration

135makeCaseDeclaration :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration

135makeCaseDeclaration ident alternatives = do

136makeCaseDeclaration ident alternatives = do

src/Language/PureScript/Sugar/DoNotation.hs+2−1

@@ -22,6 +22,7 @@ module Language.PureScript.Sugar.DoNotation (

22 desugarDoModule

23) where

24

25+import Language.PureScript.Crash

25import Language.PureScript.Names

26import Language.PureScript.Names

26import Language.PureScript.AST

27import Language.PureScript.AST

27import Language.PureScript.Errors

28import Language.PureScript.Errors

@@ -56,7 +57,7 @@ desugarDo d =

56 replace other = return other

57 replace other = return other

57

58

58 go :: [DoNotationElement] -> m Expr

59 go :: [DoNotationElement] -> m Expr

59− go [] = error "The impossible happened in desugarDo"

60+ go [] = internalError "The impossible happened in desugarDo"

60 go [DoNotationValue val] = return val

61 go [DoNotationValue val] = return val

61 go (DoNotationValue val : rest) = do

62 go (DoNotationValue val : rest) = do

62 rest' <- go rest

63 rest' <- go rest

src/Language/PureScript/Sugar/Names.hs+2−1

@@ -30,6 +30,7 @@ import Control.Monad.Writer (MonadWriter(..))

30

31import qualified Data.Map as M

32

33+import Language.PureScript.Crash

33import Language.PureScript.AST

34import Language.PureScript.AST

34import Language.PureScript.Names

35import Language.PureScript.Names

35import Language.PureScript.Types

36import Language.PureScript.Types

@@ -99,7 +100,7 @@ desugarImports externs modules = do

99 renameInModule' :: Env -> Module -> m Module

100 renameInModule' :: Env -> Module -> m Module

100 renameInModule' env m@(Module _ _ mn _ _) =

101 renameInModule' env m@(Module _ _ mn _ _) =

101 rethrow (addHint (ErrorInModule mn)) $ do

102 rethrow (addHint (ErrorInModule mn)) $ do

102− let (_, imps, exps) = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn env

103+ let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env

103 elaborateImports imps <$> renameInModule env imps (elaborateExports exps m)

104 elaborateImports imps <$> renameInModule env imps (elaborateExports exps m)

104

105

105-- |

106-- |

src/Language/PureScript/Sugar/Names/Exports.hs+8−7

@@ -33,6 +33,7 @@ import Control.Monad.Error.Class (MonadError(..))

33

34import qualified Data.Map as M

35

36+import Language.PureScript.Crash

36import Language.PureScript.AST

37import Language.PureScript.AST

37import Language.PureScript.Names

38import Language.PureScript.Names

38import Language.PureScript.Errors

39import Language.PureScript.Errors

@@ -52,7 +53,7 @@ findExportable (Module _ _ mn ds _) =

52 where

53 where

53 go exps'' (TypeDeclaration name _) = exportValue exps'' name mn

54 go exps'' (TypeDeclaration name _) = exportValue exps'' name mn

54 go exps'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go exps'' d

55 go exps'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go exps'' d

55− go _ _ = error "Invalid declaration in TypeClassDeclaration"

56+ go _ _ = internalError "Invalid declaration in TypeClassDeclaration"

56 updateExports exps (DataDeclaration _ tn _ dcs) = exportType exps tn (map fst dcs) mn

57 updateExports exps (DataDeclaration _ tn _ dcs) = exportType exps tn (map fst dcs) mn

57 updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn

58 updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn

58 updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn

59 updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn

@@ -137,24 +138,24 @@ resolveExports env mn imps exps refs =

137 resolveTypeExports tctors dctors = map go tctors

138 resolveTypeExports tctors dctors = map go tctors

138 where

139 where

139 go :: Qualified ProperName -> ((ProperName, [ProperName]), ModuleName)

140 go :: Qualified ProperName -> ((ProperName, [ProperName]), ModuleName)

140− go (Qualified (Just mn'') name) = fromMaybe (error "Missing value in resolveTypeExports") $ do

141+ go (Qualified (Just mn'') name) = fromMaybe (internalError "Missing value in resolveTypeExports") $ do

141 exps' <- envModuleExports <$> mn'' `M.lookup` env

142 exps' <- envModuleExports <$> mn'' `M.lookup` env

142 ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps')

143 ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps')

143 let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mnOrig then Just dctor else Nothing) dctors

144 let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mnOrig then Just dctor else Nothing) dctors

144 return ((name, intersect relevantDctors dctors'), mnOrig)

145 return ((name, intersect relevantDctors dctors'), mnOrig)

145− go (Qualified Nothing _) = error "Unqualified value in resolveTypeExports"

146+ go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports"

146

147

148

148 -- Looks up an imported class and re-qualifies it with the original module it

149 -- Looks up an imported class and re-qualifies it with the original module it

149 -- came from.

150 -- came from.

150 resolveClass :: Qualified ProperName -> (ProperName, ModuleName)

151 resolveClass :: Qualified ProperName -> (ProperName, ModuleName)

151− resolveClass className = splitQual $ fromMaybe (error "Missing value in resolveClass") $

152+ resolveClass className = splitQual $ fromMaybe (internalError "Missing value in resolveClass") $

152 resolve exportedTypeClasses className

153 resolve exportedTypeClasses className

153

154

154 -- Looks up an imported value and re-qualifies it with the original module it

155 -- Looks up an imported value and re-qualifies it with the original module it

155 -- came from.

156 -- came from.

156 resolveValue :: Qualified Ident -> (Ident, ModuleName)

157 resolveValue :: Qualified Ident -> (Ident, ModuleName)

157− resolveValue ident = splitQual $ fromMaybe (error "Missing value in resolveValue") $

158+ resolveValue ident = splitQual $ fromMaybe (internalError "Missing value in resolveValue") $

158 resolve exportedValues ident

159 resolve exportedValues ident

159

160

160 resolve :: (Eq a) => (Exports -> [(a, ModuleName)]) -> Qualified a -> Maybe (Qualified a)

161 resolve :: (Eq a) => (Exports -> [(a, ModuleName)]) -> Qualified a -> Maybe (Qualified a)

@@ -162,13 +163,13 @@ resolveExports env mn imps exps refs =

162 exps' <- envModuleExports <$> mn'' `M.lookup` env

163 exps' <- envModuleExports <$> mn'' `M.lookup` env

163 mn''' <- snd <$> find ((== a) . fst) (f exps')

164 mn''' <- snd <$> find ((== a) . fst) (f exps')

164 return $ Qualified (Just mn''') a

165 return $ Qualified (Just mn''') a

165− resolve _ _ = error "Unqualified value in resolve"

166+ resolve _ _ = internalError "Unqualified value in resolve"

166

167

167 -- A partial function that takes a qualified value and extracts the value and

168 -- A partial function that takes a qualified value and extracts the value and

168 -- qualified module components.

169 -- qualified module components.

169 splitQual :: Qualified a -> (a, ModuleName)

170 splitQual :: Qualified a -> (a, ModuleName)

170 splitQual (Qualified (Just mn'') a) = (a, mn'')

171 splitQual (Qualified (Just mn'') a) = (a, mn'')

171− splitQual _ = error "Unqualified value in splitQual"

172+ splitQual _ = internalError "Unqualified value in splitQual"

172

173

173-- |

174-- |

174-- Filters the full list of exportable values, types, and classes for a module

175-- Filters the full list of exportable values, types, and classes for a module

src/Language/PureScript/Sugar/Names/Imports.hs+7−6

@@ -34,6 +34,7 @@ import Control.Monad.Writer (MonadWriter(..), censor)

34

35import qualified Data.Map as M

36

37+import Language.PureScript.Crash

37import Language.PureScript.AST

38import Language.PureScript.AST

38import Language.PureScript.Names

39import Language.PureScript.Names

39import Language.PureScript.Errors

40import Language.PureScript.Errors

@@ -115,7 +116,7 @@ resolveImport currentModule importModule exps imps impQual =

115 checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name

116 checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name

116 --check (ModuleRef name) =

117 --check (ModuleRef name) =

117 -- checkImportExists (const UnknownModule) (exportedModules exps) name

118 -- checkImportExists (const UnknownModule) (exportedModules exps) name

118− check _ = error "Invalid argument to checkRefs"

119+ check _ = internalError "Invalid argument to checkRefs"

119

120

120 -- Check that an explicitly imported item exists in the module it is being imported from

121 -- Check that an explicitly imported item exists in the module it is being imported from

121 checkImportExists :: (Eq a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m ()

122 checkImportExists :: (Eq a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m ()

@@ -171,13 +172,13 @@ resolveImport currentModule importModule exps imps impQual =

171 importExplicit imp (TypeClassRef name) = do

172 importExplicit imp (TypeClassRef name) = do

172 typeClasses' <- updateImports (importedTypeClasses imp) runProperName (exportedTypeClasses exps) name

173 typeClasses' <- updateImports (importedTypeClasses imp) runProperName (exportedTypeClasses exps) name

173 return $ imp { importedTypeClasses = typeClasses' }

174 return $ imp { importedTypeClasses = typeClasses' }

174− importExplicit _ _ = error "Invalid argument to importExplicit"

175+ importExplicit _ _ = internalError "Invalid argument to importExplicit"

175

176

176 -- Find all exported data constructors for a given type

177 -- Find all exported data constructors for a given type

177 allExportedDataConstructors :: ProperName -> [(ProperName, ModuleName)]

178 allExportedDataConstructors :: ProperName -> [(ProperName, ModuleName)]

178 allExportedDataConstructors name =

179 allExportedDataConstructors name =

179 case find ((== name) . fst . fst) (exportedTypes exps) of

180 case find ((== name) . fst . fst) (exportedTypes exps) of

180− Nothing -> error "Invalid state in allExportedDataConstructors"

181+ Nothing -> internalError "Invalid state in allExportedDataConstructors"

181 Just ((_, dctors), mn) -> map (, mn) dctors

182 Just ((_, dctors), mn) -> map (, mn) dctors

182

183

183 -- Add something to the Imports if it does not already exist there

184 -- Add something to the Imports if it does not already exist there

@@ -191,7 +192,7 @@ resolveImport currentModule importModule exps imps impQual =

191 -- If the name is not already present add it to the list, after looking up

192 -- If the name is not already present add it to the list, after looking up

192 -- where it was originally defined

193 -- where it was originally defined

193 Nothing ->

194 Nothing ->

194− let mnOrig = fromMaybe (error "Invalid state in updateImports") (name `lookup` exps')

195+ let mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps')

195 in return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name, mnOrig) imps'

196 in return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name, mnOrig) imps'

196

197

197 -- If the name already is present check whether it's a duplicate import

198 -- If the name already is present check whether it's a duplicate import

@@ -199,7 +200,7 @@ resolveImport currentModule importModule exps imps impQual =

199 -- re-exports A, importing A and B in C should not result in a "conflicting

200 -- re-exports A, importing A and B in C should not result in a "conflicting

200 -- import for `x`" error

201 -- import for `x`" error

201 Just (Qualified (Just mn) _, mnOrig)

202 Just (Qualified (Just mn) _, mnOrig)

202− | mnOrig == fromMaybe (error "Invalid state in updateImports") (name `lookup` exps') -> return imps'

203+ | mnOrig == fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps') -> return imps'

203 | otherwise -> throwError . errorMessage $ err

204 | otherwise -> throwError . errorMessage $ err

204 where

205 where

205 err = if currentModule `elem` [mn, importModule]

206 err = if currentModule `elem` [mn, importModule]

@@ -207,4 +208,4 @@ resolveImport currentModule importModule exps imps impQual =

207 else ConflictingImports (render name) mn importModule

208 else ConflictingImports (render name) mn importModule

208

209

209 Just (Qualified Nothing _, _) ->

210 Just (Qualified Nothing _, _) ->

210− error "Invalid state in updateImports"

211+ internalError "Invalid state in updateImports"

src/Language/PureScript/Sugar/Operators.hs+3−2

@@ -29,6 +29,7 @@ module Language.PureScript.Sugar.Operators (

29 desugarOperatorSections

30) where

31

32+import Language.PureScript.Crash

32import Language.PureScript.AST

33import Language.PureScript.AST

33import Language.PureScript.Errors

34import Language.PureScript.Errors

34import Language.PureScript.Names

35import Language.PureScript.Names

@@ -93,7 +94,7 @@ collectFixities (Module _ _ moduleName ds _) = concatMap collect ds

93 where

94 where

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

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

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

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

96− collect FixityDeclaration{} = error "Fixity without srcpos info"

97+ collect FixityDeclaration{} = internalError "Fixity without srcpos info"

97 collect _ = []

98 collect _ = []

98

99

99ensureNoDuplicates :: (MonadError MultipleErrors m) => [(Qualified Ident, SourceSpan)] -> m ()

100ensureNoDuplicates :: (MonadError MultipleErrors m) => [(Qualified Ident, SourceSpan)] -> m ()

@@ -129,7 +130,7 @@ matchOperators ops = parseChains

129 extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r

130 extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r

130 extendChain other = [Left other]

131 extendChain other = [Left other]

131 bracketChain :: Chain -> m Expr

132 bracketChain :: Chain -> m Expr

132− bracketChain = either (\_ -> error "matchOperators: cannot reorder operators") return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"

133+ bracketChain = either (\_ -> internalError "matchOperators: cannot reorder operators") return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"

133 opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft]

134 opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft]

134 : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops

135 : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops

135 ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]

136 ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]

src/Language/PureScript/Sugar/TypeClasses.hs+8−7

@@ -24,6 +24,7 @@ module Language.PureScript.Sugar.TypeClasses

24 , superClassDictionaryNames

25 ) where

26

27+import Language.PureScript.Crash

27import Language.PureScript.AST hiding (isExported)

28import Language.PureScript.AST hiding (isExported)

28import Language.PureScript.Environment

29import Language.PureScript.Environment

29import Language.PureScript.Errors

30import Language.PureScript.Errors

@@ -75,7 +76,7 @@ desugarModule (Module ss coms name decls (Just exps)) = do

75 | isTypeClassDeclaration d1 && not (isTypeClassDeclaration d2) = LT

76 | isTypeClassDeclaration d1 && not (isTypeClassDeclaration d2) = LT

76 | not (isTypeClassDeclaration d1) && isTypeClassDeclaration d2 = GT

77 | not (isTypeClassDeclaration d1) && isTypeClassDeclaration d2 = GT

77 | otherwise = EQ

78 | otherwise = EQ

78−desugarModule _ = error "Exports should have been elaborated in name desugaring"

79+desugarModule _ = internalError "Exports should have been elaborated in name desugaring"

79

80

80{- Desugar type class and type class instance declarations

81{- Desugar type class and type class instance declarations

81--

82--

@@ -177,7 +178,7 @@ desugarDecl mn exps = go

177 go d@(TypeClassDeclaration name args implies members) = do

178 go d@(TypeClassDeclaration name args implies members) = do

178 modify (M.insert (mn, name) (args, implies, members))

179 modify (M.insert (mn, name) (args, implies, members))

179 return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)

180 return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)

180− go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = error "Derived instanced should have been desugared"

181+ go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared"

181 go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do

182 go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do

182 desugared <- desugarCases members

183 desugared <- desugarCases members

183 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared

184 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared

@@ -200,7 +201,7 @@ desugarDecl mn exps = go

200

201

201 isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool

202 isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool

202 isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps

203 isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps

203− isExported _ _ = error "Names should have been qualified in name desugaring"

204+ isExported _ _ = internalError "Names should have been qualified in name desugaring"

204

205

205 matchesTypeRef :: ProperName -> DeclarationRef -> Bool

206 matchesTypeRef :: ProperName -> DeclarationRef -> Bool

206 matchesTypeRef pn (TypeRef pn' _) = pn == pn'

207 matchesTypeRef pn (TypeRef pn' _) = pn == pn'

@@ -216,7 +217,7 @@ desugarDecl mn exps = go

216memberToNameAndType :: Declaration -> (Ident, Type)

217memberToNameAndType :: Declaration -> (Ident, Type)

217memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)

218memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)

218memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d

219memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d

219−memberToNameAndType _ = error "Invalid declaration in type class definition"

220+memberToNameAndType _ = internalError "Invalid declaration in type class definition"

220

221

221typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration

222typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration

222typeClassDictionaryDeclaration name args implies members =

223typeClassDictionaryDeclaration name args implies members =

@@ -236,7 +237,7 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

236 moveQuantifiersToFront (quantify (ConstrainedType [(className, map (TypeVar . fst) args)] ty))

237 moveQuantifiersToFront (quantify (ConstrainedType [(className, map (TypeVar . fst) args)] ty))

237typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) =

238typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) =

238 PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d

239 PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d

239−typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"

240+typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition"

240

241

241unit :: Type

242unit :: Type

242unit = TypeApp tyObject REmpty

243unit = TypeApp tyObject REmpty

@@ -294,13 +295,13 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

294 memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do

295 memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do

295 val <- memberToValue tys' d

296 val <- memberToValue tys' d

296 return (PositionedValue pos com val)

297 return (PositionedValue pos com val)

297− memberToValue _ _ = error "Invalid declaration in type instance definition"

298+ memberToValue _ _ = internalError "Invalid declaration in type instance definition"

298

299

299typeClassMemberName :: Declaration -> String

300typeClassMemberName :: Declaration -> String

300typeClassMemberName (TypeDeclaration ident _) = runIdent ident

301typeClassMemberName (TypeDeclaration ident _) = runIdent ident

301typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident

302typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident

302typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d

303typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d

303−typeClassMemberName _ = error "typeClassMemberName: Invalid declaration in type class definition"

304+typeClassMemberName _ = internalError "typeClassMemberName: Invalid declaration in type class definition"

304

305

305superClassDictionaryNames :: [Constraint] -> [String]

306superClassDictionaryNames :: [Constraint] -> [String]

306superClassDictionaryNames supers =

307superClassDictionaryNames supers =

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

@@ -36,6 +36,7 @@ import Control.Monad (replicateM)

36import Control.Monad.Supply.Class (MonadSupply, freshName)

37import Control.Monad.Error.Class (MonadError(..))

38

39+import Language.PureScript.Crash

39import Language.PureScript.AST

40import Language.PureScript.AST

40import Language.PureScript.Environment

41import Language.PureScript.Environment

41import Language.PureScript.Errors

42import Language.PureScript.Errors

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

116 $ decomposeRec rec

117 $ decomposeRec rec

117 toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i

118 toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i

118mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d

119mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d

119−mkSpineFunction _ _ = error "mkSpineFunction: expected DataDeclaration"

120+mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration"

120

121

121mkSignatureFunction :: ModuleName -> Declaration -> Expr

122mkSignatureFunction :: ModuleName -> Declaration -> Expr

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

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

@@ -145,7 +146,7 @@ mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map m

145 mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)

146 mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)

146 (TypedValue False (mkGenVar "anyProxy") (proxy typ))

147 (TypedValue False (mkGenVar "anyProxy") (proxy typ))

147mkSignatureFunction mn (PositionedDeclaration _ _ d) = mkSignatureFunction mn d

148mkSignatureFunction mn (PositionedDeclaration _ _ d) = mkSignatureFunction mn d

148−mkSignatureFunction _ _ = error "mkSignatureFunction: expected DataDeclaration"

149+mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration"

149

150

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

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

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

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

@@ -194,7 +195,7 @@ mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch

194 mkRecFun xs = mkJust $ foldr (\s e -> lam s e) recLiteral (map fst xs)

195 mkRecFun xs = mkJust $ foldr (\s e -> lam s e) recLiteral (map fst xs)

195 where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs

196 where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs

196mkFromSpineFunction mn (PositionedDeclaration _ _ d) = mkFromSpineFunction mn d

197mkFromSpineFunction mn (PositionedDeclaration _ _ d) = mkFromSpineFunction mn d

197−mkFromSpineFunction _ _ = error "mkFromSpineFunction: expected DataDeclaration"

198+mkFromSpineFunction _ _ = internalError "mkFromSpineFunction: expected DataDeclaration"

198

199

199-- Helpers

200-- Helpers

200

201

src/Language/PureScript/Sugar/TypeDeclarations.hs+2−1

@@ -29,6 +29,7 @@ import Control.Monad (forM, when)

29import Control.Monad.Error.Class (MonadError(..))

30import Control.Monad.Writer.Class (MonadWriter(tell))

31

32+import Language.PureScript.Crash

32import Language.PureScript.AST

33import Language.PureScript.AST

33import Language.PureScript.Names

34import Language.PureScript.Names

34import Language.PureScript.Environment

35import Language.PureScript.Environment

@@ -63,7 +64,7 @@ desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->

63 -- At the top level, match a type signature or emit a warning.

64 -- At the top level, match a type signature or emit a warning.

64 when reqd $ case val of

65 when reqd $ case val of

65 Right TypedValue{} -> return ()

66 Right TypedValue{} -> return ()

66− Left _ -> error "desugarTypeDeclarations: cases were not desugared"

67+ Left _ -> internalError "desugarTypeDeclarations: cases were not desugared"

67 _ -> tell (addHint (ErrorInValueDeclaration name) $ errorMessage $ MissingTypeDeclaration name)

68 _ -> tell (addHint (ErrorInValueDeclaration name) $ errorMessage $ MissingTypeDeclaration name)

68 let (_, f, _) = everywhereOnValuesTopDownM return go return

69 let (_, f, _) = everywhereOnValuesTopDownM return go return

69 f' (Left gs) = Left <$> mapM (pairM return f) gs

70 f' (Left gs) = Left <$> mapM (pairM return f) gs

src/Language/PureScript/TypeChecker.hs+14−13

@@ -38,6 +38,7 @@ import Control.Applicative ((<$>), (<*))

38import Control.Monad.State

39import Control.Monad.Error.Class (MonadError(..))

40

41+import Language.PureScript.Crash

41import Language.PureScript.Types

42import Language.PureScript.Types

42import Language.PureScript.Names

43import Language.PureScript.Names

43import Language.PureScript.Kinds

44import Language.PureScript.Kinds

@@ -90,7 +91,7 @@ addTypeClass moduleName pn args implies ds =

90 where

91 where

91 toPair (TypeDeclaration ident ty) = (ident, ty)

92 toPair (TypeDeclaration ident ty) = (ident, ty)

92 toPair (PositionedDeclaration _ _ d) = toPair d

93 toPair (PositionedDeclaration _ _ d) = toPair d

93− toPair _ = error "Invalid declaration in TypeClassDeclaration"

94+ toPair _ = internalError "Invalid declaration in TypeClassDeclaration"

94

95

95addTypeClassDictionaries :: Maybe ModuleName -> M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope) -> Check ()

96addTypeClassDictionaries :: Maybe ModuleName -> M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope) -> Check ()

96addTypeClassDictionaries mn entries =

97addTypeClassDictionaries mn entries =

@@ -147,8 +148,8 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds

147 where

148 where

148 checkNewtype :: [(ProperName, [Type])] -> Check ()

149 checkNewtype :: [(ProperName, [Type])] -> Check ()

149 checkNewtype [(_, [_])] = return ()

150 checkNewtype [(_, [_])] = return ()

150− checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype

151+ checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype name

151− checkNewtype _ = throwError . errorMessage $ InvalidNewtype

152+ checkNewtype _ = throwError . errorMessage $ InvalidNewtype name

152 go (d@(DataBindingGroupDeclaration tys)) = do

153 go (d@(DataBindingGroupDeclaration tys)) = do

153 warnAndRethrow (addHint ErrorInDataBindingGroup) $ do

154 warnAndRethrow (addHint ErrorInDataBindingGroup) $ do

154 let syns = mapMaybe toTypeSynonym tys

155 let syns = mapMaybe toTypeSynonym tys

@@ -177,14 +178,14 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds

177 let args' = args `withKinds` kind

178 let args' = args `withKinds` kind

178 addTypeSynonym moduleName name args' ty kind

179 addTypeSynonym moduleName name args' ty kind

179 return $ TypeSynonymDeclaration name args ty

180 return $ TypeSynonymDeclaration name args ty

180− go (TypeDeclaration{}) = error "Type declarations should have been removed"

181+ go (TypeDeclaration{}) = internalError "Type declarations should have been removed"

181 go (ValueDeclaration name nameKind [] (Right val)) =

182 go (ValueDeclaration name nameKind [] (Right val)) =

182 warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do

183 warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do

183 valueIsNotDefined moduleName name

184 valueIsNotDefined moduleName name

184 [(_, (val', ty))] <- typesOf moduleName [(name, val)]

185 [(_, (val', ty))] <- typesOf moduleName [(name, val)]

185 addValue moduleName name ty nameKind

186 addValue moduleName name ty nameKind

186 return $ ValueDeclaration name nameKind [] $ Right val'

187 return $ ValueDeclaration name nameKind [] $ Right val'

187− go (ValueDeclaration{}) = error "Binders were not desugared"

188+ go (ValueDeclaration{}) = internalError "Binders were not desugared"

188 go (BindingGroupDeclaration vals) =

189 go (BindingGroupDeclaration vals) =

189 warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do

190 warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do

190 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->

191 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->

@@ -245,7 +246,7 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds

245 memberName :: Declaration -> Ident

246 memberName :: Declaration -> Ident

246 memberName (ValueDeclaration ident _ _ _) = ident

247 memberName (ValueDeclaration ident _ _ _) = ident

247 memberName (PositionedDeclaration _ _ d) = memberName d

248 memberName (PositionedDeclaration _ _ d) = memberName d

248− memberName _ = error "checkInstanceMembers: Invalid declaration in type instance definition"

249+ memberName _ = internalError "checkInstanceMembers: Invalid declaration in type instance definition"

249

250

250 firstDuplicate :: (Eq a) => [a] -> Maybe a

251 firstDuplicate :: (Eq a) => [a] -> Maybe a

251 firstDuplicate (x : xs@(y : _))

252 firstDuplicate (x : xs@(y : _))

@@ -261,10 +262,10 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds

261 checkType :: Type -> Bool

262 checkType :: Type -> Bool

262 checkType (TypeVar _) = False

263 checkType (TypeVar _) = False

263 checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn''

264 checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn''

264− checkType (TypeConstructor (Qualified Nothing _)) = error "Unqualified type name in checkOrphanInstance"

265+ checkType (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance"

265 checkType (TypeApp t1 _) = checkType t1

266 checkType (TypeApp t1 _) = checkType t1

266− checkType _ = error "Invalid type in instance in checkOrphanInstance"

267+ checkType _ = internalError "Invalid type in instance in checkOrphanInstance"

267− checkOrphanInstance _ _ _ = error "Unqualified class name in checkOrphanInstance"

268+ checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance"

268

269

269 -- |

270 -- |

270 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,

271 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,

@@ -274,14 +275,14 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds

274 withKinds [] _ = []

275 withKinds [] _ = []

275 withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k

276 withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k

276 withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2

277 withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2

277− withKinds _ _ = error "Invalid arguments to peelKinds"

278+ withKinds _ _ = internalError "Invalid arguments to peelKinds"

278

279

279-- |

280-- |

280-- Type check an entire module and ensure all types and classes defined within the module that are

281-- Type check an entire module and ensure all types and classes defined within the module that are

281-- required by exported members are also exported.

282-- required by exported members are also exported.

282--

283--

283typeCheckModule :: Module -> Check Module

284typeCheckModule :: Module -> Check Module

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

285+typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated"

285typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do

286typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do

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

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

287 decls' <- typeCheckAll mn exps decls

288 decls' <- typeCheckAll mn exps decls

@@ -331,7 +332,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

331 findTcons :: Type -> [DeclarationRef]

332 findTcons :: Type -> [DeclarationRef]

332 findTcons = everythingOnTypes (++) go

333 findTcons = everythingOnTypes (++) go

333 where

334 where

334− go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (error "Data constructors unused in checkTypesAreExported")]

335+ go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (internalError "Data constructors unused in checkTypesAreExported")]

335 go _ = []

336 go _ = []

336

337

337 -- Check that all the classes defined in the current module that appear in member types have also

338 -- Check that all the classes defined in the current module that appear in member types have also

@@ -361,5 +362,5 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

361 extractMemberName :: Declaration -> Ident

362 extractMemberName :: Declaration -> Ident

362 extractMemberName (PositionedDeclaration _ _ d) = extractMemberName d

363 extractMemberName (PositionedDeclaration _ _ d) = extractMemberName d

363 extractMemberName (TypeDeclaration memberName _) = memberName

364 extractMemberName (TypeDeclaration memberName _) = memberName

364− extractMemberName _ = error "Unexpected declaration in typeclass member list"

365+ extractMemberName _ = internalError "Unexpected declaration in typeclass member list"

365 checkClassMembersAreExported _ = return ()

366 checkClassMembersAreExported _ = return ()

src/Language/PureScript/TypeChecker/Entailment.hs+3−2

@@ -35,6 +35,7 @@ import Control.Monad.State

35import Control.Monad.Error.Class (MonadError(..))

36import Control.Monad.Writer.Class (tell)

37

38+import Language.PureScript.Crash

38import Language.PureScript.AST

39import Language.PureScript.AST

39import Language.PureScript.Errors

40import Language.PureScript.Errors

40import Language.PureScript.Names

41import Language.PureScript.Names

@@ -53,11 +54,11 @@ entails moduleName context = solve

53 where

54 where

54 forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope]

55 forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope]

55 forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))

56 forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))

56− forClassName _ _ = error "forClassName: expected qualified class name"

57+ forClassName _ _ = internalError "forClassName: expected qualified class name"

57

58

58 ctorModules :: Type -> Maybe ModuleName

59 ctorModules :: Type -> Maybe ModuleName

59 ctorModules (TypeConstructor (Qualified (Just mn) _)) = Just mn

60 ctorModules (TypeConstructor (Qualified (Just mn) _)) = Just mn

60− ctorModules (TypeConstructor (Qualified Nothing _)) = error "ctorModules: unqualified type name"

61+ ctorModules (TypeConstructor (Qualified Nothing _)) = internalError "ctorModules: unqualified type name"

61 ctorModules (TypeApp ty _) = ctorModules ty

62 ctorModules (TypeApp ty _) = ctorModules ty

62 ctorModules _ = Nothing

63 ctorModules _ = Nothing

63

64

src/Language/PureScript/TypeChecker/Kinds.hs+2−1

@@ -40,6 +40,7 @@ import Control.Monad.Error.Class (MonadError(..))

40import Control.Monad.State

41import Control.Monad.Unify

42

43+import Language.PureScript.Crash

43import Language.PureScript.Environment

44import Language.PureScript.Environment

44import Language.PureScript.Errors

45import Language.PureScript.Errors

45import Language.PureScript.Kinds

46import Language.PureScript.Kinds

@@ -220,4 +221,4 @@ infer' other = (, []) <$> go other

220 k <- go ty

221 k <- go ty

221 k =?= Star

222 k =?= Star

222 return Star

223 return Star

223− go _ = error "Invalid argument to infer"

224+ go _ = internalError "Invalid argument to infer"

src/Language/PureScript/TypeChecker/Monad.hs+1−1

@@ -153,7 +153,7 @@ checkVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, Mona

153checkVisibility currentModule name@(Qualified _ var) = do

154 vis <- getVisibility currentModule name

155 case vis of

156− Undefined -> throwError . errorMessage $ NameNotInScope var

156+ Undefined -> throwError . errorMessage $ CycleInDeclaration var

157 _ -> return ()

158

159-- |

src/Language/PureScript/TypeChecker/Skolems.hs+2−1

@@ -33,6 +33,7 @@ import Control.Applicative

33import Control.Monad.Error.Class (MonadError(..))

34import Control.Monad.Unify

35

36+import Language.PureScript.Crash

36import Language.PureScript.AST

37import Language.PureScript.AST

37import Language.PureScript.Errors

38import Language.PureScript.Errors

38import Language.PureScript.TypeChecker.Monad

39import Language.PureScript.TypeChecker.Monad

@@ -115,4 +116,4 @@ skolemEscapeCheck root@TypedValue{} =

115 where

116 where

116 go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)

117 go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)

117 go' _ = mempty

118 go' _ = mempty

118−skolemEscapeCheck _ = error "Untyped value passed to skolemEscapeCheck"

119+skolemEscapeCheck _ = internalError "Untyped value passed to skolemEscapeCheck"

src/Language/PureScript/TypeChecker/Subsumption.hs+2−1

@@ -22,6 +22,7 @@ import Data.Ord (comparing)

22

23import Control.Monad.Unify

24

25+import Language.PureScript.Crash

25import Language.PureScript.AST

26import Language.PureScript.AST

26import Language.PureScript.Environment

27import Language.PureScript.Environment

27import Language.PureScript.Errors

28import Language.PureScript.Errors

@@ -49,7 +50,7 @@ subsumes' val ty1 (ForAll ident ty2 sco) =

49 sko <- newSkolemConstant

50 sko <- newSkolemConstant

50 let sk = skolemize ident sko sco' ty2

51 let sk = skolemize ident sko sco' ty2

51 subsumes val ty1 sk

52 subsumes val ty1 sk

52− Nothing -> error "subsumes: unspecified skolem scope"

53+ Nothing -> internalError "subsumes: unspecified skolem scope"

53subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do

54subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do

54 _ <- subsumes Nothing arg2 arg1

55 _ <- subsumes Nothing arg2 arg1

55 _ <- subsumes Nothing ret1 ret2

56 _ <- subsumes Nothing ret1 ret2

src/Language/PureScript/TypeChecker/Types.hs+13−12

@@ -51,6 +51,7 @@ import Control.Monad.State

51import Control.Monad.Unify

52import Control.Monad.Error.Class (MonadError(..))

53

54+import Language.PureScript.Crash

54import Language.PureScript.AST

55import Language.PureScript.AST

55import Language.PureScript.Environment

56import Language.PureScript.Environment

56import Language.PureScript.Errors

57import Language.PureScript.Errors

@@ -138,7 +139,7 @@ typeForBindingGroupElement :: (Ident, Expr) -> TypeData -> UntypedData -> UnifyT

138typeForBindingGroupElement (ident, val) dict untypedDict = do

139typeForBindingGroupElement (ident, val) dict untypedDict = do

139 -- Infer the type with the new names in scope

140 -- Infer the type with the new names in scope

140 TypedValue _ val' ty <- bindNames dict $ infer val

141 TypedValue _ val' ty <- bindNames dict $ infer val

141− ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)

142+ ty =?= fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict)

142 return (ident, (TypedValue True val' ty, ty))

143 return (ident, (TypedValue True val' ty, ty))

143

144

144-- |

145-- |

@@ -189,7 +190,7 @@ instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do

189 instantiatePolyTypeWithUnknowns val ty'

190 instantiatePolyTypeWithUnknowns val ty'

190instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do

191instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do

191 dicts <- getTypeClassDictionaries

192 dicts <- getTypeClassDictionaries

192− (_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty

193+ (_, ty') <- instantiatePolyTypeWithUnknowns (internalError "Types under a constraint cannot themselves be constrained") ty

193 return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty')

194 return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty')

194instantiatePolyTypeWithUnknowns val ty = return (val, ty)

195instantiatePolyTypeWithUnknowns val ty = return (val, ty)

195

196

@@ -239,7 +240,7 @@ infer' (Abs (Left arg) ret) = do

239 withBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do

240 withBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do

240 body@(TypedValue _ _ bodyTy) <- infer' ret

241 body@(TypedValue _ _ bodyTy) <- infer' ret

241 return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy

242 return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy

242−infer' (Abs (Right _) _) = error "Binder was not desugared"

243+infer' (Abs (Right _) _) = internalError "Binder was not desugared"

243infer' (App f arg) = do

244infer' (App f arg) = do

244 f'@(TypedValue _ _ ft) <- infer f

245 f'@(TypedValue _ _ ft) <- infer f

245 (ret, app) <- checkFunctionApplication f' ft arg Nothing

246 (ret, app) <- checkFunctionApplication f' ft arg Nothing

@@ -284,7 +285,7 @@ infer' (TypedValue checkType val ty) = do

284 val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val

285 val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val

285 return $ TypedValue True val' ty'

286 return $ TypedValue True val' ty'

286infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val

287infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val

287−infer' _ = error "Invalid argument to infer"

288+infer' _ = internalError "Invalid argument to infer"

288

289

289inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr)

290inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr)

290inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret)

291inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret)

@@ -315,7 +316,7 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do

315inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethrowWithPosition pos $ do

316inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethrowWithPosition pos $ do

316 (d' : ds', val') <- inferLetBinding seen (d : ds) ret j

317 (d' : ds', val') <- inferLetBinding seen (d : ds) ret j

317 return (PositionedDeclaration pos com d' : ds', val')

318 return (PositionedDeclaration pos com d' : ds', val')

318−inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding"

319+inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding"

319

320

320-- |

321-- |

321-- Infer the types of variables brought into scope by a binder

322-- Infer the types of variables brought into scope by a binder

@@ -332,7 +333,7 @@ inferBinder val (ConstructorBinder ctor binders) = do

332 env <- getEnv

333 env <- getEnv

333 case M.lookup ctor (dataConstructors env) of

334 case M.lookup ctor (dataConstructors env) of

334 Just (_, _, ty, _) -> do

335 Just (_, _, ty, _) -> do

335− (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contain constraints") ty

336+ (_, fn) <- instantiatePolyTypeWithUnknowns (internalError "Data constructor types cannot contain constraints") ty

336 fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn

337 fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn

337 go binders fn'

338 go binders fn'

338 where

339 where

@@ -449,7 +450,7 @@ check' val t@(ConstrainedType constraints ty) = do

449 newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> Check [TypeClassDictionaryInScope]

450 newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> Check [TypeClassDictionaryInScope]

450 newDictionaries path name (className, instanceTy) = do

451 newDictionaries path name (className, instanceTy) = do

451 tcs <- gets (typeClasses . checkEnv)

452 tcs <- gets (typeClasses . checkEnv)

452− let (args, _, superclasses) = fromMaybe (error "newDictionaries: type class lookup failed") $ M.lookup className tcs

453+ let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs

453 supDicts <- join <$> zipWithM (\(supName, supArgs) index ->

454 supDicts <- join <$> zipWithM (\(supName, supArgs) index ->

454 newDictionaries ((supName, index) : path)

455 newDictionaries ((supName, index) : path)

455 name

456 name

@@ -484,7 +485,7 @@ check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do

484 Just moduleName <- checkCurrentModule <$> get

485 Just moduleName <- checkCurrentModule <$> get

485 ret' <- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy

486 ret' <- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy

486 return $ TypedValue True (Abs (Left arg) ret') ty

487 return $ TypedValue True (Abs (Left arg) ret') ty

487−check' (Abs (Right _) _) _ = error "Binder was not desugared"

488+check' (Abs (Right _) _) _ = internalError "Binder was not desugared"

488check' (App f arg) ret = do

489check' (App f arg) ret = do

489 f'@(TypedValue _ _ ft) <- infer f

490 f'@(TypedValue _ _ ft) <- infer f

490 (_, app) <- checkFunctionApplication f' ft arg (Just ret)

491 (_, app) <- checkFunctionApplication f' ft arg (Just ret)

@@ -496,7 +497,7 @@ check' v@(Var var) ty = do

496 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

497 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

497 v' <- subsumes (Just v) repl ty'

498 v' <- subsumes (Just v) repl ty'

498 case v' of

499 case v' of

499− Nothing -> error "check: unable to check the subsumes relation."

500+ Nothing -> internalError "check: unable to check the subsumes relation."

500 Just v'' -> return $ TypedValue True v'' ty'

501 Just v'' -> return $ TypedValue True v'' ty'

501check' (SuperClassDictionary className tys) _ = do

502check' (SuperClassDictionary className tys) _ = do

502 {-

503 {-

@@ -515,7 +516,7 @@ check' (TypedValue checkType val ty1) ty2 = do

515 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2

516 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2

516 val' <- subsumes (Just val) ty1' ty2'

517 val' <- subsumes (Just val) ty1' ty2'

517 case val' of

518 case val' of

518− Nothing -> error "check: unable to check the subsumes relation."

519+ Nothing -> internalError "check: unable to check the subsumes relation."

519 Just _ -> do

520 Just _ -> do

520 val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val

521 val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val

521 return $ TypedValue checkType val''' ty2'

522 return $ TypedValue checkType val''' ty2'

@@ -557,7 +558,7 @@ check' v@(Constructor c) ty = do

557 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

558 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

558 mv <- subsumes (Just v) repl ty

559 mv <- subsumes (Just v) repl ty

559 case mv of

560 case mv of

560− Nothing -> error "check: unable to check the subsumes relation."

561+ Nothing -> internalError "check: unable to check the subsumes relation."

561 Just v' -> return $ TypedValue True v' ty

562 Just v' -> return $ TypedValue True v' ty

562check' (Let ds val) ty = do

563check' (Let ds val) ty = do

563 (ds', val') <- inferLetBinding [] ds val (`check` ty)

564 (ds', val') <- inferLetBinding [] ds val (`check` ty)

@@ -572,7 +573,7 @@ check' val ty = do

572 TypedValue _ val' ty' <- infer val

573 TypedValue _ val' ty' <- infer val

573 mt <- subsumes (Just val') ty' ty

574 mt <- subsumes (Just val') ty' ty

574 case mt of

575 case mt of

575− Nothing -> error "check: unable to check the subsumes relation."

576+ Nothing -> internalError "check: unable to check the subsumes relation."

576 Just v' -> return $ TypedValue True v' ty

577 Just v' -> return $ TypedValue True v' ty

577

578

578-- |

579-- |

src/Language/PureScript/TypeChecker/Unify.hs+3−2

@@ -36,6 +36,7 @@ import Control.Monad.Unify

36import Control.Monad.Writer

37import Control.Monad.Error.Class (MonadError(..))

38

39+import Language.PureScript.Crash

39import Language.PureScript.Errors

40import Language.PureScript.Errors

40import Language.PureScript.TypeChecker.Monad

41import Language.PureScript.TypeChecker.Monad

41import Language.PureScript.TypeChecker.Skolems

42import Language.PureScript.TypeChecker.Skolems

@@ -74,12 +75,12 @@ unifyTypes t1 t2 = rethrow (addHint (ErrorUnifyingTypes t1 t2)) $

74 let sk1 = skolemize ident1 sko sc1' ty1

75 let sk1 = skolemize ident1 sko sc1' ty1

75 let sk2 = skolemize ident2 sko sc2' ty2

76 let sk2 = skolemize ident2 sko sc2' ty2

76 sk1 `unifyTypes` sk2

77 sk1 `unifyTypes` sk2

77− _ -> error "unifyTypes: unspecified skolem scope"

78+ _ -> internalError "unifyTypes: unspecified skolem scope"

78 unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do

79 unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do

79 sko <- newSkolemConstant

80 sko <- newSkolemConstant

80 let sk = skolemize ident sko sc ty1

81 let sk = skolemize ident sko sc ty1

81 sk `unifyTypes` ty2

82 sk `unifyTypes` ty2

82− unifyTypes' ForAll{} _ = error "unifyTypes: unspecified skolem scope"

83+ unifyTypes' ForAll{} _ = internalError "unifyTypes: unspecified skolem scope"

83 unifyTypes' ty f@ForAll{} = f `unifyTypes` ty

84 unifyTypes' ty f@ForAll{} = f `unifyTypes` ty

84 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()

85 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()

85 unifyTypes' ty1@(TypeConstructor c1) ty2@(TypeConstructor c2) =

86 unifyTypes' ty1@(TypeConstructor c1) ty2@(TypeConstructor c2) =

tests/Main.hs+2−2

@@ -78,7 +78,7 @@ modulesDir :: FilePath

78modulesDir = ".test_modules" </> "node_modules"

79

80makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make

81−makeActions foreigns = (P.buildMakeActions modulesDir (error "makeActions: input file map was read.") foreigns False)

81+makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)

82 { P.getInputTimestamp = getInputTimestamp

83 , P.getOutputTimestamp = getOutputTimestamp

84 }

@@ -94,7 +94,7 @@ makeActions foreigns = (P.buildMakeActions modulesDir (error "makeActions: input

94 getOutputTimestamp mn = do

95 let filePath = modulesDir </> P.runModuleName mn

96 exists <- liftIO $ doesDirectoryExist filePath

97− return (if exists then Just (error "getOutputTimestamp: read timestamp") else Nothing)

97+ return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)

98

99readInput :: [FilePath] -> IO [(FilePath, String)]

100readInput inputFiles = forM inputFiles $ \inputFile -> do

tests/common/TestsSetup.hs+3−1

@@ -28,6 +28,8 @@ import System.Process

28import System.Directory

29import System.Info

30

31+import Language.PureScript.Crash

32+

31findNodeProcess :: IO (Maybe String)

33findNodeProcess :: IO (Maybe String)

32findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names

34findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names

33 where

35 where

@@ -35,7 +37,7 @@ findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names

35

37

36fetchSupportCode :: IO ()

38fetchSupportCode :: IO ()

37fetchSupportCode = do

39fetchSupportCode = do

38− node <- fromMaybe (error "cannot find node executable") <$> findNodeProcess

40+ node <- fromMaybe (internalError "cannot find node executable") <$> findNodeProcess

39 setCurrentDirectory "tests/support"

41 setCurrentDirectory "tests/support"

40 if System.Info.os == "mingw32"

42 if System.Info.os == "mingw32"

41 then callProcess "setup-win.cmd" []

43 then callProcess "setup-win.cmd" []