T1QQ.hs

-- Generated by RTK from grammar 'T1'. Do not edit by hand.
{-# LANGUAGE TemplateHaskell #-}
module T1QQ
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 T1Lexer
import T1Parser

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 [ ("a","A"),("b","B"),("c","C"),("d","D"),("e","E"),("f1","F1"),("f2","F2"),("f3","F3"),("f4","F4"),("f5","F5"),("g","G")]

-- 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

quoteT1Exp :: Data.Data a => String -> (A -> a) -> String -> TH.ExpQ
quoteT1Exp dummy func s = do
  s1 <- either fail return (replaceAllPatterns s)
  ast <- case scanTokens (dummy ++ " " ++ s1 ++ " " ++ dummy) >>= parseT1 of
           Left err -> fail (rtkRenderError err)
           Right a -> return a
  let expr = func ast
  dataToExpQ (const Nothing `Generics.extQ` antiAExp `Generics.extQ` antiBExp `Generics.extQ` antiDExp `Generics.extQ` antiEExp `Generics.extQ` antiF4Exp `Generics.extQ` antiGExp) expr
quoteT1Pat :: Data.Data a => String -> (A -> a) -> String -> TH.PatQ
quoteT1Pat dummy func s = do
  s1 <- either fail return (replaceAllPatterns s)
  ast <- case scanTokens (dummy ++ " " ++ s1 ++ " " ++ dummy) >>= parseT1 of
           Left err -> fail (rtkRenderError err)
           Right a -> return a
  let expr = func ast
  dataToPatQ (const Nothing `Generics.extQ` rtkPosWildPat `Generics.extQ` antiAPat `Generics.extQ` antiBPat `Generics.extQ` antiDPat `Generics.extQ` antiEPat `Generics.extQ` antiF4Pat `Generics.extQ` antiGPat) expr

antiGExp :: G -> Maybe (TH.Q TH.Exp )
antiGExp ( Anti_G v) = Just $ TH.varE (TH.mkName v)
antiGExp _ = Nothing


antiF4Exp :: F4 -> Maybe (TH.Q TH.Exp )
antiF4Exp ( Anti_F4 v) = Just $ TH.varE (TH.mkName v)
antiF4Exp _ = Nothing


antiEExp :: E -> Maybe (TH.Q TH.Exp )
antiEExp ( Anti_E v) = Just $ TH.varE (TH.mkName v)
antiEExp _ = Nothing


antiDExp :: D -> Maybe (TH.Q TH.Exp )
antiDExp ( Anti_D v) = Just $ TH.varE (TH.mkName v)
antiDExp _ = Nothing


antiBExp :: B -> Maybe (TH.Q TH.Exp )
antiBExp ( Anti_B v) = Just $ TH.varE (TH.mkName v)
antiBExp _ = Nothing


antiAExp :: A -> Maybe (TH.Q TH.Exp )
antiAExp ( Anti_A v) = Just $ TH.varE (TH.mkName v)
antiAExp _ = Nothing



antiGPat :: G -> Maybe (TH.Q TH.Pat )
antiGPat ( Anti_G v) = Just $ TH.varP (TH.mkName v)
antiGPat _ = Nothing


antiF4Pat :: F4 -> Maybe (TH.Q TH.Pat )
antiF4Pat ( Anti_F4 v) = Just $ TH.varP (TH.mkName v)
antiF4Pat _ = Nothing


antiEPat :: E -> Maybe (TH.Q TH.Pat )
antiEPat ( Anti_E v) = Just $ TH.varP (TH.mkName v)
antiEPat _ = Nothing


antiDPat :: D -> Maybe (TH.Q TH.Pat )
antiDPat ( Anti_D v) = Just $ TH.varP (TH.mkName v)
antiDPat _ = Nothing


antiBPat :: B -> Maybe (TH.Q TH.Pat )
antiBPat ( Anti_B v) = Just $ TH.varP (TH.mkName v)
antiBPat _ = Nothing


antiAPat :: A -> Maybe (TH.Q TH.Pat )
antiAPat ( Anti_A v) = Just $ TH.varP (TH.mkName v)
antiAPat _ = Nothing



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

getA ( Ctr__A__0 _ s) = s

a :: QuasiQuoter
a = QuasiQuoter (quoteT1Exp "tok_A_dummy_17" getA ) (quoteT1Pat "tok_A_dummy_17" getA ) quoteT1Type quoteT1Decs

getB ( Ctr__A__1 _ s) = s

b :: QuasiQuoter
b = QuasiQuoter (quoteT1Exp "tok_B_dummy_16" getB ) (quoteT1Pat "tok_B_dummy_16" getB ) quoteT1Type quoteT1Decs

getC ( Ctr__A__2 _ s) = s

c :: QuasiQuoter
c = QuasiQuoter (quoteT1Exp "tok_C_dummy_15" getC ) (quoteT1Pat "tok_C_dummy_15" getC ) quoteT1Type quoteT1Decs

getD ( Ctr__A__3 _ s) = s

d :: QuasiQuoter
d = QuasiQuoter (quoteT1Exp "tok_D_dummy_14" getD ) (quoteT1Pat "tok_D_dummy_14" getD ) quoteT1Type quoteT1Decs

getE ( Ctr__A__4 _ s) = s

e :: QuasiQuoter
e = QuasiQuoter (quoteT1Exp "tok_E_dummy_13" getE ) (quoteT1Pat "tok_E_dummy_13" getE ) quoteT1Type quoteT1Decs

getF1 ( Ctr__A__5 _ s) = s

f1 :: QuasiQuoter
f1 = QuasiQuoter (quoteT1Exp "tok_F1_dummy_12" getF1 ) (quoteT1Pat "tok_F1_dummy_12" getF1 ) quoteT1Type quoteT1Decs

getF2 ( Ctr__A__6 _ s) = s

f2 :: QuasiQuoter
f2 = QuasiQuoter (quoteT1Exp "tok_F2_dummy_11" getF2 ) (quoteT1Pat "tok_F2_dummy_11" getF2 ) quoteT1Type quoteT1Decs

getF3 ( Ctr__A__7 _ s) = s

f3 :: QuasiQuoter
f3 = QuasiQuoter (quoteT1Exp "tok_F3_dummy_10" getF3 ) (quoteT1Pat "tok_F3_dummy_10" getF3 ) quoteT1Type quoteT1Decs

getF4 ( Ctr__A__8 _ s) = s

f4 :: QuasiQuoter
f4 = QuasiQuoter (quoteT1Exp "tok_F4_dummy_9" getF4 ) (quoteT1Pat "tok_F4_dummy_9" getF4 ) quoteT1Type quoteT1Decs

getF5 ( Ctr__A__9 _ s) = s

f5 :: QuasiQuoter
f5 = QuasiQuoter (quoteT1Exp "tok_F5_dummy_8" getF5 ) (quoteT1Pat "tok_F5_dummy_8" getF5 ) quoteT1Type quoteT1Decs

getG ( Ctr__A__10 _ s) = s

g :: QuasiQuoter
g = QuasiQuoter (quoteT1Exp "tok_G_dummy_7" getG ) (quoteT1Pat "tok_G_dummy_7" getG ) quoteT1Type quoteT1Decs