{-
    BNF Converter: Pretty-printer generator
    Copyright (C) 2004  Author:  Aarne Ranta

-}

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module BNFC.Backend.Haskell.CFtoPrinter (cf2Printer, compareRules) where

import Prelude hiding ((<>))

import BNFC.Backend.Haskell.Utils
import BNFC.CF
import BNFC.Options (TokenText(..))
import BNFC.Utils

import Data.Char     (toLower)
import Data.Either   (lefts)
import Data.Function (on)
import Data.List     (sortBy, intersperse)

-- import Debug.Trace (trace)
import Text.PrettyPrint

-- AR 15/2/2002

type AbsMod = String

-- | Derive pretty-printer from a BNF grammar.
cf2Printer
  :: TokenText  -- ^ Are identifiers @ByteString@s or @Text@ rather than @String@s?  (Option @--bytestrings@ and @--text@)
  -> Bool    -- ^ Option @--functor@?
  -> Bool    -- ^ @--haskell-gadt@?
  -> String  -- ^ Name of created Haskell module.
  -> AbsMod  -- ^ Name of Haskell module for abstract syntax.
  -> CF      -- ^ Grammar.
  -> String
cf2Printer :: TokenText -> Bool -> Bool -> String -> String -> CF -> String
cf2Printer TokenText
tokenText Bool
functor Bool
useGadt String
name String
absMod CF
cf = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$
  -- Each of the following list entries is itself a list of lines
  [ TokenText -> Bool -> String -> String -> [String]
prologue TokenText
tokenText Bool
useGadt String
name String
absMod
  , String -> CF -> [String]
integerRule String
absMod CF
cf
  , String -> CF -> [String]
doubleRule String
absMod CF
cf
  , if CF -> Bool
forall f. CFG f -> Bool
hasIdent CF
cf then String -> TokenText -> CF -> [String]
identRule String
absMod TokenText
tokenText CF
cf else []
  ] [[String]] -> [[String]] -> [[String]]
forall a. [a] -> [a] -> [a]
++ [ String -> TokenText -> CF -> String -> [String]
ownPrintRule String
absMod TokenText
tokenText CF
cf String
own | (String
own,Reg
_) <- CF -> [(String, Reg)]
forall f. CFG f -> [(String, Reg)]
tokenPragmas CF
cf ] [[String]] -> [[String]] -> [[String]]
forall a. [a] -> [a] -> [a]
++
  [ String -> Bool -> CF -> [String]
rules String
absMod Bool
functor CF
cf
  ]


prologue :: TokenText -> Bool -> String -> AbsMod -> [String]
prologue :: TokenText -> Bool -> String -> String -> [String]
prologue TokenText
tokenText Bool
useGadt String
name String
absMod = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ String
"{-# LANGUAGE CPP #-}"
    , String
"#if __GLASGOW_HASKELL__ <= 708"
    , String
"{-# LANGUAGE OverlappingInstances #-}"
    , String
"#endif"
    ]
  , [ String
"{-# LANGUAGE GADTs, TypeSynonymInstances #-}" | Bool
useGadt ]
  , [ String
"{-# LANGUAGE FlexibleInstances #-}"
    , String
"{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}"
    , String
""
    , String
"-- | Pretty-printer for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char
'.' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=) String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
    , String
"--   Generated by the BNF converter."
    , String
""
    , String
"module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
+++ String
"where"
    , String
""
    , String
"import qualified " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
absMod
    , String
"import Data.Char"
    ]
  , TokenText -> [String]
