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