-- | Results of application of the production rules of a grammar.
{-# LANGUAGE ScopedTypeVariables #-}

module Data.Cfg.RuleApplication
  ( language
  , yields
  , directlyYields
  ) where

import Control.Monad (msum)
import Control.Monad.Omega
import Data.Cfg.Cfg
import qualified Data.DList as DL
import qualified Data.Map.Strict as M
import qualified Data.Set as S

-- | Given a grammar and a string of symbols, returns the strings
-- yielded by application of a production rule; that is, by expanding
-- one nonterminal in the string.
directlyYields :: (Cfg cfg t nt) => cfg t nt -> Vs t nt -> [Vs t nt]
directlyYields :: cfg t nt -> Vs t nt -> [Vs t nt]
directlyYields cfg t nt
cfg Vs t nt
vs = do
  Int
i <- [Int
0 .. Vs t nt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Vs t nt
vs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
  let (Vs t nt
pre, NT nt
nt:Vs t nt
post) = Int -> Vs t nt -> (Vs t nt, Vs t nt)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i Vs t nt
vs
  Vs t nt
expansion <- Set (Vs t nt) -> [Vs t nt]
forall a. Set a -> [a]
S.toList (Set (Vs t nt) -> [Vs t nt]) -> Set (Vs t nt) -> [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
  Vs t nt -> [Vs t nt]
forall (m :: * -> *) a. Monad m => a -> m a
return (Vs t nt
pre Vs t nt -> Vs t nt -> Vs t nt
forall a. [a] -> [a] -> [a]
++ Vs t nt
expansion Vs t nt -> Vs t nt -> Vs t nt
forall a. [a] -> [a] -> [a]
++ Vs t nt
post)

-- | Given a grammar, returns all strings yielded by application of
-- production rules.
yields ::
     forall cfg t nt. (Cfg cfg t nt, Ord nt)
  => cfg t nt
  -> [Vs t nt]
yields :: cfg t nt -> [Vs t nt]
yields cfg t nt
cfg = (DList (V t nt) -> Vs t nt) -> [DList (V t nt)] -> [Vs t nt]
forall a b. (a -> b) -> [a] -> [b]
map DList (V t nt) -> Vs t nt
forall a. DList a -> [a]
DL.toList ([DList (V t nt)] -> [Vs t nt]) -> [DList (V t nt)] -> [Vs t nt]
forall a b. (a -> b) -> a -> b
$ Omega (DList (V t nt)) -> [DList (V t nt)]
forall a. Omega a -> [a]
runOmega (Omega (DList (V t nt)) -> [DList (V t nt)])
-> Omega (DList (V t nt)) -> [DList (V t nt)]
forall a b. (a -> b) -> a -> b
$ nt -> Omega (DList (V t nt))
yieldNT (cfg t nt -> nt
forall (cfg :: * -> * -> *) t nt. Cfg cfg t nt => cfg t nt -> nt
startSymbol cfg t nt
cfg)
  where
    yieldNT :: nt -> Omega (DL.DList (V t nt))
    yieldNT :: nt -> Omega (DList (V t nt))
yieldNT nt
nt = Map nt (Omega (DList (V t nt)))
memoMap Map nt (Omega (DList (V t nt))) -> nt -> Omega (DList (V t nt))
forall k a. Ord k => Map k a -> k -> a
M.! nt
nt
      where
        memoMap :: M.Map nt (Omega (DL.DList (V t nt)))
        memoMap :: Map nt (Omega (DList (V t nt)))
memoMap =
          [(nt, Omega (DList (V t nt)))] -> Map nt (Omega (DList (V t nt)))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(nt
nt', nt -> Omega (DList (V t nt))
yieldNT' nt
nt') | 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]
        yieldNT' :: nt -> Omega (DL.DList (V t nt))
        yieldNT' :: nt -> Omega (DList (V t nt))
yieldNT' nt
nt' = [Omega (DList (V t nt))] -> Omega (DList (V t nt))
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum (DList (V t nt) -> Omega (DList (V t nt))
forall (m :: * -> *) a. Monad m => a -> m a
return (V t nt -> DList (V t nt)
forall a. a -> DList a
DL.singleton (nt -> V t nt
forall t nt. nt -> V t nt
NT nt
nt')) Omega (DList (V t nt))
-> [Omega (DList (V t nt))] -> [Omega (DList (V t nt))]
forall a. a -> [a] -> [a]
: (Vs t nt -> Omega (DList (V t nt)))
-> [Vs t nt] -> [Omega (DList (V t nt))]
forall a b. (a -> b) -> [a] -> [b]
map Vs t nt -> Omega (DList (V t nt))
yieldVs [Vs t nt]
rhss)
          where
            rhss :: [Vs t nt]
rhss = Set (Vs t nt) -> [Vs t nt]
forall a. Set a -> [a]
S.toList (Set (Vs t nt) -> [Vs t nt]) -> Set (Vs t nt) -> [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'
        yieldV :: V t nt -> Omega (DL.DList (V t nt))
        yieldV :: V t nt -> Omega (DList (V t nt))
yieldV V t nt
v =
          case V t nt
v of
            NT nt
nt' -> nt -> Omega (DList (V t nt))
yieldNT nt
nt'
            V t nt
t -> DList (V t nt) -> Omega (DList (V t nt))
forall (m :: * -> *) a. Monad m => a -> m a
return (DList (V t nt) -> Omega (DList (V t nt)))
-> DList (V t nt) -> Omega (DList (V t nt))
forall a b. (a -> b) -> a -> b
$ V t nt -> DList (V t nt)
forall a. a -> DList a
DL.singleton V t nt
t
        yieldVs :: Vs t nt -> Omega (DL.DList (V t nt))
        yieldVs :: Vs t nt -> Omega (DList (V t nt))
yieldVs = ([DList (V t nt)] -> DList (V t nt))
-> Omega [DList (V t nt)] -> Omega (DList (V t nt))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [DList (V t nt)] -> DList (V t nt)
forall a. [DList a] -> DList a
DL.concat (Omega [DList (V t nt)] -> Omega (DList (V t nt)))
-> (Vs t nt -> Omega [DList (V t nt)])
-> Vs t nt
-> Omega (DList (V t nt))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (V t nt -> Omega (DList (V t nt)))
-> Vs t nt -> Omega [DList (V t nt)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM V t nt -> Omega (DList (V t nt))
yieldV

-- NOTE: you shouldn't get symbol strings repeating if the grammar is
-- unambiguous.
-- | Given a grammar, returns all strings of terminals yielded by
-- application of the production rules to the start symbol.  This is
-- the /language/ of the grammar.
language :: (Cfg cfg t nt, Ord nt) => cfg t nt -> [Vs t nt]-- TODO There's certainly a more efficient way to do this.
language :: cfg t nt -> [Vs t nt]
language = (Vs t nt -> Bool) -> [Vs t nt] -> [Vs t nt]
forall a. (a -> Bool) -> [a] -> [a]
filter ((V t nt -> Bool) -> Vs t nt -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all V t nt -> Bool
forall t nt. V t nt -> Bool
isT) ([Vs t nt] -> [Vs t nt])
-> (cfg t nt -> [Vs t nt]) -> cfg t nt -> [Vs t nt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. cfg t nt -> [Vs t nt]
forall (cfg :: * -> * -> *) t nt.
(Cfg cfg t nt, Ord nt) =>
cfg t nt -> [Vs t nt]
yields