purescript 0.5.1 → 0.5.2

raw patch · 16 files changed

+245/−300 lines, 16 filesdep ~haskelinePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: haskeline

API changes (from Hackage documentation)

Files

• psc-make/Main.hs +1/−1
• purescript.cabal +4/−5
• src/Language/PureScript.hs +16/−15
• src/Language/PureScript/CodeGen/Externs.hs +1/−1
• src/Language/PureScript/CodeGen/JS.hs +103/−95
• src/Language/PureScript/CodeGen/Monad.hs +0/−43
• src/Language/PureScript/Environment.hs +2/−2
• src/Language/PureScript/Optimizer/Inliner.hs +5/−1
• src/Language/PureScript/Scope.hs +0/−84
• src/Language/PureScript/Sugar.hs +8/−7
• src/Language/PureScript/Sugar/CaseDeclarations.hs +22/−25
• src/Language/PureScript/Sugar/DoNotation.hs +14/−12
• src/Language/PureScript/Sugar/TypeClasses.hs +5/−4
• src/Language/PureScript/Supply.hs +56/−0
• src/Language/PureScript/TypeChecker.hs +4/−3
• src/Language/PureScript/TypeChecker/Monad.hs +4/−2

@@ -45,7 +45,7 @@   collect :: [(FilePath, Either ParseError [P.Module])] -> Either ParseError [(FilePath, P.Module)]   collect = fmap concat . sequence . map (\(fp, e) -> fmap (map ((,) fp)) e) -newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Monad, MonadIO, MonadError String)+newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadError String)  runMake :: Make a -> IO (Either String a) runMake = runErrorT . unMake

@@ -1,5 +1,5 @@ name: purescript-version: 0.5.1+version: 0.5.2 cabal-version: >=1.8 build-type: Custom license: MIT@@ -34,8 +34,8 @@                      Language.PureScript.Errors                      Language.PureScript.Kinds                      Language.PureScript.Names+                     Language.PureScript.Supply                      Language.PureScript.Types-                     Language.PureScript.Scope                      Language.PureScript.Traversals                      Language.PureScript.TypeClassDictionaries                      Language.PureScript.DeadCodeElimination@@ -53,7 +53,6 @@                      Language.PureScript.CodeGen.Externs                      Language.PureScript.CodeGen.JS                      Language.PureScript.CodeGen.JS.AST-                     Language.PureScript.CodeGen.Monad                      Language.PureScript.Optimizer                      Language.PureScript.Optimizer.Common                      Language.PureScript.Optimizer.MagicDo@@ -106,7 +105,7 @@  executable psci     build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,-                   mtl -any, parsec -any, haskeline -any, purescript -any,+                   mtl -any, parsec -any, haskeline >= 0.7.0.0, purescript -any,                    transformers -any, utf8-string -any, process -any,                    xdg-basedir -any, cmdtheline -any     main-is: Main.hs@@ -136,7 +135,7 @@  test-suite tests     build-depends: base >=4 && <5, containers -any, directory -any,-                   filepath -any, mtl -any, parsec -any, purescript -any, +                   filepath -any, mtl -any, parsec -any, purescript -any,                    transformers -any, utf8-string -any, process -any     type: exitcode-stdio-1.0     main-is: Main.hs

