{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

module BNFC.Backend.Haskell.Printer where

import BNFC.Prelude

import Control.Monad.State

import qualified Data.Map                  as Map
import           Data.List                 (intersperse, sortBy, (\\))
import           Data.String               (fromString)

import Prettyprinter

import System.FilePath (takeBaseName)

import BNFC.Backend.Common.Utils as Utils
import BNFC.Backend.CommonInterface.Backend

import BNFC.Backend.Haskell.Utilities.Printer
import BNFC.Backend.Haskell.Utilities.Utils
import BNFC.Backend.Haskell.Options
import BNFC.Backend.Haskell.State

import BNFC.CF
import BNFC.Options.GlobalOptions


haskellPrinter :: LBNF -> State HaskellBackendState Result
haskellPrinter :: LBNF -> State HaskellBackendState Result
haskellPrinter LBNF
lbnf = do
  HaskellBackendState
st <- StateT HaskellBackendState Identity HaskellBackendState
forall s (m :: * -> *). MonadState s m => m s
get
  let cfName :: String
cfName        = String -> String
takeBaseName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ GlobalOptions -> String
optInput (GlobalOptions -> String) -> GlobalOptions -> String
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> GlobalOptions
globalOpt HaskellBackendState
st
      inDirectory :: Bool
inDirectory   = HaskellBackendOptions -> Bool
inDir (HaskellBackendOptions -> Bool) -> HaskellBackendOptions -> Bool
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> HaskellBackendOptions
haskellOpts HaskellBackendState
st
      nSpace :: Maybe String
nSpace        = HaskellBackendOptions -> Maybe String
nameSpace (HaskellBackendOptions -> Maybe String)
-> HaskellBackendOptions -> Maybe String
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> HaskellBackendOptions
haskellOpts HaskellBackendState
st
      useGadt :: Bool
useGadt       = HaskellBackendOptions -> Bool
gadt (HaskellBackendOptions -> Bool) -> HaskellBackendOptions -> Bool
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> HaskellBackendOptions
haskellOpts HaskellBackendState
st
      rules :: [(Type, [(Label, ([Type], (Integer, ARHS)))])]
rules         = [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
filterRules ([(Type, [(Label, ([Type], (Integer, ARHS)))])]
 -> [(Type, [(Label, ([Type], (Integer, ARHS)))])])
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
forall a b. (a -> b) -> a -> b
$ HaskellBackendState
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules HaskellBackendState
st
      tks :: [(CatName, TokenDef)]
tks           = HaskellBackendState -> [(CatName, TokenDef)]
tokens HaskellBackendState
st
      funct :: Bool
funct         = HaskellBackendOptions -> Bool
functor (HaskellBackendOptions -> Bool) -> HaskellBackendOptions -> Bool
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> HaskellBackendOptions
haskellOpts HaskellBackendState
st
      tt :: TokenText
tt            = HaskellBackendOptions -> TokenText
tokenText (HaskellBackendOptions -> TokenText)
-> HaskellBackendOptions -> TokenText
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> HaskellBackendOptions
haskellOpts HaskellBackendState
st
      prettyPrinter :: String
prettyPrinter = LBNF
-> String
-> Bool
-> Maybe String
-> Bool
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(CatName, TokenDef)]
-> Bool
-> TokenText
-> String
cf2printer LBNF
lbnf String
cfName Bool
inDirectory Maybe String
nSpace Bool
useGadt [(Type, [(Label, ([Type], (Integer, ARHS)))])]
rules [(CatName, TokenDef)]
tks Bool
funct TokenText
tt
  Result -> State HaskellBackendState Result
forall (m :: * -> *) a. Monad m => a -> m a
return [(Bool -> Maybe String -> String -> String -> String -> String
mkFilePath Bool
inDirectory Maybe String
nSpace String
cfName String
"Print" String
"hs", String
prettyPrinter)]
  where
    filterRules :: [(Type, [(Label, ([Type], (Integer, ARHS)))])]
                -> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
    filterRules :: [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
filterRules [(Type, [(Label, ([Type], (Integer, ARHS)))])]
rules =
      ((Type, [(Label, ([Type], (Integer, ARHS)))]) -> Bool)
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
forall a. (a -> Bool) -> [a] -> [a]
filter
      (\(Type
_,[(Label, ([Type], (Integer, ARHS)))]
l) -> Bool -> Bool
not ([(Label, ([Type], (Integer, ARHS)))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Label, ([Type], (Integer, ARHS)))]
l))
      ((\(Type
f,[(Label, ([Type], (Integer, ARHS)))]
s) -> (Type
f, [String]
-> [(Label, ([Type], (Integer, ARHS)))]
-> [(Label, ([Type], (Integer, ARHS)))]
filterLabelsPrinter [String]
fNames [(Label, ([Type], (Integer, ARHS)))]
s)) ((Type, [(Label, ([Type], (Integer, ARHS)))])
 -> (Type, [(Label, ([Type], (Integer, ARHS)))]))
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
rules)

    -- Functions names.
    fNames :: [String]
    fNames :: [String]
fNames = CatName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (CatName -> String) -> [CatName] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map CatName (WithPosition Function) -> [CatName]
forall k a. Map k a -> [k]
Map.keys (LBNF -> Map CatName (WithPosition Function)
_lbnfFunctions LBNF
lbnf)

cf2printer :: LBNF
           -> String
           -> Bool
           -> Maybe String
           -> Bool
           -> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
           -> [(CatName,TokenDef)]
           -> Bool
           -> TokenText
           -> String
cf2printer :: LBNF
-> String
-> Bool
-> Maybe String
-> Bool
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(CatName, TokenDef)]
-> Bool
-> TokenText
-> String
cf2printer LBNF
lbnf String
cfName Bool
inDir Maybe String
nameSpace Bool
gadt [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules [(CatName, TokenDef)]
tks Bool
funct TokenText
tokenText =
  LayoutOptions -> Doc () -> String
docToString LayoutOptions
defaultLayoutOptions (Doc () -> String) -> Doc () -> String
forall a b. (a -> b) -> a -> b
$ LBNF
-> String
-> Bool
-> Maybe String
-> Bool
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(CatName, TokenDef)]
-> Bool
-> TokenText
-> Doc ()
cf2doc LBNF
lbnf String
cfName Bool
inDir Maybe String
nameSpace Bool
gadt [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules [(CatName, TokenDef)]
tks Bool
funct TokenText
tokenText


cf2doc :: LBNF
       -> String
       -> Bool
       -> Maybe String
       -> Bool
       -> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
       -> [(CatName,TokenDef)]
       -> Bool
       -> TokenText
       -> Doc ()
cf2doc :: LBNF
-> String
-> Bool
-> Maybe String
-> Bool
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(CatName, TokenDef)]
-> Bool
-> TokenText
-> Doc ()
cf2doc LBNF
lbnf String
cfName Bool
inDir Maybe String
nameSpace Bool
gadt [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules [(CatName, TokenDef)]
tokens Bool
functor TokenText
tokenText =
  ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ())
