    {-# 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
        , 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)
    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 _ preds :: Cxt
    preds ty :: 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
    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 preds :: Cxt
    preds headTy :: Type
    headTy cons0 :: [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 ("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]
    ++ "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
              | (_, ty :: Type
    ty) <- DataCon -> [(Maybe Name, Type)]
    dcFields DataCon
    dc
              ]
            )
          | Int
    ixc <- [Int]
    ints
          | DataCon
    dc <- [DataCon]
    cons0
          ]
        -- NOTE: tag code duplicated in th-storable.
        (tagType :: Name
    tagType, _, tagSize :: 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 "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 (\(_, maxN :: Int
    maxN, _) -> 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 =
            [ ('(), 1, 0)
            , (''Word8, Word8 -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word8
    forall a. Bounded a => a
    maxBound :: Word8), 1)
            , (''Word16, Word16 -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word16
    forall a. Bounded a => a
    maxBound :: Word16), 2)
            , (''Word32, Word32 -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word32
    forall a. Bounded a => a
    maxBound :: Word32), 4)
            , (''Word64, Word64 -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word64
    forall a. Bounded a => a
    maxBound :: Word64), 8)
            ]
        fName :: a -> Name
    fName ix :: a
    ix = String -> Name
    mkName ("f" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ a -> String
    forall a. Show a => a -> String
    show a
    ix)
        ints :: [Int]
    ints = [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 (\_ -> String -> Name
    mkName (String -> Name) -> (Int -> String) -> Int -> Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ("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 "tag"
        valName :: Name
    valName = String -> Name
    mkName "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
    <= 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]
                         [c :: (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]
                         _ -> [MatchQ
    matchConstSize, MatchQ
    matchVarSize])
            | Bool
    otherwise = Q Exp
    varSizeExpr
          where
            sizeAtType :: (Name, Type) -> ExpQ
            sizeAtType :: (Name, Type) -> Q Exp
    sizeAtType (_, ty :: Type
    ty) = [| size :: Size $(return ty) |]
            matchConstSize :: MatchQ
            matchConstSize :: MatchQ
    matchConstSize = do
                let sz0 :: Exp
    sz0 = Name -> Exp
    VarE (String -> Name
    mkName "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 "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
                        (_ : tailSizeNames :: [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 (\l :: Q Exp
    l r :: 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 (\szn :: 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 (\(n :: Name
    n, _) -> 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 szn :: Name
    szn (_, []) =
                PatQ -> BodyQ -> [Q Dec] -> Q Dec
    valD (Name -> PatQ
    varP Name
    szn) (Q Exp -> BodyQ
    normalB [| 0 |]) []
            constSizeDec szn :: Name
    szn (_, fields :: [(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 (\l :: Q Exp
    l r :: 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 (\(sizeName :: Name
    sizeName, _) -> 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 (\(n :: Name
    n, _) -> 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 (cname :: Name
    cname, []) =
                PatQ -> BodyQ -> [Q Dec] -> MatchQ
    match (Name -> [PatQ] -> PatQ
    conP Name
    cname []) (Q Exp -> BodyQ
    normalB [| 0 |]) []
            matchVar (cname :: Name
    cname, fields :: [(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 (\_ fn :: 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 (\l :: Q Exp
    l r :: 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 (\(sizeName :: Name
    sizeName, _) fn :: 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)) ++ ")") |]
            [con :: (Name, [(Name, Type)])
    con] -> (Name, [(Name, Type)]) -> Q Exp
    forall b. (Name, [(Name, b)]) -> Q Exp
    peekCon (Name, [(Name, Type)])
    con
            _ -> [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 [0..] [(Name, [(Name, Type)])]
    cons) [MatchQ] -> [MatchQ] -> [MatchQ]
    forall a. [a] -> [a] -> [a]
    ++ [MatchQ
    peekErr]))
                ]
        peekMatch :: (Integer, (Name, [(Name, b)])) -> MatchQ
    peekMatch (ix :: Integer
    ix, con :: (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 (cname :: Name
    cname, fields :: [(Name, b)]
    fields) =
            case [(Name, b)]
    fields of
                [] -> [| pure $(conE cname) |]
                _ -> [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 (\(fn :: Name
    fn, _) -> 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 (\(fn :: Name
    fn, _) -> 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 [0..] [(Name, [(Name, Type)])]
    cons
        pokeCon :: Int -> (Name, [(Name, Type)]) -> MatchQ
        pokeCon :: Int -> (Name, [(Name, Type)]) -> MatchQ
    pokeCon ix :: Int
    ix (cname :: Name
    cname, fields :: [(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 (\(fn :: Name
    fn, _) -> 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
                    (_:_:_) -> [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)
                    _ -> [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 ix :: t
    ix = Q Exp -> StmtQ
    noBindS [| poke (ix :: $(conT tagType)) |]
        pokeField :: (Name, b) -> StmtQ
    pokeField (fn :: Name
    fn, _) = Q Exp -> StmtQ
    noBindS [| poke $(varE fn) |]

    -- FIXME: make this work even when there are too many fields

    -- FIXME: make the ConstSize stuff explicit in the API. Have an option
    -- that always errors at runtime if it isn't ConstSize?

    -- TODO: It would be really awesome, though a bit tricky, to know at
    -- compile time if we have a static size.

    -- TODO: make sure that this tends to optimize even with tons of fields.
    -- It should also optimize when some fields are known to be , but others
    -- are unknown (determined by polymorphic var)

    {- 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 n :: 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]
    :[])) ['a'..'z'])

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

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

    -- TODO: Generate inline pragmas? Probably not necessary

    deriveManyStoreFromStorable :: (Type -> Bool) -> Q [Dec]
    deriveManyStoreFromStorable :: (Type -> Bool) -> Q [Dec]
    deriveManyStoreFromStorable p :: 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 cs :: Cxt
    cs ty :: Type
    ty _) ->
            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 n :: Name
    n) | Name
    n Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''Storable = () -> Maybe ()
    forall a. a -> Maybe a
    Just ()
        justStorable _ = Maybe ()
    forall a. Maybe a
    Nothing
        ignoreStrings :: String -> Maybe ()
        ignoreStrings :: String -> Maybe ()
    ignoreStrings _ = 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
    $ \primInst :: (Cxt, TypeclassInstance)
    primInst -> case (Cxt, TypeclassInstance)
    primInst of
            ([_], TypeclassInstance cs :: Cxt
    cs ty :: Type
    ty _) -> 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
            _ -> String -> Q Dec
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail "Invariant violated in derivemanyStorePrimVector"

    primSizeOfExpr :: Type -> ExpQ
    primSizeOfExpr :: Type -> Q Exp
    primSizeOfExpr ty :: 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 (\(preds :: Cxt
    preds, ty :: Type
    ty, cons :: [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 n :: Name
    n) arg :: 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 x :: 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
            ([ty :: Type
    ty], (_, cons :: [DataCon]
    cons)) -> do
                let headTy :: Type
    headTy = Type -> Type
    getTyHead (Type -> Cxt
    unAppsT Type
    ty Cxt -> Int -> Type
    forall a. [a] -> Int -> a
    !! 1)
                (preds :: Cxt
    preds, ty' :: 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
                  Nothing -> do
                    String -> Q ()
    reportWarning (String -> Q ()) -> String -> Q ()
    forall a b. (a -> b) -> a -> b
    $ "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 cs :: Cxt
    cs (AppT _ ty' :: Type
    ty') _) ->
                    (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 _ -> String -> Q (Cxt, Type)
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail "Impossible case"
                Cxt -> Type -> [DataCon] -> Q Dec
    deriveStore Cxt
    preds Type
    ty' [DataCon]
    cons
            _ -> String -> Q Dec
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail "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 _ insts :: [Dec]
    insts <- Name -> Q Info
    reify ''UV.Vector
        [(Cxt, Type, [DataCon])] -> Q [(Cxt, Type, [DataCon])]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((Dec -> (Cxt, Type, [DataCon]))
    -> [Dec] -> [(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]))
    -> (Dec -> (Cxt, Type, [DataCon])) -> Dec -> (Cxt, Type, [DataCon])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Dec -> (Cxt, Type, [DataCon])
    go) [Dec]
    insts)
      where
    #if MIN_VERSION_template_haskell(2,15,0)
        go :: Dec -> (Cxt, Type, [DataCon])
    go (NewtypeInstD preds :: Cxt
    preds _ lhs :: Type
    lhs _ con :: Con
    con _)
          | [_, ty :: Type
    ty] <- Type -> Cxt
    unAppsT Type
    lhs
          = (Cxt
    preds, Type
    ty, Con -> [DataCon]
    conToDataCons Con
    con)
        go (DataInstD preds :: Cxt
    preds _ lhs :: Type
    lhs _ cons :: [Con]
    cons _)
          | [_, ty :: Type
    ty] <- Type -> Cxt
    unAppsT Type
    lhs
          = (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)
    #elif MIN_VERSION_template_haskell(2,11,0)
        go (NewtypeInstD preds _ [ty] _ con _) = (preds, ty, conToDataCons con)
        go (DataInstD preds _ [ty] _ cons _) = (preds, ty, concatMap conToDataCons cons)
    #else
        go (NewtypeInstD preds _ [ty] con _) = (preds, ty, conToDataCons con)
        go (DataInstD preds _ [ty] cons _) = (preds, ty, concatMap conToDataCons cons)
    #endif
        go x :: Dec
    x = String -> (Cxt, Type, [DataCon])
    forall a. HasCallStack => String -> a
    error ("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)
        dequalVarT :: Type -> Type
        dequalVarT :: Type -> Type
    dequalVarT (VarT n :: Name
    n) = Name -> Type
    VarT (Name -> Name
    dequalify Name
    n)
        dequalVarT ty :: Type
    ty = Type
    ty

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

    makeStoreInstance :: Cxt -> Type -> Exp -> Exp -> Exp -> Dec
    makeStoreInstance :: Cxt -> Type -> Exp -> Exp -> Exp -> Dec
    makeStoreInstance cs :: Cxt
    cs ty :: Type
    ty sizeExpr :: Exp
    sizeExpr peekExpr :: Exp
    peekExpr pokeExpr :: 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 n :: Name
    n =
        (TypeclassInstance -> Cxt) -> [TypeclassInstance] -> [Cxt]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(TypeclassInstance _ ty :: Type
    ty _) -> Int -> Cxt -> Cxt
    forall a. Int -> [a] -> [a]
    drop 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 n :: 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 "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 _ = 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 (\ti :: 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 _ ty :: Type
    ty _) = Int -> Cxt -> Cxt
    forall a. Int -> [a] -> [a]
    drop 1 (Type -> Cxt
    unAppsT Type
    ty)

    getTyHead :: Type -> Type
    getTyHead :: Type -> Type
    getTyHead (SigT x :: Type
    x _) = Type -> Type
    getTyHead Type
    x
    getTyHead (ForallT _ _ x :: Type
    x) = Type -> Type
    getTyHead Type
    x
    getTyHead (AppT l :: Type
    l _) = Type -> Type
    getTyHead Type
    l
    getTyHead x :: Type
    x = Type
    x

    storePred :: Type -> Pred
    storePred :: Type -> Type
    storePred ty :: 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