summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-09-21 19:32:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-09-21 19:32:00 (GMT)
commitd61c30cc49e85a47ba05debc008fc05a05ab0867 (patch)
tree24a4a73c64b452e561e7e7713ed118c3c9d0fcbc
parentb30e19bb10b8e49c82a578b5a12d348e94989cc3 (diff)
version 0.5.60.5.6
-rw-r--r--docgen/Main.hs3
-rw-r--r--examples/failing/InstanceExport.purs15
-rw-r--r--examples/failing/MultipleErrors.purs9
-rw-r--r--examples/failing/OverlappingArguments.purs3
-rw-r--r--examples/failing/OverlappingBinders.purs4
-rw-r--r--examples/passing/BlockString.purs12
-rw-r--r--examples/passing/IfThenElseMaybe.purs9
-rw-r--r--prelude/prelude.purs18
-rw-r--r--psc-make/Main.hs11
-rw-r--r--psc/Main.hs13
-rw-r--r--psci/Main.hs36
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript.hs53
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs50
-rw-r--r--src/Language/PureScript/Errors.hs44
-rw-r--r--src/Language/PureScript/Optimizer.hs2
-rw-r--r--src/Language/PureScript/Optimizer/MagicDo.hs2
-rw-r--r--src/Language/PureScript/Optimizer/TCO.hs2
-rw-r--r--src/Language/PureScript/Options.hs56
-rw-r--r--src/Language/PureScript/Parser/Common.hs4
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs4
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs40
-rw-r--r--src/Language/PureScript/TypeChecker.hs216
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs20
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs118
-rw-r--r--src/Language/PureScript/TypeClassDictionaries.hs4
-rw-r--r--tests/Main.hs18
27 files changed, 484 insertions, 284 deletions
diff --git a/docgen/Main.hs b/docgen/Main.hs
index 793a13d..da98d75 100644
--- a/docgen/Main.hs
+++ b/docgen/Main.hs
@@ -144,7 +144,8 @@ renderDeclaration n exps (P.DataDeclaration dtype name args ctors) = do
let exported = filter (isDctorExported name exps . fst) ctors
atIndent n $ show dtype ++ " " ++ typeName ++ (if null exported then "" else " where")
forM_ exported $ \(ctor, tys) ->
- atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ concatMap (\ty -> prettyPrintType' ty ++ " -> ") tys ++ typeName
+ let ctorTy = foldr P.function (P.TypeConstructor (P.Qualified Nothing name)) tys
+ in atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ prettyPrintType' ctorTy
renderDeclaration n _ (P.ExternDataDeclaration name kind) =
atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind
renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do
diff --git a/examples/failing/InstanceExport.purs b/examples/failing/InstanceExport.purs
new file mode 100644
index 0000000..597e07b
--- /dev/null
+++ b/examples/failing/InstanceExport.purs
@@ -0,0 +1,15 @@
+module InstanceExport (S(..), f) where
+
+newtype S = S String
+
+class F a where
+ f :: a -> String
+
+instance fs :: F S where
+ f (S s) = s
+
+module Test where
+
+import InstanceExport
+
+test = f $ S "Test"
diff --git a/examples/failing/MultipleErrors.purs b/examples/failing/MultipleErrors.purs
new file mode 100644
index 0000000..27db822
--- /dev/null
+++ b/examples/failing/MultipleErrors.purs
@@ -0,0 +1,9 @@
+module MultipleErrors where
+
+foo :: Number -> Number
+foo 0 = "Test"
+foo n = bar (n - 1)
+
+bar :: Number -> Number
+bar 0 = "Test"
+bar n = foo (n - 1)
diff --git a/examples/failing/OverlappingArguments.purs b/examples/failing/OverlappingArguments.purs
new file mode 100644
index 0000000..5fb0dbe
--- /dev/null
+++ b/examples/failing/OverlappingArguments.purs
@@ -0,0 +1,3 @@
+module OverlappingArguments where
+
+f x x = x
diff --git a/examples/failing/OverlappingBinders.purs b/examples/failing/OverlappingBinders.purs
new file mode 100644
index 0000000..4ab37d4
--- /dev/null
+++ b/examples/failing/OverlappingBinders.purs
@@ -0,0 +1,4 @@
+module OverlappingBinders where
+
+f x = case x of
+ (y:y@(z:zs)) -> y
diff --git a/examples/passing/BlockString.purs b/examples/passing/BlockString.purs
new file mode 100644
index 0000000..60accf1
--- /dev/null
+++ b/examples/passing/BlockString.purs
@@ -0,0 +1,12 @@
+module Main where
+
+foreign import foo """
+ function foo(s) {
+ return s;
+ }
+""" :: String -> String
+
+bar :: String -> String
+bar _ = foo "test"
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/IfThenElseMaybe.purs b/examples/passing/IfThenElseMaybe.purs
new file mode 100644
index 0000000..91da56d
--- /dev/null
+++ b/examples/passing/IfThenElseMaybe.purs
@@ -0,0 +1,9 @@
+module Main where
+
+data Maybe a = Nothing | Just a
+
+test1 = if true then Just 10 else Nothing
+
+test2 = if true then Nothing else Just 10
+
+main = Debug.Trace.trace "Done"
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index 1043e07..8a4d317 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -66,7 +66,7 @@ module Prelude
foreign import cons
"function cons(e) {\
- \ return function (l) {\
+ \ return function(l) {\
\ return [e].concat(l);\
\ };\
\}" :: forall a. a -> [a] -> [a]
@@ -97,8 +97,8 @@ module Prelude
show = showNumberImpl
foreign import showArrayImpl
- "function showArrayImpl (f) {\
- \ return function (xs) {\
+ "function showArrayImpl(f) {\
+ \ return function(xs) {\
\ var ss = [];\
\ for (var i = 0, l = xs.length; i < l; i++) {\
\ ss[i] = f(xs[i]);\
@@ -327,10 +327,10 @@ module Prelude
foreign import unsafeCompareImpl
"function unsafeCompareImpl(lt) {\
- \ return function (eq) {\
- \ return function (gt) {\
- \ return function (x) {\
- \ return function (y) {\
+ \ return function(eq) {\
+ \ return function(gt) {\
+ \ return function(x) {\
+ \ return function(y) {\
\ return x < y ? lt : x > y ? gt : eq;\
\ };\
\ };\
@@ -803,7 +803,7 @@ module Control.Monad.Eff where
foreign import untilE "function untilE(f) {\
\ return function() {\
- \ while (!f()) { }\
+ \ while (!f());\
\ return {};\
\ };\
\}" :: forall e. Eff e Boolean -> Eff e Unit
@@ -878,7 +878,7 @@ module Control.Monad.ST where
foreign import data STArray :: * -> * -> *
foreign import newSTRef "function newSTRef(val) {\
- \ return function () {\
+ \ return function() {\
\ return { value: val };\
\ };\
\}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)
diff --git a/psc-make/Main.hs b/psc-make/Main.hs
index e8c936d..14d5f86 100644
--- a/psc-make/Main.hs
+++ b/psc-make/Main.hs
@@ -12,7 +12,7 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving #-}
module Main where
@@ -66,7 +66,7 @@ instance P.MonadMake Make where
liftError = either throwError return
progress = makeIO . U.putStrLn
-compile :: FilePath -> [FilePath] -> FilePath -> P.Options -> Bool -> IO ()
+compile :: FilePath -> [FilePath] -> FilePath -> P.Options P.Make -> Bool -> IO ()
compile prelude input outputDir opts usePrefix = do
modules <- readInput allInputFiles
case modules of
@@ -81,7 +81,7 @@ compile prelude input outputDir opts usePrefix = do
exitFailure
Right _ -> do
exitSuccess
- where
+ where
prefix = if usePrefix
then ["Generated by psc-make version " ++ showVersion Paths.version]
else []
@@ -124,8 +124,8 @@ verboseErrors :: Term Bool
verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])
{ optDoc = "Display verbose error messages" }
-options :: Term P.Options
-options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> pure Nothing <*> pure [] <*> pure [] <*> verboseErrors
+options :: Term (P.Options P.Make)
+options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> verboseErrors <*> pure P.MakeOptions
noPrefix :: Term Bool
noPrefix = value $ flag $ (optInfo ["p", "no-prefix" ])
@@ -145,3 +145,4 @@ main :: IO ()
main = do
prelude <- P.preludeFilename
run (term prelude, termInfo)
+
diff --git a/psc/Main.hs b/psc/Main.hs
index 438facd..5e10ceb 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -12,7 +12,7 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving #-}
module Main where
@@ -44,7 +44,7 @@ readInput (Just input) = fmap collect $ forM input $ \inputFile -> do
collect :: [(FilePath, Either ParseError [P.Module])] -> Either ParseError [(FilePath, P.Module)]
collect = fmap concat . sequence . map (\(fp, e) -> fmap (map ((,) fp)) e)
-compile :: FilePath -> P.Options -> Bool -> [FilePath] -> Maybe FilePath -> Maybe FilePath -> Bool -> IO ()
+compile :: FilePath -> P.Options P.Compile -> Bool -> [FilePath] -> Maybe FilePath -> Maybe FilePath -> Bool -> IO ()
compile prelude opts stdin input output externs usePrefix = do
modules <- readInput stdInOrInputFiles
case modules of
@@ -70,7 +70,7 @@ compile prelude opts stdin input output externs usePrefix = do
| P.optionsNoPrelude opts = Just input
| otherwise = Just $ prelude : input
prefix = if usePrefix
- then ["Generated by psc version " ++ showVersion Paths.version]
+ then ["Generated by psc version " ++ showVersion Paths.version]
else []
mkdirp :: FilePath -> IO ()
@@ -136,8 +136,10 @@ noPrefix :: Term Bool
noPrefix = value $ flag $ (optInfo ["no-prefix" ])
{ optDoc = "Do not include comment header"}
-options :: Term P.Options
-options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> runMain <*> noOpts <*> (Just <$> browserNamespace) <*> dceModules <*> codeGenModules <*> verboseErrors
+options :: Term (P.Options P.Compile)
+options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> runMain <*> noOpts <*> verboseErrors <*> additionalOptions
+ where
+ additionalOptions = P.CompileOptions <$> browserNamespace <*> dceModules <*> codeGenModules
term :: FilePath -> Term (IO ())
term prelude = compile prelude <$> options <*> useStdIn <*> inputFiles <*> outputFile <*> externsFile <*> (not <$> noPrefix)
@@ -154,3 +156,4 @@ main = do
prelude <- P.preludeFilename
run (term prelude, termInfo)
+
diff --git a/psci/Main.hs b/psci/Main.hs
index c05908e..1a6513b 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -13,7 +13,7 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE DoAndIfThenElse, FlexibleContexts, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DataKinds, DoAndIfThenElse, FlexibleContexts, GeneralizedNewtypeDeriving #-}
module Main where
@@ -198,8 +198,8 @@ completion = completeWord Nothing " \t\n\r" findCompletions
-- | Compilation options.
--
-options :: P.Options
-options = P.Options False True False True Nothing True Nothing [] [] False
+options :: P.Options P.Make
+options = P.Options False False False False Nothing False False P.MakeOptions
-- |
-- PSCI monad
@@ -276,7 +276,7 @@ handleDeclaration :: P.Expr -> PSCI ()
handleDeclaration value = do
st <- PSCI $ lift get
let m = createTemporaryModule True st value
- e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) []
+ e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) []
case e of
Left err -> PSCI $ outputStrLn err
Right _ -> do
@@ -295,7 +295,7 @@ handleTypeOf :: P.Expr -> PSCI ()
handleTypeOf value = do
st <- PSCI $ lift get
let m = createTemporaryModule False st value
- e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) []
+ e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) []
case e of
Left err -> PSCI $ outputStrLn err
Right env' ->
@@ -311,7 +311,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 ++ [("$PSCI.purs", m)]) []
+ e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) []
case e of
Left err -> PSCI $ outputStrLn err
Right env' ->
@@ -329,13 +329,13 @@ handleKindOf typ = do
-- |
-- Parses the input and returns either a Metacommand or an expression.
--
-getCommand :: InputT (StateT PSCiState IO) (Either ParseError (Maybe Command))
-getCommand = do
+getCommand :: Bool -> InputT (StateT PSCiState IO) (Either ParseError (Maybe Command))
+getCommand singleLineMode = do
firstLine <- getInputLine "> "
case firstLine of
Nothing -> return (Right Nothing)
Just "" -> return (Right Nothing)
- Just s@ (':' : _) -> return . either Left (Right . Just) $ parseCommand s -- The start of a command
+ Just s | singleLineMode || head s == ':' -> return . either Left (Right . Just) $ parseCommand s
Just s -> either Left (Right . Just) . parseCommand <$> go [s]
where
go :: [String] -> InputT (StateT PSCiState IO) String
@@ -371,9 +371,16 @@ handleCommand (TypeOf val) = handleTypeOf val
handleCommand (KindOf typ) = handleKindOf typ
handleCommand _ = PSCI $ outputStrLn "Unknown command"
+singleLineFlag :: Cmd.Term Bool
+singleLineFlag = Cmd.value $ Cmd.flag $ (Cmd.optInfo ["single-line-mode"])
+ { Cmd.optName = "Single-line mode"
+ , Cmd.optDoc = "Run in single-line mode"
+ }
+
inputFiles :: Cmd.Term [FilePath]
inputFiles = Cmd.value $ Cmd.posAny [] $ Cmd.posInfo { Cmd.posName = "file(s)"
- , Cmd.posDoc = "Optional .purs files to load on start" }
+ , Cmd.posDoc = "Optional .purs files to load on start"
+ }
loadUserConfig :: IO (Maybe [Command])
loadUserConfig = do
@@ -391,8 +398,8 @@ loadUserConfig = do
-- |
-- The PSCI main loop.
--
-loop :: [FilePath] -> IO ()
-loop files = do
+loop :: Bool -> [FilePath] -> IO ()
+loop singleLineMode files = do
config <- loadUserConfig
preludeFilename <- P.preludeFilename
filesAndModules <- mapM (\file -> fmap (fmap (map ((,) file))) . loadModule $ file) (preludeFilename : files)
@@ -409,7 +416,7 @@ loop files = do
where
go :: InputT (StateT PSCiState IO) ()
go = do
- c <- getCommand
+ c <- getCommand singleLineMode
case c of
Left err -> outputStrLn (show err) >> go
Right Nothing -> go
@@ -417,7 +424,7 @@ loop files = do
Right (Just c') -> runPSCI (handleCommand c') >> go
term :: Cmd.Term (IO ())
-term = loop <$> inputFiles
+term = loop <$> singleLineFlag <*> inputFiles
termInfo :: Cmd.TermInfo
termInfo = Cmd.defTI
@@ -428,3 +435,4 @@ termInfo = Cmd.defTI
main :: IO ()
main = Cmd.run (term, termInfo)
+
diff --git a/purescript.cabal b/purescript.cabal
index 0022710..fed063b 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.5.5
+version: 0.5.6
cabal-version: >=1.8
build-type: Custom
license: MIT
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index fb7eb5c..678b813 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -13,6 +13,8 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE DataKinds #-}
+
module Language.PureScript (module P, compile, compile', MonadMake(..), make, preludeFilename) where
import Language.PureScript.Types as P
@@ -39,14 +41,17 @@ import qualified Paths_purescript as Paths
import Data.List (find, sortBy, groupBy, intercalate)
import Data.Time.Clock
import Data.Function (on)
-import Data.Maybe (fromJust, fromMaybe)
+import Data.Maybe (listToMaybe, fromMaybe)
import Control.Monad.Error
import Control.Monad.State.Lazy
import Control.Arrow ((&&&))
import Control.Applicative
import qualified Data.Map as M
import qualified Data.Set as S
-import System.FilePath (pathSeparator)
+
+import System.FilePath ((</>), pathSeparator)
+import System.Directory (getHomeDirectory, doesFileExist)
+import System.Environment.XDG.BaseDir (getUserConfigDir)
-- |
-- Compile a collection of modules
@@ -67,21 +72,21 @@ import System.FilePath (pathSeparator)
--
-- * Pretty-print the generated Javascript
--
-compile :: Options -> [Module] -> [String] -> Either String (String, String, Environment)
+compile :: Options Compile -> [Module] -> [String] -> Either String (String, String, Environment)
compile = compile' initEnvironment
-compile' :: Environment -> Options -> [Module] -> [String] -> Either String (String, String, Environment)
+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)
(desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted
(elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent
regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
- let entryPoints = moduleNameFromString `map` optionsModules opts
+ let entryPoints = moduleNameFromString `map` entryPointModules (optionsAdditional opts)
let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped
let renamed = renameInModules elim
- let codeGenModules = moduleNameFromString `map` optionsCodeGenModules opts
- let modulesToCodeGen = if null codeGenModules then renamed else filter (\(Module mn _ _) -> mn `elem` codeGenModules) renamed
- let js = evalSupply nextVar $ concat <$> mapM (\m -> moduleToJs Globals opts m env') modulesToCodeGen
+ let codeGenModuleNames = moduleNameFromString `map` codeGenModules (optionsAdditional opts)
+ let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(Module mn _ _) -> mn `elem` codeGenModuleNames) renamed
+ let js = evalSupply nextVar $ concat <$> mapM (\m -> moduleToJs opts m env') modulesToCodeGen
let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen
js' <- generateMain env' opts js
let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']
@@ -92,7 +97,7 @@ compile' env opts ms prefix = do
typeCheckModule :: Maybe ModuleName -> Module -> Check Module
typeCheckModule mainModuleName (Module mn decls exps) = do
modify (\s -> s { checkCurrentModule = Just mn })
- decls' <- typeCheckAll mainModuleName mn decls
+ decls' <- typeCheckAll mainModuleName mn exps decls
mapM_ checkTypesAreExported exps'
return $ Module mn decls' exps
where
@@ -126,13 +131,13 @@ typeCheckModule mainModuleName (Module mn decls exps) = do
go _ = True
-generateMain :: Environment -> Options -> [JS] -> Either String [JS]
+generateMain :: Environment -> Options Compile -> [JS] -> Either String [JS]
generateMain env opts js =
case moduleNameFromString <$> optionsMain opts 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 (fromJust (optionsBrowserNamespace opts))))) []]
+ return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace (optionsAdditional opts))))) []]
_ -> return js
-- |
@@ -170,7 +175,7 @@ class MonadMake m where
-- 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 -> [(FilePath, Module)] -> [String] -> m Environment
+make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options Make -> [(FilePath, Module)] -> [String] -> m Environment
make outputDir opts ms prefix = do
let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)
@@ -216,9 +221,9 @@ make outputDir opts ms prefix = do
regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
let mod' = Module moduleName' regrouped exps
- let [renamed] = renameInModules [mod']
+ let [renamed] = renameInModules [mod']
- pjs <- prettyPrintJS <$> moduleToJs CommonJS opts renamed env'
+ pjs <- prettyPrintJS <$> moduleToJs opts renamed env'
let js = unlines $ map ("// " ++) prefix ++ [pjs]
let exts = unlines $ map ("-- " ++ ) prefix ++ [moduleToPs renamed env']
@@ -266,4 +271,22 @@ importPrelude :: Module -> Module
importPrelude = addDefaultImport (ModuleName [ProperName C.prelude])
preludeFilename :: IO FilePath
-preludeFilename = Paths.getDataFileName "prelude/prelude.purs"
+preludeFilename = fromMaybe missingPrelude . listToMaybe <$> do
+ fs <- sequence [xdsPrelude, homePrelude, cabalPrelude]
+ filterM doesFileExist fs
+ where
+ missingPrelude :: FilePath
+ missingPrelude = error "No Prelude found in user home, XDS user config directory or cabal path."
+
+ xdsPrelude :: IO FilePath
+ xdsPrelude = do
+ configDir <- getUserConfigDir "purescript"
+ return $ configDir </> "prelude" </> "prelude.purs"
+
+ homePrelude :: IO FilePath
+ homePrelude = do
+ homeDir <- getHomeDirectory
+ return $ homeDir </> ".purescript" </> "prelude" </> "prelude.purs"
+
+ cabalPrelude :: IO FilePath
+ cabalPrelude = Paths.getDataFileName "prelude/prelude.purs"
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 5faf3e8..f08ef43 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -13,17 +13,16 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE GADTs, DoAndIfThenElse #-}
module Language.PureScript.CodeGen.JS (
module AST,
- ModuleType(..),
declToJs,
moduleToJs,
identNeedsEscaping
) where
-import Data.Maybe (catMaybes, fromJust)
+import Data.Maybe (catMaybes)
import Data.Function (on)
import Data.List (nub, (\\), delete, sortBy)
@@ -43,39 +42,35 @@ import Language.PureScript.Traversals (sndM)
import qualified Language.PureScript.Constants as C
-- |
--- Different types of modules which are supported
---
-data ModuleType = CommonJS | Globals
-
--- |
-- Generate code in the simplified Javascript intermediate representation for all declarations in a
-- module.
--
-moduleToJs :: (Functor m, Applicative m, Monad m) => ModuleType -> Options -> Module -> Environment -> SupplyT m [JS]
-moduleToJs mt opts (Module name decls (Just exps)) env = do
- let jsImports = map (importToJs mt opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) . nub $ concatMap imports decls
+moduleToJs :: (Functor m, Applicative m, Monad m) => Options mode -> Module -> Environment -> SupplyT m [JS]
+moduleToJs opts (Module name decls (Just exps)) env = do
+ let jsImports = map (importToJs opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) . nub $ concatMap imports decls
jsDecls <- mapM (\decl -> declToJs opts name decl env) decls
let optimized = concat $ map (map $ optimize opts) $ catMaybes jsDecls
let isModuleEmpty = null exps
let moduleBody = JSStringLiteral "use strict" : jsImports ++ optimized
let moduleExports = JSObjectLiteral $ concatMap exportToJs exps
- return $ case mt of
- CommonJS -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]
- Globals | not isModuleEmpty ->
- [ JSVariableIntroduction (fromJust (optionsBrowserNamespace opts))
- (Just (JSBinary Or (JSVar (fromJust (optionsBrowserNamespace opts))) (JSObjectLiteral [])) )
- , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar (fromJust (optionsBrowserNamespace opts))))
+ return $ case optionsAdditional opts of
+ MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]
+ CompileOptions ns _ _ | not isModuleEmpty ->
+ [ JSVariableIntroduction ns
+ (Just (JSBinary Or (JSVar ns) (JSObjectLiteral [])) )
+ , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar ns))
(JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])
]
_ -> []
-moduleToJs _ _ _ _ = error "Exports should have been elaborated in name desugaring"
+moduleToJs _ _ _ = error "Exports should have been elaborated in name desugaring"
-importToJs :: ModuleType -> Options -> ModuleName -> JS
-importToJs mt opts mn = JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)
+importToJs :: Options mode -> ModuleName -> JS
+importToJs opts mn =
+ JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)
where
- moduleBody = case mt of
- CommonJS -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]
- Globals -> JSAccessor (moduleNameToJs mn) (JSVar (fromJust (optionsBrowserNamespace opts)))
+ moduleBody = case optionsAdditional opts of
+ MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]
+ CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns)
imports :: Declaration -> [ModuleName]
imports (ImportDeclaration mn _ _) = [mn]
@@ -95,7 +90,7 @@ imports other =
-- |
-- Generate code in the simplified Javascript intermediate representation for a declaration
--
-declToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Declaration -> Environment -> SupplyT m (Maybe [JS])
+declToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Declaration -> Environment -> SupplyT m (Maybe [JS])
declToJs opts mp (ValueDeclaration ident _ _ _ val) e = do
js <- valueToJs opts mp e val
return $ Just [JSVariableIntroduction (identToJs ident) (Just js)]
@@ -190,7 +185,7 @@ 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) => Options -> ModuleName -> Environment -> Expr -> SupplyT m JS
+valueToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Environment -> Expr -> SupplyT m JS
valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n
valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s
valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b
@@ -315,7 +310,7 @@ 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) => Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> SupplyT m JS
+bindersToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> SupplyT m JS
bindersToJs opts m e binders vals = do
valNames <- replicateM (length vals) freshName
let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
@@ -405,7 +400,7 @@ binderToJs m e varName done binder@(ConsBinder _ _) = do
( JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left numberOfHeadBinders)])) :
js2
)) Nothing]
- where
+ where
uncons :: [Binder] -> Binder -> ([Binder], Binder)
uncons acc (ConsBinder h t) = uncons (h : acc) t
uncons acc (PositionedBinder _ b) = uncons acc b
@@ -416,3 +411,4 @@ binderToJs m e varName done (NamedBinder ident binder) = do
binderToJs m e varName done (PositionedBinder _ binder) =
binderToJs m e varName done binder
+
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 27e28e1..9c0179b 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -16,7 +16,7 @@
module Language.PureScript.Errors where
-import Data.List (intercalate)
+import Data.List (intersperse, intercalate)
import Data.Monoid
import Control.Monad.Error
@@ -41,25 +41,35 @@ data ErrorSource
-- |
-- Compilation errors
--
-data CompileError = CompileError {
- -- |
- -- Error message
- --
- compileErrorMessage :: String
- -- |
- -- The value where the error occurred
- --
- , compileErrorValue :: Maybe ErrorSource
- -- |
- -- Optional source position information
- --
- , compileErrorPosition :: Maybe SourcePos
- } deriving (Show)
+data CompileError
+ = CompileError
+ { -- |
+ -- Error message
+ --
+ compileErrorMessage :: String
+ -- |
+ -- The value where the error occurred
+ --
+ , compileErrorValue :: Maybe ErrorSource
+ -- |
+ -- Optional source position information
+ --
+ , compileErrorPosition :: Maybe SourcePos
+ }
+ deriving (Show)
-- |
-- A stack trace for an error
--
-newtype ErrorStack = ErrorStack { runErrorStack :: [CompileError] } deriving (Show, Monoid)
+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 ]
instance Error ErrorStack where
strMsg s = ErrorStack [CompileError s Nothing Nothing]
@@ -80,6 +90,8 @@ prettyPrintErrorStack printFullStack (ErrorStack es) =
in case length es' of
1 -> showError (head es')
_ -> showError (head es') ++ "\n" ++ showError (last 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
diff --git a/src/Language/PureScript/Optimizer.hs b/src/Language/PureScript/Optimizer.hs
index fb4eacc..3a42930 100644
--- a/src/Language/PureScript/Optimizer.hs
+++ b/src/Language/PureScript/Optimizer.hs
@@ -49,7 +49,7 @@ import Language.PureScript.Optimizer.Blocks
-- |
-- Apply a series of optimizer passes to simplified Javascript code
--
-optimize :: Options -> JS -> JS
+optimize :: Options mode -> JS -> JS
optimize opts | optionsNoOptimizations opts = id
| otherwise = untilFixedPoint (applyAll
[ collapseNestedBlocks
diff --git a/src/Language/PureScript/Optimizer/MagicDo.hs b/src/Language/PureScript/Optimizer/MagicDo.hs
index 9571bad..df817f7 100644
--- a/src/Language/PureScript/Optimizer/MagicDo.hs
+++ b/src/Language/PureScript/Optimizer/MagicDo.hs
@@ -28,7 +28,7 @@ import Language.PureScript.Names
import qualified Language.PureScript.Constants as C
-magicDo :: Options -> JS -> JS
+magicDo :: Options mode -> JS -> JS
magicDo opts | optionsNoMagicDo opts = id
| otherwise = inlineST . magicDo'
diff --git a/src/Language/PureScript/Optimizer/TCO.hs b/src/Language/PureScript/Optimizer/TCO.hs
index 511b006..4541e73 100644
--- a/src/Language/PureScript/Optimizer/TCO.hs
+++ b/src/Language/PureScript/Optimizer/TCO.hs
@@ -21,7 +21,7 @@ import Language.PureScript.CodeGen.JS.AST
-- |
-- Eliminate tail calls
--
-tco :: Options -> JS -> JS
+tco :: Options mode -> JS -> JS
tco opts | optionsNoTco opts = id
| otherwise = tco'
diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs
index a271c34..6ffa3df 100644
--- a/src/Language/PureScript/Options.hs
+++ b/src/Language/PureScript/Options.hs
@@ -13,12 +13,37 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE GADTs, DataKinds, StandaloneDeriving #-}
+
module Language.PureScript.Options where
-- |
+-- Indicates the mode of the compiler. Lifted using DataKinds to refine the Options type.
+--
+data Mode = Compile | Make
+
+-- |
+-- Per-mode options
+--
+data ModeOptions mode where
+ CompileOptions :: String -> [String] -> [String] -> ModeOptions Compile
+ MakeOptions :: ModeOptions Make
+
+browserNamespace :: ModeOptions Compile -> String
+browserNamespace (CompileOptions ns _ _) = ns
+
+entryPointModules :: ModeOptions Compile -> [String]
+entryPointModules (CompileOptions _ ms _) = ms
+
+codeGenModules :: ModeOptions Compile -> [String]
+codeGenModules (CompileOptions _ _ ms) = ms
+
+deriving instance Show (ModeOptions mode)
+
+-- |
-- The data type of compiler options
--
-data Options = Options {
+data Options mode = Options {
-- |
-- Disable inclusion of the built in Prelude
--
@@ -45,27 +70,24 @@ data Options = Options {
--
, optionsNoOptimizations :: Bool
-- |
- -- Specify the namespace that PureScript modules will be exported to when running in the
- -- browser.
- --
- , optionsBrowserNamespace :: Maybe String
- -- |
- -- The modules to keep while enabling dead code elimination
- --
- , optionsModules :: [String]
- -- |
- -- The modules to code gen
- --
- , optionsCodeGenModules :: [String]
- -- |
-- Verbose error message
--
, optionsVerboseErrors :: Bool
-
+ -- |
+ -- Specify the namespace that PureScript modules will be exported to when running in the
+ -- browser.
+ --
+ , optionsAdditional :: ModeOptions mode
} deriving Show
-- |
-- Default compiler options
--
-defaultOptions :: Options
-defaultOptions = Options False False False False Nothing False Nothing [] [] False
+defaultCompileOptions :: Options Compile
+defaultCompileOptions = Options False False False False Nothing False False (CompileOptions "PS" [] [])
+
+-- |
+-- Default make options
+--
+defaultMakeOptions :: Options Make
+defaultMakeOptions = Options False False False False Nothing False False MakeOptions
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index 1789379..850920b 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -155,7 +155,9 @@ operator = PT.operator tokenParser
-- Parse a string literal
--
stringLiteral :: P.Parsec String u String
-stringLiteral = PT.stringLiteral tokenParser
+stringLiteral = lexeme blockString <|> PT.stringLiteral tokenParser
+ where delimeter = P.try (P.string "\"\"\"")
+ blockString = delimeter >> P.manyTill P.anyChar delimeter
-- |
-- Parse whitespace
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 2a215b8..958f8aa 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -20,7 +20,7 @@ module Language.PureScript.Sugar.CaseDeclarations (
) where
import Data.Monoid ((<>))
-import Data.List (groupBy)
+import Data.List (nub, groupBy)
import Control.Applicative
import Control.Monad ((<=<), forM, join, unless, replicateM)
@@ -31,6 +31,7 @@ import Language.PureScript.Declarations
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Supply
+import Language.PureScript.TypeChecker.Monad (guardWith)
-- |
-- Replace all top-level binders in a module with case expressions.
@@ -82,6 +83,7 @@ toDecls :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
toDecls [ValueDeclaration ident nameKind bs Nothing val] | all isVarBinder bs = do
let args = map (\(VarBinder arg) -> arg) bs
body = foldr (Abs . Left) val args
+ guardWith (strMsg "Overlapping function argument names") $ length (nub args) == length args
return [ValueDeclaration ident nameKind [] Nothing body]
toDecls ds@(ValueDeclaration ident _ bs _ _ : _) = do
let tuples = map toTuple ds
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 2218936..fa46877 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -151,36 +151,46 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"
-- };
-}
desugarDecl :: ModuleName -> [DeclarationRef] -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
-desugarDecl mn _ 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)
-desugarDecl mn exps d@(TypeInstanceDeclaration name deps className tys members) = do
- desugared <- lift $ desugarCases members
- dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
- let expRef = if isExportedClass className && all isExportedType (getConstructors `concatMap` tys)
- then Just $ TypeInstanceRef name
- else Nothing
- return $ (expRef, [d, dictDecl])
+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)
+ 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])
+ go (PositionedDeclaration pos d) = do
+ (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
+ return (dr, map (PositionedDeclaration pos) ds)
+ go other = return (Nothing, [other])
+
+ expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef
+ expRef name className tys
+ | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name
+ | otherwise = Nothing
+
isExportedClass :: Qualified ProperName -> Bool
isExportedClass = isExported (elem . TypeClassRef)
+
isExportedType :: Qualified ProperName -> Bool
isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)
+
isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool
isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps
isExported _ _ = error "Names should have been qualified in name desugaring"
+
matchesTypeRef :: ProperName -> DeclarationRef -> Bool
matchesTypeRef pn (TypeRef pn' _) = pn == pn'
matchesTypeRef _ _ = False
+
getConstructors :: Type -> [Qualified ProperName]
getConstructors = everythingOnTypes (++) getConstructor
+
getConstructor :: Type -> [Qualified ProperName]
getConstructor (TypeConstructor tcname) = [tcname]
getConstructor _ = []
-desugarDecl mn exps (PositionedDeclaration pos d) = do
- (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
- return (dr, map (PositionedDeclaration pos) ds)
-desugarDecl _ _ other = return (Nothing, [other])
memberToNameAndType :: Declaration -> (Ident, Type)
memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)
@@ -275,3 +285,5 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] _ val) = val
typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)
typeInstanceDictionaryEntryValue _ = error "Invalid declaration in type instance definition"
+
+
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 6a8f59b..a5c0ec7 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -119,112 +119,128 @@ checkTypeClassInstance _ ty = throwError $ mkErrorStack "Type class instance hea
--
-- * Process module imports
--
-typeCheckAll :: Maybe ModuleName -> ModuleName -> [Declaration] -> Check [Declaration]
-typeCheckAll _ _ [] = return []
-typeCheckAll mainModuleName moduleName (d@(DataDeclaration dtype name args dctors) : rest) = do
- rethrow (strMsg ("Error in type constructor " ++ show name) <>) $ do
- when (dtype == Newtype) $ checkNewtype dctors
- checkDuplicateTypeArguments args
- ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
- addDataType moduleName dtype name args dctors ctorKind
- ds <- typeCheckAll mainModuleName moduleName rest
- return $ d : ds
+typeCheckAll :: Maybe ModuleName -> ModuleName -> Maybe [DeclarationRef] -> [Declaration] -> Check [Declaration]
+typeCheckAll mainModuleName moduleName exps = go
where
- checkNewtype :: [(ProperName, [Type])] -> Check ()
- checkNewtype [(_, [_])] = return ()
- checkNewtype [(_, _)] = throwError . strMsg $ "newtypes constructors must have a single argument"
- checkNewtype _ = throwError . strMsg $ "newtypes must have a single constructor"
-typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do
- rethrow (strMsg "Error in data binding group" <>) $ do
- let syns = mapMaybe toTypeSynonym tys
- let dataDecls = mapMaybe toDataDecl tys
- (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
- forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do
+ go :: [Declaration] -> Check [Declaration]
+ go [] = return []
+ go (d@(DataDeclaration dtype name args dctors) : rest) = do
+ rethrow (strMsg ("Error in type constructor " ++ show name) <>) $ do
+ when (dtype == Newtype) $ checkNewtype dctors
checkDuplicateTypeArguments args
+ ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
addDataType moduleName dtype name args dctors ctorKind
- forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do
+ ds <- go rest
+ return $ d : ds
+ where
+ checkNewtype :: [(ProperName, [Type])] -> Check ()
+ checkNewtype [(_, [_])] = return ()
+ 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
+ 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)
+ forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do
+ checkDuplicateTypeArguments args
+ addDataType moduleName dtype name args dctors ctorKind
+ forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do
+ checkDuplicateTypeArguments args
+ addTypeSynonym moduleName name args ty kind
+ ds <- go rest
+ return $ d : ds
+ where
+ toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)
+ toTypeSynonym (PositionedDeclaration _ d') = toTypeSynonym d'
+ toTypeSynonym _ = Nothing
+ toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)
+ toDataDecl (PositionedDeclaration _ d') = toDataDecl d'
+ toDataDecl _ = Nothing
+ go (d@(TypeSynonymDeclaration name args ty) : rest) = do
+ rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do
checkDuplicateTypeArguments args
+ kind <- kindsOf False moduleName name args [ty]
addTypeSynonym moduleName name args ty kind
- ds <- typeCheckAll mainModuleName moduleName rest
- return $ d : ds
- where
- toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)
- toTypeSynonym (PositionedDeclaration _ d') = toTypeSynonym d'
- toTypeSynonym _ = Nothing
- toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)
- toDataDecl (PositionedDeclaration _ d') = toDataDecl d'
- toDataDecl _ = Nothing
-typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do
- rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do
- checkDuplicateTypeArguments args
- kind <- kindsOf False moduleName name args [ty]
- addTypeSynonym moduleName name args ty kind
- ds <- typeCheckAll mainModuleName moduleName rest
- return $ d : ds
-typeCheckAll _ _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
-typeCheckAll mainModuleName moduleName (ValueDeclaration name nameKind [] Nothing val : rest) = do
- d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do
- valueIsNotDefined moduleName name
- [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
- addValue moduleName name ty nameKind
- return $ ValueDeclaration name nameKind [] Nothing val'
- ds <- typeCheckAll mainModuleName moduleName rest
- return $ d : ds
-typeCheckAll _ _ (ValueDeclaration{} : _) = error "Binders were not desugared"
-typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = do
- d <- rethrow (strMsg ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) <>) $ do
- forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
+ ds <- go rest
+ return $ d : ds
+ go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
+ go (ValueDeclaration name nameKind [] Nothing val : rest) = do
+ d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do
valueIsNotDefined moduleName name
- tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
- vals' <- forM (zipWith (\(name, nameKind, _) (_, (val, ty)) -> (name, val, nameKind, ty)) vals tys) $ \(name, val, nameKind, ty) -> do
+ [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
addValue moduleName name ty nameKind
- return (name, nameKind, val)
- return $ BindingGroupDeclaration vals'
- ds <- typeCheckAll mainModuleName moduleName rest
- return $ d : ds
-typeCheckAll mainModuleName moduleName (d@(ExternDataDeclaration name kind) : rest) = do
- env <- getEnv
- putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }
- ds <- typeCheckAll mainModuleName moduleName rest
- return $ d : ds
-typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do
- rethrow (strMsg ("Error in foreign import declaration " ++ show name) <>) $ do
+ return $ ValueDeclaration name nameKind [] Nothing val'
+ ds <- go rest
+ 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
+ forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
+ valueIsNotDefined moduleName name
+ tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
+ vals' <- forM (zipWith (\(name, nameKind, _) (_, (val, ty)) -> (name, val, nameKind, ty)) vals tys) $ \(name, val, nameKind, ty) -> do
+ addValue moduleName name ty nameKind
+ return (name, nameKind, val)
+ return $ BindingGroupDeclaration vals'
+ ds <- go rest
+ return $ d : ds
+ go (d@(ExternDataDeclaration name kind) : rest) = do
env <- getEnv
- kind <- kindOf moduleName ty
- guardWith (strMsg "Expected kind *") $ kind == Star
- case M.lookup (moduleName, name) (names env) of
- Just _ -> throwError . strMsg $ show name ++ " is already defined"
- Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy, Defined) (names env) })
- ds <- typeCheckAll mainModuleName moduleName rest
- return $ d : ds
-typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = do
- ds <- typeCheckAll mainModuleName moduleName rest
- env <- getEnv
- guardWith (strMsg ("Fixity declaration with no binding: " ++ name)) $ M.member (moduleName, Op name) $ names env
- return $ d : ds
-typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _ _) : rest) = do
- tcds <- getTypeClassDictionaries
- let instances = filter (\tcd -> let Qualified (Just mn) _ = tcdName tcd in moduleName == mn) tcds
- addTypeClassDictionaries [ tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (canonicalizeDictionary tcd) }
- | tcd <- instances
- , let (Qualified _ ident) = tcdName tcd
- ]
- ds <- typeCheckAll mainModuleName currentModule rest
- return $ d : ds
-typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration pn args implies tys) : rest) = do
- addTypeClass moduleName pn args implies tys
- ds <- typeCheckAll mainModuleName moduleName rest
- return $ d : ds
-typeCheckAll mainModuleName moduleName (TypeInstanceDeclaration dictName deps className tys _ : rest) = do
- typeCheckAll mainModuleName moduleName (ExternInstanceDeclaration dictName deps className tys : rest)
-typeCheckAll mainModuleName moduleName (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do
- mapM_ (checkTypeClassInstance moduleName) tys
- forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
- addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular]
- ds <- typeCheckAll mainModuleName moduleName rest
- return $ d : ds
-typeCheckAll mainModuleName moduleName (PositionedDeclaration pos d : rest) =
- rethrowWithPosition pos $ do
- (d' : rest') <- typeCheckAll mainModuleName moduleName (d : rest)
- return (PositionedDeclaration pos d' : rest')
+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }
+ ds <- go rest
+ return $ d : ds
+ go (d@(ExternDeclaration importTy name _ ty) : rest) = do
+ rethrow (strMsg ("Error in foreign import declaration " ++ show name) <>) $ do
+ env <- getEnv
+ kind <- kindOf moduleName ty
+ guardWith (strMsg "Expected kind *") $ kind == Star
+ case M.lookup (moduleName, name) (names env) of
+ Just _ -> throwError . strMsg $ show name ++ " is already defined"
+ Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy, Defined) (names env) })
+ ds <- go rest
+ return $ d : ds
+ go (d@(FixityDeclaration _ name) : rest) = do
+ ds <- go rest
+ env <- getEnv
+ guardWith (strMsg ("Fixity declaration with no binding: " ++ name)) $ M.member (moduleName, Op name) $ names env
+ return $ d : ds
+ go (d@(ImportDeclaration importedModule _ _) : rest) = do
+ tcds <- getTypeClassDictionaries
+ let instances = filter (\tcd -> let Qualified (Just mn) _ = tcdName tcd in importedModule == mn) tcds
+ addTypeClassDictionaries [ tcd { tcdName = Qualified (Just moduleName) ident, tcdType = TCDAlias (canonicalizeDictionary tcd) }
+ | tcd <- instances
+ , tcdExported tcd
+ , let (Qualified _ ident) = tcdName tcd
+ ]
+ ds <- go rest
+ return $ d : ds
+ go (d@(TypeClassDeclaration pn args implies tys) : rest) = do
+ addTypeClass moduleName pn args implies tys
+ ds <- go rest
+ return $ d : ds
+ go (TypeInstanceDeclaration dictName deps className tys _ : rest) = do
+ go (ExternInstanceDeclaration dictName deps className tys : rest)
+ go (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do
+ mapM_ (checkTypeClassInstance moduleName) tys
+ forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
+ addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported]
+ ds <- go rest
+ return $ d : ds
+ where
+ isInstanceExported :: Bool
+ isInstanceExported = maybe True (any exportsInstance) exps
+
+ exportsInstance :: DeclarationRef -> Bool
+ exportsInstance (TypeInstanceRef name) | name == dictName = True
+ exportsInstance (PositionedDeclarationRef _ r) = exportsInstance r
+ exportsInstance _ = False
+
+ go (PositionedDeclaration pos d : rest) =
+ rethrowWithPosition pos $ do
+ (d' : rest') <- go (d : rest)
+ return (PositionedDeclaration pos d' : rest')
+
+
+
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 8c8731d..521c6c6 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -28,6 +28,7 @@ import Language.PureScript.Options
import Language.PureScript.Errors
import Data.Maybe
+import Data.Either (lefts, rights)
import Control.Applicative
import Control.Monad.State
@@ -190,13 +191,13 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
-- |
-- Run a computation in the Check monad, starting with an empty @Environment@
--
-runCheck :: Options -> Check a -> Either String (a, Environment)
+runCheck :: Options mode -> Check a -> Either String (a, Environment)
runCheck opts = runCheck' opts initEnvironment
-- |
-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.
--
-runCheck' :: Options -> Environment -> Check a -> Either String (a, Environment)
+runCheck' :: Options mode -> Environment -> Check a -> Either String (a, Environment)
runCheck' opts env c = stringifyErrorStack (optionsVerboseErrors opts) $ do
(a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c
return (a, checkEnv s)
@@ -233,3 +234,18 @@ liftUnify unify = do
modify $ \st' -> st' { checkNextVar = unifyNextVar ust }
return (a, unifyCurrentSubstitution ust)
+-- |
+-- Typecheck in parallel
+--
+parU :: [a] -> (a -> UnifyT t Check b) -> UnifyT t Check [b]
+parU xs f = forM xs (withError . f) >>= collectErrors
+ where
+ withError :: UnifyT t Check a -> UnifyT t Check (Either ErrorStack a)
+ withError u = catchError (Right <$> u) (return . Left)
+
+ collectErrors :: [Either ErrorStack a] -> UnifyT t Check [a]
+ collectErrors es = case lefts es of
+ [err] -> throwError err
+ [] -> return $ rights es
+ errs -> throwError $ MultipleErrors errs
+
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 0c1e72b..4aac6e0 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -42,10 +42,11 @@ module Language.PureScript.TypeChecker.Types (
-}
import Data.List
-import Data.Maybe (maybeToList, isNothing, isJust, fromMaybe)
+import Data.Maybe (maybeToList, fromMaybe)
import Data.Function (on)
import Data.Ord (comparing)
import Data.Monoid
+import Data.Either (lefts, rights)
import Language.PureScript.Declarations
import Language.PureScript.Types
@@ -171,14 +172,16 @@ unifyRows r1 r2 =
typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))]
typesOf mainModuleName moduleName vals = do
tys <- fmap tidyUp . liftUnify $ do
- (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals
- forM es $ \e -> do
- triple@(_, (_, ty)) <- typeForBindingGroupElement moduleName e dict untypedDict
- -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a
- when (Just moduleName == mainModuleName && fst e == Ident C.main) $ do
- [eff, a] <- replicateM 2 fresh
- ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a
+ (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals
+ ds1 <- parU typed $ \e -> do
+ triple@(_, (_, ty)) <- checkTypedBindingGroupElement moduleName e dict
+ checkMain (fst e) ty
return triple
+ ds2 <- forM untyped $ \e -> do
+ triple@(_, (_, ty)) <- typeForBindingGroupElement e dict untypedDict
+ checkMain (fst e) ty
+ return triple
+ return $ ds1 ++ ds2
forM tys $ \(ident, (val, ty)) -> do
-- Replace type class dictionary placeholders with actual dictionaries
@@ -193,17 +196,25 @@ typesOf mainModuleName moduleName vals = do
where
-- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
+ -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a
+ checkMain nm ty = when (Just moduleName == mainModuleName && nm == Ident C.main) $ do
+ [eff, a] <- replicateM 2 fresh
+ ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a
+
+type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
+
+type UntypedData = [(Ident, Type)]
-typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Expr)] -> UnifyT Type Check ([(Ident, (Expr, Maybe (Type, Bool)))], M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility), [(Ident, Type)])
+typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Expr)] -> UnifyT Type Check ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)
typeDictionaryForBindingGroup moduleName vals = do
let
-- Map each declaration to a name/value pair, with an optional type, if the declaration is typed
es = map isTyped vals
-- Filter the typed and untyped declarations
- typed = filter (isJust . snd . snd) es
- untyped = filter (isNothing . snd . snd) es
+ untyped = lefts es
+ typed = rights es
-- Make a map of names to typed declarations
- typedDict = map (\(ident, (_, Just (ty, _))) -> (ident, ty)) typed
+ typedDict = map (\(ident, (_, ty, _)) -> (ident, ty)) typed
-- Create fresh unification variables for the types of untyped declarations
untypedNames <- replicateM (length untyped) fresh
@@ -213,37 +224,33 @@ typeDictionaryForBindingGroup moduleName vals = do
untypedDict = zip (map fst untyped) untypedNames
-- Create the dictionary of all name/type pairs, which will be added to the environment during type checking
dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable, Undefined))) $ typedDict ++ untypedDict)
- return (es, dict, untypedDict)
-
-typeForBindingGroupElement :: ModuleName -> (Ident, (Expr, Maybe (Type, Bool))) -> M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> [(Ident, Type)] -> UnifyT Type Check (Ident, (Expr, Type))
-typeForBindingGroupElement moduleName el dict untypedDict =
- -- If the declaration is a function, it has access to other values in the binding group.
- -- If not, the generated code might fail at runtime since those values might be undefined.
- case el of
- -- Typed declarations
- (ident, (val', Just (ty, checkType))) -> do
- -- Kind check
- kind <- liftCheck $ kindOf moduleName ty
- guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
- -- Check the type with the new names in scope
- ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
- val'' <- if checkType
- then bindNames dict $ TypedValue True <$> check val' ty' <*> pure ty'
- else return (TypedValue False val' ty')
- return (ident, (val'', ty'))
- -- Untyped declarations
- (ident, (val', Nothing)) -> do
- -- Infer the type with the new names in scope
- TypedValue _ val'' ty <- bindNames dict $ infer val'
- ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
- return (ident, (TypedValue True val'' ty, ty))
+ return (untyped, typed, dict, untypedDict)
+
+checkTypedBindingGroupElement :: ModuleName -> (Ident, (Expr, Type, Bool)) -> TypeData -> UnifyT Type Check (Ident, (Expr, Type))
+checkTypedBindingGroupElement moduleName (ident, (val', ty, checkType)) dict = do
+ -- Kind check
+ kind <- liftCheck $ kindOf moduleName ty
+ guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
+ -- Check the type with the new names in scope
+ ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
+ val'' <- if checkType
+ then bindNames dict $ TypedValue True <$> check val' ty' <*> pure ty'
+ else return (TypedValue False val' ty')
+ return (ident, (val'', ty'))
+
+typeForBindingGroupElement :: (Ident, Expr) -> TypeData -> UntypedData -> UnifyT Type Check (Ident, (Expr, Type))
+typeForBindingGroupElement (ident, val) dict untypedDict = do
+ -- Infer the type with the new names in scope
+ TypedValue _ val' ty <- bindNames dict $ infer val
+ ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
+ return (ident, (TypedValue True val' ty, ty))
-- |
-- Check if a value contains a type annotation
--
-isTyped :: (Ident, Expr) -> (Ident, (Expr, Maybe (Type, Bool)))
-isTyped (name, TypedValue checkType value ty) = (name, (value, Just (ty, checkType)))
-isTyped (name, value) = (name, (value, Nothing))
+isTyped :: (Ident, Expr) -> (Either (Ident, Expr) (Ident, (Expr, Type, Bool)))
+isTyped (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType))
+isTyped (name, value) = Left (name, value)
-- |
-- Map a function over type annotations appearing inside a value
@@ -655,8 +662,8 @@ infer' (IfThenElse cond th el) = do
cond' <- check cond tyBoolean
v2@(TypedValue _ _ t2) <- infer th
v3@(TypedValue _ _ t3) <- infer el
- t2 =?= t3
- return $ TypedValue True (IfThenElse cond' v2 v3) t2
+ (v2', v3', t) <- meet v2 v3 t2 t3
+ return $ TypedValue True (IfThenElse cond' v2' v3') t
infer' (Let ds val) = do
(ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer
return $ TypedValue True (Let ds' val') valTy
@@ -692,10 +699,10 @@ inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing val : rest) ret
bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing val']) rest ret j
inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
Just moduleName <- checkCurrentModule <$> get
- (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)
- ds' <- forM es $ \e -> do
- (ident, (val', _)) <- typeForBindingGroupElement moduleName e dict untypedDict
- return $ (ident, LocalVariable, val')
+ (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)
+ ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
+ ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
+ let ds' = [(ident, LocalVariable, val') | (ident, (val', _)) <- ds1' ++ ds2']
makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
inferLetBinding seen (PositionedDeclaration pos d : ds) ret j = rethrowWithPosition pos $ do
((d' : ds'), val') <- inferLetBinding seen (d : ds) ret j
@@ -778,6 +785,8 @@ inferBinder val (PositionedBinder pos binder) =
checkBinders :: [Type] -> Type -> [CaseAlternative] -> UnifyT Type Check [CaseAlternative]
checkBinders _ _ [] = return []
checkBinders nvals ret (CaseAlternative binders grd val : bs) = do
+ guardWith (strMsg "Overlapping binders in case statement") $
+ let ns = concatMap binderNames binders in length (nub ns) == length ns
Just moduleName <- checkCurrentModule <$> get
m1 <- M.unions <$> zipWithM inferBinder nvals binders
r <- bindLocalVariables moduleName [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $ do
@@ -856,7 +865,7 @@ check' val t@(ConstrainedType constraints ty) = do
n <- liftCheck freshDictionaryName
return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
val' <- makeBindingGroupVisible $ withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->
- TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)
+ TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular False) (map (Qualified Nothing) dictNames)
constraints) $ check val ty
return $ TypedValue True (foldr (Abs . Left) val' dictNames) t
check' val (SaturatedTypeSynonym name args) = do
@@ -1119,6 +1128,23 @@ subsumes' val ty1 ty2 = do
ty1 =?= ty2
return val
+-- |
+-- Compute the meet of two types, i.e. the most general type which both types subsume.
+-- TODO: handle constrained types
+--
+meet :: Expr -> Expr -> Type -> Type -> UnifyT Type Check (Expr, Expr, Type)
+meet e1 e2 (ForAll ident t1 _) t2 = do
+ t1' <- replaceVarWithUnknown ident t1
+ meet e1 e2 t1' t2
+meet e1 e2 t1 (ForAll ident t2 _) = do
+ t2' <- replaceVarWithUnknown ident t2
+ meet e1 e2 t1 t2'
+meet e1 e2 t1 t2 = do
+ t1 =?= t2
+ return (e1, e2, t1)
+
+
+
diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs
index 35001c7..559bb89 100644
--- a/src/Language/PureScript/TypeClassDictionaries.hs
+++ b/src/Language/PureScript/TypeClassDictionaries.hs
@@ -46,6 +46,10 @@ data TypeClassDictionaryInScope
-- The type of this dictionary
--
, tcdType :: TypeClassDictionaryType
+ -- |
+ -- Is this instance exported by its module?
+ --
+ , tcdExported :: Bool
} deriving (Show, Data, Typeable)
-- |
diff --git a/tests/Main.hs b/tests/Main.hs
index debd733..390dab7 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -12,7 +12,7 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE DataKinds, DoAndIfThenElse #-}
module Main (main) where
@@ -34,15 +34,15 @@ readInput inputFiles = fmap (fmap concat . sequence) $ forM inputFiles $ \inputF
text <- U.readFile inputFile
return $ P.runIndentParser inputFile P.parseModules text
-compile :: P.Options -> [FilePath] -> IO (Either String (String, String, P.Environment))
+compile :: P.Options P.Compile -> [FilePath] -> IO (Either String (String, String, P.Environment))
compile opts inputFiles = do
modules <- readInput inputFiles
case modules of
Left parseError ->
return (Left $ show parseError)
- Right ms -> return $ P.compile opts ms []
+ Right ms -> return $ P.compile opts ms []
-assert :: FilePath -> P.Options -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO ()
+assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO ()
assert preludeExterns opts inputFile f = do
e <- compile opts [preludeExterns, inputFile]
maybeErr <- f e
@@ -53,7 +53,10 @@ assert preludeExterns opts inputFile f = do
assertCompiles :: String -> FilePath -> FilePath -> IO ()
assertCompiles preludeJs preludeExterns inputFile = do
putStrLn $ "Assert " ++ inputFile ++ " compiles successfully"
- let options = P.defaultOptions { P.optionsMain = Just "Main", P.optionsModules = ["Main"], P.optionsCodeGenModules = ["Main"], P.optionsBrowserNamespace = Just "Tests" }
+ let options = P.defaultCompileOptions
+ { P.optionsMain = Just "Main"
+ , P.optionsAdditional = P.CompileOptions "Tests" ["Main"] ["Main"]
+ }
assert preludeExterns options inputFile $ either (return . Just) $ \(js, _, _) -> do
process <- findNodeProcess
result <- traverse (\node -> readProcessWithExitCode node [] (preludeJs ++ js)) process
@@ -65,7 +68,7 @@ assertCompiles preludeJs preludeExterns inputFile = do
assertDoesNotCompile :: FilePath -> FilePath -> IO ()
assertDoesNotCompile preludeExterns inputFile = do
putStrLn $ "Assert " ++ inputFile ++ " does not compile"
- assert preludeExterns (P.defaultOptions { P.optionsBrowserNamespace = Just "Tests" }) inputFile $ \e ->
+ assert preludeExterns (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) inputFile $ \e ->
case e of
Left _ -> return Nothing
Right _ -> return $ Just "Should not have compiled"
@@ -78,7 +81,7 @@ main :: IO ()
main = do
prelude <- P.preludeFilename
putStrLn "Compiling Prelude"
- preludeResult <- compile (P.defaultOptions { P.optionsBrowserNamespace = Just "Tests" }) [prelude]
+ preludeResult <- compile (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) [prelude]
case preludeResult of
Left err -> putStrLn err >> exitFailure
Right (preludeJs, exts, _) -> do
@@ -97,3 +100,4 @@ main = do
forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
assertDoesNotCompile preludeExterns (failing ++ pathSeparator : inputFile)
exitSuccess
+