-- | Augmented grammars.
{-# LANGUAGE ScopedTypeVariables #-}

module Data.Cfg.Augment
  ( -- * Augmenting grammars
  augmentCfg
    -- * Augmenting symbols
  , AugNT(..)
  , AugT(..)
    -- * Type synonyms
  , AugV
  , AugVs
  , AugProduction
  , AugFreeCfg
  ) where

import Data.Cfg.Cfg (Cfg(..), Production, V(..), Vs)
import Data.Cfg.FreeCfg (FreeCfg(..))
import qualified Data.Set as S

-- | Nonterminal symbols augmented with a special 'StartSymbol'
data AugNT nt
  = StartSymbol
  | AugNT nt
  deriving (AugNT nt -> AugNT nt -> Bool
(AugNT nt -> AugNT nt -> Bool)
-> (AugNT nt -> AugNT nt -> Bool) -> Eq (AugNT nt)
forall nt. Eq nt => AugNT nt -> AugNT nt -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AugNT nt -> AugNT nt -> Bool
$c/= :: forall nt. Eq nt => AugNT nt -> AugNT nt -> Bool
== :: AugNT nt -> AugNT nt -> Bool
$c== :: forall nt. Eq nt => AugNT nt -> AugNT nt -> Bool
Eq, Eq (AugNT nt)
Eq (AugNT nt)
-> (AugNT nt -> AugNT nt -> Ordering)
-> (AugNT nt -> AugNT nt -> Bool)
-> (AugNT nt -> AugNT nt -> Bool)
-> (AugNT nt -> AugNT nt -> Bool)
-> (AugNT nt -> AugNT nt -> Bool)
-> (AugNT nt -> AugNT nt -> AugNT nt)
-> (AugNT nt -> AugNT nt -> AugNT nt)
-> Ord (AugNT nt)
AugNT nt -> AugNT nt -> Bool
AugNT nt -> AugNT nt -> Ordering
AugNT nt -> AugNT nt -> AugNT nt
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 nt. Ord nt => Eq (AugNT nt)
forall nt. Ord nt => AugNT nt -> AugNT nt -> Bool
forall nt. Ord nt => AugNT nt -> AugNT nt -> Ordering
forall nt. Ord nt => AugNT nt -> AugNT nt -> AugNT nt
min :: AugNT nt -> AugNT nt -> AugNT nt
$cmin :: forall nt. Ord nt => AugNT nt -> AugNT nt -> AugNT nt
max :: AugNT nt -> AugNT nt -> AugNT nt
$cmax :: forall nt. Ord nt => AugNT nt -> AugNT nt -> AugNT nt
>= :: AugNT nt -> AugNT nt -> Bool
$c>= :: forall nt. Ord nt => AugNT nt -> AugNT nt -> Bool
> :: AugNT nt -> AugNT nt -> Bool
$c> :: forall nt. Ord nt => AugNT nt -> AugNT nt -> Bool
<= :: AugNT nt -> AugNT nt -> Bool
$c<= :: forall nt. Ord nt => AugNT nt -> AugNT nt -> Bool
< :: AugNT nt -> AugNT nt -> Bool
$c< :: forall nt. Ord nt => AugNT nt -> AugNT nt -> Bool
compare :: AugNT nt -> AugNT nt -> Ordering
$ccompare :: forall nt. Ord nt => AugNT nt -> AugNT nt -> Ordering
$cp1Ord :: forall nt. Ord nt => Eq (AugNT nt)
Ord, Int -> AugNT nt -> ShowS
[AugNT nt] -> ShowS
AugNT nt -> String
(Int -> AugNT nt -> ShowS)
-> (AugNT nt -> String) -> ([AugNT nt] -> ShowS) -> Show (AugNT nt)
forall nt. Show nt => Int -> AugNT nt -> ShowS
forall nt. Show nt => [AugNT nt] -> ShowS
forall nt. Show nt => AugNT nt -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AugNT nt] -> ShowS
$cshowList :: forall nt. Show nt => [AugNT nt] -> ShowS
show :: AugNT nt -> String
$cshow :: forall nt. Show nt => AugNT nt -> String
showsPrec :: Int -> AugNT nt -> ShowS
$cshowsPrec :: forall nt. Show nt => Int -> AugNT nt -> ShowS
Show)

