{-
    BNF Converter: Haskell GADT back-end common stuff
    Copyright (C) 2004-2005  Author:  Markus Forsberg, Björn Bringert

-}

module BNFC.Backend.HaskellGADT.HaskellGADTCommon (Constructor(..), cf2cons, isTreeType) where

import BNFC.CF
import BNFC.Backend.Haskell.Utils ( catToVar )


data Constructor = Constructor
    { Constructor -> Cat
consCat :: Cat
    , Constructor -> TokenCat
consFun :: Fun
    , Constructor -> Integer
consPrec :: Integer
    , Constructor -> [(Cat, TokenCat)]
consVars :: [(Cat,String)]
    , Constructor -> [Either Cat TokenCat]
consRhs :: [Either Cat String]
    }

-- | Get category, function, and rhs categories paired with variable names.

cf2cons :: CF -> [Constructor]
cf2cons :: CF -> [Constructor]
cf2cons CF
cf =
    [  Constructor :: Cat
-> TokenCat
-> Integer
-> [(Cat, TokenCat)]
-> [Either Cat TokenCat]
-> Constructor
Constructor
        { consCat :: Cat
consCat = Cat
cat, consFun :: TokenCat
consFun = TokenCat
fun, consPrec :: Integer
consPrec = CF -> TokenCat -> Integer
precFun CF
cf TokenCat
fun
        , consVars :: [(Cat, TokenCat)]
consVars = [Cat] -> [TokenCat] -> [(Cat, TokenCat)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Cat]
cats ([Cat] -> [TokenCat]
mkVars [Cat]
cats), consRhs :: [Either Cat TokenCat]
consRhs = CF -> TokenCat -> [Either Cat TokenCat]
rhsFun CF
cf TokenCat
fun
        } | (Cat
cat,[(TokenCat, [Cat])]
rules) <- CF -> [(Cat, [(TokenCat, [Cat])])]
cf2data CF
cf, (TokenCat
fun,[Cat]
cats) <- [(TokenCat, [Cat])]
rules]
    [Constructor] -> [Constructor] -> [Constructor]
forall a. [a] -> [a] -> [a]
++ [ Constructor :: Cat
-> TokenCat
-> Integer
-> [(Cat, TokenCat)]
-> [Either Cat TokenCat]
-> Constructor
Constructor
        { consCat :: Cat
consCat = TokenCat -> Cat
TokenCat TokenCat
cat, consFun :: TokenCat
consFun = TokenCat
cat, consPrec :: Integer
consPrec = Integer
0
        , consVars :: [(Cat, TokenCat)]
consVars = [(TokenCat -> Cat
Cat TokenCat
"String",TokenCat
"str")], consRhs :: [Either Cat TokenCat]
consRhs = [Cat -> Either Cat TokenCat
forall a b. a -> Either a b
Left (TokenCat -> Cat
Cat TokenCat
"String")]
        } | TokenCat
cat <- CF -> [TokenCat]
specialCats CF
cf]
  where
    mkVars :: [Cat] -> [TokenCat]
mkVars [Cat]
cats = [TokenCat] -> Int -> [TokenCat]
forall {t}. (Ord t, Num t, Show t) => [TokenCat] -> t -> [TokenCat]
mkUnique ((Cat -> TokenCat) -> [Cat] -> [TokenCat]
forall a b. (a -> b) -> [a] -> [b]
map ([TokenCat] -> Cat -> TokenCat
catToVar []) [Cat]
cats) (Int
0 :: Int)
    mkUnique :: [TokenCat] -> t -> [TokenCat]
mkUnique [] t
_ = []
    mkUnique (TokenCat
x:[TokenCat]
xs) t
n | TokenCat
x TokenCat -> [TokenCat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TokenCat]
xs Bool -> Bool -> Bool
|| t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> t
0 = (TokenCat
x TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ t -> TokenCat
forall a. Show a => a -> TokenCat
show t
n) TokenCat -> [TokenCat] -> [TokenCat]
forall a. a -> [a] -> [a]
: [TokenCat] -> t -> [TokenCat]
mkUnique [TokenCat]
xs (t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1)
                      | Bool
otherwise = TokenCat
x TokenCat -> [TokenCat] -> [TokenCat]
forall a. a -> [a] -> [a]
: [TokenCat] -> t -> [TokenCat]
mkUnique [TokenCat]
xs t
n

-- | Get the rule for a function.

ruleFun :: CF -> Fun -> Rule
ruleFun :: CF -> TokenCat -> Rule
ruleFun CF
cf TokenCat
f = [Rule] -> Rule
forall a. [a] -> a
head ([Rule] -> Rule) -> [Rule] -> Rule
forall a b. (a -> b) -> a -> b
$ (Rule -> Bool) -> [Rule] -> [Rule]
forall a. (a -> Bool) -> [a] -> [a]
filter ((TokenCat
f TokenCat -> TokenCat -> Bool
forall a. Eq a => a -> a -> Bool
==) (TokenCat -> Bool) -> (Rule -> TokenCat) -> Rule -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RFun -> TokenCat
forall a. IsFun a => a -> TokenCat
funName (RFun -> TokenCat) -> (Rule -> RFun) -> Rule -> TokenCat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule -> RFun
forall function. Rul function -> function
funRule) ([Rule] -> [Rule]) -> [Rule] -> [Rule]
forall a b. (a -> b) -> a -> b
$ CF -> [Rule]
forall function. CFG function -> [Rul function]
cfgRules CF
cf

-- | Get the precedence of a function.

precFun :: CF -> Fun -> Integer
precFun :: CF -> TokenCat -> Integer
precFun CF
cf TokenCat
f = Rule -> Integer
forall f. Rul f -> Integer
precRule (Rule -> Integer) -> Rule -> Integer
forall a b. (a -> b) -> a -> b
$ CF -> TokenCat -> Rule
ruleFun CF
cf TokenCat
f

-- | Get the RHS of a function

rhsFun :: CF -> Fun -> [Either Cat String]
rhsFun :: CF -> TokenCat -> [Either Cat TokenCat]
rhsFun CF
cf TokenCat
f = Rule -> [Either Cat TokenCat]
forall function. Rul function -> [Either Cat TokenCat]
rhsRule (Rule -> [Either Cat TokenCat]) -> Rule -> [Either Cat TokenCat]
forall a b. (a -> b) -> a -> b
$ CF -> TokenCat -> Rule
ruleFun CF
cf TokenCat
f

isTreeType :: CF -> Cat -> Bool
isTreeType :: CF -> Cat -> Bool
isTreeType CF
cf (TokenCat TokenCat
c) = TokenCat
c TokenCat -> [TokenCat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CF -> [TokenCat]
specialCats CF
cf
isTreeType CF
cf Cat
c
  | Cat -> Bool
isList Cat
c  = CF -> Cat -> Bool
isTreeType CF
cf (Cat -> Cat
catOfList Cat
c)
  | Bool
otherwise = Cat
c Cat -> [Cat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CF -> [Cat]
forall f. CFG f -> [Cat]
reallyAllCats CF
cf