tokenTextImport TokenText
tokenText
  , [ String
""
    , String
"-- | The top-level printing method."
    , String
""
    , String
"printTree :: Print a => a -> String"
    , String
"printTree = render . prt 0"
    , String
""
    , String
"type Doc = [ShowS] -> [ShowS]"
    , String
""
    , String
"doc :: ShowS -> Doc"
    , String
"doc = (:)"
    , String
""
    , String
"render :: Doc -> String"
    , String
"render d = rend 0 (map ($ \"\") $ d []) \"\" where"
    , String
"  rend i ss = case ss of"
    , String
"    \"[\"      :ts -> showChar '[' . rend i ts"
    , String
"    \"(\"      :ts -> showChar '(' . rend i ts"
    , String
"    \"{\"      :ts -> showChar '{' . new (i+1) . rend (i+1) ts"
    , String
"    \"}\" : \";\":ts -> new (i-1) . space \"}\" . showChar ';' . new (i-1) . rend (i-1) ts"
    , String
"    \"}\"      :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts"
    , String
"    [\";\"]        -> showChar ';'"
    , String
"    \";\"      :ts -> showChar ';' . new i . rend i ts"
    , String
"    t  : ts@(p:_) | closingOrPunctuation p -> showString t . rend i ts"
    , String
"    t        :ts -> space t . rend i ts"
    , String
"    _            -> id"
    , String
"  new i     = showChar '\\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace"
    , String
"  space t s ="
    , String
"    case (all isSpace t', null spc, null rest) of"
    , String
"      (True , _   , True ) -> []              -- remove trailing space"
    , String
"      (False, _   , True ) -> t'              -- remove trailing space"
    , String
"      (False, True, False) -> t' ++ ' ' : s   -- add space if none"
    , String
"      _                    -> t' ++ s"
    , String
"    where"
    , String
"      t'          = showString t []"
    , String
"      (spc, rest) = span isSpace s"
    , String
""
    , String
"  closingOrPunctuation :: String -> Bool"
    , String
"  closingOrPunctuation [c] = c `elem` closerOrPunct"
    , String
"  closingOrPunctuation _   = False"
    , String
""
    , String
"  closerOrPunct :: String"
    , String
"  closerOrPunct = \")],;\""
    , String
""
    , String
"parenth :: Doc -> Doc"
    , String
"parenth ss = doc (showChar '(') . ss . doc (showChar ')')"
    , String
""
    , String
"concatS :: [ShowS] -> ShowS"
    , String
"concatS = foldr (.) id"
    , String
""
    , String
"concatD :: [Doc] -> Doc"
    , String
"concatD = foldr (.) id"
    , String
""
    , String
"replicateS :: Int -> ShowS -> ShowS"
    , String
"replicateS n f = concatS (replicate n f)"
    , String
""
    , String
"-- | The printer class does the job."
    , String
""
    , String
"class Print a where"
    , String
"  prt :: Int -> a -> Doc"
    , String
"  prtList :: Int -> [a] -> Doc"
    , String
"  prtList i = concatD . map (prt i)"
    , String
""
    , String
"instance {-# OVERLAPPABLE #-} Print a => Print [a] where"
    , String
"  prt = prtList"
    , String
""
    , String
"instance Print Char where"
    , String
"  prt _ s = doc (showChar '\\'' . mkEsc '\\'' s . showChar '\\'')"
    , String
"  prtList _ s = doc (showChar '\"' . concatS (map (mkEsc '\"') s) . showChar '\"')"
    , String
""
    , String
"mkEsc :: Char -> Char -> ShowS"
    , String
"mkEsc q s = case s of"
    , String
"  _ | s == q -> showChar '\\\\' . showChar s"
    , String
"  '\\\\'-> showString \"\\\\\\\\\""
    , String
"  '\\n' -> showString \"\\\\n\""
    , String
"  '\\t' -> showString \"\\\\t\""
    , String
"  _ -> showChar s"
    , String
""
    , String
"prPrec :: Int -> Int -> Doc -> Doc"
    , String
"prPrec i j = if j < i then parenth else id"
    , String
""
    ]
  ]

-- | Printing instance for @Integer@, and possibly @[Integer]@.
integerRule :: AbsMod -> CF -> [String]
integerRule :: String -> CF -> [String]
integerRule String
absMod CF
cf = String -> CF -> Cat -> [String]
showsPrintRule String
absMod CF
cf (Cat -> [String]) -> Cat -> [String]
forall a b. (a -> b) -> a -> b
$ String -> Cat
TokenCat String
catInteger

-- | Printing instance for @Double@, and possibly @[Double]@.
doubleRule :: AbsMod -> CF -> [String]
doubleRule :: String -> CF -> [String]
doubleRule String
absMod CF
cf = String -> CF -> Cat -> [String]
showsPrintRule String
absMod CF
cf (Cat -> [String]) -> Cat -> [String]
forall a b. (a -> b) -> a -> b
$ String -> Cat
TokenCat String
catDouble

