{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.Haskell.GADT.AbstractSyntax where

import BNFC.CF

import BNFC.Backend.CommonInterface.Backend

import BNFC.Backend.Common.Utils as Utils

import BNFC.Backend.Haskell.AbstractSyntax (printFunctions)
import BNFC.Backend.Haskell.Options
import BNFC.Backend.Haskell.State
import BNFC.Backend.Haskell.GADT.ComposOp
import BNFC.Backend.Haskell.GADT.Template
import BNFC.Backend.Haskell.GADT.Utils

import BNFC.Backend.Haskell.Utilities.Utils

import BNFC.Options.GlobalOptions

import BNFC.Prelude

import Control.Monad.State

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

import Prettyprinter

import System.FilePath (takeBaseName)


haskellAbstractSyntaxGADT :: LBNF -> State HaskellBackendState Result
haskellAbstractSyntaxGADT :: LBNF -> State HaskellBackendState Result
haskellAbstractSyntaxGADT LBNF
lbnf = do
  HaskellBackendState
st <- StateT HaskellBackendState Identity HaskellBackendState
forall s (m :: * -> *). MonadState s m => m s
get
  Result
template <- LBNF -> State HaskellBackendState Result
haskellGADTTemplate LBNF
lbnf
  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
      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
      funs :: [(LabelName, Function)]
funs        = HaskellBackendState -> [(LabelName, Function)]
functions HaskellBackendState
st
      toks :: [(LabelName, TokenDef)]
toks        = HaskellBackendState -> [(LabelName, TokenDef)]
tokens HaskellBackendState
st
      tt :: TokenText
tt          = HaskellBackendOptions -> TokenText
tokenText (HaskellBackendOptions -> TokenText)
-> HaskellBackendOptions -> TokenText
forall a b. (a -> b) -> a -> b
$ HaskellBackendState -> HaskellBackendOptions
haskellOpts 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
      absSyntax :: String
absSyntax   =
        LBNF
-> String
-> Bool
-> Maybe String
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(LabelName, Function)]
-> [(LabelName, TokenDef)]
-> TokenText
-> String
cf2abs LBNF
lbnf String
cfName Bool
inDirectory Maybe String
nSpace [(Type, [(Label, ([Type], (Integer, ARHS)))])]
rules [(LabelName, Function)]
funs [(LabelName, TokenDef)]
toks TokenText
tt
      composOpPath :: String
composOpPath = Bool -> Maybe String -> String -> String -> String -> String
mkFilePath Bool
inDirectory Maybe String
nSpace String
cfName String
"ComposOp" String
"hs"
      composOpMod :: String
composOpMod  = String -> String
composOp (Bool -> Maybe String -> String -> String -> String
mkModule Bool
inDirectory Maybe String
nSpace String
cfName String
"ComposOp")
      composOpFile :: Result
composOpFile = [(String
composOpPath, String
composOpMod)]
  Result -> State HaskellBackendState Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> State HaskellBackendState Result)
-> Result -> State HaskellBackendState Result
forall a b. (a -> b) -> a -> b
$ [(Bool -> Maybe String -> String -> String -> String -> String
mkFilePath Bool
inDirectory Maybe String
nSpace String
cfName String
"Abs" String
"hs", String
absSyntax)] Result -> Result -> Result
forall a. [a] -> [a] -> [a]
++ Result
template Result -> Result -> Result
forall a. [a] -> [a] -> [a]
++ Result
composOpFile
  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)))]
filterLabelsAST [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 = LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (LabelName -> String) -> [LabelName] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map LabelName (WithPosition Function) -> [LabelName]
forall k a. Map k a -> [k]
Map.keys (LBNF -> Map LabelName (WithPosition Function)
_lbnfFunctions LBNF
lbnf)

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

cf2doc :: LBNF
       -> String
       -> Bool
       -> Maybe String
       -> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
       -> [(LabelName,Function)]
       -> [(CatName,TokenDef)]
       -> TokenText
       -> Doc ()
cf2doc :: LBNF
-> String
-> Bool
-> Maybe String
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(LabelName, Function)]
-> [(LabelName, TokenDef)]
-> TokenText
-> Doc ()
cf2doc LBNF
lbnf String
cfName Bool
inDir Maybe String
nameSpace [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules [(LabelName, Function)]
functions [(LabelName, TokenDef)]
tokens 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
$
    String -> String -> Bool -> [String] -> TokenText -> Bool -> Doc ()
prologue String
absModule String
composOpModule Bool
hasPosTokens [String]
names TokenText
tokenText Bool
emptyTree
    Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
:
    [Doc ()]
toBePrinted
  where
    composOpModule :: String
composOpModule = Bool -> Maybe String -> String -> String -> String
mkModule Bool
inDir Maybe String
nameSpace String
cfName String
"ComposOp"
    absModule :: String
absModule      = Bool -> Maybe String -> String -> String -> String
mkModule Bool
inDir Maybe String
nameSpace String
cfName String
"Abs"

    dataNames :: [String]
dataNames      = Type -> String
printTypeName (Type -> String)
-> ((Type, [(Label, ([Type], (Integer, ARHS)))]) -> Type)
-> (Type, [(Label, ([Type], (Integer, ARHS)))])
-> String
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)))]) -> String)
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules
    tokenNames :: [String]
