{-
    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 qualified Data.List as List

-- 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.
  -> Doc
cf2Printer :: TokenText -> Bool -> Bool -> String -> String -> CF -> Doc
cf2Printer TokenText
tokenText Bool
functor Bool
useGadt String
name String
absMod CF
cf = [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Doc]] -> [Doc]) -> [[Doc]] -> [Doc]
forall a b. (a -> b) -> a -> b
$
  -- Each of the following list entries is itself a list of Docs
  [ TokenText -> Bool -> String -> [String] -> CF -> [Doc]
prologue TokenText
tokenText Bool
useGadt String
name [ String
absMod | Bool
importAbsMod ] CF
cf
  , String -> CF -> [Doc]
integerRule String
absMod CF
cf
  , String -> CF -> [Doc]
doubleRule String
absMod CF
cf
  , Bool -> [Doc] -> [Doc]
forall m. Monoid m => Bool -> m -> m
when (CF -> Bool
forall f. CFG f -> Bool
hasIdent CF
cf) ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ String -> TokenText -> CF -> [Doc]
identRule String
absMod TokenText
tokenText CF
cf
  , [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String -> TokenText -> CF -> String -> [Doc]
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 -> Bool -> CF -> [Doc]
rules String
absMod Bool
functor CF
cf
  ]
  where
  importAbsMod :: Bool
importAbsMod = Bool -> Bool
not ([Data] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Data] -> Bool) -> [Data] -> Bool
forall a b. (a -> b) -> a -> b
$ CF -> [Data]
cf2data CF
cf) Bool -> Bool -> Bool
|| Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ CF -> [String]
specialCats CF
cf)

-- | Lowercase Haskell identifiers imported from ''Prelude''.
lowerCaseImports :: [String]
lowerCaseImports :: [String]
lowerCaseImports =
  [ String
"all", String
"elem", String
"foldr", String
"id", String
"map", String
"null", String
"replicate", String
"shows", String
"span" ]

prologue :: TokenText -> Bool -> String -> [AbsMod] -> CF -> [Doc]
prologue :: TokenText -> Bool -> String -> [String] -> CF -> [Doc]
prologue TokenText
tokenText Bool
useGadt String
name [String]
absMod CF
cf = (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]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ String
"{-# LANGUAGE CPP #-}"
    , String
"{-# LANGUAGE FlexibleInstances #-}"
    , String
"{-# LANGUAGE LambdaCase #-}"
    ]
  , [ String
"{-# LANGUAGE GADTs #-}"                | Bool
useGadt ]
  , [ String
"#if __GLASGOW_HASKELL__ <= 708"
    , String
"{-# LANGUAGE OverlappingInstances #-}"
    , String
"#endif"
    ]
  , [ String
""
    -- -- WAS: Needed for precedence category lists, e.g. @[Exp2]@:
    -- , "{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}"
    -- , ""
    , 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
""
    , String
"module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
+++ String
"where"
    , String
""
    , String
"import Prelude"
    , String
"  ( ($), (.)"
    , String
"  , Bool(..), (==), (<)"
    , String
"  , Int, Integer, Double, (+), (-), (*)"
    , String
"  , String, (++)"
    , String
"  , ShowS, showChar, showString"
    , String
"  , " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
", " [String]
lowerCaseImports
    , String
"  )"
    , String
"import Data.Char ( Char, isSpace )"
    ]
  , (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
"import qualified " String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
absMod  -- At most 1.  (Unnecessary if Abs module is empty.)
  , Bool -> [String] -> [String]
forall m. Monoid m => Bool -> m -> m
when (CF -> Bool
forall f. CFG f -> Bool
hasTextualTokens CF
cf) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ 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 False (map ($ \"\") $ d []) \"\""
    , String
"  where"
    , String
"  rend"
    , String
"    :: Int        -- ^ Indentation level."
    , String
"    -> Bool       -- ^ Pending indentation to be output before next character?"
    , String
"    -> [String]"
    , String
"    -> ShowS"
    , String
"  rend i p = \\case"
    , String
"      \"[\"      :ts -> char '[' . rend i False ts"
    , String
"      \"(\"      :ts -> char '(' . rend i False ts"
    , String
"      \"{\"      :ts -> onNewLine i     p . showChar   '{'  . new (i+1) ts"
    , String
"      \"}\" : \";\":ts -> onNewLine (i-1) p . showString \"};\" . new (i-1) ts"
    , String
"      \"}\"      :ts -> onNewLine (i-1) p . showChar   '}'  . new (i-1) ts"
    , String
"      [\";\"]        -> char ';'"
    , String
"      \";\"      :ts -> char ';' . new i ts"
    , String
"      t  : ts@(s:_) | closingOrPunctuation s"
    , String
"                   -> pending . showString t . rend i False ts"
    , String
"      t        :ts -> pending . space t      . rend i False ts"
    , String
"      []           -> id"
    , String
"    where"
    , String
"    -- Output character after pending indentation."
    , String
"    char :: Char -> ShowS"
    , String
"    char c = pending . showChar c"
    , String
""
    , String
"    -- Output pending indentation."
    , String
"    pending :: ShowS"
    , String
"    pending = if p then indent i else id"
    , String
""
    , String
"  -- Indentation (spaces) for given indentation level."
    , String
"  indent :: Int -> ShowS"
    , String
"  indent i = replicateS (2*i) (showChar ' ')"
    , String
""
    , String
"  -- Continue rendering in new line with new indentation."
    , String
"  new :: Int -> [String] -> ShowS"
    , String
"  new j ts = showChar '\\n' . rend j True ts"
    , String
""
    , String
"  -- Make sure we are on a fresh line."
    , String
"  onNewLine :: Int -> Bool -> ShowS"
    , String
"  onNewLine i p = (if p then id else showChar '\\n') . indent i"
    , String
""
    , String
"  -- Separate given string from following text by a space (if needed)."
    , String
"  space :: String -> ShowS"
    , 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
""
    , String
"instance {-# OVERLAPPABLE #-} Print a => Print [a] where"
    , String
"  prt i = concatD . map (prt i)"
    , String
""
    , String
"instance Print Char where"
    , String
"  prt _ c = doc (showChar '\\'' . mkEsc '\\'' c . showChar '\\'')"
    , String
""
    ]
  , if Bool
haveListChar then
    [ String
"-- | No @instance 'Print' String@ because it would clash with the instance"
    , String
"--   for @[Char]@."
    ]
    else
    [ String
"instance Print String where"
    , String
"  prt _ = printString"
    , String
""
    ]
  , [ String
"printString :: String -> Doc"
    , String
"printString s = doc (showChar '\"' . concatS (map (mkEsc '\"') s) . showChar '\"')"
    , String
""
    , String
"mkEsc :: Char -> Char -> ShowS"
    , String
"mkEsc q = \\case"
    , String
"  s | s == q -> showChar '\\\\' . showChar s"
    , String
"  '\\\\' -> showString \"\\\\\\\\\""
    , String
"  '\\n' -> showString \"\\\\n\""
    , String
"  '\\t' -> showString \"\\\\t\""
    , String
"  s -> showChar s"
    , String
""
    , String
"prPrec :: Int -> Int -> Doc -> Doc"
    , String
"prPrec i j = if j < i then parenth else id"
    , String
""
    ]
  ]
  where
  haveListChar :: Bool
haveListChar = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Rule] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Rule] -> Bool) -> [Rule] -> Bool
forall a b. (a -> b) -> a -> b
$ CF -> Cat -> [Rule]
rulesForCat CF
cf (Cat -> [Rule]) -> Cat -> [Rule]
forall a b. (a -> b) -> a -> b
$ Cat -> Cat
ListCat (Cat -> Cat) -> Cat -> Cat
forall a b. (a -> b) -> a -> b
$ String -> Cat
TokenCat String
"Char"

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

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

