summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-03-09 17:59:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-03-09 17:59:00 (GMT)
commit6e481f4a8bccb1fc4972bafa95be389cf04cefd9 (patch)
treec17626f4d1f5b18d6a127ca426b6c0cc76300118
parent9d10caf3f416dc113b0ee73ff84a2f49173c6f44 (diff)
version 0.4.50.4.5
-rw-r--r--docgen/Main.hs4
-rw-r--r--prelude/prelude.purs50
-rw-r--r--psci/Main.hs8
-rw-r--r--psci/Parser.hs2
-rw-r--r--purescript.cabal5
-rw-r--r--src/Language/PureScript.hs9
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs87
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs104
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs4
-rw-r--r--src/Language/PureScript/Constants.hs192
-rw-r--r--src/Language/PureScript/DeadCodeElimination.hs42
-rw-r--r--src/Language/PureScript/Declarations.hs50
-rw-r--r--src/Language/PureScript/Environment.hs188
-rw-r--r--src/Language/PureScript/Optimizer.hs9
-rw-r--r--src/Language/PureScript/Optimizer/Common.hs2
-rw-r--r--src/Language/PureScript/Optimizer/Inliner.hs81
-rw-r--r--src/Language/PureScript/Optimizer/MagicDo.hs66
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs22
-rw-r--r--src/Language/PureScript/Parser/Types.hs2
-rw-r--r--src/Language/PureScript/Parser/Values.hs3
-rw-r--r--src/Language/PureScript/Pretty/JS.hs6
-rw-r--r--src/Language/PureScript/Pretty/Types.hs49
-rw-r--r--src/Language/PureScript/Pretty/Values.hs2
-rw-r--r--src/Language/PureScript/Prim.hs69
-rw-r--r--src/Language/PureScript/Scope.hs1
-rw-r--r--src/Language/PureScript/Sugar.hs4
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs28
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs20
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs6
-rw-r--r--src/Language/PureScript/Sugar/Let.hs4
-rw-r--r--src/Language/PureScript/Sugar/Names.hs42
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs29
-rw-r--r--src/Language/PureScript/Sugar/TypeDeclarations.hs4
-rw-r--r--src/Language/PureScript/TypeChecker.hs46
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs7
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs63
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs15
-rw-r--r--src/Language/PureScript/Types.hs6
-rw-r--r--src/Language/PureScript/Values.hs2
39 files changed, 905 insertions, 428 deletions
diff --git a/docgen/Main.hs b/docgen/Main.hs
index a2f5b42..ae74bb8 100644
--- a/docgen/Main.hs
+++ b/docgen/Main.hs
@@ -128,8 +128,8 @@ renderDeclaration n exps (P.TypeClassDeclaration name args ds) = do
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)
+ cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "
+ atIndent n $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)
renderDeclaration _ _ _ = return ()
getName :: P.Declaration -> String
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index 5396f15..f366525 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -45,23 +45,6 @@ module Prelude where
instance showNumber :: Show Number where
show = showNumberImpl
- class Read a where
- read :: String -> a
-
- instance readString :: Read String where
- read s = s
-
- instance readBoolean :: Read Boolean where
- read "true" = true
- read _ = false
-
- foreign import readNumberImpl "function readNumberImpl(n) {\
- \ return parseFloat(n);\
- \}" :: String -> Number
-
- instance readNumber :: Read Number where
- read = readNumberImpl
-
infixl 4 <$>
class Functor f where
@@ -442,6 +425,12 @@ module Data.Maybe where
show (Just x) = "Just " ++ (show x)
show Nothing = "Nothing"
+ instance eqMaybe :: (Eq a) => Eq (Maybe a) where
+ (==) Nothing Nothing = true
+ (==) (Just a1) (Just a2) = a1 == a2
+ (==) _ _ = false
+ (/=) a b = not (a == b)
+
module Data.Either where
import Prelude
@@ -469,6 +458,12 @@ module Data.Either where
show (Left x) = "Left " ++ (show x)
show (Right y) = "Right " ++ (show y)
+ instance eqEither :: (Eq a, Eq b) => Eq (Either a b) where
+ (==) (Left a1) (Left a2) = a1 == a2
+ (==) (Right b1) (Right b2) = b1 == b2
+ (==) _ _ = false
+ (/=) a b = not (a == b)
+
module Data.Array where
import Prelude
@@ -711,6 +706,10 @@ module Data.Tuple where
Tuple as bs -> Tuple (a : as) (b : bs)
unzip [] = Tuple [] []
+ instance eqTuple :: (Eq a, Eq b) => Eq (Tuple a b) where
+ (==) (Tuple a1 b1) (Tuple a2 b2) = a1 == a2 && b1 == b2
+ (/=) t1 t2 = not (t1 == t2)
+
module Data.String where
foreign import lengthS "function lengthS(s) {\
@@ -1207,3 +1206,20 @@ module Data.Enum where
class Enum a where
toEnum :: Number -> Maybe a
fromEnum :: a -> Number
+
+module Text.Parsing.Read where
+
+ class Read a where
+ read :: String -> a
+
+ instance readString :: Read String where
+ read s = s
+
+ instance readBoolean :: Read Boolean where
+ read "true" = true
+ read _ = false
+
+ foreign import readNumberImpl "var readNumberImpl = parseFloat;" :: String -> Number
+
+ instance readNumber :: Read Number where
+ read = readNumberImpl
diff --git a/psci/Main.hs b/psci/Main.hs
index 3a9e7bd..8e0d236 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -173,8 +173,8 @@ completion = completeWord Nothing " \t\n\r" findCompletions
let matches = filter (isPrefixOf str) (names ms)
return $ sortBy sorter $ map simpleCompletion matches ++ files
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
+ 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'
@@ -209,8 +209,8 @@ createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetB
trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))
itValue = foldl (\x f -> f x) value lets
mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))
- itDecl = P.ValueDeclaration (P.Ident "it") [] Nothing itValue
- mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing mainValue
+ itDecl = P.ValueDeclaration (P.Ident "it") P.Value [] Nothing itValue
+ mainDecl = P.ValueDeclaration (P.Ident "main") P.Value [] Nothing mainValue
decls = if exec then [itDecl, mainDecl] else [itDecl]
in
P.Module moduleName ((importDecl `map` imports) ++ decls) Nothing
diff --git a/psci/Parser.hs b/psci/Parser.hs
index e781683..2cc52ee 100644
--- a/psci/Parser.hs
+++ b/psci/Parser.hs
@@ -34,7 +34,7 @@ import qualified Language.PureScript as P
-- we actually want the normal @let@.
--
psciLet :: Parsec String P.ParseState Command
-psciLet = Let <$> (P.Let <$> (P.reserved "let" *> P.indented *> P.parseBinder)
+psciLet = Let <$> (P.Let <$> (P.reserved "let" *> P.indented *> (Left <$> P.parseBinder))
<*> (P.indented *> P.reservedOp "=" *> P.parseValue))
-- |
diff --git a/purescript.cabal b/purescript.cabal
index 03529ad..30dcf3b 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.4.4
+version: 0.4.5
cabal-version: >=1.8
build-type: Custom
license: MIT
@@ -26,8 +26,10 @@ library
build-depends: unix -any
exposed-modules: Data.Generics.Extras
Language.PureScript
+ Language.PureScript.Constants
Language.PureScript.Options
Language.PureScript.Declarations
+ Language.PureScript.Environment
Language.PureScript.Kinds
Language.PureScript.Names
Language.PureScript.Types
@@ -70,7 +72,6 @@ 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
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 743538b..d0b2562 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -28,8 +28,11 @@ import Language.PureScript.Pretty as P
import Language.PureScript.Sugar as P
import Language.PureScript.Options as P
import Language.PureScript.ModuleDependencies as P
+import Language.PureScript.Environment as P
import Language.PureScript.DeadCodeElimination as P
+import qualified Language.PureScript.Constants as C
+
import Data.List (intercalate)
import Data.Maybe (mapMaybe)
import Control.Monad.State.Lazy
@@ -69,9 +72,9 @@ compile opts ms = do
let exts = intercalate "\n" . map (`moduleToPs` env) $ elim
js' <- case mainModuleIdent of
Just mmi -> do
- when ((mmi, Ident "main") `M.notMember` names env) $
- Left $ show mmi ++ ".main is undefined"
- return $ js ++ [JSApp (JSAccessor "main" (JSAccessor (moduleNameToJs mmi) (JSVar "_ps"))) []]
+ when ((mmi, Ident C.main) `M.notMember` names env) $
+ Left $ show mmi ++ "." ++ C.main ++ " is undefined"
+ return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar C._ps))) []]
_ -> return js
return (prettyPrintJS [wrapExportsContainer opts js'], exts, env)
where
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index e90b283..ccb88da 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -17,36 +17,75 @@ module Language.PureScript.CodeGen.Externs (
moduleToPs
) where
-import Data.Maybe (maybeToList, mapMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
+import Data.List (intercalate, find)
+
import qualified Data.Map as M
+
+import Control.Monad.Writer
+
import Language.PureScript.Declarations
-import Language.PureScript.TypeChecker.Monad
import Language.PureScript.Pretty
import Language.PureScript.Names
-import Data.List (intercalate)
+import Language.PureScript.Values
+import Language.PureScript.Environment
-- |
-- 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 =
- "module " ++ runModuleName mn ++ " where\n" ++
- (intercalate "\n" . map (" " ++) . concatMap (declToPs mn env) $ decls)
-
-declToPs :: ModuleName -> Environment -> Declaration -> [String]
-declToPs path env (ValueDeclaration name _ _ _) = maybeToList $ do
- (ty, _) <- M.lookup (path, name) $ names env
- return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty
-declToPs path env (BindingGroupDeclaration vals) =
- flip mapMaybe vals $ \(name, _) -> do
- (ty, _) <- M.lookup (path, name) $ names env
- return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty
-declToPs path env (DataDeclaration name _ _) = maybeToList $ do
- kind <- M.lookup (Qualified (Just path) name) $ types env
- return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
-declToPs _ _ (ExternDataDeclaration name kind) =
- return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
-declToPs _ _ (TypeSynonymDeclaration name args ty) =
- return $ "type " ++ show name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty
-declToPs _ _ _ = []
+moduleToPs (Module _ _ Nothing) _ = error "Module exports were not elaborated in moduleToPs"
+moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWriter $ do
+ tell ["module " ++ runModuleName moduleName ++ " where"]
+ mapM_ fixityToPs ds
+ mapM_ exportToPs exts
+ where
+
+ fixityToPs :: Declaration -> Writer [String] ()
+ fixityToPs (FixityDeclaration (Fixity assoc prec) ident) =
+ tell [ unwords [ show assoc, show prec, ident ] ]
+ fixityToPs _ = return ()
+
+ exportToPs :: DeclarationRef -> Writer [String] ()
+ exportToPs (TypeRef pn dctors) = do
+ case Qualified (Just moduleName) pn `M.lookup` types env of
+ Nothing -> error $ show pn ++ " has no kind in exportToPs"
+ Just (kind, ExternData) ->
+ tell ["foreign import data " ++ show pn ++ " :: " ++ prettyPrintKind kind]
+ Just (_, DataType args tys) -> do
+ let dctors' = fromMaybe (map fst tys) dctors
+ printDctor dctor = case dctor `lookup` tys of
+ Nothing -> Nothing
+ Just tyArgs -> Just $ show dctor ++ " " ++ unwords (map prettyPrintTypeAtom tyArgs)
+ tell ["data " ++ show pn ++ " " ++ unwords args ++ " = " ++ intercalate " | " (mapMaybe printDctor dctors')]
+ Just (_, TypeSynonym) ->
+ case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of
+ Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"
+ Just (args, synTy) ->
+ tell ["type " ++ show pn ++ " " ++ unwords args ++ " = " ++ prettyPrintType synTy]
+ _ -> error "Invalid input in exportToPs"
+
+ exportToPs (ValueRef ident) =
+ case (moduleName, ident) `M.lookup` names env of
+ Nothing -> error $ show ident ++ " has no type in exportToPs"
+ Just (ty, nameKind) | nameKind == Value || nameKind == Extern ForeignImport || nameKind == Extern InlineJavascript ->
+ tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty]
+ _ -> return ()
+ exportToPs (TypeClassRef className) =
+ case Qualified (Just moduleName) className `M.lookup` typeClasses env of
+ Nothing -> error $ show className ++ " has no type class definition in exportToPs"
+ Just (args, members) -> do
+ tell ["class " ++ show className ++ " " ++ unwords args ++ " where"]
+ forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->
+ tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ]
+ exportToPs (TypeInstanceRef ident) = do
+ let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =
+ fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find ((== Qualified (Just moduleName) ident) . tcdName) $ typeClassDictionaries env
+ let constraintsText = case fromMaybe [] deps of
+ [] -> ""
+ cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "
+ tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)]
+
+ isValueExported :: Ident -> Bool
+ isValueExported ident = ValueRef ident `elem` exts
+
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 8254412..eb20d6a 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -30,7 +30,6 @@ import Control.Monad (replicateM, forM)
import qualified Data.Map as M
-import Language.PureScript.TypeChecker (Environment(..), NameKind(..))
import Language.PureScript.Values
import Language.PureScript.Names
import Language.PureScript.Scope
@@ -41,35 +40,37 @@ import Language.PureScript.CodeGen.JS.AST as AST
import Language.PureScript.Types
import Language.PureScript.Optimizer
import Language.PureScript.CodeGen.Common
-import Language.PureScript.Prim
+import Language.PureScript.Environment
+import qualified Language.PureScript.Constants as C
-- |
-- 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 (Just exps)) env =
case jsDecls of
[] -> Nothing
- _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar "_ps")) $
+ _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar C._ps)) $
JSApp (JSFunction Nothing ["module"] (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"]))
- [JSBinary Or (JSAccessor (moduleNameToJs name) (JSVar "_ps")) (JSObjectLiteral [])]
+ [JSBinary Or (JSAccessor (moduleNameToJs name) (JSVar C._ps)) (JSObjectLiteral [])]
where
- jsDecls = concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) decls
+ jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) decls)
+ ++ concatMap exportToJs exps
+moduleToJs _ _ _ = error "Exports should have been elaborated in name desugaring"
-- |
-- Generate code in the simplified Javascript intermediate representation for a declaration
--
declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]
-declToJs opts mp (ValueDeclaration ident _ _ val) e =
- Just $ export ident $ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))
+declToJs opts mp (ValueDeclaration ident _ _ _ val) e =
+ Just [JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))]
declToJs opts mp (BindingGroupDeclaration vals) e =
- Just $ concatMap (\(ident, val) ->
- export ident $ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))
- ) vals
+ Just $ flip concatMap vals $ \(ident, _, val) ->
+ [JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))]
declToJs _ mp (DataDeclaration _ _ ctors) _ =
Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->
- export (Escaped ctor) $ JSVariableIntroduction ctor (Just (go pn 0 tys []))
+ [JSVariableIntroduction ctor (Just (go pn 0 tys []))]
where
go :: ProperName -> Integer -> [Type] -> [JS] -> JS
go pn _ [] values =
@@ -77,18 +78,26 @@ declToJs _ mp (DataDeclaration _ _ ctors) _ =
go pn index (_ : tys') values =
JSFunction Nothing ["value" ++ show index]
(JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])
-declToJs opts mp (DataBindingGroupDeclaration ds) e =
- Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds
-declToJs _ _ (ExternDeclaration _ ident (Just js) _) _ =
- Just $ export ident js
+declToJs opts mp (DataBindingGroupDeclaration ds) e = Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds
+declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = Just [js]
declToJs _ _ _ _ = Nothing
-- |
--- Generate code in the simplified Javascript intermediate representation for exporting a
--- declaration from a module.
+-- Generate code in the simplified Javascript intermediate representation for an export from a
+-- module.
--
-export :: Ident -> JS -> [JS]
-export ident value = [ value, JSAssignment (accessor ident (JSVar "module")) (var ident) ]
+exportToJs :: DeclarationRef -> [JS]
+exportToJs (TypeRef _ (Just dctors)) = flip map dctors (export . Escaped . runProperName)
+exportToJs (ValueRef name) = [export name]
+exportToJs (TypeInstanceRef name) = [export name]
+exportToJs _ = []
+
+-- |
+-- Generate code in the simplified Javascript intermediate representation for assigning an exported
+-- value to the current module object.
+--
+export :: Ident -> JS
+export ident = JSAssignment (accessor ident (JSVar "module")) (var ident)
-- |
-- Generate code in the simplified Javascript intermediate representation for a variable based on a
@@ -116,7 +125,7 @@ valueToJs _ _ _ (StringLiteral s) = JSStringLiteral s
valueToJs _ _ _ (BooleanLiteral b) = JSBooleanLiteral b
valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs opts m e) xs)
valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs opts m e)) ps)
-valueToJs opts m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar "Object")) [ valueToJs opts m e o, JSObjectLiteral (map (second (valueToJs opts m e)) ps)]
+valueToJs opts m e (ObjectUpdate o ps) = extendObj (valueToJs opts m e o) (map (second (valueToJs opts m e)) ps)
valueToJs _ m _ (Constructor name) = qualifiedToJS m (Ident . runProperName) name
valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (valueToJs opts m e) values)
valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)
@@ -124,12 +133,29 @@ valueToJs opts m e (Accessor prop val) = JSAccessor prop (valueToJs opts m e val
valueToJs opts m e (App val arg) = JSApp (valueToJs opts m e val) [valueToJs opts m e arg]
valueToJs opts m e (Abs (Left arg) val) = JSFunction Nothing [identToJs arg] (JSBlock [JSReturn (valueToJs opts m (bindName m arg e) val)])
valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntimeTypeChecks opts = let arg' = identToJs arg in JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn (valueToJs opts m e val)])
-valueToJs _ m e (Var ident) = varToJs m e ident
+valueToJs _ m _ (Var ident) = varToJs m ident
valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val
valueToJs _ _ _ (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"
valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
-- |
+-- Shallow copy an object.
+--
+extendObj :: JS -> [(String, JS)] -> JS
+extendObj obj sts = JSApp (JSFunction Nothing [] block) []
+ where
+ [newObj, key] = take 2 . map identToJs . unusedNames $ (obj, sts)
+ jsKey = JSVar key
+ jsNewObj = JSVar newObj
+ block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
+ objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
+ copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
+ cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
+ assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
+ stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
+ extend = map stToAssign sts
+
+-- |
-- Temporarily extends the environment with a single local variable name
--
bindName :: ModuleName -> Ident -> Environment -> Environment
@@ -181,23 +207,16 @@ runtimeTypeChecks arg ty =
-- Generate code in the simplified Javascript intermediate representation for a reference to a
-- variable.
--
-varToJs :: ModuleName -> Environment -> Qualified Ident -> JS
-varToJs m e qual@(Qualified _ ident) = go qual
- where
- go qual' = case M.lookup (qualify m qual') (names e) of
- Just (_, ty) | isExtern ty -> var ident
- _ -> case qual' of
- Qualified Nothing _ -> var ident
- _ -> qualifiedToJS m id qual'
- isExtern (Extern ForeignImport) = True
- isExtern _ = False
+varToJs :: ModuleName -> Qualified Ident -> JS
+varToJs _ (Qualified Nothing ident) = var ident
+varToJs m qual = qualifiedToJS m id qual
-- |
-- Generate code in the simplified Javascript intermediate representation for a reference to a
-- variable that may have a qualified name.
--
qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS
-qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSAccessor (moduleNameToJs m') $ JSVar "_ps")
+qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSAccessor (moduleNameToJs m') $ JSVar C._ps)
qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
-- |
@@ -237,7 +256,7 @@ binderToJs _ _ varName done (VarBinder ident) =
return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
binderToJs m e varName done (ConstructorBinder ctor bs) = do
js <- go 0 done bs
- if isOnlyConstructor m e ctor
+ if isOnlyConstructor e ctor
then
return js
else
@@ -290,20 +309,17 @@ binderToJs m e varName done (NamedBinder ident binder) = do
-- Checks whether a data constructor is the only constructor for that type, used to simplify the
-- check when generating code for binders.
--
-isOnlyConstructor :: ModuleName -> Environment -> Qualified ProperName -> Bool
-isOnlyConstructor m e ctor =
+isOnlyConstructor :: Environment -> Qualified ProperName -> Bool
+isOnlyConstructor e ctor =
let ty = fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors e
- in numConstructors ty == 1
+ in numConstructors (ctor, ty) == 1
where
- numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.elems $ dataConstructors e
- typeConstructor (TypeConstructor qual) = qualify m qual
- typeConstructor (ForAll _ ty _) = typeConstructor ty
- typeConstructor (TypeApp (TypeApp t _) ty) | t == tyFunction = typeConstructor ty
- typeConstructor (TypeApp ty _) = typeConstructor ty
- typeConstructor fn = error $ "Invalid arguments to typeConstructor: " ++ show fn
+ numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e
+ typeConstructor (Qualified (Just moduleName) _, (tyCtor, _)) = (moduleName, tyCtor)
+ typeConstructor _ = error "Invalid argument to isOnlyConstructor"
wrapExportsContainer :: Options -> [JS] -> JS
-wrapExportsContainer opts modules = JSApp (JSFunction Nothing ["_ps"] $ JSBlock $ JSStringLiteral "use strict" : modules) [exportSelector]
+wrapExportsContainer opts modules = JSApp (JSFunction Nothing [C._ps] $ JSBlock $ JSStringLiteral "use strict" : modules) [exportSelector]
where
exportSelector = JSConditional (JSBinary And (JSBinary NotEqualTo (JSTypeOf $ JSVar "module") (JSStringLiteral "undefined")) (JSAccessor "exports" (JSVar "module")))
(JSAccessor "exports" (JSVar "module"))
diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs
index 2cd82af..fd7034c 100644
--- a/src/Language/PureScript/CodeGen/JS/AST.hs
+++ b/src/Language/PureScript/CodeGen/JS/AST.hs
@@ -200,6 +200,10 @@ data JS
--
| JSFor String JS JS JS
-- |
+ -- ForIn loop
+ --
+ | JSForIn String JS JS
+ -- |
-- If-then-else statement
--
| JSIfElse JS JS (Maybe JS)
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
new file mode 100644
index 0000000..45c0ede
--- /dev/null
+++ b/src/Language/PureScript/Constants.hs
@@ -0,0 +1,192 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Constants
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- Various constants which refer to things in the Prelude
+--
+-----------------------------------------------------------------------------
+
+module Language.PureScript.Constants where
+
+-- Prelude Operators
+
+($) :: String
+($) = "$"
+
+(#) :: String
+(#) = "#"
+
+(!!) :: String
+(!!) = "!!"
+
+(++) :: String
+(++) = "++"
+
+(>>=) :: String
+(>>=) = ">>="
+
+(+) :: String
+(+) = "+"
+
+(-) :: String
+(-) = "-"
+
+(*) :: String
+(*) = "*"
+
+(/) :: String
+(/) = "/"
+
+(%) :: String
+(%) = "%"
+
+(<) :: String
+(<) = "<"
+
+(>) :: String
+(>) = ">"
+
+(<=) :: String
+(<=) = "<="
+
+(>=) :: String
+(>=) = ">="
+
+(==) :: String
+(==) = "=="
+
+(/=) :: String
+(/=) = "/="
+
+(&) :: String
+(&) = "&"
+
+bar :: String
+bar = "|"
+
+(^) :: String
+(^) = "^"
+
+(&&) :: String
+(&&) = "&&"
+
+(||) :: String
+(||) = "||"
+
+-- Prelude Operator Functions
+
+negate :: String
+negate = "negate"
+
+shl :: String
+shl = "shl"
+
+shr :: String
+shr = "shr"
+
+zshr :: String
+zshr = "zshr"
+
+complement :: String
+complement = "complement"
+
+not :: String
+not = "not"
+
+-- Prelude Values
+
+return :: String
+return = "return"
+
+returnEscaped :: String
+returnEscaped = "$return"
+
+untilE :: String
+untilE = "untilE"
+
+whileE :: String
+whileE = "whileE"
+
+runST :: String
+runST = "runST"
+
+runSTArray :: String
+runSTArray = "runSTArray"
+
+stRefValue :: String
+stRefValue = "value"
+
+newSTRef :: String
+newSTRef = "newSTRef"
+
+readSTRef :: String
+readSTRef = "readSTRef"
+
+writeSTRef :: String
+writeSTRef = "writeSTRef"
+
+modifySTRef :: String
+modifySTRef = "modifySTRef"
+
+peekSTArray :: String
+peekSTArray = "peekSTArray"
+
+pokeSTArray :: String
+pokeSTArray = "pokeSTArray"
+
+-- Type Class Dictionary Names
+
+monadEffDictionary :: String
+monadEffDictionary = "monadEff"
+
+numNumber :: String
+numNumber = "numNumber"
+
+ordNumber :: String
+ordNumber = "ordNumber"
+
+eqNumber :: String
+eqNumber = "eqNumber"
+
+eqString :: String
+eqString = "eqString"
+
+eqBoolean :: String
+eqBoolean = "eqBoolean"
+
+bitsNumber :: String
+bitsNumber = "bitsNumber"
+
+boolLikeBoolean :: String
+boolLikeBoolean = "boolLikeBoolean"
+
+-- Main module
+
+main :: String
+main = "main"
+
+-- Code Generation
+
+_ps :: String
+_ps = "_ps"
+
+-- Modules
+
+prim :: String
+prim = "Prim"
+
+prelude :: String
+prelude = "Prelude"
+
+eff :: String
+eff = "Control_Monad_Eff"
+
+st :: String
+st = "Control_Monad_ST"
diff --git a/src/Language/PureScript/DeadCodeElimination.hs b/src/Language/PureScript/DeadCodeElimination.hs
index df6cd46..15889e7 100644
--- a/src/Language/PureScript/DeadCodeElimination.hs
+++ b/src/Language/PureScript/DeadCodeElimination.hs
@@ -30,11 +30,33 @@ import Language.PureScript.Declarations
-- Eliminate all declarations which are not a transitive dependency of the entry point module
--
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 exps) -> Module moduleName (filter (isUsed moduleName graph vertexFor entryPointVertices) ds) exps
+eliminateDeadCode entryPoints ms = map go ms
+ where
+ go (Module moduleName ds (Just exps)) = Module moduleName ds' (Just exps')
+ where
+ ds' = filter (isUsed moduleName graph vertexFor entryPointVertices) ds
+ exps' = mapMaybe (filterExport ds') exps
+ go _ = error "Exports should have been elaborated in name desugaring"
+ declarations = concatMap declarationsByModule ms
+ (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations
+ entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations
+
+ filterExport :: [Declaration] -> DeclarationRef -> Maybe DeclarationRef
+ filterExport decls r@(TypeRef name _) | (any $ typeExists name) decls = Just r
+ filterExport decls r@(ValueRef name) | (any $ valueExists name) decls = Just r
+ filterExport decls r@(TypeInstanceRef name) | (any $ valueExists name) decls = Just r
+ filterExport _ _ = Nothing
+
+ valueExists :: Ident -> Declaration -> Bool
+ valueExists name (ValueDeclaration name' _ _ _ _) = name == name'
+ valueExists name (ExternDeclaration _ name' _ _) = name == name'
+ valueExists name (BindingGroupDeclaration decls) = any (\(name', _, _) -> name == name') decls
+ valueExists _ _ = False
+
+ typeExists :: ProperName -> Declaration -> Bool
+ typeExists name (DataDeclaration name' _ _) = name == name'
+ typeExists name (DataBindingGroupDeclaration decls) = any (typeExists name) decls
+ typeExists _ _ = False
type Key = (ModuleName, Either Ident ProperName)
@@ -42,10 +64,10 @@ 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)]
+ go d@(ValueDeclaration name _ _ _ _) = [((moduleName, Left name), dependencies moduleName d)]
go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors
go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]
- go d@(BindingGroupDeclaration names') = map (\(name, _) -> ((moduleName, Left name), dependencies moduleName d)) names'
+ go d@(BindingGroupDeclaration names') = map (\(name, _, _) -> ((moduleName, Left name), dependencies moduleName d)) names'
go (DataBindingGroupDeclaration ds') = concatMap go ds'
go _ = []
@@ -59,7 +81,7 @@ dependencies moduleName = nub . everything (++) (mkQ [] values)
values _ = []
isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool
-isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _ _) =
+isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _ _ _) =
let Just v' = vertexFor (moduleName, Left name)
in any (\v -> path graph v v') entryPointVertices
isUsed moduleName graph vertexFor entryPointVertices (DataDeclaration _ _ dctors) =
@@ -69,8 +91,8 @@ isUsed moduleName graph vertexFor entryPointVertices (ExternDeclaration _ name _
let Just v' = vertexFor (moduleName, Left name)
in any (\v -> path graph v v') entryPointVertices
isUsed moduleName graph vertexFor entryPointVertices (BindingGroupDeclaration ds) =
- any (\(name, _) -> let Just v' = vertexFor (moduleName, Left name)
- in any (\v -> path graph v v') entryPointVertices) ds
+ any (\(name, _, _) -> let Just v' = vertexFor (moduleName, Left name)
+ in any (\v -> path graph v v') entryPointVertices) ds
isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =
any (isUsed moduleName graph vertexFor entryPointVertices) ds
isUsed _ _ _ _ _ = True
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index ca80e0b..53ce6a9 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -21,6 +21,7 @@ import Language.PureScript.Types
import Language.PureScript.Names
import Language.PureScript.Kinds
import Language.PureScript.CodeGen.JS.AST
+import Language.PureScript.Environment
import qualified Data.Data as D
@@ -32,7 +33,11 @@ type Precedence = Integer
-- |
-- Associativity for infix operators
--
-data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)
+data Associativity = Infixl | Infixr deriving (D.Data, D.Typeable)
+
+instance Show Associativity where
+ show Infixl = "infixl"
+ show Infixr = "infixr"
-- |
-- Fixity data for infix operators
@@ -46,27 +51,6 @@ data Fixity = Fixity Associativity Precedence 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
---
-data ForeignImportType
- -- |
- -- A regular foreign import
- --
- = ForeignImport
- -- |
- -- A foreign import which contains inline Javascript as a string literal
- --
- | InlineJavascript
- -- |
- -- A type class dictionary import, generated during desugaring of type class declarations
- --
- | TypeClassDictionaryImport
- -- |
- -- A type class dictionary member accessor import, generated during desugaring of type class declarations
- --
- | TypeClassAccessorImport deriving (Show, Eq, D.Data, D.Typeable)
-
--- |
-- An item in a list of explicit imports or exports
--
data DeclarationRef
@@ -82,6 +66,10 @@ data DeclarationRef
-- A type class
--
| TypeClassRef ProperName
+ -- |
+ -- A type class instance, created during typeclass desugaring (name, class name, instance types)
+ --
+ | TypeInstanceRef Ident
deriving (Show, Eq, D.Data, D.Typeable)
-- |
@@ -107,11 +95,11 @@ data Declaration
-- |
-- A value declaration (name, top-level binders, optional guard, value)
--
- | ValueDeclaration Ident [Binder] (Maybe Guard) Value
+ | ValueDeclaration Ident NameKind [Binder] (Maybe Guard) Value
-- |
-- A minimal mutually recursive set of value declarations
--
- | BindingGroupDeclaration [(Ident, Value)]
+ | BindingGroupDeclaration [(Ident, NameKind, Value)]
-- |
-- A foreign import declaration (type, name, optional inline Javascript, type)
--
@@ -121,6 +109,10 @@ data Declaration
--
| ExternDataDeclaration ProperName Kind
-- |
+ -- A type class instance foreign import
+ --
+ | ExternInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type]
+ -- |
-- A fixity declaration (fixity data, operator name)
--
| FixityDeclaration Fixity String
@@ -133,7 +125,8 @@ data Declaration
--
| TypeClassDeclaration ProperName [String] [Declaration]
-- |
- -- A type instance declaration (dependencies, class name, instance type, member declarations)
+ -- A type instance declaration (name, dependencies, class name, instance types, member
+ -- declarations)
--
| TypeInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]
deriving (Show, D.Data, D.Typeable)
@@ -168,6 +161,13 @@ isExternDataDecl ExternDataDeclaration{} = True
isExternDataDecl _ = False
-- |
+-- Test if a declaration is a type class instance foreign import
+--
+isExternInstanceDecl :: Declaration -> Bool
+isExternInstanceDecl ExternInstanceDeclaration{} = True
+isExternInstanceDecl _ = False
+
+-- |
-- Test if a declaration is a fixity declaration
--
isFixityDecl :: Declaration -> Bool
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
new file mode 100644
index 0000000..0beab12
--- /dev/null
+++ b/src/Language/PureScript/Environment.hs
@@ -0,0 +1,188 @@
+-----------------------------------------------------------------------------
+--
+-- 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 :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Language.PureScript.Environment where
+
+import Data.Data
+
+import Language.PureScript.Names
+import Language.PureScript.Types
+import Language.PureScript.Kinds
+import Language.PureScript.Values
+import qualified Language.PureScript.Constants as C
+
+import qualified Data.Map as M
+
+-- |
+-- The @Environment@ defines all values and types which are currently in scope:
+--
+data Environment = Environment {
+ -- |
+ -- Value names currently in scope
+ --
+ names :: M.Map (ModuleName, Ident) (Type, NameKind)
+ -- |
+ -- Type names currently in scope
+ --
+ , types :: M.Map (Qualified ProperName) (Kind, TypeKind)
+ -- |
+ -- Data constructors currently in scope, along with their associated data type constructors
+ --
+ , dataConstructors :: M.Map (Qualified ProperName) (ProperName, Type)
+ -- |
+ -- Type synonyms currently in scope
+ --
+ , typeSynonyms :: M.Map (Qualified ProperName) ([String], Type)
+ -- |
+ -- Available type class dictionaries
+ --
+ , typeClassDictionaries :: [TypeClassDictionaryInScope]
+ -- |
+ -- Type classes
+ --
+ , typeClasses :: M.Map (Qualified ProperName) ([String], [(Ident, Type)])
+ } deriving (Show)
+
+-- |
+-- The initial environment with no values and only the default javascript types defined
+--
+initEnvironment :: Environment
+initEnvironment = Environment M.empty primTypes M.empty M.empty [] M.empty
+
+-- |
+-- The type of a foreign import
+--
+data ForeignImportType
+ -- |
+ -- A regular foreign import
+ --
+ = ForeignImport
+ -- |
+ -- A foreign import which contains inline Javascript as a string literal
+ --
+ | InlineJavascript
+ -- |
+ -- A type class dictionary member accessor import, generated during desugaring of type class declarations
+ --
+ | TypeClassAccessorImport deriving (Show, Eq, Data, Typeable)
+
+-- |
+-- The kind of a name
+--
+data NameKind
+ -- |
+ -- A value introduced as a binding in a module
+ --
+ = Value
+ -- |
+ -- A foreign import
+ --
+ | Extern ForeignImportType
+ -- |
+ -- A local name introduced using a lambda abstraction, variable introduction or binder
+ --
+ | LocalVariable
+ -- |
+ -- A data constructor
+ --
+ | DataConstructor
+ -- |
+ -- A type class dictionary, generated during desugaring of type class declarations
+ --
+ | TypeInstanceDictionaryValue
+ -- |
+ -- A type instance member, generated during desugaring of type class declarations
+ --
+ | TypeInstanceMember deriving (Show, Eq, Data, Typeable)
+
+-- |
+-- The kinds of a type
+--
+data TypeKind
+ -- |
+ -- Data type
+ --
+ = DataType [String] [(ProperName, [Type])]
+ -- |
+ -- Type synonym
+ --
+ | TypeSynonym
+ -- |
+ -- Foreign data
+ --
+ | ExternData
+ -- |
+ -- A local type variable
+ --
+ | LocalTypeVariable deriving (Show, Eq, Data, Typeable)
+
+-- |
+-- Construct a ProperName in the Prim module
+--
+primName :: String -> Qualified ProperName
+primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName
+
+-- |
+-- Construct a type in the Prim module
+--
+primTy :: String -> Type
+primTy = TypeConstructor . primName
+
+-- |
+-- Type constructor for functions
+--
+tyFunction :: Type
+tyFunction = primTy "Function"
+
+-- |
+-- Type constructor for strings
+--
+tyString :: Type
+tyString = primTy "String"
+
+-- |
+-- Type constructor for numbers
+--
+tyNumber :: Type
+tyNumber = primTy "Number"
+
+-- |
+-- Type constructor for booleans
+--
+tyBoolean :: Type
+tyBoolean = primTy "Boolean"
+
+-- |
+-- Type constructor for arrays
+--
+tyArray :: Type
+tyArray = primTy "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, TypeKind)
+primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star), ExternData))
+ , (primName "Array" , (FunKind Star Star, ExternData))
+ , (primName "String" , (Star, ExternData))
+ , (primName "Number" , (Star, ExternData))
+ , (primName "Boolean" , (Star, ExternData)) ]
diff --git a/src/Language/PureScript/Optimizer.hs b/src/Language/PureScript/Optimizer.hs
index ec8ad5d..3e4b983 100644
--- a/src/Language/PureScript/Optimizer.hs
+++ b/src/Language/PureScript/Optimizer.hs
@@ -39,6 +39,7 @@ module Language.PureScript.Optimizer (
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Options
+import qualified Language.PureScript.Constants as C
import Language.PureScript.Optimizer.Common
import Language.PureScript.Optimizer.TCO
@@ -60,10 +61,10 @@ optimize opts | optionsNoOptimizations opts = id
, unThunk
, etaConvert
, inlineVariables
- , inlineOperator "$" $ \f x -> JSApp f [x]
- , inlineOperator "#" $ \x f -> JSApp f [x]
- , inlineOperator "!!" $ flip JSIndexer
- , inlineOperator "++" $ JSBinary Add
+ , inlineOperator (C.$) $ \f x -> JSApp f [x]
+ , inlineOperator (C.#) $ \x f -> JSApp f [x]
+ , inlineOperator (C.!!) $ flip JSIndexer
+ , inlineOperator (C.++) $ JSBinary Add
, inlineCommonOperators ]
untilFixedPoint :: (Eq a) => (a -> a) -> a -> a
diff --git a/src/Language/PureScript/Optimizer/Common.hs b/src/Language/PureScript/Optimizer/Common.hs
index 32821e8..3a6a07b 100644
--- a/src/Language/PureScript/Optimizer/Common.hs
+++ b/src/Language/PureScript/Optimizer/Common.hs
@@ -42,6 +42,8 @@ isReassigned var1 = everything (||) (mkQ False check)
check (JSFunction _ args _) | var1 `elem` args = True
check (JSVariableIntroduction arg _) | var1 == arg = True
check (JSAssignment (JSVar arg) _) | var1 == arg = True
+ check (JSFor arg _ _ _) | var1 == arg = True
+ check (JSForIn arg _ _) | var1 == arg = True
check _ = False
isRebound :: (Data d) => JS -> d -> Bool
diff --git a/src/Language/PureScript/Optimizer/Inliner.hs b/src/Language/PureScript/Optimizer/Inliner.hs
index 47898bc..df88a4b 100644
--- a/src/Language/PureScript/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/Optimizer/Inliner.hs
@@ -28,6 +28,8 @@ import Language.PureScript.CodeGen.Common (identToJs)
import Language.PureScript.Optimizer.Common
import Language.PureScript.Names
+import qualified Language.PureScript.Constants as C
+
shouldInline :: JS -> Bool
shouldInline (JSVar _) = True
shouldInline (JSNumericLiteral _) = True
@@ -71,42 +73,46 @@ inlineOperator op f = everywhere (mkT convert)
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 (JSAccessor longForm (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
+ _ps == C._ps &&
+ longForm == identToJs (Op op) = True
+ isOp (JSIndexer (JSStringLiteral op') (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
+ _ps == C._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 C.numNumber (C.+) Add
+ , binary C.numNumber (C.-) Subtract
+ , binary C.numNumber (C.*) Multiply
+ , binary C.numNumber (C./) Divide
+ , binary C.numNumber (C.%) Modulus
+ , unary C.numNumber C.negate Negate
- , binary "ordNumber" "<" LessThan
- , binary "ordNumber" ">" GreaterThan
- , binary "ordNumber" "<=" LessThanOrEqualTo
- , binary "ordNumber" ">=" GreaterThanOrEqualTo
+ , binary C.ordNumber (C.<) LessThan
+ , binary C.ordNumber (C.>) GreaterThan
+ , binary C.ordNumber (C.<=) LessThanOrEqualTo
+ , binary C.ordNumber (C.>=) GreaterThanOrEqualTo
- , binary "eqNumber" "==" EqualTo
- , binary "eqNumber" "/=" NotEqualTo
- , binary "eqString" "==" EqualTo
- , binary "eqString" "/=" NotEqualTo
- , binary "eqBoolean" "==" EqualTo
- , binary "eqBoolean" "/=" NotEqualTo
+ , binary C.eqNumber (C.==) EqualTo
+ , binary C.eqNumber (C./=) NotEqualTo
+ , binary C.eqString (C.==) EqualTo
+ , binary C.eqString (C./=) NotEqualTo
+ , binary C.eqBoolean (C.==) EqualTo
+ , binary C.eqBoolean (C./=) 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
+ , binaryFunction C.bitsNumber C.shl ShiftLeft
+ , binaryFunction C.bitsNumber C.shr ShiftRight
+ , binaryFunction C.bitsNumber C.zshr ZeroFillShiftRight
+ , binary C.bitsNumber (C.&) BitwiseAnd
+ , binary C.bitsNumber C.bar BitwiseOr
+ , binary C.bitsNumber (C.^) BitwiseXor
+ , unary C.bitsNumber C.complement BitwiseNot
- , binary "boolLikeBoolean" "&&" And
- , binary "boolLikeBoolean" "||" Or
- , unary "boolLikeBoolean" "not" Not
+ , binary C.boolLikeBoolean (C.&&) And
+ , binary C.boolLikeBoolean (C.||) Or
+ , unary C.boolLikeBoolean C.not Not
]
where
binary :: String -> String -> BinaryOperator -> JS -> JS
@@ -115,8 +121,11 @@ inlineCommonOperators = applyAll
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 (JSAccessor longForm (JSAccessor prelude (JSVar _))) | prelude == C.prelude &&
+ longForm == identToJs (Op opString) = True
+ isOp (JSIndexer (JSStringLiteral op') (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
+ _ps == C._ps &&
+ opString == op' = True
isOp _ = False
binaryFunction :: String -> String -> BinaryOperator -> JS -> JS
binaryFunction dictName fnName op = everywhere (mkT convert)
@@ -124,7 +133,9 @@ inlineCommonOperators = applyAll
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 (JSAccessor fnName' (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
+ _ps == C._ps &&
+ fnName == fnName' = True
isOp _ = False
unary :: String -> String -> UnaryOperator -> JS -> JS
unary dictName fnName op = everywhere (mkT convert)
@@ -132,7 +143,11 @@ inlineCommonOperators = applyAll
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 (JSAccessor fnName' (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
+ _ps == C._ps &&
+ fnName' == fnName = True
isOp _ = False
- isOpDict dictName (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True
+ isOpDict dictName (JSApp (JSAccessor prop (JSAccessor prelude (JSVar _ps))) [JSObjectLiteral []]) | prelude == C.prelude &&
+ _ps == C._ps &&
+ prop == dictName = True
isOpDict _ _ = False
diff --git a/src/Language/PureScript/Optimizer/MagicDo.hs b/src/Language/PureScript/Optimizer/MagicDo.hs
index 61d934f..e83bdfb 100644
--- a/src/Language/PureScript/Optimizer/MagicDo.hs
+++ b/src/Language/PureScript/Optimizer/MagicDo.hs
@@ -27,6 +27,8 @@ import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.CodeGen.Common (identToJs)
import Language.PureScript.Names
+import qualified Language.PureScript.Constants as C
+
magicDo :: Options -> JS -> JS
magicDo opts | optionsMagicDo opts = inlineST . magicDo'
| otherwise = id
@@ -63,10 +65,10 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
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 =
+ convert (JSApp (JSApp f [arg]) []) | isEffFunc C.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 =
+ convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc C.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
@@ -76,21 +78,31 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
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 (JSAccessor prop (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
+ _ps == C._ps &&
+ prop == identToJs (Op (C.>>=)) = True
+ isBindPoly (JSIndexer (JSStringLiteral bind) (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
+ _ps == C._ps &&
+ bind == (C.>>=) = 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 (JSAccessor returnEscaped (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
+ _ps == C._ps &&
+ returnEscaped == C.returnEscaped = True
+ isRetPoly (JSIndexer (JSStringLiteral return') (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
+ _ps == C._ps &&
+ return' == C.return = 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 name (JSAccessor name' (JSAccessor eff (JSVar _ps))) | eff == C.eff &&
+ _ps == C._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 (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == C.monadEffDictionary = True
+ isEffDict (JSApp (JSAccessor prop (JSAccessor eff (JSVar _ps))) [JSObjectLiteral []]) | eff == C.eff &&
+ _ps == C._ps &&
+ prop == C.monadEffDictionary = True
isEffDict _ = False
-- Remove __do function applications which remain after desugaring
undo :: JS -> JS
@@ -106,7 +118,7 @@ inlineST = everywhere (mkT convertBlock)
-- 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 =
+ convertBlock (JSApp f [arg]) | isSTFunc C.runST f || isSTFunc C.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
@@ -116,32 +128,34 @@ inlineST = everywhere (mkT convertBlock)
-- 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 =
+ convert agg (JSApp (JSApp f [arg]) []) | isSTFunc C.newSTRef f =
+ if agg then arg else JSObjectLiteral [(C.stRefValue, arg)]
+ convert agg (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f =
+ if agg then ref else JSAccessor C.stRefValue ref
+ convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =
+ if agg then JSAssignment ref arg else JSAssignment (JSAccessor C.stRefValue ref) arg
+ convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc C.modifySTRef f =
+ if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor C.stRefValue ref) (JSApp func [JSAccessor C.stRefValue ref])
+ convert _ (JSApp (JSApp (JSApp f [arr]) [i]) []) | isSTFunc C.peekSTArray f =
JSIndexer i arr
- convert _ (JSApp (JSApp (JSApp (JSApp f [arr]) [i]) [val]) []) | isSTFunc "pokeSTArray" f =
+ convert _ (JSApp (JSApp (JSApp (JSApp f [arr]) [i]) [val]) []) | isSTFunc C.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 name (JSAccessor name' (JSAccessor st (JSVar _ps))) | st == C.st &&
+ _ps == C._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 (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc C.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 (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f = [ref]
+ isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
isSTUsage _ = []
-- Find all uses of a variable
appearingIn ref = everything (++) (mkQ [] isVar)
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index bdb5f1d..edcf656 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -30,6 +30,7 @@ import Language.PureScript.Parser.Values
import Language.PureScript.Parser.Types
import Language.PureScript.Parser.Kinds
import Language.PureScript.CodeGen.JS.AST
+import Language.PureScript.Environment
parseDataDeclaration :: P.Parsec String ParseState Declaration
parseDataDeclaration = do
@@ -55,6 +56,7 @@ parseTypeSynonymDeclaration =
parseValueDeclaration :: P.Parsec String ParseState Declaration
parseValueDeclaration =
ValueDeclaration <$> parseIdent
+ <*> pure Value
<*> P.many parseBinderNoParens
<*> P.optionMaybe parseGuard
<*> (lexeme (indented *> P.char '=') *> parseValue)
@@ -62,11 +64,21 @@ parseValueDeclaration =
parseExternDeclaration :: P.Parsec String ParseState Declaration
parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>
(ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
- <*> (lexeme (indented *> P.string "::") *> parseKind)
- <|> do ident <- parseIdent
- js <- P.optionMaybe (JSRaw <$> stringLiteral)
- ty <- lexeme (indented *> P.string "::") *> parsePolyType
- return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty)
+ <*> (lexeme (indented *> P.string "::") *> parseKind)
+ <|> (do reserved "instance"
+ name <- parseIdent <* lexeme (indented *> P.string "::")
+ deps <- P.option [] $ do
+ deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))
+ indented
+ reservedOp "=>"
+ return deps
+ className <- indented *> parseQualified properName
+ tys <- P.many (indented *> parseTypeAtom)
+ return $ ExternInstanceDeclaration name deps className tys)
+ <|> (do ident <- parseIdent
+ js <- P.optionMaybe (JSRaw <$> stringLiteral)
+ ty <- lexeme (indented *> P.string "::") *> parsePolyType
+ return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty))
parseAssociativity :: P.Parsec String ParseState Associativity
parseAssociativity =
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index 0dbaa3e..2d584a3 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -25,7 +25,7 @@ import Control.Monad (when, unless)
import Language.PureScript.Types
import Language.PureScript.Parser.State
import Language.PureScript.Parser.Common
-import Language.PureScript.Prim
+import Language.PureScript.Environment
import qualified Text.Parsec as P
import qualified Text.Parsec.Expr as P
diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs
index aee8427..f148ed5 100644
--- a/src/Language/PureScript/Parser/Values.hs
+++ b/src/Language/PureScript/Parser/Values.hs
@@ -89,7 +89,8 @@ parseLet :: P.Parsec String ParseState Value
parseLet = do
C.reserved "let"
C.indented
- binder <- parseBinder
+ binder <- P.try (Right <$> ((,) <$> C.parseIdent <*> P.many (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))
+ <|> (Left <$> parseBinder)
C.indented
C.reservedOp "="
C.indented
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index afb5da4..38ad1f6 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -110,6 +110,12 @@ literals = mkPattern' match
, return $ "; " ++ ident ++ "++) "
, prettyPrintJS' sts
]
+ match (JSForIn ident obj sts) = fmap concat $ sequence
+ [ return $ "for (var " ++ ident ++ " in "
+ , prettyPrintJS' obj
+ , return ") "
+ , prettyPrintJS' sts
+ ]
match (JSIfElse cond thens elses) = fmap concat $ sequence
[ return "if ("
, prettyPrintJS' cond
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index 5924019..964398c 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -15,12 +15,13 @@
module Language.PureScript.Pretty.Types (
prettyPrintType,
+ prettyPrintTypeAtom,
prettyPrintRow
) where
import Data.Maybe (fromMaybe)
import Data.List (intercalate)
-import Data.Generics (mkT, everywhere)
+import Data.Generics (mkT, everywhere, everywhere')
import Control.Arrow ((<+>))
import Control.PatternArrows
@@ -28,7 +29,7 @@ import Control.Monad.Unify
import Language.PureScript.Types
import Language.PureScript.Pretty.Common
-import Language.PureScript.Prim
+import Language.PureScript.Environment
typeLiterals :: Pattern () Type String
typeLiterals = mkPattern match
@@ -39,9 +40,8 @@ typeLiterals = mkPattern match
match (TypeConstructor ctor) = Just $ show ctor
match (TUnknown (Unknown u)) = Just $ 'u' : show u
match (Skolem s _) = Just $ 's' : show s
- match (ConstrainedType deps ty) = Just $ "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ unwords (map prettyPrintType ty') ++ ")") deps) ++ ") => " ++ prettyPrintType ty
- match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"
- match (ForAll ident ty _) = Just $ "forall " ++ ident ++ ". " ++ prettyPrintType ty
+ match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty
+ match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">"
match REmpty = Just "()"
match row@RCons{} = Just $ '(' : prettyPrintRow row ++ ")"
match _ = Nothing
@@ -77,23 +77,46 @@ appliedFunction = mkPattern match
match _ = Nothing
insertPlaceholders :: Type -> Type
-insertPlaceholders = everywhere (mkT convert)
+insertPlaceholders = everywhere' (mkT convertForAlls) . everywhere (mkT convert)
where
convert (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret
convert (TypeApp a el) | a == tyArray = PrettyPrintArray el
convert other = other
+ convertForAlls (ForAll ident ty _) = go [ident] ty
+ where
+ go idents (ForAll ident' ty' _) = go (ident' : idents) ty'
+ go idents other = PrettyPrintForAll idents other
+ convertForAlls other = other
--- |
--- Generate a pretty-printed string representing a Type
---
-prettyPrintType :: Type -> String
-prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders
+matchTypeAtom :: Pattern () Type String
+matchTypeAtom = typeLiterals <+> fmap parens matchType
+
+matchType :: Pattern () Type String
+matchType = buildPrettyPrinter operators matchTypeAtom
where
- matchType :: Pattern () Type String
- matchType = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchType)
operators :: OperatorTable () Type String
operators =
OperatorTable [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]
, [ AssocR appliedFunction $ \arg ret -> arg ++ " -> " ++ ret
]
+ , [ Wrap forall_ $ \idents ty -> "forall " ++ unwords idents ++ ". " ++ ty ]
]
+
+forall_ :: Pattern () Type ([String], Type)
+forall_ = mkPattern match
+ where
+ match (PrettyPrintForAll idents ty) = Just (idents, ty)
+ match _ = Nothing
+
+-- |
+-- Generate a pretty-printed string representing a Type, as it should appear inside parentheses
+--
+prettyPrintTypeAtom :: Type -> String
+prettyPrintTypeAtom = fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders
+
+
+-- |
+-- Generate a pretty-printed string representing a Type
+--
+prettyPrintType :: Type -> String
+prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 947b46d..39fd6e0 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -105,7 +105,7 @@ prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue (
, [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
, [ Wrap app $ \arg val -> val ++ "(" ++ arg ++ ")" ]
, [ Split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val ]
- , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintValue th ++ " : " ++ prettyPrintValue el ]
+ , [ Wrap ifThenElse $ \(th, el) cond -> "if " ++ cond ++ " then " ++ prettyPrintValue th ++ " else " ++ prettyPrintValue el ]
, [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]
]
diff --git a/src/Language/PureScript/Prim.hs b/src/Language/PureScript/Prim.hs
deleted file mode 100644
index ce204d9..0000000
--- a/src/Language/PureScript/Prim.hs
+++ /dev/null
@@ -1,69 +0,0 @@
------------------------------------------------------------------------------
---
--- 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/Scope.hs b/src/Language/PureScript/Scope.hs
index c2509dc..043552f 100644
--- a/src/Language/PureScript/Scope.hs
+++ b/src/Language/PureScript/Scope.hs
@@ -47,6 +47,7 @@ usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesB `extQ` namesJ
namesJS (JSFunction Nothing args _) = Ident <$> args
namesJS (JSVariableIntroduction name _) = [Ident name]
namesJS (JSFor name _ _ _) = [Ident name]
+ namesJS (JSForIn name _ _) = [Ident name]
namesJS _ = []
-- |
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index e45702d..aa2abe3 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -51,9 +51,9 @@ import Language.PureScript.Sugar.Names as S
desugar :: [Module] -> Either String [Module]
desugar = rebracket
>=> desugarDo
- >=> desugarCasesModule
>=> desugarLetBindings
- >>> desugarImports
+ >>> desugarCasesModule
+ >=> desugarImports
>=> desugarTypeDeclarationsModule
>=> desugarTypeClasses
>=> createBindingGroupsModule
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index 80db161..a729969 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -31,6 +31,7 @@ import Language.PureScript.Declarations
import Language.PureScript.Names
import Language.PureScript.Values
import Language.PureScript.Types
+import Language.PureScript.Environment
-- |
-- Replace all sets of mutually-recursive declarations in a module with binding groups
@@ -59,6 +60,7 @@ createBindingGroups moduleName ds = do
bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts
return $ filter isImportDecl ds ++
filter isExternDataDecl ds ++
+ filter isExternInstanceDecl ds ++
dataBindingGroupDecls ++
filter isTypeClassDeclaration ds ++
filter isFixityDecl ds ++
@@ -72,26 +74,26 @@ collapseBindingGroups :: [Declaration] -> [Declaration]
collapseBindingGroups = concatMap go
where
go (DataBindingGroupDeclaration ds) = ds
- go (BindingGroupDeclaration ds) = map (\(ident, val) -> ValueDeclaration ident [] Nothing val) ds
+ go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] Nothing val) ds
go other = [other]
usedIdents :: (Data d) => ModuleName -> d -> [Ident]
-usedIdents moduleName = nub . everything (++) (mkQ [] names)
+usedIdents moduleName = nub . everything (++) (mkQ [] usedNames)
where
- names :: Value -> [Ident]
- names (Var (Qualified Nothing name)) = [name]
- names (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
- names _ = []
+ usedNames :: Value -> [Ident]
+ usedNames (Var (Qualified Nothing name)) = [name]
+ usedNames (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
+ usedNames _ = []
usedProperNames :: (Data d) => ModuleName -> d -> [ProperName]
-usedProperNames moduleName = nub . everything (++) (mkQ [] names)
+usedProperNames moduleName = nub . everything (++) (mkQ [] usedNames)
where
- names :: Type -> [ProperName]
- names (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
- names _ = []
+ usedNames :: Type -> [ProperName]
+ usedNames (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
+ usedNames _ = []
getIdent :: Declaration -> Ident
-getIdent (ValueDeclaration ident _ _ _) = ident
+getIdent (ValueDeclaration ident _ _ _ _) = ident
getIdent _ = error "Expected ValueDeclaration"
getProperName :: Declaration -> ProperName
@@ -115,7 +117,7 @@ toDataBindingGroup (CyclicSCC ds')
isTypeSynonym TypeSynonymDeclaration{} = True
isTypeSynonym _ = False
-fromValueDecl :: Declaration -> (Ident, Value)
-fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)
+fromValueDecl :: Declaration -> (Ident, NameKind, Value)
+fromValueDecl (ValueDeclaration ident nameKind [] Nothing val) = (ident, nameKind, val)
fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"
fromValueDecl _ = error "Expected ValueDeclaration"
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 5cb4d7b..5fe3e15 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -30,6 +30,7 @@ import Language.PureScript.Names
import Language.PureScript.Values
import Language.PureScript.Declarations
import Language.PureScript.Scope
+import Language.PureScript.Environment
-- |
-- Replace all top-level binders in a module with case expressions.
@@ -60,20 +61,27 @@ desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup
desugarRest [] = pure []
inSameGroup :: Declaration -> Declaration -> Bool
-inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2
+inSameGroup (ValueDeclaration ident1 _ _ _ _) (ValueDeclaration ident2 _ _ _ _) = ident1 == ident2
inSameGroup _ _ = False
toDecls :: [Declaration] -> Either String [Declaration]
-toDecls d@[ValueDeclaration _ [] Nothing _] = return d
-toDecls ds@(ValueDeclaration ident bs _ _ : _) = do
+toDecls [ValueDeclaration ident nameKind bs Nothing val] | all isVarBinder bs = do
+ let args = map (\(VarBinder arg) -> arg) bs
+ body = foldr (Abs . Left) val args
+ return [ValueDeclaration ident nameKind [] Nothing body]
+toDecls ds@(ValueDeclaration ident _ bs _ _ : _) = do
let tuples = map toTuple ds
unless (all ((== length bs) . length . fst) tuples) $
throwError $ "Argument list lengths differ in declaration " ++ show ident
return [makeCaseDeclaration ident tuples]
toDecls ds = return ds
+isVarBinder :: Binder -> Bool
+isVarBinder (VarBinder _) = True
+isVarBinder _ = False
+
toTuple :: Declaration -> ([Binder], (Maybe Guard, Value))
-toTuple (ValueDeclaration _ bs g val) = (bs, (g, val))
+toTuple (ValueDeclaration _ _ bs g val) = (bs, (g, val))
toTuple _ = error "Not a value declaration"
makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> Declaration
@@ -83,7 +91,7 @@ makeCaseDeclaration ident alternatives =
args = take argPattern $ unusedNames (ident, alternatives)
vars = map (Var . Qualified Nothing) args
binders = [ CaseAlternative bs g val | (bs, (g, val)) <- alternatives ]
- value = foldr (\arg ret -> Abs (Left arg) ret) (Case vars binders) args
+ value = foldr (Abs . Left) (Case vars binders) args
in
- ValueDeclaration ident [] Nothing value
+ ValueDeclaration ident Value [] Nothing value
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index ef305ad..07c0e37 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -25,6 +25,8 @@ import Language.PureScript.Values
import Language.PureScript.Names
import Language.PureScript.Scope
+import qualified Language.PureScript.Constants as C
+
-- |
-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,
-- and all @DoNotationLet@ constructors with let expressions.
@@ -33,9 +35,9 @@ desugarDo :: (Data d) => d -> Either String d
desugarDo = everywhereM (mkM replace)
where
prelude :: ModuleName
- prelude = ModuleName [ProperName "Prelude"]
+ prelude = ModuleName [ProperName C.prelude]
bind :: Value
- bind = Var (Qualified (Just prelude) (Op ">>="))
+ bind = Var (Qualified (Just prelude) (Op (C.>>=)))
replace :: Value -> Either String Value
replace (Do els) = go els
replace other = return other
diff --git a/src/Language/PureScript/Sugar/Let.hs b/src/Language/PureScript/Sugar/Let.hs
index 071cddf..6be289a 100644
--- a/src/Language/PureScript/Sugar/Let.hs
+++ b/src/Language/PureScript/Sugar/Let.hs
@@ -28,5 +28,7 @@ import Language.PureScript.Declarations
desugarLetBindings :: [Module] -> [Module]
desugarLetBindings = everywhere (mkT go)
where
- go (Let binder value result) = Case [value] [CaseAlternative [binder] Nothing result]
+ go (Let (Left (VarBinder ident)) value result) = App (Abs (Left ident) result) value
+ go (Let (Left binder) value result) = Case [value] [CaseAlternative [binder] Nothing result]
+ go (Let (Right (ident, binders)) value result) = App (Abs (Left ident) result) (foldr Abs value binders)
go other = other
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 2f9652b..fcebe16 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -29,7 +29,7 @@ import Language.PureScript.Declarations
import Language.PureScript.Names
import Language.PureScript.Types
import Language.PureScript.Values
-import Language.PureScript.Prim
+import Language.PureScript.Environment
-- |
-- The global export environment - every declaration exported from every module.
@@ -97,8 +97,8 @@ addEmptyModule env name = M.insert name (Exports [] [] []) env
--
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.
@@ -147,9 +147,10 @@ desugarImports modules = do
-- 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
+ let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports
+ let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports
+ imports <- resolveImports env m
+ renameInModule imports env (elaborateExports exps m)
-- |
-- Rethrow an error with the name of the current module in the case of a failure
@@ -158,6 +159,16 @@ rethrowForModule :: Module -> Either String a -> Either String a
rethrowForModule (Module mn _ _) = flip catchError $ \e -> throwError ("Error in module '" ++ show mn ++ "':\n" ++ e)
-- |
+-- Make all exports for a module explicit. This may still effect modules that have an exports list,
+-- as it will also make all data constructor exports explicit.
+--
+elaborateExports :: Exports -> Module -> Module
+elaborateExports exps (Module mn decls _) = Module mn decls (Just $
+ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (exportedTypes exps) ++
+ map TypeClassRef (exportedTypeClasses exps) ++
+ map ValueRef (exportedValues exps))
+
+-- |
-- Replaces all local names with qualified names within a module and checks that all existing
-- qualified names are valid.
--
@@ -167,11 +178,13 @@ renameInModule imports exports (Module mn decls exps) =
where
updateDecl (TypeInstanceDeclaration name cs cn ts ds) =
TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> pure ds
+ updateDecl (ExternInstanceDeclaration name cs cn ts) =
+ ExternInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> pure ts
updateDecl d = return d
updateVars :: Declaration -> Either String Declaration
- updateVars (ValueDeclaration name [] Nothing val) =
- ValueDeclaration name [] Nothing <$> everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val
+ updateVars (ValueDeclaration name nameKind [] Nothing val) =
+ ValueDeclaration name nameKind [] Nothing <$> everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val
where
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')
@@ -179,7 +192,7 @@ renameInModule imports exports (Module mn decls exps) =
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 (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
@@ -252,7 +265,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri
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 (ValueDeclaration name _ _ _ _) = addValue env mn name
addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
addDecl _ env _ = return env
@@ -270,10 +283,10 @@ filterExports mn exps env = do
-- Filter the exports for the specific module
filterModule :: Exports -> Either String Exports
filterModule exported = do
- types <- foldM (filterTypes $ exportedTypes exported) [] exps
+ 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 }
+ 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
@@ -357,7 +370,7 @@ resolveImport currentModule importModule exps imps = maybe importAll (foldM impo
values' <- updateImports (importedValues imp) name
return $ imp { importedValues = values' }
importExplicit imp (TypeRef name dctors) = do
- _ <- checkImportExists "type" types name
+ _ <- checkImportExists "type" availableTypes name
types' <- updateImports (importedTypes imp) name
let allDctors = allExportedDataConstructors name
dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
@@ -367,6 +380,7 @@ resolveImport currentModule importModule exps imps = maybe importAll (foldM impo
_ <- checkImportExists "type class" classes name
typeClasses' <- updateImports (importedTypeClasses imp) name
return $ imp { importedTypeClasses = typeClasses' }
+ importExplicit _ _ = error "Invalid argument to importExplicit"
-- Find all exported data constructors for a given type
allExportedDataConstructors :: ProperName -> [ProperName]
@@ -384,7 +398,7 @@ resolveImport currentModule importModule exps imps = maybe importAll (foldM impo
-- The available values, types, and classes in the module being imported
values = exportedValues exps
- types = fst `map` exportedTypes exps
+ availableTypes = fst `map` exportedTypes exps
classes = exportedTypeClasses exps
-- Ensure that an explicitly imported data constructor exists for the type it is being imported
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 98812ff..51b63ee 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -25,15 +25,15 @@ 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
+import Language.PureScript.Environment
+import Language.PureScript.CodeGen.Common (identToJs)
import Control.Applicative
import Control.Monad.State
import Control.Arrow (second)
+import Data.Maybe (catMaybes)
-import Language.PureScript.CodeGen.Common (identToJs)
+import qualified Data.Map as M
type MemberMap = M.Map (ModuleName, ProperName) ([String], [(String, Type)])
@@ -47,7 +47,10 @@ desugarTypeClasses :: [Module] -> Either String [Module]
desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
desugarModule :: Module -> Desugar Module
-desugarModule (Module name decls exps) = Module name <$> concat <$> mapM (desugarDecl name) decls <*> pure exps
+desugarModule (Module name decls (Just exps)) = do
+ (newExpss, declss) <- unzip <$> mapM (desugarDecl name) decls
+ return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss)
+desugarModule _ = error "Exports should have been elaborated in name desugaring"
-- |
-- Desugar type class and type class instance declarations
@@ -87,17 +90,17 @@ desugarModule (Module name decls exps) = Module name <$> concat <$> mapM (desuga
-- __Test_Foo_array :: forall a. Foo a -> Foo [a]
-- __Test_Foo_array _1 = { foo: __Test_Foo_array_foo _1 :: [a] -> [a] (unchecked) }
--
-desugarDecl :: ModuleName -> Declaration -> Desugar [Declaration]
+desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
desugarDecl mn d@(TypeClassDeclaration name args members) = do
let tys = map memberToNameAndType members
modify (M.insert (mn, name) (args, tys))
- return $ d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members
+ return $ (Nothing, d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members)
desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do
desugared <- lift $ desugarCases members
entries <- mapM (typeInstanceDictionaryEntryDeclaration name mn deps className ty) desugared
dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
- return $ d : entries ++ [dictDecl]
-desugarDecl _ other = return [other]
+ return $ (Just $ TypeInstanceRef name, d : entries ++ [dictDecl])
+desugarDecl _ other = return (Nothing, [other])
memberToNameAndType :: Declaration -> (String, Type)
memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty)
@@ -122,7 +125,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do
let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
let entryName = Escaped (show name)
memberNames <- mapM (memberToNameAndValue memberTypes) decls
- return $ ValueDeclaration entryName [] Nothing
+ return $ ValueDeclaration entryName TypeInstanceDictionaryValue [] Nothing
(TypedValue True
(foldr (Abs . (\n -> Left . Ident $ '_' : show n)) (ObjectLiteral memberNames) [1..max 1 (length deps)])
(quantify (if null deps then
@@ -132,7 +135,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do
)
where
memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)
- memberToNameAndValue tys' (ValueDeclaration ident _ _ _) = do
+ memberToNameAndValue tys' (ValueDeclaration ident _ _ _ _) = do
memberType <- lift . maybe (Left "Type class member type not found") Right $ lookup (identToJs ident) tys'
memberName <- mkDictionaryEntryName name ident
return (identToJs ident, TypedValue False
@@ -141,13 +144,13 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do
memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"
typeInstanceDictionaryEntryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> Declaration -> Desugar Declaration
-typeInstanceDictionaryEntryDeclaration name mn deps className tys (ValueDeclaration ident [] _ val) = do
+typeInstanceDictionaryEntryDeclaration name mn deps className tys (ValueDeclaration ident _ [] _ val) = do
m <- get
valTy <- lift $ do (args, members) <- lookupTypeClass m
ty' <- lookupIdent members
return $ replaceAllTypeVars (zip args tys) ty'
entryName <- mkDictionaryEntryName name ident
- return $ ValueDeclaration entryName [] Nothing
+ return $ ValueDeclaration entryName TypeInstanceMember [] Nothing
(TypedValue True val (quantify (if null deps then valTy else ConstrainedType deps valTy)))
where
lookupTypeClass m = maybe (Left $ "Type class " ++ show className ++ " is undefined. Type class names must be qualified.") Right $ M.lookup (qualify mn className) m
diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs
index 136d713..df72385 100644
--- a/src/Language/PureScript/Sugar/TypeDeclarations.hs
+++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs
@@ -36,8 +36,8 @@ desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) -> Module na
-- Replace all top level type declarations with type annotations
--
desugarTypeDeclarations :: [Declaration] -> Either String [Declaration]
-desugarTypeDeclarations (TypeDeclaration name ty : ValueDeclaration name' [] Nothing val : rest) | name == name' =
- desugarTypeDeclarations (ValueDeclaration name [] Nothing (TypedValue True val ty) : rest)
+desugarTypeDeclarations (TypeDeclaration name ty : ValueDeclaration name' nameKind [] Nothing val : rest) | name == name' =
+ desugarTypeDeclarations (ValueDeclaration name nameKind [] Nothing (TypedValue True val ty) : rest)
desugarTypeDeclarations (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name
desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds
desugarTypeDeclarations [] = return []
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 4b34979..6af31a7 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -35,12 +35,12 @@ import Language.PureScript.Names
import Language.PureScript.Values
import Language.PureScript.Kinds
import Language.PureScript.Declarations
-import Language.PureScript.Prim
+import Language.PureScript.Environment
addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()
addDataType moduleName name args dctors ctorKind = do
env <- getEnv
- putEnv $ env { types = M.insert (Qualified (Just moduleName) name) ctorKind (types env) }
+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
forM_ dctors $ \(dctor, tys) ->
rethrow (("Error in data constructor " ++ show dctor ++ ":\n") ++) $
addDataConstructor moduleName name args dctor tys
@@ -51,12 +51,12 @@ addDataConstructor moduleName name args dctor tys = do
let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
let dctorTy = foldr function retTy tys
let polyType = mkForAll args dctorTy
- putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) polyType (dataConstructors env) }
+ putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (name, polyType) (dataConstructors env) }
addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()
addTypeSynonym moduleName name args ty kind = do
env <- getEnv
- putEnv $ env { types = M.insert (Qualified (Just moduleName) name) kind (types env)
+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)
, typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }
valueIsNotDefined :: ModuleName -> Ident -> Check ()
@@ -66,10 +66,15 @@ valueIsNotDefined moduleName name = do
Just _ -> throwError $ show name ++ " is already defined"
Nothing -> return ()
-addValue :: ModuleName -> Ident -> Type -> Check ()
-addValue moduleName name ty = do
+addValue :: ModuleName -> Ident -> Type -> NameKind -> Check ()
+addValue moduleName name ty nameKind = do
env <- getEnv
- putEnv (env { names = M.insert (moduleName, name) (ty, Value) (names env) })
+ putEnv (env { names = M.insert (moduleName, name) (ty, nameKind) (names env) })
+
+addTypeClass :: ModuleName -> ProperName -> [String] -> [Declaration] -> Check ()
+addTypeClass moduleName pn args ds =
+ let members = map (\(TypeDeclaration ident ty) -> (ident, ty)) ds in
+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members) (typeClasses . checkEnv $ st) } }
addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()
addTypeClassDictionaries entries =
@@ -128,29 +133,29 @@ typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty)
ds <- typeCheckAll mainModuleName moduleName rest
return $ d : ds
typeCheckAll _ _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
-typeCheckAll mainModuleName moduleName (ValueDeclaration name [] Nothing val : rest) = do
+typeCheckAll mainModuleName moduleName (ValueDeclaration name nameKind [] Nothing val : rest) = do
d <- rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do
valueIsNotDefined moduleName name
[(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
- addValue moduleName name ty
- return $ ValueDeclaration name [] Nothing val'
+ addValue moduleName name ty nameKind
+ return $ ValueDeclaration name nameKind [] Nothing val'
ds <- typeCheckAll mainModuleName moduleName rest
return $ d : ds
typeCheckAll _ _ (ValueDeclaration{} : _) = error "Binders were not desugared"
typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = do
- d <- rethrow (("Error in binding group " ++ show (map fst vals) ++ ":\n") ++) $ do
- forM_ (map fst vals) $ \name ->
+ d <- rethrow (("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals) ++ ":\n") ++) $ do
+ forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
valueIsNotDefined moduleName name
- tys <- typesOf mainModuleName moduleName vals
- vals' <- forM (zip (map fst vals) (map snd tys)) $ \(name, (val, ty)) -> do
- addValue moduleName name ty
- return (name, val)
+ tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
+ vals' <- forM (zipWith (\(name, nameKind, _) (_, (val, ty)) -> (name, val, nameKind, ty)) vals tys) $ \(name, val, nameKind, ty) -> do
+ addValue moduleName name ty nameKind
+ return (name, nameKind, val)
return $ BindingGroupDeclaration vals'
ds <- typeCheckAll mainModuleName moduleName rest
return $ d : ds
typeCheckAll mainModuleName moduleName (d@(ExternDataDeclaration name kind) : rest) = do
env <- getEnv
- putEnv $ env { types = M.insert (Qualified (Just moduleName) name) kind (types env) }
+ putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }
ds <- typeCheckAll mainModuleName moduleName rest
return $ d : ds
typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do
@@ -179,10 +184,13 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _) :
addTypeClassDictionaries [tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (tcdName tcd) }]
ds <- typeCheckAll mainModuleName currentModule rest
return $ d : ds
-typeCheckAll mainModuleName moduleName (d@TypeClassDeclaration{} : rest) = do
+typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration pn args tys) : rest) = do
+ addTypeClass moduleName pn args tys
ds <- typeCheckAll mainModuleName moduleName rest
return $ d : ds
-typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration dictName deps className tys _) : rest) = do
+typeCheckAll mainModuleName moduleName (TypeInstanceDeclaration dictName deps className tys _ : rest) = do
+ typeCheckAll mainModuleName moduleName (ExternInstanceDeclaration dictName deps className tys : rest)
+typeCheckAll mainModuleName moduleName (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do
mapM_ (checkTypeClassInstance moduleName) tys
forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular]
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index a94e914..aac09b8 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -27,6 +27,7 @@ import Language.PureScript.Kinds
import Language.PureScript.Names
import Language.PureScript.TypeChecker.Monad
import Language.PureScript.Pretty
+import Language.PureScript.Environment
import Control.Monad.State
import Control.Monad.Error
@@ -70,11 +71,11 @@ kindsOf :: ModuleName -> ProperName -> [String] -> [Type] -> Check Kind
kindsOf moduleName name args ts = fmap tidyUp . liftUnify $ do
tyCon <- fresh
kargs <- replicateM (length args) fresh
- let dict = (name, tyCon) : zip (map ProperName args) kargs
+ let dict = (name, tyCon) : zipWith (\arg kind -> (arg, kind)) (map ProperName args) kargs
bindLocalTypeVariables moduleName dict $
solveTypes ts kargs tyCon
where
- tidyUp (k, sub) = sub $? k
+ tidyUp (k, sub) = starIfUnknown $ sub $? k
-- |
-- Simultaneously infer the kinds of several mutually recursive type constructors
@@ -134,7 +135,7 @@ infer (TypeConstructor v) = do
env <- liftCheck getEnv
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
+ Just (kind, _) -> return kind
infer (TypeApp t1 t2) = do
k0 <- fresh
k1 <- infer t1
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 3026ac4..c4a5312 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -22,8 +22,7 @@ import Language.PureScript.Types
import Language.PureScript.Kinds
import Language.PureScript.Values
import Language.PureScript.Names
-import Language.PureScript.Declarations
-import Language.PureScript.Prim
+import Language.PureScript.Environment
import Data.Maybe
@@ -31,64 +30,10 @@ import Control.Applicative
import Control.Monad.State
import Control.Monad.Error
import Control.Monad.Unify
-import Control.Arrow (first)
import qualified Data.Map as M
-- |
--- The type of a name in the @Environment@
---
-data NameKind
- -- |
- -- A value introduced as a binding in a module
- --
- = Value
- -- |
- -- A foreign import
- --
- | Extern ForeignImportType
- -- |
- -- A local name introduced using a lambda abstraction, variable introduction or binder
- --
- | LocalVariable
- -- |
- -- A data constructor
- --
- | DataConstructor deriving Show
-
--- |
--- The @Environment@ defines all values and types which are currently in scope:
---
-data Environment = Environment {
- -- |
- -- Value names currently in scope
- --
- names :: M.Map (ModuleName, Ident) (Type, NameKind)
- -- |
- -- Type names currently in scope
- --
- , types :: M.Map (Qualified ProperName) Kind
- -- |
- -- Data constructors currently in scope, along with their associated data type constructors
- --
- , dataConstructors :: M.Map (Qualified ProperName) Type
- -- |
- -- Type synonyms currently in scope
- --
- , typeSynonyms :: M.Map (Qualified ProperName) ([String], Type)
- -- |
- -- Available type class dictionaries
- --
- , typeClassDictionaries :: [TypeClassDictionaryInScope]
- } deriving (Show)
-
--- |
--- The initial environment with no values and only the default javascript types defined
---
-initEnvironment :: Environment
-initEnvironment = Environment M.empty primTypes M.empty M.empty []
-
--- |
-- Temporarily bind a collection of names to values
--
bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a
@@ -102,7 +47,7 @@ bindNames newNames action = do
-- |
-- Temporarily bind a collection of names to types
--
-bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) Kind -> m a -> m a
+bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) (Kind, TypeKind) -> m a -> m a
bindTypes newNames action = do
orig <- get
modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }
@@ -139,7 +84,7 @@ bindLocalVariables moduleName bindings =
--
bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a
bindLocalTypeVariables moduleName bindings =
- bindTypes (M.fromList $ flip map bindings $ first $ Qualified (Just moduleName))
+ bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable)))
-- |
-- Lookup the type of a value by name in the @Environment@
@@ -159,7 +104,7 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do
env <- getEnv
case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of
Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"
- Just k -> return k
+ Just (k, _) -> return k
-- |
-- State required for type checking:
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 2b89d35..415e2c4 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -56,7 +56,8 @@ import Language.PureScript.TypeChecker.Monad
import Language.PureScript.TypeChecker.Kinds
import Language.PureScript.TypeChecker.Synonyms
import Language.PureScript.Pretty
-import Language.PureScript.Prim
+import Language.PureScript.Environment
+import qualified Language.PureScript.Constants as C
import Control.Monad.State
import Control.Monad.Error
@@ -197,7 +198,7 @@ typesOf mainModuleName moduleName vals = do
ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
return (ident, (TypedValue True val'' ty, ty))
-- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a
- when (Just moduleName == mainModuleName && fst e == Ident "main") $ do
+ when (Just moduleName == mainModuleName && fst e == Ident C.main) $ do
[eff, a] <- replicateM 2 fresh
ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a
-- Make sure unification variables do not escape
@@ -255,7 +256,7 @@ entails :: ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName,
entails moduleName context goal@(className, tys) = do
env <- getEnv
case go env goal of
- [] -> throwError $ "No " ++ show className ++ " instance found for " ++ intercalate ", " (map prettyPrintType tys)
+ [] -> throwError $ "No " ++ show className ++ " instance found for " ++ intercalate ", " (map prettyPrintType tys) ++ show (typeClassDictionaries env)
(dict : _) -> return dict
where
go env (className', tys') =
@@ -532,8 +533,8 @@ infer' v@(Constructor c) = do
env <- getEnv
case M.lookup c (dataConstructors env) of
Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
- Just ty -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
- return $ TypedValue True v ty'
+ Just (_, ty) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
+ return $ TypedValue True v ty'
infer' (Case vals binders) = do
ts <- mapM infer vals
ret <- fresh
@@ -581,7 +582,7 @@ inferBinder val (VarBinder name) = return $ M.singleton name val
inferBinder val (ConstructorBinder ctor binders) = do
env <- getEnv
case M.lookup ctor (dataConstructors env) of
- Just ty -> do
+ Just (_, ty) -> do
(_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contains constraints") ty
go binders fn
where
@@ -777,7 +778,7 @@ check' (Constructor c) ty = do
env <- getEnv
case M.lookup c (dataConstructors env) of
Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
- Just ty1 -> do
+ Just (_, ty1) -> do
repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
_ <- subsumes Nothing repl ty
return $ TypedValue True (Constructor c) ty
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index 2f2fe79..a7b49c2 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -86,7 +86,11 @@ data Type
-- |
-- A placeholder used in pretty printing
--
- | PrettyPrintArray Type deriving (Show, Eq, Data, Typeable)
+ | PrettyPrintArray Type
+ -- |
+ -- A placeholder used in pretty printing
+ --
+ | PrettyPrintForAll [String] Type deriving (Show, Eq, Data, Typeable)
-- |
-- Convert a row to a list of pairs of labels and types
diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs
index 03d376a..76c900b 100644
--- a/src/Language/PureScript/Values.hs
+++ b/src/Language/PureScript/Values.hs
@@ -102,7 +102,7 @@ data Value
-- |
-- A let binding
--
- | Let Binder Value Value
+ | Let (Either Binder (Ident, [Either Ident Binder])) Value Value
-- |
-- A do-notation block
--