summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-05-21 20:29:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-05-21 20:29:00 (GMT)
commit3e83f43466e99b1c6479b2e9bf14a6a379704c10 (patch)
treee51d87207f9015f91f40afe5fbb2f1a77d9ea010
parent5241fc61c21072ba87d7ec68ab0e8116d444269b (diff)
version 0.5.20.5.2
-rw-r--r--psc-make/Main.hs2
-rw-r--r--purescript.cabal9
-rw-r--r--src/Language/PureScript.hs31
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs2
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs198
-rw-r--r--src/Language/PureScript/CodeGen/Monad.hs43
-rw-r--r--src/Language/PureScript/Environment.hs4
-rw-r--r--src/Language/PureScript/Optimizer/Inliner.hs6
-rw-r--r--src/Language/PureScript/Scope.hs84
-rw-r--r--src/Language/PureScript/Sugar.hs15
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs47
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs26
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs9
-rw-r--r--src/Language/PureScript/Supply.hs56
-rw-r--r--src/Language/PureScript/TypeChecker.hs7
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs6
16 files changed, 245 insertions, 300 deletions
diff --git a/psc-make/Main.hs b/psc-make/Main.hs
index 7792f89..bb0ecb0 100644
--- a/psc-make/Main.hs
+++ b/psc-make/Main.hs
@@ -45,7 +45,7 @@ readInput 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)
-newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Monad, MonadIO, MonadError String)
+newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadError String)
runMake :: Make a -> IO (Either String a)
runMake = runErrorT . unMake
diff --git a/purescript.cabal b/purescript.cabal
index 9058539..186add8 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.5.1
+version: 0.5.2
cabal-version: >=1.8
build-type: Custom
license: MIT
@@ -34,8 +34,8 @@ library
Language.PureScript.Errors
Language.PureScript.Kinds
Language.PureScript.Names
+ Language.PureScript.Supply
Language.PureScript.Types
- Language.PureScript.Scope
Language.PureScript.Traversals
Language.PureScript.TypeClassDictionaries
Language.PureScript.DeadCodeElimination
@@ -53,7 +53,6 @@ library
Language.PureScript.CodeGen.Externs
Language.PureScript.CodeGen.JS
Language.PureScript.CodeGen.JS.AST
- Language.PureScript.CodeGen.Monad
Language.PureScript.Optimizer
Language.PureScript.Optimizer.Common
Language.PureScript.Optimizer.MagicDo
@@ -106,7 +105,7 @@ executable psc-make
executable psci
build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
- mtl -any, parsec -any, haskeline -any, purescript -any,
+ mtl -any, parsec -any, haskeline >= 0.7.0.0, purescript -any,
transformers -any, utf8-string -any, process -any,
xdg-basedir -any, cmdtheline -any
main-is: Main.hs
@@ -136,7 +135,7 @@ executable hierarchy
test-suite tests
build-depends: base >=4 && <5, containers -any, directory -any,
- filepath -any, mtl -any, parsec -any, purescript -any,
+ filepath -any, mtl -any, parsec -any, purescript -any,
transformers -any, utf8-string -any, process -any
type: exitcode-stdio-1.0
main-is: Main.hs
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index ba6913f..eadd44d 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -30,6 +30,7 @@ import Language.PureScript.ModuleDependencies as P
import Language.PureScript.Environment as P
import Language.PureScript.Errors as P
import Language.PureScript.DeadCodeElimination as P
+import Language.PureScript.Supply as P
import qualified Language.PureScript.Constants as C
@@ -40,7 +41,7 @@ import Data.Maybe (fromJust, fromMaybe)
import Control.Monad.Error
import Control.Monad.State.Lazy
import Control.Arrow ((&&&))
-import Control.Applicative ((<$>))
+import Control.Applicative
import qualified Data.Map as M
import qualified Data.Set as S
import System.FilePath (pathSeparator)
@@ -70,14 +71,14 @@ compile = compile' initEnvironment
compile' :: Environment -> Options -> [Module] -> Either String (String, String, Environment)
compile' env opts ms = do
(sorted, _) <- sortModules $ if optionsNoPrelude opts then ms else (map importPrelude ms)
- desugared <- stringifyErrorStack True $ desugar sorted
+ (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 elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped
let codeGenModules = moduleNameFromString `map` optionsCodeGenModules opts
let modulesToCodeGen = if null codeGenModules then elim else filter (\(Module mn _ _) -> mn `elem` codeGenModules) elim
- let js = concatMap (\m -> moduleToJs Globals opts m env') modulesToCodeGen
+ let js = evalSupply nextVar $ concat <$> mapM (\m -> moduleToJs Globals opts m env') modulesToCodeGen
let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen
js' <- generateMain env' opts js
return (prettyPrintJS js', exts, env')
@@ -165,7 +166,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, Monad m, MonadMake m) => FilePath -> Options -> [(FilePath, Module)] -> m Environment
+make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options -> [(FilePath, Module)] -> m Environment
make outputDir opts ms = do
let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)
@@ -188,15 +189,15 @@ make outputDir opts ms = do
marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
- desugared <- liftError $ stringifyErrorStack True $ zip (map fst marked) <$> desugar (map snd marked)
+ (desugared, nextVar) <- liftError $ stringifyErrorStack True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
- go initEnvironment desugared
+ evalSupplyT nextVar (go initEnvironment desugared)
where
- go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> 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') <- liftError . runCheck' opts env $ typeCheckModule Nothing m
+ (_, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m
go env' ms'
go env ((True, m@(Module moduleName' _ exps)) : ms') = do
@@ -204,18 +205,18 @@ make outputDir opts ms = do
jsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "index.js"
externsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "externs.purs"
- progress $ "Compiling " ++ runModuleName moduleName'
+ lift . progress $ "Compiling " ++ runModuleName moduleName'
- (Module _ elaborated _, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m
+ (Module _ elaborated _, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m
- regrouped <- liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
+ regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
let mod' = Module moduleName' regrouped exps
- js = prettyPrintJS $ moduleToJs CommonJS opts mod' env'
- exts = moduleToPs mod' env'
+ js <- prettyPrintJS <$> moduleToJs CommonJS opts mod' env'
+ let exts = moduleToPs mod' env'
- writeTextFile jsFile js
- writeTextFile externsFile exts
+ lift $ writeTextFile jsFile js
+ lift $ writeTextFile externsFile exts
go env' ms'
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index 52d0f7d..6757465 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -85,7 +85,7 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite
exportToPs (TypeInstanceRef ident) = do
let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =
- fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find ((== Qualified (Just moduleName) ident) . tcdName) $ typeClassDictionaries env
+ fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find ((== Qualified (Just moduleName) ident) . tcdName) $ M.elems $ typeClassDictionaries env
let constraintsText = case fromMaybe [] deps of
[] -> ""
cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 790ff61..e59d43f 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -23,26 +23,25 @@ module Language.PureScript.CodeGen.JS (
isIdent
) where
-import Data.Maybe (fromJust, fromMaybe, mapMaybe)
+import Data.Maybe (catMaybes, fromJust, fromMaybe)
import Data.Function (on)
import Data.List (nub, (\\))
-import Control.Arrow (second)
import Control.Monad (replicateM, forM)
+import Control.Applicative
import qualified Data.Map as M
import Language.PureScript.Names
import Language.PureScript.Declarations
-import Language.PureScript.CodeGen.Monad
import Language.PureScript.Options
import Language.PureScript.CodeGen.JS.AST as AST
import Language.PureScript.Types
import Language.PureScript.Optimizer
import Language.PureScript.CodeGen.Common
import Language.PureScript.Environment
-
-import qualified Language.PureScript.Scope as S
+import Language.PureScript.Supply
+import Language.PureScript.Traversals (sndM)
-- |
-- Different types of modules which are supported
@@ -53,22 +52,23 @@ data ModuleType = CommonJS | Globals
-- Generate code in the simplified Javascript intermediate representation for all declarations in a
-- module.
--
-moduleToJs :: ModuleType -> Options -> Module -> Environment -> [JS]
-moduleToJs mt opts (Module name decls (Just exps)) env = 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))))
- (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])
- ]
- _ -> []
- where
- isModuleEmpty = null jsDecls
- moduleBody = JSStringLiteral "use strict" : jsImports ++ jsDecls
- moduleExports = JSObjectLiteral $ concatMap exportToJs exps
- jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) decls)
- jsImports = map (importToJs mt opts) . (\\ [name]) . nub $ concatMap imports decls
+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) . (\\ [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 optimized
+ 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))))
+ (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])
+ ]
+ _ -> []
moduleToJs _ _ _ _ = error "Exports should have been elaborated in name desugaring"
importToJs :: ModuleType -> Options -> ModuleName -> JS
@@ -91,14 +91,17 @@ imports =
-- |
-- Generate code in the simplified Javascript intermediate representation for a declaration
--
-declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]
-declToJs opts mp (ValueDeclaration ident _ _ _ val) e =
- Just [JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))]
-declToJs opts mp (BindingGroupDeclaration vals) e =
- Just $ flip concatMap vals $ \(ident, _, val) ->
- [JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))]
-declToJs _ mp (DataDeclaration _ _ ctors) _ =
- Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->
+declToJs :: (Functor m, Applicative m, Monad m) => Options -> 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)]
+declToJs opts mp (BindingGroupDeclaration vals) e = do
+ jss <- flip mapM vals $ \(ident, _, val) -> do
+ js <- valueToJs opts mp e val
+ return $ JSVariableIntroduction (identToJs ident) (Just js)
+ return $ Just jss
+declToJs _ mp (DataDeclaration _ _ ctors) _ = do
+ return $ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->
[JSVariableIntroduction ctor (Just (go pn 0 tys []))]
where
go :: ProperName -> Integer -> [Type] -> [JS] -> JS
@@ -107,10 +110,12 @@ declToJs _ mp (DataDeclaration _ _ ctors) _ =
go pn index (_ : tys') values =
JSFunction Nothing ["value" ++ show index]
(JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])
-declToJs opts mp (DataBindingGroupDeclaration ds) e = Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds
-declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = Just [js]
+declToJs opts mp (DataBindingGroupDeclaration ds) e = do
+ jss <- mapM (\decl -> declToJs opts mp decl e) ds
+ return $ Just $ concat $ catMaybes jss
+declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = return $ Just [js]
declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e
-declToJs _ _ _ _ = Nothing
+declToJs _ _ _ _ = return Nothing
-- |
-- Generate key//value pairs for an object literal exporting values from a module.
@@ -144,22 +149,35 @@ accessorString prop | isIdent prop = JSAccessor prop
-- |
-- Generate code in the simplified Javascript intermediate representation for a value or expression.
--
-valueToJs :: Options -> ModuleName -> Environment -> Value -> JS
-valueToJs _ _ _ (NumericLiteral n) = JSNumericLiteral n
-valueToJs _ _ _ (StringLiteral s) = JSStringLiteral s
-valueToJs _ _ _ (BooleanLiteral b) = JSBooleanLiteral b
-valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs opts m e) xs)
-valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs opts m e)) ps)
-valueToJs opts m e (ObjectUpdate o ps) = extendObj (valueToJs opts m e o) (map (second (valueToJs opts m e)) ps)
-valueToJs _ m _ (Constructor name) = qualifiedToJS m (Ident . runProperName) name
-valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (valueToJs opts m e) values)
-valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)
-valueToJs opts m e (Accessor prop val) = accessorString prop (valueToJs opts m e val)
-valueToJs opts m e (App val arg) = JSApp (valueToJs opts m e val) [valueToJs opts m e arg]
-valueToJs opts m e (Let ds val) = JSApp (JSFunction Nothing [] (JSBlock (concat (mapMaybe (flip (declToJs opts m) e) ds) ++ [JSReturn $ valueToJs opts m e val]))) []
-valueToJs opts m e (Abs (Left arg) val) = JSFunction Nothing [identToJs arg] (JSBlock [JSReturn (valueToJs opts m (bindName m arg e) val)])
-valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntimeTypeChecks opts = let arg' = identToJs arg in JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn (valueToJs opts m e val)])
-valueToJs _ m _ (Var ident) = varToJs m ident
+valueToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Environment -> Value -> SupplyT m JS
+valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n
+valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s
+valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b
+valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs opts m e) xs
+valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs opts m e)) ps
+valueToJs opts m e (ObjectUpdate o ps) = do
+ obj <- valueToJs opts m e o
+ sts <- mapM (sndM (valueToJs opts m e)) ps
+ extendObj obj sts
+valueToJs _ m _ (Constructor name) = return $ qualifiedToJS m (Ident . runProperName) name
+valueToJs opts m e (Case values binders) = do
+ vals <- mapM (valueToJs opts m e) values
+ bindersToJs opts m e binders vals
+valueToJs opts m e (IfThenElse cond th el) = JSConditional <$> valueToJs opts m e cond <*> valueToJs opts m e th <*> valueToJs opts m e el
+valueToJs opts m e (Accessor prop val) = accessorString prop <$> valueToJs opts m e val
+valueToJs opts m e (App val arg) = JSApp <$> valueToJs opts m e val <*> (return <$> valueToJs opts m e arg)
+valueToJs opts m e (Let ds val) = do
+ decls <- concat . catMaybes <$> mapM (flip (declToJs opts m) e) ds
+ ret <- valueToJs opts m e val
+ return $ JSApp (JSFunction Nothing [] (JSBlock (decls ++ [JSReturn ret]))) []
+valueToJs opts m e (Abs (Left arg) val) = do
+ ret <- valueToJs opts m (bindName m arg e) val
+ return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
+valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntimeTypeChecks opts = do
+ let arg' = identToJs arg
+ ret <- valueToJs opts m e val
+ return $ JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn ret])
+valueToJs _ m _ (Var ident) = return $ varToJs m ident
valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val
valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val
valueToJs _ _ _ (TypeClassDictionary _ _ _) = error "Type class dictionary was not replaced"
@@ -168,20 +186,22 @@ valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
-- |
-- Shallow copy an object.
--
-extendObj :: JS -> [(String, JS)] -> JS
-extendObj obj sts = JSApp (JSFunction Nothing [] block) []
+extendObj :: (Functor m, Applicative m, Monad m) => JS -> [(String, JS)] -> SupplyT m JS
+extendObj obj sts = do
+ newObj <- freshName
+ key <- freshName
+ let
+ jsKey = JSVar key
+ jsNewObj = JSVar newObj
+ block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
+ objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
+ copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
+ cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
+ assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
+ stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
+ extend = map stToAssign sts
+ return $ JSApp (JSFunction Nothing [] block) []
where
- [newObj, key] = take 2 . map identToJs . S.unusedNames $ used
- used = usedNamesJS obj ++ concatMap (usedNamesJS . snd) sts
- jsKey = JSVar key
- jsNewObj = JSVar newObj
- block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
- objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
- copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
- cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
- assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
- stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
- extend = map stToAssign sts
-- |
-- Temporarily extends the environment with a single local variable name
@@ -198,7 +218,6 @@ bindNames m idents env = env { names = M.fromList [ ((m, ident), (noType, LocalV
where
noType = error "Temporary lambda variable type was read"
-
-- |
-- Generate code in the simplified Javascript intermediate representation for runtime type checks.
--
@@ -251,42 +270,31 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
-- Generate code in the simplified Javascript intermediate representation for pattern match binders
-- and guards.
--
-bindersToJs :: Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> JS
-bindersToJs opts m e binders vals = runGen (map identToJs (S.unusedNames usedNames)) $ do
- valNames <- replicateM (length vals) fresh
- jss <- forM binders $ \(CaseAlternative bs grd result) -> go valNames [JSReturn (valueToJs opts m (bindNames m (concatMap binderNames bs) e) result)] bs grd
- return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
- vals
+bindersToJs :: (Functor m, Applicative m, Monad m) => Options -> 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)
+ jss <- forM binders $ \(CaseAlternative bs grd result) -> do
+ ret <- valueToJs opts m (bindNames m (concatMap binderNames bs) e) result
+ go valNames [JSReturn ret] bs grd
+ return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
+ []
where
- usedNames = concatMap usedNamesJS vals ++ concatMap S.usedNamesCaseAlternative binders
-
- go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]
+ go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder] -> Maybe Guard -> SupplyT m [JS]
go _ done [] Nothing = return done
- go _ done [] (Just cond) = return [JSIfElse (valueToJs opts m e cond) (JSBlock done) Nothing]
+ go _ done [] (Just cond) = do
+ cond' <- valueToJs opts m e cond
+ return [JSIfElse cond' (JSBlock done) Nothing]
go (v:vs) done' (b:bs) grd = do
done'' <- go vs done' bs grd
binderToJs m e v done'' b
go _ _ _ _ = error "Invalid arguments to bindersToJs"
-- |
--- Gather all used names appearing inside a value
---
-usedNamesJS :: JS -> [Ident]
-usedNamesJS val = nub $ everythingOnJS (++) namesJS val
- where
- namesJS (JSVar name) = [Ident name]
- namesJS (JSFunction (Just name) args _) = Ident name : map Ident args
- namesJS (JSFunction Nothing args _) = map Ident args
- namesJS (JSVariableIntroduction name _) = [Ident name]
- namesJS (JSFor name _ _ _) = [Ident name]
- namesJS (JSForIn name _ _) = [Ident name]
- namesJS _ = []
-
--- |
-- Generate code in the simplified Javascript intermediate representation for a pattern match
-- binder.
--
-binderToJs :: ModuleName -> Environment -> String -> [JS] -> Binder -> Gen [JS]
+binderToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Environment -> String -> [JS] -> Binder -> SupplyT m [JS]
binderToJs _ _ _ done NullBinder = return done
binderToJs _ _ varName done (StringBinder str) =
return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
@@ -308,19 +316,19 @@ binderToJs m e varName done (ConstructorBinder ctor bs) = do
(JSBlock js)
Nothing]
where
- go :: Integer -> [JS] -> [Binder] -> Gen [JS]
+ go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder] -> SupplyT m [JS]
go _ done' [] = return done'
go index done' (binder:bs') = do
- argVar <- fresh
+ argVar <- freshName
done'' <- go (index + 1) done' bs'
js <- binderToJs m e argVar done'' binder
return (JSVariableIntroduction argVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSAccessor "values" (JSVar varName)))) : js)
binderToJs m e varName done (ObjectBinder bs) = go done bs
where
- go :: [JS] -> [(String, Binder)] -> Gen [JS]
+ go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder)] -> SupplyT m [JS]
go done' [] = return done'
go done' ((prop, binder):bs') = do
- propVar <- fresh
+ propVar <- freshName
done'' <- go done' bs'
js <- binderToJs m e propVar done'' binder
return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
@@ -328,16 +336,16 @@ binderToJs m e varName done (ArrayBinder 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 :: [JS] -> Integer -> [Binder] -> Gen [JS]
+ go :: (Functor m, Applicative m, Monad m) => [JS] -> Integer -> [Binder] -> SupplyT m [JS]
go done' _ [] = return done'
go done' index (binder:bs') = do
- elVar <- fresh
+ elVar <- freshName
done'' <- go done' (index + 1) bs'
js <- binderToJs m e elVar done'' binder
return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
binderToJs m e varName done (ConsBinder headBinder tailBinder) = do
- headVar <- fresh
- tailVar <- fresh
+ headVar <- freshName
+ tailVar <- freshName
js1 <- binderToJs m e headVar done headBinder
js2 <- binderToJs m e tailVar js1 tailBinder
return [JSIfElse (JSBinary GreaterThan (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left 0))) (JSBlock
diff --git a/src/Language/PureScript/CodeGen/Monad.hs b/src/Language/PureScript/CodeGen/Monad.hs
deleted file mode 100644
index d6b0d71..0000000
--- a/src/Language/PureScript/CodeGen/Monad.hs
+++ /dev/null
@@ -1,43 +0,0 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.CodeGen.Monad
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- Code generation monad
---
--- This monad provides a supply of fresh names which can be used to create variables.
---
------------------------------------------------------------------------------
-
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
-module Language.PureScript.CodeGen.Monad where
-
-import Control.Monad.State
-import Control.Applicative
-
--- |
--- Code generation monad data type
---
-newtype Gen a = Gen { unGen :: State [String] a } deriving (Functor, Applicative, Monad, MonadState [String])
-
--- |
--- Run a computation in the code generation monad
---
-runGen :: [String] -> Gen a -> a
-runGen names = flip evalState names . unGen
-
--- |
--- Generate a fresh name
---
-fresh :: Gen String
-fresh = do
- (s:ss) <- get
- put ss
- return s
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 687128f..a148869 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -49,7 +49,7 @@ data Environment = Environment {
-- |
-- Available type class dictionaries
--
- , typeClassDictionaries :: [TypeClassDictionaryInScope]
+ , typeClassDictionaries :: M.Map (Qualified Ident, Maybe ModuleName) TypeClassDictionaryInScope
-- |
-- Type classes
--
@@ -60,7 +60,7 @@ data Environment = Environment {
-- The initial environment with no values and only the default javascript types defined
--
initEnvironment :: Environment
-initEnvironment = Environment M.empty primTypes M.empty M.empty [] M.empty
+initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty M.empty
-- |
-- The type of a foreign import
diff --git a/src/Language/PureScript/Optimizer/Inliner.hs b/src/Language/PureScript/Optimizer/Inliner.hs
index 65dc217..0c3626e 100644
--- a/src/Language/PureScript/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/Optimizer/Inliner.hs
@@ -53,7 +53,11 @@ unThunk :: JS -> JS
unThunk = everywhereOnJS convert
where
convert :: JS -> JS
- convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body
+ convert (JSBlock []) = JSBlock []
+ convert (JSBlock jss) =
+ case (last jss) of
+ JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) []) -> JSBlock $ init jss ++ body
+ _ -> JSBlock jss
convert js = js
evaluateIifes :: JS -> JS
diff --git a/src/Language/PureScript/Scope.hs b/src/Language/PureScript/Scope.hs
deleted file mode 100644
index 50cf065..0000000
--- a/src/Language/PureScript/Scope.hs
+++ /dev/null
@@ -1,84 +0,0 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Scope
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- Utility functions for working with names in scope
---
------------------------------------------------------------------------------
-
-module Language.PureScript.Scope (
- usedNamesDecl,
- usedNamesValue,
- usedNamesBinder,
- usedNamesCaseAlternative,
- usedNamesDoNotationElement,
- unusedNames
-) where
-
-import Data.List ((\\), nub)
-
-import Language.PureScript.Declarations
-import Language.PureScript.Names
-
-usedNames :: (Declaration -> [Ident], Value -> [Ident], Binder -> [Ident], CaseAlternative -> [Ident], DoNotationElement -> [Ident])
-usedNames = everythingOnValues (++) f g h (const []) (const [])
- where
- f :: Declaration -> [Ident]
- f (ValueDeclaration name _ _ _ _) = [name]
- f _ = []
-
- g :: Value -> [Ident]
- g (Abs (Left arg) _) = [arg]
- g (Var (Qualified Nothing name)) = [name]
- g _ = []
-
- h :: Binder -> [Ident]
- h (VarBinder name) = [name]
- h _ = []
-
--- |
--- Gather all used names appearing inside a declaration
---
-usedNamesDecl :: Declaration -> [Ident]
-usedNamesDecl = let (f, _, _, _, _) = usedNames in nub . f
-
--- |
--- Gather all used names appearing inside a value
---
-usedNamesValue :: Value -> [Ident]
-usedNamesValue = let (_, f, _, _, _) = usedNames in nub . f
-
--- |
--- Gather all used names appearing inside a binder
---
-usedNamesBinder :: Binder -> [Ident]
-usedNamesBinder = let (_, _, f, _, _) = usedNames in nub . f
-
--- |
--- Gather all used names appearing inside a case alternative
---
-usedNamesCaseAlternative :: CaseAlternative -> [Ident]
-usedNamesCaseAlternative = let (_, _, _, f, _) = usedNames in nub . f
-
--- |
--- Gather all used names appearing inside a do notation element
---
-usedNamesDoNotationElement :: DoNotationElement -> [Ident]
-usedNamesDoNotationElement = let (_, _, _, _, f) = usedNames in nub . f
-
--- |
--- Generate a set of names which are unused inside a value, of the form @_{n}@ for an integer @n@
---
-unusedNames :: [Ident] -> [Ident]
-unusedNames allNames =
- let
- varNames = map (Ident . ('_' :) . show) ([1..] :: [Int])
- in
- varNames \\ allNames
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index b2db77a..5296f6e 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -16,9 +16,12 @@
module Language.PureScript.Sugar (desugar, module S) where
import Control.Monad
+import Control.Category ((>>>))
+import Control.Monad.Trans.Class
import Language.PureScript.Declarations
import Language.PureScript.Errors
+import Language.PureScript.Supply
import Language.PureScript.Sugar.Operators as S
import Language.PureScript.Sugar.DoNotation as S
@@ -28,8 +31,6 @@ import Language.PureScript.Sugar.BindingGroups as S
import Language.PureScript.Sugar.TypeClasses as S
import Language.PureScript.Sugar.Names as S
-import Control.Category ((>>>))
-
-- |
-- The desugaring pipeline proceeds as follows:
--
@@ -47,12 +48,12 @@ import Control.Category ((>>>))
--
-- * Qualify any unqualified names and types
--
-desugar :: [Module] -> Either ErrorStack [Module]
+desugar :: [Module] -> SupplyT (Either ErrorStack) [Module]
desugar = map removeSignedLiterals
>>> mapM desugarDoModule
>=> desugarCasesModule
- >=> desugarTypeDeclarationsModule
- >=> desugarImports
- >=> rebracket
+ >=> lift . (desugarTypeDeclarationsModule
+ >=> desugarImports
+ >=> rebracket)
>=> desugarTypeClasses
- >=> createBindingGroupsModule
+ >=> lift . createBindingGroupsModule
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index c8a97b4..805a00c 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -23,43 +23,41 @@ import Data.Monoid ((<>))
import Data.List (groupBy)
import Control.Applicative
-import Control.Monad ((<=<), forM, join, unless)
+import Control.Monad ((<=<), forM, join, unless, replicateM)
import Control.Monad.Error.Class
import Language.PureScript.Names
import Language.PureScript.Declarations
-import Language.PureScript.Scope
import Language.PureScript.Environment
import Language.PureScript.Errors
+import Language.PureScript.Supply
-- |
-- Replace all top-level binders in a module with case expressions.
--
-desugarCasesModule :: [Module] -> Either ErrorStack [Module]
+desugarCasesModule :: [Module] -> SupplyT (Either ErrorStack) [Module]
desugarCasesModule ms = forM ms $ \(Module name ds exps) ->
rethrow (strMsg ("Error in module " ++ show name) <>) $
- Module name <$> (desugarCases . desugarAbs $ ds) <*> pure exps
+ Module name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
-desugarAbs :: [Declaration] -> [Declaration]
-desugarAbs = map f
+desugarAbs :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
+desugarAbs = mapM f
where
- (f, _, _) = everywhereOnValues id replace id
+ (f, _, _) = everywhereOnValuesM return replace return
- replace (Abs (Right binder) val) =
- let
- used = usedNamesBinder binder ++ usedNamesValue val
- ident = head $ unusedNames used
- in
- Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing val]
- replace other = other
+ replace :: Value -> SupplyT (Either ErrorStack) Value
+ replace (Abs (Right binder) val) = do
+ ident <- Ident <$> freshName
+ return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing val]
+ replace other = return other
-- |
-- Replace all top-level binders with case expressions.
--
-desugarCases :: [Declaration] -> Either ErrorStack [Declaration]
+desugarCases :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup
where
- desugarRest :: [Declaration] -> Either ErrorStack [Declaration]
+ desugarRest :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =
(:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest
desugarRest (ValueDeclaration name nameKind bs g val : rest) =
@@ -80,7 +78,7 @@ inSameGroup (PositionedDeclaration _ d1) d2 = inSameGroup d1 d2
inSameGroup d1 (PositionedDeclaration _ d2) = inSameGroup d1 d2
inSameGroup _ _ = False
-toDecls :: [Declaration] -> Either ErrorStack [Declaration]
+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
@@ -89,7 +87,8 @@ toDecls ds@(ValueDeclaration ident _ bs _ _ : _) = do
let tuples = map toTuple ds
unless (all ((== length bs) . length . fst) tuples) $
throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing
- return [makeCaseDeclaration ident tuples]
+ caseDecl <- makeCaseDeclaration ident tuples
+ return [caseDecl]
toDecls (PositionedDeclaration pos d : ds) = do
(d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds)
return (PositionedDeclaration pos d' : ds')
@@ -104,15 +103,13 @@ toTuple (ValueDeclaration _ _ bs g val) = (bs, (g, val))
toTuple (PositionedDeclaration _ d) = toTuple d
toTuple _ = error "Not a value declaration"
-makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> Declaration
-makeCaseDeclaration ident alternatives =
+makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> SupplyT (Either ErrorStack) Declaration
+makeCaseDeclaration ident alternatives = do
+ let argPattern = length . fst . head $ alternatives
+ args <- map Ident <$> replicateM argPattern freshName
let
- argPattern = length . fst . head $ alternatives
- args = take argPattern $ unusedNames used
- used = concatMap (\(bs, (grd, val)) -> concatMap usedNamesBinder bs ++ maybe [] usedNamesValue grd ++ usedNamesValue val) alternatives
vars = map (Var . Qualified Nothing) args
binders = [ CaseAlternative bs g val | (bs, (g, val)) <- alternatives ]
value = foldr (Abs . Left) (Case vars binders) args
- in
- ValueDeclaration ident Value [] Nothing value
+ return $ ValueDeclaration ident Value [] Nothing value
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index fc665e3..f8f83c8 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -19,25 +19,27 @@ module Language.PureScript.Sugar.DoNotation (
) where
import Language.PureScript.Names
-import Language.PureScript.Scope
import Language.PureScript.Declarations
import Language.PureScript.Errors
+import Language.PureScript.Supply
import qualified Language.PureScript.Constants as C
import Control.Applicative
+import Control.Monad.Trans.Class
-- |
-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,
-- and all @DoNotationLet@ constructors with let expressions.
--
-desugarDoModule :: Module -> Either ErrorStack Module
+desugarDoModule :: Module -> SupplyT (Either ErrorStack) Module
desugarDoModule (Module mn ds exts) = Module mn <$> mapM desugarDo ds <*> pure exts
-desugarDo :: Declaration -> Either ErrorStack Declaration
-desugarDo =
+desugarDo :: Declaration -> SupplyT (Either ErrorStack) Declaration
+desugarDo (PositionedDeclaration pos d) = (PositionedDeclaration pos) <$> (rethrowWithPosition pos $ desugarDo d)
+desugarDo d =
let (f, _, _) = everywhereOnValuesM return replace return
- in f
+ in f d
where
prelude :: ModuleName
prelude = ModuleName [ProperName C.prelude]
@@ -45,28 +47,28 @@ desugarDo =
bind :: Value
bind = Var (Qualified (Just prelude) (Op (C.>>=)))
- replace :: Value -> Either ErrorStack Value
+ replace :: Value -> SupplyT (Either ErrorStack) Value
replace (Do els) = go els
+ replace (PositionedValue pos v) = PositionedValue pos <$> rethrowWithPosition pos (replace v)
replace other = return other
- go :: [DoNotationElement] -> Either ErrorStack Value
+ go :: [DoNotationElement] -> SupplyT (Either ErrorStack) Value
go [] = error "The impossible happened in desugarDo"
go [DoNotationValue val] = return val
go (DoNotationValue val : rest) = do
rest' <- go rest
return $ App (App bind val) (Abs (Left (Ident "_")) rest')
- go [DoNotationBind _ _] = Left $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing
+ go [DoNotationBind _ _] = lift $ Left $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing
go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)
go (DoNotationBind (VarBinder ident) val : rest) = do
rest' <- go rest
return $ App (App bind val) (Abs (Left ident) rest')
go (DoNotationBind binder val : rest) = do
rest' <- go rest
- let used = concatMap usedNamesDoNotationElement rest
- ident = head $ unusedNames used
+ ident <- Ident <$> freshName
return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing rest']))
- go [DoNotationLet _] = Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing
+ go [DoNotationLet _] = lift $ Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing
go (DoNotationLet ds : rest) = do
rest' <- go rest
return $ Let ds rest'
- go (PositionedDoNotationElement pos el : rest) = PositionedValue pos <$> go (el : rest)
+ go (PositionedDoNotationElement pos el : rest) = rethrowWithPosition pos $ PositionedValue pos <$> go (el : rest)
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 2f2e0c3..3e2470b 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -24,6 +24,7 @@ import Language.PureScript.Types
import Language.PureScript.Sugar.CaseDeclarations
import Language.PureScript.Environment
import Language.PureScript.Errors
+import Language.PureScript.Supply
import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)
import qualified Language.PureScript.Constants as C
@@ -40,13 +41,13 @@ import qualified Data.Map as M
type MemberMap = M.Map (ModuleName, ProperName) Declaration
-type Desugar = StateT MemberMap (Either ErrorStack)
+type Desugar = StateT MemberMap (SupplyT (Either ErrorStack))
-- |
-- Add type synonym declarations for type class dictionary types, and value declarations for type class
-- instance dictionary expressions.
--
-desugarTypeClasses :: [Module] -> Either ErrorStack [Module]
+desugarTypeClasses :: [Module] -> SupplyT (Either ErrorStack) [Module]
desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
desugarModule :: Module -> Desugar Module
@@ -160,7 +161,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
m <- get
-- Lookup the type arguments and member types for the type class
- (TypeClassDeclaration _ args implies tyDecls) <- lift $
+ (TypeClassDeclaration _ args implies tyDecls) <- lift . lift $
maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $
M.lookup (qualify mn className) m
@@ -203,7 +204,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)
memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
- _ <- lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'
+ _ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'
let memberValue = typeInstanceDictionaryEntryValue d
return (ident, memberValue)
memberToNameAndValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do
diff --git a/src/Language/PureScript/Supply.hs b/src/Language/PureScript/Supply.hs
new file mode 100644
index 0000000..c11725b
--- /dev/null
+++ b/src/Language/PureScript/Supply.hs
@@ -0,0 +1,56 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Supply
+-- Copyright : (c) Phil Freeman 2014
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- Fresh variable supply
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Language.PureScript.Supply where
+
+import Data.Functor.Identity
+
+import Control.Applicative
+import Control.Monad.State
+import Control.Monad.Error.Class
+
+newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } deriving (Functor, Applicative, Monad, MonadTrans)
+
+runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)
+runSupplyT n = flip runStateT n . unSupplyT
+
+evalSupplyT :: (Functor m) => Integer -> SupplyT m a -> m a
+evalSupplyT n = fmap fst . runSupplyT n
+
+type Supply = SupplyT Identity
+
+runSupply :: Integer -> Supply a -> (a, Integer)
+runSupply n = runIdentity . runSupplyT n
+
+evalSupply :: Integer -> Supply a -> a
+evalSupply n = runIdentity . evalSupplyT n
+
+fresh :: (Monad m) => SupplyT m Integer
+fresh = SupplyT $ do
+ n <- get
+ put (n + 1)
+ return n
+
+freshName :: (Functor m, Monad m) => SupplyT m String
+freshName = ('_' :) . show <$> fresh
+
+instance (MonadError e m) => MonadError e (SupplyT m) where
+ throwError = SupplyT . throwError
+ catchError e f = SupplyT $ catchError (unSupplyT e) (unSupplyT . f)
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 6fadcfc..63acafe 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -84,7 +84,8 @@ addTypeClass moduleName pn args implies ds =
addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()
addTypeClassDictionaries entries =
- modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }
+ let mentries = M.fromList [ ((canonicalizeDictionary entry, mn), entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ } <- entries ]
+ in modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = (typeClassDictionaries . checkEnv $ st) `M.union` mentries } }
checkTypeClassInstance :: ModuleName -> Type -> Check ()
checkTypeClassInstance _ (TypeVar _) = return ()
@@ -182,8 +183,8 @@ typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = d
guardWith (strMsg ("Fixity declaration with no binding: " ++ name)) $ M.member (moduleName, Op name) $ names env
return $ d : ds
typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _ _) : rest) = do
- env <- getEnv
- let instances = filter (\tcd -> let Qualified (Just mn) _ = tcdName tcd in moduleName == mn) (typeClassDictionaries env)
+ 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
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 86bc9a7..9caec9e 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -21,6 +21,7 @@ module Language.PureScript.TypeChecker.Monad where
import Language.PureScript.Types
import Language.PureScript.Kinds
import Language.PureScript.Names
+import Language.PureScript.Declarations (canonicalizeDictionary)
import Language.PureScript.Environment
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Options
@@ -63,7 +64,8 @@ bindTypes newNames action = do
withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a
withTypeClassDictionaries entries action = do
orig <- get
- modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }
+ let mentries = M.fromList [ ((canonicalizeDictionary entry, mn), entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ } <- entries ]
+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = (typeClassDictionaries . checkEnv $ st) `M.union` mentries } }
a <- action
modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }
return a
@@ -72,7 +74,7 @@ withTypeClassDictionaries entries action = do
-- Get the currently available list of type class dictionaries
--
getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [TypeClassDictionaryInScope]
-getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get
+getTypeClassDictionaries = M.elems . typeClassDictionaries . checkEnv <$> get
-- |
-- Temporarily bind a collection of names to local variables