fda24b5 · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #1556 from purescript/friendly

fda24b5Phil Freeman11 years ago

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)

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

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"

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

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

18import Data.Maybe (fromMaybe)

20+import Language.PureScript.Crash

20import Language.PureScript.CodeGen.JS.AST

21import Language.PureScript.CodeGen.JS.AST

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"

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

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

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

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

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

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+103−107

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

41import Control.Monad.Trans.State.Lazy

42import Control.Arrow(first)

44+import Language.PureScript.Crash

44import Language.PureScript.AST

45import Language.PureScript.AST

45−import Language.PureScript.Environment (isObject, isFunction)

46import Language.PureScript.Pretty

47import Language.PureScript.Types

48import Language.PureScript.Names

@@ -62,13 +62,11 @@ data SimpleErrorMessage

62 | MissingFFIModule ModuleName

63 | MultipleFFIModules ModuleName [FilePath]

64 | UnnecessaryFFIModule ModuleName FilePath

65− | InvalidExternsFile FilePath

66 | CannotGetFileInfo FilePath

65 | CannotGetFileInfo FilePath

67 | CannotReadFile FilePath

66 | CannotReadFile FilePath

68 | CannotWriteFile FilePath

67 | CannotWriteFile FilePath

69 | InfiniteType Type

68 | InfiniteType Type

70 | InfiniteKind Kind

69 | InfiniteKind Kind

71− | CannotReorderOperators

72 | MultipleFixities Ident

70 | MultipleFixities Ident

73 | OrphanTypeDeclaration Ident

71 | OrphanTypeDeclaration Ident

74 | OrphanFixityDeclaration String

72 | OrphanFixityDeclaration String

@@ -108,11 +106,9 @@ data SimpleErrorMessage

108 | CycleInTypeSynonym (Maybe ProperName)

106 | CycleInTypeSynonym (Maybe ProperName)

109 | CycleInModules [ModuleName]

107 | CycleInModules [ModuleName]

110 | NameIsUndefined Ident

108 | NameIsUndefined Ident

111− | NameNotInScope Ident

112 | UndefinedTypeVariable ProperName

109 | UndefinedTypeVariable ProperName

113 | PartiallyAppliedSynonym (Qualified ProperName)

110 | PartiallyAppliedSynonym (Qualified ProperName)

114 | EscapedSkolem (Maybe Expr)

111 | EscapedSkolem (Maybe Expr)

115− | UnspecifiedSkolemScope

116 | TypesDoNotUnify Type Type

112 | TypesDoNotUnify Type Type

117 | KindsDoNotUnify Kind Kind

113 | KindsDoNotUnify Kind Kind

118 | ConstrainedTypeUnified Type Type

114 | ConstrainedTypeUnified Type Type

@@ -126,16 +122,15 @@ data SimpleErrorMessage

126 | ArgListLengthsDiffer Ident

122 | ArgListLengthsDiffer Ident

127 | OverlappingArgNames (Maybe Ident)

123 | OverlappingArgNames (Maybe Ident)

128 | MissingClassMember Ident

124 | MissingClassMember Ident

129− | ExtraneousClassMember Ident

125+ | ExtraneousClassMember Ident (Qualified ProperName)

130 | ExpectedType Type Kind

126 | ExpectedType Type Kind

131 | IncorrectConstructorArity (Qualified ProperName)

127 | IncorrectConstructorArity (Qualified ProperName)

132− | SubsumptionCheckFailed

133 | ExprDoesNotHaveType Expr Type

128 | ExprDoesNotHaveType Expr Type

134 | PropertyIsMissing String Type

129 | PropertyIsMissing String Type

135 | CannotApplyFunction Type Expr

130 | CannotApplyFunction Type Expr

136 | TypeSynonymInstance

131 | TypeSynonymInstance

137 | OrphanInstance Ident (Qualified ProperName) [Type]

132 | OrphanInstance Ident (Qualified ProperName) [Type]

138− | InvalidNewtype

133+ | InvalidNewtype ProperName

139 | InvalidInstanceHead Type

134 | InvalidInstanceHead Type

140 | TransitiveExportError DeclarationRef [DeclarationRef]

135 | TransitiveExportError DeclarationRef [DeclarationRef]

141 | ShadowedName Ident

136 | ShadowedName Ident

@@ -202,13 +197,11 @@ errorCode em = case unwrapErrorMessage em of

202 MissingFFIModule{} -> "MissingFFIModule"

197 MissingFFIModule{} -> "MissingFFIModule"

203 MultipleFFIModules{} -> "MultipleFFIModules"

198 MultipleFFIModules{} -> "MultipleFFIModules"

204 UnnecessaryFFIModule{} -> "UnnecessaryFFIModule"

199 UnnecessaryFFIModule{} -> "UnnecessaryFFIModule"

205− InvalidExternsFile{} -> "InvalidExternsFile"

206 CannotGetFileInfo{} -> "CannotGetFileInfo"

200 CannotGetFileInfo{} -> "CannotGetFileInfo"

207 CannotReadFile{} -> "CannotReadFile"

201 CannotReadFile{} -> "CannotReadFile"

208 CannotWriteFile{} -> "CannotWriteFile"

202 CannotWriteFile{} -> "CannotWriteFile"

209 InfiniteType{} -> "InfiniteType"

203 InfiniteType{} -> "InfiniteType"

210 InfiniteKind{} -> "InfiniteKind"

204 InfiniteKind{} -> "InfiniteKind"

211− CannotReorderOperators -> "CannotReorderOperators"

212 MultipleFixities{} -> "MultipleFixities"

205 MultipleFixities{} -> "MultipleFixities"

213 OrphanTypeDeclaration{} -> "OrphanTypeDeclaration"

206 OrphanTypeDeclaration{} -> "OrphanTypeDeclaration"

214 OrphanFixityDeclaration{} -> "OrphanFixityDeclaration"

207 OrphanFixityDeclaration{} -> "OrphanFixityDeclaration"

@@ -248,11 +241,9 @@ errorCode em = case unwrapErrorMessage em of

248 CycleInTypeSynonym{} -> "CycleInTypeSynonym"