-> ([Doc ()] -> [Doc ()]) -> [Doc ()] -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
intersperse Doc ()
forall ann. Doc ann
emptyDoc) ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$
    LBNF
-> String
-> Bool
-> Maybe String
-> Bool
-> String
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> Doc ()
printPrologue LBNF
lbnf String
cfName Bool
inDir Maybe String
nameSpace Bool
gadt String
absName [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules
    Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
:
    [Doc ()]
toBePrinted
  where

    absName :: ModuleName
    absName :: String
absName = Bool -> Maybe String -> String -> String -> String
mkModule Bool
inDir Maybe String
nameSpace String
cfName String
"Abs"

    tokenPrintInstances :: Maybe (Doc ())
tokenPrintInstances =
      if [(CatName, TokenDef)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(CatName, TokenDef)]
tokens
      then Maybe (Doc ())
forall a. Maybe a
Nothing
      else Doc () -> Maybe (Doc ())
forall a. a -> Maybe a
Just (Doc () -> Maybe (Doc ())) -> Doc () -> Maybe (Doc ())
forall a b. (a -> b) -> a -> b
$ String -> TokenText -> [(CatName, TokenDef)] -> Doc ()
printTokenInstances String
absName TokenText
tokenText [(CatName, TokenDef)]
tokens

    catPrintInstances :: Maybe (Doc ())
catPrintInstances =
      if [(Type, [(Label, ([Type], (Integer, ARHS)))])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules
      then Maybe (Doc ())
forall a. Maybe a
Nothing
      else Doc () -> Maybe (Doc ())
forall a. a -> Maybe a
Just (Doc () -> Maybe (Doc ())) -> Doc () -> Maybe (Doc ())
forall a b. (a -> b) -> a -> b
$ String
-> Bool -> [(Type, [(Label, ([Type], (Integer, ARHS)))])] -> Doc ()
printCatInstances String
absName Bool
functor [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules

    toBePrinted :: [Doc ()]
toBePrinted = [Maybe (Doc ())] -> [Doc ()]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Doc ())
tokenPrintInstances, Maybe (Doc ())
catPrintInstances]

printPrologue :: LBNF
              -> String
              -> Bool
              -> Maybe String
              -> Bool
              -> ModuleName
              -> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
              -> Doc ()
printPrologue :: LBNF
-> String
-> Bool
-> Maybe String
-> Bool
-> String
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> Doc ()
printPrologue LBNF
lbnf String
cfFileName Bool
inDir Maybe String
nameSpace Bool
gadt String
absName [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules =
  ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ())
-> ([Doc ()] -> [Doc ()]) -> [Doc ()] -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
intersperse Doc ()
forall ann. Doc ann
emptyDoc)
  [ Doc ()
printPragmas, String -> Doc ()
printModule String
cfFileName, Doc ()
printImports
  , Doc ()
annUtilities, Doc ()
printTree, Doc ()
streamTree, Doc ()
printDocTree
  , Doc ()
printRenderTree, Doc ()
renderFunction, Doc ()
prtPrec, Doc ()
printClass, Doc ()
printClassOverlappable
  , Doc ()
prtChar, Doc ()
prtDouble, Doc ()
prtInteger, Doc ()
prtString, Doc ()
printString, Doc ()
mkEsc
  ]
  where
    processedCats :: [Type]
