purescript 0.7.5 → 0.7.5.1

raw patch · 50 files changed

+619/−433 lines, 50 filesdep ~base

Dependency ranges changed: base

Files

• examples/failing/1169.purs +12/−0
• examples/failing/1570.purs +6/−0
• examples/failing/ExtraRecordField.purs +1/−2
• examples/failing/MissingRecordField.purs +1/−2
• examples/failing/MutRec.purs +1/−0
• examples/passing/1570.purs +6/−0
• examples/passing/TypedBinders.purs +5/−0
• psc/Main.hs +4/−5
• psci/PSCi.hs +5/−5
• purescript.cabal +3/−1
• src/Control/Monad/Logger.hs +74/−0
• src/Language/PureScript.hs +1/−0
• src/Language/PureScript/AST/Operators.hs +3/−1
• src/Language/PureScript/CodeGen/JS.hs +3/−2
• src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs +2/−1
• src/Language/PureScript/CoreFn/Desugar.hs +4/−3
• src/Language/PureScript/Crash.hs +9/−0
• src/Language/PureScript/Docs/Convert.hs +1/−1
• src/Language/PureScript/Docs/RenderedCode/Render.hs +3/−2
• src/Language/PureScript/Environment.hs +2/−1
• src/Language/PureScript/Errors.hs +216/−198
• src/Language/PureScript/Externs.hs +22/−21
• src/Language/PureScript/Linter.hs +2/−1
• src/Language/PureScript/Linter/Exhaustive.hs +3/−2
• src/Language/PureScript/Make.hs +33/−32
• src/Language/PureScript/ModuleDependencies.hs +2/−1
• src/Language/PureScript/Pretty/JS.hs +3/−2
• src/Language/PureScript/Pretty/Kinds.hs +2/−1
• src/Language/PureScript/Pretty/Types.hs +13/−6
• src/Language/PureScript/Pretty/Values.hs +2/−1
• src/Language/PureScript/Sugar/BindingGroups.hs +17/−15
• src/Language/PureScript/Sugar/CaseDeclarations.hs +3/−2
• src/Language/PureScript/Sugar/DoNotation.hs +2/−1
• src/Language/PureScript/Sugar/Names.hs +2/−1
• src/Language/PureScript/Sugar/Names/Exports.hs +8/−7
• src/Language/PureScript/Sugar/Names/Imports.hs +7/−6
• src/Language/PureScript/Sugar/Operators.hs +3/−2
• src/Language/PureScript/Sugar/TypeClasses.hs +9/−8
• src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +4/−3
• src/Language/PureScript/Sugar/TypeDeclarations.hs +14/−20
• src/Language/PureScript/TypeChecker.hs +15/−14
• src/Language/PureScript/TypeChecker/Entailment.hs +3/−2
• src/Language/PureScript/TypeChecker/Kinds.hs +4/−3
• src/Language/PureScript/TypeChecker/Monad.hs +1/−1
• src/Language/PureScript/TypeChecker/Skolems.hs +11/−5
• src/Language/PureScript/TypeChecker/Subsumption.hs +12/−4
• src/Language/PureScript/TypeChecker/Types.hs +51/−42
• src/Language/PureScript/TypeChecker/Unify.hs +3/−2
• tests/Main.hs +3/−3
• tests/common/TestsSetup.hs +3/−1

@@ -0,0 +1,12 @@+-- @shouldFailWith IncorrectConstructorArity +module Test where++data Outer a = Outer a+            +data Inner a b = Inner a b++test1 :: forall a b. Outer (Inner a b) -> Boolean+test1 (Outer (Inner _)) = true++test2 :: forall a b. Inner a b -> Boolean+test2 (Inner _) = true

@@ -0,0 +1,6 @@+-- @shouldFailWith ExpectedType+module M where++data F a = F a++test = \(x :: F) -> x

@@ -1,5 +1,4 @@--- @shouldFailWith PropertyIsMissing--- TODO: Make this fail with a new error ExtraProperty instead.+-- @shouldFailWith AdditionalProperty module ExtraRecordField where  import Prelude ((<>))

@@ -1,5 +1,4 @@--- @shouldFailWith TypesDoNotUnify--- TODO: Update type checker to make this fail with PropertyIsMissing instead. +-- @shouldFailWith PropertyIsMissing module MissingRecordField where  import Prelude ((>))

@@ -1,4 +1,5 @@ -- @shouldFailWith CycleInDeclaration+-- @shouldFailWith CycleInDeclaration module MutRec where  import Prelude

@@ -0,0 +1,6 @@+module Main where++test :: forall a. a -> a+test = \(x :: a) -> x++main = Control.Monad.Eff.Console.log "Done"

@@ -54,6 +54,11 @@ test4 :: Tuple Int Int -> Tuple Int Int  test4 = (\(Tuple a b :: Tuple Int Int) -> Tuple b a) +type Int1 = Int++test5 :: Int1 -> Int1+test5 = \(x :: Int1) -> x+ main = do   let t1 = test       t2 = test2 id

@@ -71,15 +71,14 @@         hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)       let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, fp)) ms           makeActions = buildMakeActions outputDir filePathMap foreigns usePrefix-      e <- runMake opts $ P.make makeActions (map snd ms)+      (e, warnings') <- runMake opts $ P.make makeActions (map snd ms)+      when (P.nonEmpty warnings') $+        hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings')       case e of         Left errs -> do           hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)           exitFailure-        Right (_, warnings') -> do-          when (P.nonEmpty warnings') $-            hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings')-          exitSuccess+        Right _ -> exitSuccess  warnFileTypeNotFound :: String -> IO () warnFileTypeNotFound = hPutStrLn stderr . ("psc: No files found using pattern: " ++)

@@ -71,7 +71,7 @@ supportModule =   case P.parseModulesFromFiles id [("", code)] of     Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps-    _ -> error "Support module could not be parsed"+    _ -> P.internalError "Support module could not be parsed"   where   code :: String   code = unlines@@ -254,7 +254,7 @@ -- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the -- options and ignores the warning messages. runMake :: P.Make a -> IO (Either P.MultipleErrors a)-runMake mk = fmap (fmap fst) $ P.runMake P.defaultOptions mk+runMake mk = fmap fst $ P.runMake P.defaultOptions mk  makeIO :: (IOError -> P.ErrorMessage) -> IO a -> P.Make a makeIO f io = do@@ -390,7 +390,7 @@         findType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)         showType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> String         showType (mIdent, Just (mType, _, _)) = show mIdent ++ " :: " ++ P.prettyPrintType mType-        showType _ = error "The impossible happened in printModuleSignatures."+        showType _ = P.internalError "The impossible happened in printModuleSignatures."  -- | -- Browse a module and displays its signature (if module exists).@@ -425,7 +425,7 @@       case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of         Just (_, typ') -> do           let chk = P.CheckState env' 0 0 (Just mName)-              k   = fst . runWriter . runExceptT $ L.runStateT (P.unCheck (P.kindOf mName typ')) chk+              k   = fst . runWriter . runExceptT $ L.runStateT (P.unCheck (P.kindOf typ')) chk           case k of             Left errStack   -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack             Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind@@ -482,7 +482,7 @@ handleCommand (BrowseModule moduleName) = handleBrowse moduleName handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules handleCommand (ShowInfo QueryImport) = handleShowImportedModules-handleCommand QuitPSCi = error "`handleCommand QuitPSCi` was called. This is a bug."+handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."  whenFileExists :: FilePath -> (FilePath -> PSCI ()) -> PSCI () whenFileExists filePath f = do

@@ -1,5 +1,5 @@ name: purescript-version: 0.7.5+version: 0.7.5.1 cabal-version: >=1.8 build-type: Simple license: MIT@@ -79,6 +79,7 @@                      Language.PureScript.AST.Traversals                      Language.PureScript.AST.Exported                      Language.PureScript.Bundle+                     Language.PureScript.Crash                      Language.PureScript.Externs                      Language.PureScript.CodeGen                      Language.PureScript.CodeGen.JS@@ -169,6 +170,7 @@                      Language.PureScript.Publish.ErrorsWarnings                      Language.PureScript.Publish.BoxesHelpers +                     Control.Monad.Logger                      Control.Monad.Unify                      Control.Monad.Supply                      Control.Monad.Supply.Class

@@ -0,0 +1,74 @@+-----------------------------------------------------------------------------+--+-- Module      :  Control.Monad.Logger+-- Author      :  Phil Freeman+-- License     :  MIT (http://opensource.org/licenses/MIT)+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- | A replacement for WriterT IO which uses mutable references.+--+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++module Control.Monad.Logger where++import Data.IORef++#if __GLASGOW_HASKELL__ < 710+import Data.Monoid+import Control.Applicative+#endif+import Control.Monad (ap)+import Control.Monad.IO.Class+import Control.Monad.Writer.Class+import Control.Monad.Base (MonadBase(..))+import Control.Monad.Trans.Control (MonadBaseControl(..))++-- | A replacement for WriterT IO which uses mutable references.+data Logger w a = Logger { runLogger :: IORef w -> IO a }++-- | Run a Logger computation, starting with an empty log.+runLogger' :: (Monoid w) => Logger w a -> IO (a, w)+runLogger' l = do+  r <- newIORef mempty+  a <- runLogger l r+  w <- readIORef r+  return (a, w)++instance Functor (Logger w) where+  fmap f (Logger l) = Logger $ \r -> fmap f (l r)++instance (Monoid w) => Applicative (Logger w) where+  pure = Logger . const . pure+  (<*>) = ap++instance (Monoid w) => Monad (Logger w) where+  return = pure+  Logger l >>= f = Logger $ \r -> l r >>= \a -> runLogger (f a) r++instance (Monoid w) => MonadIO (Logger w) where+  liftIO = Logger . const++instance (Monoid w) => MonadWriter w (Logger w) where+  tell w = Logger $ \r -> atomicModifyIORef' r $ \w' -> (mappend w' w, ())+  listen l = Logger $ \r -> do+    (a, w) <- liftIO (runLogger' l)+    atomicModifyIORef' r $ \w' -> (mappend w' w, (a, w))+  pass l = Logger $ \r -> do+    ((a, f), w) <- liftIO (runLogger' l)+    atomicModifyIORef' r $ \w' -> (mappend w' (f w), a)++instance (Monoid w) => MonadBase IO (Logger w) where+  liftBase = liftIO++instance (Monoid w) => MonadBaseControl IO (Logger w) where+  type StM (Logger w) a = a+  liftBaseWith f = Logger $ \r -> liftBaseWith $ \q -> f (q . flip runLogger r)+  restoreM = return

@@ -26,6 +26,7 @@ import Data.Version (Version)  import Language.PureScript.AST as P+import Language.PureScript.Crash as P import Language.PureScript.Comments as P import Language.PureScript.Environment as P import Language.PureScript.Errors as P hiding (indent)

@@ -21,6 +21,8 @@ import Data.Aeson ((.=)) import qualified Data.Aeson as A +import Language.PureScript.Crash+ -- | -- A precedence level for an infix operator --@@ -40,7 +42,7 @@ readAssoc "infixl" = Infixl readAssoc "infixr" = Infixr readAssoc "infix"  = Infix-readAssoc _ = error "readAssoc: no parse"+readAssoc _ = internalError "readAssoc: no parse"  instance A.ToJSON Associativity where   toJSON = A.toJSON . showAssoc

@@ -38,6 +38,7 @@ import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Supply.Class +import Language.PureScript.Crash import Language.PureScript.AST.SourcePos import Language.PureScript.CodeGen.JS.AST as AST import Language.PureScript.CodeGen.JS.Common as Common@@ -272,7 +273,7 @@       go (v:vs) done' (b:bs) = do         done'' <- go vs done' bs         binderToJs v done'' b-      go _ _ _ = error "Invalid arguments to bindersToJs"+      go _ _ _ = internalError "Invalid arguments to bindersToJs"        failedPatternError :: [String] -> JS       failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral errorMessage) (JSArrayLiteral $ zipWith valueError names vals)]@@ -322,7 +323,7 @@       js <- binderToJs argVar done'' binder       return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)   binderToJs _ _ ConstructorBinder{} =-    error "binderToJs: Invalid ConstructorBinder in binderToJs"+    internalError "binderToJs: Invalid ConstructorBinder in binderToJs"   binderToJs varName done (NamedBinder _ ident binder) = do     js <- binderToJs varName done binder     return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)

@@ -17,6 +17,7 @@  import Data.Maybe (fromMaybe) +import Language.PureScript.Crash import Language.PureScript.CodeGen.JS.AST  applyAll :: [a -> a] -> a -> a@@ -63,7 +64,7 @@ targetVariable (JSVar var) = var targetVariable (JSAccessor _ tgt) = targetVariable tgt targetVariable (JSIndexer _ tgt) = targetVariable tgt-targetVariable _ = error "Invalid argument to targetVariable"+targetVariable _ = internalError "Invalid argument to targetVariable"  isUpdated :: String -> JS -> Bool isUpdated var1 = everythingOnJS (||) check

@@ -21,6 +21,7 @@  import Control.Arrow (second, (***)) +import Language.PureScript.Crash import Language.PureScript.AST.SourcePos import Language.PureScript.AST.Traversals import Language.PureScript.CoreFn.Ann@@ -41,7 +42,7 @@ -- moduleToCoreFn :: Environment -> A.Module -> Module Ann moduleToCoreFn _ (A.Module _ _ _ _ Nothing) =-  error "Module exports were not elaborated before moduleToCoreFn"+  internalError "Module exports were not elaborated before moduleToCoreFn" moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =   let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls       exps' = nub $ concatMap exportToCoreFn exps@@ -98,7 +99,7 @@   exprToCoreFn ss com ty (A.Abs (Left name) v) =     Abs (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)   exprToCoreFn _ _ _ (A.Abs _ _) =-    error "Abs with Binder argument was not desugared before exprToCoreFn mn"+    internalError "Abs with Binder argument was not desugared before exprToCoreFn mn"   exprToCoreFn ss com ty (A.App v1 v2) =     App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2)   exprToCoreFn ss com ty (A.Var ident) =@@ -193,7 +194,7 @@     numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env     typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)     typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)-    typeConstructor _ = error "Invalid argument to typeConstructor"+    typeConstructor _ = internalError "Invalid argument to typeConstructor"  -- | -- Find module names from qualified references to values. This is used to

@@ -0,0 +1,9 @@+module Language.PureScript.Crash where++-- | Exit with an error message and a crash report link.+internalError :: String -> a+internalError =+  error+  . ("An internal error ocurred during compilation: " ++)+  . (++ "\nPlease report this at https://github.com/purescript/purescript/issues")+  . show

@@ -157,7 +157,7 @@   convertClassMember (P.TypeDeclaration ident' ty) =     ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty)   convertClassMember _ =-    error "Invalid argument to convertClassMember."+    P.internalError "convertDeclaration: Invalid argument to convertClassMember." convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =   Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))   where

@@ -22,6 +22,7 @@ import Control.Arrow ((<+>)) import Control.PatternArrows +import Language.PureScript.Crash import Language.PureScript.Names import Language.PureScript.Types import Language.PureScript.Kinds@@ -163,7 +164,7 @@ -- renderTypeAtom :: Type -> RenderedCode renderTypeAtom =-  fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . preprocessType defaultRenderTypeOptions+  fromMaybe (internalError "Incomplete pattern") . pattern matchTypeAtom () . preprocessType defaultRenderTypeOptions   -- |@@ -181,4 +182,4 @@  renderTypeWithOptions :: RenderTypeOptions -> Type -> RenderedCode renderTypeWithOptions opts =-  fromMaybe (error "Incomplete pattern") . pattern matchType () . preprocessType opts+  fromMaybe (internalError "Incomplete pattern") . pattern matchType () . preprocessType opts

@@ -25,6 +25,7 @@ import qualified Data.Text as T import qualified Data.Aeson as A +import Language.PureScript.Crash import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.TypeClassDictionaries@@ -252,7 +253,7 @@ -- lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident]) lookupConstructor env ctor =-  fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors env+  fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env  -- | -- Checks whether a data constructor is for a newtype.

