diff --git a/examples/failing/1169.purs b/examples/failing/1169.purs new file mode 100644 --- /dev/null +++ b/examples/failing/1169.purs @@ -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 diff --git a/examples/failing/1570.purs b/examples/failing/1570.purs new file mode 100644 --- /dev/null +++ b/examples/failing/1570.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith ExpectedType +module M where + +data F a = F a + +test = \(x :: F) -> x diff --git a/examples/failing/ExtraRecordField.purs b/examples/failing/ExtraRecordField.purs --- a/examples/failing/ExtraRecordField.purs +++ b/examples/failing/ExtraRecordField.purs @@ -1,5 +1,4 @@ --- @shouldFailWith PropertyIsMissing --- TODO: Make this fail with a new error ExtraProperty instead. +-- @shouldFailWith AdditionalProperty module ExtraRecordField where import Prelude ((<>)) diff --git a/examples/failing/MissingRecordField.purs b/examples/failing/MissingRecordField.purs --- a/examples/failing/MissingRecordField.purs +++ b/examples/failing/MissingRecordField.purs @@ -1,5 +1,4 @@ --- @shouldFailWith TypesDoNotUnify --- TODO: Update type checker to make this fail with PropertyIsMissing instead. +-- @shouldFailWith PropertyIsMissing module MissingRecordField where import Prelude ((>)) diff --git a/examples/failing/MutRec.purs b/examples/failing/MutRec.purs --- a/examples/failing/MutRec.purs +++ b/examples/failing/MutRec.purs @@ -1,4 +1,5 @@ -- @shouldFailWith CycleInDeclaration +-- @shouldFailWith CycleInDeclaration module MutRec where import Prelude diff --git a/examples/passing/1570.purs b/examples/passing/1570.purs new file mode 100644 --- /dev/null +++ b/examples/passing/1570.purs @@ -0,0 +1,6 @@ +module Main where + +test :: forall a. a -> a +test = \(x :: a) -> x + +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/TypedBinders.purs b/examples/passing/TypedBinders.purs --- a/examples/passing/TypedBinders.purs +++ b/examples/passing/TypedBinders.purs @@ -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 diff --git a/psc/Main.hs b/psc/Main.hs --- a/psc/Main.hs +++ b/psc/Main.hs @@ -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: " ++) diff --git a/psci/PSCi.hs b/psci/PSCi.hs --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -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 diff --git a/purescript.cabal b/purescript.cabal --- a/purescript.cabal +++ b/purescript.cabal @@ -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 diff --git a/src/Control/Monad/Logger.hs b/src/Control/Monad/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Logger.hs @@ -0,0 +1,74 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Monad.Logger +-- Author : Phil Freeman +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Phil Freeman +-- 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 diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -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) diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs --- a/src/Language/PureScript/AST/Operators.hs +++ b/src/Language/PureScript/AST/Operators.hs @@ -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 diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -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) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs @@ -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 diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -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 diff --git a/src/Language/PureScript/Crash.hs b/src/Language/PureScript/Crash.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Crash.hs @@ -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 diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -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 diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -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 diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -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. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -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 diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -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 ] diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -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 () diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -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 diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -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 diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -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)) diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -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 diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs --- a/src/Language/PureScript/Pretty/Kinds.hs +++ b/src/Language/PureScript/Pretty/Kinds.hs @@ -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) diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -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 diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -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) = diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -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" diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -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 diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -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 diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -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) -- | diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -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 diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -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" diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -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 ]] diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -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 = diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -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 diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -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 [] diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -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 () diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -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 diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -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" diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -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 () -- | diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -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" diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -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 diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -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 diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -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) = diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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 diff --git a/tests/common/TestsSetup.hs b/tests/common/TestsSetup.hs --- a/tests/common/TestsSetup.hs +++ b/tests/common/TestsSetup.hs @@ -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" []