processedCats = (Type, [(Label, ([Type], (Integer, ARHS)))]) -> Type
forall a b. (a, b) -> a
fst ((Type, [(Label, ([Type], (Integer, ARHS)))]) -> Type)
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules
    lstcts :: [Type]
lstcts = (Type, [(Label, ([Type], (Integer, ARHS)))]) -> Type
forall a b. (a, b) -> a
fst ((Type, [(Label, ([Type], (Integer, ARHS)))]) -> Type)
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Type, [(Label, ([Type], (Integer, ARHS)))]) -> Bool)
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Type -> Bool
isListType (Type -> Bool)
-> ((Type, [(Label, ([Type], (Integer, ARHS)))]) -> Type)
-> (Type, [(Label, ([Type], (Integer, ARHS)))])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type, [(Label, ([Type], (Integer, ARHS)))]) -> Type
forall a b. (a, b) -> a
fst) [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules
    annUtilities :: Doc ()
annUtilities = [String] -> [String] -> [String] -> Doc ()
printAnn
      (LBNF -> [String]
toks LBNF
lbnf)
      ([Type] -> [String]
cats ([Type]
processedCats [Type] -> [Type] -> [Type]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Type]
lstcts))
      ([Type] -> [String]
listcats [Type]
lstcts)

    printPragmas :: Doc ()
    printPragmas :: Doc ()
