module Text.GrammarCombinators.Utils.PrintGrammar (
printRule,
printGrammar,
printGrammarInf,
printReachableGrammar
) where
import Text.GrammarCombinators.Base
import Text.GrammarCombinators.Utils.IsReachable
newtype PrintProductionRule (phi :: * -> *) (r :: * -> *) t v = IPP {
printIPP :: Bool -> Bool -> Integer -> String
}
printIPPSub :: Integer -> Bool -> Bool -> PrintProductionRule phi r t v -> String
printIPPSub d pd pc pp = if d > 0 then printIPP pp pd pc (d1) else "..."
instance ProductionRule (PrintProductionRule phi r t) where
die = IPP $ \_ _ _ -> "die"
endOfInput = IPP $ \_ _ _ -> "EOI"
a ||| b = IPP $ \pd _ d ->
let t = printIPPSub d False True a ++ " | " ++ printIPPSub d False True b
in if pd then "(" ++ t ++ ")" else t
a >>> b = IPP $ \pd pc d ->
if printIPPSub d pd pc a == "epsilon"
then printIPPSub d pd pc b
else if printIPPSub d pd pc b == "epsilon"
then printIPPSub d pd pc a
else let t = printIPPSub d True False a ++ " " ++ printIPPSub d True False b
in if pc then "(" ++ t ++ ")" else t
instance BiasedProductionRule (PrintProductionRule phi r t) where
a >||| b = IPP $ \pd _ d ->
let t = printIPPSub d False True a ++ " >| " ++ printIPPSub d False True b
in if pd then "(" ++ t ++ ")" else t
a <||| b = IPP $ \pd _ d ->
let t = printIPPSub d False True a ++ " <| " ++ printIPPSub d False True b
in if pd then "(" ++ t ++ ")" else t
instance EpsProductionRule (PrintProductionRule phi r t) where
epsilon _ = IPP $ \_ _ _ -> "epsilon"
instance PenaltyProductionRule (PrintProductionRule phi r t) where
penalty p r = IPP $ \_ _ d -> "penalty " ++ show p ++ " ( " ++ printIPPSub d False False r ++ " )"
instance LiftableProductionRule (PrintProductionRule phi r t) where
epsilonL _ _ = IPP $ \_ _ _ -> "epsilon"
instance (Token t) => TokenProductionRule (PrintProductionRule phi r t) t where
token t = IPP $ \_ _ _ -> show t
anyToken = IPP $ \_ _ _ -> "anyToken"
instance (ShowFam phi) => RecProductionRule (PrintProductionRule phi r t) phi r where
ref idx = IPP $ \_ _ _ -> "<" ++ showIdx idx ++ ">"
instance (ShowFam phi) => LoopProductionRule (PrintProductionRule phi r t) phi r where
manyRef idx = IPP $ \_ _ _ -> "<" ++ showIdx idx ++ ">" ++ "*"
many1Ref idx = IPP $ \_ _ _ -> "<" ++ showIdx idx ++ ">" ++ "+"
printRule :: (Domain phi, Token t) => GAnyExtendedContextFreeGrammar phi t r rr -> Integer -> phi ix -> String
printRule gram depth idx = "<" ++ showIdx idx ++ ">" ++ " ::= " ++ printIPP (gram idx) False False depth
printGrammar' :: forall phi t r rr. (Domain phi, Token t) =>
(forall b. (forall ix. phi ix -> b -> b) -> b -> b) ->
GAnyExtendedContextFreeGrammar phi t r rr -> Integer -> String
printGrammar' fold' gram depth =
unlines $ fold' ((:) . printRule gram depth) []
infinity :: Integer
infinity = 999999999999999999999999999999
printGrammar :: forall phi t r rr. (Domain phi, Token t) =>
GAnyExtendedContextFreeGrammar phi t r rr -> String
printGrammar g = printGrammar' foldFam g infinity
printGrammarInf :: forall phi t r rr. (Domain phi, Token t) =>
GAnyExtendedContextFreeGrammar phi t r rr -> Integer -> String
printGrammarInf = printGrammar' foldFam
printReachableGrammar ::
forall phi t r rr ix.
(Domain phi, Token t) =>
GAnyExtendedContextFreeGrammar phi t r rr ->
phi ix -> String
printReachableGrammar gram idx = printGrammar' (foldReachable gram idx) gram infinity