diff --git a/Data/Vector/Unboxed/Deriving.hs b/Data/Vector/Unboxed/Deriving.hs new file mode 100644 --- /dev/null +++ b/Data/Vector/Unboxed/Deriving.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS -Wall #-} + +{-| +Module: Data.Vector.Unboxed.Deriving +Copyright: © Liyang HU 2012 +License: BSD3 +Maintainer: vector-th-unbox@liyang.hu +Stability: experimental +Portability: non-portable + +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 example from the +vector package represents @Complex a@ as pairs @(a, a)@. (See +.) +Using 'derivingUnbox', we can define the same instances much more +succinctly: + +>derivingUnbox "Complex" +> [d| instance (Unbox a) => Unbox' (Complex a) (a, a) |] +> [| \ (r :+ i) -> (r, i) |] +> [| \ (r, i) -> r :+ i |] + +Requires the @MultiParamTypeClasses@, @TemplateHaskell@ and @TypeFamilies@ +LANGUAGE extensions. + +The dummy 'Unbox'' class provides a convenient way to pass in the source +and representation types, along with any requisite constraints. + +-} + +module Data.Vector.Unboxed.Deriving + ( Unbox', derivingUnbox + ) where + +import Control.Arrow +import Control.Applicative +import Control.Monad +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 + +-- | A dummy class for passing arguments to 'derivingUnbox'. +class Unbox' src rep + +-- Create a Pat bound to the given name and an Exp for said binding. +newPatExp :: String -> Q (Pat, Exp) +newPatExp = fmap (VarP &&& VarE) . newName + +-- Create a wrapper for the given function with the same 'nameBase', given +-- a list of argument bindings and expressions in terms of said bindings. +-- Complimentary INLINE pragma included. +wrap :: Name -> [(Pat, Exp)] -> (Exp -> Exp) -> [Dec] +wrap fun (unzip -> (pats, exps)) coerce = [inline, method] where + base = mkName (nameBase fun) + inline = PragmaD (InlineP base (InlineSpec True False Nothing)) + body = coerce $ foldl AppE (VarE fun) exps + method = FunD base [Clause pats (NormalB body) []] + +{-| Let's consider a more complex example: suppose we want an @Unbox@ +instance for @Maybe a@. We can 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 @Default@ (see the @data-default@ package) constraint. Thus: + +>derivingUnbox "Maybe" +> [d| instance (Default a, Unbox a) => Unbox' (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 + -> DecsQ -- ^ Quotation of the form @[d| instance /ctxt/ => Unbox' 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 + let mvName = mkName ("MV_" ++ name) + let vName = mkName ("V_" ++ name) + toRep <- toRepQ + fromRep <- fromRepQ + -- fail unless argsQ quotes a single Unbox' instance + [ InstanceD cxts (ConT (nameBase -> "Unbox'") + `AppT` typ `AppT` rep) [] ] <- argsQ + + let liftE e = InfixE (Just e) (VarE 'liftM) . Just + let mvCon = ConE mvName + let vCon = ConE vName + i <- newPatExp "idx" + n <- newPatExp "len" + a <- second (AppE toRep) <$> newPatExp "val" + mv <- first (ConP mvName . (:[])) <$> newPatExp "mvec" + mv' <- first (ConP mvName . (:[])) <$> newPatExp "mvec'" + v <- first (ConP vName . (:[])) <$> newPatExp "vec" + + s <- VarT <$> newName "s" + let newtypeMVector = NewtypeInstD [] ''MVector [s, typ] + (NormalC mvName [(NotStrict, ConT ''MVector `AppT` s `AppT` rep)]) [] + let instanceMVector = InstanceD 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) + , 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.basicUnsafeGrow [mv, n] (liftE mvCon) ] + + let newtypeVector = NewtypeInstD [] ''Vector [typ] + (NormalC vName [(NotStrict, ConT ''Vector `AppT` rep)]) [] + let instanceVector = InstanceD 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 cxts (ConT ''Unbox `AppT` typ) [] + , newtypeMVector, instanceMVector + , newtypeVector, instanceVector ] + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Liyang HU + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Liyang HU nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/vector-th-unbox.cabal b/vector-th-unbox.cabal new file mode 100644 --- /dev/null +++ b/vector-th-unbox.cabal @@ -0,0 +1,32 @@ +name: vector-th-unbox +version: 0.1.0.0 +synopsis: Deriver for unboxed vectors using Template Haskell +description: + A Template Haskell deriver for unboxed vectors, given a pair of coercion + functions to and from some existing type with an Unbox instance. + . + Refer to "Data.Vector.Unboxed.Deriving" for documentation and examples. +stability: experimental +license: BSD3 +license-file: LICENSE +author: Liyang HU +maintainer: vector-th-unbox@liyang.hu +category: Data +build-type: Simple +cabal-version: >= 1.6 + +source-repository head + type: git + location: http://github.com/liyang/vector-th-unbox + +library + exposed-modules: + Data.Vector.Unboxed.Deriving + + build-depends: + base >= 4.3 && < 5, + template-haskell >= 2.5, + vector >= 0.7 + +-- vim: et sw=4 ts=4 sts=4: +