printPragmas = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$
      [ Doc ()
"{-# LANGUAGE CPP #-}"
      , Doc ()
"{-# LANGUAGE FlexibleInstances #-}"
      ]
      [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++
      Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when Bool
gadt [ Doc ()
"{-# LANGUAGE GADTs #-}" ]
      [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++
      [ Doc ()
"{-# LANGUAGE OverloadedStrings #-}"
      , Doc ()
"#if __GLASGOW_HASKELL__ <= 708"
      , Doc ()
"{-# LANGUAGE OverlappingInstances #-}"
      , Doc ()
"#endif"
      , Doc ()
forall ann. Doc ann
emptyDoc
      , Doc ()
"{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}"
      ]

    printModule :: String -> Doc ()
    printModule :: String -> Doc ()
printModule String
cfName = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"-- | Pretty-printer for language" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
cfName
      , Doc ()
"--   Generated by the BNF converter."
      , Doc ()
forall ann. Doc ann
emptyDoc
      ,Doc ()
"module" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString (Bool -> Maybe String -> String -> String -> String
mkModule Bool
inDir Maybe String
nameSpace String
cfName String
"Print")
      , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc ()
"(" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"printTree"
      , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc ()
"," Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"streamTree"
      , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc ()
"," Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"renderTree"
      , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc ()
"," Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"render"
      , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc ()
"," Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"annToAnsiStyle"
      , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc ()
"," Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"Print"
      , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc ()
")" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"where" ]

    printImports :: Doc ()
    printImports :: Doc ()
printImports = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"import qualified" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
absName
      , Doc ()
forall ann. Doc ann
emptyDoc
      , Doc ()
"import           Data.String    (fromString)"
      , Doc ()
"import qualified Data.Text      as T"
      , Doc ()
"import           Data.Text      (Text)"
      , Doc ()
"import           Data.Text.Lazy (unpack)"
      , Doc ()
forall ann. Doc ann
emptyDoc
      , Doc ()
"import Prettyprinter"
      , Doc ()
"import Prettyprinter.Render.Util.SimpleDocTree"
      , Doc ()
"import Prettyprinter.Render.Terminal" ]

    printTree :: Doc ()
    printTree :: Doc ()
printTree = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"-- | The top-level printing method."
      , Doc ()
"printTree :: Print a => a -> String"
      , Doc ()
"printTree = renderTree . streamTree annToAnsiStyle" ]

    streamTree :: Doc ()
    streamTree :: Doc ()
streamTree = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"streamTree :: Print a => (Doc Ann -> Doc AnsiStyle) -> a -> SimpleDocStream AnsiStyle"
      , Doc ()
"streamTree f a = layoutSmart defaultLayoutOptions $ f (docTree 0 a)" ]

    printDocTree :: Doc ()
    printDocTree :: Doc ()
printDocTree = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"docTree :: Print a => Int -> a -> Doc Ann"
      , Doc ()
"docTree = prt" ]

    printClass :: Doc ()
    printClass :: Doc ()
printClass = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"-- | The printer class does the job."
        , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep [ Doc ()
"class Print a where"
        , Doc ()
"prt :: Int -> a -> Doc Ann" ]
      ]

    printClassOverlappable :: Doc ()
    printClassOverlappable :: Doc ()
printClassOverlappable = Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"instance {-# OVERLAPPABLE #-} Print a => Print [a] where"
      , Doc ()
"prt i as = hsep $ map (prt i) as" ]

    printRenderTree :: Doc ()
    printRenderTree :: Doc ()
printRenderTree = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"renderTree :: SimpleDocStream AnsiStyle -> String"
      , Doc ()
"renderTree = unpack . renderLazy . render 0 False" ]

    prtPrec :: Doc ()
    prtPrec :: Doc ()
prtPrec = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"prPrec :: Int -> Int -> Doc Ann -> Doc Ann"
      , Doc ()
"prPrec i j d = if i > j then parens d else d" ]

    prtInteger :: Doc ()
    prtInteger :: Doc ()
prtInteger = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"instance Print Integer where"
      , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"prt _ x = annotate (Literal LitInteger) (fromString $ show x)" ]

    prtDouble :: Doc ()
    prtDouble :: Doc ()
prtDouble = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"instance Print Double where"
      , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"prt _ x = annotate (Literal LitDouble) (fromString $ show x)" ]

    prtChar :: Doc ()
    prtChar :: Doc ()
prtChar = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"instance Print Char where"
      , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"prt _ x = annotate (Literal LitChar) (pretty '\\'' <> mkEsc '\\'' x <> pretty '\\'')"
      ]

    prtString :: Doc ()
    prtString :: Doc ()
prtString = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"instance Print String where"
      , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"prt _ x = printString x" ]

    printString :: Doc ()
    printString :: Doc ()
printString = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"printString :: String -> Doc Ann"
      , Doc ()
"printString s = annotate (Literal LitString) (pretty '\"' <> hcat (map (mkEsc '\"') s) <> pretty '\"')" ]

    mkEsc :: Doc ()
    mkEsc :: Doc ()
mkEsc = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ()
"mkEsc :: Char -> Char -> Doc Ann"
      , Doc ()
"mkEsc q s = case s of"
      , Doc ()
"  s | s == q -> pretty '\\\\' <> pretty s"
      , Doc ()
