jmacro 0.1.2 → 0.2
raw patch · 6 files changed
+193/−75 lines, 6 filesdep +parseargsdep ~sybnew-component:exe:jmacro
Dependencies added: parseargs
Dependency ranges changed: syb
Files
- Language/Javascript/JMacro/Base.hs +72/−13
- Language/Javascript/JMacro/Executable.hs +32/−0
- Language/Javascript/JMacro/QQ.hs +78/−49
- Language/Javascript/JMacro/Typed.hs +1/−4
- Language/Javascript/JMacro/Util.hs +1/−4
- jmacro.cabal +9/−5
Language/Javascript/JMacro/Base.hs view
@@ -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
+ Language/Javascript/JMacro/Executable.hs view
@@ -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
Language/Javascript/JMacro/QQ.hs view
@@ -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]
Language/Javascript/JMacro/Typed.hs view
@@ -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
Language/Javascript/JMacro/Util.hs view
@@ -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
jmacro.cabal view
@@ -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