packages feed

unpack-funcs (empty) → 0.1.0

raw patch · 6 files changed

+275/−0 lines, 6 filesdep +basedep +bytestringdep +primitivesetup-changed

Dependencies added: base, bytestring, primitive, template-haskell, transformers, vector

Files

+ Control/Monad/Unpack.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE TypeOperators, TypeFamilies, TemplateHaskell #-}+module Control.Monad.Unpack (module Control.Monad.Unpack.Class, (:~>), unpack, ($~)) where++import Data.Functor.Identity++import Control.Monad.Unpack.Class+import Control.Monad.Unpack.TH++import Data.ByteString (ByteString)+import Data.Primitive.Addr+import Data.Primitive.Array+import Data.Primitive.ByteArray+import qualified Data.Vector as V+import qualified Data.Vector.Primitive as P+import qualified Data.Vector.Storable as S+import Foreign.ForeignPtr+import Foreign.Ptr+import Data.Word+import Data.Int++$(unpack1Instance ''Int)+$(unpack1Instance ''Int8)+$(unpack1Instance ''Int16)+$(unpack1Instance ''Int32)+$(unpack1Instance ''Int64)+$(unpack1Instance ''Word)+$(unpack1Instance ''Word8)+$(unpack1Instance ''Word16)+$(unpack1Instance ''Word32)+$(unpack1Instance ''Word64)+$(unpack1Instance ''Char)+$(unpack1Instance ''Array)+$(unpack1Instance ''MutableArray)+$(unpack1Instance ''ByteArray)+$(unpack1Instance ''MutableByteArray)+$(unpack1Instance ''Ptr)+$(unpack1Instance ''Addr)+$(unpack1Instance ''ForeignPtr)+$(unpackInstance ''ByteString)+$(unpackInstance ''V.Vector)+$(unpackInstance ''P.Vector)+$(unpackInstance ''S.Vector)+$(unpackInstance ''V.MVector)+$(unpackInstance ''P.MVector)+$(unpackInstance ''S.MVector)+$(noUnpackInstance ''Bool)+$(noUnpackInstance ''Maybe)+$(noUnpackInstance ''Either)++type (:~>) arg = UnpackedReaderT arg Identity++infixr 0 :~>++{-# INLINE ($~) #-}+($~) :: Unpackable arg => (arg :~> a) -> arg -> a+f $~ arg = runIdentity (f `runUnpackedReaderT` arg)++{-# INLINE unpack #-}+unpack :: Unpackable arg => (arg -> a) -> (arg :~> a)+unpack f = unpackedReaderT $ Identity . f
+ Control/Monad/Unpack/Class.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE TypeOperators, TypeFamilies #-}+module Control.Monad.Unpack.Class where++import Control.Applicative+import Control.Monad.Trans.Class++class Unpackable arg where+  data UnpackedReaderT arg :: (* -> *) -> * -> *+  runUnpackedReaderT :: UnpackedReaderT arg m a -> arg -> m a+  unpackedReaderT :: (arg -> m a) -> UnpackedReaderT arg m a++{-# INLINE ask #-}+ask :: (Monad m, Unpackable arg) => UnpackedReaderT arg m arg+ask = unpackedReaderT return++{-# INLINE local #-}+local :: (Monad m, Unpackable arg) => (arg -> arg) -> UnpackedReaderT arg m a -> UnpackedReaderT arg m a+local f m = unpackedReaderT $ runUnpackedReaderT m . f++instance Unpackable arg => MonadTrans (UnpackedReaderT arg) where+  {-# INLINE lift #-}+  lift m = unpackedReaderT $ \ _ -> m++instance (Unpackable arg, Monad m) => Monad (UnpackedReaderT arg m) where+  {-# INLINE return #-}+  {-# INLINE (>>=) #-}+  return x = lift $ return x+  m >>= k = unpackedReaderT $ \ arg ->+    do	a <- runUnpackedReaderT m arg+	runUnpackedReaderT (k a) arg++instance (Unpackable arg, Functor f) => Functor (UnpackedReaderT arg f) where+  {-# INLINE fmap #-}+  fmap f m = unpackedReaderT $ \ arg -> fmap f (runUnpackedReaderT m arg)++instance (Unpackable arg, Applicative f) => Applicative (UnpackedReaderT arg f) where+  {-# INLINE pure #-}+  {-# INLINE (<*>) #-}+  pure f = unpackedReaderT $ \ _ -> pure f+  f <*> x = unpackedReaderT $ \ arg -> runUnpackedReaderT f arg <*> runUnpackedReaderT x arg
+ Control/Monad/Unpack/TH.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+module Control.Monad.Unpack.TH (unpack1Instance, unpackInstance, noUnpackInstance) where++import Control.Monad+import Control.Monad.Unpack.Class++import Language.Haskell.TH++-- | Unpack wrappers around primitive types, like 'Int'.+unpack1Instance :: Name -> Q [Dec]+unpack1Instance tycon = do+  TyConI dec <- reify tycon+  case dec of+    DataD cxt _ tyvars [con] _ -> unpacker1 cxt tycon tyvars con+    dec -> error ("Cannot unpack: " ++ show dec)++-- | Unpack complicated but single-constructor types.+unpackInstance :: Name -> Q [Dec]+unpackInstance tycon = do+  TyConI dec <- reify tycon+  case dec of+    DataD cxt _ tyvars [con] _ -> unpacker cxt tycon tyvars con+    NewtypeD cxt _ tyvars con _ -> unpacker cxt tycon tyvars con+    dec -> error ("Cannot unpack: " ++ show dec)++-- | Do no unpacking at all.+noUnpackInstance :: Name -> Q [Dec]+noUnpackInstance tycon = do+  TyConI dec <- reify tycon+  case dec of+    DataD cxt _ tyvars _ _ -> noUnpacker cxt tycon tyvars+    NewtypeD cxt _ tyvars _ _ -> noUnpacker cxt tycon tyvars+    dec -> error ("Cannot unpack: " ++ show dec)++conArgs :: Con -> (Name, [Type])+conArgs (NormalC conName args) = (conName, map snd args)+conArgs (RecC conName args) = (conName, [ty | (_, _, ty) <- args])+conArgs (InfixC (_, ty1) conName (_, ty2)) = (conName, [ty1, ty2])+conArgs _ = undefined++tyVarBndrName  :: TyVarBndr -> Name+tyVarBndrName (PlainTV var) = var+tyVarBndrName (KindedTV var _) = var++unpacker1 :: Cxt -> Name -> [TyVarBndr] -> Con -> Q [Dec]+unpacker1 cxt tyCon tyArgs con = case conArgs con of+  (conName, conArgs) -> do+    argNames <- replicateM (length conArgs) (newName "arg")+    let theTy = foldl (\ t0 arg -> t0 `AppT` arg) (ConT tyCon) (map (VarT . tyVarBndrName) tyArgs)+    let inline = InlineSpec True False Nothing+    let pragmas =+	  [PragmaD $ InlineP (mkName "runUnpackedReaderT")+	    inline,+	  PragmaD $ InlineP (mkName "unpackedReaderT")+	    inline]+    funcName <- newName "UnpackedReaderT"+    mName <- newName "m"+    aName <- newName "a"+    fName <- newName "func"+    let decs = +	  [NewtypeInstD [] ''UnpackedReaderT [theTy, VarT mName, VarT aName]+	    (NormalC funcName [(NotStrict, foldr (\ argTy result -> ArrowT `AppT` argTy `AppT` result)+		  (VarT mName `AppT` VarT aName) conArgs)]) []] ++ pragmas ++ [+	    FunD 'runUnpackedReaderT+	      [Clause [ConP funcName [VarP fName], ConP conName (map VarP argNames)]+		(NormalB (foldl AppE (VarE fName) (map VarE argNames))) []],+	    FunD 'unpackedReaderT+	      [Clause [VarP fName] (NormalB $ ConE funcName `AppE`+		LamE (map VarP argNames) (VarE fName `AppE` (foldl AppE (ConE conName) (map VarE argNames)))) []]]+    return [InstanceD cxt (ConT ''Unpackable `AppT` theTy) decs]++unpacker :: Cxt -> Name -> [TyVarBndr] -> Con -> Q [Dec]+unpacker cxt tyCon tyArgs con = case conArgs con of+  (conName, conArgs) -> do+    argNames <- replicateM (length conArgs) (newName "arg")+    let theTy = foldl (\ t0 arg -> t0 `AppT` arg) (ConT tyCon) (map (VarT . tyVarBndrName) tyArgs)+    let inline = InlineSpec True False Nothing+    let pragmas =+	  [PragmaD $ InlineP (mkName "runUnpackedReaderT")+	    inline,+	  PragmaD $ InlineP (mkName "unpackedReaderT")+	    inline]+    funcName <- newName "UnpackedReaderT"+    mName <- newName "m"+    aName <- newName "a"+    fName <- newName "func"+    let monadStack = foldr (\ argTy stk -> ConT ''UnpackedReaderT `AppT` argTy `AppT` stk)+	  (VarT mName) conArgs+    let decs = +	  [NewtypeInstD [] ''UnpackedReaderT [theTy, VarT mName, VarT aName]+	    (NormalC funcName [(NotStrict, monadStack `AppT` VarT aName)]) []] ++ pragmas ++ [+	    FunD 'runUnpackedReaderT+	      [Clause [ConP funcName [VarP fName], ConP conName (map VarP argNames)]+		(NormalB (foldl (\ func arg -> InfixE (Just func) (VarE 'runUnpackedReaderT)+				  (Just arg))+		(VarE fName) (map VarE argNames))) []],+	    FunD 'unpackedReaderT+	      [Clause [VarP fName] (NormalB $ ConE funcName `AppE`+		foldr (\ argName func -> VarE 'unpackedReaderT+		  `AppE` LamE [VarP argName] func)+		  (VarE fName `AppE` (foldl AppE (ConE conName) (map VarE argNames)))+		  argNames) []]]+    return [InstanceD cxt (ConT ''Unpackable `AppT` theTy) decs]++noUnpacker :: Cxt -> Name -> [TyVarBndr] -> Q [Dec]+noUnpacker cxt tyCon tyArgs = do+    argName <- newName "arg"+    let theTy = foldl (\ t0 arg -> t0 `AppT` arg) (ConT tyCon) (map (VarT . tyVarBndrName) tyArgs)+    let inline = InlineSpec True False Nothing+    let pragmas =+	  [PragmaD $ InlineP (mkName "runUnpackedReaderT")+	    inline,+	  PragmaD $ InlineP (mkName "unpackedReaderT")+	    inline]+    funcName <- newName "UnpackedReaderT"+    mName <- newName "m"+    aName <- newName "a"+    fName <- newName "func"+    let decs = +	  [NewtypeInstD [] ''UnpackedReaderT [theTy, VarT mName, VarT aName]+	    (NormalC funcName [(NotStrict, ArrowT `AppT` theTy `AppT` (VarT mName `AppT` VarT aName))]) []] ++ pragmas ++ [+	    FunD 'runUnpackedReaderT+	      [Clause [ConP funcName [VarP fName], VarP argName]+		(NormalB (VarE fName `AppE` VarE argName)) []],+	    FunD 'unpackedReaderT+	      [Clause [VarP fName] (NormalB $ ConE funcName `AppE` VarE fName) []]]+    return [InstanceD cxt (ConT ''Unpackable `AppT` theTy) decs]
+ LICENSE view
@@ -0,0 +1,16 @@+Copyright (c) 2008, Louis Wasserman+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.+    * The name of Louis Wasserman may not 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.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ unpack-funcs.cabal view
@@ -0,0 +1,29 @@+name:		     unpack-funcs+version:             0.1.0+cabal-version:       >= 1.6+tested-with:	     GHC+category:            Control+synopsis:	     Monad transformers that mirror worker-wrapper transformations.+description:         Provides a typeclass and Template Haskell-driven instance generators that create "worker-wrapper"+                     @ReaderT@ monad transformers, which unpacks the arguments of single-constructor data types.+license:             BSD3+license-file:	     LICENSE+author:              Louis Wasserman+maintainer:          wasserman.louis@gmail.com+build-type:	     Simple++source-repository head+  type:              git+  location:          git@github.com:lowasser/unpack-funcs.git++Library{+build-Depends:    base < 5.0.0.0, template-haskell >= 2.5.0.0, bytestring >= 0.9.1.0,+                  vector >= 0.6, primitive >= 0.3, transformers+ghc-options:+  -Wall -fno-warn-name-shadowing -fno-warn-orphans+exposed-modules:  +  Control.Monad.Unpack,+  Control.Monad.Unpack.TH+other-modules:+  Control.Monad.Unpack.Class+}