-- | Productivity of productions in the grammar.
{-# LANGUAGE ScopedTypeVariables #-}

module Data.Cfg.Productive
  ( productives
  , unproductives
  , removeUnproductives
  ) where

import Control.Monad (guard, unless)
import Data.Cfg.Cfg (Cfg(..), Production, V(..), Vs, productions)
import Data.Cfg.FixedPoint (fixedPoint)
import Data.Cfg.FreeCfg (FreeCfg(..))
import qualified Data.Set as S

-- | Returns the productive productions of this grammar.
productives ::
     forall cfg t nt. (Cfg cfg t nt, Ord nt, Ord t)
  => cfg t nt
  -> S.Set (Production t nt)
productives :: cfg t nt -> Set (Production t nt)
productives cfg t nt
cfg =
  [Production t nt] -> Set (Production t nt)
forall a. Ord a => [a] -> Set a
S.fromList ([Production t nt] -> Set (Production t nt))
-> [Production t nt] -> Set (Production t nt)
forall a b. (a -> b) -> a -> b
$ (Production t nt -> Bool) -> [Production t nt] -> [Production t nt]
forall a. (a -> Bool) -> [a] -> [a]
filter (Set nt -> Production t nt -> Bool
forall t nt. Ord nt => Set nt -> Production t nt -> Bool
isProductiveProduction Set nt
productiveNTs) ([Production t nt] -> [Production t nt])
-> [Production t nt] -> [Production t nt]
forall a b. (a -> b) -> a -> b
$ cfg t nt -> [Production t nt]
forall (cfg :: * -> * -> *) t nt.
Cfg cfg t nt =>
cfg t nt -> [Production t nt]
productions cfg t nt
cfg
  where
    productiveNTs :: S.Set nt
    productiveNTs :: Set nt
productiveNTs = cfg t nt -> Set nt
forall (cfg :: * -> * -> *) t nt.
(Cfg cfg t nt, Ord nt, Ord t) =>
cfg t nt -> Set nt
productiveNonterminals cfg t nt
cfg

-- | Returns the unproductive productions of this grammar.
unproductives ::
     forall cfg t nt. (Cfg cfg t nt, Ord nt, Ord t)
  => cfg t nt
  -> S.Set (Production t nt)
unproductives :: cfg t nt -> Set (Production t nt)
unproductives cfg t nt
cfg = [Production t nt] -> Set (Production t nt)
forall a. Ord a => [a] -> Set a
S.fromList (cfg t nt -> [Production t nt]
forall (cfg :: * -> * -> *) t nt.
Cfg cfg t nt =>
cfg t nt -> [Production t nt]
productions cfg t nt
cfg) Set (Production t nt)
-> Set (Production t nt) -> Set (Production t nt)
forall a. Ord a => Set a -> Set a -> Set a
S.\\ cfg t nt -> Set (Production t nt)
forall (cfg :: * -> * -> *) t nt.
(Cfg cfg t nt, Ord nt, Ord t) =>
cfg t nt -> Set (Production t nt)
productives cfg t nt
cfg

-- | Returns an equivalent grammar not including unproductive
-- productions.
removeUnproductives ::
     forall cfg t nt. (Cfg cfg t nt, Ord nt, Ord t)
  => cfg t nt
  -> FreeCfg t nt
removeUnproductives :: cfg t nt -> FreeCfg t nt
removeUnproductives cfg t nt
cfg =
  FreeCfg :: forall t nt.
Set nt -> Set t -> (nt -> Set (Vs t nt)) -> nt -> FreeCfg t nt
FreeCfg
    { terminals' :: Set t
terminals' = cfg t nt -> Set t
forall (cfg :: * -> * -> *) t nt. Cfg cfg t nt => cfg t nt -> Set t
terminals cfg t nt
cfg
    , startSymbol' :: nt
startSymbol' = cfg t nt -> nt
forall (cfg :: * -> * -> *) t nt. Cfg cfg t nt => cfg t nt -> nt
startSymbol cfg t nt
cfg
    , nonterminals' :: Set nt
nonterminals' = Set nt
nts
    , productionRules' :: nt -> Set (Vs t nt)
productionRules' = nt -> Set (Vs t nt)
rules
    }
  where
    nts :: S.Set nt
    nts :: Set nt
nts = cfg t nt -> Set nt
forall (cfg :: * -> * -> *) t nt.
(Cfg cfg t nt, Ord nt, Ord t) =>
cfg t nt -> Set nt
productiveNonterminals cfg t nt
cfg
    rules :: nt -> S.Set (Vs t nt)
    rules :: nt -> Set (Vs t nt)
rules nt
nt =
      if nt
nt nt -> Set nt -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set nt
nts
        then (Vs t nt -> Bool) -> Set (Vs t nt) -> Set (Vs t nt)
forall a. (a -> Bool) -> Set a -> Set a
S.filter (Set nt -> Vs t nt -> Bool
forall t nt. Ord nt => Set nt -> Vs t nt -> Bool
isProductiveVs Set nt
nts) (Set (Vs t nt) -> Set (Vs t nt)) -> Set (Vs t nt) -> Set (Vs t nt)
forall a b. (a -> b) -> a -> b
$ cfg t nt -> nt -> Set (Vs t nt)
forall (cfg :: * -> * -> *) t nt.
Cfg cfg t nt =>
cfg t nt -> nt -> Set (Vs t nt)
productionRules cfg t nt
cfg nt
nt
        else Set (Vs t nt)
forall a. Set a
S.empty

-- | Returns the productive nonterminals of the grammar
productiveNonterminals ::
     forall cfg t nt. (Cfg cfg t nt, Ord nt, Ord t)
  => cfg t nt
  -> S.Set nt
productiveNonterminals :: cfg t nt -> Set nt
productiveNonterminals cfg t nt
cfg = (Set nt -> Set nt) -> Set nt -> Set nt
forall a. Eq a => (a -> a) -> a -> a
fixedPoint Set nt -> Set nt
f Set nt
forall a. Set a
S.empty
  where
    f :: S.Set nt -> S.Set nt
    f :: Set nt -> Set nt
f Set nt
productiveNTs =
      [nt] -> Set nt
forall a. Ord a => [a] -> Set a
S.fromList ([nt] -> Set nt) -> [nt] -> Set nt
forall a b. (a -> b) -> a -> b
$ do
        nt
nt <- Set nt -> [nt]
forall a. Set a -> [a]
S.toList (Set nt -> [nt]) -> Set nt -> [nt]
forall a b. (a -> b) -> a -> b
$ cfg t nt -> Set nt
forall (cfg :: * -> * -> *) t nt.
Cfg cfg t nt =>
cfg t nt -> Set nt
nonterminals cfg t nt
cfg
        Bool -> [()] -> [()]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (nt
nt nt -> Set nt -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set nt
productiveNTs) ([()] -> [()]) -> [()] -> [()]
forall a b. (a -> b) -> a -> b
$ do
          let rhss :: Set (Vs t nt)
rhss = cfg t nt -> nt -> Set (Vs t nt)
forall (cfg :: * -> * -> *) t nt.
Cfg cfg t nt =>
cfg t nt -> nt -> Set (Vs t nt)
productionRules cfg t nt
cfg nt
nt
          Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ((Vs t nt -> Bool) -> [Vs t nt] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Set nt -> Vs t nt -> Bool
forall t nt. Ord nt => Set nt -> Vs t nt -> Bool
isProductiveVs Set nt
productiveNTs) ([Vs t nt] -> Bool) -> [Vs t nt] -> Bool
forall a b. (a -> b) -> a -> b
$ Set (Vs t nt) -> [Vs t nt]
forall a. Set a -> [a]
S.toList Set (Vs t nt)
rhss)
        nt -> [nt]
