{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, TypeFamilies, TemplateHaskell, QuasiQuotes, RankNTypes, GADTs #-} ----------------------------------------------------------------------------- {- | Module : Language.Javascript.JMacro Copyright : (c) Gershom Bazerman, 2009 License : BSD 3 Clause Maintainer : gershomb@gmail.com Stability : experimental Simple EDSL for lightweight (untyped) programmatic generation of Javascript. -} ----------------------------------------------------------------------------- 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 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 Language.Haskell.TH.Quote import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Expr import Text.ParserCombinators.Parsec.Error import qualified Text.ParserCombinators.Parsec.Token as P import Text.ParserCombinators.Parsec.Language(javaStyle) import Text.Regex.Posix.String import Language.Javascript.JMacro.Base import Language.Javascript.JMacro.Types import Language.Javascript.JMacro.ParseTH import System.IO.Unsafe import Numeric(readHex) -- import Debug.Trace {-------------------------------------------------------------------- QuasiQuotation --------------------------------------------------------------------} -- | QuasiQuoter for a block of JMacro statements. jmacro :: QuasiQuoter jmacro = QuasiQuoter {quoteExp = quoteJMExp, quotePat = quoteJMPat} -- | QuasiQuoter for a JMacro expression. jmacroE :: QuasiQuoter jmacroE = QuasiQuoter {quoteExp = quoteJMExpE, quotePat = quoteJMPatE} quoteJMPat :: String -> TH.PatQ quoteJMPat s = case parseJM s of Right x -> dataToPatQ (const Nothing) x Left err -> fail (show err) quoteJMExp :: String -> TH.ExpQ quoteJMExp s = case parseJM s of Right x -> jm2th x 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 Right x -> dataToPatQ (const Nothing) x Left err -> fail (show err) quoteJMExpE :: String -> TH.ExpQ quoteJMExpE s = case parseJME s of Right x -> jm2th x 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 -- expressions. antiIdent :: JMacro a => String -> a -> a antiIdent s e = jfromGADT $ go (jtoGADT e) where go :: forall a. JMGadt a -> JMGadt a go (JMGExpr (ValExpr (JVar (StrI s')))) | s == s' = JMGExpr (AntiExpr $ fixIdent s) go (JMGExpr (SelExpr x i)) = JMGExpr (SelExpr (antiIdent s x) i) go x = composOp go x 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 where escapeDollar = map (\x -> if x =='$' then 'dž' else x) fixIdent _ = "_" jm2th :: Data a => a -> TH.ExpQ jm2th v = dataToExpQ (const Nothing `extQ` handleStat `extQ` handleExpr `extQ` handleVal `extQ` handleStr `extQ` handleTyp ) v where handleStat :: JStat -> Maybe (TH.ExpQ) handleStat (BlockStat ss) = Just $ appConstr "BlockStat" $ TH.listE (blocks ss) where blocks :: [JStat] -> [TH.ExpQ] blocks [] = [] blocks (DeclStat (StrI i) t:xs) = case i of ('!':'!':i') -> jm2th (DeclStat (StrI i') t) : 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.appE (TH.conE $ mkName "DeclStat") (TH.appE (TH.conE $ mkName "StrI") (TH.litE $ TH.StringL i'))) (jm2th t) _ -> [TH.appE (TH.appE (TH.varE $ mkName "jVarTy") (TH.lamE [TH.varP . mkName . fixIdent $ i] $ appConstr "BlockStat" (TH.listE $ blocks $ map (antiIdent i) xs))) (jm2th t) ] blocks (x:xs) = jm2th x : blocks xs handleStat (ForInStat b (StrI i) e s) = Just $ appFun (TH.varE $ forFunc) [jm2th e, TH.lamE [TH.varP $ mkName i] (jm2th $ antiIdent i s) ] 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 parseHSExp s of Right ans -> Just $ TH.appE (TH.varE (mkName "toStat")) (return ans) Left err -> Just $ fail err handleStat _ = Nothing handleExpr :: JExpr -> Maybe (TH.ExpQ) handleExpr (AntiExpr s) = case parseHSExp s of Right ans -> Just $ TH.appE (TH.varE (mkName "toJExpr")) (return ans) Left err -> Just $ fail err handleExpr (ValExpr (JFunc is' s)) = Just $ TH.appE (TH.varE $ mkName "jLam") (TH.lamE (map (TH.varP . mkName . fixIdent) is) (jm2th $ antiIdents is s)) where is = map (\(StrI i) -> i) is' handleExpr _ = Nothing handleVal :: JVal -> Maybe (TH.ExpQ) handleVal (JHash m) = Just $ TH.appE (TH.varE $ mkName "jhFromList") $ jm2th (M.toList m) handleVal _ = Nothing handleStr :: String -> Maybe (TH.ExpQ) handleStr x = Just $ TH.litE $ TH.StringL x handleTyp :: JType -> Maybe (TH.ExpQ) handleTyp (JTRecord t mp) = Just $ TH.appE (TH.appE (TH.varE $ mkName "jtFromList") (jm2th t)) (jm2th $ M.toList mp) handleTyp _ = Nothing appFun x = foldl (TH.appE) x appConstr n = TH.appE (TH.conE $ mkName n) {-------------------------------------------------------------------- Parsing --------------------------------------------------------------------} type JMParser a = CharParser () a lexer :: P.TokenParser () symbol :: String -> JMParser String parens, braces :: JMParser a -> JMParser a dot, colon, semi, identifier, identifierWithBang :: JMParser String whiteSpace :: JMParser () reserved, reservedOp :: String -> JMParser () commaSep, commaSep1 :: JMParser a -> JMParser [a] lexer = P.makeTokenParser jsLang jsLang :: P.LanguageDef () jsLang = javaStyle { P.reservedNames = ["var","return","if","else","while","for","in","break","continue","new","function","switch","case","default","fun","try","catch","finally","foreign","do"], P.reservedOpNames = ["|>","<|","+=","-=","*=","/=","%=","<<=", ">>=", ">>>=", "&=", "^=", "|=", "--","*","/","+","-",".","%","?","=","==","!=","<",">","&&","||","&", "^", "|", "++","===","!==", ">=","<=","!", "~", "<<", ">>", ">>>", "->","::","::!",":|","@"], P.identLetter = alphaNum <|> oneOf "_$", P.identStart = letter <|> oneOf "_$", P.commentLine = "//", P.commentStart = "/*", P.commentEnd = "*/"} identifierWithBang = P.identifier $ P.makeTokenParser $ jsLang {P.identStart = letter <|> oneOf "_$!"} whiteSpace= P.whiteSpace lexer symbol = P.symbol lexer parens = P.parens lexer braces = P.braces lexer -- brackets = P.brackets lexer dot = P.dot lexer colon = P.colon lexer semi = P.semi lexer identifier= P.identifier lexer reserved = P.reserved lexer reservedOp= P.reservedOp lexer commaSep1 = P.commaSep1 lexer commaSep = P.commaSep lexer lexeme :: JMParser a -> JMParser a lexeme = P.lexeme lexer (<*) :: Monad m => m b -> m a -> m b x <* y = do xr <- x _ <- y return xr parseJM :: String -> Either ParseError JStat parseJM s = BlockStat <$> runParser jmacroParser () "" s where jmacroParser = do ans <- statblock eof return ans parseJME :: String -> Either ParseError JExpr parseJME s = runParser jmacroParserE () "" s where jmacroParserE = do ans <- whiteSpace >> expr eof return ans 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 --function !foo or function foo or var !x or var x, with optional type varidentdecl :: JMParser (Ident, Maybe (Bool, JLocalType)) varidentdecl = do i <- identifierWithBang when ("jmId_" `isPrefixOf` i || "!jmId_" `isPrefixOf` i) $ fail "Illegal use of reserved jmId_ prefix in variable name." when (i=="this" || i=="!this") $ fail "Illegal attempt to name variable 'this'." t <- optionMaybe getType return (StrI i, t) --any other identifier decl identdecl :: JMParser Ident identdecl = do i <- identifier when ("jmId_" `isPrefixOf` i) $ fail "Illegal use of reserved jmId_ prefix in variable name." when (i=="this") $ fail "Illegal attempt to name variable 'this'." return (StrI i) 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 :: JMParser [JStat] 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 "")) statblock0 :: JMParser [JStat] statblock0 = try statblock <|> (whiteSpace >> return []) l2s :: [JStat] -> JStat l2s xs = BlockStat xs statementOrEmpty :: JMParser [JStat] statementOrEmpty = try emptyStat <|> statement where emptyStat = braces (whiteSpace >> return []) -- return either an expression or a statement statement :: JMParser [JStat] statement = declStat <|> funDecl <|> functionDecl <|> foreignStat <|> returnStat <|> labelStat <|> ifStat <|> whileStat <|> switchStat <|> forStat <|> doWhileStat <|> braces statblock <|> assignOpStat <|> tryStat <|> applStat <|> breakStat <|> continueStat <|> antiStat "statement" where declStat = do reserved "var" res <- concat <$> commaSep1 destructuringDecl _ <- semi return res functionDecl = do reserved "function" (i,mbTyp) <- varidentdecl (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 (cleanIdent i)) (addForcedType mbTyp $ ValExpr $ JFunc as b)] funDecl = do reserved "fun" n <- identdecl mbTyp <- optionMaybe getType (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 reserved "foreign" i <- try $ identdecl <* reservedOp "::" t <- runTypeParser return [ForeignStat i t] returnStat = reserved "return" >> (:[]) . ReturnStat <$> option (ValExpr $ JVar $ StrI "null") expr ifStat = do reserved "if" p <- parens expr b <- l2s <$> statementOrEmpty isElse <- (lookAhead (reserved "else") >> return True) <|> return False if isElse then do reserved "else" return . IfStat p b . l2s <$> statementOrEmpty else return $ [IfStat p b nullStat] whileStat = reserved "while" >> liftM2 (\e b -> [WhileStat False e (l2s b)]) (parens expr) statementOrEmpty doWhileStat = reserved "do" >> liftM2 (\b e -> [WhileStat True e (l2s b)]) statementOrEmpty (reserved "while" *> parens expr) switchStat = do reserved "switch" e <- parens $ expr (l,d) <- braces (liftM2 (,) (many caseStat) (option ([]) dfltStat)) return $ [SwitchStat e l (l2s d)] 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" >> char ':' >> whiteSpace >> statblock forStat = reserved "for" >> ((reserved "each" >> inBlock True) <|> try (inBlock False) <|> simpleForStat) inBlock isEach = do char '(' >> whiteSpace >> optional (reserved "var") i <- identdecl reserved "in" e <- expr char ')' >> whiteSpace s <- l2s <$> statement return $ [ForInStat isEach i e s] simpleForStat = do (before,after,p) <- parens threeStat b <- statement return $ jFor' before after p b where threeStat = liftM3 (,,) (option [] statement <* optional semi) (optionMaybe expr <* semi) (option [] statement) jFor' :: [JStat] -> Maybe JExpr -> [JStat]-> [JStat] -> [JStat] jFor' before p after bs = before ++ [WhileStat False (fromMaybe (jsv "true") p) b'] where b' = BlockStat $ bs ++ after assignOpStat = do let rop x = reservedOp x >> return x (e1,op) <- try $ liftM2 (,) dotExpr (fmap (take 1) $ rop "=" <|> rop "+=" <|> rop "*=" <|> rop "/=" <|> rop "%=" <|> rop "<<=" <|> rop ">>=" <|> rop ">>>=" <|> rop "&=" <|> rop "^=" <|> rop "|=" ) let gofail = fail ("Invalid assignment.") case e1 of ValExpr (JVar (StrI "this")) -> gofail ValExpr (JVar _) -> return () ApplExpr _ _ -> gofail ValExpr _ -> gofail _ -> return () e2 <- expr return [AssignStat e1 (if op == "=" then e2 else InfixExpr op e1 e2)] applStat = expr2stat' =<< expr --fixme: don't handle ifstats expr2stat' e = case expr2stat e of BlockStat [] -> pzero x -> return [x] {- expr2stat' :: JExpr -> JStat expr2stat' (ApplExpr x y) = return $ (ApplStat x y) expr2stat' (IfExpr x y z) = liftM2 (IfStat x) (expr2stat' y) (expr2stat' z) expr2stat' (PostExpr s x) = return $ PostStat s x expr2stat' (AntiExpr x) = return $ AntiStat x expr2stat' _ = fail "Value expression used as statement" -} breakStat = do reserved "break" l <- optionMaybe myIdent return [BreakStat l] continueStat = do reserved "continue" l <- optionMaybe myIdent return [ContinueStat l] labelStat = do lbl <- try $ do l <- myIdent <* char ':' guard (l /= "default") return l s <- l2s <$> statblock0 return [LabelStat lbl s] antiStat = return . AntiStat <$> do x <- (try (symbol "`(") >> anyChar `manyTill` try (symbol ")`")) either (fail . ("Bad AntiQuotation: \n" ++)) (const (return x)) (parseHSExp x) --args :: JMParser [JExpr] --args = parens $ commaSep expr compileRegex :: String -> Either WrapError Regex compileRegex s = unsafePerformIO $ compile co eo s where co = compExtended eo = execBlank expr :: JMParser JExpr expr = do e <- exprWithIf addType e where addType e = do optTyp <- optionMaybe getType case optTyp of (Just (b,t)) -> return $ TypeExpr b e t Nothing -> return e exprWithIf = do e <- rawExpr addIf e <|> return e addIf e = do reservedOp "?" t <- exprWithIf _ <- colon el <- exprWithIf let ans = (IfExpr e t el) addIf ans <|> return ans rawExpr = buildExpressionParser table dotExpr "expression" table = [[pop "~", pop "!"], [iop "*", iop "/", iop "%"], [pop "++", pop "--"], [iop "++", iop "+", iop "-", iop "--"], [iop "<<", iop ">>", iop ">>>"], [consOp], [iope "==", iope "!=", iope "<", iope ">", iope ">=", iope "<=", iope "===", iope "!=="], [iop "&"], [iop "^"], [iop "|"], [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 e <- many1 (lexeme dotExprOne) "simple expression" case e of [e'] -> return e' (e':es) -> return $ ApplExpr e' es _ -> error "exprApp" dotExprOne :: JMParser JExpr dotExprOne = addNxt =<< valExpr <|> antiExpr <|> parens' expr <|> notExpr <|> newExpr where addNxt e = do nxt <- (Just <$> lookAhead anyChar <|> return Nothing) case nxt of Just '.' -> addNxt =<< (dot >> (SelExpr e <$> (ident' <|> numIdent))) Just '[' -> addNxt =<< (IdxExpr e <$> brackets' expr) 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 notExpr = try (symbol "!" >> dotExpr) >>= \e -> return (ApplExpr (ValExpr (JVar (StrI "!"))) [e]) newExpr = NewExpr <$> (reserved "new" >> dotExpr) antiExpr = AntiExpr <$> do x <- (try (symbol "`(") >> anyChar `manyTill` try (string ")`")) either (fail . ("Bad AntiQuotation: \n" ++)) (const (return x)) (parseHSExp x) valExpr = ValExpr <$> (num <|> negnum <|> str <|> try regex <|> list <|> hash <|> func <|> var) "value" where num = either JInt JDouble <$> try natFloat negnum = either (JInt . negate) (JDouble . negate) <$> try (char '-' >> natFloat) str = JStr <$> (myStringLiteral '"' <|> myStringLiteral '\'') regex = do s <- regexLiteral --myStringLiteralNoBr '/' case compileRegex s of Right _ -> return (JRegEx s) Left err -> fail ("Parse error in regexp: " ++ show err) list = JList <$> brackets' (commaSep expr) hash = JHash . M.fromList <$> braces' (commaSep propPair) var = JVar <$> ident' func = do (symbol "\\" >> return ()) <|> reserved "function" (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 ())) --Parsers without Lexeme 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) myIdent :: JMParser String myIdent = lexeme $ many1 (alphaNum <|> oneOf "_-!@#$%^&*()") <|> myStringLiteral '\'' ident' :: JMParser Ident ident' = do i <- identifier' when ("jmId_" `isPrefixOf` i) $ fail "Illegal use of reserved jmId_ prefix in variable name." return (StrI i) where identifier' = try $ do{ name <- ident'' ; if isReservedName name then unexpected ("reserved word " ++ show name) else return name } ident'' = do{ c <- P.identStart jsLang ; cs <- many (P.identLetter jsLang) ; return (c:cs) } "identifier" isReservedName name = isReserved theReservedNames caseName where caseName | P.caseSensitive jsLang = name | otherwise = map toLower name isReserved names name = scan names where scan [] = False scan (r:rs) = case (compare r name) of LT -> scan rs EQ -> True GT -> False theReservedNames | P.caseSensitive jsLang = sortedNames | otherwise = map (map toLower) sortedNames where sortedNames = sort (P.reservedNames jsLang) natFloat :: Fractional a => JMParser (Either Integer a) natFloat = (char '0' >> zeroNumFloat) <|> decimalFloat "number" where zeroNumFloat = (Left <$> (hexadecimal <|> octal)) <|> decimalFloat <|> fractFloat 0 <|> return (Left 0) decimalFloat = do n <- decimal option (Left n)(fractFloat n) fractFloat n = Right <$> fractExponent n fractExponent n = (do fract <- fraction expo <- option 1.0 exponent' return ((fromInteger n + fract)*expo) ) <|> ((fromInteger n *) <$> exponent') fraction = char '.' >> (foldr op 0.0 <$> many1 digit "fraction") where op d f = (f + fromIntegral (digitToInt d))/10.0 exponent' = do _ <- oneOf "eE" f <- sign power . f <$> decimal where power e | e < 0 = 1.0/power(-e) | otherwise = fromInteger (10^e) sign = (char '-' >> return negate) <|> (char '+' >> return id) <|> return id decimal = number 10 digit hexadecimal = oneOf "xX" >> number 16 hexDigit octal = oneOf "oO" >> number 8 octDigit number base baseDig = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 <$> many1 baseDig myStringLiteral :: Char -> JMParser String myStringLiteral t = do _ <- char t x <- concat <$> many myChar _ <- char t decodeJson x where myChar = do c <- noneOf [t] case c of '\\' -> do c2 <- anyChar return [c,c2] _ -> return [c] -- Taken from json package by Sigbjorn Finne. decodeJson :: String -> JMParser String decodeJson x = parseIt [] x where parseIt rs cs = case cs of '\\' : c : ds -> esc rs c ds c : ds | c >= '\x20' && c <= '\xff' -> parseIt (c:rs) ds | c < '\x20' -> fail $ "Illegal unescaped character in string: " ++ x | i <= 0x10ffff -> parseIt (c:rs) ds | otherwise -> fail $ "Illegal unescaped character in string: " ++ x where i = (fromIntegral (fromEnum c) :: Integer) [] -> return $ reverse rs esc rs c cs = case c of '\\' -> parseIt ('\\' : rs) cs '"' -> parseIt ('"' : rs) cs 'n' -> parseIt ('\n' : rs) cs 'r' -> parseIt ('\r' : rs) cs 't' -> parseIt ('\t' : rs) cs 'f' -> parseIt ('\f' : rs) cs 'b' -> parseIt ('\b' : rs) cs '/' -> parseIt ('/' : rs) cs 'u' -> case cs of d1 : d2 : d3 : d4 : cs' -> case readHex [d1,d2,d3,d4] of [(n,"")] -> parseIt (toEnum n : rs) cs' badHex -> fail $ "Unable to parse JSON String: invalid hex: " ++ show badHex _ -> fail $ "Unable to parse JSON String: invalid hex: " ++ cs _ -> fail $ "Unable to parse JSON String: invalid escape char: " ++ [c] --tricky bit to deal with regex literals and comments / / -- if we hit // inside, then we fail, since that isn't ending the regex but introducing a comment, and thus the initial / could not have introduced a regex. regexLiteral :: JMParser String regexLiteral = do _ <- char '/' x <- concat <$> many myChar _ <- char '/' b <- option False (char '/' >> return True) if b then mzero else return x where myChar = do c <- noneOf ['/','\n'] case c of '\\' -> do c2 <- anyChar return [c,c2] _ -> return [c]