countable 0.2 → 1.0

raw patch · 9 files changed

+291/−30 lines, 9 filesdep +bytestringdep +countabledep +silentlydep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, countable, silently, tasty, tasty-golden, tasty-hunit

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• countable.cabal +30/−4
• src/Data/Empty.hs +11/−10
• src/Data/Expression.hs +16/−14
• src/Data/Searchable.hs +2/−2
• test/Count.hs +118/−0
• test/Golden.hs +22/−0
• test/Show.hs +7/−0
• test/Three.hs +34/−0
• test/TypeName.hs +51/−0

@@ -1,6 +1,6 @@ cabal-version:  >=1.14 name:           countable-version:        0.2+version:        1.0 x-follows-version-policy: license:        BSD3 license-file:   LICENSE@@ -39,14 +39,40 @@  library     hs-source-dirs: src-    default-language: Haskell98+    default-language: Haskell2010     default-extensions:-        EmptyDataDecls         ExistentialQuantification-    build-depends: base ==4.*+        EmptyCase+    build-depends:+        base >= 4.8 && < 5     exposed-modules:         Data.Expression         Data.Searchable         Data.Countable         Data.Empty+    ghc-options: -Wall++test-suite tests+    type: exitcode-stdio-1.0+    hs-source-dirs: test+    default-language: Haskell2010+    default-extensions:+        ExistentialQuantification+        EmptyCase+        GeneralizedNewtypeDeriving+        ScopedTypeVariables+    build-depends:+        base >= 4.8 && < 5,+        countable,+        bytestring,+        silently,+        tasty,+        tasty-hunit,+        tasty-golden+    main-is: Count.hs+    other-modules:+        Show+        TypeName+        Three+        Golden     ghc-options: -Wall

@@ -2,12 +2,10 @@ {     import Data.Countable;     import Data.Searchable;-    import Control.Applicative;      class (Finite n) => Empty n where     {         never :: n -> a;-        never n = seq n undefined;     };      instance (Empty a,Empty b) => Empty (Either a b) where@@ -26,39 +24,42 @@         never ab = never (ab countFirst);     }; -    data Nothing;+    data None; -    instance Countable Nothing where+    instance Countable None where     {         countPrevious = never;         countMaybeNext Nothing = Nothing;         countMaybeNext (Just n) = never n;     }; -    instance Searchable Nothing where+    instance Searchable None where     {         search = finiteSearch;     }; -    instance Finite Nothing where+    instance Finite None where     {         allValues = [];         assemble _ = pure never;     }; -    instance Empty Nothing;+    instance Empty None where+    {+        never a = case a of {};+    }; -    instance Eq Nothing where+    instance Eq None where     {         a == _b = never a;     }; -    instance Ord Nothing where+    instance Ord None where     {         a <= _b = never a;     }; -    instance Show Nothing where+    instance Show None where     {         show a = never a;     };

