purescript 0.6.7.1 → 0.6.8

raw patch · 43 files changed

+819/−574 lines, 43 filesdep −monad-unifydep ~basedep ~transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: monad-unify

Dependency ranges changed: base, transformers

API changes (from Hackage documentation)

Files

• examples/passing/OneConstructor.purs +1/−1
• examples/passing/Rank2Data.purs +6/−6
• examples/passing/ShadowedTCO.purs +5/−5
• prelude/prelude.purs +54/−26
• psc-docs/Main.hs +56/−94
• psc-make/Main.hs +17/−10
• psc/Main.hs +10/−2
• psci/Main.hs +34/−34
• purescript.cabal +10/−9
• src/Control/Monad/Unify.hs +155/−0
• src/Language/PureScript.hs +41/−36
• src/Language/PureScript/AST/Declarations.hs +4/−0
• src/Language/PureScript/CodeGen/JS.hs +67/−55
• src/Language/PureScript/CodeGen/JS/Optimizer.hs +29/−19
• src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +28/−18
• src/Language/PureScript/Constants.hs +15/−0
• src/Language/PureScript/CoreFn/Binders.hs +2/−1
• src/Language/PureScript/CoreFn/Desugar.hs +137/−135
• src/Language/PureScript/CoreFn/Expr.hs +14/−5
• src/Language/PureScript/CoreFn/Literals.hs +2/−1
• src/Language/PureScript/CoreFn/Meta.hs +3/−6
• src/Language/PureScript/Environment.hs +4/−4
• src/Language/PureScript/Errors.hs +28/−15
• src/Language/PureScript/ModuleDependencies.hs +7/−3
• src/Language/PureScript/Options.hs +5/−2
• src/Language/PureScript/Sugar/BindingGroups.hs +1/−2
• src/Language/PureScript/Sugar/CaseDeclarations.hs +2/−3
• src/Language/PureScript/Sugar/Names.hs +6/−6
• src/Language/PureScript/Sugar/Operators.hs +2/−3
• src/Language/PureScript/Sugar/TypeClasses.hs +14/−14
• src/Language/PureScript/Sugar/TypeDeclarations.hs +2/−4
• src/Language/PureScript/Supply.hs +1/−1
• src/Language/PureScript/TypeChecker.hs +10/−10
• src/Language/PureScript/TypeChecker/Entailment.hs +2/−1
• src/Language/PureScript/TypeChecker/Kinds.hs +3/−4
• src/Language/PureScript/TypeChecker/Monad.hs +14/−11
• src/Language/PureScript/TypeChecker/Rows.hs +1/−1
• src/Language/PureScript/TypeChecker/Skolems.hs +1/−1
• src/Language/PureScript/TypeChecker/Subsumption.hs +2/−3
• src/Language/PureScript/TypeChecker/Synonyms.hs +6/−5
• src/Language/PureScript/TypeChecker/Types.hs +13/−13
• src/Language/PureScript/TypeChecker/Unify.hs +2/−3
• tests/Main.hs +3/−2

@@ -2,6 +2,6 @@  data One a = One a -one (One a) = a+one' (One a) = a  main = Debug.Trace.trace "Done"

@@ -12,18 +12,18 @@   runNat = \nat -> case nat of     Nat f -> f 0 (\n -> n + 1) -  zero = Nat (\zero _ -> zero)+  zero' = Nat (\zero' _ -> zero')    succ = \n -> case n of-    Nat f -> Nat (\zero succ -> succ (f zero succ))+    Nat f -> Nat (\zero' succ -> succ (f zero' succ))    add = \n m -> case n of     Nat f -> case m of-      Nat g -> Nat (\zero succ -> g (f zero succ) succ)+      Nat g -> Nat (\zero' succ -> g (f zero' succ) succ) -  one = succ zero-  two = succ zero+  one' = succ zero'+  two = succ zero'   four = add two two   fourNumber = runNat four -  main = Debug.Trace.trace "Done"+  main = Debug.Trace.trace "Done'"

@@ -2,14 +2,14 @@  runNat f = f 0 (\n -> n + 1) -zero z _ = z+zero' z _ = z -succ f zero succ = succ (f zero succ)+succ f zero' succ = succ (f zero' succ) -add f g zero succ = g (f zero succ) succ+add f g zero' succ = g (f zero' succ) succ -one = succ zero-two = succ one+one' = succ zero'+two = succ one' four = add two two fourNumber = runNat four 

@@ -13,8 +13,13 @@   , Applicative, pure, liftA1   , Bind, (>>=)   , Monad, return, liftM1, ap-  , Num, (+), (-), (*), (/), (%)+  , Semiring, (+), zero, (*), one+  , ModuloSemiring, (/), mod+  , Ring, (-)+  , (%)   , negate+  , DivisionRing+  , Num   , Eq, (==), (/=), refEq, refIneq   , Ord, Ordering(..), compare, (<), (>), (<=), (>=)   , Bits, (.&.), (.|.), (.^.), shl, shr, zshr, complement@@ -24,28 +29,28 @@   , Unit(..), unit   ) where -  -- | An alias for `true`, which can be useful in guard clauses: -  -- | +  -- | An alias for `true`, which can be useful in guard clauses:+  -- |   -- | E.g.-  -- | -  -- |     max x y | x >= y = x +  -- |+  -- |     max x y | x >= y = x   -- |             | otherwise = y   otherwise :: Boolean   otherwise = true -  -- | Flips the order of the arguments to a function of two arguments. +  -- | Flips the order of the arguments to a function of two arguments.   flip :: forall a b c. (a -> b -> c) -> b -> a -> c   flip f b a = f a b -  -- | Returns its first argument and ignores its second. +  -- | Returns its first argument and ignores its second.   const :: forall a b. a -> b -> a   const a _ = a    -- | This function returns its first argument, and can be used to assert type equalities.-  -- | This can be useful when types are otherwise ambiguous. -  -- | +  -- | This can be useful when types are otherwise ambiguous.+  -- |   -- | E.g.-  -- | +  -- |   -- |     main = print $ [] `asTypeOf` [0]   -- |   -- | If instead, we had written `main = print []`, the type of the argument `[]` would have@@ -205,14 +210,33 @@   infixl 6 -   infixl 6 + -  class Num a where-    (+) :: a -> a -> a-    (-) :: a -> a -> a-    (*) :: a -> a -> a+  -- | Addition and multiplication+  class Semiring a where+    (+)  :: a -> a -> a+    zero :: a+    (*)  :: a -> a -> a+    one  :: a++  -- | Semiring with modulo operation and division where+  -- | ```a / b * b + (a `mod` b) = a```+  class (Semiring a) <= ModuloSemiring a where     (/) :: a -> a -> a-    (%) :: a -> a -> a-    negate :: a -> a+    mod :: a -> a -> a +  -- | Addition, multiplication, and subtraction+  class (Semiring a) <= Ring a where+    (-) :: a -> a -> a++  negate :: forall a. (Ring a) => a -> a+  negate a = zero - a++  -- | Ring where every nonzero element has a multiplicative inverse (possibly+  -- | a non-commutative field) so that ```a `mod` b = zero```+  class (Ring a, ModuloSemiring a) <= DivisionRing a++  -- | A commutative field+  class (DivisionRing a) <= Num a+   foreign import numAdd     """     function numAdd(n1) {@@ -258,20 +282,24 @@     }     """ :: Number -> Number -> Number -  foreign import numNegate-    """-    function numNegate(n) {-      return -n;-    }-    """ :: Number -> Number+  (%) = numMod -  instance numNumber :: Num Number where+  instance semiringNumber :: Semiring Number where     (+) = numAdd-    (-) = numSub+    zero = 0     (*) = numMul+    one = 1++  instance ringNumber :: Ring Number where+    (-) = numSub++  instance moduloSemiringNumber :: ModuloSemiring Number where     (/) = numDiv-    (%) = numMod-    negate = numNegate+    mod _ _ = 0++  instance divisionRingNumber :: DivisionRing Number++  instance numNumber :: Num Number    newtype Unit = Unit {} 

@@ -18,7 +18,6 @@ import Control.Monad import Control.Monad.Writer import Control.Arrow (first)-import Data.Function (on) import Data.List import Data.Maybe (fromMaybe) import Data.Version (showVersion)@@ -32,19 +31,18 @@ import System.IO (hPutStrLn, stderr)  data PSCDocsOptions = PSCDocsOptions-  { pscdIncludeHeir :: Bool-  , pscdInputFiles  :: [FilePath]+  { pscdInputFiles  :: [FilePath]   }  docgen :: PSCDocsOptions -> IO ()-docgen (PSCDocsOptions showHierarchy input) = do+docgen (PSCDocsOptions input) = do   e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)   case e of     Left err -> do       hPutStrLn stderr $ show err       exitFailure     Right ms -> do-      putStrLn . runDocs $ (renderModules showHierarchy) (map snd ms)+      putStrLn . runDocs $ renderModules (map snd ms)       exitSuccess  parseFile :: FilePath -> IO (FilePath, String)@@ -69,55 +67,38 @@   let ls = lines text in   withIndent indent (tell ls) +fenced :: String -> Docs+fenced text = fencedBlock (tell $ lines text)++fencedBlock :: Docs -> Docs+fencedBlock inner = do+  tell ["``` purescript"]+  inner+  tell ["```"]+ ticks :: String -> String ticks = ("`" ++) . (++ "`") -renderModules :: Bool -> [P.Module] -> Docs-renderModules showHierarchy ms = do+renderModules :: [P.Module] -> Docs+renderModules ms = do   headerLevel 1 "Module Documentation"   spacer-  mapM_ (renderModule showHierarchy) ms+  mapM_ renderModule ms -renderModule :: Bool -> P.Module -> Docs-renderModule showHierarchy mdl@(P.Module moduleName _ exps) =-  let ds = P.exportedDeclarations mdl-      hasTypes = any isTypeDeclaration ds-      hasTypeclasses = any isTypeClassDeclaration ds-      hasTypeclassInstances = any isTypeInstanceDeclaration ds-      hasValues = any isValueDeclaration ds-  in do+renderModule :: P.Module -> Docs+renderModule mdl@(P.Module moduleName _ exps) = do     headerLevel 2 $ "Module " ++ P.runModuleName moduleName     spacer-    when hasTypes $ do-      headerLevel 3 "Types"-      spacer-      renderTopLevel exps (filter isTypeDeclaration ds)-      spacer-    when hasTypeclasses $ do-      headerLevel 3 "Type Classes"-      spacer-      when showHierarchy $ do-        renderTypeclassImage moduleName-        spacer-      renderTopLevel exps (filter isTypeClassDeclaration ds)-      spacer-    when hasTypeclassInstances $ do-      headerLevel 3 "Type Class Instances"-      spacer-      renderTopLevel exps (filter isTypeInstanceDeclaration ds)-      spacer-    when hasValues $ do-      headerLevel 3 "Values"-      spacer-      renderTopLevel exps (filter isValueDeclaration ds)-      spacer+    renderTopLevel exps (P.exportedDeclarations mdl)+    spacer  renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs-renderTopLevel exps decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do-  traverse_ (headerLevel 4) (ticks `fmap` getDeclarationTitle decl)-  spacer-  renderDeclaration exps decl-  spacer+renderTopLevel exps decls = forM_ decls $ \decl ->+  when (canRenderDecl decl) $ do+    traverse_ (headerLevel 4) (ticks `fmap` getDeclarationTitle decl)+    spacer+    renderDeclaration exps decl+    spacer  renderTypeclassImage :: P.ModuleName -> Docs renderTypeclassImage name =@@ -137,63 +118,62 @@  renderDeclaration :: Maybe [P.DeclarationRef] -> P.Declaration -> Docs renderDeclaration _ (P.TypeDeclaration ident ty) =-  atIndent 4 $ show ident ++ " :: " ++ prettyPrintType' ty+  fenced $ show ident ++ " :: " ++ prettyPrintType' ty renderDeclaration _ (P.ExternDeclaration _ ident _ ty) =-  atIndent 4 $ show ident ++ " :: " ++ prettyPrintType' ty+  fenced $ show ident ++ " :: " ++ prettyPrintType' ty renderDeclaration exps (P.DataDeclaration dtype name args ctors) = do   let     typeApp  = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)     typeName = prettyPrintType' typeApp     exported = filter (P.isDctorExported name exps . fst) ctors-  atIndent 4 $ show dtype ++ " " ++ typeName-  zipWithM_ (\isFirst (ctor, tys) ->-              atIndent 6 $ (if isFirst then "= " else "| ") ++ P.runProperName ctor ++ " " ++ unwords (map P.prettyPrintTypeAtom tys))-            (True : repeat False) exported+  fencedBlock $ do+    tell [show dtype ++ " " ++ typeName]+    zipWithM_ (\isFirst (ctor, tys) ->+                atIndent 2 $ (if isFirst then "= " else "| ") ++ P.runProperName ctor ++ " " ++ unwords (map P.prettyPrintTypeAtom tys))+              (True : repeat False) exported renderDeclaration _ (P.ExternDataDeclaration name kind) =-  atIndent 4 $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind+  fenced $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind renderDeclaration _ (P.TypeSynonymDeclaration name args ty) = do   let     typeApp  = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)     typeName = prettyPrintType' typeApp-  atIndent 4 $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty+  fenced $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty renderDeclaration _ (P.TypeClassDeclaration name args implies ds) = do   let impliesText = case implies of                       [] -> ""                       is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "       classApp  = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)       className = prettyPrintType' classApp-  atIndent 4 $ "class " ++ impliesText ++ className ++ " where"-  mapM_ renderClassMember ds+  fencedBlock $ do+    tell ["class " ++ impliesText ++ className ++ " where"]+    mapM_ renderClassMember ds   where     renderClassMember (P.PositionedDeclaration _ _ d) = renderClassMember d-    renderClassMember (P.TypeDeclaration ident ty) = atIndent 6 $ show ident ++ " :: " ++ prettyPrintType' ty+    renderClassMember (P.TypeDeclaration ident ty) = atIndent 2 $ show ident ++ " :: " ++ prettyPrintType' ty     renderClassMember _ = error "Invalid argument to renderClassMember." renderDeclaration _ (P.TypeInstanceDeclaration name constraints className tys _) = do   let constraintsText = case constraints of                           [] -> ""                           cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "-  atIndent 4 $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)+  fenced $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys) renderDeclaration exps (P.PositionedDeclaration _ com d) = do-  renderComments com   renderDeclaration exps d+  renderComments com renderDeclaration _ _ = return ()  renderComments :: [P.Comment] -> Docs renderComments cs = do   let raw = concatMap toLines cs-  -  if all hasPipe raw-    then atIndent 0 . unlines . map stripPipes $ raw-    else atIndent 4 $ unlines raw-  -  unless (null raw) spacer+  when (all hasPipe raw) $ do+    spacer+    atIndent 0 . unlines . map stripPipes $ raw   where    toLines (P.LineComment s) = [s]   toLines (P.BlockComment s) = lines s-  +   hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }-  +   stripPipes = dropPipe . dropWhile (== ' ')    dropPipe ('|':' ':s) = s@@ -223,42 +203,24 @@ getName (P.PositionedDeclaration _ _ d) = getName d getName _ = error "Invalid argument to getName" -isValueDeclaration :: P.Declaration -> Bool-isValueDeclaration P.TypeDeclaration{} = True-isValueDeclaration P.ExternDeclaration{} = True-isValueDeclaration (P.PositionedDeclaration _ _ d) = isValueDeclaration d-isValueDeclaration _ = False--isTypeDeclaration :: P.Declaration -> Bool-isTypeDeclaration P.DataDeclaration{} = True-isTypeDeclaration P.ExternDataDeclaration{} = True-isTypeDeclaration P.TypeSynonymDeclaration{} = True-isTypeDeclaration (P.PositionedDeclaration _ _ d) = isTypeDeclaration d-isTypeDeclaration _ = False--isTypeClassDeclaration :: P.Declaration -> Bool-isTypeClassDeclaration P.TypeClassDeclaration{} = True-isTypeClassDeclaration (P.PositionedDeclaration _ _ d) = isTypeClassDeclaration d-isTypeClassDeclaration _ = False--isTypeInstanceDeclaration :: P.Declaration -> Bool-isTypeInstanceDeclaration P.TypeInstanceDeclaration{} = True-isTypeInstanceDeclaration (P.PositionedDeclaration _ _ d) = isTypeInstanceDeclaration d-isTypeInstanceDeclaration _ = False+canRenderDecl :: P.Declaration -> Bool+canRenderDecl P.TypeDeclaration{} = True+canRenderDecl P.ExternDeclaration{} = True+canRenderDecl P.DataDeclaration{} = True+canRenderDecl P.ExternDataDeclaration{} = True+canRenderDecl P.TypeSynonymDeclaration{} = True+canRenderDecl P.TypeClassDeclaration{} = True+canRenderDecl P.TypeInstanceDeclaration{} = True+canRenderDecl (P.PositionedDeclaration _ _ d) = canRenderDecl d+canRenderDecl _ = False  inputFile :: Parser FilePath inputFile = strArgument $      metavar "FILE"   <> help "The input .purs file(s)" -includeHeirarcy :: Parser Bool-includeHeirarcy = switch $-     long "hierarchy-images"-  <> help "Include markdown for type class hierarchy images in the output."- pscDocsOptions :: Parser PSCDocsOptions-pscDocsOptions = PSCDocsOptions <$> includeHeirarcy-                                <*> many inputFile+pscDocsOptions = PSCDocsOptions <$> many inputFile  main :: IO () main = execParser opts >>= docgen

