packages feed

purescript 0.2.0 → 0.2.1

raw patch · 17 files changed

+256/−70 lines, 17 filesdep ~base

Dependency ranges changed: base

Files

purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.2.0+version: 0.2.1 cabal-version: >=1.8 build-type: Simple license: MIT@@ -15,11 +15,12 @@  library     build-depends: base >=4 && <5, cmdtheline -any, containers -any,-                   directory -any, filepath -any, mtl -any, parsec -any,-                   syb -any, transformers -any, utf8-string -any-    exposed-modules: Data.Generics.Extras Language.PureScript-                     Language.PureScript.CodeGen Language.PureScript.CodeGen.Externs-                     Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.AST+                   directory -any, filepath -any, mtl -any, parsec -any, syb -any,+                   transformers -any, utf8-string -any+    exposed-modules: Language.PureScript.Scope Data.Generics.Extras+                     Language.PureScript Language.PureScript.CodeGen+                     Language.PureScript.CodeGen.Externs Language.PureScript.CodeGen.JS+                     Language.PureScript.CodeGen.JS.AST                      Language.PureScript.CodeGen.Monad Language.PureScript.Declarations                      Language.PureScript.Kinds Language.PureScript.Names                      Language.PureScript.Operators Language.PureScript.Optimize@@ -36,6 +37,7 @@                      Language.PureScript.TypeChecker.Synonyms                      Language.PureScript.TypeChecker.Types Language.PureScript.Types                      Language.PureScript.Unknown Language.PureScript.Values Main+                     Language.PureScript.CaseDeclarations     exposed: True     buildable: True     hs-source-dirs: src@@ -47,6 +49,7 @@     main-is: Main.hs     buildable: True     hs-source-dirs: src+    other-modules:     ghc-options: -Wall -O2 -fno-warn-unused-do-bind  test-suite tests
src/Language/PureScript.hs view
@@ -25,6 +25,7 @@ import Language.PureScript.Pretty as P import Language.PureScript.Optimize as P import Language.PureScript.Operators as P+import Language.PureScript.CaseDeclarations as P  import Data.List (intercalate) import Data.Maybe (mapMaybe)@@ -32,7 +33,8 @@ compile :: [Declaration] -> Either String (String, String, Environment) compile decls = do   bracketted <- rebracket decls-  (_, env) <- runCheck (typeCheckAll bracketted)-  let js = prettyPrintJS . map optimize . concat . mapMaybe (\decl -> declToJs Nothing global decl env) $ bracketted-  let exts = intercalate "\n" . mapMaybe (externToPs 0 global env) $ bracketted+  desugared <- desugarCases bracketted+  (_, env) <- runCheck (typeCheckAll desugared)+  let js = prettyPrintJS . map optimize . concat . mapMaybe (\decl -> declToJs Nothing global decl env) $ desugared+  let exts = intercalate "\n" . mapMaybe (externToPs 0 global env) $ desugared   return (js, exts, env)
+ src/Language/PureScript/CaseDeclarations.hs view
@@ -0,0 +1,62 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.CaseDeclarations+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.CaseDeclarations (+    desugarCases+) where++import Data.List (groupBy)+import Control.Monad (join, unless)+import Control.Monad.Error.Class++import Language.PureScript.Names+import Language.PureScript.Values+import Language.PureScript.Declarations+import Language.PureScript.Scope++desugarCases :: [Declaration] -> Either String [Declaration]+desugarCases = fmap join . mapM toDecls . groupBy inSameGroup++inSameGroup :: Declaration -> Declaration -> Bool+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+  let tuples = map toTuple ds+  unless (all ((== map length bs) . map length . fst) tuples) $+      throwError $ "Argument list lengths differ in declaration " ++ show ident+  return [makeCaseDeclaration ident tuples]+toDecls ds = return ds++toTuple :: Declaration -> ([[Binder]], (Maybe Guard, Value))+toTuple (ValueDeclaration _ bs g val) = (bs, (g, val))+toTuple _ = error "Not a value declaration"++makeCaseDeclaration :: Ident -> [([[Binder]], (Maybe Guard, Value))] -> Declaration+makeCaseDeclaration ident alternatives =+  let+    argPattern = map length . fst . head $ alternatives+    args = take (sum argPattern) $ unusedNames (ident, alternatives)+    vars = map (\arg -> Var (Qualified global arg)) args+    binders = [ (join bs, g, val) | (bs, (g, val)) <- alternatives ]+    value = foldr (\args' ret -> Abs args' ret) (Case vars binders) (rearrange argPattern args)+  in+    ValueDeclaration ident [] Nothing value++rearrange :: [Int] -> [a] -> [[a]]+rearrange [] _ = []+rearrange (n:ns) xs = take n xs : rearrange ns (drop n xs)+
src/Language/PureScript/CodeGen/Externs.hs view
@@ -24,7 +24,7 @@ import Language.PureScript.Names  externToPs :: Int -> ModulePath -> Environment -> Declaration -> Maybe String-externToPs indent path env (ValueDeclaration name _) = do+externToPs indent path env (ValueDeclaration name _ _ _) = do   (ty, _) <- M.lookup (path, name) $ names env   return $ replicate indent ' ' ++ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty externToPs indent path env (DataDeclaration name _ _) = do
src/Language/PureScript/CodeGen/JS.hs view
@@ -20,11 +20,12 @@ import Data.Maybe (mapMaybe) import qualified Data.Map as M import Control.Arrow (second)-import Control.Monad (forM)+import Control.Monad (replicateM, forM)  import Language.PureScript.TypeChecker (Environment, names) import Language.PureScript.Values import Language.PureScript.Names+import Language.PureScript.Scope import Language.PureScript.Declarations import Language.PureScript.Pretty.Common import Language.PureScript.CodeGen.Monad@@ -32,10 +33,10 @@ import Language.PureScript.TypeChecker.Monad (NameKind(..))  declToJs :: Maybe Ident -> ModulePath -> Declaration -> Environment -> Maybe [JS]-declToJs curMod mp (ValueDeclaration ident (Abs args ret)) e =+declToJs curMod mp (ValueDeclaration ident _ _ (Abs args ret)) e =   Just $ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp e ret)]) :          maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod-declToJs curMod mp (ValueDeclaration ident val) e =+declToJs curMod mp (ValueDeclaration ident _ _ val) e =   Just $ JSVariableIntroduction ident (Just (valueToJs mp e val)) :          maybe [] (return . setProperty (identToJs ident) (JSVar ident)) curMod declToJs curMod _ (ExternMemberDeclaration member ident _) _ =@@ -73,7 +74,7 @@ valueToJs m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs m e o, JSObjectLiteral (map (second (valueToJs m e)) ps)] valueToJs _ _ (Constructor name) = qualifiedToJS runProperName name valueToJs m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs m e) sts))) []-valueToJs m e (Case value binders) = runGen (bindersToJs m e binders (valueToJs m e value))+valueToJs m e (Case values binders) = runGen (bindersToJs m e binders (map (valueToJs m e) values)) valueToJs m e (IfThenElse cond th el) = JSConditional (valueToJs m e cond) (valueToJs m e th) (valueToJs m e el) valueToJs m e (Accessor prop val) = JSAccessor prop (valueToJs m e val) valueToJs m e (Indexer index val) = JSIndexer (valueToJs m e index) (valueToJs m e val)@@ -94,12 +95,21 @@        delimited (part:parts') = JSAccessor part (delimited parts')        delimited _            = error "Invalid argument to delimited" -bindersToJs :: ModulePath -> Environment -> [(Binder, Value)] -> JS -> Gen JS-bindersToJs m e binders val = do-  valName <- fresh-  jss <- forM binders $ \(binder, result) -> binderToJs m e valName [JSReturn (valueToJs m e result)] binder-  return $ JSApp (JSFunction Nothing [Ident valName] (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))-                 [val]+bindersToJs :: ModulePath -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> Gen JS+bindersToJs m e binders vals = do+  setNextName $ firstUnusedName (binders, vals)+  valNames <- replicateM (length vals) fresh+  jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs m e result)] bs grd+  return $ JSApp (JSFunction Nothing (map Ident valNames) (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))+                 vals+  where+    go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]+    go _ done [] Nothing = return done+    go _ done [] (Just cond) = return [JSIfElse (valueToJs m e cond) (JSBlock done) Nothing]+    go (v:vs) done' (b:bs) grd = do+      done'' <- go vs done' bs grd+      binderToJs m e v done'' b+    go _ _ _ _ = error "Invalid arguments to bindersToJs"  binderToJs :: ModulePath -> Environment -> String -> [JS] -> Binder -> Gen [JS] binderToJs _ _ _ done NullBinder = return done@@ -152,9 +162,6 @@ binderToJs m e varName done (NamedBinder ident binder) = do   js <- binderToJs m e varName done binder   return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)-binderToJs m e varName done (GuardedBinder cond binder) = binderToJs m e varName done' binder-  where-  done' = [JSIfElse (valueToJs m e cond) (JSBlock done) Nothing]  statementToJs :: ModulePath -> Environment -> Statement -> JS statementToJs m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m e value))
src/Language/PureScript/CodeGen/JS/AST.hs view
@@ -47,3 +47,5 @@ data JSAssignment   = JSAssignVariable Ident   | JSAssignProperty String JSAssignment deriving (Show, Data, Typeable)++
src/Language/PureScript/CodeGen/Monad.hs view
@@ -19,7 +19,7 @@ import Control.Monad.State import Control.Applicative -newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Applicative, Monad, MonadState Int)+newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Applicative, Monad, MonadState Int, MonadFix)  runGen :: Gen a -> a runGen = flip evalState 0 . unGen@@ -29,3 +29,9 @@   n <- get   modify (+ 1)   return $ '_' : show n++getNextName :: Gen Int+getNextName = get++setNextName :: Int -> Gen ()+setNextName = put
src/Language/PureScript/Declarations.hs view
@@ -33,7 +33,7 @@   = DataDeclaration ProperName [String] [(ProperName, Maybe PolyType)]   | TypeSynonymDeclaration ProperName [String] PolyType   | TypeDeclaration Ident PolyType-  | ValueDeclaration Ident Value+  | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value   | ExternDeclaration Ident PolyType   | ExternMemberDeclaration String Ident PolyType   | ExternDataDeclaration ProperName Kind
src/Language/PureScript/Optimize.hs view
@@ -17,6 +17,7 @@ ) where  import Data.Data+import Data.Maybe (fromMaybe) import Data.Generics  import Language.PureScript.Names@@ -31,6 +32,12 @@   replace (JSVar var2) | var1 == var2 = js   replace other = other +replaceIdents :: (Data d) => [(Ident, JS)] -> d -> d+replaceIdents vars = everywhere (mkT replace)+  where+  replace v@(JSVar var) = fromMaybe v $ lookup var vars+  replace other = other+ isReassigned :: (Data d) => Ident -> d -> Bool isReassigned var1 = everything (||) (mkQ False check)   where@@ -84,7 +91,8 @@ etaConvert = everywhere (mkT convert)   where   convert :: JS -> JS-  convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [ident] (JSBlock body)) [arg])]) | shouldInline arg = JSBlock (replaceIdent ident arg body)+  convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents (JSBlock body)) args)])+    | all shouldInline args = JSBlock (replaceIdents (zip idents args) body)   convert js = js  unThunk :: JS -> JS
src/Language/PureScript/Parser/Common.hs view
@@ -74,10 +74,10 @@  builtInOperators :: [String] builtInOperators = [ "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"-                  , "==", "!=", "&&", "||", "&", "^", "|", "!!", "!", "." ]+                  , "==", "!=", "&&", "||", "&", "^", "|", "!!", "!" ]  reservedOpNames :: [String]-reservedOpNames = builtInOperators ++ [ "->" ]+reservedOpNames = builtInOperators ++ [ "->", "=", "." ]  identStart :: P.Parsec String u Char identStart = P.lower <|> P.oneOf "_$"
src/Language/PureScript/Parser/Declarations.hs view
@@ -27,6 +27,7 @@ import Language.PureScript.Parser.Values import Language.PureScript.Parser.Types import Language.PureScript.Parser.Kinds+import Language.PureScript.Values  parseDataDeclaration :: P.Parsec String ParseState Declaration parseDataDeclaration = do@@ -50,8 +51,13 @@  parseValueDeclaration :: P.Parsec String ParseState Declaration parseValueDeclaration =-  ValueDeclaration <$> P.try (parseIdent <* lexeme (indented *> P.char '='))-                   <*> parseValue+  ValueDeclaration <$> parseIdent+                   <*> P.many parseTopLevelBinder+                   <*> P.optionMaybe parseGuard+                   <*> ((lexeme (indented *> P.char '=')) *> parseValue)++parseTopLevelBinder :: P.Parsec String ParseState [Binder]+parseTopLevelBinder = return <$> P.try parseBinderNoParens <|> parens (commaSep parseBinder)  parseExternDeclaration :: P.Parsec String ParseState Declaration parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>
src/Language/PureScript/Parser/Values.hs view
@@ -14,7 +14,9 @@  module Language.PureScript.Parser.Values (     parseValue,-    parseBinder+    parseGuard,+    parseBinder,+    parseBinderNoParens ) where  import Language.PureScript.Values@@ -72,13 +74,14 @@ parseConstructor = Constructor <$> C.parseQualified C.properName  parseCase :: P.Parsec String ParseState Value-parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") parseValue+parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)                  <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative))) -parseCaseAlternative :: P.Parsec String ParseState (Binder, Value)-parseCaseAlternative = (,) <$> (parseGuardedBinder <* C.lexeme (P.string "->"))-                           <*> parseValue-                           P.<?> "case alternative"+parseCaseAlternative :: P.Parsec String ParseState ([Binder], Maybe Guard, Value)+parseCaseAlternative = (,,) <$> (return <$> parseBinder)+                            <*> P.optionMaybe parseGuard+                            <*> (C.lexeme (P.string "->") *> parseValue)+                            P.<?> "case alternative"  parseIfThenElse :: P.Parsec String ParseState Value parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)@@ -263,6 +266,19 @@   where   operators = [ [ Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) AssocRight ] ] -parseGuardedBinder :: P.Parsec String ParseState Binder-parseGuardedBinder = flip ($) <$> parseBinder <*> P.option id (GuardedBinder <$> (C.indented *> C.lexeme (P.char '|') *> C.indented *> parseValue))+parseBinderNoParens :: P.Parsec String ParseState Binder+parseBinderNoParens = P.choice (map P.try+                  [ parseNullBinder+                  , parseStringBinder+                  , parseBooleanBinder+                  , parseNumberBinder+                  , parseNamedBinder+                  , parseVarBinder+                  , parseNullaryBinder+                  , parseObjectBinder+                  , parseArrayBinder+                  , C.parens parseBinder ]) P.<?> "binder"++parseGuard :: P.Parsec String ParseState Guard+parseGuard = C.indented *> C.pipe *> C.indented *> parseValue
src/Language/PureScript/Pretty/Values.hs view
@@ -37,12 +37,14 @@   match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"   match (Constructor name) = Just $ show name   match (Block sts) = Just $ "do { " ++ intercalate " ; " (map prettyPrintStatement sts) ++ " }"-  match (Case value binders) = Just $ "case " ++ prettyPrintValue value ++ " of { " ++ intercalate " ; " (map (uncurry prettyPrintCaseAlternative) binders) ++ " }"+  match (Case values binders) = Just $ "case " ++ intercalate " " (map prettyPrintValue values) +++    " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"   match (Var ident) = Just $ show ident   match _ = Nothing -prettyPrintCaseAlternative :: Binder -> Value -> String-prettyPrintCaseAlternative binder val = prettyPrintBinder binder ++ " -> " ++ prettyPrintValue val+prettyPrintCaseAlternative :: ([Binder], Maybe Guard, Value) -> String+prettyPrintCaseAlternative (binders, grd, val) = "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " +++  (maybe "" (("| " ++) . prettyPrintValue) grd) ++ " -> " ++ prettyPrintValue val  ifThenElse :: Pattern () Value ((Value, Value), Value) ifThenElse = mkPattern match@@ -158,7 +160,6 @@   match (ObjectBinder bs) = Just $ "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"   match (ArrayBinder bs) = Just $ "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]"   match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder-  match (GuardedBinder cond binder) = Just $ prettyPrintBinder binder ++ " | " ++ prettyPrintValue cond   match _ = Nothing  prettyPrintBinder :: Binder -> String
+ src/Language/PureScript/Scope.hs view
@@ -0,0 +1,71 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.Scope+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.Scope (+    usedNames,+    unusedNames,+    firstUnusedName+) where++import Data.Data+import Data.List ((\\), nub)+import Data.Generics (extQ, mkQ, everything)++import Language.PureScript.Values+import Language.PureScript.Names+import Language.PureScript.CodeGen.JS.AST+import Data.Maybe (mapMaybe)+import Text.Read (readMaybe)++usedNames :: (Data d) => d -> [Ident]+usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB `extQ` namesJS) val+  where+  namesV :: Value -> [Ident]+  namesV (Abs args _) = args+  namesV (Var (Qualified (ModulePath []) name)) = [name]+  namesV _ = []+  namesS :: Statement -> [Ident]+  namesS (VariableIntroduction name _) = [name]+  namesS (For name _ _ _) = [name]+  namesS _ = []+  namesB :: Binder -> [Ident]+  namesB (VarBinder name) = [name]+  namesB _ = []+  namesJS :: JS -> [Ident]+  namesJS (JSVar name) = [name]+  namesJS (JSFunction (Just name) args _) = name : args+  namesJS (JSFunction Nothing args _) = args+  namesJS (JSVariableIntroduction name _) = [name]+  namesJS (JSFor name _ _ _) = [name]+  namesJS _ = []++unusedNames :: (Data d) => d -> [Ident]+unusedNames val =+  let+    allNames = usedNames val+    varNames = map (Ident . ('_' :) . show) ([1..] :: [Int])+  in+    varNames \\ allNames++firstUnusedName :: (Data d) => d -> Int+firstUnusedName val =+  let+    allNames = usedNames val+    varNames = mapMaybe toUnknown allNames+  in+    1 + maximum (0 : varNames)+  where+  toUnknown :: Ident -> Maybe Int+  toUnknown (Ident ('_' : s)) = readMaybe s+  toUnknown _ = Nothing
src/Language/PureScript/TypeChecker.hs view
@@ -63,10 +63,10 @@     putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env)                  , typeSynonyms = M.insert (modulePath, name) (args, ty) (typeSynonyms env) }   typeCheckAll rest-typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' val : rest) | name == name' =-  typeCheckAll (ValueDeclaration name (TypedValue val ty) : rest)+typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' [] Nothing val : rest) | name == name' =+  typeCheckAll (ValueDeclaration name [] Nothing (TypedValue val ty) : rest) typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name-typeCheckAll (ValueDeclaration name val : rest) = do+typeCheckAll (ValueDeclaration name [] Nothing val : rest) = do   rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do     env <- getEnv     modulePath <- checkModulePath `fmap` get@@ -76,6 +76,7 @@         ty <- typeOf (Just name) val         putEnv (env { names = M.insert (modulePath, name) (ty, Value) (names env) })   typeCheckAll rest+typeCheckAll (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared" typeCheckAll (ExternDataDeclaration name kind : rest) = do   env <- getEnv   modulePath <- checkModulePath `fmap` get
src/Language/PureScript/TypeChecker/Types.hs view
@@ -331,10 +331,10 @@   case M.lookup (qualify modulePath c) (dataConstructors env) of     Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"     Just ty -> replaceAllTypeSynonyms ty-infer' (Case val binders) = do-  t1 <- infer val+infer' (Case vals binders) = do+  ts <- mapM infer vals   ret <- fresh-  checkBinders t1 ret binders+  checkBinders ts ret binders   return ret infer' (IfThenElse cond th el) = do   check cond Boolean@@ -451,9 +451,12 @@   modulePath <- checkModulePath <$> get   case M.lookup (qualify modulePath ctor) (dataConstructors env) of     Just ty -> do-      Function [obj] ret <- replaceAllVarsWithUnknowns ty-      val `subsumes` ret-      inferBinder obj binder+      fn <- replaceAllVarsWithUnknowns ty+      case fn of+        Function [obj] ret -> do+          val `subsumes` ret+          inferBinder obj binder+        _ -> throwError $ "Constructor " ++ show ctor ++ " is not a unary constructor"     _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined" inferBinder val (ObjectBinder props) = do   row <- fresh@@ -483,21 +486,17 @@ inferBinder val (NamedBinder name binder) = do   m <- inferBinder val binder   return $ M.insert name val m-inferBinder _ _ = error "Invalid argument to inferBinder" -inferGuardedBinder :: Type -> Binder -> Subst (M.Map Ident Type)-inferGuardedBinder val (GuardedBinder cond binder) = do-  m1 <- inferBinder val binder-  bindLocalVariables (M.toList m1) $ check cond Boolean-  return m1-inferGuardedBinder val b = inferBinder val b--checkBinders :: Type -> Type -> [(Binder, Value)] -> Subst ()+checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> Subst () checkBinders _ _ [] = return ()-checkBinders nval ret ((binder, val):bs) = do-  m1 <- inferGuardedBinder nval binder-  bindLocalVariables (M.toList m1) $ check val ret-  checkBinders nval ret bs+checkBinders nvals ret ((binders, grd, val):bs) = do+  m1 <- M.unions <$> zipWithM inferBinder nvals binders+  bindLocalVariables (M.toList m1) $ do+    check val ret+    case grd of+      Nothing -> return ()+      Just g -> check g Boolean+  checkBinders nvals ret bs  assignVariable :: Ident -> Subst () assignVariable name = do@@ -618,9 +617,9 @@   guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star   ty1 `subsumes` ty2   check val ty1-check' (Case val binders) ret = do-  t1 <- infer val-  checkBinders t1 ret binders+check' (Case vals binders) ret = do+  ts <- mapM infer vals+  checkBinders ts ret binders check' (IfThenElse cond th el) ty = do   check cond Boolean   check th ty@@ -712,6 +711,7 @@   replaced <- replaceVarWithUnknown ident ty   inferFunctionApplication replaced args inferFunctionApplication u@(TUnknown _) args = do+   ret <- fresh   args' <- mapM replaceAllVarsWithUnknowns args   u ~~ Function args' ret
src/Language/PureScript/Values.hs view
@@ -21,6 +21,8 @@  import Data.Data +type Guard = Value+ data UnaryOperator   = Negate   | Not@@ -67,7 +69,7 @@   | IfThenElse Value Value Value   | Block [Statement]   | Constructor (Qualified ProperName)-  | Case Value [(Binder, Value)]+  | Case [Value] [([Binder], Maybe Guard, Value)]   | TypedValue Value PolyType deriving (Show, Data, Typeable)  data Statement@@ -97,5 +99,4 @@   | ObjectBinder [(String, Binder)]   | ArrayBinder [Binder]   | ConsBinder Binder Binder-  | NamedBinder Ident Binder-  | GuardedBinder Value Binder deriving (Show, Data, Typeable)+  | NamedBinder Ident Binder deriving (Show, Data, Typeable)