@@ -1,30 +1,32 @@-module Data.Expression (Expression(..),expressionSym,runExpression) where+module Data.Expression (Expression(..),expressionSym,runValueExpression,runMatchExpression) where {-    import Control.Applicative;--    data Expression a b f r = ClosedExpression (f r) | OpenExpression a (Expression a b f (b -> r));+    data Expression a g f r = ClosedExpression (f r) | OpenExpression a (Expression a g f (g r)); -    instance (Functor f) => Functor (Expression a b f) where+    instance (Functor f, Functor g) => Functor (Expression a g f) where     {         fmap pq (ClosedExpression fp) = ClosedExpression (fmap pq fp);-        fmap pq (OpenExpression a ebp) = OpenExpression a (fmap (\bp -> pq . bp) ebp);+        fmap pq (OpenExpression a egp) = OpenExpression a (fmap (fmap pq) egp);     }; -    ffmap :: (Applicative f) => f (p -> q) -> Expression a b f p -> Expression a b f q;+    ffmap :: (Applicative f, Functor g) => f (p -> q) -> Expression a g f p -> Expression a g f q;     ffmap fpq (ClosedExpression fp) = ClosedExpression (fpq <*> fp);-    ffmap fpq (OpenExpression a ebp) = OpenExpression a (ffmap (fmap (\pq bp -> pq . bp) fpq) ebp);+    ffmap fpq (OpenExpression a ebp) = OpenExpression a (ffmap (fmap fmap fpq) ebp); -    instance (Applicative f) => Applicative (Expression a b f) where+    instance (Applicative f, Functor g) => Applicative (Expression a g f) where     {         pure t = ClosedExpression (pure t);         (ClosedExpression fpq) <*> ep = ffmap fpq ep;-        (OpenExpression a ebpq) <*> ep = OpenExpression a ((fmap (\bpq p b -> bpq b p) ebpq) <*> ep);+        (OpenExpression a egpq) <*> ep = OpenExpression a ((\p -> fmap (\pq -> pq p)) <$> ep <*> egpq);     }; -    expressionSym :: a -> f (b -> r) -> Expression a b f r;+    expressionSym :: a -> f (g r) -> Expression a g f r;     expressionSym a fbr = OpenExpression a (ClosedExpression fbr); -    runExpression :: (Functor f) => Expression a b f r -> f ((a -> b) -> r);-    runExpression (ClosedExpression fr) = fmap (\r _ab -> r) fr;-    runExpression (OpenExpression a0 ebr) = fmap (\abbr ab -> abbr ab (ab a0)) (runExpression ebr);+    runValueExpression :: (Functor f) => Expression a ((->) b) f r -> f ((a -> b) -> r);+    runValueExpression (ClosedExpression fr) = fmap (\r _ab -> r) fr;+    runValueExpression (OpenExpression a0 ebr) = fmap (\abbr ab -> abbr ab (ab a0)) (runValueExpression ebr);++    runMatchExpression :: (Functor f) => Expression a ((,) b) f r -> f ([(a,b)],r);+    runMatchExpression (ClosedExpression fr) = fmap (\r -> ([],r)) fr;+    runMatchExpression (OpenExpression a ebr) = fmap (\(ab,(b,r)) -> ((a,b):ab,r)) (runMatchExpression ebr); }

