summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2015-02-21 02:18:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-02-21 02:18:00 (GMT)
commitce534e93c9b8ca5318d48b274a455af79fe594ed (patch)
tree892a2d27a954cb1d6d0789d2c2e5e8c8094ebb61
parentfcb01e064d41495d0727163df01801d41e64908a (diff)
version 0.6.80.6.8
-rw-r--r--examples/passing/OneConstructor.purs2
-rw-r--r--examples/passing/Rank2Data.purs12
-rw-r--r--examples/passing/ShadowedTCO.purs10
-rw-r--r--prelude/prelude.purs80
-rw-r--r--psc-docs/Main.hs152
-rw-r--r--psc-make/Main.hs27
-rw-r--r--psc/Main.hs12
-rw-r--r--psci/Main.hs68
-rw-r--r--purescript.cabal19
-rw-r--r--src/Control/Monad/Unify.hs155
-rw-r--r--src/Language/PureScript.hs77
-rw-r--r--src/Language/PureScript/AST/Declarations.hs4
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs122
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer.hs48
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs46
-rw-r--r--src/Language/PureScript/Constants.hs15
-rw-r--r--src/Language/PureScript/CoreFn/Binders.hs3
-rw-r--r--src/Language/PureScript/CoreFn/Desugar.hs272
-rw-r--r--src/Language/PureScript/CoreFn/Expr.hs19
-rw-r--r--src/Language/PureScript/CoreFn/Literals.hs3
-rw-r--r--src/Language/PureScript/CoreFn/Meta.hs9
-rw-r--r--src/Language/PureScript/Environment.hs8
-rw-r--r--src/Language/PureScript/Errors.hs43
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs10
-rw-r--r--src/Language/PureScript/Options.hs7
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs3
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs5
-rw-r--r--src/Language/PureScript/Sugar/Names.hs12
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs5
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs28
-rw-r--r--src/Language/PureScript/Sugar/TypeDeclarations.hs6
-rw-r--r--src/Language/PureScript/Supply.hs2
-rw-r--r--src/Language/PureScript/TypeChecker.hs20
-rw-r--r--src/Language/PureScript/TypeChecker/Entailment.hs3
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs7
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs25
-rw-r--r--src/Language/PureScript/TypeChecker/Rows.hs2
-rw-r--r--src/Language/PureScript/TypeChecker/Skolems.hs2
-rw-r--r--src/Language/PureScript/TypeChecker/Subsumption.hs5
-rw-r--r--src/Language/PureScript/TypeChecker/Synonyms.hs11
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs26
-rw-r--r--src/Language/PureScript/TypeChecker/Unify.hs5
-rw-r--r--tests/Main.hs5
43 files changed, 820 insertions, 575 deletions
diff --git a/examples/passing/OneConstructor.purs b/examples/passing/OneConstructor.purs
index 914255a..e46cf6a 100644
--- a/examples/passing/OneConstructor.purs
+++ b/examples/passing/OneConstructor.purs
@@ -2,6 +2,6 @@ module Main where
data One a = One a
-one (One a) = a
+one' (One a) = a
main = Debug.Trace.trace "Done"
diff --git a/examples/passing/Rank2Data.purs b/examples/passing/Rank2Data.purs
index fb030b0..ccc60f5 100644
--- a/examples/passing/Rank2Data.purs
+++ b/examples/passing/Rank2Data.purs
@@ -12,18 +12,18 @@ module Main where
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'"
diff --git a/examples/passing/ShadowedTCO.purs b/examples/passing/ShadowedTCO.purs
index 6cc4ff9..05d6120 100644
--- a/examples/passing/ShadowedTCO.purs
+++ b/examples/passing/ShadowedTCO.purs
@@ -2,14 +2,14 @@ module Main where
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
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index 1ec9679..ceb99e0 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -13,8 +13,13 @@ module Prelude
, 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 @@ module Prelude
, 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,13 +210,32 @@ module Prelude
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
"""
@@ -258,20 +282,24 @@ module Prelude
}
""" :: 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 {}
diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs
index 6ca4ec5..41113f2 100644
--- a/psc-docs/Main.hs
+++ b/psc-docs/Main.hs
@@ -18,7 +18,6 @@ import Control.Applicative
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.Exit (exitSuccess, exitFailure)
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 @@ atIndent indent text =
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
-
-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
+ mapM_ renderModule ms
+
+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 @@ getDeclarationTitle _ = Nothing
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.TypeInstanceDeclaration name _ _ _ _) = show name
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
diff --git a/psc-make/Main.hs b/psc-make/Main.hs
index fcad3fb..2bf5ced 100644
--- a/psc-make/Main.hs
+++ b/psc-make/Main.hs
@@ -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 @@ readInput InputOptions{..} = do
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 @@ instance P.MonadMake Make where
mkdirp path
putStrLn $ "Writing " ++ path
writeFile path text
- liftError = either throwError return
progress = makeIO . putStrLn
compile :: PSCMakeOptions -> IO ()
@@ -82,7 +82,7 @@ compile (PSCMakeOptions input outputDir opts usePrefix) = do
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 @@ noOpts = switch $
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 @@ options = P.Options <$> noPrelude
<*> noMagicDo
<*> pure Nothing
<*> noOpts
+ <*> comments
<*> verboseErrors
<*> pure P.MakeOptions
diff --git a/psc/Main.hs b/psc/Main.hs
index df1db1f..25709a1 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -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 @@ compile (PSCOptions input opts stdin output externs usePrefix) = do
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 @@ noPrelude = switch $
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 @@ options = P.Options <$> noPrelude
<*> runMain
<*> noOpts
<*> verboseErrors
+ <*> comments
<*> additionalOptions
where
additionalOptions =
diff --git a/psci/Main.hs b/psci/Main.hs
index 73aa302..2b8bc82 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -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 qualified Data.Map as M
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 qualified Paths_purescript as Paths
import Commands as C
import Parser
-
data PSCiOptions = PSCiOptions
- { psciSingleLineFlag :: Bool
+ { psciMultiLineMode :: Bool
, psciInputFile :: [FilePath]
}
@@ -96,7 +99,7 @@ updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modu
-- 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 @@ loadAllImportedModules = do
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 @@ prologueMessage = intercalate "\n"
, " |_| "
, ""
, ":? shows help"
- , ""
- , "Expressions are terminated using Ctrl+D"
]
-- |
@@ -314,7 +315,7 @@ completion = completeWordWithPrev Nothing " \t\n\r" findCompletions
-- | 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 @@ options = P.Options False False False Nothing False False P.MakeOptions
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 :: P.Expr -> PSCI ()
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 @@ handleLet ds = do
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 :: P.ModuleName -> PSCI ()
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 :: P.Expr -> PSCI ()
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 :: P.ModuleName -> PSCI ()
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 @@ handleKindOf typ = do
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 @@ handleCommand (LoadFile filePath) = do
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 @@ loadUserConfig = do
-- 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 @@ inputFile = strArgument $
<> Opts.help "Optional .purs files to load on start"
psciOptions :: Parser PSCiOptions
-psciOptions = PSCiOptions <$> singleLineFlag
+psciOptions = PSCiOptions <$> multiLineMode
<*> many inputFile
main :: IO ()
diff --git a/purescript.cabal b/purescript.cabal
index e23d58d..223e9b3 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -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 @@ library
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 @@ library
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 @@ executable psc
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 @@ executable psc-make
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 @@ executable psci
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 @@ executable psc-docs
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 @@ executable psc-hierarchy
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,
diff --git a/src/Control/Monad/Unify.hs b/src/Control/Monad/Unify.hs
new file mode 100644
index 0000000..4fe55e9
--- /dev/null
+++ b/src/Control/Monad/Unify.hs
@@ -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
+
+
+
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 16f2189..a1a5ef7 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -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.Function (on)
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 @@ import qualified Language.PureScript.Constants as C
--
-- * 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 @@ class MonadMake m where
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 @@ traverseEither f (Right y) = Right <$> f y
-- 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 @@ make outputDir opts ms prefix = do
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 @@ make outputDir opts ms prefix = do
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 @@ make outputDir opts ms prefix = do
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 ]
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 9ed3f88..ef097e5 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -398,6 +398,10 @@ data Expr
--
| 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]
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index c5305e4..e677751 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -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 @@ import qualified Language.PureScript.Constants as C
-- 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 @@ moduleToJs opts (Module name imps exps foreigns decls) = do
-- |
-- 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 @@ bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp))
--
-- 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 @@ accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
-- |
-- 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 @@ valueToJs m (Accessor _ prop val) =
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 @@ valueToJs m e@App{} = do
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 @@ valueToJs _ (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =
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 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
-- 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 @@ bindersToJs m binders vals = do
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 @@ bindersToJs m binders vals = do
-- 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 @@ binderToJs _ varName done (VarBinder _ ident) =
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 @@ binderToJs m varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorT
(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 @@ binderToJs m varName done (NamedBinder _ ident binder) = do
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 @@ literalToBinderJS _ varName done (BooleanLiteral False) =
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 @@ literalToBinderJS m varName done (ArrayLiteral bs) = do
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
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs
index 551e179..3906cd5 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs
@@ -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 @@ import Language.PureScript.CodeGen.JS.Optimizer.Blocks
-- |
-- 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'
-
diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
index a4dc800..caf7017 100644
--- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs
@@ -15,6 +15,7 @@
module Language.PureScript.CodeGen.JS.Optimizer.Inliner (
inlineVariables,
+ inlineValues,
inlineOperator,
inlineCommonOperators,
etaConvert,
@@ -79,6 +80,15 @@ inlineVariables = everywhereOnJS $ removeFromBlock go
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 @@ inlineOperator (m, op) f = everywhereOnJS convert
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 @@ inlineCommonOperators = applyAll $
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 @@ inlineCommonOperators = applyAll $
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
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
index fb4952b..51ba984 100644
--- a/src/Language/PureScript/Constants.hs
+++ b/src/Language/PureScript/Constants.hs
@@ -105,6 +105,12 @@ not = "not"
-- Prelude Values
+zero :: String
+zero = "zero"
+
+one :: String
+one = "one"
+
return :: String
return = "return"
@@ -163,6 +169,15 @@ applicativeEffDictionary = "applicativeEff"
bindEffDictionary :: String
bindEffDictionary = "bindEff"
+semiringNumber :: String
+semiringNumber = "semiringNumber"
+
+ringNumber :: String
+ringNumber = "ringNumber"
+
+moduloSemiringNumber :: String
+moduloSemiringNumber = "moduloSemiringNumber"
+
numNumber :: String
numNumber = "numNumber"
diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs
index c88dceb..595f2cc 100644
--- a/src/Language/PureScript/CoreFn/Binders.hs
+++ b/src/Language/PureScript/CoreFn/Binders.hs
@@ -13,6 +13,7 @@
-----------------------------------------------------------------------------
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
module Language.PureScript.CoreFn.Binders where
@@ -44,4 +45,4 @@ data Binder a
-- |
-- 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)
diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index 35e6eec..cc5e16c 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -40,14 +40,148 @@ import qualified Language.PureScript.AST as A
-- 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
@@ -94,29 +228,6 @@ exportToCoreFn (A.PositionedDeclarationRef _ _ d) = exportToCoreFn d
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 @@ mkTypeClassConstructor ss com supers members =
(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"
diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs
index 02fa24d..67decc3 100644
--- a/src/Language/PureScript/CoreFn/Expr.hs
+++ b/src/Language/PureScript/CoreFn/Expr.hs
@@ -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 @@ data Expr a
--
= 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 @@ data Expr a
-- |
-- 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 @@ data Bind a
-- |
-- 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 @@ data CaseAlternative a = CaseAlternative
, 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
--
@@ -110,6 +118,7 @@ extractAnn (Var a _) = a
extractAnn (Case a _ _) = a
extractAnn (Let a _ _) = a
+
-- |
-- Modify the annotation on a term
--
diff --git a/src/Language/PureScript/CoreFn/Literals.hs b/src/Language/PureScript/CoreFn/Literals.hs
index 8e56d97..e610566 100644
--- a/src/Language/PureScript/CoreFn/Literals.hs
+++ b/src/Language/PureScript/CoreFn/Literals.hs
@@ -13,6 +13,7 @@
-----------------------------------------------------------------------------
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
module Language.PureScript.CoreFn.Literals where
@@ -42,4 +43,4 @@ data Literal a
-- |
-- An object literal
--
- | ObjectLiteral [(String, a)] deriving (Show, D.Data, D.Typeable)
+ | ObjectLiteral [(String, a)] deriving (Show, D.Data, D.Typeable, Functor)
diff --git a/src/Language/PureScript/CoreFn/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs
index 7c2199c..84859bc 100644
--- a/src/Language/PureScript/CoreFn/Meta.hs
+++ b/src/Language/PureScript/CoreFn/Meta.hs
@@ -18,6 +18,8 @@ module Language.PureScript.CoreFn.Meta where
import qualified Data.Data as D
+import Language.PureScript.Names
+
-- |
-- Metadata annotations
--
@@ -25,7 +27,7 @@ data Meta
-- |
-- The contained value is a data constructor
--
- = IsConstructor ConstructorType Arity
+ = IsConstructor ConstructorType [Ident]
-- |
-- The contained value is a newtype
--
@@ -36,11 +38,6 @@ data Meta
| IsTypeClassConstructor deriving (Show, D.Data, D.Typeable)
-- |
--- Type alias for constructor arity
---
-type Arity = Int
-
--- |
-- Data constructor metadata
--
data ConstructorType
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 71472e3..29096d5 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -41,7 +41,7 @@ data Environment = Environment {
-- |
-- 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 @@ primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star
-- |
-- 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 @@ lookupConstructor env ctor =
--
isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool
isNewtypeConstructor e ctor = case lookupConstructor e ctor of
- (Newtype, _, _) -> True
- (Data, _, _) -> False
+ (Newtype, _, _, _) -> True
+ (Data, _, _, _) -> False
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 4ced126..3ff82ff 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -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 @@ data ErrorStack
= 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 (ErrorStack es) =
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,10 +107,13 @@ showError (CompileError msg (Just (ExprError val)) _) = "Error in expression " +
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 f = flip catchError $ \e -> throwError (f e)
-- 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 @@ parU xs f = forM xs (withError . f) >>= collectErrors
[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 ]
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index 4a9cb20..71e516f 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -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 @@ type ModuleGraph = [(ModuleName, [ModuleName])]
--
-- 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 @@ usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (
-- |
-- 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)
diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs
index 421ab1f..a7265f4 100644
--- a/src/Language/PureScript/Options.hs
+++ b/src/Language/PureScript/Options.hs
@@ -70,6 +70,9 @@ data Options mode = Options {
--
, 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 @@ data Options mode = Options {
-- 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
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index 38841aa..c477180 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -24,7 +24,6 @@ module Language.PureScript.Sugar.BindingGroups (
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 @@ toBindingGroup moduleName (CyclicSCC ds') =
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
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 842c0fb..dde2428 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -19,12 +19,11 @@ module Language.PureScript.Sugar.CaseDeclarations (
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 @@ isLeft (Right _) = False
--
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]
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 31eb7d7..fc22e34 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -18,10 +18,9 @@ module Language.PureScript.Sugar.Names (
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 @@ desugarImports modules = do
-- 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 @@ renameInModule imports exports (Module mn decls exps) =
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 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri
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 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri
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
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 2120d8b..9038e63 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -32,9 +32,8 @@ import Language.PureScript.Supply
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 @@ ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
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
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 49a8dc9..ed08fc2 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -21,23 +21,22 @@ module Language.PureScript.Sugar.TypeClasses
) 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 @@ desugarDecl mn exps = go
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 @@ typeClassDictionaryDeclaration name args implies members =
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 @@ unit = TypeApp tyObject REmpty
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
diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs
index aa4427e..7779fd1 100644
--- a/src/Language/PureScript/Sugar/TypeDeclarations.hs
+++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs
@@ -19,11 +19,9 @@ module Language.PureScript.Sugar.TypeDeclarations (
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 @@ import Language.PureScript.Traversals
--
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
-- |
diff --git a/src/Language/PureScript/Supply.hs b/src/Language/PureScript/Supply.hs
index c11725b..8ff03c8 100644
--- a/src/Language/PureScript/Supply.hs
+++ b/src/Language/PureScript/Supply.hs
@@ -24,7 +24,7 @@ import Data.Functor.Identity
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)
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 150df69..bc5c64d 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -27,12 +27,11 @@ import Language.PureScript.TypeChecker.Synonyms as T
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 @@ addDataType moduleName dtype name args dctors ctorKind = do
env <- getEnv
putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
forM_ dctors $ \(dctor, tys) ->
- rethrow (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 @@ addDataConstructor moduleName dtype name args dctor tys = do
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 @@ typeCheckAll mainModuleName moduleName exps = go
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 @@ typeCheckAll mainModuleName moduleName exps = go
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 @@ typeCheckAll mainModuleName moduleName exps = go
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 @@ typeCheckAll mainModuleName moduleName exps = go
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 @@ typeCheckAll mainModuleName moduleName exps = go
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 @@ typeCheckAll mainModuleName moduleName exps = go
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
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
index 6486860..c86f979 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -25,9 +25,10 @@ import qualified Data.Map as M
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
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 60083cc..fa3d630 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -24,14 +24,13 @@ module Language.PureScript.TypeChecker.Kinds (
) 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 @@ kindOf _ ty = fst <$> kindOfWithScopedVars ty
--
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 @@ starIfUnknown k = k
-- 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
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index b59c08a..7abb0ac 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -14,7 +14,7 @@
-----------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, RankNTypes,
- MultiParamTypeClasses, FlexibleContexts #-}
+ MultiParamTypeClasses, FlexibleContexts, GADTs #-}
module Language.PureScript.TypeChecker.Monad where
@@ -22,7 +22,8 @@ import Data.Maybe
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 @@ makeBindingGroupVisible action = do
-- |
-- 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 @@ lookupVariable currentModule (Qualified moduleName var) = do
-- |
-- 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 @@ getVisibility currentModule (Qualified moduleName var) = do
-- |
-- 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 @@ checkVisibility currentModule name@(Qualified _ var) = do
-- |
-- 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 @@ data CheckState = CheckState {
-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
--
newtype Check a = Check { unCheck :: StateT CheckState (Either 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 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
-- |
-- 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)
diff --git a/src/Language/PureScript/TypeChecker/Rows.hs b/src/Language/PureScript/TypeChecker/Rows.hs
index 1c3115a..f1fec1b 100644
--- a/src/Language/PureScript/TypeChecker/Rows.hs
+++ b/src/Language/PureScript/TypeChecker/Rows.hs
@@ -19,7 +19,7 @@ module Language.PureScript.TypeChecker.Rows (
import Data.List
-import Control.Monad.Error
+import Control.Monad.Except
import Language.PureScript.AST
import Language.PureScript.Errors
diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs
index 62ee80a..221cb1a 100644
--- a/src/Language/PureScript/TypeChecker/Skolems.hs
+++ b/src/Language/PureScript/TypeChecker/Skolems.hs
@@ -26,7 +26,7 @@ import Data.List (nub, (\\))
import Data.Monoid
import Control.Applicative
-import Control.Monad.Error
+import Control.Monad.Except
import Control.Monad.Unify
import Language.PureScript.AST
diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs
index 5d8ab24..e9a7ac2 100644
--- a/src/Language/PureScript/TypeChecker/Subsumption.hs
+++ b/src/Language/PureScript/TypeChecker/Subsumption.hs
@@ -18,11 +18,10 @@ module Language.PureScript.TypeChecker.Subsumption (
) 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 @@ import Language.PureScript.Types
-- 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
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index 7ad00e2..1457a8c 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -13,7 +13,7 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, GADTs #-}
module Language.PureScript.TypeChecker.Synonyms (
saturateAllTypeSynonyms,
@@ -28,10 +28,11 @@ import Data.Maybe (fromMaybe)
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 @@ replaceAllTypeSynonyms' env d =
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 @@ expandTypeSynonym' env name args =
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
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 49f7d0d..7ad5a97 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -13,7 +13,7 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, OverloadedStrings #-}
module Language.PureScript.TypeChecker.Types (
typesOf
@@ -38,11 +38,11 @@ module Language.PureScript.TypeChecker.Types (
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 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty)
-- 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 @@ infer' v@(Constructor c) = do
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 (VarBinder name) = return $ M.singleton name val
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 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do
-- 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 @@ check' (Constructor c) ty = do
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 @@ containsTypeSynonyms = everythingOnTypes (||) go where
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 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
-- 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 @@ meet e1 e2 t1 t2 = do
-- |
-- 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
diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs
index 197ca9a..48381a2 100644
--- a/src/Language/PureScript/TypeChecker/Unify.hs
+++ b/src/Language/PureScript/TypeChecker/Unify.hs
@@ -27,10 +27,9 @@ module Language.PureScript.TypeChecker.Unify (
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 @@ instance Unifiable Check Type where
-- 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 ()
diff --git a/tests/Main.hs b/tests/Main.hs
index bfc9930..47922b0 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -22,6 +22,7 @@ import Data.List (isSuffixOf)
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 :: Either String (String, String, P.Environment)
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 @@ compile opts inputFiles = do
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