@@ -20,7 +20,7 @@ module Language.PureScript.Errors where  import Data.Either (lefts, rights)-import Data.List (intercalate, transpose, nub, nubBy, partition)+import Data.List (intercalate, transpose, nub, nubBy) import Data.Function (on) #if __GLASGOW_HASKELL__ < 710 import Data.Foldable (fold, foldMap)@@ -41,8 +41,8 @@ import Control.Monad.Trans.State.Lazy import Control.Arrow(first) +import Language.PureScript.Crash import Language.PureScript.AST-import Language.PureScript.Environment (isObject, isFunction) import Language.PureScript.Pretty import Language.PureScript.Types import Language.PureScript.Names@@ -56,19 +56,16 @@  -- | A type of error messages data SimpleErrorMessage-  = ErrorParsingExterns P.ParseError-  | ErrorParsingFFIModule FilePath+  = ErrorParsingFFIModule FilePath   | ErrorParsingModule P.ParseError   | MissingFFIModule ModuleName   | MultipleFFIModules ModuleName [FilePath]   | UnnecessaryFFIModule ModuleName FilePath-  | InvalidExternsFile FilePath   | CannotGetFileInfo FilePath   | CannotReadFile FilePath   | CannotWriteFile FilePath   | InfiniteType Type   | InfiniteKind Kind-  | CannotReorderOperators   | MultipleFixities Ident   | OrphanTypeDeclaration Ident   | OrphanFixityDeclaration String@@ -108,11 +105,9 @@   | CycleInTypeSynonym (Maybe ProperName)   | CycleInModules [ModuleName]   | NameIsUndefined Ident-  | NameNotInScope Ident   | UndefinedTypeVariable ProperName   | PartiallyAppliedSynonym (Qualified ProperName)   | EscapedSkolem (Maybe Expr)-  | UnspecifiedSkolemScope   | TypesDoNotUnify Type Type   | KindsDoNotUnify Kind Kind   | ConstrainedTypeUnified Type Type@@ -126,23 +121,23 @@   | ArgListLengthsDiffer Ident   | OverlappingArgNames (Maybe Ident)   | MissingClassMember Ident-  | ExtraneousClassMember Ident+  | ExtraneousClassMember Ident (Qualified ProperName)   | ExpectedType Type Kind   | IncorrectConstructorArity (Qualified ProperName)-  | SubsumptionCheckFailed   | ExprDoesNotHaveType Expr Type-  | PropertyIsMissing String Type+  | PropertyIsMissing String+  | AdditionalProperty String   | CannotApplyFunction Type Expr   | TypeSynonymInstance   | OrphanInstance Ident (Qualified ProperName) [Type]-  | InvalidNewtype+  | InvalidNewtype ProperName   | InvalidInstanceHead Type   | TransitiveExportError DeclarationRef [DeclarationRef]   | ShadowedName Ident   | ShadowedTypeVar String   | UnusedTypeVar String   | WildcardInferredType Type-  | MissingTypeDeclaration Ident+  | MissingTypeDeclaration Ident Type   | NotExhaustivePattern [[Binder]] Bool   | OverlappingPattern [[Binder]] Bool   | IncompleteExhaustivityCheck@@ -153,12 +148,12 @@  -- | Error message hints, providing more detailed information about failure. data ErrorMessageHint-  = NotYetDefined [Ident]-  | ErrorUnifyingTypes Type Type+  = ErrorUnifyingTypes Type Type   | ErrorInExpression Expr   | ErrorInModule ModuleName   | ErrorInInstance (Qualified ProperName) [Type]   | ErrorInSubsumption Type Type+  | ErrorCheckingAccessor Expr String   | ErrorCheckingType Expr Type   | ErrorCheckingKind Type   | ErrorInferringType Expr@@ -196,19 +191,16 @@ -- errorCode :: ErrorMessage -> String errorCode em = case unwrapErrorMessage em of-  ErrorParsingExterns{} -> "ErrorParsingExterns"   ErrorParsingFFIModule{} -> "ErrorParsingFFIModule"   ErrorParsingModule{} -> "ErrorParsingModule"   MissingFFIModule{} -> "MissingFFIModule"   MultipleFFIModules{} -> "MultipleFFIModules"   UnnecessaryFFIModule{} -> "UnnecessaryFFIModule"-  InvalidExternsFile{} -> "InvalidExternsFile"   CannotGetFileInfo{} -> "CannotGetFileInfo"   CannotReadFile{} -> "CannotReadFile"   CannotWriteFile{} -> "CannotWriteFile"   InfiniteType{} -> "InfiniteType"   InfiniteKind{} -> "InfiniteKind"-  CannotReorderOperators -> "CannotReorderOperators"   MultipleFixities{} -> "MultipleFixities"   OrphanTypeDeclaration{} -> "OrphanTypeDeclaration"   OrphanFixityDeclaration{} -> "OrphanFixityDeclaration"@@ -248,11 +240,9 @@   CycleInTypeSynonym{} -> "CycleInTypeSynonym"   CycleInModules{} -> "CycleInModules"   NameIsUndefined{} -> "NameIsUndefined"-  NameNotInScope{} -> "NameNotInScope"   UndefinedTypeVariable{} -> "UndefinedTypeVariable"   PartiallyAppliedSynonym{} -> "PartiallyAppliedSynonym"   EscapedSkolem{} -> "EscapedSkolem"-  UnspecifiedSkolemScope -> "UnspecifiedSkolemScope"   TypesDoNotUnify{} -> "TypesDoNotUnify"   KindsDoNotUnify{} -> "KindsDoNotUnify"   ConstrainedTypeUnified{} -> "ConstrainedTypeUnified"@@ -269,13 +259,13 @@   ExtraneousClassMember{} -> "ExtraneousClassMember"   ExpectedType{} -> "ExpectedType"   IncorrectConstructorArity{} -> "IncorrectConstructorArity"-  SubsumptionCheckFailed -> "SubsumptionCheckFailed"   ExprDoesNotHaveType{} -> "ExprDoesNotHaveType"   PropertyIsMissing{} -> "PropertyIsMissing"+  AdditionalProperty{} -> "AdditionalProperty"   CannotApplyFunction{} -> "CannotApplyFunction"   TypeSynonymInstance -> "TypeSynonymInstance"   OrphanInstance{} -> "OrphanInstance"-  InvalidNewtype -> "InvalidNewtype"+  InvalidNewtype{} -> "InvalidNewtype"   InvalidInstanceHead{} -> "InvalidInstanceHead"   TransitiveExportError{} -> "TransitiveExportError"   ShadowedName{} -> "ShadowedName"@@ -362,7 +352,6 @@     gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2     gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2     gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t-    gSimple (PropertyIsMissing s t) = PropertyIsMissing s <$> f t     gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e     gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t     gSimple other = pure other@@ -377,17 +366,18 @@ -- Pretty print a single error, simplifying if necessary -- prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box-prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFirst . reverseHints <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)- where+prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)+  where    -- Pretty print an ErrorMessage   prettyPrintErrorMessage :: ErrorMessage -> Box.Box   prettyPrintErrorMessage (ErrorMessage hints simple) =     paras $-      map renderHint hints ++-      renderSimpleErrorMessage simple :-      suggestions simple ++-      [line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this " ++ levelText ++ "."]+      [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints+      , Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri ++ " for more information, "+                               , line $ "or to contribute content related to this " ++ levelText ++ "."+                               ]+      ]     where     wikiUri :: String     wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e@@ -405,12 +395,8 @@       paras [ line "Unable to write file: "             , indent . line $ path             ]-    renderSimpleErrorMessage (ErrorParsingExterns err) =-      paras [ lineWithLevel "parsing externs files: "-            , prettyPrintParseError err-            ]     renderSimpleErrorMessage (ErrorParsingFFIModule path) =-      paras [ line "Unable to parse module from FFI file: "+      paras [ line "Unable to parse foreign module:"             , indent . line $ path             ]     renderSimpleErrorMessage (ErrorParsingModule err) =@@ -418,29 +404,22 @@             , prettyPrintParseError err             ]     renderSimpleErrorMessage (MissingFFIModule mn) =-      line $ "Missing FFI implementations for module " ++ runModuleName mn+      line $ "The foreign module implementation for module " ++ runModuleName mn ++ " is missing."     renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =-      paras [ line $ "Unnecessary FFI implementations have been provided for module " ++ runModuleName mn ++ ": "+      paras [ line $ "An unnecessary foreign module implementation was provided for module " ++ runModuleName mn ++ ": "             , indent . line $ path+            , line $ "Module " ++ runModuleName mn ++ " does not contain any foreign import declarations, so a foreign module is not necessary."             ]     renderSimpleErrorMessage (MultipleFFIModules mn paths) =-      paras [ line $ "Multiple FFI implementations have been provided for module " ++ runModuleName mn ++ ": "+      paras [ line $ "Multiple foreign module implementations have been provided for module " ++ runModuleName mn ++ ": "             , indent . paras $ map line paths             ]-    renderSimpleErrorMessage (InvalidExternsFile path) =-      paras [ line "Externs file is invalid: "-            , indent . line $ path-            ]     renderSimpleErrorMessage InvalidDoBind =-      line "Bind statement cannot be the last statement in a do block. The last statement must be an expression."+      line "The last statement in a 'do' block must be an expression, but this block ends with a binder."     renderSimpleErrorMessage InvalidDoLet =-      line "Let statement cannot be the last statement in a do block. The last statement must be an expression."-    renderSimpleErrorMessage CannotReorderOperators =-      line "Unable to reorder operators"-    renderSimpleErrorMessage UnspecifiedSkolemScope =-      line "Skolem variable scope is unspecified"+      line "The last statement in a 'do' block must be an expression, but this block ends with a let binding."     renderSimpleErrorMessage OverlappingNamesInLet =-      line "Overlapping names in let binding."+      line "The same name was used more than once in a let binding."     renderSimpleErrorMessage (InfiniteType ty) =       paras [ line "An infinite type was inferred for an expression: "             , indent $ typeAsBox ty@@ -450,17 +429,17 @@             , indent $ line $ prettyPrintKind ki             ]     renderSimpleErrorMessage (MultipleFixities name) =-      line $ "Multiple fixity declarations for " ++ showIdent name+      line $ "There are multiple fixity/precedence declarations for " ++ showIdent name     renderSimpleErrorMessage (OrphanTypeDeclaration nm) =-      line $ "Orphan type declaration for " ++ showIdent nm+      line $ "The type declaration for " ++ showIdent nm ++ " should be followed by its definition."     renderSimpleErrorMessage (OrphanFixityDeclaration op) =-      line $ "Orphan fixity declaration for " ++ show op+      line $ "The fixity/precedence declaration for " ++ show op ++ " should appear in the same module as its definition."     renderSimpleErrorMessage (RedefinedModule name filenames) =-      paras [ line ("Module " ++ runModuleName name ++ " has been defined multiple times:")+      paras [ line ("The module " ++ runModuleName name ++ " has been defined multiple times:")             , indent . paras $ map (line . displaySourceSpan) filenames             ]     renderSimpleErrorMessage (RedefinedIdent name) =-      line $ "Name " ++ showIdent name ++ " has been defined multiple times"+      line $ "The value " ++ showIdent name ++ " has been defined multiple times"     renderSimpleErrorMessage (UnknownModule mn) =       line $ "Unknown module " ++ runModuleName mn     renderSimpleErrorMessage (UnknownType name) =@@ -474,25 +453,36 @@     renderSimpleErrorMessage (UnknownDataConstructor dc tc) =       line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc     renderSimpleErrorMessage (UnknownImportType mn name) =-      line $ "Module " ++ runModuleName mn ++ " does not export type " ++ runProperName name+      paras [ line $ "Cannot import type " ++ runProperName name ++ " from module " ++ runModuleName mn+            , line "It either does not exist or the module does not export it."+            ]     renderSimpleErrorMessage (UnknownExportType name) =       line $ "Cannot export unknown type " ++ runProperName name     renderSimpleErrorMessage (UnknownImportTypeClass mn name) =-      line $ "Module " ++ runModuleName mn ++ " does not export type class " ++ runProperName name+      paras [ line $ "Cannot import type class " ++ runProperName name ++ " from module " ++ runModuleName mn+            , line "It either does not exist or the module does not export it."+            ]     renderSimpleErrorMessage (UnknownExportTypeClass name) =       line $ "Cannot export unknown type class " ++ runProperName name     renderSimpleErrorMessage (UnknownImportValue mn name) =-      line $ "Module " ++ runModuleName mn ++ " does not export value " ++ showIdent name+      paras [ line $ "Cannot import value " ++ showIdent name ++ " from module " ++ runModuleName mn+            , line "It either does not exist or the module does not export it."+            ]     renderSimpleErrorMessage (UnknownExportValue name) =       line $ "Cannot export unknown value " ++ showIdent name     renderSimpleErrorMessage (UnknownExportModule name) =-      line $ "Cannot export unknown module " ++ runModuleName name ++ ", it either does not exist or has not been imported by the current module"+      paras [ line $ "Cannot export unknown module " ++ runModuleName name+            , line "It either does not exist or has not been imported by the current module."+            ]     renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) =       line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon     renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) =-      line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ " as it has not been declared"+      line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ ", as it has not been declared."     renderSimpleErrorMessage (ConflictingImport nm mn) =-      line $ "Cannot declare " ++ show nm ++ " since another declaration of that name was imported from " ++ runModuleName mn+      paras [ line $ "Cannot declare " ++ show nm ++ ", since another declaration of that name was imported from module " ++ runModuleName mn+            , line $ "Consider hiding " ++ show nm ++ " when importing " ++ runModuleName mn ++ ":"+            , indent . line $ "import " ++ runModuleName mn ++ " hiding (" ++ nm ++ ")"+            ]     renderSimpleErrorMessage (ConflictingImports nm m1 m2) =       line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2     renderSimpleErrorMessage (ConflictingTypeDecls nm) =@@ -500,13 +490,13 @@     renderSimpleErrorMessage (ConflictingCtorDecls nm) =       line $ "Conflicting data constructor declarations for " ++ runProperName nm     renderSimpleErrorMessage (TypeConflictsWithClass nm) =-      line $ "Type " ++ runProperName nm ++ " conflicts with type class declaration of the same name"+      line $ "Type " ++ runProperName nm ++ " conflicts with a type class declaration with the same name."     renderSimpleErrorMessage (CtorConflictsWithClass nm) =-      line $ "Data constructor " ++ runProperName nm ++ " conflicts with type class declaration of the same name"+      line $ "Data constructor " ++ runProperName nm ++ " conflicts with a type class declaration with the same name."     renderSimpleErrorMessage (ClassConflictsWithType nm) =-      line $ "Type class " ++ runProperName nm ++ " conflicts with type declaration of the same name"+      line $ "Type class " ++ runProperName nm ++ " conflicts with a type declaration with the same name."     renderSimpleErrorMessage (ClassConflictsWithCtor nm) =-      line $ "Type class " ++ runProperName nm ++ " conflicts with data constructor declaration of the same name"+      line $ "Type class " ++ runProperName nm ++ " conflicts with a data constructor declaration with the same name."     renderSimpleErrorMessage (DuplicateModuleName mn) =       line $ "Module " ++ runModuleName mn ++ " has been defined multiple times."     renderSimpleErrorMessage (DuplicateClassExport nm) =@@ -514,19 +504,24 @@     renderSimpleErrorMessage (DuplicateValueExport nm) =       line $ "Duplicate export declaration for value " ++ showIdent nm     renderSimpleErrorMessage (CycleInDeclaration nm) =-      line $ "Cycle in declaration of " ++ showIdent nm+      line $ "The value of " ++ showIdent nm ++ " is undefined here, so this reference is not allowed."     renderSimpleErrorMessage (CycleInModules mns) =-      line $ "Cycle in module dependencies: " ++ intercalate ", " (map runModuleName mns)-    renderSimpleErrorMessage (CycleInTypeSynonym pn) =-      line $ "Cycle in type synonym" ++ foldMap ((" " ++) . runProperName) pn+      paras [ line $ "There is a cycle in module dependencies in these modules: "+            , indent $ paras (map (line . runModuleName) mns)+            ]+    renderSimpleErrorMessage (CycleInTypeSynonym name) =+      paras [ line $ case name of+                       Just pn -> "A cycle appears in the definition of type synonym " ++ runProperName pn+                       Nothing -> "A cycle appears in a set of type synonym definitions."+            , line "Cycles are disallowed because they can lead to loops in the type checker."+            , line "Consider using a 'newtype' instead."+            ]     renderSimpleErrorMessage (NameIsUndefined ident) =-      line $ showIdent ident ++ " is undefined"-    renderSimpleErrorMessage (NameNotInScope ident) =-      line $ showIdent ident ++ " may not be defined in the current scope"+      line $ "Value " ++ showIdent ident ++ " is undefined."     renderSimpleErrorMessage (UndefinedTypeVariable name) =-      line $ "Type variable " ++ runProperName name ++ " is undefined"+      line $ "Type variable " ++ runProperName name ++ " is undefined."     renderSimpleErrorMessage (PartiallyAppliedSynonym name) =-      paras [ line $ "Partially applied type synonym " ++ showQualified runProperName name+      paras [ line $ "Type synonym " ++ showQualified runProperName name ++ " is partially applied."             , line "Type synonyms must be applied to all of their type arguments."             ]     renderSimpleErrorMessage (EscapedSkolem binding) =@@ -535,70 +530,72 @@                                           , indent $ prettyPrintValue expr                                           ]) binding     renderSimpleErrorMessage (TypesDoNotUnify t1 t2)-      = paras [ line "Cannot unify type"+      = paras [ line "Could not match expected type"               , indent $ typeAsBox t1-              , line "with type"+              , line "with actual type"               , indent $ typeAsBox t2               ]     renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =-      paras [ line "Cannot unify kind"+      paras [ line "Could not match expected kind"             , indent $ line $ prettyPrintKind k1-            , line "with kind"+            , line "with actual kind"             , indent $ line $ prettyPrintKind k2             ]     renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) =-      paras [ line "Cannot unify constrained type"+      paras [ line "Could not match constrained type"             , indent $ typeAsBox t1             , line "with type"             , indent $ typeAsBox t2             ]     renderSimpleErrorMessage (OverlappingInstances nm ts (d : ds)) =-      paras [ line "Overlapping instances found for"+      paras [ line "Overlapping type class instances found for"             , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)                                            , Box.vcat Box.left (map typeAtomAsBox ts)                                            ]             , line "The following instances were found:"             , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds)+            , line "Overlapping type class instances can lead to different behavior based on the order of module imports, and for that reason are not recommended."+            , line "They may be disallowed completely in a future version of the compiler."             ]-    renderSimpleErrorMessage OverlappingInstances{} = error "OverlappingInstances: empty instance list"+    renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list"     renderSimpleErrorMessage (NoInstanceFound nm ts) =-      paras [ line "No instance found for"+      paras [ line "No type class instance was found for"             , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)                                            , Box.vcat Box.left (map typeAtomAsBox ts)                                            ]             ]     renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =-      paras [ line "Instance for"+      paras [ line "Type class instance for"             , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)                                            , Box.vcat Box.left (map typeAtomAsBox ts)                                            ]             , line "is possibly infinite."             ]     renderSimpleErrorMessage (CannotDerive nm ts) =-      paras [ line "Cannot derive an instance for"+      paras [ line "Cannot derive a type class instance for"             , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)                                            , Box.vcat Box.left (map typeAtomAsBox ts)                                            ]             ]     renderSimpleErrorMessage (CannotFindDerivingType nm) =-      line $ "Cannot derive instance, because the type declaration for " ++ runProperName nm ++ " could not be found."+      line $ "Cannot derive a type class instance, because the type declaration for " ++ runProperName nm ++ " could not be found."     renderSimpleErrorMessage (DuplicateLabel l expr) =-      paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]+      paras $ [ line $ "Label " ++ show l ++ " appears more than once in a row type." ]                        <> foldMap (\expr' -> [ line "Relevant expression: "                                              , indent $ prettyPrintValue expr'                                              ]) expr     renderSimpleErrorMessage (DuplicateTypeArgument name) =-      line $ "Duplicate type argument " ++ show name+      line $ "Type argument " ++ show name ++ " appears more than once."     renderSimpleErrorMessage (DuplicateValueDeclaration nm) =-      line $ "Duplicate value declaration for " ++ showIdent nm+      line $ "Multiple value declarations exist for " ++ showIdent nm ++ "."     renderSimpleErrorMessage (ArgListLengthsDiffer ident) =       line $ "Argument list lengths differ in declaration " ++ showIdent ident     renderSimpleErrorMessage (OverlappingArgNames ident) =       line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . showIdent) ident     renderSimpleErrorMessage (MissingClassMember ident) =-      line $ "Member " ++ showIdent ident ++ " has not been implemented"-    renderSimpleErrorMessage (ExtraneousClassMember ident) =-      line $ "Member " ++ showIdent ident ++ " is not a member of the class being instantiated"+      line $ "Type class member " ++ showIdent ident ++ " has not been implemented."+    renderSimpleErrorMessage (ExtraneousClassMember ident className) =+      line $ showIdent ident ++ " is not a member of type class " ++ showQualified runProperName className     renderSimpleErrorMessage (ExpectedType ty kind) =       paras [ line "In a type-annotated expression x :: t, the type t must have kind *."             , line "The error arises from the type"@@ -608,29 +605,27 @@             , line "instead."             ]     renderSimpleErrorMessage (IncorrectConstructorArity nm) =-      line $ "Wrong number of arguments to constructor " ++ showQualified runProperName nm-    renderSimpleErrorMessage SubsumptionCheckFailed = line "Unable to check type subsumption"+      line $ "Data constructor " ++ showQualified runProperName nm ++ " was given the wrong number of arguments in a case expression."     renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) =       paras [ line "Expression"             , indent $ prettyPrintValue expr             , line "does not have type"             , indent $ typeAsBox ty             ]-    renderSimpleErrorMessage (PropertyIsMissing prop row) =-      paras [ line "Row"-            , indent $ prettyPrintRowWith '(' ')' row-            , line $ "lacks required property " ++ show prop-            ]+    renderSimpleErrorMessage (PropertyIsMissing prop) =+      line $ "Type of expression lacks required label " ++ show prop ++ "."+    renderSimpleErrorMessage (AdditionalProperty prop) =+      line $ "Type of expression contains additional label " ++ show prop ++ "."     renderSimpleErrorMessage (CannotApplyFunction fn arg) =-      paras [ line "Cannot apply function of type"+      paras [ line "A function of type"             , indent $ typeAsBox fn-            , line "to argument"+            , line "can not be applied to the argument"             , indent $ prettyPrintValue arg             ]     renderSimpleErrorMessage TypeSynonymInstance =-      line "Type synonym instances are disallowed"+      line "Type class instances for type synonyms are disallowed."     renderSimpleErrorMessage (OrphanInstance nm cnm ts) =-      paras [ line $ "Instance " ++ showIdent nm ++ " for "+      paras [ line $ "Type class instance " ++ showIdent nm ++ " for "             , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm)                                            , Box.vcat Box.left (map typeAtomAsBox ts)                                            ]@@ -638,39 +633,44 @@             , line "An orphan instance is an instance which is defined in neither the class module nor the data type module."             , line "Consider moving the instance, if possible, or using a newtype wrapper."             ]-    renderSimpleErrorMessage InvalidNewtype =-      line "Newtypes must define a single constructor with a single argument"+    renderSimpleErrorMessage (InvalidNewtype name) =+      paras [ line $ "Newtype " ++ runProperName name ++ " is invalid."+            , line "Newtypes must define a single constructor with a single argument."+            ]     renderSimpleErrorMessage (InvalidInstanceHead ty) =-      paras [ line "Invalid type in class instance head:"+      paras [ line "Type class instance head is invalid due to use of type"             , indent $ typeAsBox ty+            , 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."             ]     renderSimpleErrorMessage (TransitiveExportError x ys) =       paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")               : map (line . prettyPrintExport) ys     renderSimpleErrorMessage (ShadowedName nm) =-      line $ "Name '" ++ showIdent nm ++ "' was shadowed"+      line $ "Name '" ++ showIdent nm ++ "' was shadowed."     renderSimpleErrorMessage (ShadowedTypeVar tv) =-      line $ "Type variable '" ++ tv ++ "' was shadowed"+      line $ "Type variable '" ++ tv ++ "' was shadowed."     renderSimpleErrorMessage (UnusedTypeVar tv) =-      line $ "Type variable '" ++ tv ++ "' was declared but not used"+      line $ "Type variable '" ++ tv ++ "' was declared but not used."     renderSimpleErrorMessage (ClassOperator className opName) =-      paras [ line $ "Class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "."+      paras [ line $ "Type class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "."             , line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"             , indent . line $ showIdent opName ++ " = someMember"             ]     renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) =-      line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors"+      line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors."     renderSimpleErrorMessage (ImportHidingModule name) =-      line $ "Attempted to hide module " ++ runModuleName name ++ " in import expression, this is not permitted"+      paras [ line $ "'hiding' imports cannot be used to hide modules."+            , line $ "An attempt was made to hide the import of " ++ runModuleName name+            ]     renderSimpleErrorMessage (WildcardInferredType ty) =-      paras [ line "The wildcard type definition has the inferred type "+      paras [ line "Wildcard type definition has the inferred type "             , indent $ typeAsBox ty             ]-    renderSimpleErrorMessage (MissingTypeDeclaration ident) =+    renderSimpleErrorMessage (MissingTypeDeclaration ident ty) =       paras [ line $ "No type declaration was provided for the top-level declaration of " ++ showIdent ident ++ "."             , line "It is good practice to provide type declarations as a form of documentation."-            , line "Consider using a type wildcard to display the inferred type:"-            , indent $ line $ showIdent ident ++ " :: _"+            , line $ "The inferred type of " ++ showIdent ident ++ " was:"+            , indent $ typeAsBox ty             ]     renderSimpleErrorMessage (NotExhaustivePattern bs b) =       paras $ [ line "A case expression could not be determined to cover all inputs."@@ -685,95 +685,126 @@               [ line "..." | not b ]     renderSimpleErrorMessage IncompleteExhaustivityCheck =       paras [ line "An exhaustivity check was abandoned due to too many possible cases."-            , line "You may want to decomposing your data types into smaller types."+            , line "You may want to decompose your data types into smaller types."             ] -    renderHint :: ErrorMessageHint -> Box.Box-    renderHint (NotYetDefined names) =-      line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"-    renderHint (ErrorUnifyingTypes t1 t2) =-      paras [ lineWithLevel "unifying type "-            , indent $ typeAsBox t1-            , line "with type"-            , indent $ typeAsBox t2+    renderHint :: ErrorMessageHint -> Box.Box -> Box.Box+    renderHint (ErrorUnifyingTypes t1 t2) detail =+      paras [ detail+            , Box.hsep 1 Box.top [ line "while trying to match type"+                                 , typeAsBox t1+                                 ]+            , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "with type"+                                                   , typeAsBox t2+                                                   ]             ]-    renderHint (ErrorInExpression expr) =-      paras [ lineWithLevel "in expression:"-            , indent $ prettyPrintValue expr+    renderHint (ErrorInExpression expr) detail =+      paras [ detail+            , Box.hsep 1 Box.top [ Box.text "in the expression"+                                 , prettyPrintValue expr+                                 ]             ]-    renderHint (ErrorInModule mn) =-      paras [ lineWithLevel $ "in module " ++ runModuleName mn ++ ":"+    renderHint (ErrorInModule mn) detail =+      paras [ line $ "in module " ++ runModuleName mn+            , detail             ]-    renderHint (ErrorInSubsumption t1 t2) =-      paras [ lineWithLevel "checking that type "-            , indent $ typeAsBox t1-            , line "subsumes type"-            , indent $ typeAsBox t2+    renderHint (ErrorInSubsumption t1 t2) detail =+      paras [ detail+            , Box.hsep 1 Box.top [ line "while checking that type"+                                 , typeAsBox t1+                                 ]+            , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "is at least as general as type"+                                                   , typeAsBox t2+                                                   ]             ]-    renderHint (ErrorInInstance nm ts) =-      paras [ lineWithLevel "in type class instance"-            , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)-                                           , Box.vcat Box.left (map typeAtomAsBox ts)-                                           ]+    renderHint (ErrorInInstance nm ts) detail =+      paras [ detail+            , Box.hsep 1 Box.top [ line "in type class instance"+                                 , line (showQualified runProperName nm)+                                 , Box.vcat Box.left (map typeAtomAsBox ts)+                                 ]             ]-    renderHint (ErrorCheckingKind ty) =-      paras [ lineWithLevel "checking kind of type "-            , indent $ typeAsBox ty+    renderHint (ErrorCheckingKind ty) detail =+      paras [ detail+            , Box.hsep 1 Box.top [ line "while checking the kind of"+                                 , typeAsBox ty+                                 ]             ]-    renderHint (ErrorInferringType expr) =-      paras [ lineWithLevel "inferring type of value "-            , indent $ prettyPrintValue expr+    renderHint (ErrorInferringType expr) detail =+      paras [ detail+            , Box.hsep 1 Box.top [ line "while inferring the type of"+                                 , prettyPrintValue expr+                                 ]             ]-    renderHint (ErrorCheckingType expr ty) =-      paras [ lineWithLevel "checking that value "-            , indent $ prettyPrintValue expr-            , line "has type"-            , indent $ typeAsBox ty+    renderHint (ErrorCheckingType expr ty) detail =+      paras [ detail+            , Box.hsep 1 Box.top [ line "while checking that expression"+                                 , prettyPrintValue expr+                                 ]+            , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "has type"+                                                   , typeAsBox ty+                                                   ]             ]-    renderHint (ErrorInApplication f t a) =-      paras [ lineWithLevel "applying function"-            , indent $ prettyPrintValue f-            , line "of type"-            , indent $ typeAsBox t-            , line "to argument"-            , indent $ prettyPrintValue a+    renderHint (ErrorCheckingAccessor expr prop) detail =+      paras [ detail+            , Box.hsep 1 Box.top [ line "while checking type of property accessor"+                                 , prettyPrintValue (Accessor prop expr)+                                 ]             ]-    renderHint (ErrorInDataConstructor nm) =-      lineWithLevel $ "in data constructor " ++ runProperName nm ++ ":"-    renderHint (ErrorInTypeConstructor nm) =-      lineWithLevel $ "in type constructor " ++ runProperName nm ++ ":"-    renderHint (ErrorInBindingGroup nms) =-      lineWithLevel $ "in binding group " ++ intercalate ", " (map showIdent nms) ++ ":"-    renderHint ErrorInDataBindingGroup =-      lineWithLevel "in data binding group:"-    renderHint (ErrorInTypeSynonym name) =-      lineWithLevel $ "in type synonym " ++ runProperName name ++ ":"-    renderHint (ErrorInValueDeclaration n) =-      lineWithLevel $ "in value declaration " ++ showIdent n ++ ":"-    renderHint (ErrorInTypeDeclaration n) =-      lineWithLevel $ "in type declaration for " ++ showIdent n ++ ":"-    renderHint (ErrorInForeignImport nm) =-      lineWithLevel $ "in foreign import " ++ showIdent nm ++ ":"-    renderHint (PositionedError srcSpan) =-      lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":"--  lineWithLevel :: String -> Box.Box-  lineWithLevel text = line $ show level ++ " " ++ text+    renderHint (ErrorInApplication f t a) detail =+      paras [ detail+            , Box.hsep 1 Box.top [ line "while applying a function"+                                 , prettyPrintValue f+                                 ]+            , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "of type"+                                                   , typeAsBox t+                                                   ]+            , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "to argument"+                                                   , prettyPrintValue a+                                                   ]+            ]+    renderHint (ErrorInDataConstructor nm) detail =+      paras [ detail+            , line $ "in data constructor " ++ runProperName nm+            ]+    renderHint (ErrorInTypeConstructor nm) detail =+      paras [ detail+            , line $ "in type constructor " ++ runProperName nm+            ]+    renderHint (ErrorInBindingGroup nms) detail =+      paras [ detail+            , line $ "in binding group " ++ intercalate ", " (map showIdent nms)+            ]+    renderHint ErrorInDataBindingGroup detail =+      paras [ detail+            , line "in data binding group"+            ]+    renderHint (ErrorInTypeSynonym name) detail =+      paras [ detail+            , line $ "in type synonym " ++ runProperName name+            ]+    renderHint (ErrorInValueDeclaration n) detail =+      paras [ detail+            , line $ "in value declaration " ++ showIdent n+            ]+    renderHint (ErrorInTypeDeclaration n) detail =+      paras [ detail+            , line $ "in type declaration for " ++ showIdent n+            ]+    renderHint (ErrorInForeignImport nm) detail =+      paras [ detail+            , line $ "in foreign import " ++ showIdent nm+            ]+    renderHint (PositionedError srcSpan) detail =+      paras [ line $ "at " ++ displaySourceSpan srcSpan+            , detail+            ]    levelText :: String   levelText = case level of     Error -> "error"     Warning -> "warning" -  suggestions :: SimpleErrorMessage -> [Box.Box]-  suggestions (ConflictingImport nm im) = [ line $ "Possible fix: hide " ++ show nm ++ " when importing " ++ runModuleName im ++ ":"-                                             , indent . line $ "import " ++ runModuleName im ++ " hiding (" ++ nm ++ ")"-                                             ]-  suggestions (TypesDoNotUnify t1 t2)-    | isObject t1 && isFunction t2 = [line "Note that function composition in PureScript is defined using (<<<)"]-    | otherwise             = []-  suggestions _ = []-   paras :: [Box.Box] -> Box.Box   paras = Box.vcat Box.left @@ -785,19 +816,6 @@   prettyPrintExport (TypeInstanceRef ident) = showIdent ident   prettyPrintExport (ModuleRef name) = "module " ++ runModuleName name   prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref--  -- Hints get added at the front, so we need to reverse them before rendering-  reverseHints :: ErrorMessage -> ErrorMessage-  reverseHints (ErrorMessage hints simple) = ErrorMessage (reverse hints) simple--  -- | Put positional hints at the front of the list-  positionHintsFirst :: ErrorMessage -> ErrorMessage-  positionHintsFirst (ErrorMessage hints simple) = ErrorMessage (uncurry (++) $ partition (isPositionHint . hintCategory) hints) simple-    where-    isPositionHint :: HintCategory -> Bool-    isPositionHint PositionHint = True-    isPositionHint OtherHint = True-    isPositionHint _ = False    -- | Simplify an error message   simplifyErrorMessage :: ErrorMessage -> ErrorMessage

