packages feed

purescript 0.2.4 → 0.2.6

raw patch · 9 files changed

+112/−27 lines, 9 files

Files

purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.2.4+version: 0.2.6 cabal-version: >=1.8 build-type: Simple license: MIT@@ -17,9 +17,7 @@     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: Language.PureScript.TypeDeclarations-                     Language.PureScript.BindingGroups Language.PureScript.Scope-                     Data.Generics.Extras Language.PureScript+    exposed-modules: 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@@ -39,6 +37,10 @@                      Language.PureScript.TypeChecker.Types Language.PureScript.Types                      Language.PureScript.Unknown Language.PureScript.Values Main                      Language.PureScript.CaseDeclarations+                     Language.PureScript.DoNotation+                     Language.PureScript.TypeDeclarations+                     Language.PureScript.BindingGroups+                     Language.PureScript.Scope     exposed: True     buildable: True     hs-source-dirs: src
src/Language/PureScript.hs view
@@ -28,6 +28,7 @@ import Language.PureScript.CaseDeclarations as P import Language.PureScript.TypeDeclarations as P import Language.PureScript.BindingGroups as P+import Language.PureScript.DoNotation as P  import Data.List (intercalate) import Control.Monad (forM_, (>=>))@@ -35,7 +36,11 @@ compile :: [Module] -> Either String (String, String, Environment) compile ms = do   bracketted <- rebracket ms-  desugared <- desugarCasesModule >=> desugarTypeDeclarationsModule >=> (return . createBindingGroupsModule) $ bracketted+  desugared <- desugarDo+               >=> desugarCasesModule+               >=> desugarTypeDeclarationsModule+               >=> (return . createBindingGroupsModule)+               $ bracketted   (_, env) <- runCheck $ forM_ desugared $ \(Module moduleName decls) -> typeCheckAll (ModuleName moduleName) decls   let js = prettyPrintJS . map optimize . concatMap (flip moduleToJs env) $ desugared   let exts = intercalate "\n" . map (flip moduleToPs env) $ desugared
src/Language/PureScript/CodeGen/JS.hs view
@@ -180,7 +180,6 @@ statementToJs m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs m e value) statementToJs m e (While cond sts) = JSWhile (valueToJs m e cond) (JSBlock (map (statementToJs m e) sts)) statementToJs m e (For ident start end sts) = JSFor ident (valueToJs m e start) (valueToJs m e end) (JSBlock (map (statementToJs m e) sts))-statementToJs m e (ForEach ident arr sts) = JSApp (JSAccessor "forEach" (valueToJs m e arr)) [JSFunction Nothing [ident] (JSBlock (map (statementToJs m e) sts))] statementToJs m e (If ifst) = ifToJs ifst   where   ifToJs :: IfStatement -> JS
+ src/Language/PureScript/DoNotation.hs view
@@ -0,0 +1,52 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.DoNotation+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.DoNotation (+    desugarDo+) where++import Data.Data+import Data.Generics++import Language.PureScript.Values+import Language.PureScript.Names+import Language.PureScript.Scope++desugarDo :: (Data d) => d -> Either String d+desugarDo = everywhereM (mkM replace)+  where+  replace :: Value -> Either String Value+  replace (Do monad els) = go monad els+  replace other = return other+  go :: Value -> [DoNotationElement] -> Either String Value+  go _ [] = error "The impossible happened in desugarDo"+  go monad [DoNotationReturn val] = return $ App (Accessor "ret" monad) [val]+  go _ (DoNotationReturn _ : _) = Left "Return statement must be the last statement in a do block"+  go _ [DoNotationValue val] = return val+  go monad (DoNotationValue val : rest) = do+    rest' <- go monad rest+    return $ App (App (Accessor "bind" monad) [val]) [Abs [Ident "_"] rest']+  go _ [DoNotationBind _ _] = Left "Bind statement cannot be the last statement in a do block"+  go monad (DoNotationBind NullBinder val : rest) = go monad (DoNotationValue val : rest)+  go monad (DoNotationBind (VarBinder ident) val : rest) = do+    rest' <- go monad rest+    return $ App (App (Accessor "bind" monad) [val]) [Abs [ident] rest']+  go monad (DoNotationBind binder val : rest) = do+    rest' <- go monad rest+    let ident = head $ unusedNames rest'+    return $ App (App (Accessor "bind" monad) [val]) [Abs [ident] (Case [Var (Qualified Nothing ident)] [([binder], Nothing, rest')])]+  go _ [DoNotationLet _ _] = Left "Let statement cannot be the last statement in a do block"+  go monad (DoNotationLet binder val : rest) = do+    rest' <- go monad rest+    return $ Case [val] [([binder], Nothing, rest')]
src/Language/PureScript/Parser/Common.hs view
@@ -70,7 +70,8 @@                 , "Boolean"                 , "infixl"                 , "infixr"-                , "module" ]+                , "module"+                , "let" ]  builtInOperators :: [String] builtInOperators = [ "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"
src/Language/PureScript/Parser/Values.hs view
@@ -125,6 +125,28 @@ parseAccessor (Constructor _) = P.unexpected "constructor" parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> C.identifier) <*> pure obj +parseDoNotationLet :: P.Parsec String ParseState DoNotationElement+parseDoNotationLet = DoNotationLet <$> (C.reserved "let" *> C.indented *> parseBinder)+                                   <*> (C.indented *> C.reservedOp "=" *> parseValue)++parseDoNotationBind :: P.Parsec String ParseState DoNotationElement+parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> C.reservedOp "<-" *> parseValue)++parseDoNotationReturn :: P.Parsec String ParseState DoNotationElement+parseDoNotationReturn = DoNotationReturn <$> (C.reserved "return" *> C.indented *> parseValue)++parseDoNotationElement :: P.Parsec String ParseState DoNotationElement+parseDoNotationElement = P.choice+            [ P.try parseDoNotationBind+            , parseDoNotationLet+            , parseDoNotationReturn+            , P.try (DoNotationValue <$> parseValue) ]++parseManyDoNotationElements :: P.Parsec String ParseState [DoNotationElement]+parseManyDoNotationElements = do+  C.indented+  C.mark (P.many (C.same *> C.mark parseDoNotationElement))+ parseValue :: P.Parsec String ParseState Value parseValue =   (buildExpressionParser operators@@ -136,7 +158,9 @@                   , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]   postfixTable2 = [ \v -> P.try (C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2])) <*> pure v                   , \v -> P.try $ flip App <$> (C.indented *> C.parens (C.commaSep parseValue)) <*> pure v-                  , \v -> flip TypedValue <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v ]+                  , \v -> flip TypedValue <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v+                  , \v -> P.try $ Do v <$> (C.indented *> C.reserved "do" *> parseManyDoNotationElements)+                  ]   operators = [ [ Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "!") >> return (Unary Not)                 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "~") >> return (Unary BitwiseNot)                 , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Unary Negate)@@ -174,11 +198,6 @@                <*> (C.indented *> C.reserved "until" *> parseValue <* C.indented <* C.lexeme (P.char ')'))                <*> parseManyStatements -parseForEach :: P.Parsec String ParseState Statement-parseForEach = ForEach <$> (C.reserved "foreach" *> C.indented *> C.lexeme (P.char '(') *> C.indented *> C.parseIdent)-                       <*> (C.indented *> C.reserved "in" *> parseValue <* C.lexeme (P.char ')'))-                       <*> parseManyStatements- parseIf :: P.Parsec String ParseState Statement parseIf = If <$> parseIfStatement @@ -204,7 +223,6 @@                  , parseAssignment                  , parseWhile                  , parseFor-                 , parseForEach                  , parseIf                  , parseValueStatement                  , parseReturn ] P.<?> "statement"
src/Language/PureScript/Pretty/Values.hs view
@@ -106,6 +106,18 @@     match' (Binary op' v1 v2) | op' == op = Just (v1, v2)     match' _ = Nothing +_do :: Pattern () Value ([DoNotationElement], Value)+_do = mkPattern match+  where+  match (Do val els) = Just (els, val)+  match _ = Nothing++prettyPrintDoNotationElement :: DoNotationElement -> String+prettyPrintDoNotationElement (DoNotationValue val) = prettyPrintValue val+prettyPrintDoNotationElement (DoNotationBind binder val) = prettyPrintBinder binder ++ " <- " ++ prettyPrintValue val+prettyPrintDoNotationElement (DoNotationLet binder val) = "let " ++ prettyPrintBinder binder ++ " = " ++ prettyPrintValue val+prettyPrintDoNotationElement (DoNotationReturn val) = "return " ++ prettyPrintValue val+ prettyPrintValue :: Value -> String prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue ()   where@@ -116,6 +128,7 @@     OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]                   , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]                   , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]+                  , [ Wrap _do $ \els val -> val ++ " do { " ++ intercalate "; " (map prettyPrintDoNotationElement els) ++ " }" ]                   , [ Split lam $ \args val -> "\\" ++ intercalate ", " args ++ " -> " ++ prettyPrintValue val ]                   , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintValue th ++ " : " ++ prettyPrintValue el ]                   , [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]@@ -190,9 +203,6 @@ prettyPrintStatement (For ident start end sts) = "for " ++ show ident   ++ " <- " ++ prettyPrintValue start   ++ " until " ++ prettyPrintValue end ++ ": {"-  ++ intercalate "; " (map prettyPrintStatement sts) ++ " }"-prettyPrintStatement (ForEach ident arr sts) = "foreach " ++ show ident-  ++ " in " ++ prettyPrintValue arr ++ ": {"   ++ intercalate "; " (map prettyPrintStatement sts) ++ " }" prettyPrintStatement (If ifst) = prettyPrintIfStatement ifst prettyPrintStatement (ValueStatement val) = prettyPrintValue val
src/Language/PureScript/TypeChecker/Types.hs view
@@ -540,14 +540,6 @@   check end Number   (allCodePathsReturn, _) <- bindLocalVariables moduleName [(ident, Number)] $ checkBlock mass ret inner   return (allCodePathsReturn, mass)-checkStatement mass ret (ForEach ident vals inner) = do-  moduleName <- substCurrentModule <$> ask-  assignVariable ident-  val <- fresh-  check vals (Array val)-  (allCodePathsReturn, _) <- bindLocalVariables moduleName [(ident, val)] $ checkBlock mass ret inner-  guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn-  return (False, mass) checkStatement mass _ (ValueStatement val) = do   check val unit   return (False, mass)
src/Language/PureScript/Values.hs view
@@ -70,14 +70,20 @@   | Block [Statement]   | Constructor (Qualified ProperName)   | Case [Value] [([Binder], Maybe Guard, Value)]-  | TypedValue Value Type deriving (Show, Data, Typeable)+  | TypedValue Value Type+  | Do Value [DoNotationElement] deriving (Show, Data, Typeable) +data DoNotationElement+  = DoNotationValue Value+  | DoNotationBind Binder Value+  | DoNotationLet Binder Value+  | DoNotationReturn Value deriving (Show, Data, Typeable)+ data Statement   = VariableIntroduction Ident Value   | Assignment Ident Value   | While Value [Statement]   | For Ident Value Value [Statement]-  | ForEach Ident Value [Statement]   | If IfStatement   | ValueStatement Value   | Return Value deriving (Show, Data, Typeable)