packages feed

purescript 0.4.9 → 0.4.10

raw patch · 29 files changed

+568/−225 lines, 29 files

Files

docgen/Main.hs view
@@ -84,6 +84,7 @@ 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 @@                           [] -> ""                           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
psc-make/Main.hs view
@@ -115,8 +115,12 @@ 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
psc/Main.hs view
@@ -122,8 +122,12 @@ 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
psci/Main.hs view
@@ -194,7 +194,7 @@ -- | 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.
purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.4.9+version: 0.4.10 cabal-version: >=1.8 build-type: Custom license: MIT
src/Language/PureScript.hs view
@@ -71,7 +71,7 @@ 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 @@   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,8 +119,8 @@     where     go (TypeRef tyName' _) = tyName' /= tyName     go _ = True-     + generateMain :: Environment -> Options -> [JS] -> Either String [JS] generateMain env opts js =   case moduleNameFromString <$> optionsMain opts of@@ -191,7 +192,7 @@   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 @@         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 @@   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
src/Language/PureScript/CodeGen/Externs.hs view
@@ -45,6 +45,7 @@     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] ()
src/Language/PureScript/CodeGen/JS.hs view
@@ -82,6 +82,7 @@         (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 (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
src/Language/PureScript/DeadCodeElimination.hs view
@@ -50,11 +50,13 @@   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 @@   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 @@                         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
src/Language/PureScript/Declarations.hs view
@@ -42,6 +42,24 @@   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 @@   -- 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 @@ -- isValueDecl :: Declaration -> Bool isValueDecl ValueDeclaration{} = True+isValueDecl (PositionedDeclaration _ d) = isValueDecl d isValueDecl _ = False  -- |@@ -147,6 +170,7 @@ isDataDecl :: Declaration -> Bool isDataDecl DataDeclaration{} = True isDataDecl TypeSynonymDeclaration{} = True+isDataDecl (PositionedDeclaration _ d) = isDataDecl d isDataDecl _ = False  -- |@@ -154,6 +178,7 @@ -- isImportDecl :: Declaration -> Bool isImportDecl ImportDeclaration{} = True+isImportDecl (PositionedDeclaration _ d) = isImportDecl d isImportDecl _ = False  -- |@@ -161,6 +186,7 @@ -- isExternDataDecl :: Declaration -> Bool isExternDataDecl ExternDataDeclaration{} = True+isExternDataDecl (PositionedDeclaration _ d) = isExternDataDecl d isExternDataDecl _ = False  -- |@@ -168,6 +194,7 @@ -- isExternInstanceDecl :: Declaration -> Bool isExternInstanceDecl ExternInstanceDeclaration{} = True+isExternInstanceDecl (PositionedDeclaration _ d) = isExternInstanceDecl d isExternInstanceDecl _ = False  -- |@@ -175,6 +202,7 @@ -- isFixityDecl :: Declaration -> Bool isFixityDecl FixityDeclaration{} = True+isFixityDecl (PositionedDeclaration _ d) = isFixityDecl d isFixityDecl _ = False  -- |@@ -182,6 +210,7 @@ -- isExternDecl :: Declaration -> Bool isExternDecl ExternDeclaration{} = True+isExternDecl (PositionedDeclaration _ d) = isExternDecl d isExternDecl _ = False  -- |@@ -190,6 +219,7 @@ isTypeClassDeclaration :: Declaration -> Bool isTypeClassDeclaration TypeClassDeclaration{} = True isTypeClassDeclaration TypeInstanceDeclaration{} = True+isTypeClassDeclaration (PositionedDeclaration _ d) = isTypeClassDeclaration d isTypeClassDeclaration _ = False  -- |@@ -214,6 +244,10 @@   --   | 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 @@   -- 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 @@   -- |   -- 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 @@   -- |   -- 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
src/Language/PureScript/ModuleDependencies.hs view
@@ -56,6 +56,7 @@   qualifiedProperNames _ = []   imports :: Declaration -> [ModuleName]   imports (ImportDeclaration mn _ _) = [mn]+  imports (PositionedDeclaration _ d) = imports d   imports _ = []  getModuleName :: Module -> ModuleName
src/Language/PureScript/Options.hs view
@@ -57,10 +57,14 @@     -- 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
src/Language/PureScript/Parser/Common.hs view
@@ -227,14 +227,8 @@ -- 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 @@ -- runIndentParser :: FilePath -> P.Parsec String ParseState a -> String -> Either P.ParseError a runIndentParser filePath p = P.runParser p (ParseState 0) filePath+
src/Language/PureScript/Parser/Declarations.hs view
@@ -38,6 +38,14 @@ 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 @@ -- 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 @@                    ] 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 @@ -- 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 @@   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 @@ -- 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
src/Language/PureScript/Pretty/Common.hs view
@@ -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
src/Language/PureScript/Pretty/JS.hs view
@@ -27,39 +27,14 @@ 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@@ -139,6 +114,22 @@     ]   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
src/Language/PureScript/Pretty/Values.hs view
@@ -20,132 +20,207 @@  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+  match (TypedValue _ val _) = prettyPrintValue' val+  match (PositionedValue _ val) = prettyPrintValue' val+  match _ = mzero -prettyPrintCaseAlternative :: CaseAlternative -> String+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+  fmap concat $ sequence+    [ intercalate ", " <$> forM binders prettyPrintBinder'+    , maybe (return "") (fmap ("| " ++) . prettyPrintValue') grd+    , return " -> "+    , prettyPrintValue' val+    ] -ifThenElse :: Pattern () Value ((Value, Value), Value)+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+prettyPrintObjectPropertyBinder :: (String, Binder) -> StateT PrinterState Maybe String+prettyPrintObjectPropertyBinder (key, binder) = fmap concat $ sequence+    [ return $ key ++ ": "+    , prettyPrintBinder' binder+    ] -prettyPrintObjectProperty :: String -> Value -> String-prettyPrintObjectProperty key value = key ++ ": " ++ prettyPrintValue value+prettyPrintObjectProperty :: (String, Value) -> StateT PrinterState Maybe String+prettyPrintObjectProperty (key, value) = fmap concat $ sequence+    [ return $ key ++ ": "+    , prettyPrintValue' value+    ]
src/Language/PureScript/Sugar.hs view
@@ -27,6 +27,8 @@ 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 @@ --  * Qualify any unqualified names and types -- desugar :: [Module] -> Either String [Module]-desugar = desugarDo+desugar = removeSignedLiterals+          >>> desugarDo           >=> desugarCasesModule           >=> desugarTypeDeclarationsModule           >=> desugarImports
src/Language/PureScript/Sugar/BindingGroups.hs view
@@ -26,7 +26,7 @@ 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 @@   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 @@  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 @@  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"
src/Language/PureScript/Sugar/CaseDeclarations.hs view
@@ -62,11 +62,16 @@       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 @@   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 @@  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
src/Language/PureScript/Sugar/DoNotation.hs view
@@ -27,6 +27,8 @@  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 @@   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)
src/Language/PureScript/Sugar/Names.hs view
@@ -216,6 +216,7 @@      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 @@   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 @@    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 @@   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 = 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  -- |
src/Language/PureScript/Sugar/Operators.hs view
@@ -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.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 @@   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 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 _ = []
src/Language/PureScript/Sugar/TypeClasses.hs view
@@ -99,10 +99,14 @@   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 @@   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 @@     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 @@   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"  -- |
src/Language/PureScript/Sugar/TypeDeclarations.hs view
@@ -27,6 +27,8 @@ 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 @@ -- 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
src/Language/PureScript/TypeChecker.hs view
@@ -26,6 +26,7 @@ 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.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 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 _ (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 @@ 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 @@   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 @@   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 @@   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 @@   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')
src/Language/PureScript/TypeChecker/Kinds.hs view
@@ -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.Applicative  import qualified Data.Map as M+import Data.Monoid ((<>))  instance Partial Kind where   unknown = KUnknown@@ -52,14 +53,14 @@   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 @@ -- | -- 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 @@ -- 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"++
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -21,10 +21,14 @@ 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,8 +36,80 @@ 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 -- bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a@@ -89,21 +165,21 @@ -- | -- 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 @@ -- | -- 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 @@ -- | -- 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 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 @@ -- 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 @@ 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)+
src/Language/PureScript/TypeChecker/Types.hs view
@@ -14,6 +14,7 @@ -----------------------------------------------------------------------------  {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -70,6 +71,7 @@ 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 @@ -- 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 @@         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' 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' [] 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 @@     (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 @@ isFunction :: Value -> Bool isFunction (Abs _ _) = True isFunction (TypedValue _ val _) = isFunction val+isFunction (PositionedValue _ val) = isFunction val isFunction _ = False  -- |@@ -270,7 +272,7 @@ 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 @@   -- 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 @@     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 @@   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 @@       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 @@ -- | -- 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' 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' (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 @@     (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 @@           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 (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 @@ -- 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 @@   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' (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' 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 @@                                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 @@         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 (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 @@ -- 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 @@       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@@ -975,4 +981,5 @@ subsumes' val ty1 ty2 = do   ty1 =?= ty2   return val+