@@ -38,6 +38,7 @@  import qualified Data.Map as M +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Environment import Language.PureScript.Names@@ -50,57 +51,57 @@ -- | The data which will be serialized to an externs file data ExternsFile = ExternsFile   {-  -- ^ The externs version+  -- | The externs version     efVersion :: String-  -- ^ Module name+  -- | Module name   , efModuleName :: ModuleName-  -- ^ List of module exports+  -- | List of module exports   , efExports :: [DeclarationRef]-  -- ^ List of module imports+  -- | List of module imports   , efImports :: [ExternsImport]-  -- ^ List of operators and their fixities+  -- | List of operators and their fixities   , efFixities :: [ExternsFixity]-  -- ^ List of type and value declaration+  -- | List of type and value declaration   , efDeclarations :: [ExternsDeclaration]   } deriving (Show, Read)  -- | A module import in an externs file data ExternsImport = ExternsImport   {-  -- ^ The imported module+  -- | The imported module     eiModule :: ModuleName-  -- ^ The import type: regular, qualified or hiding+  -- | The import type: regular, qualified or hiding   , eiImportType :: ImportDeclarationType-  -- ^ The imported-as name, for qualified imports+  -- | The imported-as name, for qualified imports   , eiImportedAs :: Maybe ModuleName   } deriving (Show, Read)  -- | A fixity declaration in an externs file data ExternsFixity = ExternsFixity   {-  -- ^ The associativity of the operator+  -- | The associativity of the operator     efAssociativity :: Associativity-  -- ^ The precedence level of the operator+  -- | The precedence level of the operator   , efPrecedence :: Precedence-  -- ^ The operator symbol+  -- | The operator symbol   , efOperator :: String   } deriving (Show, Read)  -- | A type or value declaration appearing in an externs file data ExternsDeclaration =-  -- ^ A type declaration+  -- | A type declaration     EDType       { edTypeName :: ProperName       , edTypeKind :: Kind       , edTypeDeclarationKind :: TypeKind       }-  -- ^ A type synonym+  -- | A type synonym   | EDTypeSynonym       { edTypeSynonymName :: ProperName       , edTypeSynonymArguments :: [(String, Maybe Kind)]       , edTypeSynonymType :: Type       }-  -- ^ A data construtor+  -- | A data construtor   | EDDataConstructor       { edDataCtorName :: ProperName       , edDataCtorOrigin :: DataDeclType@@ -108,19 +109,19 @@       , edDataCtorType :: Type       , edDataCtorFields :: [Ident]       }-  -- ^ A value declaration+  -- | A value declaration   | EDValue       { edValueName :: Ident       , edValueType :: Type       }-  -- ^ A type class declaration+  -- | A type class declaration   | EDClass       { edClassName :: ProperName       , edClassTypeArguments :: [(String, Maybe Kind)]       , edClassMembers :: [(Ident, Type)]       , edClassConstraints :: [Constraint]       }-  -- ^ An instance declaration+  -- | An instance declaration   | EDInstance       { edInstanceClassName :: Qualified ProperName       , edInstanceName :: Ident@@ -152,7 +153,7 @@  -- | Generate an externs file for all declarations in a module moduleToExternsFile :: Module -> Environment -> ExternsFile-moduleToExternsFile (Module _ _ _ _ Nothing) _ = error "moduleToExternsFile: module exports were not elaborated"+moduleToExternsFile (Module _ _ _ _ Nothing) _ = internalError "moduleToExternsFile: module exports were not elaborated" moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}   where   efVersion       = showVersion Paths.version@@ -181,7 +182,7 @@   toExternsDeclaration (PositionedDeclarationRef _ _ r) = toExternsDeclaration r   toExternsDeclaration (TypeRef pn dctors) =     case Qualified (Just mn) pn `M.lookup` types env of-      Nothing -> error "toExternsDeclaration: no kind in toExternsDeclaration"+      Nothing -> internalError "toExternsDeclaration: no kind in toExternsDeclaration"       Just (kind, TypeSynonym)         | Just (args, synTy) <- Qualified (Just mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ]       Just (kind, ExternData) -> [ EDType pn kind ExternData ]@@ -190,7 +191,7 @@                             | dctor <- fromMaybe (map fst tys) dctors                             , (dty, _, ty, args) <- maybeToList (M.lookup (Qualified (Just mn) dctor) (dataConstructors env))                             ]-      _ -> error "toExternsDeclaration: Invalid input"+      _ -> internalError "toExternsDeclaration: Invalid input"   toExternsDeclaration (ValueRef ident)     | Just (ty, _, _) <- (mn, ident) `M.lookup` names env     = [ EDValue ident ty ]

