{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

-- | The internal representation of LBNF grammars.
--
-- Pragmas have been desugared as far as possible.

module BNFC.CF where

import BNFC.Prelude

import Lens.Micro.TH (makeLenses)

import qualified Data.Map         as Map
import qualified BNFC.Utils.List1 as List1

import BNFC.Types.Position
import BNFC.Types.Regex

import BNFC.Backend.Common.StringUtils (escapeChars)

-- | The internal representation of a LBNF grammar.
--
-- The name is an abbreviation of Context-Free (Grammar).
--
-- Rules are stored in:
--
--   1. The signature: a map from rule names to their type (Id labels only).
--      The signature is used for type-checking definitions and special rules (lists).
--
--   2. The AST rules: a map from categories to labels to rhss.
--      This representation is useful for generating the abstract syntax and the printer.
--      Keywords are not trimmed here to allow the extra whitespace to be printed
--      (see BNFC/bnfc#70).
--
--   3. The parser rules: a map from categories to rhss to labels.
--      @internal@ rules are not contained in this map.
--      This representation expresses that each parseable BNF rule can have at most one label.
--      It is useful for detecting overlapping rules, e.g. coming from
--      proper rules and list/coercion pragmas.
--      The parser generation should start with these rules.
--      Keywords are trimmed since BNFC-generated parsers are not whitespace-sensitive.


data LBNF = LBNF
  --- Typing and definitions
  { _lbnfSignature      :: Signature
       -- ^ Type for each AST constructor and defined function.
  , _lbnfFunctions      :: Functions
       -- ^ Checked functions from @define@ pragmas.
  , _lbnfASTRules       :: ASTRules
       -- ^ Per category, its rules ordered by label.
  , _lbnfASTRulesAP     :: ASTRulesAP
       -- ^ AST rules used to generate abstract syntax and printer.
       --   Per type (category without precedence),
       --   its rules non terminals and a map from category precedence
       --   to rhs, ordered by label.
  , _lbnfASTBuiltins    :: UsedBuiltins
       -- ^ Builtin categories @Char, Integer, ...@ (non-overwritten) mentioned in the AST.
       --   (Includes builtin categories only mentioned in 'Internal' rules.)
  --- Parser components
  , _lbnfParserRules    :: ParserRules
       -- ^ Per category, its 'Parseable' rules ordered by 'RHS'.
  , _lbnfParserBuiltins :: UsedBuiltins
       -- ^ Builtin categories @Char, Integer, ...@ mentioned in the 'Parseable' rules.
       --   (and not overwritten).
  , _lbnfEntryPoints    :: EntryPoints
       -- ^ Collection of entry points for parser,
       --   each with the position(s) where it was declared entry point.
  --- Lexer components
  , _lbnfTokenDefs      :: TokenDefs
       -- ^ User-defined token categories.
  , _lbnfKeywords       :: KeywordUses
       -- ^ Keywords and their occurrences in rhss. Computed by pass 1.
  , _lbnfSymbols        :: SymbolUses
       -- ^ Symbols and their occurrences in rhss. Computed by pass 1.
  , _lbnfSymbolsKeywords :: SymbolsKeywords
       -- ^ Symbols and keywords used in lexer and parser specifications
  , _lbnfLineComments   :: LineComments
       -- ^ Line comment pragmas by position, e.g. @comment "--"@.
  , _lbnfBlockComments  :: BlockComments
       -- ^ Block comment pragmas by position, e.g. @comment "{-" "-}"@.
  , _lbnfLayoutStart    :: LayoutKeywords
       -- ^ @layout@ start keywords with the pragma position.
       --   Keywords are members of '_lbnfKeywords'.
  , _lbnfLayoutStop     :: LayoutKeywords
       -- ^ @layout stop@ keywords with the pragma position.
       --   Disjoint from '_lbnfLayout'.
       --   Keywords are members of '_lbnfKeywords'.
  , _lbnfLayoutTop      :: Maybe Position
       -- ^ 'Position' of @layout toplevel@, if present.
  }
  deriving Show

type Signature       = Map LabelName (WithPosition FunType)
type Functions       = Map LabelName (WithPosition Function)
type ASTRules        = Map Cat (Map Label (WithPosition ARuleRHS))
type ASTRulesAP      = Map Type (Map Label ([Type], (Integer, WithPosition ARHS)))
type ParserRules     = Map Cat (Map RHS (WithPosition RuleLabel))
type EntryPoints     = Map Cat (List1 Position)
type UsedBuiltins    = Map BuiltinCat (List1 Position)
type TokenDefs       = Map CatName (WithPosition TokenDef)
type KeywordUses     = Map Keyword (List1 Position)
type SymbolUses      = Map Symbol (List1 Position)
type SymbolsKeywords = Map String1 Int
type LineComments    = Map Position LineComment
type BlockComments   = Map Position BlockComment
type LayoutKeywords  = Map Keyword Position

initLBNF :: LBNF
initLBNF = LBNF
  { _lbnfSignature          = mempty
  , _lbnfFunctions          = mempty
  , _lbnfASTRules           = mempty
  , _lbnfASTRulesAP         = mempty
  , _lbnfASTBuiltins        = mempty
  , _lbnfParserRules        = mempty
  , _lbnfParserBuiltins     = mempty
  , _lbnfEntryPoints        = mempty
  , _lbnfTokenDefs          = mempty
  , _lbnfKeywords           = mempty
  , _lbnfSymbols            = mempty
  , _lbnfSymbolsKeywords    = mempty
  , _lbnfLineComments       = mempty
  , _lbnfBlockComments      = mempty
  , _lbnfLayoutStart        = mempty
  , _lbnfLayoutStop         = mempty
  , _lbnfLayoutTop          = Nothing
  }

-- -- | A (non-token) category is defined by one or more rules.
-- --   These are stored as a stack, with last rule on top.  Reverse before processing!
-- type CatDef = List1 (WithPosition RuleBody)

-- | A token category is defined by a regular expression.

data TokenDef = TokenDef
  { positionToken :: PositionToken
      -- ^ Is it a @position token@?
  , regexToken    :: Regex
      -- ^ The defining regular expression.
  , isIdent       :: Bool
      -- ^ Is it the @Ident@ token?
  } deriving Show

-- | Keywords are non-empty 'trim'med strings.
--   Trimming happens since LBNF is a whitespace-insensitive formalism.
--   Should a future version of BNFC become whitespace sensitive,
--   we have to abstain from 'trim'ming keywords by default.

newtype Keyword = Keyword { theKeyword :: List1 Char }
  deriving (Eq, Ord)

instance Show Keyword where
  showsPrec i (Keyword (c:|s)) =
    showParen (i > 10) $ showString "Data.List.NonEmpty.fromList" . shows (c:s)
    -- See https://hackage.haskell.org/package/base-4.16.0.0/docs/GHC-Show.html#t:Show
    -- Application has a precedence of 10.

newtype Symbol = Symbol { theSymbol :: List1 Char }
  deriving (Eq, Ord)

instance Show Symbol where
  showsPrec i (Symbol (c:|s)) =
    showParen (i > 10) $ showString "Data.List.NonEmpty.fromList" . shows (c:s)

newtype LineComment = LineComment String1
  deriving (Show)
data BlockComment = BlockComment String1 String1
  deriving (Show)

-- newtype LayoutKeyword = LayoutKeyword String
-- newtype LayoutStop    = LayoutStop String

-- * Categories
---------------------------------------------------------------------------

type CatName = String1
type Cat     = Cat' BaseCat

-- | Categories (non-terminals).

data Cat' a
  = Cat a
      -- ^ Base category, e.g. @Ident@, @Exp@.
  | ListCat (Cat' a)
      -- ^ List non-terminals, e.g., @[Ident]@, @[Exp]@, @[Exp1]@.
  | CoerceCat CatName Integer
      -- ^ E.g. @Exp1@, @Exp2@.
  deriving (Eq, Ord, Show)

data BaseCat
  = BuiltinCat BuiltinCat
      -- ^ @Char@, @Double@, @Integer@, @String@.
  | IdentCat IdentCat
      -- ^ @Ident@
  | TokenCat CatName
      -- ^ User-defined @token@ category.
  | BaseCat  CatName
      -- ^ Base category defined by CFG, like @Exp@.
  deriving (Eq, Ord, Show)

-- | Built-in token categories with special token representation.

data BuiltinCat
  = BChar    -- ^ @Char@
  | BDouble  -- ^ @Double@
  | BInteger -- ^ @Integer@
  | BString  -- ^ @String@
  deriving (Eq, Ord, Show, Bounded, Enum)

-- | Built-in token Ident, treated as a string.

data IdentCat = BIdent -- ^ @Ident@
  deriving(Eq, Ord, Show)

-- * Types (categories in AST)
---------------------------------------------------------------------------

-- | Types are categories without the precedences ('CoerceCat').

data Type
  = BaseType BaseCat  -- ^ Base category.
  | ListType Type     -- ^ List category.
  deriving (Eq, Ord, Show)

-- | Function type @t(t₁,...,tₙ)@ or @t₁ → ... → tₙ → t@.
data FunType = FunType
  { targetType :: Type    -- ^ Result type.
  , argTypes   :: [Type]  -- ^ Types of parameters, left to right.
  }
  deriving (Eq, Show)

-- * Expressions (for defined constructors)
---------------------------------------------------------------------------

-- | Bodies of 'A.Function'.
--   For convenience, these are fully typed.

data Exp
  = App Label FunType [Exp]
      -- ^ (Possibly defined) label with its type
      --   applied to the correct number of expressions.
  | Var Parameter
      -- ^ Use of function parameter.
  | LitInteger Integer
  | LitDouble  Double
  | LitChar    Char
  | LitString  String
  deriving (Show)

-- | Bound variable.

data Parameter = Parameter
  { paramName :: VarName
  , paramType :: Type
  }
  deriving (Show)

type VarName = String1

-- | Definition body of a constructor.

data Function = Function
  { funPars :: [Parameter]
  , funBody :: Exp
  , funType :: Type
  }
  deriving (Show)

-- * Labels
---------------------------------------------------------------------------

-- | Label names are nonempty strings.

type LabelName = String1

-- | LBNF rule label (AST constructor).

-- the constructors order is important as it will determine
-- the order labels are matched in pattern match.
-- (e.g. if LCons appears before LSg it would catch all cases
-- that would belong to LCons)
data Label
  = LId LabelName  -- ^ ordinary rule label (uppercase)
  | LDef LabelName -- ^ defined label (lowercase)
  -- No representation in AST:
  | LWild          -- ^ coercion @_@
  -- List labels, mapped to the list constructors of the target language.
  | LNil           -- ^ empty list @[]@
  | LSg            -- ^ singleton list @(:[])@ ("robot gorilla")
  | LCons          -- ^ list constructor @(:)@
  deriving (Eq, Ord, Show)

-- * Rule definition
---------------------------------------------------------------------------

-- | Element of a rule right hand side (rhs).

data Item' a
  = Terminal a
      -- ^ Keyword or symbol (not represented in AST).
  | NTerminal Cat
      -- ^ Category (represented in AST).
  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)

type AItem = Item' String1  -- ^ AST/printer flavor.
type Item  = Item' Keyword  -- ^ Parser flavor.

-- | The bare rhs of a rule.

type RHS' a = [Item' a]

-- newtype RHS' a = RHS { theRHS :: [Item' a] }
--   deriving (Eq, Ord, Show, Functor, Foldable, Traversable)

