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

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

module Clash.GHC.NetlistTypes
  (ghcTypeToHWType)
where

import Data.Coerce                      (coerce)
import Data.Functor.Identity            (Identity (..))
import Data.Text                        (pack)
import Control.Monad.State.Strict       (State)
import Control.Monad.Trans.Except
  (Except, ExceptT (..), mapExceptT, runExceptT, throwE)
import Control.Monad.Trans.Maybe        (MaybeT (..))
import Language.Haskell.TH.Syntax       (showName)

import Clash.Core.DataCon               (DataCon (..))
import Clash.Core.Name                  (Name (..))
import Clash.Core.Pretty                (showPpr)
import Clash.Core.TyCon                 (TyConMap, tyConDataCons)
import Clash.Core.Type
  (LitTy (..), Type (..), TypeView (..), coreView, coreView1, tyView)
import Clash.Core.Util                  (tyNatSize, substArgTys)
import Clash.Netlist.Util               (coreTypeToHWType, stripFiltered)
import Clash.Netlist.Types
  (HWType(..), HWMap, FilteredHWType(..), PortDirection (..))
import Clash.Signal.Internal
  (ResetPolarity(..), ActiveEdge(..), ResetKind(..)
  ,InitBehavior(..))
import Clash.Unique                     (lookupUniqMap')
import Clash.Util                       (curLoc)

import Clash.Annotations.BitRepresentation.Internal
  (CustomReprs)

ghcTypeToHWType
  :: Int
  -- ^ Integer width. The width Clash assumes an Integer to be (instead of it
  -- begin an arbitrarily large, runtime sized construct).
  -> Bool
  -- ^ Float support
  -> CustomReprs
  -- ^ Custom bit representations
  -> TyConMap
  -- ^ Type constructor map
  -> Type
  -- ^ Type to convert to HWType
  -> State HWMap (Maybe (Either String FilteredHWType))
ghcTypeToHWType :: Int
-> Bool
-> CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
ghcTypeToHWType Int
iw Bool
floatSupport = CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
go
  where
    -- returnN :: HWType ->
    returnN :: HWType -> m FilteredHWType
returnN HWType
t = FilteredHWType -> m FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> [[(Bool, FilteredHWType)]] -> FilteredHWType
FilteredHWType HWType
t [])

    go :: CustomReprs -> TyConMap -> Type -> State HWMap (Maybe (Either String FilteredHWType))
    go :: CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
go CustomReprs
reprs TyConMap
m (AnnType [Attr']
attrs Type
typ) = (Either String FilteredHWType
 -> Maybe (Either String FilteredHWType))
-> StateT HWMap Identity (Either String FilteredHWType)
-> State HWMap (Maybe (Either String FilteredHWType))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Either String FilteredHWType
-> Maybe (Either String FilteredHWType)
forall a. a -> Maybe a
Just (StateT HWMap Identity (Either String FilteredHWType)
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> (ExceptT String (StateT HWMap Identity) FilteredHWType
    -> StateT HWMap Identity (Either String FilteredHWType))
-> ExceptT String (StateT HWMap Identity) FilteredHWType
-> State HWMap (Maybe (Either String FilteredHWType))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT String (StateT HWMap Identity) FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType)
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String (StateT HWMap Identity) FilteredHWType
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> ExceptT String (StateT HWMap Identity) FilteredHWType
-> State HWMap (Maybe (Either String FilteredHWType))
forall a b. (a -> b) -> a -> b
$ do
      FilteredHWType HWType
typ' [[(Bool, FilteredHWType)]]
areVoids <- StateT HWMap Identity (Either String FilteredHWType)
-> ExceptT String (StateT HWMap Identity) FilteredHWType
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (StateT HWMap Identity (Either String FilteredHWType)
 -> ExceptT String (StateT HWMap Identity) FilteredHWType)
-> StateT HWMap Identity (Either String FilteredHWType)
-> ExceptT String (StateT HWMap Identity) FilteredHWType
forall a b. (a -> b) -> a -> b
$ (CustomReprs
 -> TyConMap
 -> Type
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity (Either String FilteredHWType)
coreTypeToHWType CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
go CustomReprs
reprs TyConMap
m Type
typ
      FilteredHWType
-> ExceptT String (StateT HWMap Identity) FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> [[(Bool, FilteredHWType)]] -> FilteredHWType
FilteredHWType ([Attr'] -> HWType -> HWType
Annotated [Attr']
attrs HWType
typ') [[(Bool, FilteredHWType)]]
areVoids)

    go CustomReprs
reprs TyConMap
m ty :: Type
ty@(Type -> TypeView
tyView -> TyConApp TyConName
tc [Type]
args) = MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> State HWMap (Maybe (Either String FilteredHWType))
forall (m :: Type -> Type) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> (ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
    -> MaybeT (StateT HWMap Identity) (Either String FilteredHWType))
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
-> State HWMap (Maybe (Either String FilteredHWType))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
-> State HWMap (Maybe (Either String FilteredHWType))
forall a b. (a -> b) -> a -> b
$
      case TyConName -> OccName
forall a. Name a -> OccName
nameOcc TyConName
tc of
        OccName
"GHC.Int.Int8"                  -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Signed Int
8)
        OccName
"GHC.Int.Int16"                 -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Signed Int
16)
        OccName
"GHC.Int.Int32"                 -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Signed Int
32)
        OccName
"GHC.Int.Int64"                 ->
          if Int
iw Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
64
             then case TyCon -> [DataCon]
tyConDataCons (TyConMap
m TyConMap -> TyConName -> TyCon
forall a b. (HasCallStack, Uniquable a) => UniqMap b -> a -> b
`lookupUniqMap'` TyConName
tc) of
                    [DataCon
dc] -> case DataCon -> [Type]
dcArgTys DataCon
dc of
                      [Type -> TypeView
tyView -> TyConApp TyConName
nm [Type]
_]
                        | TyConName -> OccName
forall a. Name a -> OccName
nameOcc TyConName
nm OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
"GHC.Prim.Int#"   ->
                            String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (String
 -> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType)
-> String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
"Int64 not supported in forced 32-bit mode on a 64-bit machine."
                                             ,String
"Run Clash with `-fclash-intwidth=64`."
                                             ]
                        | TyConName -> OccName