showsPrintRule :: AbsMod -> CF -> Cat -> [String]
showsPrintRule :: String -> CF -> Cat -> [String]
showsPrintRule String
absMod CF
cf Cat
t =
  [ [String] -> String
unwords [ String
"instance Print" , String -> Cat -> String
qualifiedCat String
absMod Cat
t , String
"where" ]
  , String
"  prt _ x = doc (shows x)"
  ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ CF -> Cat -> [String]
ifList CF
cf Cat
t [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
  [ String
""
  ]

-- | Print category (data type name) qualified if user-defined.
--
qualifiedCat :: AbsMod -> Cat -> String
qualifiedCat :: String -> Cat -> String
qualifiedCat String
absMod Cat
t = case Cat
t of
  TokenCat String
s
    | String
s String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
baseTokenCatNames -> String
unqualified
    | Bool
otherwise                  -> String
qualified
  Cat{}       -> String
qualified
  ListCat Cat
c   -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"[", String -> Cat -> String
qualifiedCat String
absMod Cat
c, String
"]" ]
  CoercCat{}  -> String
forall a. a
impossible
  where
  unqualified :: String
unqualified = Cat -> String
catToStr Cat
t
  qualified :: String
qualified   = String -> String -> String
qualify String
absMod String
unqualified
  impossible :: a
impossible  = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"impossible in Backend.Haskell.CFtoPrinter.qualifiedCat: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
forall a. Show a => a -> String
show Cat
t

qualify :: AbsMod -> String -> String
qualify :: String -> String -> String
qualify String
absMod String
s = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
absMod, String
"." , String
s ]

-- | Printing instance for @Ident@, and possibly @[Ident]@.
identRule :: AbsMod -> TokenText -> CF -> [String]
identRule :: String -> TokenText -> CF -> [String]
identRule String
absMod TokenText
tokenText CF
cf = String -> TokenText -> CF -> String -> [String]
ownPrintRule String
absMod TokenText
tokenText CF
cf String
catIdent

-- | Printing identifiers and terminals.
ownPrintRule :: AbsMod -> TokenText -> CF -> TokenCat -> [String]
ownPrintRule :: String -> TokenText -> CF -> String -> [String]
ownPrintRule String
absMod TokenText
tokenText CF
cf String
own = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ String
"instance Print " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
q String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" where"
    , String
"  prt _ (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
q String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
posn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") = doc $ showString $ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TokenText -> String -> String
tokenTextUnpack TokenText
tokenText String
"i"
    ]
  , CF -> Cat -> [String]
ifList CF
cf (String -> Cat
TokenCat String
own)
  , [ String
""
    ]
  ]
 where
   q :: String
q    = String -> Cat -> String
qualifiedCat String
absMod (Cat -> String) -> Cat -> String
forall a b. (a -> b) -> a -> b
$ String -> Cat
TokenCat String
own
   posn :: String
posn = if CF -> String -> Bool
forall f. CFG f -> String -> Bool
isPositionCat CF
cf String
own then String
" (_,i)" else String
" i"

-- | Printing rules for the AST nodes.
rules :: AbsMod -> Bool -> CF -> [String]
rules :: String -> Bool -> CF -> [String]
rules String
absMod Bool
functor CF
cf = do
    (Cat
cat, [(String, [Cat])]
xs :: [(Fun, [Cat])]) <- CF -> [(Cat, [(String, [Cat])])]
cf2dataLists CF
cf
    [ Doc -> String
render (String -> Bool -> Cat -> [Rule] -> Doc
case_fun String
absMod Bool
functor Cat
cat (((String, [Cat]) -> Rule) -> [(String, [Cat])] -> [Rule]
forall a b. (a -> b) -> [a] -> [b]
map (Cat -> (String, [Cat]) -> Rule
toArgs Cat
cat) [(String, [Cat])]
xs)) ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ CF -> Cat -> [String]
ifList CF
cf Cat
cat [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"" ]
  where
    toArgs :: Cat -> (Fun, [Cat]) -> Rule
    toArgs :: Cat -> (String, [Cat]) -> Rule
toArgs Cat
cat (String
cons, [Cat]
_) =
      case (Rule -> Bool) -> [Rule] -> [Rule]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ (Rule RFun
f RCat
c SentForm
_rhs InternalRule
_internal) -> String
cons String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== RFun -> String
forall a. IsFun a => a -> String
funName RFun
f Bool -> Bool -> Bool
&& Cat
cat Cat -> Cat -> Bool
forall a. Eq a => a -> a -> Bool
== Cat -> Cat
normCat (RCat -> Cat
forall a. WithPosition a -> a
wpThing RCat
c)) (CF -> [Rule]
forall function. CFG function -> [Rul function]
cfgRules CF
cf)
      of
        (Rule
r : [Rule]
_) -> Rule
r
        -- 2018-01-14:  Currently, there can be overlapping rules like
        --   Foo. Bar ::= "foo" ;
        --   Foo. Bar ::= "bar" ;
        -- Of course, this will generate an arbitary printer for @Foo@.
        [] -> String -> Rule