241 CycleInTypeSynonym{} -> "CycleInTypeSynonym"

249 CycleInModules{} -> "CycleInModules"

242 CycleInModules{} -> "CycleInModules"

250 NameIsUndefined{} -> "NameIsUndefined"

243 NameIsUndefined{} -> "NameIsUndefined"

251− NameNotInScope{} -> "NameNotInScope"

252 UndefinedTypeVariable{} -> "UndefinedTypeVariable"

244 UndefinedTypeVariable{} -> "UndefinedTypeVariable"

253 PartiallyAppliedSynonym{} -> "PartiallyAppliedSynonym"

245 PartiallyAppliedSynonym{} -> "PartiallyAppliedSynonym"

254 EscapedSkolem{} -> "EscapedSkolem"

246 EscapedSkolem{} -> "EscapedSkolem"

255− UnspecifiedSkolemScope -> "UnspecifiedSkolemScope"

256 TypesDoNotUnify{} -> "TypesDoNotUnify"

247 TypesDoNotUnify{} -> "TypesDoNotUnify"

257 KindsDoNotUnify{} -> "KindsDoNotUnify"

248 KindsDoNotUnify{} -> "KindsDoNotUnify"

258 ConstrainedTypeUnified{} -> "ConstrainedTypeUnified"

249 ConstrainedTypeUnified{} -> "ConstrainedTypeUnified"

@@ -269,13 +260,12 @@ errorCode em = case unwrapErrorMessage em of

269 ExtraneousClassMember{} -> "ExtraneousClassMember"

260 ExtraneousClassMember{} -> "ExtraneousClassMember"

270 ExpectedType{} -> "ExpectedType"

261 ExpectedType{} -> "ExpectedType"

271 IncorrectConstructorArity{} -> "IncorrectConstructorArity"

262 IncorrectConstructorArity{} -> "IncorrectConstructorArity"

272− SubsumptionCheckFailed -> "SubsumptionCheckFailed"

273 ExprDoesNotHaveType{} -> "ExprDoesNotHaveType"

263 ExprDoesNotHaveType{} -> "ExprDoesNotHaveType"

274 PropertyIsMissing{} -> "PropertyIsMissing"

264 PropertyIsMissing{} -> "PropertyIsMissing"

275 CannotApplyFunction{} -> "CannotApplyFunction"

265 CannotApplyFunction{} -> "CannotApplyFunction"

276 TypeSynonymInstance -> "TypeSynonymInstance"

266 TypeSynonymInstance -> "TypeSynonymInstance"

277 OrphanInstance{} -> "OrphanInstance"

267 OrphanInstance{} -> "OrphanInstance"

278− InvalidNewtype -> "InvalidNewtype"

268+ InvalidNewtype{} -> "InvalidNewtype"

279 InvalidInstanceHead{} -> "InvalidInstanceHead"

269 InvalidInstanceHead{} -> "InvalidInstanceHead"

280 TransitiveExportError{} -> "TransitiveExportError"

270 TransitiveExportError{} -> "TransitiveExportError"

281 ShadowedName{} -> "ShadowedName"

271 ShadowedName{} -> "ShadowedName"

@@ -385,9 +375,9 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

385 prettyPrintErrorMessage (ErrorMessage hints simple) =

375 prettyPrintErrorMessage (ErrorMessage hints simple) =

386 paras $

376 paras $

387 map renderHint hints ++

377 map renderHint hints ++

388− renderSimpleErrorMessage simple :

378+ [ renderSimpleErrorMessage simple

389− suggestions simple ++

390− [line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this " ++ levelText ++ "."]

379+ , line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this " ++ levelText ++ "."

380+ ]

391 where

381 where

392 wikiUri :: String

382 wikiUri :: String

393 wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e

383 wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e

@@ -410,7 +400,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

410 , prettyPrintParseError err

400 , prettyPrintParseError err

411 ]

401 ]

412 renderSimpleErrorMessage (ErrorParsingFFIModule path) =

402 renderSimpleErrorMessage (ErrorParsingFFIModule path) =

413− paras [ line "Unable to parse module from FFI file: "

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

414 , indent . line $ path

404 , indent . line $ path

415 ]

405 ]

416 renderSimpleErrorMessage (ErrorParsingModule err) =

406 renderSimpleErrorMessage (ErrorParsingModule err) =

@@ -418,29 +408,22 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

418 , prettyPrintParseError err

408 , prettyPrintParseError err

419 ]

409 ]

420 renderSimpleErrorMessage (MissingFFIModule mn) =

410 renderSimpleErrorMessage (MissingFFIModule mn) =

421− line $ "Missing FFI implementations for module " ++ runModuleName mn

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

422 renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =

412 renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =

423− paras [ line $ "Unnecessary FFI implementations have been provided for module " ++ runModuleName mn ++ ": "

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

424 , indent . line $ path

414 , indent . line $ path

415+ , line $ "Module " ++ runModuleName mn ++ " does not contain any foreign import declarations, so a foreign module is not necessary."

425 ]

416 ]

426 renderSimpleErrorMessage (MultipleFFIModules mn paths) =

417 renderSimpleErrorMessage (MultipleFFIModules mn paths) =

427− paras [ line $ "Multiple FFI implementations have been provided for module " ++ runModuleName mn ++ ": "

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

428 , indent . paras $ map line paths

419 , indent . paras $ map line paths

429 ]

420 ]

430− renderSimpleErrorMessage (InvalidExternsFile path) =

431− paras [ line "Externs file is invalid: "

432− , indent . line $ path

433− ]

434 renderSimpleErrorMessage InvalidDoBind =

421 renderSimpleErrorMessage InvalidDoBind =

435− line "Bind statement cannot be the last statement in a do block. The last statement must be an expression."

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

436 renderSimpleErrorMessage InvalidDoLet =

423 renderSimpleErrorMessage InvalidDoLet =

437− line "Let statement cannot be the last statement in a do block. The last statement must be an expression."

424+ line "The last statement in a 'do' block must be an expression, but this block ends with a let binding."

438− renderSimpleErrorMessage CannotReorderOperators =

439− line "Unable to reorder operators"