@@ -30,6 +30,7 @@ import Language.PureScript.Environment as P import Language.PureScript.Errors as P import Language.PureScript.DeadCodeElimination as P+import Language.PureScript.Supply as P  import qualified Language.PureScript.Constants as C @@ -40,7 +41,7 @@ import Control.Monad.Error import Control.Monad.State.Lazy import Control.Arrow ((&&&))-import Control.Applicative ((<$>))+import Control.Applicative import qualified Data.Map as M import qualified Data.Set as S import System.FilePath (pathSeparator)@@ -70,14 +71,14 @@ compile' :: Environment -> Options -> [Module] -> Either String (String, String, Environment) compile' env opts ms = do   (sorted, _) <- sortModules $ if optionsNoPrelude opts then ms else (map importPrelude ms)-  desugared <- stringifyErrorStack True $ desugar sorted+  (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted   (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent   regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated   let entryPoints = moduleNameFromString `map` optionsModules opts   let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped   let codeGenModules = moduleNameFromString `map` optionsCodeGenModules opts   let modulesToCodeGen = if null codeGenModules then elim else filter (\(Module mn _ _) -> mn `elem` codeGenModules) elim-  let js = concatMap (\m -> moduleToJs Globals opts m env') modulesToCodeGen+  let js = evalSupply nextVar $ concat <$> mapM (\m -> moduleToJs Globals opts m env') modulesToCodeGen   let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen   js' <- generateMain env' opts js   return (prettyPrintJS js', exts, env')@@ -165,7 +166,7 @@ -- If timestamps have not changed, the externs file can be used to provide the module's types without -- having to typecheck the module again. ---make :: (Functor m, Monad m, MonadMake m) => FilePath -> Options -> [(FilePath, Module)] -> m Environment+make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options -> [(FilePath, Module)] -> m Environment make outputDir opts ms = do   let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms) @@ -188,15 +189,15 @@    marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted -  desugared <- liftError $ stringifyErrorStack True $ zip (map fst marked) <$> desugar (map snd marked)+  (desugared, nextVar) <- liftError $ stringifyErrorStack True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked) -  go initEnvironment desugared+  evalSupplyT nextVar (go initEnvironment desugared)    where-  go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> m Environment+  go :: (Functor m, Applicative m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> SupplyT m Environment   go env [] = return env   go env ((False, m) : ms') = do-    (_, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m+    (_, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m      go env' ms'   go env ((True, m@(Module moduleName' _ exps)) : ms') = do@@ -204,18 +205,18 @@         jsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "index.js"         externsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "externs.purs" -    progress $ "Compiling " ++ runModuleName moduleName'+    lift . progress $ "Compiling " ++ runModuleName moduleName' -    (Module _ elaborated _, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m+    (Module _ elaborated _, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m -    regrouped <- liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated+    regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated      let mod' = Module moduleName' regrouped exps-        js = prettyPrintJS $ moduleToJs CommonJS opts mod' env'-        exts = moduleToPs mod' env'+    js <- prettyPrintJS <$> moduleToJs CommonJS opts mod' env'+    let exts = moduleToPs mod' env' -    writeTextFile jsFile js-    writeTextFile externsFile exts+    lift $ writeTextFile jsFile js+    lift $ writeTextFile externsFile exts      go env' ms' 

@@ -85,7 +85,7 @@      exportToPs (TypeInstanceRef ident) = do       let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =-            fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find ((== Qualified (Just moduleName) ident) . tcdName) $ typeClassDictionaries env+            fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find ((== Qualified (Just moduleName) ident) . tcdName) $ M.elems $ typeClassDictionaries env       let constraintsText = case fromMaybe [] deps of                               [] -> ""                               cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "

@@ -23,26 +23,25 @@     isIdent ) where -import Data.Maybe (fromJust, fromMaybe, mapMaybe)+import Data.Maybe (catMaybes, fromJust, fromMaybe) import Data.Function (on) import Data.List (nub, (\\)) -import Control.Arrow (second) import Control.Monad (replicateM, forM)+import Control.Applicative  import qualified Data.Map as M  import Language.PureScript.Names import Language.PureScript.Declarations-import Language.PureScript.CodeGen.Monad import Language.PureScript.Options import Language.PureScript.CodeGen.JS.AST as AST import Language.PureScript.Types import Language.PureScript.Optimizer import Language.PureScript.CodeGen.Common import Language.PureScript.Environment--import qualified Language.PureScript.Scope as S+import Language.PureScript.Supply+import Language.PureScript.Traversals (sndM)  -- | -- Different types of modules which are supported@@ -53,22 +52,23 @@ -- Generate code in the simplified Javascript intermediate representation for all declarations in a -- module. ---moduleToJs :: ModuleType -> Options -> Module -> Environment -> [JS]-moduleToJs mt opts (Module name decls (Just exps)) env = case mt of-  CommonJS -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]-  Globals | not isModuleEmpty ->-    [ JSVariableIntroduction (fromJust (optionsBrowserNamespace opts))-                             (Just (JSBinary Or (JSVar (fromJust (optionsBrowserNamespace opts))) (JSObjectLiteral [])) )-    , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar (fromJust (optionsBrowserNamespace opts))))-                   (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])-    ]-  _ -> []-  where-  isModuleEmpty = null jsDecls-  moduleBody = JSStringLiteral "use strict" : jsImports ++ jsDecls-  moduleExports = JSObjectLiteral $ concatMap exportToJs exps-  jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) decls)-  jsImports = map (importToJs mt opts) . (\\ [name]) . nub $ concatMap imports decls+moduleToJs :: (Functor m, Applicative m, Monad m) => ModuleType -> Options -> Module -> Environment -> SupplyT m [JS]+moduleToJs mt opts (Module name decls (Just exps)) env = do+  let jsImports = map (importToJs mt opts) . (\\ [name]) . nub $ concatMap imports decls+  jsDecls <- mapM (\decl -> declToJs opts name decl env) decls+  let optimized = concat $ map (map $ optimize opts) $ catMaybes jsDecls+  let isModuleEmpty = null optimized+  let moduleBody = JSStringLiteral "use strict" : jsImports ++ optimized+  let moduleExports = JSObjectLiteral $ concatMap exportToJs exps+  return $ case mt of+    CommonJS -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]+    Globals | not isModuleEmpty ->+      [ JSVariableIntroduction (fromJust (optionsBrowserNamespace opts))+                               (Just (JSBinary Or (JSVar (fromJust (optionsBrowserNamespace opts))) (JSObjectLiteral [])) )+      , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar (fromJust (optionsBrowserNamespace opts))))+                     (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])+      ]+    _ -> [] moduleToJs _ _ _ _ = error "Exports should have been elaborated in name desugaring"  importToJs :: ModuleType -> Options -> ModuleName -> JS@@ -91,14 +91,17 @@ -- | -- Generate code in the simplified Javascript intermediate representation for a declaration ---declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]-declToJs opts mp (ValueDeclaration ident _ _ _ val) e =-  Just [JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))]-declToJs opts mp (BindingGroupDeclaration vals) e =-  Just $ flip concatMap vals $ \(ident, _, val) ->-    [JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))]-declToJs _ mp (DataDeclaration _ _ ctors) _ =-  Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->+declToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Declaration -> Environment -> SupplyT m (Maybe [JS])+declToJs opts mp (ValueDeclaration ident _ _ _ val) e = do+  js <- valueToJs opts mp e val+  return $ Just [JSVariableIntroduction (identToJs ident) (Just js)]+declToJs opts mp (BindingGroupDeclaration vals) e = do+  jss <- flip mapM vals $ \(ident, _, val) -> do+    js <- valueToJs opts mp e val+    return $ JSVariableIntroduction (identToJs ident) (Just js)+  return $ Just jss+declToJs _ mp (DataDeclaration _ _ ctors) _ = do+  return $ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->     [JSVariableIntroduction ctor (Just (go pn 0 tys []))]     where     go :: ProperName -> Integer -> [Type] -> [JS] -> JS@@ -107,10 +110,12 @@     go pn index (_ : tys') values =       JSFunction Nothing ["value" ++ show index]         (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])-declToJs opts mp (DataBindingGroupDeclaration ds) e = Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds-declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = Just [js]+declToJs opts mp (DataBindingGroupDeclaration ds) e = do+  jss <- mapM (\decl -> declToJs opts mp decl e) ds+  return $ Just $ concat $ catMaybes jss+declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = return $ Just [js] declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e-declToJs _ _ _ _ = Nothing+declToJs _ _ _ _ = return Nothing  -- | -- Generate key//value pairs for an object literal exporting values from a module.@@ -144,22 +149,35 @@ -- | -- Generate code in the simplified Javascript intermediate representation for a value or expression. ---valueToJs :: Options -> ModuleName -> Environment -> Value -> JS-valueToJs _ _ _ (NumericLiteral n) = JSNumericLiteral n-valueToJs _ _ _ (StringLiteral s) = JSStringLiteral s-valueToJs _ _ _ (BooleanLiteral b) = JSBooleanLiteral b-valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs opts m e) xs)-valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs opts m e)) ps)-valueToJs opts m e (ObjectUpdate o ps) = extendObj (valueToJs opts m e o) (map (second (valueToJs opts m e)) ps)-valueToJs _ m _ (Constructor name) = qualifiedToJS m (Ident . runProperName) name-valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (valueToJs opts m e) values)-valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)-valueToJs opts m e (Accessor prop val) = accessorString prop (valueToJs opts m e val)-valueToJs opts m e (App val arg) = JSApp (valueToJs opts m e val) [valueToJs opts m e arg]-valueToJs opts m e (Let ds val) = JSApp (JSFunction Nothing [] (JSBlock (concat (mapMaybe (flip (declToJs opts m) e) ds) ++ [JSReturn $ valueToJs opts m e val]))) []-valueToJs opts m e (Abs (Left arg) val) = JSFunction Nothing [identToJs arg] (JSBlock [JSReturn (valueToJs opts m (bindName m arg e) val)])-valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntimeTypeChecks opts = let arg' = identToJs arg in JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn (valueToJs opts m e val)])-valueToJs _ m _ (Var ident) = varToJs m ident+valueToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Environment -> Value -> SupplyT m JS+valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n+valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s+valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b+valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs opts m e) xs+valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs opts m e)) ps+valueToJs opts m e (ObjectUpdate o ps) = do+  obj <- valueToJs opts m e o+  sts <- mapM (sndM (valueToJs opts m e)) ps+  extendObj obj sts+valueToJs _ m _ (Constructor name) = return $ qualifiedToJS m (Ident . runProperName) name+valueToJs opts m e (Case values binders) = do+  vals <- mapM (valueToJs opts m e) values+  bindersToJs opts m e binders vals+valueToJs opts m e (IfThenElse cond th el) = JSConditional <$> valueToJs opts m e cond <*> valueToJs opts m e th <*> valueToJs opts m e el+valueToJs opts m e (Accessor prop val) = accessorString prop <$> valueToJs opts m e val+valueToJs opts m e (App val arg) = JSApp <$> valueToJs opts m e val <*> (return <$> valueToJs opts m e arg)+valueToJs opts m e (Let ds val) = do+  decls <- concat . catMaybes <$> mapM (flip (declToJs opts m) e) ds+  ret <- valueToJs opts m e val+  return $ JSApp (JSFunction Nothing [] (JSBlock (decls ++ [JSReturn ret]))) []+valueToJs opts m e (Abs (Left arg) val) = do+  ret <- valueToJs opts m (bindName m arg e) val+  return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])+valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntimeTypeChecks opts = do+  let arg' = identToJs arg+  ret <- valueToJs opts m e val+  return $ JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn ret])+valueToJs _ m _ (Var ident) = return $ varToJs m ident valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val valueToJs _ _ _ (TypeClassDictionary _ _ _) = error "Type class dictionary was not replaced"@@ -168,20 +186,22 @@ -- | -- Shallow copy an object. ---extendObj :: JS -> [(String, JS)] -> JS-extendObj obj sts = JSApp (JSFunction Nothing [] block) []+extendObj :: (Functor m, Applicative m, Monad m) => JS -> [(String, JS)] -> SupplyT m JS+extendObj obj sts = do+  newObj <- freshName+  key <- freshName+  let+    jsKey = JSVar key+    jsNewObj = JSVar newObj+    block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])+    objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])+    copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]+    cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]+    assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]+    stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js+    extend = map stToAssign sts+  return $ JSApp (JSFunction Nothing [] block) []   where-  [newObj, key] = take 2 . map identToJs . S.unusedNames $ used-  used = usedNamesJS obj ++ concatMap (usedNamesJS . snd) sts-  jsKey = JSVar key-  jsNewObj = JSVar newObj-  block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])-  objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])-  copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]-  cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]-  assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]-  stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js-  extend = map stToAssign sts  -- | -- Temporarily extends the environment with a single local variable name@@ -198,7 +218,6 @@   where   noType = error "Temporary lambda variable type was read" - -- | -- Generate code in the simplified Javascript intermediate representation for runtime type checks. --@@ -251,42 +270,31 @@ -- Generate code in the simplified Javascript intermediate representation for pattern match binders -- and guards. ---bindersToJs :: Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> JS-bindersToJs opts m e binders vals = runGen (map identToJs (S.unusedNames usedNames)) $ do-  valNames <- replicateM (length vals) fresh-  jss <- forM binders $ \(CaseAlternative bs grd result) -> go valNames [JSReturn (valueToJs opts m (bindNames m (concatMap binderNames bs) e) result)] bs grd-  return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))-                 vals+bindersToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> SupplyT m JS+bindersToJs opts m e binders vals = do+  valNames <- replicateM (length vals) freshName+  let assignments = zipWith JSVariableIntroduction valNames (map Just vals)+  jss <- forM binders $ \(CaseAlternative bs grd result) -> do+    ret <- valueToJs opts m (bindNames m (concatMap binderNames bs) e) result+    go valNames [JSReturn ret] bs grd+  return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))+                 []   where-    usedNames = concatMap usedNamesJS vals ++ concatMap S.usedNamesCaseAlternative binders--    go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]+    go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder] -> Maybe Guard -> SupplyT m [JS]     go _ done [] Nothing = return done-    go _ done [] (Just cond) = return [JSIfElse (valueToJs opts m e cond) (JSBlock done) Nothing]+    go _ done [] (Just cond) = do+      cond' <- valueToJs opts m e cond+      return [JSIfElse cond' (JSBlock done) Nothing]     go (v:vs) done' (b:bs) grd = do       done'' <- go vs done' bs grd       binderToJs m e v done'' b     go _ _ _ _ = error "Invalid arguments to bindersToJs"  -- |--- Gather all used names appearing inside a value----usedNamesJS :: JS -> [Ident]-usedNamesJS val = nub $ everythingOnJS (++) namesJS val-  where-  namesJS (JSVar name) = [Ident name]-  namesJS (JSFunction (Just name) args _) = Ident name : map Ident args-  namesJS (JSFunction Nothing args _) = map Ident args-  namesJS (JSVariableIntroduction name _) = [Ident name]-  namesJS (JSFor name _ _ _) = [Ident name]-  namesJS (JSForIn name _ _) = [Ident name]-  namesJS _ = []---- | -- Generate code in the simplified Javascript intermediate representation for a pattern match -- binder. ---binderToJs :: ModuleName -> Environment -> String -> [JS] -> Binder -> Gen [JS]+binderToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Environment -> String -> [JS] -> Binder -> SupplyT m [JS] binderToJs _ _ _ done NullBinder = return done binderToJs _ _ varName done (StringBinder str) =   return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]@@ -308,19 +316,19 @@                      (JSBlock js)                      Nothing]   where-  go :: Integer -> [JS] -> [Binder] -> Gen [JS]+  go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder] -> SupplyT m [JS]   go _ done' [] = return done'   go index done' (binder:bs') = do-    argVar <- fresh+    argVar <- freshName     done'' <- go (index + 1) done' bs'     js <- binderToJs m e argVar done'' binder     return (JSVariableIntroduction argVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSAccessor "values" (JSVar varName)))) : js) binderToJs m e varName done (ObjectBinder bs) = go done bs   where-  go :: [JS] -> [(String, Binder)] -> Gen [JS]+  go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder)] -> SupplyT m [JS]   go done' [] = return done'   go done' ((prop, binder):bs') = do-    propVar <- fresh+    propVar <- freshName     done'' <- go done' bs'     js <- binderToJs m e propVar done'' binder     return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)@@ -328,16 +336,16 @@   js <- go done 0 bs   return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]   where-  go :: [JS] -> Integer -> [Binder] -> Gen [JS]+  go :: (Functor m, Applicative m, Monad m) => [JS] -> Integer -> [Binder] -> SupplyT m [JS]   go done' _ [] = return done'   go done' index (binder:bs') = do-    elVar <- fresh+    elVar <- freshName     done'' <- go done' (index + 1) bs'     js <- binderToJs m e elVar done'' binder     return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js) binderToJs m e varName done (ConsBinder headBinder tailBinder) = do-  headVar <- fresh-  tailVar <- fresh+  headVar <- freshName+  tailVar <- freshName   js1 <- binderToJs m e headVar done headBinder   js2 <- binderToJs m e tailVar js1 tailBinder   return [JSIfElse (JSBinary GreaterThan (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left 0))) (JSBlock

@@ -1,43 +0,0 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.CodeGen.Monad--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- Code generation monad------ This monad provides a supply of fresh names which can be used to create variables.-----------------------------------------------------------------------------------{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Language.PureScript.CodeGen.Monad where--import Control.Monad.State-import Control.Applicative---- |--- Code generation monad data type----newtype Gen a = Gen { unGen :: State [String] a } deriving (Functor, Applicative, Monad, MonadState [String])---- |--- Run a computation in the code generation monad----runGen :: [String] -> Gen a -> a-runGen names = flip evalState names . unGen---- |--- Generate a fresh name----fresh :: Gen String-fresh = do-  (s:ss) <- get-  put ss-  return s

@@ -49,7 +49,7 @@   -- |   -- Available type class dictionaries   ---  , typeClassDictionaries :: [TypeClassDictionaryInScope]+  , typeClassDictionaries :: M.Map (Qualified Ident, Maybe ModuleName) TypeClassDictionaryInScope   -- |   -- Type classes   --@@ -60,7 +60,7 @@ -- The initial environment with no values and only the default javascript types defined -- initEnvironment :: Environment-initEnvironment = Environment M.empty primTypes M.empty M.empty [] M.empty+initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty M.empty  -- | -- The type of a foreign import

@@ -53,7 +53,11 @@ unThunk = everywhereOnJS convert   where   convert :: JS -> JS-  convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body+  convert (JSBlock []) = JSBlock []+  convert (JSBlock jss) =+    case (last jss) of+      JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) []) -> JSBlock $ init jss ++ body+      _ -> JSBlock jss   convert js = js  evaluateIifes :: JS -> JS

@@ -1,84 +0,0 @@------------------------------------------------------------------------------------ Module      :  Language.PureScript.Scope--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |--- Utility functions for working with names in scope-----------------------------------------------------------------------------------module Language.PureScript.Scope (-    usedNamesDecl,-    usedNamesValue,-    usedNamesBinder,-    usedNamesCaseAlternative,-    usedNamesDoNotationElement,-    unusedNames-) where--import Data.List ((\\), nub)--import Language.PureScript.Declarations-import Language.PureScript.Names--usedNames :: (Declaration -> [Ident], Value -> [Ident], Binder -> [Ident], CaseAlternative -> [Ident], DoNotationElement -> [Ident])-usedNames = everythingOnValues (++) f g h (const []) (const [])-  where-  f :: Declaration -> [Ident]-  f (ValueDeclaration name _ _ _ _) = [name]-  f _ = []--  g :: Value -> [Ident]-  g (Abs (Left arg) _) = [arg]-  g (Var (Qualified Nothing name)) = [name]-  g _ = []--  h :: Binder -> [Ident]-  h (VarBinder name) = [name]-  h _ = []---- |--- Gather all used names appearing inside a declaration----usedNamesDecl :: Declaration -> [Ident]-usedNamesDecl = let (f, _, _, _, _) = usedNames in nub . f---- |--- Gather all used names appearing inside a value----usedNamesValue :: Value -> [Ident]-usedNamesValue = let (_, f, _, _, _) = usedNames in nub . f---- |--- Gather all used names appearing inside a binder----usedNamesBinder :: Binder -> [Ident]-usedNamesBinder = let (_, _, f, _, _) = usedNames in nub . f---- |--- Gather all used names appearing inside a case alternative----usedNamesCaseAlternative :: CaseAlternative -> [Ident]-usedNamesCaseAlternative = let (_, _, _, f, _) = usedNames in nub . f---- |--- Gather all used names appearing inside a do notation element----usedNamesDoNotationElement :: DoNotationElement -> [Ident]-usedNamesDoNotationElement = let (_, _, _, _, f) = usedNames in nub . f---- |--- Generate a set of names which are unused inside a value, of the form @_{n}@ for an integer @n@----unusedNames :: [Ident] -> [Ident]-unusedNames allNames =-  let-    varNames = map (Ident . ('_' :) . show) ([1..] :: [Int])-  in-    varNames \\ allNames

@@ -16,9 +16,12 @@ module Language.PureScript.Sugar (desugar, module S) where  import Control.Monad+import Control.Category ((>>>))+import Control.Monad.Trans.Class  import Language.PureScript.Declarations import Language.PureScript.Errors+import Language.PureScript.Supply  import Language.PureScript.Sugar.Operators as S import Language.PureScript.Sugar.DoNotation as S@@ -28,8 +31,6 @@ import Language.PureScript.Sugar.TypeClasses as S import Language.PureScript.Sugar.Names as S -import Control.Category ((>>>))- -- | -- The desugaring pipeline proceeds as follows: --@@ -47,12 +48,12 @@ -- --  * Qualify any unqualified names and types ---desugar :: [Module] -> Either ErrorStack [Module]+desugar :: [Module] -> SupplyT (Either ErrorStack) [Module] desugar = map removeSignedLiterals           >>> mapM desugarDoModule           >=> desugarCasesModule-          >=> desugarTypeDeclarationsModule-          >=> desugarImports-          >=> rebracket+          >=> lift . (desugarTypeDeclarationsModule+                      >=> desugarImports+                      >=> rebracket)           >=> desugarTypeClasses-          >=> createBindingGroupsModule+          >=> lift . createBindingGroupsModule

@@ -23,43 +23,41 @@ import Data.List (groupBy)  import Control.Applicative-import Control.Monad ((<=<), forM, join, unless)+import Control.Monad ((<=<), forM, join, unless, replicateM) import Control.Monad.Error.Class  import Language.PureScript.Names import Language.PureScript.Declarations-import Language.PureScript.Scope import Language.PureScript.Environment import Language.PureScript.Errors+import Language.PureScript.Supply  -- | -- Replace all top-level binders in a module with case expressions. ---desugarCasesModule :: [Module] -> Either ErrorStack [Module]+desugarCasesModule :: [Module] -> SupplyT (Either ErrorStack) [Module] desugarCasesModule ms = forM ms $ \(Module name ds exps) ->   rethrow (strMsg ("Error in module " ++ show name) <>) $-    Module name <$> (desugarCases . desugarAbs $ ds) <*> pure exps+    Module name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps -desugarAbs :: [Declaration] -> [Declaration]-desugarAbs = map f+desugarAbs :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]+desugarAbs = mapM f   where-  (f, _, _) = everywhereOnValues id replace id+  (f, _, _) = everywhereOnValuesM return replace return -  replace (Abs (Right binder) val) =-    let-      used = usedNamesBinder binder ++ usedNamesValue val-      ident = head $ unusedNames used-    in-      Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing val]-  replace other = other+  replace :: Value -> SupplyT (Either ErrorStack) Value+  replace (Abs (Right binder) val) = do+    ident <- Ident <$> freshName+    return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing val]+  replace other = return other  -- | -- Replace all top-level binders with case expressions. ---desugarCases :: [Declaration] -> Either ErrorStack [Declaration]+desugarCases :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration] desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup   where-    desugarRest :: [Declaration] -> Either ErrorStack [Declaration]+    desugarRest :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]     desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =       (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest     desugarRest (ValueDeclaration name nameKind bs g val : rest) =@@ -80,7 +78,7 @@ inSameGroup d1 (PositionedDeclaration _ d2) = inSameGroup d1 d2 inSameGroup _ _ = False -toDecls :: [Declaration] -> Either ErrorStack [Declaration]+toDecls :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration] toDecls [ValueDeclaration ident nameKind bs Nothing val] | all isVarBinder bs = do   let args = map (\(VarBinder arg) -> arg) bs       body = foldr (Abs . Left) val args@@ -89,7 +87,8 @@   let tuples = map toTuple ds   unless (all ((== length bs) . length . fst) tuples) $       throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing-  return [makeCaseDeclaration ident tuples]+  caseDecl <- makeCaseDeclaration ident tuples+  return [caseDecl] toDecls (PositionedDeclaration pos d : ds) = do   (d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds)   return (PositionedDeclaration pos d' : ds')@@ -104,15 +103,13 @@ toTuple (PositionedDeclaration _ d) = toTuple d toTuple _ = error "Not a value declaration" -makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> Declaration-makeCaseDeclaration ident alternatives =+makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> SupplyT (Either ErrorStack) Declaration+makeCaseDeclaration ident alternatives = do+  let argPattern = length . fst . head $ alternatives+  args <- map Ident <$> replicateM argPattern freshName   let-    argPattern = length . fst . head $ alternatives-    args = take argPattern $ unusedNames used-    used = concatMap (\(bs, (grd, val)) -> concatMap usedNamesBinder bs ++ maybe [] usedNamesValue grd ++ usedNamesValue val) alternatives     vars = map (Var . Qualified Nothing) args     binders = [ CaseAlternative bs g val | (bs, (g, val)) <- alternatives ]     value = foldr (Abs . Left) (Case vars binders) args-  in-    ValueDeclaration ident Value [] Nothing value+  return $ ValueDeclaration ident Value [] Nothing value 

