antlr-haskell-0.1.0.2: src/Language/ANTLR4/Boot/Quote.hs
{-# LANGUAGE QuasiQuotes, TemplateHaskell, ScopedTypeVariables, DataKinds,
LambdaCase, FlexibleContexts #-}
{-|
Module : Language.ANTLR4.Boot.Quote
Description : ANTLR4 boot-level quasiquoter
Copyright : (c) Karl Cronburg, 2018
License : BSD3
Maintainer : karl@cs.tufts.edu
Stability : experimental
Portability : POSIX
-}
module Language.ANTLR4.Boot.Quote
( antlr4
, g4_decls
, g4_parsers
, mkLRParser
) where
import Prelude hiding (exp, init)
import System.IO.Unsafe (unsafePerformIO)
import Data.List (nub, elemIndex, groupBy, sortBy, sort, intersperse)
import Data.Ord (comparing)
import Data.Char (toLower, toUpper, isLower, isUpper)
import Data.Maybe (fromJust, catMaybes)
import qualified Debug.Trace as D
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (lift, Exp(..))
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import qualified Language.Haskell.Meta as LHM
import Control.Monad (mapM)
import qualified Language.ANTLR4.Boot.Syntax as G4S
--import qualified Language.ANTLR4.Boot.Parser as G4P
import qualified Language.ANTLR4.Boot.SplicedParser as G4P
import Text.ANTLR.Grammar hiding (getNTs, getProds, s0)
import Text.ANTLR.Parser (AST(..), StripEOF(..))
import Text.ANTLR.Pretty
import Text.ANTLR.Lex.Tokenizer as T
import Text.ANTLR.LR as LR
import qualified Text.ANTLR.Allstar as ALL
import qualified Text.ANTLR.LL1 as LL
import qualified Text.ANTLR.Set as S
import qualified Text.ANTLR.MultiMap as M
import qualified Data.Map as M1
import Text.ANTLR.Set (Set(..))
import qualified Text.ANTLR.Set as Set
import qualified Text.ANTLR.Lex.Regex as R
--trace s = D.trace ("[Language.ANTLR4.Boot.Quote] " ++ s)
--traceM s = D.traceM ("[Language.ANTLR4.Boot.Quote] " ++ s)
trace s x = x
traceM s x = x
haskellParseExp :: (Monad m) => String -> m TH.Exp
haskellParseExp s = --D.trace ("PARSING: " ++ show s) $
case LHM.parseExp s of
Left err -> error err
Right expTH -> return expTH
haskellParseType :: (Monad m) => String -> m TH.Type
haskellParseType s = case LHM.parseType s of
Left err -> trace s (error err)
Right tyTH -> return tyTH
type2returnType :: TH.Type -> TH.Type
type2returnType = let
t2rT :: TH.Type -> TH.Type
t2rT (ForallT xs ys t) = t2rT t
t2rT ((AppT (AppT ArrowT from) to)) = t2rT to
t2rT t@(VarT _) = t
t2rT t@(AppT ListT as) = t
t2rT t@(ConT _) = t
t2rT t@(AppT (ConT _) _) = t
t2rT x = error (show x)
in t2rT
info2returnType :: Info -> TH.Type
info2returnType i = let
in case i of
(VarI _ t _) -> type2returnType t
_ -> error (show i)
--trace s = id
--traceM = return
-- | There are three different quasiquoters in antlr-haskell, each with varying
-- support for different G4 features. If you're looking for the user-facing
-- quasiquoter then turn back now, because here-be-dragons. The user-facing
-- quasiquoter can be found in 'Language.ANTLR4.G4' as @g4@.
--
-- * __User-facing__ QuasiQuoter is in 'Language.ANTLR4.G4'
-- * __Spliced__ QuasiQuoter is here
-- * __Boot__ parser is in @src/Language/ANTLR4/Boot/Parser.hs.boot@
--
-- The spliced quasiquoter, as packaged and shipped with distributions of
-- antlr-haskell, allows for bootstrapping of the user-facing quasiquoter
-- without requiring parsec as a dependency. The boot quasiquoter on the
-- other hand is written entirely in parsec.
antlr4 :: QuasiQuoter
antlr4 = QuasiQuoter
(error "parse exp")
(error "parse pattern")
(error "parse type")
aparse --(error "parse decl")
-- e.g. Named ("Num", "Int") where 'Num' was a G4 lexeme and 'Int' was given
-- as a directive specifying the desired type to read (must instance Read).
data LexemeType =
Literal Int -- A literal lexeme somewhere in the grammar, e.g. ';'
| AString -- Type was unspecified in the G4 lexeme or specified as a String
| Named String TH.TypeQ -- Type was specified as a directive in the G4 lexeme
aparse :: String -> TH.Q [TH.Dec]
aparse input = do
loc <- TH.location
let fileName = TH.loc_filename loc
let (line,column) = TH.loc_start loc
case G4P.parseANTLR input of
r@(LR.ResultAccept ast) -> codeGen r
LR.ResultSet s ->
if S.size s == 1
then codeGen (S.findMin s)
else error $ pshow' s
err -> error $ pshow' err
codeGen (LR.ResultAccept ast) = g4_decls $ G4P.ast2decls ast
{-
-- parser in quasiquotation monad
aparse :: String -> TH.Q [TH.Dec]
aparse input = do
-- TODO: replace bad error showing with
-- debugging information (filename, line #, column) in parser
loc <- TH.location
let fileName = TH.loc_filename loc
let (line,column) = TH.loc_start loc
case G4P.parseANTLR fileName line column input of
Left err -> unsafePerformIO $ fail $ show err
Right x -> g4_decls x
-}
data BaseType = List | Mybe
deriving (Eq, Ord, Show)
baseType (G4S.Regular '?') = Mybe
baseType (G4S.Regular '*') = List
-- Find the (first) name of the grammar
grammarName :: [G4S.G4] -> String
grammarName [] = error "Grammar missing a name"
grammarName (G4S.Grammar{G4S.gName = gName}:_) = gName
grammarName (_:xs) = grammarName xs
mkLower [] = []
mkLower (a:as) = toLower a : as
mkUpper [] = []
mkUpper (a:as) = toUpper a : as
justGrammarTy ast s = [t| Grammar $(s) $(ntConT ast) $(tConT ast) G4S.Directive |]
justGrammarTy' ast s = [t| Grammar $(s) $(ntConT ast) (StripEOF (Sym $(tConT ast))) G4S.Directive |]
ntConT ast = conT $ mkName $ ntDataName ast
tConT ast = conT $ mkName $ tDataName ast
ntDataName ast = gName ast ++ "NTSymbol"
tDataName ast = gName ast ++ "TSymbol"
gName ast = grammarName ast
type G4AST = [G4S.G4]
-- A list of all the G4 literal terminals scattered across production rules
terminalLiterals :: G4AST -> [String]
terminalLiterals ast = (nub $ concatMap getTerminals ast)
-- Find all terminal literals in a G4 grammar rule like '(' and ')' and ';'
getTerminals :: G4S.G4 -> [String]
getTerminals G4S.Prod{G4S.patterns = ps} = concatMap (justTerms . G4S.alphas) ps
getTerminals _ = []
-- THIS EXCLUDES LEXEME FRAGMENTS:
-- e.g. [('UpperID', AString), ('SetChar', Named String)]
lexemeTypes :: G4AST -> [(String, LexemeType)]
lexemeTypes ast = let
nullID (G4S.UpperD xs) = null xs
nullID (G4S.LowerD xs) = null xs
nullID (G4S.HaskellD _) = False
lN :: G4S.G4 -> [(String, LexemeType)]
lN (G4S.Lex{G4S.annotation = Nothing, G4S.lName = lName, G4S.pattern = G4S.LRHS{G4S.directive = Nothing}}) = [(lName, AString)]
lN (G4S.Lex{G4S.annotation = Nothing, G4S.lName = lName, G4S.pattern = G4S.LRHS{G4S.directive = Just s}})
| s == (G4S.UpperD "String") = [(lName, AString)]
| nullID s = [(lName, AString)] -- quirky G4 parser
| otherwise = case s of
(G4S.UpperD s) -> [(lName, Named s (conT $ mkName s))]
(G4S.LowerD s) -> [(lName, Named s (info2returnType <$> reify (mkName s)))]
(G4S.HaskellD s) -> [] -- TODO?
lN _ = []
in concatMap lN ast
--map (\s -> normalC (mkName s) []) lN'
-- A list of all the G4 lexeme names specified in the grammar
lexemeNames :: G4AST -> [String]
lexemeNames ast = map fst (lexemeTypes ast)
-- Find all terminals *literals* in a production like '(' and ')' and ';'
justTerms :: [G4S.ProdElem] -> [String]
justTerms [] = []
justTerms ((G4S.GTerm _ s) : as) = s : justTerms as
justTerms (_:as) = justTerms as
-- A list of all the terminals in the grammar (both literal G4 terminals and
-- G4 lexical terminals)
terminals :: G4AST -> [String]
terminals ast = terminalLiterals ast ++ (lexemeNames ast)
nonterms :: G4AST -> [String]
nonterms ast = nub $ concatMap getNTs ast
-- Find all nonterminals in a production like 'exp' and 'decl'
justNonTerms :: [G4S.ProdElem] -> [String]
justNonTerms [] = []
justNonTerms (G4S.GNonTerm _ s:as)
| (not . null) s && isLower (head s) = s : justNonTerms as
| otherwise = justNonTerms as
justNonTerms (_:as) = justNonTerms as
-- Find all the nonterminals referenced in the production(s) of the given grammar rule
getNTs :: G4S.G4 -> [String]
getNTs G4S.Prod{G4S.pName = pName, G4S.patterns = ps} = pName : concatMap (justNonTerms . G4S.alphas) ps
getNTs _ = []
-- Things Symbols must derive:
symbolDerives = derivClause Nothing $ map (conT . mkName)
[ "Eq", "Ord", "Show", "Hashable", "Generic", "Bounded", "Enum", "Data", "Lift"]
-- Nonterminal symbol data type (enum) for this grammar:
ntDataDeclQ :: G4AST -> DecQ
ntDataDeclQ ast =
dataD (cxt [])
(mkName $ ntDataName ast)
[]
Nothing
(map (\s -> normalC (mkName $ "NT_" ++ s) []) $ (nonterms ast) ++ (regexNonTermSymbols ast))
[symbolDerives]
-- E.g. ['(', ')', ';', 'exp', 'decl']
allLexicalSymbols :: G4AST -> [String]
allLexicalSymbols ast = map (lookupTName ast "") (terminalLiterals ast) ++ (lexemeNames ast)
-- E.g. [('(', Literal 0), (')', Literal 1), (';', Literal 2), ('exp',
-- AString), ('decl', AString')]
allLexicalTypes :: G4AST -> [(String, LexemeType)]
allLexicalTypes ast = (map (lookupLiteralType ast) (terminalLiterals ast)) ++ (lexemeTypes ast)
-- E.g. [('(', Literal 0), ...]
lookupLiteralType :: G4AST -> String -> (String, LexemeType)
lookupLiteralType ast s =
case s `elemIndex` (terminalLiterals ast) of
Nothing -> undefined
Just i -> (s, Literal i)
-- Terminal symbol data type (enum) for this grammar:
tDataDeclQ :: G4AST -> DecQ
tDataDeclQ ast =
dataD (cxt [])
(mkName $ tDataName ast)
[]
Nothing
(map (\s -> normalC (mkName s) []) (map ("T_" ++) (allLexicalSymbols ast)))
--(\s -> normalC (mkName $ lookupTName ast "T_" s) []) lexemes) ++ (lexemeNames "T_"))
[symbolDerives]
-- Map from a terminal's syntax to the name of the data type instance from
-- tDataDeclQ:
lookupTName :: G4AST -> String -> String -> String
lookupTName ast pfx s = pfx ++
(case s `elemIndex` (terminalLiterals ast) of
Nothing -> s
Just i -> show i)
defBang :: Q Bang
defBang = bang noSourceUnpackedness noSourceStrictness
strBangType :: (Q Bang, Q Type)
strBangType = (defBang, conT $ mkName "String")
mkCon = conE . mkName . mkUpper
mkConNT = conE . mkName . ("NT_" ++)
-- | Regular expression term annotations are just syntactic sugar by any other name.
-- Computes the set of productions that need to be added to the grammar to support
-- surface-syntax-level annotations on production rule terms.
genTermAnnotProds :: [G4S.G4] -> [G4S.G4]
genTermAnnotProds [] = []
genTermAnnotProds (G4S.Prod {G4S.pName = n, G4S.patterns = ps}:xs) = let
withAlphas newName d a = G4S.Prod {G4S.pName = newName, G4S.patterns =
[ G4S.PRHS
{ G4S.pred = Nothing
, G4S.alphas = a
, G4S.mutator = Nothing
, G4S.pDirective = Just d
}
]}
gTAP :: G4S.ProdElem -> [G4S.G4]
gTAP (G4S.GNonTerm (G4S.Regular '?') nt) = trace (show nt)
[ withAlphas (nt ++ "_quest") (G4S.UpperD "Just") [G4S.GNonTerm G4S.NoAnnot nt]
, withAlphas (nt ++ "_quest") (G4S.UpperD "Nothing") [] -- epsilon
]
gTAP (G4S.GNonTerm (G4S.Regular '*') nt) =
[ withAlphas (nt ++ "_star") (G4S.HaskellD "(:)") [G4S.GNonTerm G4S.NoAnnot nt, G4S.GNonTerm G4S.NoAnnot (nt ++ "_star")]
, withAlphas (nt ++ "_star") (G4S.HaskellD "(\\x -> [x])") [G4S.GNonTerm G4S.NoAnnot nt]
, withAlphas (nt ++ "_star") (G4S.HaskellD "[]") []
]
gTAP (G4S.GNonTerm (G4S.Regular '+') nt) =
[ withAlphas (nt ++ "_plus") (G4S.HaskellD "(:)") [G4S.GNonTerm G4S.NoAnnot nt, G4S.GNonTerm G4S.NoAnnot (nt ++ "_plus")]
, withAlphas (nt ++ "_plus") (G4S.HaskellD "(\\x -> [x])") [G4S.GNonTerm G4S.NoAnnot nt]
]
gTAP (G4S.GNonTerm G4S.NoAnnot nt) = []
gTAP (G4S.GTerm _ t) = []
gTAP term = error $ show term
in concat (concatMap (map gTAP) (map G4S.alphas ps)) ++ genTermAnnotProds xs
genTermAnnotProds (_:xs) = genTermAnnotProds xs
annotName G4S.NoAnnot s = s
annotName (G4S.Regular '?') s = s ++ "_quest"
annotName (G4S.Regular '*') s = s ++ "_star"
annotName (G4S.Regular '+') s = s ++ "_plus"
annotName (G4S.Regular c) s = s ++ [c] -- TODO: warning on unknown character annotation
annotName' (G4S.GTerm annot s) = annotName annot s
annotName' (G4S.GNonTerm annot s) = annotName annot s
regexNonTermSymbols ast = let
rNTS (G4S.Prod {G4S.patterns = ps}) = Just $ map G4S.alphas ps
rNTS _ = Nothing
in nub $ map annotName' $ filter (not . G4S.isNoAnnot . G4S.annot) (concat $ concat $ catMaybes $ map rNTS ast)
{-
toElem :: G4AST -> G4S.ProdElem, Maybe DataType) -> (TH.ExpQ
toElem ast (G4S.GTerm annot s, dt) = ([| $(mkCon "T") $(mkCon $ lookupTName ast "T_" (annotName annot s)) |], dt)
toElem ast (G4S.GNonTerm annot s, dt)
| (not . null) s && isLower (head s) = ([| $(mkCon "NT") $(mkConNT (annotName annot s)) |], dt)
| otherwise = toElem ast (G4S.GTerm G4S.NoAnnot s, dt)
mkProd :: String -> [(TH.ExpQ, Maybe DataType)] -> TH.ExpQ
mkProd n [] = [| $(mkCon "Production") $(conE $ mkName $ "NT_" ++ n) ($(mkCon "Prod") $(mkCon "Pass") [Eps]) (Just "") |]
mkProd n es = [| $(mkCon "Production") $(conE $ mkName $ "NT_" ++ n) ($(mkCon "Prod") $(mkCon "Pass") $(listE es)) (Just "") |]
getProds :: G4AST -> [G4S.G4] -> [TH.ExpQ]
getProds ast [] = []
getProds ast (G4S.Prod {G4S.pName = n, G4S.patterns = ps}:xs)
= map (mkProd n . map (toElem ast) . (\p -> (G4S.alphas p, G4S.pDirective p))) ps ++ ((getProds ast) xs)
getProds ast (_:xs) = (getProds ast) xs
-}
getProds :: G4AST -> [G4S.G4] -> [TH.ExpQ]
getProds ast [] = []
getProds ast (G4S.Prod {G4S.pName = n, G4S.patterns = ps}:xs) = let
toElem :: G4S.ProdElem -> TH.ExpQ
toElem (G4S.GTerm annot s) = [| $(mkCon "T") $(mkCon $ lookupTName ast "T_" (annotName annot s)) |]
toElem (G4S.GNonTerm annot s)
| (not . null) s && isLower (head s) = [| $(mkCon "NT") $(mkConNT (annotName annot s)) |]
| otherwise = toElem (G4S.GTerm G4S.NoAnnot s)
mkProd :: Maybe G4S.Directive -> [TH.ExpQ] -> TH.ExpQ
mkProd dir [] = [| $(mkCon "Production") $(conE $ mkName $ "NT_" ++ n) ($(mkCon "Prod") $(mkCon "Pass") []) $(lift dir) |]
mkProd dir es = [| $(mkCon "Production") $(conE $ mkName $ "NT_" ++ n) ($(mkCon "Prod") $(mkCon "Pass") $(listE es)) $(lift dir) |]
in map (\p -> mkProd (G4S.pDirective p) (map toElem $ G4S.alphas p)) ps ++ ((getProds ast) xs)
getProds ast (_:xs) = (getProds ast) xs
-- The first NonTerminal in the grammar (TODO: head of list)
s0 :: G4AST -> TH.ExpQ
s0 ast = conE $ mkName $ "NT_" ++ head (nonterms ast)
grammarProds ast = getProds ast (ast ++ ({- D.traceShowId -} (genTermAnnotProds ast)))
grammar ast gTy = [| (defaultGrammar $(s0 ast) :: $(return gTy))
{ ns = Set.fromList [minBound .. maxBound :: $(ntConT ast)]
, ts = Set.fromList [minBound .. maxBound :: $(tConT ast)]
, ps = $(listE $ grammarProds ast)
} |]
--grammarTy s = [t| forall $(s). (Prettify $(s)) => $(justGrammarTy s) |]
grammarTy ast s = [t| (Prettify $(s)) => $(justGrammarTy ast s) |]
{----------------------- Tokenizer -----------------------}
tokenNameTypeQ ast = tySynD (mkName "TokenName") [] (conT $ mkName $ tDataName ast)
lexemeValueDerives = derivClause Nothing $ map (conT . mkName)
["Show", "Ord", "Eq", "Generic", "Hashable", "Data"]
--
lexemeTypeConstructors ast = let
nullD (G4S.UpperD s) = null s
nullD (G4S.LowerD s) = null s
nullD (G4S.HaskellD s) = null s
lTC (i, lex@(G4S.Lex{G4S.annotation = Nothing, G4S.lName = lName, G4S.pattern = G4S.LRHS{G4S.directive = Just d}}))
| null lName = error $ "null lexeme name: " ++ show lex
| nullD d = Just $ normalC (mkName $ "V_" ++ lName) [bangType defBang (conT $ mkName "String")]
| otherwise = case d of
(G4S.UpperD d) -> Just $ normalC (mkName $ "V_" ++ lName) [bangType defBang (conT $ mkName d)]
(G4S.LowerD d) -> Just $ do
info <- reify $ mkName d
normalC (mkName $ "V_" ++ lName) [bangType defBang (return $ info2returnType info)]
--Just $ [|| $$(haskellParseExp d) ||] --error $ "unimplemented use of function in G4 directive: " ++ show d
(G4S.HaskellD s) -> Nothing -- TODO?
lTC _ = Nothing
in ((catMaybes $ map lTC (zip [0 .. length ast - 1] ast))
++ (map (\s -> normalC (mkName $ lookupTName ast "V_" s) []) (terminalLiterals ast)))
tokenValueTypeQ ast =
dataD (cxt []) (mkName "TokenValue") [] Nothing
(lexemeTypeConstructors ast)
[lexemeValueDerives]
mkTyVar s f = return $ f $ mkName s
lookupTokenFncnDecl ast = let
lTFD t = clause [litP $ stringL t]
(normalB $ [| Token $(conE $ mkName $ lookupTName ast "T_" t)
$(conE $ mkName $ lookupTName ast "V_" t)
$(litE $ integerL $ fromIntegral $ length t) |])
[]
in funD (mkName "lookupToken")
( map lTFD (terminalLiterals ast)
++ [clause [varP $ mkName "s"]
(normalB $ [| error ("Error: '" ++ s ++ "' is not a token") |])
[]]
)
-- Construct the function that takes in a lexeme (string) and the token name
-- (T_*) and constructs a token value type instance using 'read' where
-- appropriate based on the directives given in the grammar.
lexeme2ValueQ ast lName = let
l2VQ (_, Literal i) =
clause [varP lName, conP (mkName $ "T_" ++ show i) []]
(normalB [| $(conE $ mkName $ "V_" ++ show i) |]) []
l2VQ (s, AString) =
clause [varP lName, conP (mkName $ "T_" ++ s) []]
(normalB [| $(conE $ mkName $ "V_" ++ s) $(varE lName) |]) []
l2VQ (s, Named n t)
| isLower (head n) =
clause [varP lName, conP (mkName $ "T_" ++ s) []]
(normalB [| $(conE $ mkName $ "V_" ++ s) (trace $(varE lName) ($(varE $ mkName n) $(varE lName) :: $t)) |]) []
| otherwise =
clause [varP lName, conP (mkName $ "T_" ++ s) []]
(normalB [| $(conE $ mkName $ "V_" ++ s) (trace $(varE lName) (read $(varE lName) :: $t)) |]) []
--info <- reify $ mkName d
--normalC (mkName $ "V_" ++ lName) [bangType defBang (return $ info2returnType info)]
in funD (mkName "lexeme2value") (map l2VQ (allLexicalTypes ast))
-- Convert a G4 regex into the backend regex type (for constructing token
-- recognizers as DFAs):
convertRegex :: (Show c) => (String -> G4S.Regex c) -> G4S.Regex c -> R.Regex c
convertRegex getNamedR = let
cR G4S.Epsilon = R.Epsilon
cR (G4S.Literal []) = R.Epsilon
cR (G4S.Literal [c]) = R.Symbol c
cR (G4S.Literal cs) = R.Literal cs
cR (G4S.Union rs) = R.MultiUnion $ map cR rs
cR (G4S.Concat rs) = R.Concat $ map cR rs
cR (G4S.Kleene r) = R.Kleene $ cR r
cR (G4S.PosClos r) = R.PosClos $ cR r
cR (G4S.Question r) = R.Question $ cR r
cR (G4S.CharSet cs) = R.Class cs
cR (G4S.Named n) = convertRegex getNamedR $ getNamedR n
cR (G4S.Negation (G4S.CharSet cs)) = R.NotClass cs
cR (G4S.Negation (G4S.Literal s)) = R.NotClass s
cR (G4S.Negation (G4S.Concat [G4S.Literal s])) = R.NotClass s
cR r@(G4S.Negation _) = error $ "unimplemented: " ++ show r
in cR
getNamedRegex :: G4AST -> String -> G4S.Regex Char
getNamedRegex ast n = let
-- Only the lexeme (fragments) with the given name:
gNR (G4S.Lex{G4S.annotation = Just G4S.Fragment, G4S.lName = lName}) = lName == n
gNR _ = False
in case filter gNR ast of
[] -> error $ "No fragment named '" ++ n ++ "'"
[(G4S.Lex{G4S.pattern = G4S.LRHS{G4S.regex = r}})] -> r
xs -> error $ "Too many fragments named '" ++ n ++ "', i.e.: " ++ show xs
-- Make the list of tuples containing regexes, one for each terminal.
mkRegexesQ ast = let
mkLitR :: String -> ExpQ
mkLitR s = [| ($( conE $ mkName $ lookupTName ast "T_" s)
, $(lift $ convertRegex (getNamedRegex ast) $ G4S.Literal s)) |]
mkLexR :: G4S.G4 -> Maybe ExpQ
mkLexR (G4S.Lex{G4S.annotation = Nothing, G4S.lName = lName, G4S.pattern = G4S.LRHS{G4S.regex = r}}) = Just
[| ($(conE $ mkName $ lookupTName ast "T_" lName), $(lift $ convertRegex (getNamedRegex ast) r)) |]
mkLexR _ = Nothing
in valD (varP $ mkName $ mkLower $ gName ast ++ "Regexes")
(normalB $ listE (map mkLitR (terminalLiterals ast) ++ (catMaybes $ map mkLexR ast)))
[]
prettyTFncnQ ast fncnName = let
pTFLit lexeme =
clause [conP (mkName $ lookupTName ast "T_" lexeme) []]
(normalB [| pStr $(litE $ stringL $ "'" ++ lexeme ++ "'") |])
[]
pTFName lexeme =
clause [conP (mkName $ lookupTName ast "T_" lexeme) []]
(normalB [| pStr $(litE $ stringL $ lexeme) |])
[]
in funD fncnName (map pTFLit (terminalLiterals ast) ++ map pTFName (lexemeNames ast))
prettyVFncnQ ast fncnName = let
pVFLit lexeme =
clause [conP (mkName $ lookupTName ast "V_" lexeme) []]
(normalB [| pStr $(litE $ stringL $ "'" ++ lexeme ++ "'") |])
[]
pVFName lexeme =
clause [conP (mkName $ lookupTName ast "V_" lexeme) [varP (mkName "v")]]
(normalB [| pChr '\'' >> prettify v >> pChr '\'' |])
[]
in funD fncnName (map pVFLit (terminalLiterals ast) ++ map pVFName (lexemeNames ast))
astFncnName s = mkName $ "ast2" ++ s
a2d ast nameAST G4S.Lex{G4S.annotation = Nothing, G4S.lName = _A, G4S.pattern = G4S.LRHS{G4S.directive = dir}}
= Just [(mkName $ "ast2" ++ _A
,[ clause [ conP (mkName "Leaf")
[ conP (mkName $ "Token")
[ wildP
, conP (mkName $ lookupTName ast "V_" _A)
[ varP $ mkName "t"]
, wildP]]]
(normalB (varE $ mkName "t"))
[]
]
)]
{-
a2d G4S.Lex{G4S.lName = _A, G4S.pattern = G4S.LRHS{G4S.directive = Just s}}
| s == "String" = Just [funD (mkName $ "ast2" ++ _A) [ clause [] (normalB (varE $ mkName "id")) [] ]]
| null s = Just [funD (mkName $ "ast2" ++ _A) [ clause [] (normalB (varE $ mkName "id")) [] ]]
| otherwise = Just [funD (mkName $ "ast2" ++ _A) [ clause [] (normalB (varE $ mkName s)) [] ]]
-}
a2d ast nameAST G4S.Prod{G4S.pName = _A, G4S.patterns = ps} = let
mkConP (G4S.GNonTerm annot nt)
-- Some nonterminals are really terminal tokens (regular expressions):
| isUpper (head nt) = conP (mkName "T") [conP (mkName $ lookupTName ast "T_" $ annotName annot nt) []]
| otherwise = conP (mkName "NT") [conP (mkName $ "NT_" ++ annotName annot nt) []]
mkConP (G4S.GTerm annot t) = conP (mkName "T") [conP (mkName $ lookupTName ast "T_" $ annotName annot t) []]
justStr (G4S.GNonTerm annot s) = annotName annot s
justStr (G4S.GTerm _ s) = s
vars as = catMaybes
[ if G4S.isGNonTerm a
then Just (a, mkName $ "v" ++ show i ++ "_" ++ justStr a, varE $ mkName $ "ast2" ++ justStr a)
else Nothing
| (i, a) <- zip [0 .. length as] as
]
astListPattern as = listP $
[ if G4S.isGNonTerm a
then varP $ mkName $ "v" ++ show i ++ "_" ++ justStr a
else wildP
| (i, a) <- zip [0 .. length as] as
]
astAppRec b (alpha, varName, recName) = appE b (appE recName $ varE varName)
{- case G4S.annot alpha of
G4S.NoAnnot -> appE b (appE recName $ varE varName)
(G4S.Regular '?') -> appE b (appE recName $ varE varName)
-- TODO: Below two cases:
(G4S.Regular '*') -> appE b (appE recName $ varE varName)
(G4S.Regular '+') -> appE b (appE recName $ varE varName)
otherwise -> error $ show alpha -}
clauses = [ clause [ [p| AST $(conP (mkName $ "NT_" ++ _A) [])
$(listP $ map mkConP as)
$(astListPattern as)
|]
]
(case (dir, vars as) of
(Just (G4S.UpperD d), vs) -> normalB $ foldl astAppRec (conE $ mkName d) vs
(Just (G4S.LowerD d), vs) -> normalB $ foldl astAppRec (varE $ mkName d) vs
(Just (G4S.HaskellD d), vs) -> normalB $ foldl astAppRec (haskellParseExp d) vs
(Nothing, []) -> normalB $ tupE []
(Nothing, [(a,v0,rec)]) -> normalB $ appE rec (varE v0)
(Nothing, vs) -> normalB $ tupE $ map (\(a,vN,rN) -> appE rN $ varE vN) vs
) []
| G4S.PRHS{G4S.alphas = as, G4S.pDirective = dir} <- ps
]
retType = let
rT :: G4S.PRHS -> Q Type
rT G4S.PRHS{G4S.alphas = as, G4S.pDirective = dir}
= case (dir, (vars as :: [(G4S.ProdElem, Name, Q Exp)])) of
(Just (G4S.UpperD d), vs) ->
(do i <- reify $ mkName d
(case i of
DataConI _ t n -> return $ type2returnType t
VarI n t _ -> return t
TyConI (DataD _ n _ _ _ _) -> conT n
other -> error $ show other))
(Just (G4S.LowerD d), vs) -> info2returnType <$> reify (mkName d)
(Just (G4S.HaskellD d), vs) -> error "unimplemented" -- TODO if we ever add back the fncnSig below
(Nothing, []) -> tupleT 0
(Nothing, [(a,v0,rec)]) -> tupleT 0
(Nothing, vs) -> tupleT $ length vs
in rT (head ps)
fncnSig
= do rT <- retType
(case rT of
ForallT vs c t -> forallT vs (cxt []) [t| $(conT nameAST) -> $(return t) |]
t -> forallT [] (cxt []) [t| $(conT nameAST) -> $(return t) |])
in Just $ [ --sigD fncnName fncnSig
(astFncnName _A, clauses)
]
a2d ast nameAST _ = Nothing
a2d_error_clauses G4S.Prod{G4S.pName = _A} =
[(astFncnName _A, [ clause [ [p| ast2 |] ] (normalB [| error $ "Failed pattern match on " ++ (show ast2) |]) [] ])]
a2d_error_clauses _ = []
--concat $ (concatMap eachAlpha . map G4S.alphas) ps
{-
epsilon_a2d ast (G4S.Prod{G4S.pName = _A, G4S.patterns = ps}) = let
mkConP (G4S.GNonTerm annot nt)
-- Some nonterminals are really terminal tokens (regular expressions):
| isUpper (head nt) = conP (mkName "T") [conP (mkName $ lookupTName ast "T_" $ annotName annot nt) []]
| otherwise = conP (mkName "NT") [conP (mkName $ "NT_" ++ annotName annot nt) []]
mkConP (G4S.GTerm annot t) = conP (mkName "T") [conP (mkName $ lookupTName ast "T_" $ annotName annot t) []]
justStr (G4S.GNonTerm annot s) = annotName annot s
justStr (G4S.GTerm _ s) = s
justStr' (Left a) = Just $ justStr a
justStr' _ = Nothing
maybeBaseType (Left _) = Nothing
maybeBaseType (Right x) = Just x
isValid (Left x) = G4S.isGNonTerm x
isValid (Right _) = True
--isValid _ = False
vars :: [Either G4S.ProdElem BaseType] -> [(Maybe BaseType, String, String)]
vars as = let
vars' (base_type, i, Just s) = (base_type, "v" ++ show i ++ "_" ++ s, "ast2" ++ s)
vars' (Just Mybe, i, Nothing) = (Just Mybe, "Nothing", "undefined")
vars' (Just List, i, Nothing) = (Just List, "[]", "undefined")
--vars' (base_type, i, Nothing) = (base_type, "[]", "undefined")
in (map vars' . map (\(i,a) -> (maybeBaseType a, i, justStr' a)) . filter (isValid . snd) . zip [0 .. length as]) as
astListPattern as = listP
[ case a of
(G4S.GNonTerm annot s) -> varP $ mkName $ "v" ++ show i ++ "_" ++ annotName annot s
otherwise -> wildP
| (i, a) <- catLeftsTuple $ zip [0 .. length as] as
]
catLeftsTuple :: [(i, Either a b)] -> [(i,a)]
catLeftsTuple [] = []
catLeftsTuple ((i, Left x):rst) = (i, x) : catLeftsTuple rst
catLeftsTuple (_:rst) = catLeftsTuple rst
astAppRec b (Just Mybe, varName, _) = appE b (conE $ mkName varName)
astAppRec b (Just List, varName, _) = appE b (listE [])
astAppRec b (base_type, varName@(v:_), recName)
| isLower v = appE b (appE (varE $ mkName recName) $ varE $ mkName varName)
| otherwise = appE b (appE (varE $ mkName recName) $ conE $ mkName varName)
{-
G4S.NoAnnot -> appE b (appE recName $ varE $ mkName varName)
(G4S.Regular '?') -> appE b (appE recName $ varE $ mkName varName)
(G4S.Regular '*') -> appE b (appE recName $ varE $ mkName varName)
(G4S.Regular '+') -> appE b (appE recName $ varE $ mkName varName)
otherwise -> error $ show (b,(varName,recName))
-}
catLefts [] = []
catLefts (((Left x)):rst) = x : catLefts rst
catLefts (_:rst) = catLefts rst
pats as = [ [p| AST $(conP (mkName $ "NT_" ++ _A) [])
$(listP $ map mkConP $ catLefts as)
$(astListPattern as)
|]
]
appBodyType (base_type, vN@(v:_), rN)
| isLower v = appE (varE $ mkName rN) $ varE $ mkName vN
| otherwise = conE $ mkName vN
body dir as = (case (dir, vars as) of
(Just (G4S.UpperD d), vs) -> foldl astAppRec (conE $ mkName d) vs
(Just (G4S.LowerD d), vs) -> foldl astAppRec (varE $ mkName d) vs
(Just (G4S.HaskellD d), vs) -> foldl astAppRec (haskellParseExp d) vs
(Nothing, []) -> tupE []
(Nothing, [(Just Mybe, varName, _)]) -> conE $ mkName varName
(Nothing, [(Just List, varName, _)]) -> listE []
(Nothing, [(base_type, v0@(v:_), rec)])
| isUpper v -> conE $ mkName v0 -- 'Nothing' base case
| otherwise -> appE (varE $ mkName rec) (varE $ mkName v0)
(Nothing, vs) -> tupE $ map appBodyType vs
)
e_a2d (G4S.PRHS{G4S.alphas = as0, G4S.pDirective = dir}) = let
isEpsilonAnnot (G4S.Regular '?') = True
isEpsilonAnnot (G4S.Regular '*') = True
isEpsilonAnnot _ = False
combos' :: [Either G4S.ProdElem BaseType] -> [Either G4S.ProdElem BaseType] -> [[Either G4S.ProdElem BaseType]]
combos' ys [] = []
combos' ys (a@(Left a'):as)
| (isEpsilonAnnot . G4S.annot) a'
= (reverse ys ++ (Right $ baseType $ G4S.annot a'):as) -- Production with epsilon-able alpha 'a' removed
: (reverse ys ++ a:as) -- Production without epsilon-able alpha 'a' removed
: ( combos' ((Right $ baseType $ G4S.annot a'):ys) as -- Recursively with epsilon-able alpha 'a' removed
++ combos' (a:ys) as) -- Recursively *without* it removed
| otherwise = combos' (a:ys) as
combos' ys ((Right _):as) = error "Can't have 'Right' in second list"
orderNub ps p1
| p1 `elem` ps = ps
| otherwise = p1 : ps
combos xs = foldl orderNub [] (combos' [] $ map Left xs)
in [(astFncnName _A,
map (\as' -> clause (pats as') (normalB $ body dir as') []) $ combos as0
)]
in concatMap e_a2d ps
epsilon_a2d ast _ = []
-}
mkTupler n = let
xs = ["p" ++ show i | i <- [0 .. n - 1]]
xs_comma = intersperse "," xs
in "(\\" ++ concat (intersperse " " xs) ++ " -> (" ++ concat xs_comma ++ "))"
-- | Post-condition: all TermAnnots in this production are NoAnnots,
-- and all directives are not Nothing (Nothings turn into Unit, identity function, or tupler).
wipeOutAnnots p@(G4S.Prod{G4S.pName = _A, G4S.patterns = ps}) = let
wOA prhs@(G4S.PRHS { G4S.alphas = as0, G4S.pDirective = dir }) = let
repAnnots pe@(G4S.GTerm G4S.NoAnnot _) = pe
repAnnots pe@(G4S.GNonTerm G4S.NoAnnot _) = pe
repAnnots (G4S.GTerm a s) = G4S.GTerm G4S.NoAnnot (annotName a s)
repAnnots (G4S.GNonTerm a s) = G4S.GNonTerm G4S.NoAnnot (annotName a s)
dir' = let
as0' = filter G4S.isGNonTerm as0
in case dir of
Just x -> Just x
Nothing
| length as0' == 0 -> Just $ G4S.HaskellD "()"
| length as0' == 1 -> Just $ G4S.HaskellD "(\\x -> x)"
| otherwise -> Just $ G4S.HaskellD $ mkTupler (length as0')
in prhs { G4S.alphas = map repAnnots as0, G4S.pDirective = dir' }
in p { G4S.patterns = map wOA ps }
wipeOutAnnots x = x
--allClauses :: Grammar s nts t -> G4AST -> [(Name, [ClauseQ])]
allClauses gr ast' nameAST = let
ast = genTermAnnotProds ast' ++ ast'
in
(concat . catMaybes . map (a2d ast nameAST)) ast -- standard clauses ignoring optionals (?,+,*) syntax
{- ++ (concatMap regex_a2d) ast -- Epsilon-removed optional ast conversion functions -}
{- ++ (concatMap (epsilon_a2d ast)) ast -- Clauses for productions with epsilons -}
++ (concatMap a2d_error_clauses) ast -- Catch-all error clauses
funDecls lst@((name, _):_) = Just $ funD name $ concatMap snd lst
funDecls [] = error "groupBy can't return an empty list"
-- Pattern matches on an AST to produce a Maybe DataType
ast2DTFncnsQ gr ast nameAST =
(catMaybes . map funDecls . groupBy (\a b -> fst a == fst b) . sortBy (comparing fst)) (allClauses gr ast nameAST)
unitTy = [t| () |]
removeEpsilonsAST :: [G4S.G4] -> [G4S.G4]
removeEpsilonsAST ast = let
getPRHS (G4S.Prod { G4S.pName = s, G4S.patterns = ps }) = map (\as -> (s, as)) ps
getPRHS _ = []
epsNT (_A, G4S.PRHS { G4S.alphas = [], G4S.pDirective = dir}) = (:) (_A, dir)
epsNT _ = id
epsNTs = foldr epsNT [] (concatMap getPRHS ast)
-- Maintains order with a foldr
orderNub ast0 asts
| ast0 `elem` asts = asts
| otherwise = ast0 : asts
replicateDeclFor (nts0, dflt) (G4S.Prod { G4S.pName = nt1, G4S.patterns = ps }) = let
-- Reconstruct the directive such that we drop one symbol (NT or T) between ys xs
-- (starting with ys, ending with xs)
dropOne ys' xs' dir =
let ys = filter G4S.isGNonTerm ys'
xs = filter G4S.isGNonTerm xs'
params_ys = map (\i -> " p" ++ show i ++ " ") [0 .. length ys - 1]
params_xs = map (\i -> " p" ++ show i ++ " ") [length ys .. length ys + length xs - 1]
both = concat (intersperse "," $ params_ys ++ params_xs)
ifNull s
| null s = "id"
| otherwise = s
s_dir = case dir of
Just (G4S.UpperD s) -> "(" ++ ifNull s ++ ")"
Just (G4S.LowerD s) -> "(" ++ ifNull s ++ ")"
Just (G4S.HaskellD s) -> "(" ++ ifNull s ++ ")"
-- tuple-er:
Nothing
| length (params_ys ++ params_xs) == 0 -> "()"
| length (params_ys ++ params_xs) == 1 -> "(\\x -> x)"
| otherwise -> "(\\" ++ concat params_ys ++ concat params_xs ++ " -> ("
++ both ++ "))"
s_dflt = case dflt of
Just (G4S.UpperD s) -> s
Just (G4S.LowerD s) -> s
Just (G4S.HaskellD s) -> s
Nothing -> " () "
ret
| length params_ys + length params_xs == 0 = Just $ G4S.HaskellD $ "(" ++ s_dir ++ " " ++ s_dflt ++ ")"
| otherwise = Just $ G4S.HaskellD $ "(\\" ++ concat params_ys ++ concat params_xs ++ " -> " ++ s_dir
++ " " ++ concat params_ys ++ " " ++ s_dflt ++ " " ++ concat params_xs ++ ")"
in ret
rDF prhs ys [] = [ updatePRHS prhs $ reverse ys ]
rDF prhs ys (x:xs) = let
newPRHS = prhs { G4S.pDirective = dropOne ys xs (G4S.pDirective prhs) }
result
| G4S.prodElemSymbol x == nts0 -- String equality
= updatePRHS newPRHS (reverse ys ++ xs)
: updatePRHS prhs (reverse ys ++ x:xs)
: ( rDF newPRHS ys xs -- Recursively with nts0 removed
++ rDF prhs (x:ys) xs) -- Recursively without nts0 removed
| otherwise = rDF prhs (x:ys) xs
in result
updatePRHS prhs xs = prhs { G4S.alphas = xs }
in ( G4S.Prod
{ G4S.pName = nt1
-- TODO: nub by ignoring directives? Really the directives need to be types not strings...
, G4S.patterns = nub $ concatMap
(\prhs -> rDF prhs [] (G4S.alphas prhs))
ps
}
)
replicateDeclFor _ p = p
eliminate nts prod@(G4S.Prod { G4S.pName = _A, G4S.patterns = ps }) =
if _A == nts
then prod { G4S.patterns = filter (not . null . G4S.alphas) ps }
else prod
eliminate nts prod = prod
ast' = case {- D.trace ("epsNTs: " ++ show epsNTs) -} epsNTs of
[] -> ast
((nts, dflt):ntss) -> removeEpsilonsAST $
map (eliminate nts) (foldr orderNub [] (map (replicateDeclFor (nts, dflt)) ast))
in foldr orderNub [] ast'
{-
epsNT (_A, G4S.PRHS { G4S.alphas = [] }) = (:) _A
epsNT prod = id
ps_init = concatMap (\
epsNTs = foldr epsNT [] (map (second (filter (not . isEps))) ps_init)
orderNub ps p1
| p1 `elem` ps = ps
| otherwise = p1 : ps
replicateProd nts0 (nt1, es) = let
rP ys [] = [(nt1, reverse ys)]
rP
in rP [] es
ps' = case epsNTs of
[] -> ps_init
(nts:ntss) -> removeEpsilonsAST $
foldl orderNub [
[ p'
| (_A, as) <- ps_init
, p' <- replicateProd nts (_A, as)
, (not . null) as
]
in ps'
-}
-- | This function does the heavy-lifting of Haskell code generation, most notably
-- generating non-terminal, terminal, and grammar data types as well as accompanying
-- parsing functions.
g4_decls :: [G4S.G4] -> TH.Q [TH.Dec] -- exp :: G4
g4_decls ast' =
-- terminaLiterals, lexemeNames
-- IMPORTANT: Creating type variables in two different haskell type
-- quasiquoters with the same variable name produces two (uniquely) named type
-- variables. In order to achieve the same type variable you need to run one
-- in the Q monad first then pass the resulting type to other parts of the
-- code that need it (thus capturing the type variable).
do let ast = removeEpsilonsAST $ map wipeOutAnnots (ast' ++ genTermAnnotProds ast') -- Order of '++' matters here
tokVal = mkName "TokenValue"
tokName = mkName "TokenName"
ntSym = mkName $ ntDataName ast
tSym = mkName $ tDataName ast
nameAST = mkName (mkUpper $ gName ast ++ "AST")
nameToken = mkName (mkUpper $ gName ast ++ "Token")
nameDFAs = mkName (mkLower $ gName ast ++ "DFAs")
name = mkName $ mkLower (gName ast ++ "Grammar'")
nameUnit = mkName $ mkLower (gName ast ++ "Grammar")
lowerASTName = mkName (mkLower $ gName ast ++ "AST")
--D.traceM $ "AST=" ++ pshowList' ast
prettyTFncnName <- newName "prettifyT"
prettyValueFncnName <- newName "prettifyValue"
stateTypeName <- newName "s"
let stateType = varT stateTypeName
gTyUnit <- justGrammarTy ast unitTy
--gUnitFunD <- funD nameUnit [clause [] (normalB $ [| LL.removeEpsilons $(varE name) |]) []]
gUnitFunD <- funD nameUnit [clause [] (normalB $ [| $(varE name) |]) []]
gTySigUnit <- sigD nameUnit (return gTyUnit)
ntDataDecl <- ntDataDeclQ ast
tDataDecl <- tDataDeclQ ast
gTy <- grammarTy ast stateType
gTy' <- justGrammarTy ast stateType
gTySig <- sigD name (return gTy)
g <- grammar ast gTy'
gFunD <- funD name [clause [] (normalB (return g)) []]
prettyNT:_ <- [d| instance Prettify $(ntConT ast) where prettify = rshow |]
prettyT:_ <- [d| instance Prettify $(tConT ast) where prettify = $(varE prettyTFncnName) |]
prettyValue:_ <- [d| instance Prettify $(conT tokVal) where prettify = $(varE prettyValueFncnName) |]
lookupTokenD <- lookupTokenFncnDecl ast
tokenNameType <- tokenNameTypeQ ast
tokenValueType <- tokenValueTypeQ ast
let lName = mkName "l"
lexeme2Value <- lexeme2ValueQ ast lName
regexes <- mkRegexesQ ast
let dfasName = mkName $ mkLower (gName ast) ++ "DFAs"
let regexesE = varE $ mkName $ mkLower (gName ast) ++ "Regexes"
dfas <- funD dfasName [clause [] (normalB [| map (fst &&& regex2dfa . snd) $(regexesE) |]) []]
astDecl <-tySynD nameAST [] [t| AST $(conT ntSym) $(conT nameToken) |]
tokDecl <- tySynD nameToken [] [t| Token $(conT tSym) $(conT tokVal) |]
prettyTFncn <- prettyTFncnQ ast prettyTFncnName
prettyVFncn <- prettyVFncnQ ast prettyValueFncnName
the_ast <- funD lowerASTName [clause [] (normalB $ lift ast) []] -- [d| $(lowerASTName) = $(lift ast) |]
return $
[ ntDataDecl, tDataDecl
, gTySig, gFunD
, gTySigUnit, gUnitFunD
, tokenNameType, tokenValueType
, prettyTFncn, prettyVFncn
, prettyNT, prettyT, prettyValue
, lookupTokenD
, lexeme2Value
, regexes
, dfas, astDecl, tokDecl
, the_ast
]
g4_parsers ast gr = do
let tokVal = mkName "TokenValue"
tokName = mkName "TokenName"
ntSym = mkName $ ntDataName ast
tSym = mkName $ tDataName ast
nameAST = mkName (mkUpper $ gName ast ++ "AST")
nameToken = mkName (mkUpper $ gName ast ++ "Token")
nameDFAs = mkName (mkLower $ gName ast ++ "DFAs")
name = mkName $ mkLower (gName ast ++ "Grammar'")
nameUnit = mkName $ mkLower (gName ast ++ "Grammar")
--D.traceM $ "This is the grammar: " ++ pshow' gr
ast2DTFncns <- sequence $ ast2DTFncnsQ gr ast nameAST
decls <- [d|
instance Ref $(conT ntSym) where
type Sym $(conT ntSym) = $(conT ntSym)
getSymbol = id
tokenize :: String -> [$(conT nameToken)] --Token $(conT tokName) $(conT tokVal)]
tokenize = T.tokenize $(varE nameDFAs) lexeme2value
slrParse :: [$(conT nameToken)]
-> LR.LRResult
(LR.CoreSLRState $(conT ntSym) (StripEOF (Sym $(conT nameToken))))
$(conT nameToken)
$(conT nameToken)
$(conT nameAST)
slrParse = (LR.slrParse $(varE nameUnit) event2ast)
--glrParse :: [$(conT nameToken)] -> LR.LRResult $(conT ntSym) (StripEOF (Sym $(conT nameToken))) $(conT nameToken) $(conT nameAST)
glrParse :: ($(conT tokName) -> Bool) -> [Char]
-> LR.GLRResult
--(LR.CoreLR1State $(conT ntSym) (StripEOF (Sym $(conT nameToken))))
Int
Char
$(conT nameToken)
$(conT nameAST)
glrParse filterF = (LR.glrParseInc2 $(varE nameUnit) event2ast (T.tokenizeInc filterF $(varE nameDFAs) lexeme2value))
{- instance ALL.Token $(conT nameToken) where
type Label $(conT nameToken) = StripEOF (Sym $(conT nameToken))
getLabel = fromJust . stripEOF . getSymbol
type Literal $(conT nameToken) = $(conT tokVal)
getLiteral = T.tokenValue -}
allstarParse :: ($(conT tokName) -> Bool) -> String -- [$(conT nameToken)]
-> Either String $(conT nameAST)
allstarParse filterF inp =
ALL.parse'
(T.tokenizeIncAll filterF $(varE nameDFAs) lexeme2value (Set.fromList $ map fst $(varE nameDFAs)))
inp
(ALL.NT $(s0 ast))
(ALL.atnOf ($(varE nameUnit) :: $(justGrammarTy ast unitTy)))
True
|]
return $ decls ++ ast2DTFncns
-- | Support for this is __very__ experimental. This function allows you
-- to splice in compile-time computed versions of the LR1 data structures
-- so as to decrease the runtime of at-runtime parsing.
-- See @test/g4/G4.hs@ and @test/g4/Main.hs@ in the antlr-haskell source for
-- example usage of the @glrParseFast@ function generated.
mkLRParser ast g =
let
nameDFAs = mkName (mkLower $ gName ast ++ "DFAs")
tokName = mkName "TokenName"
nameAST = mkName (mkUpper $ grammarName ast ++ "AST")
nameToken = mkName (mkUpper $ gName ast ++ "Token")
name = mkName $ mkLower (grammarName ast ++ "Grammar")
is = sort $ S.toList $ LR.lr1Items g
tbl = LR.lr1Table g
tblInt = LR.convTableInt tbl is
(_lr1Table', errs) = LR.disambiguate tblInt
lr1Table' = M.toList tblInt -- _lr1Table'
lr1S0' = LR.convStateInt is $ LR.lr1Closure g $ LR.lr1S0 g
unitTy = [t| () |] :: Q Type
name' = [e| $(varE name) |] :: Q Exp -- :: $(justGrammarTy' ast unitTy) |]
in do --D.traceM $ pshow' is
D.traceM $ "lr1S0 = " ++ (pshow' $ LR.lr1S0 g)
--D.traceM $ "lr1Table = " ++ (pshow' $ LR.lr1Table g)
D.traceM $ "lr1S0' = " ++ (pshow' lr1S0')
D.traceM $ "lr1Table' = " ++ (pshow' lr1Table')
D.traceM $ "Total LR1 conflicts: " ++ (pshow' errs)
--
--glrParse filterF = (LR.glrParseInc2 $(varE nameUnit) event2ast (T.tokenizeInc filterF $(varE nameDFAs) lexeme2value))
--D.traceM $ "disambiguate tbl = " ++ (pshow' $ disambiguate tbl)
[d| lr1ItemsList = sort $ S.toList $ LR.lr1Items $(name')
lr1Table = $(lift lr1Table')
lr1Goto = LR.convGotoStatesInt (LR.convGoto $(name') (LR.lr1Goto $(name')) lr1ItemsList) lr1ItemsList
lr1Closure = convState $ LR.lr1Closure $(name') (LR.lr1S0 $(name'))
lr1S0 = $(lift lr1S0')
convState = LR.convStateInt lr1ItemsList
glrParseFast :: ($(conT tokName) -> Bool) -> [Char]
-> LR.GLRResult
--(LR.CoreLR1State $(conT ntSym) (StripEOF (Sym $(conT nameToken))))
Int
Char
$(conT nameToken)
$(conT nameAST)
glrParseFast filterF =
LR.glrParseInc'
$(name')
(M.fromList' lr1Table)
lr1Goto
lr1S0
(LR.tokenizerFirstSets convState $(name'))
event2ast
(T.tokenizeInc filterF $(varE nameDFAs) lexeme2value)
|]