forall a. HasCallStack => String -> a
error (String -> Rule) -> String -> Rule
forall a b. (a -> b) -> a -> b
$ String
"CFToPrinter.rules: no rhs found for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cons String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
forall a. Show a => a -> String
show Cat
cat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ::= ?"

-- |
-- >>> case_fun "Abs" False (Cat "A") [ (npRule "AA" (Cat "AB") [Right "xxx"]) Parsable ]
-- instance Print Abs.A where
--   prt i e = case e of
--     Abs.AA -> prPrec i 0 (concatD [doc (showString "xxx")])
case_fun :: AbsMod -> Bool -> Cat -> [Rule] -> Doc
case_fun :: String -> Bool -> Cat -> [Rule] -> Doc
case_fun String
absMod Bool
functor Cat
cat [Rule]
xs =
  -- trace ("case_fun: cat = " ++ show cat) $
  -- trace ("case_fun: xs  = " ++ show xs ) $
  [Doc] -> Doc
vcat
    [ Doc
"instance Print" Doc -> Doc -> Doc
<+> Doc
type_ Doc -> Doc -> Doc
<+> Doc
"where"
    , Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ if Cat -> Bool
isList Cat
cat then Doc
"prt = prtList" else [Doc] -> Doc
vcat
        [ Doc
"prt i e = case e of"
        , Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ((Rule -> Doc) -> [Rule] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Bool -> Rule -> Doc
mkPrintCase String
absMod Bool
functor) [Rule]
xs)
        ]
    ]
  where
    type_ :: Doc
type_
     | Bool
functor   = case Cat
cat of
         ListCat{}  -> Cat -> Doc
type' Cat
cat
         Cat
_ -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Cat -> Doc
type' Cat
cat
     | Bool
otherwise = String -> Doc
text (String -> Cat -> String
qualifiedCat String
absMod Cat
cat)
    type' :: Cat -> Doc
type' = \case
      ListCat Cat
c    -> Doc
"[" Doc -> Doc -> Doc
<> Cat -> Doc
type' Cat
c Doc -> Doc -> Doc
<> Doc
"]"
      c :: Cat
c@TokenCat{} -> String -> Doc
text (String -> Cat -> String
qualifiedCat String
absMod Cat
c)
      Cat
c            -> String -> Doc
text (String -> Cat -> String
qualifiedCat String
absMod Cat
c) Doc -> Doc -> Doc
<+> Doc
"a"

-- | When writing the Print instance for a category (in case_fun), we have
-- a different case for each constructor for this category.
--
-- >>> mkPrintCase "Abs" False (npRule "AA" (Cat "A") [Right "xxx"] Parsable)
-- Abs.AA -> prPrec i 0 (concatD [doc (showString "xxx")])
--
-- Coercion levels are passed to @prPrec@.
--
-- >>> mkPrintCase "Abs" False (npRule "EInt" (CoercCat "Expr" 2) [Left (TokenCat "Integer")] Parsable)
-- Abs.EInt n -> prPrec i 2 (concatD [prt 0 n])
--
-- >>> mkPrintCase "Abs" False (npRule "EPlus" (CoercCat "Expr" 1) [Left (Cat "Expr"), Right "+", Left (Cat "Expr")] Parsable)
-- Abs.EPlus expr1 expr2 -> prPrec i 1 (concatD [prt 0 expr1, doc (showString "+"), prt 0 expr2])
--
-- If the AST is a functor, ignore first argument.
--
-- >>> mkPrintCase "Abs" True (npRule "EInt" (CoercCat "Expr" 2) [Left (TokenCat "Integer")] Parsable)
-- Abs.EInt _ n -> prPrec i 2 (concatD [prt 0 n])
--
-- Skip internal categories.
--
-- >>> mkPrintCase "Abs" True $ npRule "EInternal" (Cat "Expr") [Left (Cat "Expr")] Internal
-- Abs.EInternal _ expr -> prPrec i 0 (concatD [prt 0 expr])
--
mkPrintCase :: AbsMod -> Bool -> Rule -> Doc
mkPrintCase :: String -> Bool -> Rule -> Doc
mkPrintCase String
absMod Bool
functor (Rule RFun
f RCat
cat SentForm
rhs InternalRule
_internal) =
    Doc
