    {-# LANGUAGE CPP #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE RecordWildCards #-}
    {-# LANGUAGE TemplateHaskellQuotes #-}
    {-# LANGUAGE Trustworthy #-}
    {-# LANGUAGE TypeFamilies #-}
    {-# LANGUAGE ViewPatterns #-}
    {-# OPTIONS -Wall #-}

    {-|
    Module:      Data.Vector.Unboxed.Deriving
    Copyright:   © 2012−2015 Liyang HU
    License:     BSD3
    Maintainer:  vector-th-unbox@liyang.hu
    Stability:   experimental
    Portability: non-portable
    -}

    module Data.Vector.Unboxed.Deriving
        ( -- $usage
          derivingUnbox
        ) where

    import Control.Arrow
    import Control.Monad
    import Data.Char (isAlphaNum)
    import qualified Data.Vector.Generic as G
    import qualified Data.Vector.Generic.Mutable as M
    import Data.Vector.Unboxed.Base (MVector (..), Vector (..), Unbox)
    import Language.Haskell.TH

    -- Create a @Pat@ bound to the given name and an @Exp@ for said binding.
    newPatExp :: String -> Q (Pat, Exp)
    newPatExp :: String -> Q (Pat, Exp)
    newPatExp = (Name -> (Pat, Exp)) -> Q Name -> Q (Pat, Exp)
    forall a b. (a -> b) -> Q a -> Q b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Name -> Pat
    VarP (Name -> Pat) -> (Name -> Exp) -> Name -> (Pat, Exp)
    forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
    forall (a :: * -> * -> *) b c c'.
    Arrow a =>
    a b c -> a b c' -> a b (c, c')
    &&& Name -> Exp
    VarE) (Q Name -> Q (Pat, Exp))
    -> (String -> Q Name) -> String -> Q (Pat, Exp)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName

    data Common = Common
        { Common -> Name
    mvName, Common -> Name
    vName :: Name
        , Common -> (Pat, Exp)
    i, Common -> (Pat, Exp)
    n, Common -> (Pat, Exp)
    mv, Common -> (Pat, Exp)
    mv', Common -> (Pat, Exp)
    v :: (Pat, Exp) }

    common :: String -> Q Common
    common :: String -> Q Common
    common String
    name = do
        -- A bit looser than “Haskell 2010: §2.4 Identifiers and Operators”…
        let valid :: Char -> Bool
    valid Char
    c = Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '_' Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '\'' Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '#' Bool -> Bool -> Bool
    || Char -> Bool
    isAlphaNum Char
    c
        Bool -> Q () -> Q ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless ((Char -> Bool) -> String -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Char -> Bool
    valid String
    name) (Q () -> Q ()) -> Q () -> Q ()
    forall a b. (a -> b) -> a -> b
    $ do
            String -> Q ()
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> String
    forall a. Show a => a -> String
    show String
    name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " is not a valid constructor suffix!")
        let mvName :: Name
    mvName = String -> Name
    mkName (String
    "MV_" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    name)
        let vName :: Name
    vName = String -> Name
    mkName (String
    "V_" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    name)
        i <- String -> Q (Pat, Exp)
    newPatExp String
    "idx"
        n <- newPatExp "len"
        mv  <- first (conPCompat mvName . (:[])) <$> newPatExp "mvec"
        mv' <- first (conPCompat mvName . (:[])) <$> newPatExp "mvec'"
        v   <- first (conPCompat vName  . (:[])) <$> newPatExp "vec"
        return Common {..}
      where
        conPCompat :: Name -> [Pat] -> Pat
    conPCompat Name
    n [Pat]
    pats = Name -> [Type] -> [Pat] -> Pat
    ConP Name
    n
    #if MIN_VERSION_template_haskell(2,18,0)
                                 []
    #endif
                                 [Pat]
    pats

    liftE :: Exp -> Exp -> Exp
    liftE :: Exp -> Exp -> Exp
    liftE Exp
    e = Maybe Exp -> Exp -> Maybe Exp -> Exp
    InfixE (Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just Exp
    e) (Name -> Exp
    VarE 'liftM) (Maybe Exp -> Exp) -> (Exp -> Maybe Exp) -> Exp -> Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just

    -- Create a wrapper for the given function with the same 'nameBase', given
    -- a list of argument bindings and expressions in terms of said bindings.
    -- A final coercion (@Exp → Exp@) is applied to the body of the function.
    -- Complimentary @INLINE@ pragma included.
    wrap :: Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap :: Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap Name
    name ([(Pat, Exp)] -> ([Pat], [Exp])
    forall a b. [(a, b)] -> ([a], [b])
    unzip -> ([Pat]
    pats, [Exp]
    exps)) Exp -> Exp
    coerce = [Dec
    inline, Dec
    method] where
        inline :: Dec
    inline = Pragma -> Dec
    PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
    InlineP Name
    name Inline
    Inline RuleMatch
    FunLike Phases
    AllPhases)
        body :: Exp
    body = Exp -> Exp
    coerce (Exp -> Exp) -> Exp -> Exp
    forall a b. (a -> b) -> a -> b
    $ (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Exp -> Exp -> Exp
    AppE (Name -> Exp
    VarE Name
    name) [Exp]
    exps
        method :: Dec
    method = Name -> [Clause] -> Dec
    FunD Name
    name [[Pat] -> Body -> [Dec] -> Clause
    Clause [Pat]
    pats (Exp -> Body
    NormalB Exp
    body) []]

    {-| Let's consider a more complex example: suppose we want an @Unbox@
    instance for @Maybe a@. We could encode this using the pair @(Bool, a)@,
    with the boolean indicating whether we have @Nothing@ or @Just@ something.
    This encoding requires a dummy value in the @Nothing@ case, necessitating an
    additional <http://hackage.haskell.org/package/data-default/docs/Data-Default.html#t:Default Default>
    constraint. Thus:

    >derivingUnbox "Maybe"
    >    [t| ∀ a. (Default a, Unbox a) ⇒ Maybe a → (Bool, a) |]
    >    [| maybe (False, def) (\ x → (True, x)) |]
    >    [| \ (b, x) → if b then Just x else Nothing |]
    -}
    derivingUnbox
        :: String   -- ^ Unique constructor suffix for the MVector and Vector data families
        -> TypeQ    -- ^ Quotation of the form @[t| /ctxt/ ⇒ src → rep |]@
        -> ExpQ     -- ^ Quotation of an expression of type @src → rep@
        -> ExpQ     -- ^ Quotation of an expression of type @rep → src@
        -> DecsQ    -- ^ Declarations to be spliced for the derived Unbox instance
    derivingUnbox :: String -> TypeQ -> ExpQ -> ExpQ -> DecsQ
    derivingUnbox String
    name TypeQ
    argsQ ExpQ
    toRepQ ExpQ
    fromRepQ = do
        Common {..} <- String -> Q Common
    common String
    name
        toRep <- toRepQ
        fromRep <- fromRepQ
        a <- second (AppE toRep) <$> newPatExp "val"
        args <- argsQ
        (cxts, typ, rep) <- case args of
            ForallT [TyVarBndr Specificity]
    _ [Type]
    cxts (Type
    ArrowT `AppT` Type
    typ `AppT` Type
    rep) -> ([Type], Type, Type) -> Q ([Type], Type, Type)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Type]
    cxts, Type
    typ, Type
    rep)
            Type
    ArrowT `AppT` Type
    typ `AppT` Type
    rep -> ([Type], Type, Type) -> Q ([Type], Type, Type)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([], Type
    typ, Type
    rep)
            Type
    _ -> String -> Q ([Type], Type, Type)
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Expecting a type of the form: cxts => typ -> rep"

        let s = Name -> Type
    VarT (String -> Name
    mkName String
    "s")
        let lazy = SourceUnpackedness -> SourceStrictness -> Bang
    Bang SourceUnpackedness
    NoSourceUnpackedness SourceStrictness
    NoSourceStrictness
        let newtypeMVector = Name -> [Type] -> Con -> Dec
    newtypeInstD' ''MVector [Type
    s, Type
    typ]
                (Name -> [BangType] -> Con
    NormalC Name
    mvName [(Bang
    lazy, Name -> Type
    ConT ''MVector Type -> Type -> Type
    `AppT` Type
    s Type -> Type -> Type
    `AppT` Type
    rep)])
        let mvCon = Name -> Exp
    ConE Name
    mvName
        let instanceMVector = Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
    InstanceD Maybe Overlap
    forall a. Maybe a
    Nothing [Type]
    cxts
                (Name -> Type
    ConT ''M.MVector Type -> Type -> Type
    `AppT` Name -> Type
    ConT ''MVector Type -> Type -> Type
    `AppT` Type
    typ) ([Dec] -> Dec) -> [Dec] -> Dec
    forall a b. (a -> b) -> a -> b
    $ [[Dec]] -> [Dec]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat
                [ Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap 'M.basicLength           [(Pat, Exp)
    mv]        Exp -> Exp
    forall a. a -> a
    id
                , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap 'M.basicUnsafeSlice      [(Pat, Exp)
    i, (Pat, Exp)
    n, (Pat, Exp)
    mv]  (Exp -> Exp -> Exp
    AppE Exp
    mvCon)
                , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap 'M.basicOverlaps         [(Pat, Exp)
    mv, (Pat, Exp)
    mv']   Exp -> Exp
    forall a. a -> a
    id
                , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap 'M.basicUnsafeNew        [(Pat, Exp)
    n]         (Exp -> Exp -> Exp
    liftE Exp
    mvCon)
    #if MIN_VERSION_vector(0,11,0)
                , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap 'M.basicInitialize       [(Pat, Exp)
    mv]        Exp -> Exp
    forall a. a -> a
    id
    #endif
                , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap 'M.basicUnsafeReplicate  [(Pat, Exp)
    n, (Pat, Exp)
    a]      (Exp -> Exp -> Exp
    liftE Exp
    mvCon)
                , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap 'M.basicUnsafeRead       [(Pat, Exp)
    mv, (Pat, Exp)
    i]     (Exp -> Exp -> Exp
    liftE Exp
    fromRep)
                , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap 'M.basicUnsafeWrite      [(Pat, Exp)
    mv, (Pat, Exp)
    i, (Pat, Exp)
    a]  Exp -> Exp
    forall a. a -> a
    id
                , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap 'M.basicClear            [(Pat, Exp)
    mv]        Exp -> Exp
    forall a. a -> a
    id
                , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap 'M.basicSet              [(Pat, Exp)
    mv, (Pat, Exp)
    a]     Exp -> Exp
    forall a. a -> a
    id
                , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap 'M.basicUnsafeCopy       [(Pat, Exp)
    mv, (Pat, Exp)
    mv']   Exp -> Exp
    forall a. a -> a
    id
                , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap 'M.basicUnsafeMove       [(Pat, Exp)
    mv, (Pat, Exp)
    mv']   Exp -> Exp
    forall a. a -> a
    id
                , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap 'M.basicUnsafeGrow       [(Pat, Exp)
    mv, (Pat, Exp)
    n]     (Exp -> Exp -> Exp
    liftE Exp
    mvCon) ]

        let newtypeVector = Name -> [Type] -> Con -> Dec
    newtypeInstD' ''Vector [Type
    typ]
                (Name -> [BangType] -> Con
    NormalC Name
    vName [(Bang
    lazy, Name -> Type
    ConT ''Vector Type -> Type -> Type
    `AppT` Type
    rep)])

        let vCon  = Name -> Exp
    ConE Name
    vName
        let instanceVector = Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
    InstanceD Maybe Overlap
    forall a. Maybe a
    Nothing [Type]
    cxts
                (Name -> Type
    ConT ''G.Vector Type -> Type -> Type
    `AppT` Name -> Type
    ConT ''Vector Type -> Type -> Type
    `AppT` Type
    typ) ([Dec] -> Dec) -> [Dec] -> Dec
    forall a b. (a -> b) -> a -> b
    $ [[Dec]] -> [Dec]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat
                [ Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap 'G.basicUnsafeFreeze     [(Pat, Exp)
    mv]        (Exp -> Exp -> Exp
    liftE Exp
    vCon)
                , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap 'G.basicUnsafeThaw       [(Pat, Exp)
    v]         (Exp -> Exp -> Exp
    liftE Exp
    mvCon)
                , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap 'G.basicLength           [(Pat, Exp)
    v]         Exp -> Exp
    forall a. a -> a
    id
                , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap 'G.basicUnsafeSlice      [(Pat, Exp)
    i, (Pat, Exp)
    n, (Pat, Exp)
    v]   (Exp -> Exp -> Exp
    AppE Exp
    vCon)
                , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap 'G.basicUnsafeIndexM     [(Pat, Exp)
    v, (Pat, Exp)
    i]      (Exp -> Exp -> Exp
    liftE Exp
    fromRep)
                , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap 'G.basicUnsafeCopy       [(Pat, Exp)
    mv, (Pat, Exp)
    v]     Exp -> Exp
    forall a. a -> a
    id
                , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
    wrap 'G.elemseq               [(Pat, Exp)
    v, (Pat, Exp)
    a]      Exp -> Exp
    forall a. a -> a
    id ]

        return [ InstanceD Nothing cxts (ConT ''Unbox `AppT` typ) []
            , newtypeMVector, instanceMVector
            , newtypeVector, instanceVector ]

    newtypeInstD' :: Name -> [Type] -> Con -> Dec
    newtypeInstD' :: Name -> [Type] -> Con -> Dec
    newtypeInstD' Name
    name [Type]
    args Con
    con =
    #if MIN_VERSION_template_haskell(2,15,0)
        [Type]
    -> Maybe [TyVarBndr ()]
    -> Type
    -> Maybe Type
    -> Con
    -> [DerivClause]
    -> Dec
    NewtypeInstD [] Maybe [TyVarBndr ()]
    forall a. Maybe a
    Nothing ((Type -> Type -> Type) -> Type -> [Type] -> Type
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Type -> Type -> Type
    AppT (Name -> Type
    ConT Name
    name) [Type]
    args) Maybe Type
    forall a. Maybe a
    Nothing Con
    con []
    #else
        NewtypeInstD [] name args Nothing con []
    #endif

    {-$usage

    Writing @Unbox@ instances for new data types is tedious and formulaic. More
    often than not, there is a straightforward mapping of the new type onto some
    existing one already imbued with an @Unbox@ instance. The
    <http://hackage.haskell.org/package/vector/docs/Data-Vector-Unboxed.html example>
    from the @vector@ package represents @Complex a@ as pairs @(a, a)@. Using
    'derivingUnbox', we can define the same instances much more succinctly:

    >derivingUnbox "Complex"
    >    [t| ∀ a. (Unbox a) ⇒ Complex a → (a, a) |]
    >    [| \ (r :+ i) → (r, i) |]
    >    [| \ (r, i) → r :+ i |]

    Requires the @MultiParamTypeClasses@, @TemplateHaskell@, @TypeFamilies@ and
    probably the @FlexibleInstances@ @LANGUAGE@ extensions. Note that GHC 7.4
    (but not earlier nor later) needs the 'G.Vector' and 'M.MVector' class
    method names to be in scope in order to define the appropriate instances:

    >#if __GLASGOW_HASKELL__ == 704
    >import qualified Data.Vector.Generic
    >import qualified Data.Vector.Generic.Mutable
    >#endif

    Consult the <https://github.com/liyang/vector-th-unbox/blob/master/tests/sanity.hs sanity test>
    for a working example.

    -}