type ARHS = RHS' String1
type RHS  = RHS' Keyword

-- -- | The rule (except lhs) with meta information.

-- data RuleBody = RuleBody
--   { ruleOrigin    :: RuleOrigin  -- ^ A rule can also originate from pragmas.
--   , ruleParseable :: Parseable   -- ^ @internal@ or parseable?
--   , ruleLabel     :: Label       -- ^ The name of the rule.
--   , ruleRHS       :: RHS         -- ^ Right hand side.
--   }
--   deriving (Eq, Show)

-- | The origin of a rule.

data RuleOrigin
  = FromOrdinary   -- ^ Ordinary LBNF rule.
  | FromRules      -- ^ Expanded from @rules@ pragma.
  | FromCoercions  -- ^ Expanded from @coercions@ pragma.
  | FromList       -- ^ Expanded from list pragma: @separator@ or @terminator@.
  deriving (Eq, Ord, Show)

-- | The AST-flavor representation of the rule rhs with meta information.

data ARuleRHS = ARuleRHS
  { aruleOrigin    :: RuleOrigin  -- ^ A rule can also originate from pragmas.
  , aruleParseable :: Parseable   -- ^ @internal@ or parseable?
  , aruleRHS       :: ARHS        -- ^ Right hand side.
  }
  deriving (Eq, Show)

