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

-- | First pass of processing a LBNF file.
--
-- - Find all the categories defined in a LBNF grammar.
--
-- - Complain about duplicate categories, e.g. defined both by rules and @list@ or @token@ pragmas.
--
-- - Drops errorneous definitions, returning a list of errors.
--   It is possible to continue into pass 2 with the remaining definitions,
--   should the user desire so (switch @--force@).
--
-- - Produces a map whose keys are the grammar categories parsed into 'ICat' intermediate format
--   and whose values are their first defining occurrences plus kind information.
--
-- This pass does not transform the list of parsed definitions into an intermediate format,
-- e.g. for saving the translations of category names to 'ICat'.
-- This could be done, but the translation is cheap and deterministic, so it can be repeated in pass 2.

module BNFC.Check.Pass1 where

import BNFC.Prelude

import qualified Data.Map           as Map
import Lens.Micro.TH (makeLenses)

import qualified BNFC.Abs as A
import BNFC.Abs (HasPosition(..))
import BNFC.CF
import BNFC.Types.Position

import BNFC.Check.Monad

-- | The state and result of pass1.
data Pass1 = Pass1
  { Pass1 -> DefinedICats
_stDefinedCats :: DefinedICats
      -- ^ The categories defined by the grammar.
  , Pass1 -> Map ICat (List1 (WithPosition Parseable))
_stUsedCats    :: Map ICat    (List1 (WithPosition Parseable))
      -- ^ The categories referenced (used) in the grammar.
      --   Occurrences in @internal@ rules will be labeled 'Internal'.
  , Pass1 -> Map Keyword (List1 Position)
_stKeywords    :: Map Keyword (List1 Position)
      -- ^ The keywords used in the grammar.
  }
  deriving Int -> Pass1 -> ShowS
[Pass1] -> ShowS
Pass1 -> String
(Int -> Pass1 -> ShowS)
-> (Pass1 -> String) -> ([Pass1] -> ShowS) -> Show Pass1
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pass1] -> ShowS
$cshowList :: [Pass1] -> ShowS
show :: Pass1 -> String
$cshow :: Pass1 -> String
showsPrec :: Int -> Pass1 -> ShowS
$cshowsPrec :: Int -> Pass1 -> ShowS
Show

type DefinedICats = Map ICat PCatKind

-- | The kind of a category definition.

data CatKind
  = KRules (List1 RuleKind)  -- ^ given by rules and/or @rules@ pragma
  | KList                    -- ^ given by @separator@ or @terminator@ pragma
  | KToken PositionToken     -- ^ given by @token@ pragma
  deriving (Int -> CatKind -> ShowS
[CatKind] -> ShowS
CatKind -> String
(Int -> CatKind -> ShowS)
-> (CatKind -> String) -> ([CatKind] -> ShowS) -> Show CatKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CatKind] -> ShowS
$cshowList :: [CatKind] -> ShowS
show :: CatKind -> String
$cshow :: CatKind -> String
showsPrec :: Int -> CatKind -> ShowS
$cshowsPrec :: Int -> CatKind -> ShowS
Show)

type PCatKind = WithPosition CatKind

-- | The kind of a rule definition.

data RuleKind
  = ROrdinary Parseable  -- ^ ordinary or @internal@ rule
  | RRules               -- ^ @rules@ pragma
  | RCoercion            -- ^ @coercion@ pragma
  deriving (Int -> RuleKind -> ShowS
[RuleKind] -> ShowS
RuleKind -> String
(Int -> RuleKind -> ShowS)
-> (RuleKind -> String) -> ([RuleKind] -> ShowS) -> Show RuleKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RuleKind] -> ShowS
$cshowList :: [RuleKind] -> ShowS
show :: RuleKind -> String
$cshow :: RuleKind -> String
showsPrec :: Int -> RuleKind -> ShowS
$cshowsPrec :: Int -> RuleKind -> ShowS
Show)

makeLenses ''Pass1

-- | Entry point for pass 1.

checkLBNF :: A.Grammar -> Check (A.Grammar, Pass1)
checkLBNF :: Grammar -> Check (Grammar, Pass1)
checkLBNF Grammar
grammar = StateT Pass1 Check Grammar -> Pass1 -> Check (Grammar, Pass1)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Grammar -> StateT Pass1 Check Grammar
checkGrammar Grammar
grammar) (Pass1 -> Check (Grammar, Pass1))
-> Pass1 -> Check (Grammar, Pass1)
forall a b. (a -> b) -> a -> b
$ Pass1 :: DefinedICats
-> Map ICat (List1 (WithPosition Parseable))
-> Map Keyword (List1 Position)
-> Pass1
Pass1
  { _stDefinedCats :: DefinedICats
_stDefinedCats = DefinedICats
forall a. Monoid a => a
mempty
  , _stUsedCats :: Map ICat (List1 (WithPosition Parseable))
_stUsedCats    = Map ICat (List1 (WithPosition Parseable))
forall a. Monoid a => a
mempty
  , _stKeywords :: Map Keyword (List1 Position)
_stKeywords    = Map Keyword (List1 Position)
forall a. Monoid a => a
mempty
  }

-- * Pass 1 checker
---------------------------------------------------------------------------

-- | The monad for pass 1, manipulates 'Pass1'.
type M = StateT Pass1 Check

-- | Check a whole grammar, swallowing errorneous definitions.

checkGrammar :: A.Grammar -> M A.Grammar
checkGrammar :: Grammar -> StateT Pass1 Check Grammar
checkGrammar (A.Grammar BNFC'Position
p [Def' BNFC'Position]
defs) = BNFC'Position -> [Def' BNFC'Position] -> Grammar
forall a. a -> [Def' a] -> Grammar' a
A.Grammar BNFC'Position
p ([Def' BNFC'Position] -> Grammar)
-> ([Maybe (Def' BNFC'Position)] -> [Def' BNFC'Position])
-> [Maybe (Def' BNFC'Position)]
-> Grammar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Def' BNFC'Position)] -> [Def' BNFC'Position]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Def' BNFC'Position)] -> Grammar)
-> StateT Pass1 Check [Maybe (Def' BNFC'Position)]
-> StateT Pass1 Check Grammar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Def' BNFC'Position
 -> StateT Pass1 Check (Maybe (Def' BNFC'Position)))
