module CLaSH.Core.TyCon
( TyCon (..)
, TyConName
, AlgTyConRhs (..)
, mkKindTyCon
, isTupleTyConLike
, tyConDataCons
)
where
import Control.DeepSeq
import Data.Monoid (mempty)
import Data.Typeable hiding (TyCon,tyConName)
import GHC.Generics
import Unbound.Generics.LocallyNameless (Alpha(..),Subst(..))
import Unbound.Generics.LocallyNameless.Name (Name(..),name2String)
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
}
deriving (Generic,Typeable)
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,Generic)
instance Alpha TyCon where
aeq' c tc1 tc2 = aeq' c (tyConName tc1) (tyConName tc2)
fvAny' _ _ tc = pure tc
close _ _ tc = tc
open _ _ tc = tc
isPat _ = mempty
isTerm _ = True
nthPatFind _ = Left
namePatFind _ _ = Left 0
swaps' _ _ tc = tc
lfreshen' _ tc cont = cont tc mempty
freshen' _ tc = return (tc,mempty)
acompare' c tc1 tc2 = acompare' c (tyConName tc1) (tyConName tc2)
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 tcSubst -> rnf nm `seq` rnf ki `seq` rnf ar `seq` rnf tcSubst
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
(Fn s i) -> rnf s `seq` rnf i
(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 _ = []