@@ -19,25 +19,27 @@ ) where  import Language.PureScript.Names-import Language.PureScript.Scope import Language.PureScript.Declarations import Language.PureScript.Errors+import Language.PureScript.Supply  import qualified Language.PureScript.Constants as C  import Control.Applicative+import Control.Monad.Trans.Class  -- | -- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function, -- and all @DoNotationLet@ constructors with let expressions. ---desugarDoModule :: Module -> Either ErrorStack Module+desugarDoModule :: Module -> SupplyT (Either ErrorStack) Module desugarDoModule (Module mn ds exts) = Module mn <$> mapM desugarDo ds <*> pure exts -desugarDo :: Declaration -> Either ErrorStack Declaration-desugarDo =+desugarDo :: Declaration -> SupplyT (Either ErrorStack) Declaration+desugarDo (PositionedDeclaration pos d) = (PositionedDeclaration pos) <$> (rethrowWithPosition pos $ desugarDo d)+desugarDo d =   let (f, _, _) = everywhereOnValuesM return replace return-  in f+  in f d   where   prelude :: ModuleName   prelude = ModuleName [ProperName C.prelude]@@ -45,28 +47,28 @@   bind :: Value   bind = Var (Qualified (Just prelude) (Op (C.>>=))) -  replace :: Value -> Either ErrorStack Value+  replace :: Value -> SupplyT (Either ErrorStack) Value   replace (Do els) = go els+  replace (PositionedValue pos v) = PositionedValue pos <$> rethrowWithPosition pos (replace v)   replace other = return other -  go :: [DoNotationElement] -> Either ErrorStack Value+  go :: [DoNotationElement] -> SupplyT (Either ErrorStack) Value   go [] = error "The impossible happened in desugarDo"   go [DoNotationValue val] = return val   go (DoNotationValue val : rest) = do     rest' <- go rest     return $ App (App bind val) (Abs (Left (Ident "_")) rest')-  go [DoNotationBind _ _] = Left $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing+  go [DoNotationBind _ _] = lift $ Left $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing   go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)   go (DoNotationBind (VarBinder ident) val : rest) = do     rest' <- go rest     return $ App (App bind val) (Abs (Left ident) rest')   go (DoNotationBind binder val : rest) = do     rest' <- go rest-    let used = concatMap usedNamesDoNotationElement rest-        ident = head $ unusedNames used+    ident <- Ident <$> freshName     return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing rest']))-  go [DoNotationLet _] = Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing+  go [DoNotationLet _] = lift $ Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing   go (DoNotationLet ds : rest) = do     rest' <- go rest     return $ Let ds rest'-  go (PositionedDoNotationElement pos el : rest) = PositionedValue pos <$> go (el : rest)+  go (PositionedDoNotationElement pos el : rest) = rethrowWithPosition pos $ PositionedValue pos <$> go (el : rest)

