{-| Copyright : (C) 2018, Google Inc. License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com> -} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Annotations.BitRepresentation.Internal ( buildCustomReprs , dataReprAnnToDataRepr' , constrReprToConstrRepr' , getConstrRepr , 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 qualified Data.Text as Text import Data.Typeable (Typeable) import qualified Language.Haskell.TH.Syntax as TH import GHC.Generics (Generic) -- | 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) -- | Internal version of DataRepr data DataRepr' = DataRepr' -- Qualified name of type (recursive): Type' -- Size of data type: Size -- Constructors: [ConstrRepr'] 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' -- Qualified name of constructor: Text.Text -- Syntactical position in the custom representations definition: Int -- Mask needed to determine constructor: BitMask -- Value after applying mask: Value -- Indicates where fields are stored: [FieldAnn] 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 -- | Add CustomRepr to existing index buildCustomRepr :: CustomReprs -> DataRepr' -> CustomReprs buildCustomRepr :: CustomReprs -> DataRepr' -> CustomReprs buildCustomRepr (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 :: * -> *) 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 :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl CustomReprs -> DataRepr' -> CustomReprs buildCustomRepr (Map Type' DataRepr' forall k a. Map k a Map.empty, Map Text ConstrRepr' forall k a. Map k a Map.empty)