content: {-# 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 = bang noSourceUnpackedness noSourceStrictness
  
  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{G4S.alphas = as, G4S.pDirective = dir}
        = case (dir, vars as) 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| () |]
      name' = [e| $(varE name) |] -- :: $(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)
              |]
  
  