{-# LANGUAGE DeriveTraversable #-}  -- implies DeriveFunctor, DeriveFoldable
{-# LANGUAGE FlexibleInstances #-}  -- implies TypeSynonymInstances
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}

{-
    BNF Converter: Abstract syntax
    Copyright (C) 2004  Author:  Markus Forsberg, Michael Pellauer, Aarne Ranta

-}

module BNFC.CF (
            -- Types.
            CF,
            CFG(..),
            Rule, Rul(..), npRule, valCat, lookupRule, InternalRule(..),
            Pragma(..),
            Exp(..),
            Base(..), Type(..), Signature,
            Literal,
            Symbol,
            KeyWord,
            Position(..), noPosition, prettyPosition, npIdentifier,
            WithPosition(..), blendInPosition,
            RString, RCat,
            Cat(..), strToCat, catToStr,
            BaseCat, TokenCat,
            catString, catInteger, catDouble, catChar, catIdent,
            NonTerminal, SentForm,
            Fun, RFun, IsFun(..),
            Data,           -- describes the abstract syntax of a grammar
            cf2data,        -- translates a grammar to a Data object.
            cf2dataLists,   -- translates to a Data with List categories included.
            getAbstractSyntax,
            -- Literal categories, constants,
            firstEntry,     -- the first entry or the first value category
            baseTokenCatNames,  -- "Char", "Double", "Integer", "String"
            specialCats,    -- ident
            specialCatsP,   -- all literals
            specialData,    -- special data
            isCoercion,     -- wildcards in grammar (avoid syntactic clutter)
            isDefinedRule,  -- defined rules (allows syntactic sugar)
            isProperLabel,  -- not coercion or defined rule
            allCats,        -- all categories of a grammar
            allParserCats, allParserCatsNorm,
            reallyAllCats,
            allCatsNorm,
            allCatsIdNorm,
            allEntryPoints,
            reservedWords,
            cfTokens,
            literals,
            findAllReversibleCats, -- find all reversible categories
            identCat,       -- transforms '[C]' to ListC (others, unchanged).
            isParsable,
            rulesForCat,    -- rules for a given category
            rulesForNormalizedCat,    -- rules for a given category
            ruleGroups,     -- Categories are grouped with their rules.
            ruleGroupsInternals, --As above, but includes internal cats.
            allNames,        -- Checking for non-unique names, like @Name. Name ::= Ident;@.
            filterNonUnique,
            isList,         -- Checks if a category is a list category.
            isTokenCat, maybeTokenCat,
            baseCat,
            sameCat,
            -- Information functions for list functions.
            isNilFun,       -- empty list function? ([])
            isOneFun,       -- one element list function? (:[])
            hasOneFunc,
            getCons,
            getSeparatorByPrecedence,
            isConsFun,      -- constructor function? (:)
            isNilCons,      -- either three of above?
            isEmptyListCat, -- checks if the list permits []
            revSepListRule, -- reverse a rule, if it is of form C t [C].
            normCat,
            isDataCat, isDataOrListCat,
            normCatOfList,  -- Removes precendence information and enclosed List. C1 => C, C2 => C
            catOfList,
            comments,       -- translates the pragmas into two list containing the s./m. comments
            numberOfBlockCommentForms,
            tokenPragmas,   -- get the user-defined regular expression tokens
            tokenNames,     -- get the names of all user-defined tokens
            precCat,        -- get the precendence level of a Cat C1 => 1, C => 0
            precRule,       -- get the precendence level of the value category of a rule.
            isUsedCat,
            isPositionCat,
            hasPositionTokens,
            hasIdent, hasIdentLikeTokens,
            hasLayout,
            layoutPragmas,
            sigLookup      -- Get the type of a rule label.
           ) where

import Control.Monad (guard)
import Data.Char
import Data.Function (on)
import Data.List (nub, intersperse, sort, group, intercalate, find)
import qualified Data.List as List
import Data.List.NonEmpty (pattern (:|), (<|))
import qualified Data.List.NonEmpty as List1
import Data.Maybe
import Data.Map  (Map)
import qualified Data.Map as Map
import Data.Set  (Set)
import qualified Data.Set as Set
import Data.String  (IsString(..))

import BNFC.Abs (Reg())
import BNFC.Par (pCat)
import BNFC.Lex (tokens)
import qualified BNFC.Abs as Abs

import BNFC.Utils (spanEnd)

type List1 = List1.NonEmpty

-- | A context free grammar consists of a set of rules and some extended
-- information (e.g. pragmas, literals, symbols, keywords).

type CF = CFG RFun

-- | A rule consists of a function name, a main category and a sequence of
-- terminals and non-terminals.
--
-- @
--   function_name . Main_Cat ::= sequence
-- @

type Rule = Rul RFun

-- | Polymorphic rule type.

-- N.B.: Was originally made polymorphic for the sake of removed backend --profile.
data Rul function = Rule
  { forall function. Rul function -> function
funRule :: function
      -- ^ The function (semantic action) of a rule.
      --   In order to be able to generate data types this must be a constructor
      --   (or an identity function).
  , forall function. Rul function -> RCat
valRCat :: RCat
      -- ^ The value category, i.e., the defined non-terminal.
  , forall function. Rul function -> SentForm
rhsRule :: SentForm
      -- ^ The sentential form, i.e.,
      --   the list of (non)terminals in the right-hand-side of a rule.
  , forall function. Rul function -> InternalRule
internal :: InternalRule
      -- ^ Is this an "internal" rule only for the AST and printing,
      --   not for parsing?
  } deriving (Rul function -> Rul function -> Bool
(Rul function -> Rul function -> Bool)
-> (Rul function -> Rul function -> Bool) -> Eq (Rul function)
forall function.
Eq function =>
Rul function -> Rul function -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Rul function -> Rul function -> Bool
$c/= :: forall function.
Eq function =>
Rul function -> Rul function -> Bool
== :: Rul function -> Rul function -> Bool
$c== :: forall function.
Eq function =>
Rul function -> Rul function -> Bool
Eq, (forall a b. (a -> b) -> Rul a -> Rul b)
-> (forall a b. a -> Rul b -> Rul a) -> Functor Rul
forall a b. a -> Rul b -> Rul a
forall a b. (a -> b) -> Rul a -> Rul b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Rul b -> Rul a
$c<$ :: forall a b. a -> Rul b -> Rul a
fmap :: forall a b. (a -> b) -> Rul a -> Rul b
$cfmap :: forall a b. (a -> b) -> Rul a -> Rul b
Functor)

data InternalRule
  = Internal  -- ^ @internal@ rule (only for AST & printer)
  | Parsable  -- ^ ordinary rule (also for parser)
  deriving (InternalRule -> InternalRule -> Bool
(InternalRule -> InternalRule -> Bool)
-> (InternalRule -> InternalRule -> Bool) -> Eq InternalRule
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InternalRule -> InternalRule -> Bool
$c/= :: InternalRule -> InternalRule -> Bool
== :: InternalRule -> InternalRule -> Bool
$c== :: InternalRule -> InternalRule -> Bool
Eq)

instance (Show function) => Show (Rul function) where
  show :: Rul function -> [Char]
show (Rule function
f RCat
cat SentForm
rhs InternalRule
internal) = [[Char]] -> [Char]
unwords ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
    (if InternalRule
internal InternalRule -> InternalRule -> Bool
forall a. Eq a => a -> a -> Bool
== InternalRule
Internal then ([Char]
"internal" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:) else [[Char]] -> [[Char]]
forall a. a -> a
id) ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
    function -> [Char]
forall a. Show a => a -> [Char]
show function
f [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char]
"." [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: RCat -> [Char]
forall a. Show a => a -> [Char]
show RCat
cat [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char]
"::=" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (Either Cat [Char] -> [Char]) -> SentForm -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ((Cat -> [Char]) -> ShowS -> Either Cat [Char] -> [Char]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Cat -> [Char]
forall a. Show a => a -> [Char]
show ShowS
forall a. a -> a
id) SentForm
rhs

-- | A sentential form is a sequence of non-terminals or terminals.
type SentForm = [Either Cat String]

-- | Type of context-free grammars (GFG).

data CFG function = CFG
    { forall function. CFG function -> [Pragma]
cfgPragmas        :: [Pragma]
    , forall function. CFG function -> Set Cat
cfgUsedCats       :: Set Cat    -- ^ Categories used by the parser.
    , forall function. CFG function -> [[Char]]
cfgLiterals       :: [Literal]  -- ^ @Char, String, Ident, Integer, Double@.
                                      --   @String@s are quoted strings,
                                      --   and @Ident@s are unquoted.
    , forall function. CFG function -> [[Char]]
cfgSymbols        :: [Symbol]   -- ^ Symbols in the grammar, e.g. “*”, “->”.
    , forall function. CFG function -> [[Char]]
cfgKeywords       :: [KeyWord]  -- ^ Reserved words, e.g. @if@, @while@.
    , forall function. CFG function -> [Cat]
cfgReversibleCats :: [Cat]      -- ^ Categories that can be made left-recursive.
    , forall function. CFG function -> [Rul function]
cfgRules          :: [Rul function]
    , forall function. CFG function -> Signature
cfgSignature      :: Signature  -- ^ Types of rule labels, computed from 'cfgRules'.
    } deriving ((forall a b. (a -> b) -> CFG a -> CFG b)
-> (forall a b. a -> CFG b -> CFG a) -> Functor CFG
forall a b. a -> CFG b -> CFG a
forall a b. (a -> b) -> CFG a -> CFG b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> CFG b -> CFG a
$c<$ :: forall a b. a -> CFG b -> CFG a
fmap :: forall a b. (a -> b) -> CFG a -> CFG b
$cfmap :: forall a b. (a -> b) -> CFG a -> CFG b
Functor)


instance (Show function) => Show (CFG function) where
  show :: CFG function -> [Char]
show CFG{[[Char]]
[Cat]
[Pragma]
[Rul function]
Signature
Set Cat
cfgSignature :: Signature
cfgRules :: [Rul function]
cfgReversibleCats :: [Cat]
cfgKeywords :: [[Char]]
cfgSymbols :: [[Char]]
cfgLiterals :: [[Char]]
cfgUsedCats :: Set Cat
cfgPragmas :: [Pragma]
cfgSignature :: forall function. CFG function -> Signature
cfgRules :: forall function. CFG function -> [Rul function]
cfgReversibleCats :: forall function. CFG function -> [Cat]
cfgKeywords :: forall function. CFG function -> [[Char]]
cfgSymbols :: forall function. CFG function -> [[Char]]
cfgLiterals :: forall function. CFG function -> [[Char]]
cfgUsedCats :: forall function. CFG function -> Set Cat
cfgPragmas :: forall function. CFG function -> [Pragma]
..} = [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Rul function -> [Char]) -> [Rul function] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Rul function -> [Char]
forall a. Show a => a -> [Char]
show [Rul function]
cfgRules

-- | Types of the rule labels, together with the position of the rule label.
type Signature = Map String (WithPosition Type)

-- | Type of a non-terminal.
data Base = BaseT String
          | ListT Base
    deriving (Base -> Base -> Bool
(Base -> Base -> Bool) -> (Base -> Base -> Bool) -> Eq Base
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Base -> Base -> Bool
$c/= :: Base -> Base -> Bool
== :: Base -> Base -> Bool
$c== :: Base -> Base -> Bool
Eq, Eq Base
Eq Base
-> (Base -> Base -> Ordering)
-> (Base -> Base -> Bool)
-> (Base -> Base -> Bool)
-> (Base -> Base -> Bool)
-> (Base -> Base -> Bool)
-> (Base -> Base -> Base)
-> (Base -> Base -> Base)
-> Ord Base
Base -> Base -> Bool
Base -> Base -> Ordering
Base -> Base -> Base
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Base -> Base -> Base
$cmin :: Base -> Base -> Base
max :: Base -> Base -> Base
$cmax :: Base -> Base -> Base
>= :: Base -> Base -> Bool
$c>= :: Base -> Base -> Bool
> :: Base -> Base -> Bool
$c> :: Base -> Base -> Bool
<= :: Base -> Base -> Bool
$c<= :: Base -> Base -> Bool
< :: Base -> Base -> Bool
$c< :: Base -> Base -> Bool
compare :: Base -> Base -> Ordering
$ccompare :: Base -> Base -> Ordering
Ord)

-- | Type of a rule label.
data Type = FunT [Base] Base
    deriving (Type -> Type -> Bool
(Type -> Type -> Bool) -> (Type -> Type -> Bool) -> Eq Type
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Type -> Type -> Bool
$c/= :: Type -> Type -> Bool
== :: Type -> Type -> Bool
$c== :: Type -> Type -> Bool
Eq, Eq Type
Eq Type
-> (Type -> Type -> Ordering)
-> (Type -> Type -> Bool)
-> (Type -> Type -> Bool)
-> (Type -> Type -> Bool)
-> (Type -> Type -> Bool)
-> (Type -> Type -> Type)
-> (Type -> Type -> Type)
-> Ord Type
Type -> Type -> Bool
Type -> Type -> Ordering
Type -> Type -> Type
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Type -> Type -> Type
$cmin :: Type -> Type -> Type
max :: Type -> Type -> Type
$cmax :: Type -> Type -> Type
>= :: Type -> Type -> Bool
$c>= :: Type -> Type -> Bool
> :: Type -> Type -> Bool
$c> :: Type -> Type -> Bool
<= :: Type -> Type -> Bool
$c<= :: Type -> Type -> Bool
< :: Type -> Type -> Bool
$c< :: Type -> Type -> Bool
compare :: Type -> Type -> Ordering
$ccompare :: Type -> Type -> Ordering
Ord)

instance Show Base where
    show :: Base -> [Char]
show (BaseT [Char]
x) = [Char]
x
    show (ListT Base
t) = [Char]
"[" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Base -> [Char]
forall a. Show a => a -> [Char]
show Base
t [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"]"

instance Show Type where
    show :: Type -> [Char]
show (FunT [Base]
ts Base
t) = [[Char]] -> [Char]
unwords ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Base -> [Char]) -> [Base] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Base -> [Char]
forall a. Show a => a -> [Char]
show [Base]
ts [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"->", Base -> [Char]
forall a. Show a => a -> [Char]
show Base
t]

-- | Expressions for function definitions.

data Exp
  = App String [Exp]  -- ^ (Possibly defined) label applied to expressions.
  | Var String        -- ^ Function parameter.
  | LitInt Integer
  | LitDouble Double
  | LitChar Char
  | LitString String
  deriving (Exp -> Exp -> Bool
(Exp -> Exp -> Bool) -> (Exp -> Exp -> Bool) -> Eq Exp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Exp -> Exp -> Bool
$c/= :: Exp -> Exp -> Bool
== :: Exp -> Exp -> Bool
$c== :: Exp -> Exp -> Bool
Eq)

instance Show Exp where
    showsPrec :: Int -> Exp -> ShowS
showsPrec Int
p Exp
e =
        case Exp -> Either Exp [Exp]
listView Exp
e of
            Right [Exp]
es    ->
                [Char] -> ShowS
showString [Char]
"["
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id (ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
intersperse ([Char] -> ShowS
showString [Char]
", ") ([ShowS] -> [ShowS]) -> [ShowS] -> [ShowS]
forall a b. (a -> b) -> a -> b
$ (Exp -> ShowS) -> [Exp] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> ShowS
forall a. Show a => a -> ShowS
shows [Exp]
es)
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
"]"
            Left (Var [Char]
x)    -> [Char] -> ShowS
showString [Char]
x
            Left (App [Char]
x []) -> [Char] -> ShowS
showString [Char]
x
            Left (App  [Char]
"(:)" [Exp
e1,Exp
e2]) ->
                Bool -> ShowS -> ShowS
showParen (Int
pInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0)
                (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> Exp -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
1 Exp
e1
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" : "
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> ShowS
forall a. Show a => a -> ShowS
shows Exp
e2
            Left (App [Char]
x [Exp]
es) ->
                Bool -> ShowS -> ShowS
showParen (Int
pInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
1)
                (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id
                ([ShowS] -> ShowS) -> [ShowS] -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
intersperse ([Char] -> ShowS
showString [Char]
" ")
                ([ShowS] -> [ShowS]) -> [ShowS] -> [ShowS]
forall a b. (a -> b) -> a -> b
$ [Char] -> ShowS
showString [Char]
x ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
: (Exp -> ShowS) -> [Exp] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Exp -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
2) [Exp]
es
            Left (LitInt Integer
n)     -> Integer -> ShowS
forall a. Show a => a -> ShowS
shows Integer
n
            Left (LitDouble Double
x)  -> Double -> ShowS
forall a. Show a => a -> ShowS
shows Double
x
            Left (LitChar Char
c)    -> Char -> ShowS
forall a. Show a => a -> ShowS
shows Char
c
            Left (LitString [Char]
s)  -> [Char] -> ShowS
forall a. Show a => a -> ShowS
shows [Char]
s
        where
            listView :: Exp -> Either Exp [Exp]
listView (App [Char]
"[]" []) = [Exp] -> Either Exp [Exp]
forall a b. b -> Either a b
Right []
            listView (App [Char]
"(:)" [Exp
e1,Exp
e2])
                | Right [Exp]
es <- Exp -> Either Exp [Exp]
listView Exp
e2   = [Exp] -> Either Exp [Exp]
forall a b. b -> Either a b
Right ([Exp] -> Either Exp [Exp]) -> [Exp] -> Either Exp [Exp]
forall a b. (a -> b) -> a -> b
$ Exp
e1Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
:[Exp]
es
            listView Exp
x = Exp -> Either Exp [Exp]
forall a b. a -> Either a b
Left Exp
x

-- | Pragmas.

data Pragma
  = CommentS  String              -- ^ for single line comments
  | CommentM (String, String)     -- ^  for multiple-line comments.
  | TokenReg RString Bool Reg     -- ^ for tokens
  | EntryPoints [RCat]
  | Layout [String]
  | LayoutStop [String]
  | LayoutTop
  | FunDef RFun [String] Exp
  deriving (Int -> Pragma -> ShowS
[Pragma] -> ShowS
Pragma -> [Char]
(Int -> Pragma -> ShowS)
-> (Pragma -> [Char]) -> ([Pragma] -> ShowS) -> Show Pragma
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Pragma] -> ShowS
$cshowList :: [Pragma] -> ShowS
show :: Pragma -> [Char]
$cshow :: Pragma -> [Char]
showsPrec :: Int -> Pragma -> ShowS
$cshowsPrec :: Int -> Pragma -> ShowS
Show)

-- | User-defined regular expression tokens
tokenPragmas :: CFG f -> [(TokenCat,Reg)]
tokenPragmas :: forall f. CFG f -> [([Char], Reg)]
tokenPragmas CFG f
cf = [ (RFun -> [Char]
forall a. WithPosition a -> a
wpThing RFun
name, Reg
e) | TokenReg RFun
name Bool
_ Reg
e <- CFG f -> [Pragma]
forall function. CFG function -> [Pragma]
cfgPragmas CFG f
cf ]

-- | The names of all user-defined tokens.
tokenNames :: CFG f -> [String]
tokenNames :: forall function. CFG function -> [[Char]]
tokenNames CFG f
cf = (([Char], Reg) -> [Char]) -> [([Char], Reg)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Reg) -> [Char]
forall a b. (a, b) -> a
fst (CFG f -> [([Char], Reg)]
forall f. CFG f -> [([Char], Reg)]
tokenPragmas CFG f
cf)

layoutPragmas :: CF -> (Bool,[String],[String])
layoutPragmas :: CF -> (Bool, [[Char]], [[Char]])
layoutPragmas CF
cf = let ps :: [Pragma]
ps = CF -> [Pragma]
forall function. CFG function -> [Pragma]
cfgPragmas CF
cf in (
  Bool -> Bool
not ([()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [() | Pragma
LayoutTop  <- [Pragma]
ps]),   -- if there's layout betw top-level
  [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[Char]]
ss | Layout [[Char]]
ss     <- [Pragma]
ps],    -- layout-block starting words
  [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[Char]]
ss | LayoutStop [[Char]]
ss <- [Pragma]
ps]     -- layout-block ending words
  )

hasLayout :: CF -> Bool
hasLayout :: CF -> Bool
hasLayout CF
cf = case CF -> (Bool, [[Char]], [[Char]])
layoutPragmas CF
cf of
  (Bool
t,[[Char]]
ws,[[Char]]
_) -> Bool
t Bool -> Bool -> Bool
|| Bool -> Bool
not ([[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
ws)   -- (True,[],_) means: top-level layout only

-- | Literal: builtin-token types Char, String, Ident, Integer, Double.
type Literal = String
type Symbol  = String
type KeyWord = String

------------------------------------------------------------------------------
-- Identifiers with position information
------------------------------------------------------------------------------

-- | Source positions.
data Position
  = NoPosition
  | Position
    { Position -> [Char]
posFile    :: FilePath  -- ^ Name of the grammar file.
    , Position -> Int
posLine    :: Int       -- ^ Line in the grammar file.
    , Position -> Int
posColumn  :: Int       -- ^ Column in the grammar file.
    } deriving (Int -> Position -> ShowS
[Position] -> ShowS
Position -> [Char]
(Int -> Position -> ShowS)
-> (Position -> [Char]) -> ([Position] -> ShowS) -> Show Position
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Position] -> ShowS
$cshowList :: [Position] -> ShowS
show :: Position -> [Char]
$cshow :: Position -> [Char]
showsPrec :: Int -> Position -> ShowS
$cshowsPrec :: Int -> Position -> ShowS
Show, Position -> Position -> Bool
(Position -> Position -> Bool)
-> (Position -> Position -> Bool) -> Eq Position
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Position -> Position -> Bool
$c/= :: Position -> Position -> Bool
== :: Position -> Position -> Bool
$c== :: Position -> Position -> Bool
Eq, Eq Position
Eq Position
-> (Position -> Position -> Ordering)
-> (Position -> Position -> Bool)
-> (Position -> Position -> Bool)
-> (Position -> Position -> Bool)
-> (Position -> Position -> Bool)
-> (Position -> Position -> Position)
-> (Position -> Position -> Position)
-> Ord Position
Position -> Position -> Bool
Position -> Position -> Ordering
Position -> Position -> Position
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Position -> Position -> Position
$cmin :: Position -> Position -> Position
max :: Position -> Position -> Position
$cmax :: Position -> Position -> Position
>= :: Position -> Position -> Bool
$c>= :: Position -> Position -> Bool
> :: Position -> Position -> Bool
$c> :: Position -> Position -> Bool
<= :: Position -> Position -> Bool
$c<= :: Position -> Position -> Bool
< :: Position -> Position -> Bool
$c< :: Position -> Position -> Bool
compare :: Position -> Position -> Ordering
$ccompare :: Position -> Position -> Ordering
Ord)

prettyPosition :: Position -> String
prettyPosition :: Position -> [Char]
prettyPosition = \case
  Position
NoPosition -> [Char]
""
  Position [Char]
file Int
line Int
col -> [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
List.intercalate [Char]
":" [ [Char]
file, Int -> [Char]
forall a. Show a => a -> [Char]
show Int
line, Int -> [Char]
forall a. Show a => a -> [Char]
show Int
col, [Char]
"" ]

data WithPosition a = WithPosition
  { forall a. WithPosition a -> Position
wpPosition :: Position
  , forall a. WithPosition a -> a
wpThing    :: a
  } deriving (Int -> WithPosition a -> ShowS
[WithPosition a] -> ShowS
WithPosition a -> [Char]
(Int -> WithPosition a -> ShowS)
-> (WithPosition a -> [Char])
-> ([WithPosition a] -> ShowS)
-> Show (WithPosition a)
forall a. Show a => Int -> WithPosition a -> ShowS
forall a. Show a => [WithPosition a] -> ShowS
forall a. Show a => WithPosition a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [WithPosition a] -> ShowS
$cshowList :: forall a. Show a => [WithPosition a] -> ShowS
show :: WithPosition a -> [Char]
$cshow :: forall a. Show a => WithPosition a -> [Char]
showsPrec :: Int -> WithPosition a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> WithPosition a -> ShowS
Show, (forall a b. (a -> b) -> WithPosition a -> WithPosition b)
-> (forall a b. a -> WithPosition b -> WithPosition a)
-> Functor WithPosition
forall a b. a -> WithPosition b -> WithPosition a
forall a b. (a -> b) -> WithPosition a -> WithPosition b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> WithPosition b -> WithPosition a
$c<$ :: forall a b. a -> WithPosition b -> WithPosition a
fmap :: forall a b. (a -> b) -> WithPosition a -> WithPosition b
$cfmap :: forall a b. (a -> b) -> WithPosition a -> WithPosition b
Functor, (forall m. Monoid m => WithPosition m -> m)
-> (forall m a. Monoid m => (a -> m) -> WithPosition a -> m)
-> (forall m a. Monoid m => (a -> m) -> WithPosition a -> m)
-> (forall a b. (a -> b -> b) -> b -> WithPosition a -> b)
-> (forall a b. (a -> b -> b) -> b -> WithPosition a -> b)
-> (forall b a. (b -> a -> b) -> b -> WithPosition a -> b)
-> (forall b a. (b -> a -> b) -> b -> WithPosition a -> b)
-> (forall a. (a -> a -> a) -> WithPosition a -> a)
-> (forall a. (a -> a -> a) -> WithPosition a -> a)
-> (forall a. WithPosition a -> [a])
-> (forall a. WithPosition a -> Bool)
-> (forall a. WithPosition a -> Int)
-> (forall a. Eq a => a -> WithPosition a -> Bool)
-> (forall a. Ord a => WithPosition a -> a)
-> (forall a. Ord a => WithPosition a -> a)
-> (forall a. Num a => WithPosition a -> a)
-> (forall a. Num a => WithPosition a -> a)
-> Foldable WithPosition
forall a. Eq a => a -> WithPosition a -> Bool
forall a. Num a => WithPosition a -> a
forall a. Ord a => WithPosition a -> a
forall m. Monoid m => WithPosition m -> m
forall a. WithPosition a -> Bool
forall a. WithPosition a -> Int
forall a. WithPosition a -> [a]
forall a. (a -> a -> a) -> WithPosition a -> a
forall m a. Monoid m => (a -> m) -> WithPosition a -> m
forall b a. (b -> a -> b) -> b -> WithPosition a -> b
forall a b. (a -> b -> b) -> b -> WithPosition a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => WithPosition a -> a
$cproduct :: forall a. Num a => WithPosition a -> a
sum :: forall a. Num a => WithPosition a -> a
$csum :: forall a. Num a => WithPosition a -> a
minimum :: forall a. Ord a => WithPosition a -> a
$cminimum :: forall a. Ord a => WithPosition a -> a
maximum :: forall a. Ord a => WithPosition a -> a
$cmaximum :: forall a. Ord a => WithPosition a -> a
elem :: forall a. Eq a => a -> WithPosition a -> Bool
$celem :: forall a. Eq a => a -> WithPosition a -> Bool
length :: forall a. WithPosition a -> Int
$clength :: forall a. WithPosition a -> Int
null :: forall a. WithPosition a -> Bool
$cnull :: forall a. WithPosition a -> Bool
toList :: forall a. WithPosition a -> [a]
$ctoList :: forall a. WithPosition a -> [a]
foldl1 :: forall a. (a -> a -> a) -> WithPosition a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> WithPosition a -> a
foldr1 :: forall a. (a -> a -> a) -> WithPosition a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> WithPosition a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> WithPosition a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> WithPosition a -> b
foldl :: forall b a. (b -> a -> b) -> b -> WithPosition a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> WithPosition a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> WithPosition a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> WithPosition a -> b
foldr :: forall a b. (a -> b -> b) -> b -> WithPosition a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> WithPosition a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> WithPosition a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> WithPosition a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> WithPosition a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> WithPosition a -> m
fold :: forall m. Monoid m => WithPosition m -> m
$cfold :: forall m. Monoid m => WithPosition m -> m
Foldable, Functor WithPosition
Foldable WithPosition
Functor WithPosition
-> Foldable WithPosition
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> WithPosition a -> f (WithPosition b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    WithPosition (f a) -> f (WithPosition a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> WithPosition a -> m (WithPosition b))
-> (forall (m :: * -> *) a.
    Monad m =>
    WithPosition (m a) -> m (WithPosition a))
-> Traversable WithPosition
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
WithPosition (m a) -> m (WithPosition a)
forall (f :: * -> *) a.
Applicative f =>
WithPosition (f a) -> f (WithPosition a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> WithPosition a -> m (WithPosition b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> WithPosition a -> f (WithPosition b)
sequence :: forall (m :: * -> *) a.
Monad m =>
WithPosition (m a) -> m (WithPosition a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
WithPosition (m a) -> m (WithPosition a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> WithPosition a -> m (WithPosition b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> WithPosition a -> m (WithPosition b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
WithPosition (f a) -> f (WithPosition a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
WithPosition (f a) -> f (WithPosition a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> WithPosition a -> f (WithPosition b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> WithPosition a -> f (WithPosition b)
Traversable)

-- | Ignore position in equality and ordering.
instance Eq  a => Eq  (WithPosition a) where == :: WithPosition a -> WithPosition a -> Bool
(==)    = a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==)    (a -> a -> Bool)
-> (WithPosition a -> a)
-> WithPosition a
-> WithPosition a
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` WithPosition a -> a
forall a. WithPosition a -> a
wpThing
instance Ord a => Ord (WithPosition a) where compare :: WithPosition a -> WithPosition a -> Ordering
compare = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> a -> Ordering)
-> (WithPosition a -> a)
-> WithPosition a
-> WithPosition a
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` WithPosition a -> a
forall a. WithPosition a -> a
wpThing

noPosition :: a -> WithPosition a
noPosition :: forall a. a -> WithPosition a
noPosition = Position -> a -> WithPosition a
forall a. Position -> a -> WithPosition a
WithPosition Position
NoPosition

-- | A "ranged string" (terminology from Agda code base).
type RString = WithPosition String

-- | Prefix string with pretty-printed position information.
blendInPosition :: RString -> String
blendInPosition :: RFun -> [Char]
blendInPosition (WithPosition Position
pos [Char]
msg)
  | [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
p    = [Char]
msg
  | Bool
otherwise = [[Char]] -> [Char]
unwords [ [Char]
p, [Char]
msg ]
  where
  p :: [Char]
p = Position -> [Char]
prettyPosition Position
pos

type RCat    = WithPosition Cat

valCat :: Rul fun -> Cat
valCat :: forall fun. Rul fun -> Cat
valCat = RCat -> Cat
forall a. WithPosition a -> a
wpThing (RCat -> Cat) -> (Rul fun -> RCat) -> Rul fun -> Cat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rul fun -> RCat
forall function. Rul function -> RCat
valRCat

npRule :: Fun -> Cat -> SentForm -> InternalRule -> Rule
npRule :: [Char] -> Cat -> SentForm -> InternalRule -> Rule
npRule [Char]
f Cat
c SentForm
r InternalRule
internal = RFun -> RCat -> SentForm -> InternalRule -> Rule
forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule ([Char] -> RFun
forall a. a -> WithPosition a
noPosition [Char]
f) (Cat -> RCat
forall a. a -> WithPosition a
noPosition Cat
c) SentForm
r InternalRule
internal

npIdentifier :: String -> Abs.Identifier
npIdentifier :: [Char] -> Identifier
npIdentifier [Char]
x = ((Int, Int), [Char]) -> Identifier
Abs.Identifier ((Int
0, Int
0), [Char]
x)

-- identifierName :: Identifier -> String
-- identifierName (Identifier (_, x)) = x

-- identifierPosition :: String -> Identifier -> Position
-- identifierPosition file (Identifier ((line, col), _)) = Position file line col

------------------------------------------------------------------------------
-- Categories
------------------------------------------------------------------------------

-- | Categories are the non-terminals of the grammar.
data Cat
  = Cat String               -- ^ Ordinary non-terminal.
  | TokenCat TokenCat        -- ^ Token types (like @Ident@, @Integer@, ..., user-defined).
  | ListCat Cat              -- ^ List non-terminals, e.g., @[Ident]@, @[Exp]@, @[Exp1]@.
  | CoercCat String Integer  -- ^ E.g. @Exp1@, @Exp2@.
  deriving (Cat -> Cat -> Bool
(Cat -> Cat -> Bool) -> (Cat -> Cat -> Bool) -> Eq Cat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cat -> Cat -> Bool
$c/= :: Cat -> Cat -> Bool
== :: Cat -> Cat -> Bool
$c== :: Cat -> Cat -> Bool
Eq, Eq Cat
Eq Cat
-> (Cat -> Cat -> Ordering)
-> (Cat -> Cat -> Bool)
-> (Cat -> Cat -> Bool)
-> (Cat -> Cat -> Bool)
-> (Cat -> Cat -> Bool)
-> (Cat -> Cat -> Cat)
-> (Cat -> Cat -> Cat)
-> Ord Cat
Cat -> Cat -> Bool
Cat -> Cat -> Ordering
Cat -> Cat -> Cat
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Cat -> Cat -> Cat
$cmin :: Cat -> Cat -> Cat
max :: Cat -> Cat -> Cat
$cmax :: Cat -> Cat -> Cat
>= :: Cat -> Cat -> Bool
$c>= :: Cat -> Cat -> Bool
> :: Cat -> Cat -> Bool
$c> :: Cat -> Cat -> Bool
<= :: Cat -> Cat -> Bool
$c<= :: Cat -> Cat -> Bool
< :: Cat -> Cat -> Bool
$c< :: Cat -> Cat -> Bool
compare :: Cat -> Cat -> Ordering
$ccompare :: Cat -> Cat -> Ordering
Ord)

type TokenCat = String
type BaseCat  = String

-- An alias for Cat used in many backends:
type NonTerminal = Cat

-- | Render category symbols as strings
catToStr :: Cat -> String
catToStr :: Cat -> [Char]
catToStr = \case
  Cat [Char]
s        -> [Char]
s
  TokenCat [Char]
s   -> [Char]
s
  ListCat Cat
c    -> [Char]
"[" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Cat -> [Char]
catToStr Cat
c [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"]"
  CoercCat [Char]
s Integer
i -> [Char]
s [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
i

instance Show Cat where
  show :: Cat -> [Char]
show = Cat -> [Char]
catToStr

-- | Reads a string into a category. This should only need to handle
-- the case of simple categories (with or without coercion) since list
-- categories are parsed in the grammar already. To be on the safe side here,
-- we still call the parser function that parses categries.
strToCat :: String -> Cat
strToCat :: [Char] -> Cat
strToCat [Char]
s =
    case [Token] -> Either [Char] Cat
pCat ([Char] -> [Token]
tokens [Char]
s) of
        Right Cat
c -> Cat -> Cat
cat2cat Cat
c
        Left [Char]
_ -> [Char] -> Cat
Cat [Char]
s -- error $ "Error parsing cat " ++ s ++ " (" ++ e ++ ")"
                       -- Might be one of the "Internal cat" which are not
                       -- really parsable...
  where
  cat2cat :: Cat -> Cat
cat2cat = \case
    Abs.IdCat (Abs.Identifier ((Int, Int)
_pos, [Char]
x))
      | [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
ds   -> if [Char]
c [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
specialCatsP then [Char] -> Cat
TokenCat [Char]
c else [Char] -> Cat
Cat [Char]
c
      | Bool
otherwise -> [Char] -> Integer -> Cat
CoercCat [Char]
c ([Char] -> Integer
forall a. Read a => [Char] -> a
read [Char]
ds)
      where ([Char]
ds, [Char]
c) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
spanEnd Char -> Bool
isDigit [Char]
x
    Abs.ListCat Cat
c -> Cat -> Cat
ListCat (Cat -> Cat
cat2cat Cat
c)

-- Build-in categories contants
catString, catInteger, catDouble, catChar, catIdent :: TokenCat
catString :: [Char]
catString  = [Char]
"String"
catInteger :: [Char]
catInteger = [Char]
"Integer"
catDouble :: [Char]
catDouble  = [Char]
"Double"
catChar :: [Char]
catChar    = [Char]
"Char"
catIdent :: [Char]
catIdent   = [Char]
"Ident"

-- | Token categories corresponding to base types.
baseTokenCatNames :: [TokenCat]
baseTokenCatNames :: [[Char]]
baseTokenCatNames = [ [Char]
catChar, [Char]
catDouble, [Char]
catInteger, [Char]
catString ]

-- the parser needs these
specialCatsP :: [TokenCat]
specialCatsP :: [[Char]]
specialCatsP = [Char]
catIdent [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
baseTokenCatNames

-- | Does the category correspond to a data type?
isDataCat :: Cat -> Bool
isDataCat :: Cat -> Bool
isDataCat Cat
c = Cat -> Bool
isDataOrListCat Cat
c Bool -> Bool -> Bool
&& Bool -> Bool
not (Cat -> Bool
isList Cat
c)

isDataOrListCat :: Cat -> Bool
isDataOrListCat :: Cat -> Bool
isDataOrListCat (CoercCat [Char]
_ Integer
_)  = Bool
False
isDataOrListCat (Cat (Char
'@':[Char]
_))   = Bool
False
isDataOrListCat (ListCat Cat
c)     = Cat -> Bool
isDataOrListCat Cat
c
isDataOrListCat Cat
_               = Bool
True

-- | Categories C1, C2,... (one digit at the end) are variants of C. This function
-- returns true if two category are variants of the same abstract category.
-- E.g.
--
-- >>> sameCat (Cat "Abc") (CoercCat "Abc" 44)
-- True

sameCat :: Cat -> Cat -> Bool
sameCat :: Cat -> Cat -> Bool
sameCat (CoercCat [Char]
c1 Integer
_) (CoercCat [Char]
c2 Integer
_) = [Char]
c1 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
c2
sameCat (Cat [Char]
c1)        (CoercCat [Char]
c2 Integer
_) = [Char]
c1 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
c2
sameCat (CoercCat [Char]
c1 Integer
_) (Cat [Char]
c2)        = [Char]
c1 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
c2
sameCat Cat
c1              Cat
c2              = Cat
c1 Cat -> Cat -> Bool
forall a. Eq a => a -> a -> Bool
== Cat
c2

-- | Removes precedence information. C1 => C, [C2] => [C]
normCat :: Cat -> Cat
normCat :: Cat -> Cat
normCat (ListCat Cat
c) = Cat -> Cat
ListCat (Cat -> Cat
normCat Cat
c)
normCat (CoercCat [Char]
c Integer
_) = [Char] -> Cat
Cat [Char]
c
normCat Cat
c = Cat
c

normCatOfList :: Cat -> Cat
normCatOfList :: Cat -> Cat
normCatOfList = Cat -> Cat
normCat (Cat -> Cat) -> (Cat -> Cat) -> Cat -> Cat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Cat
catOfList

-- | 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 :: Cat -> [Char]
identCat (ListCat Cat
c) = [Char]
"List" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Cat -> [Char]
identCat Cat
c
identCat Cat
c = Cat -> [Char]
catToStr Cat
c

isList :: Cat -> Bool
isList :: Cat -> Bool
isList (ListCat Cat
_) = Bool
True
isList Cat
_           = Bool
False

-- | Get the underlying category identifier.
baseCat :: Cat -> Either BaseCat TokenCat
baseCat :: Cat -> Either [Char] [Char]
baseCat = \case
  ListCat Cat
c    -> Cat -> Either [Char] [Char]
baseCat Cat
c
  CoercCat [Char]
x Integer
_ -> [Char] -> Either [Char] [Char]
forall a b. a -> Either a b
Left [Char]
x
  Cat [Char]
x        -> [Char] -> Either [Char] [Char]
forall a b. a -> Either a b
Left [Char]
x
  TokenCat [Char]
x   -> [Char] -> Either [Char] [Char]
forall a b. b -> Either a b
Right [Char]
x

isTokenCat :: Cat -> Bool
isTokenCat :: Cat -> Bool
isTokenCat (TokenCat [Char]
_) = Bool
True
isTokenCat Cat
_            = Bool
False

maybeTokenCat :: Cat -> Maybe TokenCat
maybeTokenCat :: Cat -> Maybe [Char]
maybeTokenCat = \case
  TokenCat [Char]
c -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
c
  Cat
_          -> Maybe [Char]
forall a. Maybe a
Nothing

-- | Unwraps the list constructor from the category name.
--   E.g. @[C1] => C1@.
catOfList :: Cat -> Cat
catOfList :: Cat -> Cat
catOfList (ListCat Cat
c) = Cat
c
catOfList Cat
c = Cat
c

------------------------------------------------------------------------------
-- Functions
------------------------------------------------------------------------------

-- | Fun is the function name of a rule.
type Fun     = String
type RFun    = RString

instance IsString RFun where
  fromString :: [Char] -> RFun
fromString = [Char] -> RFun
forall a. a -> WithPosition a
noPosition

class IsFun a where
  funName :: a -> String

instance IsFun String where
  funName :: ShowS
funName = ShowS
forall a. a -> a
id

instance IsFun a => IsFun (WithPosition a) where
  funName :: WithPosition a -> [Char]
funName = a -> [Char]
forall a. IsFun a => a -> [Char]
funName (a -> [Char]) -> (WithPosition a -> a) -> WithPosition a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithPosition a -> a
forall a. WithPosition a -> a
wpThing

funNameSatisfies :: IsFun a => (String -> Bool) -> a -> Bool
funNameSatisfies :: forall a. IsFun a => ([Char] -> Bool) -> a -> Bool
funNameSatisfies [Char] -> Bool
f = [Char] -> Bool
f ([Char] -> Bool) -> (a -> [Char]) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Char]
forall a. IsFun a => a -> [Char]
funName

-- | Is this function just a coercion? (I.e. the identity)
isCoercion :: IsFun a => a -> Bool
isCoercion :: forall a. IsFun a => a -> Bool
isCoercion = ([Char] -> Bool) -> a -> Bool
forall a. IsFun a => ([Char] -> Bool) -> a -> Bool
funNameSatisfies ([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"_") -- perhaps this should be changed to "id"?

isDefinedRule :: IsFun a => a -> Bool
isDefinedRule :: forall a. IsFun a => a -> Bool
isDefinedRule = ([Char] -> Bool) -> a -> Bool
forall a. IsFun a => ([Char] -> Bool) -> a -> Bool
funNameSatisfies (([Char] -> Bool) -> a -> Bool) -> ([Char] -> Bool) -> a -> Bool
forall a b. (a -> b) -> a -> b
$ \case
  (Char
x:[Char]
_) -> Char -> Bool
isLower Char
x
  []    -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"isDefinedRule: empty function name"

-- isDefinedRule :: Fun -> Bool
-- isDefinedRule (WithPosition _ (x:_)) = isLower x
-- isDefinedRule (WithPosition pos []) = error $
--   unwords [ prettyPosition pos, "isDefinedRule: empty function name" ]

isProperLabel :: IsFun a => a -> Bool
isProperLabel :: forall a. IsFun a => a -> Bool
isProperLabel a
f = Bool -> Bool
not (a -> Bool
forall a. IsFun a => a -> Bool
isCoercion a
f Bool -> Bool -> Bool
|| a -> Bool
forall a. IsFun a => a -> Bool
isDefinedRule a
f)

isNilFun, isOneFun, isConsFun, isNilCons,isConcatFun :: IsFun a => a -> Bool
isNilCons :: forall a. IsFun a => a -> Bool
isNilCons a
f = a -> Bool
forall a. IsFun a => a -> Bool
isNilFun a
f Bool -> Bool -> Bool
|| a -> Bool
forall a. IsFun a => a -> Bool
isOneFun a
f Bool -> Bool -> Bool
|| a -> Bool
forall a. IsFun a => a -> Bool
isConsFun a
f Bool -> Bool -> Bool
|| a -> Bool
forall a. IsFun a => a -> Bool
isConcatFun a
f
isNilFun :: forall a. IsFun a => a -> Bool
isNilFun    = ([Char] -> Bool) -> a -> Bool
forall a. IsFun a => ([Char] -> Bool) -> a -> Bool
funNameSatisfies ([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"[]")
isOneFun :: forall a. IsFun a => a -> Bool
isOneFun    = ([Char] -> Bool) -> a -> Bool
forall a. IsFun a => ([Char] -> Bool) -> a -> Bool
funNameSatisfies ([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"(:[])")
isConsFun :: forall a. IsFun a => a -> Bool
isConsFun   = ([Char] -> Bool) -> a -> Bool
forall a. IsFun a => ([Char] -> Bool) -> a -> Bool
funNameSatisfies ([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"(:)")
isConcatFun :: forall a. IsFun a => a -> Bool
isConcatFun = ([Char] -> Bool) -> a -> Bool
forall a. IsFun a => ([Char] -> Bool) -> a -> Bool
funNameSatisfies ([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"(++)")

------------------------------------------------------------------------------

-- | The abstract syntax of a grammar.
type Data = (Cat, [(String, [Cat])])

-- | @firstEntry@ returns the first of the @entrypoints@,
--   or (if none), the first parsable @Cat@egory appearing in the grammar.

firstEntry :: CF -> Cat
firstEntry :: CF -> Cat
firstEntry CF
cf = NonEmpty Cat -> Cat
forall a. NonEmpty a -> a
List1.head (NonEmpty Cat -> Cat) -> NonEmpty Cat -> Cat
forall a b. (a -> b) -> a -> b
$ CF -> NonEmpty Cat
forall f. CFG f -> NonEmpty Cat
allEntryPoints CF
cf

-- aggressively ban nonunique names (AR 31/5/2012)

-- | Constructors and categories.
allNames :: CF -> [RString]
allNames :: CF -> [RFun]
allNames CF
cf =
  [ RFun
f | RFun
f <- (Rule -> RFun) -> [Rule] -> [RFun]
forall a b. (a -> b) -> [a] -> [b]
map Rule -> RFun
forall function. Rul function -> function
funRule ([Rule] -> [RFun]) -> [Rule] -> [RFun]
forall a b. (a -> b) -> a -> b
$ CF -> [Rule]
forall function. CFG function -> [Rul function]
cfgRules CF
cf
      , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ RFun -> Bool
forall a. IsFun a => a -> Bool
isNilCons RFun
f
      , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ RFun -> Bool
forall a. IsFun a => a -> Bool
isCoercion RFun
f
  ] [RFun] -> [RFun] -> [RFun]
forall a. [a] -> [a] -> [a]
++
  CF -> [RFun]
allCatsIdNorm CF
cf
    -- Put the categories after the labels so that the error location
    -- for a non-unique name is at the label rather than the category.

-- | Get all elements with more than one occurrence.
filterNonUnique :: (Ord a) => [a] -> [a]
filterNonUnique :: forall a. Ord a => [a] -> [a]
filterNonUnique [a]
xs = [ a
x | (a
x:a
_:[a]
_) <- [a] -> [[a]]
forall a. Eq a => [a] -> [[a]]
group ([a] -> [[a]]) -> [a] -> [[a]]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. Ord a => [a] -> [a]
sort [a]
xs ]


-- | Extract the comment pragmas.
commentPragmas :: [Pragma] -> [Pragma]
commentPragmas :: [Pragma] -> [Pragma]
commentPragmas = (Pragma -> Bool) -> [Pragma] -> [Pragma]
forall a. (a -> Bool) -> [a] -> [a]
filter Pragma -> Bool
isComment
 where isComment :: Pragma -> Bool
isComment (CommentS [Char]
_) = Bool
True
       isComment (CommentM ([Char], [Char])
_) = Bool
True
       isComment Pragma
_            = Bool
False

lookupRule :: Eq f => f -> [Rul f] -> Maybe (Cat, SentForm)
lookupRule :: forall f. Eq f => f -> [Rul f] -> Maybe (Cat, SentForm)
lookupRule f
f = f -> [(f, (Cat, SentForm))] -> Maybe (Cat, SentForm)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup f
f ([(f, (Cat, SentForm))] -> Maybe (Cat, SentForm))
-> ([Rul f] -> [(f, (Cat, SentForm))])
-> [Rul f]
-> Maybe (Cat, SentForm)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rul f -> (f, (Cat, SentForm)))
-> [Rul f] -> [(f, (Cat, SentForm))]
forall a b. (a -> b) -> [a] -> [b]
map Rul f -> (f, (Cat, SentForm))
forall {a}. Rul a -> (a, (Cat, SentForm))
unRule
  where unRule :: Rul a -> (a, (Cat, SentForm))
unRule (Rule a
f' RCat
c SentForm
rhs InternalRule
_internal) = (a
f', (RCat -> Cat
forall a. WithPosition a -> a
wpThing RCat
c, SentForm
rhs))

-- | Returns all parseable rules that construct the given Cat.
--   Whitespace separators have been removed.
rulesForCat :: CF -> Cat -> [Rule]
rulesForCat :: CF -> Cat -> [Rule]
rulesForCat CF
cf Cat
cat =
  [ Rule -> Rule
forall f. Rul f -> Rul f
removeWhiteSpaceSeparators Rule
r | Rule
r <- CF -> [Rule]
forall function. CFG function -> [Rul function]
cfgRules CF
cf, Rule -> Bool
forall f. Rul f -> Bool
isParsable Rule
r, Rule -> Cat
forall fun. Rul fun -> Cat
valCat Rule
r Cat -> Cat -> Bool
forall a. Eq a => a -> a -> Bool
== Cat
cat]

removeWhiteSpaceSeparators :: Rul f -> Rul f
removeWhiteSpaceSeparators :: forall f. Rul f -> Rul f
removeWhiteSpaceSeparators = (SentForm -> SentForm) -> Rul f -> Rul f
forall f. (SentForm -> SentForm) -> Rul f -> Rul f
mapRhs ((SentForm -> SentForm) -> Rul f -> Rul f)
-> (SentForm -> SentForm) -> Rul f -> Rul f
forall a b. (a -> b) -> a -> b
$ (Either Cat [Char] -> Maybe (Either Cat [Char]))
-> SentForm -> SentForm
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Either Cat [Char] -> Maybe (Either Cat [Char]))
 -> SentForm -> SentForm)
-> (Either Cat [Char] -> Maybe (Either Cat [Char]))
-> SentForm
-> SentForm
forall a b. (a -> b) -> a -> b
$ (Cat -> Maybe (Either Cat [Char]))
-> ([Char] -> Maybe (Either Cat [Char]))
-> Either Cat [Char]
-> Maybe (Either Cat [Char])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either Cat [Char] -> Maybe (Either Cat [Char])
forall a. a -> Maybe a
Just (Either Cat [Char] -> Maybe (Either Cat [Char]))
-> (Cat -> Either Cat [Char]) -> Cat -> Maybe (Either Cat [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Either Cat [Char]
forall a b. a -> Either a b
Left) (([Char] -> Maybe (Either Cat [Char]))
 -> Either Cat [Char] -> Maybe (Either Cat [Char]))
-> ([Char] -> Maybe (Either Cat [Char]))
-> Either Cat [Char]
-> Maybe (Either Cat [Char])
forall a b. (a -> b) -> a -> b
$ \ [Char]
sep ->
  if (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace [Char]
sep then Maybe (Either Cat [Char])
forall a. Maybe a
Nothing else Either Cat [Char] -> Maybe (Either Cat [Char])
forall a. a -> Maybe a
Just ([Char] -> Either Cat [Char]
forall a b. b -> Either a b
Right [Char]
sep)

-- | Modify the 'rhsRule' part of a 'Rule'.
mapRhs :: (SentForm -> SentForm) -> Rul f -> Rul f
mapRhs :: forall f. (SentForm -> SentForm) -> Rul f -> Rul f
mapRhs SentForm -> SentForm
f Rul f
r = Rul f
r { rhsRule :: SentForm
rhsRule = SentForm -> SentForm
f (SentForm -> SentForm) -> SentForm -> SentForm
forall a b. (a -> b) -> a -> b
$ Rul f -> SentForm
forall function. Rul function -> SentForm
rhsRule Rul f
r }

-- | Like rulesForCat but for normalized value categories.
-- I.e., `rulesForCat (Cat "Exp")` will return rules for category Exp but also
-- Exp1, Exp2... in case of coercion
rulesForNormalizedCat :: CF -> Cat -> [Rule]
rulesForNormalizedCat :: CF -> Cat -> [Rule]
rulesForNormalizedCat CF
cf Cat
cat =
    [Rule
r | Rule
r <- CF -> [Rule]
forall function. CFG function -> [Rul function]
cfgRules CF
cf, Cat -> Cat
normCat (Rule -> Cat
forall fun. Rul fun -> Cat
valCat Rule
r) Cat -> Cat -> Bool
forall a. Eq a => a -> a -> Bool
== Cat
cat]

-- | As rulesForCat, but this version doesn't exclude internal rules.
rulesForCat' :: CF -> Cat -> [Rule]
rulesForCat' :: CF -> Cat -> [Rule]
rulesForCat' CF
cf Cat
cat = [Rule
r | Rule
r <- CF -> [Rule]
forall function. CFG function -> [Rul function]
cfgRules CF
cf, Rule -> Cat
forall fun. Rul fun -> Cat
valCat Rule
r Cat -> Cat -> Bool
forall a. Eq a => a -> a -> Bool
== Cat
cat]

-- | Get all categories of a grammar matching the filter.
--   (No Cat w/o production returned; no duplicates.)
allCats :: (InternalRule -> Bool) -> CFG f -> [Cat]
allCats :: forall f. (InternalRule -> Bool) -> CFG f -> [Cat]
allCats InternalRule -> Bool
pred = [Cat] -> [Cat]
forall a. Eq a => [a] -> [a]
nub ([Cat] -> [Cat]) -> (CFG f -> [Cat]) -> CFG f -> [Cat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rul f -> Cat) -> [Rul f] -> [Cat]
forall a b. (a -> b) -> [a] -> [b]
map Rul f -> Cat
forall fun. Rul fun -> Cat
valCat ([Rul f] -> [Cat]) -> (CFG f -> [Rul f]) -> CFG f -> [Cat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rul f -> Bool) -> [Rul f] -> [Rul f]
forall a. (a -> Bool) -> [a] -> [a]
filter (InternalRule -> Bool
pred (InternalRule -> Bool) -> (Rul f -> InternalRule) -> Rul f -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rul f -> InternalRule
forall function. Rul function -> InternalRule
internal) ([Rul f] -> [Rul f]) -> (CFG f -> [Rul f]) -> CFG f -> [Rul f]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFG f -> [Rul f]
forall function. CFG function -> [Rul function]
cfgRules

-- | Get all categories of a grammar.
--   (No Cat w/o production returned; no duplicates.)
reallyAllCats :: CFG f -> [Cat]
reallyAllCats :: forall function. CFG function -> [Cat]
reallyAllCats = (InternalRule -> Bool) -> CFG f -> [Cat]
forall f. (InternalRule -> Bool) -> CFG f -> [Cat]
allCats ((InternalRule -> Bool) -> CFG f -> [Cat])
-> (InternalRule -> Bool) -> CFG f -> [Cat]
forall a b. (a -> b) -> a -> b
$ Bool -> InternalRule -> Bool
forall a b. a -> b -> a
const Bool
True

allParserCats :: CFG f -> [Cat]
allParserCats :: forall function. CFG function -> [Cat]
allParserCats = (InternalRule -> Bool) -> CFG f -> [Cat]
forall f. (InternalRule -> Bool) -> CFG f -> [Cat]
allCats (InternalRule -> InternalRule -> Bool
forall a. Eq a => a -> a -> Bool
== InternalRule
Parsable)

-- | Gets all normalized identified Categories
allCatsIdNorm :: CF -> [RString]
allCatsIdNorm :: CF -> [RFun]
allCatsIdNorm = [RFun] -> [RFun]
forall a. Eq a => [a] -> [a]
nub ([RFun] -> [RFun]) -> (CF -> [RFun]) -> CF -> [RFun]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rule -> RFun) -> [Rule] -> [RFun]
forall a b. (a -> b) -> [a] -> [b]
map ((Cat -> [Char]) -> RCat -> RFun
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Cat -> [Char]
identCat (Cat -> [Char]) -> (Cat -> Cat) -> Cat -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Cat
normCat) (RCat -> RFun) -> (Rule -> RCat) -> Rule -> RFun
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule -> RCat
forall function. Rul function -> RCat
valRCat) ([Rule] -> [RFun]) -> (CF -> [Rule]) -> CF -> [RFun]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> [Rule]
forall function. CFG function -> [Rul function]
cfgRules

-- | Get all normalized Cat
allCatsNorm :: CF -> [Cat]
allCatsNorm :: CF -> [Cat]
allCatsNorm = [Cat] -> [Cat]
forall a. Eq a => [a] -> [a]
nub ([Cat] -> [Cat]) -> (CF -> [Cat]) -> CF -> [Cat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rule -> Cat) -> [Rule] -> [Cat]
forall a b. (a -> b) -> [a] -> [b]
map (Cat -> Cat
normCat (Cat -> Cat) -> (Rule -> Cat) -> Rule -> Cat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule -> Cat
forall fun. Rul fun -> Cat
valCat) ([Rule] -> [Cat]) -> (CF -> [Rule]) -> CF -> [Cat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> [Rule]
forall function. CFG function -> [Rul function]
cfgRules

-- | Get all normalized Cat
allParserCatsNorm :: CFG f -> [Cat]
allParserCatsNorm :: forall function. CFG function -> [Cat]
allParserCatsNorm = [Cat] -> [Cat]
forall a. Eq a => [a] -> [a]
nub ([Cat] -> [Cat]) -> (CFG f -> [Cat]) -> CFG f -> [Cat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cat -> Cat) -> [Cat] -> [Cat]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> Cat
normCat ([Cat] -> [Cat]) -> (CFG f -> [Cat]) -> CFG f -> [Cat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFG f -> [Cat]
forall function. CFG function -> [Cat]
allParserCats

-- | Is the category is used on an rhs?
--   Includes internal rules.
isUsedCat :: CFG f -> Cat -> Bool
isUsedCat :: forall f. CFG f -> Cat -> Bool
isUsedCat CFG f
cf = (Cat -> Set Cat -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` CFG f -> Set Cat
forall function. CFG function -> Set Cat
cfgUsedCats CFG f
cf)

-- | Group all parsable categories with their rules.
--   Deletes whitespace separators, as they will not become part of the parsing rules.
ruleGroups :: CF -> [(Cat,[Rule])]
ruleGroups :: CF -> [(Cat, [Rule])]
ruleGroups CF
cf = [(Cat
c, CF -> Cat -> [Rule]
rulesForCat CF
cf Cat
c) | Cat
c <- CF -> [Cat]
forall function. CFG function -> [Cat]
allParserCats CF
cf]

-- | Group all categories with their rules including internal rules.
ruleGroupsInternals :: CF -> [(Cat,[Rule])]
ruleGroupsInternals :: CF -> [(Cat, [Rule])]
ruleGroupsInternals CF
cf = [(Cat
c, CF -> Cat -> [Rule]
rulesForCat' CF
cf Cat
c) | Cat
c <- CF -> [Cat]
forall function. CFG function -> [Cat]
reallyAllCats CF
cf]

-- | Get all literals of a grammar. (e.g. String, Double)
literals :: CFG f -> [TokenCat]
literals :: forall function. CFG function -> [[Char]]
literals CFG f
cf = CFG f -> [[Char]]
forall function. CFG function -> [[Char]]
cfgLiterals CFG f
cf [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (([Char], Reg) -> [Char]) -> [([Char], Reg)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Reg) -> [Char]
forall a b. (a, b) -> a
fst (CFG f -> [([Char], Reg)]
forall f. CFG f -> [([Char], Reg)]
tokenPragmas CFG f
cf)

-- | Get the keywords of a grammar.
reservedWords :: CFG f -> [String]
reservedWords :: forall function. CFG function -> [[Char]]
reservedWords = [[Char]] -> [[Char]]
forall a. Ord a => [a] -> [a]
sort ([[Char]] -> [[Char]]) -> (CFG f -> [[Char]]) -> CFG f -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFG f -> [[Char]]
forall function. CFG function -> [[Char]]
cfgKeywords

-- | Canonical, numbered list of symbols and reserved words. (These do
-- not end up in the AST.)
cfTokens :: CFG f -> [(String,Int)]
cfTokens :: forall f. CFG f -> [([Char], Int)]
cfTokens CFG f
cf = [[Char]] -> [Int] -> [([Char], Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([[Char]] -> [[Char]]
forall a. Ord a => [a] -> [a]
sort (CFG f -> [[Char]]
forall function. CFG function -> [[Char]]
cfgSymbols CFG f
cf [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ CFG f -> [[Char]]
forall function. CFG function -> [[Char]]
reservedWords CFG f
cf)) [Int
1..]
-- NOTE: some backends (incl. Haskell) assume that this list is sorted.

-- | Comments can be defined by the 'comment' pragma
comments :: CF -> ([(String,String)],[String])
comments :: CF -> ([([Char], [Char])], [[Char]])
comments CF
cf = ([([Char], [Char])
p | CommentM ([Char], [Char])
p <- [Pragma]
xs], [[Char]
s | CommentS [Char]
s <- [Pragma]
xs])
  where
  xs :: [Pragma]
xs = [Pragma] -> [Pragma]
commentPragmas (CF -> [Pragma]
forall function. CFG function -> [Pragma]
cfgPragmas CF
cf)

-- | Number of block comment forms defined in the grammar file.
numberOfBlockCommentForms :: CF -> Int
numberOfBlockCommentForms :: CF -> Int
numberOfBlockCommentForms = [([Char], [Char])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([([Char], [Char])] -> Int)
-> (CF -> [([Char], [Char])]) -> CF -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([([Char], [Char])], [[Char]]) -> [([Char], [Char])]
forall a b. (a, b) -> a
fst (([([Char], [Char])], [[Char]]) -> [([Char], [Char])])
-> (CF -> ([([Char], [Char])], [[Char]]))
-> CF
-> [([Char], [Char])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> ([([Char], [Char])], [[Char]])
comments


-- built-in categories (corresponds to lexer)

-- | Whether the grammar uses the predefined Ident type.
hasIdent :: CFG f -> Bool
hasIdent :: forall f. CFG f -> Bool
hasIdent CFG f
cf = CFG f -> Cat -> Bool
forall f. CFG f -> Cat -> Bool
isUsedCat CFG f
cf (Cat -> Bool) -> Cat -> Bool
forall a b. (a -> b) -> a -> b
$ [Char] -> Cat
TokenCat [Char]
catIdent


-- these need new datatypes

-- | Categories corresponding to tokens. These end up in the
-- AST. (unlike tokens returned by 'cfTokens')
specialCats :: CF -> [TokenCat]
specialCats :: CF -> [[Char]]
specialCats CF
cf = (if CF -> Bool
forall f. CFG f -> Bool
hasIdent CF
cf then ([Char]
catIdent[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:) else [[Char]] -> [[Char]]
forall a. a -> a
id) ((([Char], Reg) -> [Char]) -> [([Char], Reg)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Reg) -> [Char]
forall a b. (a, b) -> a
fst (CF -> [([Char], Reg)]
forall f. CFG f -> [([Char], Reg)]
tokenPragmas CF
cf))


-- * abstract syntax trees: data type definitions
--
-- The abstract syntax, instantiated by the Data type, is the type signatures
-- of all the constructors.

-- | Return the abstract syntax of the grammar.
-- All categories are normalized, so a rule like:
--     EAdd . Exp2 ::= Exp2 "+" Exp3 ;
-- Will give the following signature: EAdd : Exp -> Exp -> Exp
getAbstractSyntax :: CF -> [Data]
getAbstractSyntax :: CF -> [Data]
getAbstractSyntax CF
cf = [ ( Cat
c, [([Char], [Cat])] -> [([Char], [Cat])]
forall a. Eq a => [a] -> [a]
nub (Cat -> [([Char], [Cat])]
constructors Cat
c) ) | Cat
c <- CF -> [Cat]
allCatsNorm CF
cf ]
  where
    constructors :: Cat -> [([Char], [Cat])]
constructors Cat
cat = do
        Rule
rule <- CF -> [Rule]
forall function. CFG function -> [Rul function]
cfgRules CF
cf
        let f :: RFun
f = Rule -> RFun
forall function. Rul function -> function
funRule Rule
rule
        Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (RFun -> Bool
forall a. IsFun a => a -> Bool
isDefinedRule RFun
f)
        Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (RFun -> Bool
forall a. IsFun a => a -> Bool
isCoercion RFun
f)
        Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Cat -> Cat
normCat (Rule -> Cat
forall fun. Rul fun -> Cat
valCat Rule
rule) Cat -> Cat -> Bool
forall a. Eq a => a -> a -> Bool
== Cat
cat
        let cs :: [Cat]
cs = [Cat -> Cat
normCat Cat
c | Left Cat
c <- Rule -> SentForm
forall function. Rul function -> SentForm
rhsRule Rule
rule ]
        ([Char], [Cat]) -> [([Char], [Cat])]
forall (m :: * -> *) a. Monad m => a -> m a
return (RFun -> [Char]
forall a. WithPosition a -> a
wpThing RFun
f, [Cat]
cs)


-- | All the functions below implement the idea of getting the
-- abstract syntax of the grammar with some variation but they seem to do a
-- poor job at handling corner cases involving coercions.
-- Use 'getAbstractSyntax' instead if possible.

cf2data' :: (Cat -> Bool) -> CF -> [Data]
cf2data' :: (Cat -> Bool) -> CF -> [Data]
cf2data' Cat -> Bool
predicate CF
cf =
  [(Cat
cat, [([Char], [Cat])] -> [([Char], [Cat])]
forall a. Eq a => [a] -> [a]
nub ((Rule -> ([Char], [Cat])) -> [Rule] -> [([Char], [Cat])]
forall a b. (a -> b) -> [a] -> [b]
map Rule -> ([Char], [Cat])
forall {a}. Rul (WithPosition a) -> (a, [Cat])
mkData [Rule
r | Rule
r <- CF -> [Rule]
forall function. CFG function -> [Rul function]
cfgRules CF
cf,
                              let f :: RFun
f = Rule -> RFun
forall function. Rul function -> function
funRule Rule
r,
                              Bool -> Bool
not (RFun -> Bool
forall a. IsFun a => a -> Bool
isDefinedRule RFun
f),
                              Bool -> Bool
not (RFun -> Bool
forall a. IsFun a => a -> Bool
isCoercion RFun
f), Cat -> Cat -> Bool
sameCat Cat
cat (Rule -> Cat
forall fun. Rul fun -> Cat
valCat Rule
r)]))
      | Cat
cat <- [Cat] -> [Cat]
forall a. Eq a => [a] -> [a]
nub ([Cat] -> [Cat]) -> [Cat] -> [Cat]
forall a b. (a -> b) -> a -> b
$ (Cat -> Cat) -> [Cat] -> [Cat]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> Cat
normCat ([Cat] -> [Cat]) -> [Cat] -> [Cat]
forall a b. (a -> b) -> a -> b
$ (Cat -> Bool) -> [Cat] -> [Cat]
forall a. (a -> Bool) -> [a] -> [a]
filter Cat -> Bool
predicate ([Cat] -> [Cat]) -> [Cat] -> [Cat]
forall a b. (a -> b) -> a -> b
$ CF -> [Cat]
forall function. CFG function -> [Cat]
reallyAllCats CF
cf ]
 where
  mkData :: Rul (WithPosition a) -> (a, [Cat])
mkData (Rule WithPosition a
f RCat
_ SentForm
its InternalRule
_) = (WithPosition a -> a
forall a. WithPosition a -> a
wpThing WithPosition a
f, [Cat -> Cat
normCat Cat
c | Left Cat
c <- SentForm
its ])

cf2data :: CF -> [Data]
cf2data :: CF -> [Data]
cf2data = (Cat -> Bool) -> CF -> [Data]
cf2data' ((Cat -> Bool) -> CF -> [Data]) -> (Cat -> Bool) -> CF -> [Data]
forall a b. (a -> b) -> a -> b
$ Cat -> Bool
isDataCat (Cat -> Bool) -> (Cat -> Cat) -> Cat -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Cat
normCat

cf2dataLists :: CF -> [Data]
cf2dataLists :: CF -> [Data]
cf2dataLists = (Cat -> Bool) -> CF -> [Data]
cf2data' ((Cat -> Bool) -> CF -> [Data]) -> (Cat -> Bool) -> CF -> [Data]
forall a b. (a -> b) -> a -> b
$ Cat -> Bool
isDataOrListCat (Cat -> Bool) -> (Cat -> Cat) -> Cat -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Cat
normCat

specialData :: CF -> [Data]
specialData :: CF -> [Data]
specialData CF
cf = [([Char] -> Cat
TokenCat [Char]
name, [([Char]
name, [[Char] -> Cat
TokenCat [Char]
catString])]) | [Char]
name <- CF -> [[Char]]
specialCats CF
cf]

-- | Get the type of a rule label.
sigLookup :: IsFun a => a -> CF -> Maybe (WithPosition Type)
sigLookup :: forall a. IsFun a => a -> CF -> Maybe (WithPosition Type)
sigLookup a
f = [Char] -> Signature -> Maybe (WithPosition Type)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (a -> [Char]
forall a. IsFun a => a -> [Char]
funName a
f) (Signature -> Maybe (WithPosition Type))
-> (CF -> Signature) -> CF -> Maybe (WithPosition Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> Signature
forall function. CFG function -> Signature
cfgSignature


-- | Checks if the rule is parsable.
isParsable :: Rul f -> Bool
isParsable :: forall f. Rul f -> Bool
isParsable = (InternalRule
Parsable InternalRule -> InternalRule -> Bool
forall a. Eq a => a -> a -> Bool
==) (InternalRule -> Bool) -> (Rul f -> InternalRule) -> Rul f -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rul f -> InternalRule
forall function. Rul function -> InternalRule
internal


-- | Checks if the list has a non-empty rule.
hasOneFunc :: [Rule] -> Bool
hasOneFunc :: [Rule] -> Bool
hasOneFunc = (Rule -> Bool) -> [Rule] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (RFun -> Bool
forall a. IsFun a => a -> Bool
isOneFun (RFun -> Bool) -> (Rule -> RFun) -> Rule -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule -> RFun
forall function. Rul function -> function
funRule)

-- | Gets the separator for a list.
getCons :: [Rule] -> String
getCons :: [Rule] -> [Char]
getCons [Rule]
rs = case (Rule -> Bool) -> [Rule] -> Maybe Rule
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (RFun -> Bool
forall a. IsFun a => a -> Bool
isConsFun (RFun -> Bool) -> (Rule -> RFun) -> Rule -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule -> RFun
forall function. Rul function -> function
funRule) [Rule]
rs of
    Just (Rule RFun
_ RCat
_ SentForm
cats InternalRule
_) -> SentForm -> [Char]
forall {a} {a}. [Either a [a]] -> [a]
seper SentForm
cats
    Maybe Rule
Nothing              -> ShowS
forall a. HasCallStack => [Char] -> a
error ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [Char]
"getCons: no construction function found in "
                                  [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ((Rule -> [Char]) -> [Rule] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (RFun -> [Char]
forall a. Show a => a -> [Char]
show (RFun -> [Char]) -> (Rule -> RFun) -> Rule -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule -> RFun
forall function. Rul function -> function
funRule) [Rule]
rs)
  where
    seper :: [Either a [a]] -> [a]
seper [] = []
    seper (Right [a]
x:[Either a [a]]
_) = [a]
x
    seper (Left a
_:[Either a [a]]
xs) = [Either a [a]] -> [a]
seper [Either a [a]]
xs

-- | Helper function that gets the list separator by precedence level
getSeparatorByPrecedence :: [Rule] -> [(Integer,String)]
getSeparatorByPrecedence :: [Rule] -> [(Integer, [Char])]
getSeparatorByPrecedence [Rule]
rules = [ (Integer
p, [Rule] -> [Char]
getCons (Integer -> [Rule]
getRulesFor Integer
p)) | Integer
p <- [Integer]
precedences ]
  where
    precedences :: [Integer]
precedences = Set Integer -> [Integer]
forall a. Set a -> [a]
Set.toDescList (Set Integer -> [Integer])
-> ([Integer] -> Set Integer) -> [Integer] -> [Integer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Integer] -> Set Integer
forall a. Ord a => [a] -> Set a
Set.fromList ([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
    getRulesFor :: Integer -> [Rule]
getRulesFor Integer
p = [ Rule
r | Rule
r <- [Rule]
rules, Rule -> Integer
forall f. Rul f -> Integer
precRule Rule
r Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
p ]

isEmptyListCat :: CF -> Cat -> Bool
isEmptyListCat :: CF -> Cat -> Bool
isEmptyListCat CF
cf Cat
c = [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char]
"[]" ([[Char]] -> Bool) -> [[Char]] -> Bool
forall a b. (a -> b) -> a -> b
$ (Rule -> [Char]) -> [Rule] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (RFun -> [Char]
forall a. WithPosition a -> a
wpThing (RFun -> [Char]) -> (Rule -> RFun) -> Rule -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule -> RFun
forall function. Rul function -> function
funRule) ([Rule] -> [[Char]]) -> [Rule] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ CF -> Cat -> [Rule]
rulesForCat' CF
cf Cat
c

isNonterm :: Either Cat String -> Bool
isNonterm :: Either Cat [Char] -> Bool
isNonterm (Left Cat
_) = Bool
True
isNonterm (Right [Char]
_) = Bool
False

-- used in Happy to parse lists of form 'C t [C]' in reverse order
-- applies only if the [] rule has no terminals
revSepListRule :: Rul f -> Rul f
revSepListRule :: forall f. Rul f -> Rul f
revSepListRule (Rule f
f RCat
c SentForm
ts InternalRule
internal) = f -> RCat -> SentForm -> InternalRule -> Rul f
forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule f
f RCat
c (Either Cat [Char]
xs Either Cat [Char] -> SentForm -> SentForm
forall a. a -> [a] -> [a]
: Either Cat [Char]
x Either Cat [Char] -> SentForm -> SentForm
forall a. a -> [a] -> [a]
: SentForm
sep) InternalRule
internal where
  (Either Cat [Char]
x,SentForm
sep,Either Cat [Char]
xs) = (SentForm -> Either Cat [Char]
forall a. [a] -> a
head SentForm
ts, SentForm -> SentForm
forall a. [a] -> [a]
init (SentForm -> SentForm
forall a. [a] -> [a]
tail SentForm
ts), SentForm -> Either Cat [Char]
forall a. [a] -> a
last SentForm
ts)
-- invariant: test in findAllReversibleCats have been performed

findAllReversibleCats :: CF -> [Cat]
findAllReversibleCats :: CF -> [Cat]
findAllReversibleCats CF
cf = [Cat
c | (Cat
c,[Rule]
r) <- CF -> [(Cat, [Rule])]
ruleGroups CF
cf, Cat -> [Rule] -> Bool
forall {a}. IsFun a => Cat -> [Rul a] -> Bool
isRev Cat
c [Rule]
r] where
  isRev :: Cat -> [Rul a] -> Bool
isRev Cat
c [Rul a]
rs = case [Rul a]
rs of
     [Rul a
r1,Rul a
r2] | Cat -> Bool
isList Cat
c -> if a -> Bool
forall a. IsFun a => a -> Bool
isConsFun (Rul a -> a
forall function. Rul function -> function
funRule Rul a
r2)
                             then Rul a -> Rul a -> Bool
forall {a} {a}. (IsFun a, IsFun a) => Rul a -> Rul a -> Bool
tryRev Rul a
r2 Rul a
r1
                           else a -> Bool
forall a. IsFun a => a -> Bool
isConsFun (Rul a -> a
forall function. Rul function -> function
funRule Rul a
r1) Bool -> Bool -> Bool
&& Rul a -> Rul a -> Bool
forall {a} {a}. (IsFun a, IsFun a) => Rul a -> Rul a -> Bool
tryRev Rul a
r1 Rul a
r2
     [Rul a]
_ -> Bool
False
  tryRev :: Rul a -> Rul a -> Bool
tryRev (Rule a
f RCat
_ ts :: SentForm
ts@(Either Cat [Char]
x:Either Cat [Char]
_:SentForm
_) InternalRule
_) Rul a
r = Rul a -> Bool
forall a. IsFun a => Rul a -> Bool
isEmptyNilRule Rul a
r Bool -> Bool -> Bool
&&
                                        a -> Bool
forall a. IsFun a => a -> Bool
isConsFun a
f Bool -> Bool -> Bool
&& Either Cat [Char] -> Bool
isNonterm Either Cat [Char]
x Bool -> Bool -> Bool
&& Either Cat [Char] -> Bool
isNonterm (SentForm -> Either Cat [Char]
forall a. [a] -> a
last SentForm
ts)
  tryRev Rul a
_ Rul a
_ = Bool
False

isEmptyNilRule :: IsFun a => Rul a -> Bool
isEmptyNilRule :: forall a. IsFun a => Rul a -> Bool
isEmptyNilRule (Rule a
f RCat
_ SentForm
ts InternalRule
_) = a -> Bool
forall a. IsFun a => a -> Bool
isNilFun a
f Bool -> Bool -> Bool
&& SentForm -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null SentForm
ts

-- | Returns the precedence of a category symbol.
-- E.g.
-- >>> precCat (CoercCat "Abc" 4)
-- 4
precCat :: Cat -> Integer
precCat :: Cat -> Integer
precCat (CoercCat [Char]
_ Integer
i) = Integer
i
precCat (ListCat Cat
c) = Cat -> Integer
precCat Cat
c
precCat Cat
_ = Integer
0

precRule :: Rul f -> Integer
precRule :: forall f. Rul f -> Integer
precRule = Cat -> Integer
precCat (Cat -> Integer) -> (Rul f -> Cat) -> Rul f -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rul f -> Cat
forall fun. Rul fun -> Cat
valCat

-- | Defines or uses the grammar token types like @Ident@?
--   Excludes position tokens.
hasIdentLikeTokens :: CFG g -> Bool
hasIdentLikeTokens :: forall f. CFG f -> Bool
hasIdentLikeTokens CFG g
cf = CFG g -> Bool
forall f. CFG f -> Bool
hasIdent CFG g
cf Bool -> Bool -> Bool
|| [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bool -> Bool
not Bool
b | TokenReg RFun
_ Bool
b Reg
_ <- CFG g -> [Pragma]
forall function. CFG function -> [Pragma]
cfgPragmas CFG g
cf ]

-- | Is there a @position token@ declaration in the grammar?
hasPositionTokens :: CFG g -> Bool
hasPositionTokens :: forall f. CFG f -> Bool
hasPositionTokens CFG g
cf = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bool
b | TokenReg RFun
_ Bool
b Reg
_ <- CFG g -> [Pragma]
forall function. CFG function -> [Pragma]
cfgPragmas CFG g
cf ]

-- | Does the category have a position stored in AST?
isPositionCat :: CFG f -> TokenCat -> Bool
isPositionCat :: forall f. CFG f -> [Char] -> Bool
isPositionCat CFG f
cf [Char]
cat = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bool
b | TokenReg RFun
name Bool
b Reg
_ <- CFG f -> [Pragma]
forall function. CFG function -> [Pragma]
cfgPragmas CFG f
cf, RFun -> [Char]
forall a. WithPosition a -> a
wpThing RFun
name [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
cat]


-- | Categories that are entry points to the parser.
--
--   These are either the declared @entrypoints@ (in the original order),
--   or, if no @entrypoints@ were declared explicitly,
--   all parsable categories (in the order of declaration in the grammar file).
allEntryPoints :: CFG f -> List1 Cat
allEntryPoints :: forall f. CFG f -> NonEmpty Cat
allEntryPoints CFG f
cf =
  case [[RCat]] -> [RCat]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [RCat]
cats | EntryPoints [RCat]
cats <- CFG f -> [Pragma]
forall function. CFG function -> [Pragma]
cfgPragmas CFG f
cf ] of
    []   -> [Cat] -> NonEmpty Cat
forall a. [a] -> NonEmpty a
List1.fromList ([Cat] -> NonEmpty Cat) -> [Cat] -> NonEmpty Cat
forall a b. (a -> b) -> a -> b
$ CFG f -> [Cat]
forall function. CFG function -> [Cat]
allParserCats CFG f
cf  -- assumed to be non-empty
    RCat
c:[RCat]
cs -> (RCat -> Cat) -> NonEmpty RCat -> NonEmpty Cat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RCat -> Cat
forall a. WithPosition a -> a
wpThing (RCat
c RCat -> [RCat] -> NonEmpty RCat
forall a. a -> [a] -> NonEmpty a
:| [RCat]
cs)