showsPrintRule :: AbsMod -> CF -> Cat -> [Doc]
showsPrintRule :: String -> CF -> Cat -> [Doc]
showsPrintRule String
absMod CF
_cf Cat
t =
  [ [Doc] -> Doc
hsep [ Doc
"instance Print" , String -> Doc
text (String -> Cat -> String
qualifiedCat String
absMod Cat
t) , Doc
"where" ]
  , Doc
"  prt _ x = doc (shows x)"
  , Doc
""
  ]

-- | 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
catToStr 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 -> [Doc]
identRule :: String -> TokenText -> CF -> [Doc]
identRule String
absMod TokenText
tokenText CF
cf = String -> TokenText -> CF -> String -> [Doc]
ownPrintRule String
absMod TokenText
tokenText CF
cf String
catIdent

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

-- | Printing rules for the AST nodes.
rules :: AbsMod -> Bool -> CF -> [Doc]
rules :: String -> Bool -> CF -> [Doc]
rules String
absMod Bool
functor CF
cf = do
  (Cat
cat, [(String, [Cat])]
xs :: [ (Fun, [Cat]) ]) <- CF -> [Data]
cf2dataLists CF
cf
  [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Doc]] -> [Doc]) -> [[Doc]] -> [Doc]
forall a b. (a -> b) -> a -> b
$
    [ String -> Bool -> CF -> Cat -> [Rule] -> [Doc]
case_fun String
absMod Bool
functor CF
cf Cat
cat ([Rule] -> [Doc]) -> [Rule] -> [Doc]
forall a b. (a -> b) -> a -> b
$ ((String, [Cat]) -> Rule) -> [(String, [Cat])] -> [Rule]
forall a b. (a -> b) -> [a] -> [b]
map (Cat -> (String, [Cat]) -> Rule
toArgs Cat
cat) [(String, [Cat])]
xs
    , [ Doc
"" ]
    ]
  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
catToStr Cat
cat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ::= ?"

