{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Data.Store.TH.Internal
    (
    -- * TH functions for generating Store instances
      deriveManyStoreFromStorable
    , deriveTupleStoreInstance
    , deriveGenericInstance
    , deriveGenericInstanceFromName
    , deriveManyStorePrimVector
    , deriveManyStoreUnboxVector
    , deriveStore
    , makeStore
    -- * Misc utilties used in Store test
    , getAllInstanceTypes1
    , isMonoType
    ) where

import           Control.Applicative
import           Data.Complex ()
import           Data.Generics.Aliases (extT, mkQ, extQ)
import           Data.Generics.Schemes (listify, everywhere, something)
import           Data.List (find)
import qualified Data.Map as M
import           Data.Maybe (fromMaybe, isJust, mapMaybe)
import           Data.Primitive.ByteArray
import           Data.Primitive.Types
import           Data.Store.Core
import           Data.Store.Impl
import qualified Data.Text as T
import           Data.Traversable (forM)
import qualified Data.Vector.Primitive as PV
import qualified Data.Vector.Unboxed as UV
import           Data.Word
import           Foreign.Storable (Storable)
import           GHC.Types (Int(..))
import           Language.Haskell.TH
import           Language.Haskell.TH.ReifyMany.Internal (TypeclassInstance(..), getInstances, unAppsT)
import           Language.Haskell.TH.Syntax (lift)
import           Prelude
import           Safe (headMay)
import           TH.Derive (Deriver(..))
import           TH.ReifySimple
import           TH.Utilities (expectTyCon1, dequalify, plainInstanceD, appsT)

instance Deriver (Store a) where
    runDeriver :: Proxy (Store a) -> [Type] -> Type -> Q [Dec]
runDeriver Proxy (Store a)
_ [Type]
preds Type
ty = do
        Type
argTy <- Name -> Type -> Q Type
expectTyCon1 ''Store Type
ty
        DataType
dt <- Type -> Q DataType
reifyDataTypeSubstituted Type
argTy
        (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type] -> Type -> [DataCon] -> Q Dec
deriveStore [Type]
preds Type
argTy (DataType -> [DataCon]
dtCons DataType
dt)

-- | Given the name of a type, generate a Store instance for it,
-- assuming that all type variables also need to be Store instances.
--
-- Note that when used with datatypes that require type variables, the
-- ScopedTypeVariables extension is required.
makeStore :: Name -> Q [Dec]
makeStore :: Name -> Q [Dec]
makeStore Name
name = do
    DataType
dt <- Name -> Q DataType
reifyDataType Name
name
    let preds :: [Type]
preds = (Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type
storePred (Type -> Type) -> (Name -> Type) -> Name -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
VarT) (DataType -> [Name]
dtTvs DataType
dt)
        argTy :: Type
argTy = Type -> [Type] -> Type
appsT (Name -> Type
ConT Name
name) ((Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT (DataType -> [Name]
dtTvs DataType
dt))
    (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type] -> Type -> [DataCon] -> Q Dec
deriveStore [Type]
preds Type
argTy (DataType -> [DataCon]
dtCons DataType
dt)

deriveStore :: Cxt -> Type -> [DataCon] -> Q Dec
deriveStore :: [Type] -> Type -> [DataCon] -> Q Dec
deriveStore [Type]
preds Type
headTy [DataCon]
cons0 =
    [Type] -> Type -> Exp -> Exp -> Exp -> Dec
makeStoreInstance [Type]
preds Type
headTy
        (Exp -> Exp -> Exp -> Dec) -> Q Exp -> Q (Exp -> Exp -> Dec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp
sizeExpr
        Q (Exp -> Exp -> Dec) -> Q Exp -> Q (Exp -> Dec)
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q Exp
peekExpr
        Q (Exp -> Dec) -> Q Exp -> Q Dec
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q Exp
pokeExpr
  where
    cons :: [(Name, [(Name, Type)])]
    cons :: [(Name, [(Name, Type)])]
cons =
      [ ( DataCon -> Name
dcName DataCon
dc
        , [ (String -> Name
mkName (String
"c" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ixc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"f" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ixf), Type
ty)
          | Int
ixf <- [Int]
ints
          | (Maybe Name
_, Type
ty) <- DataCon -> [(Maybe Name, Type)]
dcFields DataCon
dc
          ]
        )
      | Int
ixc <- [Int]
ints
      | DataCon
dc <- [DataCon]
cons0
      ]
    -- NOTE: tag code duplicated in th-storable.
    (Name
tagType, Int
_, Int
tagSize) =
        (Name, Int, Int) -> Maybe (Name, Int, Int) -> (Name, Int, Int)
forall a. a -> Maybe a -> a
fromMaybe (String -> (Name, Int, Int)
forall a. HasCallStack => String -> a
error String
"Too many constructors") (Maybe (Name, Int, Int) -> (Name, Int, Int))
-> Maybe (Name, Int, Int) -> (Name, Int, Int)
forall a b. (a -> b) -> a -> b
$
        ((Name, Int, Int) -> Bool)
-> [(Name, Int, Int)] -> Maybe (Name, Int, Int)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Name
_, Int
maxN, Int
_) -> Int
maxN Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [(Name, [(Name, Type)])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, [(Name, Type)])]
cons) [(Name, Int, Int)]
tagTypes
    tagTypes :: [(Name, Int, Int)]
    tagTypes :: [(Name, Int, Int)]
tagTypes =
        [ ('(), Int
1, Int
0)
        , (''Word8, Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
forall a. Bounded a => a
maxBound :: Word8), Int
1)
        , (''Word16, Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
forall a. Bounded a => a
maxBound :: Word16), Int
2)
        , (''Word32, Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
forall a. Bounded a => a
maxBound :: Word32), Int
4)
        , (''Word64, Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
forall a. Bounded a => a
maxBound :: Word64), Int
8)
        ]
    fName :: a -> Name
fName a
ix = String -> Name
mkName (String
"f" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
ix)
    ints :: [Int]
ints = [Int
0..] :: [Int]
    fNames :: [Name]
fNames = (Int -> Name) -> [Int] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Name
forall {a}. Show a => a -> Name
fName [Int]
ints
    sizeNames :: [Name]
sizeNames = ((Name, [(Name, Type)]) -> Int -> Name)
-> [(Name, [(Name, Type)])] -> [Int] -> [Name]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Name, [(Name, Type)])
_ -> String -> Name
mkName (String -> Name) -> (Int -> String) -> Int -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"sz" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [(Name, [(Name, Type)])]
cons [Int]
ints
    tagName :: Name
tagName = String -> Name
mkName String
"tag"
    valName :: Name
valName = String -> Name
mkName String
"val"
    sizeExpr :: Q Exp
sizeExpr
        -- Maximum size of GHC tuples
        | [(Name, [(Name, Type)])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, [(Name, Type)])]
cons Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
62 =
            Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE ([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE (((Name, [(Name, Type)]) -> [Q Exp])
-> [(Name, [(Name, Type)])] -> [Q Exp]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((Name, Type) -> Q Exp) -> [(Name, Type)] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Type) -> Q Exp
sizeAtType ([(Name, Type)] -> [Q Exp])
-> ((Name, [(Name, Type)]) -> [(Name, Type)])
-> (Name, [(Name, Type)])
-> [Q Exp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, [(Name, Type)]) -> [(Name, Type)]
forall a b. (a, b) -> b
snd) [(Name, [(Name, Type)])]
cons))
                  (case [(Name, [(Name, Type)])]
cons of
                     -- Avoid overlapping matches when the case expression is ()
                     [] -> [Q Match
matchConstSize]
                     [(Name, [(Name, Type)])
c] | [(Name, Type)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((Name, [(Name, Type)]) -> [(Name, Type)]
forall a b. (a, b) -> b
snd (Name, [(Name, Type)])
c) -> [Q Match
matchConstSize]
                     [(Name, [(Name, Type)])]
_ -> [Q Match
matchConstSize, Q Match
matchVarSize])
        | Bool
otherwise = Q Exp
varSizeExpr
      where
        sizeAtType :: (Name, Type) -> ExpQ
        sizeAtType :: (Name, Type) -> Q Exp
sizeAtType (Name
_, Type
ty) = [| size :: Size $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty) |]
        matchConstSize :: MatchQ
        matchConstSize :: Q Match
matchConstSize = do
            let sz0 :: Exp
sz0 = Name -> Exp
VarE (String -> Name
mkName String
"sz0")
                sizeDecls :: [Q Dec]
sizeDecls =
                    if [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
sizeNames
                        then [Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"sz0")) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| 0 |]) []]
                        else (Name -> (Name, [(Name, Type)]) -> Q Dec)
-> [Name] -> [(Name, [(Name, Type)])] -> [Q Dec]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> (Name, [(Name, Type)]) -> Q Dec
constSizeDec [Name]
sizeNames [(Name, [(Name, Type)])]
cons
            Exp
sameSizeExpr <-
                case [Name]
sizeNames of
                    (Name
_ : [Name]
tailSizeNames) ->
                        (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
l Q Exp
r -> [| $(Q Exp
l) && $(Q Exp
r) |]) [| True |] ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$
                        (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
szn -> [| $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
sz0) == $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
szn) |]) [Name]
tailSizeNames
                    [] -> [| True |]
            Exp
result <- [| ConstSize (tagSize + $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
sz0)) |]
            Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match ([Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP (((Name, Type) -> Q Pat) -> [(Name, Type)] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, Type
_) -> Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'ConstSize [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
n])
                             (((Name, [(Name, Type)]) -> [(Name, Type)])
-> [(Name, [(Name, Type)])] -> [(Name, Type)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name, [(Name, Type)]) -> [(Name, Type)]
forall a b. (a, b) -> b
snd [(Name, [(Name, Type)])]
cons)))
                  ([Q (Guard, Exp)] -> Q Body
forall (m :: * -> *). Quote m => [m (Guard, Exp)] -> m Body
guardedB [(Guard, Exp) -> Q (Guard, Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Guard
NormalG Exp
sameSizeExpr, Exp
result)])
                  [Q Dec]
sizeDecls
        constSizeDec :: Name -> (Name, [(Name, Type)]) -> DecQ
        constSizeDec :: Name -> (Name, [(Name, Type)]) -> Q Dec
constSizeDec Name
szn (Name
_, []) =
            Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
szn) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| 0 |]) []
        constSizeDec Name
szn (Name
_, [(Name, Type)]
fields) =
            Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
szn) Q Body
body []
          where
            body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$
                (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\Q Exp
l Q Exp
r -> [| $(Q Exp
l) + $(Q Exp
r) |]) ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$
                ((Name, Type) -> Q Exp) -> [(Name, Type)] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
sizeName, Type
_) -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
sizeName) [(Name, Type)]
fields
        matchVarSize :: MatchQ
        matchVarSize :: Q Match
matchVarSize = do
            Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match ([Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP (((Name, Type) -> Q Pat) -> [(Name, Type)] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, Type
_) -> Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
n) (((Name, [(Name, Type)]) -> [(Name, Type)])
-> [(Name, [(Name, Type)])] -> [(Name, Type)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name, [(Name, Type)]) -> [(Name, Type)]
forall a b. (a, b) -> b
snd [(Name, [(Name, Type)])]
cons)))
                  (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
varSizeExpr)
                  []
        varSizeExpr :: ExpQ
        varSizeExpr :: Q Exp
varSizeExpr =
            [| VarSize $ \x -> tagSize + $(Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE [| x |] (((Name, [(Name, Type)]) -> Q Match)
-> [(Name, [(Name, Type)])] -> [Q Match]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [(Name, Type)]) -> Q Match
matchVar [(Name, [(Name, Type)])]
cons)) |]
        matchVar :: (Name, [(Name, Type)]) -> MatchQ
        matchVar :: (Name, [(Name, Type)]) -> Q Match
matchVar (Name
cname, []) =
            Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
cname []) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| 0 |]) []
        matchVar (Name
cname, [(Name, Type)]
fields) =
            Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