pattern Doc -> Doc -> Doc
<+> Doc
"->"
    Doc -> Doc -> Doc
<+> Doc
"prPrec i" Doc -> Doc -> Doc
<+> Integer -> Doc
integer (Cat -> Integer
precCat (Cat -> Integer) -> Cat -> Integer
forall a b. (a -> b) -> a -> b
$ RCat -> Cat
forall a. WithPosition a -> a
wpThing RCat
cat) Doc -> Doc -> Doc
<+> Doc -> Doc
parens ([String] -> SentForm -> Doc
mkRhs ((Doc -> String) -> [Doc] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Doc -> String
render [Doc]
variables) SentForm
rhs)
  where
    pattern :: Doc
    pattern :: Doc
pattern
      | RFun -> Bool
forall a. IsFun a => a -> Bool
isOneFun  RFun
f = String -> Doc
text String
"[" Doc -> Doc -> Doc
<+> [Doc] -> Doc
forall a. [a] -> a
head [Doc]
variables Doc -> Doc -> Doc
<+> Doc
"]"
      | RFun -> Bool
forall a. IsFun a => a -> Bool
isConsFun RFun
f = [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (String -> Doc
text String
":") [Doc]
variables
      | Bool
otherwise   = String -> Doc
text (String -> String -> String
qualify String
absMod (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ RFun -> String
forall a. IsFun a => a -> String
funName RFun
f) Doc -> Doc -> Doc
<+> (if Bool
functor then Doc
"_" else Doc
empty) Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep [Doc]
variables
    -- Creating variables names used in pattern matching. In addition to
    -- haskell's reserved words, `e` and `i` are used in the printing function
    -- and should be avoided
    names :: [String]
names = (Cat -> String) -> [Cat] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> String
var (SentForm -> [Cat]
forall a b. [Either a b] -> [a]
lefts SentForm
rhs)
    variables :: [Doc]
    variables :: [Doc]
variables = (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text ([String] -> [Doc]) -> [String] -> [Doc]
forall a b. (a -> b) -> a -> b
$ [String] -> NameStyle -> [String] -> [String]
mkNames (String
"e" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"i" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
hsReservedWords) NameStyle
LowerCase [String]
names
    var :: Cat -> String
var (ListCat Cat
c)  = Cat -> String
var Cat
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"s"
    var (TokenCat String
"Ident")   = String
"id"
    var (TokenCat String
"Integer") = String
"n"
    var (TokenCat String
"String")  = String
"str"
    var (TokenCat String
"Char")    = String
"c"
    var (TokenCat String
"Double")  = String
"d"
    var Cat
xs = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Cat -> String
forall a. Show a => a -> String
show Cat
xs

ifList :: CF -> Cat -> [String]
ifList :: CF -> Cat -> [String]
ifList CF
cf Cat
cat =
    -- trace ("ifList cf    = " ++ show cf   ) $
    -- trace ("ifList cat   = " ++ show cat  ) $
    -- trace ("ifList rules = " ++ show rules) $
    -- trace ("ifList rulesForCat' cf (ListCat cat) = " ++ show (rulesForCat' cf (ListCat cat))) $
    -- trace "" $
    (Doc -> String) -> [Doc] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> String
render (Doc -> String) -> (Doc -> Doc) -> Doc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc -> Doc
nest Int
2) [Doc]
cases
  where
    rules :: [Rule]
rules = (Rule -> Rule -> Ordering) -> [Rule] -> [Rule]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Rule -> Rule -> Ordering
forall f. IsFun f => Rul f -> Rul f -> Ordering
compareRules ([Rule] -> [Rule]) -> [Rule] -> [Rule]
forall a b. (a -> b) -> a -> b
$ CF -> Cat -> [Rule]
rulesForNormalizedCat CF
cf (Cat -> Cat
ListCat Cat
cat)
    cases :: [Doc]
cases = [ Rule -> Doc
mkPrtListCase Rule
r | Rule
r <- [Rule]
rules ]

-- | Pattern match on the list constructor and the coercion level
--
-- >>> mkPrtListCase (npRule "[]" (ListCat (Cat "Foo")) [] Parsable)
-- prtList _ [] = concatD []
--
-- >>> mkPrtListCase (npRule "(:[])" (ListCat (Cat "Foo")) [Left (Cat "FOO")] Parsable)
-- prtList _ [x] = concatD [prt 0 x]
--
-- >>> mkPrtListCase (npRule "(:)" (ListCat (Cat "Foo")) [Left (Cat "Foo"), Left (ListCat (Cat "Foo"))] Parsable)
-- prtList _ (x:xs) = concatD [prt 0 x, prt 0 xs]
--
-- >>> mkPrtListCase (npRule "[]" (ListCat (CoercCat "Foo" 2)) [] Parsable)
-- prtList 2 [] = concatD []
--
-- >>> mkPrtListCase (npRule "(:[])" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2)] Parsable)
-- prtList 2 [x] = concatD [prt 2 x]
--
-- >>> mkPrtListCase (npRule "(:)" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2), Left (ListCat (CoercCat "Foo" 2))] Parsable)
-- prtList 2 (x:xs) = concatD [prt 2 x, prt 2 xs]
--
mkPrtListCase :: Rule -> Doc
mkPrtListCase :: Rule -> Doc
mkPrtListCase (Rule RFun
f (WithPosition Position
_ (ListCat Cat
c)) SentForm
rhs InternalRule
_internal)
  | RFun -> Bool
