module CLaSH.Core.TyCon
( TyCon (..)
, TyConName
, AlgTyConRhs (..)
, mkKindTyCon
, isTupleTyConLike
, tyConDataCons
)
where
import Control.DeepSeq
import Unbound.LocallyNameless as Unbound hiding (rnf)
import Unbound.LocallyNameless.Name (Name(Nm,Bn))
import CLaSH.Core.DataCon (DataCon)
import CLaSH.Core.Term (Term)
import CLaSH.Core.Type (Kind, TyName, Type)
import CLaSH.Util
data TyCon
= AlgTyCon
{ tyConName :: TyConName
, tyConKind :: Kind
, tyConArity :: Int
, algTcRhs :: AlgTyConRhs
}
| FunTyCon
{ tyConName :: TyConName
, tyConKind :: Kind
, tyConArity :: Int
, tyConSubst :: [([Type],Type)]
}
| PrimTyCon
{ tyConName :: TyConName
, tyConKind :: Kind
, tyConArity :: Int
}
| SuperKindTyCon
{ tyConName :: TyConName
}
instance Show TyCon where
show (AlgTyCon {tyConName = n}) = "AlgTyCon: " ++ show n
show (FunTyCon {tyConName = n}) = "FunTyCon: " ++ show n
show (PrimTyCon {tyConName = n}) = "PrimTyCon: " ++ show n
show (SuperKindTyCon {tyConName = n}) = "SuperKindTyCon: " ++ show n
instance Eq TyCon where
(==) = (==) `on` tyConName
instance Ord TyCon where
compare = compare `on` tyConName
type TyConName = Name TyCon
data AlgTyConRhs
= DataTyCon
{ dataCons :: [DataCon]
}
| NewTyCon
{ dataCon :: DataCon
, ntEtadRhs :: ([TyName],Type)
}
deriving Show
Unbound.derive [''TyCon,''AlgTyConRhs]
instance Alpha TyCon where
swaps' _ _ d = d
fv' _ _ = emptyC
lfreshen' _ a f = f a empty
freshen' _ a = return (a,empty)
aeq' _ tc1 tc2 = aeq (tyConName tc1) (tyConName tc2)
acompare' _ tc1 tc2 = acompare (tyConName tc1) (tyConName tc2)
open _ _ d = d
close _ _ d = d
isPat _ = error "isPat TyCon"
isTerm _ = error "isTerm TyCon"
isEmbed _ = error "isEmbed TyCon"
nthpatrec _ = error "nthpatrec TyCon"
findpatrec _ _ = error "findpatrec TyCon"
instance Alpha AlgTyConRhs
instance Subst Type TyCon
instance Subst Type AlgTyConRhs
instance Subst Term TyCon
instance Subst Term AlgTyConRhs
instance NFData TyCon where
rnf tc = case tc of
AlgTyCon nm ki ar rhs -> rnf nm `seq` rnf ki `seq` rnf ar `seq` rnf rhs
FunTyCon nm ki ar subst -> rnf nm `seq` rnf ki `seq` rnf ar `seq` rnf subst
PrimTyCon nm ki ar -> rnf nm `seq` rnf ki `seq` rnf ar
SuperKindTyCon nm -> rnf nm
instance NFData (Name TyCon) where
rnf nm = case nm of
(Nm _ s) -> rnf s
(Bn _ l r) -> rnf l `seq` rnf r
instance NFData AlgTyConRhs where
rnf rhs = case rhs of
DataTyCon dcs -> rnf dcs
NewTyCon dc eta -> rnf dc `seq` rnf eta
mkKindTyCon :: TyConName
-> Kind
-> TyCon
mkKindTyCon name kind
= PrimTyCon name kind 0
isTupleTyConLike :: TyConName -> Bool
isTupleTyConLike nm = tupleName (name2String nm)
where
tupleName nm
| '(' <- head nm
, ')' <- last nm
= all (== ',') (init $ tail nm)
tupleName _ = False
tyConDataCons :: TyCon -> [DataCon]
tyConDataCons (AlgTyCon {algTcRhs = DataTyCon { dataCons = cons}}) = cons
tyConDataCons (AlgTyCon {algTcRhs = NewTyCon { dataCon = con }}) = [con]
tyConDataCons _ = []