context-free-grammar-0.1.1: src/Data/Cfg/Productive.hs

-- | 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 =
  S.fromList $ filter (isProductiveProduction productiveNTs) $ productions cfg
  where
    productiveNTs :: S.Set nt
    productiveNTs = productiveNonterminals 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 = S.fromList (productions cfg) S.\\ productives 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 =
  FreeCfg
    { terminals' = terminals cfg
    , startSymbol' = startSymbol cfg
    , nonterminals' = nts
    , productionRules' = rules
    }
  where
    nts :: S.Set nt
    nts = productiveNonterminals cfg
    rules :: nt -> S.Set (Vs t nt)
    rules nt =
      if nt `S.member` nts
        then S.filter (isProductiveVs nts) $ productionRules cfg nt
        else 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 = fixedPoint f S.empty
  where
    f :: S.Set nt -> S.Set nt
    f productiveNTs =
      S.fromList $ do
        nt <- S.toList $ nonterminals cfg
        unless (nt `S.member` productiveNTs) $ do
          let rhss = productionRules cfg nt
          guard (any (isProductiveVs productiveNTs) $ S.toList rhss)
        return nt

isProductiveProduction ::
     forall t nt. (Ord nt)
  => S.Set nt
  -> Production t nt
  -> Bool
isProductiveProduction productiveNTs (hd, rhs) =
  hd `S.member` productiveNTs && isProductiveVs productiveNTs 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 productiveNTs = all isProductiveV
  where
    isProductiveV :: V t nt -> Bool
    isProductiveV v =
      case v of
        NT nt -> nt `S.member` productiveNTs
        _ -> True