-- |
-- >>> vcat $ case_fun "Abs" False undefined (Cat "A") [ (npRule "AA" (Cat "AB") [Right "xxx"]) Parsable ]
-- instance Print Abs.A where
--   prt i = \case
--     Abs.AA -> prPrec i 0 (concatD [doc (showString "xxx")])
case_fun :: AbsMod -> Bool -> CF -> Cat -> [Rule] -> [Doc]
case_fun :: String -> Bool -> CF -> Cat -> [Rule] -> [Doc]
case_fun String
absMod Bool
functor CF
cf Cat
cat [Rule]
rules =
  -- trace ("case_fun: cat   = " ++ catToStr cat) $
  -- trace ("case_fun: rules = " ++ show rules ) $
  [ 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
$ [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$

      -- Special printing of lists (precedence changes concrete syntax!)
      if Cat -> Bool
isList Cat
cat then
        [Rule] -> [Doc]
listCases ([Rule] -> [Doc]) -> [Rule] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (Rule -> Rule -> Ordering) -> [Rule] -> [Rule]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.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

      -- Ordinary category
      else
        [ Doc
"prt i = \\case"
        , Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Rule -> Doc) -> [Rule] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Bool -> Rule -> Doc
mkPrintCase String
absMod Bool
functor) [Rule]
rules
        ]
  ]
  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"
    listCases :: [Rule] -> [Doc]
listCases [] = []
    listCases [Rule]
rules = [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ Doc
"prt _ [] = concatD []" | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Rule -> Bool) -> [Rule] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Rule -> Bool
forall a. IsFun a => a -> Bool
isNilFun [Rule]
rules ]
            -- Andreas, 2021-09-22, issue #386
            -- If the list is @nonempty@ according to the grammar, still add a nil case.
            -- In the AST it is simply a list, and the AST could be created
            -- by other means than by parsing.
      , (Rule -> Doc) -> [Rule] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Integer -> Rule -> Doc
mkPrtListCase Integer
minPrec) [Rule]
rules
      ]
      where
      -- Andreas, 2021-09-22, issue #384:
      -- The minimum precedence of a rule lhs category in the rules set.
      -- This is considered the default precedence; used to make the printing function total.
      minPrec :: Integer
minPrec = [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Integer] -> Integer) -> [Integer] -> Integer
forall a b. (a -> b) -> a -> b
$ (Rule -> Integer) -> [Rule] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Rule -> Integer
forall f. Rul f -> Integer
precRule [Rule]
rules

-- | 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
pat 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
    pat :: Doc
    pat :: Doc
pat
      | RFun -> Bool
forall a. IsFun a => a -> Bool
isNilFun  RFun
f = String -> Doc
text String
"[]"
      | 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]
List.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.
    -- #337: `prt` as well, and some more entirely lowercase ones.
    avoid :: [String]
avoid = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ String
"e", String
"i", String
"doc", String
"prt" ]  -- don't need mixed-case ones: "concatD", "prPrec", "showString"
      , [String]
lowerCaseImports
      , [String]
hsReservedWords
      ]
    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]
avoid 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
catToStr Cat
xs

-- | Pattern match on the list constructor and the coercion level
--
-- >>> mkPrtListCase 0 (npRule "[]" (ListCat (Cat "Foo")) [] Parsable)
-- prt _ [] = concatD []
--
-- >>> mkPrtListCase 0 (npRule "(:[])" (ListCat (Cat "Foo")) [Left (Cat "FOO")] Parsable)
-- prt _ [x] = concatD [prt 0 x]
--
-- >>> mkPrtListCase 0 (npRule "(:)" (ListCat (Cat "Foo")) [Left (Cat "Foo"), Left (ListCat (Cat "Foo"))] Parsable)
-- prt _ (x:xs) = concatD [prt 0 x, prt 0 xs]
--
-- >>> mkPrtListCase 0 (npRule "[]" (ListCat (CoercCat "Foo" 2)) [] Parsable)
-- prt 2 [] = concatD []
--
-- >>> mkPrtListCase 0 (npRule "(:[])" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2)] Parsable)
-- prt 2 [x] = concatD [prt 2 x]
--
-- >>> mkPrtListCase 2 (npRule "(:)" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2), Left (ListCat (CoercCat "Foo" 2))] Parsable)
-- prt _ (x:xs) = concatD [prt 2 x, prt 2 xs]
--
mkPrtListCase
  :: Integer -- ^ The lowest precedence of a lhs in a list rule.  Default: 0.
  -> Rule    -- ^ The list rule.
  -> Doc
mkPrtListCase :: Integer -> Rule -> Doc
mkPrtListCase Integer
minPrec (Rule RFun
f (WithPosition Position
_ (ListCat Cat
c)) SentForm
rhs InternalRule
_internal)
  | RFun -> Bool
forall a. IsFun a => a -> Bool
isNilFun RFun
f = Doc
"prt" 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
"prt" 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
"prt" 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 = if Integer
p Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
minPrec then Doc
"_" else Integer -> Doc
integer Integer
p
    p :: Integer
p = Cat -> Integer
precCat Cat
c
    body :: Doc
body = [String] -> SentForm -> Doc
mkRhs [String
"x", String
"xs"] SentForm
rhs
mkPrtListCase Integer
_ 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 prt function for lists 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 :: forall f. IsFun f => 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 (TokenCat String
"String") = Doc
"printString"
  prt Cat
c = Doc
"prt" Doc -> Doc -> Doc
<+> Integer -> Doc
integer (Cat -> Integer
precCat Cat
c)