-- | The parser-flavor representation of the rule label with meta information.

data RuleLabel = RuleLabel
  { ruleOrigin    :: RuleOrigin  -- ^ A rule can also originate from pragmas.
  , ruleLabel     :: Label       -- ^ The name of the rule.
  }
  deriving (Eq, Show)

-- * List pragmas
---------------------------------------------------------------------------

data Separator' a
  = Separator a
      -- ^ E.g. @separator _ ","@.
  | Terminator a
      -- ^ E.g. @terminator _ ";"@.
  -- The last case is better represented as @Nothing@.
  -- -- | NoSeparator
  -- --     -- ^ E.g. @separator _ ""@ or @terminator _ ""@.
  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)

type ASeparator = Separator' String1
type  Separator = Separator' Keyword

-- * Flags etc.
---------------------------------------------------------------------------

-- | Is a rule relevant for the parser or only for the AST/printer?

data Parseable
  = Internal   -- ^ @internal@ rule (only for AST & printer)
  | Parseable  -- ^ ordinary rule (also for parser)
  deriving (Eq, Ord, Show)

-- | Does a token category carry position information?

data PositionToken
  = PositionToken     -- ^ from 'position token' pragma
  | NoPositionToken   -- ^ from ordinary 'token' pragma
  deriving (Eq, Ord, Show)

