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

-- | Second pass of processing a LBNF file.
--

module BNFC.Check.Pass2 where

import BNFC.Prelude
import           Data.List        (sort)
import qualified Data.Map         as Map
-- import           Debug.Trace

import qualified BNFC.Utils.List1 as List1

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

import BNFC.Check.Expressions
import BNFC.Check.Monad
import BNFC.Check.Pass1
  ( Pass1(..), stDefinedCats, stUsedCats
  , parseCat, parseCoerceCat
  )
import qualified BNFC.Check.Pass1 as Pass1
import BNFC.Check.Regex

-- | Entry point for pass 2.

checkLBNF :: A.Grammar -> Pass1 -> Check LBNF
checkLBNF :: Grammar -> Pass1 -> Check LBNF
checkLBNF Grammar
grammar pass1 :: Pass1
pass1@Pass1{ DefinedICats
_stDefinedCats :: Pass1 -> DefinedICats
_stDefinedCats :: DefinedICats
_stDefinedCats, Map ICat (List1 (WithPosition Parseable))
_stUsedCats :: Pass1 -> Map ICat (List1 (WithPosition Parseable))
_stUsedCats :: Map ICat (List1 (WithPosition Parseable))
_stUsedCats, Map Keyword (List1 Position)
_stKeywords :: Pass1 -> Map Keyword (List1 Position)
_stKeywords :: Map Keyword (List1 Position)
_stKeywords } =
  Grammar -> M ()
checkGrammar Grammar
grammar M () -> Pass1 -> StateT LBNF Check ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Pass1
pass1 StateT LBNF Check () -> LBNF -> Check LBNF
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
`execStateT` LBNF
st
  where
  st :: LBNF
st = LBNF
initLBNF
    { _lbnfASTBuiltins :: UsedBuiltins
_lbnfASTBuiltins    = [(BuiltinCat, List1 Position)] -> UsedBuiltins
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(BuiltinCat, List1 Position)] -> UsedBuiltins)
-> [(BuiltinCat, List1 Position)] -> UsedBuiltins
forall a b. (a -> b) -> a -> b
$ ((BuiltinCat, List1 (WithPosition Parseable))
 -> (BuiltinCat, List1 Position))
-> [(BuiltinCat, List1 (WithPosition Parseable))]
-> [(BuiltinCat, List1 Position)]
forall a b. (a -> b) -> [a] -> [b]
map ((List1 (WithPosition Parseable) -> List1 Position)
-> (BuiltinCat, List1 (WithPosition Parseable))
-> (BuiltinCat, List1 Position)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((List1 (WithPosition Parseable) -> List1 Position)
 -> (BuiltinCat, List1 (WithPosition Parseable))
 -> (BuiltinCat, List1 Position))
-> (List1 (WithPosition Parseable) -> List1 Position)
-> (BuiltinCat, List1 (WithPosition Parseable))
-> (BuiltinCat, List1 Position)
forall a b. (a -> b) -> a -> b
$ (WithPosition Parseable -> Position)
-> List1 (WithPosition Parseable) -> List1 Position
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WithPosition Parseable -> Position
forall a. WithPosition a -> Position
wpPos) [(BuiltinCat, List1 (WithPosition Parseable))]
usedBuiltins
    , _lbnfParserBuiltins :: UsedBuiltins
_lbnfParserBuiltins = [(BuiltinCat, List1 Position)] -> UsedBuiltins
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(BuiltinCat, List1 Position)] -> UsedBuiltins)
-> [(BuiltinCat, List1 Position)] -> UsedBuiltins
forall a b. (a -> b) -> a -> b
$
         [ (BuiltinCat
b, List1 Position
ps)
         | (BuiltinCat
b, List1 (WithPosition Parseable)
occs) <- [(BuiltinCat, List1 (WithPosition Parseable))]
usedBuiltins
         , List1 Position
ps <- Maybe (List1 Position) -> [List1 Position]
forall a. Maybe a -> [a]
maybeToList (Maybe (List1 Position) -> [List1 Position])
-> Maybe (List1 Position) -> [List1 Position]
forall a b. (a -> b) -> a -> b
$ List1 (WithPosition Parseable) -> Maybe (List1 Position)
filterParseable List1 (WithPosition Parseable)
occs
         ]
    , _lbnfKeywords :: Map Keyword (List1 Position)
_lbnfKeywords        = Map Keyword (List1 Position)
keywords
    , _lbnfSymbols :: SymbolUses
_lbnfSymbols         = (Keyword -> Symbol) -> Map Keyword (List1 Position) -> SymbolUses
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys (List1 Char -> Symbol
Symbol (List1 Char -> Symbol)
-> (Keyword -> List1 Char) -> Keyword -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Keyword -> List1 Char
theKeyword) Map Keyword (List1 Position)
symbols
    , _lbnfSymbolsKeywords :: SymbolsKeywords
_lbnfSymbolsKeywords = SymbolsKeywords
symbolsKeywords
    , _lbnfTokenDefs :: TokenDefs
_lbnfTokenDefs       =
        case Maybe (List1 Position)
identPositions of
          Just List1 Position
ps -> [(List1 Char, WithPosition TokenDef)] -> TokenDefs
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            [(Char
'I'Char -> [Char] -> List1 Char
forall a. a -> [a] -> NonEmpty a
:|[Char]
"dent",
              Position -> TokenDef -> WithPosition TokenDef
forall a. Position -> a -> WithPosition a
WithPosition (List1 Position -> Position
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum List1 Position
ps) (PositionToken -> Regex -> Bool -> TokenDef
TokenDef PositionToken
NoPositionToken Regex
identRegex Bool
True))]
          Maybe (List1 Position)