440− renderSimpleErrorMessage UnspecifiedSkolemScope =

441− line "Skolem variable scope is unspecified"

442 renderSimpleErrorMessage OverlappingNamesInLet =

425 renderSimpleErrorMessage OverlappingNamesInLet =

443− line "Overlapping names in let binding."

426+ line "The same name was used more than once in a let binding."

444 renderSimpleErrorMessage (InfiniteType ty) =

427 renderSimpleErrorMessage (InfiniteType ty) =

445 paras [ line "An infinite type was inferred for an expression: "

428 paras [ line "An infinite type was inferred for an expression: "

446 , indent $ typeAsBox ty

429 , indent $ typeAsBox ty

@@ -450,17 +433,17 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

450 , indent $ line $ prettyPrintKind ki

433 , indent $ line $ prettyPrintKind ki

451 ]

434 ]

452 renderSimpleErrorMessage (MultipleFixities name) =

435 renderSimpleErrorMessage (MultipleFixities name) =

453− line $ "Multiple fixity declarations for " ++ showIdent name

436+ line $ "There are multiple fixity/precedence declarations for " ++ showIdent name

454 renderSimpleErrorMessage (OrphanTypeDeclaration nm) =

437 renderSimpleErrorMessage (OrphanTypeDeclaration nm) =

455− line $ "Orphan type declaration for " ++ showIdent nm

438+ line $ "The type declaration for " ++ showIdent nm ++ " should be followed by its definition."

456 renderSimpleErrorMessage (OrphanFixityDeclaration op) =

439 renderSimpleErrorMessage (OrphanFixityDeclaration op) =

457− line $ "Orphan fixity declaration for " ++ show op

440+ line $ "The fixity/precedence declaration for " ++ show op ++ " should appear in the same module as its definition."

458 renderSimpleErrorMessage (RedefinedModule name filenames) =

441 renderSimpleErrorMessage (RedefinedModule name filenames) =

459− paras [ line ("Module " ++ runModuleName name ++ " has been defined multiple times:")

442+ paras [ line ("The module " ++ runModuleName name ++ " has been defined multiple times:")

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

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

461 ]

444 ]

462 renderSimpleErrorMessage (RedefinedIdent name) =

445 renderSimpleErrorMessage (RedefinedIdent name) =

463− line $ "Name " ++ showIdent name ++ " has been defined multiple times"

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

464 renderSimpleErrorMessage (UnknownModule mn) =

447 renderSimpleErrorMessage (UnknownModule mn) =

465 line $ "Unknown module " ++ runModuleName mn

448 line $ "Unknown module " ++ runModuleName mn

466 renderSimpleErrorMessage (UnknownType name) =

449 renderSimpleErrorMessage (UnknownType name) =

@@ -474,25 +457,36 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

474 renderSimpleErrorMessage (UnknownDataConstructor dc tc) =

457 renderSimpleErrorMessage (UnknownDataConstructor dc tc) =

475 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

476 renderSimpleErrorMessage (UnknownImportType mn name) =

459 renderSimpleErrorMessage (UnknownImportType mn name) =

477− line $ "Module " ++ runModuleName mn ++ " does not export type " ++ runProperName name

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

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

462+ ]

478 renderSimpleErrorMessage (UnknownExportType name) =

463 renderSimpleErrorMessage (UnknownExportType name) =

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

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

480 renderSimpleErrorMessage (UnknownImportTypeClass mn name) =

465 renderSimpleErrorMessage (UnknownImportTypeClass mn name) =

481− line $ "Module " ++ runModuleName mn ++ " does not export type class " ++ runProperName name

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

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

468+ ]

482 renderSimpleErrorMessage (UnknownExportTypeClass name) =

469 renderSimpleErrorMessage (UnknownExportTypeClass name) =

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

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

484 renderSimpleErrorMessage (UnknownImportValue mn name) =

471 renderSimpleErrorMessage (UnknownImportValue mn name) =

485− line $ "Module " ++ runModuleName mn ++ " does not export value " ++ showIdent name

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

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

474+ ]

486 renderSimpleErrorMessage (UnknownExportValue name) =

475 renderSimpleErrorMessage (UnknownExportValue name) =

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

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

488 renderSimpleErrorMessage (UnknownExportModule name) =

477 renderSimpleErrorMessage (UnknownExportModule name) =

478+ paras [ line $ "Cannot export unknown module " ++ runModuleName name

489− line $ "Cannot export unknown module " ++ runModuleName name ++ ", 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."

480+ ]

490 renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =

481 renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =

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

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

492 renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =

483 renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =

493− 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."

494 renderSimpleErrorMessage (ConflictingImport nm mn) =

485 renderSimpleErrorMessage (ConflictingImport nm mn) =

495− line $ "Cannot declare " ++ show nm ++ " since another declaration of that name was imported from " ++ runModuleName mn

486+ paras [ line $ "Cannot declare " ++ show nm ++ ", since another declaration of that name was imported from module " ++ runModuleName mn

487+ , line $ "Consider hiding " ++ show nm ++ " when importing " ++ runModuleName mn ++ ":"

488+ , indent . line $ "import " ++ runModuleName mn ++ " hiding (" ++ nm ++ ")"

489+ ]

496 renderSimpleErrorMessage (ConflictingImports nm m1 m2) =

490 renderSimpleErrorMessage (ConflictingImports nm m1 m2) =

497 line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2

491 line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2

498 renderSimpleErrorMessage (ConflictingTypeDecls nm) =

492 renderSimpleErrorMessage (ConflictingTypeDecls nm) =

@@ -500,13 +494,13 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

500 renderSimpleErrorMessage (ConflictingCtorDecls nm) =

494 renderSimpleErrorMessage (ConflictingCtorDecls nm) =

501 line $ "Conflicting data constructor declarations for " ++ runProperName nm

495 line $ "Conflicting data constructor declarations for " ++ runProperName nm

502 renderSimpleErrorMessage (TypeConflictsWithClass nm) =

496 renderSimpleErrorMessage (TypeConflictsWithClass nm) =

503− line $ "Type " ++ runProperName nm ++ " conflicts with type class declaration of the same name"

