----------------------------------------------------------------------
-- |
-- Module      : CFEG 
-- Maintainer  : Gleb Lobanov 
-- Stability   : (experimental)
-- Portability : (portable)
--
-- > CVS $Date: 2016/03/16 19:59:00 $ 
-- > CVS $Author: Gleb Lobanov $
-- > CVS $Revision: 0.1 $
--
-- Contains a function to convert extended CF grammars to CF grammars. 
-----------------------------------------------------------------------------

module GF.Grammar.BNFC(BNFCRule(..), BNFCSymbol, Symbol(..), CFTerm(..), bnfc2cf) where

import GF.Grammar.CFG
import PGF (Token, mkCId)
import Data.List (partition)

type IsList = Bool
type BNFCSymbol = Symbol (Cat, IsList) Token
data BNFCRule = BNFCRule {
                 BNFCRule -> Cat
lhsCat :: Cat,
                 BNFCRule -> [BNFCSymbol]
ruleRhs :: [BNFCSymbol],
                 BNFCRule -> CFTerm
ruleName :: CFTerm }
              | BNFCCoercions {
                 BNFCRule -> Cat
coerCat :: Cat,
                 BNFCRule -> Int
coerNum :: Int }
              | BNFCTerminator {
                 BNFCRule -> Bool
termNonEmpty :: Bool,
                 BNFCRule -> Cat
termCat :: Cat,
                 BNFCRule -> Cat
termSep :: String }
              | BNFCSeparator {
                 BNFCRule -> Bool
sepNonEmpty :: Bool,
                 BNFCRule -> Cat
sepCat :: Cat,
                 BNFCRule -> Cat
sepSep :: String }
              deriving (BNFCRule -> BNFCRule -> Bool
(BNFCRule -> BNFCRule -> Bool)
-> (BNFCRule -> BNFCRule -> Bool) -> Eq BNFCRule
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BNFCRule -> BNFCRule -> Bool
$c/= :: BNFCRule -> BNFCRule -> Bool
== :: BNFCRule -> BNFCRule -> Bool
$c== :: BNFCRule -> BNFCRule -> Bool
Eq, Eq BNFCRule
Eq BNFCRule
-> (BNFCRule -> BNFCRule -> Ordering)
-> (BNFCRule -> BNFCRule -> Bool)
-> (BNFCRule -> BNFCRule -> Bool)
-> (BNFCRule -> BNFCRule -> Bool)
-> (BNFCRule -> BNFCRule -> Bool)
-> (BNFCRule -> BNFCRule -> BNFCRule)
-> (BNFCRule -> BNFCRule -> BNFCRule)
-> Ord BNFCRule
BNFCRule -> BNFCRule -> Bool
BNFCRule -> BNFCRule -> Ordering
BNFCRule -> BNFCRule -> BNFCRule
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 :: BNFCRule -> BNFCRule -> BNFCRule
$cmin :: BNFCRule -> BNFCRule -> BNFCRule
max :: BNFCRule -> BNFCRule -> BNFCRule
$cmax :: BNFCRule -> BNFCRule -> BNFCRule
>= :: BNFCRule -> BNFCRule -> Bool
$c>= :: BNFCRule -> BNFCRule -> Bool
> :: BNFCRule -> BNFCRule -> Bool
$c> :: BNFCRule -> BNFCRule -> Bool
<= :: BNFCRule -> BNFCRule -> Bool
$c<= :: BNFCRule -> BNFCRule -> Bool
< :: BNFCRule -> BNFCRule -> Bool
$c< :: BNFCRule -> BNFCRule -> Bool
compare :: BNFCRule -> BNFCRule -> Ordering
$ccompare :: BNFCRule -> BNFCRule -> Ordering
$cp1Ord :: Eq BNFCRule
Ord, Int -> BNFCRule -> ShowS
[BNFCRule] -> ShowS
BNFCRule -> Cat
(Int -> BNFCRule -> ShowS)
-> (BNFCRule -> Cat) -> ([BNFCRule] -> ShowS) -> Show BNFCRule
forall a.
(Int -> a -> ShowS) -> (a -> Cat) -> ([a] -> ShowS) -> Show a
showList :: [BNFCRule] -> ShowS
$cshowList :: [BNFCRule] -> ShowS
show :: BNFCRule -> Cat
$cshow :: BNFCRule -> Cat
showsPrec :: Int -> BNFCRule -> ShowS
$cshowsPrec :: Int -> BNFCRule -> ShowS
Show)

