summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-03-29 01:26:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-03-29 01:26:00 (GMT)
commitd072c9c63fb4775925707a4cb4cfd41926958671 (patch)
treeddf237f92d7d70716de2744a858f340f38e58479
parentdea419160ee3766eadd4d1b5ca85f13e994c6dda (diff)
version 0.4.100.4.10
-rw-r--r--docgen/Main.hs3
-rw-r--r--psc-make/Main.hs6
-rw-r--r--psc/Main.hs6
-rw-r--r--psci/Main.hs2
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript.hs14
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs1
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs3
-rw-r--r--src/Language/PureScript/DeadCodeElimination.hs5
-rw-r--r--src/Language/PureScript/Declarations.hs53
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs1
-rw-r--r--src/Language/PureScript/Options.hs6
-rw-r--r--src/Language/PureScript/Parser/Common.hs11
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs24
-rw-r--r--src/Language/PureScript/Pretty/Common.hs38
-rw-r--r--src/Language/PureScript/Pretty/JS.hs45
-rw-r--r--src/Language/PureScript/Pretty/Values.hs209
-rw-r--r--src/Language/PureScript/Sugar.hs5
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs21
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs9
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs3
-rw-r--r--src/Language/PureScript/Sugar/Names.hs12
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs14
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs11
-rw-r--r--src/Language/PureScript/Sugar/TypeDeclarations.hs16
-rw-r--r--src/Language/PureScript/TypeChecker.hs34
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs32
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs114
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs99
29 files changed, 571 insertions, 228 deletions
diff --git a/docgen/Main.hs b/docgen/Main.hs
index ae74bb8..153096f 100644
--- a/docgen/Main.hs
+++ b/docgen/Main.hs
@@ -84,6 +84,7 @@ renderModule (P.Module moduleName ds exps) =
isExported :: Maybe [P.DeclarationRef] -> P.Declaration -> Bool
isExported Nothing _ = True
isExported _ (P.TypeInstanceDeclaration _ _ _ _ _) = True
+isExported exps (P.PositionedDeclaration _ d) = isExported exps d
isExported (Just exps) decl = any (matches decl) exps
where
matches (P.TypeDeclaration ident _) (P.ValueRef ident') = ident == ident'
@@ -130,6 +131,8 @@ renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys
[] -> ""
cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "
atIndent n $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)
+renderDeclaration n exps (P.PositionedDeclaration _ d) =
+ renderDeclaration n exps d
renderDeclaration _ _ _ = return ()
getName :: P.Declaration -> String
diff --git a/psc-make/Main.hs b/psc-make/Main.hs
index e8eda43..8bd9c37 100644
--- a/psc-make/Main.hs
+++ b/psc-make/Main.hs
@@ -115,8 +115,12 @@ browserNamespace :: Term String
browserNamespace = value $ opt "PS" $ (optInfo [ "browser-namespace" ])
{ optDoc = "Specify the namespace that PureScript modules will be exported to when running in the browser." }
+verboseErrors :: Term Bool
+verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])
+ { optDoc = "Display verbose error messages" }
+
options :: Term P.Options
-options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> browserNamespace <*> pure [] <*> pure []
+options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> browserNamespace <*> pure [] <*> pure [] <*> verboseErrors
inputFilesAndPrelude :: FilePath -> Term [FilePath]
inputFilesAndPrelude prelude = combine <$> (not <$> noPrelude) <*> inputFiles
diff --git a/psc/Main.hs b/psc/Main.hs
index bb0e1f9..7d53f47 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -122,8 +122,12 @@ codeGenModules :: Term [String]
codeGenModules = value $ optAll [] $ (optInfo [ "codegen" ])
{ optDoc = "A list of modules for which Javascript and externs should be generated. This argument can be used multiple times." }
+verboseErrors :: Term Bool
+verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])
+ { optDoc = "Display verbose error messages" }
+
options :: Term P.Options
-options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> runMain <*> noOpts <*> browserNamespace <*> dceModules <*> codeGenModules
+options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> runMain <*> noOpts <*> browserNamespace <*> dceModules <*> codeGenModules <*> verboseErrors
stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])
stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles
diff --git a/psci/Main.hs b/psci/Main.hs
index b9b14ab..e1eea0c 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -194,7 +194,7 @@ completion = completeWord Nothing " \t\n\r" findCompletions
-- | Compilation options.
--
options :: P.Options
-options = P.Options False True False True (Just "Main") True "PS" [] []
+options = P.Options False True False True (Just "Main") True "PS" [] [] False
-- |
-- Makes a volatile module to execute the current expression.
diff --git a/purescript.cabal b/purescript.cabal
index 467472d..62f3ae6 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.4.9
+version: 0.4.10
cabal-version: >=1.8
build-type: Custom
license: MIT
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 4323055..97d754c 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -71,7 +71,7 @@ compile' :: Environment -> Options -> [Module] -> Either String (String, String,
compile' env opts ms = do
(sorted, _) <- sortModules $ if optionsNoPrelude opts then ms else (map importPrelude ms)
desugared <- desugar sorted
- (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent
+ (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent
regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
let entryPoints = moduleNameFromString `map` optionsModules opts
let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped
@@ -100,8 +100,9 @@ typeCheckModule mainModuleName (Module mn decls exps) = do
checkTypesAreExported (ValueRef name) = do
ty <- lookupVariable mn (Qualified (Just mn) name)
case find isTconHidden (findTcons ty) of
- Just hiddenType -> throwError $ "Error in module '" ++ show mn ++ "':\n\
- \Exporting declaration '" ++ show name ++ "' requires type '" ++ show hiddenType ++ "' to be exported as well"
+ Just hiddenType -> throwError . strMsg $
+ "Error in module '" ++ show mn ++ "':\n\
+ \Exporting declaration '" ++ show name ++ "' requires type '" ++ show hiddenType ++ "' to be exported as well"
Nothing -> return ()
checkTypesAreExported _ = return ()
@@ -118,7 +119,7 @@ typeCheckModule mainModuleName (Module mn decls exps) = do
where
go (TypeRef tyName' _) = tyName' /= tyName
go _ = True
-
+
generateMain :: Environment -> Options -> [JS] -> Either String [JS]
generateMain env opts js =
@@ -191,7 +192,7 @@ make opts ms = do
go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> m ()
go _ [] = return ()
go env ((False, m) : ms') = do
- (_, env') <- liftError . runCheck' env $ typeCheckModule Nothing m
+ (_, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m
go env' ms'
go env ((True, m@(Module moduleName' _ exps)) : ms') = do
@@ -199,7 +200,7 @@ make opts ms = do
jsFile = "js" ++ pathSeparator : filePath ++ ".js"
externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"
- (Module _ elaborated _, env') <- liftError . runCheck' env $ typeCheckModule Nothing m
+ (Module _ elaborated _, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m
regrouped <- liftError . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
@@ -247,5 +248,6 @@ importPrelude m@(Module mn decls exps) =
where
prelude = ModuleName [ProperName C.prelude]
isPreludeImport (ImportDeclaration (ModuleName [ProperName mn']) _ _) | mn' == C.prelude = True
+ isPreludeImport (PositionedDeclaration _ d) = isPreludeImport d
isPreludeImport _ = False
preludeImport = ImportDeclaration prelude Nothing Nothing
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index 74617a1..02bdf8e 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -45,6 +45,7 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite
fixityToPs :: Declaration -> Writer [String] ()
fixityToPs (FixityDeclaration (Fixity assoc prec) ident) =
tell [ unwords [ show assoc, show prec, ident ] ]
+ fixityToPs (PositionedDeclaration _ d) = fixityToPs d
fixityToPs _ = return ()
exportToPs :: DeclarationRef -> Writer [String] ()
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index c40f3f6..6ccaabb 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -82,6 +82,7 @@ declToJs _ mp (DataDeclaration _ _ ctors) _ =
(JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])
declToJs opts mp (DataBindingGroupDeclaration ds) e = Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds
declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = Just [js]
+declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e
declToJs _ _ _ _ = Nothing
-- |
@@ -307,6 +308,8 @@ binderToJs m e varName done (ConsBinder headBinder tailBinder) = do
binderToJs m e varName done (NamedBinder ident binder) = do
js <- binderToJs m e varName done binder
return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
+binderToJs m e varName done (PositionedBinder _ binder) =
+ binderToJs m e varName done binder
-- |
-- Checks whether a data constructor is the only constructor for that type, used to simplify the
diff --git a/src/Language/PureScript/DeadCodeElimination.hs b/src/Language/PureScript/DeadCodeElimination.hs
index c20781a..9af904c 100644
--- a/src/Language/PureScript/DeadCodeElimination.hs
+++ b/src/Language/PureScript/DeadCodeElimination.hs
@@ -50,11 +50,13 @@ eliminateDeadCode entryPoints ms = map go ms
valueExists name (ValueDeclaration name' _ _ _ _) = name == name'
valueExists name (ExternDeclaration _ name' _ _) = name == name'
valueExists name (BindingGroupDeclaration decls) = any (\(name', _, _) -> name == name') decls
+ valueExists name (PositionedDeclaration _ d) = valueExists name d
valueExists _ _ = False
typeExists :: ProperName -> Declaration -> Bool
typeExists name (DataDeclaration name' _ _) = name == name'
typeExists name (DataBindingGroupDeclaration decls) = any (typeExists name) decls
+ typeExists name (PositionedDeclaration _ d) = typeExists name d
typeExists _ _ = False
type Key = (ModuleName, Either Ident ProperName)
@@ -68,6 +70,7 @@ declarationsByModule (Module moduleName ds _) = concatMap go ds
go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]
go d@(BindingGroupDeclaration names') = map (\(name, _, _) -> ((moduleName, Left name), dependencies moduleName d)) names'
go (DataBindingGroupDeclaration ds') = concatMap go ds'
+ go (PositionedDeclaration _ d) = go d
go _ = []
dependencies :: (Data d) => ModuleName -> d -> [Key]
@@ -94,4 +97,6 @@ isUsed moduleName graph vertexFor entryPointVertices (BindingGroupDeclaration ds
in any (\v -> path graph v v') entryPointVertices) ds
isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =
any (isUsed moduleName graph vertexFor entryPointVertices) ds
+isUsed moduleName graph vertexFor entryPointVertices (PositionedDeclaration _ d) =
+ isUsed moduleName graph vertexFor entryPointVertices d
isUsed _ _ _ _ _ = True
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index 6dc5d3c..8024343 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -42,6 +42,24 @@ instance Show Associativity where
show Infix = "infix"
-- |
+-- Source position information
+--
+data SourcePos = SourcePos
+ {
+ -- |
+ -- Line number
+ --
+ sourcePosLine :: Int
+ -- |
+ -- Column number
+ --
+ , sourcePosColumn :: Int
+ } deriving (D.Data, D.Typeable)
+
+instance Show SourcePos where
+ show sp = "line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)
+
+-- |
-- Fixity data for infix operators
--
data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
@@ -132,6 +150,10 @@ data Declaration
-- declarations)
--
| TypeInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]
+ -- |
+ -- A declaration with source position information
+ --
+ | PositionedDeclaration SourcePos Declaration
deriving (Show, D.Data, D.Typeable)
-- |
@@ -139,6 +161,7 @@ data Declaration
--
isValueDecl :: Declaration -> Bool
isValueDecl ValueDeclaration{} = True
+isValueDecl (PositionedDeclaration _ d) = isValueDecl d
isValueDecl _ = False
-- |
@@ -147,6 +170,7 @@ isValueDecl _ = False
isDataDecl :: Declaration -> Bool
isDataDecl DataDeclaration{} = True
isDataDecl TypeSynonymDeclaration{} = True
+isDataDecl (PositionedDeclaration _ d) = isDataDecl d
isDataDecl _ = False
-- |
@@ -154,6 +178,7 @@ isDataDecl _ = False
--
isImportDecl :: Declaration -> Bool
isImportDecl ImportDeclaration{} = True
+isImportDecl (PositionedDeclaration _ d) = isImportDecl d
isImportDecl _ = False
-- |
@@ -161,6 +186,7 @@ isImportDecl _ = False
--
isExternDataDecl :: Declaration -> Bool
isExternDataDecl ExternDataDeclaration{} = True
+isExternDataDecl (PositionedDeclaration _ d) = isExternDataDecl d
isExternDataDecl _ = False
-- |
@@ -168,6 +194,7 @@ isExternDataDecl _ = False
--
isExternInstanceDecl :: Declaration -> Bool
isExternInstanceDecl ExternInstanceDeclaration{} = True
+isExternInstanceDecl (PositionedDeclaration _ d) = isExternInstanceDecl d
isExternInstanceDecl _ = False
-- |
@@ -175,6 +202,7 @@ isExternInstanceDecl _ = False
--
isFixityDecl :: Declaration -> Bool
isFixityDecl FixityDeclaration{} = True
+isFixityDecl (PositionedDeclaration _ d) = isFixityDecl d
isFixityDecl _ = False
-- |
@@ -182,6 +210,7 @@ isFixityDecl _ = False
--
isExternDecl :: Declaration -> Bool
isExternDecl ExternDeclaration{} = True
+isExternDecl (PositionedDeclaration _ d) = isExternDecl d
isExternDecl _ = False
-- |
@@ -190,6 +219,7 @@ isExternDecl _ = False
isTypeClassDeclaration :: Declaration -> Bool
isTypeClassDeclaration TypeClassDeclaration{} = True
isTypeClassDeclaration TypeInstanceDeclaration{} = True
+isTypeClassDeclaration (PositionedDeclaration _ d) = isTypeClassDeclaration d
isTypeClassDeclaration _ = False
-- |
@@ -214,6 +244,10 @@ data Value
--
| BooleanLiteral Bool
-- |
+ -- A prefix -, will be desugared
+ --
+ | UnaryMinus Value
+ -- |
-- Binary operator application. During the rebracketing phase of desugaring, this data constructor
-- will be removed.
--
@@ -282,7 +316,11 @@ data Value
-- can be evaluated at runtime. The constructor arguments represent (in order): the type class name and
-- instance type, and the type class dictionaries in scope.
--
- | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope] deriving (Show, D.Data, D.Typeable)
+ | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope]
+ -- |
+ -- A value with source position information
+ --
+ | PositionedValue SourcePos Value deriving (Show, D.Data, D.Typeable)
-- |
-- An alternative in a case statement
@@ -324,7 +362,11 @@ data DoNotationElement
-- |
-- A let statement, i.e. a pure value with a binder
--
- | DoNotationLet Binder Value deriving (Show, D.Data, D.Typeable)
+ | DoNotationLet Binder Value
+ -- |
+ -- A do notation element with source position information
+ --
+ | PositionedDoNotationElement SourcePos DoNotationElement deriving (Show, D.Data, D.Typeable)
-- |
-- Data type for binders
@@ -369,8 +411,11 @@ data Binder
-- |
-- A binder which binds its input to an identifier
--
- | NamedBinder Ident Binder deriving (Show, D.Data, D.Typeable)
-
+ | NamedBinder Ident Binder
+ -- |
+ -- A binder with source position information
+ --
+ | PositionedBinder SourcePos Binder deriving (Show, D.Data, D.Typeable)
-- |
-- Collect all names introduced in binders in an expression
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index 00a857a..78c716f 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -56,6 +56,7 @@ usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProp
qualifiedProperNames _ = []
imports :: Declaration -> [ModuleName]
imports (ImportDeclaration mn _ _) = [mn]
+ imports (PositionedDeclaration _ d) = imports d
imports _ = []
getModuleName :: Module -> ModuleName
diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs
index e4eaf18..6a65d05 100644
--- a/src/Language/PureScript/Options.hs
+++ b/src/Language/PureScript/Options.hs
@@ -57,10 +57,14 @@ data Options = Options {
-- The modules to code gen
--
, optionsCodeGenModules :: [String]
+ -- |
+ -- Verbose error message
+ --
+ , optionsVerboseErrors :: Bool
} deriving Show
-- |
-- Default compiler options
--
defaultOptions :: Options
-defaultOptions = Options False False False False Nothing False "PS" [] []
+defaultOptions = Options False False False False Nothing False "PS" [] [] False
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index 49aa100..f9be3a1 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -227,14 +227,8 @@ parseQualified parser = part []
-- Parse an integer or floating point value
--
integerOrFloat :: P.Parsec String u (Either Integer Double)
-integerOrFloat = (Right <$> P.try (signed PT.float) <|>
- Left <$> P.try (signed PT.natural)) P.<?> "number"
- where
- signed p = do
- let sign = (P.char '-' >> return negate) <|> (optional (P.char '+') >> return id)
- f <- sign
- n <- p tokenParser
- return (f n)
+integerOrFloat = (Right <$> P.try (PT.float tokenParser) <|>
+ Left <$> P.try (PT.natural tokenParser)) P.<?> "number"
-- |
-- Parse an identifier or parenthesized operator
@@ -375,3 +369,4 @@ same = checkIndentation (==) P.<?> "no indentation"
--
runIndentParser :: FilePath -> P.Parsec String ParseState a -> String -> Either P.ParseError a
runIndentParser filePath p = P.runParser p (ParseState 0) filePath
+
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 3e3138b..fb725e4 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -38,6 +38,14 @@ import qualified Language.PureScript.Parser.Common as C
import qualified Text.Parsec as P
import qualified Text.Parsec.Expr as P
+-- |
+-- Read source position information
+--
+sourcePos :: P.Parsec s u SourcePos
+sourcePos = toSourcePos <$> P.getPosition
+ where
+ toSourcePos p = SourcePos (P.sourceLine p) (P.sourceColumn p)
+
parseDataDeclaration :: P.Parsec String ParseState Declaration
parseDataDeclaration = do
reserved "data"
@@ -162,7 +170,7 @@ parseTypeInstanceDeclaration = do
-- Parse a single declaration
--
parseDeclaration :: P.Parsec String ParseState Declaration
-parseDeclaration = P.choice
+parseDeclaration = PositionedDeclaration <$> sourcePos <*> P.choice
[ parseDataDeclaration
, parseTypeDeclaration
, parseTypeSynonymDeclaration
@@ -175,7 +183,7 @@ parseDeclaration = P.choice
] P.<?> "declaration"
parseLocalDeclaration :: P.Parsec String ParseState Declaration
-parseLocalDeclaration = P.choice
+parseLocalDeclaration = PositionedDeclaration <$> sourcePos <*> P.choice
[ parseTypeDeclaration
, parseValueDeclaration
] P.<?> "local declaration"
@@ -313,7 +321,7 @@ parseDoNotationElement = P.choice
-- Parse a value
--
parseValue :: P.Parsec String ParseState Value
-parseValue =
+parseValue = PositionedValue <$> sourcePos <*>
(P.buildExpressionParser operators
. C.buildPostfixParser postfixTable2
$ indexersAndAccessors) P.<?> "expression"
@@ -324,8 +332,11 @@ parseValue =
postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v
, \v -> flip (TypedValue True) <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v
]
- operators = [ [ P.Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->
- return (BinaryNoParens ident))) P.AssocRight ]
+ operators = [ [ P.Prefix (C.lexeme (P.try (C.indented *> P.char '-') >> return UnaryMinus))
+ ]
+ , [ P.Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->
+ return (BinaryNoParens ident))) P.AssocRight
+ ]
]
parseStringBinder :: P.Parsec String ParseState Binder
@@ -370,7 +381,8 @@ parseIdentifierAndBinder = do
-- Parse a binder
--
parseBinder :: P.Parsec String ParseState Binder
-parseBinder = P.buildExpressionParser operators parseBinderAtom P.<?> "expression"
+parseBinder = PositionedBinder <$> sourcePos <*>
+ P.buildExpressionParser operators parseBinderAtom P.<?> "expression"
where
operators = [ [ P.Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) P.AssocRight ] ]
parseBinderAtom :: P.Parsec String ParseState Binder
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
index af07ae4..5d9d151 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -15,8 +15,46 @@
module Language.PureScript.Pretty.Common where
+import Control.Monad.State
+import Data.List (intercalate)
+
-- |
-- Wrap a string in parentheses
--
parens :: String -> String
parens s = ('(':s) ++ ")"
+
+newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Eq, Ord)
+
+-- |
+-- Number of characters per identation level
+--
+blockIndent :: Int
+blockIndent = 4
+
+-- |
+-- Pretty print with a new indentation level
+--
+withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String
+withIndent action = do
+ modify $ \st -> st { indent = indent st + blockIndent }
+ result <- action
+ modify $ \st -> st { indent = indent st - blockIndent }
+ return result
+
+-- |
+-- Get the current indentation level
+--
+currentIndent :: StateT PrinterState Maybe String
+currentIndent = do
+ current <- get
+ return $ replicate (indent current) ' '
+
+-- |
+-- Print many lines
+--
+prettyPrintMany :: (a -> StateT PrinterState Maybe String) -> [a] -> StateT PrinterState Maybe String
+prettyPrintMany f xs = do
+ ss <- mapM f xs
+ indentString <- currentIndent
+ return $ intercalate "\n" $ map (indentString ++) ss
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index 38ad1f6..47b353c 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -27,39 +27,14 @@ import Control.Arrow ((<+>))
import Control.PatternArrows
import Control.Applicative
import Control.Monad.State
-
-newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Eq, Ord)
-
--- |
--- Number of characters per identation level
---
-blockIndent :: Int
-blockIndent = 4
-
--- |
--- Pretty print with a new indentation level
---
-withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String
-withIndent action = do
- modify $ \st -> st { indent = indent st + blockIndent }
- result <- action
- modify $ \st -> st { indent = indent st - blockIndent }
- return result
-
--- |
--- Get the current indentation level
---
-currentIndent :: StateT PrinterState Maybe String
-currentIndent = do
- current <- get
- return $ replicate (indent current) ' '
+import Numeric
literals :: Pattern PrinterState JS String
literals = mkPattern' match
where
match :: JS -> StateT PrinterState Maybe String
match (JSNumericLiteral n) = return $ either show show n
- match (JSStringLiteral s) = return $ show s
+ match (JSStringLiteral s) = return $ string s
match (JSBooleanLiteral True) = return "true"
match (JSBooleanLiteral False) = return "false"
match (JSArrayLiteral xs) = fmap concat $ sequence
@@ -140,6 +115,22 @@ literals = mkPattern' match
match (JSRaw js) = return js
match _ = mzero
+string :: String -> String
+string s = '"' : concatMap encodeChar s ++ "\""
+ where
+ encodeChar :: Char -> String
+ encodeChar '\b' = "\\b"
+ encodeChar '\t' = "\\t"
+ encodeChar '\n' = "\\n"
+ encodeChar '\v' = "\\v"
+ encodeChar '\f' = "\\f"
+ encodeChar '\r' = "\\r"
+ encodeChar '"' = "\\\""
+ encodeChar '\\' = "\\\\"
+ encodeChar c | fromEnum c > 0xFFF = "\\u" ++ showHex (fromEnum c) ""
+ encodeChar c | fromEnum c > 0xFF = "\\u0" ++ showHex (fromEnum c) ""
+ encodeChar c = [c]
+
conditional :: Pattern PrinterState JS ((JS, JS), JS)
conditional = mkPattern match
where
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index c0007bd..32f923a 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -20,132 +20,207 @@ module Language.PureScript.Pretty.Values (
import Data.Maybe (fromMaybe)
import Data.List (intercalate)
-import Control.Arrow ((<+>))
+
+import Control.Arrow ((<+>), runKleisli)
import Control.PatternArrows
+import Control.Monad.State
+import Control.Applicative
-import Language.PureScript.Types
import Language.PureScript.Declarations
import Language.PureScript.Pretty.Common
-import Language.PureScript.Pretty.Types
+import Language.PureScript.Pretty.Types (prettyPrintType)
-literals :: Pattern () Value String
-literals = mkPattern match
+literals :: Pattern PrinterState Value String
+literals = mkPattern' match
where
- match (NumericLiteral n) = Just $ either show show n
- match (StringLiteral s) = Just $ show s
- match (BooleanLiteral True) = Just "true"
- match (BooleanLiteral False) = Just "false"
- match (ArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"
- match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"
- match (Constructor name) = Just $ show name
- match (Case values binders) = Just $ "case " ++ unwords (map prettyPrintValue values) ++
- " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"
- match (Let _ val) = Just $ "let ... in " ++ prettyPrintValue val
- match (Var ident) = Just $ show ident
- match (Do els) = Just $ " do { " ++ intercalate "; " (map prettyPrintDoNotationElement els) ++ " }"
+ match :: Value -> StateT PrinterState Maybe String
+ match (NumericLiteral n) = return $ either show show n
+ match (StringLiteral s) = return $ show s
+ match (BooleanLiteral True) = return "true"
+ match (BooleanLiteral False) = return "false"
+ match (ArrayLiteral xs) = fmap concat $ sequence
+ [ return "[ "
+ , withIndent $ prettyPrintMany prettyPrintValue' xs
+ , return " ]"
+ ]
+ match (ObjectLiteral []) = return "{}"
+ match (ObjectLiteral ps) = fmap concat $ sequence
+ [ return "{\n"
+ , withIndent $ prettyPrintMany prettyPrintObjectProperty ps
+ , currentIndent
+ , return "}"
+ ]
+ match (Constructor name) = return $ show name
+ match (Case values binders) = fmap concat $ sequence
+ [ return "case "
+ , unwords <$> forM values prettyPrintValue'
+ , return " of\n"
+ , withIndent $ prettyPrintMany prettyPrintCaseAlternative binders
+ , currentIndent
+ ]
+ match (Let ds val) = fmap concat $ sequence
+ [ return "let\n"
+ , withIndent $ prettyPrintMany prettyPrintDeclaration ds
+ , return "\n"
+ , currentIndent
+ , return "in "
+ , prettyPrintValue' val
+ ]
+ match (Var ident) = return $ show ident
+ match (Do els) = fmap concat $ sequence
+ [ return "do "
+ , withIndent $ prettyPrintMany prettyPrintDoNotationElement els
+ , currentIndent
+ ]
match (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"
- match _ = Nothing
-
-prettyPrintCaseAlternative :: CaseAlternative -> String
+ match (TypedValue _ val _) = prettyPrintValue' val
+ match (PositionedValue _ val) = prettyPrintValue' val
+ match _ = mzero
+
+prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String
+prettyPrintDeclaration (TypeDeclaration ident ty) = return $ show ident ++ " :: " ++ prettyPrintType ty
+prettyPrintDeclaration (ValueDeclaration ident _ [] Nothing val) = fmap concat $ sequence
+ [ return $ show ident ++ " = "
+ , prettyPrintValue' val
+ ]
+prettyPrintDeclaration (PositionedDeclaration _ d) = prettyPrintDeclaration d
+prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"
+
+prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String
prettyPrintCaseAlternative (CaseAlternative binders grd val) =
- "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++
- maybe "" (("| " ++) . prettyPrintValue) grd ++ " -> " ++ prettyPrintValue val
-
-ifThenElse :: Pattern () Value ((Value, Value), Value)
+ fmap concat $ sequence
+ [ intercalate ", " <$> forM binders prettyPrintBinder'
+ , maybe (return "") (fmap ("| " ++) . prettyPrintValue') grd
+ , return " -> "
+ , prettyPrintValue' val
+ ]
+
+prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String
+prettyPrintDoNotationElement (DoNotationValue val) =
+ prettyPrintValue' val
+prettyPrintDoNotationElement (DoNotationBind binder val) =
+ fmap concat $ sequence
+ [ prettyPrintBinder' binder
+ , return " <- "
+ , prettyPrintValue' val
+ ]
+prettyPrintDoNotationElement (DoNotationLet binder val) =
+ fmap concat $ sequence
+ [ return "let "
+ , prettyPrintBinder' binder
+ , return " = "
+ , prettyPrintValue' val
+ ]
+prettyPrintDoNotationElement (PositionedDoNotationElement _ el) = prettyPrintDoNotationElement el
+
+ifThenElse :: Pattern PrinterState Value ((Value, Value), Value)
ifThenElse = mkPattern match
where
match (IfThenElse cond th el) = Just ((th, el), cond)
match _ = Nothing
-accessor :: Pattern () Value (String, Value)
+accessor :: Pattern PrinterState Value (String, Value)
accessor = mkPattern match
where
match (Accessor prop val) = Just (prop, val)
match _ = Nothing
-objectUpdate :: Pattern () Value ([String], Value)
+objectUpdate :: Pattern PrinterState Value ([String], Value)
objectUpdate = mkPattern match
where
match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)
match _ = Nothing
-app :: Pattern () Value (String, Value)
+app :: Pattern PrinterState Value (String, Value)
app = mkPattern match
where
match (App val arg) = Just (prettyPrintValue arg, val)
match _ = Nothing
-lam :: Pattern () Value (String, Value)
+lam :: Pattern PrinterState Value (String, Value)
lam = mkPattern match
where
match (Abs (Left arg) val) = Just (show arg, val)
match _ = Nothing
-typed :: Pattern () Value (Type, Value)
-typed = mkPattern match
- where
- match (TypedValue _ val ty) = Just (ty, val)
- match _ = Nothing
-
-prettyPrintDoNotationElement :: DoNotationElement -> String
-prettyPrintDoNotationElement (DoNotationValue val) = prettyPrintValue val
-prettyPrintDoNotationElement (DoNotationBind binder val) = prettyPrintBinder binder ++ " <- " ++ prettyPrintValue val
-prettyPrintDoNotationElement (DoNotationLet binder val) = "let " ++ prettyPrintBinder binder ++ " = " ++ prettyPrintValue val
-
-- |
--- Generate a pretty-printed string representing a Value
+-- Generate a pretty-printed string representing an expression
--
prettyPrintValue :: Value -> String
-prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue ()
+prettyPrintValue = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintValue'
+
+prettyPrintValue' :: Value -> StateT PrinterState Maybe String
+prettyPrintValue' = runKleisli $ runPattern matchValue
where
- matchValue :: Pattern () Value String
+ matchValue :: Pattern PrinterState Value String
matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
- operators :: OperatorTable () Value String
+ operators :: OperatorTable PrinterState Value String
operators =
OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
, [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
, [ Wrap app $ \arg val -> val ++ "(" ++ arg ++ ")" ]
, [ Split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val ]
, [ Wrap ifThenElse $ \(th, el) cond -> "if " ++ cond ++ " then " ++ prettyPrintValue th ++ " else " ++ prettyPrintValue el ]
- , [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]
]
-prettyPrintBinderAtom :: Pattern () Binder String
-prettyPrintBinderAtom = mkPattern match
+prettyPrintBinderAtom :: Pattern PrinterState Binder String
+prettyPrintBinderAtom = mkPattern' match
where
- match :: Binder -> Maybe String
- match NullBinder = Just "_"
- match (StringBinder str) = Just $ show str
- match (NumberBinder num) = Just $ either show show num
- match (BooleanBinder True) = Just "true"
- match (BooleanBinder False) = Just "false"
- match (VarBinder ident) = Just $ show ident
- match (ConstructorBinder ctor args) = Just $ show ctor ++ " " ++ unwords (map (parens . prettyPrintBinder) args)
- match (ObjectBinder bs) = Just $ "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"
- match (ArrayBinder bs) = Just $ "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]"
- match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder
- match _ = Nothing
+ match :: Binder -> StateT PrinterState Maybe String
+ match NullBinder = return "_"
+ match (StringBinder str) = return $ show str
+ match (NumberBinder num) = return $ either show show num
+ match (BooleanBinder True) = return "true"
+ match (BooleanBinder False) = return "false"
+ match (VarBinder ident) = return $ show ident
+ match (ConstructorBinder ctor args) = fmap concat $ sequence
+ [ return $ show ctor ++ " "
+ , unwords <$> forM args match
+ ]
+ match (ObjectBinder bs) = fmap concat $ sequence
+ [ return "{\n"
+ , withIndent $ prettyPrintMany prettyPrintObjectPropertyBinder bs
+ , currentIndent
+ , return "}"
+ ]
+ match (ArrayBinder bs) = fmap concat $ sequence
+ [ return "["
+ , unwords <$> mapM prettyPrintBinder' bs
+ , return "]"
+ ]
+ match (NamedBinder ident binder) = ((show ident ++ "@") ++) <$> prettyPrintBinder' binder
+ match (PositionedBinder _ binder) = prettyPrintBinder' binder
+ match _ = mzero
-- |
-- Generate a pretty-printed string representing a Binder
--
prettyPrintBinder :: Binder -> String
-prettyPrintBinder = fromMaybe (error "Incomplete pattern") . pattern matchBinder ()
+prettyPrintBinder = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintBinder'
+
+prettyPrintBinder' :: Binder -> StateT PrinterState Maybe String
+prettyPrintBinder' = runKleisli $ runPattern matchBinder
where
- matchBinder :: Pattern () Binder String
+ matchBinder :: Pattern PrinterState Binder String
matchBinder = buildPrettyPrinter operators (prettyPrintBinderAtom <+> fmap parens matchBinder)
- operators :: OperatorTable () Binder String
+ operators :: OperatorTable PrinterState Binder String
operators =
OperatorTable [ [ AssocR matchConsBinder (\b1 b2 -> b1 ++ " : " ++ b2) ] ]
-matchConsBinder :: Pattern () Binder (Binder, Binder)
+matchConsBinder :: Pattern PrinterState Binder (Binder, Binder)
matchConsBinder = mkPattern match'
where
match' (ConsBinder b1 b2) = Just (b1, b2)
match' _ = Nothing
-prettyPrintObjectPropertyBinder :: String -> Binder -> String
-prettyPrintObjectPropertyBinder key binder = key ++ ": " ++ prettyPrintBinder binder
-
-prettyPrintObjectProperty :: String -> Value -> String
-prettyPrintObjectProperty key value = key ++ ": " ++ prettyPrintValue value
+prettyPrintObjectPropertyBinder :: (String, Binder) -> StateT PrinterState Maybe String
+prettyPrintObjectPropertyBinder (key, binder) = fmap concat $ sequence
+ [ return $ key ++ ": "
+ , prettyPrintBinder' binder
+ ]
+
+prettyPrintObjectProperty :: (String, Value) -> StateT PrinterState Maybe String
+prettyPrintObjectProperty (key, value) = fmap concat $ sequence
+ [ return $ key ++ ": "
+ , prettyPrintValue' value
+ ]
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index 3f0f228..f7598fc 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -27,6 +27,8 @@ import Language.PureScript.Sugar.BindingGroups as S
import Language.PureScript.Sugar.TypeClasses as S
import Language.PureScript.Sugar.Names as S
+import Control.Category ((>>>))
+
-- |
-- The desugaring pipeline proceeds as follows:
--
@@ -45,7 +47,8 @@ import Language.PureScript.Sugar.Names as S
-- * Qualify any unqualified names and types
--
desugar :: [Module] -> Either String [Module]
-desugar = desugarDo
+desugar = removeSignedLiterals
+ >>> desugarDo
>=> desugarCasesModule
>=> desugarTypeDeclarationsModule
>=> desugarImports
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index 9f60af4..4406ad9 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -26,7 +26,7 @@ import Data.Graph
import Data.Generics
import Data.Generics.Extras
import Data.List (nub, intersect)
-import Data.Maybe (mapMaybe)
+import Data.Maybe (isJust, mapMaybe)
import Control.Applicative ((<$>), (<*>), pure)
import Language.PureScript.Declarations
@@ -82,6 +82,7 @@ collapseBindingGroups = everywhere (mkT collapseBindingGroupsForValue) . concatM
where
go (DataBindingGroupDeclaration ds) = ds
go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] Nothing val) ds
+ go (PositionedDeclaration pos d) = map (PositionedDeclaration pos) $ go d
go other = [other]
collapseBindingGroupsForValue :: Value -> Value
@@ -109,11 +110,13 @@ usedProperNames moduleName = nub . everything (++) (mkQ [] usedNames)
getIdent :: Declaration -> Ident
getIdent (ValueDeclaration ident _ _ _ _) = ident
+getIdent (PositionedDeclaration _ d) = getIdent d
getIdent _ = error "Expected ValueDeclaration"
getProperName :: Declaration -> ProperName
getProperName (DataDeclaration pn _ _) = pn
getProperName (TypeSynonymDeclaration pn _ _) = pn
+getProperName (PositionedDeclaration _ d) = getProperName d
getProperName _ = error "Expected DataDeclaration"
toBindingGroup :: SCC Declaration -> Declaration
@@ -123,16 +126,20 @@ toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds'
toDataBindingGroup :: SCC Declaration -> Either String Declaration
toDataBindingGroup (AcyclicSCC d) = return d
-toDataBindingGroup (CyclicSCC [TypeSynonymDeclaration pn _ _]) = Left $ "Cycle in type synonym " ++ show pn
-toDataBindingGroup (CyclicSCC [d]) = return d
+toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of
+ Just pn -> Left $ "Cycle in type synonym " ++ show pn
+ _ -> return d
toDataBindingGroup (CyclicSCC ds')
- | all isTypeSynonym ds' = Left "Cycle in type synonyms"
+ | all (isJust . isTypeSynonym) ds' = Left "Cycle in type synonyms"
| otherwise = return $ DataBindingGroupDeclaration ds'
- where
- isTypeSynonym TypeSynonymDeclaration{} = True
- isTypeSynonym _ = False
+
+isTypeSynonym :: Declaration -> Maybe ProperName
+isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn
+isTypeSynonym (PositionedDeclaration _ d) = isTypeSynonym d
+isTypeSynonym _ = Nothing
fromValueDecl :: Declaration -> (Ident, NameKind, Value)
fromValueDecl (ValueDeclaration ident nameKind [] Nothing val) = (ident, nameKind, val)
fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"
+fromValueDecl (PositionedDeclaration _ d) = fromValueDecl d
fromValueDecl _ = error "Expected ValueDeclaration"
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 06cf071..6142f2c 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -62,11 +62,16 @@ desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup
where
go (Let ds val') = Let <$> desugarCases ds <*> pure val'
go other = return other
+ desugarRest (PositionedDeclaration pos d : ds) = do
+ (d' : ds') <- desugarRest (d : ds)
+ return (PositionedDeclaration pos d' : ds')
desugarRest (d : ds) = (:) d <$> desugarRest ds
desugarRest [] = pure []
inSameGroup :: Declaration -> Declaration -> Bool
inSameGroup (ValueDeclaration ident1 _ _ _ _) (ValueDeclaration ident2 _ _ _ _) = ident1 == ident2
+inSameGroup (PositionedDeclaration _ d1) d2 = inSameGroup d1 d2
+inSameGroup d1 (PositionedDeclaration _ d2) = inSameGroup d1 d2
inSameGroup _ _ = False
toDecls :: [Declaration] -> Either String [Declaration]
@@ -79,6 +84,9 @@ toDecls ds@(ValueDeclaration ident _ bs _ _ : _) = do
unless (all ((== length bs) . length . fst) tuples) $
throwError $ "Argument list lengths differ in declaration " ++ show ident
return [makeCaseDeclaration ident tuples]
+toDecls (PositionedDeclaration pos d : ds) = do
+ (d' : ds') <- toDecls (d : ds)
+ return (PositionedDeclaration pos d' : ds')
toDecls ds = return ds
isVarBinder :: Binder -> Bool
@@ -87,6 +95,7 @@ isVarBinder _ = False
toTuple :: Declaration -> ([Binder], (Maybe Guard, Value))
toTuple (ValueDeclaration _ _ bs g val) = (bs, (g, val))
+toTuple (PositionedDeclaration _ d) = toTuple d
toTuple _ = error "Not a value declaration"
makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> Declaration
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index 0020b31..27bc7e3 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -27,6 +27,8 @@ import Language.PureScript.Declarations
import qualified Language.PureScript.Constants as C
+import Control.Applicative
+
-- |
-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,
-- and all @DoNotationLet@ constructors with let expressions.
@@ -60,3 +62,4 @@ desugarDo = everywhereM (mkM replace)
go (DoNotationLet binder val : rest) = do
rest' <- go rest
return $ Case [val] [CaseAlternative [binder] Nothing rest']
+ go (PositionedDoNotationElement pos el : rest) = PositionedValue pos <$> go (el : rest)
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 3f0d7cb..4410c74 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -216,6 +216,7 @@ renameInModule imports exports (Module mn decls exps) =
letBoundVariable :: Declaration -> Ident
letBoundVariable (ValueDeclaration ident _ _ _ _) = ident
+ letBoundVariable (PositionedDeclaration _ d) = letBoundVariable d
letBoundVariable _ = error "Invalid argument to letBoundVariable"
go (ValueDeclaration name _ _ _ _) = error $ "Binders should have been desugared in " ++ show name
go (ExternDeclaration fit name js ty) =
@@ -223,6 +224,7 @@ renameInModule imports exports (Module mn decls exps) =
go (BindingGroupDeclaration decls') = do
BindingGroupDeclaration <$> mapM go' decls'
where go' = \(name, nk, value) -> rethrowFor "declaration" name $ (,,) <$> pure name <*> pure nk <*> updateAll value
+ go (PositionedDeclaration pos d) = PositionedDeclaration pos <$> go d
go d = updateAll d
rethrowFor :: (Show a) => String -> a -> Either String b -> Either String b
@@ -230,20 +232,20 @@ renameInModule imports exports (Module mn decls exps) =
updateAll :: Data d => d -> Either String d
updateAll = everywhereM (mkM updateType `extM` updateValue `extM` updateBinder)
-
+
updateValue (Constructor name) = Constructor <$> updateDataConstructorName name
updateValue v = return v
-
+
updateBinder (ConstructorBinder name b) = ConstructorBinder <$> updateDataConstructorName name <*> pure b
updateBinder v = return v
-
+
updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name
updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys
updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints cs <*> pure t
updateType t = return t
updateType' :: Data d => d -> Either String d
updateType' = everywhereM (mkM updateType)
-
+
updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)
updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` (exportedTypes mes)))
@@ -299,6 +301,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri
addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
addDecl mn env (ValueDeclaration name _ _ _ _) = addValue env mn name
addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
+ addDecl mn env (PositionedDeclaration _ d) = addDecl mn env d
addDecl _ env _ = return env
-- |
@@ -365,6 +368,7 @@ findImports :: [Declaration] -> M.Map ModuleName (Maybe ExplicitImports, Maybe M
findImports = foldl findImports' M.empty
where
findImports' result (ImportDeclaration mn expl qual) = M.insert mn (expl, qual) result
+ findImports' result (PositionedDeclaration _ d) = findImports' result d
findImports' result _ = result
-- |
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index d0a3fc5..8147b69 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -20,7 +20,8 @@
{-# LANGUAGE Rank2Types, FlexibleContexts #-}
module Language.PureScript.Sugar.Operators (
- rebracket
+ rebracket,
+ removeSignedLiterals
) where
import Language.PureScript.Names
@@ -42,6 +43,8 @@ import qualified Text.Parsec as P
import qualified Text.Parsec.Pos as P
import qualified Text.Parsec.Expr as P
+import qualified Language.PureScript.Constants as C
+
-- |
-- Remove explicit parentheses and reorder binary operator applications
--
@@ -52,6 +55,14 @@ rebracket ms = do
let opTable = customOperatorTable fixities
mapM (rebracketModule opTable) ms
+removeSignedLiterals :: (D.Data d) => d -> d
+removeSignedLiterals = G.everywhere (G.mkT go)
+ where
+ go (UnaryMinus (NumericLiteral (Left n))) = NumericLiteral (Left $ negate n)
+ go (UnaryMinus (NumericLiteral (Right n))) = NumericLiteral (Right $ negate n)
+ go (UnaryMinus val) = App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.negate))) val
+ go other = other
+
rebracketModule :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Module -> Either String Module
rebracketModule opTable (Module mn ds exts) = Module mn <$> (removeParens <$> G.everywhereM' (G.mkM (matchOperators opTable)) ds) <*> pure exts
@@ -65,6 +76,7 @@ collectFixities :: Module -> [(Qualified Ident, Fixity)]
collectFixities (Module moduleName ds _) = concatMap collect ds
where
collect :: Declaration -> [(Qualified Ident, Fixity)]
+ collect (PositionedDeclaration _ d) = collect d
collect (FixityDeclaration fixity name) = [(Qualified (Just moduleName) (Op name), fixity)]
collect _ = []
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 67c35b0..a6f59c4 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -99,10 +99,14 @@ desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do
entries <- mapM (typeInstanceDictionaryEntryDeclaration name mn deps className ty) desugared
dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
return $ (Just $ TypeInstanceRef name, d : entries ++ [dictDecl])
+desugarDecl mn (PositionedDeclaration pos d) = do
+ (dr, ds) <- desugarDecl mn d
+ return (dr, map (PositionedDeclaration pos) ds)
desugarDecl _ other = return (Nothing, [other])
memberToNameAndType :: Declaration -> (String, Type)
memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty)
+memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d
memberToNameAndType _ = error "Invalid declaration in type class definition"
typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Declaration
@@ -114,6 +118,8 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
ExternDeclaration TypeClassAccessorImport ident
(Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))])))
(quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty))
+typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =
+ PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d
typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
@@ -143,6 +149,9 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do
return (identToJs ident, TypedValue False
(foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))
(quantify memberType))
+ memberToNameAndValue tys' (PositionedDeclaration pos d) = do
+ (ident, val) <- memberToNameAndValue tys' d
+ return (ident, PositionedValue pos val)
memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"
typeInstanceDictionaryEntryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> Declaration -> Desugar Declaration
@@ -157,6 +166,8 @@ typeInstanceDictionaryEntryDeclaration name mn deps className tys (ValueDeclarat
where
lookupTypeClass m = maybe (Left $ "Type class " ++ show className ++ " is undefined. Type class names must be qualified.") Right $ M.lookup (qualify mn className) m
lookupIdent members = maybe (Left $ "Type class " ++ show className ++ " does not have method " ++ show ident) Right $ lookup (identToJs ident) members
+typeInstanceDictionaryEntryDeclaration name mn deps className tys (PositionedDeclaration pos d) =
+ PositionedDeclaration pos <$> typeInstanceDictionaryEntryDeclaration name mn deps className tys d
typeInstanceDictionaryEntryDeclaration _ _ _ _ _ _ = error "Invalid declaration in type instance definition"
-- |
diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs
index 262f72e..ba54988 100644
--- a/src/Language/PureScript/Sugar/TypeDeclarations.hs
+++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs
@@ -27,6 +27,8 @@ import Control.Monad.Error.Class
import Control.Monad (forM)
import Language.PureScript.Declarations
+import Language.PureScript.Names
+import Language.PureScript.Environment
-- |
-- Replace all top level type declarations in a module with type annotations
@@ -38,9 +40,19 @@ desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) -> Module na
-- Replace all top level type declarations with type annotations
--
desugarTypeDeclarations :: [Declaration] -> Either String [Declaration]
-desugarTypeDeclarations (TypeDeclaration name ty : ValueDeclaration name' nameKind [] Nothing val : rest) | name == name' =
+desugarTypeDeclarations (PositionedDeclaration pos d : ds) = do
+ (d' : ds') <- desugarTypeDeclarations (d : ds)
+ return (PositionedDeclaration pos d' : ds')
+desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
+ (_, nameKind, val) <- fromValueDeclaration d
desugarTypeDeclarations (ValueDeclaration name nameKind [] Nothing (TypedValue True val ty) : rest)
-desugarTypeDeclarations (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name
+ where
+ fromValueDeclaration :: Declaration -> Either String (Ident, NameKind, Value)
+ fromValueDeclaration (ValueDeclaration name' nameKind [] Nothing val) | name == name' = return (name', nameKind, val)
+ fromValueDeclaration (PositionedDeclaration pos d') = do
+ (ident, nameKind, val) <- fromValueDeclaration d'
+ return (ident, nameKind, PositionedValue pos val)
+ fromValueDeclaration _ = throwError $ "Orphan type declaration for " ++ show name
desugarTypeDeclarations (ValueDeclaration name nameKind bs g val : rest) = do
(:) <$> (ValueDeclaration name nameKind bs g <$> everywhereM' (mkM go) val) <*> desugarTypeDeclarations rest
where
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index e55359a..e95f22b 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -26,6 +26,7 @@ import Language.PureScript.TypeChecker.Types as T
import Language.PureScript.TypeChecker.Synonyms as T
import Data.Maybe
+import Data.Monoid ((<>))
import qualified Data.Map as M
import Control.Monad.State
import Control.Monad.Error
@@ -36,14 +37,13 @@ import Language.PureScript.Kinds
import Language.PureScript.Declarations
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Environment
-import Language.PureScript.Pretty.Types
addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()
addDataType moduleName name args dctors ctorKind = do
env <- getEnv
putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
forM_ dctors $ \(dctor, tys) ->
- rethrow (("Error in data constructor " ++ show dctor ++ ":\n") ++) $
+ rethrow (strMsg ("Error in data constructor " ++ show dctor) <>) $
addDataConstructor moduleName name args dctor tys
addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
@@ -64,7 +64,7 @@ valueIsNotDefined :: ModuleName -> Ident -> Check ()
valueIsNotDefined moduleName name = do
env <- getEnv
case M.lookup (moduleName, name) (names env) of
- Just _ -> throwError $ show name ++ " is already defined"
+ Just _ -> throwError . strMsg $ show name ++ " is already defined"
Nothing -> return ()
addValue :: ModuleName -> Ident -> Type -> NameKind -> Check ()
@@ -85,10 +85,10 @@ checkTypeClassInstance :: ModuleName -> Type -> Check ()
checkTypeClassInstance _ (TypeVar _) = return ()
checkTypeClassInstance _ (TypeConstructor ctor) = do
env <- getEnv
- when (ctor `M.member` typeSynonyms env) $ throwError "Type synonym instances are disallowed"
+ when (ctor `M.member` typeSynonyms env) . throwError . strMsg $ "Type synonym instances are disallowed"
return ()
checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2
-checkTypeClassInstance _ ty = throwError $ "Type class instance head is invalid: " ++ prettyPrintType ty
+checkTypeClassInstance _ ty = throwError $ mkUnifyErrorStack "Type class instance head is invalid." (Just (TypeError ty))
-- |
-- Type check all declarations in a module
@@ -106,13 +106,13 @@ checkTypeClassInstance _ ty = throwError $ "Type class instance head is invalid:
typeCheckAll :: Maybe ModuleName -> ModuleName -> [Declaration] -> Check [Declaration]
typeCheckAll _ _ [] = return []
typeCheckAll mainModuleName moduleName (d@(DataDeclaration name args dctors) : rest) = do
- rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do
+ rethrow (strMsg ("Error in type constructor " ++ show name) <>) $ do
ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
addDataType moduleName name args dctors ctorKind
ds <- typeCheckAll mainModuleName moduleName rest
return $ d : ds
typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do
- rethrow ("Error in data binding group:\n" ++) $ do
+ rethrow (strMsg "Error in data binding group" <>) $ do
let syns = mapMaybe toTypeSynonym tys
let dataDecls = mapMaybe toDataDecl tys
(syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
@@ -124,18 +124,20 @@ typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : re
return $ d : ds
where
toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)
+ toTypeSynonym (PositionedDeclaration _ d') = toTypeSynonym d'
toTypeSynonym _ = Nothing
toDataDecl (DataDeclaration nm args dctors) = Just (nm, args, dctors)
+ toDataDecl (PositionedDeclaration _ d') = toDataDecl d'
toDataDecl _ = Nothing
typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do
- rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do
+ rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do
kind <- kindsOf False moduleName name args [ty]
addTypeSynonym moduleName name args ty kind
ds <- typeCheckAll mainModuleName moduleName rest
return $ d : ds
typeCheckAll _ _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
typeCheckAll mainModuleName moduleName (ValueDeclaration name nameKind [] Nothing val : rest) = do
- d <- rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do
+ d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do
valueIsNotDefined moduleName name
[(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
addValue moduleName name ty nameKind
@@ -144,7 +146,7 @@ typeCheckAll mainModuleName moduleName (ValueDeclaration name nameKind [] Nothin
return $ d : ds
typeCheckAll _ _ (ValueDeclaration{} : _) = error "Binders were not desugared"
typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = do
- d <- rethrow (("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals) ++ ":\n") ++) $ do
+ d <- rethrow (strMsg ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) <>) $ do
forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
valueIsNotDefined moduleName name
tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
@@ -160,19 +162,19 @@ typeCheckAll mainModuleName moduleName (d@(ExternDataDeclaration name kind) : re
ds <- typeCheckAll mainModuleName moduleName rest
return $ d : ds
typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do
- rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do
+ rethrow (strMsg ("Error in foreign import declaration " ++ show name) <>) $ do
env <- getEnv
kind <- kindOf moduleName ty
- guardWith "Expected kind *" $ kind == Star
+ guardWith (strMsg "Expected kind *") $ kind == Star
case M.lookup (moduleName, name) (names env) of
- Just _ -> throwError $ show name ++ " is already defined"
+ Just _ -> throwError . strMsg $ show name ++ " is already defined"
Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy) (names env) })
ds <- typeCheckAll mainModuleName moduleName rest
return $ d : ds
typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = do
ds <- typeCheckAll mainModuleName moduleName rest
env <- getEnv
- guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env
+ guardWith (strMsg ("Fixity declaration with no binding: " ++ name)) $ M.member (moduleName, Op name) $ names env
return $ d : ds
typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _ _) : rest) = do
env <- getEnv
@@ -194,3 +196,7 @@ typeCheckAll mainModuleName moduleName (d@(ExternInstanceDeclaration dictName de
addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular]
ds <- typeCheckAll mainModuleName moduleName rest
return $ d : ds
+typeCheckAll mainModuleName moduleName (PositionedDeclaration pos d : rest) =
+ rethrowWithPosition pos $ do
+ (d' : rest') <- typeCheckAll mainModuleName moduleName (d : rest)
+ return (PositionedDeclaration pos d' : rest')
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index c8e43bf..3dedadf 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -14,7 +14,7 @@
-----------------------------------------------------------------------------
{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
module Language.PureScript.TypeChecker.Kinds (
kindOf,
@@ -36,6 +36,7 @@ import Control.Monad.Unify
import Control.Applicative
import qualified Data.Map as M
+import Data.Monoid ((<>))
instance Partial Kind where
unknown = KUnknown
@@ -52,14 +53,14 @@ instance Unifiable Check Kind where
FunKind k1 k2 =?= FunKind k3 k4 = do
k1 =?= k3
k2 =?= k4
- k1 =?= k2 = UnifyT . lift . throwError $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."
+ k1 =?= k2 = UnifyT . lift . throwError . strMsg $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."
-- |
-- Infer the kind of a single type
--
kindOf :: ModuleName -> Type -> Check Kind
kindOf _ ty =
- rethrow (("Error checking kind of " ++ prettyPrintType ty ++ ":\n") ++) $
+ rethrow (mkUnifyErrorStack "Error checking kind" (Just (TypeError ty)) <>) $
fmap tidyUp . liftUnify $ starIfUnknown <$> infer ty
where
tidyUp (k, sub) = sub $? k
@@ -105,7 +106,7 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
-- |
-- Solve the set of kind constraints associated with the data constructors for a type constructor
--
-solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind Check Kind
+solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind (Check) Kind
solveTypes isData ts kargs tyCon = do
ks <- mapM infer ts
when isData $ do
@@ -128,39 +129,44 @@ starIfUnknown k = k
-- Infer a kind for a type
--
infer :: Type -> UnifyT Kind Check Kind
-infer (TypeVar v) = do
+infer ty = rethrow (mkUnifyErrorStack "Error inferring type of value" (Just (TypeError ty)) <>) $ infer' ty
+
+infer' :: Type -> UnifyT Kind Check Kind
+infer' (TypeVar v) = do
Just moduleName <- checkCurrentModule <$> get
UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
-infer (TypeConstructor v) = do
+infer' c@(TypeConstructor v) = do
env <- liftCheck getEnv
case M.lookup v (types env) of
- Nothing -> UnifyT . lift . throwError $ "Unknown type constructor '" ++ show v ++ "'"
+ Nothing -> UnifyT . lift . throwError $ mkUnifyErrorStack "Unknown type constructor" (Just (TypeError c))
Just (kind, _) -> return kind
-infer (TypeApp t1 t2) = do
+infer' (TypeApp t1 t2) = do
k0 <- fresh
k1 <- infer t1
k2 <- infer t2
k1 =?= FunKind k2 k0
return k0
-infer (ForAll ident ty _) = do
+infer' (ForAll ident ty _) = do
k1 <- fresh
Just moduleName <- checkCurrentModule <$> get
k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty
k2 =?= Star
return Star
-infer REmpty = do
+infer' REmpty = do
k <- fresh
return $ Row k
-infer (RCons _ ty row) = do
+infer' (RCons _ ty row) = do
k1 <- infer ty
k2 <- infer row
k2 =?= Row k1
return $ Row k1
-infer (ConstrainedType deps ty) = do
+infer' (ConstrainedType deps ty) = do
forM_ deps $ \(className, tys) -> do
_ <- infer $ foldl TypeApp (TypeConstructor className) tys
return ()
k <- infer ty
k =?= Star
return Star
-infer _ = error "Invalid argument to infer"
+infer' _ = error "Invalid argument to infer"
+
+
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 70ab2c4..8e82d92 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -21,10 +21,14 @@ module Language.PureScript.TypeChecker.Monad where
import Language.PureScript.Types
import Language.PureScript.Kinds
import Language.PureScript.Names
+import Language.PureScript.Declarations
import Language.PureScript.Environment
import Language.PureScript.TypeClassDictionaries
+import Language.PureScript.Pretty
+import Language.PureScript.Options
import Data.Maybe
+import Data.Monoid
import Control.Applicative
import Control.Monad.State
@@ -32,6 +36,78 @@ import Control.Monad.Error
import Control.Monad.Unify
import qualified Data.Map as M
+import Data.List (intercalate)
+
+-- |
+-- Type for sources of type checking errors
+--
+data UnifyErrorSource
+ -- |
+ -- An error which originated at a Value
+ --
+ = ValueError Value
+ -- |
+ -- An error which originated at a Type
+ --
+ | TypeError Type deriving (Show)
+
+-- |
+-- Unification errors
+--
+data UnifyError = UnifyError {
+ -- |
+ -- Error message
+ --
+ unifyErrorMessage :: String
+ -- |
+ -- The value where the error occurred
+ --
+ , unifyErrorValue :: Maybe UnifyErrorSource
+ -- |
+ -- Optional source position information
+ --
+ , unifyErrorPosition :: Maybe SourcePos
+ } deriving (Show)
+
+-- |
+-- A stack trace for an error
+--
+newtype UnifyErrorStack = UnifyErrorStack { runUnifyErrorStack :: [UnifyError] } deriving (Show, Monoid)
+
+instance Error UnifyErrorStack where
+ strMsg s = UnifyErrorStack [UnifyError s Nothing Nothing]
+ noMsg = UnifyErrorStack []
+
+prettyPrintUnifyErrorStack :: Options -> UnifyErrorStack -> String
+prettyPrintUnifyErrorStack opts (UnifyErrorStack es) =
+ case mconcat $ map (Last . unifyErrorPosition) es of
+ Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintUnifyErrorStack'
+ _ -> prettyPrintUnifyErrorStack'
+ where
+ prettyPrintUnifyErrorStack' :: String
+ prettyPrintUnifyErrorStack'
+ | optionsVerboseErrors opts =
+ intercalate "\n" (map showError (filter isErrorNonEmpty es))
+ | otherwise =
+ let
+ es' = filter isErrorNonEmpty es
+ in case length es' of
+ 1 -> showError (head es')
+ _ -> showError (head es') ++ "\n" ++ showError (last es')
+
+isErrorNonEmpty :: UnifyError -> Bool
+isErrorNonEmpty = not . null . unifyErrorMessage
+
+showError :: UnifyError -> String
+showError (UnifyError msg Nothing _) = msg
+showError (UnifyError msg (Just (ValueError val)) _) = "Error in value " ++ prettyPrintValue val ++ "\n" ++ msg
+showError (UnifyError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ "\n" ++ msg
+
+mkUnifyErrorStack :: String -> Maybe UnifyErrorSource -> UnifyErrorStack
+mkUnifyErrorStack msg t = UnifyErrorStack [UnifyError msg t Nothing]
+
+positionError :: SourcePos -> UnifyErrorStack
+positionError pos = UnifyErrorStack [UnifyError "" Nothing (Just pos)]
-- |
-- Temporarily bind a collection of names to values
@@ -89,21 +165,21 @@ bindLocalTypeVariables moduleName bindings =
-- |
-- Lookup the type of a value by name in the @Environment@
--
-lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified Ident -> m Type
+lookupVariable :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type
lookupVariable currentModule (Qualified moduleName var) = do
env <- getEnv
case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
- Nothing -> throwError $ show var ++ " is undefined"
+ Nothing -> throwError . strMsg $ show var ++ " is undefined"
Just (ty, _) -> return ty
-- |
-- Lookup the kind of a type by name in the @Environment@
--
-lookupTypeVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified ProperName -> m Kind
+lookupTypeVariable :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind
lookupTypeVariable currentModule (Qualified moduleName name) = do
env <- getEnv
case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of
- Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"
+ Nothing -> throwError . strMsg $ "Type variable " ++ show name ++ " is undefined"
Just (k, _) -> return k
-- |
@@ -131,8 +207,8 @@ data CheckState = CheckState {
-- |
-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
--
-newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }
- deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError String)
+newtype Check a = Check { unCheck :: StateT CheckState (Either UnifyErrorStack) a }
+ deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError UnifyErrorStack)
-- |
-- Get the current @Environment@
@@ -155,14 +231,14 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
-- |
-- Run a computation in the Check monad, starting with an empty @Environment@
--
-runCheck :: Check a -> Either String (a, Environment)
-runCheck = runCheck' initEnvironment
+runCheck :: Options -> Check a -> Either String (a, Environment)
+runCheck opts = runCheck' opts initEnvironment
-- |
-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.
--
-runCheck' :: Environment -> Check a -> Either String (a, Environment)
-runCheck' env c = do
+runCheck' :: Options -> Environment -> Check a -> Either String (a, Environment)
+runCheck' opts env c = either (Left . prettyPrintUnifyErrorStack opts) Right $ do
(a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c
return (a, checkEnv s)
@@ -180,6 +256,12 @@ rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
rethrow f = flip catchError $ \e -> throwError (f e)
-- |
+-- Rethrow an error with source position information
+--
+rethrowWithPosition :: (MonadError UnifyErrorStack m) => SourcePos -> m a -> m a
+rethrowWithPosition pos = rethrow (positionError pos <>)
+
+-- |
-- Generate new type class dictionary name
--
freshDictionaryName :: Check Int
@@ -192,7 +274,7 @@ freshDictionaryName = do
-- Lift a computation in the @Check@ monad into the substitution monad.
--
liftCheck :: Check a -> UnifyT t Check a
-liftCheck = UnifyT . lift . lift
+liftCheck = UnifyT . lift
-- |
-- Run a computation in the substitution monad, generating a return value and the final substitution.
@@ -200,9 +282,7 @@ liftCheck = UnifyT . lift . lift
liftUnify :: (Partial t) => UnifyT t Check a -> Check (a, Substitution t)
liftUnify unify = do
st <- get
- e <- runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify
- case e of
- Left err -> throwError err
- Right (a, ust) -> do
- modify $ \st' -> st' { checkNextVar = unifyNextVar ust }
- return (a, unifyCurrentSubstitution ust)
+ (a, ust) <- runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify
+ modify $ \st' -> st' { checkNextVar = unifyNextVar ust }
+ return (a, unifyCurrentSubstitution ust)
+
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 21cb6b6..e75b25b 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -14,6 +14,7 @@
-----------------------------------------------------------------------------
{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@@ -70,6 +71,7 @@ import Control.Arrow (Arrow(..))
import qualified Data.Map as M
import Data.Function (on)
import Data.Ord (comparing)
+import Data.Monoid ((<>))
instance Partial Type where
unknown = TUnknown
@@ -83,7 +85,7 @@ instance Unifiable Check Type where
-- Unify two types, updating the current substitution
--
unifyTypes :: Type -> Type -> UnifyT Type Check ()
-unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $
+unifyTypes t1 t2 = rethrow (mkUnifyErrorStack ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing <>) $
unifyTypes' t1 t2
where
unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()
@@ -100,16 +102,16 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
let sk1 = skolemize ident1 sko sc1' ty1
let sk2 = skolemize ident2 sko sc2' ty2
sk1 `unifyTypes` sk2
- _ -> throwError (prettyPrintType ty1)
+ _ -> error "Skolemized type variable was not given a scope"
unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do
sko <- newSkolemConstant
let sk = skolemize ident sko sc ty1
sk `unifyTypes` ty2
- unifyTypes' ForAll{} _ = throwError "Skolem variable scope is unspecified"
+ unifyTypes' ForAll{} _ = throwError . strMsg $ "Skolem variable scope is unspecified"
unifyTypes' ty f@ForAll{} = f `unifyTypes` ty
unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
unifyTypes' (TypeConstructor c1) (TypeConstructor c2) =
- guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (c1 == c2)
+ guardWith (strMsg ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".")) (c1 == c2)
unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
t3 `unifyTypes` t5
t4 `unifyTypes` t6
@@ -118,10 +120,9 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
unifyTypes' r1 r2@RCons{} = unifyRows r1 r2
unifyTypes' r1@REmpty r2 = unifyRows r1 r2
unifyTypes' r1 r2@REmpty = unifyRows r1 r2
- unifyTypes' t@(ConstrainedType _ _) _ = throwError $ "Attempted to unify a constrained type " ++ prettyPrintType t ++
- " with another type."
+ unifyTypes' t@(ConstrainedType _ _) _ = throwError . strMsg $ "Attempted to unify a constrained type " ++ prettyPrintType t ++ " with another type."
unifyTypes' t3 t4@(ConstrainedType _ _) = unifyTypes' t4 t3
- unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
+ unifyTypes' t3 t4 = throwError . strMsg $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
-- |
-- Unify two rows, updating the current substitution
@@ -154,7 +155,7 @@ unifyRows r1 r2 =
unifyRows' [] REmpty [] REmpty = return ()
unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
unifyRows' [] (Skolem s1 _) [] (Skolem s2 _) | s1 == s2 = return ()
- unifyRows' sd3 r3 sd4 r4 = throwError $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")."
+ unifyRows' sd3 r3 sd4 r4 = throwError . strMsg $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")"
-- |
-- Infer the types of multiple mutually-recursive values, and return elaborated values including
@@ -217,7 +218,7 @@ typeForBindingGroupElement moduleName e@(_, (val, _)) dict untypedDict = do
(ident, (val', Just (ty, checkType))) -> do
-- Kind check
kind <- liftCheck $ kindOf moduleName ty
- guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
+ guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
-- Check the type with the new names in scope
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
val'' <- bindNames dict' $ if checkType
@@ -237,6 +238,7 @@ typeForBindingGroupElement moduleName e@(_, (val, _)) dict untypedDict = do
isFunction :: Value -> Bool
isFunction (Abs _ _) = True
isFunction (TypedValue _ val _) = isFunction val
+isFunction (PositionedValue _ val) = isFunction val
isFunction _ = False
-- |
@@ -270,7 +272,7 @@ replaceTypeClassDictionaries mn = everywhereM' (mkM go)
entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Check Value
entails env moduleName context goal@(className, tys) = do
case go goal of
- [] -> throwError $ "No " ++ show className ++ " instance found for " ++ intercalate ", " (map prettyPrintType tys)
+ [] -> throwError . strMsg $ "No " ++ show className ++ " instance found for " ++ intercalate ", " (map prettyPrintType tys)
(dict : _) -> return dict
where
go (className', tys') =
@@ -362,7 +364,7 @@ skolemEscapeCheck root@TypedValue{} =
-- an escaped skolem variable.
case everythingWithContext [] (++) (mkQ ((,) []) go) root of
[] -> return ()
- ((binding, val) : _) -> throwError $ "Rigid/skolem type variable bound by " ++ maybe "<unknown>" prettyPrintValue binding ++ " has escaped at " ++ prettyPrintValue val
+ ((binding, val) : _) -> throwError $ mkUnifyErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ValueError val))
where
go :: Value -> [(SkolemScope, Value)] -> ([(Maybe Value, Value)], [(SkolemScope, Value)])
go val@(TypedValue _ _ (ForAll _ _ (Just sco))) scos = ([], (sco, val) : scos)
@@ -381,7 +383,7 @@ skolemEscapeCheck root@TypedValue{} =
where
go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = Just val
go' _ = Nothing
-skolemEscapeCheck val = throwError $ "Untyped value passed to skolemEscapeCheck: " ++ prettyPrintValue val
+skolemEscapeCheck val = throwError $ mkUnifyErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ValueError val))
-- |
-- Ensure a row contains no duplicate labels
@@ -444,10 +446,10 @@ replaceAllTypeSynonyms' env d =
in
saturateAllTypeSynonyms syns d
-replaceAllTypeSynonyms :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => (D.Data d) => d -> m d
+replaceAllTypeSynonyms :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => (D.Data d) => d -> m d
replaceAllTypeSynonyms d = do
env <- getEnv
- either throwError return $ replaceAllTypeSynonyms' env d
+ either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d
-- |
-- \"Desaturate\" @SaturatedTypeSynonym@s
@@ -469,12 +471,12 @@ expandTypeSynonym' env name args =
replaceAllTypeSynonyms' env repl
Nothing -> error "Type synonym was not defined"
-expandTypeSynonym :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => Qualified ProperName -> [Type] -> m Type
+expandTypeSynonym :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type
expandTypeSynonym name args = do
env <- getEnv
- either throwError return $ expandTypeSynonym' env name args
+ either (throwError . strMsg) return $ expandTypeSynonym' env name args
-expandAllTypeSynonyms :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => Type -> m Type
+expandAllTypeSynonyms :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
expandAllTypeSynonyms = everywhereM' (mkM go)
where
go (SaturatedTypeSynonym name args) = expandTypeSynonym name args
@@ -483,14 +485,14 @@ expandAllTypeSynonyms = everywhereM' (mkM go)
-- |
-- Ensure a set of property names and value does not contain duplicate labels
--
-ensureNoDuplicateProperties :: (MonadError String m) => [(String, Value)] -> m ()
-ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps
+ensureNoDuplicateProperties :: (Error e, MonadError e m) => [(String, Value)] -> m ()
+ensureNoDuplicateProperties ps = guardWith (strMsg "Duplicate property names") $ length (nub . map fst $ ps) == length ps
-- |
-- Infer a type for a value, rethrowing any error to provide a more useful error message
--
infer :: Value -> UnifyT Type Check Value
-infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ infer' val
+infer val = rethrow (mkUnifyErrorStack "Error inferring type of value" (Just (ValueError val)) <>) $ infer' val
-- |
-- Infer a type for a value
@@ -551,7 +553,7 @@ infer' (Var var) = do
infer' v@(Constructor c) = do
env <- getEnv
case M.lookup c (dataConstructors env) of
- Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
+ Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"
Just (_, ty) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
return $ TypedValue True v ty'
infer' (Case vals binders) = do
@@ -571,10 +573,11 @@ infer' (Let ds val) = do
infer' (TypedValue checkType val ty) = do
Just moduleName <- checkCurrentModule <$> get
kind <- liftCheck $ kindOf moduleName ty
- guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
+ guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
val' <- if checkType then check val ty' else return val
return $ TypedValue True val' ty'
+infer' (PositionedValue pos val) = rethrowWithPosition pos $ infer' val
infer' _ = error "Invalid argument to infer"
inferLetBinding :: [Declaration] -> [Declaration] -> Value -> (Value -> UnifyT Type Check Value) -> UnifyT Type Check ([Declaration], Value)
@@ -592,7 +595,10 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
(ident, (val', _)) <- typeForBindingGroupElement moduleName e dict untypedDict
return $ (ident, LocalVariable, val')
bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
-inferLetBinding _ _ _ _ = error "Invalid argument to fromValueDeclaration"
+inferLetBinding seen (PositionedDeclaration pos d : ds) ret j = do
+ ((d' : ds'), val') <- inferLetBinding seen (d : ds) ret j
+ return (PositionedDeclaration pos d' : ds', val')
+inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding"
-- |
-- Infer the type of a property inside a record with a given type
@@ -631,8 +637,8 @@ inferBinder val (ConstructorBinder ctor binders) = do
return M.empty
go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =
M.union <$> inferBinder obj binder <*> go binders' ret
- go _ _ = throwError $ "Wrong number of arguments to constructor " ++ show ctor
- _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
+ go _ _ = throwError . strMsg $ "Wrong number of arguments to constructor " ++ show ctor
+ _ -> throwError . strMsg $ "Constructor " ++ show ctor ++ " is not defined"
inferBinder val (ObjectBinder props) = do
row <- fresh
rest <- fresh
@@ -661,6 +667,8 @@ inferBinder val (ConsBinder headBinder tailBinder) = do
inferBinder val (NamedBinder name binder) = do
m <- inferBinder val binder
return $ M.insert name val m
+inferBinder val (PositionedBinder pos binder) =
+ rethrowWithPosition pos $ inferBinder val binder
-- |
-- Check the types of the return values in a set of binders in a case statement
@@ -711,15 +719,13 @@ introduceSkolemScope = everywhereM (mkM go)
-- Check the type of a value, rethrowing errors to provide a better error message
--
check :: Value -> Type -> UnifyT Type Check Value
-check val ty = rethrow errorMessage $ check' val ty
+check val ty = rethrow (mkUnifyErrorStack errorMessage (Just (ValueError val)) <>) $ check' val ty
where
- errorMessage msg =
+ errorMessage =
"Error checking type of term " ++
prettyPrintValue val ++
" against type " ++
- prettyPrintType ty ++
- ":\n" ++
- msg
+ prettyPrintType ty
-- |
-- Check the type of a value
@@ -773,16 +779,16 @@ check' v@(Var var) ty = do
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
v' <- subsumes (Just v) repl ty'
case v' of
- Nothing -> throwError "Unable to check type subsumption"
+ Nothing -> throwError . strMsg $ "Unable to check type subsumption"
Just v'' -> return $ TypedValue True v'' ty'
check' (TypedValue checkType val ty1) ty2 = do
Just moduleName <- checkCurrentModule <$> get
kind <- liftCheck $ kindOf moduleName ty1
- guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
+ guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
val' <- subsumes (Just val) ty1' ty2
case val' of
- Nothing -> throwError "Unable to check type subsumption"
+ Nothing -> throwError . strMsg $ "Unable to check type subsumption"
Just val'' -> do
val''' <- if checkType then check val'' ty1' else return val''
return $ TypedValue checkType (TypedValue True val''' ty1) ty2
@@ -816,7 +822,7 @@ check' (Accessor prop val) ty = do
check' (Constructor c) ty = do
env <- getEnv
case M.lookup c (dataConstructors env) of
- Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
+ Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"
Just (_, ty1) -> do
repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
_ <- subsumes Nothing repl ty
@@ -827,7 +833,9 @@ check' (Let ds val) ty = do
check' val ty | containsTypeSynonyms ty = do
ty' <- introduceSkolemScope <=< expandAllTypeSynonyms $ ty
check val ty'
-check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
+check' (PositionedValue pos val) ty =
+ rethrowWithPosition pos $ check val ty
+check' val ty = throwError $ mkUnifyErrorStack ("Value does not have type " ++ prettyPrintType ty) (Just (ValueError val))
containsTypeSynonyms :: Type -> Bool
containsTypeSynonyms = everything (||) (mkQ False go) where
@@ -846,8 +854,8 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
return []
go [] [] (Skolem _ _) | lax = return []
go [] ((p, _): _) _ | lax = return []
- | otherwise = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have property " ++ p
- go ((p,_):_) [] REmpty = throwError $ "Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row
+ | otherwise = throwError $ mkUnifyErrorStack ("Object does not have property " ++ p) (Just (ValueError (ObjectLiteral ps)))
+ go ((p,_):_) [] REmpty = throwError $ mkUnifyErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ValueError (ObjectLiteral ps)))
go ((p,v):ps') [] u@(TUnknown _) = do
v'@(TypedValue _ _ ty) <- infer v
rest <- fresh
@@ -866,18 +874,17 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
v' <- check v ty
ps'' <- go ps' (delete (p, ty) ts) r
return $ (p, v') : ps''
- go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (TypeApp tyObject row)
+ go _ _ _ = throwError $ mkUnifyErrorStack ("Object does not have type " ++ prettyPrintType (TypeApp tyObject row)) (Just (ValueError (ObjectLiteral ps)))
-- |
-- Check the type of a function application, rethrowing errors to provide a better error message
--
checkFunctionApplication :: Value -> Type -> Value -> Maybe Type -> UnifyT Type Check (Type, Value)
-checkFunctionApplication fn fnTy arg ret = rethrow errorMessage $ checkFunctionApplication' fn fnTy arg ret
+checkFunctionApplication fn fnTy arg ret = rethrow (mkUnifyErrorStack errorMessage (Just (ValueError fn)) <>) $ checkFunctionApplication' fn fnTy arg ret
where
- errorMessage msg = "Error applying function of type "
+ errorMessage = "Error applying function of type "
++ prettyPrintType fnTy
++ " to argument " ++ prettyPrintValue arg
- ++ ":\n" ++ msg
-- |
-- Check the type of a function application
@@ -907,7 +914,7 @@ checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do
checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
dicts <- getTypeClassDictionaries
checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy arg ret
-checkFunctionApplication' _ fnTy arg _ = throwError $ "Cannot apply a function of type "
+checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a function of type "
++ prettyPrintType fnTy
++ " to argument " ++ prettyPrintValue arg
@@ -915,13 +922,12 @@ checkFunctionApplication' _ fnTy arg _ = throwError $ "Cannot apply a function o
-- Check whether one type subsumes another, rethrowing errors to provide a better error message
--
subsumes :: Maybe Value -> Type -> Type -> UnifyT Type Check (Maybe Value)
-subsumes val ty1 ty2 = rethrow errorMessage $ subsumes' val ty1 ty2
+subsumes val ty1 ty2 = rethrow (mkUnifyErrorStack errorMessage (ValueError <$> val) <>) $ subsumes' val ty1 ty2
where
- errorMessage msg = "Error checking that type "
+ errorMessage = "Error checking that type "
++ prettyPrintType ty1
++ " subsumes type "
++ prettyPrintType ty2
- ++ ":\n" ++ msg
-- |
-- Check whether one type subsumes another
@@ -936,7 +942,7 @@ subsumes' val ty1 (ForAll ident ty2 sco) =
sko <- newSkolemConstant
let sk = skolemize ident sko sco' ty2
subsumes val ty1 sk
- Nothing -> throwError "Skolem variable scope is unspecified"
+ Nothing -> throwError . strMsg $ "Skolem variable scope is unspecified"
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
@@ -976,3 +982,4 @@ subsumes' val ty1 ty2 = do
ty1 =?= ty2
return val
+