@@ -17,9 +17,11 @@ module Main where  import Control.Applicative-import Control.Monad.Error+import Control.Monad.Except+import Control.Monad.Reader  import Data.Version (showVersion)+import Data.Traversable (traverse)  import Options.Applicative as Opts @@ -50,20 +52,19 @@   content <- forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile   return (if ioNoPrelude then content else (Left P.RebuildNever, P.prelude) : content) -newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadError String)+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT String IO) a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadError String, MonadReader (P.Options P.Make)) -runMake :: Make a -> IO (Either String a)-runMake = runErrorT . unMake+runMake :: P.Options P.Make -> Make a -> IO (Either String a)+runMake opts = runExceptT . flip runReaderT opts . unMake  makeIO :: IO a -> Make a-makeIO = Make . ErrorT . fmap (either (Left . show) Right) . tryIOError+makeIO = Make . lift . ExceptT . fmap (either (Left . show) Right) . tryIOError  instance P.MonadMake Make where   getTimestamp path = makeIO $ do     exists <- doesFileExist path-    case exists of-      True -> Just <$> getModificationTime path-      False -> return Nothing+    traverse (const $ getModificationTime path) $ guard exists   readTextFile path = makeIO $ do     putStrLn $ "Reading " ++ path     readFile path@@ -71,7 +72,6 @@     mkdirp path     putStrLn $ "Writing " ++ path     writeFile path text-  liftError = either throwError return   progress = makeIO . putStrLn  compile :: PSCMakeOptions -> IO ()@@ -82,7 +82,7 @@       print err       exitFailure     Right ms -> do-      e <- runMake $ P.make outputDir opts ms prefix+      e <- runMake opts $ P.make outputDir ms prefix       case e of         Left err -> do           putStrLn err@@ -130,6 +130,12 @@      long "no-opts"   <> help "Skip the optimization phase." +comments :: Parser Bool+comments = switch $+     short 'c'+  <> long "comments"+  <> help "Include comments in the generated code."+ verboseErrors :: Parser Bool verboseErrors = switch $      short 'v'@@ -149,6 +155,7 @@                     <*> noMagicDo                     <*> pure Nothing                     <*> noOpts+                    <*> comments                     <*> verboseErrors                     <*> pure P.MakeOptions 

@@ -17,7 +17,8 @@ module Main where  import Control.Applicative-import Control.Monad.Error+import Control.Monad.Except+import Control.Monad.Reader  import Data.Maybe (fromMaybe) import Data.Version (showVersion)@@ -61,7 +62,7 @@       hPutStrLn stderr $ show err       exitFailure     Right ms -> do-      case P.compile opts (map snd ms) prefix of+      case P.compile (map snd ms) prefix `runReaderT` opts of         Left err -> do           hPutStrLn stderr err           exitFailure@@ -137,6 +138,12 @@      long "no-prelude"   <> help "Omit the Prelude" +comments :: Parser Bool+comments = switch $+     short 'c'+  <> long "comments"+  <> help "Include comments in the generated code."+ useStdIn :: Parser Bool useStdIn = switch $      short 's'@@ -173,6 +180,7 @@                     <*> runMain                     <*> noOpts                     <*> verboseErrors+                    <*> comments                     <*> additionalOptions   where   additionalOptions =