@@ -30,6 +30,7 @@ #endif import Control.Monad.Writer.Class +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Errors@@ -50,7 +51,7 @@   getDeclIdent (ValueDeclaration ident _ _ _) = Just ident   getDeclIdent (ExternDeclaration ident _) = Just ident   getDeclIdent (TypeInstanceDeclaration ident _ _ _ _) = Just ident-  getDeclIdent (BindingGroupDeclaration _) = error "lint: binding groups should not be desugared yet."+  getDeclIdent (BindingGroupDeclaration _) = internalError "lint: binding groups should not be desugared yet."   getDeclIdent _ = Nothing    lintDeclaration :: Declaration -> m ()

@@ -38,6 +38,7 @@ import Control.Arrow (first, second) import Control.Monad.Writer.Class +import Language.PureScript.Crash import Language.PureScript.AST.Binders import Language.PureScript.AST.Declarations import Language.PureScript.Environment@@ -92,7 +93,7 @@    extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName, [Type])]   extractConstructors (Just (_, DataType _ pt)) = pt-  extractConstructors _ = error "Data name not in the scope of the current environment in extractConstructors"+  extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors"  -- | -- Replicates a wildcard binder@@ -197,7 +198,7 @@     where     (miss1, pr1) = missingCasesSingle env mn x y     (miss2, pr2) = go xs ys-  go _ _ = error "Argument lengths did not match in missingCasesMultiple."+  go _ _ = internalError "Argument lengths did not match in missingCasesMultiple."  -- | -- Guard handling

@@ -43,9 +43,10 @@ #endif import Control.Monad import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Trans.Except import Control.Monad.Reader-import Control.Monad.Writer.Strict+import Control.Monad.Logger import Control.Monad.Supply import Control.Monad.Base (MonadBase(..)) import Control.Monad.Trans.Control (MonadBaseControl(..))@@ -72,6 +73,7 @@ import System.FilePath ((</>), takeDirectory) import System.IO.Error (tryIOError) +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Externs import Language.PureScript.Environment@@ -166,7 +168,7 @@   barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar)    for_ sorted $ \m -> fork $ do-    let deps = fromMaybe (error "make: module not found in dependency graph.") (lookup (getModuleName m) graph)+    let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup (getModuleName m) graph)     buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted)    -- Wait for all threads to complete, and collect errors.@@ -176,8 +178,7 @@   unless (null errors) $ throwError (mconcat errors)    -- Bundle up all the externs and return them as an Environment-  (warnings, externs) <- unzip . fromMaybe (error "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd)-  tell (mconcat warnings)+  (_, externs) <- unzip . fromMaybe (internalError "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd)   return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs    where@@ -205,21 +206,21 @@     -- We need to wait for dependencies to be built, before checking if the current     -- module should be rebuilt, so the first thing to do is to wait on the     -- MVars for the module's dependencies.-    mexterns <- fmap unzip . sequence <$> mapM (readMVar . fst . fromMaybe (error "make: no barrier") . flip lookup barriers) deps+    mexterns <- fmap unzip . sequence <$> mapM (readMVar . fst . fromMaybe (internalError "make: no barrier") . flip lookup barriers) deps -    outputTimestamp <- getOutputTimestamp moduleName-    dependencyTimestamp <- maximumMaybe <$> mapM (fmap shouldExist . getOutputTimestamp) deps-    inputTimestamp <- getInputTimestamp moduleName+    case mexterns of+      Just (_, externs) -> do+        outputTimestamp <- getOutputTimestamp moduleName+        dependencyTimestamp <- maximumMaybe <$> mapM (fmap shouldExist . getOutputTimestamp) deps+        inputTimestamp <- getInputTimestamp moduleName -    let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of-                          (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2-                          (Right (Just t1), Nothing, Just t2) -> t1 > t2-                          (Left RebuildNever, _, Just _) -> False-                          _ -> True+        let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of+                              (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2+                              (Right (Just t1), Nothing, Just t2) -> t1 > t2+                              (Left RebuildNever, _, Just _) -> False+                              _ -> True -    let rebuild =-          case mexterns of-            Just (_, externs) -> do+        let rebuild = do               (exts, warnings) <- listen $ do                 progress $ CompilingModule moduleName                 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs@@ -235,20 +236,20 @@                 evalSupplyT nextVar $ codegen renamed env' $ encode exts                 return exts               markComplete (Just (warnings, exts)) Nothing-            Nothing -> markComplete Nothing Nothing -    if shouldRebuild-      then rebuild-      else do-        mexts <- decodeExterns . snd <$> readExterns moduleName-        case mexts of-          Just exts -> markComplete (Just (mempty, exts)) Nothing-          Nothing -> rebuild+        if shouldRebuild+          then rebuild+          else do+            mexts <- decodeExterns . snd <$> readExterns moduleName+            case mexts of+              Just exts -> markComplete (Just (mempty, exts)) Nothing+              Nothing -> rebuild+      Nothing -> markComplete Nothing Nothing     where     markComplete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m ()     markComplete externs errors = do-      putMVar (fst $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) externs-      putMVar (snd $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) errors+      putMVar (fst $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) externs+      putMVar (snd $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) errors    maximumMaybe :: (Ord a) => [a] -> Maybe a   maximumMaybe [] = Nothing@@ -257,7 +258,7 @@   -- Make sure a dependency exists   shouldExist :: Maybe UTCTime -> UTCTime   shouldExist (Just t) = t-  shouldExist _ = error "make: dependency should already have been built."+  shouldExist _ = internalError "make: dependency should already have been built."    decodeExterns :: B.ByteString -> Maybe ExternsFile   decodeExterns bs = do@@ -283,22 +284,22 @@ -- | -- A monad for running make actions ---newtype Make a = Make { unMake :: ReaderT Options (WriterT MultipleErrors (ExceptT MultipleErrors IO)) a }+newtype Make a = Make { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a }   deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)  instance MonadBase IO Make where   liftBase = liftIO  instance MonadBaseControl IO Make where-  type StM Make a = Either MultipleErrors (a, MultipleErrors)+  type StM Make a = Either MultipleErrors a   liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)   restoreM = Make . restoreM  -- | -- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings. ---runMake :: Options -> Make a -> IO (Either MultipleErrors (a, MultipleErrors))-runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake+runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)+runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake  makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a makeIO f io = do@@ -324,7 +325,7 @@    getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))   getInputTimestamp mn = do-    let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap+    let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap     e1 <- traverseEither getTimestamp path     fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns     return $ fmap (max fPath) e1

@@ -25,6 +25,7 @@ import Data.List (nub) import Data.Maybe (fromMaybe, mapMaybe) +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Types@@ -43,7 +44,7 @@   ms' <- mapM toModule $ stronglyConnComp verts   let (graph, fromVertex, toVertex) = graphFromEdges verts       moduleGraph = do (_, mn, _) <- verts-                       let v       = fromMaybe (error "sortModules: vertex not found") (toVertex mn)+                       let v       = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn)                            deps    = reachable graph v                            toKey i = case fromVertex i of (_, key, _) -> key                        return (mn, filter (/= mn) (map toKey deps))

@@ -30,6 +30,7 @@ import Control.PatternArrows import qualified Control.Arrow as A +import Language.PureScript.Crash import Language.PureScript.CodeGen.JS.AST import Language.PureScript.CodeGen.JS.Common import Language.PureScript.Pretty.Common@@ -251,13 +252,13 @@ -- Generate a pretty-printed string representing a Javascript expression -- prettyPrintJS1 :: JS -> String-prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'+prettyPrintJS1 = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'  -- | -- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level -- prettyPrintJS :: [JS] -> String-prettyPrintJS = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements+prettyPrintJS = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements  -- | -- Generate an indented, pretty-printed string representing a Javascript expression

@@ -22,6 +22,7 @@ import Control.Arrow (ArrowPlus(..)) import Control.PatternArrows +import Language.PureScript.Crash import Language.PureScript.Kinds import Language.PureScript.Pretty.Common @@ -47,7 +48,7 @@  -- | Generate a pretty-printed string representing a Kind prettyPrintKind :: Kind -> String-prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()+prettyPrintKind = fromMaybe (internalError "Incomplete pattern") . pattern matchKind ()   where   matchKind :: Pattern () Kind String   matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)