-- | Terminal symbols augmented with a special end-of-file symbol
data AugT t
  = EOF
  | AugT t
  deriving (AugT t -> AugT t -> Bool
(AugT t -> AugT t -> Bool)
-> (AugT t -> AugT t -> Bool) -> Eq (AugT t)
forall t. Eq t => AugT t -> AugT t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AugT t -> AugT t -> Bool
$c/= :: forall t. Eq t => AugT t -> AugT t -> Bool
== :: AugT t -> AugT t -> Bool
$c== :: forall t. Eq t => AugT t -> AugT t -> Bool
Eq, Eq (AugT t)
Eq (AugT t)
-> (AugT t -> AugT t -> Ordering)
-> (AugT t -> AugT t -> Bool)
-> (AugT t -> AugT t -> Bool)
-> (AugT t -> AugT t -> Bool)
-> (AugT t -> AugT t -> Bool)
-> (AugT t -> AugT t -> AugT t)
-> (AugT t -> AugT t -> AugT t)
-> Ord (AugT t)
AugT t -> AugT t -> Bool
AugT t -> AugT t -> Ordering
AugT t -> AugT t -> AugT 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 (AugT t)
forall t. Ord t => AugT t -> AugT t -> Bool
forall t. Ord t => AugT t -> AugT t -> Ordering
forall t. Ord t => AugT t -> AugT t -> AugT t
min :: AugT t -> AugT t -> AugT t
$cmin :: forall t. Ord t => AugT t -> AugT t -> AugT t
max :: AugT t -> AugT t -> AugT t
$cmax :: forall t. Ord t => AugT t -> AugT t -> AugT t
>= :: AugT t -> AugT t -> Bool
$c>= :: forall t. Ord t => AugT t -> AugT t -> Bool
> :: AugT t -> AugT t -> Bool
$c> :: forall t. Ord t => AugT t -> AugT t -> Bool
<= :: AugT t -> AugT t -> Bool
$c<= :: forall t. Ord t => AugT t -> AugT t -> Bool
< :: AugT t -> AugT t -> Bool
$c< :: forall t. Ord t => AugT t -> AugT t -> Bool
compare :: AugT t -> AugT t -> Ordering
$ccompare :: forall t. Ord t => AugT t -> AugT t -> Ordering
$cp1Ord :: forall t. Ord t => Eq (AugT t)
Ord, Int -> AugT t -> ShowS
[AugT t] -> ShowS
AugT t -> String
(Int -> AugT t -> ShowS)
-> (AugT t -> String) -> ([AugT t] -> ShowS) -> Show (AugT t)
forall t. Show t => Int -> AugT t -> ShowS
forall t. Show t => [AugT t] -> ShowS
forall t. Show t => AugT t -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AugT t] -> ShowS
$cshowList :: forall t. Show t => [AugT t] -> ShowS
show :: AugT t -> String
$cshow :: forall t. Show t => AugT t -> String
showsPrec :: Int -> AugT t -> ShowS
$cshowsPrec :: forall t. Show t => Int -> AugT t -> ShowS
Show)

-- | A convenience synonym for an augmented vocabulary symbol
type AugV t nt = V (AugT t) (AugNT nt)

-- | A convenience synonym for augmented vocabulary symbols
type AugVs t nt = Vs (AugT t) (AugNT nt)

-- | A convenience synonym for augmented productions
type AugProduction t nt = Production (AugT t) (AugNT nt)

-- | A convenience symbol for an augmented grammar
type AugFreeCfg t nt = FreeCfg (AugT t) (AugNT nt)

-- | Returns the /augmented/ grammar: a grammar for the same language
-- but using explicit start and end-of-file symbols.
augmentCfg ::
     forall cfg t nt. (Cfg cfg t nt, Ord nt, Ord t)
  => cfg t nt
  -> FreeCfg (AugT t) (AugNT nt)
augmentCfg :: cfg t nt -> FreeCfg (AugT t) (AugNT nt)
augmentCfg cfg t nt
cfg =
  FreeCfg :: forall t nt.