@@ -24,6 +24,7 @@ import Language.PureScript.Sugar.CaseDeclarations import Language.PureScript.Environment import Language.PureScript.Errors+import Language.PureScript.Supply import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)  import qualified Language.PureScript.Constants as C@@ -40,13 +41,13 @@  type MemberMap = M.Map (ModuleName, ProperName) Declaration -type Desugar = StateT MemberMap (Either ErrorStack)+type Desugar = StateT MemberMap (SupplyT (Either ErrorStack))  -- | -- Add type synonym declarations for type class dictionary types, and value declarations for type class -- instance dictionary expressions. ---desugarTypeClasses :: [Module] -> Either ErrorStack [Module]+desugarTypeClasses :: [Module] -> SupplyT (Either ErrorStack) [Module] desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule  desugarModule :: Module -> Desugar Module@@ -160,7 +161,7 @@   m <- get    -- Lookup the type arguments and member types for the type class-  (TypeClassDeclaration _ args implies tyDecls) <- lift $+  (TypeClassDeclaration _ args implies tyDecls) <- lift . lift $     maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $       M.lookup (qualify mn className) m @@ -203,7 +204,7 @@    memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)   memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do-    _ <- lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'+    _ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'     let memberValue = typeInstanceDictionaryEntryValue d     return (ident, memberValue)   memberToNameAndValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do