@@ -27,6 +27,7 @@ import Control.Arrow ((<+>)) import Control.PatternArrows +import Language.PureScript.Crash import Language.PureScript.Types import Language.PureScript.Names import Language.PureScript.Kinds@@ -45,14 +46,13 @@   match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor   match (TUnknown u) = Just $ text $ '_' : show u   match (Skolem name s _) = Just $ text $ name ++ show s-  match (ConstrainedType deps ty) = Just $ constraintsAsBox deps ty   match REmpty = Just $ text "()"   match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row   match _ = Nothing -constraintsAsBox :: [(Qualified ProperName, [Type])] -> Type -> Box-constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> typeAsBox ty-constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> typeAsBox ty)+constraintsAsBox :: [(Qualified ProperName, [Type])] -> Box -> Box+constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty+constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty)  constraintAsBox :: Qualified ProperName -> [Type] -> Box constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys)@@ -114,6 +114,12 @@     go idents other = PrettyPrintForAll idents other   convertForAlls other = other +constrained :: Pattern () Type ([Constraint], Type)+constrained = mkPattern match+  where+  match (ConstrainedType deps ty) = Just (deps, ty)+  match _ = Nothing+ matchTypeAtom :: Pattern () Type Box matchTypeAtom = typeLiterals <+> fmap ((`before` text ")") . (text "(" <>)) matchType @@ -125,6 +131,7 @@     OperatorTable [ [ AssocL typeApp $ \f x -> f `beforeWithSpace` x ]                   , [ AssocR appliedFunction $ \arg ret -> (arg <> text " ") `before` (text "-> " <> ret)                     ]+                  , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ]                   , [ Wrap forall_ $ \idents ty -> text ("forall " ++ unwords idents ++ ". ") <> ty ]                   , [ Wrap kinded $ \k ty -> ty `before` (text (" :: " ++ prettyPrintKind k)) ]                   ]@@ -136,14 +143,14 @@   match _ = Nothing  typeAtomAsBox :: Type -> Box-typeAtomAsBox = fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders+typeAtomAsBox = fromMaybe (internalError "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders  -- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses prettyPrintTypeAtom :: Type -> String prettyPrintTypeAtom = render . typeAtomAsBox  typeAsBox :: Type -> Box-typeAsBox = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders+typeAsBox = fromMaybe (internalError "Incomplete pattern") . pattern matchType () . insertPlaceholders  -- | Generate a pretty-printed string representing a Type prettyPrintType :: Type -> String

@@ -25,6 +25,7 @@  import Control.Arrow (second) +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Pretty.Common@@ -103,7 +104,7 @@   where   toDecl (nm, t, e) = ValueDeclaration nm t [] (Right e) prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d-prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"+prettyPrintDeclaration _ = internalError "Invalid argument to prettyPrintDeclaration"  prettyPrintCaseAlternative :: CaseAlternative -> Box prettyPrintCaseAlternative (CaseAlternative binders result) =

@@ -16,6 +16,7 @@  {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Language.PureScript.Sugar.BindingGroups (     createBindingGroups,@@ -28,6 +29,7 @@ import Data.List (nub, intersect) import Data.Maybe (isJust, mapMaybe) #if __GLASGOW_HASKELL__ < 710+import Data.Foldable (foldMap) import Control.Applicative #endif import Control.Monad ((<=<))@@ -35,6 +37,7 @@  import qualified Data.Set as S +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Types@@ -53,20 +56,20 @@ collapseBindingGroupsModule :: [Module] -> [Module] collapseBindingGroupsModule = map $ \(Module ss coms name ds exps) -> Module ss coms name (collapseBindingGroups ds) exps -createBindingGroups :: (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration]+createBindingGroups :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration] createBindingGroups moduleName = mapM f <=< handleDecls    where   (f, _, _) = everywhereOnValuesTopDownM return handleExprs return -  handleExprs :: (Functor m, MonadError MultipleErrors m) => Expr -> m Expr+  handleExprs :: Expr -> m Expr   handleExprs (Let ds val) = flip Let val <$> handleDecls ds   handleExprs other = return other    -- |   -- Replace all sets of mutually-recursive declarations with binding groups   ---  handleDecls :: (Functor m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]+  handleDecls :: [Declaration] -> m [Declaration]   handleDecls ds = do     let values = filter isValueDecl ds         dataDecls = filter isDataDecl ds@@ -145,19 +148,19 @@ getIdent :: Declaration -> Ident getIdent (ValueDeclaration ident _ _ _) = ident getIdent (PositionedDeclaration _ _ d) = getIdent d-getIdent _ = error "Expected ValueDeclaration"+getIdent _ = internalError "Expected ValueDeclaration"  getProperName :: Declaration -> ProperName getProperName (DataDeclaration _ pn _ _) = pn getProperName (TypeSynonymDeclaration pn _ _) = pn getProperName (PositionedDeclaration _ _ d) = getProperName d-getProperName _ = error "Expected DataDeclaration"+getProperName _ = internalError "Expected DataDeclaration"  -- | -- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration). -- ---toBindingGroup :: (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration+toBindingGroup :: forall m. (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration toBindingGroup _ (AcyclicSCC d) = return d toBindingGroup moduleName (CyclicSCC ds') =   -- Once we have a mutually-recursive group of declarations, we need to sort@@ -177,15 +180,14 @@   valueVerts :: [(Declaration, Ident, [Ident])]   valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds' -  toBinding :: (MonadError MultipleErrors m) => SCC Declaration -> m (Ident, NameKind, Expr)+  toBinding :: SCC Declaration -> m (Ident, NameKind, Expr)   toBinding (AcyclicSCC d) = return $ fromValueDecl d-  toBinding (CyclicSCC ~(d:ds)) = cycleError d ds+  toBinding (CyclicSCC ds) = throwError $ foldMap cycleError ds -  cycleError :: (MonadError MultipleErrors m) => Declaration -> [Declaration] -> m a-  cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds-  cycleError (ValueDeclaration n _ _ (Right _)) [] = throwError . errorMessage $ CycleInDeclaration n-  cycleError d ds@(_:_) = rethrow (addHint (NotYetDefined (map getIdent ds))) $ cycleError d []-  cycleError _ _ = error "Expected ValueDeclaration"+  cycleError :: Declaration -> MultipleErrors+  cycleError (PositionedDeclaration p _ d) = onErrorMessages (withPosition p) $ cycleError d+  cycleError (ValueDeclaration n _ _ (Right _)) = errorMessage $ CycleInDeclaration n+  cycleError _ = internalError "cycleError: Expected ValueDeclaration"  toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration toDataBindingGroup (AcyclicSCC d) = return d@@ -203,6 +205,6 @@  fromValueDecl :: Declaration -> (Ident, NameKind, Expr) fromValueDecl (ValueDeclaration ident nameKind [] (Right val)) = (ident, nameKind, val)-fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"+fromValueDecl ValueDeclaration{} = internalError "Binders should have been desugared" fromValueDecl (PositionedDeclaration _ _ d) = fromValueDecl d-fromValueDecl _ = error "Expected ValueDeclaration"+fromValueDecl _ = internalError "Expected ValueDeclaration"

@@ -23,6 +23,7 @@     desugarCasesModule ) where +import Language.PureScript.Crash import Data.Maybe (catMaybes) import Data.List (nub, groupBy) @@ -112,7 +113,7 @@   fromVarBinder (VarBinder name) = return name   fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b   fromVarBinder (TypedBinder _ b) = fromVarBinder b-  fromVarBinder _ = error "fromVarBinder: Invalid argument"+  fromVarBinder _ = internalError "fromVarBinder: Invalid argument" toDecls ds@(ValueDeclaration ident _ bs result : _) = do   let tuples = map toTuple ds   unless (all ((== length bs) . length . fst) tuples) $@@ -129,7 +130,7 @@ toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr) toTuple (ValueDeclaration _ _ bs result) = (bs, result) toTuple (PositionedDeclaration _ _ d) = toTuple d-toTuple _ = error "Not a value declaration"+toTuple _ = internalError "Not a value declaration"  makeCaseDeclaration :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration makeCaseDeclaration ident alternatives = do

@@ -22,6 +22,7 @@     desugarDoModule ) where +import Language.PureScript.Crash import Language.PureScript.Names import Language.PureScript.AST import Language.PureScript.Errors@@ -56,7 +57,7 @@   replace other = return other    go :: [DoNotationElement] -> m Expr-  go [] = error "The impossible happened in desugarDo"+  go [] = internalError "The impossible happened in desugarDo"   go [DoNotationValue val] = return val   go (DoNotationValue val : rest) = do     rest' <- go rest

@@ -30,6 +30,7 @@  import qualified Data.Map as M +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Types@@ -99,7 +100,7 @@   renameInModule' :: Env -> Module -> m Module   renameInModule' env m@(Module _ _ mn _ _) =     rethrow (addHint (ErrorInModule mn)) $ do-      let (_, imps, exps) = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn env+      let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env       elaborateImports imps <$> renameInModule env imps (elaborateExports exps m)  -- |

@@ -33,6 +33,7 @@  import qualified Data.Map as M +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Errors@@ -52,7 +53,7 @@     where     go exps'' (TypeDeclaration name _) = exportValue exps'' name mn     go exps'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go exps'' d-    go _ _ = error "Invalid declaration in TypeClassDeclaration"+    go _ _ = internalError "Invalid declaration in TypeClassDeclaration"   updateExports exps (DataDeclaration _ tn _ dcs) = exportType exps tn (map fst dcs) mn   updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn   updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn@@ -137,24 +138,24 @@   resolveTypeExports tctors dctors = map go tctors     where     go :: Qualified ProperName -> ((ProperName, [ProperName]), ModuleName)-    go (Qualified (Just mn'') name) = fromMaybe (error "Missing value in resolveTypeExports") $ do+    go (Qualified (Just mn'') name) = fromMaybe (internalError "Missing value in resolveTypeExports") $ do       exps' <- envModuleExports <$> mn'' `M.lookup` env       ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps')       let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mnOrig then Just dctor else Nothing) dctors       return ((name, intersect relevantDctors dctors'), mnOrig)-    go (Qualified Nothing _) = error "Unqualified value in resolveTypeExports"+    go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports"     -- Looks up an imported class and re-qualifies it with the original module it   -- came from.   resolveClass :: Qualified ProperName -> (ProperName, ModuleName)-  resolveClass className = splitQual $ fromMaybe (error "Missing value in resolveClass") $+  resolveClass className = splitQual $ fromMaybe (internalError "Missing value in resolveClass") $     resolve exportedTypeClasses className    -- Looks up an imported value and re-qualifies it with the original module it   -- came from.   resolveValue :: Qualified Ident -> (Ident, ModuleName)-  resolveValue ident = splitQual $ fromMaybe (error "Missing value in resolveValue") $+  resolveValue ident = splitQual $ fromMaybe (internalError "Missing value in resolveValue") $     resolve exportedValues ident    resolve :: (Eq a) => (Exports -> [(a, ModuleName)]) -> Qualified a -> Maybe (Qualified a)@@ -162,13 +163,13 @@     exps' <- envModuleExports <$> mn'' `M.lookup` env     mn''' <- snd <$> find ((== a) . fst) (f exps')     return $ Qualified (Just mn''') a-  resolve _ _ = error "Unqualified value in resolve"+  resolve _ _ = internalError "Unqualified value in resolve"    -- A partial function that takes a qualified value and extracts the value and   -- qualified module components.   splitQual :: Qualified a -> (a, ModuleName)   splitQual (Qualified (Just mn'') a) = (a, mn'')-  splitQual _ = error "Unqualified value in splitQual"+  splitQual _ = internalError "Unqualified value in splitQual"  -- | -- Filters the full list of exportable values, types, and classes for a module

@@ -34,6 +34,7 @@  import qualified Data.Map as M +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Errors@@ -115,7 +116,7 @@       checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name     --check (ModuleRef name) =     --  checkImportExists (const UnknownModule) (exportedModules exps) name-    check _ = error "Invalid argument to checkRefs"+    check _ = internalError "Invalid argument to checkRefs"    -- Check that an explicitly imported item exists in the module it is being imported from   checkImportExists :: (Eq a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m ()@@ -171,13 +172,13 @@   importExplicit imp (TypeClassRef name) = do     typeClasses' <- updateImports (importedTypeClasses imp) runProperName (exportedTypeClasses exps) name     return $ imp { importedTypeClasses = typeClasses' }-  importExplicit _ _ = error "Invalid argument to importExplicit"+  importExplicit _ _ = internalError "Invalid argument to importExplicit"    -- Find all exported data constructors for a given type   allExportedDataConstructors :: ProperName -> [(ProperName, ModuleName)]   allExportedDataConstructors name =     case find ((== name) . fst . fst) (exportedTypes exps) of-      Nothing -> error "Invalid state in allExportedDataConstructors"+      Nothing -> internalError "Invalid state in allExportedDataConstructors"       Just ((_, dctors), mn) -> map (, mn) dctors    -- Add something to the Imports if it does not already exist there@@ -191,7 +192,7 @@     -- If the name is not already present add it to the list, after looking up     -- where it was originally defined     Nothing ->-      let mnOrig = fromMaybe (error "Invalid state in updateImports") (name `lookup` exps')+      let mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps')       in return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name, mnOrig) imps'      -- If the name already is present check whether it's a duplicate import@@ -199,7 +200,7 @@     -- re-exports A, importing A and B in C should not result in a "conflicting     -- import for `x`" error     Just (Qualified (Just mn) _, mnOrig)-       | mnOrig == fromMaybe (error "Invalid state in updateImports") (name `lookup` exps') -> return imps'+       | mnOrig == fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps') -> return imps'        | otherwise -> throwError . errorMessage $ err         where         err = if currentModule `elem` [mn, importModule]@@ -207,4 +208,4 @@               else ConflictingImports (render name) mn importModule      Just (Qualified Nothing _, _) ->-      error "Invalid state in updateImports"+      internalError "Invalid state in updateImports"

@@ -29,6 +29,7 @@   desugarOperatorSections ) where +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Names@@ -93,7 +94,7 @@   where   collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]   collect (PositionedDeclaration pos _ (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]-  collect FixityDeclaration{} = error "Fixity without srcpos info"+  collect FixityDeclaration{} = internalError "Fixity without srcpos info"   collect _ = []  ensureNoDuplicates :: (MonadError MultipleErrors m) => [(Qualified Ident, SourceSpan)] -> m ()@@ -129,7 +130,7 @@   extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r   extendChain other = [Left other]   bracketChain :: Chain -> m Expr-  bracketChain = either (const . throwError . errorMessage $ CannotReorderOperators) return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"+  bracketChain = either (\_ -> internalError "matchOperators: cannot reorder operators") return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"   opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft]             : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops             ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]

@@ -24,6 +24,7 @@   , superClassDictionaryNames   ) where +import Language.PureScript.Crash import Language.PureScript.AST hiding (isExported) import Language.PureScript.Environment import Language.PureScript.Errors@@ -75,7 +76,7 @@     | isTypeClassDeclaration d1 && not (isTypeClassDeclaration d2) = LT     | not (isTypeClassDeclaration d1) && isTypeClassDeclaration d2 = GT     | otherwise = EQ-desugarModule _ = error "Exports should have been elaborated in name desugaring"+desugarModule _ = internalError "Exports should have been elaborated in name desugaring"  {- Desugar type class and type class instance declarations --@@ -177,7 +178,7 @@   go d@(TypeClassDeclaration name args implies members) = do     modify (M.insert (mn, name) (args, implies, members))     return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)-  go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = error "Derived instanced should have been desugared"+  go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared"   go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do     desugared <- desugarCases members     dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared@@ -200,7 +201,7 @@    isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool   isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps-  isExported _ _ = error "Names should have been qualified in name desugaring"+  isExported _ _ = internalError "Names should have been qualified in name desugaring"    matchesTypeRef :: ProperName -> DeclarationRef -> Bool   matchesTypeRef pn (TypeRef pn' _) = pn == pn'@@ -216,7 +217,7 @@ memberToNameAndType :: Declaration -> (Ident, Type) memberToNameAndType (TypeDeclaration ident ty) = (ident, ty) memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d-memberToNameAndType _ = error "Invalid declaration in type class definition"+memberToNameAndType _ = internalError "Invalid declaration in type class definition"  typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration typeClassDictionaryDeclaration name args implies members =@@ -236,7 +237,7 @@       moveQuantifiersToFront (quantify (ConstrainedType [(className, map (TypeVar . fst) args)] ty)) typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) =   PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d-typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"+typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition"  unit :: Type unit = TypeApp tyObject REmpty@@ -289,18 +290,18 @@    memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [(Ident, Type)] -> Declaration -> Desugar m Expr   memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do-    _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident) return $ lookup ident tys'+    _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys'     return val   memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do     val <- memberToValue tys' d     return (PositionedValue pos com val)-  memberToValue _ _ = error "Invalid declaration in type instance definition"+  memberToValue _ _ = internalError "Invalid declaration in type instance definition"  typeClassMemberName :: Declaration -> String typeClassMemberName (TypeDeclaration ident _) = runIdent ident typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d-typeClassMemberName _ = error "typeClassMemberName: Invalid declaration in type class definition"+typeClassMemberName _ = internalError "typeClassMemberName: Invalid declaration in type class definition"  superClassDictionaryNames :: [Constraint] -> [String] superClassDictionaryNames supers =