forall a. Name a -> OccName
nameOcc TyConName
nm OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
"GHC.Prim.Int64#" ->
                            HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Signed Int
64)
                      [Type]
_  -> String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (String
 -> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType)
-> String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Int64 DC has unexpected amount of arguments"
                    [DataCon]
_    -> String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (String
 -> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType)
-> String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Int64 TC has unexpected amount of DCs"
             else HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Signed Int
64)
        OccName
"GHC.Word.Word8"                -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Unsigned Int
8)
        OccName
"GHC.Word.Word16"               -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Unsigned Int
16)
        OccName
"GHC.Word.Word32"               -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Unsigned Int
32)
        OccName
"GHC.Word.Word64"               ->
          if Int
iw Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
64
             then case TyCon -> [DataCon]
tyConDataCons (TyConMap
m TyConMap -> TyConName -> TyCon
forall a b. (HasCallStack, Uniquable a) => UniqMap b -> a -> b
`lookupUniqMap'` TyConName
tc) of
                    [DataCon
dc] -> case DataCon -> [Type]
dcArgTys DataCon
dc of
                      [Type -> TypeView
tyView -> TyConApp TyConName
nm [Type]
_]
                        | TyConName -> OccName
forall a. Name a -> OccName
nameOcc TyConName
nm OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
"GHC.Prim.Word#"   ->
                            String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (String
 -> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType)
-> String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
"Word64 not supported in forced 32-bit mode on a 64-bit machine."
                                             ,String
"Run Clash with `-fclash-intwidth=64`."
                                             ]
                        | TyConName -> OccName
forall a. Name a -> OccName
nameOcc TyConName
nm OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
"GHC.Prim.Word64#" ->
                            HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Unsigned Int
64)
                      [Type]
_  -> String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (String
 -> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType)
-> String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Word64 DC has unexpected amount of arguments"
                    [DataCon]
_    -> String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (String
 -> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType)
-> String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Word64 TC has unexpected amount of DCs"
             else HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Unsigned Int
64)
#if MIN_VERSION_ghc(9,0,0)
        "GHC.Num.Integer.Integer"       -> returnN (Signed iw)
        "GHC.Num.Natural.Natural"       -> returnN (Unsigned iw)
#else
        OccName
"GHC.Integer.Type.Integer"      -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Signed Int
iw)
        OccName
"GHC.Natural.Natural"           -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Unsigned Int
iw)
#endif
        OccName
"GHC.Prim.Char#"                -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Unsigned Int
21)
        OccName
"GHC.Prim.Int#"                 -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Signed Int
iw)
        OccName
"GHC.Prim.Word#"                -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Unsigned Int
iw)
        OccName
"GHC.Prim.Int64#"               -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Signed Int
64)
        OccName
"GHC.Prim.Word64#"              -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Unsigned Int
64)
        OccName
"GHC.Prim.Float#" | Bool
floatSupport -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
BitVector Int
32)
        OccName
"GHC.Prim.Double#" | Bool
floatSupport -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
BitVector Int
64)
        OccName
"GHC.Prim.ByteArray#"           ->
          String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (String
 -> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType)
-> String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall a b. (a -> b) -> a -> b
$ String
"Can't translate type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall p. PrettyPrec p => p -> String
showPpr Type
ty

        OccName
"GHC.Types.Bool"                -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN HWType
Bool
        OccName
"GHC.Types.Float" | Bool
floatSupport-> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
BitVector Int
32)
        OccName
"GHC.Types.Double" | Bool
floatSupport -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
BitVector Int
64)
        OccName
"GHC.Prim.~#"                   -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Maybe HWType -> HWType
Void Maybe HWType
forall a. Maybe a
Nothing)

        OccName
"Clash.Signal.Internal.Signal" ->
          MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
 -> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType)
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall a b. (a -> b) -> a -> b
$ State HWMap (Maybe (Either String FilteredHWType))
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT (State HWMap (Maybe (Either String FilteredHWType))
 -> MaybeT (StateT HWMap Identity) (Either String FilteredHWType))
-> State HWMap (Maybe (Either String FilteredHWType))
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
forall a b. (a -> b) -> a -> b
$ Either String FilteredHWType
-> Maybe (Either String FilteredHWType)
forall a. a -> Maybe a
Just (Either String FilteredHWType
 -> Maybe (Either String FilteredHWType))
