purescript 0.4.3.1 → 0.4.4

raw patch · 37 files changed

+1133/−857 lines, 37 files

Files

• docgen/Main.hs +56/−33
• prelude/prelude.purs +16/−10
• psci/Main.hs +12/−6
• purescript.cabal +10/−2
• src/Data/Generics/Extras.hs +0/−1
• src/Language/PureScript.hs +4/−4
• src/Language/PureScript/CodeGen.hs +0/−1
• src/Language/PureScript/CodeGen/Externs.hs +2/−1
• src/Language/PureScript/CodeGen/JS.hs +10/−13
• src/Language/PureScript/CodeGen/Optimize.hs +0/−462
• src/Language/PureScript/DeadCodeElimination.hs +6/−7
• src/Language/PureScript/Declarations.hs +13/−12
• src/Language/PureScript/ModuleDependencies.hs +1/−1
• src/Language/PureScript/Optimizer.hs +74/−0
• src/Language/PureScript/Optimizer/Blocks.hs +35/−0
• src/Language/PureScript/Optimizer/Common.hs +76/−0
• src/Language/PureScript/Optimizer/Inliner.hs +138/−0
• src/Language/PureScript/Optimizer/MagicDo.hs +153/−0
• src/Language/PureScript/Optimizer/TCO.hs +102/−0
• src/Language/PureScript/Optimizer/Unused.hs +31/−0
• src/Language/PureScript/Parser/Declarations.hs +7/−6
• src/Language/PureScript/Parser/Types.hs +5/−2
• src/Language/PureScript/Pretty/Types.hs +1/−0
• src/Language/PureScript/Prim.hs +69/−0
• src/Language/PureScript/Sugar/BindingGroups.hs +3/−3
• src/Language/PureScript/Sugar/CaseDeclarations.hs +2/−2
• src/Language/PureScript/Sugar/DoNotation.hs +0/−2
• src/Language/PureScript/Sugar/Names.hs +268/−170
• src/Language/PureScript/Sugar/Operators.hs +2/−2
• src/Language/PureScript/Sugar/TypeClasses.hs +3/−6
• src/Language/PureScript/Sugar/TypeDeclarations.hs +1/−1
• src/Language/PureScript/TypeChecker.hs +3/−6
• src/Language/PureScript/TypeChecker/Kinds.hs +0/−1
• src/Language/PureScript/TypeChecker/Monad.hs +2/−13
• src/Language/PureScript/TypeChecker/Synonyms.hs +7/−8
• src/Language/PureScript/TypeChecker/Types.hs +20/−46
• src/Language/PureScript/Types.hs +1/−36

@@ -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

@@ -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);\

@@ -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.

@@ -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,

@@ -18,7 +18,6 @@ module Data.Generics.Extras where  import Data.Data-import Data.Maybe (fromMaybe)  -- | -- Apply a top-down monadic transformation everywhere

@@ -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

@@ -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

@@ -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) 

@@ -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

