{-# 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> Pat
VarP forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Name -> Exp
VarE) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'#' Bool -> Bool -> Bool
|| Char -> Bool
isAlphaNum Char
c
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
valid String
name) forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall a. Show a => a -> String
show String
name forall a. [a] -> [a] -> [a]
++ String
" is not a valid constructor suffix!")
    let mvName :: Name
mvName = String -> Name
mkName (String
"MV_" forall a. [a] -> [a] -> [a]
++ String
name)
    let vName :: Name
vName = String -> Name
mkName (String
"V_" 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  <- forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Name -> [Pat] -> Pat
conPCompat Name
mvName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[])) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q (Pat, Exp)
newPatExp String
"mvec"
    (Pat, Exp)
mv' <- forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Name -> [Pat] -> Pat
conPCompat Name
mvName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[])) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q (Pat, Exp)
newPatExp String
"mvec'"
    (Pat, Exp)
v   <- forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Name -> [Pat] -> Pat
conPCompat Name
vName  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[])) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q (Pat, Exp)
newPatExp String
"vec"
    forall (m :: * -> *) a. Monad m => a -> m a
return 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
..}
  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 (forall a. a -> Maybe a
Just Exp
e) (Name -> Exp
VarE 'liftM) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (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 forall a b. (a -> 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 {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 <- forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Exp -> Exp -> Exp
AppE Exp
toRep) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q (Pat, Exp)
newPatExp String
"val"
    Type
args <- TypeQ
argsQ
    ([Type]
cxts, Type
typ, Type
rep) <- case Type
args of
        ForallT [TyVarBndr Specificity]
_ [Type]
cxts (Type
ArrowT `AppT` Type
typ `AppT` Type
rep) -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
cxts, Type
typ, Type
rep)
        Type
ArrowT `AppT` Type
typ `AppT` Type
rep -> forall (m :: * -> *) a. Monad m => a -> m a
return ([], Type
typ, Type
rep)
        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")
    let lazy :: Bang
lazy = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness
    let newtypeMVector :: Dec
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 :: Exp
mvCon = Name -> Exp
ConE Name
mvName
    let instanceMVector :: Dec
instanceMVector = Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD 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) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
wrap 'M.basicLength           [(Pat, Exp)
mv]        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']   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]        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]  forall a. a -> a
id
            , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
wrap 'M.basicClear            [(Pat, Exp)
mv]        forall a. a -> a
id
            , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
wrap 'M.basicSet              [(Pat, Exp)
mv, (Pat, Exp)
a]     forall a. a -> a
id
            , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
wrap 'M.basicUnsafeCopy       [(Pat, Exp)
mv, (Pat, Exp)
mv']   forall a. a -> a
id
            , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
wrap 'M.basicUnsafeMove       [(Pat, Exp)
mv, (Pat, Exp)
mv']   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 -> [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 :: Exp
vCon  = Name -> Exp
ConE Name
vName
    let instanceVector :: Dec
instanceVector = Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD 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) forall a b. (a -> b) -> a -> b
$ 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]         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]     forall a. a -> a
id
            , Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
wrap 'G.elemseq               [(Pat, Exp)
v, (Pat, Exp)
a]      forall a. a -> a
id ]

    forall (m :: * -> *) a. Monad m => a -> m a
return [ Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD forall a. Maybe a
Nothing [Type]
cxts (Name -> Type
ConT ''Unbox Type -> Type -> Type
`AppT` Type
typ) []
        , Dec
newtypeMVector, Dec
instanceMVector
        , Dec
newtypeVector, Dec
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 [] forall a. Maybe a
Nothing (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) 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.

-}