{-|
  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 OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE ViewPatterns      #-}

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, 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 iw :: Int
iw floatSupport :: Bool
floatSupport = CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
go
  where
    -- returnN :: HWType ->
    returnN :: HWType -> m FilteredHWType
returnN t :: HWType
t = FilteredHWType -> m FilteredHWType
forall (m :: * -> *) 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 reprs :: CustomReprs
reprs m :: TyConMap
m (AnnType attrs :: [Attr']
attrs typ :: Type
typ) = (Either String FilteredHWType
 -> Maybe (Either String FilteredHWType))
-> StateT HWMap Identity (Either String FilteredHWType)
-> State HWMap (Maybe (Either String FilteredHWType))
forall (f :: * -> *) 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 :: * -> *) 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 typ' :: HWType
typ' areVoids :: [[(Bool, FilteredHWType)]]
areVoids <- StateT HWMap Identity (Either String FilteredHWType)
-> ExceptT String (StateT HWMap Identity) FilteredHWType
forall e (m :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return (HWType -> [[(Bool, FilteredHWType)]] -> FilteredHWType
FilteredHWType ([Attr'] -> HWType -> HWType
Annotated [Attr']
attrs HWType
typ') [[(Bool, FilteredHWType)]]
areVoids)

    go reprs :: CustomReprs
reprs m :: TyConMap
m ty :: Type
ty@(Type -> TypeView
tyView -> TyConApp tc :: TyConName
tc args :: [Type]
args) = MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> State HWMap (Maybe (Either String FilteredHWType))
forall (m :: * -> *) 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 :: * -> *) 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
        "GHC.Int.Int8"                  -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Signed 8)
        "GHC.Int.Int16"                 -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Signed 16)
        "GHC.Int.Int32"                 -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Signed 32)
        "GHC.Int.Int64"                 ->
          if Int
iw Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 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
                    [dc :: DataCon
dc] -> case DataCon -> [Type]
dcArgTys DataCon
dc of
                      [Type -> TypeView
tyView -> TyConApp nm :: TyConName
nm _]
                        | TyConName -> OccName
forall a. Name a -> OccName
nameOcc TyConName
nm OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== "GHC.Prim.Int#"   ->
                            String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *) 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 ["Int64 not supported in forced 32-bit mode on a 64-bit machine."
                                             ,"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
== "GHC.Prim.Int64#" ->
                            HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Signed 64)
                      _  -> String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *) 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
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Int64 DC has unexpected amount of arguments"
                    _    -> String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *) 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
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Int64 TC has unexpected amount of DCs"
             else HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Signed 64)
        "GHC.Word.Word8"                -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Unsigned 8)
        "GHC.Word.Word16"               -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Unsigned 16)
        "GHC.Word.Word32"               -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Unsigned 32)
        "GHC.Word.Word64"               ->
          if Int
iw Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 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
                    [dc :: DataCon
dc] -> case DataCon -> [Type]
dcArgTys DataCon
dc of
                      [Type -> TypeView
tyView -> TyConApp nm :: TyConName
nm _]
                        | TyConName -> OccName
forall a. Name a -> OccName
nameOcc TyConName
nm OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== "GHC.Prim.Word#"   ->
                            String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *) 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 ["Word64 not supported in forced 32-bit mode on a 64-bit machine."
                                             ,"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
== "GHC.Prim.Word64#" ->
                            HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Unsigned 64)
                      _  -> String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *) 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
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Word64 DC has unexpected amount of arguments"
                    _    -> String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *) 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
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Word64 TC has unexpected amount of DCs"
             else HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Unsigned 64)
        "GHC.Integer.Type.Integer"      -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Signed Int
iw)
        "GHC.Natural.Natural"           -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Unsigned Int
iw)
        "GHC.Prim.Char#"                -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Unsigned 21)
        "GHC.Prim.Int#"                 -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Signed Int
iw)
        "GHC.Prim.Word#"                -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Unsigned Int
iw)
        "GHC.Prim.Int64#"               -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Signed 64)
        "GHC.Prim.Word64#"              -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Unsigned 64)
        "GHC.Prim.Float#" | Bool
floatSupport -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
BitVector 32)
        "GHC.Prim.Double#" | Bool
floatSupport -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
BitVector 64)
        "GHC.Prim.ByteArray#"           ->
          String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *) 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
$ "Can't translate type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall p. PrettyPrec p => p -> String
showPpr Type
ty

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

        "Clash.Signal.Internal.Signal" ->
          MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall e (m :: * -> *) 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 :: * -> *) 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 :: * -> *) 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