tokenNames     = LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (LabelName -> String)
-> ((LabelName, TokenDef) -> LabelName)
-> (LabelName, TokenDef)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LabelName, TokenDef) -> LabelName
forall a b. (a, b) -> a
fst ((LabelName, TokenDef) -> String)
-> [(LabelName, TokenDef)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(LabelName, TokenDef)]
tokens
    funNames :: [String]
funNames       = LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (LabelName -> String)
-> ((LabelName, Function) -> LabelName)
-> (LabelName, Function)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LabelName, Function) -> LabelName
forall a b. (a, b) -> a
fst ((LabelName, Function) -> String)
-> [(LabelName, Function)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(LabelName, Function)]
functions
    names :: [String]
names          = [String]
dataNames [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
tokenNames [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
funNames

    hasData :: Bool
hasData        = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Type, [(Label, ([Type], (Integer, ARHS)))])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules
    hasFunctions :: Bool
hasFunctions   = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(LabelName, Function)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LabelName, Function)]
functions
    hasTokens :: Bool
hasTokens      = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(LabelName, TokenDef)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LabelName, TokenDef)]
tokens
    hasPosTokens :: Bool
hasPosTokens   = (WithPosition TokenDef -> Bool)
-> Map LabelName (WithPosition TokenDef) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any WithPosition TokenDef -> Bool
isPositionToken (LBNF -> Map LabelName (WithPosition TokenDef)
_lbnfTokenDefs LBNF
lbnf)

    emptyTree :: Bool
emptyTree      = Bool -> Bool
not (Bool
hasData Bool -> Bool -> Bool
|| Bool
hasTokens Bool -> Bool -> Bool
|| Bool
hasFunctions)

    usedBuiltins :: [String]
usedBuiltins   = (BuiltinCat -> String) -> [BuiltinCat] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (LabelName -> String)
-> (BuiltinCat -> LabelName) -> BuiltinCat -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinCat -> LabelName
printBuiltinCat) (Map BuiltinCat (List1 Position) -> [BuiltinCat]
forall k a. Map k a -> [k]
Map.keys (Map BuiltinCat (List1 Position) -> [BuiltinCat])
-> Map BuiltinCat (List1 Position) -> [BuiltinCat]
forall a b. (a -> b) -> a -> b
$ LBNF -> Map BuiltinCat (List1 Position)
_lbnfASTBuiltins LBNF
lbnf)

    labelsArhss :: [(Label, ARHS)]
    labelsArhss :: [(Label, ARHS)]
