{-|
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'
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'
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' Int
n (ConstrRepr Name
name BitMask
mask BitMask
value [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 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 String
name') (TH.NameG NameSpace
_namespace PkgName
_pkgName (TH.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
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name'
thToText Name
name' = String -> Text
forall a. HasCallStack => String -> a
error (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"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' 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.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 Type
_ = String -> Type'
forall a. HasCallStack => String -> a
error (String -> Type') -> String -> Type'
forall a b. (a -> b) -> a -> b
$ String
"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 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 :: Text -> CustomReprs -> ConstrRepr'
uncheckedGetConstrRepr Text
name (Map Type' DataRepr'
_, Map Text ConstrRepr'
reprs) =
  ConstrRepr' -> Maybe ConstrRepr' -> ConstrRepr'
forall a. a -> Maybe a -> a
fromMaybe
    (String -> ConstrRepr'
forall a. HasCallStack => String -> a
error (String
"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 (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
_ 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)

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