!! 1)

        "Clash.Signal.BiSignal.BiSignalIn" -> do
          let [_, _, szTy :: Type
szTy] = [Type]
args
          let fType :: HWType -> FilteredHWType
fType ty1 :: 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            Except String Integer
-> ExceptT String (MaybeT (StateT HWMap Identity)) Integer
forall (m :: * -> *) e a.
Applicative m =>
Except e a -> ExceptT e (MaybeT m) a
liftE (TyConMap -> Type -> Except String Integer
tyNatSize TyConMap
m Type
szTy)

        "Clash.Signal.BiSignal.BiSignalOut" -> do
          let [_, _, szTy :: Type
szTy] = [Type]
args
          let fType :: HWType -> FilteredHWType
fType ty1 :: 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            Except String Integer
-> ExceptT String (MaybeT (StateT HWMap Identity)) Integer
forall (m :: * -> *) 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
        "GHC.Classes.(%,%)"
          | [arg0 :: Type
arg0@(Type -> TypeView
tyView -> TyConApp kdNm :: TyConName
kdNm _), _] <- [Type]
args
          , TyConName -> OccName
forall a. Name a -> OccName
nameOcc TyConName
kdNm OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Signal.Internal.KnownDomain"
          -> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall e (m :: * -> *) 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 :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
go CustomReprs
reprs TyConMap
m Type
arg0))

        "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
               [dc :: DataCon
dc] -> case DataCon -> [Type] -> [Type]
substArgTys DataCon
dc [Type]
args of
                 [_,Type -> TypeView
tyView -> TyConApp _ [_,dom :: Type
dom]] -> case Type -> TypeView
tyView (TyConMap -> Type -> Type
coreView TyConMap
m Type
dom) of
                   TyConApp _ [tag0 :: Type
tag0, period0 :: Type
period0, edge0 :: Type
edge0, rstKind0 :: Type
rstKind0, init0 :: Type
init0, polarity0 :: Type
polarity0] -> do
                     String
tag1      <- Type -> ExceptT String (MaybeT (StateT HWMap Identity)) String
forall (m :: * -> *).
Monad m =>
Type -> ExceptT String (MaybeT m) String
domTag Type
tag0
                     Integer
period1   <- Type -> ExceptT String (MaybeT (StateT HWMap Identity)) Integer
forall (m :: * -> *).
Monad m =>
Type -> ExceptT String (MaybeT m) Integer
domPeriod Type
period0
                     ActiveEdge
edge1     <- TyConMap
-> Type
-> ExceptT String (MaybeT (StateT HWMap Identity)) ActiveEdge
forall (m :: * -> *).
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 :: * -> *).
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 :: * -> *).
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 :: * -> *).
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 :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Maybe HWType -> HWType
Void (HWType -> Maybe HWType
forall a. a -> Maybe a
Just HWType
kd))
                   _ -> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall e (m :: * -> *) 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 :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Maybe (Either String FilteredHWType)
-> State HWMap (Maybe (Either String FilteredHWType))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Either String FilteredHWType)
forall a. Maybe a
Nothing))
                 _ -> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall e (m :: * -> *) 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 :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Maybe (Either String FilteredHWType)
-> State HWMap (Maybe (Either String FilteredHWType))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Either String FilteredHWType)
forall a. Maybe a
Nothing))
               _ -> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall e (m :: * -> *) 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 :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Maybe (Either String FilteredHWType)
-> State HWMap (Maybe (Either String FilteredHWType))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Either String FilteredHWType)
forall a. Maybe a
Nothing))

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

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

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

        "Clash.Sized.Internal.BitVector.BitVector" -> do
          Integer
n <- Except String Integer
-> ExceptT String (MaybeT (StateT HWMap Identity)) Integer
forall (m :: * -> *) 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
            0 -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). 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))))
            _ -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
BitVector (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n))

        "Clash.Sized.Internal.Index.Index" -> do
          Integer
n <- Except String Integer
-> ExceptT String (MaybeT (StateT HWMap Identity)) Integer
forall (m :: * -> *) 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
< 2
             then HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). 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 :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Integer -> HWType
Index (Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
n))

        "Clash.Sized.Internal.Signed.Signed" -> do
          Integer
n <- Except String Integer
-> ExceptT String (MaybeT (StateT HWMap Identity)) Integer
forall (m :: * -> *) 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
== 0
             then HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). 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 :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Signed (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n))

        "Clash.Sized.Internal.Unsigned.Unsigned" -> do
          Integer
n <- Except String Integer
-> ExceptT String (MaybeT (StateT HWMap Identity)) Integer
forall (m :: * -> *) 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
== 0
             then HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). 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 :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Int -> HWType