-> [Def' BNFC'Position]
-> StateT Pass1 Check [Maybe (Def' BNFC'Position)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Def' BNFC'Position
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
checkDef [Def' BNFC'Position]
defs

-- | Check a definition.  Swallow it if it produces a recoverable error.

checkDef :: A.Def -> M (Maybe A.Def)
checkDef :: Def' BNFC'Position
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
checkDef Def' BNFC'Position
def =
  case Def' BNFC'Position
def of
    A.Rule       (Just (Int, Int)
p) Label' BNFC'Position
_ Cat' BNFC'Position
cat RHS' BNFC'Position
rhs -> M ()
-> Maybe (Def' BNFC'Position)
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
may (RHS' BNFC'Position -> M ()
forall a. AddCategories a => a -> M ()
useCats RHS' BNFC'Position
rhs M () -> M () -> M ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RHS' BNFC'Position -> M ()
forall a. AddKeywords a => a -> M ()
addKeywords RHS' BNFC'Position
rhs) (Maybe (Def' BNFC'Position)
 -> StateT Pass1 Check (Maybe (Def' BNFC'Position)))
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
                                       (Int, Int)
-> CatKind
-> Cat' BNFC'Position
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall p.
ToPosition p =>
p
-> CatKind
-> Cat' BNFC'Position
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
addCat (Int, Int)
p (RuleKind -> CatKind
ruleKind (RuleKind -> CatKind) -> RuleKind -> CatKind
forall a b. (a -> b) -> a -> b
$ Parseable -> RuleKind
ROrdinary Parseable
Parseable) Cat' BNFC'Position
cat
    A.Internal   (Just (Int, Int)
p) Label' BNFC'Position
_ Cat' BNFC'Position
cat RHS' BNFC'Position
rhs -> M ()
-> Maybe (Def' BNFC'Position)
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
may (RHS' BNFC'Position -> M ()
forall a. AddCategories a => a -> M ()
useCatsInternal RHS' BNFC'Position
rhs) (Maybe (Def' BNFC'Position)
 -> StateT Pass1 Check (Maybe (Def' BNFC'Position)))
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do   -- no keywords when 'internal'!
                                       (Int, Int)
-> CatKind
-> Cat' BNFC'Position
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall p.
ToPosition p =>
p
-> CatKind
-> Cat' BNFC'Position
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
addCat (Int, Int)
p (RuleKind -> CatKind
ruleKind (RuleKind -> CatKind) -> RuleKind -> CatKind
forall a b. (a -> b) -> a -> b
$ Parseable -> RuleKind
ROrdinary Parseable
Internal ) Cat' BNFC'Position
cat
    A.Token      (Just (Int, Int)
p) Identifier
x Reg' BNFC'Position
_       -> (Int, Int)
-> CatKind
-> Cat' BNFC'Position
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall p.
ToPosition p =>
p
-> CatKind
-> Cat' BNFC'Position
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
addCat (Int, Int)
p (PositionToken -> CatKind
KToken PositionToken
NoPositionToken) (Cat' BNFC'Position
 -> StateT Pass1 Check (Maybe (Def' BNFC'Position)))
-> Cat' BNFC'Position
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall a b. (a -> b) -> a -> b
$ Identifier -> Cat' BNFC'Position
identifierToCat Identifier
x
    A.PosToken   (Just (Int, Int)
p) Identifier
x Reg' BNFC'Position
_       -> (Int, Int)
-> CatKind
-> Cat' BNFC'Position
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall p.
ToPosition p =>
p
-> CatKind
-> Cat' BNFC'Position
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
addCat (Int, Int)
p (PositionToken -> CatKind
KToken   PositionToken
PositionToken) (Cat' BNFC'Position
 -> StateT Pass1 Check (Maybe (Def' BNFC'Position)))
-> Cat' BNFC'Position
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall a b. (a -> b) -> a -> b
$ Identifier -> Cat' BNFC'Position
identifierToCat Identifier
x
    A.Separator  (Just (Int, Int)
p) MinimumSize' BNFC'Position
_ Cat' BNFC'Position
cat String
s   -> M ()
-> Maybe (Def' BNFC'Position)
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
may (Cat' BNFC'Position -> M ()
forall a. AddCategories a => a -> M ()
useCats Cat' BNFC'Position
cat M () -> M () -> M ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ((Int, Int), String) -> M ()
forall a. AddKeywords a => a -> M ()
addKeywords ((Int, Int)
p, String
s)) (Maybe (Def' BNFC'Position)
 -> StateT Pass1 Check (Maybe (Def' BNFC'Position)))
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Int, Int)
-> Cat' BNFC'Position
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall p.
ToPosition p =>
p
-> Cat' BNFC'Position
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
addListCat (Int, Int)
p Cat' BNFC'Position
cat
    A.Terminator (Just (Int, Int)
p) MinimumSize' BNFC'Position
_ Cat' BNFC'Position
cat String
s   -> M ()
-> Maybe (Def' BNFC'Position)
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
may (Cat' BNFC'Position -> M ()
forall a. AddCategories a => a -> M ()
useCats Cat' BNFC'Position
cat M () -> M () -> M ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ((Int, Int), String) -> M ()
forall a. AddKeywords a => a -> M ()
addKeywords ((Int, Int)
p, String
s)) (Maybe (Def' BNFC'Position)
 -> StateT Pass1 Check (Maybe (Def' BNFC'Position)))
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Int, Int)
-> Cat' BNFC'Position
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall p.
ToPosition p =>
p
-> Cat' BNFC'Position
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
addListCat (Int, Int)
p Cat' BNFC'Position
cat
    A.Delimiters (Just (Int, Int)
p) Cat' BNFC'Position
_ String
_ String
_ Separation' BNFC'Position
_ MinimumSize' BNFC'Position
_ -> (Int, Int)
-> RecoverableError
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall p a.
ToPosition' p =>
p -> RecoverableError -> StateT Pass1 Check (Maybe a)
failure (Int, Int)
p RecoverableError
DelimitersNotSupported
    A.Coercions  (Just (Int, Int)
p) Identifier
x Integer
n       -> M ()
-> Maybe (Def' BNFC'Position)
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
may ([((Int, Int), String)] -> M ()
forall a. AddKeywords a => a -> M ()
addKeywords [((Int, Int)
p, String
"("), ((Int, Int)
p, String
")")]) (Maybe (Def' BNFC'Position)
 -> StateT Pass1 Check (Maybe (Def' BNFC'Position)))
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Int, Int)
-> Identifier
-> Integer
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall p.
(ToPosition p, ToPosition' p) =>
p
-> Identifier
-> Integer
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
addCoercions (Int, Int)
p Identifier
x Integer
n
    A.Rules      (Just (Int, Int)
p) Identifier
x [RHS' BNFC'Position]
rhs     -> M ()
-> Maybe (Def' BNFC'Position)
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
may ([RHS' BNFC'Position] -> M ()
forall a. AddCategories a => a -> M ()
useCats [RHS' BNFC'Position]
rhs M () -> M () -> M ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [RHS' BNFC'Position] -> M ()
forall a. AddKeywords a => a -> M ()
addKeywords [RHS' BNFC'Position]
rhs) (Maybe (Def' BNFC'Position)
 -> StateT Pass1 Check (Maybe (Def' BNFC'Position)))
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
                                       (Int, Int)
-> CatKind
-> Cat' BNFC'Position
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall p.
ToPosition p =>
p
-> CatKind
-> Cat' BNFC'Position
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
addCat (Int, Int)
p (RuleKind -> CatKind
ruleKind RuleKind
RRules) (Cat' BNFC'Position
 -> StateT Pass1 Check (Maybe (Def' BNFC'Position)))
-> Cat' BNFC'Position
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall a b. (a -> b) -> a -> b
$ Identifier -> Cat' BNFC'Position
identifierToCat Identifier
x
    A.Entryp     BNFC'Position
_        [Cat' BNFC'Position]
cats      -> [Cat' BNFC'Position] -> M ()
forall a. AddCategories a => a -> M ()
useCats [Cat' BNFC'Position]
cats M ()
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT Pass1 Check (Maybe (Def' BNFC'Position))
nop
    -- Ignore these definitions forms in pass 1:
    A.Function{}   -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
nop
    -- Lexer stuff:
    A.Comment{}    -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
nop
    A.Comments{}   -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
nop
    A.Layout{}     -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
nop
    A.LayoutStop{} -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
nop
    A.LayoutTop{}  -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
nop
    A.Rule       BNFC'Position
Nothing Label' BNFC'Position
_ Cat' BNFC'Position
_ RHS' BNFC'Position
_     -> String -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall a. HasCallStack => String -> a
panic String
panicStr
    A.Internal   BNFC'Position
Nothing Label' BNFC'Position
_ Cat' BNFC'Position
_ RHS' BNFC'Position
_     -> String -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall a. HasCallStack => String -> a
panic String
panicStr
    A.Token      BNFC'Position
Nothing Identifier
_ Reg' BNFC'Position
_       -> String -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall a. HasCallStack => String -> a
panic String
panicStr
    A.PosToken   BNFC'Position
Nothing Identifier
_ Reg' BNFC'Position
_       -> String -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall a. HasCallStack => String -> a
panic String
panicStr
    A.Separator  BNFC'Position
Nothing MinimumSize' BNFC'Position
_ Cat' BNFC'Position
_ String
_     -> String -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall a. HasCallStack => String -> a
panic String
panicStr
    A.Terminator BNFC'Position
Nothing MinimumSize' BNFC'Position
_ Cat' BNFC'Position
_ String
_     -> String -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall a. HasCallStack => String -> a
panic String
panicStr
    A.Delimiters BNFC'Position
Nothing Cat' BNFC'Position
_ String
_ String
_ Separation' BNFC'Position
_ MinimumSize' BNFC'Position
_ -> String -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall a. HasCallStack => String -> a
panic String
panicStr
    A.Coercions  BNFC'Position
Nothing Identifier
_ Integer
_       -> String -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall a. HasCallStack => String -> a
panic String
panicStr
    A.Rules      BNFC'Position
Nothing Identifier
_ [RHS' BNFC'Position]
_       -> String -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall a. HasCallStack => String -> a
panic String
panicStr

  where
  nop :: StateT Pass1 Check (Maybe (Def' BNFC'Position))
nop = Maybe (Def' BNFC'Position)
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Def' BNFC'Position)
 -> StateT Pass1 Check (Maybe (Def' BNFC'Position)))