@@ -1,462 +0,0 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Optimize--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- This module optimizes code in the simplified-Javascript intermediate representation.------ The following optimizations are supported:------  * Collapsing nested blocks------  * Tail call elimination------  * Inlining of (>>=) and ret for the Eff monad------  * Removal of unused variables------  * Removal of unnecessary thunks------  * Eta conversion------  * Inlining variables------  * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!)------  * Inlining primitive Javascript operators-----------------------------------------------------------------------------------module Language.PureScript.CodeGen.Optimize (-    optimize-) where--import Data.Data-import Data.List (nub)-import Data.Maybe (fromJust, isJust, fromMaybe)-import Data.Generics--import Language.PureScript.Names-import Language.PureScript.CodeGen.JS.AST-import Language.PureScript.Options-import Language.PureScript.CodeGen.Common (identToJs)-import Language.PureScript.Types---- |--- Apply a series of optimizer passes to simplified Javascript code----optimize :: Options -> JS -> JS-optimize opts | optionsNoOptimizations opts = id-              | otherwise = untilFixedPoint $ applyAll-  [ collapseNestedBlocks-  , tco opts-  , magicDo opts-  , removeUnusedVariables-  , unThunk-  , etaConvert-  , inlineVariables-  , inlineOperator "$" $ \f x -> JSApp f [x]-  , inlineOperator "#" $ \x f -> JSApp f [x]-  , inlineOperator "!!" $ flip JSIndexer-  , inlineOperator "++" $ JSBinary Add-  , inlineCommonOperators ]--applyAll :: [a -> a] -> a -> a-applyAll = foldl1 (.)--untilFixedPoint :: (Eq a) => (a -> a) -> a -> a-untilFixedPoint f = go-  where-  go a = let a' = f a in-          if a' == a then a' else go a'--replaceIdent :: (Data d) => String -> JS -> d -> d-replaceIdent var1 js = everywhere (mkT replace)-  where-  replace (JSVar var2) | var1 == var2 = js-  replace other = other--replaceIdents :: (Data d) => [(String, JS)] -> d -> d-replaceIdents vars = everywhere (mkT replace)-  where-  replace v@(JSVar var) = fromMaybe v $ lookup var vars-  replace other = other--isReassigned :: (Data d) => String -> d -> Bool-isReassigned var1 = everything (||) (mkQ False check)-  where-  check :: JS -> Bool-  check (JSFunction _ args _) | var1 `elem` args = True-  check (JSVariableIntroduction arg _) | var1 == arg = True-  check (JSAssignment (JSVar arg) _) | var1 == arg = True-  check _ = False--isRebound :: (Data d) => JS -> d -> Bool-isRebound js d = any (`isReassigned` d) (everything (++) (mkQ [] variablesOf) js)-  where-  variablesOf (JSVar var) = [var]-  variablesOf _ = []--isUsed :: (Data d) => String -> d -> Bool-isUsed var1 = everything (||) (mkQ False check)-  where-  check :: JS -> Bool-  check (JSVar var2) | var1 == var2 = True-  check (JSAssignment target _) | var1 == targetVariable target = True-  check _ = False--targetVariable :: JS -> String-targetVariable (JSVar var) = var-targetVariable (JSAccessor _ tgt) = targetVariable tgt-targetVariable (JSIndexer _ tgt) = targetVariable tgt-targetVariable _ = error "Invalid argument to targetVariable"--isUpdated :: (Data d) => String -> d -> Bool-isUpdated var1 = everything (||) (mkQ False check)-  where-  check :: JS -> Bool-  check (JSAssignment target _) | var1 == targetVariable target = True-  check _ = False--shouldInline :: JS -> Bool-shouldInline (JSVar _) = True-shouldInline (JSNumericLiteral _) = True-shouldInline (JSStringLiteral _) = True-shouldInline (JSBooleanLiteral _) = True-shouldInline (JSAccessor _ val) = shouldInline val-shouldInline (JSIndexer index val) = shouldInline index && shouldInline val-shouldInline _ = False--removeFromBlock :: ([JS] -> [JS]) -> JS -> JS-removeFromBlock go (JSBlock sts) = JSBlock (go sts)-removeFromBlock _  js = js--inlineVariables :: JS -> JS-inlineVariables = everywhere (mkT $ removeFromBlock go)-  where-  go :: [JS] -> [JS]-  go [] = []-  go (JSVariableIntroduction var (Just js) : sts)-    | shouldInline js && not (isReassigned var sts) && not (isRebound js sts) && not (isUpdated var sts) =-      go (replaceIdent var js sts)-  go (s:sts) = s : go sts--removeUnusedVariables :: JS -> JS-removeUnusedVariables = everywhere (mkT $ removeFromBlock go)-  where-  go :: [JS] -> [JS]-  go [] = []-  go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts-  go (s:sts) = s : go sts--etaConvert :: JS -> JS-etaConvert = everywhere (mkT convert)-  where-  convert :: JS -> JS-  convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])-    | all shouldInline args &&-      not (any (`isRebound` block) (map JSVar idents)) &&-      not (any (`isRebound` block) args)-      = JSBlock (replaceIdents (zip idents args) body)-  convert js = js--unThunk :: JS -> JS-unThunk = everywhere (mkT convert)-  where-  convert :: JS -> JS-  convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body-  convert js = js--tco :: Options -> JS -> JS-tco opts | optionsTco opts = tco'-         | otherwise = id--tco' :: JS -> JS-tco' = everywhere (mkT convert)-  where-  tcoLabel :: String-  tcoLabel = "tco"-  tcoVar :: String -> String-  tcoVar arg = "__tco_" ++ arg-  copyVar :: String -> String-  copyVar arg = "__copy_" ++ arg-  convert :: JS -> JS-  convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =-    let-      (argss, body', replace) = collectAllFunctionArgs [] id fn-    in case () of-      _ | isTailCall name body' ->-            let-              allArgs = reverse $ concat argss-            in-              JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))-        | otherwise -> js-  convert js = js-  collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)-  collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =-    collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body-  collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =-    (args : allArgs, body, f . JSFunction ident (map copyVar args))-  collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =-    collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body-  collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =-    (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))-  collectAllFunctionArgs allArgs f body = (allArgs, body, f)-  isTailCall :: String -> JS -> Bool-  isTailCall ident js =-    let-      numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js-      numSelfCallsInTailPosition = everything (+) (mkQ 0 countSelfCallsInTailPosition) js-      numSelfCallsUnderFunctions = everything (+) (mkQ 0 countSelfCallsUnderFunctions) js-    in-      numSelfCalls > 0-      && numSelfCalls == numSelfCallsInTailPosition-      && numSelfCallsUnderFunctions == 0-    where-    countSelfCalls :: JS -> Int-    countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1-    countSelfCalls _ = 0-    countSelfCallsInTailPosition :: JS -> Int-    countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1-    countSelfCallsInTailPosition _ = 0-    countSelfCallsUnderFunctions (JSFunction _ _ js') = everything (+) (mkQ 0 countSelfCalls) js'-    countSelfCallsUnderFunctions _ = 0-  toLoop :: String -> [String] -> JS -> JS-  toLoop ident allArgs js = JSBlock $-        map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++-        [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhere (mkT loopify) js ]) ]-    where-    loopify :: JS -> JS-    loopify (JSReturn ret) | isSelfCall ident ret =-      let-        allArgumentValues = concat $ collectSelfCallArgs [] ret-      in-        JSBlock $ zipWith (\val arg ->-                    JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs-                  ++ map (\arg ->-                    JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs-                  ++ [ JSContinue tcoLabel ]-    loopify other = other-    collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]-    collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn-    collectSelfCallArgs allArgumentValues _ = allArgumentValues-  isSelfCall :: String -> JS -> Bool-  isSelfCall ident (JSApp (JSVar ident') _) | ident == ident' = True-  isSelfCall ident (JSApp fn _) = isSelfCall ident fn-  isSelfCall _ _ = False--magicDo :: Options -> JS -> JS-magicDo opts | optionsMagicDo opts = inlineST . magicDo'-             | otherwise = id---- |--- Inline type class dictionaries for >>= and return for the Eff monad------ E.g.------  Prelude[">>="](dict)(m1)(function(x) {---    return ...;---  })------ becomes------  function __do {---    var x = m1();---    ...---  }----magicDo' :: JS -> JS-magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)-  where-  -- The name of the function block which is added to denote a do block-  fnName = "__do"-  -- Desugar monomorphic calls to >>= and return for the Eff monad-  convert :: JS -> JS-  -- Desugar return-  convert (JSApp (JSApp ret [val]) []) | isReturn ret = val-  -- Desugae >>-  convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock [JSReturn ret])]) | isBind bind =-    JSFunction (Just fnName) [] $ JSBlock [ JSApp m [], JSReturn (JSApp ret []) ]-  -- Desugar >>=-  convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =-    JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]-  -- Desugar untilE-  convert (JSApp (JSApp f [arg]) []) | isEffFunc "untilE" f =-    JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn (JSObjectLiteral []) ])) []-  -- Desugar whileE-  convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc "whileE" f =-    JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn (JSObjectLiteral []) ])) []-  convert other = other-  -- Check if an expression represents a monomorphic call to >>= for the Eff monad-  isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict effDict = True-  isBind _ = False-  -- Check if an expression represents a monomorphic call to return for the Eff monad-  isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict effDict = True-  isReturn _ = False-  -- Check if an expression represents the polymorphic >>= function-  isBindPoly (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) | prop == identToJs (Op ">>=") = True-  isBindPoly (JSIndexer (JSStringLiteral ">>=") (JSAccessor "Prelude" (JSVar "_ps"))) = True-  isBindPoly _ = False-  -- Check if an expression represents the polymorphic return function-  isRetPoly (JSAccessor "$return" (JSAccessor "Prelude" (JSVar "_ps"))) = True-  isRetPoly (JSIndexer (JSStringLiteral "return") (JSAccessor "Prelude" (JSVar "_ps"))) = True-  isRetPoly _ = False-  -- Check if an expression represents a function in the Ef module-  isEffFunc name (JSAccessor name' (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) | name == name' = True-  isEffFunc _ _ = False-  -- Module names-  prelude = ModuleName [ProperName "Prelude"]-  effModule = ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"]-  -- The name of the type class dictionary for the Monad Eff instance-  effDictName = "monadEff"-  -- Check if an expression represents the Monad Eff dictionary-  isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == effDictName = True-  isEffDict (JSApp (JSAccessor prop (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True-  isEffDict _ = False-  -- Remove __do function applications which remain after desugaring-  undo :: JS -> JS-  undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body-  undo other = other---- |--- Inline functions in the ST module----inlineST :: JS -> JS-inlineST = everywhere (mkT convertBlock)-  where-  -- Look for runST blocks and inline the STRefs there.-  -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then-  -- we can be more aggressive about inlining, and actually turn STRefs into local variables.-  convertBlock (JSApp f [arg]) | isSTFunc "runST" f || isSTFunc "runSTArray" f =-    let refs = nub . findSTRefsIn $ arg-        usages = findAllSTUsagesIn arg-        allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages-        localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs-    in everywhere (mkT $ convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg-  convertBlock other = other-  -- Convert a block in a safe way, preserving object wrappers of references,-  -- or in a more aggressive way, turning wrappers into local variables depending on the-  -- agg(ressive) parameter.-  convert agg (JSApp (JSApp f [arg]) []) | isSTFunc "newSTRef" f =-    if agg then arg else JSObjectLiteral [("value", arg)]-  convert agg (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f =-    if agg then ref else JSAccessor "value" ref-  convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc "writeSTRef" f =-    if agg then JSAssignment ref arg else JSAssignment (JSAccessor "value" ref) arg-  convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc "modifySTRef" f =-    if agg then JSAssignment ref (JSApp func [ref]) else  JSAssignment (JSAccessor "value" ref) (JSApp func [JSAccessor "value" ref])-  convert _ (JSApp (JSApp (JSApp f [arr]) [i]) []) | isSTFunc "peekSTArray" f =-    JSIndexer i arr-  convert _ (JSApp (JSApp (JSApp (JSApp f [arr]) [i]) [val]) []) | isSTFunc "pokeSTArray" f =-    JSAssignment (JSIndexer i arr) val-  convert _ other = other-  -- Check if an expression represents a function in the ST module-  isSTFunc name (JSAccessor name' (JSAccessor "Control_Monad_ST" (JSVar "_ps"))) | name == name' = True-  isSTFunc _ _ = False-  -- Find all ST Refs initialized in this block-  findSTRefsIn = everything (++) (mkQ [] isSTRef)-    where-    isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc "newSTRef" f = [ident]-    isSTRef _ = []-  -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef-  findAllSTUsagesIn = everything (++) (mkQ [] isSTUsage)-    where-    isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f = [ref]-    isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc "writeSTRef" f || isSTFunc "modifySTRef" f = [ref]-    isSTUsage _ = []-  -- Find all uses of a variable-  appearingIn ref = everything (++) (mkQ [] isVar)-    where-    isVar e@(JSVar v) | v == ref = [e]-    isVar _ = []-  -- Convert a JS value to a String if it is a JSVar-  toVar (JSVar v) = Just v-  toVar _ = Nothing--collapseNestedBlocks :: JS -> JS-collapseNestedBlocks = everywhere (mkT collapse)-  where-  collapse :: JS -> JS-  collapse (JSBlock sts) = JSBlock (concatMap go sts)-  collapse js = js-  go :: JS -> [JS]-  go (JSBlock sts) = sts-  go s = [s]--inlineOperator :: String -> (JS -> JS -> JS) -> JS -> JS-inlineOperator op f = everywhere (mkT convert)-  where-  convert :: JS -> JS-  convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y-  convert other = other-  isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar "_ps"))) | longForm == identToJs (Op op) = True-  isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | op == op' = True-  isOp _ = False--inlineCommonOperators :: JS -> JS-inlineCommonOperators = applyAll-  [ binary "numNumber" "+" "Num" tyNumber Add-  , binary "numNumber" "-" "Num" tyNumber Subtract-  , binary "numNumber" "*" "Num" tyNumber Multiply-  , binary "numNumber" "/" "Num" tyNumber Divide-  , binary "numNumber" "%" "Num" tyNumber Modulus-  , unary  "numNumber" "negate" "Num" tyNumber Negate--  , binary "ordNumber" "<" "Ord" tyNumber LessThan-  , binary "ordNumber" ">" "Ord" tyNumber GreaterThan-  , binary "ordNumber" "<=" "Ord" tyNumber LessThanOrEqualTo-  , binary "ordNumber" ">=" "Ord" tyNumber GreaterThanOrEqualTo--  , binary "eqNumber" "==" "Eq" tyNumber EqualTo-  , binary "eqNumber" "/=" "Eq" tyNumber NotEqualTo-  , binary "eqString" "==" "Eq" tyString EqualTo-  , binary "eqString" "/=" "Eq" tyString NotEqualTo-  , binary "eqBoolean" "==" "Eq" tyBoolean EqualTo-  , binary "eqBoolean" "/=" "Eq" tyBoolean NotEqualTo--  , binaryFunction "bitsNumber" "shl" "Bits" tyNumber ShiftLeft-  , binaryFunction "bitsNumber" "shr" "Bits" tyNumber ShiftRight-  , binaryFunction "bitsNumber" "zshr" "Bits" tyNumber ZeroFillShiftRight-  , binary         "bitsNumber" "&" "Bits" tyNumber BitwiseAnd-  , binary         "bitsNumber" "|" "Bits" tyNumber BitwiseOr-  , binary         "bitsNumber" "^" "Bits" tyNumber BitwiseXor-  , unary          "bitsNumber" "complement" "Bits" tyNumber BitwiseNot--  , binary "boolLikeBoolean" "&&" "BoolLike" tyBoolean And-  , binary "boolLikeBoolean" "||" "BoolLike" tyBoolean Or-  , unary  "boolLikeBoolean" "not" "BoolLike" tyBoolean Not-  ]-  where-  binary :: String -> String -> String -> Type -> BinaryOperator -> JS -> JS-  binary dictName opString className classTy op = everywhere (mkT convert)-    where-    convert :: JS -> JS-    convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName className classTy dict = JSBinary op x y-    convert other = other-    isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar _))) | longForm == identToJs (Op opString) = True-    isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | opString == op' = True-    isOp _ = False-  binaryFunction :: String -> String -> String -> Type -> BinaryOperator -> JS -> JS-  binaryFunction dictName fnName className classTy op = everywhere (mkT convert)-    where-    convert :: JS -> JS-    convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName className classTy dict = JSBinary op x y-    convert other = other-    isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName == fnName' = True-    isOp _ = False-  unary :: String -> String -> String -> Type -> UnaryOperator -> JS -> JS-  unary dictName fnName className classTy op = everywhere (mkT convert)-    where-    convert :: JS -> JS-    convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName className classTy dict = JSUnary op x-    convert other = other-    isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName' == fnName = True-    isOp _ = False-  isOpDict dictName className ty (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True-  isOpDict _ _ _ _ = False