-> StateT HWMap Identity (Either String FilteredHWType)
-> State HWMap (Maybe (Either String FilteredHWType))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (CustomReprs
 -> TyConMap
 -> Type
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity (Either String FilteredHWType)
coreTypeToHWType CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
go CustomReprs
reprs TyConMap
m ([Type]
args [Type] -> Int -> Type
forall a. [a] -> Int -> a
!! Int
1)

        OccName
"Clash.Signal.BiSignal.BiSignalIn" -> do
          let [Type
_, Type
_, Type
szTy] = [Type]
args
          let fType :: HWType -> FilteredHWType
fType HWType
ty1 = HWType -> [[(Bool, FilteredHWType)]] -> FilteredHWType
FilteredHWType HWType
ty1 []
          (HWType -> FilteredHWType
fType (HWType -> FilteredHWType)
-> (Integer -> HWType) -> Integer -> FilteredHWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PortDirection -> HWType -> HWType
BiDirectional PortDirection
In (HWType -> HWType) -> (Integer -> HWType) -> Integer -> HWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> HWType
BitVector (Int -> HWType) -> (Integer -> Int) -> Integer -> HWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a. Num a => Integer -> a
fromInteger) (Integer -> FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) Integer
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
            Except String Integer
-> ExceptT String (MaybeT (StateT HWMap Identity)) Integer
forall (m :: Type -> Type) e a.
Applicative m =>
Except e a -> ExceptT e (MaybeT m) a
liftE (TyConMap -> Type -> Except String Integer
tyNatSize TyConMap
m Type
szTy)

        OccName
"Clash.Signal.BiSignal.BiSignalOut" -> do
          let [Type
_, Type
_, Type
szTy] = [Type]
args
          let fType :: HWType -> FilteredHWType
fType HWType
ty1 = HWType -> [[(Bool, FilteredHWType)]] -> FilteredHWType
FilteredHWType HWType
ty1 []
          (HWType -> FilteredHWType
fType (HWType -> FilteredHWType)
-> (Integer -> HWType) -> Integer -> FilteredHWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe HWType -> HWType
Void (Maybe HWType -> HWType)
-> (Integer -> Maybe HWType) -> Integer -> HWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HWType -> Maybe HWType
forall a. a -> Maybe a
Just (HWType -> Maybe HWType)
-> (Integer -> HWType) -> Integer -> Maybe HWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PortDirection -> HWType -> HWType
BiDirectional PortDirection
Out (HWType -> HWType) -> (Integer -> HWType) -> Integer -> HWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> HWType
BitVector (Int -> HWType) -> (Integer -> Int) -> Integer -> HWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a. Num a => Integer -> a
fromInteger) (Integer -> FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) Integer
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
            Except String Integer
-> ExceptT String (MaybeT (StateT HWMap Identity)) Integer
forall (m :: Type -> Type) e a.
Applicative m =>
Except e a -> ExceptT e (MaybeT m) a
liftE (TyConMap -> Type -> Except String Integer
tyNatSize TyConMap
m Type
szTy)

        -- XXX: this is a hack to get a KnownDomain from a KnownConfiguration
        OccName
"GHC.Classes.(%,%)"
          | [arg0 :: Type
arg0@(Type -> TypeView
tyView -> TyConApp TyConName
kdNm [Type]
_), Type
arg1] <- [Type]
args
          , TyConName -> OccName
forall a. Name a -> OccName
nameOcc TyConName
kdNm OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
"Clash.Signal.Internal.KnownDomain"
          -> case Type -> TypeView
tyView Type
arg1 of
                TyConApp TyConName
kdNm1 [Type]
_
                  | TyConName -> OccName
forall a. Name a -> OccName
nameOcc TyConName
kdNm1 OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
"Clash.Signal.Internal.KnownDomain"
                  -> do HWType
k1 <- (HWType -> HWType
stripVoid (HWType -> HWType)
-> (FilteredHWType -> HWType) -> FilteredHWType -> HWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilteredHWType -> HWType
stripFiltered) (FilteredHWType -> HWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) HWType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (State HWMap (Maybe (Either String FilteredHWType))
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT (CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
go CustomReprs
reprs TyConMap
m Type
arg0))
                        HWType
k2 <- (HWType -> HWType
stripVoid (HWType -> HWType)
-> (FilteredHWType -> HWType) -> FilteredHWType -> HWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilteredHWType -> HWType
stripFiltered) (FilteredHWType -> HWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) HWType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (State HWMap (Maybe (Either String FilteredHWType))
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT (CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
go CustomReprs
reprs TyConMap
m Type
arg1))
                        HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Maybe HWType -> HWType
Void (HWType -> Maybe HWType
forall a. a -> Maybe a
Just (OccName -> Maybe [OccName] -> [HWType] -> HWType
Product OccName
"(%,%)" Maybe [OccName]
forall a. Maybe a
Nothing [HWType
k1,HWType
k2])))
                  where
                    stripVoid :: HWType -> HWType
stripVoid (Void (Just HWType
t)) = HWType
t
                    stripVoid HWType
t = HWType
t
                TypeView
_ -> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (State HWMap (Maybe (Either String FilteredHWType))
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT (CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
go CustomReprs
reprs TyConMap
m Type
arg0))


        OccName