-> Maybe (Def' BNFC'Position)
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall a b. (a -> b) -> a -> b
$ Def' BNFC'Position -> Maybe (Def' BNFC'Position)
forall a. a -> Maybe a
Just Def' BNFC'Position
def
  keep :: StateT Pass1 Check b
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
keep = (Def' BNFC'Position -> Maybe (Def' BNFC'Position)
forall a. a -> Maybe a
Just Def' BNFC'Position
def Maybe (Def' BNFC'Position)
-> StateT Pass1 Check b
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$)
  skip :: StateT Pass1 Check b -> StateT Pass1 Check (Maybe a)
skip = (Maybe a
forall a. Maybe a
Nothing Maybe a -> StateT Pass1 Check b -> StateT Pass1 Check (Maybe a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$)
  failure :: p -> RecoverableError -> StateT Pass1 Check (Maybe a)
failure p
p RecoverableError
err = M () -> StateT Pass1 Check (Maybe a)
forall b a. StateT Pass1 Check b -> StateT Pass1 Check (Maybe a)
skip (M () -> StateT Pass1 Check (Maybe a))
-> M () -> StateT Pass1 Check (Maybe a)
forall a b. (a -> b) -> a -> b
$ p -> M () -> M ()
forall (m :: * -> *) p a.
(MonadCheck m, ToPosition' p) =>
p -> m a -> m a
atPosition p
p (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ RecoverableError -> M ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError RecoverableError
err
  panicStr :: String
panicStr = String
"position cannot be Nothing"

  -- Run a computation if definition wasn't dropped.
  may :: M () -> Maybe A.Def -> M (Maybe A.Def)
  may :: M ()
-> Maybe (Def' BNFC'Position)
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
may M ()
m = (Def' BNFC'Position -> StateT Pass1 Check (Def' BNFC'Position))
-> Maybe (Def' BNFC'Position)
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Def' BNFC'Position
-> M () -> StateT Pass1 Check (Def' BNFC'Position)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ M ()
m)

  addListCat :: p
-> Cat' BNFC'Position
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
addListCat p
apos Cat' BNFC'Position
acat  = Position
-> CatKind
-> ICat
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
addCat' (p -> Position
forall p. ToPosition p => p -> Position
toPosition p
apos) CatKind
KList (ICat -> ICat
forall a. Cat' a -> Cat' a
ListCat (ICat -> ICat) -> ICat -> ICat
forall a b. (a -> b) -> a -> b
$ Cat' BNFC'Position -> ICat
parseCat Cat' BNFC'Position
acat)
  addCat :: p
-> CatKind
-> Cat' BNFC'Position
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
addCat p
apos CatKind
kind Cat' BNFC'Position
acat = Position
-> CatKind
-> ICat
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
addCat' (p -> Position
forall p. ToPosition p => p -> Position
toPosition p
apos) CatKind
kind (Cat' BNFC'Position -> ICat
parseCat Cat' BNFC'Position
acat)
  addCat' :: Position
