BNFC.hs

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 {
                 lhsCat :: Cat,
                 ruleRhs :: [BNFCSymbol],
                 ruleName :: CFTerm }
              | BNFCCoercions {
                 coerCat :: Cat,
                 coerNum :: Int }
              | BNFCTerminator {
                 termNonEmpty :: Bool,
                 termCat :: Cat,
                 termSep :: String }
              | BNFCSeparator {
                 sepNonEmpty :: Bool,
                 sepCat :: Cat,
                 sepSep :: String }
              deriving (Eq, Ord, Show)

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

bnfc2cf :: [BNFCRule] -> [ParamCFRule]
bnfc2cf rules = concatMap (transformRules (map makeSepTerm rules1)) rules2
  where (rules1,rules2) = partition isSepTerm rules
        makeSepTerm (BNFCTerminator ne c s) = (c, (ne, False, s))
        makeSepTerm (BNFCSeparator  ne c s) = (c, (ne, True,  s))

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

transformRules :: SepMap -> BNFCRule -> [ParamCFRule]
transformRules sepMap (BNFCRule c smbs@(s:ss) r) = Rule (c,[0]) cfSmbs r : rls
  where smbs'   = map (transformSymb sepMap) smbs
        cfSmbs  = [snd s | s            <- smbs']
        ids = filter (/= "") [fst s | s <- smbs']
        rls = concatMap (createListRules sepMap) ids
transformRules sepMap (BNFCCoercions c num) = rules ++ [lastRule]
          where rules = map (fRules c)  [0..num-1]
                lastRule = Rule (c',[0]) ss rn
                  where c' = c ++ show num
                        ss = [Terminal "(", NonTerminal (c,[0]), Terminal ")"]
                        rn = CFObj (mkCId $ "coercion_" ++ c) []

fRules c n = Rule (c',[0]) ss rn
   where c' = if n == 0 then c else c ++ show n
         ss = [NonTerminal (c ++ show (n+1),[0])]
         rn = CFObj (mkCId $ "coercion_" ++ c') []

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

createListRules :: SepMap -> String -> [ParamCFRule]
createListRules sepMap c =
  case lookup c sepMap of
    Just (ne, isSep, symb) -> createListRules' ne isSep symb c
    Nothing                -> createListRules' False True "" c

createListRules':: IsNonempty -> IsSeparator -> SepTermSymb -> String -> [ParamCFRule]
createListRules' ne isSep symb c = ruleBase : ruleCons
  where ruleBase = Rule ("List" ++ c,[0]) smbs rn
          where smbs = if isSep
                       then [NonTerminal (c,[0]) | ne]
                       else [NonTerminal (c,[0]) | ne] ++
                            [Terminal symb | symb /= "" && ne]
                rn   = CFObj (mkCId $ "Base" ++ c) []
        ruleCons
          | isSep && symb /= "" && not ne = [Rule ("List" ++ c,[1]) smbs0 rn
                                            ,Rule ("List" ++ c,[1]) smbs1 rn]
          | otherwise                     = [Rule ("List" ++ c,[0]) smbs  rn]
          where smbs0 =[NonTerminal (c,[0])] ++
                       [NonTerminal ("List" ++ c,[0])]
                smbs1 =[NonTerminal (c,[0])] ++
                       [Terminal symb] ++
                       [NonTerminal ("List" ++ c,[1])]
                smbs = [NonTerminal (c,[0])] ++
                       [Terminal symb | symb /= ""] ++
                       [NonTerminal ("List" ++ c,[0])]
                rn   = CFObj (mkCId $ "Cons" ++ c) []