module CLaSH.Core.TyCon
( TyCon (..)
, TyConName
, AlgTyConRhs (..)
, PrimRep (..)
, 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
}
| PrimTyCon
{ tyConName :: TyConName
, tyConKind :: Kind
, tyConArity :: Int
, primTyConRep :: PrimRep
}
| SuperKindTyCon
{ tyConName :: TyConName
}
instance Show TyCon where
show (AlgTyCon {tyConName = n}) = "AlgTyCon: " ++ 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
data PrimRep
= IntRep
| VoidRep
deriving Show
Unbound.derive [''TyCon,''AlgTyConRhs,''PrimRep]
instance Alpha PrimRep
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 Type PrimRep
instance Subst Term TyCon
instance Subst Term AlgTyConRhs
instance Subst Term PrimRep
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
PrimTyCon nm ki ar rep -> rnf nm `seq` rnf ki `seq` rnf ar `seq` rnf rep
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
instance NFData PrimRep where
rnf pm = case pm of
IntRep -> ()
VoidRep -> ()
mkKindTyCon :: TyConName
-> Kind
-> TyCon
mkKindTyCon name kind
= PrimTyCon name kind 0 VoidRep
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 _ = []