@@ -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)]

@@ -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)   --

@@ -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

@@ -0,0 +1,74 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Optimizer+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- This module optimizes code in the simplified-Javascript intermediate representation.+--+-- The following optimizations are supported:+--+--  * Collapsing nested blocks+--+--  * Tail call elimination+--+--  * Inlining of (>>=) and ret for the Eff monad+--+--  * Removal of unused variables+--+--  * Removal of unnecessary thunks+--+--  * Eta conversion+--+--  * Inlining variables+--+--  * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!)+--+--  * Inlining primitive Javascript operators+--+-----------------------------------------------------------------------------++module Language.PureScript.Optimizer (+    optimize+) where++import Language.PureScript.CodeGen.JS.AST+import Language.PureScript.Options++import Language.PureScript.Optimizer.Common+import Language.PureScript.Optimizer.TCO+import Language.PureScript.Optimizer.MagicDo+import Language.PureScript.Optimizer.Inliner+import Language.PureScript.Optimizer.Unused+import Language.PureScript.Optimizer.Blocks++-- |+-- Apply a series of optimizer passes to simplified Javascript code+--+optimize :: Options -> JS -> JS+optimize opts | optionsNoOptimizations opts = id+              | otherwise = untilFixedPoint $ applyAll+  [ collapseNestedBlocks+  , tco opts+  , magicDo opts+  , removeUnusedVariables+  , unThunk+  , etaConvert+  , inlineVariables+  , inlineOperator "$" $ \f x -> JSApp f [x]+  , inlineOperator "#" $ \x f -> JSApp f [x]+  , inlineOperator "!!" $ flip JSIndexer+  , inlineOperator "++" $ JSBinary Add+  , inlineCommonOperators ]++untilFixedPoint :: (Eq a) => (a -> a) -> a -> a+untilFixedPoint f = go+  where+  go a = let a' = f a in+          if a' == a then a' else go a'+