"  '\\\\' -> fromString \"\\\\\\\\\""
      , Doc ()
"  '\\n' -> fromString \"\\\\n\""
      , Doc ()
"  '\\t' -> fromString \"\\\\t\""
      , Doc ()
"  s -> pretty s"
      ]


-- | Print tokens instances for the printer.

printTokenInstances :: ModuleName -> TokenText -> [(CatName,TokenDef)] -> Doc ()
printTokenInstances :: String -> TokenText -> [(CatName, TokenDef)] -> Doc ()
printTokenInstances String
absName TokenText
tokenText =
  [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ())
-> ([(CatName, TokenDef)] -> [Doc ()])
-> [(CatName, TokenDef)]
-> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
intersperse Doc ()
forall ann. Doc ann
emptyDoc ([Doc ()] -> [Doc ()])
-> ([(CatName, TokenDef)] -> [Doc ()])
-> [(CatName, TokenDef)]
-> [Doc ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CatName, TokenDef) -> Doc ())
-> [(CatName, TokenDef)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> TokenText -> (CatName, TokenDef) -> Doc ()
printTokenInstance String
absName TokenText
tokenText)

printTokenInstance :: ModuleName -> TokenText -> (CatName,TokenDef) -> Doc ()
printTokenInstance :: String -> TokenText -> (CatName, TokenDef) -> Doc ()
printTokenInstance String
absName TokenText
tokenText (CatName
cName, TokenDef
tokenDef) =
  case TokenDef
tokenDef of
    (TokenDef PositionToken
PositionToken Regex
_ Bool
_)   ->
      Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
        [ Doc ()
"instance Print" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
forall ann. Doc ann
absModule Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
cat'
            Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"where"
        , Doc ()
"prt _" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (Doc ()
forall ann. Doc ann
absModule Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
cat' Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"(_,i)")
          Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
rhs ]
    (TokenDef PositionToken
NoPositionToken Regex
_ Bool
_) ->
      Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
        [ Doc ()
"instance Print" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
forall ann. Doc ann
absModule Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
cat'
            Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"where"
        , Doc ()
"prt _" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (Doc ()
forall ann. Doc ann
absModule Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
cat' Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"i")
          Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
rhs ]
  where
    cat' :: Doc ()
cat' = CatName -> Doc ()
parseTokenName CatName
cName
    absModule :: Doc ann
absModule = String -> Doc ann
forall a. IsString a => String -> a
fromString String
absName Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
dot
    rhs :: Doc ()
rhs = Doc ()
"=" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"token" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"Tok" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
cat' Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens
       ( if TokenText -> Bool
isStringToken TokenText
tokenText
         then Doc ()
"fromString i"
         else Doc ()
"fromString $ T.unpack i"
        )

-- | Print cateries instances for the printer.

printCatInstances :: ModuleName
                  -> Bool
                  -> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
                  -> Doc ()
printCatInstances :: String
-> Bool -> [(Type, [(Label, ([Type], (Integer, ARHS)))])] -> Doc ()
printCatInstances String
absName Bool
functor =
  [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ())
-> ([(Type, [(Label, ([Type], (Integer, ARHS)))])] -> [Doc ()])
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
intersperse Doc ()
forall ann. Doc ann
emptyDoc ([Doc ()] -> [Doc ()])
-> ([(Type, [(Label, ([Type], (Integer, ARHS)))])] -> [Doc ()])
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [Doc ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  ((Type, [(Label, ([Type], (Integer, ARHS)))]) -> Doc ())
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Type -> [(Label, ([Type], (Integer, ARHS)))] -> Doc ())
-> (Type, [(Label, ([Type], (Integer, ARHS)))]) -> Doc ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (String
-> Bool -> Type -> [(Label, ([Type], (Integer, ARHS)))] -> Doc ()
printCatInstance String
absName Bool
functor))

printCatInstance :: ModuleName
                 -> Bool
                 -> Type
                 -> [(Label, ([Type], (Integer, ARHS)))]
                 -> Doc ()
printCatInstance :: String
-> Bool -> Type -> [(Label, ([Type], (Integer, ARHS)))] -> Doc ()
printCatInstance String
absName Bool
functor Type
t [(Label, ([Type], (Integer, ARHS)))]
labelsRhs =
  Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
    [ Doc ()
"instance Print" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Type -> Doc ()
name Type
t Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"where"
    , Doc ()
instances ]
  where
    absModule :: Doc ()
absModule =  String -> Doc ()
forall a. IsString a => String -> a
fromString String
absName Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"."
    name :: Type -> Doc ()
    name :: Type -> Doc ()
name Type
tt
      | Type -> Bool
isListType Type
tt
      = if Type -> Bool
isBuiltinType Type
tt
        then Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
brackets (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ Type -> Doc ()
parseType Type
t
        else
          if Type -> Bool
isTokenType Type
tt
          then Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
brackets (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc ()
absModule Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Type -> Doc ()
parseType Type
t
          else
            if Bool
functor then
              if Type -> Bool
isIdentType Type
tt
              then Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
brackets (Doc ()
absModule Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Type -> Doc ()
parseType Type
t)
              else Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
brackets (Doc ()
absModule Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Type -> Doc ()
parseType Type
t Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"'" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"a")
            else
                Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
brackets (Doc ()
absModule Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Type -> Doc ()
parseType Type
t)
      | Bool
functor = Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc ()
absModule Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Type -> Doc ()
parseType Type
t Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"'" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"a"
      | Bool
otherwise = Doc ()
absModule Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Type -> Doc ()
parseType Type
t
    instances :: Doc ()
instances = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ ((Integer, Doc ()) -> Doc ()) -> [(Integer, Doc ())] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer, Doc ()) -> Doc ()
forall a b. (a, b) -> b
snd ([(Integer, Doc ())] -> [Doc ()])
-> [(Integer, Doc ())] -> [Doc ()]
forall a b. (a -> b) -> a -> b
$
      ((Integer, Doc ()) -> (Integer, Doc ()) -> Ordering)
-> [(Integer, Doc ())] -> [(Integer, Doc ())]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Integer -> Integer -> Ordering)
-> ((Integer, Doc ()) -> Integer)
-> (Integer, Doc ())
-> (Integer, Doc ())
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Integer, Doc ()) -> Integer
forall a b. (a, b) -> a
fst) ([(Integer, Doc ())] -> [(Integer, Doc ())])
-> [(Integer, Doc ())] -> [(Integer, Doc ())]
forall a b. (a -> b) -> a -> b
$
      ((Label, (Integer, ARHS)) -> (Integer, Doc ()))
