1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
{-# 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 = fmap (VarP &&& VarE) . newName
data Common = Common
{ mvName, vName :: Name
, i, n, mv, mv', v :: (Pat, Exp) }
common :: String -> Q Common
common name = do
-- A bit looser than “Haskell 2010: §2.4 Identifiers and Operators”…
let valid c = c == '_' || c == '\'' || c == '#' || isAlphaNum c
unless (all valid name) $ do
fail (show name ++ " is not a valid constructor suffix!")
let mvName = mkName ("MV_" ++ name)
let vName = mkName ("V_" ++ name)
i <- newPatExp "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 n pats = ConP n
#if MIN_VERSION_template_haskell(2,18,0)
[]
#endif
pats
liftE :: Exp -> Exp -> Exp
liftE e = InfixE (Just e) (VarE 'liftM) . 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 (unzip -> (pats, exps)) coerce = [inline, method] where
inline = PragmaD (InlineP name Inline FunLike AllPhases)
body = coerce $ foldl AppE (VarE name) exps
method = FunD name [Clause pats (NormalB 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 name argsQ toRepQ fromRepQ = do
Common {..} <- common name
toRep <- toRepQ
fromRep <- fromRepQ
a <- second (AppE toRep) <$> newPatExp "val"
args <- argsQ
(cxts, typ, rep) <- case args of
ForallT _ cxts (ArrowT `AppT` typ `AppT` rep) -> return (cxts, typ, rep)
ArrowT `AppT` typ `AppT` rep -> return ([], typ, rep)
_ -> fail "Expecting a type of the form: cxts => typ -> rep"
let s = VarT (mkName "s")
let lazy = Bang NoSourceUnpackedness NoSourceStrictness
let newtypeMVector = newtypeInstD' ''MVector [s, typ]
(NormalC mvName [(lazy, ConT ''MVector `AppT` s `AppT` rep)])
let mvCon = ConE mvName
let instanceMVector = InstanceD Nothing cxts
(ConT ''M.MVector `AppT` ConT ''MVector `AppT` typ) $ concat
[ wrap 'M.basicLength [mv] id
, wrap 'M.basicUnsafeSlice [i, n, mv] (AppE mvCon)
, wrap 'M.basicOverlaps [mv, mv'] id
, wrap 'M.basicUnsafeNew [n] (liftE mvCon)
#if MIN_VERSION_vector(0,11,0)
, wrap 'M.basicInitialize [mv] id
#endif
, wrap 'M.basicUnsafeReplicate [n, a] (liftE mvCon)
, wrap 'M.basicUnsafeRead [mv, i] (liftE fromRep)
, wrap 'M.basicUnsafeWrite [mv, i, a] id
, wrap 'M.basicClear [mv] id
, wrap 'M.basicSet [mv, a] id
, wrap 'M.basicUnsafeCopy [mv, mv'] id
, wrap 'M.basicUnsafeMove [mv, mv'] id
, wrap 'M.basicUnsafeGrow [mv, n] (liftE mvCon) ]
let newtypeVector = newtypeInstD' ''Vector [typ]
(NormalC vName [(lazy, ConT ''Vector `AppT` rep)])
let vCon = ConE vName
let instanceVector = InstanceD Nothing cxts
(ConT ''G.Vector `AppT` ConT ''Vector `AppT` typ) $ concat
[ wrap 'G.basicUnsafeFreeze [mv] (liftE vCon)
, wrap 'G.basicUnsafeThaw [v] (liftE mvCon)
, wrap 'G.basicLength [v] id
, wrap 'G.basicUnsafeSlice [i, n, v] (AppE vCon)
, wrap 'G.basicUnsafeIndexM [v, i] (liftE fromRep)
, wrap 'G.basicUnsafeCopy [mv, v] id
, wrap 'G.elemseq [v, a] id ]
return [ InstanceD Nothing cxts (ConT ''Unbox `AppT` typ) []
, newtypeMVector, instanceMVector
, newtypeVector, instanceVector ]
newtypeInstD' :: Name -> [Type] -> Con -> Dec
newtypeInstD' name args con =
#if MIN_VERSION_template_haskell(2,15,0)
NewtypeInstD [] Nothing (foldl AppT (ConT name) args) Nothing 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.
-}
|