Nothing -> TokenDefs
forall a. Monoid a => a
mempty
    }
  -- partion keywords and symbols.
  (Map Keyword (List1 Position)
symbols, Map Keyword (List1 Position)
keywords) = (Keyword -> List1 Position -> Bool)
-> Map Keyword (List1 Position)
-> (Map Keyword (List1 Position), Map Keyword (List1 Position))
forall k a. (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partitionWithKey (\Keyword
k List1 Position
_ -> Keyword -> Bool
notIdentifier Keyword
k) Map Keyword (List1 Position)
_stKeywords

  symbolsKeywords :: SymbolsKeywords
symbolsKeywords = [(List1 Char, Int)] -> SymbolsKeywords
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(List1 Char, Int)] -> SymbolsKeywords)
-> [(List1 Char, Int)] -> SymbolsKeywords
forall a b. (a -> b) -> a -> b
$ [List1 Char] -> [Int] -> [(List1 Char, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip
    ( [List1 Char] -> [List1 Char]
forall a. Ord a => [a] -> [a]
sort ([List1 Char] -> [List1 Char]) -> [List1 Char] -> [List1 Char]
forall a b. (a -> b) -> a -> b
$
      (Keyword -> List1 Char
theKeyword (Keyword -> List1 Char) -> [Keyword] -> [List1 Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Keyword (List1 Position) -> [Keyword]
forall k a. Map k a -> [k]
Map.keys Map Keyword (List1 Position)
symbols)
      [List1 Char] -> [List1 Char] -> [List1 Char]
forall a. [a] -> [a] -> [a]
++
      (Keyword -> List1 Char
theKeyword (Keyword -> List1 Char) -> [Keyword] -> [List1 Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Keyword (List1 Position) -> [Keyword]
forall k a. Map k a -> [k]
Map.keys Map Keyword (List1 Position)
keywords)
    )
    [Int
1..]

  notIdentifier :: Keyword -> Bool
  notIdentifier :: Keyword -> Bool
notIdentifier (Keyword List1 Char
k) = [Char] -> Bool
notIdent ([Char] -> Bool) -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ List1 Char -> [Char]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList List1 Char
k
    where
    notIdent :: [Char] -> Bool
notIdent [Char]
s = [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
s Bool -> Bool -> Bool
|| Bool -> Bool
not (Char -> Bool
isAlpha ([Char] -> Char
forall a. [a] -> a
head [Char]
s)) Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isIdentRest) [Char]
s
    isIdentRest :: Char -> Bool
isIdentRest Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''

  identRegex :: Regex
  identRegex :: Regex
identRegex = List2 Regex -> Regex
RSeqs (List2 Regex -> Regex) -> List2 Regex -> Regex
forall a b. (a -> b) -> a -> b
$ Regex -> Regex -> [Regex] -> List2 Regex
forall a. a -> a -> [a] -> List2 a
List2 Regex
letter (Regex -> Regex
RStar Regex
letterDigitSpecial) []
  letter :: Regex
  letter :: Regex
letter = CharClass -> Regex
RChar (CharClass -> Regex) -> CharClass -> Regex
forall a b. (a -> b) -> a -> b
$ CharClassUnion -> CharClass
CC (CharClassUnion -> CharClass) -> CharClassUnion -> CharClass
forall a b. (a -> b) -> a -> b
$ [CharClassAtom] -> CharClassUnion
CAlt [CharClassAtom
CLower, CharClassAtom
CUpper]
  letterDigitSpecial :: Regex
  letterDigitSpecial :: Regex
letterDigitSpecial = CharClass -> Regex
RChar (CharClass -> Regex) -> CharClass -> Regex
forall a b. (a -> b) -> a -> b
$ CharClassUnion -> CharClass
CC (CharClassUnion -> CharClass) -> CharClassUnion -> CharClass
forall a b. (a -> b) -> a -> b
$ [CharClassAtom] -> CharClassUnion
CAlt [ CharClassAtom
CUpper, CharClassAtom
CLower, CharClassAtom
CDigit, Char -> CharClassAtom
CChar Char
'_', Char -> CharClassAtom
CChar Char
'\'' ]

  -- Note: we could add list categories which are used but not defined
  -- with their standard definition @terminator Cat ""@.
  -- See issue: BNFC/bnfc#336.
  -- These should be added before pass2 runs.

  -- Get all builtins mentioned in the grammar that are not overwritten
  -- by definitions.
  usedBuiltins :: [(BuiltinCat, List1 (WithPosition Parseable))]
  usedBuiltins :: [(BuiltinCat, List1 (WithPosition Parseable))]
usedBuiltins =
    [ (BuiltinCat
b, List1 (WithPosition Parseable)
occs)
    | (BuiltinCat
b, List1 Char
bx) <- [(BuiltinCat, List1 Char)]
builtinCats
    , let icat :: ICat
icat = List1 Char -> ICat
forall a. a -> Cat' a
Cat List1 Char
bx
    , ICat -> DefinedICats -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember ICat
icat DefinedICats
_stDefinedCats
        -- b should not be overwritten by a definition
    , List1 (WithPosition Parseable)
occs <- Maybe (List1 (WithPosition Parseable))
-> [List1 (WithPosition Parseable)]
forall a. Maybe a -> [a]
maybeToList (Maybe (List1 (WithPosition Parseable))
 -> [List1 (WithPosition Parseable)])
-> Maybe (List1 (WithPosition Parseable))
-> [List1 (WithPosition Parseable)]
forall a b. (a -> b) -> a -> b
$ ICat
-> Map ICat (List1 (WithPosition Parseable))
-> Maybe (List1 (WithPosition Parseable))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ICat
icat  Map ICat (List1 (WithPosition Parseable))
_stUsedCats
        -- b should be used somewhere
    ]

  -- Positions of the uses of @Ident@ as category.
  identPositions :: Maybe (List1 Position)
  identPositions :: Maybe (List1 Position)
identPositions =
    -- No category or token named "Ident" has been defined.
    if ICat -> DefinedICats -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember ICat
icat DefinedICats
_stDefinedCats
    then case ICat
-> Map ICat (List1 (WithPosition Parseable))
-> Maybe (List1 (WithPosition Parseable))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ICat
icat Map ICat (List1 (WithPosition Parseable))
_stUsedCats of
        Maybe (List1 (WithPosition Parseable))
Nothing -> Maybe (List1 Position)
forall a. Maybe a
Nothing
        Just List1 (WithPosition Parseable)
p  -> List1 Position -> Maybe (List1 Position)
forall a. a -> Maybe a
Just (List1 Position -> Maybe (List1 Position))
-> List1 Position -> Maybe (List1 Position)
forall a b. (a -> b) -> a -> b
$ WithPosition Parseable -> Position
forall a. WithPosition a -> Position
wpPos (WithPosition Parseable -> Position)
-> List1 (WithPosition Parseable) -> List1 Position
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> List1 (WithPosition Parseable)
p
    else Maybe (List1 Position)
forall a. Maybe a
Nothing
    where
      icat :: ICat
icat = List1 Char -> ICat
forall a. a -> Cat' a
Cat (List1 Char -> ICat) -> List1 Char -> ICat
forall a b. (a -> b) -> a -> b
$ Char
'I'Char -> [Char] -> List1 Char
forall a. a -> [a] -> NonEmpty a
:|[Char]
"dent"

-- Keep only the non-@internal@ uses.
filterParseable :: List1 (WithPosition Parseable) -> Maybe (List1 Position)
filterParseable :: List1 (WithPosition Parseable) -> Maybe (List1 Position)
filterParseable = [Position] -> Maybe (List1 Position)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Position] -> Maybe (List1 Position))
-> (List1 (WithPosition Parseable) -> [Position])
-> List1 (WithPosition Parseable)
-> Maybe (List1 Position)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WithPosition Parseable -> Maybe Position)
-> [WithPosition Parseable] -> [Position]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe WithPosition Parseable -> Maybe Position
isParseable ([WithPosition Parseable] -> [Position])
-> (List1 (WithPosition Parseable) -> [WithPosition Parseable])
-> List1 (WithPosition Parseable)
-> [Position]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. List1 (WithPosition Parseable) -> [WithPosition Parseable]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
  where
  isParseable :: WithPosition Parseable -> Maybe Position
isParseable (WithPosition Position
pos Parseable
p) =
    case Parseable
p of
      Parseable
Parseable -> Position -> Maybe Position
forall a. a -> Maybe a
Just Position
pos
      Parseable
Internal  -> Maybe Position
forall a. Maybe a
Nothing

-- | The monad for pass2.

type M = ReaderT Pass1 (StateT LBNF Check)


checkGrammar :: A.Grammar -> M ()
checkGrammar :: Grammar -> M ()
checkGrammar (A.Grammar BNFC'Position
_ [Def' BNFC'Position]
defs) = do
  (Def' BNFC'Position -> M ()) -> [Def' BNFC'Position] -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Def' BNFC'Position -> M ()
checkDef [Def' BNFC'Position]
defs
  M ()
checkEntryPoints

-- | If no entrypoints are given explicitly, take the first non-terminal.
-- If no non-terminal is defined, raise an error
checkEntryPoints :: M ()
checkEntryPoints :: M ()
checkEntryPoints = do
  EntryPoints
eps <- Getting EntryPoints LBNF EntryPoints
-> ReaderT Pass1 (StateT LBNF Check) EntryPoints
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting EntryPoints LBNF EntryPoints
Lens' LBNF EntryPoints
lbnfEntryPoints
  Bool -> M () -> M ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EntryPoints -> Bool
forall k a. Map k a -> Bool
Map.null EntryPoints
eps) (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ do
    ParserRules
rules <- Getting ParserRules LBNF ParserRules
-> ReaderT Pass1 (StateT LBNF Check) ParserRules
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ParserRules LBNF ParserRules
Lens' LBNF ParserRules
lbnfParserRules
    -- traceShowM rules
    if ParserRules -> Bool
forall k a. Map k a -> Bool
Map.null ParserRules
rules then RecoverableError -> M ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError RecoverableError
EmptyGrammar
    else do
      -- Find non-terminal defined first (least Position value of RuleLabel).
      -- ParserRules = Map Cat (Map RHS (WithPosition RuleLabel))
      -- EntryPoints = Map Cat (List1 Position)
      let WithPosition Position
pos Cat
ep = (WithPosition Cat
 -> Cat -> Map RHS (WithPosition RuleLabel) -> WithPosition Cat)
-> WithPosition Cat -> ParserRules -> WithPosition Cat
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey WithPosition Cat
-> Cat -> Map RHS (WithPosition RuleLabel) -> WithPosition Cat
forall rhs label.
WithPosition Cat
-> Cat -> Map rhs (WithPosition label) -> WithPosition Cat
f (Position -> Cat -> WithPosition Cat
forall a. Position -> a -> WithPosition a
WithPosition Position
forall a. Bounded a => a
maxBound Cat
dummyCat) ParserRules
rules
      (EntryPoints -> Identity EntryPoints) -> LBNF -> Identity LBNF
Lens' LBNF EntryPoints
lbnfEntryPoints ((EntryPoints -> Identity EntryPoints) -> LBNF -> Identity LBNF)
-> EntryPoints -> M ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Cat -> List1 Position -> EntryPoints
forall k a. k -> a -> Map k a
Map.singleton Cat
ep (Position -> List1 Position
forall el coll. Singleton el coll => el -> coll
singleton Position
pos)
  where
  f :: WithPosition Cat -> Cat -> Map rhs (WithPosition label) -> WithPosition Cat
  f :: WithPosition Cat
-> Cat -> Map rhs (WithPosition label) -> WithPosition Cat
f WithPosition Cat
x Cat
cat = (WithPosition Cat -> WithPosition label -> WithPosition Cat)
-> WithPosition Cat
-> Map rhs (WithPosition label)
-> WithPosition Cat
forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl (\ WithPosition Cat
y (WithPosition Position
pos label
_) -> WithPosition Cat
y WithPosition Cat -> WithPosition Cat -> WithPosition Cat
forall a. Ord a => a -> a -> a
`min` Position -> Cat -> WithPosition Cat
forall a. Position -> a -> WithPosition a
WithPosition Position
pos Cat
cat) WithPosition Cat
x
  dummyCat :: Cat
dummyCat = BaseCat -> Cat
forall a. a -> Cat' a
Cat (BaseCat -> Cat) -> BaseCat -> Cat
forall a b. (a -> b) -> a -> b
$ List1 Char -> BaseCat
BaseCat (List1 Char -> BaseCat) -> List1 Char -> BaseCat
forall a b. (a -> b) -> a -> b
$ List1 Char
"Internal error in checkEntryPoints: no non-terminals"

checkDef :: A.Def -> M ()
checkDef :: Def' BNFC'Position -> M ()
checkDef Def' BNFC'Position
def =
  case Def' BNFC'Position
def of
    A.Rule       (Just (Int, Int)
p) Label' BNFC'Position
l Cat' BNFC'Position
cat RHS' BNFC'Position
rhs      -> Position
-> Parseable
-> Label' BNFC'Position
-> Cat' BNFC'Position
-> RHS' BNFC'Position
-> M ()
checkRule ((Int, Int) -> Position
forall p. ToPosition p => p -> Position
toPosition (Int, Int)
p) Parseable
Parseable Label' BNFC'Position
l Cat' BNFC'Position
cat RHS' BNFC'Position
rhs
    A.Internal   (Just (Int, Int)
p) Label' BNFC'Position
l Cat' BNFC'Position
cat RHS' BNFC'Position
rhs      -> Position
-> Parseable
-> Label' BNFC'Position
-> Cat' BNFC'Position
-> RHS' BNFC'Position
-> M ()
checkRule ((Int, Int) -> Position
forall p. ToPosition p => p -> Position
toPosition (Int, Int)
p) Parseable
Internal  Label' BNFC'Position
l Cat' BNFC'Position
cat RHS' BNFC'Position
rhs
    A.Token      (Just (Int, Int)
p) Identifier
x Reg' BNFC'Position
re           -> Position
-> Identifier -> PositionToken -> Reg' BNFC'Position -> M ()
addTokenDef ((Int, Int) -> Position
forall p. ToPosition p => p -> Position
toPosition (Int, Int)
p) Identifier
x PositionToken
NoPositionToken Reg' BNFC'Position
re
    A.PosToken   (Just (Int, Int)
p) Identifier
x Reg' BNFC'Position
re           -> Position
-> Identifier -> PositionToken -> Reg' BNFC'Position -> M ()
addTokenDef ((Int, Int) -> Position
forall p. ToPosition p => p -> Position
toPosition (Int, Int)
p) Identifier
x   PositionToken
PositionToken Reg' BNFC'Position
re
    A.Separator  (Just (Int, Int)
p) MinimumSize' BNFC'Position
nonempty Cat' BNFC'Position
cat [Char]
s -> Position
-> MinimumSize' BNFC'Position
-> Cat' BNFC'Position
-> Separator' [Char]
-> M ()
checkList ((Int, Int) -> Position
forall p. ToPosition p => p -> Position
toPosition (Int, Int)
p) MinimumSize' BNFC'Position
nonempty Cat' BNFC'Position
cat ([Char] -> Separator' [Char]
forall a. a -> Separator' a
Separator  [Char]
s)
    A.Terminator (Just (Int, Int)
p) MinimumSize' BNFC'Position
nonempty Cat' BNFC'Position
cat [Char]
s -> Position
-> MinimumSize' BNFC'Position
-> Cat' BNFC'Position
-> Separator' [Char]
-> M ()
checkList ((Int, Int) -> Position
forall p. ToPosition p => p -> Position
toPosition (Int, Int)
p) MinimumSize' BNFC'Position
nonempty Cat' BNFC'Position
cat ([Char] -> Separator' [Char]
forall a. a -> Separator' a
Terminator [Char]
s)
    A.Delimiters (Just (Int, Int)
_) Cat' BNFC'Position
_ [Char]
_ [Char]
_ Separation' BNFC'Position
_ MinimumSize' BNFC'Position
_      -> [Char] -> M ()
forall a. HasCallStack => [Char] -> a
panic [Char]
"Delimiters should have been filtered in Pass1"
    A.Coercions  (Just (Int, Int)
p) Identifier
x Integer
n            -> Position -> Identifier -> Integer -> M ()
checkCoercions ((Int, Int) -> Position
forall p. ToPosition p => p -> Position
toPosition (Int, Int)
p) Identifier
x Integer
n
    A.Rules      (Just (Int, Int)
p) Identifier
x [RHS' BNFC'Position]
rhss         -> Position -> Identifier -> [RHS' BNFC'Position] -> M ()
checkRules ((Int, Int) -> Position
forall p. ToPosition p => p -> Position
toPosition (Int, Int)
p) Identifier
x [RHS' BNFC'Position]
rhss

    A.Entryp     (Just (Int, Int)
_) [Cat' BNFC'Position]
cats           -> (Cat' BNFC'Position -> M ()) -> [Cat' BNFC'Position] -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (WithPosition Cat -> M ()
forall (m :: * -> *). MonadState LBNF m => WithPosition Cat -> m ()
addEntryPoint (WithPosition Cat -> M ())
-> (Cat' BNFC'Position
    -> ReaderT Pass1 (StateT LBNF Check) (WithPosition Cat))
-> Cat' BNFC'Position
-> M ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Cat' BNFC'Position
-> ReaderT Pass1 (StateT LBNF Check) (WithPosition Cat)
checkCat) [Cat' BNFC'Position]
cats
      where
      addEntryPoint :: WithPosition Cat -> m ()
addEntryPoint (WithPosition Position
p Cat
c) = ((EntryPoints -> Identity EntryPoints) -> LBNF -> Identity LBNF)
-> (EntryPoints -> EntryPoints) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying (EntryPoints -> Identity EntryPoints) -> LBNF -> Identity LBNF
Lens' LBNF EntryPoints
lbnfEntryPoints ((EntryPoints -> EntryPoints) -> m ())
-> (EntryPoints -> EntryPoints) -> m ()
forall a b. (a -> b) -> a -> b
$ (List1 Position -> List1 Position -> List1 Position)
-> Cat -> List1 Position -> EntryPoints -> EntryPoints
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
(<>) Cat
c (List1 Position -> EntryPoints -> EntryPoints)
-> List1 Position -> EntryPoints -> EntryPoints
forall a b. (a -> b) -> a -> b
$ Position -> List1 Position
forall el coll. Singleton el coll => el -> coll
singleton Position
p

    A.Function   (Just (Int, Int)
p) Identifier
x [Arg' BNFC'Position]
args Exp' BNFC'Position
exp     -> Position
-> Identifier -> [Arg' BNFC'Position] -> Exp' BNFC'Position -> M ()
checkDefine ((Int, Int) -> Position
forall p. ToPosition p => p -> Position
toPosition (Int, Int)
p) Identifier
x [Arg' BNFC'Position]
args Exp' BNFC'Position
exp

    -- Lexer stuff:
    A.Comment  (Just (Int, Int)
p) [Char]
s     -> Position -> [Char] -> M ()
addLineComment  ((Int, Int) -> Position
forall p. ToPosition p => p -> Position
toPosition (Int, Int)
p) [Char]
s
    A.Comments (Just (Int, Int)
p) [Char]
s1 [Char]
s2 -> Position -> [Char] -> [Char] -> M ()
addBlockComment ((Int, Int) -> Position
forall p. ToPosition p => p -> Position
toPosition (Int, Int)
p) [Char]
s1 [Char]
s2

    A.Layout     (Just (Int, Int)
p) [[Char]]
ss -> ([Char] -> M ()) -> [[Char]] -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Lens' LBNF LayoutKeywords
-> Lens' LBNF LayoutKeywords -> Position -> [Char] -> M ()
addLayoutKeyword Lens' LBNF LayoutKeywords
lbnfLayoutStart Lens' LBNF LayoutKeywords
lbnfLayoutStop (Position -> [Char] -> M ()) -> Position -> [Char] -> M ()
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Position
forall p. ToPosition p => p -> Position
toPosition (Int, Int)
p) [[Char]]
ss
    A.LayoutStop (Just (Int, Int)
p) [[Char]]
ss -> ([Char] -> M ()) -> [[Char]] -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Lens' LBNF LayoutKeywords
-> Lens' LBNF LayoutKeywords -> Position -> [Char] -> M ()
addLayoutKeyword Lens' LBNF LayoutKeywords
lbnfLayoutStop Lens' LBNF LayoutKeywords
lbnfLayoutStart (Position -> [Char] -> M ()) -> Position -> [Char] -> M ()
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Position
forall p. ToPosition p => p -> Position
toPosition (Int, Int)
p) [[Char]]
ss
    A.LayoutTop  (Just (Int, Int)
p)    -> Getting (Maybe Position) LBNF (Maybe Position)
-> ReaderT Pass1 (StateT LBNF Check) (Maybe Position)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Maybe Position) LBNF (Maybe Position)
Lens' LBNF (Maybe Position)
lbnfLayoutTop ReaderT Pass1 (StateT LBNF Check) (Maybe Position)
-> (Maybe Position -> M ()) -> M ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe Position
Nothing  -> ASetter LBNF LBNF (Maybe Position) (Maybe Position)
-> Maybe Position -> M ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ASetter LBNF LBNF (Maybe Position) (Maybe Position)
Lens' LBNF (Maybe Position)
lbnfLayoutTop (Maybe Position -> M ()) -> Maybe Position -> M ()
forall a b. (a -> b) -> a -> b
$ Position -> Maybe Position
forall a. a -> Maybe a
Just (Position -> Maybe Position) -> Position -> Maybe Position
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Position
forall p. ToPosition p => p -> Position
toPosition (Int, Int)
p
      Just Position
