summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-03-07 00:20:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-03-07 00:20:00 (GMT)
commit9d10caf3f416dc113b0ee73ff84a2f49173c6f44 (patch)
tree3907c0536e592fa5a75ca20abf9ba4e6bbc547c8
parenta1fb4a72fa49520d39868c4d7dbfd8dd0b642836 (diff)
version 0.4.40.4.4
-rw-r--r--docgen/Main.hs91
-rw-r--r--prelude/prelude.purs26
-rw-r--r--psci/Main.hs18
-rw-r--r--purescript.cabal12
-rw-r--r--src/Data/Generics/Extras.hs1
-rw-r--r--src/Language/PureScript.hs8
-rw-r--r--src/Language/PureScript/CodeGen.hs1
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs3
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs23
-rw-r--r--src/Language/PureScript/CodeGen/Optimize.hs462
-rw-r--r--src/Language/PureScript/DeadCodeElimination.hs13
-rw-r--r--src/Language/PureScript/Declarations.hs25
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs2
-rw-r--r--src/Language/PureScript/Optimizer.hs74
-rw-r--r--src/Language/PureScript/Optimizer/Blocks.hs35
-rw-r--r--src/Language/PureScript/Optimizer/Common.hs76
-rw-r--r--src/Language/PureScript/Optimizer/Inliner.hs138
-rw-r--r--src/Language/PureScript/Optimizer/MagicDo.hs153
-rw-r--r--src/Language/PureScript/Optimizer/TCO.hs102
-rw-r--r--src/Language/PureScript/Optimizer/Unused.hs31
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs13
-rw-r--r--src/Language/PureScript/Parser/Types.hs7
-rw-r--r--src/Language/PureScript/Pretty/Types.hs1
-rw-r--r--src/Language/PureScript/Prim.hs69
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs6
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs4
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs2
-rw-r--r--src/Language/PureScript/Sugar/Names.hs458
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs4
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs9
-rw-r--r--src/Language/PureScript/Sugar/TypeDeclarations.hs2
-rw-r--r--src/Language/PureScript/TypeChecker.hs9
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs1
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs15
-rw-r--r--src/Language/PureScript/TypeChecker/Synonyms.hs15
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs66
-rw-r--r--src/Language/PureScript/Types.hs37
37 files changed, 1144 insertions, 868 deletions
diff --git a/docgen/Main.hs b/docgen/Main.hs
index ca4fbbb..a2f5b42 100644
--- a/docgen/Main.hs
+++ b/docgen/Main.hs
@@ -59,55 +59,78 @@ renderModules ms = do
mapM_ renderModule ms
renderModule :: P.Module -> Docs
-renderModule (P.Module moduleName ds) = do
- headerLevel 2 $ "Module " ++ P.runModuleName moduleName
- spacer
- headerLevel 3 "Types"
- spacer
- renderTopLevel (filter isTypeDeclaration ds)
- spacer
- headerLevel 3 "Type Classes"
- spacer
- renderTopLevel (filter isTypeClassDeclaration ds)
- spacer
- headerLevel 3 "Type Class Instances"
- spacer
- renderTopLevel (filter isTypeInstanceDeclaration ds)
- spacer
- headerLevel 3 "Values"
- spacer
- renderTopLevel (filter isValueDeclaration ds)
- spacer
-
-renderTopLevel :: [P.Declaration] -> Docs
-renderTopLevel decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do
- renderDeclaration 4 decl
+renderModule (P.Module moduleName ds exps) =
+ let exported = filter (isExported exps) ds
+ in do
+ headerLevel 2 $ "Module " ++ P.runModuleName moduleName
+ spacer
+ headerLevel 3 "Types"
+ spacer
+ renderTopLevel exps (filter isTypeDeclaration exported)
+ spacer
+ headerLevel 3 "Type Classes"
+ spacer
+ renderTopLevel exps (filter isTypeClassDeclaration exported)
+ spacer
+ headerLevel 3 "Type Class Instances"
+ spacer
+ renderTopLevel exps (filter isTypeInstanceDeclaration ds)
+ spacer
+ headerLevel 3 "Values"
+ spacer
+ renderTopLevel exps (filter isValueDeclaration exported)
+ spacer
+
+isExported :: Maybe [P.DeclarationRef] -> P.Declaration -> Bool
+isExported Nothing _ = True
+isExported _ (P.TypeInstanceDeclaration _ _ _ _ _) = True
+isExported (Just exps) decl = any (matches decl) exps
+ where
+ matches (P.TypeDeclaration ident _) (P.ValueRef ident') = ident == ident'
+ matches (P.ExternDeclaration _ ident _ _) (P.ValueRef ident') = ident == ident'
+ matches (P.DataDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'
+ matches (P.ExternDataDeclaration ident _) (P.TypeRef ident' _) = ident == ident'
+ matches (P.TypeSynonymDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'
+ matches (P.TypeClassDeclaration ident _ _) (P.TypeClassRef ident') = ident == ident'
+ matches _ _ = False
+
+isDctorExported :: P.ProperName -> Maybe [P.DeclarationRef] -> P.ProperName -> Bool
+isDctorExported _ Nothing _ = True
+isDctorExported ident (Just exps) ctor = flip any exps $ \e -> case e of
+ P.TypeRef ident' Nothing -> ident == ident'
+ P.TypeRef ident' (Just ctors) -> ident == ident' && ctor `elem` ctors
+ _ -> False
+
+renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs
+renderTopLevel exps decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do
+ renderDeclaration 4 exps decl
spacer
-renderDeclaration :: Int -> P.Declaration -> Docs
-renderDeclaration n (P.TypeDeclaration ident ty) =
+renderDeclaration :: Int -> Maybe [P.DeclarationRef] -> P.Declaration -> Docs
+renderDeclaration n _ (P.TypeDeclaration ident ty) =
atIndent n $ show ident ++ " :: " ++ P.prettyPrintType ty
-renderDeclaration n (P.ExternDeclaration _ ident _ ty) =
+renderDeclaration n _ (P.ExternDeclaration _ ident _ ty) =
atIndent n $ show ident ++ " :: " ++ P.prettyPrintType ty
-renderDeclaration n (P.DataDeclaration name args ctors) = do
+renderDeclaration n exps (P.DataDeclaration name args ctors) = do
let typeName = P.runProperName name ++ " " ++ unwords args
atIndent n $ "data " ++ typeName ++ " where"
- forM_ ctors $ \(ctor, tys) ->
+ let exported = filter (isDctorExported name exps . fst) ctors
+ forM_ exported $ \(ctor, tys) ->
atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ concatMap (\ty -> P.prettyPrintType ty ++ " -> ") tys ++ typeName
-renderDeclaration n (P.ExternDataDeclaration name kind) =
+renderDeclaration n _ (P.ExternDataDeclaration name kind) =
atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind
-renderDeclaration n (P.TypeSynonymDeclaration name args ty) = do
+renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do
let typeName = P.runProperName name ++ " " ++ unwords args
atIndent n $ "type " ++ typeName ++ " = " ++ P.prettyPrintType ty
-renderDeclaration n (P.TypeClassDeclaration name args ds) = do
+renderDeclaration n exps (P.TypeClassDeclaration name args ds) = do
atIndent n $ "class " ++ P.runProperName name ++ " " ++ unwords args ++ " where"
- mapM_ (renderDeclaration (n + 2)) ds
-renderDeclaration n (P.TypeInstanceDeclaration name constraints className tys _) = do
+ mapM_ (renderDeclaration (n + 2) exps) ds
+renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys _) = do
let constraintsText = case constraints of
[] -> ""
cs -> "(" ++ intercalate "," (map (\(pn, tys') -> show pn ++ " (" ++ unwords (map (("(" ++) . (++ ")") . P.prettyPrintType) tys') ++ ")") cs) ++ ") => "
atIndent n $ constraintsText ++ "instance " ++ show name ++ " :: " ++ show className ++ " " ++ unwords (map (("(" ++) . (++ ")") . P.prettyPrintType) tys)
-renderDeclaration _ _ = return ()
+renderDeclaration _ _ _ = return ()
getName :: P.Declaration -> String
getName (P.TypeDeclaration ident _) = show ident
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index 4f6c10f..5396f15 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -780,11 +780,11 @@ module Data.String where
\}" :: Number -> Number -> String -> String
foreign import toLower "function toLower(s) {\
- \ return s.toLower();\
+ \ return s.toLowerCase();\
\}" :: String -> String
foreign import toUpper "function toUpper(s) {\
- \ return s.toUpper();\
+ \ return s.toUpperCase();\
\}" :: String -> String
foreign import trim "function trim(s) {\
@@ -909,17 +909,23 @@ module Math where
\ return Math.log(n);\
\}" :: Number -> Number
- foreign import max "function max(n){\
- \ return Math.max(n);\
- \}" :: Number -> Number
+ foreign import max "function max(n1){\
+ \ return function(n2) {\
+ \ return Math.max(n1, n2);\
+ \ }\
+ \}" :: Number -> Number -> Number
- foreign import min "function min(n){\
- \ return Math.min(n);\
- \}" :: Number -> Number
+ foreign import min "function min(n1){\
+ \ return function(n2) {\
+ \ return Math.min(n1, n2);\
+ \ }\
+ \}" :: Number -> Number -> Number
foreign import pow "function pow(n){\
- \ return Math.pow(n);\
- \}" :: Number -> Number
+ \ return function(p) {\
+ \ return Math.pow(n, p);\
+ \ }\
+ \}" :: Number -> Number -> Number
foreign import round "function round(n){\
\ return Math.round(n);\
diff --git a/psci/Main.hs b/psci/Main.hs
index 4c1d3a9..3a9e7bd 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -161,6 +161,7 @@ quitMessage = "See ya!"
-- |
-- Loads module, function, and file completions.
+-- TODO: filter names to only include exported decls
--
completion :: CompletionFunc (StateT PSCiState IO)
completion = completeWord Nothing " \t\n\r" findCompletions
@@ -171,13 +172,18 @@ completion = completeWord Nothing " \t\n\r" findCompletions
files <- listFiles str
let matches = filter (isPrefixOf str) (names ms)
return $ sortBy sorter $ map simpleCompletion matches ++ files
- getDeclName :: P.Declaration -> Maybe P.Ident
- getDeclName (P.ValueDeclaration ident _ _ _) = Just ident
- getDeclName _ = Nothing
+ getDeclName :: Maybe [P.DeclarationRef] -> P.Declaration -> Maybe P.Ident
+ getDeclName Nothing (P.ValueDeclaration ident _ _ _) = Just ident
+ getDeclName (Just exts) (P.ValueDeclaration ident _ _ _) | isExported = Just ident
+ where
+ isExported = flip any exts $ \e -> case e of
+ P.ValueRef ident' -> ident == ident'
+ _ -> False
+ getDeclName _ _ = Nothing
names :: [P.Module] -> [String]
names ms = nub [ show qual
- | P.Module moduleName ds <- ms
- , ident <- mapMaybe getDeclName ds
+ | P.Module moduleName ds exts <- ms
+ , ident <- mapMaybe (getDeclName exts) ds
, qual <- [ P.Qualified Nothing ident
, P.Qualified (Just moduleName) ident]
]
@@ -207,7 +213,7 @@ createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetB
mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing mainValue
decls = if exec then [itDecl, mainDecl] else [itDecl]
in
- P.Module moduleName $ map importDecl imports ++ decls
+ P.Module moduleName ((importDecl `map` imports) ++ decls) Nothing
-- |
-- Takes a value declaration and evaluates it with the current state.
diff --git a/purescript.cabal b/purescript.cabal
index af69628..03529ad 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.4.3.1
+version: 0.4.4
cabal-version: >=1.8
build-type: Custom
license: MIT
@@ -50,7 +50,13 @@ library
Language.PureScript.CodeGen.JS
Language.PureScript.CodeGen.JS.AST
Language.PureScript.CodeGen.Monad
- Language.PureScript.CodeGen.Optimize
+ Language.PureScript.Optimizer
+ Language.PureScript.Optimizer.Common
+ Language.PureScript.Optimizer.MagicDo
+ Language.PureScript.Optimizer.TCO
+ Language.PureScript.Optimizer.Inliner
+ Language.PureScript.Optimizer.Unused
+ Language.PureScript.Optimizer.Blocks
Language.PureScript.Parser
Language.PureScript.Parser.Common
Language.PureScript.Parser.Declarations
@@ -64,6 +70,7 @@ library
Language.PureScript.Pretty.Kinds
Language.PureScript.Pretty.Types
Language.PureScript.Pretty.Values
+ Language.PureScript.Prim
Language.PureScript.TypeChecker
Language.PureScript.TypeChecker.Kinds
Language.PureScript.TypeChecker.Monad
@@ -73,6 +80,7 @@ library
buildable: True
hs-source-dirs: src
other-modules:
+ ghc-options: -Wall -O2
executable psc
build-depends: base >=4 && <5, cmdtheline -any, containers -any,
diff --git a/src/Data/Generics/Extras.hs b/src/Data/Generics/Extras.hs
index 508dd6c..adf9892 100644
--- a/src/Data/Generics/Extras.hs
+++ b/src/Data/Generics/Extras.hs
@@ -18,7 +18,6 @@
module Data.Generics.Extras where
import Data.Data
-import Data.Maybe (fromMaybe)
-- |
-- Apply a top-down monadic transformation everywhere
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 5b2f7cf..743538b 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -33,7 +33,7 @@ import Language.PureScript.DeadCodeElimination as P
import Data.List (intercalate)
import Data.Maybe (mapMaybe)
import Control.Monad.State.Lazy
-import Control.Applicative ((<$>))
+import Control.Applicative ((<$>), (<*>), pure)
import qualified Data.Map as M
-- |
@@ -59,12 +59,12 @@ compile :: Options -> [Module] -> Either String (String, String, Environment)
compile opts ms = do
sorted <- sortModules ms
desugared <- desugar sorted
- (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName' decls) -> do
+ (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName' decls exps) -> do
modify (\s -> s { checkCurrentModule = Just moduleName' })
- Module moduleName' <$> typeCheckAll mainModuleIdent moduleName' decls
+ Module moduleName' <$> typeCheckAll mainModuleIdent moduleName' decls <*> pure exps
regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
let entryPoints = moduleNameFromString `map` optionsModules opts
- let elim = if null entryPoints then regrouped else eliminateDeadCode env entryPoints regrouped
+ let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped
let js = mapMaybe (flip (moduleToJs opts) env) elim
let exts = intercalate "\n" . map (`moduleToPs` env) $ elim
js' <- case mainModuleIdent of
diff --git a/src/Language/PureScript/CodeGen.hs b/src/Language/PureScript/CodeGen.hs
index 0540020..fb16fb5 100644
--- a/src/Language/PureScript/CodeGen.hs
+++ b/src/Language/PureScript/CodeGen.hs
@@ -23,4 +23,3 @@ module Language.PureScript.CodeGen (module C) where
import Language.PureScript.CodeGen.JS as C
import Language.PureScript.CodeGen.Externs as C
-import Language.PureScript.CodeGen.Optimize as C
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index c6023b0..e90b283 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -27,9 +27,10 @@ import Data.List (intercalate)
-- |
-- Generate foreign imports for all declarations in a module
+-- TODO: only expose items listed in "exps"
--
moduleToPs :: Module -> Environment -> String
-moduleToPs (Module mn decls) env =
+moduleToPs (Module mn decls _) env =
"module " ++ runModuleName mn ++ " where\n" ++
(intercalate "\n" . map (" " ++) . concatMap (declToPs mn env) $ decls)
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 5bd62bd..8254412 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -24,8 +24,6 @@ module Language.PureScript.CodeGen.JS (
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Function (on)
-import Data.Data (Data)
-import Data.Generics (mkQ, everything)
import Control.Arrow (second)
import Control.Monad (replicateM, forM)
@@ -41,15 +39,16 @@ import Language.PureScript.CodeGen.Monad
import Language.PureScript.Options
import Language.PureScript.CodeGen.JS.AST as AST
import Language.PureScript.Types
-import Language.PureScript.CodeGen.Optimize
+import Language.PureScript.Optimizer
import Language.PureScript.CodeGen.Common
+import Language.PureScript.Prim
-- |
-- Generate code in the simplified Javascript intermediate representation for all declarations in a
-- module.
--
moduleToJs :: Options -> Module -> Environment -> Maybe JS
-moduleToJs opts (Module name decls) env =
+moduleToJs opts (Module name decls _) env =
case jsDecls of
[] -> Nothing
_ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar "_ps")) $
@@ -63,18 +62,16 @@ moduleToJs opts (Module name decls) env =
--
declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]
declToJs opts mp (ValueDeclaration ident _ _ val) e =
- Just [ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))
- , setExportProperty ident (var ident) ]
+ Just $ export ident $ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))
declToJs opts mp (BindingGroupDeclaration vals) e =
Just $ concatMap (\(ident, val) ->
- [ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))
- , setExportProperty ident (var ident) ]
+ export ident $ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))
) vals
declToJs _ mp (DataDeclaration _ _ ctors) _ =
Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->
- [ JSVariableIntroduction ctor (Just (go pn 0 tys []))
- , setExportProperty (Escaped ctor) (JSVar ctor) ]
+ export (Escaped ctor) $ JSVariableIntroduction ctor (Just (go pn 0 tys []))
where
+ go :: ProperName -> Integer -> [Type] -> [JS] -> JS
go pn _ [] values =
JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))), ("values", JSArrayLiteral $ reverse values) ]
go pn index (_ : tys') values =
@@ -83,15 +80,15 @@ declToJs _ mp (DataDeclaration _ _ ctors) _ =
declToJs opts mp (DataBindingGroupDeclaration ds) e =
Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds
declToJs _ _ (ExternDeclaration _ ident (Just js) _) _ =
- Just [js, setExportProperty ident (var ident)]
+ Just $ export ident js
declToJs _ _ _ _ = Nothing
-- |
-- Generate code in the simplified Javascript intermediate representation for exporting a
-- declaration from a module.
--
-setExportProperty :: Ident -> JS -> JS
-setExportProperty ident = JSAssignment (accessor ident (JSVar "module"))
+export :: Ident -> JS -> [JS]
+export ident value = [ value, JSAssignment (accessor ident (JSVar "module")) (var ident) ]
-- |
-- Generate code in the simplified Javascript intermediate representation for a variable based on a
diff --git a/src/Language/PureScript/CodeGen/Optimize.hs b/src/Language/PureScript/CodeGen/Optimize.hs
deleted file mode 100644
index a814759..0000000
--- a/src/Language/PureScript/CodeGen/Optimize.hs
+++ /dev/null
@@ -1,462 +0,0 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Optimize
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- This module optimizes code in the simplified-Javascript intermediate representation.
---
--- The following optimizations are supported:
---
--- * Collapsing nested blocks
---
--- * Tail call elimination
---
--- * Inlining of (>>=) and ret for the Eff monad
---
--- * Removal of unused variables
---
--- * Removal of unnecessary thunks
---
--- * Eta conversion
---
--- * Inlining variables
---
--- * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!)
---
--- * Inlining primitive Javascript operators
---
------------------------------------------------------------------------------
-
-module Language.PureScript.CodeGen.Optimize (
- optimize
-) where
-
-import Data.Data
-import Data.List (nub)
-import Data.Maybe (fromJust, isJust, fromMaybe)
-import Data.Generics
-
-import Language.PureScript.Names
-import Language.PureScript.CodeGen.JS.AST
-import Language.PureScript.Options
-import Language.PureScript.CodeGen.Common (identToJs)
-import Language.PureScript.Types
-
--- |
--- Apply a series of optimizer passes to simplified Javascript code
---
-optimize :: Options -> JS -> JS
-optimize opts | optionsNoOptimizations opts = id
- | otherwise = untilFixedPoint $ applyAll
- [ collapseNestedBlocks
- , tco opts
- , magicDo opts
- , removeUnusedVariables
- , unThunk
- , etaConvert
- , inlineVariables
- , inlineOperator "$" $ \f x -> JSApp f [x]
- , inlineOperator "#" $ \x f -> JSApp f [x]
- , inlineOperator "!!" $ flip JSIndexer
- , inlineOperator "++" $ JSBinary Add
- , inlineCommonOperators ]
-
-applyAll :: [a -> a] -> a -> a
-applyAll = foldl1 (.)
-
-untilFixedPoint :: (Eq a) => (a -> a) -> a -> a
-untilFixedPoint f = go
- where
- go a = let a' = f a in
- if a' == a then a' else go a'
-
-replaceIdent :: (Data d) => String -> JS -> d -> d
-replaceIdent var1 js = everywhere (mkT replace)
- where
- replace (JSVar var2) | var1 == var2 = js
- replace other = other
-
-replaceIdents :: (Data d) => [(String, JS)] -> d -> d
-replaceIdents vars = everywhere (mkT replace)
- where
- replace v@(JSVar var) = fromMaybe v $ lookup var vars
- replace other = other
-
-isReassigned :: (Data d) => String -> d -> Bool
-isReassigned var1 = everything (||) (mkQ False check)
- where
- check :: JS -> Bool
- check (JSFunction _ args _) | var1 `elem` args = True
- check (JSVariableIntroduction arg _) | var1 == arg = True
- check (JSAssignment (JSVar arg) _) | var1 == arg = True
- check _ = False
-
-isRebound :: (Data d) => JS -> d -> Bool
-isRebound js d = any (`isReassigned` d) (everything (++) (mkQ [] variablesOf) js)
- where
- variablesOf (JSVar var) = [var]
- variablesOf _ = []
-
-isUsed :: (Data d) => String -> d -> Bool
-isUsed var1 = everything (||) (mkQ False check)
- where
- check :: JS -> Bool
- check (JSVar var2) | var1 == var2 = True
- check (JSAssignment target _) | var1 == targetVariable target = True
- check _ = False
-
-targetVariable :: JS -> String
-targetVariable (JSVar var) = var
-targetVariable (JSAccessor _ tgt) = targetVariable tgt
-targetVariable (JSIndexer _ tgt) = targetVariable tgt
-targetVariable _ = error "Invalid argument to targetVariable"
-
-isUpdated :: (Data d) => String -> d -> Bool
-isUpdated var1 = everything (||) (mkQ False check)
- where
- check :: JS -> Bool
- check (JSAssignment target _) | var1 == targetVariable target = True
- check _ = False
-
-shouldInline :: JS -> Bool
-shouldInline (JSVar _) = True
-shouldInline (JSNumericLiteral _) = True
-shouldInline (JSStringLiteral _) = True
-shouldInline (JSBooleanLiteral _) = True
-shouldInline (JSAccessor _ val) = shouldInline val
-shouldInline (JSIndexer index val) = shouldInline index && shouldInline val
-shouldInline _ = False
-
-removeFromBlock :: ([JS] -> [JS]) -> JS -> JS
-removeFromBlock go (JSBlock sts) = JSBlock (go sts)
-removeFromBlock _ js = js
-
-inlineVariables :: JS -> JS
-inlineVariables = everywhere (mkT $ removeFromBlock go)
- where
- go :: [JS] -> [JS]
- go [] = []
- go (JSVariableIntroduction var (Just js) : sts)
- | shouldInline js && not (isReassigned var sts) && not (isRebound js sts) && not (isUpdated var sts) =
- go (replaceIdent var js sts)
- go (s:sts) = s : go sts
-
-removeUnusedVariables :: JS -> JS
-removeUnusedVariables = everywhere (mkT $ removeFromBlock go)
- where
- go :: [JS] -> [JS]
- go [] = []
- go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts
- go (s:sts) = s : go sts
-
-etaConvert :: JS -> JS
-etaConvert = everywhere (mkT convert)
- where
- convert :: JS -> JS
- convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])
- | all shouldInline args &&
- not (any (`isRebound` block) (map JSVar idents)) &&
- not (any (`isRebound` block) args)
- = JSBlock (replaceIdents (zip idents args) body)
- convert js = js
-
-unThunk :: JS -> JS
-unThunk = everywhere (mkT convert)
- where
- convert :: JS -> JS
- convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body
- convert js = js
-
-tco :: Options -> JS -> JS
-tco opts | optionsTco opts = tco'
- | otherwise = id
-
-tco' :: JS -> JS
-tco' = everywhere (mkT convert)
- where
- tcoLabel :: String
- tcoLabel = "tco"
- tcoVar :: String -> String
- tcoVar arg = "__tco_" ++ arg
- copyVar :: String -> String
- copyVar arg = "__copy_" ++ arg
- convert :: JS -> JS
- convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =
- let
- (argss, body', replace) = collectAllFunctionArgs [] id fn
- in case () of
- _ | isTailCall name body' ->
- let
- allArgs = reverse $ concat argss
- in
- JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
- | otherwise -> js
- convert js = js
- collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)
- collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =
- collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body
- collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =
- (args : allArgs, body, f . JSFunction ident (map copyVar args))
- collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =
- collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body
- collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =
- (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))
- collectAllFunctionArgs allArgs f body = (allArgs, body, f)
- isTailCall :: String -> JS -> Bool
- isTailCall ident js =
- let
- numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js
- numSelfCallsInTailPosition = everything (+) (mkQ 0 countSelfCallsInTailPosition) js
- numSelfCallsUnderFunctions = everything (+) (mkQ 0 countSelfCallsUnderFunctions) js
- in
- numSelfCalls > 0
- && numSelfCalls == numSelfCallsInTailPosition
- && numSelfCallsUnderFunctions == 0
- where
- countSelfCalls :: JS -> Int
- countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1
- countSelfCalls _ = 0
- countSelfCallsInTailPosition :: JS -> Int
- countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
- countSelfCallsInTailPosition _ = 0
- countSelfCallsUnderFunctions (JSFunction _ _ js') = everything (+) (mkQ 0 countSelfCalls) js'
- countSelfCallsUnderFunctions _ = 0
- toLoop :: String -> [String] -> JS -> JS
- toLoop ident allArgs js = JSBlock $
- map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++
- [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhere (mkT loopify) js ]) ]
- where
- loopify :: JS -> JS
- loopify (JSReturn ret) | isSelfCall ident ret =
- let
- allArgumentValues = concat $ collectSelfCallArgs [] ret
- in
- JSBlock $ zipWith (\val arg ->
- JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs
- ++ map (\arg ->
- JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs
- ++ [ JSContinue tcoLabel ]
- loopify other = other
- collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]
- collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
- collectSelfCallArgs allArgumentValues _ = allArgumentValues
- isSelfCall :: String -> JS -> Bool
- isSelfCall ident (JSApp (JSVar ident') _) | ident == ident' = True
- isSelfCall ident (JSApp fn _) = isSelfCall ident fn
- isSelfCall _ _ = False
-
-magicDo :: Options -> JS -> JS
-magicDo opts | optionsMagicDo opts = inlineST . magicDo'
- | otherwise = id
-
--- |
--- Inline type class dictionaries for >>= and return for the Eff monad
---
--- E.g.
---
--- Prelude[">>="](dict)(m1)(function(x) {
--- return ...;
--- })
---
--- becomes
---
--- function __do {
--- var x = m1();
--- ...
--- }
---
-magicDo' :: JS -> JS
-magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
- where
- -- The name of the function block which is added to denote a do block
- fnName = "__do"
- -- Desugar monomorphic calls to >>= and return for the Eff monad
- convert :: JS -> JS
- -- Desugar return
- convert (JSApp (JSApp ret [val]) []) | isReturn ret = val
- -- Desugae >>
- convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock [JSReturn ret])]) | isBind bind =
- JSFunction (Just fnName) [] $ JSBlock [ JSApp m [], JSReturn (JSApp ret []) ]
- -- Desugar >>=
- convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =
- JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]
- -- Desugar untilE
- convert (JSApp (JSApp f [arg]) []) | isEffFunc "untilE" f =
- JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn (JSObjectLiteral []) ])) []
- -- Desugar whileE
- convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc "whileE" f =
- JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn (JSObjectLiteral []) ])) []
- convert other = other
- -- Check if an expression represents a monomorphic call to >>= for the Eff monad
- isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict effDict = True
- isBind _ = False
- -- Check if an expression represents a monomorphic call to return for the Eff monad
- isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict effDict = True
- isReturn _ = False
- -- Check if an expression represents the polymorphic >>= function
- isBindPoly (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) | prop == identToJs (Op ">>=") = True
- isBindPoly (JSIndexer (JSStringLiteral ">>=") (JSAccessor "Prelude" (JSVar "_ps"))) = True
- isBindPoly _ = False
- -- Check if an expression represents the polymorphic return function
- isRetPoly (JSAccessor "$return" (JSAccessor "Prelude" (JSVar "_ps"))) = True
- isRetPoly (JSIndexer (JSStringLiteral "return") (JSAccessor "Prelude" (JSVar "_ps"))) = True
- isRetPoly _ = False
- -- Check if an expression represents a function in the Ef module
- isEffFunc name (JSAccessor name' (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) | name == name' = True
- isEffFunc _ _ = False
- -- Module names
- prelude = ModuleName [ProperName "Prelude"]
- effModule = ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"]
- -- The name of the type class dictionary for the Monad Eff instance
- effDictName = "monadEff"
- -- Check if an expression represents the Monad Eff dictionary
- isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == effDictName = True
- isEffDict (JSApp (JSAccessor prop (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True
- isEffDict _ = False
- -- Remove __do function applications which remain after desugaring
- undo :: JS -> JS
- undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
- undo other = other
-
--- |
--- Inline functions in the ST module
---
-inlineST :: JS -> JS
-inlineST = everywhere (mkT convertBlock)
- where
- -- Look for runST blocks and inline the STRefs there.
- -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
- -- we can be more aggressive about inlining, and actually turn STRefs into local variables.
- convertBlock (JSApp f [arg]) | isSTFunc "runST" f || isSTFunc "runSTArray" f =
- let refs = nub . findSTRefsIn $ arg
- usages = findAllSTUsagesIn arg
- allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
- localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
- in everywhere (mkT $ convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg
- convertBlock other = other
- -- Convert a block in a safe way, preserving object wrappers of references,
- -- or in a more aggressive way, turning wrappers into local variables depending on the
- -- agg(ressive) parameter.
- convert agg (JSApp (JSApp f [arg]) []) | isSTFunc "newSTRef" f =
- if agg then arg else JSObjectLiteral [("value", arg)]
- convert agg (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f =
- if agg then ref else JSAccessor "value" ref
- convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc "writeSTRef" f =
- if agg then JSAssignment ref arg else JSAssignment (JSAccessor "value" ref) arg
- convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc "modifySTRef" f =
- if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor "value" ref) (JSApp func [JSAccessor "value" ref])
- convert _ (JSApp (JSApp (JSApp f [arr]) [i]) []) | isSTFunc "peekSTArray" f =
- JSIndexer i arr
- convert _ (JSApp (JSApp (JSApp (JSApp f [arr]) [i]) [val]) []) | isSTFunc "pokeSTArray" f =
- JSAssignment (JSIndexer i arr) val
- convert _ other = other
- -- Check if an expression represents a function in the ST module
- isSTFunc name (JSAccessor name' (JSAccessor "Control_Monad_ST" (JSVar "_ps"))) | name == name' = True
- isSTFunc _ _ = False
- -- Find all ST Refs initialized in this block
- findSTRefsIn = everything (++) (mkQ [] isSTRef)
- where
- isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc "newSTRef" f = [ident]
- isSTRef _ = []
- -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
- findAllSTUsagesIn = everything (++) (mkQ [] isSTUsage)
- where
- isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f = [ref]
- isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc "writeSTRef" f || isSTFunc "modifySTRef" f = [ref]
- isSTUsage _ = []
- -- Find all uses of a variable
- appearingIn ref = everything (++) (mkQ [] isVar)
- where
- isVar e@(JSVar v) | v == ref = [e]
- isVar _ = []
- -- Convert a JS value to a String if it is a JSVar
- toVar (JSVar v) = Just v
- toVar _ = Nothing
-
-collapseNestedBlocks :: JS -> JS
-collapseNestedBlocks = everywhere (mkT collapse)
- where
- collapse :: JS -> JS
- collapse (JSBlock sts) = JSBlock (concatMap go sts)
- collapse js = js
- go :: JS -> [JS]
- go (JSBlock sts) = sts
- go s = [s]
-
-inlineOperator :: String -> (JS -> JS -> JS) -> JS -> JS
-inlineOperator op f = everywhere (mkT convert)
- where
- convert :: JS -> JS
- convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y
- convert other = other
- isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar "_ps"))) | longForm == identToJs (Op op) = True
- isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | op == op' = True
- isOp _ = False
-
-inlineCommonOperators :: JS -> JS
-inlineCommonOperators = applyAll
- [ binary "numNumber" "+" "Num" tyNumber Add
- , binary "numNumber" "-" "Num" tyNumber Subtract
- , binary "numNumber" "*" "Num" tyNumber Multiply
- , binary "numNumber" "/" "Num" tyNumber Divide
- , binary "numNumber" "%" "Num" tyNumber Modulus
- , unary "numNumber" "negate" "Num" tyNumber Negate
-
- , binary "ordNumber" "<" "Ord" tyNumber LessThan
- , binary "ordNumber" ">" "Ord" tyNumber GreaterThan
- , binary "ordNumber" "<=" "Ord" tyNumber LessThanOrEqualTo
- , binary "ordNumber" ">=" "Ord" tyNumber GreaterThanOrEqualTo
-
- , binary "eqNumber" "==" "Eq" tyNumber EqualTo
- , binary "eqNumber" "/=" "Eq" tyNumber NotEqualTo
- , binary "eqString" "==" "Eq" tyString EqualTo
- , binary "eqString" "/=" "Eq" tyString NotEqualTo
- , binary "eqBoolean" "==" "Eq" tyBoolean EqualTo
- , binary "eqBoolean" "/=" "Eq" tyBoolean NotEqualTo
-
- , binaryFunction "bitsNumber" "shl" "Bits" tyNumber ShiftLeft
- , binaryFunction "bitsNumber" "shr" "Bits" tyNumber ShiftRight
- , binaryFunction "bitsNumber" "zshr" "Bits" tyNumber ZeroFillShiftRight
- , binary "bitsNumber" "&" "Bits" tyNumber BitwiseAnd
- , binary "bitsNumber" "|" "Bits" tyNumber BitwiseOr
- , binary "bitsNumber" "^" "Bits" tyNumber BitwiseXor
- , unary "bitsNumber" "complement" "Bits" tyNumber BitwiseNot
-
- , binary "boolLikeBoolean" "&&" "BoolLike" tyBoolean And
- , binary "boolLikeBoolean" "||" "BoolLike" tyBoolean Or
- , unary "boolLikeBoolean" "not" "BoolLike" tyBoolean Not
- ]
- where
- binary :: String -> String -> String -> Type -> BinaryOperator -> JS -> JS
- binary dictName opString className classTy op = everywhere (mkT convert)
- where
- convert :: JS -> JS
- convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName className classTy dict = JSBinary op x y
- convert other = other
- isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar _))) | longForm == identToJs (Op opString) = True
- isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | opString == op' = True
- isOp _ = False
- binaryFunction :: String -> String -> String -> Type -> BinaryOperator -> JS -> JS
- binaryFunction dictName fnName className classTy op = everywhere (mkT convert)
- where
- convert :: JS -> JS
- convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName className classTy dict = JSBinary op x y
- convert other = other
- isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName == fnName' = True
- isOp _ = False
- unary :: String -> String -> String -> Type -> UnaryOperator -> JS -> JS
- unary dictName fnName className classTy op = everywhere (mkT convert)
- where
- convert :: JS -> JS
- convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName className classTy dict = JSUnary op x
- convert other = other
- isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName' == fnName = True
- isOp _ = False
- isOpDict dictName className ty (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True
- isOpDict _ _ _ _ = False
diff --git a/src/Language/PureScript/DeadCodeElimination.hs b/src/Language/PureScript/DeadCodeElimination.hs
index 2afe8fb..df6cd46 100644
--- a/src/Language/PureScript/DeadCodeElimination.hs
+++ b/src/Language/PureScript/DeadCodeElimination.hs
@@ -25,22 +25,21 @@ import Data.Maybe (mapMaybe)
import Language.PureScript.Names
import Language.PureScript.Values
import Language.PureScript.Declarations
-import Language.PureScript.TypeChecker.Monad
-- |
-- Eliminate all declarations which are not a transitive dependency of the entry point module
--
-eliminateDeadCode :: Environment -> [ModuleName] -> [Module] -> [Module]
-eliminateDeadCode env entryPoints ms =
- let declarations = concatMap (declarationsByModule env) ms
+eliminateDeadCode :: [ModuleName] -> [Module] -> [Module]
+eliminateDeadCode entryPoints ms =
+ let declarations = concatMap declarationsByModule ms
(graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations
entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations
- in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed moduleName graph vertexFor entryPointVertices) ds)
+ in flip map ms $ \(Module moduleName ds exps) -> Module moduleName (filter (isUsed moduleName graph vertexFor entryPointVertices) ds) exps
type Key = (ModuleName, Either Ident ProperName)
-declarationsByModule :: Environment -> Module -> [(Key, [Key])]
-declarationsByModule env (Module moduleName ds) = concatMap go ds
+declarationsByModule :: Module -> [(Key, [Key])]
+declarationsByModule (Module moduleName ds _) = concatMap go ds
where
go :: Declaration -> [(Key, [Key])]
go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies moduleName d)]
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index c2f92c6..ca80e0b 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -40,9 +40,10 @@ data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)
data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
-- |
--- A module declaration, consisting of a module name and a list of declarations
+-- A module declaration, consisting of a module name, a list of declarations, and a list of the
+-- declarations that are explicitly imported. If the export list is Nothing, everything is exported.
--
-data Module = Module ModuleName [Declaration] deriving (Show, D.Data, D.Typeable)
+data Module = Module ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)
-- |
-- The type of a foreign import
@@ -66,22 +67,22 @@ data ForeignImportType
| TypeClassAccessorImport deriving (Show, Eq, D.Data, D.Typeable)
-- |
--- An item in a list of explicit imports
+-- An item in a list of explicit imports or exports
--
-data ImportType
+data DeclarationRef
-- |
- -- A type constructor import
+ -- A type constructor with data constructors
--
- = TypeImport ProperName (Maybe [ProperName])
+ = TypeRef ProperName (Maybe [ProperName])
-- |
- -- A declaration import
+ -- A value
--
- | NameImport Ident
+ | ValueRef Ident
-- |
- -- A type class import
+ -- A type class
--
- | TypeClassImport ProperName
- deriving (Show, D.Data, D.Typeable)
+ | TypeClassRef ProperName
+ deriving (Show, Eq, D.Data, D.Typeable)
-- |
-- The data type of declarations
@@ -126,7 +127,7 @@ data Declaration
-- |
-- A module import (module name, optional set of identifiers to import)
--
- | ImportDeclaration ModuleName (Maybe [ImportType])
+ | ImportDeclaration ModuleName (Maybe [DeclarationRef])
-- |
-- A type class declaration (name, argument, member declarations)
--
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index 7b15f40..19f7aeb 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -51,7 +51,7 @@ usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProp
imports _ = []
getModuleName :: Module -> ModuleName
-getModuleName (Module mn _) = mn
+getModuleName (Module mn _ _) = mn
-- |
-- Convert a strongly connected component of the module graph to a module
diff --git a/src/Language/PureScript/Optimizer.hs b/src/Language/PureScript/Optimizer.hs
new file mode 100644
index 0000000..ec8ad5d
--- /dev/null
+++ b/src/Language/PureScript/Optimizer.hs
@@ -0,0 +1,74 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Optimizer
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- This module optimizes code in the simplified-Javascript intermediate representation.
+--
+-- The following optimizations are supported:
+--
+-- * Collapsing nested blocks
+--
+-- * Tail call elimination
+--
+-- * Inlining of (>>=) and ret for the Eff monad
+--
+-- * Removal of unused variables
+--
+-- * Removal of unnecessary thunks
+--
+-- * Eta conversion
+--
+-- * Inlining variables
+--
+-- * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!)
+--
+-- * Inlining primitive Javascript operators
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.Optimizer (
+ optimize
+) where
+
+import Language.PureScript.CodeGen.JS.AST
+import Language.PureScript.Options
+
+import Language.PureScript.Optimizer.Common
+import Language.PureScript.Optimizer.TCO
+import Language.PureScript.Optimizer.MagicDo
+import Language.PureScript.Optimizer.Inliner
+import Language.PureScript.Optimizer.Unused
+import Language.PureScript.Optimizer.Blocks
+
+-- |
+-- Apply a series of optimizer passes to simplified Javascript code
+--
+optimize :: Options -> JS -> JS
+optimize opts | optionsNoOptimizations opts = id
+ | otherwise = untilFixedPoint $ applyAll
+ [ collapseNestedBlocks
+ , tco opts
+ , magicDo opts
+ , removeUnusedVariables
+ , unThunk
+ , etaConvert
+ , inlineVariables
+ , inlineOperator "$" $ \f x -> JSApp f [x]
+ , inlineOperator "#" $ \x f -> JSApp f [x]
+ , inlineOperator "!!" $ flip JSIndexer
+ , inlineOperator "++" $ JSBinary Add
+ , inlineCommonOperators ]
+
+untilFixedPoint :: (Eq a) => (a -> a) -> a -> a
+untilFixedPoint f = go
+ where
+ go a = let a' = f a in
+ if a' == a then a' else go a'
+
diff --git a/src/Language/PureScript/Optimizer/Blocks.hs b/src/Language/PureScript/Optimizer/Blocks.hs
new file mode 100644
index 0000000..19a5f9c
--- /dev/null
+++ b/src/Language/PureScript/Optimizer/Blocks.hs
@@ -0,0 +1,35 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Optimizer.Blocks
+-- Copyright : (c) Phil Freeman 2013-14
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- Optimizer steps for simplifying Javascript blocks
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.Optimizer.Blocks (
+ collapseNestedBlocks
+) where
+
+import Data.Generics
+
+import Language.PureScript.CodeGen.JS.AST
+
+-- |
+-- Collapse blocks which appear nested directly below another block
+--
+collapseNestedBlocks :: JS -> JS
+collapseNestedBlocks = everywhere (mkT collapse)
+ where
+ collapse :: JS -> JS
+ collapse (JSBlock sts) = JSBlock (concatMap go sts)
+ collapse js = js
+ go :: JS -> [JS]
+ go (JSBlock sts) = sts
+ go s = [s]
diff --git a/src/Language/PureScript/Optimizer/Common.hs b/src/Language/PureScript/Optimizer/Common.hs
new file mode 100644
index 0000000..32821e8
--- /dev/null
+++ b/src/Language/PureScript/Optimizer/Common.hs
@@ -0,0 +1,76 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Optimizer.Common
+-- Copyright : (c) Phil Freeman 2013-14
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- Common functions used by the various optimizer phases
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.Optimizer.Common where
+
+import Data.Maybe (fromMaybe)
+import Data.Generics
+
+import Language.PureScript.CodeGen.JS.AST
+
+applyAll :: [a -> a] -> a -> a
+applyAll = foldl1 (.)
+
+replaceIdent :: (Data d) => String -> JS -> d -> d
+replaceIdent var1 js = everywhere (mkT replace)
+ where
+ replace (JSVar var2) | var1 == var2 = js
+ replace other = other
+
+replaceIdents :: (Data d) => [(String, JS)] -> d -> d
+replaceIdents vars = everywhere (mkT replace)
+ where
+ replace v@(JSVar var) = fromMaybe v $ lookup var vars
+ replace other = other
+
+isReassigned :: (Data d) => String -> d -> Bool
+isReassigned var1 = everything (||) (mkQ False check)
+ where
+ check :: JS -> Bool
+ check (JSFunction _ args _) | var1 `elem` args = True
+ check (JSVariableIntroduction arg _) | var1 == arg = True
+ check (JSAssignment (JSVar arg) _) | var1 == arg = True
+ check _ = False
+
+isRebound :: (Data d) => JS -> d -> Bool
+isRebound js d = any (`isReassigned` d) (everything (++) (mkQ [] variablesOf) js)
+ where
+ variablesOf (JSVar var) = [var]
+ variablesOf _ = []
+
+isUsed :: (Data d) => String -> d -> Bool
+isUsed var1 = everything (||) (mkQ False check)
+ where
+ check :: JS -> Bool
+ check (JSVar var2) | var1 == var2 = True
+ check (JSAssignment target _) | var1 == targetVariable target = True
+ check _ = False
+
+targetVariable :: JS -> String
+targetVariable (JSVar var) = var
+targetVariable (JSAccessor _ tgt) = targetVariable tgt
+targetVariable (JSIndexer _ tgt) = targetVariable tgt
+targetVariable _ = error "Invalid argument to targetVariable"
+
+isUpdated :: (Data d) => String -> d -> Bool
+isUpdated var1 = everything (||) (mkQ False check)
+ where
+ check :: JS -> Bool
+ check (JSAssignment target _) | var1 == targetVariable target = True
+ check _ = False
+
+removeFromBlock :: ([JS] -> [JS]) -> JS -> JS
+removeFromBlock go (JSBlock sts) = JSBlock (go sts)
+removeFromBlock _ js = js
diff --git a/src/Language/PureScript/Optimizer/Inliner.hs b/src/Language/PureScript/Optimizer/Inliner.hs
new file mode 100644
index 0000000..47898bc
--- /dev/null
+++ b/src/Language/PureScript/Optimizer/Inliner.hs
@@ -0,0 +1,138 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Optimizer.Inliner
+-- Copyright : (c) Phil Freeman 2013-14
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- This module provides basic inlining capabilities
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.Optimizer.Inliner (
+ inlineVariables,
+ inlineOperator,
+ inlineCommonOperators,
+ etaConvert,
+ unThunk
+) where
+
+import Data.Generics
+
+import Language.PureScript.CodeGen.JS.AST
+import Language.PureScript.CodeGen.Common (identToJs)
+import Language.PureScript.Optimizer.Common
+import Language.PureScript.Names
+
+shouldInline :: JS -> Bool
+shouldInline (JSVar _) = True
+shouldInline (JSNumericLiteral _) = True
+shouldInline (JSStringLiteral _) = True
+shouldInline (JSBooleanLiteral _) = True
+shouldInline (JSAccessor _ val) = shouldInline val
+shouldInline (JSIndexer index val) = shouldInline index && shouldInline val
+shouldInline _ = False
+
+etaConvert :: JS -> JS
+etaConvert = everywhere (mkT convert)
+ where
+ convert :: JS -> JS
+ convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])
+ | all shouldInline args &&
+ not (any (`isRebound` block) (map JSVar idents)) &&
+ not (any (`isRebound` block) args)
+ = JSBlock (replaceIdents (zip idents args) body)
+ convert js = js
+
+unThunk :: JS -> JS
+unThunk = everywhere (mkT convert)
+ where
+ convert :: JS -> JS
+ convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body
+ convert js = js
+
+inlineVariables :: JS -> JS
+inlineVariables = everywhere (mkT $ removeFromBlock go)
+ where
+ go :: [JS] -> [JS]
+ go [] = []
+ go (JSVariableIntroduction var (Just js) : sts)
+ | shouldInline js && not (isReassigned var sts) && not (isRebound js sts) && not (isUpdated var sts) =
+ go (replaceIdent var js sts)
+ go (s:sts) = s : go sts
+
+inlineOperator :: String -> (JS -> JS -> JS) -> JS -> JS
+inlineOperator op f = everywhere (mkT convert)
+ where
+ convert :: JS -> JS
+ convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y
+ convert other = other
+ isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar "_ps"))) | longForm == identToJs (Op op) = True
+ isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | op == op' = True
+ isOp _ = False
+
+inlineCommonOperators :: JS -> JS
+inlineCommonOperators = applyAll
+ [ binary "numNumber" "+" Add
+ , binary "numNumber" "-" Subtract
+ , binary "numNumber" "*" Multiply
+ , binary "numNumber" "/" Divide
+ , binary "numNumber" "%" Modulus
+ , unary "numNumber" "negate" Negate
+
+ , binary "ordNumber" "<" LessThan
+ , binary "ordNumber" ">" GreaterThan
+ , binary "ordNumber" "<=" LessThanOrEqualTo
+ , binary "ordNumber" ">=" GreaterThanOrEqualTo
+
+ , binary "eqNumber" "==" EqualTo
+ , binary "eqNumber" "/=" NotEqualTo
+ , binary "eqString" "==" EqualTo
+ , binary "eqString" "/=" NotEqualTo
+ , binary "eqBoolean" "==" EqualTo
+ , binary "eqBoolean" "/=" NotEqualTo
+
+ , binaryFunction "bitsNumber" "shl" ShiftLeft
+ , binaryFunction "bitsNumber" "shr" ShiftRight
+ , binaryFunction "bitsNumber" "zshr" ZeroFillShiftRight
+ , binary "bitsNumber" "&" BitwiseAnd
+ , binary "bitsNumber" "|" BitwiseOr
+ , binary "bitsNumber" "^" BitwiseXor
+ , unary "bitsNumber" "complement" BitwiseNot
+
+ , binary "boolLikeBoolean" "&&" And
+ , binary "boolLikeBoolean" "||" Or
+ , unary "boolLikeBoolean" "not" Not
+ ]
+ where
+ binary :: String -> String -> BinaryOperator -> JS -> JS
+ binary dictName opString op = everywhere (mkT convert)
+ where
+ convert :: JS -> JS
+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
+ convert other = other
+ isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar _))) | longForm == identToJs (Op opString) = True
+ isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | opString == op' = True
+ isOp _ = False
+ binaryFunction :: String -> String -> BinaryOperator -> JS -> JS
+ binaryFunction dictName fnName op = everywhere (mkT convert)
+ where
+ convert :: JS -> JS
+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
+ convert other = other
+ isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName == fnName' = True
+ isOp _ = False
+ unary :: String -> String -> UnaryOperator -> JS -> JS
+ unary dictName fnName op = everywhere (mkT convert)
+ where
+ convert :: JS -> JS
+ convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x
+ convert other = other
+ isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName' == fnName = True
+ isOp _ = False
+ isOpDict dictName (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True
+ isOpDict _ _ = False
diff --git a/src/Language/PureScript/Optimizer/MagicDo.hs b/src/Language/PureScript/Optimizer/MagicDo.hs
new file mode 100644
index 0000000..61d934f
--- /dev/null
+++ b/src/Language/PureScript/Optimizer/MagicDo.hs
@@ -0,0 +1,153 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Optimizer.MagicDo
+-- Copyright : (c) Phil Freeman 2013-14
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- This module implements the "Magic Do" optimization, which inlines calls to return
+-- and bind for the Eff monad, as well as some of its actions.
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.Optimizer.MagicDo (
+ magicDo
+) where
+
+import Data.List (nub)
+import Data.Maybe (fromJust, isJust)
+import Data.Generics
+
+import Language.PureScript.Options
+import Language.PureScript.CodeGen.JS.AST
+import Language.PureScript.CodeGen.Common (identToJs)
+import Language.PureScript.Names
+
+magicDo :: Options -> JS -> JS
+magicDo opts | optionsMagicDo opts = inlineST . magicDo'
+ | otherwise = id
+
+-- |
+-- Inline type class dictionaries for >>= and return for the Eff monad
+--
+-- E.g.
+--
+-- Prelude[">>="](dict)(m1)(function(x) {
+-- return ...;
+-- })
+--
+-- becomes
+--
+-- function __do {
+-- var x = m1();
+-- ...
+-- }
+--
+magicDo' :: JS -> JS
+magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
+ where
+ -- The name of the function block which is added to denote a do block
+ fnName = "__do"
+ -- Desugar monomorphic calls to >>= and return for the Eff monad
+ convert :: JS -> JS
+ -- Desugar return
+ convert (JSApp (JSApp ret [val]) []) | isReturn ret = val
+ -- Desugae >>
+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock [JSReturn ret])]) | isBind bind =
+ JSFunction (Just fnName) [] $ JSBlock [ JSApp m [], JSReturn (JSApp ret []) ]
+ -- Desugar >>=
+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =
+ JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]
+ -- Desugar untilE
+ convert (JSApp (JSApp f [arg]) []) | isEffFunc "untilE" f =
+ JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn (JSObjectLiteral []) ])) []
+ -- Desugar whileE
+ convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc "whileE" f =
+ JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn (JSObjectLiteral []) ])) []
+ convert other = other
+ -- Check if an expression represents a monomorphic call to >>= for the Eff monad
+ isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict effDict = True
+ isBind _ = False
+ -- Check if an expression represents a monomorphic call to return for the Eff monad
+ isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict effDict = True
+ isReturn _ = False
+ -- Check if an expression represents the polymorphic >>= function
+ isBindPoly (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) | prop == identToJs (Op ">>=") = True
+ isBindPoly (JSIndexer (JSStringLiteral ">>=") (JSAccessor "Prelude" (JSVar "_ps"))) = True
+ isBindPoly _ = False
+ -- Check if an expression represents the polymorphic return function
+ isRetPoly (JSAccessor "$return" (JSAccessor "Prelude" (JSVar "_ps"))) = True
+ isRetPoly (JSIndexer (JSStringLiteral "return") (JSAccessor "Prelude" (JSVar "_ps"))) = True
+ isRetPoly _ = False
+ -- Check if an expression represents a function in the Ef module
+ isEffFunc name (JSAccessor name' (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) | name == name' = True
+ isEffFunc _ _ = False
+ -- The name of the type class dictionary for the Monad Eff instance
+ effDictName = "monadEff"
+ -- Check if an expression represents the Monad Eff dictionary
+ isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == effDictName = True
+ isEffDict (JSApp (JSAccessor prop (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True
+ isEffDict _ = False
+ -- Remove __do function applications which remain after desugaring
+ undo :: JS -> JS
+ undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
+ undo other = other
+
+-- |
+-- Inline functions in the ST module
+--
+inlineST :: JS -> JS
+inlineST = everywhere (mkT convertBlock)
+ where
+ -- Look for runST blocks and inline the STRefs there.
+ -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
+ -- we can be more aggressive about inlining, and actually turn STRefs into local variables.
+ convertBlock (JSApp f [arg]) | isSTFunc "runST" f || isSTFunc "runSTArray" f =
+ let refs = nub . findSTRefsIn $ arg
+ usages = findAllSTUsagesIn arg
+ allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
+ localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
+ in everywhere (mkT $ convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg
+ convertBlock other = other
+ -- Convert a block in a safe way, preserving object wrappers of references,
+ -- or in a more aggressive way, turning wrappers into local variables depending on the
+ -- agg(ressive) parameter.
+ convert agg (JSApp (JSApp f [arg]) []) | isSTFunc "newSTRef" f =
+ if agg then arg else JSObjectLiteral [("value", arg)]
+ convert agg (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f =
+ if agg then ref else JSAccessor "value" ref
+ convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc "writeSTRef" f =
+ if agg then JSAssignment ref arg else JSAssignment (JSAccessor "value" ref) arg
+ convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc "modifySTRef" f =
+ if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor "value" ref) (JSApp func [JSAccessor "value" ref])
+ convert _ (JSApp (JSApp (JSApp f [arr]) [i]) []) | isSTFunc "peekSTArray" f =
+ JSIndexer i arr
+ convert _ (JSApp (JSApp (JSApp (JSApp f [arr]) [i]) [val]) []) | isSTFunc "pokeSTArray" f =
+ JSAssignment (JSIndexer i arr) val
+ convert _ other = other
+ -- Check if an expression represents a function in the ST module
+ isSTFunc name (JSAccessor name' (JSAccessor "Control_Monad_ST" (JSVar "_ps"))) | name == name' = True
+ isSTFunc _ _ = False
+ -- Find all ST Refs initialized in this block
+ findSTRefsIn = everything (++) (mkQ [] isSTRef)
+ where
+ isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc "newSTRef" f = [ident]
+ isSTRef _ = []
+ -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
+ findAllSTUsagesIn = everything (++) (mkQ [] isSTUsage)
+ where
+ isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f = [ref]
+ isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc "writeSTRef" f || isSTFunc "modifySTRef" f = [ref]
+ isSTUsage _ = []
+ -- Find all uses of a variable
+ appearingIn ref = everything (++) (mkQ [] isVar)
+ where
+ isVar e@(JSVar v) | v == ref = [e]
+ isVar _ = []
+ -- Convert a JS value to a String if it is a JSVar
+ toVar (JSVar v) = Just v
+ toVar _ = Nothing
diff --git a/src/Language/PureScript/Optimizer/TCO.hs b/src/Language/PureScript/Optimizer/TCO.hs
new file mode 100644
index 0000000..e29f230
--- /dev/null
+++ b/src/Language/PureScript/Optimizer/TCO.hs
@@ -0,0 +1,102 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Optimizer.TCO
+-- Copyright : (c) Phil Freeman 2013-14
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- This module implements tail call elimination.
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.Optimizer.TCO (tco) where
+
+import Data.Generics
+
+import Language.PureScript.Options
+import Language.PureScript.CodeGen.JS.AST
+
+-- |
+-- Eliminate tail calls
+--
+tco :: Options -> JS -> JS
+tco opts | optionsTco opts = tco'
+ | otherwise = id
+
+tco' :: JS -> JS
+tco' = everywhere (mkT convert)
+ where
+ tcoLabel :: String
+ tcoLabel = "tco"
+ tcoVar :: String -> String
+ tcoVar arg = "__tco_" ++ arg
+ copyVar :: String -> String
+ copyVar arg = "__copy_" ++ arg
+ convert :: JS -> JS
+ convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =
+ let
+ (argss, body', replace) = collectAllFunctionArgs [] id fn
+ in case () of
+ _ | isTailCall name body' ->
+ let
+ allArgs = reverse $ concat argss
+ in
+ JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
+ | otherwise -> js
+ convert js = js
+ collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)
+ collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =
+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body
+ collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =
+ (args : allArgs, body, f . JSFunction ident (map copyVar args))
+ collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =
+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body
+ collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =
+ (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))
+ collectAllFunctionArgs allArgs f body = (allArgs, body, f)
+ isTailCall :: String -> JS -> Bool
+ isTailCall ident js =
+ let
+ numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js
+ numSelfCallsInTailPosition = everything (+) (mkQ 0 countSelfCallsInTailPosition) js
+ numSelfCallsUnderFunctions = everything (+) (mkQ 0 countSelfCallsUnderFunctions) js
+ in
+ numSelfCalls > 0
+ && numSelfCalls == numSelfCallsInTailPosition
+ && numSelfCallsUnderFunctions == 0
+ where
+ countSelfCalls :: JS -> Int
+ countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1
+ countSelfCalls _ = 0
+ countSelfCallsInTailPosition :: JS -> Int
+ countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
+ countSelfCallsInTailPosition _ = 0
+ countSelfCallsUnderFunctions (JSFunction _ _ js') = everything (+) (mkQ 0 countSelfCalls) js'
+ countSelfCallsUnderFunctions _ = 0
+ toLoop :: String -> [String] -> JS -> JS
+ toLoop ident allArgs js = JSBlock $
+ map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++
+ [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhere (mkT loopify) js ]) ]
+ where
+ loopify :: JS -> JS
+ loopify (JSReturn ret) | isSelfCall ident ret =
+ let
+ allArgumentValues = concat $ collectSelfCallArgs [] ret
+ in
+ JSBlock $ zipWith (\val arg ->
+ JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs
+ ++ map (\arg ->
+ JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs
+ ++ [ JSContinue tcoLabel ]
+ loopify other = other
+ collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]
+ collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
+ collectSelfCallArgs allArgumentValues _ = allArgumentValues
+ isSelfCall :: String -> JS -> Bool
+ isSelfCall ident (JSApp (JSVar ident') _) | ident == ident' = True
+ isSelfCall ident (JSApp fn _) = isSelfCall ident fn
+ isSelfCall _ _ = False
diff --git a/src/Language/PureScript/Optimizer/Unused.hs b/src/Language/PureScript/Optimizer/Unused.hs
new file mode 100644
index 0000000..58ca4c6
--- /dev/null
+++ b/src/Language/PureScript/Optimizer/Unused.hs
@@ -0,0 +1,31 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Optimizer.Unused
+-- Copyright : (c) Phil Freeman 2013-14
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- Removes unused variables
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.Optimizer.Unused (
+ removeUnusedVariables
+) where
+
+import Data.Generics
+
+import Language.PureScript.CodeGen.JS.AST
+import Language.PureScript.Optimizer.Common
+
+removeUnusedVariables :: JS -> JS
+removeUnusedVariables = everywhere (mkT $ removeFromBlock go)
+ where
+ go :: [JS] -> [JS]
+ go [] = []
+ go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts
+ go (s:sts) = s : go sts
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 4827cd2..bdb5f1d 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -88,14 +88,14 @@ parseImportDeclaration = do
reserved "import"
indented
moduleName' <- moduleName
- idents <- P.optionMaybe $ parens $ commaSep1 parseExplicitImport
+ idents <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef
return $ ImportDeclaration moduleName' idents
-parseExplicitImport :: P.Parsec String ParseState ImportType
-parseExplicitImport = NameImport <$> parseIdent
+parseDeclarationRef :: P.Parsec String ParseState DeclarationRef
+parseDeclarationRef = ValueRef <$> parseIdent
<|> do name <- properName
- dctors <- P.optionMaybe $ parens (Just <$> commaSep1 properName <|> lexeme (P.string "..") *> pure Nothing)
- return $ maybe (TypeClassImport name) (TypeImport name) dctors
+ dctors <- P.optionMaybe $ parens (lexeme (P.string "..") *> pure Nothing <|> Just <$> commaSep properName)
+ return $ maybe (TypeClassRef name) (TypeRef name) dctors
parseTypeClassDeclaration :: P.Parsec String ParseState Declaration
parseTypeClassDeclaration = do
@@ -146,9 +146,10 @@ parseModule = do
reserved "module"
indented
name <- moduleName
+ exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef
_ <- lexeme $ P.string "where"
decls <- mark (P.many (same *> parseDeclaration))
- return $ Module name decls
+ return $ Module name decls exports
-- |
-- Parse a collection of modules
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index 314dd3c..0dbaa3e 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -19,13 +19,16 @@ module Language.PureScript.Parser.Types (
parseTypeAtom
) where
+import Control.Applicative
+import Control.Monad (when, unless)
+
import Language.PureScript.Types
import Language.PureScript.Parser.State
import Language.PureScript.Parser.Common
-import Control.Applicative
+import Language.PureScript.Prim
+
import qualified Text.Parsec as P
import qualified Text.Parsec.Expr as P
-import Control.Monad (when, unless)
parseNumber :: P.Parsec String ParseState Type
parseNumber = const tyNumber <$> reserved "Number"
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index c267f44..5924019 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -28,6 +28,7 @@ import Control.Monad.Unify
import Language.PureScript.Types
import Language.PureScript.Pretty.Common
+import Language.PureScript.Prim
typeLiterals :: Pattern () Type String
typeLiterals = mkPattern match
diff --git a/src/Language/PureScript/Prim.hs b/src/Language/PureScript/Prim.hs
new file mode 100644
index 0000000..ce204d9
--- /dev/null
+++ b/src/Language/PureScript/Prim.hs
@@ -0,0 +1,69 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Prim
+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.Prim where
+
+import Language.PureScript.Kinds
+import Language.PureScript.Names
+import Language.PureScript.Types
+
+import qualified Data.Map as M
+
+-- |
+-- Type constructor for functions
+--
+tyFunction :: Type
+tyFunction = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Function")
+
+-- |
+-- Type constructor for strings
+--
+tyString :: Type
+tyString = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "String")
+
+-- |
+-- Type constructor for numbers
+--
+tyNumber :: Type
+tyNumber = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Number")
+
+-- |
+-- Type constructor for booleans
+--
+tyBoolean :: Type
+tyBoolean = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Boolean")
+
+-- |
+-- Type constructor for arrays
+--
+tyArray :: Type
+tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")
+
+-- |
+-- Smart constructor for function types
+--
+function :: Type -> Type -> Type
+function t1 = TypeApp (TypeApp tyFunction t1)
+
+-- |
+-- The primitive types in the external javascript environment with their associated kinds.
+--
+primTypes :: M.Map (Qualified ProperName) Kind
+primTypes = M.fromList [ (primName "Function" , FunKind Star (FunKind Star Star))
+ , (primName "Array" , FunKind Star Star)
+ , (primName "String" , Star)
+ , (primName "Number" , Star)
+ , (primName "Boolean" , Star) ]
+ where
+ primName name = Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName name)
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index fa5b6dd..80db161 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -25,7 +25,7 @@ import Data.Data
import Data.Graph
import Data.Generics
import Data.List (nub, intersect)
-import Control.Applicative ((<$>))
+import Control.Applicative ((<$>), (<*>), pure)
import Language.PureScript.Declarations
import Language.PureScript.Names
@@ -36,13 +36,13 @@ import Language.PureScript.Types
-- Replace all sets of mutually-recursive declarations in a module with binding groups
--
createBindingGroupsModule :: [Module] -> Either String [Module]
-createBindingGroupsModule = mapM $ \(Module name ds) -> Module name <$> createBindingGroups name ds
+createBindingGroupsModule = mapM $ \(Module name ds exps) -> Module name <$> createBindingGroups name ds <*> pure exps
-- |
-- Collapse all binding groups in a module to individual declarations
--
collapseBindingGroupsModule :: [Module] -> [Module]
-collapseBindingGroupsModule = map $ \(Module name ds) -> Module name (collapseBindingGroups ds)
+collapseBindingGroupsModule = map $ \(Module name ds exps) -> Module name (collapseBindingGroups ds) exps
-- |
-- Replace all sets of mutually-recursive declarations with binding groups
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index a0e605f..5cb4d7b 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -35,7 +35,7 @@ import Language.PureScript.Scope
-- Replace all top-level binders in a module with case expressions.
--
desugarCasesModule :: [Module] -> Either String [Module]
-desugarCasesModule ms = forM ms $ \(Module name ds) -> Module name <$> (desugarCases . desugarAbs $ ds)
+desugarCasesModule ms = forM ms $ \(Module name ds exps) -> Module name <$> (desugarCases . desugarAbs $ ds) <*> pure exps
desugarAbs :: [Declaration] -> [Declaration]
desugarAbs = everywhere (mkT replace)
@@ -54,7 +54,7 @@ desugarCases :: [Declaration] -> Either String [Declaration]
desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup
where
desugarRest :: [Declaration] -> Either String [Declaration]
- desugarRest ((TypeInstanceDeclaration name constraints className tys ds) : rest) =
+ desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =
(:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest
desugarRest (d : ds) = (:) d <$> desugarRest ds
desugarRest [] = pure []
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index b76aef1..ef305ad 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -34,8 +34,6 @@ desugarDo = everywhereM (mkM replace)
where
prelude :: ModuleName
prelude = ModuleName [ProperName "Prelude"]
- ret :: Value
- ret = Var (Qualified (Just prelude) (Ident "ret"))
bind :: Value
bind = Var (Qualified (Just prelude) (Op ">>="))
replace :: Value -> Either String Value
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index bba4a06..2f9652b 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -17,21 +17,19 @@ module Language.PureScript.Sugar.Names (
) where
import Data.Maybe (fromMaybe)
-import Data.Data
import Data.Generics (extM, mkM, everywhereM)
import Data.Generics.Extras (mkS, extS, everywhereWithContextM')
import Control.Applicative (Applicative(..), (<$>), (<*>))
-import Control.Monad (foldM)
import Control.Monad.Error
import qualified Data.Map as M
-import qualified Data.Set as S
import Language.PureScript.Declarations
import Language.PureScript.Names
import Language.PureScript.Types
import Language.PureScript.Values
+import Language.PureScript.Prim
-- |
-- The global export environment - every declaration exported from every module.
@@ -42,41 +40,41 @@ type ExportEnvironment = M.Map ModuleName Exports
-- The exported declarations from a module.
--
data Exports = Exports
- -- |
- -- The types exported from each module
- --
- { exportedTypes :: S.Set (ProperName, [ProperName])
- -- |
- -- The classes exported from each module
- --
- , exportedTypeClasses :: S.Set ProperName
- -- |
- -- The values exported from each module
- , exportedValues :: S.Set Ident
- --
- } deriving (Show)
+ -- |
+ -- The types exported from each module
+ --
+ { exportedTypes :: [(ProperName, [ProperName])]
+ -- |
+ -- The classes exported from each module
+ --
+ , exportedTypeClasses :: [ProperName]
+ -- |
+ -- The values exported from each module
+ , exportedValues :: [Ident]
+ --
+ } deriving (Show)
-- |
-- An imported environment for a particular module. This also contains the module's own members.
--
data ImportEnvironment = ImportEnvironment
- -- |
- -- Local names for types within a module mapped to to their qualified names
- --
- { importedTypes :: M.Map ProperName (Qualified ProperName)
- -- |
- -- Local names for data constructors within a module mapped to to their qualified names
- --
- , importedDataConstructors :: M.Map ProperName (Qualified ProperName)
- -- |
- -- Local names for classes within a module mapped to to their qualified names
- --
- , importedTypeClasses :: M.Map ProperName (Qualified ProperName)
- -- |
- -- Local names for values within a module mapped to to their qualified names
- --
- , importedValues :: M.Map Ident (Qualified Ident)
- } deriving (Show)
+ -- |
+ -- Local names for types within a module mapped to to their qualified names
+ --
+ { importedTypes :: M.Map ProperName (Qualified ProperName)
+ -- |
+ -- Local names for data constructors within a module mapped to to their qualified names
+ --
+ , importedDataConstructors :: M.Map ProperName (Qualified ProperName)
+ -- |
+ -- Local names for classes within a module mapped to to their qualified names
+ --
+ , importedTypeClasses :: M.Map ProperName (Qualified ProperName)
+ -- |
+ -- Local names for values within a module mapped to to their qualified names
+ --
+ , importedValues :: M.Map Ident (Qualified Ident)
+ } deriving (Show)
-- |
-- Updates the exports for a module from the global environment. If the module was not previously
@@ -84,134 +82,235 @@ data ImportEnvironment = ImportEnvironment
--
updateExportedModule :: ExportEnvironment -> ModuleName -> (Exports -> Either String Exports) -> Either String ExportEnvironment
updateExportedModule env mn update = do
- let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env
- exports' <- update exports
- return $ M.insert mn exports' env
+ let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env
+ exports' <- update exports
+ return $ M.insert mn exports' env
-- |
-- Adds an empty module to an ExportEnvironment.
--
addEmptyModule :: ExportEnvironment -> ModuleName -> ExportEnvironment
-addEmptyModule env name = M.insert name (Exports S.empty S.empty S.empty) env
+addEmptyModule env name = M.insert name (Exports [] [] []) env
-- |
-- Adds a type belonging to a module to the export environment.
--
addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either String ExportEnvironment
addType env mn name dctors = updateExportedModule env mn $ \m -> do
- types <- addExport (exportedTypes m) (name, dctors)
- return $ m { exportedTypes = types }
+ types <- addExport (exportedTypes m) (name, dctors)
+ return $ m { exportedTypes = types }
-- |
-- Adds a class to the export environment.
--
addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
addTypeClass env mn name = updateExportedModule env mn $ \m -> do
- classes <- addExport (exportedTypeClasses m) name
- return $ m { exportedTypeClasses = classes }
+ classes <- addExport (exportedTypeClasses m) name
+ return $ m { exportedTypeClasses = classes }
-- |
-- Adds a class to the export environment.
--
addValue :: ExportEnvironment -> ModuleName -> Ident -> Either String ExportEnvironment
addValue env mn name = updateExportedModule env mn $ \m -> do
- values <- addExport (exportedValues m) name
- return $ m { exportedValues = values }
+ values <- addExport (exportedValues m) name
+ return $ m { exportedValues = values }
-- |
--- Adds an export to a map of exports of that type.
+-- Adds an entry to a list of exports unless it is already present, in which case an error is
+-- returned.
--
-addExport :: (Ord s, Show s) => S.Set s -> s -> Either String (S.Set s)
+addExport :: (Eq a, Show a) => [a] -> a -> Either String [a]
addExport exports name =
- if S.member name exports
- then throwError $ "Multiple definitions for '" ++ show name ++ "'"
- else return $ S.insert name exports
+ if name `elem` exports
+ then throwError $ "Multiple definitions for '" ++ show name ++ "'"
+ else return $ name : exports
-- |
-- Replaces all local names with qualified names within a set of modules.
--
desugarImports :: [Module] -> Either String [Module]
desugarImports modules = do
- exports <- findExports modules
- mapM (renameInModule' exports) modules
- where
- renameInModule' exports m = rethrowForModule m $ do
- imports <- resolveImports exports m
- renameInModule imports m
+ unfilteredExports <- findExports modules
+ exports <- foldM filterModuleExports unfilteredExports modules
+ mapM (renameInModule' unfilteredExports exports) modules
+ where
+
+ -- Filters the exports for a module in the global exports environment so that only explicitly
+ -- exported members remain. If the module does not explicitly export anything, everything is
+ -- exported.
+ filterModuleExports :: ExportEnvironment -> Module -> Either String ExportEnvironment
+ filterModuleExports env (Module mn _ (Just exps)) = filterExports mn exps env
+ filterModuleExports env _ = return env
+
+ -- Rename and check all the names within a module. We tweak the global exports environment so
+ -- the module has access to an unfiltered list of its own members.
+ renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> Either String Module
+ renameInModule' unfilteredExports exports m@(Module mn _ _) = rethrowForModule m $ do
+ let exports' = M.update (\_ -> M.lookup mn unfilteredExports) mn exports
+ imports <- resolveImports exports' m
+ renameInModule imports exports' m
-- |
-- Rethrow an error with the name of the current module in the case of a failure
--
rethrowForModule :: Module -> Either String a -> Either String a
-rethrowForModule (Module mn _) = flip catchError $ \e -> throwError ("Error in module '" ++ show mn ++ "':\n" ++ e)
+rethrowForModule (Module mn _ _) = flip catchError $ \e -> throwError ("Error in module '" ++ show mn ++ "':\n" ++ e)
-- |
--- Replaces all local names with qualified names within a module.
+-- Replaces all local names with qualified names within a module and checks that all existing
+-- qualified names are valid.
--
-renameInModule :: ImportEnvironment -> Module -> Either String Module
-renameInModule imports (Module mn decls) =
- Module mn <$> mapM updateDecl decls >>= everywhereM (mkM updateType `extM` updateValue `extM` updateBinder `extM` updateVars)
+renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either String Module
+renameInModule imports exports (Module mn decls exps) =
+ Module mn <$> (mapM updateDecl decls >>= everywhereM (mkM updateType `extM` updateValue `extM` updateBinder `extM` updateVars)) <*> pure exps
+ where
+ updateDecl (TypeInstanceDeclaration name cs cn ts ds) =
+ TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> pure ds
+ updateDecl d = return d
+
+ updateVars :: Declaration -> Either String Declaration
+ updateVars (ValueDeclaration name [] Nothing val) =
+ ValueDeclaration name [] Nothing <$> everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val
where
- updateDecl (TypeInstanceDeclaration name cs (Qualified Nothing cn) ts ds) =
- TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> pure ds
- updateDecl d = return d
-
- updateVars :: Declaration -> Either String Declaration
- updateVars (ValueDeclaration name [] Nothing val) =
- ValueDeclaration name [] Nothing <$> everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val
- where
- bindFunctionArgs bound (Abs (Left arg) val) = return (arg : bound, Abs (Left arg) val)
- bindFunctionArgs bound (Var (Qualified Nothing ident)) | ident `notElem` bound = (,) bound <$> (Var <$> updateValueName ident)
- bindFunctionArgs bound other = return (bound, other)
- bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)
- bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)
- updateVars (ValueDeclaration name _ _ _) = error $ "Binders should have been desugared in " ++ show name
- updateVars other = return other
-
- updateValue (Constructor (Qualified Nothing nm)) =
- Constructor <$> updateDataConstructorName nm
- updateValue v = return v
-
- updateBinder (ConstructorBinder (Qualified Nothing nm) b) =
- ConstructorBinder <$> updateDataConstructorName nm <*> pure b
- updateBinder v = return v
- updateType (TypeConstructor (Qualified Nothing nm)) =
- TypeConstructor <$> updateTypeName nm
- updateType (SaturatedTypeSynonym (Qualified Nothing nm) tys) =
- SaturatedTypeSynonym <$> updateTypeName nm <*> mapM updateType tys
- updateType (ConstrainedType cs t) =
- ConstrainedType <$> updateConstraints cs <*> pure t
- updateType t = return t
- updateConstraints = mapM updateConstraint
- updateConstraint (Qualified Nothing nm, ts) = (,) <$> updateClassName nm <*> pure ts
- updateConstraint other = return other
- updateTypeName = update "type" importedTypes
- updateClassName = update "type class" importedTypeClasses
- updateValueName = update "value" importedValues
- updateDataConstructorName = update "data constructor" importedDataConstructors
- update t get nm = maybe (throwError $ "Unknown " ++ t ++ " '" ++ show nm ++ "'") return $ M.lookup nm (get imports)
+ bindFunctionArgs bound (Abs (Left arg) val') = return (arg : bound, Abs (Left arg) val')
+ bindFunctionArgs bound (Var name'@(Qualified Nothing ident)) | ident `notElem` bound = (,) bound <$> (Var <$> updateValueName name')
+ bindFunctionArgs bound (Var name'@(Qualified (Just _) _)) = (,) bound <$> (Var <$> updateValueName name')
+ bindFunctionArgs bound other = return (bound, other)
+ bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)
+ bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)
+ updateVars (ValueDeclaration name _ _ _) = error $ "Binders should have been desugared in " ++ show name
+ updateVars other = return other
+ updateValue (Constructor name) = Constructor <$> updateDataConstructorName name
+ updateValue v = return v
+ updateBinder (ConstructorBinder name b) = ConstructorBinder <$> updateDataConstructorName name <*> pure b
+ updateBinder v = return v
+ updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name
+ updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys
+ updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints cs <*> pure t
+ updateType t = return t
+ updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)
+
+ updateTypeName (Qualified Nothing name) = update "type" importedTypes name
+ updateTypeName (Qualified (Just mn') name) = do
+ modExports <- getExports mn'
+ case name `lookup` exportedTypes modExports of
+ Nothing -> throwError $ "Unknown type '" ++ show (Qualified (Just mn') name) ++ "'"
+ _ -> return $ Qualified (Just mn') name
+
+ updateDataConstructorName (Qualified Nothing name) = update "data constructor" importedDataConstructors name
+ updateDataConstructorName (Qualified (Just mn') name) = do
+ modExports <- getExports mn'
+ let allDcons = join $ snd `map` exportedTypes modExports
+ if name `elem` allDcons
+ then return $ Qualified (Just mn') name
+ else throwError $ "Unknown data constructor '" ++ show (Qualified (Just mn') name) ++ "'"
+
+ updateClassName (Qualified Nothing name) = update "type class" importedTypeClasses name
+ updateClassName (Qualified (Just mn') name) = check "type class" exportedTypeClasses mn' name
+
+ updateValueName (Qualified Nothing name) = update "value" importedValues name
+ updateValueName (Qualified (Just mn') name) = check "value" exportedValues mn' name
+
+ -- Replace an unqualified name with a qualified
+ update :: (Ord a, Show a) => String -> (ImportEnvironment -> M.Map a (Qualified a)) -> a -> Either String (Qualified a)
+ update t get name = maybe (throwError $ "Unknown " ++ t ++ " '" ++ show name ++ "'") return $ M.lookup name (get imports)
+
+ -- Check that a qualified name is valid
+ check :: (Show a, Eq a) => String -> (Exports -> [a]) -> ModuleName -> a -> Either String (Qualified a)
+ check t get mn' name = do
+ modExports <- getExports mn'
+ if name `elem` get modExports
+ then return $ Qualified (Just mn') name
+ else throwError $ "Unknown " ++ t ++ " '" ++ show (Qualified (Just mn') name) ++ "'"
+
+ -- Gets the exports for a module, or an error message if the module doesn't exist
+ getExports :: ModuleName -> Either String Exports
+ getExports mn' = maybe (throwError $ "Unknown module '" ++ show mn' ++ "'") return $ M.lookup mn' exports
-- |
-- Finds all exported declarations in a set of modules.
--
findExports :: [Module] -> Either String ExportEnvironment
-findExports = foldM addModule M.empty
+findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) primExports
+ where
+
+ -- The exported types from the Prim module
+ primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []
where
- addModule env m@(Module mn ds) = rethrowForModule m $ foldM (addDecl mn) (addEmptyModule env mn) ds
- addDecl mn env (TypeClassDeclaration tcn _ ds) = do
- env' <- addTypeClass env mn tcn
- foldM (\env'' (TypeDeclaration name _) -> addValue env'' mn name) env' ds
- addDecl mn env (DataDeclaration tn _ dcs) = addType env mn tn (map fst dcs)
- addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []
- addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
- addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
- addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
- addDecl _ env _ = return env
+ mkTypeEntry (Qualified _ name) = (name, [])
+
+ -- Add all of the exported declarations from a module to the global export environment
+ addModule :: ExportEnvironment -> Module -> Either String ExportEnvironment
+ addModule env m@(Module mn ds _) = rethrowForModule m $ foldM (addDecl mn) (addEmptyModule env mn) ds
+
+ -- Add a declaration from a module to the global export environment
+ addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either String ExportEnvironment
+ addDecl mn env (TypeClassDeclaration tcn _ ds) = do
+ env' <- addTypeClass env mn tcn
+ foldM (\env'' (TypeDeclaration name _) -> addValue env'' mn name) env' ds
+ addDecl mn env (DataDeclaration tn _ dcs) = addType env mn tn (map fst dcs)
+ addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []
+ addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
+ addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
+ addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
+ addDecl _ env _ = return env
+
+-- |
+-- Filters the exports for a module to ensure only explicit exports are kept in the global exports
+-- environment.
+--
+filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either String ExportEnvironment
+filterExports mn exps env = do
+ let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)
+ moduleExports' <- filterModule moduleExports
+ return $ M.insert mn moduleExports' env
+ where
+
+ -- Filter the exports for the specific module
+ filterModule :: Exports -> Either String Exports
+ filterModule exported = do
+ types <- foldM (filterTypes $ exportedTypes exported) [] exps
+ values <- foldM (filterValues $ exportedValues exported) [] exps
+ classes <- foldM (filterClasses $ exportedTypeClasses exported) [] exps
+ return exported { exportedTypes = types, exportedTypeClasses = classes, exportedValues = values }
+
+ -- Ensure the exported types and data constructors exist in the module and add them to the set of
+ -- exports
+ filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either String [(ProperName, [ProperName])]
+ filterTypes expTys result (TypeRef name expDcons) = do
+ dcons <- maybe (throwError $ "Cannot export undefined type '" ++ show name ++ "'") return $ name `lookup` expTys
+ dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons
+ return $ (name, dcons') : result
+ filterTypes _ result _ = return result
+
+ -- Ensure the exported data constructors exists for a type and add them to the list of exports
+ filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> Either String [ProperName]
+ filterDcons tcon exps' result name =
+ if name `elem` exps'
+ then return $ name : result
+ else throwError $ "Cannot export undefined data constructor '" ++ show name ++ "' for type '" ++ show tcon ++ "'"
+
+ -- Ensure the exported classes exist in the module and add them to the set of exports
+ filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either String [ProperName]
+ filterClasses exps' result (TypeClassRef name) =
+ if name `elem` exps'
+ then return $ name : result
+ else throwError $ "Cannot export undefined type class '" ++ show name ++ "'"
+ filterClasses _ result _ = return result
+
+ -- Ensure the exported values exist in the module and add them to the set of exports
+ filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either String [Ident]
+ filterValues exps' result (ValueRef name) =
+ if name `elem` exps'
+ then return $ name : result
+ else throwError $ "Cannot export undefined value '" ++ show name ++ "'"
+ filterValues _ result _ = return result
-- |
-- Type representing a set of declarations being explicitly imported from a module
--
-type ExplicitImports = [ImportType]
+type ExplicitImports = [DeclarationRef]
-- |
-- Finds the imports within a module, mapping the imported module name to an optional set of
@@ -219,85 +318,84 @@ type ExplicitImports = [ImportType]
--
findImports :: [Declaration] -> M.Map ModuleName (Maybe ExplicitImports)
findImports = foldl findImports' M.empty
- where
- findImports' result (ImportDeclaration mn expl) = M.insert mn expl result
- findImports' result _ = result
+ where
+ findImports' result (ImportDeclaration mn expl) = M.insert mn expl result
+ findImports' result _ = result
-- |
-- Constructs a local environment for a module.
--
resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment
-resolveImports env (Module currentModule decls) =
- foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
- where
- -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported
- scope :: M.Map ModuleName (Maybe ExplicitImports)
- scope = M.insert currentModule Nothing (findImports decls)
- resolveImport' imp (mn, i) = do
- m <- maybe (throwError $ "Cannot import unknown module '" ++ show mn ++ "'") return $ mn `M.lookup` env
- resolveImport currentModule mn m imp i
+resolveImports env (Module currentModule decls _) =
+ foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
+ where
+ -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported
+ scope :: M.Map ModuleName (Maybe ExplicitImports)
+ scope = M.insert currentModule Nothing (findImports decls)
+ resolveImport' imp (mn, i) = do
+ m <- maybe (throwError $ "Cannot import unknown module '" ++ show mn ++ "'") return $ mn `M.lookup` env
+ resolveImport currentModule mn m imp i
-- |
-- Extends the local environment for a module by resolving an import of another module.
--
resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ExplicitImports -> Either String ImportEnvironment
-resolveImport currentModule importModule exp imp i = case i of
- Nothing -> importAll imp
- (Just expl) -> foldM importExplicit imp expl
- where
-
- -- Import everything from a module
- importAll :: ImportEnvironment -> Either String ImportEnvironment
- importAll imp = do
- imp' <- foldM (\m (name, dctors) -> importExplicit m (TypeImport name (Just dctors))) imp (S.toList $ exportedTypes exp)
- imp'' <- foldM (\m name -> importExplicit m (NameImport name)) imp' (S.toList $ exportedValues exp)
- foldM (\m name -> importExplicit m (TypeClassImport name)) imp'' (S.toList $ exportedTypeClasses exp)
-
- -- Import something explicitly
- importExplicit :: ImportEnvironment -> ImportType -> Either String ImportEnvironment
- importExplicit imp (NameImport name) = do
- checkImportExists "value" values name
- values' <- updateImports (importedValues imp) name
- return $ imp { importedValues = values' }
- importExplicit imp (TypeImport name dctors) = do
- checkImportExists "type" types name
- types' <- updateImports (importedTypes imp) name
- let allDctors = allExportedDataConstructors name
- dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
- dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'
- return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
- importExplicit imp (TypeClassImport name) = do
- checkImportExists "type class" classes name
- typeClasses' <- updateImports (importedTypeClasses imp) name
- return $ imp { importedTypeClasses = typeClasses' }
-
- -- Find all exported data constructors for a given type
- allExportedDataConstructors :: ProperName -> [ProperName]
- allExportedDataConstructors name = fromMaybe [] $ name `lookup` S.toList (exportedTypes exp)
-
- -- Add something to the ImportEnvironment if it does not already exist there
- updateImports :: (Ord id, Show id) => M.Map id (Qualified id) -> id -> Either String (M.Map id (Qualified id))
- updateImports m name = case M.lookup name m of
- Nothing -> return $ M.insert name (Qualified (Just importModule) name) m
- Just x@(Qualified (Just mn) _) -> throwError $
- if mn == currentModule || importModule == currentModule
- then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just importModule) name) ++ "'"
- else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"
-
- -- The available values, types, and classes in the module being imported
- values = exportedValues exp
- types = fst `S.map` exportedTypes exp
- classes = exportedTypeClasses exp
-
- -- Ensure that an explicitly imported data constructor exists for the type it is being imported
- -- from
- checkDctorExists :: [ProperName] -> ProperName -> Either String ProperName
- checkDctorExists names = checkImportExists "data constructor" (S.fromList names)
-
- -- Check that an explicitly imported item exists in the module it is being imported from
- checkImportExists :: (Show a, Ord a, Eq a) => String -> S.Set a -> a -> Either String a
- checkImportExists t exports item =
- if item `S.member` exports
- then return item
- else throwError $ "Unable to find " ++ t ++ " '" ++ show (Qualified (Just importModule) item) ++ "'"
+resolveImport currentModule importModule exps imps = maybe importAll (foldM importExplicit imps)
+ where
+
+ -- Import everything from a module
+ importAll :: Either String ImportEnvironment
+ importAll = do
+ imp' <- foldM (\m (name, dctors) -> importExplicit m (TypeRef name (Just dctors))) imps (exportedTypes exps)
+ imp'' <- foldM (\m name -> importExplicit m (ValueRef name)) imp' (exportedValues exps)
+ foldM (\m name -> importExplicit m (TypeClassRef name)) imp'' (exportedTypeClasses exps)
+
+ -- Import something explicitly
+ importExplicit :: ImportEnvironment -> DeclarationRef -> Either String ImportEnvironment
+ importExplicit imp (ValueRef name) = do
+ _ <- checkImportExists "value" values name
+ values' <- updateImports (importedValues imp) name
+ return $ imp { importedValues = values' }
+ importExplicit imp (TypeRef name dctors) = do
+ _ <- checkImportExists "type" types name
+ types' <- updateImports (importedTypes imp) name
+ let allDctors = allExportedDataConstructors name
+ dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
+ dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'
+ return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
+ importExplicit imp (TypeClassRef name) = do
+ _ <- checkImportExists "type class" classes name
+ typeClasses' <- updateImports (importedTypeClasses imp) name
+ return $ imp { importedTypeClasses = typeClasses' }
+
+ -- Find all exported data constructors for a given type
+ allExportedDataConstructors :: ProperName -> [ProperName]
+ allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps
+
+ -- Add something to the ImportEnvironment if it does not already exist there
+ updateImports :: (Ord a, Show a) => M.Map a (Qualified a) -> a -> Either String (M.Map a (Qualified a))
+ updateImports m name = case M.lookup name m of
+ Nothing -> return $ M.insert name (Qualified (Just importModule) name) m
+ Just (Qualified Nothing _) -> error "Invalid state in updateImports"
+ Just x@(Qualified (Just mn) _) -> throwError $
+ if mn == currentModule || importModule == currentModule
+ then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just importModule) name) ++ "'"
+ else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"
+
+ -- The available values, types, and classes in the module being imported
+ values = exportedValues exps
+ types = fst `map` exportedTypes exps
+ classes = exportedTypeClasses exps
+
+ -- Ensure that an explicitly imported data constructor exists for the type it is being imported
+ -- from
+ checkDctorExists :: [ProperName] -> ProperName -> Either String ProperName
+ checkDctorExists = checkImportExists "data constructor"
+
+ -- Check that an explicitly imported item exists in the module it is being imported from
+ checkImportExists :: (Eq a, Show a) => String -> [a] -> a -> Either String a
+ checkImportExists t exports item =
+ if item `elem` exports
+ then return item
+ else throwError $ "Unable to find " ++ t ++ " '" ++ show (Qualified (Just importModule) item) ++ "'"
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index c07ca08..5320404 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -49,11 +49,11 @@ rebracket :: [Module] -> Either String [Module]
rebracket = go M.empty []
where
go _ rb [] = return . reverse $ rb
- go m rb (Module name ds : ms) = do
+ go m rb (Module name ds exps : ms) = do
m' <- M.union m <$> collectFixities m name ds
let opTable = customOperatorTable m'
ds' <- G.everywhereM' (G.mkM (matchOperators name opTable)) ds
- go m' (Module name (G.everywhere (G.mkT removeParens) ds') : rb) ms
+ go m' (Module name (G.everywhere (G.mkT removeParens) ds') exps : rb) ms
removeParens :: Value -> Value
removeParens (Parens val) = val
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 1bdc932..98812ff 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -25,6 +25,7 @@ import Language.PureScript.Types
import Language.PureScript.Values
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Sugar.CaseDeclarations
+import Language.PureScript.Prim
import qualified Data.Map as M
@@ -32,8 +33,7 @@ import Control.Applicative
import Control.Monad.State
import Control.Arrow (second)
-import Data.List (intercalate)
-import Language.PureScript.CodeGen.Common (identToJs, moduleNameToJs)
+import Language.PureScript.CodeGen.Common (identToJs)
type MemberMap = M.Map (ModuleName, ProperName) ([String], [(String, Type)])
@@ -47,7 +47,7 @@ desugarTypeClasses :: [Module] -> Either String [Module]
desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
desugarModule :: Module -> Desugar Module
-desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl name) decls
+desugarModule (Module name decls exps) = Module name <$> concat <$> mapM (desugarDecl name) decls <*> pure exps
-- |
-- Desugar type class and type class instance declarations
@@ -154,9 +154,6 @@ typeInstanceDictionaryEntryDeclaration name mn deps className tys (ValueDeclarat
lookupIdent members = maybe (Left $ "Type class " ++ show className ++ " does not have method " ++ show ident) Right $ lookup (identToJs ident) members
typeInstanceDictionaryEntryDeclaration _ _ _ _ _ _ = error "Invalid declaration in type instance definition"
-qualifiedToString :: ModuleName -> Qualified ProperName -> String
-qualifiedToString mn (Qualified _ pn) = moduleNameToJs mn ++ "_" ++ runProperName pn
-
-- |
-- Generate a name for a type class dictionary member, based on the module name, class name, type name and
-- member name
diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs
index 53c54fc..136d713 100644
--- a/src/Language/PureScript/Sugar/TypeDeclarations.hs
+++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs
@@ -30,7 +30,7 @@ import Language.PureScript.Values
-- Replace all top level type declarations in a module with type annotations
--
desugarTypeDeclarationsModule :: [Module] -> Either String [Module]
-desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarTypeDeclarations ds
+desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) -> Module name <$> desugarTypeDeclarations ds <*> pure exps
-- |
-- Replace all top level type declarations with type annotations
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 227ba92..4b34979 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -29,14 +29,13 @@ import Data.Maybe
import qualified Data.Map as M
import Control.Monad.State
import Control.Monad.Error
-import Data.Either (rights, lefts)
import Language.PureScript.Types
import Language.PureScript.Names
import Language.PureScript.Values
import Language.PureScript.Kinds
import Language.PureScript.Declarations
-import Language.PureScript.Sugar.TypeClasses
+import Language.PureScript.Prim
addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()
addDataType moduleName name args dctors ctorKind = do
@@ -78,7 +77,7 @@ addTypeClassDictionaries entries =
checkTypeClassInstance :: ModuleName -> Type -> Check ()
checkTypeClassInstance _ (TypeVar _) = return ()
-checkTypeClassInstance m (TypeConstructor ctor) = do
+checkTypeClassInstance _ (TypeConstructor ctor) = do
env <- getEnv
when (ctor `M.member` typeSynonyms env) $ throwError "Type synonym instances are disallowed"
return ()
@@ -169,7 +168,7 @@ typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = d
env <- getEnv
guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env
return $ d : ds
-typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName idents) : rest) = do
+typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _) : rest) = do
env <- getEnv
let instances = filter (\tcd ->
let Qualified (Just mn) _ = tcdName tcd in
@@ -181,11 +180,9 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident
ds <- typeCheckAll mainModuleName currentModule rest
return $ d : ds
typeCheckAll mainModuleName moduleName (d@TypeClassDeclaration{} : rest) = do
- env <- getEnv
ds <- typeCheckAll mainModuleName moduleName rest
return $ d : ds
typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration dictName deps className tys _) : rest) = do
- env <- getEnv
mapM_ (checkTypeClassInstance moduleName) tys
forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular]
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 570880f..a94e914 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -132,7 +132,6 @@ infer (TypeVar v) = do
UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
infer (TypeConstructor v) = do
env <- liftCheck getEnv
- Just moduleName <- checkCurrentModule <$> get
case M.lookup v (types env) of
Nothing -> UnifyT . lift . throwError $ "Unknown type constructor '" ++ show v ++ "'" ++ show (M.keys (types env))
Just kind -> return kind
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index d65710c..3026ac4 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -23,10 +23,9 @@ import Language.PureScript.Kinds
import Language.PureScript.Values
import Language.PureScript.Names
import Language.PureScript.Declarations
+import Language.PureScript.Prim
-import Data.Data
import Data.Maybe
-import Data.Generics (mkT, everywhere)
import Control.Applicative
import Control.Monad.State
@@ -84,20 +83,10 @@ data Environment = Environment {
} deriving (Show)
-- |
--- The basic types existing in the external javascript environment
---
-jsTypes ::M.Map (Qualified ProperName) Kind
-jsTypes = M.fromList [ (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Function"), FunKind Star (FunKind Star Star))
- , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array"), FunKind Star Star)
- , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "String"), Star)
- , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Number"), Star)
- , (Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Boolean"), Star) ]
-
--- |
-- The initial environment with no values and only the default javascript types defined
--
initEnvironment :: Environment
-initEnvironment = Environment M.empty jsTypes M.empty M.empty []
+initEnvironment = Environment M.empty primTypes M.empty M.empty []
-- |
-- Temporarily bind a collection of names to values
diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs
index fb6ae65..9da09fe 100644
--- a/src/Language/PureScript/TypeChecker/Synonyms.hs
+++ b/src/Language/PureScript/TypeChecker/Synonyms.hs
@@ -20,7 +20,6 @@ module Language.PureScript.TypeChecker.Synonyms (
import Language.PureScript.Types
import Language.PureScript.Names
-import Language.PureScript.TypeChecker.Monad (Environment(..))
import Control.Applicative ((<$>))
import Data.Maybe (fromMaybe)
@@ -33,8 +32,8 @@ import Control.Monad.Error
-- |
-- Build a type substitution for a type synonym
--
-buildTypeSubstitution :: Environment -> ModuleName -> Qualified ProperName -> Int -> Type -> Either String (Maybe Type)
-buildTypeSubstitution env moduleName name n = go n []
+buildTypeSubstitution :: Qualified ProperName -> Int -> Type -> Either String (Maybe Type)
+buildTypeSubstitution name n = go n []
where
go :: Int -> [Type] -> Type -> Either String (Maybe Type)
go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)
@@ -45,16 +44,16 @@ buildTypeSubstitution env moduleName name n = go n []
-- |
-- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor
--
-saturateTypeSynonym :: (Data d) => Environment -> ModuleName -> Qualified ProperName -> Int -> d -> Either String d
-saturateTypeSynonym env moduleName name n = everywhereM' (mkM replace)
+saturateTypeSynonym :: (Data d) => Qualified ProperName -> Int -> d -> Either String d
+saturateTypeSynonym name n = everywhereM' (mkM replace)
where
- replace t = fromMaybe t <$> buildTypeSubstitution env moduleName name n t
+ replace t = fromMaybe t <$> buildTypeSubstitution name n t
-- |
-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor
--
-saturateAllTypeSynonyms :: (Data d) => Environment -> ModuleName -> [(Qualified ProperName, Int)] -> d -> Either String d
-saturateAllTypeSynonyms env moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym env moduleName name n result) d syns
+saturateAllTypeSynonyms :: (Data d) => [(Qualified ProperName, Int)] -> d -> Either String d
+saturateAllTypeSynonyms syns d = foldM (\result (name, n) -> saturateTypeSynonym name n result) d syns
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 3252a50..2b89d35 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -56,6 +56,7 @@ import Language.PureScript.TypeChecker.Monad
import Language.PureScript.TypeChecker.Kinds
import Language.PureScript.TypeChecker.Synonyms
import Language.PureScript.Pretty
+import Language.PureScript.Prim
import Control.Monad.State
import Control.Monad.Error
@@ -106,9 +107,7 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
unifyTypes' ty f@ForAll{} = f `unifyTypes` ty
unifyTypes' (Object row1) (Object row2) = row1 =?= row2
unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
- unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do
- env <- getEnv
- Just moduleName <- checkCurrentModule <$> get
+ unifyTypes' (TypeConstructor c1) (TypeConstructor c2) =
guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (c1 == c2)
unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
t3 `unifyTypes` t5
@@ -306,10 +305,10 @@ typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String
typeHeadsAreEqual _ _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = Just []
typeHeadsAreEqual _ _ (TypeVar v) t = Just [(v, t)]
typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]
-typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
+typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2
typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1
-typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e m name args of
+typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e name args of
Left _ -> Nothing
Right t1 -> typeHeadsAreEqual m e t1 t2
typeHeadsAreEqual _ _ _ _ = Nothing
@@ -407,8 +406,6 @@ instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do
ty' <- replaceVarWithUnknown ident ty
instantiatePolyTypeWithUnknowns val ty'
instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do
- env <- getEnv
- Just moduleName <- checkCurrentModule <$> get
dicts <- getTypeClassDictionaries
(_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty
return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty')
@@ -426,18 +423,17 @@ replaceVarWithUnknown ident ty = do
-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate
-- better error messages during unification.
--
-replaceAllTypeSynonyms' :: (D.Data d) => Environment -> ModuleName -> d -> Either String d
-replaceAllTypeSynonyms' env moduleName d =
+replaceAllTypeSynonyms' :: (D.Data d) => Environment -> d -> Either String d
+replaceAllTypeSynonyms' env d =
let
syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env
in
- saturateAllTypeSynonyms env moduleName syns d
+ saturateAllTypeSynonyms syns d
replaceAllTypeSynonyms :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => (D.Data d) => d -> m d
replaceAllTypeSynonyms d = do
env <- getEnv
- Just moduleName <- checkCurrentModule <$> get
- either throwError return $ replaceAllTypeSynonyms' env moduleName d
+ either throwError return $ replaceAllTypeSynonyms' env d
-- |
-- \"Desaturate\" @SaturatedTypeSynonym@s
@@ -451,19 +447,18 @@ desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
-- |
-- Replace a type synonym and its arguments with the aliased type
--
-expandTypeSynonym' :: Environment -> ModuleName -> Qualified ProperName -> [Type] -> Either String Type
-expandTypeSynonym' env moduleName name args =
+expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either String Type
+expandTypeSynonym' env name args =
case M.lookup name (typeSynonyms env) of
Just (synArgs, body) -> do
let repl = replaceAllTypeVars (zip synArgs args) body
- replaceAllTypeSynonyms' env moduleName repl
+ replaceAllTypeSynonyms' env repl
Nothing -> error "Type synonym was not defined"
expandTypeSynonym :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => Qualified ProperName -> [Type] -> m Type
expandTypeSynonym name args = do
env <- getEnv
- Just moduleName <- checkCurrentModule <$> get
- either throwError return $ expandTypeSynonym' env moduleName name args
+ either throwError return $ expandTypeSynonym' env name args
-- |
-- Ensure a set of property names and value does not contain duplicate labels
@@ -530,13 +525,11 @@ infer' (Var var) = do
ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var
case ty of
ConstrainedType constraints ty' -> do
- env <- getEnv
dicts <- getTypeClassDictionaries
return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) constraints)) ty'
_ -> return $ TypedValue True (Var var) ty
infer' v@(Constructor c) = do
env <- getEnv
- Just moduleName <- checkCurrentModule <$> get
case M.lookup c (dataConstructors env) of
Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
Just ty -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
@@ -587,14 +580,13 @@ inferBinder val (BooleanBinder _) = val =?= tyBoolean >> return M.empty
inferBinder val (VarBinder name) = return $ M.singleton name val
inferBinder val (ConstructorBinder ctor binders) = do
env <- getEnv
- Just moduleName <- checkCurrentModule <$> get
case M.lookup ctor (dataConstructors env) of
Just ty -> do
(_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contains constraints") ty
go binders fn
where
go [] ty' = do
- subsumes Nothing val ty'
+ _ <- subsumes Nothing val ty'
return M.empty
go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =
M.union <$> inferBinder obj binder <*> go binders' ret
@@ -648,17 +640,6 @@ checkBinders nvals ret (CaseAlternative binders grd val : bs) = do
return $ r : rs
-- |
--- Check that a local variable name is not already used
---
-assignVariable :: Ident -> UnifyT Type Check ()
-assignVariable name = do
- env <- checkEnv <$> get
- Just moduleName <- checkCurrentModule <$> get
- case M.lookup (moduleName, name) (names env) of
- Just _ -> UnifyT . lift . throwError $ "Variable with name " ++ show name ++ " already exists."
- _ -> return ()
-
--- |
-- Generate a new skolem constant
--
newSkolemConstant :: UnifyT Type Check Int
@@ -710,8 +691,6 @@ check' val (ForAll ident ty _) = do
val' <- check val sk
return $ TypedValue True val' (ForAll ident ty (Just scope))
check' val t@(ConstrainedType constraints ty) = do
- env <- getEnv
- Just moduleName <- checkCurrentModule <$> get
dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do
n <- liftCheck freshDictionaryName
return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
@@ -746,7 +725,7 @@ check' (Abs (Right _) _) _ = error "Binder was not desugared"
check' (App f arg) ret = do
f'@(TypedValue _ _ ft) <- infer f
(ret', app) <- checkFunctionApplication f' ft arg
- subsumes Nothing ret' ret
+ _ <- subsumes Nothing ret' ret
return $ TypedValue True app ret
check' v@(Var var) ty = do
Just moduleName <- checkCurrentModule <$> get
@@ -796,7 +775,6 @@ check' (Accessor prop val) ty = do
return $ TypedValue True (Accessor prop val') ty
check' (Constructor c) ty = do
env <- getEnv
- Just moduleName <- checkCurrentModule <$> get
case M.lookup c (dataConstructors env) of
Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
Just ty1 -> do
@@ -874,9 +852,7 @@ checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg = do
ty <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs
checkFunctionApplication fn ty arg
checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg = do
- env <- getEnv
dicts <- getTypeClassDictionaries
- Just moduleName <- checkCurrentModule <$> get
checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy arg
checkFunctionApplication' _ fnTy arg = throwError $ "Cannot apply a function of type "
++ prettyPrintType fnTy
@@ -909,8 +885,8 @@ subsumes' val ty1 (ForAll ident ty2 sco) =
subsumes val ty1 sk
Nothing -> throwError "Skolem variable scope is unspecified"
subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do
- subsumes Nothing arg2 arg1
- subsumes Nothing ret1 ret2
+ _ <- subsumes Nothing arg2 arg1
+ _ <- subsumes Nothing ret1 ret2
return val
subsumes' val (SaturatedTypeSynonym name tyArgs) ty2 = do
ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs
@@ -919,9 +895,7 @@ subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do
ty2 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs
subsumes val ty1 ty2
subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
- env <- getEnv
dicts <- getTypeClassDictionaries
- Just moduleName <- checkCurrentModule <$> get
_ <- subsumes' Nothing ty1 ty2
return . Just $ foldl App val (map (flip TypeClassDictionary dicts) constraints)
subsumes' val (Object r1) (Object r2) = do
@@ -936,14 +910,14 @@ subsumes' val (Object r1) (Object r2) = do
go [] ts2 r1' r2' = r1' =?= rowFromList (ts2, r2')
go ts1 [] r1' r2' = r2' =?= rowFromList (ts1, r1')
go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2'
- | p1 == p2 = do subsumes Nothing ty1 ty2
+ | p1 == p2 = do _ <- subsumes Nothing ty1 ty2
go ts1 ts2 r1' r2'
| p1 < p2 = do rest <- fresh
r2' =?= RCons p1 ty1 rest
go ts1 ((p2, ty2) : ts2) r1' rest
- | p1 > p2 = do rest <- fresh
- r1' =?= RCons p2 ty2 rest
- go ((p1, ty1) : ts1) ts2 rest r2'
+ | otherwise = do rest <- fresh
+ r1' =?= RCons p2 ty2 rest
+ go ((p1, ty1) : ts1) ts2 rest r2'
subsumes' val ty1 ty2@(Object _) = subsumes val ty2 ty1
subsumes' val ty1 ty2 = do
ty1 =?= ty2
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index 7ca3e5d..2f2fe79 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -89,42 +89,6 @@ data Type
| PrettyPrintArray Type deriving (Show, Eq, Data, Typeable)
-- |
--- Type constructor for functions
---
-tyFunction :: Type
-tyFunction = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Function")
-
--- |
--- Type constructor for strings
---
-tyString :: Type
-tyString = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "String")
-
--- |
--- Type constructor for numbers
---
-tyNumber :: Type
-tyNumber = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Number")
-
--- |
--- Type constructor for booleans
---
-tyBoolean :: Type
-tyBoolean = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Boolean")
-
--- |
--- Type constructor for arrays
---
-tyArray :: Type
-tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")
-
--- |
--- Smart constructor for function types
---
-function :: Type -> Type -> Type
-function t1 = TypeApp (TypeApp tyFunction t1)
-
--- |
-- Convert a row to a list of pairs of labels and types
--
rowToList :: Type -> ([(String, Type)], Type)
@@ -182,6 +146,7 @@ replaceTypeVars = replaceTypeVars' []
go _ ty = ty
genName orig inUse = try 0
where
+ try :: Integer -> String
try n | (orig ++ show n) `elem` inUse = try (n + 1)
| otherwise = orig ++ show n