    {-# OPTIONS_GHC -fno-warn-orphans #-}
    {-# LANGUAGE DeriveDataTypeable #-}
    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE MagicHash #-}
    {-# LANGUAGE RecordWildCards #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# LANGUAGE TupleSections #-}
    {-# LANGUAGE ViewPatterns #-}

    -- | Implementation of a 'Storable' deriver for data types. This works for
    -- any non-recursive datatype which has 'Storable' fields.
    --
    -- Most users won't need to import this module directly. Instead, use
    -- 'derive' / 'Deriving' to create 'Storable' instances.
    module TH.Derive.Storable
        ( makeStorableInst
        ) where

    import           Control.Applicative
    import           Control.Monad
    import           Data.List (find)
    import           Data.Maybe (fromMaybe)
    import           Data.Word
    import           Foreign.Ptr
    import           Foreign.Storable
    import           Language.Haskell.TH
    import           Language.Haskell.TH.Syntax
    import           Prelude
    import           TH.Derive.Internal
    import           TH.ReifySimple
    import           TH.Utilities

    instance Deriver (Storable a) where
        runDeriver :: Proxy (Storable a) -> Cxt -> Type -> Q [Dec]
    runDeriver Proxy (Storable a)
    _ = Cxt -> Type -> Q [Dec]
    makeStorableInst

    -- | Implementation used for 'runDeriver'.
    makeStorableInst :: Cxt -> Type -> Q [Dec]
    makeStorableInst :: Cxt -> Type -> Q [Dec]
    makeStorableInst Cxt
    preds Type
    ty = do
        argTy <- Name -> Type -> Q Type
    expectTyCon1 ''Storable Type
    ty
        dt <- reifyDataTypeSubstituted argTy
        makeStorableImpl preds ty (dtCons dt)

    -- TODO: recursion check? At least document that this could in some
    -- cases work, but produce a bogus instance.

    makeStorableImpl :: Cxt -> Type -> [DataCon] -> Q [Dec]
    makeStorableImpl :: Cxt -> Type -> [DataCon] -> Q [Dec]
    makeStorableImpl Cxt
    preds Type
    headTy [DataCon]
    cons = do
        -- Since this instance doesn't pay attention to alignment, we
        -- just say alignment doesn't matter.
        alignmentMethod <- [| 1 |]
        sizeOfMethod <- sizeExpr
        peekMethod <- peekExpr
        pokeMethod <- pokeExpr
        let methods =
                [ Name -> [Clause] -> Dec
    FunD (String -> Name
    mkName String
    "alignment") [[Pat] -> Body -> [Dec] -> Clause
    Clause [Pat
    WildP] (Exp -> Body
    NormalB Exp
    alignmentMethod) []]
                , Name -> [Clause] -> Dec
    FunD (String -> Name
    mkName String
    "sizeOf") [[Pat] -> Body -> [Dec] -> Clause
    Clause [] (Exp -> Body
    NormalB Exp
    sizeOfMethod) []]
                , Name -> [Clause] -> Dec
    FunD (String -> Name
    mkName String
    "peek") [[Pat] -> Body -> [Dec] -> Clause
    Clause [Name -> Pat
    VarP Name
    ptrName] (Exp -> Body
    NormalB Exp
    peekMethod) []]
                , Name -> [Clause] -> Dec
    FunD (String -> Name
    mkName String
    "poke") [[Pat] -> Body -> [Dec] -> Clause
    Clause [Name -> Pat
    VarP Name
    ptrName, Name -> Pat
    VarP Name
    valName] (Exp -> Body
    NormalB Exp
    pokeMethod) []]
                ]
        return [plainInstanceD preds headTy methods]
      where
        -- NOTE: Much of the code here resembles code in store for deriving
        -- Store instances. Changes here may be relevant there as well.
        (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
    >= [DataCon] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [DataCon]
    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)
            ]
        valName :: Name
    valName = String -> Name
    mkName String
    "val"
        tagName :: Name
    tagName = String -> Name
    mkName String
    "tag"
        ptrName :: Name
    ptrName = String -> Name
    mkName String
    "ptr"
        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)
        ptrExpr :: Q Exp
    ptrExpr = Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    ptrName
        -- [[Int]] expression, where the inner lists are the sizes of the
        -- fields. Each member of the outer list corresponds to a different
        -- constructor.
        sizeExpr :: Q Exp
    sizeExpr = Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    appE (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE 'const) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    appE (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE 'maximum) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $
            [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    listE [ Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    appE (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE 'sum) ([Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    listE [Type -> Q Exp
    forall {m :: * -> *}. Quote m => Type -> m Exp
    sizeOfExpr Type
    ty | (Maybe Name
    _, Type
    ty) <- [(Maybe Name, Type)]
    fields])
                  | (DataCon Name
    _ [Name]
    _ Cxt
    _ [(Maybe Name, Type)]
    fields) <- [DataCon]
    cons
                  ]
        -- Choose a tag size large enough for this constructor count.
        -- Expression used for the definition of peek.
        peekExpr :: Q Exp
    peekExpr = case [DataCon]
    cons of
            [] -> [| error ("Attempting to peek type with no constructors (" ++ $(String -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => String -> m Exp
    lift (Type -> String
    forall a. Ppr a => a -> String
    pprint Type
    headTy)) ++ ")") |]
            [DataCon
    con] -> DataCon -> Q Exp
    peekCon DataCon
    con
            [DataCon]
    _ -> [Q Stmt] -> Q Exp
    forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
    doE
                [ Q Pat -> Q Exp -> Q Stmt
    forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
    bindS (Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP Name
    tagName) [| peek (castPtr $(Q Exp
    ptrExpr)) |]
                , Q Exp -> Q Stmt
    forall (m :: * -> *). Quote m => m Exp -> m Stmt
    noBindS (Q Exp -> [Q Match] -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
    caseE (Q Exp -> Q Type -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
    sigE (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    tagName) (Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    conT Name
    tagType))
                                 (((Integer, DataCon) -> Q Match)
    -> [(Integer, DataCon)] -> [Q Match]
    forall a b. (a -> b) -> [a] -> [b]
    map (Integer, DataCon) -> Q Match
    peekMatch ([Integer] -> [DataCon] -> [(Integer, DataCon)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Integer
    0..] [DataCon]
    cons) [Q Match] -> [Q Match] -> [Q Match]
    forall a. [a] -> [a] -> [a]
    ++ [Q Match
    peekErr]))
                ]
        peekMatch :: (Integer, DataCon) -> Q Match
    peekMatch (Integer
    ix, DataCon
    con) = Q Pat -> Q Body -> [Q Dec] -> Q Match
    forall (m :: * -> *).
    Quote m =>
    m Pat -> m Body -> [m Dec] -> m Match
    match (Lit -> Q Pat
    forall (m :: * -> *). Quote m => Lit -> m Pat
    litP (Integer -> Lit
    IntegerL Integer
    ix)) (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB (DataCon -> Q Exp
    peekCon DataCon
    con)) []
        peekErr :: Q Match
    peekErr = Q Pat -> Q Body -> [Q Dec] -> Q Match
    forall (m :: * -> *).
    Quote m =>
    m Pat -> m Body -> [m Dec] -> m Match
    match Q Pat
    forall (m :: * -> *). Quote m => m Pat
    wildP (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB [| error ("Found invalid tag while peeking (" ++ $(String -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => String -> m Exp
    lift (Type -> String
    forall a. Ppr a => a -> String
    pprint Type
    headTy)) ++ ")") |]) []
        peekCon :: DataCon -> Q Exp
    peekCon (DataCon Name
    cname [Name]
    _ Cxt
    _ [(Maybe Name, Type)]
    fields) =
            [Q Dec] -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => [m Dec] -> m Exp -> m Exp
    letE ([(Maybe Name, Type)] -> [Q Dec]
    forall {m :: * -> *} {a}. Quote m => [(a, Type)] -> [m Dec]
    offsetDecls [(Maybe Name, Type)]
    fields) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $
            case [(Maybe Name, Type)]
    fields of
                [] -> [| pure $(Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    conE Name
    cname) |]
                ((Maybe Name, Type)
    _:[(Maybe Name, Type)]
    fields') ->
                    (Q Exp -> (Int, (Maybe Name, Type)) -> Q Exp)
    -> Q Exp -> [(Int, (Maybe Name, Type))] -> Q Exp
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl (\Q Exp
    acc (Int
    ix, (Maybe Name, Type)
    _) -> [| $(Q Exp
    acc) <*> $(Int -> Q Exp
    peekOffset Int
    ix) |] )
                          [| $(Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    conE Name
    cname) <$> $(Int -> Q Exp
    peekOffset Int
    0) |]
                          ([Int] -> [(Maybe Name, Type)] -> [(Int, (Maybe Name, Type))]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Int
    1..] [(Maybe Name, Type)]
    fields')
        peekOffset :: Int -> Q Exp
    peekOffset Int
    ix = [| peek (castPtr (plusPtr $(Q Exp
    ptrExpr) $(Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE (Int -> Name
    offset Int
    ix)))) |]
        -- Expression used for the definition of poke.
        pokeExpr :: Q Exp
    pokeExpr = Q Exp -> [Q Match] -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
    caseE (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    valName) (((Int, DataCon) -> Q Match) -> [(Int, DataCon)] -> [Q Match]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int, DataCon) -> Q Match
    pokeMatch ([Int] -> [DataCon] -> [(Int, DataCon)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Int
    0..] [DataCon]
    cons))
        pokeMatch :: (Int, DataCon) -> MatchQ
        pokeMatch :: (Int, DataCon) -> Q Match
    pokeMatch (Int
    ixcon, DataCon Name
    cname [Name]
    _ Cxt
    _ [(Maybe Name, Type)]
    fields) =
            Q Pat -> Q Body -> [Q Dec] -> Q Match
    forall (m :: * -> *).
    Quote m =>
    m Pat -> m Body -> [m Dec] -> m Match
    match (Name -> [Q Pat] -> Q Pat
    forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
    conP Name
    cname ((Name -> Q Pat) -> [Name] -> [Q Pat]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP ((Int -> Name) -> [Int] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map Int -> Name
    forall {a}. Show a => a -> Name
    fName [Int]
    ixs)))
                  (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB (case [Q Stmt]
    tagPokes [Q Stmt] -> [Q Stmt] -> [Q Stmt]
    forall a. [a] -> [a] -> [a]
    ++ [Q Stmt]
    offsetLet [Q Stmt] -> [Q Stmt] -> [Q Stmt]
    forall a. [a] -> [a] -> [a]
    ++ [Q Stmt]
    fieldPokes of
                               [] -> [|return ()|]
                               [Q Stmt]
    stmts -> [Q Stmt] -> Q Exp
    forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
    doE [Q Stmt]
    stmts))
                  []
          where
            tagPokes :: [Q Stmt]
    tagPokes = case [DataCon]
    cons of
                (DataCon
    _:DataCon
    _:[DataCon]
    _) -> [Q Exp -> Q Stmt
    forall (m :: * -> *). Quote m => m Exp -> m Stmt
    noBindS [| poke (castPtr $(Q Exp
    ptrExpr)) (ixcon :: $(Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    conT Name
    tagType)) |]]
                [DataCon]
    _ -> []
            offsetLet :: [Q Stmt]
    offsetLet
                | [Int] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Int]
    ixs = []
                | Bool
    otherwise = [[Q Dec] -> Q Stmt
    forall (m :: * -> *). Quote m => [m Dec] -> m Stmt
    letS ([(Maybe Name, Type)] -> [Q Dec]
    forall {m :: * -> *} {a}. Quote m => [(a, Type)] -> [m Dec]
    offsetDecls [(Maybe Name, Type)]
    fields)]
            fieldPokes :: [Q Stmt]
    fieldPokes = (Int -> Q Stmt) -> [Int] -> [Q Stmt]
    forall a b. (a -> b) -> [a] -> [b]
    map (Q Exp -> Q Stmt
    forall (m :: * -> *). Quote m => m Exp -> m Stmt
    noBindS (Q Exp -> Q Stmt) -> (Int -> Q Exp) -> Int -> Q Stmt
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> Q Exp
    pokeField) [Int]
    ixs
            ixs :: [Int]
    ixs = ((Int, (Maybe Name, Type)) -> Int)
    -> [(Int, (Maybe Name, Type))] -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int, (Maybe Name, Type)) -> Int
    forall a b. (a, b) -> a
    fst ([Int] -> [(Maybe Name, Type)] -> [(Int, (Maybe Name, Type))]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Int
    0..] [(Maybe Name, Type)]
    fields)
        pokeField :: Int -> Q Exp
    pokeField Int
    ix = [| poke (castPtr (plusPtr $(Q Exp
    ptrExpr)
                                                 $(Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE (Int -> Name
    offset Int
    ix))))
                               $(Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE (Int -> Name
    forall {a}. Show a => a -> Name
    fName Int
    ix)) |]
        -- Generate declarations which compute the field offsets.
        offsetDecls :: [(a, Type)] -> [m Dec]
    offsetDecls [(a, Type)]
    fields =
            -- Skip the last one, to avoid unused variable warnings.
            [m Dec] -> [m Dec]
    forall a. HasCallStack => [a] -> [a]
    init ([m Dec] -> [m Dec]) -> [m Dec] -> [m Dec]
    forall a b. (a -> b) -> a -> b
    $
            ((Int, m Exp) -> m Dec) -> [(Int, m Exp)] -> [m Dec]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Int
    ix, m Exp
    expr) -> m Pat -> m Body -> [m Dec] -> m Dec
    forall (m :: * -> *).
    Quote m =>
    m Pat -> m Body -> [m Dec] -> m Dec
    valD (Name -> m Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP (Int -> Name
    offset Int
    ix)) (m Exp -> m Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB m Exp
    expr) []) ([(Int, m Exp)] -> [m Dec]) -> [(Int, m Exp)] -> [m Dec]
    forall a b. (a -> b) -> a -> b
    $
            -- Initial offset is the tag size.
            ((Int
    0, [| tagSize |]) (Int, m Exp) -> [(Int, m Exp)] -> [(Int, m Exp)]
    forall a. a -> [a] -> [a]
    :) ([(Int, m Exp)] -> [(Int, m Exp)])
    -> [(Int, m Exp)] -> [(Int, m Exp)]
    forall a b. (a -> b) -> a -> b
    $
            ((Int, (a, Type)) -> (Int, m Exp))
    -> [(Int, (a, Type))] -> [(Int, m Exp)]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Int
    ix, (a
    _, Type
    ty)) -> (Int
    ix, Int -> Type -> m Exp
    forall {m :: * -> *}. Quote m => Int -> Type -> m Exp
    offsetExpr Int
    ix Type
    ty)) ([(Int, (a, Type))] -> [(Int, m Exp)])
    -> [(Int, (a, Type))] -> [(Int, m Exp)]
    forall a b. (a -> b) -> a -> b
    $
            [Int] -> [(a, Type)] -> [(Int, (a, Type))]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Int
    1..] [(a, Type)]
    fields
          where
            offsetExpr :: Int -> Type -> m Exp
    offsetExpr Int
    ix Type
    ty = [| $(Type -> m Exp
    forall {m :: * -> *}. Quote m => Type -> m Exp
    sizeOfExpr Type
    ty) + $(Name -> m Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE (Int -> Name
    offset (Int
    ix Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1))) |]
        sizeOfExpr :: Type -> m Exp
    sizeOfExpr Type
    ty = [| $(Name -> m Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE 'sizeOf) (error "sizeOf evaluated its argument" :: $(Type -> m Type
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    ty)) |]
        offset :: Int -> Name
    offset Int
    ix = String -> Name
    mkName (String
    "offset" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show (Int
    ix :: Int))