diff --git a/purescript.cabal b/purescript.cabal --- 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 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -128,23 +128,27 @@ 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 @@ 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 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -74,7 +74,7 @@ builtInOperators :: [String] builtInOperators = [ "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>" - , "==", "!=", "&&", "||", "&", "^", "|", "!!", "!" ] + , "==", "!=", "&&", "||", "&", "^", "|", "!!", "!", "." ] reservedOpNames :: [String] reservedOpNames = builtInOperators ++ [ "->" ] @@ -89,10 +89,10 @@ 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 --- a/src/Language/PureScript/Parser/Values.hs +++ b/src/Language/PureScript/Parser/Values.hs @@ -86,18 +86,23 @@ <*> (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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ , 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 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -143,20 +143,39 @@ , [ 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 @@ ++ " 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 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -469,15 +469,17 @@ 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 @@ -535,6 +537,9 @@ check vals (Array val) (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 diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -68,3 +68,6 @@ 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 --- a/src/Language/PureScript/Values.hs +++ b/src/Language/PureScript/Values.hs @@ -77,6 +77,7 @@ | 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 @@ | 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)