-> [(Label, (Integer, ARHS))] -> [(Integer, Doc ())]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      (Doc () -> Bool -> (Label, (Integer, ARHS)) -> (Integer, Doc ())
printCase Doc ()
absModule Bool
functor)
      ((\(Label
l,([Type]
_,(Integer, ARHS)
tup)) -> (Label
l,(Integer, ARHS)
tup)) ((Label, ([Type], (Integer, ARHS))) -> (Label, (Integer, ARHS)))
-> [(Label, ([Type], (Integer, ARHS)))]
-> [(Label, (Integer, ARHS))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Label, ([Type], (Integer, ARHS)))]
labelsRhs)

printCase :: Doc ()
          -> Bool
          -> (Label, (Integer, ARHS))
          -> (Integer, Doc ())
printCase :: Doc () -> Bool -> (Label, (Integer, ARHS)) -> (Integer, Doc ())
printCase Doc ()
absModule Bool
functor (Label
label, (Integer
p, ARHS
arhs)) = case Label
label of
  LId CatName
_ ->
    (Integer
0, Doc ()
leftRhs Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"=" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"prPrec i" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> (Integer -> String) -> Integer -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show) Integer
p
    Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> if ARHS -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ARHS
arhs
        then Doc ()
"emptyDoc"
        else
          if ARHS -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ARHS
arhs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
          then Doc ()
"$" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep (ARHS -> [Doc ()]
rhsToPrint ARHS
arhs)
          else Doc ()
"$ hsep" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
brackets ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ ARHS -> [Doc ()]
rhsToPrint ARHS
arhs))
    where
      leftRhs :: Doc ()
leftRhs
        | [Doc ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ARHS -> [Doc ()]
printArgs ARHS
arhs)
        = if Bool
functor then
            Doc ()
"prt i" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (Doc ()
absModule Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> (Label -> String) -> Label -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> String
printLabelName) Label
label Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"_")
          else
            Doc ()
"prt i" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
absModule Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> (Label -> String) -> Label -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> String
printLabelName) Label
label
        | Bool
