diff options
| author | PhilFreeman <> | 2014-03-09 17:59:00 (GMT) |
|---|---|---|
| committer | hdiff <hdiff@hdiff.luite.com> | 2014-03-09 17:59:00 (GMT) |
| commit | 6e481f4a8bccb1fc4972bafa95be389cf04cefd9 (patch) | |
| tree | c17626f4d1f5b18d6a127ca426b6c0cc76300118 | |
| parent | 9d10caf3f416dc113b0ee73ff84a2f49173c6f44 (diff) | |
version 0.4.50.4.5
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 -- |