@@ -13,7 +13,11 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DataKinds, DoAndIfThenElse, FlexibleContexts, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}  module Main where @@ -27,8 +31,8 @@  import Control.Applicative import Control.Monad-import Control.Monad.Error (ErrorT(..), MonadError)-import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.Except (ExceptT(..), MonadError, runExceptT)+import Control.Monad.Reader (MonadReader, ReaderT, runReaderT) import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.Trans.State.Strict@@ -53,9 +57,8 @@ import Commands as C import Parser - data PSCiOptions = PSCiOptions-  { psciSingleLineFlag :: Bool+  { psciMultiLineMode :: Bool   , psciInputFile      :: [FilePath]   } @@ -96,7 +99,7 @@ -- Updates the state to have more let bindings. -- updateLets :: [P.Declaration] -> PSCiState -> PSCiState-updateLets ds st = st { psciLetBindings = ds ++ psciLetBindings st }+updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds }  -- File helpers -- |@@ -150,7 +153,7 @@   modulesOrFirstError <- psciIO $ loadAllModules files   case modulesOrFirstError of     Left err -> psciIO $ print err-    Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules } +    Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules }  -- | -- Expands tilde in path.@@ -182,8 +185,6 @@   , "                                       |_|        "   , ""   , ":? shows help"-  , ""-  , "Expressions are terminated using Ctrl+D"   ]  -- |@@ -314,7 +315,7 @@ -- | Compilation options. -- options :: P.Options P.Make-options = P.Options False False False Nothing False False P.MakeOptions+options = P.Options False False False Nothing False False False P.MakeOptions  -- | -- PSCI monad@@ -322,27 +323,25 @@ newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)  psciIO :: IO a -> PSCI a-psciIO io = PSCI (lift (lift io))+psciIO io = PSCI . lift $ lift io -newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadError String)+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT String IO) a }+  deriving (Functor, Applicative, Monad, MonadError String, MonadReader (P.Options P.Make))  runMake :: Make a -> IO (Either String a)-runMake = runErrorT . unMake+runMake = runExceptT . flip runReaderT options . unMake  makeIO :: IO a -> Make a-makeIO = Make . ErrorT . fmap (either (Left . show) Right) . tryIOError+makeIO = Make . lift . ExceptT . fmap (either (Left . show) Right) . tryIOError  instance P.MonadMake Make where   getTimestamp path = makeIO $ do     exists <- doesFileExist path-    if exists-      then Just <$> getModificationTime path-      else return Nothing+    traverse (const $ getModificationTime path) $ guard exists   readTextFile path = makeIO $ readFile path   writeTextFile path text = makeIO $ do     mkdirp path     writeFile path text-  liftError = either throwError return   progress s = unless (s == "Compiling $PSCI") $ makeIO . putStrLn $ s  mkdirp :: FilePath -> IO ()@@ -402,7 +401,7 @@ handleDeclaration val = do   st <- PSCI $ lift get   let m = createTemporaryModule True st val-  e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []+  e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []   case e of     Left err -> PSCI $ outputStrLn err     Right _ -> do@@ -423,7 +422,7 @@   st <- PSCI $ lift get   let st' = updateLets ds st   let m = createTemporaryModule False st' (P.ObjectLiteral [])-  e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) []+  e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) []   case e of     Left err -> PSCI $ outputStrLn err     Right _ -> PSCI $ lift (put st')@@ -456,7 +455,7 @@ handleImport moduleName = do    st <- updateImports moduleName <$> PSCI (lift get)    let m = createTemporaryModuleForImports st-   e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []+   e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []    case e of      Left err -> PSCI $ outputStrLn err      Right _  -> do@@ -470,7 +469,7 @@ handleTypeOf val = do   st <- PSCI $ lift get   let m = createTemporaryModule False st val-  e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []+  e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []   case e of     Left err -> PSCI $ outputStrLn err     Right env' ->@@ -504,7 +503,7 @@ handleBrowse moduleName = do   st <- PSCI $ lift get   let loadedModules = psciLoadedModules st-  env <- psciIO . runMake $ P.make modulesDir options loadedModules []+  env <- psciIO . runMake $ P.make modulesDir loadedModules []   case env of     Left err -> PSCI $ outputStrLn err     Right env' ->@@ -520,7 +519,7 @@   st <- PSCI $ lift get   let m = createTemporaryModuleForKind st typ       mName = P.ModuleName [P.ProperName "$PSCI"]-  e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []+  e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []   case e of     Left err -> PSCI $ outputStrLn err     Right env' ->@@ -571,7 +570,7 @@     PSCI . outputStrLn $ "Couldn't locate: " ++ filePath handleCommand Reset = do   files <- psciImportedFilenames <$> PSCI (lift get)-  PSCI . lift . modify $ \st -> st +  PSCI . lift . modify $ \st -> st     { psciImportedFilenames   = files     , psciImportedModuleNames = defaultImports     , psciLetBindings         = []@@ -601,32 +600,33 @@ -- The PSCI main loop. -- loop :: PSCiOptions -> IO ()-loop (PSCiOptions singleLineMode files) = do+loop PSCiOptions{..} = do   config <- loadUserConfig-  modulesOrFirstError <- loadAllModules files+  modulesOrFirstError <- loadAllModules psciInputFile   case modulesOrFirstError of     Left err -> print err >> exitFailure     Right modules -> do       historyFilename <- getHistoryFilename       let settings = defaultSettings { historyFile = Just historyFilename }-      flip evalStateT (PSCiState files defaultImports modules []) . runInputT (setComplete completion settings) $ do+      flip evalStateT (PSCiState psciInputFile defaultImports modules []) . runInputT (setComplete completion settings) $ do         outputStrLn prologueMessage         traverse_ (mapM_ (runPSCI . handleCommand)) config         go       where         go :: InputT (StateT PSCiState IO) ()         go = do-          c <- getCommand singleLineMode+          c <- getCommand (not psciMultiLineMode)           case c of             Left err -> outputStrLn err >> go             Right Nothing -> go             Right (Just Quit) -> outputStrLn quitMessage             Right (Just c') -> runPSCI (loadAllImportedModules >> handleCommand c') >> go -singleLineFlag :: Parser Bool-singleLineFlag = switch $-     long "single-line-mode"-  <> Opts.help "Run in single-line mode"+multiLineMode :: Parser Bool+multiLineMode = switch $+     long "multi-line-mode"+  <> short 'm'+  <> Opts.help "Run in multi-line mode (use ^D to terminate commands)"  inputFile :: Parser FilePath inputFile = strArgument $@@ -634,7 +634,7 @@   <> Opts.help "Optional .purs files to load on start"  psciOptions :: Parser PSCiOptions-psciOptions = PSCiOptions <$> singleLineFlag+psciOptions = PSCiOptions <$> multiLineMode                           <*> many inputFile  main :: IO ()

@@ -1,5 +1,5 @@ name: purescript-version: 0.6.7.1+version: 0.6.8 cabal-version: >=1.8 build-type: Simple license: MIT@@ -31,10 +31,9 @@                    filepath -any,                    mtl >= 2.1.0 && < 2.3.0,                    parsec -any,-                   transformers >= 0.3 && < 0.5,+                   transformers >= 0.4.0 && < 0.5,                    utf8-string >= 1 && < 2,                    pattern-arrows >= 0.0.2 && < 0.1,-                   monad-unify >= 0.2.2 && < 0.3,                    file-embed >= 0.0.7 && < 0.0.8,                    time -any     exposed-modules: Language.PureScript@@ -111,11 +110,13 @@                      Language.PureScript.TypeChecker.Unify                      Language.PureScript.TypeClassDictionaries                      Language.PureScript.Types++                     Control.Monad.Unify     exposed: True     buildable: True     hs-source-dirs: src     other-modules: Paths_purescript-    ghc-options: -Wall -fno-warn-warnings-deprecations -O2+    ghc-options: -Wall -O2  executable psc     build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,@@ -125,7 +126,7 @@     buildable: True     hs-source-dirs: psc     other-modules:-    ghc-options: -Wall -fno-warn-warnings-deprecations -O2 -fno-warn-unused-do-bind+    ghc-options: -Wall -O2 -fno-warn-unused-do-bind  executable psc-make     build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,@@ -135,7 +136,7 @@     buildable: True     hs-source-dirs: psc-make     other-modules:-    ghc-options: -Wall -fno-warn-warnings-deprecations -O2 -fno-warn-unused-do-bind+    ghc-options: -Wall -O2 -fno-warn-unused-do-bind  executable psci     build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,@@ -148,7 +149,7 @@     hs-source-dirs: psci     other-modules: Commands                    Parser-    ghc-options: -Wall -fno-warn-warnings-deprecations -O2+    ghc-options: -Wall -O2  executable psc-docs     build-depends: base >=4 && <5, purescript -any,@@ -157,7 +158,7 @@     buildable: True     hs-source-dirs: psc-docs     other-modules:-    ghc-options: -Wall -fno-warn-warnings-deprecations -O2+    ghc-options: -Wall -O2  executable psc-hierarchy     build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.10.0,@@ -166,7 +167,7 @@     buildable: True     hs-source-dirs: hierarchy     other-modules:-    ghc-options: -Wall -fno-warn-warnings-deprecations -O2+    ghc-options: -Wall -O2  test-suite tests     build-depends: base >=4 && <5, containers -any, directory -any,

@@ -0,0 +1,155 @@+-----------------------------------------------------------------------------+--+-- Module      :  Control.Monad.Unify+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+--+-----------------------------------------------------------------------------++{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Control.Monad.Unify where++import Data.String (IsString)+import Data.Monoid++import Control.Applicative+import Control.Monad.State+import Control.Monad.Error.Class++import Data.HashMap.Strict as M++-- |+-- Untyped unification variables+--+type Unknown = Int++-- |+-- A type which can contain unification variables+--+class Partial t where+  unknown :: Unknown -> t+  isUnknown :: t -> Maybe Unknown+  unknowns :: t -> [Unknown]+  ($?) :: Substitution t -> t -> t++-- |+-- Identifies types which support unification+--+class (Partial t) => Unifiable m t | t -> m where+  (=?=) :: t -> t -> UnifyT t m ()++-- |+-- A substitution maintains a mapping from unification variables to their values+--+data Substitution t = Substitution { runSubstitution :: M.HashMap Int t }++instance (Partial t) => Monoid (Substitution t) where+  mempty = Substitution M.empty+  s1 `mappend` s2 = Substitution $+                      M.map (s2 $?) (runSubstitution s1) `M.union`+                      M.map (s1 $?) (runSubstitution s2)++-- |+-- State required for type checking+--+data UnifyState t = UnifyState {+  -- |+  -- The next fresh unification variable+  --+    unifyNextVar :: Int+  -- |+  -- The current substitution+  --+  , unifyCurrentSubstitution :: Substitution t+  }++-- |+-- An empty @UnifyState@+--+defaultUnifyState :: (Partial t) => UnifyState t+defaultUnifyState = UnifyState 0 mempty++-- |+-- The type checking monad, which provides the state of the type checker, and error reporting capabilities+--+newtype UnifyT t m a = UnifyT { unUnify :: (StateT (UnifyState t) m) a }+  deriving (Functor, Monad, Applicative, Alternative, MonadPlus)++instance (MonadState s m) => MonadState s (UnifyT t m) where+  get = UnifyT . lift $ get+  put = UnifyT . lift . put++instance (MonadError e m) => MonadError e (UnifyT t m) where+  throwError = UnifyT . throwError+  catchError e f = UnifyT $ catchError (unUnify e) (unUnify . f)++-- |+-- Run a computation in the Unify monad, failing with an error, or succeeding with a return value and the new next unification variable+--+runUnify :: UnifyState t -> UnifyT t m a -> m (a, UnifyState t)+runUnify s = flip runStateT s . unUnify++-- |+-- Substitute a single unification variable+--+substituteOne :: (Partial t) => Unknown -> t -> Substitution t+substituteOne u t = Substitution $ M.singleton u t++-- |+-- Replace a unification variable with the specified value in the current substitution+--+(=:=) :: (IsString e, Monad m, MonadError e m, Unifiable m t) => Unknown -> t -> UnifyT t m ()+(=:=) u t' = do+  st <- UnifyT get+  let sub = unifyCurrentSubstitution st+  let t = sub $? t'+  occursCheck u t+  let current = sub $? unknown u+  case isUnknown current of+    Just u1 | u1 == u -> return ()+    _ -> current =?= t+  UnifyT $ modify $ \s -> s { unifyCurrentSubstitution = substituteOne u t <> unifyCurrentSubstitution s }++-- |+-- Perform the occurs check, to make sure a unification variable does not occur inside a value+--+occursCheck :: (IsString e, Monad m, MonadError e m, Partial t) => Unknown -> t -> UnifyT t m ()+occursCheck u t =+  case isUnknown t of+    Nothing -> when (u `elem` unknowns t) $ UnifyT . lift . throwError $ "Occurs check fails"+    _ -> return ()++-- |+-- Generate a fresh untyped unification variable+--+fresh' :: (Monad m) => UnifyT t m Unknown+fresh' = do+  st <- UnifyT get+  UnifyT $ modify $ \s -> s { unifyNextVar = succ (unifyNextVar s) }+  return $ unifyNextVar st++-- |+-- Generate a fresh unification variable at a specific type+--+fresh :: (Monad m, Partial t) => UnifyT t m t+fresh = do+  u <- fresh'+  return $ unknown u+++

@@ -13,7 +13,7 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DataKinds, QuasiQuotes, TemplateHaskell #-}+{-# LANGUAGE DataKinds, QuasiQuotes, TemplateHaskell, FlexibleContexts #-}  module Language.PureScript (module P, compile, compile', RebuildPolicy(..), MonadMake(..), make, prelude) where @@ -22,13 +22,15 @@ import Data.List (sortBy, groupBy, intercalate) import Data.Maybe (fromMaybe) import Data.Time.Clock+import qualified Data.Traversable as T (traverse) import qualified Data.ByteString.UTF8 as BU import qualified Data.Map as M import qualified Data.Set as S  import Control.Applicative import Control.Arrow ((&&&))-import Control.Monad.Error+import Control.Monad.Except+import Control.Monad.Reader  import System.FilePath ((</>)) @@ -71,42 +73,47 @@ -- --  * Pretty-print the generated Javascript ---compile :: Options Compile -> [Module] -> [String] -> Either String (String, String, Environment)+compile :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)+        => [Module] -> [String] -> m (String, String, Environment) compile = compile' initEnvironment -compile' :: Environment -> Options Compile -> [Module] -> [String] -> Either String (String, String, Environment)-compile' env opts ms prefix = do-  (sorted, _) <- sortModules $ map importPrim $ if optionsNoPrelude opts then ms else map importPrelude ms+compile' :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)+         => Environment -> [Module] -> [String] -> m (String, String, Environment)+compile' env ms prefix = do+  noPrelude <- asks optionsNoPrelude+  additional <- asks optionsAdditional+  mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)+  (sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms   (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted-  (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent+  (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent   regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated   let corefn = map (CoreFn.moduleToCoreFn env') regrouped-  let entryPoints = moduleNameFromString `map` entryPointModules (optionsAdditional opts)+  let entryPoints = moduleNameFromString `map` entryPointModules additional   let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn   let renamed = renameInModules elim-  let codeGenModuleNames = moduleNameFromString `map` codeGenModules (optionsAdditional opts)+  let codeGenModuleNames = moduleNameFromString `map` codeGenModules additional   let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed-  let js = evalSupply nextVar $ concat <$> mapM (moduleToJs opts) modulesToCodeGen+  js <- concat <$> (evalSupplyT nextVar $ T.traverse moduleToJs modulesToCodeGen)   let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped-  js' <- generateMain env' opts js+  js' <- generateMain env' js   let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']   return (pjs, exts, env')-  where-  mainModuleIdent = moduleNameFromString <$> optionsMain opts -generateMain :: Environment -> Options Compile -> [JS] -> Either String [JS]-generateMain env opts js =-  case moduleNameFromString <$> optionsMain opts of+generateMain :: (MonadError String m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS]+generateMain env js = do+  main <- asks optionsMain+  additional <- asks optionsAdditional+  case moduleNameFromString <$> main of     Just mmi -> do       when ((mmi, Ident C.main) `M.notMember` names env) $-        Left $ show mmi ++ "." ++ C.main ++ " is undefined"-      return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace (optionsAdditional opts))))) []]+        throwError $ show mmi ++ "." ++ C.main ++ " is undefined"+      return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace additional)))) []]     _ -> return js  -- | -- A type class which collects the IO actions we need to be able to run in "make" mode ---class MonadMake m where+class (MonadReader (P.Options P.Make) m, MonadError String m) => MonadMake m where   -- |   -- Get a file timestamp   --@@ -123,11 +130,6 @@   writeTextFile :: FilePath -> String -> m ()    -- |-  -- Report an error-  ---  liftError :: Either String a -> m a--  -- |   -- Respond to a progress update   --   progress :: String -> m ()@@ -152,11 +154,13 @@ -- If timestamps have not changed, the externs file can be used to provide the module's types without -- having to typecheck the module again. ---make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options Make -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment-make outputDir opts ms prefix = do+make :: (Functor m, Applicative m, Monad m, MonadMake m)+     => FilePath -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment+make outputDir ms prefix = do+  noPrelude <- asks optionsNoPrelude   let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms) -  (sorted, graph) <- liftError $ sortModules $ map importPrim $ if optionsNoPrelude opts then map snd ms else map (importPrelude . snd) ms+  (sorted, graph) <- sortModules $ map importPrim $ if noPrelude then map snd ms else map (importPrelude . snd) ms    toRebuild <- foldM (\s (Module moduleName' _ _) -> do     let filePath = runModuleName moduleName'@@ -176,15 +180,16 @@    marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted -  (desugared, nextVar) <- liftError $ stringifyErrorStack True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)+  (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked) -  evalSupplyT nextVar (go initEnvironment desugared)+  evalSupplyT nextVar $ go initEnvironment desugared    where-  go :: (Functor m, Applicative m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> SupplyT m Environment+  go :: (Functor m, Applicative m, Monad m, MonadMake m)+     => Environment -> [(Bool, Module)] -> SupplyT m Environment   go env [] = return env   go env ((False, m) : ms') = do-    (_, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m+    (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m      go env' ms'   go env ((True, m@(Module moduleName' _ exps)) : ms') = do@@ -194,15 +199,15 @@      lift . progress $ "Compiling " ++ runModuleName moduleName' -    (Module _ elaborated _, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m+    (Module _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m -    regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated+    regrouped <- stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated      let mod' = Module moduleName' regrouped exps     let corefn = CoreFn.moduleToCoreFn env' mod'     let [renamed] = renameInModules [corefn] -    pjs <- prettyPrintJS <$> moduleToJs opts renamed+    pjs <- prettyPrintJS <$> moduleToJs renamed     let js = unlines $ map ("// " ++) prefix ++ [pjs]     let exts = unlines $ map ("-- " ++) prefix ++ [moduleToPs mod' env'] @@ -220,10 +225,10 @@   rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms') = do     let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"     externs <- readTextFile externsFile-    externsModules <- liftError . fmap (map snd) . either (Left . show) Right $ P.parseModulesFromFiles id [(externsFile, externs)]+    externsModules <- fmap (map snd) . either (throwError . show) return $ P.parseModulesFromFiles id [(externsFile, externs)]     case externsModules of       [m'@(Module moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'-      _ -> liftError . Left $ "Externs file " ++ externsFile ++ " was invalid"+      _ -> throwError $ "Externs file " ++ externsFile ++ " was invalid"  reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName] reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]

@@ -398,6 +398,10 @@   --   | TypeClassDictionary Bool Constraint [TypeClassDictionaryInScope]   -- |+  -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.+  --+  | TypeClassDictionaryAccessor (Qualified ProperName) Ident+  -- |   -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking   --   | SuperClassDictionary (Qualified ProperName) [Type]

@@ -13,21 +13,22 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE GADTs, ViewPatterns #-}+{-# LANGUAGE GADTs, ViewPatterns, FlexibleContexts #-}  module Language.PureScript.CodeGen.JS (     module AST,     module Common,-    bindToJs,     moduleToJs ) where  import Data.List ((\\), delete) import Data.Maybe (mapMaybe)+import qualified Data.Traversable as T (traverse)  import Control.Applicative import Control.Arrow ((&&&)) import Control.Monad (foldM, replicateM, forM)+import Control.Monad.Reader (MonadReader, asks, lift)  import Language.PureScript.CodeGen.JS.AST as AST import Language.PureScript.CodeGen.JS.Common as Common@@ -43,16 +44,18 @@ -- Generate code in the simplified Javascript intermediate representation for all declarations in a -- module. ---moduleToJs :: (Functor m, Applicative m, Monad m) => Options mode -> Module Ann -> SupplyT m [JS]-moduleToJs opts (Module name imps exps foreigns decls) = do-  let jsImports = map (importToJs opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) $ imps+moduleToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)+           => Module Ann -> SupplyT m [JS]+moduleToJs (Module name imps exps foreigns decls) = do+  additional <- lift $ asks optionsAdditional+  jsImports <- lift . T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [name]) $ imps   let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns   jsDecls <- mapM (bindToJs name) decls-  let optimized = concatMap (map $ optimize opts) jsDecls+  optimized <- lift $ T.traverse (T.traverse optimize) jsDecls   let isModuleEmpty = null exps-  let moduleBody = JSStringLiteral "use strict" : jsImports ++ foreigns' ++ optimized+  let moduleBody = JSStringLiteral "use strict" : jsImports ++ foreigns' ++ concat optimized   let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) exps-  return $ case optionsAdditional opts of+  return $ case additional of     MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']     CompileOptions ns _ _ | not isModuleEmpty ->       [ JSVariableIntroduction ns@@ -65,18 +68,19 @@ -- | -- Generates Javascript code for a module import. ---importToJs :: Options mode -> ModuleName -> JS-importToJs opts mn =-  JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)-  where-  moduleBody = case optionsAdditional opts of-    MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]-    CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns)+importToJs :: (Monad m, MonadReader (Options mode) m) => ModuleName -> m JS+importToJs mn = do+  additional <- asks optionsAdditional+  let moduleBody = case additional of+        MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]+        CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns)+  return $ JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)  -- | -- Generate code in the simplified Javascript intermediate representation for a declaration ---bindToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Bind Ann -> SupplyT m [JS]+bindToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)+         => ModuleName -> Bind Ann -> SupplyT m [JS] bindToJs mp (NonRec ident val) = return <$> nonRecToJS mp ident val bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp)) @@ -86,9 +90,13 @@ -- -- The main purpose of this function is to handle code generation for comments. ---nonRecToJS :: (Functor m, Applicative m, Monad m) => ModuleName -> Ident -> Expr Ann -> SupplyT m JS-nonRecToJS m i e@(extractAnn -> (_, com, _, _)) | not (null com) =-  JSComment com <$> nonRecToJS m i (modifyAnn removeComments e)+nonRecToJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)+           => ModuleName -> Ident -> Expr Ann -> SupplyT m JS+nonRecToJS m i e@(extractAnn -> (_, com, _, _)) | not (null com) = do+  withoutComment <- lift $ asks optionsNoComments+  if withoutComment+     then nonRecToJS m i (modifyAnn removeComments e)+     else JSComment com <$> nonRecToJS m i (modifyAnn removeComments e) nonRecToJS mp ident val = do   js <- valueToJs mp val   return $ JSVariableIntroduction (identToJs ident) (Just js)@@ -117,10 +125,11 @@ -- | -- Generate code in the simplified Javascript intermediate representation for a value or expression. ---valueToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Expr Ann -> SupplyT m JS+valueToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)+          => ModuleName -> Expr Ann -> SupplyT m JS valueToJs m (Literal _ l) =   literalToValueJS m l-valueToJs m (Var (_, _, _, Just (IsConstructor _ 0)) name) =+valueToJs m (Var (_, _, _, Just (IsConstructor _ [])) name) =   return $ JSAccessor "value" $ qualifiedToJS m id name valueToJs m (Var (_, _, _, Just (IsConstructor _ _)) name) =   return $ JSAccessor "create" $ qualifiedToJS m id name@@ -128,7 +137,7 @@   accessorString prop <$> valueToJs m val valueToJs m (ObjectUpdate _ o ps) = do   obj <- valueToJs m o-  sts <- mapM (sndM (valueToJs m)) ps+  sts <- mapM (sndM $ valueToJs m) ps   extendObj obj sts valueToJs _ e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =   let args = unAbs e@@ -148,7 +157,7 @@   args' <- mapM (valueToJs m) args   case f of     Var (_, _, _, Just IsNewtype) _ -> return (head args')-    Var (_, _, _, Just (IsConstructor _ arity)) name | arity == length args ->+    Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->       return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'     Var (_, _, _, Just IsTypeClassConstructor) name ->       return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'@@ -171,30 +180,25 @@               JSObjectLiteral [("create",                 JSFunction Nothing ["value"]                   (JSBlock [JSReturn $ JSVar "value"]))])-valueToJs _ (Constructor _ _ (ProperName ctor) 0) =+valueToJs _ (Constructor _ _ (ProperName ctor) []) =   return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])          , JSAssignment (JSAccessor "value" (JSVar ctor))               (JSUnary JSNew $ JSApp (JSVar ctor) []) ]-valueToJs _ (Constructor _ _ (ProperName ctor) arity) =-  return $ iife ctor [ makeConstructor ctor arity-         , JSAssignment (JSAccessor "create" (JSVar ctor)) (go ctor 0 arity [])-         ]-    where-    makeConstructor :: String -> Int -> JS-    makeConstructor ctorName n =-      let args = [ "value" ++ show index | index <- [0..n-1] ]-          body = [ JSAssignment (JSAccessor arg (JSVar "this")) (JSVar arg) | arg <- args ]-      in JSFunction (Just ctorName) args (JSBlock body)-    go :: String -> Int -> Int -> [JS] -> JS-    go pn _ 0 values = JSUnary JSNew $ JSApp (JSVar pn) (reverse values)-    go pn index n values =-      JSFunction Nothing ["value" ++ show index]-        (JSBlock [JSReturn (go pn (index + 1) (n - 1) (JSVar ("value" ++ show index) : values))])-+valueToJs _ (Constructor _ _ (ProperName ctor) fields) =+  let constructor =+        let body = [ JSAssignment (JSAccessor (identToJs f) (JSVar "this")) (var f) | f <- fields ]+        in JSFunction (Just ctor) (identToJs `map` fields) (JSBlock body)+      createFn =+        let body = JSUnary JSNew $ JSApp (JSVar ctor) (var `map` fields)+        in foldr (\f inner -> JSFunction Nothing [identToJs f] (JSBlock [JSReturn inner])) body fields+  in return $ iife ctor [ constructor+                        , JSAssignment (JSAccessor "create" (JSVar ctor)) createFn+                        ] iife :: String -> [JS] -> JS iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) [] -literalToValueJS :: (Functor m, Applicative m, Monad m) => ModuleName -> Literal (Expr Ann) -> SupplyT m JS+literalToValueJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)+                 => ModuleName -> Literal (Expr Ann) -> SupplyT m JS literalToValueJS _ (NumericLiteral n) = return $ JSNumericLiteral n literalToValueJS _ (StringLiteral s) = return $ JSStringLiteral s literalToValueJS _ (BooleanLiteral b) = return $ JSBooleanLiteral b@@ -241,7 +245,8 @@ -- Generate code in the simplified Javascript intermediate representation for pattern match binders -- and guards. ---bindersToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> [CaseAlternative Ann] -> [JS] -> SupplyT m JS+bindersToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)+            => ModuleName -> [CaseAlternative Ann] -> [JS] -> SupplyT m JS bindersToJs m binders vals = do   valNames <- replicateM (length vals) freshName   let assignments = zipWith JSVariableIntroduction valNames (map Just vals)@@ -251,14 +256,16 @@   return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]])))                  []   where-    go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder Ann] -> SupplyT m [JS]+    go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)+       => [String] -> [JS] -> [Binder Ann] -> SupplyT m [JS]     go _ done [] = return done     go (v:vs) done' (b:bs) = do       done'' <- go vs done' bs       binderToJs m v done'' b     go _ _ _ = error "Invalid arguments to bindersToJs" -    guardsToJs :: (Functor m, Applicative m, Monad m) => Either [(Guard Ann, Expr Ann)] (Expr Ann) -> SupplyT m [JS]+    guardsToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)+               => Either [(Guard Ann, Expr Ann)] (Expr Ann) -> SupplyT m [JS]     guardsToJs (Left gs) = forM gs $ \(cond, val) -> do       cond' <- valueToJs m cond       done  <- valueToJs m val@@ -269,7 +276,8 @@ -- Generate code in the simplified Javascript intermediate representation for a pattern match -- binder. ---binderToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> String -> [JS] -> Binder Ann -> SupplyT m [JS]+binderToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)+           => ModuleName -> String -> [JS] -> Binder Ann -> SupplyT m [JS] binderToJs _ _ done (NullBinder{}) = return done binderToJs m varName done (LiteralBinder _ l) =   literalToBinderJS m varName done l@@ -277,8 +285,8 @@   return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done) binderToJs m varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =   binderToJs m varName done b-binderToJs m varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType _)) _ ctor bs) = do-  js <- go 0 done bs+binderToJs m varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do+  js <- go (zip fields bs) done   return $ case ctorType of     ProductType -> js     SumType ->@@ -286,13 +294,14 @@                 (JSBlock js)                 Nothing]   where-  go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder Ann] -> SupplyT m [JS]-  go _ done' [] = return done'-  go index done' (binder:bs') = do+  go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)+     => [(Ident, Binder Ann)] -> [JS] -> SupplyT m [JS]+  go [] done' = return done'+  go ((field, binder) : remain) done' = do     argVar <- freshName-    done'' <- go (index + 1) done' bs'+    done'' <- go remain done'     js <- binderToJs m argVar done'' binder-    return (JSVariableIntroduction argVar (Just (JSAccessor ("value" ++ show index) (JSVar varName))) : js)+    return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js) binderToJs m varName done binder@(ConstructorBinder _ _ ctor _) | isCons ctor = do   let (headBinders, tailBinder) = uncons [] binder       numberOfHeadBinders = fromIntegral $ length headBinders@@ -316,7 +325,8 @@   js <- binderToJs m varName done binder   return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js) -literalToBinderJS :: (Functor m, Applicative m, Monad m) => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> SupplyT m [JS]+literalToBinderJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)+                  => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> SupplyT m [JS] literalToBinderJS _ varName done (NumericLiteral num) =   return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing] literalToBinderJS _ varName done (StringLiteral str) =@@ -327,7 +337,8 @@   return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing] literalToBinderJS m varName done (ObjectLiteral bs) = go done bs   where-  go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder Ann)] -> SupplyT m [JS]+  go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)+     => [JS] -> [(String, Binder Ann)] -> SupplyT m [JS]   go done' [] = return done'   go done' ((prop, binder):bs') = do     propVar <- freshName@@ -338,7 +349,8 @@   js <- go done 0 bs   return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]   where-  go :: (Functor m, Applicative m, Monad m) => [JS] -> Integer -> [Binder Ann] -> SupplyT m [JS]+  go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)+     => [JS] -> Integer -> [Binder Ann] -> SupplyT m [JS]   go done' _ [] = return done'   go done' index (binder:bs') = do     elVar <- freshName

@@ -31,10 +31,14 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts #-}+ module Language.PureScript.CodeGen.JS.Optimizer (     optimize ) where +import Control.Monad.Reader (MonadReader, ask, asks)+ import Language.PureScript.CodeGen.JS.AST import Language.PureScript.Options import qualified Language.PureScript.Constants as C@@ -49,28 +53,34 @@ -- | -- Apply a series of optimizer passes to simplified Javascript code ---optimize :: Options mode -> JS -> JS-optimize opts | optionsNoOptimizations opts = id-              | otherwise = untilFixedPoint (applyAll-  [ collapseNestedBlocks-  , collapseNestedIfs-  , tco opts-  , magicDo opts-  , removeCodeAfterReturnStatements-  , removeUnusedArg-  , removeUndefinedApp-  , unThunk-  , etaConvert-  , evaluateIifes-  , inlineVariables-  , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]-  , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]-  , inlineOperator (C.preludeUnsafe, C.unsafeIndex) $ flip JSIndexer-  , inlineCommonOperators ])+optimize :: (Monad m, MonadReader (Options mode) m) => JS -> m JS+optimize js = do+  noOpt <- asks optionsNoOptimizations+  if noOpt then return js else optimize' js +optimize' :: (Monad m, MonadReader (Options mode) m) => JS -> m JS+optimize' js = do+  opts <- ask+  return $ untilFixedPoint (applyAll+    [ collapseNestedBlocks+    , collapseNestedIfs+    , tco opts+    , magicDo opts+    , removeCodeAfterReturnStatements+    , removeUnusedArg+    , removeUndefinedApp+    , unThunk+    , etaConvert+    , evaluateIifes+    , inlineVariables+    , inlineValues+    , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]+    , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]+    , inlineOperator (C.preludeUnsafe, C.unsafeIndex) $ flip JSIndexer+    , inlineCommonOperators ]) js+ untilFixedPoint :: (Eq a) => (a -> a) -> a -> a untilFixedPoint f = go   where   go a = let a' = f a in           if a' == a then a' else go a'-

@@ -15,6 +15,7 @@  module Language.PureScript.CodeGen.JS.Optimizer.Inliner (   inlineVariables,+  inlineValues,   inlineOperator,   inlineCommonOperators,   etaConvert,@@ -79,6 +80,15 @@       go (map (replaceIdent var js) sts)   go (s:sts) = s : go sts +inlineValues :: JS -> JS+inlineValues = everywhereOnJS convert+  where+  convert :: JS -> JS+  convert (JSApp fn [dict]) | isPreludeDict C.semiringNumber dict && isPreludeFn C.zero fn = JSNumericLiteral (Left 0)+  convert (JSApp fn [dict]) | isPreludeDict C.semiringNumber dict && isPreludeFn C.one fn = JSNumericLiteral (Left 1)+  convert (JSApp (JSApp fn [x]) [y]) | isPreludeFn (C.%) fn = JSBinary Modulus x y+  convert other = other+ inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS inlineOperator (m, op) f = everywhereOnJS convert   where@@ -91,12 +101,11 @@  inlineCommonOperators :: JS -> JS inlineCommonOperators = applyAll $-  [ binary C.numNumber (C.+) Add-  , binary C.numNumber (C.-) Subtract-  , binary C.numNumber (C.*) Multiply-  , binary C.numNumber (C./) Divide-  , binary C.numNumber (C.%) Modulus-  , unary  C.numNumber C.negate Negate+  [ binary C.semiringNumber (C.+) Add+  , binary C.semiringNumber (C.*) Multiply+  , binary C.ringNumber (C.-) Subtract+  , unary  C.ringNumber C.negate Negate+  , binary C.moduloSemiringNumber (C./) Divide    , binary C.ordNumber (C.<) LessThan   , binary C.ordNumber (C.>) GreaterThan@@ -131,29 +140,20 @@   binary dictName opString op = everywhereOnJS convert     where     convert :: JS -> JS-    convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y+    convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeDict dictName dict && isPreludeFn opString fn = JSBinary op x y     convert other = other-    isOp (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op opString)-    isOp (JSIndexer (JSStringLiteral op') (JSVar prelude)) = prelude == C.prelude && opString == op'-    isOp _ = False   binaryFunction :: String -> String -> BinaryOperator -> JS -> JS   binaryFunction dictName fnName op = everywhereOnJS convert     where     convert :: JS -> JS-    convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y+    convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSBinary op x y     convert other = other-    isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName == fnName'-    isOp _ = False   unary :: String -> String -> UnaryOperator -> JS -> JS   unary dictName fnName op = everywhereOnJS convert     where     convert :: JS -> JS-    convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x+    convert (JSApp (JSApp fn [dict]) [x]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSUnary op x     convert other = other-    isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName-    isOp _ = False-  isOpDict dictName (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == dictName-  isOpDict _ _ = False   mkFn :: Int -> JS -> JS   mkFn 0 = everywhereOnJS convert     where@@ -189,3 +189,13 @@     go 0 acc (JSApp runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp fn acc)     go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs     go _ _   _ = Nothing++isPreludeDict :: String -> JS -> Bool+isPreludeDict dictName (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == dictName+isPreludeDict _ _ = False++isPreludeFn :: String -> JS -> Bool+isPreludeFn fnName (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName+isPreludeFn fnName (JSIndexer (JSStringLiteral fnName') (JSVar prelude)) = prelude == C.prelude && fnName' == fnName+isPreludeFn fnName (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op fnName)+isPreludeFn _ _ = False

@@ -105,6 +105,12 @@  -- Prelude Values +zero :: String+zero = "zero"++one :: String+one = "one"+ return :: String return = "return" @@ -162,6 +168,15 @@  bindEffDictionary :: String bindEffDictionary = "bindEff"++semiringNumber :: String+semiringNumber = "semiringNumber"++ringNumber :: String+ringNumber = "ringNumber"++moduloSemiringNumber :: String+moduloSemiringNumber = "moduloSemiringNumber"  numNumber :: String numNumber = "numNumber"

@@ -13,6 +13,7 @@ -----------------------------------------------------------------------------  {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}  module Language.PureScript.CoreFn.Binders where @@ -44,4 +45,4 @@   -- |   -- A binder which binds its input to an identifier   ---  | NamedBinder a Ident (Binder a) deriving (Show, D.Data, D.Typeable)+  | NamedBinder a Ident (Binder a) deriving (Show, D.Data, D.Typeable, Functor)

@@ -40,15 +40,149 @@ -- Desugars a module from AST to CoreFn representation. -- moduleToCoreFn :: Environment -> A.Module -> Module Ann+moduleToCoreFn _ (A.Module _ _ Nothing) =+  error "Module exports were not elaborated before moduleToCoreFn" moduleToCoreFn env (A.Module mn decls (Just exps)) =   let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls       exps' = nub $ concatMap exportToCoreFn exps       externs = nub $ mapMaybe externToCoreFn decls-      decls' = concatMap (declToCoreFn env Nothing []) decls+      decls' = concatMap (declToCoreFn Nothing []) decls   in Module mn imports exps' externs decls'-moduleToCoreFn _ (A.Module{}) =-  error "Module exports were not elaborated before moduleToCoreFn" +  where++  -- |+  -- Desugars member declarations from AST to CoreFn representation.+  --+  declToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]+  declToCoreFn ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =+    [NonRec (properToIdent ctor) $+      Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]+  declToCoreFn _ _ d@(A.DataDeclaration Newtype _ _ _) =+    error $ "Found newtype with multiple constructors: " ++ show d+  declToCoreFn ss com (A.DataDeclaration Data tyName _ ctors) =+    flip map ctors $ \(ctor, _) ->+      let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor)+      in NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields+  declToCoreFn ss _   (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds+  declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =+    [NonRec name (exprToCoreFn ss com Nothing e)]+  declToCoreFn ss _   (A.BindingGroupDeclaration ds) =+    [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]+  declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =+    [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members]+  declToCoreFn _  com (A.PositionedDeclaration ss com1 d) =+    declToCoreFn (Just ss) (com ++ com1) d+  declToCoreFn _ _ _ = []++  -- |+  -- Desugars expressions from AST to CoreFn representation.+  --+  exprToCoreFn :: Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann+  exprToCoreFn ss com ty (A.NumericLiteral v) =+    Literal (ss, com, ty, Nothing) (NumericLiteral v)+  exprToCoreFn ss com ty (A.StringLiteral v) =+    Literal (ss, com, ty, Nothing) (StringLiteral v)+  exprToCoreFn ss com ty (A.BooleanLiteral v) =+    Literal (ss, com, ty, Nothing) (BooleanLiteral v)+  exprToCoreFn ss com ty (A.ArrayLiteral vs) =+    Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn ss [] Nothing) vs)+  exprToCoreFn ss com ty (A.ObjectLiteral vs) =+    Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn ss [] Nothing)) vs)+  exprToCoreFn ss com ty (A.Accessor name v) =+    Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)+  exprToCoreFn ss com ty (A.ObjectUpdate obj vs) =+    ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing obj) $ map (second (exprToCoreFn ss [] Nothing)) vs+  exprToCoreFn ss com ty (A.Abs (Left name) v) =+    Abs (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)+  exprToCoreFn _ _ _ (A.Abs _ _) =+    error "Abs with Binder argument was not desugared before exprToCoreFn mn"+  exprToCoreFn ss com ty (A.App v1 v2) =+    App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2)+  exprToCoreFn ss com ty (A.Var ident) =+    Var (ss, com, ty, Nothing) ident+  exprToCoreFn ss com ty (A.IfThenElse v1 v2 v3) =+    Case (ss, com, ty, Nothing) [exprToCoreFn ss [] Nothing v1]+      [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]+                        (Right $ exprToCoreFn Nothing [] Nothing v2)+      , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False]+                        (Right $ exprToCoreFn Nothing [] Nothing v3) ]+  exprToCoreFn ss com ty (A.Constructor name) =+    Var (ss, com, ty, Just $ getConstructorMeta name) $ fmap properToIdent name+  exprToCoreFn ss com ty (A.Case vs alts) =+    Case (ss, com, ty, Nothing) (map (exprToCoreFn ss [] Nothing) vs) (map (altToCoreFn ss) alts)+  exprToCoreFn ss com _ (A.TypedValue _ v ty) =+    exprToCoreFn ss com (Just ty) v+  exprToCoreFn ss com ty (A.Let ds v) =+    Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v)+  exprToCoreFn ss com _  (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) =+    let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs+        ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)+    in foldl (App (ss, com, Nothing, Nothing)) ctor args+  exprToCoreFn ss com ty  (A.TypeClassDictionaryAccessor _ ident) =+    Abs (ss, com, ty, Nothing) (Ident "dict")+      (Accessor nullAnn (runIdent ident) (Var nullAnn $ Qualified Nothing (Ident "dict")))+  exprToCoreFn _ com ty (A.PositionedValue ss com1 v) =+    exprToCoreFn (Just ss) (com ++ com1) ty v+  exprToCoreFn _ _ _ e =+    error $ "Unexpected value in exprToCoreFn mn: " ++ show e++  -- |+  -- Desugars case alternatives from AST to CoreFn representation.+  --+  altToCoreFn :: Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann+  altToCoreFn ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn ss []) bs) (go vs)+    where+    go :: Either [(A.Guard, A.Expr)] A.Expr -> Either [(Guard Ann, Expr Ann)] (Expr Ann)+    go (Left ges) = Left $ map (exprToCoreFn ss [] Nothing *** exprToCoreFn ss [] Nothing) ges+    go (Right e) = Right (exprToCoreFn ss [] Nothing e)++  -- |+  -- Desugars case binders from AST to CoreFn representation.+  --+  binderToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann+  binderToCoreFn ss com (A.NullBinder) =+    NullBinder (ss, com, Nothing, Nothing)+  binderToCoreFn ss com (A.BooleanBinder b) =+    LiteralBinder (ss, com, Nothing, Nothing) (BooleanLiteral b)+  binderToCoreFn ss com (A.StringBinder s) =+    LiteralBinder (ss, com, Nothing, Nothing) (StringLiteral s)+  binderToCoreFn ss com (A.NumberBinder n) =+    LiteralBinder (ss, com, Nothing, Nothing) (NumericLiteral n)+  binderToCoreFn ss com (A.VarBinder name) =+    VarBinder (ss, com, Nothing, Nothing) name+  binderToCoreFn ss com (A.ConstructorBinder dctor@(Qualified mn' _) bs) =+    let (_, tctor, _, _) = lookupConstructor env dctor+    in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (map (binderToCoreFn ss []) bs)+  binderToCoreFn ss com (A.ObjectBinder bs) =+    LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn ss [])) bs)+  binderToCoreFn ss com (A.ArrayBinder bs) =+    LiteralBinder (ss, com, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn ss []) bs)+  binderToCoreFn ss com (A.ConsBinder b1 b2) =+    let arrCtor = Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")+    in ConstructorBinder (ss, com, Nothing, Nothing) arrCtor arrCtor $ map (binderToCoreFn ss []) [b1, b2]+  binderToCoreFn ss com (A.NamedBinder name b) =+    NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b)+  binderToCoreFn _ com (A.PositionedBinder ss com1 b) =+    binderToCoreFn (Just ss) (com ++ com1) b++  -- |+  -- Gets metadata for data constructors.+  --+  getConstructorMeta :: Qualified ProperName -> Meta+  getConstructorMeta ctor =+    case lookupConstructor env ctor of+      (Newtype, _, _, _) -> IsNewtype+      dc@(Data, _, _, fields) ->+        let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType+        in IsConstructor constructorType fields+    where+    numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> Int+    numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env+    typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)+    typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)+    typeConstructor _ = error "Invalid argument to typeConstructor"+ -- | -- Find module names from qualified references to values. This is used to -- ensure instances are imported from any module that is referenced by the@@ -94,29 +228,6 @@ exportToCoreFn _ = []  -- |--- Desugars member declarations from AST to CoreFn representation.----declToCoreFn :: Environment -> Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]-declToCoreFn _ ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =-  [NonRec (properToIdent ctor) $-    Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]-declToCoreFn _ _ _ d@(A.DataDeclaration Newtype _ _ _) =-  error $ "Found newtype with multiple constructors: " ++ show d-declToCoreFn _ ss com (A.DataDeclaration Data tyName _ ctors) =-  flip map ctors $ \(ctor, tys) ->-    NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor (length tys)-declToCoreFn env ss _   (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn env ss []) ds-declToCoreFn env ss com (A.ValueDeclaration name _ _ (Right e)) =-  [NonRec name (exprToCoreFn env ss com Nothing e)]-declToCoreFn env ss _   (A.BindingGroupDeclaration ds) =-  [Rec $ map (\(name, _, e) -> (name, exprToCoreFn env ss [] Nothing e)) ds]-declToCoreFn _   ss com (A.TypeClassDeclaration name _ supers members) =-  [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members]-declToCoreFn env _  com (A.PositionedDeclaration ss com1 d) =-  declToCoreFn env (Just ss) (com ++ com1) d-declToCoreFn _ _ _ _ = []---- | -- Makes a typeclass dictionary constructor function. The returned expression -- is a function that accepts the superclass instances and member -- implementations and returns a record for the instance dictionary.@@ -132,116 +243,7 @@          (foldr (Abs nullAnn . Ident) dict as)  -- |--- Desugars expressions from AST to CoreFn representation.----exprToCoreFn :: Environment -> Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann-exprToCoreFn _ ss com ty (A.NumericLiteral v) =-  Literal (ss, com, ty, Nothing) (NumericLiteral v)-exprToCoreFn _ ss com ty (A.StringLiteral v) =-  Literal (ss, com, ty, Nothing) (StringLiteral v)-exprToCoreFn _ ss com ty (A.BooleanLiteral v) =-  Literal (ss, com, ty, Nothing) (BooleanLiteral v)-exprToCoreFn env ss com ty (A.ArrayLiteral vs) =-  Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn env ss [] Nothing) vs)-exprToCoreFn env ss com ty (A.ObjectLiteral vs) =-  Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn env ss [] Nothing)) vs)-exprToCoreFn env ss com ty (A.Accessor name v) =-  Accessor (ss, com, ty, Nothing) name (exprToCoreFn env ss [] Nothing v)-exprToCoreFn env ss com ty (A.ObjectUpdate obj vs) =-  ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn env ss [] Nothing obj) $ map (second (exprToCoreFn env ss [] Nothing)) vs-exprToCoreFn env ss com ty (A.Abs (Left name) v) =-  Abs (ss, com, ty, Nothing) name (exprToCoreFn env ss [] Nothing v)-exprToCoreFn _ _ _ _ (A.Abs _ _) =-  error "Abs with Binder argument was not desugared before exprToCoreFn"-exprToCoreFn env ss com ty (A.App v1 v2) =-  App (ss, com, ty, Nothing) (exprToCoreFn env ss [] Nothing v1) (exprToCoreFn env ss [] Nothing v2)-exprToCoreFn _ ss com ty (A.Var ident) =-  Var (ss, com, ty, Nothing) ident-exprToCoreFn env ss com ty (A.IfThenElse v1 v2 v3) =-  Case (ss, com, ty, Nothing) [exprToCoreFn env ss [] Nothing v1]-    [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]-                      (Right $ exprToCoreFn env Nothing [] Nothing v2)-    , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False]-                      (Right $ exprToCoreFn env Nothing [] Nothing v3) ]-exprToCoreFn env ss com ty (A.Constructor name) =-  Var (ss, com, ty, Just $ getConstructorMeta env name) $ fmap properToIdent name-exprToCoreFn env ss com ty (A.Case vs alts) =-  Case (ss, com, ty, Nothing) (map (exprToCoreFn env ss [] Nothing) vs) (map (altToCoreFn env ss) alts)-exprToCoreFn env ss com _ (A.TypedValue _ v ty) =-  exprToCoreFn env ss com (Just ty) v-exprToCoreFn env ss com ty (A.Let ds v) =-  Let (ss, com, ty, Nothing) (concatMap (declToCoreFn env ss []) ds) (exprToCoreFn env ss [] Nothing v)-exprToCoreFn env ss com _  (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) =-  let args = map (exprToCoreFn env ss [] Nothing . snd) $ sortBy (compare `on` fst) vs-      ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)-  in foldl (App (ss, com, Nothing, Nothing)) ctor args-exprToCoreFn env _ com ty (A.PositionedValue ss com1 v) =-  exprToCoreFn env (Just ss) (com ++ com1) ty v-exprToCoreFn _ _ _ _ e =-  error $ "Unexpected value in exprToCoreFn: " ++ show e---- |--- Desugars case alternatives from AST to CoreFn representation.----altToCoreFn :: Environment -> Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann-altToCoreFn env ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn env ss []) bs) (go vs)-  where-  go :: Either [(A.Guard, A.Expr)] A.Expr -> Either [(Guard Ann, Expr Ann)] (Expr Ann)-  go (Left ges) = Left $ map (exprToCoreFn env ss [] Nothing *** exprToCoreFn env ss [] Nothing) ges-  go (Right e) = Right (exprToCoreFn env ss [] Nothing e)---- |--- Desugars case binders from AST to CoreFn representation.----binderToCoreFn :: Environment -> Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann-binderToCoreFn _ ss com (A.NullBinder) =-  NullBinder (ss, com, Nothing, Nothing)-binderToCoreFn _ ss com (A.BooleanBinder b) =-  LiteralBinder (ss, com, Nothing, Nothing) (BooleanLiteral b)-binderToCoreFn _ ss com (A.StringBinder s) =-  LiteralBinder (ss, com, Nothing, Nothing) (StringLiteral s)-binderToCoreFn _ ss com (A.NumberBinder n) =-  LiteralBinder (ss, com, Nothing, Nothing) (NumericLiteral n)-binderToCoreFn _ ss com (A.VarBinder name) =-  VarBinder (ss, com, Nothing, Nothing) name-binderToCoreFn env ss com (A.ConstructorBinder dctor@(Qualified mn _) bs) =-  let (_, tctor, _) = lookupConstructor env dctor-  in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta env dctor) (Qualified mn tctor) dctor (map (binderToCoreFn env ss []) bs)-binderToCoreFn env ss com (A.ObjectBinder bs) =-  LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn env ss [])) bs)-binderToCoreFn env ss com (A.ArrayBinder bs) =-  LiteralBinder (ss, com, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn env ss []) bs)-binderToCoreFn env ss com (A.ConsBinder b1 b2) =-  let arrCtor = Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")-  in ConstructorBinder (ss, com, Nothing, Nothing) arrCtor arrCtor $ map (binderToCoreFn env ss []) [b1, b2]-binderToCoreFn env ss com (A.NamedBinder name b) =-  NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn env ss [] b)-binderToCoreFn env _ com (A.PositionedBinder ss com1 b) =-  binderToCoreFn env (Just ss) (com ++ com1) b---- | -- Converts a ProperName to an Ident. -- properToIdent :: ProperName -> Ident properToIdent = Ident . runProperName---- |--- Gets metadata for data constructors.----getConstructorMeta :: Environment -> Qualified ProperName -> Meta-getConstructorMeta env ctor =-  case lookupConstructor env ctor of-    (Newtype, _, _) -> IsNewtype-    dc@(Data, _, ty) ->-      let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType-      in IsConstructor constructorType (getArity ty)-  where-  getArity :: Type -> Int-  getArity (TypeApp (TypeApp f _) t) | f == tyFunction = getArity t + 1-  getArity (ForAll _ ty _) = getArity ty-  getArity _ = 0-  numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> Int-  numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env-  typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> (ModuleName, ProperName)-  typeConstructor (Qualified (Just mn) _, (_, tyCtor, _)) = (mn, tyCtor)-  typeConstructor _ = error "Invalid argument to typeConstructor"