"Clash.Signal.Internal.KnownDomain"
          -> case TyCon -> [DataCon]
tyConDataCons (TyConMap
m TyConMap -> TyConName -> TyCon
forall a b. (HasCallStack, Uniquable a) => UniqMap b -> a -> b
`lookupUniqMap'` TyConName
tc) of
               [DataCon
dc] -> case DataCon -> [Type] -> [Type]
substArgTys DataCon
dc [Type]
args of
                 [Type
_,Type -> TypeView
tyView -> TyConApp TyConName
_ [Type
_,Type
dom]] -> case Type -> TypeView
tyView (TyConMap -> Type -> Type
coreView TyConMap
m Type
dom) of
                   TyConApp TyConName
_ [Type
tag0, Type
period0, Type
edge0, Type
rstKind0, Type
init0, Type
polarity0] -> do
                     String
tag1      <- TyConMap
-> Type -> ExceptT String (MaybeT (StateT HWMap Identity)) String
forall (m :: Type -> Type).
Monad m =>
TyConMap -> Type -> ExceptT String (MaybeT m) String
domTag TyConMap
m Type
tag0
                     Integer
period1   <- TyConMap
-> Type -> ExceptT String (MaybeT (StateT HWMap Identity)) Integer
forall (m :: Type -> Type).
Monad m =>
TyConMap -> Type -> ExceptT String (MaybeT m) Integer
domPeriod TyConMap
m Type
period0
                     ActiveEdge
edge1     <- TyConMap
-> Type
-> ExceptT String (MaybeT (StateT HWMap Identity)) ActiveEdge
forall (m :: Type -> Type).
Monad m =>
TyConMap -> Type -> ExceptT String (MaybeT m) ActiveEdge
domEdge TyConMap
m Type
edge0
                     ResetKind
rstKind1  <- TyConMap
-> Type
-> ExceptT String (MaybeT (StateT HWMap Identity)) ResetKind
forall (m :: Type -> Type).
Monad m =>
TyConMap -> Type -> ExceptT String (MaybeT m) ResetKind
domResetKind TyConMap
m Type
rstKind0
                     InitBehavior
init1     <- TyConMap
-> Type
-> ExceptT String (MaybeT (StateT HWMap Identity)) InitBehavior
forall (m :: Type -> Type).
Monad m =>
TyConMap -> Type -> ExceptT String (MaybeT m) InitBehavior
domInitBehavior TyConMap
m Type
init0
                     ResetPolarity
polarity1 <- TyConMap
-> Type
-> ExceptT String (MaybeT (StateT HWMap Identity)) ResetPolarity
forall (m :: Type -> Type).
Monad m =>
TyConMap -> Type -> ExceptT String (MaybeT m) ResetPolarity
domResetPolarity TyConMap
m Type
polarity0
                     let kd :: HWType
kd = OccName
-> Integer
-> ActiveEdge
-> ResetKind
-> InitBehavior
-> ResetPolarity
-> HWType
KnownDomain (String -> OccName
pack String
tag1) Integer
period1 ActiveEdge
edge1 ResetKind
rstKind1 InitBehavior
init1 ResetPolarity
polarity1
                     HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Maybe HWType -> HWType
Void (HWType -> Maybe HWType
forall a. a -> Maybe a
Just HWType
kd))
                   TypeView
_ -> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (State HWMap (Maybe (Either String FilteredHWType))
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT (Maybe (Either String FilteredHWType)
-> State HWMap (Maybe (Either String FilteredHWType))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe (Either String FilteredHWType)
forall a. Maybe a
Nothing))
                 [Type]
_ -> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (State HWMap (Maybe (Either String FilteredHWType))
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT (Maybe (Either String FilteredHWType)
-> State HWMap (Maybe (Either String FilteredHWType))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe (Either String FilteredHWType)
forall a. Maybe a
Nothing))
               [DataCon]
_ -> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (State HWMap (Maybe (Either String FilteredHWType))
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT (Maybe (Either String FilteredHWType)
-> State HWMap (Maybe (Either String FilteredHWType))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe (Either String FilteredHWType)
forall a. Maybe a
Nothing))

        OccName
"Clash.Signal.Internal.Clock"
          | [Type
tag0] <- [Type]
args
          -> do
            String
tag1 <- TyConMap
-> Type -> ExceptT String (MaybeT (StateT HWMap Identity)) String
forall (m :: Type -> Type).
Monad m =>
TyConMap -> Type -> ExceptT String (MaybeT m) String
domTag TyConMap
m Type
tag0
            HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (OccName -> HWType
Clock (String -> OccName
pack String
tag1))

        OccName
"Clash.Signal.Internal.Reset"
          | [Type
tag0] <- [Type]
args
          -> do
            String
tag1 <- TyConMap
-> Type -> ExceptT String (MaybeT (StateT HWMap Identity)) String
forall (m :: Type -> Type).
Monad m =>
TyConMap -> Type -> ExceptT String (MaybeT m) String
domTag TyConMap
m Type
tag0
            HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (OccName -> HWType
Reset (String -> OccName
pack String
tag1))

        OccName
"Clash.Signal.Internal.Enable"
          | [Type
tag0] <- [Type]
args
          -> do
            String
tag1 <- TyConMap
-> Type -> ExceptT String (MaybeT (StateT HWMap Identity)) String
forall (m :: Type -> Type).
Monad m =>
TyConMap -> Type -> ExceptT String (MaybeT m) String
domTag TyConMap
m Type
tag0
            HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (OccName -> HWType
Enable (String -> OccName
pack String
tag1))

        OccName
"Clash.Sized.Internal.BitVector.Bit" -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN HWType
Bit

        OccName
"Clash.Sized.Internal.BitVector.BitVector" -> do
          Integer
n <- Except String Integer
-> ExceptT String (MaybeT (StateT HWMap Identity)) Integer
forall (m :: Type -> Type) e a.
Applicative m =>
Except e a -> ExceptT e (MaybeT m) a
liftE (TyConMap -> Type -> Except String Integer
tyNatSize TyConMap
m ([Type] -> Type
forall a. [a] -> a
head [Type]
args))
          case Integer
n of
            Integer
0 -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Maybe HWType -> HWType
Void (HWType -> Maybe HWType
forall a. a -> Maybe a
Just (Int -> HWType
BitVector (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n))))
            Integer
_ -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
BitVector (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n))

        OccName
"Clash.Sized.Internal.Index.Index" -> do
          Integer
n <- Except String Integer
-> ExceptT String (MaybeT (StateT HWMap Identity)) Integer
forall (m :: Type -> Type) e a.
Applicative m =>
Except e a -> ExceptT e (MaybeT m) a
liftE (TyConMap -> Type -> Except String Integer
tyNatSize TyConMap
m ([Type] -> Type
forall a. [a] -> a
head [Type]
args))
          if Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
2
             then HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Maybe HWType -> HWType
Void (HWType -> Maybe HWType
forall a. a -> Maybe a
Just (Integer -> HWType
Index (Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
n))))
             else HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Integer -> HWType
Index (Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
n))

        OccName
"Clash.Sized.Internal.Signed.Signed" -> do
          Integer
n <- Except String Integer
-> ExceptT String (MaybeT (StateT HWMap Identity)) Integer
forall (m :: Type -> Type) e a.
Applicative m =>
Except e a -> ExceptT e (MaybeT m) a
liftE (TyConMap -> Type -> Except String Integer
tyNatSize TyConMap
m ([Type] -> Type
forall a. [a] -> a
head [Type]
args))
          if Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0
             then HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Maybe HWType -> HWType
Void (HWType -> Maybe HWType
forall a. a -> Maybe a
Just (Int -> HWType
Signed (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n))))
             else HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Signed (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n))

        OccName
"Clash.Sized.Internal.Unsigned.Unsigned" -> do
          Integer
n <- Except String Integer
-> ExceptT String (MaybeT (StateT HWMap Identity)) Integer
forall (m :: Type -> Type) e a.
Applicative m =>
Except e a -> ExceptT e (MaybeT m) a
liftE (TyConMap -> Type -> Except String Integer
tyNatSize TyConMap
m ([Type] -> Type
forall a. [a] -> a
head [Type]
args))
          if Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0
             then HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Maybe HWType -> HWType
Void (HWType -> Maybe HWType
forall a. a -> Maybe a
Just (Int -> HWType
Unsigned (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n))))
             else HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Unsigned (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n))

        OccName
"Clash.Sized.Vector.Vec" -> do
          let [Type
szTy,Type
elTy] = [Type]
args
          Integer
sz0     <- Except String Integer
-> ExceptT String (MaybeT (StateT HWMap Identity)) Integer
forall (m :: Type -> Type) e a.
Applicative m =>
Except e a -> ExceptT e (MaybeT m) a
liftE (TyConMap -> Type -> Except String Integer
tyNatSize TyConMap
m Type
szTy)
          FilteredHWType
fElHWTy <- MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
 -> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType)
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall a b. (a -> b) -> a -> b
$ State HWMap (Maybe (Either String FilteredHWType))
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT (State HWMap (Maybe (Either String FilteredHWType))
 -> MaybeT (StateT HWMap Identity) (Either String FilteredHWType))
-> State HWMap (Maybe (Either String FilteredHWType))
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
forall a b. (a -> b) -> a -> b
$ Either String FilteredHWType
-> Maybe (Either String FilteredHWType)
forall a. a -> Maybe a
Just (Either String FilteredHWType
 -> Maybe (Either String FilteredHWType))
-> StateT HWMap Identity (Either String FilteredHWType)
-> State HWMap (Maybe (Either String FilteredHWType))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (CustomReprs
 -> TyConMap
 -> Type
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity (Either String FilteredHWType)
coreTypeToHWType CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
go CustomReprs
reprs TyConMap
m Type
elTy

          -- Treat Vec as a product type with a single constructor and N
          -- constructor fields.
          let sz1 :: Int
sz1    = Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
sz0 :: Int
              elHWTy :: HWType
elHWTy = FilteredHWType -> HWType
stripFiltered FilteredHWType
fElHWTy

          let
            (Bool
isVoid, HWType
vecHWTy) =
              case HWType
elHWTy of
                Void {}      -> (Bool
True, Maybe HWType -> HWType
Void (HWType -> Maybe HWType
forall a. a -> Maybe a
Just (Int -> HWType -> HWType
Vector Int
sz1 HWType
elHWTy)))
                HWType
_ | Int
sz1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> (Bool
True, Maybe HWType -> HWType
Void (HWType -> Maybe HWType
forall a. a -> Maybe a
Just (Int -> HWType -> HWType
Vector Int
sz1 HWType
elHWTy)))
                HWType
_            -> (Bool
False, Int -> HWType -> HWType
Vector Int
sz1 HWType
elHWTy)

          let filtered :: [[(Bool, FilteredHWType)]]
filtered = [Int -> (Bool, FilteredHWType) -> [(Bool, FilteredHWType)]
forall a. Int -> a -> [a]
replicate Int
sz1 (Bool
isVoid, FilteredHWType
fElHWTy)]
          FilteredHWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> [[(Bool, FilteredHWType)]] -> FilteredHWType
FilteredHWType HWType
vecHWTy [[(Bool, FilteredHWType)]]
filtered)

        OccName