forall a. IsFun a => a -> Bool
isNilFun RFun
f = Doc
"prtList" Doc -> Doc -> Doc
<+> Doc
precPattern Doc -> Doc -> Doc
<+> Doc
"[]" Doc -> Doc -> Doc
<+> Doc
"=" Doc -> Doc -> Doc
<+> Doc
body
  | RFun -> Bool
forall a. IsFun a => a -> Bool
isOneFun RFun
f = Doc
"prtList" Doc -> Doc -> Doc
<+> Doc
precPattern Doc -> Doc -> Doc
<+> Doc
"[x]" Doc -> Doc -> Doc
<+> Doc
"=" Doc -> Doc -> Doc
<+> Doc
body
  | RFun -> Bool
forall a. IsFun a => a -> Bool
isConsFun RFun
f = Doc
"prtList" Doc -> Doc -> Doc
<+> Doc
precPattern Doc -> Doc -> Doc
<+> Doc
"(x:xs)" Doc -> Doc -> Doc
<+> Doc
"=" Doc -> Doc -> Doc
<+> Doc
body
  | Bool
otherwise = Doc
empty -- (++) constructor
  where
    precPattern :: Doc
precPattern = case Cat -> Integer
precCat Cat
c of Integer
0 -> Doc
"_" ; Integer
p -> Integer -> Doc
integer Integer
p
    body :: Doc
body = [String] -> SentForm -> Doc
mkRhs [String
"x", String
"xs"] SentForm
rhs
mkPrtListCase Rule
_ = String -> Doc
forall a. HasCallStack => String -> a
error String
"mkPrtListCase undefined for non-list categories"


-- | Define an ordering on lists' rules with the following properties:
--
-- - rules with a higher coercion level should come first, i.e. the rules for
--   [Foo3] are before rules for [Foo1] and they are both lower than rules for
--   [Foo].
--
-- - [] < [_] < _:_
--
-- This is desiged to correctly order the rules in the prtList function so that
-- the pattern matching works as expectd.
--
-- >>> compareRules (npRule "[]" (ListCat (CoercCat "Foo" 3)) [] Parsable) (npRule "[]" (ListCat (CoercCat "Foo" 1)) [] Parsable)
-- LT
--
-- >>> compareRules (npRule "[]" (ListCat (CoercCat "Foo" 3)) [] Parsable) (npRule "[]" (ListCat (Cat "Foo")) [] Parsable)
-- LT
--
-- >>> compareRules (npRule "[]" (ListCat (Cat "Foo")) [] Parsable) (npRule "(:[])" (ListCat (Cat "Foo")) [] Parsable)
-- LT
--
-- >>> compareRules (npRule "(:[])" (ListCat (Cat "Foo")) [] Parsable) (npRule "(:)" (ListCat (Cat "Foo")) [] Parsable)
-- LT
--
compareRules :: IsFun f => Rul f -> Rul f -> Ordering
compareRules :: Rul f -> Rul f -> Ordering
compareRules Rul f
r1 Rul f
r2
  | Rul f -> Integer