@@ -13,14 +13,16 @@ -----------------------------------------------------------------------------  {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}  module Language.PureScript.CoreFn.Expr where +import Control.Arrow ((***))+ import qualified Data.Data as D  import Language.PureScript.CoreFn.Binders import Language.PureScript.CoreFn.Literals-import Language.PureScript.CoreFn.Meta import Language.PureScript.Names  -- |@@ -32,9 +34,9 @@   --   = Literal a (Literal (Expr a))   -- |-  -- A data constructor (type name, constructor name, arity)+  -- A data constructor (type name, constructor name, field names)   ---  | Constructor a ProperName ProperName Arity+  | Constructor a ProperName ProperName [Ident]   -- |   -- A record property accessor   --@@ -62,7 +64,7 @@   -- |   -- A let binding   ---  | Let a [Bind a] (Expr a) deriving (Show, D.Data, D.Typeable)+  | Let a [Bind a] (Expr a) deriving (Show, D.Data, D.Typeable, Functor)  -- | -- A let or module binding.@@ -75,7 +77,7 @@   -- |   -- Mutually recursive binding group for several values   ---  | Rec [(Ident, Expr a)] deriving (Show, D.Data, D.Typeable)+  | Rec [(Ident, Expr a)] deriving (Show, D.Data, D.Typeable, Functor)  -- | -- A guard is just a boolean-valued expression that appears alongside a set of binders@@ -96,6 +98,12 @@   , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)   } deriving (Show, D.Data, D.Typeable) +instance Functor CaseAlternative where++  fmap f (CaseAlternative cabs car) = CaseAlternative+    (fmap (fmap f) $ cabs)+    (either (Left . fmap (fmap f *** fmap f)) (Right . fmap f) car)+ -- | -- Extract the annotation from a term --@@ -109,6 +117,7 @@ extractAnn (Var a _) = a extractAnn (Case a _ _) = a extractAnn (Let a _ _) = a+  -- | -- Modify the annotation on a term

