module CLaSH.Core.TyCon
( TyCon (..)
, TyConName
, AlgTyConRhs (..)
, mkKindTyCon
, isTupleTyConLike
, tyConDataCons
)
where
import Control.DeepSeq
import GHC.Generics
import Unbound.Generics.LocallyNameless (Alpha(..))
import Unbound.Generics.LocallyNameless.Extra ()
import Unbound.Generics.LocallyNameless.Name (Name,name2String)
import CLaSH.Core.DataCon (DataCon)
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,NFData)
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,NFData,Alpha)
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)
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 _ = []