packages feed

purescript 0.4.10.2 → 0.4.11

raw patch · 20 files changed

+306/−238 lines, 20 files

Files

purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.4.10.2+version: 0.4.11 cabal-version: >=1.8 build-type: Custom license: MIT@@ -32,6 +32,7 @@                      Language.PureScript.Options                      Language.PureScript.Declarations                      Language.PureScript.Environment+                     Language.PureScript.Errors                      Language.PureScript.Kinds                      Language.PureScript.Names                      Language.PureScript.Types
src/Language/PureScript.hs view
@@ -28,6 +28,7 @@ import Language.PureScript.Options as P import Language.PureScript.ModuleDependencies as P import Language.PureScript.Environment as P+import Language.PureScript.Errors as P import Language.PureScript.DeadCodeElimination as P  import qualified Language.PureScript.Constants as C@@ -70,9 +71,9 @@ compile' :: Environment -> Options -> [Module] -> Either String (String, String, Environment) compile' env opts ms = do   (sorted, _) <- sortModules $ if optionsNoPrelude opts then ms else (map importPrelude ms)-  desugared <- desugar sorted+  desugared <- stringifyErrorStack True $ desugar sorted   (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent-  regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated+  regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated   let entryPoints = moduleNameFromString `map` optionsModules opts   let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped   let codeGenModules = moduleNameFromString `map` optionsCodeGenModules opts@@ -184,7 +185,7 @@    marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted -  desugared <- liftError $ zip (map fst marked) <$> desugar (map snd marked)+  desugared <- liftError $ stringifyErrorStack True $ zip (map fst marked) <$> desugar (map snd marked)    go initEnvironment desugared @@ -202,7 +203,7 @@      (Module _ elaborated _, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m -    regrouped <- liftError . createBindingGroups moduleName' . collapseBindingGroups $ elaborated+    regrouped <- liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated      let mod' = Module moduleName' regrouped exps         js = moduleToJs opts mod' env'
src/Language/PureScript/Declarations.hs view
@@ -45,11 +45,14 @@ -- Source position information -- data SourcePos = SourcePos-  {+  { -- |+    -- Source name+    --+    sourceName :: String     -- |     -- Line number     ---    sourcePosLine :: Int+  , sourcePosLine :: Int     -- |     -- Column number     --@@ -57,7 +60,7 @@   } deriving (D.Data, D.Typeable)  instance Show SourcePos where-  show sp = "line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)+  show sp = (sourceName sp) ++ " line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)  -- | -- Fixity data for infix operators
+ src/Language/PureScript/Errors.hs view
@@ -0,0 +1,111 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Error+-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-}++module Language.PureScript.Errors where++import Data.List (intercalate)+import Data.Monoid++import Control.Monad.Error++import Language.PureScript.Declarations+import Language.PureScript.Pretty+import Language.PureScript.Types++-- |+-- Type for sources of type checking errors+--+data ErrorSource+  -- |+  -- An error which originated at a Value+  --+  = ValueError Value+  -- |+  -- An error which originated at a Type+  --+  | TypeError Type deriving (Show)++-- |+-- Compilation errors+--+data CompileError = CompileError {+    -- |+    -- Error message+    --+    compileErrorMessage :: String+    -- |+    -- The value where the error occurred+    --+  , compileErrorValue :: Maybe ErrorSource+    -- |+    -- Optional source position information+    --+  , compileErrorPosition :: Maybe SourcePos+  } deriving (Show)++-- |+-- A stack trace for an error+--+newtype ErrorStack = ErrorStack { runErrorStack :: [CompileError] } deriving (Show, Monoid)++instance Error ErrorStack where+  strMsg s = ErrorStack [CompileError s Nothing Nothing]+  noMsg = ErrorStack []++prettyPrintErrorStack :: Bool -> ErrorStack -> String+prettyPrintErrorStack printFullStack (ErrorStack es) =+  case mconcat $ map (Last . compileErrorPosition) es of+    Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintErrorStack'+    _ -> prettyPrintErrorStack'+  where+  prettyPrintErrorStack' :: String+  prettyPrintErrorStack'+    | printFullStack = 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')++stringifyErrorStack :: Bool -> Either ErrorStack a -> Either String a+stringifyErrorStack printFullStack = either (Left . prettyPrintErrorStack printFullStack) Right++isErrorNonEmpty :: CompileError -> Bool+isErrorNonEmpty = not . null . compileErrorMessage++showError :: CompileError -> String+showError (CompileError msg Nothing _) = msg+showError (CompileError msg (Just (ValueError val)) _) = "Error in value " ++ prettyPrintValue val ++ ":\n" ++ msg+showError (CompileError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg++mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack+mkErrorStack msg t = ErrorStack [CompileError msg t Nothing]++positionError :: SourcePos -> ErrorStack+positionError pos = ErrorStack [CompileError "" Nothing (Just pos)]++-- |+-- Rethrow an error with a more detailed error message in the case of failure+--+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 ErrorStack m) => SourcePos -> m a -> m a+rethrowWithPosition pos = rethrow (positionError pos <>)
src/Language/PureScript/Optimizer.hs view
@@ -53,19 +53,21 @@ -- optimize :: Options -> JS -> JS optimize opts | optionsNoOptimizations opts = id-              | otherwise = untilFixedPoint $ applyAll+              | otherwise = untilFixedPoint (applyAll   [ collapseNestedBlocks   , tco opts   , magicDo opts   , removeUnusedVariables+  , removeCodeAfterReturnStatements   , unThunk   , etaConvert+  , evaluateIifes   , inlineVariables   , inlineOperator (C.$) $ \f x -> JSApp f [x]   , inlineOperator (C.#) $ \x f -> JSApp f [x]   , inlineOperator (C.!!) $ flip JSIndexer   , inlineOperator (C.++) $ JSBinary Add-  , inlineCommonOperators ]+  , inlineCommonOperators ])  untilFixedPoint :: (Eq a) => (a -> a) -> a -> a untilFixedPoint f = go
src/Language/PureScript/Optimizer/Inliner.hs view
@@ -18,7 +18,8 @@   inlineOperator,   inlineCommonOperators,   etaConvert,-  unThunk+  unThunk,+  evaluateIifes ) where  import Data.Generics@@ -55,6 +56,13 @@   where   convert :: JS -> JS   convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body+  convert js = js++evaluateIifes :: JS -> JS+evaluateIifes = everywhere (mkT convert)+  where+  convert :: JS -> JS+  convert (JSApp (JSFunction Nothing [] (JSBlock [JSReturn ret])) []) = ret   convert js = js  inlineVariables :: JS -> JS
src/Language/PureScript/Optimizer/Unused.hs view
@@ -14,7 +14,8 @@ -----------------------------------------------------------------------------  module Language.PureScript.Optimizer.Unused (-  removeUnusedVariables+  removeUnusedVariables,+  removeCodeAfterReturnStatements ) where  import Data.Generics@@ -29,3 +30,12 @@   go [] = []   go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts   go (s:sts) = s : go sts++removeCodeAfterReturnStatements :: JS -> JS+removeCodeAfterReturnStatements = everywhere (mkT $ removeFromBlock go)+  where+  go :: [JS] -> [JS]+  go jss | not (any isJSReturn jss) = jss+         | otherwise = let (body, ret : _) = span (not . isJSReturn) jss in body ++ [ret]+  isJSReturn (JSReturn _) = True+  isJSReturn _ = False
src/Language/PureScript/Parser/Declarations.hs view
@@ -44,7 +44,7 @@ sourcePos :: P.Parsec s u SourcePos sourcePos = toSourcePos <$> P.getPosition   where-  toSourcePos p = SourcePos (P.sourceLine p) (P.sourceColumn p)+  toSourcePos p = SourcePos (P.sourceName p) (P.sourceLine p) (P.sourceColumn p)  parseDataDeclaration :: P.Parsec String ParseState Declaration parseDataDeclaration = do
src/Language/PureScript/Sugar.hs view
@@ -18,6 +18,7 @@ import Control.Monad  import Language.PureScript.Declarations+import Language.PureScript.Errors  import Language.PureScript.Sugar.Operators as S import Language.PureScript.Sugar.DoNotation as S@@ -46,7 +47,7 @@ -- --  * Qualify any unqualified names and types ---desugar :: [Module] -> Either String [Module]+desugar :: [Module] -> Either ErrorStack [Module] desugar = removeSignedLiterals           >>> desugarDo           >=> desugarCasesModule
src/Language/PureScript/Sugar/BindingGroups.hs view
@@ -33,11 +33,12 @@ import Language.PureScript.Names import Language.PureScript.Types import Language.PureScript.Environment+import Language.PureScript.Errors  -- | -- Replace all sets of mutually-recursive declarations in a module with binding groups ---createBindingGroupsModule :: [Module] -> Either String [Module]+createBindingGroupsModule :: [Module] -> Either ErrorStack [Module] createBindingGroupsModule = mapM $ \(Module name ds exps) -> Module name <$> createBindingGroups name ds <*> pure exps  -- |@@ -49,7 +50,7 @@ -- | -- Replace all sets of mutually-recursive declarations with binding groups ---createBindingGroups :: ModuleName -> [Declaration] -> Either String [Declaration]+createBindingGroups :: ModuleName -> [Declaration] -> Either ErrorStack [Declaration] createBindingGroups moduleName ds = do   values <- mapM (createBindingGroupsForValue moduleName) $ filter isValueDecl ds   let dataDecls = filter isDataDecl ds@@ -68,7 +69,7 @@            filter isExternDecl ds ++            bindingGroupDecls -createBindingGroupsForValue :: ModuleName -> Declaration -> Either String Declaration+createBindingGroupsForValue :: ModuleName -> Declaration -> Either ErrorStack Declaration createBindingGroupsForValue moduleName = everywhereM' (mkM go)   where   go (Let ds val) = Let <$> createBindingGroups moduleName ds <*> pure val@@ -124,13 +125,13 @@ toBindingGroup (CyclicSCC [d]) = d toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds' -toDataBindingGroup :: SCC Declaration -> Either String Declaration+toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration toDataBindingGroup (AcyclicSCC d) = return d toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of-  Just pn -> Left $ "Cycle in type synonym " ++ show pn+  Just pn -> Left $ mkErrorStack ("Cycle in type synonym " ++ show pn) Nothing   _ -> return d toDataBindingGroup (CyclicSCC ds')-  | all (isJust . isTypeSynonym) ds' = Left "Cycle in type synonyms"+  | all (isJust . isTypeSynonym) ds' = Left $ mkErrorStack "Cycle in type synonyms" Nothing   | otherwise = return $ DataBindingGroupDeclaration ds'  isTypeSynonym :: Declaration -> Maybe ProperName
src/Language/PureScript/Sugar/CaseDeclarations.hs view
@@ -19,6 +19,7 @@     desugarCasesModule ) where +import Data.Monoid ((<>)) import Data.List (groupBy) import Data.Generics (mkM, mkT, everywhere) import Data.Generics.Extras@@ -31,12 +32,15 @@ import Language.PureScript.Declarations import Language.PureScript.Scope import Language.PureScript.Environment+import Language.PureScript.Errors  -- | -- Replace all top-level binders in a module with case expressions. ---desugarCasesModule :: [Module] -> Either String [Module]-desugarCasesModule ms = forM ms $ \(Module name ds exps) -> Module name <$> (desugarCases . desugarAbs $ ds) <*> pure exps+desugarCasesModule :: [Module] -> Either ErrorStack [Module]+desugarCasesModule ms = forM ms $ \(Module name ds exps) ->+  rethrow (strMsg ("Error in module " ++ show name) <>) $+    Module name <$> (desugarCases . desugarAbs $ ds) <*> pure exps  desugarAbs :: [Declaration] -> [Declaration] desugarAbs = everywhere (mkT replace)@@ -51,10 +55,10 @@ -- | -- Replace all top-level binders with case expressions. ---desugarCases :: [Declaration] -> Either String [Declaration]+desugarCases :: [Declaration] -> Either ErrorStack [Declaration] desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup   where-    desugarRest :: [Declaration] -> Either String [Declaration]+    desugarRest :: [Declaration] -> Either ErrorStack [Declaration]     desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =       (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest     desugarRest (ValueDeclaration name nameKind bs g val : rest) = do@@ -74,7 +78,7 @@ inSameGroup d1 (PositionedDeclaration _ d2) = inSameGroup d1 d2 inSameGroup _ _ = False -toDecls :: [Declaration] -> Either String [Declaration]+toDecls :: [Declaration] -> Either ErrorStack [Declaration] toDecls [ValueDeclaration ident nameKind bs Nothing val] | all isVarBinder bs = do   let args = map (\(VarBinder arg) -> arg) bs       body = foldr (Abs . Left) val args@@ -82,10 +86,10 @@ toDecls ds@(ValueDeclaration ident _ bs _ _ : _) = do   let tuples = map toTuple ds   unless (all ((== length bs) . length . fst) tuples) $-      throwError $ "Argument list lengths differ in declaration " ++ show ident+      throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing   return [makeCaseDeclaration ident tuples] toDecls (PositionedDeclaration pos d : ds) = do-  (d' : ds') <- toDecls (d : ds)+  (d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds)   return (PositionedDeclaration pos d' : ds') toDecls ds = return ds
src/Language/PureScript/Sugar/DoNotation.hs view
@@ -24,6 +24,7 @@ import Language.PureScript.Names import Language.PureScript.Scope import Language.PureScript.Declarations+import Language.PureScript.Errors  import qualified Language.PureScript.Constants as C @@ -33,23 +34,23 @@ -- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function, -- and all @DoNotationLet@ constructors with let expressions. ---desugarDo :: (Data d) => d -> Either String d+desugarDo :: (Data d) => d -> Either ErrorStack d desugarDo = everywhereM (mkM replace)   where   prelude :: ModuleName   prelude = ModuleName [ProperName C.prelude]   bind :: Value   bind = Var (Qualified (Just prelude) (Op (C.>>=)))-  replace :: Value -> Either String Value+  replace :: Value -> Either ErrorStack Value   replace (Do els) = go els   replace other = return other-  go :: [DoNotationElement] -> Either String Value+  go :: [DoNotationElement] -> Either ErrorStack Value   go [] = error "The impossible happened in desugarDo"   go [DoNotationValue val] = return val   go (DoNotationValue val : rest) = do     rest' <- go rest     return $ App (App bind val) (Abs (Left (Ident "_")) rest')-  go [DoNotationBind _ _] = Left "Bind statement cannot be the last statement in a do block"+  go [DoNotationBind _ _] = Left $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing   go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)   go (DoNotationBind (VarBinder ident) val : rest) = do     rest' <- go rest@@ -58,7 +59,7 @@     rest' <- go rest     let ident = head $ unusedNames rest'     return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing rest']))-  go [DoNotationLet _ _] = Left "Let statement cannot be the last statement in a do block"+  go [DoNotationLet _ _] = Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing   go (DoNotationLet binder val : rest) = do     rest' <- go rest     return $ Case [val] [CaseAlternative [binder] Nothing rest']
src/Language/PureScript/Sugar/Names.hs view
@@ -18,6 +18,7 @@  import Data.Data import Data.Maybe (fromMaybe, isJust, mapMaybe)+import Data.Monoid ((<>)) import Data.Generics (extM, mkM, everywhereM) import Data.Generics.Extras (mkS, extS, everywhereWithContextM') @@ -30,6 +31,7 @@ import Language.PureScript.Names import Language.PureScript.Types import Language.PureScript.Environment+import Language.PureScript.Errors  -- | -- The global export environment - every declaration exported from every module.@@ -80,7 +82,7 @@ -- Updates the exports for a module from the global environment. If the module was not previously -- present in the global environment, it is created. ---updateExportedModule :: ExportEnvironment -> ModuleName -> (Exports -> Either String Exports) -> Either String ExportEnvironment+updateExportedModule :: ExportEnvironment -> ModuleName -> (Exports -> Either ErrorStack Exports) -> Either ErrorStack ExportEnvironment updateExportedModule env mn update = do   let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env   exports' <- update exports@@ -89,16 +91,16 @@ -- | -- Adds an empty module to an ExportEnvironment. ---addEmptyModule :: ExportEnvironment -> ModuleName -> Either String ExportEnvironment+addEmptyModule :: ExportEnvironment -> ModuleName -> Either ErrorStack ExportEnvironment addEmptyModule env name =   if name `M.member` env-    then throwError $ "Module '" ++ show name ++ "' has been defined more than once"+    then throwError $ mkErrorStack ("Module '" ++ show name ++ "' has been defined more than once") Nothing     else return $ M.insert name (Exports [] [] []) env  -- | -- Adds a type belonging to a module to the export environment. ---addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either String ExportEnvironment+addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either ErrorStack ExportEnvironment addType env mn name dctors = updateExportedModule env mn $ \m -> do   types' <- addExport (exportedTypes m) (name, dctors)   return $ m { exportedTypes = types' }@@ -106,7 +108,7 @@ -- | -- Adds a class to the export environment. ---addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment+addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either ErrorStack ExportEnvironment addTypeClass env mn name = updateExportedModule env mn $ \m -> do   classes <- addExport (exportedTypeClasses m) name   return $ m { exportedTypeClasses = classes }@@ -114,7 +116,7 @@ -- | -- Adds a class to the export environment. ---addValue :: ExportEnvironment -> ModuleName -> Ident -> Either String ExportEnvironment+addValue :: ExportEnvironment -> ModuleName -> Ident -> Either ErrorStack ExportEnvironment addValue env mn name = updateExportedModule env mn $ \m -> do   values <- addExport (exportedValues m) name   return $ m { exportedValues = values }@@ -123,16 +125,16 @@ -- Adds an entry to a list of exports unless it is already present, in which case an error is -- returned. ---addExport :: (Eq a, Show a) => [a] -> a -> Either String [a]+addExport :: (Eq a, Show a) => [a] -> a -> Either ErrorStack [a] addExport exports name =   if name `elem` exports-  then throwError $ "Multiple definitions for '" ++ show name ++ "'"+  then throwError $ mkErrorStack ("Multiple definitions for '" ++ show name ++ "'") Nothing   else return $ name : exports  -- | -- Replaces all local names with qualified names within a set of modules. ---desugarImports :: [Module] -> Either String [Module]+desugarImports :: [Module] -> Either ErrorStack [Module] desugarImports modules = do   unfilteredExports <- findExports modules   exports <- foldM filterModuleExports unfilteredExports modules@@ -142,30 +144,19 @@   -- Filters the exports for a module in the global exports environment so that only explicitly   -- exported members remain. If the module does not explicitly export anything, everything is   -- exported.-  filterModuleExports :: ExportEnvironment -> Module -> Either String ExportEnvironment+  filterModuleExports :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment   filterModuleExports env (Module mn _ (Just exps)) = filterExports mn exps env   filterModuleExports env _ = return env    -- Rename and check all the names within a module. We tweak the global exports environment so   -- the module has access to an unfiltered list of its own members.-  renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> Either String Module-  renameInModule' unfilteredExports exports m@(Module mn _ _) = rethrowForModule m $ do-    let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports-    let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports-    imports <- resolveImports env m-    renameInModule imports env (elaborateExports exps m)---- |--- Rethrow an error with an extra message line prepended----rethrow :: String -> Either String a -> Either String a-rethrow msg = flip catchError $ \e -> throwError (msg ++ ":\n" ++  e)---- |--- Rethrow an error with details of the current module prepended to the message----rethrowForModule :: Module -> Either String a -> Either String a-rethrowForModule (Module mn _ _) = rethrow $ "Error in module '" ++ show mn ++ "'"+  renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module+  renameInModule' unfilteredExports exports m@(Module mn _ _) =+    rethrow (strMsg ("Error in module " ++ show mn) <>) $ do+      let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports+      let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports+      imports <- resolveImports env m+      renameInModule imports env (elaborateExports exps m)  -- | -- Make all exports for a module explicit. This may still effect modules that have an exports list,@@ -181,23 +172,27 @@ -- Replaces all local names with qualified names within a module and checks that all existing -- qualified names are valid. ---renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either String Module+renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module renameInModule imports exports (Module mn decls exps) =   Module mn <$> mapM go decls <*> pure exps   where+  go :: Declaration -> Either ErrorStack Declaration   go (DataDeclaration name args dctors) =-      rethrowFor "data declaration" name $ DataDeclaration <$> pure name <*> pure args <*> updateAll dctors+      rethrow (strMsg ("Error in data declaration " ++ show name) <>) $+        DataDeclaration <$> pure name <*> pure args <*> updateAll dctors   go (DataBindingGroupDeclaration decls') =       DataBindingGroupDeclaration <$> mapM go decls'   go (TypeSynonymDeclaration name ps ty) =-      rethrowFor "type synonym" name $ TypeSynonymDeclaration <$> pure name <*> pure ps <*> updateType' ty+      rethrow (strMsg ("Error in type synonym " ++ show name) <>) $+        TypeSynonymDeclaration <$> pure name <*> pure ps <*> updateType' ty   go (TypeInstanceDeclaration name cs cn ts ds) =       TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> updateType' ts <*> mapM go ds   go (ExternInstanceDeclaration name cs cn ts) =       ExternInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> updateType' ts   go (ValueDeclaration name nameKind [] Nothing val) = do     val' <- everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val-    rethrowFor "declaration" name $ ValueDeclaration name nameKind [] Nothing <$> updateAll val'+    rethrow (strMsg ("Error in declaration " ++ show name) <>) $+      ValueDeclaration name nameKind [] Nothing <$> updateAll val'     where     bindFunctionArgs bound (Abs (Left arg) val') = return (arg : bound, Abs (Left arg) val')     bindFunctionArgs bound (Let ds val') = let args = mapMaybe letBoundVariable ds in@@ -211,7 +206,7 @@     bindFunctionArgs bound (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =       (,) bound <$> (BinaryNoParens <$> updateValueName name' <*> pure v1 <*> pure v2)     bindFunctionArgs bound other = return (bound, other)-    bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)+    bindBinders :: [Ident] -> CaseAlternative -> Either ErrorStack ([Ident], CaseAlternative)     bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)      letBoundVariable :: Declaration -> Maybe Ident@@ -220,17 +215,18 @@     letBoundVariable _ = Nothing   go (ValueDeclaration name _ _ _ _) = error $ "Binders should have been desugared in " ++ show name   go (ExternDeclaration fit name js ty) =-      rethrowFor "declaration" name $ ExternDeclaration <$> pure fit <*> pure name <*> pure js <*> updateType' ty+      rethrow (strMsg ("Error in declaration " ++ show name) <>) $+        ExternDeclaration <$> pure fit <*> pure name <*> pure js <*> updateType' ty   go (BindingGroupDeclaration decls') = do       BindingGroupDeclaration <$> mapM go' decls'-      where go' = \(name, nk, value) -> rethrowFor "declaration" name $ (,,) <$> pure name <*> pure nk <*> updateAll value+      where+      go' = \(name, nk, value) ->+        rethrow (strMsg ("Error in declaration " ++ show 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-  rethrowFor what name = rethrow $ "Error in " ++ what ++ "  '" ++ show name ++ "'"--  updateAll :: Data d => d -> Either String d+  updateAll :: Data d => d -> Either ErrorStack d   updateAll = everywhereM (mkM updateType `extM` updateValue `extM` updateBinder)    updateValue (Constructor name) = Constructor <$> updateDataConstructorName name@@ -243,7 +239,7 @@   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' :: Data d => d -> Either ErrorStack d   updateType' = everywhereM (mkM updateType)    updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)@@ -259,24 +255,24 @@                             -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))                             -> (Exports -> a -> Bool)                             -> (Qualified a)-                            -> Either String (Qualified a)+                            -> Either ErrorStack (Qualified a)   update t getI checkE qname@(Qualified mn' name) = case (M.lookup qname (getI imports), mn') of     (Just qname', _) -> return qname'     (Nothing, Just mn'') -> do       modExports <- getExports mn''       if checkE modExports name         then return qname-        else throwError $ "Unknown " ++ t ++ " '" ++ show (qname) ++ "'"-    _ -> throwError $ "Unknown " ++ t ++ " '" ++ show name ++ "'"+        else throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show (qname) ++ "'") Nothing+    _ -> throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show name ++ "'") Nothing    -- Gets the exports for a module, or an error message if the module doesn't exist-  getExports :: ModuleName -> Either String Exports-  getExports mn' = maybe (throwError $ "Unknown module '" ++ show mn' ++ "'") return $ M.lookup mn' exports+  getExports :: ModuleName -> Either ErrorStack Exports+  getExports mn' = maybe (throwError $ mkErrorStack ("Unknown module '" ++ show mn' ++ "'") Nothing) return $ M.lookup mn' exports  -- | -- Finds all exported declarations in a set of modules. ---findExports :: [Module] -> Either String ExportEnvironment+findExports :: [Module] -> Either ErrorStack ExportEnvironment findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) primExports   where @@ -286,13 +282,13 @@     mkTypeEntry (Qualified _ name) = (name, [])    -- Add all of the exported declarations from a module to the global export environment-  addModule :: ExportEnvironment -> Module -> Either String ExportEnvironment+  addModule :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment   addModule env m@(Module mn ds _) = do     env' <- addEmptyModule env mn-    rethrowForModule m $ foldM (addDecl mn) env' ds+    rethrow (strMsg ("Error in module " ++ show mn) <>) $ foldM (addDecl mn) env' ds    -- Add a declaration from a module to the global export environment-  addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either String ExportEnvironment+  addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either ErrorStack ExportEnvironment   addDecl mn env (TypeClassDeclaration tcn _ ds) = do     env' <- addTypeClass env mn tcn     foldM (\env'' (TypeDeclaration name _) -> addValue env'' mn name) env' ds@@ -308,7 +304,7 @@ -- Filters the exports for a module to ensure only explicit exports are kept in the global exports -- environment. ---filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either String ExportEnvironment+filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either ErrorStack ExportEnvironment filterExports mn exps env = do   let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)   moduleExports' <- filterModule moduleExports@@ -316,7 +312,7 @@   where    -- Filter the exports for the specific module-  filterModule :: Exports -> Either String Exports+  filterModule :: Exports -> Either ErrorStack Exports   filterModule exported = do     types' <- foldM (filterTypes $ exportedTypes exported) [] exps     values <- foldM (filterValues $ exportedValues exported) [] exps@@ -325,34 +321,34 @@    -- Ensure the exported types and data constructors exist in the module and add them to the set of   -- exports-  filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either String [(ProperName, [ProperName])]+  filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either ErrorStack [(ProperName, [ProperName])]   filterTypes expTys result (TypeRef name expDcons) = do-    dcons <- maybe (throwError $ "Cannot export undefined type '" ++ show name ++ "'") return $ name `lookup` expTys+    dcons <- maybe (throwError $ mkErrorStack ("Cannot export undefined type '" ++ show name ++ "'") Nothing) return $ name `lookup` expTys     dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons     return $ (name, dcons') : result   filterTypes _ result _ = return result    -- Ensure the exported data constructors exists for a type and add them to the list of exports-  filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> Either String [ProperName]+  filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> Either ErrorStack [ProperName]   filterDcons tcon exps' result name =     if name `elem` exps'     then return $ name : result-    else throwError $ "Cannot export undefined data constructor '" ++ show name ++ "' for type '" ++ show tcon ++ "'"+    else throwError $ mkErrorStack ("Cannot export undefined data constructor '" ++ show name ++ "' for type '" ++ show tcon ++ "'") Nothing    -- Ensure the exported classes exist in the module and add them to the set of exports-  filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either String [ProperName]+  filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either ErrorStack [ProperName]   filterClasses exps' result (TypeClassRef name) =     if name `elem` exps'     then return $ name : result-    else throwError $ "Cannot export undefined type class '" ++ show name ++ "'"+    else throwError $ mkErrorStack ("Cannot export undefined type class '" ++ show name ++ "'") Nothing   filterClasses _ result _ = return result    -- Ensure the exported values exist in the module and add them to the set of exports-  filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either String [Ident]+  filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either ErrorStack [Ident]   filterValues exps' result (ValueRef name) =     if name `elem` exps'     then return $ name : result-    else throwError $ "Cannot export undefined value '" ++ show name ++ "'"+    else throwError $ mkErrorStack ("Cannot export undefined value '" ++ show name ++ "'") Nothing   filterValues _ result _ = return result  -- |@@ -374,7 +370,7 @@ -- | -- Constructs a local environment for a module. ---resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment+resolveImports :: ExportEnvironment -> Module -> Either ErrorStack ImportEnvironment resolveImports env (Module currentModule decls _) =   foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)   where@@ -382,25 +378,25 @@   scope :: M.Map ModuleName (Maybe ExplicitImports, Maybe ModuleName)   scope = M.insert currentModule (Nothing, Nothing) (findImports decls)   resolveImport' imp (mn, (explImports, impQual)) = do-      modExports <- maybe (throwError $ "Cannot import unknown module '" ++ show mn ++ "'") return $ mn `M.lookup` env+      modExports <- maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env       resolveImport currentModule mn modExports imp impQual explImports  -- | -- Extends the local environment for a module by resolving an import of another module. ---resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> Maybe ExplicitImports-> Either String ImportEnvironment+resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> Maybe ExplicitImports-> Either ErrorStack ImportEnvironment resolveImport currentModule importModule exps imps impQual = maybe importAll (foldM importExplicit imps)   where    -- Import everything from a module-  importAll :: Either String ImportEnvironment+  importAll :: Either ErrorStack ImportEnvironment   importAll = do     imp' <- foldM (\m (name, dctors) -> importExplicit m (TypeRef name (Just dctors))) imps (exportedTypes exps)     imp'' <- foldM (\m name -> importExplicit m (ValueRef name)) imp' (exportedValues exps)     foldM (\m name -> importExplicit m (TypeClassRef name)) imp'' (exportedTypeClasses exps)    -- Import something explicitly-  importExplicit :: ImportEnvironment -> DeclarationRef -> Either String ImportEnvironment+  importExplicit :: ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment   importExplicit imp (ValueRef name) = do     _ <- checkImportExists "value" values name     values' <- updateImports (importedValues imp) name@@ -423,14 +419,15 @@   allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps    -- Add something to the ImportEnvironment if it does not already exist there-  updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> Either String (M.Map (Qualified a) (Qualified a))+  updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> Either ErrorStack (M.Map (Qualified a) (Qualified a))   updateImports m name = case M.lookup (Qualified impQual name) m of     Nothing -> return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name) m     Just (Qualified Nothing _) -> error "Invalid state in updateImports"-    Just x@(Qualified (Just mn) _) -> throwError $-      if mn == currentModule || importModule == currentModule-      then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just importModule) name) ++ "'"-      else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"+    Just x@(Qualified (Just mn) _) -> throwError $ mkErrorStack err Nothing+      where+      err = if mn == currentModule || importModule == currentModule+            then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just importModule) name) ++ "'"+            else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"    -- The available values, types, and classes in the module being imported   values = exportedValues exps@@ -439,14 +436,14 @@    -- Ensure that an explicitly imported data constructor exists for the type it is being imported   -- from-  checkDctorExists :: [ProperName] -> ProperName -> Either String ProperName+  checkDctorExists :: [ProperName] -> ProperName -> Either ErrorStack ProperName   checkDctorExists = checkImportExists "data constructor"    -- Check that an explicitly imported item exists in the module it is being imported from-  checkImportExists :: (Eq a, Show a) => String -> [a] -> a -> Either String a+  checkImportExists :: (Eq a, Show a) => String -> [a] -> a -> Either ErrorStack a   checkImportExists t exports item =       if item `elem` exports       then return item-      else throwError $ "Unable to find " ++ t ++  " '" ++ show (Qualified (Just importModule) item) ++ "'"+      else throwError $ mkErrorStack ("Unable to find " ++ t ++  " '" ++ show (Qualified (Just importModule) item) ++ "'") Nothing
src/Language/PureScript/Sugar/Operators.hs view
@@ -26,14 +26,16 @@  import Language.PureScript.Names import Language.PureScript.Declarations+import Language.PureScript.Errors  import Control.Applicative import Control.Monad.State import Control.Monad.Error.Class +import Data.Monoid ((<>)) import Data.Function (on) import Data.Functor.Identity-import Data.List (sort, groupBy, sortBy)+import Data.List (groupBy, sortBy)  import qualified Data.Data as D import qualified Data.Generics as G@@ -48,11 +50,11 @@ -- | -- Remove explicit parentheses and reorder binary operator applications ---rebracket :: [Module] -> Either String [Module]+rebracket :: [Module] -> Either ErrorStack [Module] rebracket ms = do   let fixities = concatMap collectFixities ms-  ensureNoDuplicates $ map fst fixities-  let opTable = customOperatorTable fixities+  ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities+  let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities   mapM (rebracketModule opTable) ms  removeSignedLiterals :: (D.Data d) => d -> d@@ -63,7 +65,7 @@   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 :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Module -> Either ErrorStack Module rebracketModule opTable (Module mn ds exts) = Module mn <$> (removeParens <$> G.everywhereM' (G.mkM (matchOperators opTable)) ds) <*> pure exts  removeParens :: (D.Data d) => d -> d@@ -72,20 +74,23 @@   go (Parens val) = val   go val = val -collectFixities :: Module -> [(Qualified Ident, Fixity)]+collectFixities :: Module -> [(Qualified Ident, SourcePos, 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 :: Declaration -> [(Qualified Ident, SourcePos, Fixity)]+  collect (PositionedDeclaration pos (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]+  collect FixityDeclaration{} = error "Fixity without srcpos info"   collect _ = [] -ensureNoDuplicates :: [Qualified Ident] -> Either String ()-ensureNoDuplicates m = go $ sort m+ensureNoDuplicates :: [(Qualified Ident, SourcePos)] -> Either ErrorStack ()+ensureNoDuplicates m = go $ sortBy (compare `on` fst) m   where   go [] = return ()   go [_] = return ()-  go (x : y : _) | x == y = throwError $ "Redefined fixity for " ++ show x+  go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y =+    rethrow (strMsg ("Error in module " ++ show mn) <>) $+      rethrowWithPosition pos $+        throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing   go (_ : rest) = go rest  customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]@@ -100,17 +105,17 @@  type Chain = [Either Value (Qualified Ident)] -matchOperators :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value+matchOperators :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either ErrorStack Value matchOperators ops = parseChains   where-  parseChains :: Value -> Either String Value+  parseChains :: Value -> Either ErrorStack Value   parseChains b@BinaryNoParens{} = bracketChain (extendChain b)   parseChains other = return other   extendChain :: Value -> Chain   extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r   extendChain other = [Left other]-  bracketChain :: Chain -> Either String Value-  bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"+  bracketChain :: Chain -> Either ErrorStack Value+  bracketChain = either (Left . (`mkErrorStack` Nothing) . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"   opTable = [P.Infix (P.try (parseTicks >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft]             : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops             ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]
src/Language/PureScript/Sugar/TypeClasses.hs view
@@ -25,6 +25,7 @@ import Language.PureScript.CodeGen.JS.AST import Language.PureScript.Sugar.CaseDeclarations import Language.PureScript.Environment+import Language.PureScript.Errors import Language.PureScript.CodeGen.Common (identToJs)  import Control.Applicative@@ -36,13 +37,13 @@  type MemberMap = M.Map (ModuleName, ProperName) ([String], [(String, Type)]) -type Desugar = StateT MemberMap (Either String)+type Desugar = StateT MemberMap (Either ErrorStack)  -- | -- Add type synonym declarations for type class dictionary types, and value declarations for type class -- instance dictionary expressions. ---desugarTypeClasses :: [Module] -> Either String [Module]+desugarTypeClasses :: [Module] -> Either ErrorStack [Module] desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule  desugarModule :: Module -> Desugar Module@@ -125,7 +126,7 @@ typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration typeInstanceDictionaryDeclaration name mn deps className tys decls = do   m <- get-  (args, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show className ++ " is undefined. Type class names must be qualified.") Right+  (args, instanceTys) <- lift $ maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right                         $ M.lookup (qualify mn className) m   let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys   let entryName = Escaped (show name)@@ -144,7 +145,7 @@    memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)   memberToNameAndValue tys' (ValueDeclaration ident _ _ _ _) = do-    memberType <- lift . maybe (Left "Type class member type not found") Right $ lookup (identToJs ident) tys'+    memberType <- lift . maybe (Left $ mkErrorStack "Type class member type not found" Nothing) Right $ lookup (identToJs ident) tys'     memberName <- mkDictionaryEntryName name ident     return (identToJs ident, TypedValue False                                (foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))@@ -164,8 +165,8 @@   return $ ValueDeclaration entryName TypeInstanceMember [] Nothing     (TypedValue True val (quantify (if null deps then valTy else ConstrainedType deps valTy)))   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+  lookupTypeClass m = maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $ M.lookup (qualify mn className) m+  lookupIdent members = maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " does not have method " ++ show ident) Nothing) 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
@@ -21,6 +21,7 @@  import Data.Generics (mkM) import Data.Generics.Extras+import Data.Monoid ((<>))  import Control.Applicative import Control.Monad.Error.Class@@ -29,30 +30,34 @@ import Language.PureScript.Declarations import Language.PureScript.Names import Language.PureScript.Environment+import Language.PureScript.Errors  -- | -- Replace all top level type declarations in a module with type annotations ---desugarTypeDeclarationsModule :: [Module] -> Either String [Module]-desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) -> Module name <$> desugarTypeDeclarations ds <*> pure exps+desugarTypeDeclarationsModule :: [Module] -> Either ErrorStack [Module]+desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) ->+  rethrow (strMsg ("Error in module " ++ show name) <>) $+    Module name <$> desugarTypeDeclarations ds <*> pure exps  -- | -- Replace all top level type declarations with type annotations ---desugarTypeDeclarations :: [Declaration] -> Either String [Declaration]+desugarTypeDeclarations :: [Declaration] -> Either ErrorStack [Declaration] desugarTypeDeclarations (PositionedDeclaration pos d : ds) = do-  (d' : ds') <- desugarTypeDeclarations (d : ds)+  (d' : ds') <- rethrowWithPosition pos $ 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)   where-  fromValueDeclaration :: Declaration -> Either String (Ident, NameKind, Value)+  fromValueDeclaration :: Declaration -> Either ErrorStack (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'+    (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'     return (ident, nameKind, PositionedValue pos val)-  fromValueDeclaration _ = throwError $ "Orphan type declaration for " ++ show name+  fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing+desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing 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
@@ -37,6 +37,7 @@ import Language.PureScript.Declarations import Language.PureScript.TypeClassDictionaries import Language.PureScript.Environment+import Language.PureScript.Errors  addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check () addDataType moduleName name args dctors ctorKind = do@@ -88,7 +89,7 @@   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 $ mkUnifyErrorStack "Type class instance head is invalid." (Just (TypeError ty))+checkTypeClassInstance _ ty = throwError $ mkErrorStack "Type class instance head is invalid." (Just (TypeError ty))  -- | -- Type check all declarations in a module
src/Language/PureScript/TypeChecker/Kinds.hs view
@@ -28,6 +28,7 @@ import Language.PureScript.TypeChecker.Monad import Language.PureScript.Pretty import Language.PureScript.Environment+import Language.PureScript.Errors  import Control.Monad.State import Control.Monad.Error@@ -60,7 +61,7 @@ -- kindOf :: ModuleName -> Type -> Check Kind kindOf _ ty =-  rethrow (mkUnifyErrorStack "Error checking kind" (Just (TypeError ty)) <>) $+  rethrow (mkErrorStack "Error checking kind" (Just (TypeError ty)) <>) $     fmap tidyUp . liftUnify $ starIfUnknown <$> infer ty   where   tidyUp (k, sub) = sub $? k@@ -129,7 +130,7 @@ -- Infer a kind for a type -- infer :: Type -> UnifyT Kind Check Kind-infer ty = rethrow (mkUnifyErrorStack "Error inferring type of value" (Just (TypeError ty)) <>) $ infer' ty+infer ty = rethrow (mkErrorStack "Error inferring type of value" (Just (TypeError ty)) <>) $ infer' ty  infer' :: Type -> UnifyT Kind Check Kind infer' (TypeVar v) = do@@ -138,7 +139,7 @@ infer' c@(TypeConstructor v) = do   env <- liftCheck getEnv   case M.lookup v (types env) of-    Nothing -> UnifyT . lift . throwError $ mkUnifyErrorStack "Unknown type constructor" (Just (TypeError c))+    Nothing -> UnifyT . lift . throwError $ mkErrorStack "Unknown type constructor" (Just (TypeError c))     Just (kind, _) -> return kind infer' (TypeApp t1 t2) = do   k0 <- fresh
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -21,14 +21,12 @@ 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 Language.PureScript.Errors  import Data.Maybe-import Data.Monoid  import Control.Applicative import Control.Monad.State@@ -36,80 +34,8 @@ 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@@ -207,8 +133,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 UnifyErrorStack) a }-  deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError UnifyErrorStack)+newtype Check a = Check { unCheck :: StateT CheckState (Either ErrorStack) a }+  deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError ErrorStack)  -- | -- Get the current @Environment@@@ -238,7 +164,7 @@ -- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@. -- runCheck' :: Options -> Environment -> Check a -> Either String (a, Environment)-runCheck' opts env c = either (Left . prettyPrintUnifyErrorStack opts) Right $ do+runCheck' opts env c = stringifyErrorStack (optionsVerboseErrors opts) $ do   (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c   return (a, checkEnv s) @@ -248,18 +174,6 @@ guardWith :: (MonadError e m) => e -> Bool -> m () guardWith _ True = return () guardWith e False = throwError e---- |--- Rethrow an error with a more detailed error message in the case of failure----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
src/Language/PureScript/TypeChecker/Types.hs view
@@ -59,6 +59,7 @@ import Language.PureScript.TypeChecker.Synonyms import Language.PureScript.Pretty import Language.PureScript.Environment+import Language.PureScript.Errors import qualified Language.PureScript.Constants as C  import Control.Monad.State@@ -85,7 +86,7 @@ -- Unify two types, updating the current substitution -- unifyTypes :: Type -> Type -> UnifyT Type Check ()-unifyTypes t1 t2 = rethrow (mkUnifyErrorStack ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing <>) $+unifyTypes t1 t2 = rethrow (mkErrorStack ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing <>) $   unifyTypes' t1 t2   where   unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()@@ -364,7 +365,7 @@   -- an escaped skolem variable.   case everythingWithContext [] (++) (mkQ ((,) []) go) root of     [] -> return ()-    ((binding, val) : _) -> throwError $ mkUnifyErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ValueError val))+    ((binding, val) : _) -> throwError $ mkErrorStack ("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)@@ -383,7 +384,7 @@     where     go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = Just val     go' _ = Nothing-skolemEscapeCheck val = throwError $ mkUnifyErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ValueError val))+skolemEscapeCheck val = throwError $ mkErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ValueError val))  -- | -- Ensure a row contains no duplicate labels@@ -492,7 +493,7 @@ -- 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 (mkUnifyErrorStack "Error inferring type of value" (Just (ValueError val)) <>) $ infer' val+infer val = rethrow (mkErrorStack "Error inferring type of value" (Just (ValueError val)) <>) $ infer' val  -- | -- Infer a type for a value@@ -720,7 +721,7 @@ -- 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 (mkUnifyErrorStack errorMessage (Just (ValueError val)) <>) $ check' val ty+check val ty = rethrow (mkErrorStack errorMessage (Just (ValueError val)) <>) $ check' val ty   where   errorMessage =     "Error checking type of term " ++@@ -836,7 +837,7 @@   check val 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))+check' val ty = throwError $ mkErrorStack ("Value does not have type " ++ prettyPrintType ty) (Just (ValueError val))  containsTypeSynonyms :: Type -> Bool containsTypeSynonyms = everything (||) (mkQ False go) where@@ -855,8 +856,8 @@                                return []   go [] [] (Skolem _ _) | lax = return []   go [] ((p, _): _) _ | lax = return []-                      | 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)))+                      | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ValueError (ObjectLiteral ps)))+  go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("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@@ -875,13 +876,13 @@         v' <- check v ty         ps'' <- go ps' (delete (p, ty) ts) r         return $ (p, v') : ps''-  go _ _ _ = throwError $ mkUnifyErrorStack ("Object does not have type " ++ prettyPrintType (TypeApp tyObject row)) (Just (ValueError (ObjectLiteral ps)))+  go _ _ _ = throwError $ mkErrorStack ("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 (mkUnifyErrorStack errorMessage (Just (ValueError fn)) <>) $ checkFunctionApplication' fn fnTy arg ret+checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (Just (ValueError fn)) <>) $ checkFunctionApplication' fn fnTy arg ret   where   errorMessage = "Error applying function of type "     ++ prettyPrintType fnTy@@ -923,7 +924,7 @@ -- 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 (mkUnifyErrorStack errorMessage (ValueError <$> val) <>) $ subsumes' val ty1 ty2+subsumes val ty1 ty2 = rethrow (mkErrorStack errorMessage (ValueError <$> val) <>) $ subsumes' val ty1 ty2   where   errorMessage = "Error checking that type "     ++ prettyPrintType ty1