@@ -13,6 +13,7 @@ -----------------------------------------------------------------------------  {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}  module Language.PureScript.CoreFn.Literals where @@ -42,4 +43,4 @@   -- |   -- An object literal   ---  | ObjectLiteral [(String, a)] deriving (Show, D.Data, D.Typeable)+  | ObjectLiteral [(String, a)] deriving (Show, D.Data, D.Typeable, Functor)

@@ -18,6 +18,8 @@  import qualified Data.Data as D +import Language.PureScript.Names+ -- | -- Metadata annotations --@@ -25,7 +27,7 @@   -- |   -- The contained value is a data constructor   ---  = IsConstructor ConstructorType Arity+  = IsConstructor ConstructorType [Ident]   -- |   -- The contained value is a newtype   --@@ -34,11 +36,6 @@   -- The contained value is a typeclass dictionary constructor   --   | IsTypeClassConstructor deriving (Show, D.Data, D.Typeable)---- |--- Type alias for constructor arity----type Arity = Int  -- | -- Data constructor metadata

@@ -41,7 +41,7 @@   -- |   -- Data constructors currently in scope, along with their associated data type constructors   ---  , dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type)+  , dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])   -- |   -- Type synonyms currently in scope   --@@ -228,7 +228,7 @@ -- | -- Finds information about data constructors from the current environment. ---lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type)+lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident]) lookupConstructor env ctor =   fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors env @@ -237,5 +237,5 @@ -- isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool isNewtypeConstructor e ctor = case lookupConstructor e ctor of-  (Newtype, _, _) -> True-  (Data, _, _) -> False+  (Newtype, _, _, _) -> True+  (Data, _, _, _) -> False