@@ -0,0 +1,35 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Optimizer.Blocks+-- Copyright   :  (c) Phil Freeman 2013-14+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- Optimizer steps for simplifying Javascript blocks+--+-----------------------------------------------------------------------------++module Language.PureScript.Optimizer.Blocks (+  collapseNestedBlocks+) where++import Data.Generics++import Language.PureScript.CodeGen.JS.AST++-- |+-- Collapse blocks which appear nested directly below another block+--+collapseNestedBlocks :: JS -> JS+collapseNestedBlocks = everywhere (mkT collapse)+  where+  collapse :: JS -> JS+  collapse (JSBlock sts) = JSBlock (concatMap go sts)+  collapse js = js+  go :: JS -> [JS]+  go (JSBlock sts) = sts+  go s = [s]

@@ -0,0 +1,76 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Optimizer.Common+-- Copyright   :  (c) Phil Freeman 2013-14+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- Common functions used by the various optimizer phases+--+-----------------------------------------------------------------------------++module Language.PureScript.Optimizer.Common where++import Data.Maybe (fromMaybe)+import Data.Generics++import Language.PureScript.CodeGen.JS.AST++applyAll :: [a -> a] -> a -> a+applyAll = foldl1 (.)++replaceIdent :: (Data d) => String -> JS -> d -> d+replaceIdent var1 js = everywhere (mkT replace)+  where+  replace (JSVar var2) | var1 == var2 = js+  replace other = other++replaceIdents :: (Data d) => [(String, JS)] -> d -> d+replaceIdents vars = everywhere (mkT replace)+  where+  replace v@(JSVar var) = fromMaybe v $ lookup var vars+  replace other = other++isReassigned :: (Data d) => String -> d -> Bool+isReassigned var1 = everything (||) (mkQ False check)+  where+  check :: JS -> Bool+  check (JSFunction _ args _) | var1 `elem` args = True+  check (JSVariableIntroduction arg _) | var1 == arg = True+  check (JSAssignment (JSVar arg) _) | var1 == arg = True+  check _ = False++isRebound :: (Data d) => JS -> d -> Bool+isRebound js d = any (`isReassigned` d) (everything (++) (mkQ [] variablesOf) js)+  where+  variablesOf (JSVar var) = [var]+  variablesOf _ = []++isUsed :: (Data d) => String -> d -> Bool+isUsed var1 = everything (||) (mkQ False check)+  where+  check :: JS -> Bool+  check (JSVar var2) | var1 == var2 = True+  check (JSAssignment target _) | var1 == targetVariable target = True+  check _ = False++targetVariable :: JS -> String+targetVariable (JSVar var) = var+targetVariable (JSAccessor _ tgt) = targetVariable tgt+targetVariable (JSIndexer _ tgt) = targetVariable tgt+targetVariable _ = error "Invalid argument to targetVariable"++isUpdated :: (Data d) => String -> d -> Bool+isUpdated var1 = everything (||) (mkQ False check)+  where+  check :: JS -> Bool+  check (JSAssignment target _) | var1 == targetVariable target = True+  check _ = False++removeFromBlock :: ([JS] -> [JS]) -> JS -> JS+removeFromBlock go (JSBlock sts) = JSBlock (go sts)+removeFromBlock _  js = js