labelsArhss = (\(Label
l,([Type]
_,(Integer, ARHS)
tup)) -> (Label
l, (Integer, ARHS) -> ARHS
forall a b. (a, b) -> b
snd (Integer, ARHS)
tup)) ((Label, ([Type], (Integer, ARHS))) -> (Label, ARHS))
-> [(Label, ([Type], (Integer, ARHS)))] -> [(Label, ARHS)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Type, [(Label, ([Type], (Integer, ARHS)))])
 -> [(Label, ([Type], (Integer, ARHS)))])
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(Label, ([Type], (Integer, ARHS)))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Type, [(Label, ([Type], (Integer, ARHS)))])
-> [(Label, ([Type], (Integer, ARHS)))]
forall a b. (a, b) -> b
snd [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules

    labelsTypes :: [(Label, [Type])]
    labelsTypes :: [(Label, [Type])]
labelsTypes =
      ((Label, ([Type], (Integer, ARHS))) -> (Label, [Type]))
-> [(Label, ([Type], (Integer, ARHS)))] -> [(Label, [Type])]
forall a b. (a -> b) -> [a] -> [b]
map
      (\(Label
l,([Type]
ts,(Integer, ARHS)
_)) -> (Label
l,[Type]
ts))
      (((Type, [(Label, ([Type], (Integer, ARHS)))])
 -> [(Label, ([Type], (Integer, ARHS)))])
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(Label, ([Type], (Integer, ARHS)))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Type, [(Label, ([Type], (Integer, ARHS)))])
-> [(Label, ([Type], (Integer, ARHS)))]
forall a b. (a, b) -> b
snd [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules)

    dataAndInstances :: Maybe (Doc ())
dataAndInstances =
      if Bool -> Bool
not ([(Type, [(Label, ([Type], (Integer, ARHS)))])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules) Bool -> Bool -> Bool
|| Bool -> Bool
not ([(LabelName, TokenDef)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LabelName, TokenDef)]
tokens)
      then Doc () -> Maybe (Doc ())
forall a. a -> Maybe a
Just (Doc () -> Maybe (Doc ())) -> Doc () -> Maybe (Doc ())
forall a b. (a -> b) -> a -> b
$ [String] -> Doc ()
printData [String]
names
      else Maybe (Doc ())
forall a. Maybe a
Nothing

    tree :: Maybe (Doc ())
tree =
      if Bool -> Bool
not ([(Type, [(Label, ([Type], (Integer, ARHS)))])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules) Bool -> Bool -> Bool
|| Bool -> Bool
not ([(LabelName, TokenDef)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LabelName, TokenDef)]
tokens)
      then Doc () -> Maybe (Doc ())
forall a. a -> Maybe a
Just (Doc () -> Maybe (Doc ())) -> Doc () -> Maybe (Doc ())
forall a b. (a -> b) -> a -> b
$ [String]
-> TokenText
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(LabelName, TokenDef)]
-> Doc ()
printTree [String]
usedBuiltins TokenText
tokenText [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules [(LabelName, TokenDef)]
tokens
      else Maybe (Doc ())
forall a. Maybe a
Nothing

    compos :: Maybe (Doc ())
compos =
      if Bool -> Bool
not ([(Type, [(Label, ([Type], (Integer, ARHS)))])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules) Bool -> Bool -> Bool
|| Bool -> Bool
not ([(LabelName, TokenDef)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LabelName, TokenDef)]
tokens)
      then Doc () -> Maybe (Doc ())
forall a. a -> Maybe a
Just (Doc () -> Maybe (Doc ())) -> Doc () -> Maybe (Doc ())
forall a b. (a -> b) -> a -> b
$ [(Label, ARHS)] -> Doc ()
composInstances [(Label, ARHS)]
labelsArhss
      else Maybe (Doc ())
forall a. Maybe a
Nothing

    shws :: Maybe (Doc ())
shws =
      if Bool -> Bool
not ([(Type, [(Label, ([Type], (Integer, ARHS)))])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules) Bool -> Bool -> Bool
|| Bool -> Bool
not ([(LabelName, TokenDef)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LabelName, TokenDef)]
tokens)
      then Doc () -> Maybe (Doc ())
forall a. a -> Maybe a
Just (Doc () -> Maybe (Doc ())) -> Doc () -> Maybe (Doc ())
forall a b. (a -> b) -> a -> b
$ [(Label, ARHS)] -> [(LabelName, TokenDef)] -> Doc ()
showInstances [(Label, ARHS)]
labelsArhss [(LabelName, TokenDef)]
tokens
      else Maybe (Doc ())
forall a. Maybe a
Nothing

    eqInst :: Maybe (Doc ())
eqInst = Doc () -> Maybe (Doc ())
forall a. a -> Maybe a
Just Doc ()
eqInstance

    ordInst :: Maybe (Doc ())
ordInst = Doc () -> Maybe (Doc ())
forall a. a -> Maybe a
Just Doc ()
ordInstance

    index :: Maybe (Doc ())
index =
      if Bool -> Bool
not ([(Type, [(Label, ([Type], (Integer, ARHS)))])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules) Bool -> Bool -> Bool
|| Bool -> Bool
not ([(LabelName, TokenDef)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LabelName, TokenDef)]
tokens)
      then Doc () -> Maybe (Doc ())
forall a. a -> Maybe a
Just (Doc () -> Maybe (Doc ())) -> Doc () -> Maybe (Doc ())
forall a b. (a -> b) -> a -> b
$ [(Label, [Type])] -> [String] -> Doc ()
indexes [(Label, [Type])]
labelsTypes [String]
tokenNames
      else Maybe (Doc ())
forall a. Maybe a
Nothing

    jmEq :: Maybe (Doc ())
jmEq =
      if Bool -> Bool
not ([(Type, [(Label, ([Type], (Integer, ARHS)))])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules) Bool -> Bool -> Bool
|| Bool -> Bool
not ([(LabelName, TokenDef)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LabelName, TokenDef)]
tokens)
      then Doc () -> Maybe (Doc ())
forall a. a -> Maybe a
Just (Doc () -> Maybe (Doc ())) -> Doc () -> Maybe (Doc ())
forall a b. (a -> b) -> a -> b
$ [(Label, ARHS)] -> [(LabelName, TokenDef)] -> Doc ()
johnMajorEq [(Label, ARHS)]
labelsArhss [(LabelName, TokenDef)]
tokens
      else Maybe (Doc ())
forall a. Maybe a
Nothing

    cmpSame :: Maybe (Doc ())
cmpSame =
      if Bool -> Bool
not ([(Type, [(Label, ([Type], (Integer, ARHS)))])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules) Bool -> Bool -> Bool
|| Bool -> Bool
not ([(LabelName, TokenDef)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LabelName, TokenDef)]
tokens)
      then Doc () -> Maybe (Doc ())
forall a. a -> Maybe a
Just (Doc () -> Maybe (Doc ())) -> Doc () -> Maybe (Doc ())
forall a b. (a -> b) -> a -> b
$ [(Label, ARHS)] -> [(LabelName, TokenDef)] -> Doc ()
compareSame [(Label, ARHS)]
labelsArhss [(LabelName, TokenDef)]
tokens
      else Maybe (Doc ())
forall a. Maybe a
Nothing

    funs :: Maybe (Doc ())
funs =
      if [(LabelName, Function)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LabelName, Function)]
