{-# 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) -> Cxt -> Type -> Q [Dec]
runDeriver Proxy (Store a)
_ Cxt
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
<$> Cxt -> Type -> [DataCon] -> Q Dec
deriveStore Cxt
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 :: Cxt
preds = (Name -> Type) -> [Name] -> Cxt
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 -> Cxt -> Type
appsT (Name -> Type
ConT Name
name) ((Name -> Type) -> [Name] -> Cxt
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
<$> Cxt -> Type -> [DataCon] -> Q Dec
deriveStore Cxt
preds Type
argTy (DataType -> [DataCon]
dtCons DataType
dt)

deriveStore :: Cxt -> Type -> [DataCon] -> Q Dec
deriveStore :: Cxt -> Type -> [DataCon] -> Q Dec
deriveStore Cxt
preds Type
headTy [DataCon]
cons0 =
    Cxt -> Type -> Exp -> Exp -> Exp -> Dec
makeStoreInstance Cxt
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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q Exp
peekExpr
        Q (Exp -> Dec) -> Q Exp -> Q Dec
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 (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 (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 -> [MatchQ] -> Q Exp
caseE ([Q Exp] -> Q 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 ()
                     [] -> [MatchQ
matchConstSize]
                     [(Name, [(Name, Type)])
c] | [(Name, Type)] -> 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) -> [MatchQ
matchConstSize]
                     [(Name, [(Name, Type)])]
_ -> [MatchQ
matchConstSize, MatchQ
matchVarSize])
        | Bool
otherwise = Q Exp
varSizeExpr
      where
        sizeAtType :: (Name, Type) -> ExpQ
        sizeAtType :: (Name, Type) -> Q Exp
sizeAtType (Name
_, Type
ty) = [| size :: Size $(return ty) |]
        matchConstSize :: MatchQ
        matchConstSize :: MatchQ
matchConstSize = do
            let sz0 :: Exp
sz0 = Name -> Exp
VarE (String -> Name
mkName String
"sz0")
                sizeDecls :: [Q Dec]
sizeDecls =
                    if [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
sizeNames
                        then [PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP (String -> Name
mkName String
"sz0")) (Q Exp -> BodyQ
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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
l Q Exp
r -> [| $(l) && $(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 -> [| $(return sz0) == $(varE szn) |]) [Name]
tailSizeNames
                    [] -> [| True |]
            Exp
result <- [| ConstSize (tagSize + $(return sz0)) |]
            PatQ -> BodyQ -> [Q Dec] -> MatchQ
match ([PatQ] -> PatQ
tupP (((Name, Type) -> PatQ) -> [(Name, Type)] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, Type
_) -> Name -> [PatQ] -> PatQ
conP 'ConstSize [Name -> PatQ
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)] -> BodyQ
guardedB [(Guard, Exp) -> Q (Guard, Exp)
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
_, []) =
            PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
szn) (Q Exp -> BodyQ
normalB [| 0 |]) []
        constSizeDec Name
szn (Name
_, [(Name, Type)]
fields) =
            PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
szn) BodyQ
body []
          where
            body :: BodyQ
body = Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$
                (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\Q Exp
l Q Exp
r -> [| $(l) + $(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
varE Name
sizeName) [(Name, Type)]
fields
        matchVarSize :: MatchQ
        matchVarSize :: MatchQ
matchVarSize = do
            PatQ -> BodyQ -> [Q Dec] -> MatchQ
match ([PatQ] -> PatQ
tupP (((Name, Type) -> PatQ) -> [(Name, Type)] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, Type
_) -> Name -> PatQ
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 -> BodyQ
normalB Q Exp
varSizeExpr)
                  []
        varSizeExpr :: ExpQ
        varSizeExpr :: Q Exp
varSizeExpr =
            [| VarSize $ \x -> tagSize + $(caseE [| x |] (map matchVar cons)) |]
        matchVar :: (Name, [(Name, Type)]) -> MatchQ
        matchVar :: (Name, [(Name, Type)]) -> MatchQ
matchVar (Name
cname, []) =
            PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
cname []) (Q Exp -> BodyQ
normalB [| 0 |]) []
        matchVar (Name
cname, [(Name, Type)]
fields) =
            PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
cname (((Name, Type) -> Name -> PatQ)
-> [(Name, Type)] -> [Name] -> [PatQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Name, Type)
_ Name
fn -> Name -> PatQ
varP Name
fn) [(Name, Type)]
fields [Name]
fNames))
                  BodyQ
body
                  []
          where
            body :: BodyQ
body = Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$
                (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\Q Exp
l Q Exp
r -> [| $(l) + $(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 $(varE sizeName) $(varE 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 (" ++ $(lift (show headTy)) ++ ")") |]
        [(Name, [(Name, Type)])
con] -> (Name, [(Name, Type)]) -> Q Exp
forall b. (Name, [(Name, b)]) -> Q Exp
peekCon (Name, [(Name, Type)])
con
        [(Name, [(Name, Type)])]
_ -> [StmtQ] -> Q Exp
doE
            [ PatQ -> Q Exp -> StmtQ
bindS (Name -> PatQ
varP Name
tagName) [| peek |]
            , Q Exp -> StmtQ
noBindS (Q Exp -> [MatchQ] -> Q Exp
caseE (Q Exp -> Q Type -> Q Exp
sigE (Name -> Q Exp
varE Name
tagName) (Name -> Q Type
conT Name
tagType))
                      (((Integer, (Name, [(Name, Type)])) -> MatchQ)
-> [(Integer, (Name, [(Name, Type)]))] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map (Integer, (Name, [(Name, Type)])) -> MatchQ
forall b. (Integer, (Name, [(Name, b)])) -> MatchQ
peekMatch ([Integer]
-> [(Name, [(Name, Type)])] -> [(Integer, (Name, [(Name, Type)]))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] [(Name, [(Name, Type)])]
cons) [MatchQ] -> [MatchQ] -> [MatchQ]
forall a. [a] -> [a] -> [a]
++ [MatchQ
peekErr]))
            ]
    peekMatch :: (Integer, (Name, [(Name, b)])) -> MatchQ
peekMatch (Integer
ix, (Name, [(Name, b)])
con) = PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Lit -> PatQ
litP (Integer -> Lit
IntegerL Integer
ix)) (Q Exp -> BodyQ
normalB ((Name, [(Name, b)]) -> Q Exp
forall b. (Name, [(Name, b)]) -> Q Exp
peekCon (Name, [(Name, b)])
con)) []
    peekErr :: MatchQ
peekErr = PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
wildP (Q Exp -> BodyQ
normalB
        [| peekException $ T.pack $ "Found invalid tag while peeking (" ++ $(lift (show headTy)) ++ ")" |]) []
    peekCon :: (Name, [(Name, b)]) -> Q Exp
peekCon (Name
cname, [(Name, b)]
fields) =
        case [(Name, b)]
fields of
            [] -> [| pure $(conE cname) |]
            [(Name, b)]
_ -> [StmtQ] -> Q Exp
doE ([StmtQ] -> Q Exp) -> [StmtQ] -> Q Exp
forall a b. (a -> b) -> a -> b
$
                ((Name, b) -> StmtQ) -> [(Name, b)] -> [StmtQ]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
fn, b
_) -> PatQ -> Q Exp -> StmtQ
bindS (Name -> PatQ
varP Name
fn) [| peek |]) [(Name, b)]
fields [StmtQ] -> [StmtQ] -> [StmtQ]
forall a. [a] -> [a] -> [a]
++
               [Q Exp -> StmtQ
noBindS (Q Exp -> StmtQ) -> Q Exp -> StmtQ
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE 'return) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
cname Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: ((Name, b) -> Q Exp) -> [(Name, b)] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
fn, b
_) -> Name -> Q Exp
varE Name
fn) [(Name, b)]
fields]
    pokeExpr :: Q Exp
pokeExpr = [PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
valName] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> [MatchQ] -> Q Exp
caseE (Name -> Q Exp
varE Name
valName) ([MatchQ] -> Q Exp) -> [MatchQ] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Int -> (Name, [(Name, Type)]) -> MatchQ)
-> [Int] -> [(Name, [(Name, Type)])] -> [MatchQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> (Name, [(Name, Type)]) -> MatchQ
pokeCon [Int
0..] [(Name, [(Name, Type)])]
cons
    pokeCon :: Int -> (Name, [(Name, Type)]) -> MatchQ
    pokeCon :: Int -> (Name, [(Name, Type)]) -> MatchQ
pokeCon Int
ix (Name
cname, [(Name, Type)]
fields) =
        PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
cname (((Name, Type) -> PatQ) -> [(Name, Type)] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
fn, Type
_) -> Name -> PatQ
varP Name
fn) [(Name, Type)]
fields)) BodyQ
body []
      where
        body :: BodyQ
body = Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$
            case [(Name, [(Name, Type)])]
cons of
                ((Name, [(Name, Type)])
_:(Name, [(Name, Type)])
_:[(Name, [(Name, Type)])]
_) -> [StmtQ] -> Q Exp
doE (Int -> StmtQ
forall t. Lift t => t -> StmtQ
pokeTag Int
ix StmtQ -> [StmtQ] -> [StmtQ]
forall a. a -> [a] -> [a]
: ((Name, Type) -> StmtQ) -> [(Name, Type)] -> [StmtQ]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Type) -> StmtQ
forall b. (Name, b) -> StmtQ
pokeField [(Name, Type)]
fields)
                [(Name, [(Name, Type)])]
_ -> [StmtQ] -> Q Exp
doE (((Name, Type) -> StmtQ) -> [(Name, Type)] -> [StmtQ]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Type) -> StmtQ
forall b. (Name, b) -> StmtQ
pokeField [(Name, Type)]
fields)
    pokeTag :: t -> StmtQ
pokeTag t
ix = Q Exp -> StmtQ
noBindS [| poke (ix :: $(conT tagType)) |]
    pokeField :: (Name, b) -> StmtQ
pokeField (Name
fn, b
_) = Q Exp -> StmtQ
noBindS [| poke $(varE 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 =
    Cxt -> Type -> Dec
deriveGenericInstance ((Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
storePred Cxt
tvs)
                          ((Type -> Type -> Type) -> Cxt -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Type -> Type -> Type
AppT (Int -> Type
TupleT Int
n Type -> Cxt -> Cxt
forall a. a -> [a] -> [a]
: Cxt
tvs))
  where
    tvs :: Cxt
tvs = Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
take Int
n ((Char -> Type) -> String -> Cxt
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 :: Cxt -> Type -> Dec
deriveGenericInstance Cxt
cs Type
ty = Cxt -> Type -> [Dec] -> Dec
plainInstanceD Cxt
cs (Type -> Type -> Type
AppT (Name -> Type
ConT ''Store) Type
ty) []

deriveGenericInstanceFromName :: Name -> Q Dec
deriveGenericInstanceFromName :: Name -> Q Dec
deriveGenericInstanceFromName Name
n = do
    Cxt
tvs <- (Name -> Type) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT ([Name] -> Cxt) -> (DataType -> [Name]) -> DataType -> Cxt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataType -> [Name]
dtTvs (DataType -> Cxt) -> Q DataType -> Q Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q DataType
reifyDataType Name
n
    Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Cxt -> Type -> Dec
deriveGenericInstance ((Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
storePred Cxt
tvs) (Type -> Cxt -> Type
appsT (Name -> Type
ConT Name
n) Cxt
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 Cxt TypeclassInstance
storables <- Map Cxt [TypeclassInstance] -> Map Cxt TypeclassInstance
forall a. Map Cxt [a] -> Map Cxt a
postprocess (Map Cxt [TypeclassInstance] -> Map Cxt TypeclassInstance)
-> ([TypeclassInstance] -> Map Cxt [TypeclassInstance])
-> [TypeclassInstance]
-> Map Cxt TypeclassInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeclassInstance] -> Map Cxt [TypeclassInstance]
instancesMap ([TypeclassInstance] -> Map Cxt TypeclassInstance)
-> Q [TypeclassInstance] -> Q (Map Cxt TypeclassInstance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q [TypeclassInstance]
getInstances ''Storable
    Map Cxt TypeclassInstance
stores <- Map Cxt [TypeclassInstance] -> Map Cxt TypeclassInstance
forall a. Map Cxt [a] -> Map Cxt a
postprocess (Map Cxt [TypeclassInstance] -> Map Cxt TypeclassInstance)
-> ([TypeclassInstance] -> Map Cxt [TypeclassInstance])
-> [TypeclassInstance]
-> Map Cxt TypeclassInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeclassInstance] -> Map Cxt [TypeclassInstance]
instancesMap ([TypeclassInstance] -> Map Cxt TypeclassInstance)
-> Q [TypeclassInstance] -> Q (Map Cxt TypeclassInstance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q [TypeclassInstance]
getInstances ''Store
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Map Cxt Dec -> [Dec]
forall k a. Map k a -> [a]
M.elems (Map Cxt Dec -> [Dec]) -> Map Cxt Dec -> [Dec]
forall a b. (a -> b) -> a -> b
$ ((TypeclassInstance -> Maybe Dec)
 -> Map Cxt TypeclassInstance -> Map Cxt Dec)
-> Map Cxt TypeclassInstance
-> (TypeclassInstance -> Maybe Dec)
-> Map Cxt Dec
forall a b c. (a -> b -> c) -> b -> a -> c
flip (TypeclassInstance -> Maybe Dec)
-> Map Cxt TypeclassInstance -> Map Cxt Dec
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
M.mapMaybe (Map Cxt TypeclassInstance
storables Map Cxt TypeclassInstance
-> Map Cxt TypeclassInstance -> Map Cxt TypeclassInstance
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`M.difference` Map Cxt TypeclassInstance
stores) ((TypeclassInstance -> Maybe Dec) -> Map Cxt Dec)
-> (TypeclassInstance -> Maybe Dec) -> Map Cxt Dec
forall a b. (a -> b) -> a -> b
$
        \(TypeclassInstance Cxt
cs Type
ty [Dec]
_) ->
        let argTy :: Type
argTy = Cxt -> Type
forall a. [a] -> a
head (Cxt -> Cxt
forall a. [a] -> [a]
tail (Type -> Cxt
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 (Cxt -> Bool
superclassHasStorable Cxt
cs)
            then Dec -> Maybe Dec
forall a. a -> Maybe a
Just (Dec -> Maybe Dec) -> Dec -> Maybe Dec
forall a b. (a -> b) -> a -> b
$ Cxt -> Type -> Exp -> Exp -> Exp -> Dec
makeStoreInstance Cxt
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 :: Cxt -> Bool
superclassHasStorable = Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (Maybe () -> Bool) -> (Cxt -> Maybe ()) -> Cxt -> 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 q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`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 Cxt TypeclassInstance
prims <- Map Cxt [TypeclassInstance] -> Map Cxt TypeclassInstance
forall a. Map Cxt [a] -> Map Cxt a
postprocess (Map Cxt [TypeclassInstance] -> Map Cxt TypeclassInstance)
-> ([TypeclassInstance] -> Map Cxt [TypeclassInstance])
-> [TypeclassInstance]
-> Map Cxt TypeclassInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeclassInstance] -> Map Cxt [TypeclassInstance]
instancesMap ([TypeclassInstance] -> Map Cxt TypeclassInstance)
-> Q [TypeclassInstance] -> Q (Map Cxt TypeclassInstance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q [TypeclassInstance]
getInstances ''PV.Prim
    Map Cxt TypeclassInstance
stores <- Map Cxt [TypeclassInstance] -> Map Cxt TypeclassInstance
forall a. Map Cxt [a] -> Map Cxt a
postprocess (Map Cxt [TypeclassInstance] -> Map Cxt TypeclassInstance)
-> ([TypeclassInstance] -> Map Cxt [TypeclassInstance])
-> [TypeclassInstance]
-> Map Cxt TypeclassInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeclassInstance] -> Map Cxt [TypeclassInstance]
instancesMap ([TypeclassInstance] -> Map Cxt TypeclassInstance)
-> Q [TypeclassInstance] -> Q (Map Cxt TypeclassInstance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q [TypeclassInstance]
getInstances ''Store
    let primInsts :: Map Cxt TypeclassInstance
primInsts =
            (Cxt -> Cxt)
-> Map Cxt TypeclassInstance -> Map Cxt TypeclassInstance
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys ((Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type -> Type
AppT (Name -> Type
ConT ''PV.Vector))) Map Cxt TypeclassInstance
prims
            Map Cxt TypeclassInstance
-> Map Cxt TypeclassInstance -> Map Cxt TypeclassInstance
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`M.difference`
            Map Cxt TypeclassInstance
stores
    [(Cxt, TypeclassInstance)]
-> ((Cxt, TypeclassInstance) -> Q Dec) -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map Cxt TypeclassInstance -> [(Cxt, TypeclassInstance)]
forall k a. Map k a -> [(k, a)]
M.toList Map Cxt TypeclassInstance
primInsts) (((Cxt, TypeclassInstance) -> Q Dec) -> Q [Dec])
-> ((Cxt, TypeclassInstance) -> Q Dec) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \(Cxt, TypeclassInstance)
primInst -> case (Cxt, TypeclassInstance)
primInst of
        ([Type
_], TypeclassInstance Cxt
cs Type
ty [Dec]
_) -> do
            let argTy :: Type
argTy = Cxt -> Type
forall a. [a] -> a
head (Cxt -> Cxt
forall a. [a] -> [a]
tail (Type -> Cxt
unAppsT Type
ty))
            Exp
sizeExpr <- [|
                VarSize $ \x ->
                    I# $(primSizeOfExpr (ConT ''Int)) +
                    I# $(primSizeOfExpr argTy) * PV.length x
                |]
            Exp
peekExpr <- [| do
                len <- peek
                let sz = I# $(primSizeOfExpr argTy)
                array <- peekToByteArray $(lift ("Primitive Vector (" ++ pprint argTy ++ ")"))
                                         (len * sz)
                return (PV.Vector 0 len array)
                |]
            Exp
pokeExpr <- [| \(PV.Vector offset len (ByteArray array)) -> do
                let sz = I# $(primSizeOfExpr argTy)
                poke len
                pokeFromByteArray array (offset * sz) (len * sz)
                |]
            Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Cxt -> Type -> Exp -> Exp -> Exp -> Dec
makeStoreInstance Cxt
cs (Type -> Type -> Type
AppT (Name -> Type
ConT ''PV.Vector) Type
argTy) Exp
sizeExpr Exp
peekExpr Exp
pokeExpr
        (Cxt, TypeclassInstance)
_ -> String -> Q Dec
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invariant violated in derivemanyStorePrimVector"


primSizeOfExpr :: Type -> ExpQ
primSizeOfExpr :: Type -> Q Exp
primSizeOfExpr Type
ty = [| $(varE 'sizeOf#) (error "sizeOf# evaluated its argument" :: $(return ty)) |]

deriveManyStoreUnboxVector :: Q [Dec]
deriveManyStoreUnboxVector :: Q [Dec]
deriveManyStoreUnboxVector = do
    [(Cxt, Type, [DataCon])]
unboxes <- Q [(Cxt, Type, [DataCon])]
getUnboxInfo
    Map Cxt TypeclassInstance
stores <- Map Cxt [TypeclassInstance] -> Map Cxt TypeclassInstance
forall a. Map Cxt [a] -> Map Cxt a
postprocess (Map Cxt [TypeclassInstance] -> Map Cxt TypeclassInstance)
-> ([TypeclassInstance] -> Map Cxt [TypeclassInstance])
-> [TypeclassInstance]
-> Map Cxt TypeclassInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeclassInstance] -> Map Cxt [TypeclassInstance]
instancesMap ([TypeclassInstance] -> Map Cxt TypeclassInstance)
-> Q [TypeclassInstance] -> Q (Map Cxt TypeclassInstance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q [TypeclassInstance]
getInstances ''Store
    Map Cxt TypeclassInstance
unboxInstances <- Map Cxt [TypeclassInstance] -> Map Cxt TypeclassInstance
forall a. Map Cxt [a] -> Map Cxt a
postprocess (Map Cxt [TypeclassInstance] -> Map Cxt TypeclassInstance)
-> ([TypeclassInstance] -> Map Cxt [TypeclassInstance])
-> [TypeclassInstance]
-> Map Cxt TypeclassInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeclassInstance] -> Map Cxt [TypeclassInstance]
instancesMap ([TypeclassInstance] -> Map Cxt TypeclassInstance)
-> Q [TypeclassInstance] -> Q (Map Cxt TypeclassInstance)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q [TypeclassInstance]
getInstances ''UV.Unbox
    let dataFamilyDecls :: Map Cxt (Cxt, [DataCon])
dataFamilyDecls =
            [(Cxt, (Cxt, [DataCon]))] -> Map Cxt (Cxt, [DataCon])
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (((Cxt, Type, [DataCon]) -> (Cxt, (Cxt, [DataCon])))
-> [(Cxt, Type, [DataCon])] -> [(Cxt, (Cxt, [DataCon]))]
forall a b. (a -> b) -> [a] -> [b]
map (\(Cxt
preds, Type
ty, [DataCon]
cons) -> ([Type -> Type -> Type
AppT (Name -> Type
ConT ''UV.Vector) Type
ty], (Cxt
preds, [DataCon]
cons))) [(Cxt, Type, [DataCon])]
unboxes)
            Map Cxt (Cxt, [DataCon])
-> Map Cxt TypeclassInstance -> Map Cxt (Cxt, [DataCon])
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`M.difference`
            Map Cxt 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.
    [(Cxt, (Cxt, [DataCon]))]
-> ((Cxt, (Cxt, [DataCon])) -> Q Dec) -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map Cxt (Cxt, [DataCon]) -> [(Cxt, (Cxt, [DataCon]))]
forall k a. Map k a -> [(k, a)]
M.toList Map Cxt (Cxt, [DataCon])
dataFamilyDecls) (((Cxt, (Cxt, [DataCon])) -> Q Dec) -> Q [Dec])
-> ((Cxt, (Cxt, [DataCon])) -> Q Dec) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \case
        ([Type
ty], (Cxt
_, [DataCon]
cons)) -> do
            let headTy :: Type
headTy = Type -> Type
getTyHead (Type -> Cxt
unAppsT Type
ty Cxt -> Int -> Type
forall a. [a] -> Int -> a
!! Int
1)
            (Cxt
preds, Type
ty') <- case Cxt -> Map Cxt TypeclassInstance -> Maybe TypeclassInstance
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Type
headTy] Map Cxt 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
                (Cxt, Type) -> Q (Cxt, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Type
ty)
              Just (TypeclassInstance Cxt
cs (AppT Type
_ Type
ty') [Dec]
_) ->
                (Cxt, Type) -> Q (Cxt, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
substituteConstraint Cxt
cs, Type -> Type -> Type
AppT (Name -> Type
ConT ''UV.Vector) Type
ty')
              Just TypeclassInstance
_ -> String -> Q (Cxt, Type)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Impossible case"
            Cxt -> Type -> [DataCon] -> Q Dec
deriveStore Cxt
preds Type
ty' [DataCon]
cons
        (Cxt, (Cxt, [DataCon]))
_ -> String -> Q Dec
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 [(Cxt, Type, [DataCon])]
getUnboxInfo = do
    FamilyI Dec
_ [Dec]
insts <- Name -> Q Info
reify ''UV.Vector
    [(Cxt, Type, [DataCon])] -> Q [(Cxt, Type, [DataCon])]
forall (m :: * -> *) a. Monad m => a -> m a
return (((Cxt, Type, [DataCon]) -> (Cxt, Type, [DataCon]))
-> [(Cxt, Type, [DataCon])] -> [(Cxt, 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)) ([(Cxt, Type, [DataCon])] -> [(Cxt, Type, [DataCon])])
-> [(Cxt, Type, [DataCon])] -> [(Cxt, Type, [DataCon])]
forall a b. (a -> b) -> a -> b
$ (Dec -> Maybe (Cxt, Type, [DataCon]))
-> [Dec] -> [(Cxt, Type, [DataCon])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Dec -> Maybe (Cxt, Type, [DataCon])
go [Dec]
insts)
  where
#if MIN_VERSION_template_haskell(2,15,0)
    go :: Dec -> Maybe (Cxt, Type, [DataCon])
go (NewtypeInstD Cxt
preds Maybe [TyVarBndr]
_ Type
lhs Maybe Type
_ Con
con [DerivClause]
_)
      | [Type
_, Type
ty] <- Type -> Cxt
unAppsT Type
lhs
      = Cxt -> Type -> [Con] -> Maybe (Cxt, Type, [DataCon])
toResult Cxt
preds Type
ty [Con
con]
    go (DataInstD Cxt
preds Maybe [TyVarBndr]
_ Type
lhs Maybe Type
_ [Con]
cons [DerivClause]
_)
      | [Type
_, Type
ty] <- Type -> Cxt
unAppsT Type
lhs
      = Cxt -> Type -> [Con] -> Maybe (Cxt, Type, [DataCon])
toResult Cxt
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 (Cxt, 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 :: Cxt -> Type -> [Con] -> Maybe (Cxt, Type, [DataCon])
toResult Cxt
_ Type
_ [NormalC Name
conName [BangType]
_]
      | Name -> String
nameBase Name
conName String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
skippedUnboxConstructors = Maybe (Cxt, Type, [DataCon])
forall a. Maybe a
Nothing
    toResult Cxt
preds Type
ty [Con]
cons
      = (Cxt, Type, [DataCon]) -> Maybe (Cxt, Type, [DataCon])
forall a. a -> Maybe a
Just (Cxt
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"]

------------------------------------------------------------------------
-- 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 :: Map Cxt [a] -> Map Cxt a
postprocess =
    (Cxt -> [a] -> Maybe a) -> Map Cxt [a] -> Map Cxt a
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
M.mapMaybeWithKey ((Cxt -> [a] -> Maybe a) -> Map Cxt [a] -> Map Cxt a)
-> (Cxt -> [a] -> Maybe a) -> Map Cxt [a] -> Map Cxt a
forall a b. (a -> b) -> a -> b
$ \Cxt
tys [a]
xs ->
        case (Cxt
tys, [a]
xs) of
            ([Type
_ty], [a
x]) -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
            (Cxt, [a])
_ -> Maybe a
forall a. Maybe a
Nothing

makeStoreInstance :: Cxt -> Type -> Exp -> Exp -> Exp -> Dec
makeStoreInstance :: Cxt -> Type -> Exp -> Exp -> Exp -> Dec
makeStoreInstance Cxt
cs Type
ty Exp
sizeExpr Exp
peekExpr Exp
pokeExpr =
    Cxt -> Type -> [Dec] -> Dec
plainInstanceD
        Cxt
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 [Cxt]
getAllInstanceTypes Name
n =
    (TypeclassInstance -> Cxt) -> [TypeclassInstance] -> [Cxt]
forall a b. (a -> b) -> [a] -> [b]
map (\(TypeclassInstance Cxt
_ Type
ty [Dec]
_) -> Int -> Cxt -> Cxt
forall a. Int -> [a] -> [a]
drop Int
1 (Type -> Cxt
unAppsT Type
ty)) ([TypeclassInstance] -> [Cxt]) -> Q [TypeclassInstance] -> Q [Cxt]
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 Cxt
getAllInstanceTypes1 Name
n =
    ([Cxt] -> Cxt) -> Q [Cxt] -> Q Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Cxt -> Type) -> [Cxt] -> Cxt
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) -> (Cxt -> Maybe Type) -> Cxt -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cxt -> Maybe Type
forall a. [a] -> Maybe a
headMay))
         (Name -> Q [Cxt]
getAllInstanceTypes Name
n)

isMonoType :: Type -> Bool
isMonoType :: Type -> Bool
isMonoType = Cxt -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Cxt -> Bool) -> (Type -> Cxt) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Bool) -> GenericQ Cxt
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 Cxt [TypeclassInstance]
instancesMap =
    ([TypeclassInstance] -> [TypeclassInstance] -> [TypeclassInstance])
-> [(Cxt, [TypeclassInstance])] -> Map Cxt [TypeclassInstance]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [TypeclassInstance] -> [TypeclassInstance] -> [TypeclassInstance]
forall a. [a] -> [a] -> [a]
(++) ([(Cxt, [TypeclassInstance])] -> Map Cxt [TypeclassInstance])
-> ([TypeclassInstance] -> [(Cxt, [TypeclassInstance])])
-> [TypeclassInstance]
-> Map Cxt [TypeclassInstance]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (TypeclassInstance -> (Cxt, [TypeclassInstance]))
-> [TypeclassInstance] -> [(Cxt, [TypeclassInstance])]
forall a b. (a -> b) -> [a] -> [b]
map (\TypeclassInstance
ti -> ((Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
getTyHead (TypeclassInstance -> Cxt
instanceArgTypes TypeclassInstance
ti), [TypeclassInstance
ti]))

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

getTyHead :: Type -> Type
getTyHead :: Type -> Type
getTyHead (SigT Type
x Type
_) = Type -> Type
getTyHead Type
x
getTyHead (ForallT [TyVarBndr]
_ Cxt
_ 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