diff --git a/benchmarks/Reference.hs b/benchmarks/Reference.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Reference.hs @@ -0,0 +1,14 @@ +module Main where +import Criterion.Main +import Data.Generics.Maybe +import qualified Data.Maybe as M + +main :: IO () +main = defaultMain + [ bgroup "Generic" + [ bench "fromMaybe Nothing" $ whnf (fromMaybe ()) Nothing + ] + , bgroup "Data" + [ bench "fromMaybe Nothing" $ whnf (M.fromMaybe ()) Nothing + ] + ] diff --git a/generic-maybe.cabal b/generic-maybe.cabal --- a/generic-maybe.cabal +++ b/generic-maybe.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: generic-maybe -version: 0.3.0.1 +version: 0.3.0.2 synopsis: A generic version of Data.Maybe description: This module is a drop in replacement for 'Data.Maybe'. It generalizes @@ -127,3 +127,14 @@ , tasty-hunit >= 0.4.1 && < 0.5 , HUnit >= 1.2 && < 1.3 +benchmark bench-builder-all + type: exitcode-stdio-1.0 + hs-source-dirs: src, benchmarks + main-is: Reference.hs + build-depends: base + , deepseq + , criterion + ghc-options: -O2 + -fmax-simplifier-iterations=10 + -fdicts-cheap + -fspec-constr-count=6 diff --git a/src/Data/Generics/Maybe.hs b/src/Data/Generics/Maybe.hs --- a/src/Data/Generics/Maybe.hs +++ b/src/Data/Generics/Maybe.hs @@ -24,7 +24,8 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} module Data.Generics.Maybe - ( fromMaybe + ( -- * Data.Maybe Functions + fromMaybe , maybe , isJust , isNothing @@ -33,6 +34,8 @@ , maybeToList , catMaybes , mapMaybe + -- * Convert between Maybelikes + , convert -- * Exported for groking, but not for implementing. , MaybeLike ) where @@ -309,29 +312,51 @@ case f x of L1 {} -> ys R1 (K1 y) -> y:ys + ------------------------------------------------------------------------------- -- Utils ------------------------------------------------------------------------------- +-- | Convert between two Maybelikes +-- +-- >>> convert (Just 'a') :: Result Char +-- Success 'a' +-- +-- >>> convert (Success 'a') :: Maybe Char +-- Just 'a' +-- +-- >>> convert (Success Zero) :: Nat +-- Succ Zero +convert :: (Generic maybe1, MaybeLike (Rep maybe1) a, Generic maybe2, MaybeLike (Rep maybe2) a) + => maybe1 -> maybe2 +convert = to . fromMaybelike . toMaybelike . from +------------------------------------------------------------------------------- +-- Utils +------------------------------------------------------------------------------- + commuteInto :: (M1 m a (f :+: g)) p -> (M1 m a (g :+: f)) p -commuteInto = M1 . commuteSum . unM1 +commuteInto x = M1 $ commuteSum $ unM1 x +{-# INLINE commuteInto #-} commuteSum :: (f :+: g) p -> (g :+: f) p commuteSum e = case e of L1 x -> R1 x R1 x -> L1 x +{-# INLINE commuteSum #-} toClean :: M1 t t1 (M1 t2 t3 f :+: M1 t4 t5 (M1 t6 t7 (K1 t8 c))) p -> (:+:) f (K1 i c) p toClean (M1 x) = case x of L1 (M1 l) -> L1 l R1 (M1 (M1 (K1 r))) -> R1 $ K1 r +{-# INLINE toClean #-} fromClean :: (:+:) f (K1 t c4) p -> M1 i c (M1 i1 c1 f :+: M1 i2 c2 (M1 i3 c3 (K1 i4 c4))) p fromClean e = case e of L1 l -> M1 $ L1 $ M1 l R1 (K1 r) -> M1 $ R1 $ M1 $ M1 $ K1 r +{-# INLINE fromClean #-} -- | This type class is used to swap the order of constructors so -- unit shows up first. @@ -356,17 +381,27 @@ instance MaybeLike (M1 m a (C1 y U1 :+: C1 b (S1 e (K1 k any)))) any where toMaybelike = toClean + {-# INLINE toMaybelike #-} +-- {-# SPECIALIZE toMaybelike :: (M1 m a (C1 y U1 :+: C1 b (S1 e (K1 k any)))) p -> (U1 :+: Rec0 any) p #-} fromMaybelike = fromClean + {-# INLINE fromMaybelike #-} +-- {-# SPECIALIZE fromMaybelike :: (U1 :+: Rec0 any) p -> (M1 m a (C1 y U1 :+: C1 b (S1 e (K1 k any)))) p #-} instance MaybeLike (M1 m a (C1 b (S1 e (K1 k any)) :+: C1 y U1)) any where toMaybelike = toClean . commuteInto + {-# INLINE toMaybelike #-} +-- {-# SPECIALIZE toMaybelike :: (M1 m a (C1 b (S1 e (K1 k any)) :+: C1 y U1)) p -> (U1 :+: Rec0 any) p #-} fromMaybelike = commuteInto . fromClean + {-# INLINE fromMaybelike #-} +-- {-# SPECIALIZE fromMaybelike :: (U1 :+: Rec0 any) p ->(M1 m a (C1 b (S1 e (K1 k any)) :+: C1 y U1)) p #-} toGSimple :: (Generic maybe, MaybeLike (Rep maybe) a) => maybe -> (U1 :+: Rec0 a) p toGSimple = toMaybelike . from +{-# INLINE toGSimple #-} fromGSimple :: (Generic maybe, MaybeLike (Rep maybe) a) => (U1 :+: Rec0 a) p -> maybe fromGSimple = to . fromMaybelike +{-# INLINE fromGSimple #-} diff --git a/tests/tasty.hs b/tests/tasty.hs --- a/tests/tasty.hs +++ b/tests/tasty.hs @@ -11,6 +11,7 @@ import Control.Exception import Control.Monad import Control.DeepSeq +import qualified Data.Maybe as M isLeft x = case x of { Left {} -> True; Right {} -> True } @@ -140,5 +141,53 @@ case_mapMaybe_Nat = mapMaybe (\x -> if x then Succ Zero else Zero) [True, False, True] @?= [Zero,Zero] + +case_convert_Just + = convert (Just 'a') @?= Success 'a' + +case_convert_Success + = convert (Success 'a') @?= Just 'a' + +case_convert_Nat + = convert (Success Zero) @?= Succ Zero + +-- Check against Data.Maybe +case_fromMaybe_Ref_Nothing = + fromMaybe 'a' Nothing @?= M.fromMaybe 'a' Nothing + +case_fromMaybe_Ref_Just = + fromMaybe 'a' (Just 'b') @?= M.fromMaybe 'a' (Just 'b') + +case_maybe_Ref_Nothing = + maybe (1 :: Int) (+1) Nothing @?= M.maybe (1 :: Int) (+1) Nothing + +case_maybe_Ref_Just = + maybe (1 :: Int) (+1) (Just 1) @?= M.maybe (1 :: Int) (+1) (Just 1) + +case_listToMaybe_Ref_Empty = + listToMaybe ([] :: [Char]) @?= M.listToMaybe [] + +case_listToMaybe_Ref_NonEmpty = + listToMaybe ['a', 'b'] @?= M.listToMaybe ['a', 'b'] + +case_maybeToList_Ref_Nothing = + maybeToList (Nothing :: Maybe Char) @?= M.maybeToList Nothing + +case_maybeToList_Ref_Just = + maybeToList (Just 'a') @?= M.maybeToList (Just 'a') + +case_catMaybes_Ref + = catMaybes [Just 'a', Nothing, Just 'b'] + @?= M.catMaybes [Just 'a', Nothing, Just 'b'] + +case_mapMaybe_Ref + = mapMaybe (\x -> if x then Just "True" else Nothing) [True, False, True] + @?= M.mapMaybe (\x -> if x then Just "True" else Nothing) [True, False, True] + + + + + +