"Clash.Sized.RTree.RTree" -> do
          let [Type
szTy,Type
elTy] = [Type]
args
          Integer
sz0     <- Except String Integer
-> ExceptT String (MaybeT (StateT HWMap Identity)) Integer
forall (m :: Type -> Type) e a.
Applicative m =>
Except e a -> ExceptT e (MaybeT m) a
liftE (TyConMap -> Type -> Except String Integer
tyNatSize TyConMap
m Type
szTy)
          FilteredHWType
fElHWTy <- MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
 -> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType)
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall a b. (a -> b) -> a -> b
$ State HWMap (Maybe (Either String FilteredHWType))
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT (State HWMap (Maybe (Either String FilteredHWType))
 -> MaybeT (StateT HWMap Identity) (Either String FilteredHWType))
-> State HWMap (Maybe (Either String FilteredHWType))
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
forall a b. (a -> b) -> a -> b
$ Either String FilteredHWType
-> Maybe (Either String FilteredHWType)
forall a. a -> Maybe a
Just (Either String FilteredHWType
 -> Maybe (Either String FilteredHWType))
-> StateT HWMap Identity (Either String FilteredHWType)
-> State HWMap (Maybe (Either String FilteredHWType))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (CustomReprs
 -> TyConMap
 -> Type
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity (Either String FilteredHWType)
coreTypeToHWType CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
go CustomReprs
reprs TyConMap
m Type
elTy

          -- Treat RTree as a product type with a single constructor and 2^N
          -- constructor fields.
          let sz1 :: Int
sz1    = Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
sz0 :: Int
              elHWTy :: HWType
elHWTy = FilteredHWType -> HWType
stripFiltered FilteredHWType
fElHWTy

          let
            (Bool
isVoid, HWType
vecHWTy) =
              case HWType
elHWTy of
                Void {} -> (Bool
True, Maybe HWType -> HWType
Void (HWType -> Maybe HWType
forall a. a -> Maybe a
Just (Int -> HWType -> HWType
RTree Int
sz1 HWType
elHWTy)))
                HWType
_       -> (Bool
False, Int -> HWType -> HWType
RTree Int
sz1 HWType
elHWTy)

          let filtered :: [[(Bool, FilteredHWType)]]
filtered = [Int -> (Bool, FilteredHWType) -> [(Bool, FilteredHWType)]
forall a. Int -> a -> [a]
replicate (Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Int
sz1) (Bool
isVoid, FilteredHWType
fElHWTy)]
          FilteredHWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> [[(Bool, FilteredHWType)]] -> FilteredHWType
FilteredHWType HWType
vecHWTy [[(Bool, FilteredHWType)]]
filtered)

        OccName
"String" -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN HWType
String
        OccName
"GHC.Types.[]" -> case Type -> TypeView
tyView ([Type] -> Type
forall a. [a] -> a
head [Type]
args) of
          (TyConApp (TyConName -> OccName
forall a. Name a -> OccName
nameOcc -> OccName
"GHC.Types.Char") []) -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN HWType
String
          TypeView
_ -> String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (String
 -> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType)
-> String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall a b. (a -> b) -> a -> b
$ String
"Can't translate type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall p. PrettyPrec p => p -> String
showPpr Type
ty

        -- To ensure that Clash doesn't get stuck working away callstacks that
        -- never end up being used in the generated HDL.
        OccName
"GHC.Stack.Types.CallStack" -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN (Maybe HWType -> HWType
Void Maybe HWType
forall a. Maybe a
Nothing)

        OccName
"Clash.Explicit.SimIO.SimIO" ->
          MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
 -> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType)
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall a b. (a -> b) -> a -> b
$ State HWMap (Maybe (Either String FilteredHWType))
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT (State HWMap (Maybe (Either String FilteredHWType))
 -> MaybeT (StateT HWMap Identity) (Either String FilteredHWType))
-> State HWMap (Maybe (Either String FilteredHWType))
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
forall a b. (a -> b) -> a -> b
$ Either String FilteredHWType
-> Maybe (Either String FilteredHWType)
forall a. a -> Maybe a
Just (Either String FilteredHWType
 -> Maybe (Either String FilteredHWType))
-> StateT HWMap Identity (Either String FilteredHWType)
-> State HWMap (Maybe (Either String FilteredHWType))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (CustomReprs
 -> TyConMap
 -> Type
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity (Either String FilteredHWType)
coreTypeToHWType CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
go CustomReprs
reprs TyConMap
m ([Type] -> Type
forall a. [a] -> a
head [Type]
args)

        OccName
"Clash.Explicit.SimIO.File" -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: Type -> Type). Monad m => HWType -> m FilteredHWType
returnN HWType
FileType

        OccName