@@ -107,7 +107,7 @@         ;         allValues :: [a]; -        assemble :: (Applicative f) => (a -> f b) -> f (a -> b);+        assemble :: forall b f. (Applicative f) => (a -> f b) -> f (a -> b);         assemble afb = fmap listLookup (traverse (\a -> fmap (\b -> (a,b)) (afb a)) allValues) where         {             -- listLookup :: [(a,b)] -> a -> b;@@ -337,7 +337,7 @@     instance (Finite a,Finite b) => Finite (a -> b) where     {         allValues = sequenceA (\_ -> allValues);-        assemble abfr = runExpression (Data.Foldable.foldr assemble1 (\ab -> ClosedExpression (abfr ab)) allValues (\_ -> error "missing value")) where+        assemble abfr = runValueExpression (Data.Foldable.foldr assemble1 (\ab -> ClosedExpression (abfr ab)) allValues (\_ -> error "missing value")) where         {             -- assemble1 :: a -> ((a -> b) -> Expression a b f r) -> (a -> b) -> Expression a b f r             assemble1 a0 aber x = OpenExpression a0 (assemble (\b0 -> aber (\a -> if a == a0 then b0 else x a)))

@@ -0,0 +1,118 @@+module Main where+{+    import Prelude;+    import Data.Proxy;+    import Data.Word;+    import Test.Tasty;+    import Test.Tasty.HUnit;++    import Data.Empty;+    import Data.Searchable;+    import Data.Countable;++    import Show;+    import TypeName;+    import Three;+    import Golden;++    (@/=?) :: (Eq a,Show a) => a -> a -> Assertion;+    unexpected @/=? actual | unexpected /= actual = return ();+    _unexpected @/=? actual = assertFailure $ "got unexpected " ++ show actual;++    prevMaybeNext :: (Countable a,Show a) => Maybe a -> Assertion;+    prevMaybeNext ma = case countMaybeNext ma of+    {+        Just a' -> countPrevious a' @=? ma;+        Nothing -> return ();+    };++    countableTests' :: (Show a,Countable a) => a -> [TestTree];+    countableTests' a =+    [+        testCase "maybeNextDifferent" $ (Just a) @/=? countMaybeNext (Just a),+        testCase "prevDifferent" $ (Just a) @/=? (countPrevious a),+        testCase "maybeNextPrev" $ (Just a) @=? countMaybeNext (countPrevious a),+        testCase "prevMaybeNext" $ prevMaybeNext (Just a)+    ];++    findInNext :: (Countable a) => Int -> a -> TestTree;+    findInNext n a = testCase "findInNext" $ findInNext' n Nothing where+    {+        findInNext' 0 _ = assertFailure "failed";+        findInNext' _ (Just x) | x == a = return ();+        findInNext' n' mx = case countMaybeNext mx of+        {+            Nothing -> assertFailure "failed";+            mx' -> findInNext' (n' - 1) mx';+        };+    };++    countableTests :: (Show a,Countable a) => a -> [TestTree];+    countableTests a = (countableTests' a) ++ [findInNext 1000 a];++    nextIsMaybeNext :: (Show a,InfiniteCountable a) => Maybe a -> TestTree;+    nextIsMaybeNext ma = testCase "nextIsMaybeNext" $ (Just (countNext ma)) @=? (countMaybeNext ma);++    infiniteCountableTests :: (Show a,InfiniteCountable a) => a -> [TestTree];+    infiniteCountableTests a = (countableTests a) ++ [nextIsMaybeNext (Just a)];+    checkN :: (Show a,Countable a) => (String -> IO ()) -> Int -> Maybe a -> IO ();+    checkN _ 0 _ = return ();+    checkN write n ma = let+    {+        ma' = countMaybeNext ma;+    } in do+    {+        prevMaybeNext ma;+        write (show ma ++ "\n");+        case ma' of+        {+            Nothing -> return ();+            _ -> checkN write (n - 1) ma';+        };+    };++    testType :: forall a. (TypeName a,Show a) => (a -> [TestTree]) -> [a] -> TestTree;+    testType tests vals = testGroup (typeName (Proxy::Proxy a)) $ fmap (\a -> testGroup (show a) (tests a)) vals;++    -- This is to prevent overlapping Show function instance in Text.Show.Functions,+    -- which gets imported somehow with lts-5.+    newtype WrapFunction a b = MkWrapFunction (a -> b) deriving (Eq,Searchable,Countable,TypeName);+    instance (Show a,Finite a,Show b) => Show (WrapFunction a b) where+    {+        show (MkWrapFunction f) = showFunction f;+    };+    instance (Finite a,Finite b) => Finite (WrapFunction a b) where+    {+        allValues = fmap MkWrapFunction allValues;+        assemble wabfx = let+            foo abx (MkWrapFunction ab) = abx ab;+            in fmap foo $ assemble (wabfx . MkWrapFunction);+    };++    allTests :: TestTree;+    allTests = testGroup "countable"+        [+        testType countableTests (allValues :: [()]),+        testType countableTests (allValues :: [Bool]),+        testType countableTests ([0,3,255] :: [Word8]),+        testType countableTests (allValues :: [Maybe ()]),+        testType countableTests (allValues :: [Maybe Bool]),+        testType countableTests (allValues :: [Maybe (Maybe Bool)]),+        testType countableTests ([[],[0],[2],[-1,1],[0,0,0]] :: [[Integer]]),+        testType countableTests' ([[1,2,1],[-5,17,112]] :: [[Integer]]),+        testType countableTests ([[],[True,True]] :: [[Bool]]),+        testType infiniteCountableTests ([0,1,-1,3,-7] :: [Integer]),+        testType countableTests (allValues :: [WrapFunction Three Three]),+        testType countableTests (allValues :: [None]),+        testType countableTests ([[] :: [None]]),+        testGroup "list"+            [+            goldenVsWriteString "Bool"    "test/count.Bool.ref"    $ \write -> checkN write 40 (Nothing :: Maybe [Bool   ]),+            goldenVsWriteString "Word8"   "test/count.Word8.ref"   $ \write -> checkN write 40 (Nothing :: Maybe [Word8  ]),+            goldenVsWriteString "Integer" "test/count.Integer.ref" $ \write -> checkN write 40 (Nothing :: Maybe [Integer])+            ]+        ];++    main :: IO ();+    main = defaultMain allTests;+}

@@ -0,0 +1,22 @@+module Golden where+{+    import Data.IORef;+    import Data.ByteString.Builder;+    import Data.ByteString.Lazy.Char8;+    import Test.Tasty;+    import Test.Tasty.Golden;++    accumulate :: Monoid a => ((a -> IO ()) -> IO r) -> IO a;+    accumulate f = do+    {+        ref <- newIORef mempty;+        _ <- f $ \a1 -> modifyIORef ref (\a0 -> mappend a0 a1);+        readIORef ref;+    };++    goldenVsWrite :: TestName -> FilePath -> ((ByteString -> IO ()) -> IO a) -> TestTree;+    goldenVsWrite name path action = goldenVsString name path $ fmap toLazyByteString $ accumulate $ \write -> action (write . lazyByteString);++    goldenVsWriteString :: TestName -> FilePath -> ((String -> IO ()) -> IO a) -> TestTree;+    goldenVsWriteString name path action = goldenVsWrite name path $ \write -> action (write . pack);+}

@@ -0,0 +1,7 @@+module Show where+{+    import Data.Searchable;++    showFunction :: (Show a,Finite a,Show b) => (a -> b) -> String;+    showFunction f = show f;+}

@@ -0,0 +1,34 @@+module Three where+{+    import Data.Searchable;+    import Data.Countable;+    import TypeName;++    data Three = T1 | T2 | T3 deriving (Eq,Show);++    instance Searchable Three where+    {+        search = finiteSearch;+    };++    instance Countable Three where+    {+        countPrevious = finiteCountPrevious;+        countMaybeNext = finiteCountMaybeNext;+    };++    instance AtLeastOneCountable Three where+    {+        countFirst = T1;+    };++    instance Finite Three where+    {+        allValues = [T1,T2,T3];+    };++    instance TypeName Three where+    {+        typeName _ = "Three";+    };+}

@@ -0,0 +1,51 @@+module TypeName where+{+    import Data.Proxy;+    import Data.Word;+    import Data.Empty;++    class TypeName a where+    {+        typeName :: Proxy a -> String;+    };++    instance TypeName None where+    {+        typeName _ = "None";+    };++    instance TypeName () where+    {+        typeName _ = "()";+    };++    instance TypeName Bool where+    {+        typeName _ = "Bool";+    };++    instance TypeName Word8 where+    {+        typeName _ = "Word8";+    };++    instance TypeName Integer where+    {+        typeName _ = "Integer";+    };++    instance TypeName a => TypeName (Maybe a) where+    {+        typeName _ = "Maybe " ++ (typeName (Proxy :: Proxy a));+    };++    instance TypeName a => TypeName [a] where+    {+        typeName _ = "[" ++ (typeName (Proxy :: Proxy a)) ++ "]";+    };++    instance (TypeName a,TypeName b) => TypeName (a -> b) where+    {+        typeName _ = (typeName (Proxy :: Proxy a)) ++ "->" ++ (typeName (Proxy :: Proxy b));+    };+}