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) []