Unsigned (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n))

        "Clash.Sized.Vector.Vec" -> do
          let [szTy :: Type
szTy,elTy :: Type
elTy] = [Type]
args
          Integer
sz0     <- Except String Integer
-> ExceptT String (MaybeT (StateT HWMap Identity)) Integer
forall (m :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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
            (isVoid :: Bool
isVoid, vecHWTy :: 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)))
                _ | Int
sz1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 -> (Bool
True, Maybe HWType -> HWType
Void (HWType -> Maybe HWType
forall a. a -> Maybe a
Just (Int -> HWType -> HWType
Vector Int
sz1 HWType
elHWTy)))
                _            -> (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 :: * -> *) a. Monad m => a -> m a
return (HWType -> [[(Bool, FilteredHWType)]] -> FilteredHWType
FilteredHWType HWType
vecHWTy [[(Bool, FilteredHWType)]]
filtered)

        "Clash.Sized.RTree.RTree" -> do
          let [szTy :: Type
szTy,elTy :: Type
elTy] = [Type]
args
          Integer
sz0     <- Except String Integer
-> ExceptT String (MaybeT (StateT HWMap Identity)) Integer
forall (m :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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
            (isVoid :: Bool
isVoid, vecHWTy :: 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)))
                _       -> (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 (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 :: * -> *) a. Monad m => a -> m a
return (HWType -> [[(Bool, FilteredHWType)]] -> FilteredHWType
FilteredHWType HWType
vecHWTy [[(Bool, FilteredHWType)]]
filtered)

        "String" -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN HWType
String
        "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 :: * -> *). Monad m => HWType -> m FilteredHWType
returnN HWType
String
          _ -> String
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *) 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
$ "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.
        "GHC.Stack.Types.CallStack" -> HWType
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall (m :: * -> *). Monad m => HWType -> m FilteredHWType
returnN (Maybe HWType -> HWType
Void Maybe HWType
forall a. Maybe a
Nothing)

        _ -> MaybeT (StateT HWMap Identity) (Either String FilteredHWType)
-> ExceptT String (MaybeT (StateT HWMap Identity)) FilteredHWType
forall e (m :: * -> *) 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 :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Maybe (Either String FilteredHWType)
-> State HWMap (Maybe (Either String FilteredHWType))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Either String FilteredHWType)
forall a. Maybe a
Nothing))

    go _ _ _ = Maybe (Either String FilteredHWType)
-> State HWMap (Maybe (Either String FilteredHWType))
forall (f :: * -> *) 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 :: * -> *) e a (n :: * -> *) 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 :: * -> *) 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 :: * -> *) 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
forall a b. Coercible a b => a -> b
coerce)

domTag :: Monad m => Type -> ExceptT String (MaybeT m) String
domTag :: Type -> ExceptT String (MaybeT m) String
domTag (LitTy (SymTy tag :: String
tag)) = String -> ExceptT String (MaybeT m) String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
tag
domTag ty :: Type
ty = String -> ExceptT String (MaybeT m) String
forall (m :: * -> *) 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
$ "Can't translate domain tag" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall p. PrettyPrec p => p -> String
showPpr Type
ty

domPeriod :: Monad m => Type -> ExceptT String (MaybeT m) Integer
domPeriod :: Type -> ExceptT String (MaybeT m) Integer
domPeriod (LitTy (NumTy period :: Integer
period)) = Integer -> ExceptT String (MaybeT m) Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
period
domPeriod ty :: Type
ty = String -> ExceptT String (MaybeT m) Integer
forall (m :: * -> *) 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
$ "Can't translate domain period" 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 tyNm :: String
tyNm constrs :: [(String, a)]
constrs m :: TyConMap
m ty :: Type
ty =
  case Type -> TypeView
tyView (TyConMap -> Type -> Type
coreView TyConMap
m Type
ty) of
    TyConApp tcNm :: TyConName
tcNm [] ->
      [(String, a)] -> OccName -> ExceptT String (MaybeT m) a
forall (m :: * -> *) a.
Monad m =>
[(String, a)] -> OccName -> ExceptT String m a
go [(String, a)]
constrs (TyConName -> OccName
forall a. Name a -> OccName
nameOcc TyConName
tcNm)
    _ ->
      String -> ExceptT String (MaybeT m) a
forall (m :: * -> *) 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
$ "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 ((cName :: String
cName,c :: a
c):cs :: [(String, a)]
cs) tcNm :: 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 :: * -> *) a. Applicative f => a -> f a
pure a
c
    else
      [(String, a)] -> OccName -> ExceptT String m a
go [(String, a)]
cs OccName
tcNm
  go [] _ =
    String -> ExceptT String m a
forall (m :: * -> *) 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
$ "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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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) ]