functor
        = Doc ()
"prt i" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"(" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
absModule Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> (Label -> String) -> Label -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> String
printLabelName) Label
label
            Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"_" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep (ARHS -> [Doc ()]
printArgs ARHS
arhs) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
")"
        | Bool
otherwise
        = Doc ()
"prt i" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"(" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
absModule Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> (Label -> String) -> Label -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> String
printLabelName) Label
label
            Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep (ARHS -> [Doc ()]
printArgs ARHS
arhs) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
")"
  LDef CatName
_ -> String -> (Integer, Doc ())
forall a. HasCallStack => String -> a
panic String
"LDef labels should have been filtered out"
  Label
LWild  -> String -> (Integer, Doc ())
forall a. HasCallStack => String -> a
panic String
"LWild labels should have been filtered out"
  Label
LNil -> (Integer
p, Doc ()
"prt" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"_" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"[]" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"=" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"emptyDoc")
  Label
LCons -> (Integer
p, Doc ()
"prt" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"_" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
lcons Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"="
      Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"hsep" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
brackets ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep (ARHS -> [Doc ()]
rhsToPrint ARHS
arhs)))
    where
      lcons :: Doc ()
lcons = Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall a. [a] -> a
head (ARHS -> [Doc ()]
printArgs ARHS
arhs) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
":" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> [Doc ()] -> Doc ()
forall a. [a] -> a
head ([Doc ()] -> [Doc ()]
forall a. [a] -> [a]
tail (ARHS -> [Doc ()]
printArgs ARHS
arhs))
  Label
LSg -> (Integer
p, Doc ()
"prt" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"_" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
brackets ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep (ARHS -> [Doc ()]
printArgs ARHS
arhs))
      Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"=" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"hsep" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
brackets ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep (ARHS -> [Doc ()]
rhsToPrint ARHS
arhs)))

rhsToPrint :: ARHS -> [Doc ()]
rhsToPrint :: ARHS -> [Doc ()]
rhsToPrint ARHS
items =
  if ARHS -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ARHS
items
  then [ Doc ()
"emptyDoc" ]
  else Doc () -> [Doc ()] -> [Doc ()]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ()
forall ann. Doc ann
comma ([Doc ()] -> [Doc ()]) -> [Doc ()] -> [Doc ()]
forall a b. (a -> b) -> a -> b
$ (String, ((String, Integer), Bool)) -> Doc ()
prtItem ((String, ((String, Integer), Bool)) -> Doc ())
-> [(String, ((String, Integer), Bool))] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
-> [((String, Integer), Bool)]
-> [(String, ((String, Integer), Bool))]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
anns [((String, Integer), Bool)]
itemsWithPrec
  where
    prtItem :: (String,((String, Integer), Bool)) -> Doc ()
    prtItem :: (String, ((String, Integer), Bool)) -> Doc ()
prtItem (String
a, ((String
s, Integer
p), Bool
b))
      | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
a = if Bool
b then Doc ()
forall ann. Doc ann
prtNT else Doc ()
forall ann. Doc ann
prtT
      | Bool
b = String -> Doc ()
forall a. IsString a => String -> a
fromString String
a Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens Doc ()
forall ann. Doc ann
prtNT
      | Bool
otherwise = String -> Doc ()
forall a. IsString a => String -> a
fromString String
a Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens Doc ()
forall ann. Doc ann
prtT
      where
        prtNT :: Doc ann
prtNT = Doc ann
"prt" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (String -> Doc ann
forall a. IsString a => String -> a
fromString (String -> Doc ann) -> (Integer -> String) -> Integer -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show) Integer
p Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall a. IsString a => String -> a
fromString String
s
        prtT :: Doc ann
prtT  = Doc ann
"fromString" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall a. IsString a => String -> a
fromString String
s
    itemsWithPrec :: [((String, Integer), Bool)]
itemsWithPrec = [(String, Integer)] -> [Bool] -> [((String, Integer), Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip (ARHS -> [(String, Integer)]
indexVars ARHS
items) (Item' CatName -> Bool
forall a. Item' a -> Bool
isNTerminal (Item' CatName -> Bool) -> ARHS -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ARHS
items)
    anns :: [String]
anns = ARHS -> [String]
annotations ARHS
items