makeLenses ''LBNF

---------------------------------------------------------------------------
-- * Utilities
---------------------------------------------------------------------------

-- ** Categories
---------------------------------------------------------------------------

-- | Convert 'Cat' to 'Type', converting 'CoerceCat' to 'BaseCat'.

catToType :: Cat -> Type
catToType = \case
  Cat c         -> BaseType c
  ListCat c     -> ListType $ catToType c
  CoerceCat x _ -> BaseType $ BaseCat x

catToIdentifier :: Cat -> String1
catToIdentifier = \case
  Cat x         -> baseCatToIdentifier x
  CoerceCat x n -> List1.appendList x $ show n
  ListCat c     -> "List" <> catToIdentifier c

baseCatToIdentifier :: BaseCat -> String1
baseCatToIdentifier = \case
  BuiltinCat b -> printBuiltinCat b
  IdentCat   i -> printIdentCat i
  TokenCat   x -> x
  BaseCat    x -> x

-- | Print @CatName@ from @Cat@ in AST generator.

printCatName :: Cat -> String
printCatName = \case
  Cat       b   -> printBaseCatName b
  ListCat   c   -> printCatName c
  CoerceCat c _ -> toList c

printCatNamePrec :: Cat -> String
printCatNamePrec = \case
  Cat       b   -> printBaseCatName b
  ListCat   c   -> printCatNamePrec c
  CoerceCat c i -> toList c ++ show i

printCatNamePrec' :: Cat -> String
printCatNamePrec' = \case
  Cat       b   -> printBaseCatName b
  ListCat   c   -> "List" ++ printCatNamePrec' c
  CoerceCat c i -> toList c ++ show i

catToString :: Cat -> String
catToString = \case
  Cat       b   -> printBaseCatName b
  ListCat   c   -> printCatName c
  CoerceCat c i -> toList c ++ show i

printBaseCatName :: BaseCat -> String
printBaseCatName = \case
  BuiltinCat b -> toList $ printBuiltinCat b
  IdentCat   i -> toList $ printIdentCat i
  TokenCat   c -> toList c
  BaseCat    c -> toList c

-- | is @Cat@ coerced?

isCatCoerced :: Cat -> Bool
isCatCoerced = \case
  (Cat _)         -> False
  (ListCat _)     -> False
  (CoerceCat _ _) -> True

-- | is @Cat@ list category?

isCatList :: Cat -> Bool
isCatList = \case
  (Cat _)         -> False
  (ListCat _)     -> True
  (CoerceCat _ _) -> False

-- | is @Cat@ between used builtins.

isCatBuiltin :: Cat -> Bool
isCatBuiltin = \case
  (Cat bcat)         -> case bcat of
    BuiltinCat _ -> True
    IdentCat _   -> False
    TokenCat _   -> False
    BaseCat _    -> False
  (ListCat c)     -> isCatBuiltin c
  (CoerceCat _ _) -> False


