summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-01-08 01:07:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-01-08 01:07:00 (GMT)
commitfc8d4c3d5d95b1c3b13b307fce2d5a0bb1b2bd67 (patch)
tree867f6d5962ff038e840961874c8a333ad47b64f1
parent57b6d9b2e8978c8b7e70cad2070205359ae1978d (diff)
version 0.2.60.2.6
-rw-r--r--purescript.cabal10
-rw-r--r--src/Language/PureScript.hs7
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs1
-rw-r--r--src/Language/PureScript/DoNotation.hs52
-rw-r--r--src/Language/PureScript/Parser/Common.hs3
-rw-r--r--src/Language/PureScript/Parser/Values.hs32
-rw-r--r--src/Language/PureScript/Pretty/Values.hs16
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs8
-rw-r--r--src/Language/PureScript/Values.hs10
9 files changed, 112 insertions, 27 deletions
diff --git a/purescript.cabal b/purescript.cabal
index 25054eb..1262a55 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -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 @@ 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: 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 @@ library
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
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 97a7991..67fa706 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -28,6 +28,7 @@ import Language.PureScript.Operators as P
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 @@ import Control.Monad (forM_, (>=>))
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
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 661c88f..89ac0e8 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -180,7 +180,6 @@ statementToJs m e (VariableIntroduction ident value) = JSVariableIntroduction id
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
diff --git a/src/Language/PureScript/DoNotation.hs b/src/Language/PureScript/DoNotation.hs
new file mode 100644
index 0000000..52d897f
--- /dev/null
+++ b/src/Language/PureScript/DoNotation.hs
@@ -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')]
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index 912bb25..24d0468 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -70,7 +70,8 @@ reservedNames = [ "case"
, "Boolean"
, "infixl"
, "infixr"
- , "module" ]
+ , "module"
+ , "let" ]
builtInOperators :: [String]
builtInOperators = [ "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"
diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs
index 9d17004..24dcecb 100644
--- a/src/Language/PureScript/Parser/Values.hs
+++ b/src/Language/PureScript/Parser/Values.hs
@@ -125,6 +125,28 @@ parseAccessor :: Value -> P.Parsec String ParseState Value
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 @@ parseValue =
, \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 @@ parseFor = For <$> (C.reserved "for" *> C.indented *> C.lexeme (P.char '(') *> C
<*> (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 @@ parseStatement = P.choice
, parseAssignment
, parseWhile
, parseFor
- , parseForEach
, parseIf
, parseValueStatement
, parseReturn ] P.<?> "statement"
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index c17579d..7db75a2 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -106,6 +106,18 @@ binary op str = AssocR match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
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 @@ prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue (
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 ]
@@ -191,9 +204,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
prettyPrintStatement (Return value) = "return " ++ prettyPrintValue value
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 754e63b..bbaad81 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -540,14 +540,6 @@ checkStatement mass ret (For ident start end inner) = do
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)
diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs
index c26e0dc..a91231a 100644
--- a/src/Language/PureScript/Values.hs
+++ b/src/Language/PureScript/Values.hs
@@ -70,14 +70,20 @@ data Value
| 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)