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

-- | Get the rule for a function.

ruleFun :: CF -> Fun -> Rule
ruleFun :: CF -> Fun -> Rule
ruleFun CF
cf Fun
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 ((Fun
f Fun -> Fun -> Bool
forall a. Eq a => a -> a -> Bool
==) (Fun -> Bool) -> (Rule -> Fun) -> Rule -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RFun -> Fun
forall a. IsFun a => a -> Fun
funName (RFun -> Fun) -> (Rule -> RFun) -> Rule -> Fun
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 -> Fun -> Integer
precFun CF
cf Fun
f = Rule -> Integer
forall f. Rul f -> Integer
precRule (Rule -> Integer) -> Rule -> Integer
forall a b. (a -> b) -> a -> b
$ CF -> Fun -> Rule
ruleFun CF
cf Fun
f

-- | Get the RHS of a function

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

isTreeType :: CF -> Cat -> Bool
isTreeType :: CF -> Cat -> Bool
isTreeType CF
cf (TokenCat Fun
c) = Fun
c Fun -> [Fun] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CF -> [Fun]
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