@@ -36,6 +36,7 @@ import Control.Monad.Supply.Class (MonadSupply, freshName)
 import Control.Monad.Error.Class (MonadError(..))
 
+import Language.PureScript.Crash
 import Language.PureScript.AST
 import Language.PureScript.Environment
 import Language.PureScript.Errors
@@ -116,7 +117,7 @@           $ decomposeRec rec
   toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i
 mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d
-mkSpineFunction _ _ = error "mkSpineFunction: expected DataDeclaration"
+mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration"
 
 mkSignatureFunction :: ModuleName -> Declaration -> Expr
 mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map mkProdClause args
@@ -145,7 +146,7 @@   mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)
                            (TypedValue False (mkGenVar "anyProxy") (proxy typ))
 mkSignatureFunction mn (PositionedDeclaration _ _ d) = mkSignatureFunction mn d
-mkSignatureFunction _ _ = error "mkSignatureFunction: expected DataDeclaration"
+mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration"
 
 mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
 mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)
@@ -194,7 +195,7 @@   mkRecFun xs = mkJust $ foldr (\s e -> lam s e) recLiteral (map fst xs)
      where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs
 mkFromSpineFunction mn (PositionedDeclaration _ _ d) = mkFromSpineFunction mn d
-mkFromSpineFunction _ _ = error "mkFromSpineFunction: expected DataDeclaration"
+mkFromSpineFunction _ _ = internalError "mkFromSpineFunction: expected DataDeclaration"
 
 -- Helpers
 

@@ -25,9 +25,8 @@ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif-import Control.Monad (forM, when)+import Control.Monad (forM) import Control.Monad.Error.Class (MonadError(..))-import Control.Monad.Writer.Class (MonadWriter(tell))  import Language.PureScript.AST import Language.PureScript.Names@@ -38,19 +37,19 @@ -- | -- Replace all top level type declarations in a module with type annotations ---desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module]+desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module] desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) ->   rethrow (addHint (ErrorInModule name)) $-    Module ss coms name <$> desugarTypeDeclarations True ds <*> pure exps+    Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps   where -  desugarTypeDeclarations :: Bool -> [Declaration] -> m [Declaration]-  desugarTypeDeclarations reqd (PositionedDeclaration pos com d : ds) = do-    (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations reqd (d : ds)+  desugarTypeDeclarations :: [Declaration] -> m [Declaration]+  desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do+    (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)     return (PositionedDeclaration pos com d' : ds')-  desugarTypeDeclarations reqd (TypeDeclaration name ty : d : rest) = do+  desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do     (_, nameKind, val) <- fromValueDeclaration d-    desugarTypeDeclarations reqd (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)+    desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)     where     fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr)     fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)@@ -58,19 +57,14 @@       (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'       return (ident, nameKind, PositionedValue pos com val)     fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name-  desugarTypeDeclarations _ [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name-  desugarTypeDeclarations reqd (ValueDeclaration name nameKind bs val : rest) = do-    -- At the top level, match a type signature or emit a warning.-    when reqd $ case val of-                  Right TypedValue{} -> return ()-                  Left _ -> error "desugarTypeDeclarations: cases were not desugared"-                  _ -> tell (addHint (ErrorInValueDeclaration name) $ errorMessage $ MissingTypeDeclaration name)+  desugarTypeDeclarations [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name+  desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do     let (_, f, _) = everywhereOnValuesTopDownM return go return         f' (Left gs) = Left <$> mapM (pairM return f) gs         f' (Right v) = Right <$> f v-    (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations reqd rest+    (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest     where-    go (Let ds val') = Let <$> desugarTypeDeclarations False ds <*> pure val'+    go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'     go other = return other-  desugarTypeDeclarations reqd (d:ds) = (:) d <$> desugarTypeDeclarations reqd ds-  desugarTypeDeclarations _ [] = return []+  desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds+  desugarTypeDeclarations [] = return []