497+ line $ "Type " ++ runProperName nm ++ " conflicts with a type class declaration with the same name."

504 renderSimpleErrorMessage (CtorConflictsWithClass nm) =

498 renderSimpleErrorMessage (CtorConflictsWithClass nm) =

505− line $ "Data constructor " ++ runProperName nm ++ " conflicts with type class declaration of the same name"

499+ line $ "Data constructor " ++ runProperName nm ++ " conflicts with a type class declaration with the same name."

506 renderSimpleErrorMessage (ClassConflictsWithType nm) =

500 renderSimpleErrorMessage (ClassConflictsWithType nm) =

507− line $ "Type class " ++ runProperName nm ++ " conflicts with type declaration of the same name"

501+ line $ "Type class " ++ runProperName nm ++ " conflicts with a type declaration with the same name."

508 renderSimpleErrorMessage (ClassConflictsWithCtor nm) =

502 renderSimpleErrorMessage (ClassConflictsWithCtor nm) =

509− line $ "Type class " ++ runProperName nm ++ " conflicts with data constructor declaration of the same name"

503+ line $ "Type class " ++ runProperName nm ++ " conflicts with a data constructor declaration with the same name."

510 renderSimpleErrorMessage (DuplicateModuleName mn) =

504 renderSimpleErrorMessage (DuplicateModuleName mn) =

511 line $ "Module " ++ runModuleName mn ++ " has been defined multiple times."

505 line $ "Module " ++ runModuleName mn ++ " has been defined multiple times."

512 renderSimpleErrorMessage (DuplicateClassExport nm) =

506 renderSimpleErrorMessage (DuplicateClassExport nm) =

@@ -514,19 +508,24 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

514 renderSimpleErrorMessage (DuplicateValueExport nm) =

508 renderSimpleErrorMessage (DuplicateValueExport nm) =

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

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

516 renderSimpleErrorMessage (CycleInDeclaration nm) =

510 renderSimpleErrorMessage (CycleInDeclaration nm) =

517− line $ "Cycle in declaration of " ++ showIdent nm

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

518 renderSimpleErrorMessage (CycleInModules mns) =

512 renderSimpleErrorMessage (CycleInModules mns) =

519− line $ "Cycle in module dependencies: " ++ intercalate ", " (map runModuleName mns)

513+ paras [ line $ "There is a cycle in module dependencies in these modules: "

514+ , indent $ paras (map (line . runModuleName) mns)

515+ ]

520− renderSimpleErrorMessage (CycleInTypeSynonym pn) =

516+ renderSimpleErrorMessage (CycleInTypeSynonym name) =

521− line $ "Cycle in type synonym" ++ foldMap ((" " ++) . runProperName) pn

517+ paras [ line $ case name of

518+ Just pn -> "A cycle appears in the definition of type synonym " ++ runProperName pn

519+ Nothing -> "A cycle appears in a set of type synonym definitions."

520+ , line "Cycles are disallowed because they can lead to loops in the type checker."

521+ , line "Consider using a 'newtype' instead."

522+ ]

522 renderSimpleErrorMessage (NameIsUndefined ident) =

523 renderSimpleErrorMessage (NameIsUndefined ident) =

523− line $ showIdent ident ++ " is undefined"

524+ line $ "Value " ++ showIdent ident ++ " is undefined."

524− renderSimpleErrorMessage (NameNotInScope ident) =

525− line $ showIdent ident ++ " may not be defined in the current scope"

526 renderSimpleErrorMessage (UndefinedTypeVariable name) =

525 renderSimpleErrorMessage (UndefinedTypeVariable name) =

527− line $ "Type variable " ++ runProperName name ++ " is undefined"

526+ line $ "Type variable " ++ runProperName name ++ " is undefined."

528 renderSimpleErrorMessage (PartiallyAppliedSynonym name) =

527 renderSimpleErrorMessage (PartiallyAppliedSynonym name) =

529− paras [ line $ "Partially applied type synonym " ++ showQualified runProperName name

528+ paras [ line $ "Type synonym " ++ showQualified runProperName name ++ " is partially applied."

530 , line "Type synonyms must be applied to all of their type arguments."

529 , line "Type synonyms must be applied to all of their type arguments."

531 ]

530 ]

532 renderSimpleErrorMessage (EscapedSkolem binding) =

531 renderSimpleErrorMessage (EscapedSkolem binding) =

@@ -535,70 +534,72 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

535 , indent $ prettyPrintValue expr

534 , indent $ prettyPrintValue expr

536 ]) binding

535 ]) binding

537 renderSimpleErrorMessage (TypesDoNotUnify t1 t2)

536 renderSimpleErrorMessage (TypesDoNotUnify t1 t2)

538− = paras [ line "Cannot unify type"

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

539 , indent $ typeAsBox t1

538 , indent $ typeAsBox t1

540− , line "with type"

539+ , line "with actual type"

541 , indent $ typeAsBox t2

540 , indent $ typeAsBox t2

542 ]

541 ]

543 renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =

542 renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =

544− paras [ line "Cannot unify kind"

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

545 , indent $ line $ prettyPrintKind k1

544 , indent $ line $ prettyPrintKind k1

546− , line "with kind"

545+ , line "with actual kind"

547 , indent $ line $ prettyPrintKind k2

546 , indent $ line $ prettyPrintKind k2

548 ]

547 ]

549 renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) =

548 renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) =

550− paras [ line "Cannot unify constrained type"

549+ paras [ line "Could not match constrained type"

551 , indent $ typeAsBox t1

550 , indent $ typeAsBox t1

552 , line "with type"

551 , line "with type"

553 , indent $ typeAsBox t2

552 , indent $ typeAsBox t2

554 ]

553 ]

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

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

556− paras [ line "Overlapping instances found for"

555+ paras [ line "Overlapping type class instances found for"

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

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

558 , Box.vcat Box.left (map typeAtomAsBox ts)

557 , Box.vcat Box.left (map typeAtomAsBox ts)

559 ]

558 ]

560 , line "The following instances were found:"

559 , line "The following instances were found:"

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

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

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

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

562 ]

