diff --git a/Data/Vector/Unboxed/Deriving.hs b/Data/Vector/Unboxed/Deriving.hs --- a/Data/Vector/Unboxed/Deriving.hs +++ b/Data/Vector/Unboxed/Deriving.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} @@ -10,7 +11,7 @@ {-| Module: Data.Vector.Unboxed.Deriving -Copyright: © Liyang HU 2012 +Copyright: © 2012−2013 Liyang HU License: BSD3 Maintainer: vector-th-unbox@liyang.hu Stability: experimental @@ -18,11 +19,10 @@ 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: +existing one already imbued with an @Unbox@ instance. The + +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| (Unbox a) ⇒ Complex a → (a, a) |] @@ -30,12 +30,17 @@ > [| \ (r, i) → r :+ i |] Requires the @MultiParamTypeClasses@, @TemplateHaskell@, @TypeFamilies@ and -probably the @FlexibleInstances@ @LANGUAGE@ extensions. Older versions of -GHC needs the 'G.Vector' and 'M.MVector' class method names in scope: +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 +for a working example. -} module Data.Vector.Unboxed.Deriving (derivingUnbox) where @@ -48,30 +53,55 @@ import Data.Vector.Unboxed.Base (MVector (..), Vector (..), Unbox) import Language.Haskell.TH +consUnbox :: String -> (Name, Name) +consUnbox name = (mkName $ "MV_" ++ name, mkName $ "V_" ++ name) + -- 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 + let (mvName, vName) = consUnbox name + i <- newPatExp "idx" + n <- newPatExp "len" + mv <- first (ConP mvName . (:[])) <$> newPatExp "mvec" + mv' <- first (ConP mvName . (:[])) <$> newPatExp "mvec'" + v <- first (ConP vName . (:[])) <$> newPatExp "vec" + return Common {..} + +-- Turn any 'Name' into a capturable one. +capture :: Name -> Name +capture = mkName . nameBase + +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 fun (unzip -> (pats, exps)) coerce = [inline, method] where + name = capture fun #if MIN_VERSION_template_haskell(2,8,0) - inline = PragmaD (InlineP fun Inline FunLike AllPhases) + inline = PragmaD (InlineP name Inline FunLike AllPhases) #else - inline = PragmaD ( InlineP (mkName (nameBase fun)) - (InlineSpec True False Nothing) ) + inline = PragmaD ( InlineP name (InlineSpec True False Nothing) ) #endif body = coerce $ foldl AppE (VarE fun) exps - method = FunD fun [Clause pats (NormalB body) []] + method = FunD name [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: +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 +constraint. Thus: >derivingUnbox "Maybe" > [t| (Default a, Unbox a) ⇒ Maybe a → (Bool, a) |] @@ -85,29 +115,20 @@ -> 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) + 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 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 mvCon = ConE mvName let instanceMVector = InstanceD cxts (ConT ''M.MVector `AppT` ConT ''MVector `AppT` typ) $ concat [ wrap 'M.basicLength [mv] id @@ -120,10 +141,12 @@ , 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 [(NotStrict, ConT ''Vector `AppT` rep)]) [] + let vCon = ConE vName let instanceVector = InstanceD cxts (ConT ''G.Vector `AppT` ConT ''Vector `AppT` typ) $ concat [ wrap 'G.basicUnsafeFreeze [mv] (liftE vCon) diff --git a/tests/sanity.hs b/tests/sanity.hs new file mode 100644 --- /dev/null +++ b/tests/sanity.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706 +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +#endif + +module Main (main) where + +import Prelude +import Data.Default +import qualified Data.Vector.Generic +import qualified Data.Vector.Generic.Mutable +import Data.Vector.Unboxed.Base (Unbox) +import Data.Vector.Unboxed.Deriving + +derivingUnbox "Maybe" + [t| (Default a, Unbox a) ⇒ Maybe a → (Bool, a) |] + [| maybe (False, def) (\ x → (True, x)) |] + [| \ (b, x) → if b then Just x else Nothing |] + +main ∷ IO () +main = return () + diff --git a/vector-th-unbox.cabal b/vector-th-unbox.cabal --- a/vector-th-unbox.cabal +++ b/vector-th-unbox.cabal @@ -1,5 +1,5 @@ name: vector-th-unbox -version: 0.2.0.1 +version: 0.2.0.2 synopsis: Deriver for Data.Vector.Unboxed using Template Haskell description: A Template Haskell deriver for unboxed vectors, given a pair of coercion @@ -9,17 +9,19 @@ stability: experimental license: BSD3 license-file: LICENSE -author: Liyang HU -maintainer: vector-th-unbox@liyang.hu +copyright: © 2012−2013 Liyang HU +author: Liyang HU +maintainer: Liyang HU category: Data build-type: Simple -cabal-version: >= 1.6 +cabal-version: >= 1.10 source-repository head type: git location: http://github.com/liyang/vector-th-unbox library + default-language: Haskell2010 exposed-modules: Data.Vector.Unboxed.Deriving @@ -27,6 +29,18 @@ base >= 4.3 && < 5, template-haskell >= 2.5, vector >= 0.7 + +test-suite sanity + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: sanity.hs + build-depends: + base, + data-default, + vector, + vector-th-unbox + ghc-options: -Wall -- vim: et sw=4 ts=4 sts=4: