{-|
  Copyright   :  (C) 2012-2016, University of Twente
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>

  Type Constructors in CoreHW
-}

{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Clash.Core.TyCon
  ( TyCon (..)
  , TyConName
  , TyConMap
  , AlgTyConRhs (..)
  , mkKindTyCon
  , isTupleTyConLike
  , isNewTypeTc
  , tyConDataCons
  )
where

-- External Import
import Control.DeepSeq
import Data.Binary                            (Binary)
import qualified Data.Text as T
import GHC.Generics

-- Internal Imports
import Clash.Core.DataCon                     (DataCon)
import Clash.Core.Name
import {-# SOURCE #-} Clash.Core.Type         (Kind, Type)
import Clash.Core.Var                         (TyVar)
import Clash.Unique
import Clash.Util

-- | Type Constructor
data TyCon
  -- | Algorithmic DataCons
  = AlgTyCon
  { TyCon -> Unique
tyConUniq   :: {-# UNPACK #-} !Unique
  , TyCon -> TyConName
tyConName   :: !TyConName   -- ^ Name of the TyCon
  , TyCon -> Kind
tyConKind   :: !Kind        -- ^ Kind of the TyCon
  , TyCon -> Unique
tyConArity  :: !Int         -- ^ Number of type arguments
  , TyCon -> AlgTyConRhs
algTcRhs    :: !AlgTyConRhs -- ^ DataCon definitions
  , TyCon -> Bool
isClassTc   :: !Bool        -- ^ Is this a class dictionary?
  }
  -- | Function TyCons (e.g. type families)
  | FunTyCon
  { tyConUniq   :: {-# UNPACK #-} !Unique
  , tyConName   :: !TyConName      -- ^ Name of the TyCon
  , tyConKind   :: !Kind           -- ^ Kind of the TyCon
  , tyConArity  :: !Int            -- ^ Number of type arguments
  , TyCon -> [([Kind], Kind)]
tyConSubst  :: [([Type],Type)] -- ^ List of: ([LHS match types], RHS type)
  }
  -- | Primitive TyCons
  | PrimTyCon
  { tyConUniq    :: {-# UNPACK #-} !Unique
  , tyConName    :: !TyConName  -- ^ Name of the TyCon
  , tyConKind    :: !Kind       -- ^ Kind of the TyCon
  , tyConArity   :: !Int        -- ^ Number of type arguments
  }
  -- | To close the loop on the type hierarchy
  | SuperKindTyCon
  { tyConUniq    :: {-# UNPACK #-} !Unique
  , tyConName    :: !TyConName  -- ^ Name of the TyCon
  }
  deriving ((forall x. TyCon -> Rep TyCon x)
-> (forall x. Rep TyCon x -> TyCon) -> Generic TyCon
forall x. Rep TyCon x -> TyCon
forall x. TyCon -> Rep TyCon x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TyCon x -> TyCon
$cfrom :: forall x. TyCon -> Rep TyCon x
Generic,TyCon -> ()
(TyCon -> ()) -> NFData TyCon
forall a. (a -> ()) -> NFData a
rnf :: TyCon -> ()
$crnf :: TyCon -> ()
NFData,Get TyCon
[TyCon] -> Put
TyCon -> Put
(TyCon -> Put) -> Get TyCon -> ([TyCon] -> Put) -> Binary TyCon
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [TyCon] -> Put
$cputList :: [TyCon] -> Put
get :: Get TyCon
$cget :: Get TyCon
put :: TyCon -> Put
$cput :: TyCon -> Put
Binary)

instance Show TyCon where
  show :: TyCon -> String
show (AlgTyCon       {tyConName :: TyCon -> TyConName
tyConName = TyConName
n}) = "AlgTyCon: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TyConName -> String
forall a. Show a => a -> String
show TyConName
n
  show (FunTyCon       {tyConName :: TyCon -> TyConName
tyConName = TyConName
n}) = "FunTyCon: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TyConName -> String
forall a. Show a => a -> String
show TyConName
n
  show (PrimTyCon      {tyConName :: TyCon -> TyConName
tyConName = TyConName
n}) = "PrimTyCon: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TyConName -> String
forall a. Show a => a -> String
show TyConName
n
  show (SuperKindTyCon {tyConName :: TyCon -> TyConName
tyConName = TyConName
n}) = "SuperKindTyCon: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TyConName -> String
forall a. Show a => a -> String
show TyConName
n

instance Eq TyCon where
  == :: TyCon -> TyCon -> Bool
(==) = Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Unique -> Unique -> Bool)
-> (TyCon -> Unique) -> TyCon -> TyCon -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TyCon -> Unique
tyConUniq
  /= :: TyCon -> TyCon -> Bool
(/=) = Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
(/=) (Unique -> Unique -> Bool)
-> (TyCon -> Unique) -> TyCon -> TyCon -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TyCon -> Unique
tyConUniq

instance Uniquable TyCon where
  getUnique :: TyCon -> Unique
getUnique = TyCon -> Unique
tyConUniq
  setUnique :: TyCon -> Unique -> TyCon
setUnique tyCon :: TyCon
tyCon u :: Unique
u = TyCon
tyCon {tyConUniq :: Unique
tyConUniq=Unique
u}

-- | TyCon reference
type TyConName = Name TyCon
type TyConMap  = UniqMap TyCon

-- | The RHS of an Algebraic Datatype
data AlgTyConRhs
  = DataTyCon
  { AlgTyConRhs -> [DataCon]
dataCons :: [DataCon]        -- ^ The DataCons of a TyCon
  }
  | NewTyCon
  { AlgTyConRhs -> DataCon
dataCon   :: !DataCon        -- ^ The newtype DataCon
  , AlgTyConRhs -> ([TyVar], Kind)
ntEtadRhs :: ([TyVar],Type)  -- ^ The argument type of the newtype
                                 -- DataCon in eta-reduced form, which is
                                 -- just the representation of the TyCon.
                                 -- The TyName's are the type-variables from
                                 -- the corresponding TyCon.
  }
  deriving (Unique -> AlgTyConRhs -> ShowS
[AlgTyConRhs] -> ShowS
AlgTyConRhs -> String
(Unique -> AlgTyConRhs -> ShowS)
-> (AlgTyConRhs -> String)
-> ([AlgTyConRhs] -> ShowS)
-> Show AlgTyConRhs
forall a.
(Unique -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AlgTyConRhs] -> ShowS
$cshowList :: [AlgTyConRhs] -> ShowS
show :: AlgTyConRhs -> String
$cshow :: AlgTyConRhs -> String
showsPrec :: Unique -> AlgTyConRhs -> ShowS
$cshowsPrec :: Unique -> AlgTyConRhs -> ShowS
Show,(forall x. AlgTyConRhs -> Rep AlgTyConRhs x)
-> (forall x. Rep AlgTyConRhs x -> AlgTyConRhs)
-> Generic AlgTyConRhs
forall x. Rep AlgTyConRhs x -> AlgTyConRhs
forall x. AlgTyConRhs -> Rep AlgTyConRhs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AlgTyConRhs x -> AlgTyConRhs
$cfrom :: forall x. AlgTyConRhs -> Rep AlgTyConRhs x
Generic,AlgTyConRhs -> ()
(AlgTyConRhs -> ()) -> NFData AlgTyConRhs
forall a. (a -> ()) -> NFData a
rnf :: AlgTyConRhs -> ()
$crnf :: AlgTyConRhs -> ()
NFData,Get AlgTyConRhs
[AlgTyConRhs] -> Put
AlgTyConRhs -> Put
(AlgTyConRhs -> Put)
-> Get AlgTyConRhs -> ([AlgTyConRhs] -> Put) -> Binary AlgTyConRhs
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [AlgTyConRhs] -> Put
$cputList :: [AlgTyConRhs] -> Put
get :: Get AlgTyConRhs
$cget :: Get AlgTyConRhs
put :: AlgTyConRhs -> Put
$cput :: AlgTyConRhs -> Put
Binary)

-- | Create a Kind out of a TyConName
mkKindTyCon :: TyConName
            -> Kind
            -> TyCon
mkKindTyCon :: TyConName -> Kind -> TyCon
mkKindTyCon name :: TyConName
name kind :: Kind
kind
  = Unique -> TyConName -> Kind -> Unique -> TyCon
PrimTyCon (TyConName -> Unique
forall a. Name a -> Unique
nameUniq TyConName
name) TyConName
name Kind
kind 0

-- | Does the TyCon look like a tuple TyCon
isTupleTyConLike :: TyConName -> Bool
isTupleTyConLike :: TyConName -> Bool
isTupleTyConLike nm :: TyConName
nm = Text -> Bool
tupleName (TyConName -> Text
forall a. Name a -> Text
nameOcc TyConName
nm)
  where
    tupleName :: Text -> Bool
tupleName nm' :: Text
nm'
      | Char
'(' <- Text -> Char
T.head Text
nm'
      , Char
')' <- Text -> Char
T.last Text
nm'
      = (Char -> Bool) -> Text -> Bool
T.all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ',') (Text -> Text
T.init (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.tail Text
nm')
    tupleName _ = Bool
False

-- | Get the DataCons belonging to a TyCon
tyConDataCons :: TyCon -> [DataCon]
tyConDataCons :: TyCon -> [DataCon]
tyConDataCons (AlgTyCon {algTcRhs :: TyCon -> AlgTyConRhs
algTcRhs = DataTyCon { dataCons :: AlgTyConRhs -> [DataCon]
dataCons = [DataCon]
cons}}) = [DataCon]
cons
tyConDataCons (AlgTyCon {algTcRhs :: TyCon -> AlgTyConRhs
algTcRhs = NewTyCon  { dataCon :: AlgTyConRhs -> DataCon
dataCon  = DataCon
con }}) = [DataCon
con]
tyConDataCons _                                                    = []

isNewTypeTc
  :: TyCon
  -> Bool
isNewTypeTc :: TyCon -> Bool
isNewTypeTc (AlgTyCon {algTcRhs :: TyCon -> AlgTyConRhs
algTcRhs = NewTyCon {}}) = Bool
True
isNewTypeTc _ = Bool
False