old -> (Int, Int) -> M () -> M ()
forall (m :: * -> *) p a.
(MonadCheck m, ToPosition' p) =>
p -> m a -> m a
atPosition (Int, Int)
p (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ Warning -> M ()
forall (m :: * -> *). MonadCheck m => Warning -> m ()
warn (Warning -> M ()) -> Warning -> M ()
forall a b. (a -> b) -> a -> b
$ Position -> Warning
DuplicateLayoutTop Position
old

    Def' BNFC'Position
_ -> M ()
forall a. HasCallStack => a
panicPositionNothing

parseICat :: ICat -> M Cat
parseICat :: ICat -> M Cat
parseICat ICat
cat = (Pass1 -> StateT LBNF Check Cat) -> M Cat
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((Pass1 -> StateT LBNF Check Cat) -> M Cat)
-> (Pass1 -> StateT LBNF Check Cat) -> M Cat
forall a b. (a -> b) -> a -> b
$ \ Pass1{ DefinedICats
_stDefinedCats :: DefinedICats
_stDefinedCats :: Pass1 -> DefinedICats
_stDefinedCats } -> do
  Check Cat -> StateT LBNF Check Cat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Check Cat -> StateT LBNF Check Cat)
-> Check Cat -> StateT LBNF Check Cat
forall a b. (a -> b) -> a -> b
$ ICat -> ReaderT DefinedICats Check Cat
Pass1.parseICat ICat
cat ReaderT DefinedICats Check Cat -> DefinedICats -> Check Cat
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` DefinedICats
_stDefinedCats

-- | Check that a category is defined and convert it into internal representation
checkCat :: A.Cat -> M (WithPosition Cat)
checkCat :: Cat' BNFC'Position
-> ReaderT Pass1 (StateT LBNF Check) (WithPosition Cat)
checkCat Cat' BNFC'Position
c = Position
-> ReaderT Pass1 (StateT LBNF Check) (WithPosition Cat)
-> ReaderT Pass1 (StateT LBNF Check) (WithPosition Cat)
forall (m :: * -> *) p a.
(MonadCheck m, ToPosition' p) =>
p -> m a -> m a
atPosition Position
p (ReaderT Pass1 (StateT LBNF Check) (WithPosition Cat)
 -> ReaderT Pass1 (StateT LBNF Check) (WithPosition Cat))
-> ReaderT Pass1 (StateT LBNF Check) (WithPosition Cat)
-> ReaderT Pass1 (StateT LBNF Check) (WithPosition Cat)
forall a b. (a -> b) -> a -> b
$ Position -> Cat -> WithPosition Cat
forall a. Position -> a -> WithPosition a
WithPosition Position
p (Cat -> WithPosition Cat)
-> M Cat -> ReaderT Pass1 (StateT LBNF Check) (WithPosition Cat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
  ICat -> M Cat
parseICat (ICat -> M Cat) -> ICat -> M Cat
forall a b. (a -> b) -> a -> b
$ Cat' BNFC'Position -> ICat
parseCat Cat' BNFC'Position
c
  where
  p :: Position
p = Position -> ((Int, Int) -> Position) -> BNFC'Position -> Position
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Position
forall a. HasCallStack => a
panicPositionNothing (Int, Int) -> Position
forall p. ToPosition p => p -> Position
toPosition (BNFC'Position -> Position) -> BNFC'Position -> Position
forall a b. (a -> b) -> a -> b
$ Cat' BNFC'Position -> BNFC'Position
forall a. HasPosition a => a -> BNFC'Position
hasPosition Cat' BNFC'Position
c

-- | Convert a LBNF label into internal representation.

parseLabel :: A.Label -> WithPosition Label
parseLabel :: Label' BNFC'Position -> WithPosition Label
parseLabel Label' BNFC'Position
l0 = case Label' BNFC'Position
l0 of
  A.Id BNFC'Position
_ (A.Identifier ((Int, Int)
_, [Char]
x)) -> Position -> Label -> WithPosition Label
forall a. Position -> a -> WithPosition a
WithPosition Position
p (Label -> WithPosition Label) -> Label -> WithPosition Label
forall a b. (a -> b) -> a -> b
$
    List1 Char -> Label
labelFromIdentifier (List1 Char -> Label) -> List1 Char -> Label
forall a b. (a -> b) -> a -> b
$ List1 Char -> Maybe (List1 Char) -> List1 Char
forall a. a -> Maybe a -> a
fromMaybe List1 Char
forall a. HasCallStack => a
panicEmptyIdentifier (Maybe (List1 Char) -> List1 Char)
-> Maybe (List1 Char) -> List1 Char
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe (List1 Char)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Char]
x
  A.Wild      BNFC'Position
_ -> Position -> Label -> WithPosition Label
forall a. Position -> a -> WithPosition a
WithPosition Position
p Label
LWild
  A.ListEmpty BNFC'Position
_ -> Position -> Label -> WithPosition Label
forall a. Position -> a -> WithPosition a
WithPosition Position
p Label
LNil
  A.ListCons  BNFC'Position
_ -> Position -> Label -> WithPosition Label
forall a. Position -> a -> WithPosition a
WithPosition Position
p Label
LCons
  A.ListOne   BNFC'Position
_ -> Position -> Label -> WithPosition Label
forall a. Position -> a -> WithPosition a
WithPosition Position
p Label
LSg
  where
  p :: Position
p = Position -> ((Int, Int) -> Position) -> BNFC'Position -> Position
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Position
forall a. HasCallStack => a
panicPositionNothing (Int, Int) -> Position
forall p. ToPosition p => p -> Position
toPosition (BNFC'Position -> Position) -> BNFC'Position -> Position
forall a b. (a -> b) -> a -> b
$ Label' BNFC'Position -> BNFC'Position
forall a. HasPosition a => a -> BNFC'Position
hasPosition Label' BNFC'Position
l0

-- | Convert an LBNF item (terminal or non-terminal) to internal representation.

checkItem :: A.Item -> M (Maybe (WithPosition AItem))
checkItem :: Item -> M (Maybe (WithPosition AItem))
checkItem = \case
  -- Empty keywords are immediately dropped:
  A.Terminal BNFC'Position
_ []     -> Maybe (WithPosition AItem) -> M (Maybe (WithPosition AItem))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (WithPosition AItem)
forall a. Maybe a
Nothing
  A.Terminal BNFC'Position
p0 (Char
c:[Char]
s) -> Maybe (WithPosition AItem) -> M (Maybe (WithPosition AItem))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (WithPosition AItem) -> M (Maybe (WithPosition AItem)))
-> (List1 Char -> Maybe (WithPosition AItem))
-> List1 Char
-> M (Maybe (WithPosition AItem))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithPosition AItem -> Maybe (WithPosition AItem)
forall a. a -> Maybe a
Just (WithPosition AItem -> Maybe (WithPosition AItem))
-> (List1 Char -> WithPosition AItem)
-> List1 Char
-> Maybe (WithPosition AItem)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> AItem -> WithPosition AItem
forall a. Position -> a -> WithPosition a
WithPosition Position
p (AItem -> WithPosition AItem)
-> (List1 Char -> AItem) -> List1 Char -> WithPosition AItem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. List1 Char -> AItem
forall a. a -> Item' a
Terminal (List1 Char -> M (Maybe (WithPosition AItem)))
-> List1 Char -> M (Maybe (WithPosition AItem))
forall a b. (a -> b) -> a -> b
$ Char
c Char -> [Char] -> List1 Char
forall a. a -> [a] -> NonEmpty a
:| [Char]
s
    where p :: Position
p = Position -> ((Int, Int) -> Position) -> BNFC'Position -> Position
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Position
forall a. HasCallStack => a
panicPositionNothing (Int, Int) -> Position
forall p. ToPosition p => p -> Position
toPosition BNFC'Position
p0
  A.NTerminal BNFC'Position
_ Cat' BNFC'Position
cat -> WithPosition AItem -> Maybe (WithPosition AItem)
forall a. a -> Maybe a
Just (WithPosition AItem -> Maybe (WithPosition AItem))
-> (WithPosition Cat -> WithPosition AItem)
-> WithPosition Cat
-> Maybe (WithPosition AItem)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cat -> AItem) -> WithPosition Cat -> WithPosition AItem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cat -> AItem
forall a. Cat -> Item' a
NTerminal (WithPosition Cat -> Maybe (WithPosition AItem))
-> ReaderT Pass1 (StateT LBNF Check) (WithPosition Cat)
-> M (Maybe (WithPosition AItem))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cat' BNFC'Position
-> ReaderT Pass1 (StateT LBNF Check) (WithPosition Cat)
checkCat Cat' BNFC'Position
cat

-- | Check that
--   (1) ordinary labels define ordinary types (not list types),
--   (2) coercions are have identity type, and
--   (3) list constructors have their respective types.
--
checkLabel :: WithPosition Label -> FunType -> M ()
checkLabel :: WithPosition Label -> FunType -> M ()
checkLabel (WithPosition Position
p Label
l) ft :: FunType
ft@(FunType Type
t [Type]
ts) = Position -> M () -> M ()
forall (m :: * -> *) p a.
(MonadCheck m, ToPosition' p) =>
p -> m a -> m a
atPosition Position
p (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ do
  case Label
l of
    LId  List1 Char
f -> List1 Char -> M () -> M ()
forall (m :: * -> *). MonadCheck m => List1 Char -> m () -> m ()
notListType List1 Char
f (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ List1 Char -> WithPosition FunType -> M ()
addSig List1 Char
f (WithPosition FunType -> M ()) -> WithPosition FunType -> M ()
forall a b. (a -> b) -> a -> b
$ Position -> FunType -> WithPosition FunType
forall a. Position -> a -> WithPosition a
WithPosition Position
p FunType
ft
    LDef List1 Char
f -> List1 Char -> M () -> M ()
forall (m :: * -> *). MonadCheck m => List1 Char -> m () -> m ()
notListType List1 Char
f (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ List1 Char -> WithPosition FunType -> M ()
addSig List1 Char
f (WithPosition FunType -> M ()) -> WithPosition FunType -> M ()
forall a b. (a -> b) -> a -> b
$ Position -> FunType -> WithPosition FunType
forall a. Position -> a -> WithPosition a
WithPosition Position
p FunType
ft
    Label
LWild  -> Bool -> M () -> M ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Type]
ts [Type] -> [Type] -> Bool
forall a. Eq a => a -> a -> Bool
== [Type
t]) (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ RecoverableError -> M ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError (RecoverableError -> M ()) -> RecoverableError -> M ()
forall a b. (a -> b) -> a -> b
$ FunType -> RecoverableError
InvalidLabelWild FunType
ft
    Label
LNil   -> (Type -> M ()) -> M ()
forall (m :: * -> *). MonadCheck m => (Type -> m ()) -> m ()
elemType ((Type -> M ()) -> M ()) -> (Type -> M ()) -> M ()
forall a b. (a -> b) -> a -> b
$ \ Type
_ -> Bool -> M () -> M ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Type]
ts [Type] -> [Type] -> Bool
forall a. Eq a => a -> a -> Bool
== [])    (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ RecoverableError -> M ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError (RecoverableError -> M ()) -> RecoverableError -> M ()
forall a b. (a -> b) -> a -> b
$ FunType -> RecoverableError
InvalidLabelNil  FunType
ft
    Label
LCons  -> (Type -> M ()) -> M ()
forall (m :: * -> *). MonadCheck m => (Type -> m ()) -> m ()
elemType ((Type -> M ()) -> M ()) -> (Type -> M ()) -> M ()
forall a b. (a -> b) -> a -> b
$ \ Type
s -> Bool -> M () -> M ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Type]
ts [Type] -> [Type] -> Bool
forall a. Eq a => a -> a -> Bool
== [Type
s,Type
t]) (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ RecoverableError -> M ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError (RecoverableError -> M ()) -> RecoverableError -> M ()
forall a b. (a -> b) -> a -> b
$ FunType -> RecoverableError
InvalidLabelCons FunType
ft
    Label
LSg    -> (Type -> M ()) -> M ()
forall (m :: * -> *). MonadCheck m => (Type -> m ()) -> m ()
elemType ((Type -> M ()) -> M ()) -> (Type -> M ()) -> M ()
forall a b. (a -> b) -> a -> b
$ \ Type
s -> Bool -> M () -> M ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Type]
ts [Type] -> [Type] -> Bool
forall a. Eq a => a -> a -> Bool
== [Type
s])   (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ RecoverableError -> M ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError (RecoverableError -> M ()) -> RecoverableError -> M ()
forall a b. (a -> b) -> a -> b
$ FunType -> RecoverableError
InvalidLabelSg   FunType
ft
  where
  elemType :: (Type -> m ()) -> m ()
elemType Type -> m ()
k =
    case Type
t of
      ListType Type
s -> Type -> m ()
k Type
s
      BaseType{} -> RecoverableError -> m ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError (RecoverableError -> m ()) -> RecoverableError -> m ()
forall a b. (a -> b) -> a -> b
$ Type -> RecoverableError
InvalidListLabel Type
t
  notListType :: List1 Char -> m () -> m ()
notListType List1 Char
f m ()
k =
    case Type
t of
      ListType{} -> RecoverableError -> m ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError (RecoverableError -> m ()) -> RecoverableError -> m ()
forall a b. (a -> b) -> a -> b
$ List1 Char -> RecoverableError
InvalidListRule List1 Char
f
      BaseType{} -> m ()
k

-- | Check list rules for uniform indexing.
--   This flags rules like @(:).  [Exp] ::= Exp1 [Exp]@.
--   Such rules make sense in the abstract syntax and the parser,
--   but may lead to non-faithful printers.

checkListLabelForUniformity
  :: WithPosition Label  -- ^ Possibly a list label.
  -> Cat                 -- ^ Lhs cat.
  -> [Cat]               -- ^ Rhs cats.
  -> M ()
checkListLabelForUniformity :: WithPosition Label -> Cat -> [Cat] -> M ()
checkListLabelForUniformity (WithPosition Position
p Label
l) Cat
c [Cat]
cs = Position -> M () -> M ()
forall (m :: * -> *) p a.
(MonadCheck m, ToPosition' p) =>
p -> m a -> m a
atPosition Position
p (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ do
  case Label
l of
    Label
LCons  -> M () -> M ()
forall a. a -> a
tr (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ (Cat -> M ()) -> M ()
forall (m :: * -> *). Monad m => (Cat -> m ()) -> m ()
elemCat ((Cat -> M ()) -> M ()) -> (Cat -> M ()) -> M ()
forall a b. (a -> b) -> a -> b
$ \ Cat
b -> Bool -> M () -> M ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Cat]
cs [Cat] -> [Cat] -> Bool
forall a. Eq a => a -> a -> Bool
== [Cat
b,Cat
c]) M ()
warning
    Label
LSg    -> M () -> M ()
forall a. a -> a
tr (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ (Cat -> M ()) -> M ()
forall (m :: * -> *). Monad m => (Cat -> m ()) -> m ()
elemCat ((Cat -> M ()) -> M ()) -> (Cat -> M ()) -> M ()
forall a b. (a -> b) -> a -> b
$ \ Cat
b -> Bool -> M () -> M ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Cat]
cs [Cat] -> [Cat] -> Bool
forall a. Eq a => a -> a -> Bool
== [Cat
b])   M ()
warning
    Label
_      -> () -> M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
  tr :: a -> a
tr = a -> a
forall a. a -> a
id
  -- tr = trace (unwords [ "checkListLabelForUniformity", show l, ":", show c, "<-", show cs ])
  warning :: M ()
warning   = Warning -> M ()
forall (m :: * -> *). MonadCheck m => Warning -> m ()
warn (Warning -> M ()) -> Warning -> M ()
forall a b. (a -> b) -> a -> b
$ Cat -> [Cat] -> Warning
NonUniformListRule Cat
c [Cat]
cs
  elemCat :: (Cat -> m ()) -> m ()
elemCat Cat -> m ()
k =
    case Cat
c of
      ListCat Cat
b   -> Cat -> m ()
k Cat
b
      CoerceCat{} -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- Error already reported in checkLabel.
      Cat{}       -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- Error already reported in checkLabel.



-- | Add label to signature, if it does not exist there yet.
--   Otherwise, throw error.

addSig :: LabelName -> WithPosition FunType -> M ()
addSig :: List1 Char -> WithPosition FunType -> M ()
addSig List1 Char
f WithPosition FunType
t = do
  (List1 Char
-> Map (List1 Char) (WithPosition FunType)
-> Maybe (WithPosition FunType)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup List1 Char
f (Map (List1 Char) (WithPosition FunType)
 -> Maybe (WithPosition FunType))
-> ReaderT
     Pass1 (StateT LBNF Check) (Map (List1 Char) (WithPosition FunType))
-> ReaderT Pass1 (StateT LBNF Check) (Maybe (WithPosition FunType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (Map (List1 Char) (WithPosition FunType))
  LBNF
  (Map (List1 Char) (WithPosition FunType))
-> ReaderT
     Pass1 (StateT LBNF Check) (Map (List1 Char) (WithPosition FunType))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (Map (List1 Char) (WithPosition FunType))
  LBNF
  (Map (List1 Char) (WithPosition FunType))
Lens' LBNF (Map (List1 Char) (WithPosition FunType))
lbnfSignature) ReaderT Pass1 (StateT LBNF Check) (Maybe (WithPosition FunType))
-> (Maybe (WithPosition FunType) -> M ()) -> M ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case

    -- If not present yet, add to signature.
    Maybe (WithPosition FunType)
Nothing -> ASetter
  LBNF
  LBNF
  (Map (List1 Char) (WithPosition FunType))
  (Map (List1 Char) (WithPosition FunType))
-> (Map (List1 Char) (WithPosition FunType)
    -> Map (List1 Char) (WithPosition FunType))
-> M ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter
  LBNF
  LBNF
  (Map (List1 Char) (WithPosition FunType))
  (Map (List1 Char) (WithPosition FunType))
Lens' LBNF (Map (List1 Char) (WithPosition FunType))
lbnfSignature ((Map (List1 Char) (WithPosition FunType)
  -> Map (List1 Char) (WithPosition FunType))
 -> M ())
-> (Map (List1 Char) (WithPosition FunType)
    -> Map (List1 Char) (WithPosition FunType))
-> M ()
forall a b. (a -> b) -> a -> b
$ List1 Char
-> WithPosition FunType
-> Map (List1 Char) (WithPosition FunType)
-> Map (List1 Char) (WithPosition FunType)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert List1 Char
f WithPosition FunType
t

    -- Otherwise complain about duplicate definition
    Just (WithPosition Position
p FunType
_) -> RecoverableError -> M ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError (RecoverableError -> M ()) -> RecoverableError -> M ()
forall a b. (a -> b) -> a -> b
$ List1 Char -> Position -> RecoverableError
DuplicateLabel List1 Char
f Position
p

checkRHS :: A.RHS -> M ARHS
checkRHS :: RHS' BNFC'Position -> M ARHS
checkRHS (A.RHS BNFC'Position
_ [Item]
items0) = (WithPosition AItem -> AItem) -> [WithPosition AItem] -> ARHS
forall a b. (a -> b) -> [a] -> [b]
map WithPosition AItem -> AItem
forall a. WithPosition a -> a
wpThing ([WithPosition AItem] -> ARHS)
-> ([Maybe (WithPosition AItem)] -> [WithPosition AItem])
-> [Maybe (WithPosition AItem)]
-> ARHS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (WithPosition AItem)] -> [WithPosition AItem]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (WithPosition AItem)] -> ARHS)
-> ReaderT Pass1 (StateT LBNF Check) [Maybe (WithPosition AItem)]
-> M ARHS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Item -> M (Maybe (WithPosition AItem)))
-> [Item]
-> ReaderT Pass1 (StateT LBNF Check) [Maybe (WithPosition AItem)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Item -> M (Maybe (WithPosition AItem))
checkItem [Item]
items0

trimRHS :: ARHS -> RHS
trimRHS :: ARHS -> RHS
trimRHS = (AItem -> Maybe (Item' Keyword)) -> ARHS -> RHS
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((AItem -> Maybe (Item' Keyword)) -> ARHS -> RHS)
-> (AItem -> Maybe (Item' Keyword)) -> ARHS -> RHS
forall a b. (a -> b) -> a -> b
$ (List1 Char -> Maybe Keyword) -> AItem -> Maybe (Item' Keyword)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((List1 Char -> Maybe Keyword) -> AItem -> Maybe (Item' Keyword))
-> (List1 Char -> Maybe Keyword) -> AItem -> Maybe (Item' Keyword)
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe Keyword
parseKeyword ([Char] -> Maybe Keyword)
-> (List1 Char -> [Char]) -> List1 Char -> Maybe Keyword
forall b c a. (b -> c) -> (a -> b) -> a -> c
. List1 Char -> [Char]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

-- | Check a LBNF rule and convert it into internal form.

checkRule :: Position -> Parseable -> A.Label -> A.Cat -> A.RHS -> M ()
checkRule :: Position
-> Parseable
-> Label' BNFC'Position
-> Cat' BNFC'Position
-> RHS' BNFC'Position
-> M ()
checkRule Position
p Parseable
parseable Label' BNFC'Position
l0 Cat' BNFC'Position
cat0 RHS' BNFC'Position
rhs0 = do

  -- Convert rule to internal format.
  let l :: WithPosition Label
l = Label' BNFC'Position -> WithPosition Label
parseLabel Label' BNFC'Position
l0
  WithPosition Position
_ Cat
cat <- Cat' BNFC'Position
-> ReaderT Pass1 (StateT LBNF Check) (WithPosition Cat)
checkCat Cat' BNFC'Position
cat0
  ARHS
items <- RHS' BNFC'Position -> M ARHS
checkRHS RHS' BNFC'Position
rhs0

  -- Check (list, wild) or store (constructor, definition) type.
  let cs :: [Cat]
cs = ARHS -> [Cat]
forall a. RHS' a -> [Cat]
rhsCats ARHS
items
  let ty :: FunType
ty = Type -> [Type] -> FunType
FunType (Cat -> Type
catToType Cat
cat) ([Type] -> FunType) -> [Type] -> FunType
forall a b. (a -> b) -> a -> b
$ (Cat -> Type) -> [Cat] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> Type
catToType [Cat]
cs
  WithPosition Label -> FunType -> M ()
checkLabel WithPosition Label
l FunType
ty
  WithPosition Label -> Cat -> [Cat] -> M ()
checkListLabelForUniformity WithPosition Label
l Cat
cat [Cat]
cs

  -- Add grammar rule with origin.
  Position -> RuleOrigin -> Parseable -> Cat -> Label -> ARHS -> M ()
addRule Position
p RuleOrigin
FromOrdinary Parseable
parseable  Cat
cat (WithPosition Label -> Label
forall a. WithPosition a -> a
wpThing WithPosition Label
l) ARHS
items

-- | Add a well-typed rule to 'lnbfASTRules', 'lbnfASTRulesAP'
--   and, if it is 'Parseable', to 'lbnfParserRules'.

addRule :: Position -> RuleOrigin -> Parseable -> Cat -> Label -> ARHS -> M ()
addRule :: Position -> RuleOrigin -> Parseable -> Cat -> Label -> ARHS -> M ()
addRule Position
p RuleOrigin
origin Parseable
parseable Cat
cat Label
l ARHS
items = Position -> M () -> M ()
forall (m :: * -> *) p a.
(MonadCheck m, ToPosition' p) =>
p -> m a -> m a
atPosition Position
p (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ do

  -- Warn if label clashes with category.  (Error in e.g. Java backend.)
  case Label
l of
    LId List1 Char
x -> do
      (ICat -> DefinedICats -> Maybe PCatKind
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (List1 Char -> ICat
forall a. a -> Cat' a
Cat List1 Char
x) (DefinedICats -> Maybe PCatKind)
-> ReaderT Pass1 (StateT LBNF Check) DefinedICats
-> ReaderT Pass1 (StateT LBNF Check) (Maybe PCatKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting DefinedICats Pass1 DefinedICats
-> ReaderT Pass1 (StateT LBNF Check) DefinedICats
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting DefinedICats Pass1 DefinedICats
Lens' Pass1 DefinedICats
stDefinedCats) ReaderT Pass1 (StateT LBNF Check) (Maybe PCatKind)
-> (Maybe PCatKind -> M ()) -> M ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just (WithPosition Position
p1 CatKind
_) -> Warning -> M ()
forall (m :: * -> *). MonadCheck m => Warning -> m ()
warn (Warning -> M ()) -> Warning -> M ()
forall a b. (a -> b) -> a -> b
$ List1 Char -> Position -> Warning
LabelClashesWithCategory List1 Char
x Position
p1
        Maybe PCatKind
Nothing -> do
          (ICat
-> Map ICat (List1 (WithPosition Parseable))
-> Maybe (List1 (WithPosition Parseable))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (List1 Char -> ICat
forall a. a -> Cat' a
Cat List1 Char
x) (Map ICat (List1 (WithPosition Parseable))
 -> Maybe (List1 (WithPosition Parseable)))
-> ReaderT
     Pass1
     (StateT LBNF Check)
     (Map ICat (List1 (WithPosition Parseable)))
-> ReaderT
     Pass1 (StateT LBNF Check) (Maybe (List1 (WithPosition Parseable)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (Map ICat (List1 (WithPosition Parseable)))
  Pass1
  (Map ICat (List1 (WithPosition Parseable)))
-> ReaderT
     Pass1
     (StateT LBNF Check)
     (Map ICat (List1 (WithPosition Parseable)))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Map ICat (List1 (WithPosition Parseable)))
  Pass1
  (Map ICat (List1 (WithPosition Parseable)))
Lens' Pass1 (Map ICat (List1 (WithPosition Parseable)))
stUsedCats) ReaderT
  Pass1 (StateT LBNF Check) (Maybe (List1 (WithPosition Parseable)))
-> (Maybe (List1 (WithPosition Parseable)) -> M ()) -> M ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just (WithPosition Position
p2 Parseable
_ :| [WithPosition Parseable]
_) -> Warning -> M ()
forall (m :: * -> *). MonadCheck m => Warning -> m ()
warn (Warning -> M ()) -> Warning -> M ()
forall a b. (a -> b) -> a -> b
$ List1 Char -> Position -> Warning
LabelClashesWithCategory List1 Char
x Position
p2
            Maybe (List1 (WithPosition Parseable))
Nothing -> () -> M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Label
_ -> () -> M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  -- Add AST flavor of rule.
  -- This cannot fail since we already ensured that the label is unique.
  -- (See 'DuplicateLabel'.)
  -- However, in case the user uses @--force@, we should keep the existing entry
  -- and ignore the new entry.
  ASetter LBNF LBNF ASTRules ASTRules
-> (ASTRules -> ASTRules) -> M ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter LBNF LBNF ASTRules ASTRules
Lens' LBNF ASTRules
lbnfASTRules ((ASTRules -> ASTRules) -> M ()) -> (ASTRules -> ASTRules) -> M ()
forall a b. (a -> b) -> a -> b
$ (Map Label (WithPosition ARuleRHS)
 -> Map Label (WithPosition ARuleRHS)
 -> Map Label (WithPosition ARuleRHS))
-> Cat -> Map Label (WithPosition ARuleRHS) -> ASTRules -> ASTRules
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith ((WithPosition ARuleRHS
 -> WithPosition ARuleRHS -> WithPosition ARuleRHS)
-> Map Label (WithPosition ARuleRHS)
-> Map Label (WithPosition ARuleRHS)
-> Map Label (WithPosition ARuleRHS)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (\ WithPosition ARuleRHS
_new WithPosition ARuleRHS
old -> WithPosition ARuleRHS
old)) Cat
cat (Map Label (WithPosition ARuleRHS) -> ASTRules -> ASTRules)
-> Map Label (WithPosition ARuleRHS) -> ASTRules -> ASTRules
forall a b. (a -> b) -> a -> b
$
    Label -> WithPosition ARuleRHS -> Map Label (WithPosition ARuleRHS)
forall k a. k -> a -> Map k a
Map.singleton Label
l (WithPosition ARuleRHS -> Map Label (WithPosition ARuleRHS))
-> WithPosition ARuleRHS -> Map Label (WithPosition ARuleRHS)
forall a b. (a -> b) -> a -> b
$ Position -> ARuleRHS -> WithPosition ARuleRHS
forall a. Position -> a -> WithPosition a
WithPosition Position
p (ARuleRHS -> WithPosition ARuleRHS)
-> ARuleRHS -> WithPosition ARuleRHS
forall a b. (a -> b) -> a -> b
$ ARuleRHS :: RuleOrigin -> Parseable -> ARHS -> ARuleRHS
ARuleRHS
      { aruleOrigin :: RuleOrigin
aruleOrigin    = RuleOrigin
origin
      , aruleParseable :: Parseable
aruleParseable = Parseable
parseable
      , aruleRHS :: ARHS
aruleRHS       = ARHS
items
      }

  ASetter LBNF LBNF ASTRulesAP ASTRulesAP
-> (ASTRulesAP -> ASTRulesAP) -> M ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter LBNF LBNF ASTRulesAP ASTRulesAP
Lens' LBNF ASTRulesAP
lbnfASTRulesAP ((ASTRulesAP -> ASTRulesAP) -> M ())
-> (ASTRulesAP -> ASTRulesAP) -> M ()
forall a b. (a -> b) -> a -> b
$ (Map Label ([Type], (Integer, WithPosition ARHS))
 -> Map Label ([Type], (Integer, WithPosition ARHS))
 -> Map Label ([Type], (Integer, WithPosition ARHS)))
-> Type
-> Map Label ([Type], (Integer, WithPosition ARHS))
-> ASTRulesAP
-> ASTRulesAP
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith ((([Type], (Integer, WithPosition ARHS))
 -> ([Type], (Integer, WithPosition ARHS))
 -> ([Type], (Integer, WithPosition ARHS)))
-> Map Label ([Type], (Integer, WithPosition ARHS))
-> Map Label ([Type], (Integer, WithPosition ARHS))
-> Map Label ([Type], (Integer, WithPosition ARHS))
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (\ ([Type], (Integer, WithPosition ARHS))
_new ([Type], (Integer, WithPosition ARHS))
old -> ([Type], (Integer, WithPosition ARHS))
old)) (Cat -> Type
catToType Cat
cat) (Map Label ([Type], (Integer, WithPosition ARHS))
 -> ASTRulesAP -> ASTRulesAP)
-> Map Label ([Type], (Integer, WithPosition ARHS))
-> ASTRulesAP
-> ASTRulesAP
forall a b. (a -> b) -> a -> b
$
    Label
-> ([Type], (Integer, WithPosition ARHS))
-> Map Label ([Type], (Integer, WithPosition ARHS))
forall k a. k -> a -> Map k a
Map.singleton Label
l (ARHS -> [Type]
forall a. RHS' a -> [Type]
rhsType ARHS
items, (Cat -> Integer
getCatPrec Cat
cat, Position -> ARHS -> WithPosition ARHS
forall a. Position -> a -> WithPosition a
WithPosition Position
p ARHS
items))

  Bool -> M () -> M ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Parseable
parseable Parseable -> Parseable -> Bool
forall a. Eq a => a -> a -> Bool
== Parseable
Parseable) (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ do

    -- Trim keywords in RHS.
    let rhs :: RHS
rhs = ARHS -> RHS
trimRHS ARHS
items

    -- Add Parser rule of flavor.
    -- If the same RHS already exist, raise an error and skip this rule for the parser.
    (Cat -> RHS -> ParserRules -> Maybe (WithPosition RuleLabel)
lookupRHS Cat
cat RHS
rhs (ParserRules -> Maybe (WithPosition RuleLabel))
-> ReaderT Pass1 (StateT LBNF Check) ParserRules
-> ReaderT
     Pass1 (StateT LBNF Check) (Maybe (WithPosition RuleLabel))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting ParserRules LBNF ParserRules
-> ReaderT Pass1 (StateT LBNF Check) ParserRules
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ParserRules LBNF ParserRules
Lens' LBNF ParserRules
lbnfParserRules) ReaderT Pass1 (StateT LBNF Check) (Maybe (WithPosition RuleLabel))
-> (Maybe (WithPosition RuleLabel) -> M ()) -> M ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
       Just (WithPosition Position
p' RuleLabel
_) -> RecoverableError -> M ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError (RecoverableError -> M ()) -> RecoverableError -> M ()
forall a b. (a -> b) -> a -> b
$ Position -> RecoverableError
DuplicateRHS Position
p'
       Maybe (WithPosition RuleLabel)
Nothing -> do
         ASetter LBNF LBNF ParserRules ParserRules
-> (ParserRules -> ParserRules) -> M ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter LBNF LBNF ParserRules ParserRules
Lens' LBNF ParserRules
lbnfParserRules ((ParserRules -> ParserRules) -> M ())
-> (ParserRules -> ParserRules) -> M ()
forall a b. (a -> b) -> a -> b
$ (Map RHS (WithPosition RuleLabel)
 -> Map RHS (WithPosition RuleLabel)
 -> Map RHS (WithPosition RuleLabel))
-> Cat
-> Map RHS (WithPosition RuleLabel)
-> ParserRules
-> ParserRules
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith ((WithPosition RuleLabel
 -> WithPosition RuleLabel -> WithPosition RuleLabel)
-> Map RHS (WithPosition RuleLabel)
-> Map RHS (WithPosition RuleLabel)
-> Map RHS (WithPosition RuleLabel)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith ((WithPosition RuleLabel
  -> WithPosition RuleLabel -> WithPosition RuleLabel)
 -> Map RHS (WithPosition RuleLabel)
 -> Map RHS (WithPosition RuleLabel)
 -> Map RHS (WithPosition RuleLabel))
-> (WithPosition RuleLabel
    -> WithPosition RuleLabel -> WithPosition RuleLabel)
-> Map RHS (WithPosition RuleLabel)
-> Map RHS (WithPosition RuleLabel)
-> Map RHS (WithPosition RuleLabel)
forall a b. (a -> b) -> a -> b
$ [Char]
-> WithPosition RuleLabel
-> WithPosition RuleLabel
-> WithPosition RuleLabel
forall a. HasCallStack => [Char] -> a
panic [Char]
panicRHS) Cat
cat (Map RHS (WithPosition RuleLabel) -> ParserRules -> ParserRules)
-> Map RHS (WithPosition RuleLabel) -> ParserRules -> ParserRules
forall a b. (a -> b) -> a -> b
$
           RHS -> WithPosition RuleLabel -> Map RHS (WithPosition RuleLabel)
forall k a. k -> a -> Map k a
Map.singleton RHS
rhs (WithPosition RuleLabel -> Map RHS (WithPosition RuleLabel))
-> WithPosition RuleLabel -> Map RHS (WithPosition RuleLabel)
forall a b. (a -> b) -> a -> b
$ Position -> RuleLabel -> WithPosition RuleLabel
forall a. Position -> a -> WithPosition a
WithPosition Position
p (RuleLabel -> WithPosition RuleLabel)
-> RuleLabel -> WithPosition RuleLabel
forall a b. (a -> b) -> a -> b
$ RuleLabel :: RuleOrigin -> Label -> RuleLabel
RuleLabel
             { ruleOrigin :: RuleOrigin
ruleOrigin = RuleOrigin
origin
             , ruleLabel :: Label
ruleLabel  = Label
l
             }
  where
  panicRHS :: [Char]
panicRHS = [Char]
"this RHS cannot exist in the map since we just looked it up"

-- addRule :: Position -> RuleOrigin -> Parseable -> Label -> Cat -> RHS -> M ()
-- addRule p origin parseable l cat items = do
--   modifying lbnfRules $ Map.insertWith (<>) cat $ singleton $ WithPosition p $ RuleBody
--     { ruleOrigin    = origin
--     , ruleParseable = parseable
--     , ruleLabel     = l
--     , ruleRHS       = items
--     }

-- | Add rules from list pragma.
--
--
checkList :: Position -> A.MinimumSize -> A.Cat -> Separator' String -> M ()
checkList :: Position
-> MinimumSize' BNFC'Position
-> Cat' BNFC'Position
-> Separator' [Char]
-> M ()
checkList Position
p MinimumSize' BNFC'Position
size Cat' BNFC'Position
cat0 Separator' [Char]
sep0 = Position -> M () -> M ()
forall (m :: * -> *) p a.
(MonadCheck m, ToPosition' p) =>
p -> m a -> m a
atPosition Position
p (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ do
  WithPosition Position
_ Cat
cat <- Cat' BNFC'Position
-> ReaderT Pass1 (StateT LBNF Check) (WithPosition Cat)
checkCat Cat' BNFC'Position
cat0
  let
    list :: Cat
list = Cat -> Cat
forall a. Cat' a -> Cat' a
ListCat Cat
cat
    -- @asep@ is the separator including whitespace (Nothing for "")
    asep :: Maybe ASeparator
asep = Separator' [Char] -> Maybe ASeparator
parseASeparator Separator' [Char]
sep0
    -- @sep@ is the separator with whitespace trimmed (Nothing for @all isSpace@)
    sep :: Maybe Separator
sep  = ASeparator -> Maybe Separator
trimSeparator (ASeparator -> Maybe Separator)
-> Maybe ASeparator -> Maybe Separator
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ASeparator
asep
    -- Only one of these two is not null:
    term :: ARHS
term = [ List1 Char -> AItem
forall a. a -> Item' a
Terminal List1 Char
s | Terminator List1 Char
s <- Maybe ASeparator -> [ASeparator]
forall a. Maybe a -> [a]
maybeToList Maybe ASeparator
asep ]
    tsep :: ARHS
tsep = [ List1 Char -> AItem
forall a. a -> Item' a
Terminal List1 Char
s | Separator  List1 Char
s <- Maybe ASeparator -> [ASeparator]
forall a. Maybe a -> [a]
maybeToList Maybe ASeparator
asep ]
    arules :: [(Label, ARHS)]
arules = [[(Label, ARHS)]] -> [(Label, ARHS)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ (Label
LNil , []                  ) | Bool
mayEmpty ]
        -- If either the list is required to be @nonempty@
        -- or its is @separator@ which isn't just whitespace,
        -- then we need an extra rule for the singleton list (that may have a terminator):
      , [ (Label
LSg  , Cat -> AItem
forall a. Cat -> Item' a
NTerminal Cat
cat AItem -> ARHS -> ARHS
forall a. a -> [a] -> [a]
: ARHS
term) | Bool -> Bool
not Bool
mayEmpty Bool -> Bool -> Bool
|| Maybe Separator -> Bool
forall a. Maybe (Separator' a) -> Bool
isSep Maybe Separator
sep ]
      , [ (Label
LCons, [ARHS] -> ARHS
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Cat -> AItem
forall a. Cat -> Item' a
NTerminal Cat
cat], ARHS
tsep, ARHS
term, [Cat -> AItem
forall a. Cat -> Item' a
NTerminal Cat
list] ]) ]
      ]
  ((Label, ARHS) -> M ()) -> [(Label, ARHS)] -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Label -> ARHS -> M ()) -> (Label, ARHS) -> M ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Label -> ARHS -> M ()) -> (Label, ARHS) -> M ())
-> (Label -> ARHS -> M ()) -> (Label, ARHS) -> M ()
forall a b. (a -> b) -> a -> b
$ Position -> RuleOrigin -> Parseable -> Cat -> Label -> ARHS -> M ()
addRule Position
p RuleOrigin
FromList Parseable
Parseable Cat
list) [(Label, ARHS)]
arules
  where
  -- Are empty lists allowed?
  mayEmpty :: Bool
mayEmpty = case MinimumSize' BNFC'Position
size of
    A.MEmpty    BNFC'Position
_ -> Bool
True
    A.MNonEmpty BNFC'Position
_ -> Bool
False
  isSep :: Maybe (Separator' a) -> Bool
isSep = Bool -> (Separator' a -> Bool) -> Maybe (Separator' a) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((Separator' a -> Bool) -> Maybe (Separator' a) -> Bool)
-> (Separator' a -> Bool) -> Maybe (Separator' a) -> Bool
forall a b. (a -> b) -> a -> b
$ \case
    Separator{}  -> Bool
True
    Terminator{} -> Bool
False

-- | Add rules from @coercion@ pragma.
--
-- E.g. @coercions Exp 3@ will add the following rules:
--
-- @
--    _. Exp  ::= Exp1;
--    _. Exp1 ::= Exp2;
--    _. Exp2 ::= Exp3;
--    _. Exp3 ::= "(" Exp ")";
-- @

checkCoercions :: Position -> A.Identifier -> Integer -> M ()
-- @coercions _ 0@ is ignored.
checkCoercions :: Position -> Identifier -> Integer -> M ()
checkCoercions Position
p Identifier
_ Integer
n | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 = Position -> M () -> M ()
forall (m :: * -> *) p a.
(MonadCheck m, ToPosition' p) =>
p -> m a -> m a
atPosition Position
p (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ Warning -> M ()
forall (m :: * -> *). MonadCheck m => Warning -> m ()
warn Warning
IgnoringNullCoercions
checkCoercions Position
p (A.Identifier ((Int, Int)
_, [Char]
x)) Integer
n = Position -> M () -> M ()
forall (m :: * -> *) p a.
(MonadCheck m, ToPosition' p) =>
p -> m a -> m a
atPosition Position
p (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ do
  Cat
c0 <- ICat -> M Cat
parseICat (ICat -> M Cat) -> ICat -> M Cat
forall a b. (a -> b) -> a -> b
$ [Char] -> ICat
parseCoerceCat [Char]
x
  case Cat
c0 of
    ListCat{}           -> [Char] -> M ()
forall a. HasCallStack => [Char] -> a
panic [Char]
"Identifier cannot resolve to ListCat"
    CoerceCat{}         -> () -> M ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- this has been flagged already in pass 1
    Cat BuiltinCat{}    -> RecoverableError -> M ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError RecoverableError
CoercionsOfBuiltinCat
    Cat (IdentCat  IdentCat
_)   -> RecoverableError -> M ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError RecoverableError
CoercionsOfIdentCat
    Cat TokenCat  {}    -> RecoverableError -> M ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError RecoverableError
CoercionsOfTokenCat
    Cat (BaseCat List1 Char
ident) -> do
      let c :: Integer -> Cat' a
c = List1 Char -> Integer -> Cat' a
forall a. List1 Char -> Integer -> Cat' a
CoerceCat List1 Char
ident
      ((Cat, ARHS) -> M ()) -> [(Cat, ARHS)] -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ (Cat
cat, ARHS
rhs) -> Position -> RuleOrigin -> Parseable -> Cat -> Label -> ARHS -> M ()
addRule Position
p RuleOrigin
FromCoercions Parseable
Parseable Cat
cat Label
LWild ARHS
rhs) ([(Cat, ARHS)] -> M ()) -> [(Cat, ARHS)] -> M ()
forall a b. (a -> b) -> a -> b
$ [[(Cat, ARHS)]] -> [(Cat, ARHS)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [ (Cat
c0     , [ Cat -> AItem
forall a. Cat -> Item' a
NTerminal (Integer -> Cat
forall a. Integer -> Cat' a
c Integer
1) ])                                        ]
        , [ (Integer -> Cat
forall a. Integer -> Cat' a
c (Integer
iInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1), [ Cat -> AItem
forall a. Cat -> Item' a
NTerminal (Integer -> Cat
forall a. Integer -> Cat' a
c Integer
i) ])                          | Integer
i <- [Integer
2..Integer
n] ]
        , [ (Integer -> Cat
forall a. Integer -> Cat' a
c Integer
n    , [ List1 Char -> AItem
forall a. a -> Item' a
Terminal List1 Char
"(", Cat -> AItem
forall a. Cat -> Item' a
NTerminal Cat
c0, List1 Char -> AItem
forall a. a -> Item' a
Terminal List1 Char
")" ])               ]
        ]

-- | Add rules from @rules@ pragma.

checkRules :: Position -> A.Identifier -> [A.RHS] -> M ()
checkRules :: Position -> Identifier -> [RHS' BNFC'Position] -> M ()
checkRules Position
p (A.Identifier ((Int, Int)
_, [Char]
x0)) [RHS' BNFC'Position]
rhss = do
  let x :: List1 Char
x = List1 Char -> Maybe (List1 Char) -> List1 Char
forall a. a -> Maybe a -> a
fromMaybe List1 Char
forall a. HasCallStack => a
panicEmptyIdentifier (Maybe (List1 Char) -> List1 Char)
-> Maybe (List1 Char) -> List1 Char
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe (List1 Char)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Char]
x0
  Cat
cat   <- ICat -> M Cat
parseICat (ICat -> M Cat) -> ICat -> M Cat
forall a b. (a -> b) -> a -> b
$ [Char] -> ICat
parseCoerceCat [Char]
x0
  [ARHS]
arhss <- (RHS' BNFC'Position -> M ARHS)
-> [RHS' BNFC'Position] -> ReaderT Pass1 (StateT LBNF Check) [ARHS]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM RHS' BNFC'Position -> M ARHS
checkRHS [RHS' BNFC'Position]
rhss
  [(Int, ARHS)] -> ((Int, ARHS) -> M ()) -> M ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [ARHS] -> [(Int, ARHS)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] [ARHS]
arhss) (((Int, ARHS) -> M ()) -> M ()) -> ((Int, ARHS) -> M ()) -> M ()
forall a b. (a -> b) -> a -> b
$ \ (Int
k, ARHS
arhs) -> do
    let
      l :: List1 Char
l = case ARHS -> RHS
trimRHS ARHS
arhs of
        -- If the rhs is a single keyword @kw@ which is a valid identifier, use @Cat_kw@ as label.
        [Terminal (Keyword List1 Char
s)] | (Char -> Bool) -> List1 Char -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c ([Char]
"_'" :: [Char])) List1 Char
s
                      -> Char
'_' Char -> List1 Char -> List1 Char
forall a. a -> NonEmpty a -> NonEmpty a
<| List1 Char
s
        -- If the rhs is a single category @D@, use @CatD@ as label.
        [NTerminal Cat
c] -> Cat -> List1 Char
catToIdentifier Cat
c
        -- Otherwise, the label is @Cat_k@ where @k@ is the number of the generated rule.
        RHS
_             -> Char
'_' Char -> [Char] -> List1 Char
forall a. a -> [a] -> NonEmpty a
:| Int -> [Char]
forall a. Show a => a -> [Char]
show Int
k
    Position -> RuleOrigin -> Parseable -> Cat -> Label -> ARHS -> M ()
addRule Position
p RuleOrigin
FromRules Parseable
Parseable Cat
cat (List1 Char -> Label
LId (List1 Char -> Label) -> List1 Char -> Label
forall a b. (a -> b) -> a -> b
$ List1 Char
x List1 Char -> List1 Char -> List1 Char
forall a. Semigroup a => a -> a -> a
<> List1 Char
l) ARHS
arhs

checkDefine :: Position -> A.Identifier -> [A.Arg] -> A.Exp -> M ()
checkDefine :: Position
-> Identifier -> [Arg' BNFC'Position] -> Exp' BNFC'Position -> M ()
checkDefine Position
p (A.Identifier ((Int, Int)
_, [Char]
x0)) [Arg' BNFC'Position]
args Exp' BNFC'Position
exp = Position -> M () -> M ()
forall (m :: * -> *) p a.
(MonadCheck m, ToPosition' p) =>
p -> m a -> m a
atPosition Position
p (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ do
  let x :: List1 Char
x = List1 Char -> Maybe (List1 Char) -> List1 Char
forall a. a -> Maybe a -> a
fromMaybe List1 Char
forall a. HasCallStack => a
panicEmptyIdentifier (Maybe (List1 Char) -> List1 Char)
-> Maybe (List1 Char) -> List1 Char
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe (List1 Char)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Char]
x0
  Map (List1 Char) (WithPosition FunType)
sig <- Getting
  (Map (List1 Char) (WithPosition FunType))
  LBNF
  (Map (List1 Char) (WithPosition FunType))
-> ReaderT
     Pass1 (StateT LBNF Check) (Map (List1 Char) (WithPosition FunType))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (Map (List1 Char) (WithPosition FunType))
  LBNF
  (Map (List1 Char) (WithPosition FunType))
Lens' LBNF (Map (List1 Char) (WithPosition FunType))
lbnfSignature
  case List1 Char
-> Map (List1 Char) (WithPosition FunType)
-> Maybe (WithPosition FunType)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup List1 Char
x Map (List1 Char) (WithPosition FunType)
sig of
    Maybe (WithPosition FunType)
Nothing -> RecoverableError -> M ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError RecoverableError
IgnoringUndeclaredFunction
    Just (WithPosition Position
_ FunType
ft) -> do
      Function
fun <- StateT LBNF Check Function
-> ReaderT Pass1 (StateT LBNF Check) Function
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT LBNF Check Function
 -> ReaderT Pass1 (StateT LBNF Check) Function)
-> (Check Function -> StateT LBNF Check Function)
-> Check Function
-> ReaderT Pass1 (StateT LBNF Check) Function
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Check Function -> StateT LBNF Check Function
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Check Function -> ReaderT Pass1 (StateT LBNF Check) Function)
-> Check Function -> ReaderT Pass1 (StateT LBNF Check) Function
forall a b. (a -> b) -> a -> b
$ Position
-> Map (List1 Char) (WithPosition FunType)
-> List1 Char
-> [Arg' BNFC'Position]
-> Exp' BNFC'Position
-> FunType
-> Check Function
checkFunction Position
p Map (List1 Char) (WithPosition FunType)
sig List1 Char
x [Arg' BNFC'Position]
args Exp' BNFC'Position
exp FunType
ft
      ASetter LBNF LBNF Functions Functions
-> (Functions -> Functions) -> M ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter LBNF LBNF Functions Functions
Lens' LBNF Functions
lbnfFunctions ((Functions -> Functions) -> M ())
-> (Functions -> Functions) -> M ()
forall a b. (a -> b) -> a -> b
$ List1 Char -> WithPosition Function -> Functions -> Functions
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert List1 Char
x (WithPosition Function -> Functions -> Functions)
-> WithPosition Function -> Functions -> Functions
forall a b. (a -> b) -> a -> b
$ Position -> Function -> WithPosition Function
forall a. Position -> a -> WithPosition a
WithPosition Position
p Function
fun

-- | Add a token category (position carrying or not) defined by a regular expression.

addTokenDef :: Position -> A.Identifier -> PositionToken -> A.Reg -> M ()
addTokenDef :: Position
-> Identifier -> PositionToken -> Reg' BNFC'Position -> M ()
addTokenDef Position
pos (A.Identifier ((Int, Int)
_, [Char]
x0)) PositionToken
posTok Reg' BNFC'Position
reg = Position -> M () -> M ()
forall (m :: * -> *) p a.
(MonadCheck m, ToPosition' p) =>
p -> m a -> m a
atPosition Position
pos (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ do
  let x :: List1 Char
x = List1 Char -> Maybe (List1 Char) -> List1 Char
forall a. a -> Maybe a -> a
fromMaybe List1 Char
forall a. HasCallStack => a
panicEmptyIdentifier (Maybe (List1 Char) -> List1 Char)
-> Maybe (List1 Char) -> List1 Char
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe (List1 Char)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Char]
x0
  ASetter LBNF LBNF TokenDefs TokenDefs
-> (TokenDefs -> TokenDefs) -> M ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter LBNF LBNF TokenDefs TokenDefs
Lens' LBNF TokenDefs
lbnfTokenDefs ((TokenDefs -> TokenDefs) -> M ())
-> (TokenDefs -> TokenDefs) -> M ()
forall a b. (a -> b) -> a -> b
$ List1 Char -> WithPosition TokenDef -> TokenDefs -> TokenDefs
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert List1 Char
x (WithPosition TokenDef -> TokenDefs -> TokenDefs)
-> WithPosition TokenDef -> TokenDefs -> TokenDefs
forall a b. (a -> b) -> a -> b
$ Position -> TokenDef -> WithPosition TokenDef
forall a. Position -> a -> WithPosition a
WithPosition Position
pos TokenDef
def
  List1 Char -> WithPosition FunType -> M ()
addSig List1 Char
x (Position -> FunType -> WithPosition FunType
forall a. Position -> a -> WithPosition a
WithPosition Position
pos (Type -> [Type] -> FunType
FunType (BaseCat -> Type
BaseType (List1 Char -> BaseCat
TokenCat List1 Char
x)) [BaseCat -> Type
BaseType (BuiltinCat -> BaseCat
BuiltinCat BuiltinCat
BString)]))
  Bool -> M () -> M ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Regex -> Bool
forall a. Satisfiable a => a -> Bool
satisfiable Regex
regex) (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ Warning -> M ()
forall (m :: * -> *). MonadCheck m => Warning -> m ()
warn             (Warning -> M ()) -> Warning -> M ()
forall a b. (a -> b) -> a -> b
$ List1 Char -> Regex -> Warning
EmptyToken    List1 Char
x Regex
regex
  Bool -> M () -> M ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when   (Regex -> Bool
nullable    Regex
regex) (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ RecoverableError -> M ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError (RecoverableError -> M ()) -> RecoverableError -> M ()
forall a b. (a -> b) -> a -> b
$ List1 Char -> Regex -> RecoverableError
NullableToken List1 Char
x Regex
regex
  where
  regex :: Regex
regex = Reg' BNFC'Position -> Regex
normRegex Reg' BNFC'Position
reg
  def :: TokenDef
def = TokenDef :: PositionToken -> Regex -> Bool -> TokenDef
TokenDef
    { positionToken :: PositionToken
positionToken = PositionToken
posTok
    , regexToken :: Regex
regexToken    = Regex
regex
    , isIdent :: Bool
isIdent       = Bool
False
    }

-- | Add a keyword that starts or stops layout.

addLayoutKeyword
  :: Lens' LBNF LayoutKeywords   -- ^ add here
  -> Lens' LBNF LayoutKeywords   -- ^ shouldn't be in here
  -> Position
  -> String                      -- ^ shouldn't be empty
  -> M ()
addLayoutKeyword :: Lens' LBNF LayoutKeywords
-> Lens' LBNF LayoutKeywords -> Position -> [Char] -> M ()
addLayoutKeyword Lens' LBNF LayoutKeywords
we Lens' LBNF LayoutKeywords
others Position
p [Char]
s = Position -> M () -> M ()
forall (m :: * -> *) p a.
(MonadCheck m, ToPosition' p) =>
p -> m a -> m a
atPosition Position
p (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ do
  case [Char] -> Maybe Keyword
parseKeyword [Char]
s of
    Maybe Keyword
Nothing -> Warning -> M ()
forall (m :: * -> *). MonadCheck m => Warning -> m ()
warn Warning
EmptyLayoutKeyword
    Just Keyword
kw -> do
      -- Check that keyword isn't amoung the @others@.
      -- If it is there, ignore it with a recoverable error.
      (Keyword -> LayoutKeywords -> Maybe Position
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Keyword
kw (LayoutKeywords -> Maybe Position)
-> ReaderT Pass1 (StateT LBNF Check) LayoutKeywords
-> ReaderT Pass1 (StateT LBNF Check) (Maybe Position)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting LayoutKeywords LBNF LayoutKeywords
-> ReaderT Pass1 (StateT LBNF Check) LayoutKeywords
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting LayoutKeywords LBNF LayoutKeywords
Lens' LBNF LayoutKeywords
others) ReaderT Pass1 (StateT LBNF Check) (Maybe Position)
-> (Maybe Position -> M ()) -> M ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Position
pold -> RecoverableError -> M ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError (RecoverableError -> M ()) -> RecoverableError -> M ()
forall a b. (a -> b) -> a -> b
$ Keyword -> Position -> RecoverableError
ConflictingUsesOfLayoutKeyword Keyword
kw Position
pold
        Maybe Position
Nothing -> do
          -- Check that keyword is defined in the grammar, otherwise ignore.
          (Keyword -> Map Keyword (List1 Position) -> Maybe (List1 Position)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Keyword
kw (Map Keyword (List1 Position) -> Maybe (List1 Position))
-> ReaderT Pass1 (StateT LBNF Check) (Map Keyword (List1 Position))
-> ReaderT Pass1 (StateT LBNF Check) (Maybe (List1 Position))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (Map Keyword (List1 Position)) LBNF (Map Keyword (List1 Position))
-> ReaderT Pass1 (StateT LBNF Check) (Map Keyword (List1 Position))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (Map Keyword (List1 Position)) LBNF (Map Keyword (List1 Position))
Lens' LBNF (Map Keyword (List1 Position))
lbnfKeywords) ReaderT Pass1 (StateT LBNF Check) (Maybe (List1 Position))
-> (Maybe (List1 Position) -> M ()) -> M ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (List1 Position)
Nothing -> Warning -> M ()
forall (m :: * -> *). MonadCheck m => Warning -> m ()
warn (Warning -> M ()) -> Warning -> M ()
forall a b. (a -> b) -> a -> b
$ Keyword -> Warning
UndefinedLayoutKeyword Keyword
kw
            Just{}  -> do
            -- Check that keyword isn't defined as layout yet.
              (Keyword -> LayoutKeywords -> Maybe Position
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Keyword
kw (LayoutKeywords -> Maybe Position)
-> ReaderT Pass1 (StateT LBNF Check) LayoutKeywords
-> ReaderT Pass1 (StateT LBNF Check) (Maybe Position)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting LayoutKeywords LBNF LayoutKeywords
-> ReaderT Pass1 (StateT LBNF Check) LayoutKeywords
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting LayoutKeywords LBNF LayoutKeywords
Lens' LBNF LayoutKeywords
we) ReaderT Pass1 (StateT LBNF Check) (Maybe Position)
-> (Maybe Position -> M ()) -> M ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Just Position
pold -> Warning -> M ()
forall (m :: * -> *). MonadCheck m => Warning -> m ()
warn (Warning -> M ()) -> Warning -> M ()
forall a b. (a -> b) -> a -> b
$ Keyword -> Position -> Warning
DuplicateLayoutKeyword Keyword
kw Position
pold
                -- Store layout keyword
                Maybe Position
Nothing -> ASetter LBNF LBNF LayoutKeywords LayoutKeywords
-> (LayoutKeywords -> LayoutKeywords) -> M ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter LBNF LBNF LayoutKeywords LayoutKeywords
Lens' LBNF LayoutKeywords
we ((LayoutKeywords -> LayoutKeywords) -> M ())
-> (LayoutKeywords -> LayoutKeywords) -> M ()
forall a b. (a -> b) -> a -> b
$ Keyword -> Position -> LayoutKeywords -> LayoutKeywords
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Keyword
kw Position
p


-- | Add line comment delimiter, unless empty.

addLineComment :: Position -> String -> M ()
addLineComment :: Position -> [Char] -> M ()
addLineComment Position
p = \case
  []   -> Position -> M () -> M ()
forall (m :: * -> *) p a.
(MonadCheck m, ToPosition' p) =>
p -> m a -> m a
atPosition Position
p (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$ Warning -> M ()
forall (m :: * -> *). MonadCheck m => Warning -> m ()
warn (Warning -> M ()) -> Warning -> M ()
forall a b. (a -> b) -> a -> b
$ Warning
IgnoringEmptyLineComment
  Char
c:[Char]
cs -> ASetter LBNF LBNF LineComments LineComments
-> (LineComments -> LineComments) -> M ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter LBNF LBNF LineComments LineComments
Lens' LBNF LineComments
lbnfLineComments ((LineComments -> LineComments) -> M ())
-> (LineComments -> LineComments) -> M ()
forall a b. (a -> b) -> a -> b
$ Position -> LineComment -> LineComments -> LineComments
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Position
p (LineComment -> LineComments -> LineComments)
-> LineComment -> LineComments -> LineComments
forall a b. (a -> b) -> a -> b
$ List1 Char -> LineComment
LineComment (List1 Char -> LineComment) -> List1 Char -> LineComment
forall a b. (a -> b) -> a -> b
$ Char
c Char -> [Char] -> List1 Char
forall a. a -> [a] -> NonEmpty a
:| [Char]
cs
      -- NB: Map.insert is safe (not to overwrite) because we cannot have two
      -- definitions with the same position

-- | Add block comment delimiters if both are non-empty.

addBlockComment :: Position -> String -> String -> M ()
addBlockComment :: Position -> [Char] -> [Char] -> M ()
addBlockComment Position
p [Char]
s1 [Char]
s2 = Position -> M () -> M ()
forall (m :: * -> *) p a.
(MonadCheck m, ToPosition' p) =>
p -> m a -> m a
atPosition Position
p (M () -> M ()) -> M () -> M ()
forall a b. (a -> b) -> a -> b
$
  case ([Char] -> Maybe (List1 Char)
forall a. [a] -> Maybe (NonEmpty a)
List1.nonEmpty [Char]
s1, [Char] -> Maybe (List1 Char)
forall a. [a] -> Maybe (NonEmpty a)
List1.nonEmpty [Char]
s2) of
    (Just List1 Char
n1, Just List1 Char
n2) ->
      ASetter LBNF LBNF BlockComments BlockComments
-> (BlockComments -> BlockComments) -> M ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter LBNF LBNF BlockComments BlockComments
Lens' LBNF BlockComments
lbnfBlockComments ((BlockComments -> BlockComments) -> M ())
-> (BlockComments -> BlockComments) -> M ()
forall a b. (a -> b) -> a -> b
$ Position -> BlockComment -> BlockComments -> BlockComments
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Position
p (BlockComment -> BlockComments -> BlockComments)
-> BlockComment -> BlockComments -> BlockComments
forall a b. (a -> b) -> a -> b
$ List1 Char -> List1 Char -> BlockComment
BlockComment List1 Char
n1 List1 Char
n2
    (Maybe (List1 Char)
Nothing, Maybe (List1 Char)
Nothing) -> Warning -> M ()
forall (m :: * -> *). MonadCheck m => Warning -> m ()
warn (Warning -> M ()) -> Warning -> M ()
forall a b. (a -> b) -> a -> b
$ Warning
IgnoringEmptyBlockComment
    -- If one of the delimiters is null, this is a more harmful situation,
    -- we opt for an error here instead of a warning.
    (Maybe (List1 Char), Maybe (List1 Char))
_                  -> RecoverableError -> M ()
forall (m :: * -> *). MonadCheck m => RecoverableError -> m ()
recoverableError (RecoverableError -> M ()) -> RecoverableError -> M ()
forall a b. (a -> b) -> a -> b
$ RecoverableError
IllformedBlockComment