@@ -17,10 +17,11 @@ module Language.PureScript.Errors where  import Data.Either (lefts, rights)+import Data.String (IsString(..)) import Data.List (intersperse, intercalate) import Data.Monoid -import Control.Monad.Error+import Control.Monad.Except import Control.Applicative ((<$>))  import Language.PureScript.AST@@ -67,15 +68,14 @@   = ErrorStack { runErrorStack :: [CompileError] }   | MultipleErrors [ErrorStack] deriving (Show) -instance Monoid ErrorStack where-  mempty = ErrorStack []-  mappend (ErrorStack xs) (ErrorStack ys) = ErrorStack (xs ++ ys)-  mappend (MultipleErrors es) x = MultipleErrors [ e <> x | e <- es ]-  mappend x (MultipleErrors es) = MultipleErrors [ x <> e | e <- es ]+-- TODO: Remove strMsg, the IsString instance, and unnecessary+-- OverloadedStrings pragmas. See #745+-- | Create an ErrorStack from a string+strMsg :: String -> ErrorStack+strMsg s = ErrorStack [CompileError s Nothing Nothing] -instance Error ErrorStack where-  strMsg s = ErrorStack [CompileError s Nothing Nothing]-  noMsg = ErrorStack []+instance IsString ErrorStack where+  fromString = strMsg  prettyPrintErrorStack :: Bool -> ErrorStack -> String prettyPrintErrorStack printFullStack (ErrorStack es) =@@ -95,8 +95,8 @@ prettyPrintErrorStack printFullStack (MultipleErrors es) =   unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintErrorStack printFullStack) es -stringifyErrorStack :: Bool -> Either ErrorStack a -> Either String a-stringifyErrorStack printFullStack = either (Left . prettyPrintErrorStack printFullStack) Right+stringifyErrorStack :: (MonadError String m) => Bool -> Either ErrorStack a -> m a+stringifyErrorStack printFullStack = either (throwError . prettyPrintErrorStack printFullStack) return  isErrorNonEmpty :: CompileError -> Bool isErrorNonEmpty = not . null . compileErrorMessage@@ -107,11 +107,14 @@ 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]+mkErrorStack msg t = ErrorStack [mkCompileError msg t] -positionError :: SourceSpan -> ErrorStack-positionError pos = ErrorStack [CompileError "" Nothing (Just pos)]+mkCompileError :: String -> Maybe ErrorSource -> CompileError+mkCompileError msg t = CompileError msg t Nothing +positionError :: SourceSpan -> CompileError+positionError pos = CompileError "" Nothing (Just pos)+ -- | -- Rethrow an error with a more detailed error message in the case of failure --@@ -122,7 +125,7 @@ -- Rethrow an error with source position information -- rethrowWithPosition :: (MonadError ErrorStack m) => SourceSpan -> m a -> m a-rethrowWithPosition pos = rethrow (positionError pos <>)+rethrowWithPosition pos = rethrow (positionError pos `combineErrors`)  -- | -- Collect errors in in parallel@@ -138,3 +141,13 @@     [err] -> throwError err     [] -> return $ rights es     errs -> throwError $ MultipleErrors errs+ +-- |+-- Add an extra error string onto the top of each error stack in a list of possibly many errors+--+combineErrors :: CompileError -> ErrorStack -> ErrorStack+combineErrors ce err = go (ErrorStack [ce]) err+  where +  go (ErrorStack xs) (ErrorStack ys) = ErrorStack (xs ++ ys)+  go (MultipleErrors es) x = MultipleErrors [ go e x | e <- es ]+  go x (MultipleErrors es) = MultipleErrors [ go x e | e <- es ]