forall (m :: * -> *) a. Monad m => a -> m a
return nt
nt

isProductiveProduction ::
     forall t nt. (Ord nt)
  => S.Set nt
  -> Production t nt
  -> Bool
isProductiveProduction :: Set nt -> Production t nt -> Bool
isProductiveProduction Set nt
productiveNTs (nt
hd, Vs t nt
rhs) =
  nt
hd nt -> Set nt -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set nt
productiveNTs Bool -> Bool -> Bool
&& Set nt -> Vs t nt -> Bool
forall t nt. Ord nt => Set nt -> Vs t nt -> Bool
isProductiveVs Set nt
productiveNTs Vs t nt
rhs

-- | Given a set of known productive nonterminals, is the vocabulary
-- symbol productive?
isProductiveVs ::
     forall t nt. (Ord nt)
  => S.Set nt
  -> Vs t nt
  -> Bool
isProductiveVs :: Set nt -> Vs t nt -> Bool
isProductiveVs Set nt
productiveNTs = (V t nt -> Bool) -> Vs t nt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all V t nt -> Bool
isProductiveV
  where
    isProductiveV :: V t nt -> Bool
    isProductiveV :: V t nt -> Bool
isProductiveV V t nt
v =
      case V t nt
v of
        NT nt
nt -> nt
nt nt -> Set nt -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set nt
productiveNTs
        V t nt
_ -> Bool
True