GrammarQQ.hs

-- Generated by RTK from grammar 'Grammar'. Do not edit by hand.
{-# LANGUAGE TemplateHaskell #-}
module GrammarQQ
where

import qualified Data.Char as C
import qualified Data.Map as M
import Data.List
import Data.Maybe
import qualified Data.Generics as Generics
import qualified Data.Data as Data
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Quote
import GrammarLexer
import GrammarParser

qqShortcuts :: M.Map String String

-- A $name metavariable is rewritten to $Type:name using the qqShortcuts
-- table below. The rewrite is purely textual, so it would also fire inside
-- the quoted language's own string literals: write $$name there to escape
-- it and get the literal text $name. Each '$$' pair directly before a
-- metavariable stands for one literal '$' (so $$$x is a literal '$'
-- followed by the metavariable $x). A '$' not followed by an identifier is
-- never rewritten and needs no escape, and an explicit $Type:name antiquote
-- (the character after the name is ':') passes through untouched.
-- A plain character scan rather than a regex: metavariables are recognized
-- regardless of what follows the name - including a newline or the end of
-- the quote, which the previous regex's terminator class missed.
replaceAllPatterns :: String -> Either String String
replaceAllPatterns [] = Right []
replaceAllPatterns s@('$' : _) =
  let (dollars, rest) = span (== '$') s
  in case rest of
       (c1 : _) | C.isAlpha c1 || c1 == '_' ->
         let (varName, post) = span (\ ch -> C.isAlphaNum ch || ch == '_') rest
             escCount = length dollars - 1
             keptPre = replicate (div escCount 2) '$'
         in case post of
              (':' : _) -> ((dollars ++ varName) ++) <$> replaceAllPatterns post
              _ | odd escCount -> ((keptPre ++ '$' : varName) ++) <$> replaceAllPatterns post
              _ -> case catMaybes $ map (\ prefix -> M.lookup prefix qqShortcuts) $ reverse $ inits varName of
                     [] -> Left $ unlines
                             [ "Unknown metavariable $" ++ varName ++ " in quasi-quote:"
                             , "no prefix of '" ++ varName ++ "' is a known shortcut. Known shortcuts:"
                             , "  " ++ intercalate ", " (M.keys qqShortcuts)
                             , "To include the literal text $" ++ varName ++ " in the quoted code"
                             , "(e.g. inside a string literal), escape it as $$" ++ varName ++ "." ]
                     (rule : _) -> ((keptPre ++ '$' : rule ++ ":" ++ varName) ++) <$> replaceAllPatterns post
       _ -> (dollars ++) <$> replaceAllPatterns rest
replaceAllPatterns (c : rest) = (c :) <$> replaceAllPatterns rest

-- The generated lexer and parser encode error positions as "LINE:COL:message"
-- so structured-diagnostic callers can split them; render them back
-- human-readably for quasi-quote compile errors. Positions refer to the quote
-- body (padded with a start token in front).
rtkRenderError :: String -> String
rtkRenderError err =
    case span (/= ':') err of
        (l, ':' : rest1) | [(line, "")] <- (reads l :: [(Int, String)]) ->
            case span (/= ':') rest1 of
                (c, ':' : msg) | [(col, "")] <- (reads c :: [(Int, String)]) ->
                    "line " ++ show line ++ ", column " ++ show col ++ ": " ++ msg
                _ -> err
        _ -> err

qqShortcuts = M.fromList [ ("grammar","Grammar"),("clause","Clause"),("idList","IdList"),("name","Name"),("option","Option"),("optionList","OptionList"),("rule","Rule"),("ruleList","RuleList"),("strLit","StrLit"),("cl","Clause"),("r","Rule")]

-- A quasi-quote pattern must match an AST parsed from anywhere in a source
-- file, while the pattern itself was parsed from the quote body - so every
-- RtkPos position field becomes a wildcard in generated patterns.
-- (Expressions need no special case: the compile-time position they embed
-- is equality-transparent.)
rtkPosWildPat :: RtkPos -> Maybe (TH.Q TH.Pat)
rtkPosWildPat _ = Just TH.wildP

quoteGrammarExp :: Data.Data a => String -> (Grammar -> a) -> String -> TH.ExpQ
quoteGrammarExp dummy func s = do
  s1 <- either fail return (replaceAllPatterns s)
  ast <- case scanTokens (dummy ++ " " ++ s1 ++ " " ++ dummy) >>= parseGrammar of
           Left err -> fail (rtkRenderError err)
           Right a -> return a
  let expr = func ast
  dataToExpQ (const Nothing `Generics.extQ` antiGrammarExp `Generics.extQ` antiRuleExp `Generics.extQ` antiOptionExp `Generics.extQ` antiNameExp `Generics.extQ` antiClauseExp `Generics.extQ` antiStrLitExp) expr
quoteGrammarPat :: Data.Data a => String -> (Grammar -> a) -> String -> TH.PatQ
quoteGrammarPat dummy func s = do
  s1 <- either fail return (replaceAllPatterns s)
  ast <- case scanTokens (dummy ++ " " ++ s1 ++ " " ++ dummy) >>= parseGrammar of
           Left err -> fail (rtkRenderError err)
           Right a -> return a
  let expr = func ast
  dataToPatQ (const Nothing `Generics.extQ` rtkPosWildPat `Generics.extQ` antiGrammarPat `Generics.extQ` antiRulePat `Generics.extQ` antiOptionPat `Generics.extQ` antiNamePat `Generics.extQ` antiClausePat `Generics.extQ` antiStrLitPat) expr

antiStrLitExp :: StrLit -> Maybe (TH.Q TH.Exp )
antiStrLitExp ( Anti_StrLit v) = Just $ TH.varE (TH.mkName v)
antiStrLitExp _ = Nothing


antiClauseExp :: Clause -> Maybe (TH.Q TH.Exp )
antiClauseExp ( Anti_Clause v) = Just $ TH.varE (TH.mkName v)
antiClauseExp _ = Nothing


antiNameExp :: [ Name ] -> Maybe (TH.Q TH.Exp)
antiNameExp ((Anti_Name v):rest) =
 let restExp =   dataToExpQ (const Nothing `Generics.extQ` antiGrammarExp `Generics.extQ` antiRuleExp `Generics.extQ` antiOptionExp `Generics.extQ` antiNameExp `Generics.extQ` antiClauseExp `Generics.extQ` antiStrLitExp) rest
     lvar = TH.varE $ TH.mkName v
   in Just [| $lvar ++ $restExp |]
antiNameExp _ = Nothing


antiOptionExp :: [ Option ] -> Maybe (TH.Q TH.Exp)
antiOptionExp ((Anti_Option v):rest) =
 let restExp =   dataToExpQ (const Nothing `Generics.extQ` antiGrammarExp `Generics.extQ` antiRuleExp `Generics.extQ` antiOptionExp `Generics.extQ` antiNameExp `Generics.extQ` antiClauseExp `Generics.extQ` antiStrLitExp) rest
     lvar = TH.varE $ TH.mkName v
   in Just [| $lvar ++ $restExp |]
antiOptionExp _ = Nothing


antiRuleExp :: [ Rule ] -> Maybe (TH.Q TH.Exp)
antiRuleExp ((Anti_Rule v):rest) =
 let restExp =   dataToExpQ (const Nothing `Generics.extQ` antiGrammarExp `Generics.extQ` antiRuleExp `Generics.extQ` antiOptionExp `Generics.extQ` antiNameExp `Generics.extQ` antiClauseExp `Generics.extQ` antiStrLitExp) rest
     lvar = TH.varE $ TH.mkName v
   in Just [| $lvar ++ $restExp |]
antiRuleExp _ = Nothing


antiGrammarExp :: Grammar -> Maybe (TH.Q TH.Exp )
antiGrammarExp ( Anti_Grammar v) = Just $ TH.varE (TH.mkName v)
antiGrammarExp _ = Nothing



antiStrLitPat :: StrLit -> Maybe (TH.Q TH.Pat )
antiStrLitPat ( Anti_StrLit v) = Just $ TH.varP (TH.mkName v)
antiStrLitPat _ = Nothing


antiClausePat :: Clause -> Maybe (TH.Q TH.Pat )
antiClausePat ( Anti_Clause v) = Just $ TH.varP (TH.mkName v)
antiClausePat _ = Nothing


antiNamePat :: [ Name ] -> Maybe (TH.Q TH.Pat)
antiNamePat [Anti_Name v] = Just $ TH.varP (TH.mkName v)
antiNamePat _ = Nothing


antiOptionPat :: [ Option ] -> Maybe (TH.Q TH.Pat)
antiOptionPat [Anti_Option v] = Just $ TH.varP (TH.mkName v)
antiOptionPat _ = Nothing


antiRulePat :: [ Rule ] -> Maybe (TH.Q TH.Pat)
antiRulePat [Anti_Rule v] = Just $ TH.varP (TH.mkName v)
antiRulePat _ = Nothing


antiGrammarPat :: Grammar -> Maybe (TH.Q TH.Pat )
antiGrammarPat ( Anti_Grammar v) = Just $ TH.varP (TH.mkName v)
antiGrammarPat _ = Nothing



-- This grammar's quasi-quoters work in expression and pattern contexts only
quoteGrammarType _ = fail "this quasi-quoter cannot be used in a type context"
quoteGrammarDecs _ = fail "this quasi-quoter cannot be used in a declaration context"

getGrammar ( Ctr__Grammar__0 _ s) = s

grammar :: QuasiQuoter
grammar = QuasiQuoter (quoteGrammarExp "tok_Grammar_dummy_11" getGrammar ) (quoteGrammarPat "tok_Grammar_dummy_11" getGrammar ) quoteGrammarType quoteGrammarDecs

getClause ( Ctr__Grammar__1 _ s) = s

clause :: QuasiQuoter
clause = QuasiQuoter (quoteGrammarExp "tok_Clause_dummy_10" getClause ) (quoteGrammarPat "tok_Clause_dummy_10" getClause ) quoteGrammarType quoteGrammarDecs

getIdList ( Ctr__Grammar__2 _ s) = s

idList :: QuasiQuoter
idList = QuasiQuoter (quoteGrammarExp "tok_IdList_dummy_9" getIdList ) (quoteGrammarPat "tok_IdList_dummy_9" getIdList ) quoteGrammarType quoteGrammarDecs

getName ( Ctr__Grammar__3 _ s) = s

name :: QuasiQuoter
name = QuasiQuoter (quoteGrammarExp "tok_Name_dummy_8" getName ) (quoteGrammarPat "tok_Name_dummy_8" getName ) quoteGrammarType quoteGrammarDecs

getOption ( Ctr__Grammar__4 _ s) = s

option :: QuasiQuoter
option = QuasiQuoter (quoteGrammarExp "tok_Option_dummy_7" getOption ) (quoteGrammarPat "tok_Option_dummy_7" getOption ) quoteGrammarType quoteGrammarDecs

getOptionList ( Ctr__Grammar__5 _ s) = s

optionList :: QuasiQuoter
optionList = QuasiQuoter (quoteGrammarExp "tok_OptionList_dummy_6" getOptionList ) (quoteGrammarPat "tok_OptionList_dummy_6" getOptionList ) quoteGrammarType quoteGrammarDecs

getRule ( Ctr__Grammar__6 _ s) = s

rule :: QuasiQuoter
rule = QuasiQuoter (quoteGrammarExp "tok_Rule_dummy_5" getRule ) (quoteGrammarPat "tok_Rule_dummy_5" getRule ) quoteGrammarType quoteGrammarDecs

getRuleList ( Ctr__Grammar__7 _ s) = s

ruleList :: QuasiQuoter
ruleList = QuasiQuoter (quoteGrammarExp "tok_RuleList_dummy_4" getRuleList ) (quoteGrammarPat "tok_RuleList_dummy_4" getRuleList ) quoteGrammarType quoteGrammarDecs

getStrLit ( Ctr__Grammar__8 _ s) = s

strLit :: QuasiQuoter
strLit = QuasiQuoter (quoteGrammarExp "tok_StrLit_dummy_3" getStrLit ) (quoteGrammarPat "tok_StrLit_dummy_3" getStrLit ) quoteGrammarType quoteGrammarDecs