cname (((Name, Type) -> Name -> Q Pat)
-> [(Name, Type)] -> [Name] -> [Q Pat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Name, Type)
_ Name
fn -> Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
fn) [(Name, Type)]
fields [Name]
fNames))
                  Q Body
body
                  []
          where
            body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$
                (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\Q Exp
l Q Exp
r -> [| $(Q Exp
l) + $(Q Exp
r) |])
                (((Name, Type) -> Name -> Q Exp)
-> [(Name, Type)] -> [Name] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Name
sizeName, Type
_) Name
fn -> [| getSizeWith $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
sizeName) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fn) |])
                         [(Name, Type)]
fields
                         [Name]
fNames)
    -- Choose a tag size large enough for this constructor count.
    -- Expression used for the definition of peek.
    peekExpr :: Q Exp
peekExpr = case [(Name, [(Name, Type)])]
cons of
        [] -> [| error ("Attempting to peek type with no constructors (" ++ $(String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift (Type -> String
forall a. Show a => a -> String
show Type
headTy)) ++ ")") |]
        [(Name, [(Name, Type)])
con] -> (Name, [(Name, Type)]) -> Q Exp
forall {m :: * -> *} {b}. Quote m => (Name, [(Name, b)]) -> m Exp
peekCon (Name, [(Name, Type)])
con
        [(Name, [(Name, Type)])]
_ -> [Q Stmt] -> Q Exp
forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE
            [ Q Pat -> Q Exp -> Q Stmt
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
tagName) [| peek |]
            , Q Exp -> Q Stmt
forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS (Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Q Exp -> Q Type -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
sigE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tagName) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tagType))
                      (((Integer, (Name, [(Name, Type)])) -> Q Match)
-> [(Integer, (Name, [(Name, Type)]))] -> [Q Match]
forall a b. (a -> b) -> [a] -> [b]
map (Integer, (Name, [(Name, Type)])) -> Q Match
forall {m :: * -> *} {b}.
Quote m =>
(Integer, (Name, [(Name, b)])) -> m Match
peekMatch ([Integer]
-> [(Name, [(Name, Type)])] -> [(Integer, (Name, [(Name, Type)]))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] [(Name, [(Name, Type)])]
cons) [Q Match] -> [Q Match] -> [Q Match]
forall a. [a] -> [a] -> [a]
++ [Q Match
peekErr]))
            ]
    peekMatch :: (Integer, (Name, [(Name, b)])) -> m Match
peekMatch (Integer
ix, (Name, [(Name, b)])
con) = m Pat -> m Body -> [m Dec] -> m Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Lit -> m Pat
forall (m :: * -> *). Quote m => Lit -> m Pat
litP (Integer -> Lit
IntegerL Integer
ix)) (m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ((Name, [(Name, b)]) -> m Exp
forall {m :: * -> *} {b}. Quote m => (Name, [(Name, b)]) -> m Exp
peekCon (Name, [(Name, b)])
con)) []
    peekErr :: Q Match
peekErr = Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
        [| peekException $ T.pack $ "Found invalid tag while peeking (" ++ $(String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift (Type -> String
forall a. Show a => a -> String
show Type
headTy)) ++ ")" |]) []
    peekCon :: (Name, [(Name, b)]) -> m Exp
peekCon (Name
cname, [(Name, b)]
fields) =
        case [(Name, b)]
fields of
            [] -> [| pure $(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
cname) |]
            [(Name, b)]
_ -> [m Stmt] -> m Exp
forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE ([m Stmt] -> m Exp) -> [m Stmt] -> m Exp
forall a b. (a -> b) -> a -> b
$
                ((Name, b) -> m Stmt) -> [(Name, b)] -> [m Stmt]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
fn, b
_) -> m Pat -> m Exp -> m Stmt
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS (Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
fn) [| peek |]) [(Name, b)]
fields [m Stmt] -> [m Stmt] -> [m Stmt]
forall a. [a] -> [a] -> [a]
++
               [m Exp -> m Stmt
forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS (m Exp -> m Stmt) -> m Exp -> m Stmt
forall a b. (a -> b) -> a -> b
$ m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'return) (m Exp -> m Exp) -> m Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ [m Exp] -> m Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE ([m Exp] -> m Exp) -> [m Exp] -> m Exp
forall a b. (a -> b) -> a -> b
$ Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
cname m Exp -> [m Exp] -> [m Exp]
forall a. a -> [a] -> [a]
: ((Name, b) -> m Exp) -> [(Name, b)] -> [m Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
fn, b
_) -> Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fn) [(Name, b)]
fields]
    pokeExpr :: Q Exp
pokeExpr = [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
valName] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
valName) ([Q Match] -> Q Exp) -> [Q Match] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Int -> (Name, [(Name, Type)]) -> Q Match)
-> [Int] -> [(Name, [(Name, Type)])] -> [Q Match]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> (Name, [(Name, Type)]) -> Q Match
pokeCon [Int
0..] [(Name, [(Name, Type)])]
cons
    pokeCon :: Int -> (Name, [(Name, Type)]) -> MatchQ
    pokeCon :: Int -> (Name, [(Name, Type)]) -> Q Match
pokeCon Int
ix (Name
cname, [(Name, Type)]
fields) =
        Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
cname (((Name, Type) -> Q Pat) -> [(Name, Type)] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
fn, Type
_) -> Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
fn) [(Name, Type)]
fields)) Q Body
body []
      where
        body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$
            case [(Name, [(Name, Type)])]
cons of
                ((Name, [(Name, Type)])
_:(Name, [(Name, Type)])
_:[(Name, [(Name, Type)])]
_) -> [Q Stmt] -> Q Exp
forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE (Int -> Q Stmt
forall {m :: * -> *} {t}. (Quote m, Lift t) => t -> m Stmt
pokeTag Int
ix Q Stmt -> [Q Stmt] -> [Q Stmt]
forall a. a -> [a] -> [a]
: ((Name, Type) -> Q Stmt) -> [(Name, Type)] -> [Q Stmt]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Type) -> Q Stmt
forall {m :: * -> *} {b}. Quote m => (Name, b) -> m Stmt
pokeField [(Name, Type)]
fields)
                [(Name, [(Name, Type)])]