563 ]

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

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

564 renderSimpleErrorMessage (NoInstanceFound nm ts) =

565 renderSimpleErrorMessage (NoInstanceFound nm ts) =

565− paras [ line "No instance found for"

566+ paras [ line "No type class instance was found for"

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

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

567 , Box.vcat Box.left (map typeAtomAsBox ts)

568 , Box.vcat Box.left (map typeAtomAsBox ts)

568 ]

569 ]

570 ]

570 renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =

571 renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =

571− paras [ line "Instance for"

572+ paras [ line "Type class instance for"

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

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

573 , Box.vcat Box.left (map typeAtomAsBox ts)

574 , Box.vcat Box.left (map typeAtomAsBox ts)

574 ]

575 ]

575 , line "is possibly infinite."

576 , line "is possibly infinite."

576 ]

577 ]

577 renderSimpleErrorMessage (CannotDerive nm ts) =

578 renderSimpleErrorMessage (CannotDerive nm ts) =

578− paras [ line "Cannot derive an instance for"

579+ paras [ line "Cannot derive a type class instance for"

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

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

580 , Box.vcat Box.left (map typeAtomAsBox ts)

581 , Box.vcat Box.left (map typeAtomAsBox ts)

581 ]

582 ]

583 ]

583 renderSimpleErrorMessage (CannotFindDerivingType nm) =

584 renderSimpleErrorMessage (CannotFindDerivingType nm) =

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

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

585 renderSimpleErrorMessage (DuplicateLabel l expr) =

586 renderSimpleErrorMessage (DuplicateLabel l expr) =

586− paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]

587+ paras $ [ line $ "Label " ++ show l ++ " appears more than once in a row type." ]

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

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

588 , indent $ prettyPrintValue expr'

589 , indent $ prettyPrintValue expr'

589 ]) expr

590 ]) expr

590 renderSimpleErrorMessage (DuplicateTypeArgument name) =

591 renderSimpleErrorMessage (DuplicateTypeArgument name) =

591− line $ "Duplicate type argument " ++ show name

592+ line $ "Type argument " ++ show name ++ " appears more than once."

592 renderSimpleErrorMessage (DuplicateValueDeclaration nm) =

593 renderSimpleErrorMessage (DuplicateValueDeclaration nm) =

593− line $ "Duplicate value declaration for " ++ showIdent nm

594+ line $ "Multiple value declarations exist for " ++ showIdent nm ++ "."

594 renderSimpleErrorMessage (ArgListLengthsDiffer ident) =

595 renderSimpleErrorMessage (ArgListLengthsDiffer ident) =

595 line $ "Argument list lengths differ in declaration " ++ showIdent ident

596 line $ "Argument list lengths differ in declaration " ++ showIdent ident

596 renderSimpleErrorMessage (OverlappingArgNames ident) =

597 renderSimpleErrorMessage (OverlappingArgNames ident) =

597 line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . showIdent) ident

598 line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . showIdent) ident

598 renderSimpleErrorMessage (MissingClassMember ident) =

599 renderSimpleErrorMessage (MissingClassMember ident) =

599− line $ "Member " ++ showIdent ident ++ " has not been implemented"

600+ line $ "Type class member " ++ showIdent ident ++ " has not been implemented."

600− renderSimpleErrorMessage (ExtraneousClassMember ident) =

601+ renderSimpleErrorMessage (ExtraneousClassMember ident className) =

601− line $ "Member " ++ showIdent ident ++ " is not a member of the class being instantiated"

602+ line $ showIdent ident ++ " is not a member of type class " ++ showQualified runProperName className

602 renderSimpleErrorMessage (ExpectedType ty kind) =

603 renderSimpleErrorMessage (ExpectedType ty kind) =

603 paras [ line "In a type-annotated expression x :: t, the type t must have kind *."

604 paras [ line "In a type-annotated expression x :: t, the type t must have kind *."

604 , line "The error arises from the type"

605 , line "The error arises from the type"

@@ -608,8 +609,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

608 , line "instead."

609 , line "instead."

609 ]

610 ]

610 renderSimpleErrorMessage (IncorrectConstructorArity nm) =

611 renderSimpleErrorMessage (IncorrectConstructorArity nm) =

611− line $ "Wrong number of arguments to constructor " ++ showQualified runProperName nm

612+ line $ "Data constructor " ++ showQualified runProperName nm ++ " was given the wrong number of arguments in a case expression."

612− renderSimpleErrorMessage SubsumptionCheckFailed = line "Unable to check type subsumption"

613 renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) =

614 paras [ line "Expression"

615 , indent $ prettyPrintValue expr

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

617 , indent $ typeAsBox ty

618 ]

619 renderSimpleErrorMessage (PropertyIsMissing prop row) =

620− paras [ line "Row"

620+ paras [ line "Row type"

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

622− , line $ "lacks required property " ++ show prop

622+ , line $ "lacks required label " ++ show prop

623 ]

624 renderSimpleErrorMessage (CannotApplyFunction fn arg) =

625− paras [ line "Cannot apply function of type"

625+ paras [ line "A function of type"

626 , indent $ typeAsBox fn

627− , line "to argument"

627+ , line "can not be applied to the argument"

628 , indent $ prettyPrintValue arg

629 ]

630 renderSimpleErrorMessage TypeSynonymInstance =

631− line "Type synonym instances are disallowed"

631+ line "Type class instances for type synonyms are disallowed."

632 renderSimpleErrorMessage (OrphanInstance nm cnm ts) =

633− paras [ line $ "Instance " ++ showIdent nm ++ " for "

633+ paras [ line $ "Type class instance " ++ showIdent nm ++ " for "

634 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm)

635 , Box.vcat Box.left (map typeAtomAsBox ts)

636 ]

@@ -638,32 +638,37 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

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

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

640 ]

641− renderSimpleErrorMessage InvalidNewtype =

641+ renderSimpleErrorMessage (InvalidNewtype name) =

642+ paras [ line $ "Newtype " ++ runProperName name ++ " is invalid."

642− line "Newtypes must define a single constructor with a single argument"

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

644+ ]

643 renderSimpleErrorMessage (InvalidInstanceHead ty) =

645 renderSimpleErrorMessage (InvalidInstanceHead ty) =

644− paras [ line "Invalid type in class instance head:"

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

645 , indent $ typeAsBox ty

647 , indent $ typeAsBox ty

648+ , 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."

646 ]

649 ]