-- | get @Cat@ coercion number, returns 0 if @Cat@ is not coerced.

getCatPrec :: Cat -> Integer
getCatPrec = \case
  (Cat _)         -> 0
  (ListCat c)     -> getCatPrec c
  (CoerceCat _ i) -> i

-- | When given a list Cat, i.e. '[C]', it removes the square
-- brackets, and adds the prefix List, i.e. 'ListC'.  (for Happy and
-- Latex)
identCat :: Cat -> String
identCat c@(Cat _) = catToString c
identCat (ListCat c) = "List" ++ identCat c
identCat c@(CoerceCat _ _) = catToString c

-- Is a @BaseCat@ a builtin category.
isBuiltin :: BaseCat -> Bool
isBuiltin = \case
  BuiltinCat _ -> True
  IdentCat   _ -> False
  TokenCat   _ -> False
  BaseCat    _ -> False

-- Is a @BaseCat@ an identifier.
isIdentifier :: BaseCat -> Bool
isIdentifier = \case
  BuiltinCat _ -> False
  IdentCat   _ -> True
  TokenCat   _ -> False
  BaseCat    _ -> False

-- Is a @BaseCat@ a token category.
isToken :: BaseCat -> Bool
isToken = \case
  BuiltinCat _ -> False
  IdentCat   _ -> False
  TokenCat   _ -> True
  BaseCat    _ -> False

-- ** Builtin categories
---------------------------------------------------------------------------

builtinCats :: [(BuiltinCat, String1)]
builtinCats = map (\ b -> (b, printBuiltinCat b)) [minBound..maxBound]

printBuiltinCat :: BuiltinCat -> String1
printBuiltinCat = \case
  BChar    -> "Char"
  BDouble  -> "Double"
  BInteger -> "Integer"
  BString  -> "String"

printIdentCat :: IdentCat -> String1
printIdentCat BIdent = "Ident"

parseBuiltinCat :: String1 -> Maybe (Either IdentCat BuiltinCat)
parseBuiltinCat = (`Map.lookup` dict)
  where
  dict :: Map String1 (Either IdentCat BuiltinCat)
  dict = Map.fromList $ map swap identBuiltinCats

identBuiltinCats :: [(Either IdentCat BuiltinCat, String1)]
identBuiltinCats =
  [ (Right BChar,    "Char")
  , (Right BDouble,  "Double")
  , (Right BInteger, "Integer")
  , (Right BString,  "String")
  , (Left  BIdent,   "Ident") ]

tChar, tDouble, tInteger, tString :: Type
tChar    = BaseType $ BuiltinCat BChar
tDouble  = BaseType $ BuiltinCat BDouble
tInteger = BaseType $ BuiltinCat BInteger
tString  = BaseType $ BuiltinCat BString

-- ** Types
---------------------------------------------------------------------------

printTypeName :: Type -> String
printTypeName (BaseType b) = printBaseCatName b
printTypeName (ListType t) = printTypeName t

-- | When given a list Type, i.e. '[C]', it removes the square
-- brackets, and adds the prefix List, i.e. 'ListC'.  (for Happy and
-- Latex)
identType :: Type -> String
identType (BaseType b) = printBaseCatName b
identType (ListType t) = "List" ++ identType t

isListType :: Type -> Bool
isListType (BaseType _) = False
isListType (ListType _) = True

isBuiltinType :: Type -> Bool
isBuiltinType (BaseType b) = isBuiltin b
isBuiltinType (ListType t) = isBuiltinType t

isIdentType :: Type -> Bool
isIdentType (BaseType b) = isIdentifier b
isIdentType (ListType t) = isIdentType t

isTokenType :: Type -> Bool
isTokenType (BaseType b) = isToken b
isTokenType (ListType t) = isTokenType t

-- ** Labels
---------------------------------------------------------------------------

labelFromIdentifier :: LabelName -> Label
labelFromIdentifier x
  | isLower c = LDef x
  | isUpper c = LId  x
  | otherwise = panic "label has to start with letter"
  where
  c = List1.head x

