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