module CLaSH.Core.DataCon
( DataCon (..)
, DcName
, ConTag
, dataConInstArgTys
)
where
import Data.Monoid (mempty)
import Data.Typeable (Typeable)
import Control.DeepSeq (NFData(..))
import GHC.Generics (Generic)
import Unbound.Generics.LocallyNameless (Alpha(..),Subst,substs)
import Unbound.Generics.LocallyNameless.Name (Name(..))
import CLaSH.Core.Term (Term)
import CLaSH.Core.Type (TyName, Type)
import CLaSH.Util
data DataCon
= MkData
{ dcName :: DcName
, dcTag :: ConTag
, dcType :: Type
, dcUnivTyVars :: [TyName]
, dcExtTyVars :: [TyName]
, dcArgTys :: [Type]
} deriving (Generic,Typeable)
instance Show DataCon where
show = show . dcName
instance Eq DataCon where
(==) = (==) `on` dcName
instance Ord DataCon where
compare = compare `on` dcName
type ConTag = Int
type DcName = Name DataCon
instance Alpha DataCon where
aeq' c dc1 dc2 = aeq' c (dcName dc1) (dcName dc2)
fvAny' _ _ dc = pure dc
close _ _ dc = dc
open _ _ dc = dc
isPat _ = mempty
isTerm _ = True
nthPatFind _ = Left
namePatFind _ _ = Left 0
swaps' _ _ dc = dc
lfreshen' _ dc cont = cont dc mempty
freshen' _ dc = return (dc,mempty)
acompare' c dc1 dc2 = acompare' c (dcName dc1) (dcName dc2)
instance Subst Type DataCon
instance Subst Term DataCon
instance NFData DataCon where
rnf dc = case dc of
MkData nm tag ty uv ev args -> rnf nm `seq` rnf tag `seq` rnf ty `seq`
rnf uv `seq` rnf ev `seq` rnf args
instance NFData (Name DataCon) where
rnf nm = case nm of
(Fn s i) -> rnf s `seq` rnf i
(Bn l r) -> rnf l `seq` rnf r
dataConInstArgTys :: DataCon -> [Type] -> [Type]
dataConInstArgTys (MkData { dcArgTys = arg_tys
, dcUnivTyVars = univ_tvs
, dcExtTyVars = ex_tvs
})
inst_tys
| length tyvars == length inst_tys
= map (substs (zip tyvars inst_tys)) arg_tys
| otherwise
= error $ $(curLoc) ++ "dataConInstArgTys: number of tyVars and Types differ"
where
tyvars = univ_tvs ++ ex_tvs