packages feed

purescript 0.4.4 → 0.4.5

raw patch · 39 files changed

+904/−427 lines, 39 files

Files

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