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 @@ -19,17 +19,19 @@ JMacro(..), MultiComp(..), Compos(..), composOp, composOpM, composOpM_, composOpFold, -- * Hygienic transformation - withHygiene, + withHygiene, scopify, -- * Display/Output renderJs, JsToDoc(..), -- * Ad-hoc data marshalling ToJExpr(..), + -- * Literals + jsv, -- * Occasionally helpful combinators - jLam, jVar, jFor, jForIn, jForEachIn, + jLam, jVar, jFor, jForIn, jForEachIn, jTryCatchFinally, expr2stat, ToStat(..), nullStat, -- * Hash combinators jhEmpty, jhSingle, jhAdd, jhFromList, - -- * utility + -- * Utility jsSaturate ) where import Prelude hiding (tail, init, head, last, minimum, maximum, foldr1, foldl1, (!!), read) @@ -41,6 +43,7 @@ import Safe import Control.Monad.Identity import Data.Generics +import Data.Monoid {-------------------------------------------------------------------- ADTs @@ -59,6 +62,7 @@ | WhileStat JExpr JStat | ForInStat Bool Ident JExpr JStat | SwitchStat JExpr [(JExpr, JStat)] JStat + | TryStat JStat Ident JStat JStat | BlockStat [JStat] | ApplStat JExpr [JExpr] | PostStat String JExpr @@ -68,6 +72,13 @@ | BreakStat deriving (Eq, Ord, Show, Data, Typeable) +instance Monoid JStat where + mempty = BlockStat [] + mappend (BlockStat xs) (BlockStat ys) = BlockStat $ xs ++ ys + mappend (BlockStat xs) ys = BlockStat $ xs ++ [ys] + mappend xs (BlockStat ys) = BlockStat $ xs : ys + mappend xs ys = BlockStat [xs,ys] + -- | Expressions data JExpr = ValExpr JVal | SelExpr JExpr Ident @@ -181,6 +192,7 @@ where l' = mapM' (\(c,s) -> ret (,) `app` f c `app` f s) l 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 AssignStat e e' -> ret AssignStat `app` f e `app` f e' UnsatBlock _ -> ret v' @@ -278,9 +290,9 @@ jsSaturate_ :: (JMacro a) => a -> State [Ident] a jsSaturate_ e = fromMC <$> go (toMC e) where go v = case v of - MStat (UnsatBlock us) -> composOpM go =<< (MStat <$> us) - MExpr (UnsatExpr us) -> composOpM go =<< (MExpr <$> us) - MVal (UnsatVal us) -> composOpM go =<< (MVal <$> us) + MStat (UnsatBlock us) -> go =<< (MStat <$> us) + MExpr (UnsatExpr us) -> go =<< (MExpr <$> us) + MVal (UnsatVal us) -> go =<< (MVal <$> us) _ -> composOpM go v {-------------------------------------------------------------------- @@ -289,7 +301,7 @@ --doesn't apply to unsaturated bits jsReplace_ :: JMacro a => [(Ident, Ident)] -> a -> a -jsReplace_ xs e = fromMC $ composOp go (toMC e) +jsReplace_ xs e = fromMC $ go (toMC e) where go v = case v of MIdent i -> maybe v MIdent (M.lookup i mp) _ -> composOp go v @@ -305,7 +317,7 @@ -- | Apply a transformation to a fully saturated syntax tree, -- taking care to return any free variables back to their free state -- following the transformation. As the transformation preserves --- free variables, it is hygienic. +-- free variables, it is hygienic. Cannot be used nested. withHygiene:: JMacro a => (a -> a) -> a -> a withHygiene f x = fromMC $ case mx of MStat _ -> toMC $ UnsatBlock (coerceMC <$> jsUnsat_ is' x'') @@ -321,11 +333,46 @@ coerceMC :: (JMacro a, JMacro b) => a -> b coerceMC = fromMC . toMC -{- -jsReplace :: JMacro a => [(Ident, Ident)] -> a -> a -jsReplace xs = withHygiene (jsReplace_ xs) --} + + +-- | Takes a fully saturated expression and transforms it to use unique variables that respect scope. +scopify :: JStat -> JStat +scopify x = evalState (fromMC <$> go (toMC x)) (newIdentSupply Nothing) + where go v = case v of + (MStat (BlockStat ss)) -> MStat . BlockStat <$> + blocks ss + where blocks [] = return [] + blocks (DeclStat (StrI i) : xs) = case i of + ('!':'!':i') -> (DeclStat (StrI i'):) <$> blocks xs + ('!':i') -> (DeclStat (StrI i'):) <$> blocks xs + _ -> do + (newI:st) <- get + put st + rest <- blocks xs + return $ [DeclStat newI `mappend` jsReplace_ [(StrI i, newI)] (BlockStat rest)] + blocks (x':xs) = (fromMC <$> go (toMC x')) <:> blocks xs + (<:>) = liftM2 (:) + (MStat (ForInStat b (StrI i) e s)) -> do + (newI:st) <- get + put st + rest <- fromMC <$> go (toMC s) + return $ MStat . ForInStat b newI e $ jsReplace_ [(StrI i, newI)] rest + (MStat (TryStat s (StrI i) s1 s2)) -> do + (newI:st) <- get + put st + t <- fromMC <$> go (toMC s) + c <- fromMC <$> go (toMC s1) + f <- fromMC <$> go (toMC s2) + return . MStat . TryStat t newI (jsReplace_ [(StrI i, newI)] c) $ f + (MExpr (ValExpr (JFunc is s))) -> do + st <- get + let (newIs,newSt) = splitAt (length is) st + put (newSt) + rest <- fromMC <$> go (toMC s) + return . MExpr . ValExpr $ JFunc newIs $ (jsReplace_ $ zip is newIs) rest + _ -> composOpM go v + {-------------------------------------------------------------------- Pretty Printing --------------------------------------------------------------------} @@ -361,6 +408,11 @@ cases = vcat l' jsToDoc (ReturnStat e) = text "return" <+> jsToDoc e jsToDoc (ApplStat e es) = jsToDoc e <> (parens . fsep . punctuate comma $ map jsToDoc es) + jsToDoc (TryStat s i s1 s2) = text "try" $$ braceNest' (jsToDoc s) $$ mbCatch $$ mbFinally + where mbCatch | s1 == BlockStat [] = empty + | otherwise = text "catch" <> parens (jsToDoc i) $$ braceNest' (jsToDoc s1) + mbFinally | s2 == BlockStat [] = 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 (AntiStat s) = text $ "`(" ++ s ++ ")`" @@ -388,7 +440,9 @@ jsToDoc (JInt i) = integer i jsToDoc (JStr s) = text ("\""++s++"\"") jsToDoc (JRegEx s) = text ("/"++s++"/") - jsToDoc (JHash m) = braceNest . fsep . punctuate comma . map (\(x,y) -> quotes (text x) <> colon <+> jsToDoc y) $ M.toList m + jsToDoc (JHash m) + | M.null m = text "{}" + | otherwise = braceNest . fsep . punctuate comma . map (\(x,y) -> quotes (text x) <> colon <+> jsToDoc y) $ M.toList m jsToDoc (JFunc is b) = parens $ text "function" <> parens (fsep . punctuate comma . map jsToDoc $ is) $$ braceNest' (jsToDoc b) jsToDoc (UnsatVal f) = jsToDoc $ sat_ f @@ -523,6 +577,11 @@ jForEachIn e f = UnsatBlock $ do (block, is) <- toSat_ f [] return $ ForInStat True (headNote "jForIn" is) e block + +jTryCatchFinally :: (ToSat a) => JStat -> a -> JStat -> JStat +jTryCatchFinally s f s2 = UnsatBlock $ do + (block, is) <- toSat_ f [] + return $ TryStat s (headNote "jTryCatch" is) block s2 jsv :: String -> JExpr jsv = ValExpr . JVar . StrI diff --git a/Language/Javascript/JMacro/Executable.hs b/Language/Javascript/JMacro/Executable.hs new file mode 100644 --- /dev/null +++ b/Language/Javascript/JMacro/Executable.hs @@ -0,0 +1,32 @@ +module Main where + +import Control.Applicative +import Control.Monad +import Language.Javascript.JMacro +import System.Environment +import System.Console.ParseArgs +import System.IO + +main = do + args <- parseArgsIO ArgsComplete + [Arg "Scope" (Just 's') (Just "scope") Nothing "Enforce block scoping through global variable renames.", + Arg "Help" (Just 'h') (Just "help") Nothing "", + Arg "Infile" Nothing Nothing (argDataOptional "Input file" ArgtypeString) "Input file", + Arg "Outfile" Nothing Nothing (argDataOptional "Output file" ArgtypeString) "Output file"] + when (gotArg args "Help") $ usageError args "Transforms jmacro code into valid javascript." + let s = gotArg args "Scope" + infile <- getArgStdio args "Infile" ReadMode + outfile <- getArgStdio args "Outfile" WriteMode + either (hPrint stderr) (hPrint outfile) . parseIt s =<< hGetContents infile + where + parseIt True = onRight (renderJs . scopify) . parseJM + parseIt False = onRight (renderJs . fixIdent) . parseJM + onRight :: (a -> b) -> Either c a -> Either c b + onRight f (Right x) = Right (f x) + onRight _ (Left x) = (Left x) + + fixIdent x = fromMC $ composOp go (toMC x) :: JStat + where go v = case v of + (MStat (DeclStat (StrI ('!':'!':i')))) -> MStat (DeclStat (StrI i')) + (MStat (DeclStat (StrI ('!':i')))) -> MStat (DeclStat (StrI i')) + _ -> composOp go v 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, TemplateHaskell, QuasiQuotes #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, TypeFamilies, TemplateHaskell, QuasiQuotes #-} ----------------------------------------------------------------------------- {- | @@ -12,13 +12,12 @@ -} ----------------------------------------------------------------------------- -module Language.Javascript.JMacro.QQ(jmacro,jmacroE) where +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((&&&)) import Control.Monad.State.Strict import qualified Data.ByteString.Char8 as BS -import Data.Char(digitToInt, toLower) +import Data.Char(digitToInt, toLower, isUpper) import Data.List(isPrefixOf, sort) import Data.Generics(extQ,Data) import qualified Data.Map as M @@ -32,7 +31,6 @@ import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Expr import Text.ParserCombinators.Parsec.Error -import Text.ParserCombinators.Parsec.Pos import qualified Text.ParserCombinators.Parsec.Token as P import Text.ParserCombinators.Parsec.Language(javaStyle) @@ -42,8 +40,6 @@ -- import Debug.Trace ---compileM _ _ = Right "hack" - {-------------------------------------------------------------------- QuasiQuotation --------------------------------------------------------------------} @@ -62,11 +58,13 @@ Left err -> fail (show err) quoteJMExp :: String -> TH.ExpQ -quoteJMExp s = do - (f,p) <- (TH.loc_filename &&& TH.loc_start) <$> TH.location - case parseJMPos s f p of +quoteJMExp s = case parseJM s of Right x -> jm2th x - Left err -> fail (show err) + Left err -> do + (line,_) <- TH.loc_start <$> TH.location + let pos = errorPos err + let newPos = setSourceLine pos $ line + sourceLine pos - 1 + fail (show $ setErrorPos newPos err) quoteJMPatE :: String -> TH.PatQ quoteJMPatE s = case parseJME s of @@ -74,12 +72,15 @@ Left err -> fail (show err) quoteJMExpE :: String -> TH.ExpQ -quoteJMExpE s = do - (f,p) <- (TH.loc_filename &&& TH.loc_start) <$> TH.location - case parseJMEPos s f p of +quoteJMExpE s = case parseJME s of Right x -> jm2th x - Left err -> fail (show err) + Left err -> do + (line,_) <- TH.loc_start <$> TH.location + let pos = errorPos err + let newPos = setSourceLine pos $ line + sourceLine pos - 1 + fail (show $ setErrorPos newPos err) + -- | Traverse a syntax tree, replace an identifier by an -- antiquotation of a free variable. -- Don't replace identifiers on the right hand side of selector @@ -101,6 +102,7 @@ `extQ` handleStat `extQ` handleExpr `extQ` handleVal + `extQ` handleStr ) v where handleStat :: JStat -> Maybe (TH.ExpQ) @@ -109,16 +111,29 @@ TH.listE (blocks ss) where blocks :: [JStat] -> [TH.ExpQ] blocks [] = [] - blocks (DeclStat (StrI i):xs) = case i of - ('!':i') -> jm2th (DeclStat (StrI i')) : blocks xs + ('!':'!':i') -> jm2th (DeclStat (StrI i')) : blocks xs + ('!':i') -> + [TH.appE (TH.lamE [TH.varP . mkName . fixIdent $ i'] $ + appConstr "BlockStat" + (TH.listE . (ds:) . blocks $ xs)) (TH.appE (TH.varE $ mkName "jsv") + (TH.litE $ TH.StringL i'))] + where ds = TH.appE (TH.conE $ mkName "DeclStat") + (TH.appE (TH.conE $ mkName "StrI") + (TH.litE $ TH.StringL i')) _ -> [TH.appE (TH.varE $ mkName "jVar") - (TH.lamE [TH.varP . mkName $ i] $ + (TH.lamE [TH.varP . mkName . fixIdent $ i] $ appConstr "BlockStat" (TH.listE $ blocks $ map (antiIdent i) xs))] blocks (x:xs) = jm2th x : blocks xs + + + fixIdent css@(c:_) + | isUpper c = '_' : css + | otherwise = css + fixIdent _ = "_" handleStat (ForInStat b (StrI i) e s) = Just $ appFun (TH.varE $ forFunc) [jm2th e, @@ -128,6 +143,17 @@ where forFunc | b = mkName "jForEachIn" | otherwise = mkName "jForIn" + + handleStat (TryStat s (StrI i) s1 s2) + | s1 == BlockStat [] = Nothing + | otherwise = Just $ + appFun (TH.varE $ mkName "jTryCatchFinally") + [jm2th s, + TH.lamE [TH.varP $ mkName i] + (jm2th $ antiIdent i s1), + jm2th s2 + ] + handleStat (AntiStat s) = case parseExp s of Right ans -> Just $ TH.appE (TH.varE (mkName "toStat")) (return ans) @@ -152,6 +178,9 @@ jm2th (M.toList m) handleVal _ = Nothing + handleStr :: String -> Maybe (TH.ExpQ) + handleStr x = Just $ TH.litE $ TH.StringL x + appFun x = foldl (TH.appE) x appConstr n = TH.appE (TH.conE $ mkName n) @@ -172,11 +201,10 @@ lexer = P.makeTokenParser jsLang - jsLang :: P.LanguageDef () jsLang = javaStyle { - P.reservedNames = ["var","return","if","else","while","for","in","break","new","function","switch","case","default","fun"], - P.reservedOpNames = ["--","*","/","+","-",".","?","=","==","!=","<",">","&&","||","++","===",">=","<=","->"], + P.reservedNames = ["var","return","if","else","while","for","in","break","new","function","switch","case","default","fun","try","catch","finally"], + P.reservedOpNames = ["--","*","/","+","-",".","%","?","=","==","!=","<",">","&&","||","++","===",">=","<=","->"], P.identLetter = alphaNum <|> oneOf "_$", P.identStart = letter <|> oneOf "_$", P.commentLine = "//", @@ -208,14 +236,6 @@ y return xr -parseJMPos :: String -> String -> (Int, Int) -> Either ParseError JStat -parseJMPos s f (p1,p2) = BlockStat <$> runParser jmacroParser () "" s - where jmacroParser = do - setPosition $ newPos f p1 p2 - ans <- statblock - eof - return ans - parseJM :: String -> Either ParseError JStat parseJM s = BlockStat <$> runParser jmacroParser () "" s where jmacroParser = do @@ -230,14 +250,6 @@ eof return ans -parseJMEPos :: String -> String -> (Int, Int) -> Either ParseError JExpr -parseJMEPos s f (p1,p2) = runParser jmacroParserE () "" s - where jmacroParserE = do - setPosition $ newPos f p1 p2 - ans <- whiteSpace >> expr - eof - return ans - {- ident :: JMParser Ident ident = do @@ -291,6 +303,7 @@ <|> forStat <|> braces statblock <|> assignStat + <|> tryStat <|> applStat <|> breakStat <|> antiStat @@ -315,7 +328,7 @@ as <- many identdecl b <- try (ReturnStat <$> braces expr) <|> (l2s <$> statement) <|> (symbol "->" >> ReturnStat <$> expr) return $ [DeclStat (addBang n), AssignStat (ValExpr $ JVar n) (ValExpr $ JFunc as b)] - where addBang (StrI x) = StrI ('!':x) + where addBang (StrI x) = StrI ('!':'!':x) returnStat = reserved "return" >> (:[]) . ReturnStat <$> expr @@ -345,8 +358,26 @@ caseStat = reserved "case" >> liftM2 (,) expr (char ':' >> l2s <$> statblock) + tryStat = do + reserved "try" + s <- statement + isCatch <- (lookAhead (reserved "catch") >> return True) + <|> return False + (i,s1) <- if isCatch + then do + reserved "catch" + liftM2 (,) (parens identdecl) statement + else return $ (StrI "", []) + isFinally <- (lookAhead (reserved "finally") >> return True) + <|> return False + s2 <- if isFinally + then reserved "finally" >> statement + else return $ [] + return [TryStat (BlockStat s) i (BlockStat s1) (BlockStat s2)] + + dfltStat = - reserved "default:" >> statblock + reserved "default" >> char ':' >> whiteSpace >> statblock forStat = reserved "for" >> ((reserved "each" >> inBlock True) @@ -426,7 +457,7 @@ expr' = buildExpressionParser table dotExpr "expression" - table = [[iop "*", iop "/"], + table = [[iop "*", iop "/", iop "%"], [iop "+", iop "-"], [iope "==", iope "!=", iope "<", iope ">", iope ">=", iope "<=", iope "==="], @@ -472,7 +503,7 @@ negnum = either (JInt . negate) (JDouble . negate) <$> try (char '-' >> natFloat) str = JStr <$> (myStringLiteral '"' <|> myStringLiteral '\'') regex = do - s <- myRegexLiteral + s <- myStringLiteralNoBr '/' case compileM (BS.pack s) [] of Right _ -> return (JRegEx s) Left err -> fail ("Parse error in regexp: " ++ err) @@ -487,8 +518,7 @@ 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 +--notFolBy a b = a <* notFollowedBy (char b) folBy a b = a <* (lookAhead (char b) >>= const (return ())) args' :: JMParser [JExpr] args' = parens' $ commaSep expr @@ -597,17 +627,16 @@ '\n' -> return "\\n" _ -> return [c] -myRegexLiteral :: JMParser String -myRegexLiteral = do - char '/' `notFolBy` ' ' +myStringLiteralNoBr :: Char -> JMParser String +myStringLiteralNoBr t = do + char t x <- concat <$> many myChar - char '/' + char t return x where myChar = do - c <- noneOf ['/'] + c <- noneOf [t,'\n'] case c of '\\' -> do c2 <- anyChar return [c,c2] - '\n' -> return "\\n" _ -> return [c] diff --git a/Language/Javascript/JMacro/Typed.hs b/Language/Javascript/JMacro/Typed.hs --- a/Language/Javascript/JMacro/Typed.hs +++ b/Language/Javascript/JMacro/Typed.hs @@ -13,15 +13,12 @@ import Data.Function(on) import qualified Data.Map as M import Data.Map(Map) -import Data.Maybe +import Data.Maybe(fromMaybe) import qualified Data.Set as S import Data.Set(Set) import Text.PrettyPrint.HughesPJ import Debug.Trace - ---Type Parser ---primitives for arrays, strings --todo: collect errors --pretty types, bump down variable nums diff --git a/Language/Javascript/JMacro/Util.hs b/Language/Javascript/JMacro/Util.hs --- a/Language/Javascript/JMacro/Util.hs +++ b/Language/Javascript/JMacro/Util.hs @@ -8,7 +8,7 @@ (.) :: JExpr -> String -> JExpr x . y = SelExpr x (StrI y) -(<>) :: ToJExpr a => JExpr -> a -> JExpr +(<>) :: (ToJExpr a) => JExpr -> a -> JExpr x <> y = IdxExpr x (toJExpr y) infixl 2 =: @@ -54,9 +54,6 @@ (ValExpr (JList l)) -> l x' -> [x'] - -jsv :: P.String -> JExpr -jsv = ValExpr P.. JVar P.. StrI jstr :: P.String -> JExpr jstr = ValExpr P.. JStr diff --git a/jmacro.cabal b/jmacro.cabal --- a/jmacro.cabal +++ b/jmacro.cabal @@ -1,7 +1,7 @@ name: jmacro -version: 0.1.2 +version: 0.2 synopsis: QuasiQuotation library for programmatic generation of Javascript code. -description: Javascript syntax, functional syntax, hygeinic names, compile-time guarantees of syntactic correctness, limited typechecking. +description: Javascript syntax, functional syntax, hygienic names, compile-time guarantees of syntactic correctness, limited typechecking. category: Language license: BSD3 license-file: LICENSE @@ -13,8 +13,8 @@ library - build-depends: base >= 4, base < 5, containers, pretty, safe >= 0.2, parsec >= 2.1, pcre-light, - template-haskell >= 2.3, mtl, haskell-src-meta, bytestring >= 0.9, syb + build-depends: base >= 4, base < 5, containers, pretty, safe >= 0.2, parsec >= 2.1, template-haskell >= 2.3, mtl, haskell-src-meta, bytestring >= 0.9, syb, pcre-light + exposed-modules: Language.Javascript.JMacro Language.Javascript.JMacro.Util Language.Javascript.JMacro.Typed @@ -24,6 +24,10 @@ if impl(ghc >= 6.8) ghc-options: -fwarn-tabs +executable jmacro + build-depends: parseargs + main-is: Language/Javascript/JMacro/Executable.hs + source-repository head type: darcs - location: http://patch-tag.com/r/jmacro/pullrepo + location: http://patch-tag.com/r/gershomb/jmacro