{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
{-# 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

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> Pat
VarP (Name -> Pat) -> (Name -> Exp) -> Name -> (Pat, Exp)
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
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 (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)
    (Pat, Exp)
i <- String -> Q (Pat, Exp)
newPatExp String
"idx"
    (Pat, Exp)
n <- String -> Q (Pat, Exp)
newPatExp String
"len"
    (Pat, Exp)
mv  <- (Pat -> Pat) -> (Pat, Exp) -> (Pat, Exp)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Name -> [Pat] -> Pat
ConP Name
mvName ([Pat] -> Pat) -> (Pat -> [Pat]) -> Pat -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
:[])) ((Pat, Exp) -> (Pat, Exp)) -> Q (Pat, Exp) -> Q (Pat, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q (Pat, Exp)
newPatExp String
"mvec"
    (Pat, Exp)
mv' <- (Pat -> Pat) -> (Pat, Exp) -> (Pat, Exp)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Name -> [Pat] -> Pat
ConP Name
mvName ([Pat] -> Pat) -> (Pat -> [Pat]) -> Pat -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
:[])) ((Pat, Exp) -> (Pat, Exp)) -> Q (Pat, Exp) -> Q (Pat, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q (Pat, Exp)
newPatExp String
"mvec'"
    (Pat, Exp)
v   <- (Pat -> Pat) -> (Pat, Exp) -> (Pat, Exp)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Name -> [Pat] -> Pat
ConP Name
vName  ([Pat] -> Pat) -> (Pat -> [Pat]) -> Pat -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
:[])) ((Pat, Exp) -> (Pat, Exp)) -> Q (Pat, Exp) -> Q (Pat, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q (Pat, Exp)
newPatExp String
"vec"
    Common -> Q Common
forall (m :: * -> *) a. Monad m => a -> m a
return Common :: Name
-> Name
-> (Pat, Exp)
-> (Pat, Exp)
-> (Pat, Exp)
-> (Pat, Exp)
-> (Pat, Exp)
-> Common
Common {Name
(Pat, Exp)
v :: (Pat, Exp)
mv' :: (Pat, Exp)
mv :: (Pat, Exp)
n :: (Pat, Exp)
i :: (Pat, Exp)
vName :: Name
mvName :: Name
v :: (Pat, Exp)
mv' :: (Pat, Exp)
mv :: (Pat, Exp)
n :: (Pat, Exp)
i :: (Pat, Exp)
vName :: Name
mvName :: Name
..}

-- Turn any 'Name' into a capturable one.
capture :: Name -> Name
#if __GLASGOW_HASKELL__ == 704
capture = mkName . nameBase
#else
capture :: Name -> Name
capture = Name -> Name
forall a. a -> a
id
#endif

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
fun ([(Pat, Exp)] -> ([Pat], [Exp])
forall a b. [(a, b)] -> ([a], [b])
unzip -> ([Pat]
pats, [Exp]
exps)) Exp -> Exp
coerce = [Dec
inline, Dec
method] where
    name :: Name
name = Name -> Name
capture Name
fun
#if MIN_VERSION_template_haskell(2,8,0)
    inline :: Dec
inline = Pragma -> Dec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
name Inline
Inline RuleMatch
FunLike Phases
AllPhases)
#else
    inline = PragmaD ( InlineP name (InlineSpec True False Nothing) )
#endif
    body :: Exp
body = Exp -> Exp
coerce (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
fun) [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 {Name
(Pat, Exp)
v :: (Pat, Exp)
mv' :: (Pat, Exp)
mv :: (Pat, Exp)
n :: (Pat, Exp)
i :: (Pat, Exp)
vName :: Name
mvName :: Name
v :: Common -> (Pat, Exp)
mv' :: Common -> (Pat, Exp)
mv :: Common -> (Pat, Exp)
n :: Common -> (Pat, Exp)
i :: Common -> (Pat, Exp)
vName :: Common -> Name
mvName :: Common -> Name
..} <- String -> Q Common
common String
name
    Exp
toRep <- ExpQ
toRepQ
    Exp
fromRep <- ExpQ
fromRepQ
    (Pat, Exp)
a <- (Exp -> Exp) -> (Pat, Exp) -> (Pat, Exp)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Exp -> Exp -> Exp
AppE Exp
toRep) ((Pat, Exp) -> (Pat, Exp)) -> Q (Pat, Exp) -> Q (Pat, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q (Pat, Exp)
newPatExp String
"val"
    Type
args <- TypeQ
argsQ
    (Cxt
cxts, Type
typ, Type
rep) <- case Type
args of
        ForallT [TyVarBndr]
_ Cxt
cxts (Type
ArrowT `AppT` Type
typ `AppT` Type
rep) -> (Cxt, Type, Type) -> Q (Cxt, Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cxt
cxts, Type
typ, Type
rep)
        Type
ArrowT `AppT` Type
typ `AppT` Type
rep -> (Cxt, Type, Type) -> Q (Cxt, Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Type
typ, Type
rep)
        Type
_ -> String -> Q (Cxt, Type, Type)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expecting a type of the form: cxts => typ -> rep"

    let s :: Type
s = Name -> Type
VarT (String -> Name
mkName String
"s")
#if MIN_VERSION_template_haskell(2,11,0)
    let lazy :: Bang
lazy = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness
# define MAYBE_OVERLAP Nothing
#else
    let lazy = NotStrict
# define MAYBE_OVERLAP
#endif
    let newtypeMVector :: Dec
newtypeMVector = Name -> Cxt -> 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 :: Exp
mvCon = Name -> Exp
ConE Name
mvName
    let instanceMVector :: Dec
instanceMVector = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD MAYBE_OVERLAP 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 :: Dec
newtypeVector = Name -> Cxt -> 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 :: Exp
vCon  = Name -> Exp
ConE Name
vName
    let instanceVector :: Dec
instanceVector = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD MAYBE_OVERLAP 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 ]

    [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return [ Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD MAYBE_OVERLAP Name -> Type
cxts (ConT ''Unbox `AppT` typ) []
        , Dec
newtypeMVector, Dec
instanceMVector
        , Dec
newtypeVector, Dec
instanceVector ]

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

#undef __GLASGOW_HASKELL__
{-$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.

-}