forall f. Rul f -> Integer
precRule Rul f
r1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Rul f -> Integer
forall f. Rul f -> Integer
precRule Rul f
r2 = Ordering
LT
  | Rul f -> Integer
forall f. Rul f -> Integer
precRule Rul f
r1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Rul f -> Integer
forall f. Rul f -> Integer
precRule Rul f
r2 = Ordering
GT
  | Bool
otherwise = (String -> String -> Ordering
compareFunNames (String -> String -> Ordering)
-> (Rul f -> String) -> Rul f -> Rul f -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (f -> String
forall a. IsFun a => a -> String
funName (f -> String) -> (Rul f -> f) -> Rul f -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rul f -> f
forall function. Rul function -> function
funRule)) Rul f
r1 Rul f
r2

compareFunNames :: String -> String -> Ordering
compareFunNames :: String -> String -> Ordering
compareFunNames = ((String, String) -> Ordering) -> String -> String -> Ordering
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (((String, String) -> Ordering) -> String -> String -> Ordering)
-> ((String, String) -> Ordering) -> String -> String -> Ordering
forall a b. (a -> b) -> a -> b
$ \case
  (String
"[]"    , String
"[]"   ) -> Ordering
EQ
  (String
"[]"    , String
_      ) -> Ordering
LT
  (String
"(:[])" , String
"[]"   ) -> Ordering
GT
  (String
"(:[])" , String
"(:[])") -> Ordering
EQ
  (String
"(:[])" , String
"(:)"  ) -> Ordering
LT
  (String
"(:)"   , String
"(:)"  ) -> Ordering
EQ
  (String
"(:)"   , String
_      ) -> Ordering
GT
  (String
_       , String
_      ) -> Ordering
EQ


-- |
--
-- >>> mkRhs ["expr1", "n", "expr2"] [Left (Cat "Expr"), Right "-", Left (TokenCat "Integer"), Left (Cat "Expr")]
-- concatD [prt 0 expr1, doc (showString "-"), prt 0 n, prt 0 expr2]
--
-- Coercions on the right hand side should be passed to prt:
--
-- >>> mkRhs ["expr1"] [Left (CoercCat "Expr" 2)]
-- concatD [prt 2 expr1]
--
-- >>> mkRhs ["expr2s"] [Left (ListCat (CoercCat "Expr" 2))]
-- concatD [prt 2 expr2s]
--
mkRhs :: [String] -> [Either Cat String] -> Doc
mkRhs :: [String] -> SentForm -> Doc
mkRhs [String]
args SentForm
its =
  Doc
"concatD" Doc -> Doc -> Doc
<+> Doc -> Doc
brackets ([Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
punctuate Doc
"," ([String] -> SentForm -> [Doc]
forall a. Show a => [String] -> [Either Cat a] -> [Doc]
mk [String]
args SentForm
its)))
  where
  mk :: [String] -> [Either Cat a] -> [Doc]
mk (String
arg:[String]
args) (Left Cat
c  : [Either Cat a]
items)    = (Cat -> Doc
prt Cat
c Doc -> Doc -> Doc
<+> String -> Doc
text String
arg) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [String] -> [Either Cat a] -> [Doc]
mk [String]
args [Either Cat a]
items
  mk [String]
args       (Right a
s : [Either Cat a]
items)    = (Doc
"doc (showString" Doc -> Doc -> Doc
<+> String -> Doc
text (a -> String
forall a. Show a => a -> String
show a
s) Doc -> Doc -> Doc
<> Doc
")") Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [String] -> [Either Cat a] -> [Doc]
mk [String]
args [Either Cat a]
items
  mk [String]
_          [Either Cat a]
_                    = []
  prt :: Cat -> Doc
prt Cat
c = Doc
"prt" Doc -> Doc -> Doc
<+> Integer -> Doc
integer (Cat -> Integer
precCat Cat
c)