type IsNonempty  = Bool
type IsSeparator = Bool
type SepTermSymb = String 
type SepMap      = [(Cat, (IsNonempty, IsSeparator, SepTermSymb))]

bnfc2cf :: [BNFCRule] -> [ParamCFRule]
bnfc2cf :: [BNFCRule] -> [ParamCFRule]
bnfc2cf [BNFCRule]
rules = (BNFCRule -> [ParamCFRule]) -> [BNFCRule] -> [ParamCFRule]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (SepMap -> BNFCRule -> [ParamCFRule]
transformRules ((BNFCRule -> (Cat, (Bool, Bool, Cat))) -> [BNFCRule] -> SepMap
forall a b. (a -> b) -> [a] -> [b]
map BNFCRule -> (Cat, (Bool, Bool, Cat))
makeSepTerm [BNFCRule]
rules1)) [BNFCRule]
rules2
  where ([BNFCRule]
rules1,[BNFCRule]
rules2) = (BNFCRule -> Bool) -> [BNFCRule] -> ([BNFCRule], [BNFCRule])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition BNFCRule -> Bool
isSepTerm [BNFCRule]
rules
        makeSepTerm :: BNFCRule -> (Cat, (Bool, Bool, Cat))
makeSepTerm (BNFCTerminator Bool
ne Cat
c Cat
s) = (Cat
c, (Bool
ne, Bool
False, Cat
s))
        makeSepTerm (BNFCSeparator  Bool
ne Cat
c Cat
s) = (Cat
c, (Bool
ne, Bool
True,  Cat
s))

isSepTerm :: BNFCRule -> Bool
isSepTerm :: BNFCRule -> Bool
isSepTerm (BNFCTerminator {}) = Bool
True
isSepTerm (BNFCSeparator  {}) = Bool
True
isSepTerm BNFCRule
_                   = Bool
False

transformRules :: SepMap -> BNFCRule -> [ParamCFRule]
transformRules :: SepMap -> BNFCRule -> [ParamCFRule]
transformRules SepMap
sepMap (BNFCRule Cat
c smbs :: [BNFCSymbol]
smbs@(BNFCSymbol
s:[BNFCSymbol]
ss) CFTerm
r) = (Cat, [Int]) -> [Symbol (Cat, [Int]) Cat] -> CFTerm -> ParamCFRule
forall c t. c -> [Symbol c t] -> CFTerm -> Rule c t
Rule (Cat
c,[Int
0]) [Symbol (Cat, [Int]) Cat]
cfSmbs CFTerm
r ParamCFRule -> [ParamCFRule] -> [ParamCFRule]
forall a. a -> [a] -> [a]
: [ParamCFRule]
rls
  where smbs' :: [(Cat, Symbol (Cat, [Int]) Cat)]
smbs'   = (BNFCSymbol -> (Cat, Symbol (Cat, [Int]) Cat))
-> [BNFCSymbol] -> [(Cat, Symbol (Cat, [Int]) Cat)]
forall a b. (a -> b) -> [a] -> [b]
map (SepMap -> BNFCSymbol -> (Cat, Symbol (Cat, [Int]) Cat)
transformSymb SepMap
sepMap) [BNFCSymbol]
smbs
        cfSmbs :: [Symbol (Cat, [Int]) Cat]
