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

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

module BNFC.CF where

import Prelude hiding ((<>))

import Control.Arrow ( (&&&) )
import Control.Monad ( guard )

import Data.Char
import Data.Ord      ( Down(..) )
import qualified Data.Either as Either
import Data.Function ( on )
import Data.List     ( nub, sort, group )
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.PrettyPrint
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
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 -> 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
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 Pretty function => Pretty (Rul function) where
  pretty :: Rul function -> Doc
pretty (Rule function
f RCat
cat SentForm
rhs InternalRule
internal) =
    (if InternalRule
internal forall a. Eq a => a -> a -> Bool
== InternalRule
Internal then (Doc
"internal" Doc -> Doc -> Doc
<+>) else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
    forall a. Pretty a => a -> Doc
pretty function
f Doc -> Doc -> Doc
<> Doc
"." Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
pretty RCat
cat Doc -> Doc -> Doc
<+> Doc
"::=" Doc -> Doc -> Doc
<+> [Doc] -> Doc
sep (forall a b. (a -> b) -> [a] -> [b]
map (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Pretty a => a -> Doc
pretty (String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show)) 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 -> [String]
cfgLiterals       :: [Literal]  -- ^ @Char, String, Ident, Integer, Double@.
                                      --   @String@s are quoted strings,
                                      --   and @Ident@s are unquoted.
    , forall function. CFG function -> [String]
cfgSymbols        :: [Symbol]   -- ^ Symbols in the grammar, e.g. “*”, “->”.
    , forall function. CFG function -> [String]
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 -> 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{..} = unlines $ map show 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.
type Base = Base' String

data Base' a
  = BaseT a
  | ListT (Base' a)
    deriving (Base' a -> Base' a -> Bool
forall a. Eq a => Base' a -> Base' a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Base' a -> Base' a -> Bool
$c/= :: forall a. Eq a => Base' a -> Base' a -> Bool
== :: Base' a -> Base' a -> Bool
$c== :: forall a. Eq a => Base' a -> Base' a -> Bool
Eq, Base' a -> Base' a -> Bool
Base' a -> Base' a -> Ordering
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
forall {a}. Ord a => Eq (Base' a)
forall a. Ord a => Base' a -> Base' a -> Bool
forall a. Ord a => Base' a -> Base' a -> Ordering
forall a. Ord a => Base' a -> Base' a -> Base' a
min :: Base' a -> Base' a -> Base' a
$cmin :: forall a. Ord a => Base' a -> Base' a -> Base' a
max :: Base' a -> Base' a -> Base' a
$cmax :: forall a. Ord a => Base' a -> Base' a -> Base' a
>= :: Base' a -> Base' a -> Bool
$c>= :: forall a. Ord a => Base' a -> Base' a -> Bool
> :: Base' a -> Base' a -> Bool
$c> :: forall a. Ord a => Base' a -> Base' a -> Bool
<= :: Base' a -> Base' a -> Bool
$c<= :: forall a. Ord a => Base' a -> Base' a -> Bool
< :: Base' a -> Base' a -> Bool
$c< :: forall a. Ord a => Base' a -> Base' a -> Bool
compare :: Base' a -> Base' a -> Ordering
$ccompare :: forall a. Ord a => Base' a -> Base' a -> Ordering
Ord, forall a b. a -> Base' b -> Base' a
forall a b. (a -> b) -> Base' a -> Base' 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 -> Base' b -> Base' a
$c<$ :: forall a b. a -> Base' b -> Base' a
fmap :: forall a b. (a -> b) -> Base' a -> Base' b
$cfmap :: forall a b. (a -> b) -> Base' a -> Base' b
Functor)

-- | Type of a rule label.
data Type = FunT [Base] Base
    deriving (Type -> Type -> Bool
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
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)

-- | Placeholder for a type.
dummyBase :: Base
dummyBase :: Base
dummyBase = forall a. a -> Base' a
BaseT String
"<DUMMY>"

-- | Placeholder for a function type.
dummyType :: Type
dummyType :: Type
dummyType = [Base] -> Base -> Type
FunT [] Base
dummyBase

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

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

-- | Expressions for function definitions.

data Exp' f
  = App f Type [Exp' f]     -- ^ (Possibly defined) label applied to expressions.
                            --   The function 'Type' is inferred by the type checker.
  | Var       String        -- ^ Function parameter.
  | LitInt    Integer
  | LitDouble Double
  | LitChar   Char
  | LitString String
  deriving (Exp' f -> Exp' f -> Bool
forall f. Eq f => Exp' f -> Exp' f -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Exp' f -> Exp' f -> Bool
$c/= :: forall f. Eq f => Exp' f -> Exp' f -> Bool
== :: Exp' f -> Exp' f -> Bool
$c== :: forall f. Eq f => Exp' f -> Exp' f -> Bool
Eq)

type Exp = Exp' String

instance (IsFun f, Pretty f) => Pretty (Exp' f) where
  prettyPrec :: Int -> Exp' f -> Doc
prettyPrec Int
p Exp' f
e =
    case forall {a}. IsFun a => Exp' a -> Either (Exp' a) [Exp' a]
listView Exp' f
e of
      Right [Exp' f]
es           -> Doc -> Doc
brackets forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
0) [Exp' f]
es
      Left (Var String
x)       -> String -> Doc
text String
x
      Left (App f
f Type
_ [])  -> forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
p f
f
      Left (App f
f Type
_ [Exp' f
e1,Exp' f
e2])
        | forall a. IsFun a => a -> Bool
isConsFun f
f    -> Bool -> Doc -> Doc
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep [ forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 Exp' f
e1, Doc
":", forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
0 Exp' f
e2 ]
      Left (App f
f Type
_ [Exp' f]
es)  -> Bool -> Doc -> Doc
parensIf (Int
p forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 f
f forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
2) [Exp' f]
es
      Left (LitInt Integer
n)    -> (String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) Integer
n
      Left (LitDouble Double
x) -> (String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) Double
x
      Left (LitChar Char
c)   -> (String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) Char
c
      Left (LitString String
s) -> (String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) String
s
    where
      listView :: Exp' a -> Either (Exp' a) [Exp' a]
listView (App a
f Type
_ [])
        | forall a. IsFun a => a -> Bool
isNilFun a
f              = forall a b. b -> Either a b
Right []
      listView (App a
f Type
_ [Exp' a
e1,Exp' a
e2])
        | forall a. IsFun a => a -> Bool
isConsFun a
f
        , Right [Exp' a]
es <- Exp' a -> Either (Exp' a) [Exp' a]
listView Exp' a
e2 = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Exp' a
e1forall a. a -> [a] -> [a]
:[Exp' a]
es
      listView Exp' a
e0                 = forall a b. a -> Either a b
Left Exp' a
e0

-- | 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 LayoutKeyWords
  | LayoutStop [KeyWord]
  | LayoutTop Symbol              -- ^ Separator for top-level layout.
  | FunDef Define

data Define = Define
  { Define -> RString
defName :: RFun
  , Define -> Telescope
defArgs :: Telescope  -- ^ Argument types inferred by the type checker.
  , Define -> Exp
defBody :: Exp
  , Define -> Base
defType :: Base       -- ^ Type of the body, inferred by the type checker.
  }

-- | Function arguments with type.
type Telescope = [(String, Base)]

-- | For use with 'partitionEithers'.
isFunDef :: Pragma -> Either Pragma Define
isFunDef :: Pragma -> Either Pragma Define
isFunDef = \case
  FunDef Define
d -> forall a b. b -> Either a b
Right Define
d
  Pragma
p        -> forall a b. a -> Either a b
Left  Pragma
p

-- | All 'define' pragmas of the grammar.
definitions :: CFG f -> [Define]
definitions :: forall f. CFG f -> [Define]
definitions CFG f
cf = [ Define
def | FunDef Define
def <- forall function. CFG function -> [Pragma]
cfgPragmas CFG f
cf ]

------------------------------------------------------------------------------
-- Layout
------------------------------------------------------------------------------

type LayoutKeyWords = [(KeyWord, Delimiters)]

-- | List delimiters.

data Delimiters = Delimiters
  { Delimiters -> String
listSep   :: Symbol           -- ^ List separator.
  , Delimiters -> String
listOpen  :: Symbol           -- ^ List opening delimiter.
  , Delimiters -> String
listClose :: Symbol           -- ^ List closing delimiter.
  } deriving Int -> Delimiters -> ShowS
[Delimiters] -> ShowS
Delimiters -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Delimiters] -> ShowS
$cshowList :: [Delimiters] -> ShowS
show :: Delimiters -> String
$cshow :: Delimiters -> String
showsPrec :: Int -> Delimiters -> ShowS
$cshowsPrec :: Int -> Delimiters -> ShowS
Show

-- | User-defined regular expression tokens
tokenPragmas :: CFG f -> [(TokenCat,Reg)]
tokenPragmas :: forall f. CFG f -> [(String, Reg)]
tokenPragmas CFG f
cf = [ (forall a. WithPosition a -> a
wpThing RString
name, Reg
e) | TokenReg RString
name Bool
_ Reg
e <- 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 -> [String]
tokenNames CFG f
cf = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall f. CFG f -> [(String, Reg)]
tokenPragmas CFG f
cf)

layoutPragmas :: CF -> (Maybe Symbol, LayoutKeyWords, [KeyWord])
layoutPragmas :: CF -> (Maybe String, LayoutKeyWords, [String])
layoutPragmas CF
cf =
  ( forall a. [a] -> Maybe a
listToMaybe [ String
sep | LayoutTop  String
sep <- [Pragma]
ps ]   -- if there's top-level layout
  , forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat      [ LayoutKeyWords
kws | Layout     LayoutKeyWords
kws <- [Pragma]
ps ]   -- layout-block inducing words
  , forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat      [ [String]
kws | LayoutStop [String]
kws <- [Pragma]
ps ]   -- layout-block aborting words
  )
  where
  ps :: [Pragma]
ps = forall function. CFG function -> [Pragma]
cfgPragmas CF
cf

hasLayout_ :: (Maybe Symbol, LayoutKeyWords, [KeyWord]) -> Bool
hasLayout_ :: (Maybe String, LayoutKeyWords, [String]) -> Bool
hasLayout_ (Maybe String
top, LayoutKeyWords
kws, [String]
_) = forall a. Maybe a -> Bool
isJust Maybe String
top Bool -> Bool -> Bool
|| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null LayoutKeyWords
kws)   -- (True,[],_) means: top-level layout only

hasLayout :: CF -> Bool
hasLayout :: CF -> Bool
hasLayout = (Maybe String, LayoutKeyWords, [String]) -> Bool
hasLayout_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> (Maybe String, LayoutKeyWords, [String])
layoutPragmas


-- | 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 -> String
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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Position] -> ShowS
$cshowList :: [Position] -> ShowS
show :: Position -> String
$cshow :: Position -> String
showsPrec :: Int -> Position -> ShowS
$cshowsPrec :: Int -> Position -> ShowS
Show, Position -> Position -> Bool
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
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 -> String
prettyPosition = \case
  Position
NoPosition -> String
""
  Position String
file Int
line Int
col -> forall a. [a] -> [[a]] -> [a]
List.intercalate String
":" [ String
file, forall a. Show a => a -> String
show Int
line, forall a. Show a => a -> String
show Int
col, String
"" ]

data WithPosition a = WithPosition
  { forall a. WithPosition a -> Position
wpPosition :: Position
  , forall a. WithPosition a -> a
wpThing    :: a
  } deriving (Int -> WithPosition a -> ShowS
forall a. Show a => Int -> WithPosition a -> ShowS
forall a. Show a => [WithPosition a] -> ShowS
forall a. Show a => WithPosition a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WithPosition a] -> ShowS
$cshowList :: forall a. Show a => [WithPosition a] -> ShowS
show :: WithPosition a -> String
$cshow :: forall a. Show a => WithPosition a -> String
showsPrec :: Int -> WithPosition a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> WithPosition a -> ShowS
Show, 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 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
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
(==)    = forall a. Eq a => a -> a -> Bool
(==)    forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a. WithPosition a -> a
wpThing
instance Ord a => Ord (WithPosition a) where compare :: WithPosition a -> WithPosition a -> Ordering
compare = forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a. WithPosition a -> a
wpThing

instance Pretty a => Pretty (WithPosition a) where pretty :: WithPosition a -> Doc
pretty = forall a. Pretty a => a -> Doc
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. WithPosition a -> a
wpThing

noPosition :: a -> WithPosition a
noPosition :: forall a. a -> WithPosition a
noPosition = 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 :: RString -> String
blendInPosition (WithPosition Position
pos String
msg)
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
p    = String
msg
  | Bool
otherwise = [String] -> String
unwords [ String
p, String
msg ]
  where
  p :: String
p = Position -> String
prettyPosition Position
pos

type RCat    = WithPosition Cat

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

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

npIdentifier :: String -> Abs.Identifier
npIdentifier :: String -> Identifier
npIdentifier String
x = ((Int, Int), String) -> Identifier
Abs.Identifier ((Int
0, Int
0), String
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
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
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 -> String
catToStr = \case
  Cat String
s        -> String
s
  TokenCat String
s   -> String
s
  ListCat Cat
c    -> String
"[" forall a. [a] -> [a] -> [a]
++ Cat -> String
catToStr Cat
c forall a. [a] -> [a] -> [a]
++ String
"]"
  CoercCat String
s Integer
i -> String
s forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
i

-- | This instance is for the Hspec test suite.
instance Show Cat where
  show :: Cat -> String
show = Cat -> String
catToStr

instance Pretty Cat where
  pretty :: Cat -> Doc
pretty = \case
    Cat String
s        -> String -> Doc
text String
s
    TokenCat String
s   -> String -> Doc
text String
s
    ListCat Cat
c    -> Doc -> Doc
brackets forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
pretty Cat
c
    CoercCat String
s Integer
i -> String -> Doc
text String
s Doc -> Doc -> Doc
<> forall a. Pretty a => a -> Doc
pretty Integer
i


-- | 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 :: String -> Cat
strToCat String
s =
    case [Token] -> Err Cat
pCat (String -> [Token]
tokens String
s) of
        Right Cat
c -> Cat -> Cat
cat2cat Cat
c
        Left String
_ -> String -> Cat
Cat String
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, String
x))
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ds   -> if String
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
specialCatsP then String -> Cat
TokenCat String
c else String -> Cat
Cat String
c
      | Bool
otherwise -> String -> Integer -> Cat
CoercCat String
c (forall a. Read a => String -> a
read String
ds)
      where (String
ds, String
c) = forall a. (a -> Bool) -> [a] -> ([a], [a])
spanEnd Char -> Bool
isDigit String
x
    Abs.ListCat Cat
c -> Cat -> Cat
ListCat (Cat -> Cat
cat2cat Cat
c)

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

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

-- all literals
-- the parser needs these
specialCatsP :: [TokenCat]
specialCatsP :: [String]
specialCatsP = String
catIdent forall a. a -> [a] -> [a]
: [String]
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 String
_ Integer
_)  = Bool
False
isDataOrListCat (Cat (Char
'@':String
_))   = 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 = forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Cat -> Cat
normCat

-- | 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 String
c Integer
_) = String -> Cat
Cat String
c
normCat Cat
c = Cat
c

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

identType :: Base -> String
identType :: Base -> String
identType (ListT Base
t) = String
"List" forall a. [a] -> [a] -> [a]
++ Base -> String
identType Base
t
identType (BaseT String
s) = String
s

-- | Reconstruct (non-coercion) category from a type, given a list of
-- what should be the token categories.
catOfType :: [TokenCat] -> Base -> Cat
catOfType :: [String] -> Base -> Cat
catOfType [String]
tk = \case
  ListT Base
t -> Cat -> Cat
ListCat forall a b. (a -> b) -> a -> b
$ [String] -> Base -> Cat
catOfType [String]
tk Base
t
  BaseT String
s
   | String
s forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
tk -> String -> Cat
TokenCat String
s
   | Bool
otherwise   -> String -> Cat
Cat String
s

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 String String
baseCat = \case
  ListCat Cat
c    -> Cat -> Either String String
baseCat Cat
c
  CoercCat String
x Integer
_ -> forall a b. a -> Either a b
Left String
x
  Cat String
x        -> forall a b. a -> Either a b
Left String
x
  TokenCat String
x   -> forall a b. b -> Either a b
Right String
x

isTokenCat :: Cat -> Bool
isTokenCat :: Cat -> Bool
isTokenCat (TokenCat String
_) = Bool
True
isTokenCat Cat
_            = Bool
False

maybeTokenCat :: Cat -> Maybe TokenCat
maybeTokenCat :: Cat -> Maybe String
maybeTokenCat = \case
  TokenCat String
c -> forall a. a -> Maybe a
Just String
c
  Cat
_          -> 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 :: String -> RString
fromString = forall a. a -> WithPosition a
noPosition

class IsFun a where
  funName :: a -> String

  isNilFun    :: a -> Bool   -- ^ Is this the constructor for empty lists?
  isOneFun    :: a -> Bool   -- ^ Is this the constructor for singleton lists?
  isConsFun   :: a -> Bool   -- ^ Is this the list constructor?
  isConcatFun :: a -> Bool   -- ^ Is this list concatenation?

  -- | Is this function just a coercion? (I.e. the identity)
  isCoercion :: a -> Bool

  isNilFun    = forall a. IsFun a => (String -> Bool) -> a -> Bool
funNameSatisfies (forall a. Eq a => a -> a -> Bool
== String
"[]")
  isOneFun    = forall a. IsFun a => (String -> Bool) -> a -> Bool
funNameSatisfies (forall a. Eq a => a -> a -> Bool
== String
"(:[])")
  isConsFun   = forall a. IsFun a => (String -> Bool) -> a -> Bool
funNameSatisfies (forall a. Eq a => a -> a -> Bool
== String
"(:)")
  isConcatFun = forall a. IsFun a => (String -> Bool) -> a -> Bool
funNameSatisfies (forall a. Eq a => a -> a -> Bool
== String
"(++)")
  isCoercion  = forall a. IsFun a => (String -> Bool) -> a -> Bool
funNameSatisfies (forall a. Eq a => a -> a -> Bool
== String
"_")

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

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

instance IsFun a => IsFun (Rul a) where
  funName :: Rul a -> String
funName = forall a. IsFun a => a -> String
funName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall function. Rul function -> function
funRule

instance IsFun a => IsFun (k, a) where
  funName :: (k, a) -> String
funName = forall a. IsFun a => a -> String
funName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd

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

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

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

isNilCons :: IsFun a => a -> Bool
isNilCons :: forall a. IsFun a => a -> Bool
isNilCons a
f = forall a. IsFun a => a -> Bool
isNilFun a
f Bool -> Bool -> Bool
|| forall a. IsFun a => a -> Bool
isOneFun a
f Bool -> Bool -> Bool
|| forall a. IsFun a => a -> Bool
isConsFun a
f Bool -> Bool -> Bool
|| forall a. IsFun a => a -> Bool
isConcatFun a
f

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

-- | 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 = forall a. NonEmpty a -> a
List1.head forall a b. (a -> b) -> a -> b
$ forall f. CFG f -> List1 Cat
allEntryPoints CF
cf

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

-- | Constructors and categories.
allNames :: CF -> [RString]
allNames :: CF -> [RString]
allNames CF
cf =
  [ RString
f | RString
f <- forall a b. (a -> b) -> [a] -> [b]
map forall function. Rul function -> function
funRule forall a b. (a -> b) -> a -> b
$ forall function. CFG function -> [Rul function]
cfgRules CF
cf
      , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. IsFun a => a -> Bool
isNilCons RString
f
      , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. IsFun a => a -> Bool
isCoercion RString
f
  ] forall a. [a] -> [a] -> [a]
++
  CF -> [RString]
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]
_) <- forall a. Eq a => [a] -> [[a]]
group forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort [a]
xs ]


-- | Extract the comment pragmas.
commentPragmas :: [Pragma] -> [Pragma]
commentPragmas :: [Pragma] -> [Pragma]
commentPragmas = forall a. (a -> Bool) -> [a] -> [a]
filter Pragma -> Bool
isComment
 where isComment :: Pragma -> Bool
isComment (CommentS String
_) = Bool
True
       isComment (CommentM (String, String)
_) = 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 = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup f
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map 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', (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 =
  [ forall f. Rul f -> Rul f
removeWhiteSpaceSeparators Rule
r | Rule
r <- forall function. CFG function -> [Rul function]
cfgRules CF
cf, forall f. Rul f -> Bool
isParsable Rule
r, forall fun. Rul fun -> Cat
valCat Rule
r forall a. Eq a => a -> a -> Bool
== Cat
cat]

removeWhiteSpaceSeparators :: Rul f -> Rul f
removeWhiteSpaceSeparators :: forall f. Rul f -> Rul f
removeWhiteSpaceSeparators = forall f. (SentForm -> SentForm) -> Rul f -> Rul f
mapRhs forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) forall a b. (a -> b) -> a -> b
$ \ String
sep ->
  if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
sep then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (forall a b. b -> Either a b
Right String
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 forall a b. (a -> b) -> a -> b
$ 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 <- forall function. CFG function -> [Rul function]
cfgRules CF
cf, Cat -> Cat
normCat (forall fun. Rul fun -> Cat
valCat Rule
r) 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 <- forall function. CFG function -> [Rul function]
cfgRules CF
cf, forall fun. Rul fun -> Cat
valCat Rule
r 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 = forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall fun. Rul fun -> Cat
valCat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (InternalRule -> Bool
pred forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall function. Rul function -> InternalRule
internal) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall f. (InternalRule -> Bool) -> CFG f -> [Cat]
allCats forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Bool
True

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

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

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

-- | Get all normalized Cat
allParserCatsNorm :: CFG f -> [Cat]
allParserCatsNorm :: forall function. CFG function -> [Cat]
allParserCatsNorm = forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Cat -> Cat
normCat forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = (forall a. Ord a => a -> Set a -> Bool
`Set.member` 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 <- 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 <- 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 -> [String]
literals CFG f
cf = forall function. CFG function -> [String]
cfgLiterals CFG f
cf forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall f. CFG f -> [(String, Reg)]
tokenPragmas CFG f
cf)

-- | Get the keywords of a grammar.
reservedWords :: CFG f -> [String]
reservedWords :: forall function. CFG function -> [String]
reservedWords = forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall function. CFG function -> [String]
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 -> [(String, Int)]
cfTokens CFG f
cf = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Ord a => [a] -> [a]
sort (forall function. CFG function -> [String]
cfgSymbols CFG f
cf forall a. [a] -> [a] -> [a]
++ forall function. CFG function -> [String]
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 -> ([(String, String)], [String])
comments CF
cf = ([(String, String)
p | CommentM (String, String)
p <- [Pragma]
xs], [String
s | CommentS String
s <- [Pragma]
xs])
  where
  xs :: [Pragma]
xs = [Pragma] -> [Pragma]
commentPragmas (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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> ([(String, String)], [String])
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 = forall f. CFG f -> Cat -> Bool
isUsedCat CFG f
cf forall a b. (a -> b) -> a -> b
$ String -> Cat
TokenCat String
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 -> [String]
specialCats CF
cf = (if forall f. CFG f -> Bool
hasIdent CF
cf then (String
catIdentforall a. a -> [a] -> [a]
:) else forall a. a -> a
id) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall f. CFG f -> [(String, 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, forall a. Eq a => [a] -> [a]
nub (Cat -> [(String, [Cat])]
constructors Cat
c) ) | Cat
c <- CF -> [Cat]
allCatsNorm CF
cf ]
  where
    constructors :: Cat -> [(String, [Cat])]
constructors Cat
cat = do
        Rule
rule <- forall function. CFG function -> [Rul function]
cfgRules CF
cf
        let f :: RString
f = forall function. Rul function -> function
funRule Rule
rule
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (forall a. IsFun a => a -> Bool
isDefinedRule RString
f)
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (forall a. IsFun a => a -> Bool
isCoercion RString
f)
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Cat -> Cat
normCat (forall fun. Rul fun -> Cat
valCat Rule
rule) forall a. Eq a => a -> a -> Bool
== Cat
cat
        let cs :: [Cat]
cs = [Cat -> Cat
normCat Cat
c | Left Cat
c <- forall function. Rul function -> SentForm
rhsRule Rule
rule ]
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. WithPosition a -> a
wpThing RString
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, forall a. Eq a => [a] -> [a]
nub (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Rul (WithPosition a) -> (a, [Cat])
mkData [Rule
r | Rule
r <- forall function. CFG function -> [Rul function]
cfgRules CF
cf,
                              let f :: RString
f = forall function. Rul function -> function
funRule Rule
r,
                              Bool -> Bool
not (forall a. IsFun a => a -> Bool
isDefinedRule RString
f),
                              Bool -> Bool
not (forall a. IsFun a => a -> Bool
isCoercion RString
f), Cat
cat forall a. Eq a => a -> a -> Bool
== Cat -> Cat
normCat (forall fun. Rul fun -> Cat
valCat Rule
r)]))
      | Cat
cat <- forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Cat -> Cat
normCat forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter Cat -> Bool
predicate forall a b. (a -> b) -> a -> b
$ forall function. CFG function -> [Cat]
reallyAllCats CF
cf ]
  where
  mkData :: Rul (WithPosition a) -> (a, [Cat])
mkData (Rule WithPosition a
f RCat
_ SentForm
its InternalRule
_) = (forall a. WithPosition a -> a
wpThing WithPosition a
f, [Cat -> Cat
normCat Cat
c | Left Cat
c <- SentForm
its ])

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

-- translates to a Data with List categories included.
cf2dataLists :: CF -> [Data]
cf2dataLists :: CF -> [Data]
cf2dataLists = (Cat -> Bool) -> CF -> [Data]
cf2data' forall a b. (a -> b) -> a -> b
$ Cat -> Bool
isDataOrListCat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> Cat
normCat

specialData :: CF -> [Data]
specialData :: CF -> [Data]
specialData CF
cf = [(String -> Cat
TokenCat String
name, [(String
name, [String -> Cat
TokenCat String
catString])]) | String
name <- CF -> [String]
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 = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall a. IsFun a => a -> String
funName a
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall function. Rul function -> InternalRule
internal

hasNilRule :: [Rule] -> Maybe Rule
hasNilRule :: [Rule] -> Maybe Rule
hasNilRule = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find forall a. IsFun a => a -> Bool
isNilFun

-- | Gets the singleton rule out of the rules for a list.
hasSingletonRule :: [Rule] -> Maybe Rule
hasSingletonRule :: [Rule] -> Maybe Rule
hasSingletonRule = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find forall a. IsFun a => a -> Bool
isOneFun

-- | Sort rules by descending precedence.

sortRulesByPrecedence :: [Rule] -> [(Integer,Rule)]
sortRulesByPrecedence :: [Rule] -> [(Integer, Rule)]
sortRulesByPrecedence = forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn (forall a. a -> Down a
Down forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall f. Rul f -> Integer
precRule forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. a -> a
id)

-- | Is the given category a list category parsing also empty lists?
isEmptyListCat :: CF -> Cat -> Bool
isEmptyListCat :: CF -> Cat -> Bool
isEmptyListCat CF
cf = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a. IsFun a => a -> Bool
isNilFun forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> Cat -> [Rule]
rulesForCat' CF
cf

isNonterm :: Either Cat String -> Bool
isNonterm :: Either Cat String -> Bool
isNonterm = forall a b. Either a b -> Bool
Either.isLeft

-- 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) = forall function.
function -> RCat -> SentForm -> InternalRule -> Rul function
Rule f
f RCat
c (Either Cat String
xs forall a. a -> [a] -> [a]
: Either Cat String
x forall a. a -> [a] -> [a]
: SentForm
sep) InternalRule
internal where
  (Either Cat String
x,SentForm
sep,Either Cat String
xs) = (forall a. [a] -> a
head SentForm
ts, forall a. [a] -> [a]
init (forall a. [a] -> [a]
tail SentForm
ts), 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, forall {a}. IsFun a => Cat -> [Rul a] -> Bool
isRev Cat
c [Rule]
r]
  where
  isRev :: Cat -> [Rul a] -> Bool
isRev Cat
c = \case
     [Rul a
r1,Rul a
r2] | Cat -> Bool
isList Cat
c -> if forall a. IsFun a => a -> Bool
isConsFun (forall function. Rul function -> function
funRule Rul a
r2) then forall {a} {a}. (IsFun a, IsFun a) => Rul a -> Rul a -> Bool
tryRev Rul a
r2 Rul a
r1
                           else forall a. IsFun a => a -> Bool
isConsFun (forall function. Rul function -> function
funRule Rul a
r1) Bool -> Bool -> 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 String
x:Either Cat String
_:SentForm
_) InternalRule
_) Rul a
r = forall a. IsFun a => Rul a -> Bool
isEmptyNilRule Rul a
r Bool -> Bool -> Bool
&&
                                        forall a. IsFun a => a -> Bool