functions
      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
$ Bool -> [(LabelName, Function)] -> Doc ()
printFunctions Bool
False [(LabelName, Function)]
functions

    toBePrinted :: [Doc ()]
toBePrinted = [Maybe (Doc ())] -> [Doc ()]
forall a. [Maybe a] -> [a]
catMaybes
      [Maybe (Doc ())
dataAndInstances, Maybe (Doc ())
tree, Maybe (Doc ())
compos, Maybe (Doc ())
shws, Maybe (Doc ())
eqInst, Maybe (Doc ())
ordInst, Maybe (Doc ())
index, Maybe (Doc ())
jmEq, Maybe (Doc ())
cmpSame, Maybe (Doc ())
funs]

prologue :: ModuleName
         -> ModuleName
         -> Bool
         -> [String]
         -> TokenText
         -> Bool
         -> Doc ()
prologue :: String -> String -> Bool -> [String] -> TokenText -> Bool -> Doc ()
prologue String
absName String
compOpName Bool
hasPosTokens [String]
toExport TokenText
tokenText Bool
emptyTree = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"-- For GHC version 7.10 or higher"
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Bool -> Doc ()
pragmas Bool
emptyTree
  , 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 String
absName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
exports Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"where"
  , Doc ()
forall ann. Doc ann
emptyDoc
  , String -> Bool -> TokenText -> Doc ()
imports String
compOpName Bool
hasPosTokens TokenText
tokenText
  ]
  where
    exports :: Doc ()
    exports :: Doc ()