@@ -0,0 +1,56 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Supply+-- Copyright   :  (c) Phil Freeman 2014+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+-- Fresh variable supply+--+-----------------------------------------------------------------------------++{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}++module Language.PureScript.Supply where++import Data.Functor.Identity++import Control.Applicative+import Control.Monad.State+import Control.Monad.Error.Class++newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } deriving (Functor, Applicative, Monad, MonadTrans)++runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)+runSupplyT n = flip runStateT n . unSupplyT++evalSupplyT :: (Functor m) => Integer -> SupplyT m a -> m a+evalSupplyT n = fmap fst . runSupplyT n++type Supply = SupplyT Identity++runSupply :: Integer -> Supply a -> (a, Integer)+runSupply n = runIdentity . runSupplyT n++evalSupply :: Integer -> Supply a -> a+evalSupply n = runIdentity . evalSupplyT n++fresh :: (Monad m) => SupplyT m Integer+fresh = SupplyT $ do+  n <- get+  put (n + 1)+  return n++freshName :: (Functor m, Monad m) => SupplyT m String+freshName = ('_' :) . show <$> fresh++instance (MonadError e m) => MonadError e (SupplyT m) where+  throwError = SupplyT . throwError+  catchError e f = SupplyT $ catchError (unSupplyT e) (unSupplyT . f)