647 renderSimpleErrorMessage (TransitiveExportError x ys) =

650 renderSimpleErrorMessage (TransitiveExportError x ys) =

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

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

649 : map (line . prettyPrintExport) ys

652 : map (line . prettyPrintExport) ys

650 renderSimpleErrorMessage (ShadowedName nm) =

653 renderSimpleErrorMessage (ShadowedName nm) =

651− line $ "Name '" ++ showIdent nm ++ "' was shadowed"

654+ line $ "Name '" ++ showIdent nm ++ "' was shadowed."

652 renderSimpleErrorMessage (ShadowedTypeVar tv) =

655 renderSimpleErrorMessage (ShadowedTypeVar tv) =

653− line $ "Type variable '" ++ tv ++ "' was shadowed"

656+ line $ "Type variable '" ++ tv ++ "' was shadowed."

654 renderSimpleErrorMessage (UnusedTypeVar tv) =

657 renderSimpleErrorMessage (UnusedTypeVar tv) =

655− line $ "Type variable '" ++ tv ++ "' was declared but not used"

658+ line $ "Type variable '" ++ tv ++ "' was declared but not used."

656 renderSimpleErrorMessage (ClassOperator className opName) =

659 renderSimpleErrorMessage (ClassOperator className opName) =

657− paras [ line $ "Class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "."

660+ paras [ line $ "Type class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "."

658 , line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"

661 , line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"

659 , indent . line $ showIdent opName ++ " = someMember"

662 , indent . line $ showIdent opName ++ " = someMember"

660 ]

663 ]

661 renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =

664 renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =

662− line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors"

665+ line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors."

663 renderSimpleErrorMessage (ImportHidingModule name) =

666 renderSimpleErrorMessage (ImportHidingModule name) =

667+ paras [ line $ "'hiding' imports cannot be used to hide modules."

664− line $ "Attempted to hide module " ++ runModuleName name ++ " in import expression, this is not permitted"

668+ , line $ "An attempt was made to hide the import of " ++ runModuleName name

669+ ]

665 renderSimpleErrorMessage (WildcardInferredType ty) =

670 renderSimpleErrorMessage (WildcardInferredType ty) =

666− paras [ line "The wildcard type definition has the inferred type "

671+ paras [ line "Wildcard type definition has the inferred type "

667 , indent $ typeAsBox ty

672 , indent $ typeAsBox ty

668 ]

673 ]

669 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

674 renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =

@@ -692,7 +697,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

692 renderHint (NotYetDefined names) =

697 renderHint (NotYetDefined names) =

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

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

694 renderHint (ErrorUnifyingTypes t1 t2) =

699 renderHint (ErrorUnifyingTypes t1 t2) =

695− paras [ lineWithLevel "unifying type "

700+ paras [ lineWithLevel "while trying to match type "

696 , indent $ typeAsBox t1

701 , indent $ typeAsBox t1

697 , line "with type"

702 , line "with type"

698 , indent $ typeAsBox t2

703 , indent $ typeAsBox t2

@@ -705,9 +710,9 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

705 paras [ lineWithLevel $ "in module " ++ runModuleName mn ++ ":"

710 paras [ lineWithLevel $ "in module " ++ runModuleName mn ++ ":"

706 ]

711 ]

707 renderHint (ErrorInSubsumption t1 t2) =

712 renderHint (ErrorInSubsumption t1 t2) =

708− paras [ lineWithLevel "checking that type "

713+ paras [ lineWithLevel "checking that type"

709 , indent $ typeAsBox t1

714 , indent $ typeAsBox t1

710− , line "subsumes type"

715+ , line "is at least as general as type"

711 , indent $ typeAsBox t2

716 , indent $ typeAsBox t2

712 ]

717 ]

713 renderHint (ErrorInInstance nm ts) =

718 renderHint (ErrorInInstance nm ts) =

@@ -717,21 +722,21 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

717 ]

722 ]

718 ]

723 ]

719 renderHint (ErrorCheckingKind ty) =

724 renderHint (ErrorCheckingKind ty) =

720− paras [ lineWithLevel "checking kind of type "

725+ paras [ lineWithLevel "checking kind of type"

721 , indent $ typeAsBox ty

726 , indent $ typeAsBox ty

722 ]

727 ]

723 renderHint (ErrorInferringType expr) =

728 renderHint (ErrorInferringType expr) =

724− paras [ lineWithLevel "inferring type of value "

729+ paras [ lineWithLevel "inferring type of expression"

725 , indent $ prettyPrintValue expr

730 , indent $ prettyPrintValue expr

726 ]

731 ]

727 renderHint (ErrorCheckingType expr ty) =

732 renderHint (ErrorCheckingType expr ty) =

728− paras [ lineWithLevel "checking that value "

733+ paras [ lineWithLevel "checking that expression"

729 , indent $ prettyPrintValue expr

734 , indent $ prettyPrintValue expr

730 , line "has type"

735 , line "has type"

731 , indent $ typeAsBox ty

736 , indent $ typeAsBox ty

732 ]

737 ]

733 renderHint (ErrorInApplication f t a) =

738 renderHint (ErrorInApplication f t a) =

734− paras [ lineWithLevel "applying function"

739+ paras [ lineWithLevel "applying a function"

735 , indent $ prettyPrintValue f

740 , indent $ prettyPrintValue f

736 , line "of type"

741 , line "of type"

737 , indent $ typeAsBox t

742 , indent $ typeAsBox t

@@ -765,15 +770,6 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir

765 Error -> "error"

770 Error -> "error"

766 Warning -> "warning"

771 Warning -> "warning"

767

772

768− suggestions :: SimpleErrorMessage -> [Box.Box]

769− suggestions (ConflictingImport nm im) = [ line $ "Possible fix: hide " ++ show nm ++ " when importing " ++ runModuleName im ++ ":"

770− , indent . line $ "import " ++ runModuleName im ++ " hiding (" ++ nm ++ ")"

771− ]

772− suggestions (TypesDoNotUnify t1 t2)

773− | isObject t1 && isFunction t2 = [line "Note that function composition in PureScript is defined using (<<<)"]

774− | otherwise = []

775− suggestions _ = []

776−

777 paras :: [Box.Box] -> Box.Box

773 paras :: [Box.Box] -> Box.Box

778 paras = Box.vcat Box.left

774 paras = Box.vcat Box.left

779

775

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

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

39import qualified Data.Map as M

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

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

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

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

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"

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)

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)

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

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