cfSmbs  = [(Cat, Symbol (Cat, [Int]) Cat) -> Symbol (Cat, [Int]) Cat
forall a b. (a, b) -> b
snd (Cat, Symbol (Cat, [Int]) Cat)
s | (Cat, Symbol (Cat, [Int]) Cat)
s            <- [(Cat, Symbol (Cat, [Int]) Cat)]
smbs']
        ids :: [Cat]
ids = (Cat -> Bool) -> [Cat] -> [Cat]
forall a. (a -> Bool) -> [a] -> [a]
filter (Cat -> Cat -> Bool
forall a. Eq a => a -> a -> Bool
/= Cat
"") [(Cat, Symbol (Cat, [Int]) Cat) -> Cat
forall a b. (a, b) -> a
fst (Cat, Symbol (Cat, [Int]) Cat)
s | (Cat, Symbol (Cat, [Int]) Cat)
s <- [(Cat, Symbol (Cat, [Int]) Cat)]
smbs']
        rls :: [ParamCFRule]
rls = (Cat -> [ParamCFRule]) -> [Cat] -> [ParamCFRule]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (SepMap -> Cat -> [ParamCFRule]
createListRules SepMap
sepMap) [Cat]
ids
transformRules SepMap
sepMap (BNFCCoercions Cat
c Int
num) = [ParamCFRule]
forall t. [Rule (Cat, [Int]) t]
rules [ParamCFRule] -> [ParamCFRule] -> [ParamCFRule]
forall a. [a] -> [a] -> [a]
++ [ParamCFRule
lastRule]
          where rules :: [Rule (Cat, [Int]) t]
rules = (Int -> Rule (Cat, [Int]) t) -> [Int] -> [Rule (Cat, [Int]) t]
forall a b. (a -> b) -> [a] -> [b]
map (Cat -> Int -> Rule (Cat, [Int]) t
forall a a t.
(Num a, Eq a, Num a, Show a) =>
Cat -> a -> Rule (Cat, [a]) t
fRules Cat
c)  [Int
0..Int
numInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
                lastRule :: ParamCFRule
lastRule = (Cat, [Int]) -> [Symbol (Cat, [Int]) Cat] -> CFTerm -> ParamCFRule
forall c t. c -> [Symbol c t] -> CFTerm -> Rule c t
Rule (Cat
c',[Int
0]) [Symbol (Cat, [Int]) Cat]
ss CFTerm
rn
                  where c' :: Cat
c' = Cat
c Cat -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Cat
forall a. Show a => a -> Cat
show Int
num
                        ss :: [Symbol (Cat, [Int]) Cat]
ss = [Cat -> Symbol (Cat, [Int]) Cat
forall c t. t -> Symbol c t
Terminal Cat
"(", (Cat, [Int]) -> Symbol (Cat, [Int]) Cat
forall c t. c -> Symbol c t
NonTerminal (Cat
c,[Int
0]), Cat -> Symbol (Cat, [Int]) Cat
forall c t. t -> Symbol c t
Terminal Cat
")"]
                        rn :: CFTerm
rn = CId -> [CFTerm] -> CFTerm
CFObj (Cat -> CId
mkCId (Cat -> CId) -> Cat -> CId
forall a b. (a -> b) -> a -> b
$ Cat
"coercion_" Cat -> ShowS
forall a. [a] -> [a] -> [a]
++ Cat
c) []

fRules :: Cat -> a -> Rule (Cat, [a]) t
fRules Cat
c a
n = (Cat, [a]) -> [Symbol (Cat, [a]) t] -> CFTerm -> Rule (Cat, [a]) t
forall c t. c -> [Symbol c t] -> CFTerm -> Rule c t
Rule (Cat
c',[a
0]) [Symbol (Cat, [a]) t]
forall t. [Symbol (Cat, [a]) t]
ss CFTerm
rn
   where c' :: Cat
c' = if a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 then Cat
c else Cat
c Cat -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> Cat
forall a. Show a => a -> Cat
show a
n
         ss :: [Symbol (Cat, [a]) t]
ss = [(Cat, [a]) -> Symbol (Cat, [a]) t
forall c t. c -> Symbol c t
NonTerminal (Cat
c Cat -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> Cat
forall a. Show a => a -> Cat
show (a
na -> a -> a
forall a. Num a => a -> a -> a
+a
1),[a
0])]
         rn :: CFTerm
rn = CId -> [CFTerm] -> CFTerm
CFObj (Cat -> CId
mkCId (Cat -> CId) -> Cat -> CId
forall a b. (a -> b) -> a -> b
$ Cat
"coercion_" Cat -> ShowS
forall a. [a] -> [a] -> [a]
++ Cat
c') []

transformSymb :: SepMap -> BNFCSymbol -> (String, ParamCFSymbol)
transformSymb :: SepMap -> BNFCSymbol -> (Cat, Symbol (Cat, [Int]) Cat)
transformSymb SepMap
sepMap BNFCSymbol
s = case BNFCSymbol
s of
  NonTerminal (Cat
c,Bool
False) -> (Cat
"", (Cat, [Int]) -> Symbol (Cat, [Int]) Cat
forall c t. c -> Symbol c t
NonTerminal (Cat
c,[Int
0]))
  NonTerminal (Cat
c,Bool
True ) -> let needsCoercion :: Bool
needsCoercion = 
                                 case Cat -> SepMap -> Maybe (Bool, Bool, Cat)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Cat
c SepMap
sepMap of
                                   Just (Bool
ne, Bool
isSep, Cat
symb) -> Bool
isSep Bool -> Bool -> Bool
&& Cat
symb Cat -> Cat -> Bool
forall a. Eq a => a -> a -> Bool
/= Cat
"" Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
ne
                                   Maybe (Bool, Bool, Cat)
Nothing                -> Bool
False
                           in (Cat
c , (Cat, [Int]) -> Symbol (Cat, [Int]) Cat
forall c t. c -> Symbol c t
NonTerminal (Cat
"List" Cat -> ShowS
forall a. [a] -> [a] -> [a]
++ Cat
c,if Bool
needsCoercion then [Int
0,Int
1] else [Int
0]))
  Terminal Cat
t            -> (Cat
"", Cat -> Symbol (Cat, [Int]) Cat
forall c t. t -> Symbol c t
Terminal Cat
t)

createListRules :: SepMap -> String -> [ParamCFRule]
createListRules :: SepMap -> Cat -> [ParamCFRule]
createListRules SepMap
sepMap Cat
c =
  case Cat -> SepMap -> Maybe (Bool, Bool, Cat)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Cat
c SepMap
sepMap of
    Just (Bool
ne, Bool
isSep, Cat
symb) -> Bool -> Bool -> Cat -> Cat -> [ParamCFRule]
createListRules' Bool
ne Bool
isSep Cat
symb Cat
c
    Maybe (Bool, Bool, Cat)
Nothing                -> Bool -> Bool -> Cat -> Cat -> [ParamCFRule]
createListRules' Bool
False Bool
True Cat
"" Cat
c

createListRules':: IsNonempty -> IsSeparator -> SepTermSymb -> String -> [ParamCFRule]
createListRules' :: Bool -> Bool -> Cat -> Cat -> [ParamCFRule]
createListRules' Bool
ne Bool
isSep Cat
symb Cat
c = ParamCFRule
ruleBase ParamCFRule -> [ParamCFRule] -> [ParamCFRule]
forall a. a -> [a] -> [a]
: [ParamCFRule]
ruleCons
  where ruleBase :: ParamCFRule
ruleBase = (Cat, [Int]) -> [Symbol (Cat, [Int]) Cat] -> CFTerm -> ParamCFRule
forall c t. c -> [Symbol c t] -> CFTerm -> Rule c t
Rule (Cat
"List" Cat -> ShowS
forall a. [a] -> [a] -> [a]
++ Cat
c,[Int
0]) [Symbol (Cat, [Int]) Cat]
smbs CFTerm
rn
          where smbs :: [Symbol (Cat, [Int]) Cat]
smbs = if Bool
isSep
                       then [(Cat, [Int]) -> Symbol (Cat, [Int]) Cat
forall c t. c -> Symbol c t
NonTerminal (Cat
c,[Int
0]) | Bool
ne]
                       else [(Cat, [Int]) -> Symbol (Cat, [Int]) Cat
forall c t. c -> Symbol c t
NonTerminal (Cat
c,[Int
0]) | Bool
ne] [Symbol (Cat, [Int]) Cat]
-> [Symbol (Cat, [Int]) Cat] -> [Symbol (Cat, [Int]) Cat]
forall a. [a] -> [a] -> [a]
++
                            [Cat -> Symbol (Cat, [Int]) Cat
forall c t. t -> Symbol c t
Terminal Cat
symb | Cat
symb Cat -> Cat -> Bool
forall a. Eq a => a -> a -> Bool
/= Cat
"" Bool -> Bool -> Bool
&& Bool
ne]
                rn :: CFTerm
rn   = CId -> [CFTerm] -> CFTerm
CFObj (Cat -> CId
mkCId (Cat -> CId) -> Cat -> CId
forall a b. (a -> b) -> a -> b
$ Cat
"Base" Cat -> ShowS
forall a. [a] -> [a] -> [a]
++ Cat
c) []
        ruleCons :: [ParamCFRule]
ruleCons
          | Bool
isSep Bool -> Bool -> Bool
&& Cat
symb Cat -> Cat -> Bool
forall a. Eq a => a -> a -> Bool
/= Cat
"" Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
ne = [(Cat, [Int]) -> [Symbol (Cat, [Int]) Cat] -> CFTerm -> ParamCFRule
forall c t. c -> [Symbol c t] -> CFTerm -> Rule c t
Rule (Cat
"List" Cat -> ShowS
forall a. [a] -> [a] -> [a]
++ Cat
c,[Int
1]) [Symbol (Cat, [Int]) Cat]
forall t. [Symbol (Cat, [Int]) t]
smbs0 CFTerm
rn
                                            ,(Cat, [Int]) -> [Symbol (Cat, [Int]) Cat] -> CFTerm -> ParamCFRule
forall c t. c -> [Symbol c t] -> CFTerm -> Rule c t
Rule (Cat
"List" Cat -> ShowS
forall a. [a] -> [a] -> [a]
++ Cat
c,[Int
1]) [Symbol (Cat, [Int]) Cat]
smbs1 CFTerm
rn]
          | Bool
otherwise                     = [(Cat, [Int]) -> [Symbol (Cat, [Int]) Cat] -> CFTerm -> ParamCFRule
forall c t. c -> [Symbol c t] -> CFTerm -> Rule c t
Rule (Cat
"List" Cat -> ShowS
forall a. [a] -> [a] -> [a]
++ Cat
c,[Int
0]) [Symbol (Cat, [Int]) Cat]
smbs  CFTerm
rn]
          where smbs0 :: [Symbol (Cat, [Int]) t]
smbs0 =[(Cat, [Int]) -> Symbol (Cat, [Int]) t
forall c t. c -> Symbol c t
NonTerminal (Cat
c,[Int
0])] [Symbol (Cat, [Int]) t]
-> [Symbol (Cat, [Int]) t] -> [Symbol (Cat, [Int]) t]
forall a. [a] -> [a] -> [a]
++
                       [(Cat, [Int]) -> Symbol (Cat, [Int]) t
forall c t. c -> Symbol c t
NonTerminal (Cat
"List" Cat -> ShowS
forall a. [a] -> [a] -> [a]
++ Cat
c,[Int
0])]
                smbs1 :: [Symbol (Cat, [Int]) Cat]
smbs1 =[(Cat, [Int]) -> Symbol (Cat, [Int]) Cat
forall c t. c -> Symbol c t
NonTerminal (Cat
c,[Int
0])] [Symbol (Cat, [Int]) Cat]
-> [Symbol (Cat, [Int]) Cat] -> [Symbol (Cat, [Int]) Cat]
forall a. [a] -> [a] -> [a]
++
                       [Cat -> Symbol (Cat, [Int]) Cat
forall c t. t -> Symbol c t
Terminal Cat
symb] [Symbol (Cat, [Int]) Cat]
-> [Symbol (Cat, [Int]) Cat] -> [Symbol (Cat, [Int]) Cat]
forall a. [a] -> [a] -> [a]
++
                       [(Cat, [Int]) -> Symbol (Cat, [Int]) Cat
forall c t. c -> Symbol c t
NonTerminal (Cat
"List" Cat -> ShowS
forall a. [a] -> [a] -> [a]
++ Cat
c,[Int
1])]
                smbs :: [Symbol (Cat, [Int]) Cat]
smbs = [(Cat, [Int]) -> Symbol (Cat, [Int]) Cat
forall c t. c -> Symbol c t
NonTerminal (Cat
c,[Int
0])] [Symbol (Cat, [Int]) Cat]
-> [Symbol (Cat, [Int]) Cat] -> [Symbol (Cat, [Int]) Cat]
forall a. [a] -> [a] -> [a]
++
                       [Cat -> Symbol (Cat, [Int]) Cat
forall c t. t -> Symbol c t
Terminal Cat
symb | Cat
symb Cat -> Cat -> Bool
forall a. Eq a => a -> a -> Bool
/= Cat
""] [Symbol (Cat, [Int]) Cat]
-> [Symbol (Cat, [Int]) Cat] -> [Symbol (Cat, [Int]) Cat]
forall a. [a] -> [a] -> [a]
++
                       [(Cat, [Int]) -> Symbol (Cat, [Int]) Cat
forall c t. c -> Symbol c t
NonTerminal (Cat
"List" Cat -> ShowS
forall a. [a] -> [a] -> [a]
++ Cat
c,[Int
0])]
                rn :: CFTerm
rn   = CId -> [CFTerm] -> CFTerm
CFObj (Cat -> CId
mkCId (Cat -> CId) -> Cat -> CId
forall a b. (a -> b) -> a -> b
$ Cat
"Cons" Cat -> ShowS
forall a. [a] -> [a] -> [a]
++ Cat
c) []