{-| Copyright : (C) 2018, Google Inc. License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com> -} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} 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.Coerce (coerce) 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) import qualified TextShow as TS import qualified TextShow.Generic as TS -- | Simple version of template haskell type. Used internally to match on. data Type' = AppTy' Type' Type' -- ^ Type application | ConstTy' Text.Text -- ^ Qualified name of type | LitTy' Integer -- ^ Numeral literal (used in BitVector 10, for example) 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, Int -> Type' -> Int Type' -> Int (Int -> Type' -> Int) -> (Type' -> Int) -> Hashable Type' forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a hash :: Type' -> Int $chash :: Type' -> Int hashWithSalt :: Int -> Type' -> Int $chashWithSalt :: Int -> Type' -> Int 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 $cp1Ord :: Eq Type' Ord, Int -> Type' -> ShowS [Type'] -> ShowS Type' -> String (Int -> Type' -> ShowS) -> (Type' -> String) -> ([Type'] -> ShowS) -> Show Type' forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Type'] -> ShowS $cshowList :: [Type'] -> ShowS show :: Type' -> String $cshow :: Type' -> String showsPrec :: Int -> Type' -> ShowS $cshowsPrec :: Int -> Type' -> ShowS Show) -- Replace with -- -- deriving TS.TextShow via TS.FromGeneric (Type') -- -- after dropping support for GHC 8.4 instance TS.TextShow Type' where showt :: Type' -> Text showt = FromGeneric Type' -> Text forall a. TextShow a => a -> Text TS.showt (FromGeneric Type' -> Text) -> (Type' -> FromGeneric Type') -> Type' -> Text forall b c a. (b -> c) -> (a -> b) -> a -> c . Coercible Type' (FromGeneric Type') => Type' -> FromGeneric Type' forall a b. Coercible a b => a -> b coerce @_ @(TS.FromGeneric (Type')) showb :: Type' -> Builder showb = FromGeneric Type' -> Builder forall a. TextShow a => a -> Builder TS.showb (FromGeneric Type' -> Builder) -> (Type' -> FromGeneric Type') -> Type' -> Builder forall b c a. (b -> c) -> (a -> b) -> a -> c . Coercible Type' (FromGeneric Type') => Type' -> FromGeneric Type' forall a b. Coercible a b => a -> b coerce @_ @(TS.FromGeneric (Type')) -- | Internal version of DataRepr data DataRepr' = DataRepr' { DataRepr' -> Type' drType :: Type' -- ^ Simple representation of data type , DataRepr' -> Int drSize :: Size -- ^ Size of data type , DataRepr' -> [ConstrRepr'] drConstrs :: [ConstrRepr'] -- ^ Constructors } deriving (Int -> DataRepr' -> ShowS [DataRepr'] -> ShowS DataRepr' -> String (Int -> DataRepr' -> ShowS) -> (DataRepr' -> String) -> ([DataRepr'] -> ShowS) -> Show DataRepr' forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [DataRepr'] -> ShowS $cshowList :: [DataRepr'] -> ShowS show :: DataRepr' -> String $cshow :: DataRepr' -> String showsPrec :: Int -> DataRepr' -> ShowS $cshowsPrec :: Int -> 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, Int -> DataRepr' -> Int DataRepr' -> Int (Int -> DataRepr' -> Int) -> (DataRepr' -> Int) -> Hashable DataRepr' forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a hash :: DataRepr' -> Int $chash :: DataRepr' -> Int hashWithSalt :: Int -> DataRepr' -> Int $chashWithSalt :: Int -> DataRepr' -> Int 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 $cp1Ord :: Eq DataRepr' Ord) -- | Internal version of ConstrRepr data ConstrRepr' = ConstrRepr' { ConstrRepr' -> Text crName :: Text.Text -- ^ Qualified name of constructor , ConstrRepr' -> Int crPosition :: Int -- ^ Syntactical position in the custom representations definition , ConstrRepr' -> BitMask crMask :: BitMask -- ^ Mask needed to determine constructor , ConstrRepr' -> BitMask crValue :: Value -- ^ Value after applying mask , ConstrRepr' -> [BitMask] crFieldAnns :: [FieldAnn] -- ^ Indicates where fields are stored } deriving (Int -> ConstrRepr' -> ShowS [ConstrRepr'] -> ShowS ConstrRepr' -> String (Int -> ConstrRepr' -> ShowS) -> (ConstrRepr' -> String) -> ([ConstrRepr'] -> ShowS) -> Show ConstrRepr' forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [ConstrRepr'] -> ShowS $cshowList :: [ConstrRepr'] -> ShowS show :: ConstrRepr' -> String $cshow :: ConstrRepr' -> String showsPrec :: Int -> ConstrRepr' -> ShowS $cshowsPrec :: Int -> 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 $cp1Ord :: Eq ConstrRepr' Ord, Int -> ConstrRepr' -> Int ConstrRepr' -> Int (Int -> ConstrRepr' -> Int) -> (ConstrRepr' -> Int) -> Hashable ConstrRepr' forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a hash :: ConstrRepr' -> Int $chash :: ConstrRepr' -> Int hashWithSalt :: Int -> ConstrRepr' -> Int $chashWithSalt :: Int -> ConstrRepr' -> Int Hashable) constrReprToConstrRepr' :: Int -> ConstrRepr -> ConstrRepr' constrReprToConstrRepr' :: Int -> ConstrRepr -> ConstrRepr' constrReprToConstrRepr' n :: Int n (ConstrRepr name :: Name name mask :: BitMask mask value :: BitMask value fieldanns :: [BitMask] fieldanns) = Text -> Int -> BitMask -> BitMask -> [BitMask] -> ConstrRepr' ConstrRepr' (Name -> Text thToText Name name) Int 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 typ :: Type typ size :: Int size constrs :: [ConstrRepr] constrs) = Type' -> Int -> [ConstrRepr'] -> DataRepr' DataRepr' (Type -> Type' thTypeToType' Type typ) Int size ((Int -> ConstrRepr -> ConstrRepr') -> [Int] -> [ConstrRepr] -> [ConstrRepr'] forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith Int -> ConstrRepr -> ConstrRepr' constrReprToConstrRepr' [0..] [ConstrRepr] constrs) thToText :: TH.Name -> Text.Text thToText :: Name -> Text thToText (TH.Name (TH.OccName name' :: String name') (TH.NameG _namespace :: NameSpace _namespace _pkgName :: PkgName _pkgName (TH.ModName modName :: String modName))) = String -> Text Text.pack (String -> Text) -> String -> Text forall a b. (a -> b) -> a -> b $ String modName String -> ShowS forall a. [a] -> [a] -> [a] ++ "." String -> ShowS forall a. [a] -> [a] -> [a] ++ String name' thToText name' :: Name name' = String -> Text forall a. HasCallStack => String -> a error (String -> Text) -> String -> Text forall a b. (a -> b) -> a -> b $ "Unexpected pattern: " String -> ShowS forall a. [a] -> [a] -> [a] ++ Name -> String forall a. Show a => a -> String show Name name' -- | Convert template haskell type to simple representation of type thTypeToType' :: TH.Type -> Type' thTypeToType' :: Type -> Type' thTypeToType' ty :: Type ty = Type -> Type' go Type ty where go :: Type -> Type' go (TH.ConT name' :: Name name') = Text -> Type' ConstTy' (Name -> Text thToText Name name') go (TH.AppT ty1 :: Type ty1 ty2 :: Type ty2) = Type' -> Type' -> Type' AppTy' (Type -> Type' go Type ty1) (Type -> Type' go Type ty2) go (TH.LitT (TH.NumTyLit n :: BitMask n)) = BitMask -> Type' LitTy' BitMask n go _ = String -> Type' forall a. HasCallStack => String -> a error (String -> Type') -> String -> Type' forall a b. (a -> b) -> a -> b $ "Unsupported type: " String -> ShowS forall a. [a] -> [a] -> [a] ++ Type -> String forall a. Show a => a -> String show Type ty -- | Convenience type for index built by buildCustomReprs type CustomReprs = ( Map.Map Type' DataRepr' , Map.Map Text.Text ConstrRepr' ) -- | Lookup data type representation based on name getDataRepr :: Type' -> CustomReprs -> Maybe DataRepr' getDataRepr :: Type' -> CustomReprs -> Maybe DataRepr' getDataRepr name :: Type' name (reprs :: Map Type' DataRepr' reprs, _) = 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 -- | Lookup constructor representation based on name getConstrRepr :: Text.Text -> CustomReprs -> Maybe ConstrRepr' getConstrRepr :: Text -> CustomReprs -> Maybe ConstrRepr' getConstrRepr name :: Text name (_, reprs :: 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 -- | Unchecked version of getConstrRepr uncheckedGetConstrRepr :: HasCallStack => Text.Text -> CustomReprs -> ConstrRepr' uncheckedGetConstrRepr :: Text -> CustomReprs -> ConstrRepr' uncheckedGetConstrRepr name :: Text name (_, reprs :: Map Text ConstrRepr' reprs) = ConstrRepr' -> Maybe ConstrRepr' -> ConstrRepr' forall a. a -> Maybe a -> a fromMaybe (String -> ConstrRepr' forall a. HasCallStack => String -> a error ("Could not find custom representation for" String -> ShowS forall a. [a] -> [a] -> [a] ++ Text -> String 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) -- | Add CustomRepr to existing index addCustomRepr :: CustomReprs -> DataRepr' -> CustomReprs addCustomRepr :: CustomReprs -> DataRepr' -> CustomReprs addCustomRepr (dMap :: Map Type' DataRepr' dMap, cMap :: Map Text ConstrRepr' cMap) d :: DataRepr' d@(DataRepr' name :: Type' name _size :: Int _size constrReprs :: [ConstrRepr'] constrReprs) = let insertConstr :: ConstrRepr' -> Map Text ConstrRepr' -> Map Text ConstrRepr' insertConstr c :: ConstrRepr' c@(ConstrRepr' name' :: Text name' _ _ _ _) cMap' :: 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) -- | Create indices based on names of constructors and data types 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)