25+import Language.PureScript.Crash

25import Language.PureScript.Kinds

26import Language.PureScript.Kinds

26import Language.PureScript.Pretty.Common

27import Language.PureScript.Pretty.Common

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

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

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

@@ -142,14 +143,14 @@ forall_ = mkPattern match

142 match _ = Nothing

143 match _ = Nothing

143

144

144typeAtomAsBox :: Type -> Box

145typeAtomAsBox :: Type -> Box

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

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

146

147

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

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

148prettyPrintTypeAtom :: Type -> String

149prettyPrintTypeAtom :: Type -> String

149prettyPrintTypeAtom = render . typeAtomAsBox

150prettyPrintTypeAtom = render . typeAtomAsBox

150

151

151typeAsBox :: Type -> Box

152typeAsBox :: Type -> Box

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

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

153

154

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

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

155prettyPrintType :: Type -> String

156prettyPrintType :: Type -> String

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

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

26import Control.Arrow (second)

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

36import qualified Data.Set as S

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

26+import Language.PureScript.Crash

26import Data.Maybe (catMaybes)

27import Data.Maybe (catMaybes)

27import Data.List (nub, groupBy)

28import Data.List (nub, groupBy)

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

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

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

31import qualified Data.Map as M

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

34import qualified Data.Map as M

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)

35import qualified Data.Map as M

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

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 _ = []

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 (const . throwError . errorMessage $ CannotReorderOperators) 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+9−8

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

24 , superClassDictionaryNames

25 ) where

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"

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

@@ -289,18 +290,18 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

289

290

290 memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [(Ident, Type)] -> Declaration -> Desugar m Expr

291 memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [(Ident, Type)] -> Declaration -> Desugar m Expr

291 memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do

292 memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do

292− _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident) return $ lookup ident tys'

293+ _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys'

293 return val

294 return val

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

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/TypeChecker.hs+14−13

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

38import Control.Monad.State

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

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"

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)

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"

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

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

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

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−2

@@ -20,9 +20,9 @@ module Language.PureScript.TypeChecker.Subsumption (

20import Data.List (sortBy)

21import Data.Ord (comparing)

23−import Control.Monad.Error.Class (MonadError(..))

24import Control.Monad.Unify

23import Control.Monad.Unify

25+import Language.PureScript.Crash

26import Language.PureScript.AST

27import Language.PureScript.Environment

28import Language.PureScript.Errors

@@ -50,7 +50,7 @@ subsumes' val ty1 (ForAll ident ty2 sco) =

50 sko <- newSkolemConstant

51 let sk = skolemize ident sko sco' ty2

52 subsumes val ty1 sk

53− Nothing -> throwError . errorMessage $ UnspecifiedSkolemScope

53+ Nothing -> internalError "subsumes: unspecified skolem scope"

54subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do

55 _ <- subsumes Nothing arg2 arg1

56 _ <- subsumes Nothing ret1 ret2

src/Language/PureScript/TypeChecker/Types.hs+13−12

@@ -52,6 +52,7 @@ import Control.Monad.Unify

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

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

55+import Language.PureScript.Crash

55import Language.PureScript.AST

56import Language.PureScript.AST

56import Language.PureScript.Environment

57import Language.PureScript.Environment

57import Language.PureScript.Errors

58import Language.PureScript.Errors

@@ -140,7 +141,7 @@ typeForBindingGroupElement :: (Ident, Expr) -> TypeData -> UntypedData -> UnifyT

140typeForBindingGroupElement (ident, val) dict untypedDict = do

141typeForBindingGroupElement (ident, val) dict untypedDict = do

141 -- Infer the type with the new names in scope

142 -- Infer the type with the new names in scope

142 TypedValue _ val' ty <- bindNames dict $ infer val

143 TypedValue _ val' ty <- bindNames dict $ infer val

143− ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)

144+ ty =?= fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict)

144 tell . errorMessage $ MissingTypeDeclaration ident ty

145 tell . errorMessage $ MissingTypeDeclaration ident ty