@@ -84,7 +84,8 @@  addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check () addTypeClassDictionaries entries =-  modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }+  let mentries = M.fromList [ ((canonicalizeDictionary entry, mn), entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ }  <- entries ]+  in modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = (typeClassDictionaries . checkEnv $ st) `M.union` mentries } }  checkTypeClassInstance :: ModuleName -> Type -> Check () checkTypeClassInstance _ (TypeVar _) = return ()@@ -182,8 +183,8 @@   guardWith (strMsg ("Fixity declaration with no binding: " ++ name)) $ M.member (moduleName, Op name) $ names env   return $ d : ds typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _ _) : rest) = do-  env <- getEnv-  let instances = filter (\tcd -> let Qualified (Just mn) _ = tcdName tcd in moduleName == mn) (typeClassDictionaries env)+  tcds <- getTypeClassDictionaries+  let instances = filter (\tcd -> let Qualified (Just mn) _ = tcdName tcd in moduleName == mn) tcds   addTypeClassDictionaries [ tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (canonicalizeDictionary tcd) }                            | tcd <- instances                            , let (Qualified _ ident) = tcdName tcd

@@ -21,6 +21,7 @@ import Language.PureScript.Types import Language.PureScript.Kinds import Language.PureScript.Names+import Language.PureScript.Declarations (canonicalizeDictionary) import Language.PureScript.Environment import Language.PureScript.TypeClassDictionaries import Language.PureScript.Options@@ -63,7 +64,8 @@ withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a withTypeClassDictionaries entries action = do   orig <- get-  modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }+  let mentries = M.fromList [ ((canonicalizeDictionary entry, mn), entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ }  <- entries ]+  modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = (typeClassDictionaries . checkEnv $ st) `M.union` mentries } }   a <- action   modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }   return a@@ -72,7 +74,7 @@ -- Get the currently available list of type class dictionaries -- getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [TypeClassDictionaryInScope]-getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get+getTypeClassDictionaries = M.elems . typeClassDictionaries . checkEnv <$> get  -- | -- Temporarily bind a collection of names to local variables