{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Clash.Annotations.BitRepresentation.Internal
( buildCustomReprs
, dataReprAnnToDataRepr'
, constrReprToConstrRepr'
, getConstrRepr
, uncheckedGetConstrRepr
, getDataRepr
, thTypeToType'
, ConstrRepr'(..)
, DataRepr'(..)
, Type'(..)
, CustomReprs
) where
import Clash.Annotations.BitRepresentation
(BitMask, Value, Size, FieldAnn, DataReprAnn(..), ConstrRepr(..))
import Control.DeepSeq (NFData)
import Data.Hashable (Hashable)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import qualified Data.Text as Text
import Data.Typeable (Typeable)
import qualified Language.Haskell.TH.Syntax as TH
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
data Type'
= AppTy' Type' Type'
| ConstTy' Text.Text
| LitTy' Integer
| SymLitTy' Text.Text
deriving ((forall x. Type' -> Rep Type' x)
-> (forall x. Rep Type' x -> Type') -> Generic Type'
forall x. Rep Type' x -> Type'
forall x. Type' -> Rep Type' x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Type' x -> Type'
$cfrom :: forall x. Type' -> Rep Type' x
Generic, Type' -> ()
(Type' -> ()) -> NFData Type'
forall a. (a -> ()) -> NFData a
rnf :: Type' -> ()
$crnf :: Type' -> ()
NFData, Type' -> Type' -> Bool
(Type' -> Type' -> Bool) -> (Type' -> Type' -> Bool) -> Eq Type'
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Type' -> Type' -> Bool
$c/= :: Type' -> Type' -> Bool
== :: Type' -> Type' -> Bool
$c== :: Type' -> Type' -> Bool
Eq, Typeable, Size -> Type' -> Size
Type' -> Size
(Size -> Type' -> Size) -> (Type' -> Size) -> Hashable Type'
forall a. (Size -> a -> Size) -> (a -> Size) -> Hashable a
hash :: Type' -> Size
$chash :: Type' -> Size
hashWithSalt :: Size -> Type' -> Size
$chashWithSalt :: Size -> Type' -> Size
Hashable, Eq Type'
Eq Type'
-> (Type' -> Type' -> Ordering)
-> (Type' -> Type' -> Bool)
-> (Type' -> Type' -> Bool)
-> (Type' -> Type' -> Bool)
-> (Type' -> Type' -> Bool)
-> (Type' -> Type' -> Type')
-> (Type' -> Type' -> Type')
-> Ord Type'
Type' -> Type' -> Bool
Type' -> Type' -> Ordering
Type' -> Type' -> Type'
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Type' -> Type' -> Type'
$cmin :: Type' -> Type' -> Type'
max :: Type' -> Type' -> Type'
$cmax :: Type' -> Type' -> Type'
>= :: Type' -> Type' -> Bool
$c>= :: Type' -> Type' -> Bool
> :: Type' -> Type' -> Bool
$c> :: Type' -> Type' -> Bool
<= :: Type' -> Type' -> Bool
$c<= :: Type' -> Type' -> Bool
< :: Type' -> Type' -> Bool
$c< :: Type' -> Type' -> Bool
compare :: Type' -> Type' -> Ordering
$ccompare :: Type' -> Type' -> Ordering
Ord, Size -> Type' -> ShowS
[Type'] -> ShowS
Type' -> [Char]
(Size -> Type' -> ShowS)
-> (Type' -> [Char]) -> ([Type'] -> ShowS) -> Show Type'
forall a.
(Size -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Type'] -> ShowS
$cshowList :: [Type'] -> ShowS
show :: Type' -> [Char]
$cshow :: Type' -> [Char]
showsPrec :: Size -> Type' -> ShowS
$cshowsPrec :: Size -> Type' -> ShowS
Show)
data DataRepr' = DataRepr'
{ DataRepr' -> Type'
drType :: Type'
, DataRepr' -> Size
drSize :: Size
, DataRepr' -> [ConstrRepr']
drConstrs :: [ConstrRepr']
}
deriving (Size -> DataRepr' -> ShowS
[DataRepr'] -> ShowS
DataRepr' -> [Char]
(Size -> DataRepr' -> ShowS)
-> (DataRepr' -> [Char])
-> ([DataRepr'] -> ShowS)
-> Show DataRepr'
forall a.
(Size -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [DataRepr'] -> ShowS
$cshowList :: [DataRepr'] -> ShowS
show :: DataRepr' -> [Char]
$cshow :: DataRepr' -> [Char]
showsPrec :: Size -> DataRepr' -> ShowS
$cshowsPrec :: Size -> DataRepr' -> ShowS
Show, (forall x. DataRepr' -> Rep DataRepr' x)
-> (forall x. Rep DataRepr' x -> DataRepr') -> Generic DataRepr'
forall x. Rep DataRepr' x -> DataRepr'
forall x. DataRepr' -> Rep DataRepr' x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DataRepr' x -> DataRepr'
$cfrom :: forall x. DataRepr' -> Rep DataRepr' x
Generic, DataRepr' -> ()
(DataRepr' -> ()) -> NFData DataRepr'
forall a. (a -> ()) -> NFData a
rnf :: DataRepr' -> ()
$crnf :: DataRepr' -> ()
NFData, DataRepr' -> DataRepr' -> Bool
(DataRepr' -> DataRepr' -> Bool)
-> (DataRepr' -> DataRepr' -> Bool) -> Eq DataRepr'
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DataRepr' -> DataRepr' -> Bool
$c/= :: DataRepr' -> DataRepr' -> Bool
== :: DataRepr' -> DataRepr' -> Bool
$c== :: DataRepr' -> DataRepr' -> Bool
Eq, Typeable, Size -> DataRepr' -> Size
DataRepr' -> Size
(Size -> DataRepr' -> Size)
-> (DataRepr' -> Size) -> Hashable DataRepr'
forall a. (Size -> a -> Size) -> (a -> Size) -> Hashable a
hash :: DataRepr' -> Size
$chash :: DataRepr' -> Size
hashWithSalt :: Size -> DataRepr' -> Size
$chashWithSalt :: Size -> DataRepr' -> Size
Hashable, Eq DataRepr'
Eq DataRepr'
-> (DataRepr' -> DataRepr' -> Ordering)
-> (DataRepr' -> DataRepr' -> Bool)
-> (DataRepr' -> DataRepr' -> Bool)
-> (DataRepr' -> DataRepr' -> Bool)
-> (DataRepr' -> DataRepr' -> Bool)
-> (DataRepr' -> DataRepr' -> DataRepr')
-> (DataRepr' -> DataRepr' -> DataRepr')
-> Ord DataRepr'
DataRepr' -> DataRepr' -> Bool
DataRepr' -> DataRepr' -> Ordering
DataRepr' -> DataRepr' -> DataRepr'
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DataRepr' -> DataRepr' -> DataRepr'
$cmin :: DataRepr' -> DataRepr' -> DataRepr'
max :: DataRepr' -> DataRepr' -> DataRepr'
$cmax :: DataRepr' -> DataRepr' -> DataRepr'
>= :: DataRepr' -> DataRepr' -> Bool
$c>= :: DataRepr' -> DataRepr' -> Bool
> :: DataRepr' -> DataRepr' -> Bool
$c> :: DataRepr' -> DataRepr' -> Bool
<= :: DataRepr' -> DataRepr' -> Bool
$c<= :: DataRepr' -> DataRepr' -> Bool
< :: DataRepr' -> DataRepr' -> Bool
$c< :: DataRepr' -> DataRepr' -> Bool
compare :: DataRepr' -> DataRepr' -> Ordering
$ccompare :: DataRepr' -> DataRepr' -> Ordering
Ord)
data ConstrRepr' = ConstrRepr'
{ ConstrRepr' -> Text
crName :: Text.Text
, ConstrRepr' -> Size
crPosition :: Int
, ConstrRepr' -> BitMask
crMask :: BitMask
, ConstrRepr' -> BitMask
crValue :: Value
, ConstrRepr' -> [BitMask]
crFieldAnns :: [FieldAnn]
}
deriving (Size -> ConstrRepr' -> ShowS
[ConstrRepr'] -> ShowS
ConstrRepr' -> [Char]
(Size -> ConstrRepr' -> ShowS)
-> (ConstrRepr' -> [Char])
-> ([ConstrRepr'] -> ShowS)
-> Show ConstrRepr'
forall a.
(Size -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ConstrRepr'] -> ShowS
$cshowList :: [ConstrRepr'] -> ShowS
show :: ConstrRepr' -> [Char]
$cshow :: ConstrRepr' -> [Char]
showsPrec :: Size -> ConstrRepr' -> ShowS
$cshowsPrec :: Size -> ConstrRepr' -> ShowS
Show, (forall x. ConstrRepr' -> Rep ConstrRepr' x)
-> (forall x. Rep ConstrRepr' x -> ConstrRepr')
-> Generic ConstrRepr'
forall x. Rep ConstrRepr' x -> ConstrRepr'
forall x. ConstrRepr' -> Rep ConstrRepr' x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ConstrRepr' x -> ConstrRepr'
$cfrom :: forall x. ConstrRepr' -> Rep ConstrRepr' x
Generic, ConstrRepr' -> ()
(ConstrRepr' -> ()) -> NFData ConstrRepr'
forall a. (a -> ()) -> NFData a
rnf :: ConstrRepr' -> ()
$crnf :: ConstrRepr' -> ()
NFData, ConstrRepr' -> ConstrRepr' -> Bool
(ConstrRepr' -> ConstrRepr' -> Bool)
-> (ConstrRepr' -> ConstrRepr' -> Bool) -> Eq ConstrRepr'
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConstrRepr' -> ConstrRepr' -> Bool
$c/= :: ConstrRepr' -> ConstrRepr' -> Bool
== :: ConstrRepr' -> ConstrRepr' -> Bool
$c== :: ConstrRepr' -> ConstrRepr' -> Bool
Eq, Typeable, Eq ConstrRepr'
Eq ConstrRepr'
-> (ConstrRepr' -> ConstrRepr' -> Ordering)
-> (ConstrRepr' -> ConstrRepr' -> Bool)
-> (ConstrRepr' -> ConstrRepr' -> Bool)
-> (ConstrRepr' -> ConstrRepr' -> Bool)
-> (ConstrRepr' -> ConstrRepr' -> Bool)
-> (ConstrRepr' -> ConstrRepr' -> ConstrRepr')
-> (ConstrRepr' -> ConstrRepr' -> ConstrRepr')
-> Ord ConstrRepr'
ConstrRepr' -> ConstrRepr' -> Bool
ConstrRepr' -> ConstrRepr' -> Ordering
ConstrRepr' -> ConstrRepr' -> ConstrRepr'
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ConstrRepr' -> ConstrRepr' -> ConstrRepr'
$cmin :: ConstrRepr' -> ConstrRepr' -> ConstrRepr'
max :: ConstrRepr' -> ConstrRepr' -> ConstrRepr'
$cmax :: ConstrRepr' -> ConstrRepr' -> ConstrRepr'
>= :: ConstrRepr' -> ConstrRepr' -> Bool
$c>= :: ConstrRepr' -> ConstrRepr' -> Bool
> :: ConstrRepr' -> ConstrRepr' -> Bool
$c> :: ConstrRepr' -> ConstrRepr' -> Bool
<= :: ConstrRepr' -> ConstrRepr' -> Bool
$c<= :: ConstrRepr' -> ConstrRepr' -> Bool
< :: ConstrRepr' -> ConstrRepr' -> Bool
$c< :: ConstrRepr' -> ConstrRepr' -> Bool
compare :: ConstrRepr' -> ConstrRepr' -> Ordering
$ccompare :: ConstrRepr' -> ConstrRepr' -> Ordering
Ord, Size -> ConstrRepr' -> Size
ConstrRepr' -> Size
(Size -> ConstrRepr' -> Size)
-> (ConstrRepr' -> Size) -> Hashable ConstrRepr'
forall a. (Size -> a -> Size) -> (a -> Size) -> Hashable a
hash :: ConstrRepr' -> Size
$chash :: ConstrRepr' -> Size
hashWithSalt :: Size -> ConstrRepr' -> Size
$chashWithSalt :: Size -> ConstrRepr' -> Size
Hashable)
constrReprToConstrRepr' :: Int -> ConstrRepr -> ConstrRepr'
constrReprToConstrRepr' :: Size -> ConstrRepr -> ConstrRepr'
constrReprToConstrRepr' Size
n (ConstrRepr Name
name BitMask
mask BitMask
value [BitMask]
fieldanns) =
Text -> Size -> BitMask -> BitMask -> [BitMask] -> ConstrRepr'
ConstrRepr' (Name -> Text
thToText Name
name) Size
n BitMask
mask BitMask
value ((BitMask -> BitMask) -> [BitMask] -> [BitMask]
forall a b. (a -> b) -> [a] -> [b]
map BitMask -> BitMask
forall a b. (Integral a, Num b) => a -> b
fromIntegral [BitMask]
fieldanns)
dataReprAnnToDataRepr' :: DataReprAnn -> DataRepr'
dataReprAnnToDataRepr' :: DataReprAnn -> DataRepr'
dataReprAnnToDataRepr' (DataReprAnn Type
typ Size
size [ConstrRepr]
constrs) =
Type' -> Size -> [ConstrRepr'] -> DataRepr'
DataRepr' (Type -> Type'
thTypeToType' Type
typ) Size
size ((Size -> ConstrRepr -> ConstrRepr')
-> [Size] -> [ConstrRepr] -> [ConstrRepr']
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Size -> ConstrRepr -> ConstrRepr'
constrReprToConstrRepr' [Size
0..] [ConstrRepr]
constrs)
thToText :: TH.Name -> Text.Text
thToText :: Name -> Text
thToText (TH.Name (TH.OccName [Char]
name') (TH.NameG NameSpace
_namespace PkgName
_pkgName (TH.ModName [Char]
modName))) =
[Char] -> Text
Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
modName [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"." [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
name'
thToText Name
name' = [Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected pattern: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
name'
thTypeToType' :: TH.Type -> Type'
thTypeToType' :: Type -> Type'
thTypeToType' Type
ty = Type -> Type'
go Type
ty
where
go :: Type -> Type'
go (TH.ConT Name
name') = Text -> Type'
ConstTy' (Name -> Text
thToText Name
name')
go (TH.PromotedT Name
name') = Text -> Type'
ConstTy' (Name -> Text
thToText Name
name')
go (TH.AppT Type
ty1 Type
ty2) = Type' -> Type' -> Type'
AppTy' (Type -> Type'
go Type
ty1) (Type -> Type'
go Type
ty2)
go (TH.LitT (TH.NumTyLit BitMask
n)) = BitMask -> Type'
LitTy' BitMask
n
go (TH.LitT (TH.StrTyLit [Char]
lit)) = Text -> Type'
SymLitTy' ([Char] -> Text
Text.pack [Char]
lit)
go Type
_ = [Char] -> Type'
forall a. HasCallStack => [Char] -> a
error ([Char] -> Type') -> [Char] -> Type'
forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported type: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
ty
type CustomReprs =
( Map.Map Type' DataRepr'
, Map.Map Text.Text ConstrRepr'
)
getDataRepr :: Type' -> CustomReprs -> Maybe DataRepr'
getDataRepr :: Type' -> CustomReprs -> Maybe DataRepr'
getDataRepr Type'
name (Map Type' DataRepr'
reprs, Map Text ConstrRepr'
_) = Type' -> Map Type' DataRepr' -> Maybe DataRepr'
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Type'
name Map Type' DataRepr'
reprs
getConstrRepr :: Text.Text -> CustomReprs -> Maybe ConstrRepr'
getConstrRepr :: Text -> CustomReprs -> Maybe ConstrRepr'
getConstrRepr Text
name (Map Type' DataRepr'
_, Map Text ConstrRepr'
reprs) = Text -> Map Text ConstrRepr' -> Maybe ConstrRepr'
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text ConstrRepr'
reprs
uncheckedGetConstrRepr
:: HasCallStack
=> Text.Text
-> CustomReprs
-> ConstrRepr'
uncheckedGetConstrRepr :: HasCallStack => Text -> CustomReprs -> ConstrRepr'
uncheckedGetConstrRepr Text
name (Map Type' DataRepr'
_, Map Text ConstrRepr'
reprs) =
ConstrRepr' -> Maybe ConstrRepr' -> ConstrRepr'
forall a. a -> Maybe a -> a
fromMaybe
([Char] -> ConstrRepr'
forall a. HasCallStack => [Char] -> a
error ([Char]
"Could not find custom representation for" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Text.unpack Text
name))
(Text -> Map Text ConstrRepr' -> Maybe ConstrRepr'
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text ConstrRepr'
reprs)
addCustomRepr :: CustomReprs -> DataRepr' -> CustomReprs
addCustomRepr :: CustomReprs -> DataRepr' -> CustomReprs
addCustomRepr (Map Type' DataRepr'
dMap, Map Text ConstrRepr'
cMap) d :: DataRepr'
d@(DataRepr' Type'
name Size
_size [ConstrRepr']
constrReprs) =
let insertConstr :: ConstrRepr' -> Map Text ConstrRepr' -> Map Text ConstrRepr'
insertConstr c :: ConstrRepr'
c@(ConstrRepr' Text
name' Size
_ BitMask
_ BitMask
_ [BitMask]
_) Map Text ConstrRepr'
cMap' = Text -> ConstrRepr' -> Map Text ConstrRepr' -> Map Text ConstrRepr'
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name' ConstrRepr'
c Map Text ConstrRepr'
cMap' in
(Type' -> DataRepr' -> Map Type' DataRepr' -> Map Type' DataRepr'
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Type'
name DataRepr'
d Map Type' DataRepr'
dMap, (ConstrRepr' -> Map Text ConstrRepr' -> Map Text ConstrRepr')
-> Map Text ConstrRepr' -> [ConstrRepr'] -> Map Text ConstrRepr'
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ConstrRepr' -> Map Text ConstrRepr' -> Map Text ConstrRepr'
insertConstr Map Text ConstrRepr'
cMap [ConstrRepr']
constrReprs)
buildCustomReprs :: [DataRepr'] -> CustomReprs
buildCustomReprs :: [DataRepr'] -> CustomReprs
buildCustomReprs = (CustomReprs -> DataRepr' -> CustomReprs)
-> CustomReprs -> [DataRepr'] -> CustomReprs
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl CustomReprs -> DataRepr' -> CustomReprs
addCustomRepr (Map Type' DataRepr'
forall k a. Map k a
Map.empty, Map Text ConstrRepr'
forall k a. Map k a
Map.empty)