-> CatKind
-> ICat
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
addCat' Position
p CatKind
kind ICat
cat = do
    ICat -> M (Maybe PCatKind)
lookupCat ICat
cat M (Maybe PCatKind)
-> (Maybe PCatKind
    -> StateT Pass1 Check (Maybe (Def' BNFC'Position)))
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe PCatKind
Nothing -> CatKind -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
storeCat CatKind
kind
      Just (WithPosition Position
pold CatKind
old) -> do
        case CatKind -> CatKind -> Either () CatKind
mergeKind CatKind
old CatKind
kind of
          Right CatKind
new -> CatKind -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
storeCat CatKind
new
          Left ()   -> Position
-> RecoverableError
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall p a.
ToPosition' p =>
p -> RecoverableError -> StateT Pass1 Check (Maybe a)
failure Position
p (RecoverableError
 -> StateT Pass1 Check (Maybe (Def' BNFC'Position)))
-> RecoverableError
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall a b. (a -> b) -> a -> b
$ ICat -> Position -> RecoverableError
IncompatibleDefinition ICat
cat Position
pold
    where
    storeCat :: CatKind -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
storeCat CatKind
k = M () -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall b.
StateT Pass1 Check b
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
keep (M () -> StateT Pass1 Check (Maybe (Def' BNFC'Position)))
-> M () -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall a b. (a -> b) -> a -> b
$ ASetter Pass1 Pass1 DefinedICats DefinedICats
-> (DefinedICats -> DefinedICats) -> M ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter Pass1 Pass1 DefinedICats DefinedICats
Lens' Pass1 DefinedICats
stDefinedCats ((DefinedICats -> DefinedICats) -> M ())
-> (DefinedICats -> DefinedICats) -> M ()
forall a b. (a -> b) -> a -> b
$ ICat -> PCatKind -> DefinedICats -> DefinedICats
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ICat
cat (PCatKind -> DefinedICats -> DefinedICats)
-> PCatKind -> DefinedICats -> DefinedICats
forall a b. (a -> b) -> a -> b
$ Position -> CatKind -> PCatKind
forall a. Position -> a -> WithPosition a
WithPosition Position
p CatKind
k

  addCoercions :: p
-> Identifier
-> Integer
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
addCoercions p
p (A.Identifier ((Int, Int)
_, String
x)) Integer
n = do
    case String -> ICat
parseCoerceCat String
x of
      c :: ICat
c@(Cat CatName
y)   -> M () -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall b.
StateT Pass1 Check b
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
keep (M () -> StateT Pass1 Check (Maybe (Def' BNFC'Position)))
-> M () -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall a b. (a -> b) -> a -> b
$ do
        ICat -> M ()
add ICat
c
        (Integer -> M ()) -> [Integer] -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ICat -> M ()
add (ICat -> M ()) -> (Integer -> ICat) -> Integer -> M ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CatName -> Integer -> ICat
forall a. CatName -> Integer -> Cat' a
CoerceCat CatName
y) [Integer
1..Integer
n]
      CoerceCat{} -> p
-> RecoverableError
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall p a.
ToPosition' p =>
p -> RecoverableError -> StateT Pass1 Check (Maybe a)
failure p
p RecoverableError
CoercionsOfCoerceCat
      ListCat{}   -> String -> StateT Pass1 Check (Maybe (Def' BNFC'Position))
forall a. HasCallStack => String -> a
panic String
"parseCoerceCat returned a list category"
    where
    add :: ICat -> M ()
    add :: ICat -> M ()
add = StateT Pass1 Check (Maybe (Def' BNFC'Position)) -> M ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Pass1 Check (Maybe (Def' BNFC'Position)) -> M ())
-> (ICat -> StateT Pass1 Check (Maybe (Def' BNFC'Position)))
-> ICat
-> M ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position
-> CatKind
-> ICat
-> StateT Pass1 Check (Maybe (Def' BNFC'Position))
addCat' (p -> Position
forall p. ToPosition p => p -> Position
toPosition p
p) (RuleKind -> CatKind
ruleKind RuleKind
RCoercion)

  lookupCat :: ICat -> M (Maybe PCatKind)
  lookupCat :: ICat -> M (Maybe PCatKind)
