----------------------------------------------------------------------
-- |
-- Module      : GF.Grammar.CFG
--
-- Context-free grammar representation and manipulation.
----------------------------------------------------------------------
module GF.Grammar.CFG where

import GF.Data.Utilities
import PGF
import GF.Data.Relation

import Data.Map (Map)
import qualified Data.Map as Map
import Data.List
import Data.Set (Set)
import qualified Data.Set as Set

--
-- * Types
--

type Cat = String

data Symbol c t = NonTerminal c | Terminal t
  deriving (Symbol c t -> Symbol c t -> Bool
(Symbol c t -> Symbol c t -> Bool)
-> (Symbol c t -> Symbol c t -> Bool) -> Eq (Symbol c t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall c t. (Eq c, Eq t) => Symbol c t -> Symbol c t -> Bool
/= :: Symbol c t -> Symbol c t -> Bool
$c/= :: forall c t. (Eq c, Eq t) => Symbol c t -> Symbol c t -> Bool
== :: Symbol c t -> Symbol c t -> Bool
$c== :: forall c t. (Eq c, Eq t) => Symbol c t -> Symbol c t -> Bool
Eq, Eq (Symbol c t)
Eq (Symbol c t)
-> (Symbol c t -> Symbol c t -> Ordering)
-> (Symbol c t -> Symbol c t -> Bool)
-> (Symbol c t -> Symbol c t -> Bool)
-> (Symbol c t -> Symbol c t -> Bool)
-> (Symbol c t -> Symbol c t -> Bool)
-> (Symbol c t -> Symbol c t -> Symbol c t)
-> (Symbol c t -> Symbol c t -> Symbol c t)
-> Ord (Symbol c t)
Symbol c t -> Symbol c t -> Bool
Symbol c t -> Symbol c t -> Ordering
Symbol c t -> Symbol c t -> Symbol c 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 c t. (Ord c, Ord t) => Eq (Symbol c t)
forall c t. (Ord c, Ord t) => Symbol c t -> Symbol c t -> Bool
forall c t. (Ord c, Ord t) => Symbol c t -> Symbol c t -> Ordering
forall c t.
(Ord c, Ord t) =>
Symbol c t -> Symbol c t -> Symbol c t
min :: Symbol c t -> Symbol c t -> Symbol c t
$cmin :: forall c t.
(Ord c, Ord t) =>
Symbol c t -> Symbol c t -> Symbol c t
max :: Symbol c t -> Symbol c t -> Symbol c t
$cmax :: forall c t.
(Ord c, Ord t) =>
Symbol c t -> Symbol c t -> Symbol c t
>= :: Symbol c t -> Symbol c t -> Bool
$c>= :: forall c t. (Ord c, Ord t) => Symbol c t -> Symbol c t -> Bool
> :: Symbol c t -> Symbol c t -> Bool
$c> :: forall c t. (Ord c, Ord t) => Symbol c t -> Symbol c t -> Bool
<= :: Symbol c t -> Symbol c t -> Bool
$c<= :: forall c t. (Ord c, Ord t) => Symbol c t -> Symbol c t -> Bool
< :: Symbol c t -> Symbol c t -> Bool
$c< :: forall c t. (Ord c, Ord t) => Symbol c t -> Symbol c t -> Bool
compare :: Symbol c t -> Symbol c t -> Ordering
$ccompare :: forall c t. (Ord c, Ord t) => Symbol c t -> Symbol c t -> Ordering
$cp1Ord :: forall c t. (Ord c, Ord t) => Eq (Symbol c t)
Ord, Int -> Symbol c t -> ShowS
[Symbol c t] -> ShowS
Symbol c t -> String
(Int -> Symbol c t -> ShowS)
-> (Symbol c t -> String)
-> ([Symbol c t] -> ShowS)
-> Show (Symbol c t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall c t. (Show c, Show t) => Int -> Symbol c t -> ShowS
forall c t. (Show c, Show t) => [Symbol c t] -> ShowS
forall c t. (Show c, Show t) => Symbol c t -> String
showList :: [Symbol c t] -> ShowS
$cshowList :: forall c t. (Show c, Show t) => [Symbol c t] -> ShowS
show :: Symbol c t -> String
$cshow :: forall c t. (Show c, Show t) => Symbol c t -> String
showsPrec :: Int -> Symbol c t -> ShowS
$cshowsPrec :: forall c t. (Show c, Show t) => Int -> Symbol c t -> ShowS
Show)

data Rule c t = Rule { 
      Rule c t -> c
ruleLhs  :: c,
      Rule c t -> [Symbol c t]
ruleRhs  :: [Symbol c t],
      Rule c t -> CFTerm
ruleName :: CFTerm 
    }
  deriving (Rule c t -> Rule c t -> Bool
(Rule c t -> Rule c t -> Bool)
-> (Rule c t -> Rule c t -> Bool) -> Eq (Rule c t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall c t. (Eq c, Eq t) => Rule c t -> Rule c t -> Bool
/= :: Rule c t -> Rule c t -> Bool
$c/= :: forall c t. (Eq c, Eq t) => Rule c t -> Rule c t -> Bool
== :: Rule c t -> Rule c t -> Bool
$c== :: forall c t. (Eq c, Eq t) => Rule c t -> Rule c t -> Bool
Eq, Eq (Rule c t)
Eq (Rule c t)
-> (Rule c t -> Rule c t -> Ordering)
-> (Rule c t -> Rule c t -> Bool)
-> (Rule c t -> Rule c t -> Bool)
-> (Rule c t -> Rule c t -> Bool)
-> (Rule c t -> Rule c t -> Bool)
-> (Rule c t -> Rule c t -> Rule c t)
-> (Rule c t -> Rule c t -> Rule c t)
-> Ord (Rule c t)
Rule c t -> Rule c t -> Bool
Rule c t -> Rule c t -> Ordering
Rule c t -> Rule c t -> Rule c 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 c t. (Ord c, Ord t) => Eq (Rule c t)
forall c t. (Ord c, Ord t) => Rule c t -> Rule c t -> Bool
forall c t. (Ord c, Ord t) => Rule c t -> Rule c t -> Ordering
forall c t. (Ord c, Ord t) => Rule c t -> Rule c t -> Rule c t
min :: Rule c t -> Rule c t -> Rule c t
$cmin :: forall c t. (Ord c, Ord t) => Rule c t -> Rule c t -> Rule c t
max :: Rule c t -> Rule c t -> Rule c t
$cmax :: forall c t. (Ord c, Ord t) => Rule c t -> Rule c t -> Rule c t
>= :: Rule c t -> Rule c t -> Bool
$c>= :: forall c t. (Ord c, Ord t) => Rule c t -> Rule c t -> Bool
> :: Rule c t -> Rule c t -> Bool
$c> :: forall c t. (Ord c, Ord t) => Rule c t -> Rule c t -> Bool
<= :: Rule c t -> Rule c t -> Bool
$c<= :: forall c t. (Ord c, Ord t) => Rule c t -> Rule c t -> Bool
< :: Rule c t -> Rule c t -> Bool
$c< :: forall c t. (Ord c, Ord t) => Rule c t -> Rule c t -> Bool
compare :: Rule c t -> Rule c t -> Ordering
$ccompare :: forall c t. (Ord c, Ord t) => Rule c t -> Rule c t -> Ordering
$cp1Ord :: forall c t. (Ord c, Ord t) => Eq (Rule c t)
Ord, Int -> Rule c t -> ShowS
[Rule c t] -> ShowS
Rule c t -> String
(Int -> Rule c t -> ShowS)
-> (Rule c t -> String) -> ([Rule c t] -> ShowS) -> Show (Rule c t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall c t. (Show c, Show t) => Int -> Rule c t -> ShowS
forall c t. (Show c, Show t) => [Rule c t] -> ShowS
forall c t. (Show c, Show t) => Rule c t -> String
showList :: [Rule c t] -> ShowS
$cshowList :: forall c t. (Show c, Show t) => [Rule c t] -> ShowS
show :: Rule c t -> String
$cshow :: forall c t. (Show c, Show t) => Rule c t -> String
showsPrec :: Int -> Rule c t -> ShowS
$cshowsPrec :: forall c t. (Show c, Show t) => Int -> Rule c t -> ShowS
Show)

data Grammar c t = Grammar { 
      Grammar c t -> c
cfgStartCat     :: c,
      Grammar c t -> Set c
cfgExternalCats :: Set c,
      Grammar c t -> Map c (Set (Rule c t))
cfgRules        :: Map c (Set (Rule c t)) }
  deriving (Grammar c t -> Grammar c t -> Bool
(Grammar c t -> Grammar c t -> Bool)
-> (Grammar c t -> Grammar c t -> Bool) -> Eq (Grammar c t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall c t. (Eq c, Eq t) => Grammar c t -> Grammar c t -> Bool
/= :: Grammar c t -> Grammar c t -> Bool
$c/= :: forall c t. (Eq c, Eq t) => Grammar c t -> Grammar c t -> Bool
== :: Grammar c t -> Grammar c t -> Bool
$c== :: forall c t. (Eq c, Eq t) => Grammar c t -> Grammar c t -> Bool
Eq, Eq (Grammar c t)
Eq (Grammar c t)
-> (Grammar c t -> Grammar c t -> Ordering)
-> (Grammar c t -> Grammar c t -> Bool)
-> (Grammar c t -> Grammar c t -> Bool)
-> (Grammar c t -> Grammar c t -> Bool)
-> (Grammar c t -> Grammar c t -> Bool)
-> (Grammar c t -> Grammar c t -> Grammar c t)
-> (Grammar c t -> Grammar c t -> Grammar c t)
-> Ord (Grammar c t)
Grammar c t -> Grammar c t -> Bool
Grammar c t -> Grammar c t -> Ordering
Grammar c t -> Grammar c t -> Grammar c 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 c t. (Ord c, Ord t) => Eq (Grammar c t)
forall c t. (Ord c, Ord t) => Grammar c t -> Grammar c t -> Bool
forall c t.
(Ord c, Ord t) =>
Grammar c t -> Grammar c t -> Ordering
forall c t.
(Ord c, Ord t) =>
Grammar c t -> Grammar c t -> Grammar c t
min :: Grammar c t -> Grammar c t -> Grammar c t
$cmin :: forall c t.
(Ord c, Ord t) =>
Grammar c t -> Grammar c t -> Grammar c t
max :: Grammar c t -> Grammar c t -> Grammar c t
$cmax :: forall c t.
(Ord c, Ord t) =>
Grammar c t -> Grammar c t -> Grammar c t
>= :: Grammar c t -> Grammar c t -> Bool
$c>= :: forall c t. (Ord c, Ord t) => Grammar c t -> Grammar c t -> Bool
> :: Grammar c t -> Grammar c t -> Bool
$c> :: forall c t. (Ord c, Ord t) => Grammar c t -> Grammar c t -> Bool
<= :: Grammar c t -> Grammar c t -> Bool
$c<= :: forall c t. (Ord c, Ord t) => Grammar c t -> Grammar c t -> Bool
< :: Grammar c t -> Grammar c t -> Bool
$c< :: forall c t. (Ord c, Ord t) => Grammar c t -> Grammar c t -> Bool
compare :: Grammar c t -> Grammar c t -> Ordering
$ccompare :: forall c t.
(Ord c, Ord t) =>
Grammar c t -> Grammar c t -> Ordering
$cp1Ord :: forall c t. (Ord c, Ord t) => Eq (Grammar c t)
Ord, Int -> Grammar c t -> ShowS
[Grammar c t] -> ShowS
Grammar c t -> String
(Int -> Grammar c t -> ShowS)
-> (Grammar c t -> String)
-> ([Grammar c t] -> ShowS)
-> Show (Grammar c t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall c t. (Show c, Show t) => Int -> Grammar c t -> ShowS
forall c t. (Show c, Show t) => [Grammar c t] -> ShowS
forall c t. (Show c, Show t) => Grammar c t -> String
showList :: [Grammar c t] -> ShowS
$cshowList :: forall c t. (Show c, Show t) => [Grammar c t] -> ShowS
show :: Grammar c t -> String
$cshow :: forall c t. (Show c, Show t) => Grammar c t -> String
showsPrec :: Int -> Grammar c t -> ShowS
$cshowsPrec :: forall c t. (Show c, Show t) => Int -> Grammar c t -> ShowS
Show)

data CFTerm
    = CFObj CId [CFTerm] -- ^ an abstract syntax function with arguments
    | CFAbs Int CFTerm -- ^ A lambda abstraction. The Int is the variable id.
    | CFApp CFTerm CFTerm -- ^ Application
    | CFRes Int -- ^ The result of the n:th (0-based) non-terminal
    | CFVar Int -- ^ A lambda-bound variable
    | CFMeta CId -- ^ A metavariable
  deriving (CFTerm -> CFTerm -> Bool
(CFTerm -> CFTerm -> Bool)
-> (CFTerm -> CFTerm -> Bool) -> Eq CFTerm
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CFTerm -> CFTerm -> Bool
$c/= :: CFTerm -> CFTerm -> Bool
== :: CFTerm -> CFTerm -> Bool
$c== :: CFTerm -> CFTerm -> Bool
Eq, Eq CFTerm
Eq CFTerm
-> (CFTerm -> CFTerm -> Ordering)
-> (CFTerm -> CFTerm -> Bool)
-> (CFTerm -> CFTerm -> Bool)
-> (CFTerm -> CFTerm -> Bool)
-> (CFTerm -> CFTerm -> Bool)
-> (CFTerm -> CFTerm -> CFTerm)
-> (CFTerm -> CFTerm -> CFTerm)
-> Ord CFTerm
CFTerm -> CFTerm -> Bool
CFTerm -> CFTerm -> Ordering
CFTerm -> CFTerm -> CFTerm
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
min :: CFTerm -> CFTerm -> CFTerm
$cmin :: CFTerm -> CFTerm -> CFTerm
max :: CFTerm -> CFTerm -> CFTerm
$cmax :: CFTerm -> CFTerm -> CFTerm
>= :: CFTerm -> CFTerm -> Bool
$c>= :: CFTerm -> CFTerm -> Bool
> :: CFTerm -> CFTerm -> Bool
$c> :: CFTerm -> CFTerm -> Bool
<= :: CFTerm -> CFTerm -> Bool
$c<= :: CFTerm -> CFTerm -> Bool
< :: CFTerm -> CFTerm -> Bool
$c< :: CFTerm -> CFTerm -> Bool
compare :: CFTerm -> CFTerm -> Ordering
$ccompare :: CFTerm -> CFTerm -> Ordering
$cp1Ord :: Eq CFTerm
Ord, Int -> CFTerm -> ShowS
[CFTerm] -> ShowS
CFTerm -> String
(Int -> CFTerm -> ShowS)
-> (CFTerm -> String) -> ([CFTerm] -> ShowS) -> Show CFTerm
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CFTerm] -> ShowS
$cshowList :: [CFTerm] -> ShowS
show :: CFTerm -> String
$cshow :: CFTerm -> String
showsPrec :: Int -> CFTerm -> ShowS
$cshowsPrec :: Int -> CFTerm -> ShowS
Show)

type CFSymbol = Symbol  Cat Token
type CFRule   = Rule    Cat Token
type CFG      = Grammar Cat Token

type Param         = Int
type ParamCFSymbol = Symbol (Cat,[Param]) Token
type ParamCFRule   = Rule    (Cat,[Param]) Token
type ParamCFG      = Grammar (Cat,[Param]) Token

--
-- * Grammar filtering
--

-- | Removes all directly and indirectly cyclic productions.
--   FIXME: this may be too aggressive, only one production
--   needs to be removed to break a given cycle. But which
--   one should we pick?
--   FIXME: Does not (yet) remove productions which are cyclic
--   because of empty productions.
removeCycles :: (Ord c,Ord t) => Grammar c t -> Grammar c t
removeCycles :: Grammar c t -> Grammar c t
removeCycles = ([Rule c t] -> [Rule c t]) -> Grammar c t -> Grammar c t
forall c t.
(Ord c, Ord t) =>
([Rule c t] -> [Rule c t]) -> Grammar c t -> Grammar c t
onRules [Rule c t] -> [Rule c t]
forall a t. Ord a => [Rule a t] -> [Rule a t]
f
  where f :: [Rule a t] -> [Rule a t]
f [Rule a t]
rs = (Rule a t -> Bool) -> [Rule a t] -> [Rule a t]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Rule a t -> Bool) -> Rule a t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule a t -> Bool
forall t. Rule a t -> Bool
isCycle) [Rule a t]
rs
          where alias :: Rel a
alias = Rel a -> Rel a
forall a. Ord a => Rel a -> Rel a
transitiveClosure (Rel a -> Rel a) -> Rel a -> Rel a
forall a b. (a -> b) -> a -> b
$ [(a, a)] -> Rel a
forall a. Ord a => [(a, a)] -> Rel a
mkRel [(a
c,a
c') | Rule a
c [NonTerminal a
c'] CFTerm
_ <- [Rule a t]
rs]
                isCycle :: Rule a t -> Bool
isCycle (Rule a
c [NonTerminal a
c'] CFTerm
_) = Rel a -> a -> a -> Bool
forall a. Ord a => Rel a -> a -> a -> Bool
isRelatedTo Rel a
alias a
c' a
c
                isCycle Rule a t
_ = Bool
False

-- | Better bottom-up filter that also removes categories which contain no finite
-- strings.
bottomUpFilter :: (Ord c,Ord t) => Grammar c t -> Grammar c t
bottomUpFilter :: Grammar c t -> Grammar c t
bottomUpFilter Grammar c t
gr = (Grammar c t -> Grammar c t) -> Grammar c t -> Grammar c t
forall a. Eq a => (a -> a) -> a -> a
fix Grammar c t -> Grammar c t
grow (Grammar c t
gr { cfgRules :: Map c (Set (Rule c t))
cfgRules = Map c (Set (Rule c t))
forall k a. Map k a
Map.empty })
  where grow :: Grammar c t -> Grammar c t
grow Grammar c t
g = Grammar c t
g Grammar c t -> Grammar c t -> Grammar c t
forall c t.
(Ord c, Ord t) =>
Grammar c t -> Grammar c t -> Grammar c t
`unionCFG` (Rule c t -> Bool) -> Grammar c t -> Grammar c t
forall c t. (Rule c t -> Bool) -> Grammar c t -> Grammar c t
filterCFG ((Symbol c t -> Bool) -> [Symbol c t] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Grammar c t -> Symbol c t -> Bool
forall a t b. Eq a => Grammar a t -> Symbol a b -> Bool
okSym Grammar c t
g) ([Symbol c t] -> Bool)
-> (Rule c t -> [Symbol c t]) -> Rule c t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule c t -> [Symbol c t]
forall c t. Rule c t -> [Symbol c t]
ruleRhs) Grammar c t
gr
        okSym :: Grammar a t -> Symbol a b -> Bool
okSym Grammar a t
g = (a -> Bool) -> (b -> Bool) -> Symbol a b -> Bool
forall c a t. (c -> a) -> (t -> a) -> Symbol c t -> a
symbol (a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Grammar a t -> [a]
forall c t. Grammar c t -> [c]
allCats Grammar a t
g) (Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | Removes categories which are not reachable from any external category.
topDownFilter :: (Ord c,Ord t) => Grammar c t -> Grammar c t
topDownFilter :: Grammar c t -> Grammar c t
topDownFilter Grammar c t
cfg = (c -> Bool) -> Grammar c t -> Grammar c t
forall c t. (c -> Bool) -> Grammar c t -> Grammar c t
filterCFGCats (c -> Set c -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set c
keep) Grammar c t
cfg
  where
    rhsCats :: [(c, c)]
rhsCats = [ (Rule c t -> c
forall c t. Rule c t -> c
ruleLhs Rule c t
r, c
c') | Rule c t
r <- Grammar c t -> [Rule c t]
forall c t. Grammar c t -> [Rule c t]
allRules Grammar c t
cfg, c
c' <- [Symbol c t] -> [c]
forall c t. [Symbol c t] -> [c]
filterCats (Rule c t -> [Symbol c t]
forall c t. Rule c t -> [Symbol c t]
ruleRhs Rule c t
r) ]
    uses :: Rel c
uses = [c] -> Rel c -> Rel c
forall a. Ord a => [a] -> Rel a -> Rel a
reflexiveClosure_ (Grammar c t -> [c]
forall c t. Grammar c t -> [c]
allCats Grammar c t
cfg) (Rel c -> Rel c) -> Rel c -> Rel c
forall a b. (a -> b) -> a -> b
$ Rel c -> Rel c
forall a. Ord a => Rel a -> Rel a
transitiveClosure (Rel c -> Rel c) -> Rel c -> Rel c
forall a b. (a -> b) -> a -> b
$ [(c, c)] -> Rel c
forall a. Ord a => [(a, a)] -> Rel a
mkRel [(c, c)]
rhsCats
    keep :: Set c
keep = [Set c] -> Set c
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set c] -> Set c) -> [Set c] -> Set c
forall a b. (a -> b) -> a -> b
$ (c -> Set c) -> [c] -> [Set c]
forall a b. (a -> b) -> [a] -> [b]
map (Rel c -> c -> Set c
forall a. Ord a => Rel a -> a -> Set a
allRelated Rel c
uses) ([c] -> [Set c]) -> [c] -> [Set c]
forall a b. (a -> b) -> a -> b
$ Set c -> [c]
forall a. Set a -> [a]
Set.toList (Set c -> [c]) -> Set c -> [c]
forall a b. (a -> b) -> a -> b
$ Grammar c t -> Set c
forall c t. Grammar c t -> Set c
cfgExternalCats Grammar c t
cfg

-- | Merges categories with identical right-hand-sides.
-- FIXME: handle probabilities
mergeIdentical :: CFG -> CFG
mergeIdentical :: CFG -> CFG
mergeIdentical CFG
g = ([Rule String String] -> [Rule String String]) -> CFG -> CFG
forall c t.
(Ord c, Ord t) =>
([Rule c t] -> [Rule c t]) -> Grammar c t -> Grammar c t
onRules ((Rule String String -> Rule String String)
-> [Rule String String] -> [Rule String String]
forall a b. (a -> b) -> [a] -> [b]
map Rule String String -> Rule String String
forall t. Rule String t -> Rule String t
subst) CFG
g
  where
    -- maps categories to their replacement
    m :: Map String String
m = [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String
y,[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"+" [String]
xs)) 
                          | (Set (CFTerm, [Symbol String String])
_,[String]
xs) <- [(Set (CFTerm, [Symbol String String]), String)]
-> [(Set (CFTerm, [Symbol String String]), [String])]
forall a b. Ord a => [(a, b)] -> [(a, [b])]
buildMultiMap [(Set (Rule String String) -> Set (CFTerm, [Symbol String String])
rulesKey Set (Rule String String)
rs,String
c) | (String
c,Set (Rule String String)
rs) <- Map String (Set (Rule String String))
-> [(String, Set (Rule String String))]
forall k a. Map k a -> [(k, a)]
Map.toList (CFG -> Map String (Set (Rule String String))
forall c t. Grammar c t -> Map c (Set (Rule c t))
cfgRules CFG
g)], String
y <- [String]
xs]
    -- build data to compare for each category: a set of name,rhs pairs
    rulesKey :: Set (Rule String String) -> Set (CFTerm, [Symbol String String])
rulesKey = (Rule String String -> (CFTerm, [Symbol String String]))
-> Set (Rule String String) -> Set (CFTerm, [Symbol String String])
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\ (Rule String
_ [Symbol String String]
r CFTerm
n) -> (CFTerm
n,[Symbol String String]
r))
    subst :: Rule String t -> Rule String t
subst (Rule String
c [Symbol String t]
r CFTerm
n) = String -> [Symbol String t] -> CFTerm -> Rule String t
forall c t. c -> [Symbol c t] -> CFTerm -> Rule c t
Rule (ShowS
substCat String
c) ((Symbol String t -> Symbol String t)
-> [Symbol String t] -> [Symbol String t]
forall a b. (a -> b) -> [a] -> [b]
map (ShowS -> (t -> t) -> Symbol String t -> Symbol String t
forall c c' t t'.
(c -> c') -> (t -> t') -> Symbol c t -> Symbol c' t'
mapSymbol ShowS
substCat t -> t
forall a. a -> a
id) [Symbol String t]
r) CFTerm
n
    substCat :: ShowS
substCat String
c = String -> String -> Map String String -> String
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (ShowS
forall a. HasCallStack => String -> a
error ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"mergeIdentical: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
c) String
c Map String String
m

-- | Keeps only the start category as an external category.
purgeExternalCats :: Grammar c t -> Grammar c t
purgeExternalCats :: Grammar c t -> Grammar c t
purgeExternalCats Grammar c t
cfg = Grammar c t
cfg { cfgExternalCats :: Set c
cfgExternalCats = c -> Set c
forall a. a -> Set a
Set.singleton (Grammar c t -> c
forall c t. Grammar c t -> c
cfgStartCat Grammar c t
cfg) }

--
-- * Removing left recursion
--

-- The LC_LR algorithm from
-- http://research.microsoft.com/users/bobmoore/naacl2k-proc-rev.pdf
removeLeftRecursion :: CFG -> CFG
removeLeftRecursion :: CFG -> CFG
removeLeftRecursion CFG
gr 
    = CFG
gr { cfgRules :: Map String (Set (Rule String String))
cfgRules = [Rule String String] -> Map String (Set (Rule String String))
forall c t. (Ord c, Ord t) => [Rule c t] -> Map c (Set (Rule c t))
groupProds ([Rule String String] -> Map String (Set (Rule String String)))
-> [Rule String String] -> Map String (Set (Rule String String))
forall a b. (a -> b) -> a -> b
$ [[Rule String String]] -> [Rule String String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Rule String String]
scheme1, [Rule String String]
scheme2, [Rule String String]
scheme3, [Rule String String]
scheme4] }
  where
    scheme1 :: [Rule String String]
scheme1 = [String -> [Symbol String String] -> CFTerm -> Rule String String
forall c t. c -> [Symbol c t] -> CFTerm -> Rule c t
Rule String
a [Symbol String String
x,String -> Symbol String String
forall c t. c -> Symbol c t
NonTerminal String
a_x] CFTerm
n' | 
               String
a <- [String]
retainedLeftRecursive, 
               Symbol String String
x <- String -> [Symbol String String]
properLeftCornersOf String
a,
               Bool -> Bool
not (Symbol String String -> Bool
isLeftRecursive Symbol String String
x),
               let a_x :: String
a_x = Symbol String String -> Symbol String String -> String
mkCat (String -> Symbol String String
forall c t. c -> Symbol c t
NonTerminal String
a) Symbol String String
x,
               -- this is an extension of LC_LR to avoid generating
               -- A-X categories for which there are no productions:
               String
a_x String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
newCats,
               let n' :: CFTerm
n' = (String -> CFTerm)
-> (String -> CFTerm) -> Symbol String String -> CFTerm
forall c a t. (c -> a) -> (t -> a) -> Symbol c t -> a
symbol (\String
_ -> CFTerm -> CFTerm -> CFTerm
CFApp (Int -> CFTerm
CFRes Int
1) (Int -> CFTerm
CFRes Int
0))
                               (\String
_ -> Int -> CFTerm
CFRes Int
0) Symbol String String
x] 
    scheme2 :: [Rule String String]
scheme2 = [String -> [Symbol String String] -> CFTerm -> Rule String String
forall c t. c -> [Symbol c t] -> CFTerm -> Rule c t
Rule String
a_x ([Symbol String String]
beta[Symbol String String]
-> [Symbol String String] -> [Symbol String String]
forall a. [a] -> [a] -> [a]
++[String -> Symbol String String
forall c t. c -> Symbol c t
NonTerminal String
a_b]) CFTerm
n' | 
               String
a <- [String]
retainedLeftRecursive, 
               b :: Symbol String String
b@(NonTerminal String
b') <- String -> [Symbol String String]
properLeftCornersOf String
a,
               Symbol String String -> Bool
isLeftRecursive Symbol String String
b,
               Rule String
_ (Symbol String String
x:[Symbol String String]
beta) CFTerm
n <- CFG -> String -> [Rule String String]
forall c t. Ord c => Grammar c t -> c -> [Rule c t]
catRules CFG
gr String
b', 
               let a_x :: String
a_x = Symbol String String -> Symbol String String -> String
mkCat (String -> Symbol String String
forall c t. c -> Symbol c t
NonTerminal String
a) Symbol String String
x,
               let a_b :: String
a_b = Symbol String String -> Symbol String String -> String
mkCat (String -> Symbol String String
forall c t. c -> Symbol c t
NonTerminal String
a) Symbol String String
b,
               let i :: Int
i = [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([String] -> Int) -> [String] -> Int
forall a b. (a -> b) -> a -> b
$ [Symbol String String] -> [String]
forall c t. [Symbol c t] -> [c]
filterCats [Symbol String String]
beta,
               let n' :: CFTerm
n' = (String -> CFTerm)
-> (String -> CFTerm) -> Symbol String String -> CFTerm
forall c a t. (c -> a) -> (t -> a) -> Symbol c t -> a
symbol (\String
_ -> Int -> CFTerm -> CFTerm
CFAbs Int
1 (CFTerm -> CFTerm -> CFTerm
CFApp (Int -> CFTerm
CFRes Int
i) (CFTerm -> CFTerm
shiftTerm CFTerm
n)))
                               (\String
_ -> CFTerm -> CFTerm -> CFTerm
CFApp (Int -> CFTerm
CFRes Int
i) CFTerm
n) Symbol String String
x]
    scheme3 :: [Rule String String]
scheme3 = [String -> [Symbol String String] -> CFTerm -> Rule String String
forall c t. c -> [Symbol c t] -> CFTerm -> Rule c t
Rule String
a_x [Symbol String String]
beta CFTerm
n' |
               String
a <- [String]
retainedLeftRecursive, 
               Symbol String String
x <- String -> [Symbol String String]
properLeftCornersOf String
a,
               Rule String
_ (Symbol String String
x':[Symbol String String]
beta) CFTerm
n <- CFG -> String -> [Rule String String]
forall c t. Ord c => Grammar c t -> c -> [Rule c t]
catRules CFG
gr String
a,
               Symbol String String
x Symbol String String -> Symbol String String -> Bool
forall a. Eq a => a -> a -> Bool
== Symbol String String
x',
               let a_x :: String
a_x = Symbol String String -> Symbol String String -> String
mkCat (String -> Symbol String String
forall c t. c -> Symbol c t
NonTerminal String
a) Symbol String String
x,
               let n' :: CFTerm
n' = (String -> CFTerm)
-> (String -> CFTerm) -> Symbol String String -> CFTerm
forall c a t. (c -> a) -> (t -> a) -> Symbol c t -> a
symbol (\String
_ -> Int -> CFTerm -> CFTerm
CFAbs Int
1 (CFTerm -> CFTerm
shiftTerm CFTerm
n)) 
                               (\String
_ -> CFTerm
n) Symbol String String
x]
    scheme4 :: [Rule String String]
scheme4 = CFG -> Set String -> [Rule String String]
catSetRules CFG
gr (Set String -> [Rule String String])
-> Set String -> [Rule String String]
forall a b. (a -> b) -> a -> b
$ [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ([String] -> Set String) -> [String] -> Set String
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol String String -> Bool
isLeftRecursive (Symbol String String -> Bool)
-> (String -> Symbol String String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Symbol String String
forall c t. c -> Symbol c t
NonTerminal) [String]
cats

    newCats :: Set String
newCats = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ((Rule String String -> String) -> [Rule String String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Rule String String -> String
forall c t. Rule c t -> c
ruleLhs ([Rule String String]
scheme2 [Rule String String]
-> [Rule String String] -> [Rule String String]
forall a. [a] -> [a] -> [a]
++ [Rule String String]
scheme3))

    shiftTerm :: CFTerm -> CFTerm
    shiftTerm :: CFTerm -> CFTerm
shiftTerm (CFObj CId
f [CFTerm]
ts) = CId -> [CFTerm] -> CFTerm
CFObj CId
f ((CFTerm -> CFTerm) -> [CFTerm] -> [CFTerm]
forall a b. (a -> b) -> [a] -> [b]
map CFTerm -> CFTerm
shiftTerm [CFTerm]
ts)
    shiftTerm (CFRes Int
0) = Int -> CFTerm
CFVar Int
1
    shiftTerm (CFRes Int
n) = Int -> CFTerm
CFRes (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
    shiftTerm CFTerm
t = CFTerm
t
    -- note: the rest don't occur in the original grammar

    cats :: [String]
cats = CFG -> [String]
forall c t. Grammar c t -> [c]
allCats CFG
gr
--  rules = allRules gr

    directLeftCorner :: Rel (Symbol String String)
directLeftCorner = [(Symbol String String, Symbol String String)]
-> Rel (Symbol String String)
forall a. Ord a => [(a, a)] -> Rel a
mkRel [(String -> Symbol String String
forall c t. c -> Symbol c t
NonTerminal String
c,Symbol String String
t) | Rule String
c (Symbol String String
t:[Symbol String String]
_) CFTerm
_ <- CFG -> [Rule String String]
forall c t. Grammar c t -> [Rule c t]
allRules CFG
gr]
--  leftCorner = reflexiveClosure_ (map NonTerminal cats) $ transitiveClosure directLeftCorner
    properLeftCorner :: Rel (Symbol String String)
properLeftCorner = Rel (Symbol String String) -> Rel (Symbol String String)
forall a. Ord a => Rel a -> Rel a
transitiveClosure Rel (Symbol String String)
directLeftCorner
    properLeftCornersOf :: String -> [Symbol String String]
properLeftCornersOf = Set (Symbol String String) -> [Symbol String String]
forall a. Set a -> [a]
Set.toList (Set (Symbol String String) -> [Symbol String String])
-> (String -> Set (Symbol String String))
-> String
-> [Symbol String String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rel (Symbol String String)
-> Symbol String String -> Set (Symbol String String)
forall a. Ord a => Rel a -> a -> Set a
allRelated Rel (Symbol String String)
properLeftCorner (Symbol String String -> Set (Symbol String String))
-> (String -> Symbol String String)
-> String
-> Set (Symbol String String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Symbol String String
forall c t. c -> Symbol c t
NonTerminal
--  isProperLeftCornerOf = flip (isRelatedTo properLeftCorner)

    leftRecursive :: Set (Symbol String String)
leftRecursive = Rel (Symbol String String) -> Set (Symbol String String)
forall a. Ord a => Rel a -> Set a
reflexiveElements Rel (Symbol String String)
properLeftCorner
    isLeftRecursive :: Symbol String String -> Bool
isLeftRecursive = (Symbol String String -> Set (Symbol String String) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (Symbol String String)
leftRecursive)

    retained :: Set String
retained = CFG -> String
forall c t. Grammar c t -> c
cfgStartCat CFG
gr String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
`Set.insert`
                [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String
a | Rule String String
r <- CFG -> [Rule String String]
forall c t. Grammar c t -> [Rule c t]
allRules ((String -> Bool) -> CFG -> CFG
forall c t. (c -> Bool) -> Grammar c t -> Grammar c t
filterCFGCats (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol String String -> Bool
isLeftRecursive (Symbol String String -> Bool)
-> (String -> Symbol String String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Symbol String String
forall c t. c -> Symbol c t
NonTerminal) CFG
gr),
                                  NonTerminal String
a <- Rule String String -> [Symbol String String]
forall c t. Rule c t -> [Symbol c t]
ruleRhs Rule String String
r]
--  isRetained = (`Set.member` retained)

    retainedLeftRecursive :: [String]
retainedLeftRecursive = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Symbol String String -> Bool
isLeftRecursive (Symbol String String -> Bool)
-> (String -> Symbol String String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Symbol String String
forall c t. c -> Symbol c t
NonTerminal) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
retained

    mkCat :: CFSymbol -> CFSymbol -> Cat
    mkCat :: Symbol String String -> Symbol String String -> String
mkCat Symbol String String
x Symbol String String
y = Symbol String String -> String
showSymbol Symbol String String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Symbol String String -> String
showSymbol Symbol String String
y
        where showSymbol :: Symbol String String -> String
showSymbol = ShowS -> ShowS -> Symbol String String -> String
forall c a t. (c -> a) -> (t -> a) -> Symbol c t -> a
symbol ShowS
forall a. a -> a
id ShowS
forall a. Show a => a -> String
show

-- | Get the sets of mutually recursive non-terminals for a grammar.
mutRecCats :: Ord c
           => Bool    -- ^ If true, all categories will be in some set.
                      --   If false, only recursive categories will be included.
           -> Grammar c t -> [Set c]
mutRecCats :: Bool -> Grammar c t -> [Set c]
mutRecCats Bool
incAll Grammar c t
g = Rel c -> [Set c]
forall a. Ord a => Rel a -> [Set a]
equivalenceClasses (Rel c -> [Set c]) -> Rel c -> [Set c]
forall a b. (a -> b) -> a -> b
$ Rel c -> Rel c
refl (Rel c -> Rel c) -> Rel c -> Rel c
forall a b. (a -> b) -> a -> b
$ Rel c -> Rel c
forall a. Ord a => Rel a -> Rel a
symmetricSubrelation (Rel c -> Rel c) -> Rel c -> Rel c
forall a b. (a -> b) -> a -> b
$ Rel c -> Rel c
forall a. Ord a => Rel a -> Rel a
transitiveClosure Rel c
r
  where r :: Rel c
r = [(c, c)] -> Rel c
forall a. Ord a => [(a, a)] -> Rel a
mkRel [(c
c,c
c') | Rule c
c [Symbol c t]
ss CFTerm
_ <- Grammar c t -> [Rule c t]
forall c t. Grammar c t -> [Rule c t]
allRules Grammar c t
g, NonTerminal c
c' <- [Symbol c t]
ss]
        refl :: Rel c -> Rel c
refl = if Bool
incAll then [c] -> Rel c -> Rel c
forall a. Ord a => [a] -> Rel a -> Rel a
reflexiveClosure_ (Grammar c t -> [c]
forall c t. Grammar c t -> [c]
allCats Grammar c t
g) else Rel c -> Rel c
forall a. Ord a => Rel a -> Rel a
reflexiveSubrelation

--
-- * Approximate context-free grammars with regular grammars.
--

makeSimpleRegular :: CFG -> CFG
makeSimpleRegular :: CFG -> CFG
makeSimpleRegular = CFG -> CFG
makeRegular (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFG -> CFG
forall c t. (Ord c, Ord t) => Grammar c t -> Grammar c t
topDownFilter (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFG -> CFG
forall c t. (Ord c, Ord t) => Grammar c t -> Grammar c t
bottomUpFilter (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFG -> CFG
forall c t. (Ord c, Ord t) => Grammar c t -> Grammar c t
removeCycles

-- Use the transformation algorithm from \"Regular Approximation of Context-free
-- Grammars through Approximation\", Mohri and Nederhof, 2000
-- to create an over-generating regular grammar for a context-free 
-- grammar
makeRegular :: CFG -> CFG
makeRegular :: CFG -> CFG
makeRegular CFG
g = CFG
g { cfgRules :: Map String (Set (Rule String String))
cfgRules = [Rule String String] -> Map String (Set (Rule String String))
forall c t. (Ord c, Ord t) => [Rule c t] -> Map c (Set (Rule c t))
groupProds ([Rule String String] -> Map String (Set (Rule String String)))
-> [Rule String String] -> Map String (Set (Rule String String))
forall a b. (a -> b) -> a -> b
$ (Set String -> [Rule String String])
-> [Set String] -> [Rule String String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Set String -> [Rule String String]
trSet (Bool -> CFG -> [Set String]
forall c t. Ord c => Bool -> Grammar c t -> [Set c]
mutRecCats Bool
True CFG
g) }
  where trSet :: Set String -> [Rule String String]
trSet Set String
cs | Set String -> [Rule String String] -> Bool
forall c t. Ord c => Set c -> [Rule c t] -> Bool
allXLinear Set String
cs [Rule String String]
rs = [Rule String String]
rs
                 | Bool
otherwise = (String -> [Rule String String])
-> [String] -> [Rule String String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [Rule String String]
handleCat (Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
cs)
            where rs :: [Rule String String]
rs = CFG -> Set String -> [Rule String String]
catSetRules CFG
g Set String
cs
                  handleCat :: String -> [Rule String String]
handleCat String
c = [String -> [Symbol String String] -> CFTerm -> Rule String String
forall c t. c -> [Symbol c t] -> CFTerm -> Rule c t
Rule String
c' [] (String -> CFTerm
mkCFTerm (String
cString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"-empty"))] -- introduce A' -> e
                                [Rule String String]
-> [Rule String String] -> [Rule String String]
forall a. [a] -> [a] -> [a]
++ (Rule String String -> [Rule String String])
-> [Rule String String] -> [Rule String String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> Rule String String -> [Rule String String]
forall t. Eq t => String -> Rule String t -> [Rule String t]
makeRightLinearRules String
c) (CFG -> String -> [Rule String String]
forall c t. Ord c => Grammar c t -> c -> [Rule c t]
catRules CFG
g String
c)
                      where c' :: String
c' = ShowS
newCat String
c
                  makeRightLinearRules :: String -> Rule String t -> [Rule String t]
makeRightLinearRules String
b' (Rule String
c [Symbol String t]
ss CFTerm
n) = 
                      case [Symbol String t]
ys of
                              [] -> String -> [Symbol String t] -> CFTerm -> [Rule String t]
forall c t.
(Eq c, Eq t) =>
c -> [Symbol c t] -> CFTerm -> [Rule c t]
newRule String
b' ([Symbol String t]
xs [Symbol String t] -> [Symbol String t] -> [Symbol String t]
forall a. [a] -> [a] -> [a]
++ [String -> Symbol String t
forall c t. c -> Symbol c t
NonTerminal (ShowS
newCat String
c)]) CFTerm
n -- no non-terminals left
                              (NonTerminal String
b:[Symbol String t]
zs) -> String -> [Symbol String t] -> CFTerm -> [Rule String t]
forall c t.
(Eq c, Eq t) =>
c -> [Symbol c t] -> CFTerm -> [Rule c t]
newRule String
b' ([Symbol String t]
xs [Symbol String t] -> [Symbol String t] -> [Symbol String t]
forall a. [a] -> [a] -> [a]
++ [String -> Symbol String t
forall c t. c -> Symbol c t
NonTerminal String
b]) CFTerm
n 
                                        [Rule String t] -> [Rule String t] -> [Rule String t]
forall a. [a] -> [a] -> [a]
++ String -> Rule String t -> [Rule String t]
makeRightLinearRules (ShowS
newCat String
b) (String -> [Symbol String t] -> CFTerm -> Rule String t
forall c t. c -> [Symbol c t] -> CFTerm -> Rule c t
Rule String
c [Symbol String t]
zs CFTerm
n)
                      where ([Symbol String t]
xs,[Symbol String t]
ys) = (Symbol String t -> Bool)
-> [Symbol String t] -> ([Symbol String t], [Symbol String t])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Symbol String t -> Set String -> Bool
forall c t. Ord c => Symbol c t -> Set c -> Bool
`catElem` Set String
cs) [Symbol String t]
ss
                            -- don't add rules on the form A -> A
                            newRule :: c -> [Symbol c t] -> CFTerm -> [Rule c t]
newRule c
c [Symbol c t]
rhs CFTerm
n | [Symbol c t]
rhs [Symbol c t] -> [Symbol c t] -> Bool
forall a. Eq a => a -> a -> Bool
== [c -> Symbol c t
forall c t. c -> Symbol c t
NonTerminal c
c] = []
                                            | Bool
otherwise = [c -> [Symbol c t] -> CFTerm -> Rule c t
forall c t. c -> [Symbol c t] -> CFTerm -> Rule c t
Rule c
c [Symbol c t]
rhs CFTerm
n]
        newCat :: ShowS
newCat String
c = String
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"$"

--
-- * CFG Utilities
--

mkCFG :: (Ord c,Ord t) => c -> Set c -> [Rule c t] -> Grammar c t
mkCFG :: c -> Set c -> [Rule c t] -> Grammar c t
mkCFG c
start Set c
ext [Rule c t]
rs = Grammar :: forall c t. c -> Set c -> Map c (Set (Rule c t)) -> Grammar c t
Grammar { cfgStartCat :: c
cfgStartCat = c
start, cfgExternalCats :: Set c
cfgExternalCats = Set c
ext, cfgRules :: Map c (Set (Rule c t))
cfgRules = [Rule c t] -> Map c (Set (Rule c t))
forall c t. (Ord c, Ord t) => [Rule c t] -> Map c (Set (Rule c t))
groupProds [Rule c t]
rs }

groupProds :: (Ord c,Ord t) => [Rule c t] -> Map c (Set (Rule c t))
groupProds :: [Rule c t] -> Map c (Set (Rule c t))
groupProds = (Set (Rule c t) -> Set (Rule c t) -> Set (Rule c t))
-> [(c, Set (Rule c t))] -> Map c (Set (Rule c t))
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Set (Rule c t) -> Set (Rule c t) -> Set (Rule c t)
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([(c, Set (Rule c t))] -> Map c (Set (Rule c t)))
-> ([Rule c t] -> [(c, Set (Rule c t))])
-> [Rule c t]
-> Map c (Set (Rule c t))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rule c t -> (c, Set (Rule c t)))
-> [Rule c t] -> [(c, Set (Rule c t))]
forall a b. (a -> b) -> [a] -> [b]
map (\Rule c t
r -> (Rule c t -> c
forall c t. Rule c t -> c
ruleLhs Rule c t
r,Rule c t -> Set (Rule c t)
forall a. a -> Set a
Set.singleton Rule c t
r))

uniqueFuns :: [Rule c t] -> [Rule c t]
uniqueFuns :: [Rule c t] -> [Rule c t]
uniqueFuns = (Set CId, [Rule c t]) -> [Rule c t]
forall a b. (a, b) -> b
snd ((Set CId, [Rule c t]) -> [Rule c t])
-> ([Rule c t] -> (Set CId, [Rule c t]))
-> [Rule c t]
-> [Rule c t]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set CId -> Rule c t -> (Set CId, Rule c t))
-> Set CId -> [Rule c t] -> (Set CId, [Rule c t])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL Set CId -> Rule c t -> (Set CId, Rule c t)
forall c t. Set CId -> Rule c t -> (Set CId, Rule c t)
uniqueFun Set CId
forall a. Set a
Set.empty
  where
    uniqueFun :: Set CId -> Rule c t -> (Set CId, Rule c t)
uniqueFun Set CId
funs (Rule c
cat [Symbol c t]
items (CFObj CId
fun [CFTerm]
args)) = (CId -> Set CId -> Set CId
forall a. Ord a => a -> Set a -> Set a
Set.insert CId
fun' Set CId
funs,c -> [Symbol c t] -> CFTerm -> Rule c t
forall c t. c -> [Symbol c t] -> CFTerm -> Rule c t
Rule c
cat [Symbol c t]
items (CId -> [CFTerm] -> CFTerm
CFObj CId
fun' [CFTerm]
args))
      where
        fun' :: CId
fun' = [CId] -> CId
forall a. [a] -> a
head [CId
fun'|String
suffix<-String
""String -> [String] -> [String]
forall a. a -> [a] -> [a]
:(Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show ([Int
2..]::[Int]),
                          let fun' :: CId
fun'=String -> CId
mkCId (CId -> String
showCId CId
funString -> ShowS
forall a. [a] -> [a] -> [a]
++String
suffix),
                          Bool -> Bool
not (CId
fun' CId -> Set CId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set CId
funs)]

-- | Gets all rules in a CFG.
allRules :: Grammar c t -> [Rule c t]
allRules :: Grammar c t -> [Rule c t]
allRules = (Set (Rule c t) -> [Rule c t]) -> [Set (Rule c t)] -> [Rule c t]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Set (Rule c t) -> [Rule c t]
forall a. Set a -> [a]
Set.toList ([Set (Rule c t)] -> [Rule c t])
-> (Grammar c t -> [Set (Rule c t)]) -> Grammar c t -> [Rule c t]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map c (Set (Rule c t)) -> [Set (Rule c t)]
forall k a. Map k a -> [a]
Map.elems (Map c (Set (Rule c t)) -> [Set (Rule c t)])
-> (Grammar c t -> Map c (Set (Rule c t)))
-> Grammar c t
-> [Set (Rule c t)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Grammar c t -> Map c (Set (Rule c t))
forall c t. Grammar c t -> Map c (Set (Rule c t))
cfgRules

-- | Gets all rules in a CFG, grouped by their LHS categories.
allRulesGrouped :: Grammar c t -> [(c,[Rule c t])]
allRulesGrouped :: Grammar c t -> [(c, [Rule c t])]
allRulesGrouped = Map c [Rule c t] -> [(c, [Rule c t])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map c [Rule c t] -> [(c, [Rule c t])])
-> (Grammar c t -> Map c [Rule c t])
-> Grammar c t
-> [(c, [Rule c t])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (Rule c t) -> [Rule c t])
-> Map c (Set (Rule c t)) -> Map c [Rule c t]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Set (Rule c t) -> [Rule c t]
forall a. Set a -> [a]
Set.toList (Map c (Set (Rule c t)) -> Map c [Rule c t])
-> (Grammar c t -> Map c (Set (Rule c t)))
-> Grammar c t
-> Map c [Rule c t]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Grammar c t -> Map c (Set (Rule c t))
forall c t. Grammar c t -> Map c (Set (Rule c t))
cfgRules

-- | Gets all categories which have rules.
allCats :: Grammar c t -> [c]
allCats :: Grammar c t -> [c]
allCats = Map c (Set (Rule c t)) -> [c]
forall k a. Map k a -> [k]
Map.keys (Map c (Set (Rule c t)) -> [c])
-> (Grammar c t -> Map c (Set (Rule c t))) -> Grammar c t -> [c]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Grammar c t -> Map c (Set (Rule c t))
forall c t. Grammar c t -> Map c (Set (Rule c t))
cfgRules

-- | Gets all categories which have rules or occur in a RHS.
allCats' :: (Ord c,Ord t) => Grammar c t -> [c]
allCats' :: Grammar c t -> [c]
allCats' Grammar c t
cfg = Set c -> [c]
forall a. Set a -> [a]
Set.toList (Map c (Set (Rule c t)) -> Set c
forall k a. Map k a -> Set k
Map.keysSet (Grammar c t -> Map c (Set (Rule c t))
forall c t. Grammar c t -> Map c (Set (Rule c t))
cfgRules Grammar c t
cfg) Set c -> Set c -> Set c
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` 
                           [c] -> Set c
forall a. Ord a => [a] -> Set a
Set.fromList [c
c | Set (Rule c t)
rs <- Map c (Set (Rule c t)) -> [Set (Rule c t)]
forall k a. Map k a -> [a]
Map.elems (Grammar c t -> Map c (Set (Rule c t))
forall c t. Grammar c t -> Map c (Set (Rule c t))
cfgRules Grammar c t
cfg), 
                                             Rule c t
r  <- Set (Rule c t) -> [Rule c t]
forall a. Set a -> [a]
Set.toList Set (Rule c t)
rs, 
                                             NonTerminal c
c <- Rule c t -> [Symbol c t]
forall c t. Rule c t -> [Symbol c t]
ruleRhs Rule c t
r])

-- | Gets all rules for the given category.
catRules :: Ord c => Grammar c t -> c -> [Rule c t]
catRules :: Grammar c t -> c -> [Rule c t]
catRules Grammar c t
gr c
c = Set (Rule c t) -> [Rule c t]
forall a. Set a -> [a]
Set.toList (Set (Rule c t) -> [Rule c t]) -> Set (Rule c t) -> [Rule c t]
forall a b. (a -> b) -> a -> b
$ Set (Rule c t) -> c -> Map c (Set (Rule c t)) -> Set (Rule c t)
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set (Rule c t)
forall a. Set a
Set.empty c
c (Grammar c t -> Map c (Set (Rule c t))
forall c t. Grammar c t -> Map c (Set (Rule c t))
cfgRules Grammar c t
gr)

-- | Gets all rules for categories in the given set.
catSetRules :: CFG -> Set Cat -> [CFRule]
catSetRules :: CFG -> Set String -> [Rule String String]
catSetRules CFG
gr Set String
cs = CFG -> [Rule String String]
forall c t. Grammar c t -> [Rule c t]
allRules (CFG -> [Rule String String]) -> CFG -> [Rule String String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> CFG -> CFG
forall c t. (c -> Bool) -> Grammar c t -> Grammar c t
filterCFGCats (String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
cs) CFG
gr

mapCFGCats :: (Ord c,Ord c',Ord t) => (c -> c') -> Grammar c t -> Grammar c' t
mapCFGCats :: (c -> c') -> Grammar c t -> Grammar c' t
mapCFGCats c -> c'
f Grammar c t
cfg = c' -> Set c' -> Map c' (Set (Rule c' t)) -> Grammar c' t
forall c t. c -> Set c -> Map c (Set (Rule c t)) -> Grammar c t
Grammar (c -> c'
f (Grammar c t -> c
forall c t. Grammar c t -> c
cfgStartCat Grammar c t
cfg)) 
                           ((c -> c') -> Set c -> Set c'
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map c -> c'
f (Grammar c t -> Set c
forall c t. Grammar c t -> Set c
cfgExternalCats Grammar c t
cfg))
                           ([Rule c' t] -> Map c' (Set (Rule c' t))
forall c t. (Ord c, Ord t) => [Rule c t] -> Map c (Set (Rule c t))
groupProds [c' -> [Symbol c' t] -> CFTerm -> Rule c' t
forall c t. c -> [Symbol c t] -> CFTerm -> Rule c t
Rule (c -> c'
f c
lhs) ((Symbol c t -> Symbol c' t) -> [Symbol c t] -> [Symbol c' t]
forall a b. (a -> b) -> [a] -> [b]
map ((c -> c') -> (t -> t) -> Symbol c t -> Symbol c' t
forall c c' t t'.
(c -> c') -> (t -> t') -> Symbol c t -> Symbol c' t'
mapSymbol c -> c'
f t -> t
forall a. a -> a
id) [Symbol c t]
rhs) CFTerm
t | Rule c
lhs [Symbol c t]
rhs CFTerm
t <- Grammar c t -> [Rule c t]
forall c t. Grammar c t -> [Rule c t]
allRules Grammar c t
cfg])

onRules :: (Ord c,Ord t) => ([Rule c t] -> [Rule c t]) -> Grammar c t -> Grammar c t
onRules :: ([Rule c t] -> [Rule c t]) -> Grammar c t -> Grammar c t
onRules [Rule c t] -> [Rule c t]
f Grammar c t
cfg = Grammar c t
cfg { cfgRules :: Map c (Set (Rule c t))
cfgRules = [Rule c t] -> Map c (Set (Rule c t))
forall c t. (Ord c, Ord t) => [Rule c t] -> Map c (Set (Rule c t))
groupProds ([Rule c t] -> Map c (Set (Rule c t)))
-> [Rule c t] -> Map c (Set (Rule c t))
forall a b. (a -> b) -> a -> b
$ [Rule c t] -> [Rule c t]
f ([Rule c t] -> [Rule c t]) -> [Rule c t] -> [Rule c t]
forall a b. (a -> b) -> a -> b
$ Grammar c t -> [Rule c t]
forall c t. Grammar c t -> [Rule c t]
allRules Grammar c t
cfg }

-- | Clean up CFG after rules have been removed.
cleanCFG :: Ord c => Grammar c t -> Grammar c t
cleanCFG :: Grammar c t -> Grammar c t
cleanCFG Grammar c t
cfg = Grammar c t
cfg{ cfgRules :: Map c (Set (Rule c t))
cfgRules = (Set (Rule c t) -> Bool)
-> Map c (Set (Rule c t)) -> Map c (Set (Rule c t))
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not (Bool -> Bool)
-> (Set (Rule c t) -> Bool) -> Set (Rule c t) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Rule c t) -> Bool
forall a. Set a -> Bool
Set.null) (Grammar c t -> Map c (Set (Rule c t))
forall c t. Grammar c t -> Map c (Set (Rule c t))
cfgRules Grammar c t
cfg) }

-- | Combine two CFGs.
unionCFG :: (Ord c,Ord t) => Grammar c t -> Grammar c t -> Grammar c t
unionCFG :: Grammar c t -> Grammar c t -> Grammar c t
unionCFG Grammar c t
x Grammar c t
y = Grammar c t
x { cfgRules :: Map c (Set (Rule c t))
cfgRules = (Set (Rule c t) -> Set (Rule c t) -> Set (Rule c t))
-> Map c (Set (Rule c t))
-> Map c (Set (Rule c t))
-> Map c (Set (Rule c t))
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set (Rule c t) -> Set (Rule c t) -> Set (Rule c t)
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Grammar c t -> Map c (Set (Rule c t))
forall c t. Grammar c t -> Map c (Set (Rule c t))
cfgRules Grammar c t
x) (Grammar c t -> Map c (Set (Rule c t))
forall c t. Grammar c t -> Map c (Set (Rule c t))
cfgRules Grammar c t
y) }

filterCFG :: (Rule c t -> Bool) -> Grammar c t -> Grammar c t
filterCFG :: (Rule c t -> Bool) -> Grammar c t -> Grammar c t
filterCFG Rule c t -> Bool
p Grammar c t
cfg = Grammar c t
cfg { cfgRules :: Map c (Set (Rule c t))
cfgRules = (Set (Rule c t) -> Maybe (Set (Rule c t)))
-> Map c (Set (Rule c t)) -> Map c (Set (Rule c t))
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe Set (Rule c t) -> Maybe (Set (Rule c t))
filterRules (Grammar c t -> Map c (Set (Rule c t))
forall c t. Grammar c t -> Map c (Set (Rule c t))
cfgRules Grammar c t
cfg) }
  where
    filterRules :: Set (Rule c t) -> Maybe (Set (Rule c t))
filterRules Set (Rule c t)
rules = 
      let rules' :: Set (Rule c t)
rules' = (Rule c t -> Bool) -> Set (Rule c t) -> Set (Rule c t)
forall a. (a -> Bool) -> Set a -> Set a
Set.filter Rule c t -> Bool
p Set (Rule c t)
rules
      in if Set (Rule c t) -> Bool
forall a. Set a -> Bool
Set.null Set (Rule c t)
rules' then Maybe (Set (Rule c t))
forall a. Maybe a
Nothing else Set (Rule c t) -> Maybe (Set (Rule c t))
forall a. a -> Maybe a
Just Set (Rule c t)
rules'

filterCFGCats :: (c -> Bool) -> Grammar c t -> Grammar c t
filterCFGCats :: (c -> Bool) -> Grammar c t -> Grammar c t
filterCFGCats c -> Bool
p Grammar c t
cfg = Grammar c t
cfg { cfgRules :: Map c (Set (Rule c t))
cfgRules = (c -> Set (Rule c t) -> Bool)
-> Map c (Set (Rule c t)) -> Map c (Set (Rule c t))
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\c
c Set (Rule c t)
_ -> c -> Bool
p c
c) (Grammar c t -> Map c (Set (Rule c t))
forall c t. Grammar c t -> Map c (Set (Rule c t))
cfgRules Grammar c t
cfg) }

countCats :: Ord c => Grammar c t -> Int
countCats :: Grammar c t -> Int
countCats = Map c (Set (Rule c t)) -> Int
forall k a. Map k a -> Int
Map.size (Map c (Set (Rule c t)) -> Int)
-> (Grammar c t -> Map c (Set (Rule c t))) -> Grammar c t -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Grammar c t -> Map c (Set (Rule c t))
forall c t. Grammar c t -> Map c (Set (Rule c t))
cfgRules (Grammar c t -> Map c (Set (Rule c t)))
-> (Grammar c t -> Grammar c t)
-> Grammar c t
-> Map c (Set (Rule c t))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Grammar c t -> Grammar c t
forall c t. Ord c => Grammar c t -> Grammar c t
cleanCFG

countRules :: Grammar c t -> Int
countRules :: Grammar c t -> Int
countRules = [Rule c t] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Rule c t] -> Int)
-> (Grammar c t -> [Rule c t]) -> Grammar c t -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Grammar c t -> [Rule c t]
forall c t. Grammar c t -> [Rule c t]
allRules

prCFG :: CFG -> String
prCFG :: CFG -> String
prCFG = [(String, String)] -> String
prProductions ([(String, String)] -> String)
-> (CFG -> [(String, String)]) -> CFG -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rule String String -> (String, String))
-> [Rule String String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map Rule String String -> (String, String)
prRule ([Rule String String] -> [(String, String)])
-> (CFG -> [Rule String String]) -> CFG -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFG -> [Rule String String]
forall c t. Grammar c t -> [Rule c t]
allRules
    where 
      prRule :: Rule String String -> (String, String)
prRule Rule String String
r = (Rule String String -> String
forall c t. Rule c t -> c
ruleLhs Rule String String
r, [String] -> String
unwords ((Symbol String String -> String)
-> [Symbol String String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Symbol String String -> String
prSym (Rule String String -> [Symbol String String]
forall c t. Rule c t -> [Symbol c t]
ruleRhs Rule String String
r)))
      prSym :: Symbol String String -> String
prSym = ShowS -> ShowS -> Symbol String String -> String
forall c a t. (c -> a) -> (t -> a) -> Symbol c t -> a
symbol ShowS
forall a. a -> a
id (\String
t -> String
"\""String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
t String -> ShowS
forall a. [a] -> [a] -> [a]
++String
"\"")

prProductions :: [(Cat,String)] -> String
prProductions :: [(String, String)] -> String
prProductions [(String, String)]
prods = 
    [String] -> String
unlines [Int -> ShowS
rpad Int
maxLHSWidth String
lhs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ::= " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
rhs | (String
lhs,String
rhs) <- [(String, String)]
prods]
    where
      maxLHSWidth :: Int
maxLHSWidth = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Int
0Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:(((String, String) -> Int) -> [(String, String)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> ((String, String) -> String) -> (String, String) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst) [(String, String)]
prods)
      rpad :: Int -> ShowS
rpad Int
n String
s = String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
' '

prCFTerm :: CFTerm -> String
prCFTerm :: CFTerm -> String
prCFTerm = Integer -> CFTerm -> String
forall t. (Eq t, Num t) => t -> CFTerm -> String
pr Integer
0
  where
    pr :: t -> CFTerm -> String
pr t
p (CFObj CId
f [CFTerm]
args) = t -> ShowS
forall a. (Eq a, Num a) => a -> ShowS
paren t
p (CId -> String
showCId CId
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"," ((CFTerm -> String) -> [CFTerm] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (t -> CFTerm -> String
pr t
0) [CFTerm]
args)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")")
    pr t
p (CFAbs Int
i CFTerm
t) = t -> ShowS
forall a. (Eq a, Num a) => a -> ShowS
paren t
p (String
"\\x" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
". " String -> ShowS
forall a. [a] -> [a] -> [a]
++ t -> CFTerm -> String
pr t
0 CFTerm
t)
    pr t
p (CFApp CFTerm
t1 CFTerm
t2) = t -> ShowS
forall a. (Eq a, Num a) => a -> ShowS
paren t
p (t -> CFTerm -> String
pr t
1 CFTerm
t1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ t -> CFTerm -> String
pr t
0 CFTerm
t2 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")")
    pr t
_ (CFRes Int
i) = String
"$" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
    pr t
_ (CFVar Int
i) = String
"x" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
    pr t
_ (CFMeta CId
c) = String
"?" String -> ShowS
forall a. [a] -> [a] -> [a]
++ CId -> String
showCId CId
c
    paren :: a -> ShowS
paren a
0 String
x = String
x
    paren a
1 String
x = String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

--
-- * CFRule Utilities
--

ruleFun :: Rule c t -> CId
ruleFun :: Rule c t -> CId
ruleFun (Rule c
_ [Symbol c t]
_ CFTerm
t) = CFTerm -> CId
f CFTerm
t
  where f :: CFTerm -> CId
f (CFObj CId
n [CFTerm]
_) = CId
n
        f (CFApp CFTerm
_ CFTerm
x) = CFTerm -> CId
f CFTerm
x
        f (CFAbs Int
_ CFTerm
x) = CFTerm -> CId
f CFTerm
x
        f CFTerm
_ = String -> CId
mkCId String
""

-- | Check if any of the categories used on the right-hand side
--   are in the given list of categories.
anyUsedBy :: Eq c => [c] -> Rule c t -> Bool
anyUsedBy :: [c] -> Rule c t -> Bool
anyUsedBy [c]
cs (Rule c
_ [Symbol c t]
ss CFTerm
_) = (c -> Bool) -> [c] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (c -> [c] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [c]
cs) ([Symbol c t] -> [c]
forall c t. [Symbol c t] -> [c]
filterCats [Symbol c t]
ss)

mkCFTerm :: String -> CFTerm
mkCFTerm :: String -> CFTerm
mkCFTerm String
n = CId -> [CFTerm] -> CFTerm
CFObj (String -> CId
mkCId String
n) []

ruleIsNonRecursive :: Ord c => Set c -> Rule c t -> Bool
ruleIsNonRecursive :: Set c -> Rule c t -> Bool
ruleIsNonRecursive Set c
cs = Set c -> [Symbol c t] -> Bool
forall c t. Ord c => Set c -> [Symbol c t] -> Bool
noCatsInSet Set c
cs ([Symbol c t] -> Bool)
-> (Rule c t -> [Symbol c t]) -> Rule c t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule c t -> [Symbol c t]
forall c t. Rule c t -> [Symbol c t]
ruleRhs

-- | Check if all the rules are right-linear, or all the rules are
--   left-linear, with respect to given categories.
allXLinear :: Ord c => Set c -> [Rule c t] -> Bool
allXLinear :: Set c -> [Rule c t] -> Bool
allXLinear Set c
cs [Rule c t]
rs = (Rule c t -> Bool) -> [Rule c t] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Set c -> Rule c t -> Bool
forall c t. Ord c => Set c -> Rule c t -> Bool
isRightLinear Set c
cs) [Rule c t]
rs Bool -> Bool -> Bool
|| (Rule c t -> Bool) -> [Rule c t] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Set c -> Rule c t -> Bool
forall c t. Ord c => Set c -> Rule c t -> Bool
isLeftLinear Set c
cs) [Rule c t]
rs

-- | Checks if a context-free rule is right-linear.
isRightLinear :: Ord c
              => Set c    -- ^ The categories to consider
              -> Rule c t -- ^ The rule to check for right-linearity
              -> Bool
isRightLinear :: Set c -> Rule c t -> Bool
isRightLinear Set c
cs = Set c -> [Symbol c t] -> Bool
forall c t. Ord c => Set c -> [Symbol c t] -> Bool
noCatsInSet Set c
cs ([Symbol c t] -> Bool)
-> (Rule c t -> [Symbol c t]) -> Rule c t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Symbol c t] -> [Symbol c t]
forall a. [a] -> [a]
safeInit ([Symbol c t] -> [Symbol c t])
-> (Rule c t -> [Symbol c t]) -> Rule c t -> [Symbol c t]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule c t -> [Symbol c t]
forall c t. Rule c t -> [Symbol c t]
ruleRhs

-- | Checks if a context-free rule is left-linear.
isLeftLinear :: Ord c
             => Set c    -- ^ The categories to consider
             -> Rule c t -- ^ The rule to check for left-linearity
             -> Bool
isLeftLinear :: Set c -> Rule c t -> Bool
isLeftLinear Set c
cs = Set c -> [Symbol c t] -> Bool
forall c t. Ord c => Set c -> [Symbol c t] -> Bool
noCatsInSet Set c
cs ([Symbol c t] -> Bool)
-> (Rule c t -> [Symbol c t]) -> Rule c t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Symbol c t] -> [Symbol c t]
forall a. Int -> [a] -> [a]
drop Int
1 ([Symbol c t] -> [Symbol c t])
-> (Rule c t -> [Symbol c t]) -> Rule c t -> [Symbol c t]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule c t -> [Symbol c t]
forall c t. Rule c t -> [Symbol c t]
ruleRhs


--
-- * Symbol utilities
--

symbol :: (c -> a) -> (t -> a) -> Symbol c t -> a
symbol :: (c -> a) -> (t -> a) -> Symbol c t -> a
symbol c -> a
fc t -> a
ft (NonTerminal c
cat) = c -> a
fc c
cat
symbol c -> a
fc t -> a
ft (Terminal t
tok) = t -> a
ft t
tok

mapSymbol :: (c -> c') -> (t -> t') -> Symbol c t -> Symbol c' t'
mapSymbol :: (c -> c') -> (t -> t') -> Symbol c t -> Symbol c' t'
mapSymbol c -> c'
fc t -> t'
ft = (c -> Symbol c' t')
-> (t -> Symbol c' t') -> Symbol c t -> Symbol c' t'
forall c a t. (c -> a) -> (t -> a) -> Symbol c t -> a
symbol (c' -> Symbol c' t'
forall c t. c -> Symbol c t
NonTerminal (c' -> Symbol c' t') -> (c -> c') -> c -> Symbol c' t'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> c'
fc) (t' -> Symbol c' t'
forall c t. t -> Symbol c t
Terminal (t' -> Symbol c' t') -> (t -> t') -> t -> Symbol c' t'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> t'
ft)

filterCats :: [Symbol c t] -> [c]
filterCats :: [Symbol c t] -> [c]
filterCats [Symbol c t]
syms = [ c
cat | NonTerminal c
cat <- [Symbol c t]
syms ]

filterToks :: [Symbol c t] -> [t]
filterToks :: [Symbol c t] -> [t]
filterToks [Symbol c t]
syms = [ t
tok | Terminal t
tok <- [Symbol c t]
syms ]

-- | Checks if a symbol is a non-terminal of one of the given categories.
catElem :: Ord c => Symbol c t -> Set c -> Bool
catElem :: Symbol c t -> Set c -> Bool
catElem Symbol c t
s Set c
cs = (c -> Bool) -> (t -> Bool) -> Symbol c t -> Bool
forall c a t. (c -> a) -> (t -> a) -> Symbol c t -> a
symbol (c -> Set c -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set c
cs) (Bool -> t -> Bool
forall a b. a -> b -> a
const Bool
False) Symbol c t
s

noCatsInSet :: Ord c => Set c -> [Symbol c t] -> Bool
noCatsInSet :: Set c -> [Symbol c t] -> Bool
noCatsInSet Set c
cs = Bool -> Bool
not (Bool -> Bool) -> ([Symbol c t] -> Bool) -> [Symbol c t] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Symbol c t -> Bool) -> [Symbol c t] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Symbol c t -> Set c -> Bool
forall c t. Ord c => Symbol c t -> Set c -> Bool
`catElem` Set c
cs)