PrintGrammar.hs

{-  Copyright 2010 Dominique Devriese

    This file is part of the grammar-combinators library.

    The grammar-combinators library is free software: you can
    redistribute it and/or modify it under the terms of the GNU
    Lesser General Public License as published by the Free
    Software Foundation, either version 3 of the License, or (at
    your option) any later version.

    Foobar is distributed in the hope that it will be useful, but
    WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
    GNU Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General
    Public License along with Foobar. If not, see
    <http://www.gnu.org/licenses/>.
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

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 (d-1) 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 ++ ">" ++ "+"

-- | Print out a single production rule
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) []

-- close enough... 
infinity :: Integer
infinity = 999999999999999999999999999999

-- | Print out a full grammar.
printGrammar :: forall phi t r rr. (Domain phi, Token t) =>
                GAnyExtendedContextFreeGrammar phi t r rr -> String
printGrammar g = printGrammar' foldFam g infinity

-- | Print out a grammar with a depth limit. Intended for infinite grammars.
printGrammarInf :: forall phi t r rr. (Domain phi, Token t) =>
                GAnyExtendedContextFreeGrammar phi t r rr -> Integer -> String
printGrammarInf = printGrammar' foldFam 

-- | Print out the part of a grammar that is reachable from a given non-terminal.
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