@@ -12,11 +12,15 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts #-}+ module Language.PureScript.ModuleDependencies (   sortModules,   ModuleGraph ) where +import Control.Monad.Except+ import Data.Graph import Data.List (nub) import Data.Maybe (mapMaybe)@@ -35,7 +39,7 @@ -- -- Reports an error if the module graph contains a cycle. ---sortModules :: [Module] -> Either String ([Module], ModuleGraph)+sortModules :: (MonadError String m) => [Module] -> m ([Module], ModuleGraph) sortModules ms = do   let verts = map (\m@(Module _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms   ms' <- mapM toModule $ stronglyConnComp verts@@ -66,7 +70,7 @@ -- | -- Convert a strongly connected component of the module graph to a module ---toModule :: SCC Module -> Either String Module+toModule :: (MonadError String m) => SCC Module -> m Module toModule (AcyclicSCC m) = return m toModule (CyclicSCC [m]) = return m-toModule (CyclicSCC ms) = Left $ "Cycle in module dependencies: " ++ show (map getModuleName ms)+toModule (CyclicSCC ms) = throwError $ "Cycle in module dependencies: " ++ show (map getModuleName ms)

@@ -70,6 +70,9 @@     --   , optionsVerboseErrors :: Bool     -- |+    -- Remove the comments from the generated js+  , optionsNoComments :: Bool+    -- |     -- Specify the namespace that PureScript modules will be exported to when running in the     -- browser.     --@@ -80,10 +83,10 @@ -- Default compiler options -- defaultCompileOptions :: Options Compile-defaultCompileOptions = Options False False False Nothing False False (CompileOptions "PS" [] [])+defaultCompileOptions = Options False False False Nothing False False False (CompileOptions "PS" [] [])  -- | -- Default make options -- defaultMakeOptions :: Options Make-defaultMakeOptions = Options False False False Nothing False False MakeOptions+defaultMakeOptions = Options False False False Nothing False False False MakeOptions

@@ -24,7 +24,6 @@ import Data.Graph import Data.List (nub, intersect) import Data.Maybe (isJust, mapMaybe)-import Data.Monoid ((<>)) import Control.Applicative ((<$>), (<*>), pure) import Control.Monad ((<=<)) @@ -181,7 +180,7 @@   cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds   cycleError (ValueDeclaration n _ _ (Right e)) [] = Left $     mkErrorStack ("Cycle in definition of " ++ show n) (Just (ExprError e))-  cycleError d ds@(_:_) = rethrow (<> mkErrorStack ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing) $ cycleError d []+  cycleError d ds@(_:_) = rethrow (mkCompileError ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing `combineErrors`) $ cycleError d []   cycleError _ _ = error "Expected ValueDeclaration"  toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration

@@ -19,12 +19,11 @@     desugarCasesModule ) where -import Data.Monoid ((<>)) import Data.List (nub, groupBy)  import Control.Applicative import Control.Monad ((<=<), forM, join, unless, replicateM)-import Control.Monad.Error.Class+import Control.Monad.Except (throwError)  import Language.PureScript.Names import Language.PureScript.AST@@ -44,7 +43,7 @@ -- desugarCasesModule :: [Module] -> SupplyT (Either ErrorStack) [Module] desugarCasesModule ms = forM ms $ \(Module name ds exps) ->-  rethrow (strMsg ("Error in module " ++ show name) <>) $+  rethrow (mkCompileError ("Error in module " ++ show name) Nothing `combineErrors`) $     Module name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps  desugarAbs :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]

@@ -18,10 +18,9 @@  import Data.List (nub) import Data.Maybe (fromMaybe, isJust, mapMaybe)-import Data.Monoid ((<>))  import Control.Applicative (Applicative(..), (<$>), (<*>))-import Control.Monad.Error+import Control.Monad.Except  import qualified Data.Map as M @@ -166,7 +165,7 @@   -- the module has access to an unfiltered list of its own members.   renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module   renameInModule' unfilteredExports exports m@(Module mn _ _) =-    rethrow (strMsg ("Error in module " ++ show mn) <>) $ do+    rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ 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@@ -233,7 +232,8 @@   updateValue (pos, bound) (Let ds val') = do       let args = mapMaybe letBoundVariable ds       unless (length (nub args) == length args) $-        throwError $ maybe id (\p e -> positionError p <> e) pos $ mkErrorStack ("Overlapping names in let binding.") Nothing+        maybe id rethrowWithPosition pos $ +          throwError $ mkErrorStack ("Overlapping names in let binding.") Nothing       return ((pos, args ++ bound), Let ds val')       where   updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =@@ -318,7 +318,7 @@   addModule :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment   addModule env (Module mn ds _) = do     env' <- addEmptyModule env mn-    rethrow (strMsg ("Error in module " ++ show mn) <>) $ foldM (addDecl mn) env' ds+    rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ foldM (addDecl mn) env' ds    -- Add a declaration from a module to the global export environment   addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either ErrorStack ExportEnvironment@@ -344,7 +344,7 @@ filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either ErrorStack ExportEnvironment filterExports mn exps env = do   let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)-  moduleExports' <- rethrow (strMsg ("Error in module " ++ show mn) <>) $ filterModule moduleExports+  moduleExports' <- rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ filterModule moduleExports   return $ M.insert mn moduleExports' env   where 

@@ -32,9 +32,8 @@  import Control.Applicative import Control.Monad.State-import Control.Monad.Error.Class+import Control.Monad.Except -import Data.Monoid ((<>)) import Data.Function (on) import Data.Functor.Identity import Data.List (groupBy, sortBy)@@ -90,7 +89,7 @@   go [] = return ()   go [_] = return ()   go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y =-    rethrow (strMsg ("Error in module " ++ show mn) <>) $+    rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $       rethrowWithPosition pos $         throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing   go (_ : rest) = go rest

@@ -21,23 +21,22 @@   ) where  import Language.PureScript.AST hiding (isExported)-import Language.PureScript.Names-import Language.PureScript.Types-import Language.PureScript.Kinds-import Language.PureScript.Sugar.CaseDeclarations import Language.PureScript.Environment import Language.PureScript.Errors-import Language.PureScript.Supply+import Language.PureScript.Kinds+import Language.PureScript.Names import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)+import Language.PureScript.Sugar.CaseDeclarations+import Language.PureScript.Supply+import Language.PureScript.Types  import qualified Language.PureScript.Constants as C  import Control.Applicative-import Control.Monad.Error-import Control.Monad.State import Control.Arrow (first, second)+import Control.Monad.Except+import Control.Monad.State import Data.List ((\\), find)-import Data.Monoid ((<>)) import Data.Maybe (catMaybes, mapMaybe, isJust)  import qualified Data.Map as M@@ -158,12 +157,12 @@   where   go d@(TypeClassDeclaration name args implies members) = do     modify (M.insert (mn, name) d)-    return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)+    return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)   go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d])   go d@(TypeInstanceDeclaration name deps className tys members) = do     desugared <- lift $ desugarCases members     dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared-    return $ (expRef name className tys, [d, dictDecl])+    return (expRef name className tys, [d, dictDecl])   go (PositionedDeclaration pos com d) = do     (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d     return (dr, map (PositionedDeclaration pos com) ds)@@ -212,9 +211,10 @@  typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =-  ValueDeclaration ident TypeClassAccessorImport [] $ Right $-    TypedValue False (Abs (Left $ Ident "dict") (Accessor (runIdent ident) (Var $ Qualified Nothing (Ident "dict")))) $-    moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map (TypeVar . fst) args)] ty))+  let className = Qualified (Just mn) name+  in ValueDeclaration ident TypeClassAccessorImport [] $ Right $+      TypedValue False (TypeClassDictionaryAccessor className ident) $+      moveQuantifiersToFront (quantify (ConstrainedType [(className, map (TypeVar . fst) args)] ty)) typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) =   PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"@@ -224,7 +224,7 @@  typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration typeInstanceDictionaryDeclaration name mn deps className tys decls =-  rethrow (strMsg ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") <>) $ do+  rethrow (mkCompileError ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") Nothing `combineErrors`) $ do   m <- get    -- Lookup the type arguments and member types for the type class

@@ -19,11 +19,9 @@     desugarTypeDeclarationsModule ) where -import Data.Monoid ((<>))- import Control.Applicative-import Control.Monad.Error.Class import Control.Monad (forM)+import Control.Monad.Except (throwError)  import Language.PureScript.AST import Language.PureScript.Names@@ -36,7 +34,7 @@ -- desugarTypeDeclarationsModule :: [Module] -> Either ErrorStack [Module] desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) ->-  rethrow (strMsg ("Error in module " ++ show name) <>) $+  rethrow (mkCompileError ("Error in module " ++ show name) Nothing `combineErrors`) $     Module name <$> desugarTypeDeclarations ds <*> pure exps  -- |

@@ -24,7 +24,7 @@  import Control.Applicative import Control.Monad.State-import Control.Monad.Error.Class+import Control.Monad.Except  newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } deriving (Functor, Applicative, Monad, MonadTrans) 

@@ -27,12 +27,11 @@  import Data.Maybe import Data.List (nub, (\\), find, intercalate)-import Data.Monoid ((<>)) import Data.Foldable (for_) import qualified Data.Map as M  import Control.Monad.State-import Control.Monad.Error+import Control.Monad.Except  import Language.PureScript.Types import Language.PureScript.Names@@ -47,7 +46,7 @@   env <- getEnv   putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }   forM_ dctors $ \(dctor, tys) ->-    rethrow (strMsg ("Error in data constructor " ++ show dctor) <>) $+    rethrow (mkCompileError ("Error in data constructor " ++ show dctor) Nothing `combineErrors`) $       addDataConstructor moduleName dtype name (map fst args) dctor tys  addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()@@ -57,7 +56,8 @@   let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)   let dctorTy = foldr function retTy tys   let polyType = mkForAll args dctorTy-  putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType) (dataConstructors env) }+  let fields = [Ident ("value" ++ show n) | n <- [0..(length tys - 1)]]+  putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }  addTypeSynonym :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Type -> Kind -> Check () addTypeSynonym moduleName name args ty kind = do@@ -133,7 +133,7 @@   go :: [Declaration] -> Check [Declaration]   go [] = return []   go (DataDeclaration dtype name args dctors : rest) = do-    rethrow (strMsg ("Error in type constructor " ++ show name) <>) $ do+    rethrow (mkCompileError ("Error in type constructor " ++ show name) Nothing `combineErrors`) $ do       when (dtype == Newtype) $ checkNewtype dctors       checkDuplicateTypeArguments $ map fst args       ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)@@ -147,7 +147,7 @@     checkNewtype [(_, _)] = throwError . strMsg $ "newtypes constructors must have a single argument"     checkNewtype _ = throwError . strMsg $ "newtypes must have a single constructor"   go (d@(DataBindingGroupDeclaration tys) : rest) = do-    rethrow (strMsg "Error in data binding group" <>) $ do+    rethrow (mkCompileError "Error in data binding group" Nothing `combineErrors`) $ 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)@@ -169,7 +169,7 @@     toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'     toDataDecl _ = Nothing   go (TypeSynonymDeclaration name args ty : rest) = do-    rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do+    rethrow (mkCompileError ("Error in type synonym " ++ show name) Nothing `combineErrors`) $ do       checkDuplicateTypeArguments $ map fst args       kind <- kindsOf False moduleName name args [ty]       let args' = args `withKinds` kind@@ -178,7 +178,7 @@     return $ TypeSynonymDeclaration name args ty : ds   go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"   go (ValueDeclaration name nameKind [] (Right val) : rest) = do-    d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do+    d <- rethrow (mkCompileError ("Error in declaration " ++ show name) Nothing `combineErrors`) $ do       valueIsNotDefined moduleName name       [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]       addValue moduleName name ty nameKind@@ -187,7 +187,7 @@     return $ d : ds   go (ValueDeclaration{} : _) = error "Binders were not desugared"   go (BindingGroupDeclaration vals : rest) = do-    d <- rethrow (strMsg ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) <>) $ do+    d <- rethrow (mkCompileError ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) Nothing `combineErrors`) $ do       forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->         valueIsNotDefined moduleName name       tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals@@ -207,7 +207,7 @@     ds <- go rest     return $ d : ds   go (d@(ExternDeclaration importTy name _ ty) : rest) = do-    rethrow (strMsg ("Error in foreign import declaration " ++ show name) <>) $ do+    rethrow (mkCompileError ("Error in foreign import declaration " ++ show name) Nothing `combineErrors`) $ do       env <- getEnv       kind <- kindOf moduleName ty       guardWith (strMsg "Expected kind *") $ kind == Star