_ -> [Q Stmt] -> Q Exp
forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE (((Name, Type) -> Q Stmt) -> [(Name, Type)] -> [Q Stmt]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Type) -> Q Stmt
forall {m :: * -> *} {b}. Quote m => (Name, b) -> m Stmt
pokeField [(Name, Type)]
fields)
    pokeTag :: t -> m Stmt
pokeTag t
ix = m Exp -> m Stmt
forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS [| poke (ix :: $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tagType)) |]
    pokeField :: (Name, b) -> m Stmt
pokeField (Name
fn, b
_) = m Exp -> m Stmt
forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS [| poke $(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fn) |]

{- What the generated code looks like

data Foo = Foo Int Double Float

instance Store Foo where
    size =
        case (size :: Size Int, size :: Size Double, size :: Size Float) of
            (ConstSize c0f0, ConstSize c0f1, ConstSize c0f2) -> ConstSize (0 + sz0)
              where
                sz0 = c0f0 + c0f1 + c0f2
            (c0f0, c0f1, c0f2)
                VarSize $ \(Foo f0 f1 f2) -> 0 +
                    getSizeWith c0f0 f0 + getSizeWith c0f1 f1 + getSizeWith c0f2 f2
    peek = do
        f0 <- peek
        f1 <- peek
        f2 <- peek
        return (Foo f0 f1 f2)
    poke (Foo f0 f1 f2) = do
        poke f0
        poke f1
        poke f2

data Bar = Bar Int | Baz Double

instance Store Bar where
    size =
        case (size :: Size Int, size :: Size Double) of
            (ConstSize c0f0, ConstSize c1f0) | sz0 == sz1 -> ConstSize (1 + sz0)
              where
                sz0 = c0f0
                sz1 = c1f0
            (c0f0, c1f0) -> VarSize $ \x -> 1 +
                case x of
                    Bar f0 -> getSizeWith c0f0 f0
                    Baz f0 -> getSizeWith c1f0 f0
    peek = do
        tag <- peek
        case (tag :: Word8) of
            0 -> do
                f0 <- peek
                return (Bar f0)
            1 -> do
                f0 <- peek
                return (Baz f0)
            _ -> peekException "Found invalid tag while peeking (Bar)"
    poke (Bar f0) = do
        poke 0
        poke f0
    poke (Bar f0) = do
        poke 1
        poke f0
-}

------------------------------------------------------------------------
-- Generic

deriveTupleStoreInstance :: Int -> Dec
deriveTupleStoreInstance :: Int -> Dec
deriveTupleStoreInstance Int
n =
    [Type] -> Type -> Dec
deriveGenericInstance ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
storePred [Type]
tvs)
                          ((Type -> Type -> Type) -> [Type] -> Type
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Type -> Type -> Type
AppT (Int -> Type
TupleT Int
n Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
tvs))
  where
    tvs :: [Type]
tvs = Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
take Int
n ((Char -> Type) -> String -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT (Name -> Type) -> (Char -> Name) -> Char -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Name) -> (Char -> String) -> Char -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> String
forall a. a -> [a] -> [a]
:[])) [Char
'a'..Char
'z'])

deriveGenericInstance :: Cxt -> Type -> Dec
deriveGenericInstance :: [Type] -> Type -> Dec
deriveGenericInstance [Type]
cs Type
ty = [Type] -> Type -> [Dec] -> Dec
plainInstanceD [Type]
cs (Type -> Type -> Type
AppT (Name -> Type
ConT ''Store) Type
ty) []

deriveGenericInstanceFromName :: Name -> Q Dec
deriveGenericInstanceFromName :: Name -> Q Dec
deriveGenericInstanceFromName Name
n = do
    [Type]
tvs <- (Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT ([Name] -> [Type]) -> (DataType -> [Name]) -> DataType -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataType -> [Name]
dtTvs (DataType -> [Type]) -> Q DataType -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q DataType
reifyDataType Name
n
    Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> Dec
deriveGenericInstance ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
storePred [Type]
tvs) (Type -> [Type] -> Type
appsT (Name -> Type
ConT Name
n) [Type]
tvs)

------------------------------------------------------------------------
-- Storable

-- TODO: Generate inline pragmas? Probably not necessary

deriveManyStoreFromStorable :: (Type -> Bool) -> Q [Dec]
deriveManyStoreFromStorable :: (Type -> Bool) -> Q [Dec]
deriveManyStoreFromStorable Type -> Bool
p = do
    Map [Type] TypeclassInstance