isConsFun a
f Bool -> Bool -> Bool
&& Either Cat String -> Bool
isNonterm Either Cat String
x Bool -> Bool -> Bool
&& Either Cat String -> Bool
isNonterm (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
_) = forall a. IsFun a => a -> Bool
isNilFun a
f Bool -> Bool -> 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 String
_ 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall f. CFG f -> Bool
hasIdent CFG g
cf Bool -> Bool -> Bool
|| forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bool -> Bool
not Bool
b | TokenReg RString
_ Bool
b Reg
_ <- forall function. CFG function -> [Pragma]
cfgPragmas CFG g
cf ]

-- | Defines or uses the grammar @token@ types or @Ident@?
hasTextualTokens :: CFG g -> Bool
hasTextualTokens :: forall f. CFG f -> Bool
hasTextualTokens CFG g
cf = forall f. CFG f -> Bool
hasIdent CFG g
cf Bool -> Bool -> Bool
|| forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bool
True | TokenReg{} <- 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 = forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bool
b | TokenReg RString
_ Bool
b Reg
_ <- 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 -> String -> Bool
isPositionCat CFG f
cf String
cat = forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bool
b | TokenReg RString
name Bool
b Reg
_ <- forall function. CFG function -> [Pragma]
cfgPragmas CFG f
cf, forall a. WithPosition a -> a
wpThing RString
name forall a. Eq a => a -> a -> Bool
== String
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 -> List1 Cat
allEntryPoints CFG f
cf =
  case forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [RCat]
cats | EntryPoints [RCat]
cats <- forall function. CFG function -> [Pragma]
cfgPragmas CFG f
cf ] of
    []   -> forall a. [a] -> NonEmpty a
List1.fromList forall a b. (a -> b) -> a -> b
$ forall function. CFG function -> [Cat]
allParserCats CFG f
cf  -- assumed to be non-empty
    RCat
c:[RCat]
cs -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. WithPosition a -> a
wpThing (RCat
c forall a. a -> [a] -> NonEmpty a
:| [RCat]
cs)