145 return (ident, (TypedValue True val' ty, ty))

146 return (ident, (TypedValue True val' ty, ty))

146

147

@@ -192,7 +193,7 @@ instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do

192 instantiatePolyTypeWithUnknowns val ty'

193 instantiatePolyTypeWithUnknowns val ty'

193instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do

194instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do

194 dicts <- getTypeClassDictionaries

195 dicts <- getTypeClassDictionaries

195− (_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty

196+ (_, ty') <- instantiatePolyTypeWithUnknowns (internalError "Types under a constraint cannot themselves be constrained") ty

196 return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty')

197 return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty')

197instantiatePolyTypeWithUnknowns val ty = return (val, ty)

198instantiatePolyTypeWithUnknowns val ty = return (val, ty)

198

199

@@ -242,7 +243,7 @@ infer' (Abs (Left arg) ret) = do

242 withBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do

243 withBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do

243 body@(TypedValue _ _ bodyTy) <- infer' ret

244 body@(TypedValue _ _ bodyTy) <- infer' ret

244 return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy

245 return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy

245−infer' (Abs (Right _) _) = error "Binder was not desugared"

246+infer' (Abs (Right _) _) = internalError "Binder was not desugared"

246infer' (App f arg) = do

247infer' (App f arg) = do

247 f'@(TypedValue _ _ ft) <- infer f

248 f'@(TypedValue _ _ ft) <- infer f

248 (ret, app) <- checkFunctionApplication f' ft arg Nothing

249 (ret, app) <- checkFunctionApplication f' ft arg Nothing

@@ -287,7 +288,7 @@ infer' (TypedValue checkType val ty) = do

287 val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val

288 val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val

288 return $ TypedValue True val' ty'

289 return $ TypedValue True val' ty'

289infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val

290infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val

290−infer' _ = error "Invalid argument to infer"

291+infer' _ = internalError "Invalid argument to infer"

291

292

292inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr)

293inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr)

293inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret)

294inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret)

@@ -318,7 +319,7 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do

318inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethrowWithPosition pos $ do

319inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethrowWithPosition pos $ do

319 (d' : ds', val') <- inferLetBinding seen (d : ds) ret j

320 (d' : ds', val') <- inferLetBinding seen (d : ds) ret j

320 return (PositionedDeclaration pos com d' : ds', val')

321 return (PositionedDeclaration pos com d' : ds', val')

321−inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding"

322+inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding"

322

323

323-- |

324-- |

324-- Infer the types of variables brought into scope by a binder

325-- Infer the types of variables brought into scope by a binder

@@ -335,7 +336,7 @@ inferBinder val (ConstructorBinder ctor binders) = do

335 env <- getEnv

336 env <- getEnv

336 case M.lookup ctor (dataConstructors env) of

337 case M.lookup ctor (dataConstructors env) of

337 Just (_, _, ty, _) -> do

338 Just (_, _, ty, _) -> do

338− (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contain constraints") ty

339+ (_, fn) <- instantiatePolyTypeWithUnknowns (internalError "Data constructor types cannot contain constraints") ty

339 fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn

340 fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn

340 go binders fn'

341 go binders fn'

341 where

342 where

@@ -454,7 +455,7 @@ check' val t@(ConstrainedType constraints ty) = do

454 newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> Check [TypeClassDictionaryInScope]

455 newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> Check [TypeClassDictionaryInScope]

455 newDictionaries path name (className, instanceTy) = do

456 newDictionaries path name (className, instanceTy) = do

456 tcs <- gets (typeClasses . checkEnv)

457 tcs <- gets (typeClasses . checkEnv)

457− let (args, _, superclasses) = fromMaybe (error "newDictionaries: type class lookup failed") $ M.lookup className tcs

458+ let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs

458 supDicts <- join <$> zipWithM (\(supName, supArgs) index ->

459 supDicts <- join <$> zipWithM (\(supName, supArgs) index ->

459 newDictionaries ((supName, index) : path)

460 newDictionaries ((supName, index) : path)

460 name

461 name

@@ -489,7 +490,7 @@ check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do

489 Just moduleName <- checkCurrentModule <$> get

490 Just moduleName <- checkCurrentModule <$> get

490 ret' <- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy

491 ret' <- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy

491 return $ TypedValue True (Abs (Left arg) ret') ty

492 return $ TypedValue True (Abs (Left arg) ret') ty

492−check' (Abs (Right _) _) _ = error "Binder was not desugared"

493+check' (Abs (Right _) _) _ = internalError "Binder was not desugared"

493check' (App f arg) ret = do

494check' (App f arg) ret = do

494 f'@(TypedValue _ _ ft) <- infer f

495 f'@(TypedValue _ _ ft) <- infer f

495 (_, app) <- checkFunctionApplication f' ft arg (Just ret)

496 (_, app) <- checkFunctionApplication f' ft arg (Just ret)

@@ -501,7 +502,7 @@ check' v@(Var var) ty = do

501 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

502 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

502 v' <- subsumes (Just v) repl ty'

503 v' <- subsumes (Just v) repl ty'

503 case v' of

504 case v' of

504− Nothing -> throwError . errorMessage $ SubsumptionCheckFailed

505+ Nothing -> internalError "check: unable to check the subsumes relation."

505 Just v'' -> return $ TypedValue True v'' ty'

506 Just v'' -> return $ TypedValue True v'' ty'

506check' (SuperClassDictionary className tys) _ = do

507check' (SuperClassDictionary className tys) _ = do

507 {-

508 {-

@@ -520,7 +521,7 @@ check' (TypedValue checkType val ty1) ty2 = do

520 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2

521 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2

521 val' <- subsumes (Just val) ty1' ty2'

522 val' <- subsumes (Just val) ty1' ty2'

522 case val' of

523 case val' of

523− Nothing -> throwError . errorMessage $ SubsumptionCheckFailed

524+ Nothing -> internalError "check: unable to check the subsumes relation."

524 Just _ -> do

525 Just _ -> do

525 val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val

526 val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val

526 return $ TypedValue checkType val''' ty2'

527 return $ TypedValue checkType val''' ty2'

@@ -562,7 +563,7 @@ check' v@(Constructor c) ty = do

562 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

563 repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1

563 mv <- subsumes (Just v) repl ty

564 mv <- subsumes (Just v) repl ty

564 case mv of

565 case mv of

565− Nothing -> throwError . errorMessage $ SubsumptionCheckFailed

566+ Nothing -> internalError "check: unable to check the subsumes relation."

566 Just v' -> return $ TypedValue True v' ty

567 Just v' -> return $ TypedValue True v' ty

567check' (Let ds val) ty = do

568check' (Let ds val) ty = do

568 (ds', val') <- inferLetBinding [] ds val (`check` ty)

569 (ds', val') <- inferLetBinding [] ds val (`check` ty)

@@ -577,7 +578,7 @@ check' val ty = do

577 TypedValue _ val' ty' <- infer val

578 TypedValue _ val' ty' <- infer val

578 mt <- subsumes (Just val') ty' ty

579 mt <- subsumes (Just val') ty' ty

579 case mt of

580 case mt of

580− Nothing -> throwError . errorMessage $ SubsumptionCheckFailed

581+ Nothing -> internalError "check: unable to check the subsumes relation."

581 Just v' -> return $ TypedValue True v' ty

582 Just v' -> return $ TypedValue True v' ty

582

583

583-- |

584-- |

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

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 "Skolemized type variable was not given a 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{} _ = throwError . errorMessage $ UnspecifiedSkolemScope

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"

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)

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

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

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" []