Set nt -> Set t -> (nt -> Set (Vs t nt)) -> nt -> FreeCfg t nt
FreeCfg
    { nonterminals' :: Set (AugNT nt)
nonterminals' = AugNT nt -> Set (AugNT nt) -> Set (AugNT nt)
forall a. Ord a => a -> Set a -> Set a
S.insert AugNT nt
forall nt. AugNT nt
StartSymbol (Set (AugNT nt) -> Set (AugNT nt))
-> Set (AugNT nt) -> Set (AugNT nt)
forall a b. (a -> b) -> a -> b
$ (nt -> AugNT nt) -> Set nt -> Set (AugNT nt)
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map nt -> AugNT nt
forall nt. nt -> AugNT nt
AugNT (Set nt -> Set (AugNT nt)) -> Set nt -> Set (AugNT 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
    , terminals' :: Set (AugT t)
terminals' = AugT t -> Set (AugT t) -> Set (AugT t)
forall a. Ord a => a -> Set a -> Set a
S.insert AugT t
forall t. AugT t
EOF (Set (AugT t) -> Set (AugT t)) -> Set (AugT t) -> Set (AugT t)
forall a b. (a -> b) -> a -> b
$ (t -> AugT t) -> Set t -> Set (AugT t)
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map t -> AugT t
forall t. t -> AugT t
AugT (Set t -> Set (AugT t)) -> Set t -> Set (AugT t)
forall a b. (a -> b) -> a -> b
$ cfg t nt -> Set t
forall (cfg :: * -> * -> *) t nt. Cfg cfg t nt => cfg t nt -> Set t
terminals cfg t nt
cfg
    , productionRules' :: AugNT nt -> Set (Vs (AugT t) (AugNT nt))
productionRules' = AugNT nt -> Set (Vs (AugT t) (AugNT nt))
pr
    , startSymbol' :: AugNT nt
startSymbol' = AugNT nt
forall nt. AugNT nt
StartSymbol
    }
  where
    pr :: AugNT nt -> S.Set (Vs (AugT t) (AugNT nt))
    pr :: AugNT nt -> Set (Vs (AugT t) (AugNT nt))
pr AugNT nt
StartSymbol = Vs (AugT t) (AugNT nt) -> Set (Vs (AugT t) (AugNT nt))
forall a. a -> Set a
S.singleton [AugNT nt -> V (AugT t) (AugNT nt)
forall t nt. nt -> V t nt
NT (AugNT nt -> V (AugT t) (AugNT nt))
-> AugNT nt -> V (AugT t) (AugNT nt)
forall a b. (a -> b) -> a -> b
$ nt -> AugNT nt
forall nt. nt -> AugNT nt
AugNT (nt -> AugNT nt) -> nt -> AugNT nt
forall a b. (a -> b) -> a -> b
$ cfg t nt -> nt
forall (cfg :: * -> * -> *) t nt. Cfg cfg t nt => cfg t nt -> nt
startSymbol cfg t nt
cfg, AugT t -> V (AugT t) (AugNT nt)
forall t nt. t -> V t nt
T AugT t
forall t. AugT t
EOF]
    pr (AugNT nt
nt) = (Vs t nt -> Vs (AugT t) (AugNT nt))
-> Set (Vs t nt) -> Set (Vs (AugT t) (AugNT nt))
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map Vs t nt -> Vs (AugT t) (AugNT nt)
augmentVs Set (Vs t nt)
oldRhss
      where
        oldRhss :: S.Set (Vs t nt)
        oldRhss :: Set (Vs t nt)
oldRhss = 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
    augmentVs :: Vs t nt -> Vs (AugT t) (AugNT nt)
    augmentVs :: Vs t nt -> Vs (AugT t) (AugNT nt)
augmentVs = (V t nt -> V (AugT t) (AugNT nt))
-> Vs t nt -> Vs (AugT t) (AugNT nt)
forall a b. (a -> b) -> [a] -> [b]
map V t nt -> V (AugT t) (AugNT nt)
augmentV
    augmentV :: V t nt -> V (AugT t) (AugNT nt)
    augmentV :: V t nt -> V (AugT t) (AugNT nt)
augmentV (NT nt
nt') = AugNT nt -> V (AugT t) (AugNT nt)
forall t nt. nt -> V t nt
NT (AugNT nt -> V (AugT t) (AugNT nt))
-> AugNT nt -> V (AugT t) (AugNT nt)
forall a b. (a -> b) -> a -> b
$ nt -> AugNT nt
forall nt. nt -> AugNT nt
AugNT nt
nt'
    augmentV (T t
t') = AugT t -> V (AugT t) (AugNT nt)
forall t nt. t -> V t nt
T (AugT t -> V (AugT t) (AugNT nt))
-> AugT t -> V (AugT t) (AugNT nt)
forall a b. (a -> b) -> a -> b
$ t -> AugT t
forall t. t -> AugT t
AugT t
t'