@@ -38,6 +38,7 @@ import Control.Monad.State import Control.Monad.Error.Class (MonadError(..)) +import Language.PureScript.Crash import Language.PureScript.Types import Language.PureScript.Names import Language.PureScript.Kinds@@ -90,7 +91,7 @@   where   toPair (TypeDeclaration ident ty) = (ident, ty)   toPair (PositionedDeclaration _ _ d) = toPair d-  toPair _ = error "Invalid declaration in TypeClassDeclaration"+  toPair _ = internalError "Invalid declaration in TypeClassDeclaration"  addTypeClassDictionaries :: Maybe ModuleName -> M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope) -> Check () addTypeClassDictionaries mn entries =@@ -147,8 +148,8 @@     where     checkNewtype :: [(ProperName, [Type])] -> Check ()     checkNewtype [(_, [_])] = return ()-    checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype-    checkNewtype _ = throwError . errorMessage $ InvalidNewtype+    checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype name+    checkNewtype _ = throwError . errorMessage $ InvalidNewtype name   go (d@(DataBindingGroupDeclaration tys)) = do     warnAndRethrow (addHint ErrorInDataBindingGroup) $ do       let syns = mapMaybe toTypeSynonym tys@@ -177,14 +178,14 @@       let args' = args `withKinds` kind       addTypeSynonym moduleName name args' ty kind     return $ TypeSynonymDeclaration name args ty-  go (TypeDeclaration{}) = error "Type declarations should have been removed"+  go (TypeDeclaration{}) = internalError "Type declarations should have been removed"   go (ValueDeclaration name nameKind [] (Right val)) =     warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do       valueIsNotDefined moduleName name       [(_, (val', ty))] <- typesOf moduleName [(name, val)]       addValue moduleName name ty nameKind       return $ ValueDeclaration name nameKind [] $ Right val'-  go (ValueDeclaration{}) = error "Binders were not desugared"+  go (ValueDeclaration{}) = internalError "Binders were not desugared"   go (BindingGroupDeclaration vals) =     warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do       forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->@@ -205,7 +206,7 @@   go (d@(ExternDeclaration name ty)) = do     warnAndRethrow (addHint (ErrorInForeignImport name)) $ do       env <- getEnv-      kind <- kindOf moduleName ty+      kind <- kindOf ty       guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star       case M.lookup (moduleName, name) (names env) of         Just _ -> throwError . errorMessage $ RedefinedIdent name@@ -245,7 +246,7 @@     memberName :: Declaration -> Ident     memberName (ValueDeclaration ident _ _ _) = ident     memberName (PositionedDeclaration _ _ d) = memberName d-    memberName _ = error "checkInstanceMembers: Invalid declaration in type instance definition"+    memberName _ = internalError "checkInstanceMembers: Invalid declaration in type instance definition"      firstDuplicate :: (Eq a) => [a] -> Maybe a     firstDuplicate (x : xs@(y : _))@@ -261,10 +262,10 @@     checkType :: Type -> Bool     checkType (TypeVar _) = False     checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn''-    checkType (TypeConstructor (Qualified Nothing _)) = error "Unqualified type name in checkOrphanInstance"+    checkType (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance"     checkType (TypeApp t1 _) = checkType t1-    checkType _ = error "Invalid type in instance in checkOrphanInstance"-  checkOrphanInstance _ _ _ = error "Unqualified class name in checkOrphanInstance"+    checkType _ = internalError "Invalid type in instance in checkOrphanInstance"+  checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance"    -- |   -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,@@ -274,14 +275,14 @@   withKinds []                  _               = []   withKinds (s@(_, Just _ ):ss) (FunKind _   k) = s : withKinds ss k   withKinds (  (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2-  withKinds _                   _               = error "Invalid arguments to peelKinds"+  withKinds _                   _               = internalError "Invalid arguments to peelKinds"  -- | -- Type check an entire module and ensure all types and classes defined within the module that are -- required by exported members are also exported. -- typeCheckModule :: Module -> Check Module-typeCheckModule (Module _ _ _ _ Nothing) = error "exports should have been elaborated"+typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated" typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do   modify (\s -> s { checkCurrentModule = Just mn })   decls' <- typeCheckAll mn exps decls@@ -331,7 +332,7 @@     findTcons :: Type -> [DeclarationRef]     findTcons = everythingOnTypes (++) go       where-      go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (error "Data constructors unused in checkTypesAreExported")]+      go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (internalError "Data constructors unused in checkTypesAreExported")]       go _ = []    -- Check that all the classes defined in the current module that appear in member types have also@@ -361,5 +362,5 @@     extractMemberName :: Declaration -> Ident     extractMemberName (PositionedDeclaration _ _ d) = extractMemberName d     extractMemberName (TypeDeclaration memberName _) = memberName-    extractMemberName _ = error "Unexpected declaration in typeclass member list"+    extractMemberName _ = internalError "Unexpected declaration in typeclass member list"   checkClassMembersAreExported _ = return ()

@@ -35,6 +35,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (tell) +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Names@@ -53,11 +54,11 @@   where     forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope]     forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys))-    forClassName _ _ = error "forClassName: expected qualified class name"+    forClassName _ _ = internalError "forClassName: expected qualified class name"      ctorModules :: Type -> Maybe ModuleName     ctorModules (TypeConstructor (Qualified (Just mn) _)) = Just mn-    ctorModules (TypeConstructor (Qualified Nothing _)) = error "ctorModules: unqualified type name"+    ctorModules (TypeConstructor (Qualified Nothing _)) = internalError "ctorModules: unqualified type name"     ctorModules (TypeApp ty _) = ctorModules ty     ctorModules _ = Nothing 

@@ -40,6 +40,7 @@ import Control.Monad.State import Control.Monad.Unify +import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Kinds@@ -75,8 +76,8 @@ -- | -- Infer the kind of a single type ---kindOf :: ModuleName -> Type -> Check Kind-kindOf _ ty = fst <$> kindOfWithScopedVars ty+kindOf :: Type -> Check Kind+kindOf ty = fst <$> kindOfWithScopedVars ty  -- | -- Infer the kind of a single type, returning the kinds of any scoped type variables@@ -220,4 +221,4 @@     k <- go ty     k =?= Star     return Star-  go _ = error "Invalid argument to infer"+  go _ = internalError "Invalid argument to infer"

@@ -153,7 +153,7 @@ checkVisibility currentModule name@(Qualified _ var) = do   vis <- getVisibility currentModule name   case vis of-    Undefined -> throwError . errorMessage $ NameNotInScope var+    Undefined -> throwError . errorMessage $ CycleInDeclaration var     _ -> return ()  -- |

@@ -33,6 +33,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Unify +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.TypeChecker.Monad@@ -71,12 +72,17 @@ -- only example of scoped type variables. -- skolemizeTypesInValue :: String -> Int -> SkolemScope -> Expr -> Expr-skolemizeTypesInValue ident sko scope = let (_, f, _) = everywhereOnValues id go id in f+skolemizeTypesInValue ident sko scope = let (_, f, _) = everywhereOnValues id onExpr onBinder in f   where-  go (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts)-  go (TypedValue check val ty) = TypedValue check val (skolemize ident sko scope ty)-  go other = other+  onExpr :: Expr -> Expr+  onExpr (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts)+  onExpr (TypedValue check val ty) = TypedValue check val (skolemize ident sko scope ty)+  onExpr other = other +  onBinder :: Binder -> Binder+  onBinder (TypedBinder ty b) = TypedBinder (skolemize ident sko scope ty) b+  onBinder other = other+ -- | -- Ensure skolem variables do not escape their scope --@@ -115,4 +121,4 @@     where     go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)     go' _ = mempty-skolemEscapeCheck _ = error "Untyped value passed to skolemEscapeCheck"+skolemEscapeCheck _ = internalError "Untyped value passed to skolemEscapeCheck"

@@ -20,9 +20,10 @@ import Data.List (sortBy) import Data.Ord (comparing) -import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Unify+import Control.Monad.Error.Class (throwError) +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Environment import Language.PureScript.Errors@@ -50,7 +51,7 @@       sko <- newSkolemConstant       let sk = skolemize ident sko sco' ty2       subsumes val ty1 sk-    Nothing -> throwError . errorMessage $ UnspecifiedSkolemScope+    Nothing -> internalError "subsumes: unspecified skolem scope" subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do   _ <- subsumes Nothing arg2 arg1   _ <- subsumes Nothing ret1 ret2@@ -77,10 +78,17 @@     | p1 == p2 = do _ <- subsumes Nothing ty1 ty2                     go ts1 ts2 r1' r2'     | p1 < p2 = do rest <- fresh-                   r2' =?= RCons p1 ty1 rest+                   -- What happens next is a bit of a hack.+                   -- TODO: in the new type checker, object properties will probably be restricted to being monotypes+                   -- in which case, this branch of the subsumes function should not even be necessary.+                   case r2' of+                     REmpty -> throwError . errorMessage $ AdditionalProperty p1+                     _ -> r2' =?= RCons p1 ty1 rest                    go ts1 ((p2, ty2) : ts2) r1' rest     | otherwise = do rest <- fresh-                     r1' =?= RCons p2 ty2 rest+                     case r1' of+                       REmpty -> throwError . errorMessage $ PropertyIsMissing p2+                       _ -> r1' =?= RCons p2 ty2 rest                      go ((p1, ty1) : ts1) ts2 rest r2' subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyObject = subsumes val ty2 ty1 subsumes' val ty1 ty2 = do

@@ -50,7 +50,9 @@ import Control.Monad.State import Control.Monad.Unify import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.Writer.Class (tell) +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Environment import Language.PureScript.Errors@@ -77,7 +79,7 @@   tys <- fmap tidyUp . liftUnifyWarnings replace $ do     (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals     ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict-    ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict+    ds2 <- forM untyped $ \e -> typeForBindingGroupElement True e dict untypedDict     return $ ds1 ++ ds2    forM tys $ \(ident, (val, ty)) -> do@@ -93,6 +95,7 @@   tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts   -- Replace all the wildcards types with their inferred types   replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints $ WildcardInferredType (sub $? ty)+  replace sub (ErrorMessage hints (MissingTypeDeclaration name ty)) = ErrorMessage hints $ MissingTypeDeclaration name (varIfUnknown (sub $? ty))   replace _ em = em  type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)@@ -134,11 +137,12 @@            else return (TypedValue False val' ty'')   return (ident, (val'', ty'')) -typeForBindingGroupElement :: (Ident, Expr) -> TypeData -> UntypedData -> UnifyT Type Check (Ident, (Expr, Type))-typeForBindingGroupElement (ident, val) dict untypedDict = do+typeForBindingGroupElement :: Bool -> (Ident, Expr) -> TypeData -> UntypedData -> UnifyT Type Check (Ident, (Expr, Type))+typeForBindingGroupElement warn (ident, val) dict untypedDict = do   -- Infer the type with the new names in scope   TypedValue _ val' ty <- bindNames dict $ infer val-  ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)+  ty =?= fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict)+  when warn . tell . errorMessage $ MissingTypeDeclaration ident ty   return (ident, (TypedValue True val' ty, ty))  -- |@@ -189,7 +193,7 @@   instantiatePolyTypeWithUnknowns val ty' instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do    dicts <- getTypeClassDictionaries-   (_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty+   (_, ty') <- instantiatePolyTypeWithUnknowns (internalError "Types under a constraint cannot themselves be constrained") ty    return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty') instantiatePolyTypeWithUnknowns val ty = return (val, ty) @@ -228,7 +232,7 @@   let oldTy = TypeApp tyObject $ rowFromList (oldTys, row)   o' <- TypedValue True <$> check o oldTy <*> pure oldTy   return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyObject $ rowFromList (newTys, row)-infer' (Accessor prop val) = do+infer' (Accessor prop val) = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do   field <- fresh   rest <- fresh   typed <- check val (TypeApp tyObject (RCons prop field rest))@@ -239,7 +243,7 @@   withBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do     body@(TypedValue _ _ bodyTy) <- infer' ret     return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy-infer' (Abs (Right _) _) = error "Binder was not desugared"+infer' (Abs (Right _) _) = internalError "Binder was not desugared" infer' (App f arg) = do   f'@(TypedValue _ _ ft) <- infer f   (ret, app) <- checkFunctionApplication f' ft arg Nothing@@ -284,7 +288,7 @@   val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val   return $ TypedValue True val' ty' infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val-infer' _ = error "Invalid argument to infer"+infer' _ = internalError "Invalid argument to infer"  inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr) inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret)@@ -307,7 +311,7 @@   Just moduleName <- checkCurrentModule <$> get   (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)   ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict-  ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict+  ds2' <- forM untyped $ \e -> typeForBindingGroupElement False e dict untypedDict   let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2']   bindNames dict $ do     makeBindingGroupVisible@@ -315,7 +319,7 @@ inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethrowWithPosition pos $ do   (d' : ds', val') <- inferLetBinding seen (d : ds) ret j   return (PositionedDeclaration pos com d' : ds', val')-inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding"+inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding"  -- | -- Infer the types of variables brought into scope by a binder@@ -332,20 +336,19 @@   env <- getEnv   case M.lookup ctor (dataConstructors env) of     Just (_, _, ty, _) -> do-      (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contain constraints") ty+      (_, fn) <- instantiatePolyTypeWithUnknowns (internalError "Data constructor types cannot contain constraints") ty       fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn-      go binders fn'-        where-        go [] ty' = case (val, ty') of-          (TypeConstructor _, TypeApp _ _) -> throwIncorrectArity-          _ -> do-            _ <- val =?= ty'-            return M.empty-        go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =-          M.union <$> inferBinder obj binder <*> go binders' ret-        go _ _ = throwIncorrectArity-        throwIncorrectArity = throwError . errorMessage $ IncorrectConstructorArity ctor+      let (args, ret) = peelArgs fn'+      unless (length args == length binders) . throwError . errorMessage $ IncorrectConstructorArity ctor+      ret =?= val+      M.unions <$> zipWithM inferBinder (reverse args) binders     _ -> throwError . errorMessage $ UnknownDataConstructor ctor Nothing+  where+  peelArgs :: Type -> ([Type], Type)+  peelArgs = go []+    where+    go args (TypeApp (TypeApp fn arg) ret) | fn == tyFunction = go (arg : args) ret+    go args ret = (args, ret) inferBinder val (ObjectBinder props) = do   row <- fresh   rest <- fresh@@ -370,9 +373,15 @@   return $ M.insert name val m inferBinder val (PositionedBinder pos _ binder) =   warnAndRethrowWithPosition pos $ inferBinder val binder--- TODO: When adding support for polymorphic types, check subsumption here--- and change the definition of `binderRequiresMonotype`-inferBinder val (TypedBinder ty binder) = val =?= ty >> inferBinder val binder+-- TODO: When adding support for polymorphic types, check subsumption here,+-- change the definition of `binderRequiresMonotype`,+-- and use `kindOfWithScopedVars`.+inferBinder val (TypedBinder ty binder) = do+  ty1 <- replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty+  kind <- liftCheck $ kindOf ty1+  checkTypeKind ty1 kind+  val =?= ty1+  inferBinder val binder  -- | Returns true if a binder requires its argument type to be a monotype. -- | If this is the case, we need to instantiate any polymorphic types before checking binders.@@ -449,7 +458,7 @@   newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> Check [TypeClassDictionaryInScope]   newDictionaries path name (className, instanceTy) = do     tcs <- gets (typeClasses . checkEnv)-    let (args, _, superclasses) = fromMaybe (error "newDictionaries: type class lookup failed") $ M.lookup className tcs+    let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs     supDicts <- join <$> zipWithM (\(supName, supArgs) index ->                                       newDictionaries ((supName, index) : path)                                                       name@@ -484,7 +493,7 @@   Just moduleName <- checkCurrentModule <$> get   ret' <- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy   return $ TypedValue True (Abs (Left arg) ret') ty-check' (Abs (Right _) _) _ = error "Binder was not desugared"+check' (Abs (Right _) _) _ = internalError "Binder was not desugared" check' (App f arg) ret = do   f'@(TypedValue _ _ ft) <- infer f   (_, app) <- checkFunctionApplication f' ft arg (Just ret)@@ -496,7 +505,7 @@   ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty   v' <- subsumes (Just v) repl ty'   case v' of-    Nothing -> throwError . errorMessage $ SubsumptionCheckFailed+    Nothing -> internalError "check: unable to check the subsumes relation."     Just v'' -> return $ TypedValue True v'' ty' check' (SuperClassDictionary className tys) _ = do   {-@@ -515,7 +524,7 @@   ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2   val' <- subsumes (Just val) ty1' ty2'   case val' of-    Nothing -> throwError . errorMessage $ SubsumptionCheckFailed+    Nothing -> internalError "check: unable to check the subsumes relation."     Just _ -> do       val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val       return $ TypedValue checkType val''' ty2'@@ -528,24 +537,24 @@   th' <- check th ty   el' <- check el ty   return $ TypedValue True (IfThenElse cond' th' el') ty-check' (ObjectLiteral ps) t@(TypeApp obj row) | obj == tyObject = do+check' e@(ObjectLiteral ps) t@(TypeApp obj row) | obj == tyObject = do   ensureNoDuplicateProperties ps-  ps' <- checkProperties ps row False+  ps' <- checkProperties e ps row False   return $ TypedValue True (ObjectLiteral ps') t check' (TypeClassDictionaryConstructorApp name ps) t = do   ps' <- check' ps t   return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t-check' (ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do+check' e@(ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do   ensureNoDuplicateProperties ps   -- We need to be careful to avoid duplicate labels here.-  -- We check _obj_ agaist the type _t_ with the types in _ps_ replaced with unknowns.+  -- We check _obj_ against the type _t_ with the types in _ps_ replaced with unknowns.   let (propsToCheck, rest) = rowToList row       (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map fst ps) propsToCheck   us <- zip (map fst removedProps) <$> replicateM (length ps) fresh   obj' <- check obj (TypeApp tyObject (rowFromList (us ++ remainingProps, rest)))-  ps' <- checkProperties ps row True+  ps' <- checkProperties e ps row True   return $ TypedValue True (ObjectUpdate obj' ps') t-check' (Accessor prop val) ty = do+check' (Accessor prop val) ty = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do   rest <- fresh   val' <- check val (TypeApp tyObject (RCons prop ty rest))   return $ TypedValue True (Accessor prop val') ty@@ -557,7 +566,7 @@       repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1       mv <- subsumes (Just v) repl ty       case mv of-        Nothing -> throwError . errorMessage $ SubsumptionCheckFailed+        Nothing -> internalError "check: unable to check the subsumes relation."         Just v' -> return $ TypedValue True v' ty check' (Let ds val) ty = do   (ds', val') <- inferLetBinding [] ds val (`check` ty)@@ -572,7 +581,7 @@   TypedValue _ val' ty' <- infer val   mt <- subsumes (Just val') ty' ty   case mt of-    Nothing -> throwError . errorMessage $ SubsumptionCheckFailed+    Nothing -> internalError "check: unable to check the subsumes relation."     Just v' -> return $ TypedValue True v' ty  -- |@@ -580,8 +589,8 @@ -- -- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case. ---checkProperties :: [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)]-checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where+checkProperties :: Expr -> [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)]+checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' where   go [] [] REmpty = return []   go [] [] u@(TUnknown _)     | lax = return []@@ -589,8 +598,8 @@                      return []   go [] [] Skolem{} | lax = return []   go [] ((p, _): _) _ | lax = return []-                      | otherwise = throwError . errorMessage $ PropertyIsMissing p row-  go ((p,_):_) [] REmpty = throwError . errorMessage $ PropertyIsMissing p row+                      | otherwise = throwError . errorMessage $ PropertyIsMissing p+  go ((p,_):_) [] REmpty = throwError . errorMessage $ AdditionalProperty p   go ((p,v):ps') ts r =     case lookup p ts of       Nothing -> do@@ -603,7 +612,7 @@         v' <- check v ty         ps'' <- go ps' (delete (p, ty) ts) r         return $ (p, v') : ps''-  go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType (ObjectLiteral ps) (TypeApp tyObject row)+  go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (TypeApp tyObject row)  -- | -- Check the type of a function application, rethrowing errors to provide a better error message

@@ -36,6 +36,7 @@ import Control.Monad.Writer import Control.Monad.Error.Class (MonadError(..)) +import Language.PureScript.Crash import Language.PureScript.Errors import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Skolems@@ -74,12 +75,12 @@         let sk1 = skolemize ident1 sko sc1' ty1         let sk2 = skolemize ident2 sko sc2' ty2         sk1 `unifyTypes` sk2-      _ -> error "Skolemized type variable was not given a scope"+      _ -> internalError "unifyTypes: unspecified skolem scope"   unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do     sko <- newSkolemConstant     let sk = skolemize ident sko sc ty1     sk `unifyTypes` ty2-  unifyTypes' ForAll{} _ = throwError . errorMessage $ UnspecifiedSkolemScope+  unifyTypes' ForAll{} _ = internalError "unifyTypes: unspecified skolem scope"   unifyTypes' ty f@ForAll{} = f `unifyTypes` ty   unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()   unifyTypes' ty1@(TypeConstructor c1) ty2@(TypeConstructor c2) =

@@ -78,7 +78,7 @@ modulesDir = ".test_modules" </> "node_modules"  makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make-makeActions foreigns = (P.buildMakeActions modulesDir (error "makeActions: input file map was read.") foreigns False)+makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)                          { P.getInputTimestamp = getInputTimestamp                          , P.getOutputTimestamp = getOutputTimestamp                          }@@ -94,7 +94,7 @@   getOutputTimestamp mn = do     let filePath = modulesDir </> P.runModuleName mn     exists <- liftIO $ doesDirectoryExist filePath-    return (if exists then Just (error "getOutputTimestamp: read timestamp") else Nothing)+    return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)  readInput :: [FilePath] -> IO [(FilePath, String)] readInput inputFiles = forM inputFiles $ \inputFile -> do@@ -104,7 +104,7 @@ type TestM = WriterT [(FilePath, String)] IO  runTest :: P.Make a -> IO (Either P.MultipleErrors a)-runTest = fmap (fmap fst) . P.runMake P.defaultOptions+runTest = fmap fst . P.runMake P.defaultOptions  compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment) compile inputFiles foreigns = runTest $ do

@@ -28,6 +28,8 @@ import System.Directory import System.Info +import Language.PureScript.Crash+ findNodeProcess :: IO (Maybe String) findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names   where@@ -35,7 +37,7 @@  fetchSupportCode :: IO () fetchSupportCode = do-  node <- fromMaybe (error "cannot find node executable") <$> findNodeProcess+  node <- fromMaybe (internalError "cannot find node executable") <$> findNodeProcess   setCurrentDirectory "tests/support"   if System.Info.os == "mingw32"     then callProcess "setup-win.cmd" []