summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2013-12-23 02:58:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2013-12-23 02:58:00 (GMT)
commitffeeca8afd412c527d80ce9b6d65299d859d34d0 (patch)
tree68c466b68c51819dcb7b963d21cb781c952cf1d7
parent85a7deed23509180aaa3389b5ce1de7f238fcc69 (diff)
version 0.2.00.2.0
-rw-r--r--purescript.cabal2
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs31
-rw-r--r--src/Language/PureScript/Parser/Common.hs6
-rw-r--r--src/Language/PureScript/Parser/Values.hs64
-rw-r--r--src/Language/PureScript/Pretty/Values.hs44
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs17
-rw-r--r--src/Language/PureScript/Types.hs3
-rw-r--r--src/Language/PureScript/Values.hs4
8 files changed, 112 insertions, 59 deletions
diff --git a/purescript.cabal b/purescript.cabal
index 2b9e70a..ef94abd 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.1.15
+version: 0.2.0
cabal-version: >=1.8
build-type: Simple
license: MIT
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 7c4bef3..a3b0ec8 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -128,23 +128,27 @@ binderToJs m e varName done (ObjectBinder bs) = go done bs
done'' <- go done' bs'
js <- binderToJs m e propVar done'' binder
return (JSVariableIntroduction (Ident propVar) (Just (JSAccessor prop (JSVar (Ident varName)))) : js)
-binderToJs m e varName done (ArrayBinder bs rest) = do
- js <- go done rest 0 bs
- return [JSIfElse (JSBinary cmp (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
+binderToJs m e varName done (ArrayBinder bs) = do
+ js <- go done 0 bs
+ return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
where
- cmp :: BinaryOperator
- cmp = maybe EqualTo (const GreaterThanOrEqualTo) rest
- go :: [JS] -> Maybe Binder -> Integer -> [Binder] -> Gen [JS]
- go done' Nothing _ [] = return done'
- go done' (Just binder) index [] = do
- restVar <- fresh
- js <- binderToJs m e restVar done' binder
- return (JSVariableIntroduction (Ident restVar) (Just (JSApp (JSAccessor "slice" (JSVar (Ident varName))) [JSNumericLiteral (Left index)])) : js)
- go done' rest' index (binder:bs') = do
+ go :: [JS] -> Integer -> [Binder] -> Gen [JS]
+ go done' _ [] = return done'
+ go done' index (binder:bs') = do
elVar <- fresh
- done'' <- go done' rest' (index + 1) bs'
+ done'' <- go done' (index + 1) bs'
js <- binderToJs m e elVar done'' binder
return (JSVariableIntroduction (Ident elVar) (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar (Ident varName)))) : js)
+binderToJs m e varName done (ConsBinder headBinder tailBinder) = do
+ headVar <- fresh
+ tailVar <- fresh
+ js1 <- binderToJs m e headVar done headBinder
+ js2 <- binderToJs m e tailVar js1 tailBinder
+ return [JSIfElse (JSBinary GreaterThan (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left 0))) (JSBlock
+ ( JSVariableIntroduction (Ident headVar) (Just (JSIndexer (JSNumericLiteral (Left 0)) (JSVar (Ident varName)))) :
+ JSVariableIntroduction (Ident tailVar) (Just (JSApp (JSAccessor "slice" (JSVar (Ident varName))) [JSNumericLiteral (Left 1)])) :
+ js2
+ )) Nothing]
binderToJs m e varName done (NamedBinder ident binder) = do
js <- binderToJs m e varName done binder
return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)
@@ -165,4 +169,5 @@ statementToJs m e (If ifst) = ifToJs ifst
elseToJs :: ElseStatement -> JS
elseToJs (Else sts) = JSBlock (map (statementToJs m e) sts)
elseToJs (ElseIf elif) = ifToJs elif
+statementToJs m e (ValueStatement val) = valueToJs m e val
statementToJs m e (Return value) = JSReturn (valueToJs m e value)
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index a7c64c4..95326c1 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -74,7 +74,7 @@ reservedNames = [ "case"
builtInOperators :: [String]
builtInOperators = [ "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"
- , "==", "!=", "&&", "||", "&", "^", "|", "!!", "!" ]
+ , "==", "!=", "&&", "||", "&", "^", "|", "!!", "!", "." ]
reservedOpNames :: [String]
reservedOpNames = builtInOperators ++ [ "->" ]
@@ -89,10 +89,10 @@ identLetter :: P.Parsec String u Char
identLetter = P.alphaNum <|> P.oneOf "_'"
opStart :: P.Parsec String u Char
-opStart = P.oneOf "!#%&*+/<=>?@^|~"
+opStart = P.oneOf ":.!#%&*+/<=>?@^|~"
opLetter :: P.Parsec String u Char
-opLetter = P.oneOf ":#$%&*+./<=>?@^|"
+opLetter = P.oneOf ":.#$%&*+./<=>?@^|"
langDef :: PT.GenLanguageDef String u Identity
langDef = PT.LanguageDef
diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs
index f0e9f2d..f2e7ad4 100644
--- a/src/Language/PureScript/Parser/Values.hs
+++ b/src/Language/PureScript/Parser/Values.hs
@@ -86,18 +86,23 @@ parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parse
<*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)
parseBlock :: P.Parsec String ParseState Value
-parseBlock = Block <$> (P.try (C.reserved "do") *> parseManyStatements)
+parseBlock = Block <$> parseManyStatements
parseManyStatements :: P.Parsec String ParseState [Statement]
-parseManyStatements = C.indented *> C.mark (P.many (C.same *> C.mark parseStatement)) P.<?> "block"
+parseManyStatements = (do
+ C.lexeme $ P.char '{'
+ C.indented
+ sts <- C.mark (P.many (C.same *> C.mark parseStatement))
+ C.lexeme (P.char '}')
+ return sts) P.<?> "block"
parseValueAtom :: P.Parsec String ParseState Value
-parseValueAtom = C.indented *> P.choice
+parseValueAtom = P.choice
[ P.try parseNumericLiteral
, P.try parseStringLiteral
, P.try parseBooleanLiteral
, parseArrayLiteral
- , parseObjectLiteral
+ , P.try parseObjectLiteral
, parseAbs
, P.try parseConstructor
, P.try parseVar
@@ -115,7 +120,7 @@ parsePropertyUpdate = do
parseAccessor :: Value -> P.Parsec String ParseState Value
parseAccessor (Constructor _) = P.unexpected "constructor"
-parseAccessor obj = Accessor <$> (C.indented *> C.dot *> C.indented *> C.identifier) <*> pure obj
+parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> C.identifier) <*> pure obj
parseValue :: P.Parsec String ParseState Value
parseValue =
@@ -143,28 +148,32 @@ parseVariableIntroduction = do
name <- C.indented *> C.parseIdent
C.lexeme $ C.indented *> P.char '='
value <- parseValue
+ C.indented *> C.semi
return $ VariableIntroduction name value
parseAssignment :: P.Parsec String ParseState Statement
parseAssignment = do
- tgt <- C.parseIdent
- C.lexeme $ C.indented *> P.char '='
+ tgt <- P.try $ do
+ tgt <- C.parseIdent
+ C.lexeme $ C.indented *> P.char '='
+ return tgt
value <- parseValue
+ C.indented *> C.semi
return $ Assignment tgt value
parseWhile :: P.Parsec String ParseState Statement
-parseWhile = While <$> (C.reserved "while" *> C.indented *> parseValue <* C.indented <* C.colon)
- <*> parseManyStatements
+parseWhile = While <$> (C.reserved "while" *> C.indented *> C.parens parseValue)
+ <*> (C.indented *> parseManyStatements)
parseFor :: P.Parsec String ParseState Statement
-parseFor = For <$> (C.reserved "for" *> C.indented *> C.parseIdent)
+parseFor = For <$> (C.reserved "for" *> C.indented *> C.lexeme (P.char '(') *> C.indented *> C.parseIdent)
<*> (C.indented *> C.lexeme (P.string "<-") *> parseValue)
- <*> (C.indented *> C.reserved "until" *> parseValue <* C.indented <* C.colon)
+ <*> (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.parseIdent)
- <*> (C.indented *> C.reserved "in" *> parseValue <* C.indented <* C.colon)
+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
@@ -172,26 +181,30 @@ parseIf = If <$> parseIfStatement
parseIfStatement :: P.Parsec String ParseState IfStatement
parseIfStatement =
- IfStatement <$> (C.reserved "if" *> C.indented *> parseValue <* C.indented <* C.colon)
+ IfStatement <$> (C.reserved "if" *> C.indented *> C.parens parseValue)
<*> parseManyStatements
- <*> P.optionMaybe (C.same *> parseElseStatement)
+ <*> P.optionMaybe parseElseStatement
parseElseStatement :: P.Parsec String ParseState ElseStatement
-parseElseStatement = C.reserved "else" >> (ElseIf <$> (C.indented *> parseIfStatement)
- <|> Else <$> (C.indented *> C.colon *> parseManyStatements))
+parseElseStatement = C.reserved "else" >> (ElseIf <$> parseIfStatement
+ <|> Else <$> parseManyStatements)
+
+parseValueStatement :: P.Parsec String ParseState Statement
+parseValueStatement = ValueStatement <$> (parseValue <* C.semi)
parseReturn :: P.Parsec String ParseState Statement
-parseReturn = Return <$> (C.reserved "return" *> parseValue)
+parseReturn = Return <$> (C.reserved "return" *> parseValue <* C.indented <* C.semi)
parseStatement :: P.Parsec String ParseState Statement
-parseStatement = P.choice (map P.try
+parseStatement = P.choice
[ parseVariableIntroduction
, parseAssignment
, parseWhile
, parseFor
, parseForEach
, parseIf
- , parseReturn ]) P.<?> "statement"
+ , parseValueStatement
+ , parseReturn ] P.<?> "statement"
parseStringBinder :: P.Parsec String ParseState Binder
parseStringBinder = StringBinder <$> C.stringLiteral
@@ -216,7 +229,6 @@ parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseId
parseArrayBinder :: P.Parsec String ParseState Binder
parseArrayBinder = C.squares $ ArrayBinder <$> (C.commaSep (C.indented *> parseBinder))
- <*> P.optionMaybe (C.indented *> C.colon *> C.indented *> parseBinder)
parseNamedBinder :: P.Parsec String ParseState Binder
parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))
@@ -232,8 +244,8 @@ parseIdentifierAndBinder = do
binder <- C.indented *> parseBinder
return (name, binder)
-parseBinder :: P.Parsec String ParseState Binder
-parseBinder = P.choice (map P.try
+parseBinderAtom :: P.Parsec String ParseState Binder
+parseBinderAtom = P.choice (map P.try
[ parseNullBinder
, parseStringBinder
, parseBooleanBinder
@@ -246,5 +258,11 @@ parseBinder = P.choice (map P.try
, parseArrayBinder
, C.parens parseBinder ]) P.<?> "binder"
+parseBinder :: P.Parsec String ParseState Binder
+parseBinder = (buildExpressionParser operators parseBinderAtom) P.<?> "expression"
+ 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))
+
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 07065d4..de6b030 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -143,19 +143,38 @@ prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue (
, [ binary Or "||" ]
]
+prettyPrintBinderAtom :: Pattern () Binder String
+prettyPrintBinderAtom = mkPattern match
+ where
+ match :: Binder -> Maybe String
+ match NullBinder = Just "_"
+ match (StringBinder str) = Just $ show str
+ match (NumberBinder num) = Just $ either show show num
+ match (BooleanBinder True) = Just "true"
+ match (BooleanBinder False) = Just "false"
+ match (VarBinder ident) = Just $ show ident
+ match (NullaryBinder ctor) = Just $ show ctor
+ match (UnaryBinder ctor b) = Just $ show ctor ++ " " ++ prettyPrintBinder b
+ 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
-prettyPrintBinder NullBinder = "_"
-prettyPrintBinder (StringBinder str) = show str
-prettyPrintBinder (NumberBinder num) = either show show num
-prettyPrintBinder (BooleanBinder True) = "true"
-prettyPrintBinder (BooleanBinder False) = "false"
-prettyPrintBinder (VarBinder ident) = show ident
-prettyPrintBinder (NullaryBinder ctor) = show ctor
-prettyPrintBinder (UnaryBinder ctor b) = show ctor ++ " " ++ prettyPrintBinder b
-prettyPrintBinder (ObjectBinder bs) = "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"
-prettyPrintBinder (ArrayBinder bs rest) = "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ maybe "" (("; " ++) . prettyPrintBinder) rest ++ " ]"
-prettyPrintBinder (NamedBinder ident binder) = show ident ++ "@" ++ prettyPrintBinder binder
-prettyPrintBinder (GuardedBinder cond binder) = prettyPrintBinder binder ++ " | " ++ prettyPrintValue cond
+prettyPrintBinder = fromMaybe (error "Incomplete pattern") . pattern matchBinder ()
+ where
+ matchBinder :: Pattern () Binder String
+ matchBinder = buildPrettyPrinter operators (prettyPrintBinderAtom <+> fmap parens matchBinder)
+ operators :: OperatorTable () Binder String
+ operators =
+ OperatorTable [ [ AssocR matchConsBinder (\b1 b2 -> b1 ++ " : " ++ b2) ] ]
+
+matchConsBinder :: Pattern () Binder (Binder, Binder)
+matchConsBinder = mkPattern match'
+ where
+ match' (ConsBinder b1 b2) = Just (b1, b2)
+ match' _ = Nothing
prettyPrintObjectPropertyBinder :: String -> Binder -> String
prettyPrintObjectPropertyBinder key binder = key ++ ": " ++ prettyPrintBinder binder
@@ -175,6 +194,7 @@ 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
prettyPrintIfStatement :: IfStatement -> String
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 0ab8170..15f1cad 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -469,15 +469,17 @@ inferBinder val (ObjectBinder props) = do
m1 <- inferBinder propTy binder
m2 <- inferRowProperties nrow (RCons name propTy row) binders
return $ m1 `M.union` m2
-inferBinder val (ArrayBinder binders rest) = do
+inferBinder val (ArrayBinder binders) = do
el <- fresh
m1 <- M.unions <$> mapM (inferBinder el) binders
val ~~ Array el
- case rest of
- Nothing -> return m1
- Just binder -> do
- m2 <- inferBinder val binder
- return $ m1 `M.union` m2
+ return m1
+inferBinder val (ConsBinder headBinder tailBinder) = do
+ el <- fresh
+ m1 <- inferBinder el headBinder
+ m2 <- inferBinder val tailBinder
+ val ~~ Array el
+ return $ m1 `M.union` m2
inferBinder val (NamedBinder name binder) = do
m <- inferBinder val binder
return $ M.insert name val m
@@ -536,6 +538,9 @@ checkStatement mass ret (ForEach ident vals inner) = do
(allCodePathsReturn, _) <- bindLocalVariables [(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)
checkStatement mass ret (Return val) = do
check val ret
return (True, mass)
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index fd8d31b..8028109 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -68,3 +68,6 @@ isPolyType _ = True
mkForAll :: [String] -> Type -> Type
mkForAll = flip . foldl . flip $ ForAll
+
+unit :: Type
+unit = Object REmpty
diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs
index 402ec1b..108b733 100644
--- a/src/Language/PureScript/Values.hs
+++ b/src/Language/PureScript/Values.hs
@@ -77,6 +77,7 @@ data Statement
| For Ident Value Value [Statement]
| ForEach Ident Value [Statement]
| If IfStatement
+ | ValueStatement Value
| Return Value deriving (Show, Data, Typeable)
data IfStatement = IfStatement Value [Statement] (Maybe ElseStatement) deriving (Show, Data, Typeable)
@@ -94,6 +95,7 @@ data Binder
| NullaryBinder (Qualified ProperName)
| UnaryBinder (Qualified ProperName) Binder
| ObjectBinder [(String, Binder)]
- | ArrayBinder [Binder] (Maybe Binder)
+ | ArrayBinder [Binder]
+ | ConsBinder Binder Binder
| NamedBinder Ident Binder
| GuardedBinder Value Binder deriving (Show, Data, Typeable)