{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TupleSections #-}

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- | Context-free grammars: syntax and grammar folds.

module CFG where

import Control.Monad.Except
import Control.Monad.State

import qualified Data.Foldable as Fold
import qualified Data.List as List
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set

import Data.Maybe (mapMaybe)
import Data.Function (on)
import Data.Tuple (swap)
import Data.Semigroup (Semigroup(..))

-- uses microlens-platform
import Lens.Micro
import Lens.Micro.Extras (view)
import Lens.Micro.TH (makeLenses)

import Saturation
import SetMaybe (SetMaybe)
import qualified SetMaybe

-- | A grammar over non-terminal names x, rulenames r and an alphabet t
--   consists of definitions of the nonterminals, represented as Ints.

data Grammar' x r t = Grammar
  { forall x r t. Grammar' x r t -> Int
_grmNumNT  :: Int                   -- ^ Number of non-terminals.
  , forall x r t. Grammar' x r t -> Map x Int
_grmNTDict :: Map x NTId            -- ^ Names-to-number map for non-terminals.
  , forall x r t. Grammar' x r t -> IntMap (NTDef' x r t)
_grmNTDefs :: IntMap (NTDef' x r t) -- ^ Definitions of non-terminals.
  }

emptyGrammar :: Grammar' x r t
emptyGrammar :: forall x r t. Grammar' x r t
emptyGrammar = Int -> Map x Int -> IntMap (NTDef' x r t) -> Grammar' x r t
forall x r t.
Int -> Map x Int -> IntMap (NTDef' x r t) -> Grammar' x r t
Grammar Int
0 Map x Int
forall k a. Map k a
Map.empty IntMap (NTDef' x r t)
forall a. IntMap a
IntMap.empty

-- | A nonterminal is defined by a list of alternatives.

data NTDef' x r t = NTDef { forall x r t. NTDef' x r t -> x
_ntName :: x, forall x r t. NTDef' x r t -> [Alt' x r t]
_ntDef :: [Alt' x r t] }

-- | Each alternative is a rule name plus a sentential form.

data Alt' x r t = Alt r (Form' x t)
  deriving (Alt' x r t -> Alt' x r t -> Bool
(Alt' x r t -> Alt' x r t -> Bool)
-> (Alt' x r t -> Alt' x r t -> Bool) -> Eq (Alt' x r t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall x r t. (Eq r, Eq t) => Alt' x r t -> Alt' x r t -> Bool
$c== :: forall x r t. (Eq r, Eq t) => Alt' x r t -> Alt' x r t -> Bool
== :: Alt' x r t -> Alt' x r t -> Bool
$c/= :: forall x r t. (Eq r, Eq t) => Alt' x r t -> Alt' x r t -> Bool
/= :: Alt' x r t -> Alt' x r t -> Bool
Eq, Eq (Alt' x r t)
Eq (Alt' x r t) =>
(Alt' x r t -> Alt' x r t -> Ordering)
-> (Alt' x r t -> Alt' x r t -> Bool)
-> (Alt' x r t -> Alt' x r t -> Bool)
-> (Alt' x r t -> Alt' x r t -> Bool)
-> (Alt' x r t -> Alt' x r t -> Bool)
-> (Alt' x r t -> Alt' x r t -> Alt' x r t)
-> (Alt' x r t -> Alt' x r t -> Alt' x r t)
-> Ord (Alt' x r t)
Alt' x r t -> Alt' x r t -> Bool
Alt' x r t -> Alt' x r t -> Ordering
Alt' x r t -> Alt' x r t -> Alt' x r t
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall x r t. (Ord r, Ord t) => Eq (Alt' x r t)
forall x r t. (Ord r, Ord t) => Alt' x r t -> Alt' x r t -> Bool
forall x r t.
(Ord r, Ord t) =>
Alt' x r t -> Alt' x r t -> Ordering
forall x r t.
(Ord r, Ord t) =>
Alt' x r t -> Alt' x r t -> Alt' x r t
$ccompare :: forall x r t.
(Ord r, Ord t) =>
Alt' x r t -> Alt' x r t -> Ordering
compare :: Alt' x r t -> Alt' x r t -> Ordering
$c< :: forall x r t. (Ord r, Ord t) => Alt' x r t -> Alt' x r t -> Bool
< :: Alt' x r t -> Alt' x r t -> Bool
$c<= :: forall x r t. (Ord r, Ord t) => Alt' x r t -> Alt' x r t -> Bool
<= :: Alt' x r t -> Alt' x r t -> Bool
$c> :: forall x r t. (Ord r, Ord t) => Alt' x r t -> Alt' x r t -> Bool
> :: Alt' x r t -> Alt' x r t -> Bool
$c>= :: forall x r t. (Ord r, Ord t) => Alt' x r t -> Alt' x r t -> Bool
>= :: Alt' x r t -> Alt' x r t -> Bool
$cmax :: forall x r t.
(Ord r, Ord t) =>
Alt' x r t -> Alt' x r t -> Alt' x r t
max :: Alt' x r t -> Alt' x r t -> Alt' x r t
$cmin :: forall x r t.
(Ord r, Ord t) =>
Alt' x r t -> Alt' x r t -> Alt' x r t
min :: Alt' x r t -> Alt' x r t -> Alt' x r t
Ord, Int -> Alt' x r t -> ShowS
[Alt' x r t] -> ShowS
Alt' x r t -> String
(Int -> Alt' x r t -> ShowS)
-> (Alt' x r t -> String)
-> ([Alt' x r t] -> ShowS)
-> Show (Alt' x r t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall x r t.
(Show r, Show t, Show x) =>
Int -> Alt' x r t -> ShowS
forall x r t. (Show r, Show t, Show x) => [Alt' x r t] -> ShowS
forall x r t. (Show r, Show t, Show x) => Alt' x r t -> String
$cshowsPrec :: forall x r t.
(Show r, Show t, Show x) =>
Int -> Alt' x r t -> ShowS
showsPrec :: Int -> Alt' x r t -> ShowS
$cshow :: forall x r t. (Show r, Show t, Show x) => Alt' x r t -> String
show :: Alt' x r t -> String
$cshowList :: forall x r t. (Show r, Show t, Show x) => [Alt' x r t] -> ShowS
showList :: [Alt' x r t] -> ShowS
Show)

-- | A sentential form is a string of symbols.

newtype Form' x t = Form { forall x t. Form' x t -> [Symbol' x t]
theForm :: [Symbol' x t] }
  deriving (Form' x t -> Form' x t -> Bool
(Form' x t -> Form' x t -> Bool)
-> (Form' x t -> Form' x t -> Bool) -> Eq (Form' x t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall x t. Eq t => Form' x t -> Form' x t -> Bool
$c== :: forall x t. Eq t => Form' x t -> Form' x t -> Bool
== :: Form' x t -> Form' x t -> Bool
$c/= :: forall x t. Eq t => Form' x t -> Form' x t -> Bool
/= :: Form' x t -> Form' x t -> Bool
Eq, Eq (Form' x t)
Eq (Form' x t) =>
(Form' x t -> Form' x t -> Ordering)
-> (Form' x t -> Form' x t -> Bool)
-> (Form' x t -> Form' x t -> Bool)
-> (Form' x t -> Form' x t -> Bool)
-> (Form' x t -> Form' x t -> Bool)
-> (Form' x t -> Form' x t -> Form' x t)
-> (Form' x t -> Form' x t -> Form' x t)
-> Ord (Form' x t)
Form' x t -> Form' x t -> Bool
Form' x t -> Form' x t -> Ordering
Form' x t -> Form' x t -> Form' x t
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall x t. Ord t => Eq (Form' x t)
forall x t. Ord t => Form' x t -> Form' x t -> Bool
forall x t. Ord t => Form' x t -> Form' x t -> Ordering
forall x t. Ord t => Form' x t -> Form' x t -> Form' x t
$ccompare :: forall x t. Ord t => Form' x t -> Form' x t -> Ordering
compare :: Form' x t -> Form' x t -> Ordering
$c< :: forall x t. Ord t => Form' x t -> Form' x t -> Bool
< :: Form' x t -> Form' x t -> Bool
$c<= :: forall x t. Ord t => Form' x t -> Form' x t -> Bool
<= :: Form' x t -> Form' x t -> Bool
$c> :: forall x t. Ord t => Form' x t -> Form' x t -> Bool
> :: Form' x t -> Form' x t -> Bool
$c>= :: forall x t. Ord t => Form' x t -> Form' x t -> Bool
>= :: Form' x t -> Form' x t -> Bool
$cmax :: forall x t. Ord t => Form' x t -> Form' x t -> Form' x t
max :: Form' x t -> Form' x t -> Form' x t
$cmin :: forall x t. Ord t => Form' x t -> Form' x t -> Form' x t
min :: Form' x t -> Form' x t -> Form' x t
Ord, Int -> Form' x t -> ShowS
[Form' x t] -> ShowS
Form' x t -> String
(Int -> Form' x t -> ShowS)
-> (Form' x t -> String)
-> ([Form' x t] -> ShowS)
-> Show (Form' x t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall x t. (Show t, Show x) => Int -> Form' x t -> ShowS
forall x t. (Show t, Show x) => [Form' x t] -> ShowS
forall x t. (Show t, Show x) => Form' x t -> String
$cshowsPrec :: forall x t. (Show t, Show x) => Int -> Form' x t -> ShowS
showsPrec :: Int -> Form' x t -> ShowS
$cshow :: forall x t. (Show t, Show x) => Form' x t -> String
show :: Form' x t -> String
$cshowList :: forall x t. (Show t, Show x) => [Form' x t] -> ShowS
showList :: [Form' x t] -> ShowS
Show)

-- | A symbol is a terminal or a non-terminal.

data Symbol' x t
  = Term t
  | NonTerm (NT' x)
  deriving (Symbol' x t -> Symbol' x t -> Bool
(Symbol' x t -> Symbol' x t -> Bool)
-> (Symbol' x t -> Symbol' x t -> Bool) -> Eq (Symbol' x t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall x t. Eq t => Symbol' x t -> Symbol' x t -> Bool
$c== :: forall x t. Eq t => Symbol' x t -> Symbol' x t -> Bool
== :: Symbol' x t -> Symbol' x t -> Bool
$c/= :: forall x t. Eq t => Symbol' x t -> Symbol' x t -> Bool
/= :: Symbol' x t -> Symbol' x t -> Bool
Eq, Eq (Symbol' x t)
Eq (Symbol' x t) =>
(Symbol' x t -> Symbol' x t -> Ordering)
-> (Symbol' x t -> Symbol' x t -> Bool)
-> (Symbol' x t -> Symbol' x t -> Bool)
-> (Symbol' x t -> Symbol' x t -> Bool)
-> (Symbol' x t -> Symbol' x t -> Bool)
-> (Symbol' x t -> Symbol' x t -> Symbol' x t)
-> (Symbol' x t -> Symbol' x t -> Symbol' x t)
-> Ord (Symbol' x t)
Symbol' x t -> Symbol' x t -> Bool
Symbol' x t -> Symbol' x t -> Ordering
Symbol' x t -> Symbol' x t -> Symbol' x t
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall x t. Ord t => Eq (Symbol' x t)
forall x t. Ord t => Symbol' x t -> Symbol' x t -> Bool
forall x t. Ord t => Symbol' x t -> Symbol' x t -> Ordering
forall x t. Ord t => Symbol' x t -> Symbol' x t -> Symbol' x t
$ccompare :: forall x t. Ord t => Symbol' x t -> Symbol' x t -> Ordering
compare :: Symbol' x t -> Symbol' x t -> Ordering
$c< :: forall x t. Ord t => Symbol' x t -> Symbol' x t -> Bool
< :: Symbol' x t -> Symbol' x t -> Bool
$c<= :: forall x t. Ord t => Symbol' x t -> Symbol' x t -> Bool
<= :: Symbol' x t -> Symbol' x t -> Bool
$c> :: forall x t. Ord t => Symbol' x t -> Symbol' x t -> Bool
> :: Symbol' x t -> Symbol' x t -> Bool
$c>= :: forall x t. Ord t => Symbol' x t -> Symbol' x t -> Bool
>= :: Symbol' x t -> Symbol' x t -> Bool
$cmax :: forall x t. Ord t => Symbol' x t -> Symbol' x t -> Symbol' x t
max :: Symbol' x t -> Symbol' x t -> Symbol' x t
$cmin :: forall x t. Ord t => Symbol' x t -> Symbol' x t -> Symbol' x t
min :: Symbol' x t -> Symbol' x t -> Symbol' x t
Ord, Int -> Symbol' x t -> ShowS
[Symbol' x t] -> ShowS
Symbol' x t -> String
(Int -> Symbol' x t -> ShowS)
-> (Symbol' x t -> String)
-> ([Symbol' x t] -> ShowS)
-> Show (Symbol' x t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall x t. (Show t, Show x) => Int -> Symbol' x t -> ShowS
forall x t. (Show t, Show x) => [Symbol' x t] -> ShowS
forall x t. (Show t, Show x) => Symbol' x t -> String
$cshowsPrec :: forall x t. (Show t, Show x) => Int -> Symbol' x t -> ShowS
showsPrec :: Int -> Symbol' x t -> ShowS
$cshow :: forall x t. (Show t, Show x) => Symbol' x t -> String
show :: Symbol' x t -> String
$cshowList :: forall x t. (Show t, Show x) => [Symbol' x t] -> ShowS
showList :: [Symbol' x t] -> ShowS
Show)

-- | Non-terminals are natural numbers.
--   We store the original name for printing purposes.
--
data NT' x = NT { forall x. NT' x -> Int
ntNum :: NTId, forall x. NT' x -> x
ntNam :: x }
  deriving (Int -> NT' x -> ShowS
[NT' x] -> ShowS
NT' x -> String
(Int -> NT' x -> ShowS)
-> (NT' x -> String) -> ([NT' x] -> ShowS) -> Show (NT' x)
forall x. Show x => Int -> NT' x -> ShowS
forall x. Show x => [NT' x] -> ShowS
forall x. Show x => NT' x -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall x. Show x => Int -> NT' x -> ShowS
showsPrec :: Int -> NT' x -> ShowS
$cshow :: forall x. Show x => NT' x -> String
show :: NT' x -> String
$cshowList :: forall x. Show x => [NT' x] -> ShowS
showList :: [NT' x] -> ShowS
Show)

instance Eq  (NT' x) where == :: NT' x -> NT' x -> Bool
(==)    = Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==)    (Int -> Int -> Bool) -> (NT' x -> Int) -> NT' x -> NT' x -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` NT' x -> Int
forall x. NT' x -> Int
ntNum
instance Ord (NT' x) where compare :: NT' x -> NT' x -> Ordering
compare = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> (NT' x -> Int) -> NT' x -> NT' x -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` NT' x -> Int
forall x. NT' x -> Int
ntNum

type NTId = Int

-- Lenses
makeLenses ''Grammar'
makeLenses ''NTDef'

-- | Disregarding 'NTName', we can join non-terminal definitions.

instance (Show x, Eq x) => Semigroup (NTDef' x r t) where
  NTDef x
x [Alt' x r t]
alts <> :: NTDef' x r t -> NTDef' x r t -> NTDef' x r t
<> NTDef x
x' [Alt' x r t]
alts'
    | x
x x -> x -> Bool
forall a. Eq a => a -> a -> Bool
== x
x'   = x -> [Alt' x r t] -> NTDef' x r t
forall x r t. x -> [Alt' x r t] -> NTDef' x r t
NTDef x
x ([Alt' x r t] -> NTDef' x r t) -> [Alt' x r t] -> NTDef' x r t
forall a b. (a -> b) -> a -> b
$ [Alt' x r t]
alts [Alt' x r t] -> [Alt' x r t] -> [Alt' x r t]
forall a. [a] -> [a] -> [a]
++ [Alt' x r t]
alts'
    | Bool
otherwise = String -> NTDef' x r t
forall a. HasCallStack => String -> a
error (String -> NTDef' x r t) -> String -> NTDef' x r t
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
       [ String
"non-terminal names do not match:" ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (x -> String) -> [x] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map x -> String
forall a. Show a => a -> String
show [x
x, x
x']

-- ** Converting 'NTId' back to name.

-- | Decoration of something with a NT printing dictionary.

data WithNTNames x a = WithNTNames
  { forall x a. WithNTNames x a -> IntMap x
_wntNames :: IntMap x               -- ^ Number-to-names map for non-terminals.
  , forall x a. WithNTNames x a -> a
_wntThing :: a                      -- ^ The decorated thing.
  }

makeLenses ''WithNTNames

class GetNTNames x a where
  getNTNames :: a -> IntMap x

instance GetNTNames x (WithNTNames x a) where
  getNTNames :: WithNTNames x a -> IntMap x
getNTNames = (WithNTNames x a
-> Getting (IntMap x) (WithNTNames x a) (IntMap x) -> IntMap x
forall s a. s -> Getting a s a -> a
^. Getting (IntMap x) (WithNTNames x a) (IntMap x)
forall x a x (f :: * -> *).
Functor f =>
(IntMap x -> f (IntMap x))
-> WithNTNames x a -> f (WithNTNames x a)
wntNames)

instance GetNTNames x (Grammar' x r t) where
  getNTNames :: Grammar' x r t -> IntMap x
getNTNames Grammar' x r t
g = (NTDef' x r t -> Getting x (NTDef' x r t) x -> x
forall s a. s -> Getting a s a -> a
^. Getting x (NTDef' x r t) x
forall x r t (f :: * -> *).
Functor f =>
(x -> f x) -> NTDef' x r t -> f (NTDef' x r t)
ntName) (NTDef' x r t -> x) -> IntMap (NTDef' x r t) -> IntMap x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Grammar' x r t
g Grammar' x r t
-> Getting
     (IntMap (NTDef' x r t)) (Grammar' x r t) (IntMap (NTDef' x r t))
-> IntMap (NTDef' x r t)
forall s a. s -> Getting a s a -> a
^. Getting
  (IntMap (NTDef' x r t)) (Grammar' x r t) (IntMap (NTDef' x r t))
forall x r t r t (f :: * -> *).
Functor f =>
(IntMap (NTDef' x r t) -> f (IntMap (NTDef' x r t)))
-> Grammar' x r t -> f (Grammar' x r t)
grmNTDefs


-- * Generic grammar folds.

-- The class-based approach did not go well with Haskell's
-- instance inference.
--
-- class GrmAlg t a where
--   gaTerminal :: t -> a        -- ^ Single terminal.
--   gaZero     :: a             -- ^ Empty language.
--   gaPlus     :: a -> a -> a   -- ^ Language union.
--   gaEps      :: a             -- ^ Language of the empty word.
--   gaConcat   :: a -> a -> a   -- ^ Language concatenation.

-- class GrmFold t a b where
--   grmFold :: GrmAlg t a => (NT -> a) -> b -> a

-- | A grammar algebra provides an implementation for
--   the operations constituting CFGs.

data GrmAlg r t a = GrmAlg
  { forall r t a. GrmAlg r t a -> t -> a
gaTerminal :: t -> a        -- ^ Single terminal.
  , forall r t a. GrmAlg r t a -> a
gaZero     :: a             -- ^ Empty language.
  , forall r t a. GrmAlg r t a -> a -> a -> a
gaPlus     :: a -> a -> a   -- ^ Language union.
  , forall r t a. GrmAlg r t a -> a
gaEps      :: a             -- ^ Language of the empty word.
  , forall r t a. GrmAlg r t a -> a -> a -> a
gaConcat   :: a -> a -> a   -- ^ Language concatenation.
  , forall r t a. GrmAlg r t a -> r -> a -> a
gaLabel    :: r -> a -> a   -- ^ Labelled language.
  }

-- | @n@-ary concatenation, with a special case for empty concatenation.
gaProduct :: GrmAlg r t a -> [a] -> a
gaProduct :: forall r t a. GrmAlg r t a -> [a] -> a
gaProduct GrmAlg r t a
ga [] = GrmAlg r t a -> a
forall r t a. GrmAlg r t a -> a
gaEps GrmAlg r t a
ga
gaProduct GrmAlg r t a
ga [a]
as = (a -> a -> a) -> [a] -> a
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (GrmAlg r t a -> a -> a -> a
forall r t a. GrmAlg r t a -> a -> a -> a
gaConcat GrmAlg r t a
ga) [a]
as

-- | @n@-ary alternative, with a special case for empty language.
gaSum :: GrmAlg r t a -> [a] -> a
gaSum :: forall r t a. GrmAlg r t a -> [a] -> a
gaSum GrmAlg r t a
ga [] = GrmAlg r t a -> a
forall r t a. GrmAlg r t a -> a
gaZero GrmAlg r t a
ga
gaSum GrmAlg r t a
ga [a]
as = (a -> a -> a) -> [a] -> a
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (GrmAlg r t a -> a -> a -> a
forall r t a. GrmAlg r t a -> a -> a -> a
gaPlus GrmAlg r t a
ga) [a]
as

-- | Generic fold over a grammar.

class GrmFold r t a b where
  grmFold :: GrmAlg r t a -> (NTId -> a) -> b -> a

instance GrmFold r t a (NT' x) where
  grmFold :: GrmAlg r t a -> (Int -> a) -> NT' x -> a
grmFold GrmAlg r t a
ga Int -> a
env NT' x
x = Int -> a
env (Int -> a) -> Int -> a
forall a b. (a -> b) -> a -> b
$ NT' x -> Int
forall x. NT' x -> Int
ntNum NT' x
x

instance GrmFold r t a (Symbol' r' t) where
  grmFold :: GrmAlg r t a -> (Int -> a) -> Symbol' r' t -> a
grmFold GrmAlg r t a
ga Int -> a
env = \case
    Term t
t    -> GrmAlg r t a -> t -> a
forall r t a. GrmAlg r t a -> t -> a
gaTerminal GrmAlg r t a
ga t
t
    NonTerm NT' r'
x -> Int -> a
env (Int -> a) -> Int -> a
forall a b. (a -> b) -> a -> b
$ NT' r' -> Int
forall x. NT' x -> Int
ntNum NT' r'
x

instance GrmFold r t a (Form' r' t) where
  grmFold :: GrmAlg r t a -> (Int -> a) -> Form' r' t -> a
grmFold GrmAlg r t a
ga Int -> a
env (Form [Symbol' r' t]
alpha) = GrmAlg r t a -> [a] -> a
forall r t a. GrmAlg r t a -> [a] -> a
gaProduct GrmAlg r t a
ga ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ (Symbol' r' t -> a) -> [Symbol' r' t] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (GrmAlg r t a -> (Int -> a) -> Symbol' r' t -> a
forall r t a b.
GrmFold r t a b =>
GrmAlg r t a -> (Int -> a) -> b -> a
grmFold GrmAlg r t a
ga Int -> a
env) [Symbol' r' t]
alpha

instance GrmFold r t a (Alt' x r t) where
  grmFold :: GrmAlg r t a -> (Int -> a) -> Alt' x r t -> a
grmFold GrmAlg r t a
ga Int -> a
env (Alt r
r Form' x t
alpha) = GrmAlg r t a -> r -> a -> a
forall r t a. GrmAlg r t a -> r -> a -> a
gaLabel GrmAlg r t a
ga r
r (GrmAlg r t a -> (Int -> a) -> Form' x t -> a
forall r t a b.
GrmFold r t a b =>
GrmAlg r t a -> (Int -> a) -> b -> a
grmFold GrmAlg r t a
ga Int -> a
env Form' x t
alpha)

instance GrmFold r t a (NTDef' x r t) where
  grmFold :: GrmAlg r t a -> (Int -> a) -> NTDef' x r t -> a
grmFold GrmAlg r t a
ga Int -> a
env (NTDef x
_x [Alt' x r t]
alts) = GrmAlg r t a -> [a] -> a
forall r t a. GrmAlg r t a -> [a] -> a
gaSum GrmAlg r t a
ga ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ (Alt' x r t -> a) -> [Alt' x r t] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (GrmAlg r t a -> (Int -> a) -> Alt' x r t -> a
forall r t a b.
GrmFold r t a b =>
GrmAlg r t a -> (Int -> a) -> b -> a
grmFold GrmAlg r t a
ga Int -> a
env) [Alt' x r t]
alts


-- | Computing properties of non-terminals by saturation.
--   The iteration is needed to handle the recursion inherent in CFGs.
--   Requires a bounded lattice @a@.

grmIterate :: forall r t a x . (Eq a, Ord a)
  => GrmAlg r t a   -- ^ Grammar algebra.
  -> Grammar' x r t -- ^ Grammar.
  -> a              -- ^ Default/start value.
  -> Maybe a        -- ^ Best value (if it exists).
  -> IntMap a       -- ^ Final value for each non-terminal.
grmIterate :: forall r t a x.
(Eq a, Ord a) =>
GrmAlg r t a -> Grammar' x r t -> a -> Maybe a -> IntMap a
grmIterate GrmAlg r t a
ga grm :: Grammar' x r t
grm@(Grammar Int
n Map x Int
dict IntMap (NTDef' x r t)
defs) a
bot Maybe a
mtop
  = ((a, NTDef' x r t) -> a) -> IntMap (a, NTDef' x r t) -> IntMap a
forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map (a, NTDef' x r t) -> a
forall a b. (a, b) -> a
fst
  (IntMap (a, NTDef' x r t) -> IntMap a)
-> IntMap (a, NTDef' x r t) -> IntMap a
forall a b. (a -> b) -> a -> b
$ (IntMap (a, NTDef' x r t) -> Change (IntMap (a, NTDef' x r t)))
-> IntMap (a, NTDef' x r t) -> IntMap (a, NTDef' x r t)
forall a. (a -> Change a) -> a -> a
saturate (\ IntMap (a, NTDef' x r t)
gs -> (Int
 -> (a, NTDef' x r t) -> WriterT Any Identity (a, NTDef' x r t))
-> IntMap (a, NTDef' x r t) -> Change (IntMap (a, NTDef' x r t))
forall (t :: * -> *) a b.
Applicative t =>
(Int -> a -> t b) -> IntMap a -> t (IntMap b)
IntMap.traverseWithKey (IntMap (a, NTDef' x r t)
-> Int
-> (a, NTDef' x r t)
-> WriterT Any Identity (a, NTDef' x r t)
step IntMap (a, NTDef' x r t)
gs) IntMap (a, NTDef' x r t)
gs)
  (IntMap (a, NTDef' x r t) -> IntMap (a, NTDef' x r t))
-> IntMap (a, NTDef' x r t) -> IntMap (a, NTDef' x r t)
forall a b. (a -> b) -> a -> b
$ (NTDef' x r t -> (a, NTDef' x r t))
-> IntMap (NTDef' x r t) -> IntMap (a, NTDef' x r t)
forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map (a
bot,) IntMap (NTDef' x r t)
defs
  where
  step :: IntMap (a, NTDef' x r t)
       -> NTId
       -> (a, NTDef' x r t)
       -> Change (a, NTDef' x r t)
  step :: IntMap (a, NTDef' x r t)
-> Int
-> (a, NTDef' x r t)
-> WriterT Any Identity (a, NTDef' x r t)
step IntMap (a, NTDef' x r t)
gs Int
i d :: (a, NTDef' x r t)
d@(a
a, NTDef' x r t
def)
    | a -> Maybe a
forall a. a -> Maybe a
Just a
a Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe a
mtop, let a' :: a
a' = GrmAlg r t a -> (Int -> a) -> NTDef' x r t -> a
forall r t a b.
GrmFold r t a b =>
GrmAlg r t a -> (Int -> a) -> b -> a
grmFold GrmAlg r t a
ga Int -> a
env NTDef' x r t
def, a
a' a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
a = do
      Change ()
dirty  -- change!
      (a, NTDef' x r t) -> WriterT Any Identity (a, NTDef' x r t)
forall a. a -> WriterT Any Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a', NTDef' x r t
def)
    | Bool
otherwise = (a, NTDef' x r t) -> WriterT Any Identity (a, NTDef' x r t)
forall a. a -> WriterT Any Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (a, NTDef' x r t)
d  -- no change
    where
    env :: Int -> a
env Int
j = (a, NTDef' x r t) -> a
forall a b. (a, b) -> a
fst ((a, NTDef' x r t) -> a) -> (a, NTDef' x r t) -> a
forall a b. (a -> b) -> a -> b
$ (a, NTDef' x r t)
-> Int -> IntMap (a, NTDef' x r t) -> (a, NTDef' x r t)
forall a. a -> Int -> IntMap a -> a
IntMap.findWithDefault (String -> (a, NTDef' x r t)
forall a. HasCallStack => String -> a
error String
"grmIterate") Int
j IntMap (a, NTDef' x r t)
gs

-- * Guardedness.

newtype Guarded = Guarded { Guarded -> Bool
getGuarded :: Bool }
  deriving (Guarded -> Guarded -> Bool
(Guarded -> Guarded -> Bool)
-> (Guarded -> Guarded -> Bool) -> Eq Guarded
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Guarded -> Guarded -> Bool
== :: Guarded -> Guarded -> Bool
$c/= :: Guarded -> Guarded -> Bool
/= :: Guarded -> Guarded -> Bool
Eq, Eq Guarded
Eq Guarded =>
(Guarded -> Guarded -> Ordering)
-> (Guarded -> Guarded -> Bool)
-> (Guarded -> Guarded -> Bool)
-> (Guarded -> Guarded -> Bool)
-> (Guarded -> Guarded -> Bool)
-> (Guarded -> Guarded -> Guarded)
-> (Guarded -> Guarded -> Guarded)
-> Ord Guarded
Guarded -> Guarded -> Bool
Guarded -> Guarded -> Ordering
Guarded -> Guarded -> Guarded
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
$ccompare :: Guarded -> Guarded -> Ordering
compare :: Guarded -> Guarded -> Ordering
$c< :: Guarded -> Guarded -> Bool
< :: Guarded -> Guarded -> Bool
$c<= :: Guarded -> Guarded -> Bool
<= :: Guarded -> Guarded -> Bool
$c> :: Guarded -> Guarded -> Bool
> :: Guarded -> Guarded -> Bool
$c>= :: Guarded -> Guarded -> Bool
>= :: Guarded -> Guarded -> Bool
$cmax :: Guarded -> Guarded -> Guarded
max :: Guarded -> Guarded -> Guarded
$cmin :: Guarded -> Guarded -> Guarded
min :: Guarded -> Guarded -> Guarded
Ord, Int -> Guarded -> ShowS
[Guarded] -> ShowS
Guarded -> String
(Int -> Guarded -> ShowS)
-> (Guarded -> String) -> ([Guarded] -> ShowS) -> Show Guarded
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Guarded -> ShowS
showsPrec :: Int -> Guarded -> ShowS
$cshow :: Guarded -> String
show :: Guarded -> String
$cshowList :: [Guarded] -> ShowS
showList :: [Guarded] -> ShowS
Show, Guarded
Guarded -> Guarded -> Bounded Guarded
forall a. a -> a -> Bounded a
$cminBound :: Guarded
minBound :: Guarded
$cmaxBound :: Guarded
maxBound :: Guarded
Bounded) -- False < True

guardedAlg :: GrmAlg r t Guarded
guardedAlg :: forall r t. GrmAlg r t Guarded
guardedAlg = GrmAlg
  { gaTerminal :: t -> Guarded
gaTerminal = Guarded -> t -> Guarded
forall a b. a -> b -> a
const Guarded
forall a. Bounded a => a
maxBound  -- Yes. A terminal is guarded.
  , gaZero :: Guarded
gaZero     = Guarded
forall a. Bounded a => a
maxBound  -- Yes.  (A bit arbitrary, but consistent with gaPlus.)
  , gaPlus :: Guarded -> Guarded -> Guarded
gaPlus     = Guarded -> Guarded -> Guarded
forall a. Ord a => a -> a -> a
min       -- All alternatives need to be guarded.
  , gaEps :: Guarded
gaEps      = Guarded
forall a. Bounded a => a
maxBound  -- Empty language is guarded!  (Outlier!)
  , gaConcat :: Guarded -> Guarded -> Guarded
gaConcat   = Guarded -> Guarded -> Guarded
forall a. Ord a => a -> a -> a
max       -- One factor needs to be guarded.
  , gaLabel :: r -> Guarded -> Guarded
gaLabel    = (Guarded -> Guarded) -> r -> Guarded -> Guarded
forall a b. a -> b -> a
const Guarded -> Guarded
forall a. a -> a
id  -- Labels do not change the game.
  }

computeGuardedness :: Grammar' x r t -> IntMap Guarded
computeGuardedness :: forall x r t. Grammar' x r t -> IntMap Guarded
computeGuardedness Grammar' x r t
grm = GrmAlg r t Guarded
-> Grammar' x r t -> Guarded -> Maybe Guarded -> IntMap Guarded
forall r t a x.
(Eq a, Ord a) =>
GrmAlg r t a -> Grammar' x r t -> a -> Maybe a -> IntMap a
grmIterate GrmAlg r t Guarded
forall r t. GrmAlg r t Guarded
guardedAlg Grammar' x r t
grm Guarded
forall a. Bounded a => a
minBound (Guarded -> Maybe Guarded
forall a. a -> Maybe a
Just Guarded
forall a. Bounded a => a
maxBound)

-- * Nullability.

newtype Nullable = Nullable { Nullable -> Bool
getNullable :: Bool }
  deriving (Nullable -> Nullable -> Bool
(Nullable -> Nullable -> Bool)
-> (Nullable -> Nullable -> Bool) -> Eq Nullable
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Nullable -> Nullable -> Bool
== :: Nullable -> Nullable -> Bool
$c/= :: Nullable -> Nullable -> Bool
/= :: Nullable -> Nullable -> Bool
Eq, Eq Nullable
Eq Nullable =>
(Nullable -> Nullable -> Ordering)
-> (Nullable -> Nullable -> Bool)
-> (Nullable -> Nullable -> Bool)
-> (Nullable -> Nullable -> Bool)
-> (Nullable -> Nullable -> Bool)
-> (Nullable -> Nullable -> Nullable)
-> (Nullable -> Nullable -> Nullable)
-> Ord Nullable
Nullable -> Nullable -> Bool
Nullable -> Nullable -> Ordering
Nullable -> Nullable -> Nullable
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
$ccompare :: Nullable -> Nullable -> Ordering
compare :: Nullable -> Nullable -> Ordering
$c< :: Nullable -> Nullable -> Bool
< :: Nullable -> Nullable -> Bool
$c<= :: Nullable -> Nullable -> Bool
<= :: Nullable -> Nullable -> Bool
$c> :: Nullable -> Nullable -> Bool
> :: Nullable -> Nullable -> Bool
$c>= :: Nullable -> Nullable -> Bool
>= :: Nullable -> Nullable -> Bool
$cmax :: Nullable -> Nullable -> Nullable
max :: Nullable -> Nullable -> Nullable
$cmin :: Nullable -> Nullable -> Nullable
min :: Nullable -> Nullable -> Nullable
Ord, Int -> Nullable -> ShowS
[Nullable] -> ShowS
Nullable -> String
(Int -> Nullable -> ShowS)
-> (Nullable -> String) -> ([Nullable] -> ShowS) -> Show Nullable
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Nullable -> ShowS
showsPrec :: Int -> Nullable -> ShowS
$cshow :: Nullable -> String
show :: Nullable -> String
$cshowList :: [Nullable] -> ShowS
showList :: [Nullable] -> ShowS
Show, Nullable
Nullable -> Nullable -> Bounded Nullable
forall a. a -> a -> Bounded a
$cminBound :: Nullable
minBound :: Nullable
$cmaxBound :: Nullable
maxBound :: Nullable
Bounded) -- False < True

nullableAlg :: GrmAlg r t Nullable
nullableAlg :: forall r t. GrmAlg r t Nullable
nullableAlg = GrmAlg
  { gaTerminal :: t -> Nullable
gaTerminal = Nullable -> t -> Nullable
forall a b. a -> b -> a
const Nullable
forall a. Bounded a => a
minBound  -- No. A terminal is not nullable.
  , gaZero :: Nullable
gaZero     = Nullable
forall a. Bounded a => a
minBound  -- No.
  , gaPlus :: Nullable -> Nullable -> Nullable
gaPlus     = Nullable -> Nullable -> Nullable
forall a. Ord a => a -> a -> a
max       -- One alternative suffices.
  , gaEps :: Nullable
gaEps      = Nullable
forall a. Bounded a => a
maxBound  -- Yes. Empty language is exactly nullable.
  , gaConcat :: Nullable -> Nullable -> Nullable
gaConcat   = Nullable -> Nullable -> Nullable
forall a. Ord a => a -> a -> a
min       -- All factor must be nullable.
  , gaLabel :: r -> Nullable -> Nullable
gaLabel    = (Nullable -> Nullable) -> r -> Nullable -> Nullable
forall a b. a -> b -> a
const Nullable -> Nullable
forall a. a -> a
id  -- Labels do not change the game.
  }

computeNullable :: Grammar' x r t -> IntMap Nullable
computeNullable :: forall x r t. Grammar' x r t -> IntMap Nullable
computeNullable Grammar' x r t
grm = GrmAlg r t Nullable
-> Grammar' x r t -> Nullable -> Maybe Nullable -> IntMap Nullable
forall r t a x.
(Eq a, Ord a) =>
GrmAlg r t a -> Grammar' x r t -> a -> Maybe a -> IntMap a
grmIterate GrmAlg r t Nullable
forall r t. GrmAlg r t Nullable
nullableAlg Grammar' x r t
grm Nullable
forall a. Bounded a => a
minBound (Nullable -> Maybe Nullable
forall a. a -> Maybe a
Just Nullable
forall a. Bounded a => a
maxBound)


-- * First sets

newtype First t = First { forall t. First t -> SetMaybe t
getFirst :: SetMaybe t }
  deriving (First t -> First t -> Bool
(First t -> First t -> Bool)
-> (First t -> First t -> Bool) -> Eq (First t)
forall t. Eq t => First t -> First t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall t. Eq t => First t -> First t -> Bool
== :: First t -> First t -> Bool
$c/= :: forall t. Eq t => First t -> First t -> Bool
/= :: First t -> First t -> Bool
Eq, Eq (First t)
Eq (First t) =>
(First t -> First t -> Ordering)
-> (First t -> First t -> Bool)
-> (First t -> First t -> Bool)
-> (First t -> First t -> Bool)
-> (First t -> First t -> Bool)
-> (First t -> First t -> First t)
-> (First t -> First t -> First t)
-> Ord (First t)
First t -> First t -> Bool
First t -> First t -> Ordering
First t -> First t -> First t
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall t. Ord t => Eq (First t)
forall t. Ord t => First t -> First t -> Bool
forall t. Ord t => First t -> First t -> Ordering
forall t. Ord t => First t -> First t -> First t
$ccompare :: forall t. Ord t => First t -> First t -> Ordering
compare :: First t -> First t -> Ordering
$c< :: forall t. Ord t => First t -> First t -> Bool
< :: First t -> First t -> Bool
$c<= :: forall t. Ord t => First t -> First t -> Bool
<= :: First t -> First t -> Bool
$c> :: forall t. Ord t => First t -> First t -> Bool
> :: First t -> First t -> Bool
$c>= :: forall t. Ord t => First t -> First t -> Bool
>= :: First t -> First t -> Bool
$cmax :: forall t. Ord t => First t -> First t -> First t
max :: First t -> First t -> First t
$cmin :: forall t. Ord t => First t -> First t -> First t
min :: First t -> First t -> First t
Ord, Int -> First t -> ShowS
[First t] -> ShowS
First t -> String
(Int -> First t -> ShowS)
-> (First t -> String) -> ([First t] -> ShowS) -> Show (First t)
forall t. Show t => Int -> First t -> ShowS
forall t. Show t => [First t] -> ShowS
forall t. Show t => First t -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall t. Show t => Int -> First t -> ShowS
showsPrec :: Int -> First t -> ShowS
$cshow :: forall t. Show t => First t -> String
show :: First t -> String
$cshowList :: forall t. Show t => [First t] -> ShowS
showList :: [First t] -> ShowS
Show)

-- | Rules to compute first sets.
--
--   FIRST(a)   = {a}
--   FIRST(ε)   = {ε}
--   FIRST(αβ)  = FIRST(α) ∪ (NULLABLE(α) ⇒ FIRST(β))
--   FIRST(α+β) = FIRST(α) ∪ FIRST(β)

firstAlg :: Ord t => GrmAlg r t (First t)
firstAlg :: forall t r. Ord t => GrmAlg r t (First t)
firstAlg = GrmAlg
  { gaTerminal :: t -> First t
gaTerminal = SetMaybe t -> First t
forall t. SetMaybe t -> First t
First (SetMaybe t -> First t) -> (t -> SetMaybe t) -> t -> First t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe t -> SetMaybe t
forall t. Maybe t -> SetMaybe t
SetMaybe.singleton (Maybe t -> SetMaybe t) -> (t -> Maybe t) -> t -> SetMaybe t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Maybe t
forall a. a -> Maybe a
Just
  , gaEps :: First t
gaEps      = SetMaybe t -> First t
forall t. SetMaybe t -> First t
First (SetMaybe t -> First t) -> SetMaybe t -> First t
forall a b. (a -> b) -> a -> b
$ Maybe t -> SetMaybe t
forall t. Maybe t -> SetMaybe t
SetMaybe.singleton Maybe t
forall a. Maybe a
Nothing
  , gaZero :: First t
gaZero     = SetMaybe t -> First t
forall t. SetMaybe t -> First t
First (SetMaybe t -> First t) -> SetMaybe t -> First t
forall a b. (a -> b) -> a -> b
$ SetMaybe t
forall t. SetMaybe t
SetMaybe.empty
  , gaPlus :: First t -> First t -> First t
gaPlus     = \ (First SetMaybe t
s) (First SetMaybe t
s') -> SetMaybe t -> First t
forall t. SetMaybe t -> First t
First (SetMaybe t -> First t) -> SetMaybe t -> First t
forall a b. (a -> b) -> a -> b
$ SetMaybe t -> SetMaybe t -> SetMaybe t
forall t. Ord t => SetMaybe t -> SetMaybe t -> SetMaybe t
SetMaybe.union SetMaybe t
s SetMaybe t
s'
  , gaConcat :: First t -> First t -> First t
gaConcat   = First t -> First t -> First t
forall t. Ord t => First t -> First t -> First t
concatFirst
  , gaLabel :: r -> First t -> First t
gaLabel    = (First t -> First t) -> r -> First t -> First t
forall a b. a -> b -> a
const First t -> First t
forall a. a -> a
id
  }

-- | Empty FIRST set.

emptyFirst :: First t
emptyFirst :: forall t. First t
emptyFirst = SetMaybe t -> First t
forall t. SetMaybe t -> First t
First (SetMaybe t -> First t) -> SetMaybe t -> First t
forall a b. (a -> b) -> a -> b
$ SetMaybe t
forall t. SetMaybe t
SetMaybe.empty

-- |  FIRST(αβ)  = FIRST(α) ∪ (NULLABLE(α) ⇒ FIRST(β)).

concatFirst :: Ord t => First t -> First t -> First t
concatFirst :: forall t. Ord t => First t -> First t -> First t
concatFirst (First SetMaybe t
s) (First SetMaybe t
s')
  | Maybe t -> SetMaybe t -> Bool
forall t. Ord t => Maybe t -> SetMaybe t -> Bool
SetMaybe.member Maybe t
forall a. Maybe a
Nothing SetMaybe t
s = SetMaybe t -> First t
forall t. SetMaybe t -> First t
First (SetMaybe t -> First t) -> SetMaybe t -> First t
forall a b. (a -> b) -> a -> b
$ SetMaybe t -> SetMaybe t -> SetMaybe t
forall t. Ord t => SetMaybe t -> SetMaybe t -> SetMaybe t
SetMaybe.union SetMaybe t
s SetMaybe t
s'
  | Bool
otherwise                 = SetMaybe t -> First t
forall t. SetMaybe t -> First t
First SetMaybe t
s

-- | FIRST sets for all non-terminals.

type FirstSets t = IntMap (First t)

-- | Compute FIRST sets for all non-terminals.

computeFirst :: Ord t => Grammar' x r t -> FirstSets t
computeFirst :: forall t x r. Ord t => Grammar' x r t -> FirstSets t
computeFirst Grammar' x r t
grm = GrmAlg r t (First t)
-> Grammar' x r t -> First t -> Maybe (First t) -> IntMap (First t)
forall r t a x.
(Eq a, Ord a) =>
GrmAlg r t a -> Grammar' x r t -> a -> Maybe a -> IntMap a
grmIterate GrmAlg r t (First t)
forall t r. Ord t => GrmAlg r t (First t)
firstAlg Grammar' x r t
grm First t
forall t. First t
emptyFirst Maybe (First t)
forall a. Maybe a
Nothing

-- Ambiguous: r
-- firstSet :: (GrmFold r t (First t) b, Ord t) => FirstSets t -> b -> First t
firstSet :: (Ord t) => FirstSets t -> Form' r t -> First t
firstSet :: forall t r. Ord t => FirstSets t -> Form' r t -> First t
firstSet FirstSets t
fs = GrmAlg (ZonkAny 0) t (First t)
-> (Int -> First t) -> Form' r t -> First t
forall r t a b.
GrmFold r t a b =>
GrmAlg r t a -> (Int -> a) -> b -> a
grmFold GrmAlg (ZonkAny 0) t (First t)
forall t r. Ord t => GrmAlg r t (First t)
firstAlg (\ Int
x -> First t -> Int -> FirstSets t -> First t
forall a. a -> Int -> IntMap a -> a
IntMap.findWithDefault First t
forall {b}. b
err Int
x FirstSets t
fs)
  where
  err :: b
err = String -> b
forall a. HasCallStack => String -> a
error (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$ String
"CFG.firstSet: undefined nonterminal"


-- | Enriched grammar.

data EGrammar' x r t = EGrammar
  { forall x r t. EGrammar' x r t -> Grammar' x r t
_eGrm   :: Grammar' x r t   -- ^ CFG.
  , forall x r t. EGrammar' x r t -> NT' x
_eStart :: NT' x            -- ^ Start symbol.
  , forall x r t. EGrammar' x r t -> FirstSets t
_eFirst :: FirstSets t      -- ^ Precomputed FIRST sets.
  }
makeLenses ''EGrammar'

makeEGrammar :: Ord t => Grammar' x r t -> NT' x -> EGrammar' x r t
makeEGrammar :: forall t x r. Ord t => Grammar' x r t -> NT' x -> EGrammar' x r t
makeEGrammar Grammar' x r t
grm NT' x
start = Grammar' x r t -> NT' x -> FirstSets t -> EGrammar' x r t
forall x r t.
Grammar' x r t -> NT' x -> FirstSets t -> EGrammar' x r t
EGrammar Grammar' x r t
grm NT' x
start (FirstSets t -> EGrammar' x r t) -> FirstSets t -> EGrammar' x r t
forall a b. (a -> b) -> a -> b
$ Grammar' x r t -> FirstSets t
forall t x r. Ord t => Grammar' x r t -> FirstSets t
computeFirst Grammar' x r t
grm

instance GetNTNames x (EGrammar' x r t) where
  getNTNames :: EGrammar' x r t -> IntMap x
getNTNames = Grammar' x r t -> IntMap x
forall x a. GetNTNames x a => a -> IntMap x
getNTNames (Grammar' x r t -> IntMap x)
-> (EGrammar' x r t -> Grammar' x r t)
-> EGrammar' x r t
-> IntMap x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EGrammar' x r t -> Grammar' x r t
forall x r t. EGrammar' x r t -> Grammar' x r t
_eGrm