diff --git a/Language/Javascript/JMacro.hs b/Language/Javascript/JMacro.hs --- a/Language/Javascript/JMacro.hs +++ b/Language/Javascript/JMacro.hs @@ -60,6 +60,8 @@ Other than that, the language is essentially Javascript (1.5). Note however that one must use semicolons in a principled fashion -- i.e. to end statements consistently. Otherwise, the parser will mistake the whitespace for a whitespace application, and odd things will occur. A further gotcha exists in regex literals, whicch cannot begin with a space. @x / 5 / 4@ parses as ((x / 5) / 4). However, @x /5 / 4@ will parse as x(/5 /, 4). Such are the perils of operators used as delimeters in the presence of whitespace application. +Additional features in jmacro (documented on the wiki) include an infix application operator, and an enhanced destructuring bind. + Additional datatypes can be marshalled to Javascript by proper instance declarations for the ToJExpr class. An experimental typechecker is available in the "Language.Javascript.JMacro.Typed" module. @@ -73,7 +75,9 @@ module Language.Javascript.JMacro.Types ) where +{- import Prelude hiding (tail, init, head, last, minimum, maximum, foldr1, foldl1, (!!), read) +-} import Language.Javascript.JMacro.Base hiding (expr2stat) import Language.Javascript.JMacro.QQ diff --git a/Language/Javascript/JMacro/Base.hs b/Language/Javascript/JMacro/Base.hs --- a/Language/Javascript/JMacro/Base.hs +++ b/Language/Javascript/JMacro/Base.hs @@ -109,7 +109,7 @@ | TryStat JStat Ident JStat JStat | BlockStat [JStat] | ApplStat JExpr [JExpr] - | PostStat String JExpr + | PPostStat Bool String JExpr | AssignStat JExpr JExpr | UnsatBlock (IdentSupply JStat) | AntiStat String @@ -132,7 +132,7 @@ | SelExpr JExpr Ident | IdxExpr JExpr JExpr | InfixExpr String JExpr JExpr - | PostExpr String JExpr + | PPostExpr Bool String JExpr | IfExpr JExpr JExpr JExpr | NewExpr JExpr | ApplExpr JExpr [JExpr] @@ -167,7 +167,7 @@ expr2stat :: JExpr -> JStat expr2stat (ApplExpr x y) = (ApplStat x y) expr2stat (IfExpr x y z) = IfStat x (expr2stat y) (expr2stat z) -expr2stat (PostExpr s x) = PostStat s x +expr2stat (PPostExpr b s x) = PPostStat b s x expr2stat (AntiExpr x) = AntiStat x expr2stat _ = nullStat @@ -245,7 +245,7 @@ BlockStat xs -> ret BlockStat `app` mapM' f xs ApplStat e xs -> ret ApplStat `app` f e `app` mapM' f xs TryStat s i s1 s2 -> ret TryStat `app` f s `app` f i `app` f s1 `app` f s2 - PostStat o e -> ret (PostStat o) `app` f e + PPostStat b o e -> ret (PPostStat b o) `app` f e AssignStat e e' -> ret AssignStat `app` f e `app` f e' UnsatBlock _ -> ret v' AntiStat _ -> ret v' @@ -256,7 +256,7 @@ SelExpr e e' -> ret SelExpr `app` f e `app` f e' IdxExpr e e' -> ret IdxExpr `app` f e `app` f e' InfixExpr o e e' -> ret (InfixExpr o) `app` f e `app` f e' - PostExpr o e -> ret (PostExpr o) `app` f e + PPostExpr b o e -> ret (PPostExpr b o) `app` f e IfExpr e e' e'' -> ret IfExpr `app` f e `app` f e' `app` f e'' NewExpr e -> ret NewExpr `app` f e ApplExpr e xs -> ret ApplExpr `app` f e `app` mapM' f xs @@ -469,7 +469,9 @@ mbFinally | s2 == BlockStat [] = PP.empty | otherwise = text "finally" $$ braceNest' (jsToDoc s2) jsToDoc (AssignStat i x) = jsToDoc i <+> char '=' <+> jsToDoc x - jsToDoc (PostStat op x) = jsToDoc x <> text op + jsToDoc (PPostStat isPre op x) + | isPre = text op <> jsToDoc x + | otherwise = jsToDoc x <> text op jsToDoc (AntiStat s) = text $ "`(" ++ s ++ ")`" jsToDoc (ForeignStat i t) = text "//foriegn" <+> jsToDoc i <+> text "::" <+> jsToDoc t jsToDoc (BlockStat xs) = jsToDoc (flattenBlocks xs) @@ -486,7 +488,10 @@ where op' | op == "++" = "+" | otherwise = op - jsToDoc (PostExpr op x) = jsToDoc x <> text op + jsToDoc (PPostExpr isPre op x) + | isPre = text op <> jsToDoc x + | otherwise = jsToDoc x <> text op + jsToDoc (ApplExpr je xs) = jsToDoc je <> (parens . fsep . punctuate comma $ map jsToDoc xs) jsToDoc (NewExpr e) = text "new" <+> jsToDoc e jsToDoc (AntiExpr s) = text $ "`(" ++ s ++ ")`" @@ -680,7 +685,7 @@ -- | Create a for in statement. -- Usage: -- @jForIn {expression} $ \x -> {block involving x}@ -jForIn :: ToSat a => JExpr -> (JExpr -> a) -> JStat +jForIn :: ToSat a => JExpr -> (JExpr -> a) -> JStat jForIn e f = UnsatBlock . IS $ do (block, is) <- runIdentSupply $ toSat_ f [] return $ ForInStat False (headNote "jForIn" is) e block diff --git a/Language/Javascript/JMacro/QQ.hs b/Language/Javascript/JMacro/QQ.hs --- a/Language/Javascript/JMacro/QQ.hs +++ b/Language/Javascript/JMacro/QQ.hs @@ -15,17 +15,20 @@ module Language.Javascript.JMacro.QQ(jmacro,jmacroE,parseJM) where import Prelude hiding (tail, init, head, last, minimum, maximum, foldr1, foldl1, (!!), read) import Control.Applicative hiding ((<|>),many,optional,(<*)) +import Control.Arrow(first) import Control.Monad.State.Strict import qualified Data.ByteString.Char8 as BS import Data.Char(digitToInt, toLower, isUpper) import Data.List(isPrefixOf, sort) import Data.Generics(extQ,Data) +import Data.Maybe(fromMaybe) +import Data.Monoid import qualified Data.Map as M --import Language.Haskell.Meta.Parse import qualified Language.Haskell.TH as TH import Language.Haskell.TH(mkName) -import qualified Language.Haskell.TH.Lib as TH +--import qualified Language.Haskell.TH.Lib as TH import Language.Haskell.TH.Quote import Text.ParserCombinators.Parsec @@ -42,7 +45,7 @@ import Web.Encodings -import Debug.Trace +--import Debug.Trace {-------------------------------------------------------------------- QuasiQuotation @@ -100,7 +103,7 @@ antiIdents :: JMacro a => [String] -> a -> a antiIdents ss x = foldr antiIdent x ss - +fixIdent :: String -> String fixIdent css@(c:_) | isUpper c = '_' : escapeDollar css | otherwise = escapeDollar css @@ -228,7 +231,7 @@ jsLang :: P.LanguageDef () jsLang = javaStyle { P.reservedNames = ["var","return","if","else","while","for","in","break","new","function","switch","case","default","fun","try","catch","finally","foreign"], - P.reservedOpNames = ["|>","<|","+=","-=","*=","/=","%=","--","*","/","+","-",".","%","?","=","==","!=","<",">","&&","||","++","===",">=","<=","->","::","::!"], + P.reservedOpNames = ["|>","<|","+=","-=","*=","/=","%=","--","*","/","+","-",".","%","?","=","==","!=","<",">","&&","||","++","===",">=","<=","->","::","::!",":|","@"], P.identLetter = alphaNum <|> oneOf "_$", P.identStart = letter <|> oneOf "_$", P.commentLine = "//", @@ -257,7 +260,7 @@ (<*) :: Monad m => m b -> m a -> m b x <* y = do xr <- x - y + _ <- y return xr parseJM :: String -> Either ParseError JStat @@ -274,20 +277,13 @@ eof return ans -{- -ident :: JMParser Ident -ident = do - i <- identifier - when ("jmId_" `isPrefixOf` i) $ fail "Illegal use of reserved jmId_ prefix in variable name." - return (StrI i) --} - - +getType :: JMParser (Bool, JLocalType) getType = do isForce <- (reservedOp "::!" >> return True) <|> (reservedOp "::" >> return False) t <- runTypeParser return (isForce, t) +addForcedType :: Maybe (Bool, JLocalType) -> JExpr -> JExpr addForcedType (Just (True,t)) e = TypeExpr True e t addForcedType _ e = e @@ -308,18 +304,65 @@ when (i=="this") $ fail "Illegal attempt to name variable 'this'." return (StrI i) ---varidentdecls can take types! -identAssignDecl :: JMParser [JStat] -identAssignDecl = do - (i,mbTyp) <- varidentdecl - optAssignStat <- optionMaybe $ do - reservedOp "=" - e <- expr - return $ AssignStat (ValExpr (JVar (clean i))) (addForcedType mbTyp e) - return $ DeclStat i (fmap snd mbTyp) : maybe [] (:[]) optAssignStat - where clean (StrI ('!':x)) = StrI x - clean x = x +cleanIdent :: Ident -> Ident +cleanIdent (StrI ('!':x)) = StrI x +cleanIdent x = x +-- Handle varident decls for type annotations? +-- Patterns +data PatternTree = PTAs Ident PatternTree + | PTCons PatternTree PatternTree + | PTList [PatternTree] + | PTObj [(String,PatternTree)] + | PTVar Ident + deriving Show +patternTree :: JMParser PatternTree +patternTree = toCons <$> (parens patternTree <|> ptList <|> ptObj <|> varOrAs) `sepBy1` reservedOp ":|" + where + toCons [] = PTVar (StrI "_") + toCons [x] = x + toCons (x:xs) = PTCons x (toCons xs) + ptList = lexeme $ PTList <$> brackets' (commaSep patternTree) + ptObj = lexeme $ PTObj <$> oxfordBraces (commaSep $ liftM2 (,) myIdent (colon >> patternTree)) + varOrAs = do + i <- fst <$> varidentdecl + isAs <- option False (reservedOp "@" >> return True) + if isAs + then PTAs i <$> patternTree + else return $ PTVar i + +--either we have a function from any ident to the constituent parts +--OR the top level is named, and hence we have the top ident, plus decls for the constituent parts +patternBinding :: JMParser (Either (Ident -> [JStat]) (Ident,[JStat])) +patternBinding = do + ptree <- patternTree + let go path (PTAs asIdent pt) = [DeclStat asIdent Nothing, AssignStat (ValExpr (JVar (cleanIdent asIdent))) path] ++ go path pt + go path (PTVar i) + | i == (StrI "_") = [] + | otherwise = [DeclStat i Nothing, AssignStat (ValExpr (JVar (cleanIdent i))) (path)] + go path (PTList pts) = concatMap (uncurry go) $ zip (map addIntToPath [0..]) pts + where addIntToPath i = IdxExpr path (ValExpr $ JInt i) + go path (PTObj xs) = concatMap (uncurry go) $ map (first fixPath) xs + where fixPath lbl = IdxExpr path (ValExpr $ JStr lbl) + go path (PTCons x xs) = concat [go (IdxExpr path (ValExpr $ JInt 0)) x, + go (ApplExpr (SelExpr path (StrI "slice")) [ValExpr $ JInt 1]) xs] + case ptree of + PTVar i -> return $ Right (i,[]) + PTAs i pt -> return $ Right (i, go (ValExpr $ JVar i) pt) + _ -> return $ Left $ \i -> go (ValExpr $ JVar i) ptree + +patternBlocks :: JMParser ([Ident],[JStat]) +patternBlocks = fmap concat . unzip . zipWith (\i efr -> either (\f -> (i, f i)) id efr) (map (StrI . ("jmId_match_" ++) . show) [(1::Int)..]) <$> many patternBinding + +destructuringDecl = do + (i,patDecls) <- either (\f -> (matchVar, f matchVar)) id <$> patternBinding + optAssignStat <- optionMaybe $ do + reservedOp "=" + e <- expr + return $ AssignStat (ValExpr (JVar (cleanIdent i))) e : patDecls + return $ DeclStat i Nothing : fromMaybe [] optAssignStat + where matchVar = StrI "jmId_match_var" + statblock :: JMParser [JStat] statblock = concat <$> (sepEndBy1 (whiteSpace >> statement) (semi <|> return "")) @@ -354,7 +397,7 @@ where declStat = do reserved "var" - res <- concat <$> commaSep1 identAssignDecl + res <- concat <$> commaSep1 destructuringDecl _ <- semi return res @@ -362,22 +405,21 @@ reserved "function" (i,mbTyp) <- varidentdecl - as <- parens (commaSep identdecl) <|> many1 identdecl - b <- try (ReturnStat <$> braces expr) <|> (l2s <$> statement) + (as,patDecls) <- fmap (\x -> (x,[])) (try $ parens (commaSep identdecl)) <|> patternBlocks + b' <- try (ReturnStat <$> braces expr) <|> (l2s <$> statement) + let b = BlockStat patDecls `mappend` b' return $ [DeclStat i (fmap snd mbTyp), - AssignStat (ValExpr $ JVar (clean i)) (addForcedType mbTyp $ ValExpr $ JFunc as b)] - where clean (StrI ('!':x)) = StrI x - clean x = x + AssignStat (ValExpr $ JVar (cleanIdent i)) (addForcedType mbTyp $ ValExpr $ JFunc as b)] funDecl = do reserved "fun" n <- identdecl mbTyp <- optionMaybe getType - as <- many identdecl - b <- try (ReturnStat <$> braces expr) <|> (l2s <$> statement) <|> (symbol "->" >> ReturnStat <$> expr) + (as, patDecls) <- patternBlocks + b' <- try (ReturnStat <$> braces expr) <|> (l2s <$> statement) <|> (symbol "->" >> ReturnStat <$> expr) + let b = BlockStat patDecls `mappend` b' return $ [DeclStat (addBang n) (fmap snd mbTyp), AssignStat (ValExpr $ JVar n) (addForcedType mbTyp $ ValExpr $ JFunc as b)] - where addBang (StrI x) = StrI ('!':'!':x) foreignStat = do @@ -529,16 +571,22 @@ addIf ans <|> return ans rawExpr = buildExpressionParser table dotExpr "expression" table = [[iop "*", iop "/", iop "%"], + [pop "++", pop "--"], [iop "++", iop "+", iop "-", iop "--"], + [consOp], [iope "==", iope "!=", iope "<", iope ">", iope ">=", iope "<=", iope "==="], [iop "&&", iop "||"], [applOp, applOpRev] ] + pop s = Prefix (reservedOp s >> return (PPostExpr True s)) iop s = Infix (reservedOp s >> return (InfixExpr s)) AssocLeft iope s = Infix (reservedOp s >> return (InfixExpr s)) AssocNone applOp = Infix (reservedOp "<|" >> return (\x y -> ApplExpr x [y])) AssocRight applOpRev = Infix (reservedOp "|>" >> return (\x y -> ApplExpr y [x])) AssocLeft + consOp = Infix (reservedOp ":|" >> return consAct) AssocRight + consAct x y = ApplExpr (ValExpr (JFunc [StrI "x",StrI "y"] (BlockStat [BlockStat [DeclStat (StrI "tmp") Nothing, AssignStat tmpVar (ApplExpr (SelExpr (ValExpr (JVar (StrI "x"))) (StrI "slice")) [ValExpr (JInt 0)]),ApplStat (SelExpr tmpVar (StrI "unshift")) [ValExpr (JVar (StrI "y"))],ReturnStat tmpVar]]))) [x,y] + where tmpVar = ValExpr (JVar (StrI "tmp")) dotExpr :: JMParser JExpr dotExpr = do @@ -556,9 +604,9 @@ case nxt of Just '.' -> addNxt =<< (dot >> (SelExpr e <$> (ident' <|> numIdent))) Just '[' -> addNxt =<< (IdxExpr e <$> brackets' expr) - Just '(' -> addNxt =<< (ApplExpr e <$> args') - Just '-' -> try (reservedOp "--" >> return (PostExpr "--" e)) <|> return e - Just '+' -> try (reservedOp "++" >> return (PostExpr "++" e)) <|> return e + Just '(' -> addNxt =<< (ApplExpr e <$> parens' (commaSep expr)) + Just '-' -> try (reservedOp "--" >> return (PPostExpr False "--" e)) <|> return e + Just '+' -> try (reservedOp "++" >> return (PPostExpr False "++" e)) <|> return e _ -> return e numIdent = StrI <$> many1 digit @@ -588,23 +636,22 @@ var = JVar <$> ident' func = do (symbol "\\" >> return ()) <|> reserved "function" - liftM2 JFunc (parens (commaSep identdecl) <|> many identdecl) - (braces' statOrEblock <|> - (symbol "->" >> (ReturnStat <$> expr))) + (as,patDecls) <- fmap (\x -> (x,[])) (try $ parens (commaSep identdecl)) <|> patternBlocks + b' <- (braces' statOrEblock <|> (symbol "->" >> (ReturnStat <$> expr))) + return $ JFunc as (BlockStat patDecls `mappend` b') statOrEblock = try (ReturnStat <$> expr `folBy` '}') <|> (l2s <$> statblock) propPair = liftM2 (,) myIdent (colon >> expr) --notFolBy a b = a <* notFollowedBy (char b) +folBy :: JMParser a -> Char -> JMParser a folBy a b = a <* (lookAhead (char b) >>= const (return ())) -args' :: JMParser [JExpr] -args' = parens' $ commaSep expr --Parsers without Lexeme - -braces', brackets', parens' :: JMParser a -> JMParser a +braces', brackets', parens', oxfordBraces :: JMParser a -> JMParser a brackets' = around' '[' ']' braces' = around' '{' '}' parens' = around' '(' ')' +oxfordBraces x = lexeme (reservedOp "{|") >> (lexeme x <* reservedOp "|}") around' :: Char -> Char -> JMParser a -> JMParser a around' a b x = lexeme (char a) >> (lexeme x <* char b) diff --git a/Language/Javascript/JMacro/TypeCheck.hs b/Language/Javascript/JMacro/TypeCheck.hs --- a/Language/Javascript/JMacro/TypeCheck.hs +++ b/Language/Javascript/JMacro/TypeCheck.hs @@ -806,7 +806,7 @@ typecheck e <<:> return t typecheck e1 <<:> return t - typecheck (PostExpr _ e) = case e of + typecheck (PPostExpr _ _ e) = case e of (SelExpr _ _) -> go (ValExpr (JVar _)) -> go (IdxExpr _ _) -> go @@ -903,7 +903,7 @@ stripStat (t:ts) = t : stripStat ts stripStat t = t typecheck (ApplStat args body) = typecheck (ApplExpr args body) >> return JTStat - typecheck (PostStat s e) = typecheck (PostExpr s e) >> return JTStat + typecheck (PPostStat b s e) = typecheck (PPostExpr b s e) >> return JTStat typecheck (AssignStat e e1) = do typecheck e1 <<:> typecheck e return JTStat diff --git a/jmacro.cabal b/jmacro.cabal --- a/jmacro.cabal +++ b/jmacro.cabal @@ -1,7 +1,7 @@ name: jmacro -version: 0.5.1 +version: 0.5.2 synopsis: QuasiQuotation library for programmatic generation of Javascript code. -description: Javascript syntax, functional syntax, hygienic names, compile-time guarantees of syntactic correctness, limited typechecking. +description: Javascript syntax, functional syntax, hygienic names, compile-time guarantees of syntactic correctness, limited typechecking. Additional documentation available at category: Language license: BSD3 license-file: LICENSE