storables <- Map [Type] [TypeclassInstance] -> Map [Type] TypeclassInstance
forall a. Map [Type] [a] -> Map [Type] a
postprocess (Map [Type] [TypeclassInstance] -> Map [Type] TypeclassInstance)
-> ([TypeclassInstance] -> Map [Type] [TypeclassInstance])
-> [TypeclassInstance]
-> Map [Type] TypeclassInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeclassInstance] -> Map [Type] [TypeclassInstance]
instancesMap ([TypeclassInstance] -> Map [Type] TypeclassInstance)
-> Q [TypeclassInstance] -> Q (Map [Type] TypeclassInstance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q [TypeclassInstance]
getInstances ''Storable
    Map [Type] TypeclassInstance
stores <- Map [Type] [TypeclassInstance] -> Map [Type] TypeclassInstance
forall a. Map [Type] [a] -> Map [Type] a
postprocess (Map [Type] [TypeclassInstance] -> Map [Type] TypeclassInstance)
-> ([TypeclassInstance] -> Map [Type] [TypeclassInstance])
-> [TypeclassInstance]
-> Map [Type] TypeclassInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeclassInstance] -> Map [Type] [TypeclassInstance]
instancesMap ([TypeclassInstance] -> Map [Type] TypeclassInstance)
-> Q [TypeclassInstance] -> Q (Map [Type] TypeclassInstance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q [TypeclassInstance]
getInstances ''Store
    [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Map [Type] Dec -> [Dec]
forall k a. Map k a -> [a]
M.elems (Map [Type] Dec -> [Dec]) -> Map [Type] Dec -> [Dec]
forall a b. (a -> b) -> a -> b
$ ((TypeclassInstance -> Maybe Dec)
 -> Map [Type] TypeclassInstance -> Map [Type] Dec)
-> Map [Type] TypeclassInstance
-> (TypeclassInstance -> Maybe Dec)
-> Map [Type] Dec
forall a b c. (a -> b -> c) -> b -> a -> c
flip (TypeclassInstance -> Maybe Dec)
-> Map [Type] TypeclassInstance -> Map [Type] Dec
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
M.mapMaybe (Map [Type] TypeclassInstance
storables Map [Type] TypeclassInstance
-> Map [Type] TypeclassInstance -> Map [Type] TypeclassInstance
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`M.difference` Map [Type] TypeclassInstance
stores) ((TypeclassInstance -> Maybe Dec) -> Map [Type] Dec)
-> (TypeclassInstance -> Maybe Dec) -> Map [Type] Dec
forall a b. (a -> b) -> a -> b
$
        \(TypeclassInstance [Type]
cs Type
ty [Dec]
_) ->
        let argTy :: Type
argTy = [Type] -> Type
forall a. HasCallStack => [a] -> a
head ([Type] -> [Type]
forall a. HasCallStack => [a] -> [a]
tail (Type -> [Type]
unAppsT Type
ty))
            tyNameLit :: Exp
tyNameLit = Lit -> Exp
LitE (String -> Lit
StringL (Type -> String
forall a. Ppr a => a -> String
pprint Type
ty)) in
        if Type -> Bool
p Type
argTy Bool -> Bool -> Bool
&& Bool -> Bool
not ([Type] -> Bool
superclassHasStorable [Type]
cs)
            then Dec -> Maybe Dec
forall a. a -> Maybe a
Just (Dec -> Maybe Dec) -> Dec -> Maybe Dec
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> Exp -> Exp -> Exp -> Dec
makeStoreInstance [Type]
cs Type
argTy
                (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'sizeStorableTy) Exp
tyNameLit)
                (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'peekStorableTy) Exp
tyNameLit)
                (Name -> Exp
VarE 'pokeStorable)
            else Maybe Dec
forall a. Maybe a
Nothing

-- See #143. Often Storable superclass constraints should instead be
-- Store constraints, so instead it just warns for these.
superclassHasStorable :: Cxt -> Bool
superclassHasStorable :: [Type] -> Bool
superclassHasStorable = Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (Maybe () -> Bool) -> ([Type] -> Maybe ()) -> [Type] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericQ (Maybe ()) -> GenericQ (Maybe ())
forall u. GenericQ (Maybe u) -> GenericQ (Maybe u)
something (Maybe () -> (Type -> Maybe ()) -> a -> Maybe ()
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ Maybe ()
forall a. Maybe a
Nothing Type -> Maybe ()
justStorable (a -> Maybe ()) -> (String -> Maybe ()) -> a -> Maybe ()
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` String -> Maybe ()
ignoreStrings)
  where
    justStorable :: Type -> Maybe ()
    justStorable :: Type -> Maybe ()
justStorable (ConT Name
n) | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Storable = () -> Maybe ()
forall a. a -> Maybe a
Just ()
    justStorable Type
_ = Maybe ()
forall a. Maybe a
Nothing
    ignoreStrings :: String -> Maybe ()
    ignoreStrings :: String -> Maybe ()
ignoreStrings String
_ = Maybe ()
forall a. Maybe a
Nothing

------------------------------------------------------------------------
-- Vector

deriveManyStorePrimVector :: Q [Dec]
deriveManyStorePrimVector :: Q [Dec]
deriveManyStorePrimVector = do
    Map [Type] TypeclassInstance
prims <- Map [Type] [TypeclassInstance] -> Map [Type] TypeclassInstance
forall a. Map [Type] [a] -> Map [Type] a
postprocess (Map [Type] [TypeclassInstance] -> Map [Type] TypeclassInstance)
-> ([TypeclassInstance] -> Map [Type] [TypeclassInstance])
-> [TypeclassInstance]
-> Map [Type] TypeclassInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeclassInstance] -> Map [Type] [TypeclassInstance]
instancesMap ([TypeclassInstance] -> Map [Type] TypeclassInstance)
-> Q [TypeclassInstance] -> Q (Map [Type] TypeclassInstance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q [TypeclassInstance]
getInstances ''PV.Prim
    Map [Type] TypeclassInstance
stores <- Map [Type] [TypeclassInstance] -> Map [Type] TypeclassInstance
forall a. Map [Type] [a] -> Map [Type] a
postprocess (Map [Type] [TypeclassInstance] -> Map [Type] TypeclassInstance)
-> ([TypeclassInstance] -> Map [Type] [TypeclassInstance])
-> [TypeclassInstance]
-> Map [Type] TypeclassInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeclassInstance] -> Map [Type] [TypeclassInstance]
instancesMap ([TypeclassInstance] -> Map [Type] TypeclassInstance)
-> Q [TypeclassInstance] -> Q (Map [Type] TypeclassInstance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q [TypeclassInstance]
getInstances ''Store
    let primInsts :: Map [Type] TypeclassInstance
primInsts =
            ([Type] -> [Type])
-> Map [Type] TypeclassInstance -> Map [Type] TypeclassInstance
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type -> Type
AppT (Name -> Type
ConT ''PV.Vector))) Map [Type] TypeclassInstance
prims
            Map [Type] TypeclassInstance
-> Map [Type] TypeclassInstance -> Map [Type] TypeclassInstance
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`M.difference`
            Map [Type] TypeclassInstance
stores
    [([Type], TypeclassInstance)]
-> (([Type], TypeclassInstance) -> Q Dec) -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map [Type] TypeclassInstance -> [([Type], TypeclassInstance)]
forall k a. Map k a -> [(k, a)]
M.toList Map [Type] TypeclassInstance
primInsts) ((([Type], TypeclassInstance) -> Q Dec) -> Q [Dec])
-> (([Type], TypeclassInstance) -> Q Dec) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \([Type], TypeclassInstance)
primInst -> case ([Type], TypeclassInstance)
primInst of
        ([Type
_], TypeclassInstance [Type]
cs Type
ty [Dec]
_) -> do
            let argTy :: Type
argTy = [Type] -> Type
forall a. HasCallStack => [a] -> a
head ([Type] -> [Type]
forall a. HasCallStack => [a] -> [a]
tail (Type -> [Type]
unAppsT Type
ty))
            Exp
sizeExpr <- [|
                VarSize $ \x ->
                    I# $(Type -> Q Exp
primSizeOfExpr (Name -> Type
ConT ''Int)) +
                    I# $(Type -> Q Exp
primSizeOfExpr Type
argTy) * PV.length x
                |]
            Exp
peekExpr <- [| do
                len <- peek
                let sz = I# $(Type -> Q Exp
primSizeOfExpr Type
argTy)
                array <- peekToByteArray $(String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift (String
"Primitive Vector (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
argTy String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"))
                                         (len * sz)
                return (PV.Vector 0 len array)
                |]
            Exp
pokeExpr <- [| \(PV.Vector offset len (ByteArray array)) -> do
                let sz = I# $(Type -> Q Exp
primSizeOfExpr Type
argTy)
                poke len
                pokeFromByteArray array (offset * sz) (len * sz)
                |]
            Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> Exp -> Exp -> Exp -> Dec
makeStoreInstance [Type]
cs (Type -> Type -> Type
AppT (Name -> Type
ConT ''PV.Vector) Type
argTy) Exp
sizeExpr Exp
peekExpr Exp
pokeExpr
        ([Type], TypeclassInstance)
_ -> String -> Q Dec
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invariant violated in derivemanyStorePrimVector"


primSizeOfExpr :: Type -> ExpQ
primSizeOfExpr :: Type -> Q Exp
primSizeOfExpr Type
ty = [| $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'sizeOf#) (error "sizeOf# evaluated its argument" :: $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)) |]

deriveManyStoreUnboxVector :: Q [Dec]
deriveManyStoreUnboxVector :: Q [Dec]
deriveManyStoreUnboxVector = do
    [([Type], Type, [DataCon])]
unboxes <- Q [([Type], Type, [DataCon])]
getUnboxInfo
    Map [Type] TypeclassInstance
stores <- Map [Type] [TypeclassInstance] -> Map [Type] TypeclassInstance
forall a. Map [Type] [a] -> Map [Type] a
postprocess (Map [Type] [TypeclassInstance] -> Map [Type] TypeclassInstance)
-> ([TypeclassInstance] -> Map [Type] [TypeclassInstance])
-> [TypeclassInstance]
-> Map [Type] TypeclassInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeclassInstance] -> Map [Type] [TypeclassInstance]
instancesMap ([TypeclassInstance] -> Map [Type] TypeclassInstance)
-> Q [TypeclassInstance] -> Q (Map [Type] TypeclassInstance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q [TypeclassInstance]
getInstances ''Store
    Map [Type] TypeclassInstance
unboxInstances <- Map [Type] [TypeclassInstance] -> Map [Type] TypeclassInstance
forall a. Map [Type] [a] -> Map [Type] a
postprocess (Map [Type] [TypeclassInstance] -> Map [Type] TypeclassInstance)
-> ([TypeclassInstance] -> Map [Type] [TypeclassInstance])
-> [TypeclassInstance]
-> Map [Type] TypeclassInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeclassInstance] -> Map [Type] [TypeclassInstance]
instancesMap ([TypeclassInstance] -> Map [Type] TypeclassInstance)
-> Q [TypeclassInstance] -> Q (Map [Type] TypeclassInstance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q [TypeclassInstance]
getInstances ''UV.Unbox
    let dataFamilyDecls :: Map [Type] ([Type], [DataCon])
dataFamilyDecls =
            [([Type], ([Type], [DataCon]))] -> Map [Type] ([Type], [DataCon])
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ((([Type], Type, [DataCon]) -> ([Type], ([Type], [DataCon])))
-> [([Type], Type, [DataCon])] -> [([Type], ([Type], [DataCon]))]
forall a b. (a -> b) -> [a] -> [b]
map (\([Type]
preds, Type
ty, [DataCon]
cons) -> ([Type -> Type -> Type
AppT (Name -> Type
ConT ''UV.Vector) Type
ty], ([Type]
preds, [DataCon]
cons))) [([Type], Type, [DataCon])]
unboxes)
            Map [Type] ([Type], [DataCon])
-> Map [Type] TypeclassInstance -> Map [Type] ([Type], [DataCon])
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`M.difference`
            Map [Type] TypeclassInstance
stores
#if MIN_VERSION_template_haskell(2,10,0)
        substituteConstraint :: Type -> Type
substituteConstraint (AppT (ConT Name
n) Type
arg)
          | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''UV.Unbox = Type -> Type -> Type
AppT (Name -> Type
ConT ''Store) (Type -> Type -> Type
AppT (Name -> Type
ConT ''UV.Vector) Type
arg)
#else
        substituteConstraint (ClassP n [arg])
          | n == ''UV.Unbox = ClassP ''Store [AppT (ConT ''UV.Vector) arg]
#endif
        substituteConstraint Type
x = Type
x
    -- TODO: ideally this would use a variant of 'deriveStore' which
    -- assumes VarSize.
    [([Type], ([Type], [DataCon]))]
-> (([Type], ([Type], [DataCon])) -> Q Dec) -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map [Type] ([Type], [DataCon]) -> [([Type], ([Type], [DataCon]))]
forall k a. Map k a -> [(k, a)]
M.toList Map [Type] ([Type], [DataCon])
dataFamilyDecls) ((([Type], ([Type], [DataCon])) -> Q Dec) -> Q [Dec])
-> (([Type], ([Type], [DataCon])) -> Q Dec) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \case
        ([Type
ty], ([Type]
_, [DataCon]
cons)) -> do
            let headTy :: Type
headTy = Type -> Type
getTyHead (Type -> [Type]
unAppsT Type
ty [Type] -> Int -> Type
forall a. HasCallStack => [a] -> Int -> a
!! Int
1)
            ([Type]
preds, Type
ty') <- case [Type] -> Map [Type] TypeclassInstance -> Maybe TypeclassInstance
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Type
headTy] Map [Type] TypeclassInstance
unboxInstances of
              Maybe TypeclassInstance
Nothing -> do
                String -> Q ()
reportWarning (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"No Unbox instance found for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
headTy
                ([Type], Type) -> Q ([Type], Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Type
ty)
              Just (TypeclassInstance [Type]
cs (AppT Type
_ Type
ty') [Dec]
_) -> case Type
ty' of
                AppT (ConT Name
conName) Type
arg ->
                  if Name -> String
nameBase Name
conName String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
doNotUnboxConstructors
                    then ([Type], Type) -> Q ([Type], Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type -> Type -> Type
AppT (Name -> Type
ConT ''Store) Type
arg], Type -> Type -> Type
AppT (Name -> Type
ConT ''UV.Vector) Type
ty')
                    else ([Type], Type) -> Q ([Type], Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
substituteConstraint [Type]
cs, Type -> Type -> Type
AppT (Name -> Type
ConT ''UV.Vector) Type
ty')
                Type
_ -> ([Type], Type) -> Q ([Type], Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
substituteConstraint [Type]
cs, Type -> Type -> Type
AppT (Name -> Type
ConT ''UV.Vector) Type
ty')
              Just TypeclassInstance
_ -> String -> Q ([Type], Type)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Impossible case"
            [Type] -> Type -> [DataCon] -> Q Dec
deriveStore [Type]
preds Type
ty' [DataCon]
cons
        ([Type], ([Type], [DataCon]))
_ -> String -> Q Dec
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"impossible case in deriveManyStoreUnboxVector"

-- TODO: Add something for this purpose to TH.ReifyDataType

getUnboxInfo :: Q [(Cxt, Type, [DataCon])]
getUnboxInfo :: Q [([Type], Type, [DataCon])]
getUnboxInfo = do
    FamilyI Dec
_ [Dec]
insts <- Name -> Q Info
reify ''UV.Vector
    [([Type], Type, [DataCon])] -> Q [([Type], Type, [DataCon])]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((([Type], Type, [DataCon]) -> ([Type], Type, [DataCon]))
-> [([Type], Type, [DataCon])] -> [([Type], Type, [DataCon])]
forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere (a -> a
forall a. a -> a
id (a -> a) -> (Type -> Type) -> a -> a
forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`extT` Type -> Type
dequalVarT)) ([([Type], Type, [DataCon])] -> [([Type], Type, [DataCon])])
-> [([Type], Type, [DataCon])] -> [([Type], Type, [DataCon])]
forall a b. (a -> b) -> a -> b
$ (Dec -> Maybe ([Type], Type, [DataCon]))
-> [Dec] -> [([Type], Type, [DataCon])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Dec -> Maybe ([Type], Type, [DataCon])
go [Dec]
insts)
  where
#if MIN_VERSION_template_haskell(2,15,0)
    go :: Dec -> Maybe ([Type], Type, [DataCon])
go (NewtypeInstD [Type]
preds Maybe [TyVarBndr ()]
_ Type
lhs Maybe Type
_ Con
con [DerivClause]
_)
      | [Type
_, Type
ty] <- Type -> [Type]
unAppsT Type
lhs
      = [Type] -> Type -> [Con] -> Maybe ([Type], Type, [DataCon])
toResult [Type]
preds Type
ty [Con
con]
    go (DataInstD [Type]
preds Maybe [TyVarBndr ()]
_ Type
lhs Maybe Type
_ [Con]
cons [DerivClause]
_)
      | [Type
_, Type
ty] <- Type -> [Type]
unAppsT Type
lhs
      = [Type] -> Type -> [Con] -> Maybe ([Type], Type, [DataCon])
toResult [Type]
preds Type
ty [Con]
cons
#elif MIN_VERSION_template_haskell(2,11,0)
    go (NewtypeInstD preds _ [ty] _ con _) = toResult preds ty [con]
    go (DataInstD preds _ [ty] _ cons _) = toResult preds ty cons
#else
    go (NewtypeInstD preds _ [ty] con _) = toResult preds ty [con]
    go (DataInstD preds _ [ty] cons _) = toResult preds ty cons
#endif
    go Dec
x = String -> Maybe ([Type], Type, [DataCon])
forall a. HasCallStack => String -> a
error (String
"Unexpected result from reifying Unboxed Vector instances: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Dec -> String
forall a. Ppr a => a -> String
pprint Dec
x)
    toResult :: Cxt -> Type -> [Con] -> Maybe (Cxt, Type, [DataCon])
    toResult :: [Type] -> Type -> [Con] -> Maybe ([Type], Type, [DataCon])
toResult [Type]
_ Type
_ [NormalC Name
conName [BangType]
_]
      | Name -> String
nameBase Name
conName String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
skippedUnboxConstructors = Maybe ([Type], Type, [DataCon])
forall a. Maybe a
Nothing
    toResult [Type]
preds Type
ty [Con]
cons
      = ([Type], Type, [DataCon]) -> Maybe ([Type], Type, [DataCon])
forall a. a -> Maybe a
Just ([Type]
preds, Type
ty, (Con -> [DataCon]) -> [Con] -> [DataCon]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Con -> [DataCon]
conToDataCons [Con]
cons)
    dequalVarT :: Type -> Type
    dequalVarT :: Type -> Type
dequalVarT (VarT Name
n) = Name -> Type
VarT (Name -> Name
dequalify Name
n)
    dequalVarT Type
ty = Type
ty

-- See issue #174
skippedUnboxConstructors :: [String]
skippedUnboxConstructors :: [String]
skippedUnboxConstructors = [String
"MV_UnboxAs", String
"V_UnboxAs", String
"MV_UnboxViaPrim", String
"V_UnboxViaPrim"]

-- See issue #179
doNotUnboxConstructors :: [String]
doNotUnboxConstructors :: [String]
doNotUnboxConstructors = [String
"DoNotUnboxLazy",String
"DoNotUnboxStrict",String
"DoNotUnboxNormalForm"]

------------------------------------------------------------------------
-- Utilities

-- Filters out overlapping instances and instances with more than one
-- type arg (should be impossible).
postprocess :: M.Map [Type] [a] -> M.Map [Type] a
postprocess :: forall a. Map [Type] [a] -> Map [Type] a
postprocess =
    ([Type] -> [a] -> Maybe a) -> Map [Type] [a] -> Map [Type] a
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
M.mapMaybeWithKey (([Type] -> [a] -> Maybe a) -> Map [Type] [a] -> Map [Type] a)
-> ([Type] -> [a] -> Maybe a) -> Map [Type] [a] -> Map [Type] a
forall a b. (a -> b) -> a -> b
$ \[Type]
tys [a]
xs ->
        case ([Type]
tys, [a]
xs) of
            ([Type
_ty], [a
x]) -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
            ([Type], [a])
_ -> Maybe a
forall a. Maybe a
Nothing

makeStoreInstance :: Cxt -> Type -> Exp -> Exp -> Exp -> Dec
makeStoreInstance :: [Type] -> Type -> Exp -> Exp -> Exp -> Dec
makeStoreInstance [Type]
cs Type
ty Exp
sizeExpr Exp
peekExpr Exp
pokeExpr =
    [Type] -> Type -> [Dec] -> Dec
plainInstanceD
        [Type]
cs
        (Type -> Type -> Type
AppT (Name -> Type
ConT ''Store) Type
ty)
        [ Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP 'size) (Exp -> Body
NormalB Exp
sizeExpr) []
        , Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP 'peek) (Exp -> Body
NormalB Exp
peekExpr) []
        , Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP 'poke) (Exp -> Body
NormalB Exp
pokeExpr) []
        ]

-- TODO: either generate random types that satisfy instances with
-- variables in them, or have a check that there's at least a manual
-- check for polymorphic instances.

getAllInstanceTypes :: Name -> Q [[Type]]
getAllInstanceTypes :: Name -> Q [[Type]]
getAllInstanceTypes Name
n =
    (TypeclassInstance -> [Type]) -> [TypeclassInstance] -> [[Type]]
forall a b. (a -> b) -> [a] -> [b]
map (\(TypeclassInstance [Type]
_ Type
ty [Dec]
_) -> Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop Int
1 (Type -> [Type]
unAppsT Type
ty)) ([TypeclassInstance] -> [[Type]])
-> Q [TypeclassInstance] -> Q [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Name -> Q [TypeclassInstance]
getInstances Name
n

getAllInstanceTypes1 :: Name -> Q [Type]
getAllInstanceTypes1 :: Name -> Q [Type]
getAllInstanceTypes1 Name
n =
    ([[Type]] -> [Type]) -> Q [[Type]] -> Q [Type]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Type] -> Type) -> [[Type]] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe (String -> Type
forall a. HasCallStack => String -> a
error String
"getAllMonoInstances1 expected only one type argument") (Maybe Type -> Type) -> ([Type] -> Maybe Type) -> [Type] -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type] -> Maybe Type
forall a. [a] -> Maybe a
headMay))
         (Name -> Q [[Type]]
getAllInstanceTypes Name
n)

isMonoType :: Type -> Bool
isMonoType :: Type -> Bool
isMonoType = [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Type] -> Bool) -> (Type -> [Type]) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Bool) -> GenericQ [Type]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify Type -> Bool
isVarT

isVarT :: Type -> Bool
isVarT :: Type -> Bool
isVarT VarT{} = Bool
True
isVarT Type
_ = Bool
False

-- TOOD: move these to th-reify-many

-- | Get a map from the 'getTyHead' type of instances to
-- 'TypeclassInstance'.
instancesMap :: [TypeclassInstance] -> M.Map [Type] [TypeclassInstance]
instancesMap :: [TypeclassInstance] -> Map [Type] [TypeclassInstance]
instancesMap =
    ([TypeclassInstance] -> [TypeclassInstance] -> [TypeclassInstance])
-> [([Type], [TypeclassInstance])]
-> Map [Type] [TypeclassInstance]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [TypeclassInstance] -> [TypeclassInstance] -> [TypeclassInstance]
forall a. [a] -> [a] -> [a]
(++) ([([Type], [TypeclassInstance])] -> Map [Type] [TypeclassInstance])
-> ([TypeclassInstance] -> [([Type], [TypeclassInstance])])
-> [TypeclassInstance]
-> Map [Type] [TypeclassInstance]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (TypeclassInstance -> ([Type], [TypeclassInstance]))
-> [TypeclassInstance] -> [([Type], [TypeclassInstance])]
forall a b. (a -> b) -> [a] -> [b]
map (\TypeclassInstance
ti -> ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
getTyHead (TypeclassInstance -> [Type]
instanceArgTypes TypeclassInstance
ti), [TypeclassInstance
ti]))

instanceArgTypes :: TypeclassInstance -> [Type]
instanceArgTypes :: TypeclassInstance -> [Type]
instanceArgTypes (TypeclassInstance [Type]
_ Type
ty [Dec]
_) = Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop Int
1 (Type -> [Type]
unAppsT Type
ty)

getTyHead :: Type -> Type
getTyHead :: Type -> Type
getTyHead (SigT Type
x Type
_) = Type -> Type
getTyHead Type
x
getTyHead (ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
x) = Type -> Type
getTyHead Type
x
getTyHead (AppT Type
l Type
_) = Type -> Type
getTyHead Type
l
getTyHead Type
x = Type
x

storePred :: Type -> Pred
storePred :: Type -> Type
storePred Type
ty =
#if MIN_VERSION_template_haskell(2,10,0)
        Type -> Type -> Type
AppT (Name -> Type
ConT ''Store) Type
ty
#else
        ClassP ''Store [ty]
#endif