{-# 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
(
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
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 name :: String
name = do
let valid :: Char -> Bool
valid c :: Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\'' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '#' 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]
++ " is not a valid constructor suffix!")
let mvName :: Name
mvName = String -> Name
mkName ("MV_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name)
let vName :: Name
vName = String -> Name
mkName ("V_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name)
(Pat, Exp)
i <- String -> Q (Pat, Exp)
newPatExp "idx"
(Pat, Exp)
n <- String -> Q (Pat, Exp)
newPatExp "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 "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 "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 "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 {..}
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 e :: 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
wrap :: Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
wrap :: Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec]
wrap fun :: Name
fun ([(Pat, Exp)] -> ([Pat], [Exp])
forall a b. [(a, b)] -> ([a], [b])
unzip -> (pats :: [Pat]
pats, exps :: [Exp]
exps)) coerce :: 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) []]
derivingUnbox
:: String
-> TypeQ
-> ExpQ
-> ExpQ
-> DecsQ
derivingUnbox :: String -> TypeQ -> ExpQ -> ExpQ -> DecsQ
derivingUnbox name :: String
name argsQ :: TypeQ
argsQ toRepQ :: ExpQ
toRepQ fromRepQ :: ExpQ
fromRepQ = do
Common {..} <- 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 "val"
Type
args <- TypeQ
argsQ
(cxts :: Cxt
cxts, typ :: Type
typ, rep :: Type
rep) <- case Type
args of
ForallT _ cxts :: Cxt
cxts (ArrowT `AppT` typ :: Type
typ `AppT` rep :: Type
rep) -> (Cxt, Type, Type) -> Q (Cxt, Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cxt
cxts, Type
typ, Type
rep)
ArrowT `AppT` typ :: Type
typ `AppT` rep :: Type
rep -> (Cxt, Type, Type) -> Q (Cxt, Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Type
typ, Type
rep)
_ -> String -> Q (Cxt, Type, Type)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Expecting a type of the form: cxts => typ -> rep"
let s :: Type
s = Name -> Type
VarT (String -> Name
mkName "s")
#if MIN_VERSION_template_haskell(2,11,0)
let lazy :: Bang
lazy = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness
# define MAYBE_KIND Nothing
# define MAYBE_OVERLAP Nothing
#else
let lazy = NotStrict
# define MAYBE_KIND
# define MAYBE_OVERLAP
#endif
#if MIN_VERSION_template_haskell(2,15,0)
let newtypeMVector :: Dec
newtypeMVector = Cxt
-> Maybe [TyVarBndr]
-> Type
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeInstD [] Maybe [TyVarBndr]
forall a. Maybe a
Nothing (Name -> Type
ConT ''MVector Type -> Type -> Type
`AppT` Type
s Type -> Type -> Type
`AppT` Type
typ) MAYBE_KIND
#else
let newtypeMVector = NewtypeInstD [] ''MVector [s, typ] MAYBE_KIND
#endif
(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) ]
#if MIN_VERSION_template_haskell(2,15,0)
let newtypeVector :: Dec
newtypeVector = Cxt
-> Maybe [TyVarBndr]
-> Type
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeInstD [] Maybe [TyVarBndr]
forall a. Maybe a
Nothing (Name -> Type
ConT ''Vector Type -> Type -> Type
`AppT` Type
typ) MAYBE_KIND
(Name -> [BangType] -> Con
NormalC Name
vName [(Bang
lazy, Name -> Type
ConT ''Vector Type -> Type -> Type
`AppT` Type
rep)]) []
#else
let newtypeVector = NewtypeInstD [] ''Vector [typ] MAYBE_KIND
(NormalC vName [(lazy, ConT ''Vector `AppT` rep)]) []
#endif
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 ]
#undef __GLASGOW_HASKELL__