diff options
author | PhilFreeman <> | 2013-12-23 02:58:00 (GMT) |
---|---|---|
committer | hdiff <hdiff@hdiff.luite.com> | 2013-12-23 02:58:00 (GMT) |
commit | ffeeca8afd412c527d80ce9b6d65299d859d34d0 (patch) | |
tree | 68c466b68c51819dcb7b963d21cb781c952cf1d7 | |
parent | 85a7deed23509180aaa3389b5ce1de7f238fcc69 (diff) |
version 0.2.00.2.0
-rw-r--r-- | purescript.cabal | 2 | ||||
-rw-r--r-- | src/Language/PureScript/CodeGen/JS.hs | 31 | ||||
-rw-r--r-- | src/Language/PureScript/Parser/Common.hs | 6 | ||||
-rw-r--r-- | src/Language/PureScript/Parser/Values.hs | 64 | ||||
-rw-r--r-- | src/Language/PureScript/Pretty/Values.hs | 44 | ||||
-rw-r--r-- | src/Language/PureScript/TypeChecker/Types.hs | 17 | ||||
-rw-r--r-- | src/Language/PureScript/Types.hs | 3 | ||||
-rw-r--r-- | src/Language/PureScript/Values.hs | 4 |
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) |