lookupCat ICat
cat = ICat -> DefinedICats -> Maybe PCatKind
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ICat
cat (DefinedICats -> Maybe PCatKind)
-> StateT Pass1 Check DefinedICats -> M (Maybe PCatKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting DefinedICats Pass1 DefinedICats
-> StateT Pass1 Check DefinedICats
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting DefinedICats Pass1 DefinedICats
Lens' Pass1 DefinedICats
stDefinedCats

-- * Collecting categories
---------------------------------------------------------------------------

useCats :: AddCategories a => a -> M ()
useCats :: a -> M ()
useCats a
a = a -> ReaderT Parseable M ()
forall a. AddCategories a => a -> ReaderT Parseable M ()
addCategories a
a ReaderT Parseable M () -> Parseable -> M ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Parseable
Parseable

useCatsInternal :: AddCategories a => a -> M ()
useCatsInternal :: a -> M ()
useCatsInternal a
a = a -> ReaderT Parseable M ()
forall a. AddCategories a => a -> ReaderT Parseable M ()
addCategories a
a ReaderT Parseable M () -> Parseable -> M ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Parseable
Internal

-- | Collect categories used in something.
class AddCategories a where
  addCategories :: a -> ReaderT Parseable M ()

-- | Directly add to '_stUsedCats'.
instance AddCategories (WithPosition ICat) where
  addCategories :: WithPosition ICat -> ReaderT Parseable M ()
addCategories (WithPosition Position
p ICat
c) = do
    Parseable
parseable <- ReaderT Parseable M Parseable
forall r (m :: * -> *). MonadReader r m => m r
ask
    ASetter
  Pass1
  Pass1
  (Map ICat (List1 (WithPosition Parseable)))
  (Map ICat (List1 (WithPosition Parseable)))
-> (Map ICat (List1 (WithPosition Parseable))
    -> Map ICat (List1 (WithPosition Parseable)))
-> ReaderT Parseable M ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter
  Pass1
  Pass1
  (Map ICat (List1 (WithPosition Parseable)))
  (Map ICat (List1 (WithPosition Parseable)))
Lens' Pass1 (Map ICat (List1 (WithPosition Parseable)))
stUsedCats ((Map ICat (List1 (WithPosition Parseable))
  -> Map ICat (List1 (WithPosition Parseable)))
 -> ReaderT Parseable M ())
-> (Map ICat (List1 (WithPosition Parseable))
    -> Map ICat (List1 (WithPosition Parseable)))
-> ReaderT Parseable M ()
forall a b. (a -> b) -> a -> b
$ (List1 (WithPosition Parseable)
 -> List1 (WithPosition Parseable)
 -> List1 (WithPosition Parseable))
-> ICat
-> List1 (WithPosition Parseable)
-> Map ICat (List1 (WithPosition Parseable))
-> Map ICat (List1 (WithPosition Parseable))
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith List1 (WithPosition Parseable)
-> List1 (WithPosition Parseable) -> List1 (WithPosition Parseable)
forall a. Semigroup a => a -> a -> a
(<>) ICat
c (List1 (WithPosition Parseable)
 -> Map ICat (List1 (WithPosition Parseable))
 -> Map ICat (List1 (WithPosition Parseable)))
-> List1 (WithPosition Parseable)
-> Map ICat (List1 (WithPosition Parseable))
-> Map ICat (List1 (WithPosition Parseable))
forall a b. (a -> b) -> a -> b
$ WithPosition Parseable -> List1 (WithPosition Parseable)
forall el coll. Singleton el coll => el -> coll
singleton (WithPosition Parseable -> List1 (WithPosition Parseable))
-> WithPosition Parseable -> List1 (WithPosition Parseable)
forall a b. (a -> b) -> a -> b
$ Position -> Parseable -> WithPosition Parseable
forall a. Position -> a -> WithPosition a
WithPosition (Position -> Position
forall p. ToPosition p => p -> Position
toPosition Position
p) Parseable
parseable

-- | Also adds for each list category its element category, transitively.
instance AddCategories A.Cat where
  addCategories :: Cat' BNFC'Position -> ReaderT Parseable M ()
addCategories Cat' BNFC'Position
c0 =
    case Cat' BNFC'Position
c0 of
      A.ListCat (Just (Int, Int)
p0) Cat' BNFC'Position
c1 -> do
        WithPosition ICat -> ReaderT Parseable M ()
forall a. AddCategories a => a -> ReaderT Parseable M ()
addCategories (WithPosition ICat -> ReaderT Parseable M ())
-> WithPosition ICat -> ReaderT Parseable M ()
forall a b. (a -> b) -> a -> b
$ Position -> ICat -> WithPosition ICat
forall a. Position -> a -> WithPosition a
WithPosition ((Int, Int) -> Position
forall p. ToPosition p => p -> Position
toPosition (Int, Int)
p0) ICat
c
        Cat' BNFC'Position -> ReaderT Parseable M ()
forall a. AddCategories a => a -> ReaderT Parseable M ()
addCategories Cat' BNFC'Position
c1
      A.IdCat   (Just (Int, Int)
p0) Identifier
_  -> do
        WithPosition ICat -> ReaderT Parseable M ()
forall a. AddCategories a => a -> ReaderT Parseable M ()
addCategories (WithPosition ICat -> ReaderT Parseable M ())
-> WithPosition ICat -> ReaderT Parseable M ()
forall a b. (a -> b) -> a -> b
$ Position -> ICat -> WithPosition ICat
forall a. Position -> a -> WithPosition a
WithPosition ((Int, Int) -> Position
forall p. ToPosition p => p -> Position
toPosition (Int, Int)
p0) ICat
c
      A.ListCat BNFC'Position
Nothing Cat' BNFC'Position
_ -> String -> ReaderT Parseable M ()
forall a. HasCallStack => String -> a
panic String
panicStr
      A.IdCat   BNFC'Position
Nothing Identifier
_ -> String -> ReaderT Parseable M ()
forall a. HasCallStack => String -> a
panic String
panicStr
    where
    c :: ICat
c = Cat' BNFC'Position -> ICat
parseCat Cat' BNFC'Position
c0
    panicStr :: String
panicStr = String
"position cannot be Nothing"

instance AddCategories a => AddCategories [a] where
  addCategories :: [a] -> ReaderT Parseable M ()
addCategories = (a -> ReaderT Parseable M ()) -> [a] -> ReaderT Parseable M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> ReaderT Parseable M ()
forall a. AddCategories a => a -> ReaderT Parseable M ()
addCategories

instance AddCategories A.RHS where
  addCategories :: RHS' BNFC'Position -> ReaderT Parseable M ()
addCategories (A.RHS BNFC'Position
_ [Item' BNFC'Position]
rhs) = [Item' BNFC'Position] -> ReaderT Parseable M ()
forall a. AddCategories a => a -> ReaderT Parseable M ()
addCategories [Item' BNFC'Position]
rhs

instance AddCategories A.Item where
  addCategories :: Item' BNFC'Position -> ReaderT Parseable M ()
addCategories = \case
    A.NTerminal BNFC'Position
_ Cat' BNFC'Position
c -> Cat' BNFC'Position -> ReaderT Parseable M ()
forall a. AddCategories a => a -> ReaderT Parseable M ()
addCategories Cat' BNFC'Position
c
    A.Terminal  BNFC'Position
_ String
_ -> () -> ReaderT Parseable M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- * Collecting keywords
---------------------------------------------------------------------------

class AddKeywords a where
  addKeywords :: a -> M ()

instance ToPosition p => AddKeywords (p, String) where
  addKeywords :: (p, String) -> M ()
addKeywords (p
p, String
s) =
    -- Ignore empty keywords.
    Maybe Keyword -> (Keyword -> M ()) -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (String -> Maybe Keyword
parseKeyword String
s) ((Keyword -> M ()) -> M ()) -> (Keyword -> M ()) -> M ()
forall a b. (a -> b) -> a -> b
$ \ Keyword
kw -> do
      ASetter
  Pass1
  Pass1
  (Map Keyword (List1 Position))
  (Map Keyword (List1 Position))
-> (Map Keyword (List1 Position) -> Map Keyword (List1 Position))
-> M ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter
  Pass1
  Pass1
  (Map Keyword (List1 Position))
  (Map Keyword (List1 Position))
Lens' Pass1 (Map Keyword (List1 Position))
stKeywords ((Map Keyword (List1 Position) -> Map Keyword (List1 Position))
 -> M ())
-> (Map Keyword (List1 Position) -> Map Keyword (List1 Position))
-> M ()
forall a b. (a -> b) -> a -> b
$ (List1 Position -> List1 Position -> List1 Position)
-> Keyword
-> List1 Position
-> Map Keyword (List1 Position)
-> Map Keyword (List1 Position)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith List1 Position -> List1 Position -> List1 Position
forall a. Semigroup a => a -> a -> a
(<>) Keyword
kw (List1 Position
 -> Map Keyword (List1 Position) -> Map Keyword (List1 Position))
-> List1 Position
-> Map Keyword (List1 Position)
-> Map Keyword (List1 Position)
forall a b. (a -> b) -> a -> b
$ Position -> List1 Position
forall el coll. Singleton el coll => el -> coll
singleton (Position -> List1 Position) -> Position -> List1 Position
forall a b. (a -> b) -> a -> b
$ p -> Position
forall p. ToPosition p => p -> Position
toPosition p
p

instance AddKeywords a => AddKeywords [a] where
  addKeywords :: [a] -> M ()
addKeywords = (a -> M ()) -> [a] -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> M ()
forall a. AddKeywords a => a -> M ()
addKeywords

instance AddKeywords A.RHS where
  addKeywords :: RHS' BNFC'Position -> M ()
addKeywords (A.RHS BNFC'Position
_ [Item' BNFC'Position]
rhs) = [Item' BNFC'Position] -> M ()
forall a. AddKeywords a => a -> M ()
addKeywords [Item' BNFC'Position]
rhs

instance AddKeywords A.Item where
  addKeywords :: Item' BNFC'Position -> M ()
addKeywords = \case
    A.Terminal (Just (Int, Int)
p) String
s -> ((Int, Int), String) -> M ()
forall a. AddKeywords a => a -> M ()
addKeywords ((Int, Int)
p, String
s)
    A.Terminal BNFC'Position
Nothing  String
_ -> String -> M ()
forall a. HasCallStack => String -> a
panic String
"postion cannot be Nothing"
    A.NTerminal{}  -> () -> M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

ruleKind :: RuleKind -> CatKind
ruleKind :: RuleKind -> CatKind
ruleKind RuleKind
k = List1 RuleKind -> CatKind
KRules (List1 RuleKind -> CatKind) -> List1 RuleKind -> CatKind
forall a b. (a -> b) -> a -> b
$ RuleKind
k RuleKind -> [RuleKind] -> List1 RuleKind
forall a. a -> [a] -> NonEmpty a
:| []

mergeKind :: CatKind -> CatKind -> Either () CatKind
mergeKind :: CatKind -> CatKind -> Either () CatKind
mergeKind = ((CatKind, CatKind) -> Either () CatKind)
-> CatKind -> CatKind -> Either () CatKind
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (((CatKind, CatKind) -> Either () CatKind)
 -> CatKind -> CatKind -> Either () CatKind)
-> ((CatKind, CatKind) -> Either () CatKind)
-> CatKind
-> CatKind
-> Either () CatKind
forall a b. (a -> b) -> a -> b
$ \case
  (KRules List1 RuleKind
rs1, KRules List1 RuleKind
rs2) -> CatKind -> Either () CatKind
forall a b. b -> Either a b
Right (CatKind -> Either () CatKind) -> CatKind -> Either () CatKind
forall a b. (a -> b) -> a -> b
$ List1 RuleKind -> CatKind
KRules (List1 RuleKind -> CatKind) -> List1 RuleKind -> CatKind
forall a b. (a -> b) -> a -> b
$ List1 RuleKind
rs1 List1 RuleKind -> List1 RuleKind -> List1 RuleKind
forall a. Semigroup a => a -> a -> a
<> List1 RuleKind
rs2
  (CatKind, CatKind)
_ -> () -> Either () CatKind
forall a b. a -> Either a b
Left ()

parseCat :: A.Cat -> ICat
parseCat :: Cat' BNFC'Position -> ICat
parseCat = \case
  A.ListCat BNFC'Position
_ Cat' BNFC'Position
c                   -> ICat -> ICat
forall a. Cat' a -> Cat' a
ListCat (ICat -> ICat) -> ICat -> ICat
forall a b. (a -> b) -> a -> b
$ Cat' BNFC'Position -> ICat
parseCat Cat' BNFC'Position
c
  A.IdCat BNFC'Position
_ (A.Identifier ((Int, Int)
_, String
x)) -> String -> ICat
parseCoerceCat String
x

parseCoerceCat :: String -> ICat
parseCoerceCat :: String -> ICat
parseCoerceCat String
x =
  case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
spanEnd Char -> Bool
isDigit String
x of
    (String
_ , []  ) -> String -> ICat
forall a. HasCallStack => String -> a
panic String
"category name starts with a letter"
    ([], Char
c:String
cs) -> CatName -> ICat
forall a. a -> Cat' a
Cat (Char
c Char -> String -> CatName
forall a. a -> [a] -> NonEmpty a
:| String
cs)
    (String
ds, Char
c:String
cs) -> CatName -> Integer -> ICat
forall a. CatName -> Integer -> Cat' a
CoerceCat (Char
c Char -> String -> CatName
forall a. a -> [a] -> NonEmpty a
:| String
cs) (Integer -> ICat) -> Integer -> ICat
forall a b. (a -> b) -> a -> b
$ String -> Integer
forall a. Read a => String -> a
read String
ds

identifierToCat :: A.Identifier -> A.Cat
identifierToCat :: Identifier -> Cat' BNFC'Position
identifierToCat Identifier
x = BNFC'Position -> Identifier -> Cat' BNFC'Position
forall a. a -> Identifier -> Cat' a
A.IdCat (Identifier -> BNFC'Position
forall a. HasPosition a => a -> BNFC'Position
hasPosition Identifier
x) Identifier
x

-- | Resolve category.
parseICat :: ICat -> ReaderT DefinedICats Check Cat
parseICat :: ICat -> ReaderT DefinedICats Check Cat
parseICat = \case
  ListCat ICat
c -> Cat -> Cat
forall a. Cat' a -> Cat' a
ListCat (Cat -> Cat)
-> ReaderT DefinedICats Check Cat -> ReaderT DefinedICats Check Cat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ICat -> ReaderT DefinedICats Check Cat
parseICat ICat
c
  CoerceCat CatName
x Integer
n -> do
    (DefinedICats -> Maybe CatKind)
-> ReaderT DefinedICats Check (Maybe CatKind)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((PCatKind -> CatKind) -> Maybe PCatKind -> Maybe CatKind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PCatKind -> CatKind
forall a. WithPosition a -> a
wpThing (Maybe PCatKind -> Maybe CatKind)
-> (DefinedICats -> Maybe PCatKind)
-> DefinedICats
-> Maybe CatKind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ICat -> DefinedICats -> Maybe PCatKind
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (CatName -> ICat
forall a. a -> Cat' a
Cat CatName
x)) ReaderT DefinedICats Check (Maybe CatKind)
-> (Maybe CatKind -> ReaderT DefinedICats Check ())
-> ReaderT DefinedICats Check ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe CatKind
Nothing       -> do
        case CatName -> Maybe (Either IdentCat BuiltinCat)
parseBuiltinCat CatName
x of
          Maybe (Either IdentCat BuiltinCat)
Nothing        -> RecoverableError -> ReaderT DefinedICats Check ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError (RecoverableError -> ReaderT DefinedICats Check ())
-> RecoverableError -> ReaderT DefinedICats Check ()
forall a b. (a -> b) -> a -> b
$ CatName -> RecoverableError
UnknownCatName CatName
x
          Just (Left  IdentCat
i) -> RecoverableError -> ReaderT DefinedICats Check ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError (RecoverableError -> ReaderT DefinedICats Check ())
-> RecoverableError -> ReaderT DefinedICats Check ()
forall a b. (a -> b) -> a -> b
$ IdentCat -> RecoverableError
CoerceIdentCat IdentCat
i
          Just (Right BuiltinCat
b) -> RecoverableError -> ReaderT DefinedICats Check ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError (RecoverableError -> ReaderT DefinedICats Check ())
-> RecoverableError -> ReaderT DefinedICats Check ()
forall a b. (a -> b) -> a -> b
$ BuiltinCat -> RecoverableError
CoerceBuiltinCat BuiltinCat
b
      Just KToken{} -> RecoverableError -> ReaderT DefinedICats Check ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError (RecoverableError -> ReaderT DefinedICats Check ())
-> RecoverableError -> ReaderT DefinedICats Check ()
forall a b. (a -> b) -> a -> b
$ CatName -> RecoverableError
CoerceTokenCat CatName
x
      Just KList{}  -> RecoverableError -> ReaderT DefinedICats Check ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError (RecoverableError -> ReaderT DefinedICats Check ())
-> RecoverableError -> ReaderT DefinedICats Check ()
forall a b. (a -> b) -> a -> b
$ CatName -> RecoverableError
CoerceListCat CatName
x
      Just KRules{} -> () -> ReaderT DefinedICats Check ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Cat -> ReaderT DefinedICats Check Cat
forall (m :: * -> *) a. Monad m => a -> m a
return (Cat -> ReaderT DefinedICats Check Cat)
-> Cat -> ReaderT DefinedICats Check Cat
forall a b. (a -> b) -> a -> b
$ CatName -> Integer -> Cat
forall a. CatName -> Integer -> Cat' a
CoerceCat CatName
x Integer
n
  c :: ICat
c@(Cat CatName
x) -> BaseCat -> Cat
forall a. a -> Cat' a
Cat (BaseCat -> Cat)
-> ReaderT DefinedICats Check BaseCat
-> ReaderT DefinedICats Check Cat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    (DefinedICats -> Maybe CatKind)
-> ReaderT DefinedICats Check (Maybe CatKind)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((PCatKind -> CatKind) -> Maybe PCatKind -> Maybe CatKind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PCatKind -> CatKind
forall a. WithPosition a -> a
wpThing (Maybe PCatKind -> Maybe CatKind)
-> (DefinedICats -> Maybe PCatKind)
-> DefinedICats
-> Maybe CatKind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ICat -> DefinedICats -> Maybe PCatKind
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ICat
c) ReaderT DefinedICats Check (Maybe CatKind)
-> (Maybe CatKind -> ReaderT DefinedICats Check BaseCat)
-> ReaderT DefinedICats Check BaseCat
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just KRules{} -> BaseCat -> ReaderT DefinedICats Check BaseCat
forall (m :: * -> *) a. Monad m => a -> m a
return (BaseCat -> ReaderT DefinedICats Check BaseCat)
-> BaseCat -> ReaderT DefinedICats Check BaseCat
forall a b. (a -> b) -> a -> b
$ CatName -> BaseCat
BaseCat CatName
x
      Just KToken{} -> BaseCat -> ReaderT DefinedICats Check BaseCat
forall (m :: * -> *) a. Monad m => a -> m a
return (BaseCat -> ReaderT DefinedICats Check BaseCat)
-> BaseCat -> ReaderT DefinedICats Check BaseCat
forall a b. (a -> b) -> a -> b
$ CatName -> BaseCat
TokenCat CatName
x
      Just CatKind
KList    -> String -> ReaderT DefinedICats Check BaseCat
forall a. HasCallStack => String -> a
panic String
"base category cannot have KList kind"
      Maybe CatKind
Nothing       -> do
        case CatName -> Maybe (Either IdentCat BuiltinCat)
parseBuiltinCat CatName
x of
          Just (Left  IdentCat
i) -> BaseCat -> ReaderT DefinedICats Check BaseCat
forall (m :: * -> *) a. Monad m => a -> m a
return (BaseCat -> ReaderT DefinedICats Check BaseCat)
-> BaseCat -> ReaderT DefinedICats Check BaseCat
forall a b. (a -> b) -> a -> b
$ IdentCat -> BaseCat
IdentCat IdentCat
i
          Just (Right BuiltinCat
b) -> BaseCat -> ReaderT DefinedICats Check BaseCat
forall (m :: * -> *) a. Monad m => a -> m a
return (BaseCat -> ReaderT DefinedICats Check BaseCat)
-> BaseCat -> ReaderT DefinedICats Check BaseCat
forall a b. (a -> b) -> a -> b
$ BuiltinCat -> BaseCat
BuiltinCat BuiltinCat
b
          Maybe (Either IdentCat BuiltinCat)
Nothing -> do
            RecoverableError -> ReaderT DefinedICats Check ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError (RecoverableError -> ReaderT DefinedICats Check ())
-> RecoverableError -> ReaderT DefinedICats Check ()
forall a b. (a -> b) -> a -> b
$ CatName -> RecoverableError
UnknownCatName CatName
x
            BaseCat -> ReaderT DefinedICats Check BaseCat
forall (m :: * -> *) a. Monad m => a -> m a
return (BaseCat -> ReaderT DefinedICats Check BaseCat)
-> BaseCat -> ReaderT DefinedICats Check BaseCat
forall a b. (a -> b) -> a -> b
$ CatName -> BaseCat
BaseCat CatName
x  -- fallback


-- * Trash
---------------------------------------------------------------------------

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

type PCatOrigin = WithPosition CatOrigin
data CatOrigin
  = ORule   -- ^ ordinary or 'internal' rule
  | ORules  -- ^ 'rules' pragma
  | OList   -- ^ 'separator' or 'terminator' pragma
  | OToken  -- ^ 'token' definition (exclusive)
  deriving (CatOrigin -> CatOrigin -> Bool
(CatOrigin -> CatOrigin -> Bool)
-> (CatOrigin -> CatOrigin -> Bool) -> Eq CatOrigin
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CatOrigin -> CatOrigin -> Bool
$c/= :: CatOrigin -> CatOrigin -> Bool
== :: CatOrigin -> CatOrigin -> Bool
$c== :: CatOrigin -> CatOrigin -> Bool
Eq, Eq CatOrigin
Eq CatOrigin
-> (CatOrigin -> CatOrigin -> Ordering)
-> (CatOrigin -> CatOrigin -> Bool)
-> (CatOrigin -> CatOrigin -> Bool)
-> (CatOrigin -> CatOrigin -> Bool)
-> (CatOrigin -> CatOrigin -> Bool)
-> (CatOrigin -> CatOrigin -> CatOrigin)
-> (CatOrigin -> CatOrigin -> CatOrigin)
-> Ord CatOrigin
CatOrigin -> CatOrigin -> Bool
CatOrigin -> CatOrigin -> Ordering
CatOrigin -> CatOrigin -> CatOrigin
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 :: CatOrigin -> CatOrigin -> CatOrigin
$cmin :: CatOrigin -> CatOrigin -> CatOrigin
max :: CatOrigin -> CatOrigin -> CatOrigin
$cmax :: CatOrigin -> CatOrigin -> CatOrigin
>= :: CatOrigin -> CatOrigin -> Bool
$c>= :: CatOrigin -> CatOrigin -> Bool
> :: CatOrigin -> CatOrigin -> Bool
$c> :: CatOrigin -> CatOrigin -> Bool
<= :: CatOrigin -> CatOrigin -> Bool
$c<= :: CatOrigin -> CatOrigin -> Bool
< :: CatOrigin -> CatOrigin -> Bool
$c< :: CatOrigin -> CatOrigin -> Bool
compare :: CatOrigin -> CatOrigin -> Ordering
$ccompare :: CatOrigin -> CatOrigin -> Ordering
$cp1Ord :: Eq CatOrigin
Ord, Int -> CatOrigin -> ShowS
[CatOrigin] -> ShowS
CatOrigin -> String
(Int -> CatOrigin -> ShowS)
-> (CatOrigin -> String)
-> ([CatOrigin] -> ShowS)
-> Show CatOrigin
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CatOrigin] -> ShowS
$cshowList :: [CatOrigin] -> ShowS
show :: CatOrigin -> String
$cshow :: CatOrigin -> String
showsPrec :: Int -> CatOrigin -> ShowS
$cshowsPrec :: Int -> CatOrigin -> ShowS
Show)

type PDCatKind = WithPosition (WithDefinition CatKind)


data CatInfo = CatInfo
  { CatInfo -> Parseable
_catParsable :: Parseable
      -- ^ Does this category have at least one parseable rule?
  , CatInfo -> [PCatOrigin]
_catOrigins  :: [PCatOrigin]
      -- ^ Where is this category defined?
      --   For ordinary categories, list of definitions that populate the category.
  } deriving Int -> CatInfo -> ShowS
[CatInfo] -> ShowS
CatInfo -> String
(Int -> CatInfo -> ShowS)
-> (CatInfo -> String) -> ([CatInfo] -> ShowS) -> Show CatInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CatInfo] -> ShowS
$cshowList :: [CatInfo] -> ShowS
show :: CatInfo -> String
$cshow :: CatInfo -> String
showsPrec :: Int -> CatInfo -> ShowS
$cshowsPrec :: Int -> CatInfo -> ShowS
Show

makeLenses ''CatInfo