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.2.0.0 +version: 0.2.1.0 synopsis: A generic version of Data.Maybe description: This module is a drop in replacement for 'Data.Maybe'. It generalizes @@ -39,12 +39,12 @@ flag test-doctests default: True manual: True - + -- You can disable the hlint test suite with -f-test-hlint -- Disabled until the LambdaCase extension is added src-exts flag test-hlint - default: False - manual: False + default: True + manual: True library exposed-modules: Generics.Maybe @@ -55,11 +55,13 @@ , MultiParamTypeClasses , FunctionalDependencies , FlexibleContexts - , LambdaCase , FlexibleInstances - , ConstraintKinds - build-depends: base >=4.6 && <4.7 + , ScopedTypeVariables + + build-depends: base >=4.5 && < 4.7 , lens >=3.10 && < 5.0 + , ghc-prim + hs-source-dirs: src default-language: Haskell2010 @@ -72,6 +74,9 @@ hs-source-dirs: tests default-language: Haskell2010 + if impl(ghc<7.6.1) + buildable: False + if !flag(test-doctests) buildable: False else @@ -100,7 +105,7 @@ test-suite hlint type: exitcode-stdio-1.0 main-is: hlint.hs - ghc-options: -w -threaded -rtsopts -with-rtsopts=-N +-- ghc-options: -w -threaded -rtsopts -with-rtsopts=-N hs-source-dirs: tests default-language: Haskell2010 @@ -110,3 +115,18 @@ build-depends: base, hlint >= 1.7 + +test-suite tasty + type: exitcode-stdio-1.0 + main-is: tasty.hs + hs-source-dirs: tests, src + default-language: Haskell2010 + + build-depends: base + , lens >= 3.10 && < 5.0 + , ghc-prim + , tasty >= 0.7 && < 0.8 + , tasty-th >= 0.1.1 && < 0.2 + , tasty-hunit >= 0.4.1 && < 0.5 + , HUnit >= 1.2 && < 1.3 + diff --git a/src/Generics/Maybe.hs b/src/Generics/Maybe.hs --- a/src/Generics/Maybe.hs +++ b/src/Generics/Maybe.hs @@ -17,9 +17,7 @@ After which you can use the function, like your type was 'Data.Maybe.Maybe' -} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -39,17 +37,17 @@ , mapMaybe -- * Exported for groking, but not for implementing. , MaybeLike - , G ) where import GHC.Generics - ( Generic(..), - U1(..), - K1(K1), - M1(..), - type (:+:)(..), - Rec0, - C1, - S1 ) + ( Generic(..) + , U1(..) + , K1(K1) + , M1(..) + , (:+:)(..) + , Rec0 + , C1 + , S1 + ) import Control.Lens ( Iso', Iso, over, iso, view ) import Generics.Deriving.Lens ( generic ) import qualified Control.Lens.Iso as Iso @@ -90,7 +88,7 @@ fromMaybe' :: a -> (U1 :+: Rec0 a) b -> a -fromMaybe' def = \case +fromMaybe' def e = case e of L1 U1 -> def R1 (K1 x) -> x -- | A generalized version of 'Data.Maybe.maybe' @@ -119,7 +117,7 @@ maybe def f = maybe' def f . view gsimple maybe' :: b -> (a -> b) -> (U1 :+: Rec0 a) x -> b -maybe' def f = \case +maybe' def f e = case e of L1 U1 -> def R1 (K1 x) -> f x @@ -150,7 +148,7 @@ isJust = isJust' . view (gsimple :: Iso' maybe ((U1 :+: Rec0 a) p)) isJust' :: (U1 :+: Rec0 a) b -> Bool -isJust' = \case +isJust' e = case e of L1 {} -> False R1 {} -> True @@ -181,7 +179,7 @@ isNothing = isNothing' . view (gsimple :: Iso' maybe ((U1 :+: Rec0 a) p)) isNothing' :: (U1 :+: Rec0 a) b -> Bool -isNothing' = \case +isNothing' e = case e of L1 {} -> True R1 {} -> False @@ -240,7 +238,7 @@ listToMaybe = view (Iso.from gsimple) . listToMaybe' listToMaybe' :: [a] -> (U1 :+: Rec0 a) b -listToMaybe' = \case +listToMaybe' e = case e of x:_ -> R1 $ K1 x [] -> L1 U1 @@ -270,7 +268,7 @@ maybeToList = maybeToList' . view gsimple maybeToList' :: (U1 :+: Rec0 a) b -> [a] -maybeToList' = \case +maybeToList' e = case e of L1 {} -> [] R1 (K1 x) -> [x] @@ -320,45 +318,55 @@ -- Utils ------------------------------------------------------------------------------- --- | A silly type synonym to make the signatures look better. --- None of the type variables matter except @any@. --- Read @G@eneric maybe -type G m a y b e any = M1 m a (C1 y U1 :+: C1 b (S1 e (Rec0 any))) - m1 :: Iso (M1 i c f p) (M1 i' c' f' p') (f p) (f' p') m1 = iso unM1 M1 commuteSum :: (f :+: g) p -> (g :+: f) p -commuteSum = \case +commuteSum e = case e of L1 x -> R1 x R1 x -> L1 x --- | This class is used internally to get the GHC.Generic Rep into --- a uniform form. --- There are only two instances and no more should be made +-- | This type class is used to swap the order of constructors so +-- unit shows up first. +-- +-- > (M1 m a (C1 b (S1 e (Rec0 any)) :+: C1 y U1)) +-- +-- will become +-- +-- > (M1 m a (C1 y U1 :+: C1 b (S1 e (Rec0 any)))) +-- +-- and +-- +-- > (M1 m a (C1 y U1 :+: C1 b (S1 e (Rec0 any)))) +-- +-- is unchanged +-- +-- Thus, there are only two instances and should only be, forever +-- and always ... I think. class MaybeLike rep any | rep -> any where maybelike :: Iso' (rep p) ((U1 :+: Rec0 any) p) - -instance MaybeLike (G m a y b e any) any where + +instance MaybeLike (M1 m a (C1 y U1 :+: C1 b (S1 e (K1 k any)))) any where maybelike = clean -instance MaybeLike (M1 m a (C1 b (S1 e (Rec0 any)) :+: C1 y U1)) any where +instance MaybeLike (M1 m a (C1 b (S1 e (K1 k any)) :+: C1 y U1)) any where maybelike = iso invo invo . clean where invo = over m1 commuteSum -- Get rid of all the meta info -clean :: Iso (G m a y b e any p) - (G m' a' y' b' e' any' p') +clean :: Iso ((M1 m a (C1 y U1 :+: C1 b (S1 e (K1 k any )))) p) + ((M1 m' a' (C1 y' U1 :+: C1 b' (S1 e' (K1 k any')))) p') ((U1 :+: Rec0 any) p) ((U1 :+: Rec0 any') p') clean = iso fw bk where fw (M1 x) = case x of - L1 (M1 l) -> L1 l - R1 (M1 (M1 r)) -> R1 r - bk = \case - L1 l -> M1 $ L1 $ M1 $ l - R1 r -> M1 $ R1 $ M1 $ M1 $ r + L1 (M1 l) -> L1 l + R1 (M1 (M1 (K1 r))) -> R1 $ K1 r + bk e = case e of + L1 l -> M1 $ L1 $ M1 l + R1 (K1 r) -> M1 $ R1 $ M1 $ M1 $ K1 r + -- Convert to the simplified generic form gsimple :: ( Generic maybe diff --git a/tests/tasty.hs b/tests/tasty.hs new file mode 100644 --- /dev/null +++ b/tests/tasty.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +module Main where +import Test.Tasty +import Test.Tasty.TH +import Test.Tasty.HUnit +import Test.HUnit +import Generics.Maybe +import Prelude hiding (maybe) +import GHC.Generics +import Control.Exception +import Control.Monad + +main :: IO () +main = $(defaultMainGenerator) + +data Nat = Zero | Succ Nat deriving (Eq, Show, Generic) +data Result a = Success a | Fail deriving (Eq, Show, Generic) + +case_fromMaybe_Nothing = fromMaybe 'a' Nothing @?= 'a' + +case_fromMaybe_Just = fromMaybe 'a' (Just 'b') @?= 'b' + +case_fromMaybe_Fail = fromMaybe 'a' Fail @?= 'a' + +case_fromMaybe_Success = fromMaybe 'a' (Success 'b') @?= 'b' + +case_fromMaybe_Zero = fromMaybe Zero Zero @?= Zero + +case_fromMaybe_Succ = fromMaybe Zero (Succ (Succ Zero)) @?= Succ Zero + + +case_maybe_Nothing = maybe (1 :: Int) (+1) Nothing @?= 1 + +case_maybe_Just = maybe 1 (+1) (Just 1) @?= 2 + +case_maybe_Fail = maybe (1 :: Int) (+1) Fail @?= 1 + +case_maybe_Success = maybe 1 (+1) (Success 1) @?= 2 + +case_maybe_Zero = maybe (Succ Zero) Succ Zero @?= Succ Zero + +case_maybe_Succ = maybe (Succ Zero) Succ (Succ (Succ Zero)) + @?= Succ (Succ Zero) + +case_isJust_Nothing = isJust Nothing @?= False + +case_isJust_Just = isJust (Just 'a') @?= True + +case_isJust_Fail = isJust Fail @?= False + +case_isJust_Successs = isJust (Success 'a') @?= True + +case_isJust_Zero = isJust Zero @?= False + +case_isJust_Succ = isJust (Succ Zero) @?= True + +case_isNothing_Nothing = isNothing Nothing @?= True + +case_isNothing_Just = isNothing (Just 'a') @?= False + +case_isNothing_Fail = isNothing Fail @?= True + +case_isNothing_Success = isNothing (Success 'a') @?= False + +case_isNothing_Zero = isNothing Zero @?= True + +case_isNothing_Succ = isNothing (Succ Zero) @?= False + +assertException :: Show a => a -> IO () +assertException a = handle (\(SomeException e) -> return ()) + $ assertFailure $ "Expected exception: " ++ show a + +case_fromJust_Nothing = assertException (fromJust Nothing :: Char) + +case_fromJust_Just = fromJust (Just 'a') @?= 'a' + +case_fromJust_Fail = assertException (fromJust Fail :: Char) + +case_fromJust_Success = fromJust (Success 'a') @?= 'a' + +case_fromJust_Zero = assertException (fromJust Zero :: Nat) + +case_fromJust_Succ = fromJust (Succ Zero) @?= Zero + +case_listToMaybe_NonEmpty_Maybe = listToMaybe ['a', 'b'] @?= Just 'a' + +case_listToMaybe_Empty_Maybe = listToMaybe ([] :: [Char]) @?= Nothing + +case_listToMaybe_NonEmpty_Result = listToMaybe ['a', 'b'] @?= Success 'a' + +case_listToMaybe_Empty_Result = listToMaybe ([] :: [Char]) @?= Fail + +case_listToMaybe_NonEmpty_Nat = listToMaybe [Zero, Succ Zero] @?= Succ Zero + +case_listToMaybe_Empty_Nat = listToMaybe ([] :: [Nat]) @?= Zero + +case_maybeToList_Just = maybeToList (Just True) @?= [True] + +case_maybeToList_Nothing = maybeToList Nothing @?= ([] :: [Bool]) + +case_maybeToList_Success = maybeToList (Success True) @?= [True] + +case_maybeToList_Fail = maybeToList Fail @?= ([] :: [Bool]) + +case_maybeToList_Succ = maybeToList (Succ Zero) @?= [Zero] + +case_maybeToList_Zero = maybeToList Zero @?= [] + +case_catMaybes_Maybe = catMaybes [Just True, Nothing, Just False] + @?= [True,False] + +case_catMaybes_Result = catMaybes [Success True, Fail, Success False] + @?= [True,False] + +case_catMaybes_Nat = catMaybes [Succ Zero, Zero, Succ Zero] + @?= [Zero,Zero] + +case_mapMaybe_Maybe + = mapMaybe (\x -> if x then Just "True" else Nothing) [True, False, True] + @?= ["True","True"] + +case_mapMaybe_Result + = mapMaybe (\x -> if x then Success "True" else Fail) [True, False, True] + @?= ["True","True"] + +case_mapMaybe_Nat + = mapMaybe (\x -> if x then Succ Zero else Zero) [True, False, True] + @?= [Zero,Zero] + +