{-|
Copyright  :  (C) 2018, Google Inc.
                  2022, LUMI GUIDE FIETSDETECTIE B.V.
License    :  BSD2 (see the file LICENSE)
Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>
-}

{-# 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)


-- | 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)
  | SymLitTy' Text.Text
  -- ^ Symbol literal (used in for example (Signal "System" Int))
  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
$cfrom :: forall x. Type' -> Rep Type' x
from :: forall x. Type' -> Rep Type' x
$cto :: forall x. Rep Type' x -> Type'
to :: forall x. Rep Type' x -> Type'
Generic, Type' -> ()
(Type' -> ()) -> NFData Type'
forall a. (a -> ()) -> NFData a
$crnf :: Type' -> ()
rnf :: Type' -> ()
NFData, Type' -> Type' -> Bool
(Type' -> Type' -> Bool) -> (Type' -> Type' -> Bool) -> Eq Type'
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Type' -> Type' -> Bool
== :: Type' -> Type' -> Bool
$c/= :: Type' -> Type' -> Bool
/= :: Type' -> Type' -> Bool
Eq, Typeable, Eq Type'
Eq Type' =>
(Int -> Type' -> Int) -> (Type' -> Int) -> Hashable Type'
Int -> Type' -> Int
Type' -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> Type' -> Int
hashWithSalt :: Int -> Type' -> Int
$chash :: Type' -> Int
hash :: 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
$ccompare :: Type' -> Type' -> Ordering
compare :: Type' -> Type' -> Ordering
$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
>= :: Type' -> Type' -> Bool
$cmax :: Type' -> Type' -> Type'
max :: Type' -> Type' -> Type'
$cmin :: Type' -> Type' -> Type'
min :: Type' -> Type' -> Type'
Ord, Int -> Type' -> ShowS
[Type'] -> ShowS
Type' -> [Char]
(Int -> Type' -> ShowS)
-> (Type' -> [Char]) -> ([Type'] -> ShowS) -> Show Type'
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Type' -> ShowS
showsPrec :: Int -> Type' -> ShowS
$cshow :: Type' -> [Char]
show :: Type' -> [Char]
$cshowList :: [Type'] -> ShowS
showList :: [Type'] -> ShowS
Show)

-- | 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' -> [Char]
(Int -> DataRepr' -> ShowS)
-> (DataRepr' -> [Char])
-> ([DataRepr'] -> ShowS)
-> Show DataRepr'
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DataRepr' -> ShowS
showsPrec :: Int -> DataRepr' -> ShowS
$cshow :: DataRepr' -> [Char]
show :: DataRepr' -> [Char]
$cshowList :: [DataRepr'] -> ShowS
showList :: [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
$cfrom :: forall x. DataRepr' -> Rep DataRepr' x
from :: forall x. DataRepr' -> Rep DataRepr' x
$cto :: forall x. Rep DataRepr' x -> DataRepr'
to :: forall x. Rep DataRepr' x -> DataRepr'
Generic, DataRepr' -> ()
(DataRepr' -> ()) -> NFData DataRepr'
forall a. (a -> ()) -> NFData a
$crnf :: DataRepr' -> ()
rnf :: DataRepr' -> ()
NFData, DataRepr' -> DataRepr' -> Bool
(DataRepr' -> DataRepr' -> Bool)
-> (DataRepr' -> DataRepr' -> Bool) -> Eq DataRepr'
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DataRepr' -> DataRepr' -> Bool
== :: DataRepr' -> DataRepr' -> Bool
$c/= :: DataRepr' -> DataRepr' -> Bool
/= :: DataRepr' -> DataRepr' -> Bool
Eq, Typeable, Eq DataRepr'
Eq DataRepr' =>
(Int -> DataRepr' -> Int)
-> (DataRepr' -> Int) -> Hashable DataRepr'
Int -> DataRepr' -> Int
DataRepr' -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> DataRepr' -> Int
hashWithSalt :: Int -> DataRepr' -> Int
$chash :: DataRepr' -> Int
hash :: 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
$ccompare :: DataRepr' -> DataRepr' -> Ordering
compare :: DataRepr' -> DataRepr' -> Ordering
$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
>= :: DataRepr' -> DataRepr' -> Bool
$cmax :: DataRepr' -> DataRepr' -> DataRepr'
max :: DataRepr' -> DataRepr' -> DataRepr'
$cmin :: DataRepr' -> DataRepr' -> DataRepr'
min :: DataRepr' -> DataRepr' -> 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' -> FieldAnn
crMask :: BitMask
  -- ^ Mask needed to determine constructor
  , ConstrRepr' -> FieldAnn
crValue :: Value
  -- ^ Value after applying mask
  , ConstrRepr' -> [FieldAnn]
crFieldAnns :: [FieldAnn]
  -- ^ Indicates where fields are stored
  }
  deriving (Int -> ConstrRepr' -> ShowS
[ConstrRepr'] -> ShowS
ConstrRepr' -> [Char]
(Int -> ConstrRepr' -> ShowS)
-> (ConstrRepr' -> [Char])
-> ([ConstrRepr'] -> ShowS)
-> Show ConstrRepr'
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConstrRepr' -> ShowS
showsPrec :: Int -> ConstrRepr' -> ShowS
$cshow :: ConstrRepr' -> [Char]
show :: ConstrRepr' -> [Char]
$cshowList :: [ConstrRepr'] -> ShowS
showList :: [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
$cfrom :: forall x. ConstrRepr' -> Rep ConstrRepr' x
from :: forall x. ConstrRepr' -> Rep ConstrRepr' x
$cto :: forall x. Rep ConstrRepr' x -> ConstrRepr'
to :: forall x. Rep ConstrRepr' x -> ConstrRepr'
Generic, ConstrRepr' -> ()
(ConstrRepr' -> ()) -> NFData ConstrRepr'
forall a. (a -> ()) -> NFData a
$crnf :: ConstrRepr' -> ()
rnf :: ConstrRepr' -> ()
NFData, ConstrRepr' -> ConstrRepr' -> Bool
(ConstrRepr' -> ConstrRepr' -> Bool)
-> (ConstrRepr' -> ConstrRepr' -> Bool) -> Eq ConstrRepr'
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConstrRepr' -> ConstrRepr' -> Bool
== :: ConstrRepr' -> ConstrRepr' -> Bool
$c/= :: ConstrRepr' -> ConstrRepr' -> Bool
/= :: 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
$ccompare :: ConstrRepr' -> ConstrRepr' -> Ordering
compare :: ConstrRepr' -> ConstrRepr' -> Ordering
$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
>= :: ConstrRepr' -> ConstrRepr' -> Bool
$cmax :: ConstrRepr' -> ConstrRepr' -> ConstrRepr'
max :: ConstrRepr' -> ConstrRepr' -> ConstrRepr'
$cmin :: ConstrRepr' -> ConstrRepr' -> ConstrRepr'
min :: ConstrRepr' -> ConstrRepr' -> ConstrRepr'
Ord, Eq ConstrRepr'
Eq ConstrRepr' =>
(Int -> ConstrRepr' -> Int)
-> (ConstrRepr' -> Int) -> Hashable ConstrRepr'
Int -> ConstrRepr' -> Int
ConstrRepr' -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> ConstrRepr' -> Int
hashWithSalt :: Int -> ConstrRepr' -> Int
$chash :: ConstrRepr' -> Int
hash :: ConstrRepr' -> Int
Hashable)

constrReprToConstrRepr' :: Int -> ConstrRepr -> ConstrRepr'
constrReprToConstrRepr' :: Int -> ConstrRepr -> ConstrRepr'
constrReprToConstrRepr' Int
n (ConstrRepr Name
name FieldAnn
mask FieldAnn
value [FieldAnn]
fieldanns) =
  Text -> Int -> FieldAnn -> FieldAnn -> [FieldAnn] -> ConstrRepr'
ConstrRepr' (Name -> Text
thToText Name
name) Int
n FieldAnn
mask FieldAnn
value ((FieldAnn -> FieldAnn) -> [FieldAnn] -> [FieldAnn]
forall a b. (a -> b) -> [a] -> [b]
map FieldAnn -> FieldAnn
forall a b. (Integral a, Num b) => a -> b
fromIntegral [FieldAnn]
fieldanns)

dataReprAnnToDataRepr' :: DataReprAnn -> DataRepr'
dataReprAnnToDataRepr' :: DataReprAnn -> DataRepr'
dataReprAnnToDataRepr' (DataReprAnn Type
typ Int
size [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' [Int
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'

-- | Convert template haskell type to simple representation of type
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 FieldAnn
n)) = FieldAnn -> Type'
LitTy' FieldAnn
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

-- | 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 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

-- | Lookup constructor representation based on name
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

-- | Unchecked version of getConstrRepr
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)

-- | Add CustomRepr to existing index
addCustomRepr :: CustomReprs -> DataRepr' -> CustomReprs
addCustomRepr :: CustomReprs -> DataRepr' -> CustomReprs
addCustomRepr (Map Type' DataRepr'
dMap, Map Text ConstrRepr'
cMap) d :: DataRepr'
d@(DataRepr' Type'
name Int
_size [ConstrRepr']
constrReprs) =
  let insertConstr :: ConstrRepr' -> Map Text ConstrRepr' -> Map Text ConstrRepr'
insertConstr c :: ConstrRepr'
c@(ConstrRepr' Text
name' Int
_ FieldAnn
_ FieldAnn
_ [FieldAnn]
_) 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 a b. (a -> b -> b) -> b -> [a] -> b
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 b a. (b -> a -> b) -> b -> [a] -> b
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)