exports = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
tupled ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ --parens $ hsep $ intersperse comma $
      [ if Bool
emptyTree then Doc ()
"Tree" else Doc ()
"Tree(..)" ] [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++ (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> [String] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
toExport) [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++
      [ Doc ()
"johnMajorEq", Doc ()
"module" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
compOpName ]

pragmas :: Bool -> Doc ()
pragmas :: Bool -> Doc ()
pragmas Bool
emptyTree = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$
  [ Doc ()
"{-# LANGUAGE GADTs, KindSignatures, DataKinds #-}" ]
  [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++
  Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when Bool
emptyTree [ Doc ()
"{-# LANGUAGE EmptyCase #-}" ]
  [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++
  [Doc ()
"{-# LANGUAGE LambdaCase #-}"]
  [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++
  [ Doc ()
forall ann. Doc ann
emptyDoc
  , Doc ()
"{-# OPTIONS_GHC -fno-warn-unused-binds #-}"
    -- unused-local-binds would be sufficient, but parses only from GHC 8.0
  , Doc ()
"{-# OPTIONS_GHC -fno-warn-unused-imports #-}"
  , Doc ()
"{-# OPTIONS_GHC -fno-warn-unused-matches #-}"
  , Doc ()
"{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}"
    -- defects of coverage checker, e.g. in 8.2.2, may lead to warning
    -- about exceeded iterations for pattern match checker
  , Doc ()
"{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}"
  ]

imports :: ModuleName -> Bool -> TokenText -> Doc ()
imports :: String -> Bool -> TokenText -> Doc ()
imports String
compOpName Bool
hasPosTokens TokenText
tokenText = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$
  [ Doc ()
"import Prelude ((.), (>), (&&), (==))"
  , if Bool
hasPosTokens
    then Doc ()
"import Prelude" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
tupled (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> [String] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String
"Int" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [ String
"(.)", String
"(>)", String
"(&&)", String
"(==)"]))
    else Doc ()
"import Prelude" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
tupled (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> [String] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ String
"(.)", String
"(>)", String
"(&&)", String
"(==)"])
  , Doc ()
"import qualified Prelude as P"
  , Doc ()
forall ann. Doc ann
emptyDoc
  , Doc ()
"import" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
compOpName
  ]
  [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++ Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (TokenText
tokenText TokenText -> TokenText -> Bool
forall a. Eq a => a -> a -> Bool
== TokenText
TextToken)
  [ Doc ()
forall ann. Doc ann
emptyDoc
  , TokenText -> Doc ()
tokenTextImport TokenText
tokenText
  ]

-- Dummy types.
printData :: [String]
          -> Doc ()
printData :: [String] -> Doc ()
printData [String]
names = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"data Tag =" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ([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
pipe) (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> (String -> String) -> String -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_") (String -> Doc ()) -> [String] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
names)
  , [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ String -> Doc ()
mkType (String -> Doc ()) -> [String] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
names
  ]
  where
    mkType :: String -> Doc ()
    mkType :: String -> Doc ()
mkType String
name = Doc ()
"type" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString String
name Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"=" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"Tree" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      String -> Doc ()
forall a. IsString a => String -> a
fromString (String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_")

-- Print Tree data type.
printTree :: [String]
          -> TokenText
          -> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
          -> [(CatName,TokenDef)]
          -> Doc ()
printTree :: [String]
-> TokenText
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
-> [(LabelName, TokenDef)]
-> Doc ()
printTree [String]
usedBuiltins TokenText
tokenText [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules [(LabelName, TokenDef)]
tokens = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"data Tree (a :: Tag) where"
  , 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 ()
forall ann. [Doc ann] -> Doc ann
vsep
    [ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ (Type, [(Label, ([Type], (Integer, ARHS)))]) -> Doc ()
catField ((Type, [(Label, ([Type], (Integer, ARHS)))]) -> Doc ())
-> [(Type, [(Label, ([Type], (Integer, ARHS)))])] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
astRules
    , [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ (LabelName, TokenDef) -> Doc ()
tokenField ((LabelName, TokenDef) -> Doc ())
-> [(LabelName, TokenDef)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(LabelName, TokenDef)]
tokens
    ]
  ]
  where
    catField :: (Type, [(Label, ([Type], (Integer, ARHS)))]) -> Doc ()
    catField :: (Type, [(Label, ([Type], (Integer, ARHS)))]) -> Doc ()
catField (Type
t, [(Label, ([Type], (Integer, ARHS)))]
ls) = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ (Label, ([Type], (Integer, ARHS))) -> Doc ()
printCase ((Label, ([Type], (Integer, ARHS))) -> Doc ())
-> [(Label, ([Type], (Integer, ARHS)))] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Label, ([Type], (Integer, ARHS)))]
ls
      where
        printCase :: (Label, ([Type], (Integer, ARHS))) -> Doc ()
        printCase :: (Label, ([Type], (Integer, ARHS))) -> Doc ()
printCase (Label
l, ([Type]
ts, (Integer, ARHS)
_)) = String -> Doc ()
forall a. IsString a => String -> a
fromString (Label -> String
printLabelName Label
l) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"::" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
          if [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
ts
          then Doc ()
"Tree" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString (String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
printTypeName Type
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_")
          else ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ([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 ()
"->") (Type -> Doc ()
printType (Type -> Doc ()) -> [Type] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
ts) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
          Doc ()
"-> Tree" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString (String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
printTypeName Type
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_")

        printType :: Type -> Doc ()
        printType :: Type -> Doc ()
printType Type
ty =
          Bool -> (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a. Bool -> (a -> a) -> a -> a
applyWhen (Type -> Bool
isListType Type
ty) Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
brackets (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$
          Bool -> (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a. Bool -> (a -> a) -> a -> a
applyWhen (Type -> Bool
isTypeBuiltin Type
ty) Doc () -> Doc ()
addQualified (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$
          String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ Type -> String
printTypeName Type
ty

        applyWhen :: Bool -> (a -> a) -> a -> a
        applyWhen :: Bool -> (a -> a) -> a -> a
applyWhen Bool
True  a -> a
f a
x = a -> a
f a
x
        applyWhen Bool
False a -> a
_ a
x = a
x
        addQualified :: Doc () -> Doc ()
        addQualified :: Doc () -> Doc ()
addQualified Doc ()
name = Doc ()
"P." Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
name
        isTypeBuiltin :: Type -> Bool
        isTypeBuiltin :: Type -> Bool
isTypeBuiltin Type
ty = Type -> String
printTypeName Type
ty String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
usedBuiltins

    tokenField :: (CatName,TokenDef) -> Doc ()
    tokenField :: (LabelName, TokenDef) -> Doc ()
tokenField (LabelName
cName, TokenDef PositionToken
PositionToken Regex
_ Bool
_) =
      (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> (LabelName -> String) -> LabelName -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) LabelName
cName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
":: ((Int,Int)," Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"P." Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> TokenText -> Doc ()
tokenTextType TokenText
tokenText Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
") ->" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      Doc ()
"Tree" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> (String -> String) -> String -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) (String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList LabelName
cName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_")
    tokenField (LabelName
cName, TokenDef PositionToken
NoPositionToken Regex
_ Bool
_) =
      (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> (LabelName -> String) -> LabelName -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) LabelName
cName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"::" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"P." Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> TokenText -> Doc ()
tokenTextType TokenText
tokenText Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
" ->" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"Tree" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      (String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> (String -> String) -> String -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) (String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList LabelName
cName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_")

-- Compos instances for a category.
composInstances :: [(Label, ARHS)] -> Doc ()
composInstances :: [(Label, ARHS)] -> Doc ()
composInstances [(Label, ARHS)]
labelsArhss = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$
  [ Doc ()
"instance Compos Tree where"
  , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"compos r a f = \\case"
  , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ (Label, ARHS) -> Doc ()
treeCase ((Label, ARHS) -> Doc ()) -> [(Label, ARHS)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Label, ARHS) -> Bool) -> [(Label, ARHS)] -> [(Label, ARHS)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Label, ARHS) -> Bool
isTreeType [(Label, ARHS)]
labelsArhss
  ]
  [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++
  Bool -> [Doc ()] -> [Doc ()]
forall m. Monoid m => Bool -> m -> m
Utils.when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ((Label, ARHS) -> Bool) -> [(Label, ARHS)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Label, ARHS) -> Bool
isTreeType [(Label, ARHS)]
labelsArhss) [ Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 Doc ()
"t -> r t" ]
  where

    treeCase :: (Label, ARHS) -> Doc ()
    treeCase :: (Label, ARHS) -> Doc ()
treeCase (Label
l, ARHS
arhs) = Doc ()
label Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep [Doc ()]
args Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"->" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"r" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
label Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"`a`" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ([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 ()
"`a`") ((Doc (), Bool, Bool) -> Doc ()
printRhs ((Doc (), Bool, Bool) -> Doc ())
-> [(Doc (), Bool, Bool)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Doc ()] -> [Bool] -> [Bool] -> [(Doc (), Bool, Bool)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Doc ()]
args [Bool]
listArgs [Bool]
builtinArgs)

      where

      printRhs :: (Doc (), Bool, Bool) -> Doc ()
      printRhs :: (Doc (), Bool, Bool) -> Doc ()
printRhs (Doc ()
arg, Bool
False, Bool
True ) = Doc ()
"r" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
arg
      printRhs (Doc ()
arg, Bool
True, Bool
True ) = Doc ()
"r" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
arg
      printRhs (Doc ()
arg, Bool
True, Bool
False) =
        Doc ()
"P.foldr (\\ x z -> r (:) `a` f x `a` z) (r [])" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
arg
      printRhs (Doc ()
arg, Bool
_, Bool
_ ) = Doc ()
"f" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
arg

      label :: Doc ()
      label :: Doc ()
label = String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ Label -> String
printLabelName Label
l

      args :: [Doc ()]
      args :: [Doc ()]
args = ARHS -> [Doc ()]
printArgs ARHS
arhs

      -- Does an argument come from a list category.
      listArgs :: [Bool]
      listArgs :: [Bool]
listArgs = Item' LabelName -> Bool
forall a. Item' a -> Bool
isItemListCat (Item' LabelName -> Bool) -> ARHS -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Item' LabelName -> Bool) -> ARHS -> ARHS
forall a. (a -> Bool) -> [a] -> [a]
filter Item' LabelName -> Bool
forall a. Item' a -> Bool
isNTerminal ARHS
arhs

      -- Does an argument come from a builtin category.
      builtinArgs :: [Bool]
      builtinArgs :: [Bool]
builtinArgs = Item' LabelName -> Bool
forall a. Item' a -> Bool
isItemBuiltin (Item' LabelName -> Bool) -> ARHS -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Item' LabelName -> Bool) -> ARHS -> ARHS
forall a. (a -> Bool) -> [a] -> [a]
filter Item' LabelName -> Bool
forall a. Item' a -> Bool
isNTerminal ARHS
arhs


showInstances :: [(Label, ARHS)]
              -> [(CatName,TokenDef)]
              -> Doc ()
showInstances :: [(Label, ARHS)] -> [(LabelName, TokenDef)] -> Doc ()
showInstances [(Label, ARHS)]
labelsArhss [(LabelName, TokenDef)]
tokens = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"instance P.Show (Tree c) where"
  , 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 ()
forall ann. [Doc ann] -> Doc ann
vsep
    [Doc ()
"showsPrec n = \\case"
    , 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 ()
forall ann. [Doc ann] -> Doc ann
vsep
      [ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ (LabelName, TokenDef) -> Doc ()
tokenInstance ((LabelName, TokenDef) -> Doc ())
-> [(LabelName, TokenDef)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(LabelName, TokenDef)]
tokens
      , [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ (Label, ARHS) -> Doc ()
catInstance ((Label, ARHS) -> Doc ()) -> [(Label, ARHS)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Label, ARHS)]
labelsArhss
      , Doc ()
"where"
      , Doc ()
"opar = if n > 0 then P.showChar '(' else P.id"
      , Doc ()
"cpar = if n > 0 then P.showChar ')' else P.id"
      ]
    ]
  ]

  where

    catInstance :: (Label, ARHS) -> Doc ()
    catInstance :: (Label, ARHS) -> Doc ()
catInstance (Label
l, ARHS
arhs) = Doc ()
label Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      if [Doc ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc ()]
args
      then Doc ()
"-> P.showString" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
dquotes Doc ()
label
      else [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep [Doc ()]
args Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"->" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
rhs

      where

      rhs :: Doc ()
      rhs :: Doc ()
rhs = if [Doc ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc ()]
args
        then Doc ()
"P.showString" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
dquotes Doc ()
label
        else Doc ()
"opar . P.showString" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
dquotes Doc ()
label Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
forall ann. Doc ann
dot Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
          ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ([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
dot) (Doc () -> Doc ()
printArg (Doc () -> Doc ()) -> [Doc ()] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Doc ()]
args) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
". cpar"

      printArg :: Doc () -> Doc ()
      printArg :: Doc () -> Doc ()
printArg Doc ()
arg = Doc ()
"P.showChar ' ' . P.showsPrec 1" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
arg

      label :: Doc ()
      label :: Doc ()
label = String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ Label -> String
printLabelName Label
l

      args :: [Doc ()]
      args :: [Doc ()]
args  = ARHS -> [Doc ()]
printArgs ARHS
arhs

    tokenInstance :: (CatName,TokenDef) -> Doc ()
    tokenInstance :: (LabelName, TokenDef) -> Doc ()
tokenInstance (LabelName
cName, TokenDef
_)   = String -> Doc ()
forall a. IsString a => String -> a
fromString (LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList LabelName
cName) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"str" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"->" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      Doc ()
"opar . P.showString" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
dquotes (String -> Doc ()
forall a. IsString a => String -> a
fromString (LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList LabelName
cName)) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
". P.showChar ' ' . P.showsPrec 1 str . cpar"

eqInstance :: Doc ()
eqInstance :: Doc ()
eqInstance = Doc ()
"instance P.Eq (Tree c) where (==) = johnMajorEq"

ordInstance :: Doc ()
ordInstance :: Doc ()
ordInstance = Doc ()
"instance P.Ord (Tree c) where compare x y = P.compare (index x) (index y) `P.mappend` compareSame x y"

johnMajorEq :: [(Label, ARHS)] -> [(CatName,TokenDef)] -> Doc ()
johnMajorEq :: [(Label, ARHS)] -> [(LabelName, TokenDef)] -> Doc ()
johnMajorEq [(Label, ARHS)]
labelsRhss [(LabelName, TokenDef)]
tokens = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"johnMajorEq :: Tree a -> Tree b -> P.Bool"
  , [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ (Label, ARHS) -> Doc ()
catCase ((Label, ARHS) -> Doc ()) -> [(Label, ARHS)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Label, ARHS)]
labelsRhss
  , [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ (LabelName, TokenDef) -> Doc ()
tokenCase ((LabelName, TokenDef) -> Doc ())
-> [(LabelName, TokenDef)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(LabelName, TokenDef)]
tokens
  , Doc ()
"johnMajorEq _ _ = P.False"
  ]
  where
    catCase :: (Label, ARHS) -> Doc ()
    catCase :: (Label, ARHS) -> Doc ()
catCase (Label
l,ARHS
arhs) = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep
      [ Doc ()
"johnMajorEq"
      , if [Doc ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc ()]
args
        then [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep [ Doc ()
label, Doc ()
label, Doc ()
"= P.True"]
        else [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep
          [ Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (Doc ()
label Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep [Doc ()]
args)
          , Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (Doc ()
label Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ((Doc () -> Doc ()) -> [Doc ()] -> [Doc ()]
forall a b. (a -> b) -> [a] -> [b]
map (Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"_") [Doc ()]
args))
          , Doc ()
"="
          , ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ([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 ()
"&&") (Doc () -> Doc ()
eq (Doc () -> Doc ()) -> [Doc ()] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Doc ()]
args)
          ]
      ]
      where
        eq :: Doc() -> Doc ()
        eq :: Doc () -> Doc ()
eq Doc ()
arg = Doc ()
arg Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"==" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
arg Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"_"
        label :: Doc ()
        label :: Doc ()
label = String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ Label -> String
printLabelName Label
l
        args :: [Doc ()]
        args :: [Doc ()]
args = ARHS -> [Doc ()]
printArgs ARHS
arhs

    tokenCase :: (CatName,TokenDef) -> Doc ()
    tokenCase :: (LabelName, TokenDef) -> Doc ()
tokenCase (LabelName
cName, TokenDef
_) = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep
      [ Doc ()
"johnMajorEq"
      , Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (Doc ()
tokenName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"str")
      , Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (Doc ()
tokenName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"str_")
      , Doc ()
"= str == str_"
      ]
      where
        tokenName :: Doc ()
        tokenName :: Doc ()
tokenName = String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList LabelName
cName

indexes :: [(Label, [Type])] -> [String] -> Doc ()
indexes :: [(Label, [Type])] -> [String] -> Doc ()
indexes [(Label, [Type])]
labelsTypes [String]
tokNames = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"index :: Tree c -> P.Int"
  , Doc ()
indexCases
  ]
  where
    indexCases :: Doc ()
    indexCases :: Doc ()
indexCases = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$
      (\(Doc ()
d,Integer
i) -> Doc ()
"index" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
d Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"=" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a. IsString a => String -> a
fromString (Integer -> String
forall a. Show a => a -> String
show Integer
i))
      ((Doc (), Integer) -> Doc ()) -> [(Doc (), Integer)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      [Doc ()] -> [Integer] -> [(Doc (), Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Label, [Type]) -> Doc ()
catArg ((Label, [Type]) -> Doc ()) -> [(Label, [Type])] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Label, [Type])]
labelsTypes) [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++ (String -> Doc ()
tokArg (String -> Doc ()) -> [String] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
tokNames)) [(Integer
1::Integer)..]

    catArg :: (Label, [Type]) -> Doc ()
    catArg :: (Label, [Type]) -> Doc ()
catArg (Label
l, [Type]
ts) = Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens ( String -> Doc ()
forall a. IsString a => String -> a
fromString (Label -> String
printLabelName Label
l) Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep (Int -> Doc () -> [Doc ()]
forall a. Int -> a -> [a]
replicate ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts) Doc ()
"_") )

    tokArg :: String -> Doc ()
    tokArg :: String -> Doc ()
tokArg String
cName = Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens ( String -> Doc ()
forall a. IsString a => String -> a
fromString String
cName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"_")

compareSame :: [(Label, ARHS)] -> [(CatName,TokenDef)] -> Doc ()
compareSame :: [(Label, ARHS)] -> [(LabelName, TokenDef)] -> Doc ()
compareSame [(Label, ARHS)]
labelsRhss [(LabelName, TokenDef)]
tokens = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"compareSame :: Tree c -> Tree c -> P.Ordering"
  , [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ (Label, ARHS) -> Doc ()
catCase ((Label, ARHS) -> Doc ()) -> [(Label, ARHS)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Label, ARHS)]
labelsRhss
  , [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ (LabelName, TokenDef) -> Doc ()
tokenCase ((LabelName, TokenDef) -> Doc ())
-> [(LabelName, TokenDef)] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(LabelName, TokenDef)]
tokens
  , Doc ()
"compareSame _ _ = P.error \"BNFC error: compareSame\""
  ]
  where
    catCase :: (Label, ARHS) -> Doc ()
    catCase :: (Label, ARHS) -> Doc ()
catCase (Label
l,ARHS
arhs) = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep
      [ Doc ()
"compareSame"
      , if [Doc ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc ()]
args
        then [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep [ Doc ()
label, Doc ()
label, Doc ()
"= P.EQ"]
        else [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep
          [ Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (Doc ()
label Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep [Doc ()]
args)
          , Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (Doc ()
label Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep ((Doc () -> Doc ()) -> [Doc ()] -> [Doc ()]
forall a b. (a -> b) -> [a] -> [b]
map (Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"_") [Doc ()]
args))
          , Doc ()
"="
          , [Doc ()] -> Doc ()
rhs ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc () -> Doc ()
comp (Doc () -> Doc ()) -> [Doc ()] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Doc ()]
args
          ]
      ]
      where

        rhs :: [Doc ()] -> Doc ()
        rhs :: [Doc ()] -> Doc ()
rhs []  = String -> Doc ()
forall a. HasCallStack => String -> a
panic String
"Arguments lost shouldn't be empty."
        rhs [Doc ()
a] = Doc ()
a
        rhs (Doc ()
a:Doc ()
a1:[]) = Doc ()
"P.mappend" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens Doc ()
a Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens Doc ()
a1
        rhs (Doc ()
a:Doc ()
a1:[Doc ()]
a2) = Doc ()
"P.mappend" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens Doc ()
a Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
          Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens ( Doc ()
"P.mappend" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens Doc ()
a1 Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens ([Doc ()] -> Doc ()
rhs [Doc ()]
a2))

        comp :: Doc() -> Doc ()
        comp :: Doc () -> Doc ()
comp Doc ()
arg = Doc ()
"P.compare" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
arg Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
arg Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"_"

        label :: Doc ()
        label :: Doc ()
label = String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ Label -> String
printLabelName Label
l

        args :: [Doc ()]
        args :: [Doc ()]
args = ARHS -> [Doc ()]
printArgs ARHS
arhs

    tokenCase :: (CatName,TokenDef) -> Doc ()
    tokenCase :: (LabelName, TokenDef) -> Doc ()
tokenCase (LabelName
c,TokenDef
_) = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
hsep
      [ Doc ()
"compareSame"
      , Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (Doc ()
tokenName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"str")
      , Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (Doc ()
tokenName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
"str_")
      , Doc ()
"= P.compare str str_"
      ]
      where
        tokenName :: Doc ()
        tokenName :: Doc ()
tokenName = String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ LabelName -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList LabelName
c