@@ -25,9 +25,10 @@  import Control.Applicative import Control.Arrow (Arrow(..))-import Control.Monad.Error+import Control.Monad.Except  import Language.PureScript.AST+import Language.PureScript.Errors import Language.PureScript.Environment import Language.PureScript.Names import Language.PureScript.Pretty

@@ -24,14 +24,13 @@ ) where  import Data.Maybe (fromMaybe)-import Data.Monoid ((<>))  import qualified Data.HashMap.Strict as H import qualified Data.Map as M  import Control.Arrow (second) import Control.Applicative-import Control.Monad.Error+import Control.Monad.Except import Control.Monad.State import Control.Monad.Unify @@ -79,7 +78,7 @@ -- kindOfWithScopedVars :: Type -> Check (Kind, [(String, Kind)])    kindOfWithScopedVars ty = -  rethrow (mkErrorStack "Error checking kind" (Just (TypeError ty)) <>) $+  rethrow (mkCompileError "Error checking kind" (Just (TypeError ty)) `combineErrors`) $     fmap tidyUp . liftUnify $ infer ty   where   tidyUp ((k, args), sub) = ( starIfUnknown (sub $? k)@@ -157,7 +156,7 @@ -- Infer a kind for a type -- infer :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])-infer ty = rethrow (mkErrorStack "Error inferring type of value" (Just (TypeError ty)) <>) $ infer' ty+infer ty = rethrow (mkCompileError "Error inferring type of value" (Just (TypeError ty)) `combineErrors`) $ infer' ty  infer' :: Type -> UnifyT Kind Check (Kind, [(String, Kind)]) infer' (ForAll ident ty _) = do

@@ -14,7 +14,7 @@ -----------------------------------------------------------------------------  {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, RankNTypes,-    MultiParamTypeClasses, FlexibleContexts #-}+    MultiParamTypeClasses, FlexibleContexts, GADTs #-}  module Language.PureScript.TypeChecker.Monad where @@ -22,7 +22,8 @@ import qualified Data.Map as M  import Control.Applicative-import Control.Monad.Error+import Control.Monad.Except+import Control.Monad.Reader.Class import Control.Monad.State import Control.Monad.Unify @@ -108,7 +109,7 @@ -- | -- Lookup the type of a value by name in the @Environment@ ---lookupVariable :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type+lookupVariable :: (e ~ ErrorStack, 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@@ -118,7 +119,7 @@ -- | -- Lookup the visibility of a value by name in the @Environment@ ---getVisibility :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility+getVisibility :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility getVisibility currentModule (Qualified moduleName var) = do   env <- getEnv   case M.lookup (fromMaybe currentModule moduleName, var) (names env) of@@ -128,7 +129,7 @@ -- | -- Assert that a name is visible ---checkVisibility :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()+checkVisibility :: (e ~ ErrorStack, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m () checkVisibility currentModule name@(Qualified _ var) = do   vis <- getVisibility currentModule name   case vis of@@ -138,7 +139,7 @@ -- | -- Lookup the kind of a type by name in the @Environment@ ---lookupTypeVariable :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind+lookupTypeVariable :: (e ~ ErrorStack, 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@@ -171,7 +172,7 @@ -- The type checking monad, which provides the state of the type checker, and error reporting capabilities -- newtype Check a = Check { unCheck :: StateT CheckState (Either ErrorStack) a }-  deriving (Functor, Monad, Applicative, Alternative, MonadPlus, MonadState CheckState, MonadError ErrorStack)+  deriving (Functor, Monad, Applicative, MonadState CheckState, MonadError ErrorStack)  -- | -- Get the current @Environment@@@ -194,14 +195,16 @@ -- | -- Run a computation in the Check monad, starting with an empty @Environment@ ---runCheck :: Options mode -> Check a -> Either String (a, Environment)-runCheck opts = runCheck' opts initEnvironment+runCheck :: (MonadReader (Options mode) m, MonadError String m) => Check a -> m (a, Environment)+runCheck = runCheck' initEnvironment  -- | -- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@. ---runCheck' :: Options mode -> Environment -> Check a -> Either String (a, Environment)-runCheck' opts env c = stringifyErrorStack (optionsVerboseErrors opts) $ do+runCheck' :: (MonadReader (Options mode) m, MonadError String m) => Environment -> Check a -> m (a, Environment)+runCheck' env c = do+  verbose <- asks optionsVerboseErrors+  stringifyErrorStack verbose $ do   (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c   return (a, checkEnv s) 

@@ -19,7 +19,7 @@  import Data.List -import Control.Monad.Error+import Control.Monad.Except  import Language.PureScript.AST import Language.PureScript.Errors

@@ -26,7 +26,7 @@ import Data.Monoid  import Control.Applicative-import Control.Monad.Error+import Control.Monad.Except import Control.Monad.Unify  import Language.PureScript.AST

@@ -18,11 +18,10 @@ ) where  import Data.List (sortBy)-import Data.Monoid import Data.Ord (comparing)  import Control.Applicative-import Control.Monad.Error+import Control.Monad.Except import Control.Monad.Unify  import Language.PureScript.AST@@ -39,7 +38,7 @@ -- Check whether one type subsumes another, rethrowing errors to provide a better error message -- subsumes :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)-subsumes val ty1 ty2 = rethrow (mkErrorStack errorMessage (ExprError <$> val) <>) $ subsumes' val ty1 ty2+subsumes val ty1 ty2 = rethrow (mkCompileError errorMessage (ExprError <$> val) `combineErrors`) $ subsumes' val ty1 ty2   where   errorMessage = "Error checking that type "     ++ prettyPrintType ty1

@@ -13,7 +13,7 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, GADTs #-}  module Language.PureScript.TypeChecker.Synonyms (     saturateAllTypeSynonyms,@@ -28,10 +28,11 @@ import qualified Data.Map as M  import Control.Applicative-import Control.Monad.Error+import Control.Monad.Except import Control.Monad.State  import Language.PureScript.Environment+import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.TypeChecker.Monad import Language.PureScript.Types@@ -82,7 +83,7 @@   in     saturateAllTypeSynonyms syns d -replaceAllTypeSynonyms :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type+replaceAllTypeSynonyms :: (e ~ ErrorStack, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type replaceAllTypeSynonyms d = do   env <- getEnv   either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d@@ -98,12 +99,12 @@       replaceAllTypeSynonyms' env repl     Nothing -> error "Type synonym was not defined" -expandTypeSynonym :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type+expandTypeSynonym :: (e ~ ErrorStack, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type expandTypeSynonym name args = do   env <- getEnv   either (throwError . strMsg) return $ expandTypeSynonym' env name args -expandAllTypeSynonyms :: (Error e, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type+expandAllTypeSynonyms :: (e ~ ErrorStack, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type expandAllTypeSynonyms = everywhereOnTypesTopDownM go   where   go (SaturatedTypeSynonym name args) = expandTypeSynonym name args

@@ -13,7 +13,7 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, OverloadedStrings #-}  module Language.PureScript.TypeChecker.Types (     typesOf@@ -38,11 +38,11 @@ import Data.Either (lefts, rights) import Data.List import Data.Maybe (fromMaybe)-import Data.Monoid import qualified Data.Map as M+import Data.String (IsString)  import Control.Applicative-import Control.Monad.Error+import Control.Monad.Except import Control.Monad.State import Control.Monad.Unify @@ -207,7 +207,7 @@ -- Infer a type for a value, rethrowing any error to provide a more useful error message -- infer :: Expr -> UnifyT Type Check Expr-infer val = rethrow (mkErrorStack "Error inferring type of value" (Just (ExprError val)) <>) $ infer' val+infer val = rethrow (mkCompileError "Error inferring type of value" (Just (ExprError val)) `combineErrors`) $ infer' val  -- | -- Infer a type for a value@@ -270,8 +270,8 @@   env <- getEnv   case M.lookup c (dataConstructors env) of     Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"-    Just (_, _, ty) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty-                          return $ TypedValue True v' ty'+    Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty+                             return $ TypedValue True v' ty' infer' (Case vals binders) = do   ts <- mapM infer vals   ret <- fresh@@ -355,7 +355,7 @@ inferBinder val (ConstructorBinder ctor binders) = do   env <- getEnv   case M.lookup ctor (dataConstructors env) of-    Just (_, _, ty) -> do+    Just (_, _, ty, _) -> do       (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contain constraints") ty       fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn       go binders fn'@@ -427,7 +427,7 @@ -- Check the type of a value, rethrowing errors to provide a better error message -- check :: Expr -> Type -> UnifyT Type Check Expr-check val ty = rethrow (mkErrorStack errorMessage (Just (ExprError val)) <>) $ check' val ty+check val ty = rethrow (mkCompileError errorMessage (Just (ExprError val)) `combineErrors`) $ check' val ty   where   errorMessage =     "Error checking type of term " ++@@ -552,7 +552,7 @@   env <- getEnv   case M.lookup c (dataConstructors env) of     Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"-    Just (_, _, ty1) -> do+    Just (_, _, ty1, _) -> do       repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1       _ <- subsumes Nothing repl ty       return $ TypedValue True (Constructor c) ty@@ -583,7 +583,7 @@ checkProperties :: [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)] checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where   go [] [] REmpty = return []-  go [] [] u@(TUnknown _) +  go [] [] u@(TUnknown _)     | lax = return []     | otherwise = do u =?= REmpty                      return []@@ -609,7 +609,7 @@ -- Check the type of a function application, rethrowing errors to provide a better error message -- checkFunctionApplication :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr)-checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (Just (ExprError fn)) <>) $ do+checkFunctionApplication fn fnTy arg ret = rethrow (mkCompileError errorMessage (Just (ExprError fn)) `combineErrors`) $ do   subst <- unifyCurrentSubstitution <$> UnifyT get   checkFunctionApplication' fn (subst $? fnTy) arg (($?) subst <$> ret)   where@@ -673,5 +673,5 @@ -- | -- Ensure a set of property names and value does not contain duplicate labels ---ensureNoDuplicateProperties :: (Error e, MonadError e m) => [(String, Expr)] -> m ()-ensureNoDuplicateProperties ps = guardWith (strMsg "Duplicate property names") $ length (nub . map fst $ ps) == length ps+ensureNoDuplicateProperties :: (IsString e, MonadError e m) => [(String, Expr)] -> m ()+ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps

@@ -27,10 +27,9 @@  import Data.List (nub, sort) import Data.Maybe (fromMaybe)-import Data.Monoid import qualified Data.HashMap.Strict as H -import Control.Monad.Error+import Control.Monad.Except import Control.Monad.Unify  import Language.PureScript.Environment@@ -61,7 +60,7 @@ -- Unify two types, updating the current substitution -- unifyTypes :: Type -> Type -> UnifyT Type Check ()-unifyTypes t1 t2 = rethrow (mkErrorStack ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing <>) $+unifyTypes t1 t2 = rethrow (mkCompileError ("Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2) Nothing `combineErrors`) $   unifyTypes' t1 t2   where   unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()

@@ -22,6 +22,7 @@ import Data.Traversable (traverse) import Control.Monad import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)+import Control.Monad.Reader (runReaderT) import Control.Applicative import System.Exit import System.Process@@ -38,7 +39,7 @@ loadPrelude =   case P.parseModulesFromFiles id [("", P.prelude)] of     Left parseError -> Left (show parseError)-    Right ms -> P.compile (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) (map snd ms) []+    Right ms -> runReaderT (P.compile (map snd ms) []) $ P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }  compile :: P.Options P.Compile -> [FilePath] -> IO (Either String (String, String, P.Environment)) compile opts inputFiles = do@@ -46,7 +47,7 @@   case modules of     Left parseError ->       return (Left $ show parseError)-    Right ms -> return $ P.compile opts (map snd ms) []+    Right ms -> return $ runReaderT (P.compile (map snd ms) []) opts  assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO () assert preludeExterns opts inputFile f = do