@@ -0,0 +1,138 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Optimizer.Inliner+-- Copyright   :  (c) Phil Freeman 2013-14+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- This module provides basic inlining capabilities+--+-----------------------------------------------------------------------------++module Language.PureScript.Optimizer.Inliner (+  inlineVariables,+  inlineOperator,+  inlineCommonOperators,+  etaConvert,+  unThunk+) where++import Data.Generics++import Language.PureScript.CodeGen.JS.AST+import Language.PureScript.CodeGen.Common (identToJs)+import Language.PureScript.Optimizer.Common+import Language.PureScript.Names++shouldInline :: JS -> Bool+shouldInline (JSVar _) = True+shouldInline (JSNumericLiteral _) = True+shouldInline (JSStringLiteral _) = True+shouldInline (JSBooleanLiteral _) = True+shouldInline (JSAccessor _ val) = shouldInline val+shouldInline (JSIndexer index val) = shouldInline index && shouldInline val+shouldInline _ = False++etaConvert :: JS -> JS+etaConvert = everywhere (mkT convert)+  where+  convert :: JS -> JS+  convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])+    | all shouldInline args &&+      not (any (`isRebound` block) (map JSVar idents)) &&+      not (any (`isRebound` block) args)+      = JSBlock (replaceIdents (zip idents args) body)+  convert js = js++unThunk :: JS -> JS+unThunk = everywhere (mkT convert)+  where+  convert :: JS -> JS+  convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body+  convert js = js++inlineVariables :: JS -> JS+inlineVariables = everywhere (mkT $ removeFromBlock go)+  where+  go :: [JS] -> [JS]+  go [] = []+  go (JSVariableIntroduction var (Just js) : sts)+    | shouldInline js && not (isReassigned var sts) && not (isRebound js sts) && not (isUpdated var sts) =+      go (replaceIdent var js sts)+  go (s:sts) = s : go sts++inlineOperator :: String -> (JS -> JS -> JS) -> JS -> JS+inlineOperator op f = everywhere (mkT convert)+  where+  convert :: JS -> JS+  convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y+  convert other = other+  isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar "_ps"))) | longForm == identToJs (Op op) = True+  isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | op == op' = True+  isOp _ = False++inlineCommonOperators :: JS -> JS+inlineCommonOperators = applyAll+  [ binary "numNumber" "+" Add+  , binary "numNumber" "-" Subtract+  , binary "numNumber" "*" Multiply+  , binary "numNumber" "/" Divide+  , binary "numNumber" "%" Modulus+  , unary  "numNumber" "negate" Negate++  , binary "ordNumber" "<" LessThan+  , binary "ordNumber" ">" GreaterThan+  , binary "ordNumber" "<=" LessThanOrEqualTo+  , binary "ordNumber" ">=" GreaterThanOrEqualTo++  , binary "eqNumber" "==" EqualTo+  , binary "eqNumber" "/=" NotEqualTo+  , binary "eqString" "==" EqualTo+  , binary "eqString" "/=" NotEqualTo+  , binary "eqBoolean" "==" EqualTo+  , binary "eqBoolean" "/=" NotEqualTo++  , binaryFunction "bitsNumber" "shl" ShiftLeft+  , binaryFunction "bitsNumber" "shr" ShiftRight+  , binaryFunction "bitsNumber" "zshr" ZeroFillShiftRight+  , binary         "bitsNumber" "&" BitwiseAnd+  , binary         "bitsNumber" "|" BitwiseOr+  , binary         "bitsNumber" "^" BitwiseXor+  , unary          "bitsNumber" "complement" BitwiseNot++  , binary "boolLikeBoolean" "&&" And+  , binary "boolLikeBoolean" "||" Or+  , unary  "boolLikeBoolean" "not" Not+  ]+  where+  binary :: String -> String -> BinaryOperator -> JS -> JS+  binary dictName opString op = everywhere (mkT convert)+    where+    convert :: JS -> JS+    convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y+    convert other = other+    isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar _))) | longForm == identToJs (Op opString) = True+    isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | opString == op' = True+    isOp _ = False+  binaryFunction :: String -> String -> BinaryOperator -> JS -> JS+  binaryFunction dictName fnName op = everywhere (mkT convert)+    where+    convert :: JS -> JS+    convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y+    convert other = other+    isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName == fnName' = True+    isOp _ = False+  unary :: String -> String -> UnaryOperator -> JS -> JS+  unary dictName fnName op = everywhere (mkT convert)+    where+    convert :: JS -> JS+    convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x+    convert other = other+    isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName' == fnName = True+    isOp _ = False+  isOpDict dictName (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True+  isOpDict _ _ = False

@@ -0,0 +1,153 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Optimizer.MagicDo+-- Copyright   :  (c) Phil Freeman 2013-14+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- This module implements the "Magic Do" optimization, which inlines calls to return+-- and bind for the Eff monad, as well as some of its actions.+--+-----------------------------------------------------------------------------++module Language.PureScript.Optimizer.MagicDo (+  magicDo+) where++import Data.List (nub)+import Data.Maybe (fromJust, isJust)+import Data.Generics++import Language.PureScript.Options+import Language.PureScript.CodeGen.JS.AST+import Language.PureScript.CodeGen.Common (identToJs)+import Language.PureScript.Names++magicDo :: Options -> JS -> JS+magicDo opts | optionsMagicDo opts = inlineST . magicDo'+             | otherwise = id++-- |+-- Inline type class dictionaries for >>= and return for the Eff monad+--+-- E.g.+--+--  Prelude[">>="](dict)(m1)(function(x) {+--    return ...;+--  })+--+-- becomes+--+--  function __do {+--    var x = m1();+--    ...+--  }+--+magicDo' :: JS -> JS+magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)+  where+  -- The name of the function block which is added to denote a do block+  fnName = "__do"+  -- Desugar monomorphic calls to >>= and return for the Eff monad+  convert :: JS -> JS+  -- Desugar return+  convert (JSApp (JSApp ret [val]) []) | isReturn ret = val+  -- Desugae >>+  convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock [JSReturn ret])]) | isBind bind =+    JSFunction (Just fnName) [] $ JSBlock [ JSApp m [], JSReturn (JSApp ret []) ]+  -- Desugar >>=+  convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =+    JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]+  -- Desugar untilE+  convert (JSApp (JSApp f [arg]) []) | isEffFunc "untilE" f =+    JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn (JSObjectLiteral []) ])) []+  -- Desugar whileE+  convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc "whileE" f =+    JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn (JSObjectLiteral []) ])) []+  convert other = other+  -- Check if an expression represents a monomorphic call to >>= for the Eff monad+  isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict effDict = True+  isBind _ = False+  -- Check if an expression represents a monomorphic call to return for the Eff monad+  isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict effDict = True+  isReturn _ = False+  -- Check if an expression represents the polymorphic >>= function+  isBindPoly (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) | prop == identToJs (Op ">>=") = True+  isBindPoly (JSIndexer (JSStringLiteral ">>=") (JSAccessor "Prelude" (JSVar "_ps"))) = True+  isBindPoly _ = False+  -- Check if an expression represents the polymorphic return function+  isRetPoly (JSAccessor "$return" (JSAccessor "Prelude" (JSVar "_ps"))) = True+  isRetPoly (JSIndexer (JSStringLiteral "return") (JSAccessor "Prelude" (JSVar "_ps"))) = True+  isRetPoly _ = False+  -- Check if an expression represents a function in the Ef module+  isEffFunc name (JSAccessor name' (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) | name == name' = True+  isEffFunc _ _ = False+  -- The name of the type class dictionary for the Monad Eff instance+  effDictName = "monadEff"+  -- Check if an expression represents the Monad Eff dictionary+  isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == effDictName = True+  isEffDict (JSApp (JSAccessor prop (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True+  isEffDict _ = False+  -- Remove __do function applications which remain after desugaring+  undo :: JS -> JS+  undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body+  undo other = other++-- |+-- Inline functions in the ST module+--+inlineST :: JS -> JS+inlineST = everywhere (mkT convertBlock)+  where+  -- Look for runST blocks and inline the STRefs there.+  -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then+  -- we can be more aggressive about inlining, and actually turn STRefs into local variables.+  convertBlock (JSApp f [arg]) | isSTFunc "runST" f || isSTFunc "runSTArray" f =+    let refs = nub . findSTRefsIn $ arg+        usages = findAllSTUsagesIn arg+        allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages+        localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs+    in everywhere (mkT $ convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg+  convertBlock other = other+  -- Convert a block in a safe way, preserving object wrappers of references,+  -- or in a more aggressive way, turning wrappers into local variables depending on the+  -- agg(ressive) parameter.+  convert agg (JSApp (JSApp f [arg]) []) | isSTFunc "newSTRef" f =+    if agg then arg else JSObjectLiteral [("value", arg)]+  convert agg (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f =+    if agg then ref else JSAccessor "value" ref+  convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc "writeSTRef" f =+    if agg then JSAssignment ref arg else JSAssignment (JSAccessor "value" ref) arg+  convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc "modifySTRef" f =+    if agg then JSAssignment ref (JSApp func [ref]) else  JSAssignment (JSAccessor "value" ref) (JSApp func [JSAccessor "value" ref])+  convert _ (JSApp (JSApp (JSApp f [arr]) [i]) []) | isSTFunc "peekSTArray" f =+    JSIndexer i arr+  convert _ (JSApp (JSApp (JSApp (JSApp f [arr]) [i]) [val]) []) | isSTFunc "pokeSTArray" f =+    JSAssignment (JSIndexer i arr) val+  convert _ other = other+  -- Check if an expression represents a function in the ST module+  isSTFunc name (JSAccessor name' (JSAccessor "Control_Monad_ST" (JSVar "_ps"))) | name == name' = True+  isSTFunc _ _ = False+  -- Find all ST Refs initialized in this block+  findSTRefsIn = everything (++) (mkQ [] isSTRef)+    where+    isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc "newSTRef" f = [ident]+    isSTRef _ = []+  -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef+  findAllSTUsagesIn = everything (++) (mkQ [] isSTUsage)+    where+    isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f = [ref]+    isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc "writeSTRef" f || isSTFunc "modifySTRef" f = [ref]+    isSTUsage _ = []+  -- Find all uses of a variable+  appearingIn ref = everything (++) (mkQ [] isVar)+    where+    isVar e@(JSVar v) | v == ref = [e]+    isVar _ = []+  -- Convert a JS value to a String if it is a JSVar+  toVar (JSVar v) = Just v+  toVar _ = Nothing

@@ -0,0 +1,102 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Optimizer.TCO+-- Copyright   :  (c) Phil Freeman 2013-14+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- This module implements tail call elimination.+--+-----------------------------------------------------------------------------++module Language.PureScript.Optimizer.TCO (tco) where++import Data.Generics++import Language.PureScript.Options+import Language.PureScript.CodeGen.JS.AST++-- |+-- Eliminate tail calls+--+tco :: Options -> JS -> JS+tco opts | optionsTco opts = tco'+         | otherwise = id++tco' :: JS -> JS+tco' = everywhere (mkT convert)+  where+  tcoLabel :: String+  tcoLabel = "tco"+  tcoVar :: String -> String+  tcoVar arg = "__tco_" ++ arg+  copyVar :: String -> String+  copyVar arg = "__copy_" ++ arg+  convert :: JS -> JS+  convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =+    let+      (argss, body', replace) = collectAllFunctionArgs [] id fn+    in case () of+      _ | isTailCall name body' ->+            let+              allArgs = reverse $ concat argss+            in+              JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))+        | otherwise -> js+  convert js = js+  collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)+  collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =+    collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body+  collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =+    (args : allArgs, body, f . JSFunction ident (map copyVar args))+  collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =+    collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body+  collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =+    (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))+  collectAllFunctionArgs allArgs f body = (allArgs, body, f)+  isTailCall :: String -> JS -> Bool+  isTailCall ident js =+    let+      numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js+      numSelfCallsInTailPosition = everything (+) (mkQ 0 countSelfCallsInTailPosition) js+      numSelfCallsUnderFunctions = everything (+) (mkQ 0 countSelfCallsUnderFunctions) js+    in+      numSelfCalls > 0+      && numSelfCalls == numSelfCallsInTailPosition+      && numSelfCallsUnderFunctions == 0+    where+    countSelfCalls :: JS -> Int+    countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1+    countSelfCalls _ = 0+    countSelfCallsInTailPosition :: JS -> Int+    countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1+    countSelfCallsInTailPosition _ = 0+    countSelfCallsUnderFunctions (JSFunction _ _ js') = everything (+) (mkQ 0 countSelfCalls) js'+    countSelfCallsUnderFunctions _ = 0+  toLoop :: String -> [String] -> JS -> JS+  toLoop ident allArgs js = JSBlock $+        map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs +++        [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhere (mkT loopify) js ]) ]+    where+    loopify :: JS -> JS+    loopify (JSReturn ret) | isSelfCall ident ret =+      let+        allArgumentValues = concat $ collectSelfCallArgs [] ret+      in+        JSBlock $ zipWith (\val arg ->+                    JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs+                  ++ map (\arg ->+                    JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs+                  ++ [ JSContinue tcoLabel ]+    loopify other = other+    collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]+    collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn+    collectSelfCallArgs allArgumentValues _ = allArgumentValues+  isSelfCall :: String -> JS -> Bool+  isSelfCall ident (JSApp (JSVar ident') _) | ident == ident' = True+  isSelfCall ident (JSApp fn _) = isSelfCall ident fn+  isSelfCall _ _ = False

@@ -0,0 +1,31 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Optimizer.Unused+-- Copyright   :  (c) Phil Freeman 2013-14+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- Removes unused variables+--+-----------------------------------------------------------------------------++module Language.PureScript.Optimizer.Unused (+  removeUnusedVariables+) where++import Data.Generics++import Language.PureScript.CodeGen.JS.AST+import Language.PureScript.Optimizer.Common++removeUnusedVariables :: JS -> JS+removeUnusedVariables = everywhere (mkT $ removeFromBlock go)+  where+  go :: [JS] -> [JS]+  go [] = []+  go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts+  go (s:sts) = s : go sts

@@ -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

@@ -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"

@@ -28,6 +28,7 @@  import Language.PureScript.Types import Language.PureScript.Pretty.Common+import Language.PureScript.Prim  typeLiterals :: Pattern () Type String typeLiterals = mkPattern match

@@ -0,0 +1,69 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Prim+-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.Prim where++import Language.PureScript.Kinds+import Language.PureScript.Names+import Language.PureScript.Types++import qualified Data.Map as M++-- |+-- Type constructor for functions+--+tyFunction :: Type+tyFunction = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Function")++-- |+-- Type constructor for strings+--+tyString :: Type+tyString = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "String")++-- |+-- Type constructor for numbers+--+tyNumber :: Type+tyNumber = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Number")++-- |+-- Type constructor for booleans+--+tyBoolean :: Type+tyBoolean = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Boolean")++-- |+-- Type constructor for arrays+--+tyArray :: Type+tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")++-- |+-- Smart constructor for function types+--+function :: Type -> Type -> Type+function t1 = TypeApp (TypeApp tyFunction t1)++-- |+-- The primitive types in the external javascript environment with their associated kinds.+--+primTypes :: M.Map (Qualified ProperName) Kind+primTypes = M.fromList [ (primName "Function" , FunKind Star (FunKind Star Star))+                       , (primName "Array"    , FunKind Star Star)+                       , (primName "String"   , Star)+                       , (primName "Number"   , Star)+                       , (primName "Boolean"  , Star) ]+  where+  primName name = Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName name)

@@ -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

@@ -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 []

@@ -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

@@ -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) ++ "'" 

@@ -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

@@ -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

@@ -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

@@ -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]

@@ -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

@@ -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

@@ -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   

@@ -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

@@ -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