"Clash.Explicit.SimIO.Reg" -> do
          let [Type
aTy] = [Type]
args
          MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (State HWMap (Maybe (Either String FilteredHWType))
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT (Either String FilteredHWType
-> Maybe (Either String FilteredHWType)
forall a. a -> Maybe a
Just (Either String FilteredHWType
 -> Maybe (Either String FilteredHWType))
-> StateT HWMap Identity (Either String FilteredHWType)
-> State HWMap (Maybe (Either String FilteredHWType))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (CustomReprs
 -> TyConMap
 -> Type
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity (Either String FilteredHWType)
coreTypeToHWType CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
go CustomReprs
reprs TyConMap
m Type
aTy))

        OccName
"GHC.STRef.STRef" -> do
          let [Type
_,Type
aTy] = [Type]
args
          MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (State HWMap (Maybe (Either String FilteredHWType))
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT (Either String FilteredHWType
-> Maybe (Either String FilteredHWType)
forall a. a -> Maybe a
Just (Either String FilteredHWType
 -> Maybe (Either String FilteredHWType))
-> StateT HWMap Identity (Either String FilteredHWType)
-> State HWMap (Maybe (Either String FilteredHWType))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (CustomReprs
 -> TyConMap
 -> Type
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity (Either String FilteredHWType)
coreTypeToHWType CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
go CustomReprs
reprs TyConMap
m Type
aTy))

        OccName
_ -> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (State HWMap (Maybe (Either String FilteredHWType))
-> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT (Maybe (Either String FilteredHWType)
-> State HWMap (Maybe (Either String FilteredHWType))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe (Either String FilteredHWType)
forall a. Maybe a
Nothing))

    go CustomReprs
_ TyConMap
_ Type
_ = Maybe (Either String FilteredHWType)
-> State HWMap (Maybe (Either String FilteredHWType))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe (Either String FilteredHWType)
forall a. Maybe a
Nothing

liftE
  :: Applicative m
  => Except e a
  -> ExceptT e (MaybeT m) a
liftE :: Except e a -> ExceptT e (MaybeT m) a
liftE = (Identity (Either e a) -> MaybeT m (Either e a))
-> Except e a -> ExceptT e (MaybeT m) a
forall (m :: Type -> Type) e a (n :: Type -> Type) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT (m (Maybe (Either e a)) -> MaybeT m (Either e a)
forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe (Either e a)) -> MaybeT m (Either e a))
-> (Identity (Either e a) -> m (Maybe (Either e a)))
-> Identity (Either e a)
-> MaybeT m (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Either e a) -> m (Maybe (Either e a))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe (Either e a) -> m (Maybe (Either e a)))
-> (Identity (Either e a) -> Maybe (Either e a))
-> Identity (Either e a)
-> m (Maybe (Either e a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either e a -> Maybe (Either e a)
forall a. a -> Maybe a
Just (Either e a -> Maybe (Either e a))
-> (Identity (Either e a) -> Either e a)
-> Identity (Either e a)
-> Maybe (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (Either e a) -> Either e a
coerce)

domTag :: Monad m => TyConMap -> Type -> ExceptT String (MaybeT m) String
domTag :: TyConMap -> Type -> ExceptT String (MaybeT m) String
domTag TyConMap
m (TyConMap -> Type -> Maybe Type
coreView1 TyConMap
m -> Just Type
ty) = TyConMap -> Type -> ExceptT String (MaybeT m) String
forall (m :: Type -> Type).
Monad m =>
TyConMap -> Type -> ExceptT String (MaybeT m) String
domTag TyConMap
m Type
ty
domTag TyConMap
_ (LitTy (SymTy String
tag)) = String -> ExceptT String (MaybeT m) String
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure String
tag
domTag TyConMap
_ Type
ty = String -> ExceptT String (MaybeT m) String
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (String -> ExceptT String (MaybeT m) String)
-> String -> ExceptT String (MaybeT m) String
forall a b. (a -> b) -> a -> b
$ String
"Internal error. Cannot translate domain tag:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall p. PrettyPrec p => p -> String
showPpr Type
ty

domPeriod :: Monad m => TyConMap -> Type -> ExceptT String (MaybeT m) Integer
domPeriod :: TyConMap -> Type -> ExceptT String (MaybeT m) Integer
domPeriod TyConMap
m (TyConMap -> Type -> Maybe Type
coreView1 TyConMap
m -> Just Type
ty) = TyConMap -> Type -> ExceptT String (MaybeT m) Integer
forall (m :: Type -> Type).
Monad m =>
TyConMap -> Type -> ExceptT String (MaybeT m) Integer
domPeriod TyConMap
m Type
ty
domPeriod TyConMap
_ (LitTy (NumTy Integer
period)) = Integer -> ExceptT String (MaybeT m) Integer
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Integer
period
domPeriod TyConMap
_ Type
ty = String -> ExceptT String (MaybeT m) Integer
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (String -> ExceptT String (MaybeT m) Integer)
-> String -> ExceptT String (MaybeT m) Integer
forall a b. (a -> b) -> a -> b
$ String
"Internal error. Cannot translate domain period:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall p. PrettyPrec p => p -> String
showPpr Type
ty

fromType
  :: Monad m
  => String
  -- ^ Name of type (for error reporting)
  -> [(String, a)]
  -- ^ [(Fully qualified constructor name, constructor value)
  -> TyConMap
  -- ^ Constructor map (used to look through newtypes)
  -> Type
  -- ^ Type representing some constructor
  -> ExceptT String (MaybeT m) a
fromType :: String
-> [(String, a)] -> TyConMap -> Type -> ExceptT String (MaybeT m) a
fromType String
tyNm [(String, a)]
constrs TyConMap
m Type
ty =
  case Type -> TypeView
tyView (TyConMap -> Type -> Type
coreView TyConMap
m Type
ty) of
    TyConApp TyConName
tcNm [] ->
      [(String, a)] -> OccName -> ExceptT String (MaybeT m) a
forall (m :: Type -> Type) a.
Monad m =>
[(String, a)] -> OccName -> ExceptT String m a
go [(String, a)]
constrs (TyConName -> OccName
forall a. Name a -> OccName
nameOcc TyConName
tcNm)
    TypeView
_ ->
      String -> ExceptT String (MaybeT m) a
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (String -> ExceptT String (MaybeT m) a)
-> String -> ExceptT String (MaybeT m) a
forall a b. (a -> b) -> a -> b
$ String
"Can't translate " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tyNm String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall p. PrettyPrec p => p -> String
showPpr Type
ty
 where
  go :: [(String, a)] -> OccName -> ExceptT String m a
go ((String
cName,a
c):[(String, a)]
cs) OccName
tcNm =
    if String -> OccName
pack String
cName OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
tcNm then
      a -> ExceptT String m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
c
    else
      [(String, a)] -> OccName -> ExceptT String m a
go [(String, a)]
cs OccName
tcNm
  go [] OccName
_ =
    String -> ExceptT String m a
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (String -> ExceptT String m a) -> String -> ExceptT String m a
forall a b. (a -> b) -> a -> b
$ String
"Can't translate " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tyNm String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall p. PrettyPrec p => p -> String
showPpr Type
ty

domEdge
  :: Monad m
  => TyConMap
  -> Type
  -> ExceptT String (MaybeT m) ActiveEdge
domEdge :: TyConMap -> Type -> ExceptT String (MaybeT m) ActiveEdge
domEdge =
  String
-> [(String, ActiveEdge)]
-> TyConMap
-> Type
-> ExceptT String (MaybeT m) ActiveEdge
forall (m :: Type -> Type) a.
Monad m =>
String
-> [(String, a)] -> TyConMap -> Type -> ExceptT String (MaybeT m) a
fromType
    (Name -> String
showName ''ActiveEdge)
    [ (Name -> String
showName 'Rising, ActiveEdge
Rising)
    , (Name -> String
showName 'Falling, ActiveEdge
Falling) ]

domResetKind
  :: Monad m
  => TyConMap
  -> Type
  -> ExceptT String (MaybeT m) ResetKind
domResetKind :: TyConMap -> Type -> ExceptT String (MaybeT m) ResetKind
domResetKind =
  String
-> [(String, ResetKind)]
-> TyConMap
-> Type
-> ExceptT String (MaybeT m) ResetKind
forall (m :: Type -> Type) a.
Monad m =>
String
-> [(String, a)] -> TyConMap -> Type -> ExceptT String (MaybeT m) a
fromType
    (Name -> String
showName ''ResetKind)
    [ (Name -> String
showName 'Synchronous, ResetKind
Synchronous)
    , (Name -> String
showName 'Asynchronous, ResetKind
Asynchronous) ]

domInitBehavior
  :: Monad m
  => TyConMap
  -> Type
  -> ExceptT String (MaybeT m) InitBehavior
domInitBehavior :: TyConMap -> Type -> ExceptT String (MaybeT m) InitBehavior
domInitBehavior =
  String
-> [(String, InitBehavior)]
-> TyConMap
-> Type
-> ExceptT String (MaybeT m) InitBehavior
forall (m :: Type -> Type) a.
Monad m =>
String
-> [(String, a)] -> TyConMap -> Type -> ExceptT String (MaybeT m) a
fromType
    (Name -> String
showName ''InitBehavior)
    [ (Name -> String
showName 'Defined, InitBehavior
Defined)
    , (Name -> String
showName 'Unknown, InitBehavior
Unknown) ]

domResetPolarity
  :: Monad m
  => TyConMap
  -> Type
  -> ExceptT String (MaybeT m) ResetPolarity
domResetPolarity :: TyConMap -> Type -> ExceptT String (MaybeT m) ResetPolarity
domResetPolarity =
  String
-> [(String, ResetPolarity)]
-> TyConMap
-> Type
-> ExceptT String (MaybeT m) ResetPolarity
forall (m :: Type -> Type) a.
Monad m =>
String
-> [(String, a)] -> TyConMap -> Type -> ExceptT String (MaybeT m) a
fromType
    (Name -> String
showName ''ResetPolarity)
    [ (Name -> String
showName 'ActiveHigh, ResetPolarity
ActiveHigh)
    , (Name -> String
showName 'ActiveLow, ResetPolarity
ActiveLow) ]