-- | Print @Label@ name.
printLabelName :: Label -> String
printLabelName = \case
  LId  lname -> toList lname
  LDef lname -> toList lname
  LWild      -> panicName
  LNil       -> panicName
  LCons      -> panicName
  LSg        -> panicName
  where
    panicName = panic "trying to print name from label with no name"

-- Print parser rule name.
printRuleName :: Label -> String
printRuleName = \case
  LId  lname -> toList lname
  LDef lname -> toList lname
  LWild      -> "_"
  LNil       -> "[]"
  LCons      -> "(:)"
  LSg        -> "(:[])"

isDef :: Label -> Bool
isDef = \case
  LId  _ -> False
  LDef _ -> True
  LWild  -> False
  LNil   -> False
  LCons  -> False
  LSg    -> False

isCoercion :: Label -> Bool
isCoercion = \case
  LId  _ -> False
  LDef _ -> False
  LWild  -> True
  LNil   -> False
  LCons  -> False
  LSg    -> False

isList :: Label -> Bool
isList = \case
  LId  _ -> False
  LDef _ -> False
  LWild  -> False
  LNil   -> True
  LCons  -> True
  LSg    -> True

-- Will the @Label@ be used to print the AST ?
isALabel :: Label -> Bool
isALabel = \case
  LId  _ -> True
  LDef _ -> False
  LWild  -> False
  LNil   -> False
  LCons  -> False
  LSg    -> False

-- Will the @Label@ be used to print the pretty printer ?
isPLabel :: Label -> Bool
isPLabel = \case
  LId  _ -> True
  LDef _ -> False
  LWild  -> False
  LNil   -> True
  LCons  -> True
  LSg    -> True

-- | Filter @Label@s that will be printed in the AST datatypes.

filterLabelsAST :: [String]
                -> [(Label, ([Type], (Integer, ARHS)))]
                -> [(Label, ([Type], (Integer, ARHS)))]
filterLabelsAST fNames =
  filter (\(l,_) -> isALabel l && notElem (printLabelName l) fNames)

-- | Filter @Label@s that will be printed in the Pretty printer.

filterLabelsPrinter :: [String]
                    -> [(Label, ([Type], (Integer, ARHS)))]
                    -> [(Label, ([Type], (Integer, ARHS)))]
filterLabelsPrinter fNames =
  filter (\(l,_) -> isPLabel l && notElem (printLabelName l) fNames)

-- ** RHS
---------------------------------------------------------------------------

-- | Print names of @Cat@ in a rhs.
printRhsCats :: [Item' a] -> [String]
printRhsCats = mapMaybe printItemCat
  where
    printItemCat :: Item' a -> Maybe String
    printItemCat (Terminal _)    = Nothing
    printItemCat (NTerminal cat) = Just $ printCatName cat

-- | Print rhs @Item@s, both non terminals and terminals.
printRHS :: [Item' Keyword] -> [String]
printRHS items = printItem <$> items
  where
  printItem :: Item' Keyword -> String
  printItem (Terminal k)    = "'" ++ (escapeChars . toList . theKeyword) k ++ "'"
  printItem (NTerminal cat) = printCatNamePrec' cat


-- | Get @Cat@s in a rhs.
getRhsCats :: [Item' a] -> [Cat]
getRhsCats = mapMaybe getItemCat
  where
    getItemCat :: Item' a -> Maybe Cat
    getItemCat (Terminal _)    = Nothing
    getItemCat (NTerminal cat) = Just cat


printItemName :: Item' String1 -> String
printItemName (Terminal s1)   = '"' : (escapeChars . toList) s1 ++ ['"']
printItemName (NTerminal cat) = printCatNamePrec cat

isNTerminal :: Item' a -> Bool
isNTerminal (Terminal _)  = False
isNTerminal (NTerminal _) = True

isItemListCat :: Item' a -> Bool
isItemListCat (Terminal _)  = False
isItemListCat (NTerminal cat) = case cat of
  (Cat _)         -> False
  (ListCat _)     -> True
  (CoerceCat _ _) -> False

isItemBuiltin :: Item' a -> Bool
isItemBuiltin (Terminal _)  = False
isItemBuiltin (NTerminal cat) = isCatBuiltin cat

-- | Get the non-terminals of a rhs in left-to-right order.
--
rhsCats :: RHS' a -> [Cat]
rhsCats = mapMaybe $ \case
    Terminal{}  -> Nothing
    NTerminal c -> Just c

-- | Get the types of a rhs.
--
rhsType :: RHS' a -> [Type]
rhsType = map catToType . rhsCats

-- ** Token definitions
---------------------------------------------------------------------------

-- | does a token definition contain a no position token.
isNoPositionToken :: WithPosition TokenDef -> Bool
isNoPositionToken def = positionToken (wpThing def) == NoPositionToken

-- | does a token definition contain (with position) a position token.
isPositionToken :: WithPosition TokenDef -> Bool
isPositionToken def = positionToken (wpThing def) == PositionToken

-- | does a token definition contain a position token.
isPosToken :: TokenDef -> Bool
isPosToken def = positionToken def == PositionToken

hasIdentifier :: TokenDefs -> Bool
hasIdentifier defs =
  length
  (filter (== True) (isIdent . wpThing <$> Map.elems defs))
  == 1

-- ** Functions
---------------------------------------------------------------------------

-- | Print @Exp@ (function body in define pragma).

printExp :: Bool -> String -> Exp -> String
printExp functor functorParam exp =
  if functor
  then printExp2 functorParam exp
  else printExp1 exp

printExp1 :: Exp -> String
printExp1 = \case
  (App label _fType exps)
    -> printLabelName label
       ++ concatMap
          (\e ->
          if isApp1 e
          then " (" ++ printExp1 e ++ ")"
          else ((" " ++) . printExp1) e)
          exps
  (Var p)        -> toList $ paramName p
  (LitInteger i) -> show i
  (LitDouble d)  -> show d
  (LitChar c)    -> "\"" ++ show c ++ "\""
  (LitString s)  -> "\"" ++ s ++ "\""

printExp2 :: String -> Exp -> String
printExp2 functorParam = \case
  (App label fType exps)
    -> if isTokenType $ targetType fType
       then printLabelName label
       else printLabelName label ++ " " ++ functorParam
        ++ concatMap
          (\e ->
          if isApp2 e
          then " (" ++ printExp2 functorParam e ++ ")"
          else ((" " ++) . printExp2 functorParam) e)
          exps
  (Var p)        -> toList $ paramName p
  (LitInteger i) -> show i
  (LitDouble d)  -> show d
  (LitChar c)    -> "\"" ++ show c ++ "\""
  (LitString s)  -> "\"" ++ s ++ "\""

-- Is @Exp@ an application containing a non emtpy list of expressions.
isApp1 :: Exp -> Bool
isApp1 = \case
  App _ _ exps -> not $ null exps
  Var _ -> False
  LitInteger _ -> False
  LitDouble _ -> False
  LitChar _ -> False
  LitString _ -> False

-- Is @Exp@ an application.
isApp2 :: Exp -> Bool
isApp2 = \case
  App _ _ _ -> True
  Var _ -> False
  LitInteger _ -> False
  LitDouble _ -> False
  LitChar _ -> False
  LitString _ -> False

-- ** Keywords
---------------------------------------------------------------------------

-- | All-whitespace strings (in particular, empty strings) give 'Nothing'.

getKeyword :: Separator -> Keyword
getKeyword = \case
  (Separator k) -> k
  (Terminator k) -> k

parseKeyword :: String -> Maybe Keyword
parseKeyword s = Keyword <$> trim1 s

parseASeparator :: Separator' String -> Maybe ASeparator
parseASeparator = traverse List1.nonEmpty

trimSeparator :: ASeparator -> Maybe Separator
trimSeparator = traverse $ parseKeyword . toList


-- ** Parser rules.
---------------------------------------------------------------------------

lookupRHS :: Cat -> RHS -> ParserRules -> Maybe (WithPosition RuleLabel)
lookupRHS cat rhs = Map.lookup rhs <=< Map.lookup cat


-- ** Layouts.
---------------------------------------------------------------------------

-- This function doesn't check for layout stop since a layout stop can not
-- occur without a layout start. This is checked in the checks performed before
-- the state initialization.
layoutsAreUsed :: LBNF -> Bool
layoutsAreUsed lbnf =
  isJust (_lbnfLayoutTop lbnf)
  ||
  not (Map.null (_lbnfLayoutStart lbnf))