packages feed

countable 1.0 → 1.1

raw patch · 13 files changed

+777/−1008 lines, 13 filesdep ~basesetup-changed

Dependency ranges changed: base

Files

LICENSE view
@@ -3,8 +3,10 @@  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.+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. -- Neither name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.+2. 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. -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.+3. Neither the name of the copyright holder nor the names of its contributors may 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 HOLDER 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.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
countable.cabal view
@@ -1,78 +1,62 @@-cabal-version:  >=1.14+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack+ name:           countable-version:        1.0-x-follows-version-policy:-license:        BSD3-license-file:   LICENSE-copyright:      Ashley Yakeley <ashley@semantic.org>-author:         Ashley Yakeley <ashley@semantic.org>-maintainer:     Ashley Yakeley <ashley@semantic.org>-homepage:       https://github.com/AshleyYakeley/countable-bug-reports:    https://github.com/AshleyYakeley/countable/issues+version:        1.1 synopsis:       Countable, Searchable, Finite, Empty classes-description:-    * @class Countable@, for countable types-    .-    * @class AtLeastOneCountable@, for countable types that have at least one value-    .-    * @class InfiniteCountable@, for infinite countable types-    .-    * @class Searchable@, for types that can be searched over. This turns out to include some infinite types, see <http://math.andrej.com/2007/09/28/seemingly-impossible-functional-programs/>.-    .-    * @class Finite@, for finite types-    .-    * @class Empty@, for empty types-    .-    * @data Nothing@, an empty type-    .-    Some orphan instances:-    .-    * @(Searchable a,Eq b) => Eq (a -> b)@ / /-    .-    * @(Finite t) => Foldable ((->) t)@ / /-    .-    * @(Finite a) => Traversable ((->) a)@ / /-    .-    * @(Show a,Finite a,Show b) => Show (a -> b)@ / /+description:     * @class Countable@, for countable types . * @class AtLeastOneCountable@, for countable types that have at least one value . * @class InfiniteCountable@, for infinite countable types . * @class Searchable@, for types that can be searched over. This turns out to include some infinite types, see <http://math.andrej.com/2007/09/28/seemingly-impossible-functional-programs/>. . * @class Finite@, for finite types . * @class Singular@, for singular (n = 1) types . * @class Empty@, for empty (n = 0) types . * @data Nothing@, an empty type . Some orphan instances: . * @(Searchable a,Eq b) => Eq (a -> b)@ / / . * @(Finite t) => Foldable ((->) t)@ / / . * @(Finite a) => Traversable ((->) a)@ / / . * @(Show a,Finite a,Show b) => Show (a -> b)@ / / category:       Data+homepage:       https://github.com/AshleyYakeley/countable+bug-reports:    https://github.com/AshleyYakeley/countable/issues+author:         Ashley Yakeley+maintainer:     <ashley@semantic.org>+copyright:      (c) 2010 Ashley Yakeley+license:        BSD-3-Clause+license-file:   LICENSE build-type:     Simple  library-    hs-source-dirs: src-    default-language: Haskell2010-    default-extensions:-        ExistentialQuantification-        EmptyCase-    build-depends:-        base >= 4.8 && < 5-    exposed-modules:-        Data.Expression-        Data.Searchable-        Data.Countable-        Data.Empty-    ghc-options: -Wall+  exposed-modules:+      Data.Searchable+      Data.Countable+      Data.Singular+      Data.Empty+  other-modules:+      Data.Expression+  hs-source-dirs:+      src+  default-extensions:+      EmptyCase+      ExistentialQuantification+  ghc-options: -Wall+  build-depends:+      base >=4.15 && <5+  default-language: Haskell2010 -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+test-suite test+  type: exitcode-stdio-1.0+  main-is: Count.hs+  other-modules:+      Show+      TypeName+      Three+      Golden+  hs-source-dirs:+      test+  default-extensions:+      EmptyCase+      ExistentialQuantification+      GeneralizedNewtypeDeriving ScopedTypeVariables+  ghc-options: -Wall+  build-depends:+      base >=4.15 && <5+    , bytestring+    , countable+    , silently+    , tasty+    , tasty-golden+    , tasty-hunit+  default-language: Haskell2010
src/Data/Countable.hs view
@@ -1,423 +1,307 @@ module Data.Countable where-{-    import Data.Word;-    import Data.Int;-    import Prelude; -    class (Eq a) => Countable a where-    {-        countPrevious :: a -> Maybe a;-        countMaybeNext :: Maybe a -> Maybe a;-    };+import Data.Int+import Data.Void+import Data.Word+import Prelude -    countDown :: (Countable a) => a -> [a];-    countDown a = case countPrevious a of-    {-        Just a' -> a':(countDown a');-        Nothing -> [];-    };+-- | Values form a possibly empty, possibly finite, countable sequence.+class Eq a => Countable a where+    countPrevious :: a -> Maybe a+    countMaybeNext :: Maybe a -> Maybe a -    instance Countable () where-    {-        countPrevious () = Nothing;-        countMaybeNext Nothing = Just ();-        countMaybeNext (Just ()) = Nothing;-    };+countDown :: (Countable a) => a -> [a]+countDown a =+    case countPrevious a of+        Just a' -> a' : (countDown a')+        Nothing -> [] -    instance Countable Bool where-    {-        countPrevious True = Just False;-        countPrevious False = Nothing;-        countMaybeNext Nothing = Just False;-        countMaybeNext (Just False) = Just True;-        countMaybeNext (Just True) = Nothing;-    };+instance Countable Void where+    countPrevious = absurd+    countMaybeNext Nothing = Nothing+    countMaybeNext (Just n) = absurd n -    boundedCountPrevious :: (Eq a,Bounded a,Enum a) => a -> Maybe a;-    boundedCountPrevious n | n == minBound = Nothing;-    boundedCountPrevious n = Just (pred n);+instance Countable () where+    countPrevious () = Nothing+    countMaybeNext Nothing = Just ()+    countMaybeNext (Just ()) = Nothing -    boundedCountMaybeNext :: (Eq a,Bounded a,Enum a) => Maybe a -> Maybe a;-    boundedCountMaybeNext Nothing = Just minBound;-    boundedCountMaybeNext (Just n) | n == maxBound = Nothing;-    boundedCountMaybeNext (Just n) = Just (succ n);+instance Countable Bool where+    countPrevious True = Just False+    countPrevious False = Nothing+    countMaybeNext Nothing = Just False+    countMaybeNext (Just False) = Just True+    countMaybeNext (Just True) = Nothing -    instance Countable Word8 where-    {-        countPrevious = boundedCountPrevious;-        countMaybeNext = boundedCountMaybeNext;-    };+boundedCountPrevious :: (Eq a, Bounded a, Enum a) => a -> Maybe a+boundedCountPrevious n+    | n == minBound = Nothing+boundedCountPrevious n = Just (pred n) -    instance Countable Word16 where-    {-        countPrevious = boundedCountPrevious;-        countMaybeNext = boundedCountMaybeNext;-    };+boundedCountMaybeNext :: (Eq a, Bounded a, Enum a) => Maybe a -> Maybe a+boundedCountMaybeNext Nothing = Just minBound+boundedCountMaybeNext (Just n)+    | n == maxBound = Nothing+boundedCountMaybeNext (Just n) = Just (succ n) -    instance Countable Word32 where-    {-        countPrevious = boundedCountPrevious;-        countMaybeNext = boundedCountMaybeNext;-    };+instance Countable Word8 where+    countPrevious = boundedCountPrevious+    countMaybeNext = boundedCountMaybeNext -    instance Countable Word64 where-    {-        countPrevious = boundedCountPrevious;-        countMaybeNext = boundedCountMaybeNext;-    };+instance Countable Word16 where+    countPrevious = boundedCountPrevious+    countMaybeNext = boundedCountMaybeNext -    instance Countable Int8 where-    {-        countPrevious = boundedCountPrevious;-        countMaybeNext = boundedCountMaybeNext;-    };+instance Countable Word32 where+    countPrevious = boundedCountPrevious+    countMaybeNext = boundedCountMaybeNext -    instance Countable Int16 where-    {-        countPrevious = boundedCountPrevious;-        countMaybeNext = boundedCountMaybeNext;-    };+instance Countable Word64 where+    countPrevious = boundedCountPrevious+    countMaybeNext = boundedCountMaybeNext -    instance Countable Int32 where-    {-        countPrevious = boundedCountPrevious;-        countMaybeNext = boundedCountMaybeNext;-    };+instance Countable Int8 where+    countPrevious = boundedCountPrevious+    countMaybeNext = boundedCountMaybeNext -    instance Countable Int64 where-    {-        countPrevious = boundedCountPrevious;-        countMaybeNext = boundedCountMaybeNext;-    };+instance Countable Int16 where+    countPrevious = boundedCountPrevious+    countMaybeNext = boundedCountMaybeNext -    instance Countable Integer where-    {-        countPrevious 0 = Nothing;-        countPrevious a | a < 0 = Just (- a - 1);-        countPrevious a = Just (- a);-        countMaybeNext = Just . countNext;-    };+instance Countable Int32 where+    countPrevious = boundedCountPrevious+    countMaybeNext = boundedCountMaybeNext -    instance (Countable a) => Countable (Maybe a) where-    {-        countPrevious = fmap countPrevious;-        countMaybeNext Nothing = Just Nothing;-        countMaybeNext (Just ma) = fmap Just (countMaybeNext ma);-    };+instance Countable Int64 where+    countPrevious = boundedCountPrevious+    countMaybeNext = boundedCountMaybeNext -    maybeRecount :: (Countable a,Countable b) => a -> Maybe b;-    maybeRecount a = case countPrevious a of-    {-        Just a' -> do-        {-            b' <- maybeRecount a';-            countMaybeNext b';-        };-        Nothing -> countMaybeNext Nothing;-    };+instance Countable Integer where+    countPrevious 0 = Nothing+    countPrevious a+        | a < 0 = Just (-a - 1)+    countPrevious a = Just (-a)+    countMaybeNext = Just . countNext -    {--    Right 0-    Left 0-    Right 1-    Left 1-    Left 2-    Left 3-    -}+instance (Countable a) => Countable (Maybe a) where+    countPrevious = fmap countPrevious+    countMaybeNext Nothing = Just Nothing+    countMaybeNext (Just ma) = fmap Just (countMaybeNext ma) -    instance (Countable a,Countable b) => Countable (Either a b) where-    {-        countPrevious (Right b) = case countPrevious b of-        {-            Just b' -> case maybeRecount b' of-            {-                Just a -> Just (Left a);-                Nothing -> Just (Right b);-            };-            Nothing -> Nothing;-        };-        countPrevious (Left a) = case maybeRecount a of-        {-            Just b -> Just (Right b);-            Nothing -> fmap Left (countPrevious a);-        };+maybeRecount :: (Countable a, Countable b) => a -> Maybe b+maybeRecount a =+    case countPrevious a of+        Just a' -> do+            b' <- maybeRecount a'+            countMaybeNext b'+        Nothing -> countMaybeNext Nothing -        countMaybeNext Nothing = case countMaybeNext Nothing of-        {-            Just b -> Just (Right b);-            Nothing -> fmap Left (countMaybeNext Nothing);-        };-        countMaybeNext (Just (Right b)) = case maybeRecount b of-        {-            Just a -> Just (Left a);-            Nothing -> fmap Right (countMaybeNext (Just b));-        };-        countMaybeNext (Just (Left a)) = case maybeRecount a >>= (countMaybeNext . Just) of-        {-            Just b -> (Just (Right b));-            Nothing -> fmap Left (countMaybeNext (Just a));-        };-    };+{-+Right 0+Left 0+Right 1+Left 1+Left 2+Left 3+-}+instance (Countable a, Countable b) => Countable (Either a b) where+    countPrevious (Right b) =+        case countPrevious b of+            Just b' ->+                case maybeRecount b' of+                    Just a -> Just (Left a)+                    Nothing -> Just (Right b)+            Nothing -> Nothing+    countPrevious (Left a) =+        case maybeRecount a of+            Just b -> Just (Right b)+            Nothing -> fmap Left (countPrevious a)+    countMaybeNext Nothing =+        case countMaybeNext Nothing of+            Just b -> Just (Right b)+            Nothing -> fmap Left (countMaybeNext Nothing)+    countMaybeNext (Just (Right b)) =+        case maybeRecount b of+            Just a -> Just (Left a)+            Nothing -> fmap Right (countMaybeNext (Just b))+    countMaybeNext (Just (Left a)) =+        case maybeRecount a >>= (countMaybeNext . Just) of+            Just b -> (Just (Right b))+            Nothing -> fmap Left (countMaybeNext (Just a)) -    countDownUp :: (Countable down,Countable up) => (down,up) -> Maybe (down,up);-    countDownUp (down,up) = do-    {-        down' <- countPrevious down;-        up' <- countMaybeNext (Just up);-        return (down',up');-    };+countDownUp :: (Countable down, Countable up) => (down, up) -> Maybe (down, up)+countDownUp (down, up) = do+    down' <- countPrevious down+    up' <- countMaybeNext (Just up)+    return (down', up') -    countUpDown :: (Countable up,Countable down) => (up,down) -> Maybe (up,down);-    countUpDown (up,down) = do-    {-        up' <- countMaybeNext (Just up);-        down' <- countPrevious down;-        return (up',down');-    };+countUpDown :: (Countable up, Countable down) => (up, down) -> Maybe (up, down)+countUpDown (up, down) = do+    up' <- countMaybeNext (Just up)+    down' <- countPrevious down+    return (up', down') -    finalIteration :: (a -> Maybe a) -> a -> a;-    finalIteration f a = case f a of-    {-        Just a' -> finalIteration f a';-        Nothing -> a;-    };+finalIteration :: (a -> Maybe a) -> a -> a+finalIteration f a =+    case f a of+        Just a' -> finalIteration f a'+        Nothing -> a -    instance (Countable a,Countable b) => Countable (a,b) where-    {-        countPrevious ab = case countUpDown ab of-        {-            Just ab' -> Just ab';+instance (Countable a, Countable b) => Countable (a, b) where+    countPrevious ab =+        case countUpDown ab of+            Just ab' -> Just ab'             _ -> let-            {-                (a',b') = finalIteration countDownUp ab;-            } in case countPrevious a' of-            {-                Just a'' -> Just (a'',b');-                Nothing -> case countPrevious b' of-                {-                    Just b'' -> Just (a',b'');-                    Nothing -> Nothing;-                };-            };-        };--        countMaybeNext Nothing = do-        {-            a <- countMaybeNext Nothing;-            b <- countMaybeNext Nothing;-            return (a,b);-        };-        countMaybeNext (Just ab) = case countDownUp ab of-        {-            Just ab' -> Just ab';+                (a', b') = finalIteration countDownUp ab+                in case countPrevious a' of+                       Just a'' -> Just (a'', b')+                       Nothing ->+                           case countPrevious b' of+                               Just b'' -> Just (a', b'')+                               Nothing -> Nothing+    countMaybeNext Nothing = do+        a <- countMaybeNext Nothing+        b <- countMaybeNext Nothing+        return (a, b)+    countMaybeNext (Just ab) =+        case countDownUp ab of+            Just ab' -> Just ab'             _ -> let-            {-                (a',b') = finalIteration countUpDown ab;-            } in case countMaybeNext (Just a') of-            {-                Just a'' -> Just (a'',b');-                Nothing -> case countMaybeNext (Just b') of-                {-                    Just b'' -> Just (a',b'');-                    Nothing -> Nothing;-                };-            };-        };-    };+                (a', b') = finalIteration countUpDown ab+                in case countMaybeNext (Just a') of+                       Just a'' -> Just (a'', b')+                       Nothing ->+                           case countMaybeNext (Just b') of+                               Just b'' -> Just (a', b'')+                               Nothing -> Nothing -    class (Countable a) => AtLeastOneCountable a where-    {-        countFirst :: a;-    };+-- | Values form a non-empty, possibly finite, countable sequence.+class Countable a => AtLeastOneCountable a where+    countFirst :: a -    instance AtLeastOneCountable () where-    {-        countFirst = ();-    };+instance AtLeastOneCountable () where+    countFirst = () -    instance AtLeastOneCountable Bool where-    {-        countFirst = False;-    };+instance AtLeastOneCountable Bool where+    countFirst = False -    instance AtLeastOneCountable Word8 where-    {-        countFirst = minBound;-    };+instance AtLeastOneCountable Word8 where+    countFirst = minBound -    instance AtLeastOneCountable Word16 where-    {-        countFirst = minBound;-    };+instance AtLeastOneCountable Word16 where+    countFirst = minBound -    instance AtLeastOneCountable Word32 where-    {-        countFirst = minBound;-    };+instance AtLeastOneCountable Word32 where+    countFirst = minBound -    instance AtLeastOneCountable Word64 where-    {-        countFirst = minBound;-    };+instance AtLeastOneCountable Word64 where+    countFirst = minBound -    instance AtLeastOneCountable Int8 where-    {-        countFirst = minBound;-    };+instance AtLeastOneCountable Int8 where+    countFirst = minBound -    instance AtLeastOneCountable Int16 where-    {-        countFirst = minBound;-    };+instance AtLeastOneCountable Int16 where+    countFirst = minBound -    instance AtLeastOneCountable Int32 where-    {-        countFirst = minBound;-    };+instance AtLeastOneCountable Int32 where+    countFirst = minBound -    instance AtLeastOneCountable Int64 where-    {-        countFirst = minBound;-    };+instance AtLeastOneCountable Int64 where+    countFirst = minBound -    instance AtLeastOneCountable Integer where-    {-        countFirst = 0;-    };+instance AtLeastOneCountable Integer where+    countFirst = 0 -    instance (Countable a) => AtLeastOneCountable (Maybe a) where-    {-        countFirst = Nothing;-    };+instance (Countable a) => AtLeastOneCountable (Maybe a) where+    countFirst = Nothing -    instance (Countable a,AtLeastOneCountable b) => AtLeastOneCountable (Either a b) where-    {-        countFirst = Right countFirst;-    };+instance (Countable a, AtLeastOneCountable b) => AtLeastOneCountable (Either a b) where+    countFirst = Right countFirst -    instance (AtLeastOneCountable a,AtLeastOneCountable b) => AtLeastOneCountable (a,b) where-    {-        countFirst = (countFirst,countFirst);-    };+instance (AtLeastOneCountable a, AtLeastOneCountable b) => AtLeastOneCountable (a, b) where+    countFirst = (countFirst, countFirst) -    class (AtLeastOneCountable a) => InfiniteCountable a where-    {-        countNext :: Maybe a -> a;-    };+-- | Values form an infinite countable sequence.+class (AtLeastOneCountable a) => InfiniteCountable a where+    countNext :: Maybe a -> a -    instance InfiniteCountable Integer where-    {-        countNext Nothing = 0;-        countNext (Just a) | a < 0 = - a;-        countNext (Just a) = - a - 1;-    };+instance InfiniteCountable Integer where+    countNext Nothing = 0+    countNext (Just a)+        | a < 0 = -a+    countNext (Just a) = -a - 1 -    instance (InfiniteCountable a) => InfiniteCountable (Maybe a) where-    {-        countNext = fmap countNext;-    };+instance (InfiniteCountable a) => InfiniteCountable (Maybe a) where+    countNext = fmap countNext -    instance (AtLeastOneCountable a,InfiniteCountable b) => InfiniteCountable (a,b) where-    {-        countNext Nothing = (countFirst,countNext Nothing);-        countNext (Just ab) = case countDownUp ab of-        {-            Just ab' -> ab';+instance (AtLeastOneCountable a, InfiniteCountable b) => InfiniteCountable (a, b) where+    countNext Nothing = (countFirst, countNext Nothing)+    countNext (Just ab) =+        case countDownUp ab of+            Just ab' -> ab'             _ -> let-            {-                (a',b') = finalIteration countUpDown ab;-            } in case countMaybeNext (Just a') of-            {-                Just a'' -> (a'',b');-                Nothing -> (a',countNext (Just b'));-            };-        };-    };--    recount :: (Countable a,InfiniteCountable b) => a -> b;-    recount = countNext . (fmap recount) . countPrevious;--    instance (Countable a,InfiniteCountable b) => InfiniteCountable (Either a b) where-    {-        countNext Nothing = Right (countNext Nothing);-        countNext (Just (Right b)) = case maybeRecount b of-        {-            Just a -> Left a;-            Nothing -> Right (countNext (Just b));-        };-        countNext (Just (Left a)) = Right (countNext (recount a));-    };--    instance (Countable a) => Countable [a] where-    {-        countPrevious [] = Nothing;-        countPrevious (x:xs) = case countMaybeNext Nothing of-        {-            Nothing -> seq x undefined; -- x not supposed to exist-            Just firsta -> Just (pp x xs) where-            {-                pp a r = case countPrevious a of-                {-                    Just a' -> firsta:(pp a' r);-                    Nothing -> case r of-                    {-                        [] -> [];-                        b:r' -> case countMaybeNext (Just b) of-                        {-                            Just b' -> b':r';-                            Nothing -> firsta:(pp b r');-                        };-                    };-                };-            };-        };+                (a', b') = finalIteration countUpDown ab+                in case countMaybeNext (Just a') of+                       Just a'' -> (a'', b')+                       Nothing -> (a', countNext (Just b')) -        countMaybeNext Nothing = Just [];-        countMaybeNext (Just l) = case countMaybeNext Nothing of-        {-            Nothing -> Nothing;-            Just firsta -> Just (countNext' l) where-            {-                countNext' [] = [firsta];-                countNext' (a:r) = case countPrevious a of-                {-                    Just a' -> firsta:a':r;-                    Nothing -> upOne (countNext' r);-                };+recount :: (Countable a, InfiniteCountable b) => a -> b+recount = countNext . (fmap recount) . countPrevious -                upOne [] = [firsta];-                upOne (a:r) = case countMaybeNext (Just a) of-                {-                    Just a' -> a':r;-                    Nothing -> firsta:a:r;-                };-            };-        };-    };+instance (Countable a, InfiniteCountable b) => InfiniteCountable (Either a b) where+    countNext Nothing = Right (countNext Nothing)+    countNext (Just (Right b)) =+        case maybeRecount b of+            Just a -> Left a+            Nothing -> Right (countNext (Just b))+    countNext (Just (Left a)) = Right (countNext (recount a)) -    instance (Countable a) => AtLeastOneCountable [a] where-    {-        countFirst = [];-    };+instance (Countable a) => Countable [a] where+    countPrevious [] = Nothing+    countPrevious (x:xs) =+        case countMaybeNext Nothing of+            Nothing -> seq x undefined -- x not supposed to exist+            Just firsta -> Just (pp x xs)+                where pp a r =+                          case countPrevious a of+                              Just a' -> firsta : (pp a' r)+                              Nothing ->+                                  case r of+                                      [] -> []+                                      b:r' ->+                                          case countMaybeNext (Just b) of+                                              Just b' -> b' : r'+                                              Nothing -> firsta : (pp b r')+    countMaybeNext Nothing = Just []+    countMaybeNext (Just l) =+        case countMaybeNext Nothing of+            Nothing -> Nothing+            Just firsta -> Just (countNext' l)+                where countNext' [] = [firsta]+                      countNext' (a:r) =+                          case countPrevious a of+                              Just a' -> firsta : a' : r+                              Nothing -> upOne (countNext' r)+                      upOne [] = [firsta]+                      upOne (a:r) =+                          case countMaybeNext (Just a) of+                              Just a' -> a' : r+                              Nothing -> firsta : a : r -    instance (AtLeastOneCountable a) => InfiniteCountable [a] where-    {-        countNext Nothing = [];-        countNext (Just l) = countNext' l where-        {-            countNext' [] = [countFirst];-            countNext' (a:r) = case countPrevious a of-            {-                Just a' -> countFirst:a':r;-                Nothing -> upOne (countNext' r);-            };+instance (Countable a) => AtLeastOneCountable [a] where+    countFirst = [] -            upOne [] = [countFirst];-            upOne (a:r) = case countMaybeNext (Just a) of-            {-                Just a' -> a':r;-                Nothing -> countFirst:a:r;-            };-        };-    };-}+instance (AtLeastOneCountable a) => InfiniteCountable [a] where+    countNext Nothing = []+    countNext (Just l) = countNext' l+      where+        countNext' [] = [countFirst]+        countNext' (a:r) =+            case countPrevious a of+                Just a' -> countFirst : a' : r+                Nothing -> upOne (countNext' r)+        upOne [] = [countFirst]+        upOne (a:r) =+            case countMaybeNext (Just a) of+                Just a' -> a' : r+                Nothing -> countFirst : a : r
src/Data/Empty.hs view
@@ -1,66 +1,22 @@ module Data.Empty where-{-    import Data.Countable;-    import Data.Searchable; -    class (Finite n) => Empty n where-    {-        never :: n -> a;-    };--    instance (Empty a,Empty b) => Empty (Either a b) where-    {-        never (Left a) = never a;-        never (Right a) = never a;-    };--    instance (Empty a,Finite b) => Empty (a,b) where-    {-        never (a,_) = never a;-    };--    instance (AtLeastOneCountable a,Finite a,Empty b) => Empty (a -> b) where-    {-        never ab = never (ab countFirst);-    };--    data None;--    instance Countable None where-    {-        countPrevious = never;-        countMaybeNext Nothing = Nothing;-        countMaybeNext (Just n) = never n;-    };--    instance Searchable None where-    {-        search = finiteSearch;-    };+import Data.Countable+import Data.Searchable+import Data.Void -    instance Finite None where-    {-        allValues = [];-        assemble _ = pure never;-    };+-- | There are no values.+class Finite n => Empty n where+    never :: n -> a -    instance Empty None where-    {-        never a = case a of {};-    };+instance Empty Void where+    never = absurd -    instance Eq None where-    {-        a == _b = never a;-    };+instance (Empty a, Empty b) => Empty (Either a b) where+    never (Left a) = never a+    never (Right a) = never a -    instance Ord None where-    {-        a <= _b = never a;-    };+instance (Empty a, Finite b) => Empty (a, b) where+    never (a, _) = never a -    instance Show None where-    {-        show a = never a;-    };-}+instance (AtLeastOneCountable a, Finite a, Empty b) => Empty (a -> b) where+    never ab = never (ab countFirst)
src/Data/Expression.hs view
@@ -1,32 +1,35 @@-module Data.Expression (Expression(..),expressionSym,runValueExpression,runMatchExpression) where-{-    data Expression a g f r = ClosedExpression (f r) | OpenExpression a (Expression a g f (g r));+module Data.Expression+    ( Expression(..)+    , expressionSym+    , runValueExpression+    , runMatchExpression+    ) where -    instance (Functor f, Functor g) => Functor (Expression a g f) where-    {-        fmap pq (ClosedExpression fp) = ClosedExpression (fmap pq fp);-        fmap pq (OpenExpression a egp) = OpenExpression a (fmap (fmap pq) egp);-    };+data Expression a g f r+    = ClosedExpression (f r)+    | OpenExpression a+                     (Expression a g f (g r)) -    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 fmap fpq) ebp);+instance (Functor f, Functor g) => Functor (Expression a g f) where+    fmap pq (ClosedExpression fp) = ClosedExpression (fmap pq fp)+    fmap pq (OpenExpression a egp) = OpenExpression a (fmap (fmap pq) egp) -    instance (Applicative f, Functor g) => Applicative (Expression a g f) where-    {-        pure t = ClosedExpression (pure t);-        (ClosedExpression fpq) <*> ep = ffmap fpq ep;-        (OpenExpression a egpq) <*> ep = OpenExpression a ((\p -> fmap (\pq -> pq p)) <$> ep <*> egpq);-    };+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 fmap fpq) ebp) -    expressionSym :: a -> f (g r) -> Expression a g f r;-    expressionSym a fbr = OpenExpression a (ClosedExpression fbr);+instance (Applicative f, Functor g) => Applicative (Expression a g f) where+    pure t = ClosedExpression (pure t)+    (ClosedExpression fpq) <*> ep = ffmap fpq ep+    (OpenExpression a egpq) <*> ep = OpenExpression a ((\p -> fmap (\pq -> pq p)) <$> ep <*> egpq) -    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);+expressionSym :: a -> f (g r) -> Expression a g f r+expressionSym a fbr = OpenExpression a (ClosedExpression fbr) -    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);-}+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)
src/Data/Searchable.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS -fno-warn-orphans #-}+ -- | This module also includes these orphan instances: -- -- * @('Searchable' a,'Eq' b) => 'Eq' (a -> b)@ / /@@ -9,343 +10,296 @@ -- -- * @('Show' a,'Finite' a,'Show' b) => 'Show' (a -> b)@ / / module Data.Searchable-(-    Searchable(..),forsome,forevery,-    Finite(..),finiteSearch,finiteCountPrevious,finiteCountMaybeNext-) where-{-    import Data.Expression;-    import Data.Countable;-    import Data.Monoid;-    import Data.Maybe;-    import Data.List;-    import Control.Applicative;-    import Data.Foldable hiding (find);-    import Data.Traversable;-    import Data.Word;-    import Data.Int;-    import Prelude;+    ( Searchable(..)+    , forsome+    , forevery+    , Finite(..)+    , finiteSearch+    , finiteCountPrevious+    , finiteCountMaybeNext+    ) where -    -- | It turns out there are 'Searchable' instances that are not 'Finite'.-    -- The @(c -> s)@ instance is based on the algorithm at-    -- <http://math.andrej.com/2007/09/28/seemingly-impossible-functional-programs/>.-    ;-    class Searchable a where-    {-        search :: (a -> Maybe b) -> Maybe b;-    };+import Control.Applicative+import Data.Countable+import Data.Expression+import Data.Foldable hiding (find)+import Data.Int+import Data.List+import Data.Maybe+import Data.Monoid+import Data.Traversable+import Data.Void+import Data.Word+import Prelude -    forsome :: (Searchable a) => (a -> Bool) -> Bool;-    forsome = isJust . search . (\ab a -> if ab a then Just () else Nothing);+-- | It turns out there are 'Searchable' instances that are not 'Finite'.+-- The @(c -> s)@ instance is based on the algorithm at+-- <http://math.andrej.com/2007/09/28/seemingly-impossible-functional-programs/>.+class Searchable a where+    search :: (a -> Maybe b) -> Maybe b -    forevery :: (Searchable a) => (a -> Bool) -> Bool;-    forevery p = not (forsome (not . p));+forsome :: (Searchable a) => (a -> Bool) -> Bool+forsome =+    isJust .+    search .+    (\ab a ->+         if ab a+             then Just ()+             else Nothing) -    instance (Searchable a) => Searchable (Maybe a) where-    {-        search mamb = case mamb Nothing of-        {-            Just b -> Just b;-            Nothing -> search (mamb . Just);-        };-    };+forevery :: (Searchable a) => (a -> Bool) -> Bool+forevery p = not (forsome (not . p)) -    instance (Searchable a,Searchable b) => Searchable (Either a b) where-    {-        search eabb = case search (eabb . Left) of-        {-            Just b -> Just b;-            _ -> search (eabb . Right);-        }-    };+instance (Searchable a) => Searchable (Maybe a) where+    search mamb =+        case mamb Nothing of+            Just b -> Just b+            Nothing -> search (mamb . Just) -    instance (Searchable a,Searchable b) => Searchable (a,b) where-    {-        search abb = search (\a -> search (\b -> abb (a,b)));-    };+instance (Searchable a, Searchable b) => Searchable (Either a b) where+    search eabb =+        case search (eabb . Left) of+            Just b -> Just b+            _ -> search (eabb . Right) -    instance (Countable c,Searchable s) => Searchable (c -> s) where-    {-        search csmx = case search Just of-        {-            Just def -> let-            {-                -- prepend :: s -> (c -> s) -> c -> s;-                prepend s cs c = case countPrevious c of-                {-                    Just c' -> cs c';-                    Nothing -> s;-                };+instance (Searchable a, Searchable b) => Searchable (a, b) where+    search abb = search (\a -> search (\b -> abb (a, b))) -                -- findcs :: ((c -> s) -> Maybe x) -> c -> s;+instance (Countable c, Searchable s) => Searchable (c -> s) where+    search csmx =+        case search Just of+            Just def -> let+                prepend s cs c =+                    case countPrevious c of+                        Just c' -> cs c'+                        Nothing -> s+                -- | prepend :: s -> (c -> s) -> c -> s+                -- | findcs :: ((c -> s) -> Maybe x) -> c -> s                 findcs csm = let-                {-                    mx = search (\s' -> do-                    {-                        _ <- search (csm . (prepend s'));-                        return s';-                    });-                    s = case mx of-                    {-                        Just s' -> s';-                        _ -> def;-                    };-                } in prepend s (findcs (csm . (prepend s)));-            } in csmx (findcs csmx);-            Nothing -> Nothing;-        };-    };+                    mx =+                        search+                            (\s' -> do+                                 _ <- search (csm . (prepend s'))+                                 return s')+                    s =+                        case mx of+                            Just s' -> s'+                            _ -> def+                    in prepend s (findcs (csm . (prepend s)))+                in csmx (findcs csmx)+            Nothing -> Nothing -    instance (Searchable a,Eq b) => Eq (a -> b) where-    {-        p == q = forevery (\a -> p a == q a);-    };+instance (Searchable a, Eq b) => Eq (a -> b) where+    p == q = forevery (\a -> p a == q a) -    class (Searchable a,Countable a) => Finite a where-    {-        -- | Not necessarily in counting order.-        ;-        allValues :: [a];+-- | There are a finite number of values (possibly zero).+class (Searchable a, Countable a) => Finite a where+    -- | Not necessarily in counting order.+    allValues :: [a]+    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;+        listLookup [] _ = error "missing value" -- this should never happen+        listLookup ((a, b):_) a'+            | a == a' = b+        listLookup (_:l) a' = listLookup l a' -        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;-            listLookup [] _ = error "missing value";    -- this should never happen-            listLookup ((a,b):_) a' | a == a' = b;-            listLookup (_:l) a' = listLookup l a';-        };-    };+instance (Finite t) => Foldable ((->) t) where+    foldMap am ta = mconcat (fmap (am . ta) allValues) -    instance (Finite t) => Foldable ((->) t) where-    {-        foldMap am ta = mconcat (fmap (am . ta) allValues);-    };+instance (Finite a) => Traversable ((->) a) where+    sequenceA = assemble -    instance (Finite a) => Traversable ((->) a) where-    {-        sequenceA = assemble;-    };+firstJust :: [Maybe a] -> Maybe a+firstJust [] = Nothing+firstJust ((Just a):_) = Just a+firstJust (Nothing:mas) = firstJust mas -    firstJust :: [Maybe a] -> Maybe a;-    firstJust [] = Nothing;-    firstJust ((Just a):_) = Just a;-    firstJust (Nothing:mas) = firstJust mas;+finiteSearch :: (Finite a) => (a -> Maybe b) -> Maybe b+finiteSearch p = firstJust (fmap p allValues) -    finiteSearch :: (Finite a) => (a -> Maybe b) -> Maybe b;-    finiteSearch p = firstJust (fmap p allValues);+finiteCountPrevious :: (Finite a) => a -> Maybe a+finiteCountPrevious x = findp Nothing allValues+  where+    findp ma (a:_)+        | a == x = ma+    findp _ (a:as) = findp (Just a) as+    findp _ [] = seq x (error "missing value") -    finiteCountPrevious :: (Finite a) => a -> Maybe a;-    finiteCountPrevious x = findp Nothing allValues where-    {-        findp ma (a:_) | a == x = ma;-        findp _ (a:as) = findp (Just a) as;-        findp _ [] = seq x (error "missing value");-    };+firstItem :: [a] -> Maybe a+firstItem [] = Nothing+firstItem (a:_) = Just a -    firstItem :: [a] -> Maybe a;-    firstItem [] = Nothing;-    firstItem (a:_) = Just a;+finiteCountMaybeNext :: (Finite a) => Maybe a -> Maybe a+finiteCountMaybeNext Nothing = firstItem allValues+finiteCountMaybeNext (Just x) = findmn allValues+  where+    findmn (a:as)+        | x == a = firstItem as+    findmn (_:as) = findmn as+    findmn [] = seq x (error "missing value") -    finiteCountMaybeNext :: (Finite a) => Maybe a -> Maybe a;-    finiteCountMaybeNext Nothing = firstItem allValues;-    finiteCountMaybeNext (Just x) = findmn allValues where-    {-        findmn (a:as) | x == a = firstItem as;-        findmn (_:as) = findmn as;-        findmn [] = seq x (error "missing value");-    };+instance Searchable Void where+    search = finiteSearch -    instance Searchable () where-    {-        search = finiteSearch;-    };+instance Finite Void where+    allValues = []+    assemble _ = pure absurd -    instance Finite () where-    {-        allValues = [()];-        assemble afb = liftA (\v _ -> v) (afb ());-    };+instance Searchable () where+    search = finiteSearch -    instance Searchable Bool where-    {-        search = finiteSearch;-    };+instance Finite () where+    allValues = [()]+    assemble afb = liftA (\v _ -> v) (afb ()) -    instance Finite Bool where-    {-        allValues = [False,True];-        assemble afb = liftA2 (\f t x -> if x then t else f) (afb False) (afb True);-    };+instance Searchable Bool where+    search = finiteSearch -    instance Searchable Word8 where-    {-        search = finiteSearch;-    };+instance Finite Bool where+    allValues = [False, True]+    assemble afb =+        liftA2+            (\f t x ->+                 if x+                     then t+                     else f)+            (afb False)+            (afb True) -    instance Finite Word8 where-    {-        allValues = enumFrom minBound;-    };+instance Searchable Word8 where+    search = finiteSearch -    instance Searchable Word16 where-    {-        search = finiteSearch;-    };+instance Finite Word8 where+    allValues = enumFrom minBound -    instance Finite Word16 where-    {-        allValues = enumFrom minBound;-    };+instance Searchable Word16 where+    search = finiteSearch -    instance Searchable Word32 where-    {-        search = finiteSearch;-    };+instance Finite Word16 where+    allValues = enumFrom minBound -    instance Finite Word32 where-    {-        allValues = enumFrom minBound;-    };+instance Searchable Word32 where+    search = finiteSearch -    instance Searchable Word64 where-    {-        search = finiteSearch;-    };+instance Finite Word32 where+    allValues = enumFrom minBound -    instance Finite Word64 where-    {-        allValues = enumFrom minBound;-    };+instance Searchable Word64 where+    search = finiteSearch -    instance Searchable Int8 where-    {-        search = finiteSearch;-    };+instance Finite Word64 where+    allValues = enumFrom minBound -    instance Finite Int8 where-    {-        allValues = enumFrom minBound;-    };+instance Searchable Int8 where+    search = finiteSearch -    instance Searchable Int16 where-    {-        search = finiteSearch;-    };+instance Finite Int8 where+    allValues = enumFrom minBound -    instance Finite Int16 where-    {-        allValues = enumFrom minBound;-    };+instance Searchable Int16 where+    search = finiteSearch -    instance Searchable Int32 where-    {-        search = finiteSearch;-    };+instance Finite Int16 where+    allValues = enumFrom minBound -    instance Finite Int32 where-    {-        allValues = enumFrom minBound;-    };+instance Searchable Int32 where+    search = finiteSearch -    instance Searchable Int64 where-    {-        search = finiteSearch;-    };+instance Finite Int32 where+    allValues = enumFrom minBound -    instance Finite Int64 where-    {-        allValues = enumFrom minBound;-    };+instance Searchable Int64 where+    search = finiteSearch -    instance (Finite a) => Finite (Maybe a) where-    {-        allValues = Nothing:(fmap Just allValues);-        assemble mafb = liftA2 maybe (mafb Nothing) (assemble (mafb . Just));-    };+instance Finite Int64 where+    allValues = enumFrom minBound -    instance (Finite a,Finite b) => Finite (Either a b) where-    {-        allValues = (fmap Left allValues) ++ (fmap Right allValues);-        assemble eabfr = liftA2 either (assemble (eabfr . Left)) (assemble (eabfr . Right));-    };+instance (Finite a) => Finite (Maybe a) where+    allValues = Nothing : (fmap Just allValues)+    assemble mafb = liftA2 maybe (mafb Nothing) (assemble (mafb . Just)) -    instance (Finite a,Finite b) => Finite (a,b) where-    {-        allValues = liftA2 (,) allValues allValues;-        assemble abfr = fmap (\abr (a,b) -> abr a b) (assemble (\a -> assemble (\b -> abfr (a,b))));-    };+instance (Finite a, Finite b) => Finite (Either a b) where+    allValues = (fmap Left allValues) ++ (fmap Right allValues)+    assemble eabfr = liftA2 either (assemble (eabfr . Left)) (assemble (eabfr . Right)) -    setpair :: (Eq a) => (a,b) -> (a -> b) -> (a -> b);-    setpair (a',b') _ a | a == a' = b';-    setpair _ ab a = ab a;+instance (Finite a, Finite b) => Finite (a, b) where+    allValues = liftA2 (,) allValues allValues+    assemble abfr = fmap (\abr (a, b) -> abr a b) (assemble (\a -> assemble (\b -> abfr (a, b)))) -    data IsoCountable x = forall l. (Countable l) => MkIsoCountable (x -> l) (l -> x);+setpair :: (Eq a) => (a, b) -> (a -> b) -> (a -> b)+setpair (a', b') _ a+    | a == a' = b'+setpair _ ab a = ab a -    isoCountableFn :: (Finite a,Countable b) => IsoCountable (a -> b);-    isoCountableFn = makeFromList allValues where-    {-        makeFromList :: (Eq a,Countable b) => [a] -> IsoCountable (a -> b);-        makeFromList [] = MkIsoCountable (\_ -> ()) (\a -> seq a undefined);-        makeFromList (a:as) = case makeFromList as of-        {+data IsoCountable x =+    forall l. (Countable l) =>+                  MkIsoCountable (x -> l)+                                 (l -> x)++isoCountableFn :: (Finite a, Countable b) => IsoCountable (a -> b)+isoCountableFn = makeFromList allValues+  where+    makeFromList :: (Eq a, Countable b) => [a] -> IsoCountable (a -> b)+    makeFromList [] = MkIsoCountable (\_ -> ()) (\a -> seq a undefined)+    makeFromList (a:as) =+        case makeFromList as of             MkIsoCountable encode decode ->-             MkIsoCountable (\ab -> (ab a,encode ab)) (\(b,l) -> setpair (a,b) (decode l));-        };-    };+                MkIsoCountable (\ab -> (ab a, encode ab)) (\(b, l) -> setpair (a, b) (decode l)) -    instance (Finite a,Countable b) => Countable (a -> b) where-    {-        countPrevious = case isoCountableFn of-        {-            MkIsoCountable encode decode -> (fmap decode) . countPrevious . encode;-        };-        countMaybeNext = case isoCountableFn of-        {-            MkIsoCountable encode decode -> (fmap decode) . countMaybeNext . (fmap encode);-        };-    };+instance (Finite a, Countable b) => Countable (a -> b) where+    countPrevious =+        case isoCountableFn of+            MkIsoCountable encode decode -> (fmap decode) . countPrevious . encode+    countMaybeNext =+        case isoCountableFn of+            MkIsoCountable encode decode -> (fmap decode) . countMaybeNext . (fmap encode) -    instance (Finite a,AtLeastOneCountable b) => AtLeastOneCountable (a -> b) where-    {-        countFirst = \_ -> countFirst;-    };+instance (Finite a, AtLeastOneCountable b) => AtLeastOneCountable (a -> b) where+    countFirst = \_ -> countFirst -    data IsoInfiniteCountable x = forall l. (InfiniteCountable l) => MkIsoInfiniteCountable (x -> l) (l -> x);+data IsoInfiniteCountable x =+    forall l. (InfiniteCountable l) =>+                  MkIsoInfiniteCountable (x -> l)+                                         (l -> x) -    isoInfiniteCountableFn :: (Finite a,AtLeastOneCountable a,InfiniteCountable b) => IsoInfiniteCountable (a -> b);-    isoInfiniteCountableFn = makeFromList allValues where-    {-        makeFromList :: (Eq a,InfiniteCountable b) => [a] -> IsoInfiniteCountable (a -> b);-        makeFromList [] = undefined;-        makeFromList [a] = MkIsoInfiniteCountable (\ab -> ab a) (\b -> setpair (a,b) (\a' -> seq a' undefined));-        makeFromList (a:as) = case makeFromList as of-        {+isoInfiniteCountableFn :: (Finite a, AtLeastOneCountable a, InfiniteCountable b) => IsoInfiniteCountable (a -> b)+isoInfiniteCountableFn = makeFromList allValues+  where+    makeFromList :: (Eq a, InfiniteCountable b) => [a] -> IsoInfiniteCountable (a -> b)+    makeFromList [] = undefined+    makeFromList [a] = MkIsoInfiniteCountable (\ab -> ab a) (\b -> setpair (a, b) (\a' -> seq a' undefined))+    makeFromList (a:as) =+        case makeFromList as of             MkIsoInfiniteCountable encode decode ->-             MkIsoInfiniteCountable (\ab -> (ab a,encode ab)) (\(b,l) -> setpair (a,b) (decode l));-        };-    };+                MkIsoInfiniteCountable (\ab -> (ab a, encode ab)) (\(b, l) -> setpair (a, b) (decode l)) -    instance (Finite a,AtLeastOneCountable a,InfiniteCountable b) => InfiniteCountable (a -> b) where-    {-        countNext = case isoInfiniteCountableFn of-        {-            MkIsoInfiniteCountable encode decode -> decode . countNext . (fmap encode);-        };-    };+instance (Finite a, AtLeastOneCountable a, InfiniteCountable b) => InfiniteCountable (a -> b) where+    countNext =+        case isoInfiniteCountableFn of+            MkIsoInfiniteCountable encode decode -> decode . countNext . (fmap encode) -    instance (Finite a,Finite b) => Finite (a -> b) where-    {-        allValues = sequenceA (\_ -> allValues);-        assemble abfr = runValueExpression (Data.Foldable.foldr assemble1 (\ab -> ClosedExpression (abfr ab)) allValues (\_ -> error "missing value")) where-        {+instance (Finite a, Finite b) => Finite (a -> b) where+    allValues = sequenceA (\_ -> allValues)+    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)))-        };-    };+        assemble1 a0 aber x =+            OpenExpression+                a0+                (assemble+                     (\b0 ->+                          aber+                              (\a ->+                                   if a == a0+                                       then b0+                                       else x a))) -    instance (Show a,Finite a,Show b) => Show (a -> b) where-    {-        show f = "{" ++ (intercalate "," (fmap (\a -> (show a) ++ "->" ++ (show (f a))) allValues)) ++ "}";-    };-}+instance (Show a, Finite a, Show b) => Show (a -> b) where+    show f = "{" ++ (intercalate "," (fmap (\a -> (show a) ++ "->" ++ (show (f a))) allValues)) ++ "}"
+ src/Data/Singular.hs view
@@ -0,0 +1,14 @@+module Data.Singular where++import Data.Countable+import Data.Searchable++-- | There is exactly one value.+class (Finite a, AtLeastOneCountable a) => Singular a where+    single :: a++instance Singular () where+    single = ()++instance (Singular a, Singular b) => Singular (a, b) where+    single = (single, single)
test/Count.hs view
@@ -1,118 +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 Data.Proxy+import Data.Void+import Data.Word+import Prelude+import Test.Tasty+import Test.Tasty.HUnit -    import Show;-    import TypeName;-    import Three;-    import Golden;+import Data.Countable+import Data.Searchable -    (@/=?) :: (Eq a,Show a) => a -> a -> Assertion;-    unexpected @/=? actual | unexpected /= actual = return ();-    _unexpected @/=? actual = assertFailure $ "got unexpected " ++ show actual;+import Golden+import Show+import Three+import TypeName -    prevMaybeNext :: (Countable a,Show a) => Maybe a -> Assertion;-    prevMaybeNext ma = case countMaybeNext ma of-    {-        Just a' -> countPrevious a' @=? ma;-        Nothing -> return ();-    };+(@/=?) :: (Eq a, Show a) => a -> a -> Assertion+unexpected @/=? actual+    | unexpected /= actual = return ()+_unexpected @/=? actual = assertFailure $ "got unexpected " ++ show actual -    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)-    ];+prevMaybeNext :: (Countable a, Show a) => Maybe a -> Assertion+prevMaybeNext ma =+    case countMaybeNext ma of+        Just a' -> countPrevious a' @=? ma+        Nothing -> return () -    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 =+    [ 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)+    ] -    countableTests :: (Show a,Countable a) => a -> [TestTree];-    countableTests a = (countableTests' a) ++ [findInNext 1000 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' -    nextIsMaybeNext :: (Show a,InfiniteCountable a) => Maybe a -> TestTree;-    nextIsMaybeNext ma = testCase "nextIsMaybeNext" $ (Just (countNext ma)) @=? (countMaybeNext ma);+countableTests :: (Show a, Countable a) => a -> [TestTree]+countableTests a = (countableTests' a) ++ [findInNext 1000 a] -    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';-        };-    };+nextIsMaybeNext :: (Show a, InfiniteCountable a) => Maybe a -> TestTree+nextIsMaybeNext ma = testCase "nextIsMaybeNext" $ (Just (countNext ma)) @=? (countMaybeNext 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;+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])-            ]-        ];+newtype WrapFunction a b =+    MkWrapFunction (a -> b)+    deriving (Eq, Searchable, Countable, TypeName) -    main :: IO ();-    main = defaultMain allTests;-}+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 :: [Void])+        , testType countableTests ([[] :: [Void]])+        , 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
test/Golden.hs view
@@ -1,22 +1,20 @@ 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;-    };+import Data.ByteString.Builder+import Data.ByteString.Lazy.Char8+import Data.IORef+import Test.Tasty+import Test.Tasty.Golden -    goldenVsWrite :: TestName -> FilePath -> ((ByteString -> IO ()) -> IO a) -> TestTree;-    goldenVsWrite name path action = goldenVsString name path $ fmap toLazyByteString $ accumulate $ \write -> action (write . lazyByteString);+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 -    goldenVsWriteString :: TestName -> FilePath -> ((String -> IO ()) -> IO a) -> TestTree;-    goldenVsWriteString name path action = goldenVsWrite name path $ \write -> action (write . pack);-}+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)
test/Show.hs view
@@ -1,7 +1,6 @@ module Show where-{-    import Data.Searchable; -    showFunction :: (Show a,Finite a,Show b) => (a -> b) -> String;-    showFunction f = show f;-}+import Data.Searchable++showFunction :: (Show a, Finite a, Show b) => (a -> b) -> String+showFunction f = show f
test/Three.hs view
@@ -1,34 +1,27 @@ module Three where-{-    import Data.Searchable;-    import Data.Countable;-    import TypeName; -    data Three = T1 | T2 | T3 deriving (Eq,Show);+import Data.Countable+import Data.Searchable+import TypeName -    instance Searchable Three where-    {-        search = finiteSearch;-    };+data Three+    = T1+    | T2+    | T3+    deriving (Eq, Show) -    instance Countable Three where-    {-        countPrevious = finiteCountPrevious;-        countMaybeNext = finiteCountMaybeNext;-    };+instance Searchable Three where+    search = finiteSearch -    instance AtLeastOneCountable Three where-    {-        countFirst = T1;-    };+instance Countable Three where+    countPrevious = finiteCountPrevious+    countMaybeNext = finiteCountMaybeNext -    instance Finite Three where-    {-        allValues = [T1,T2,T3];-    };+instance AtLeastOneCountable Three where+    countFirst = T1 -    instance TypeName Three where-    {-        typeName _ = "Three";-    };-}+instance Finite Three where+    allValues = [T1, T2, T3]++instance TypeName Three where+    typeName _ = "Three"
test/TypeName.hs view
@@ -1,51 +1,32 @@ module TypeName where-{-    import Data.Proxy;-    import Data.Word;-    import Data.Empty; -    class TypeName a where-    {-        typeName :: Proxy a -> String;-    };+import Data.Proxy+import Data.Void+import Data.Word -    instance TypeName None where-    {-        typeName _ = "None";-    };+class TypeName a where+    typeName :: Proxy a -> String -    instance TypeName () where-    {-        typeName _ = "()";-    };+instance TypeName Void where+    typeName _ = "Void" -    instance TypeName Bool where-    {-        typeName _ = "Bool";-    };+instance TypeName () where+    typeName _ = "()" -    instance TypeName Word8 where-    {-        typeName _ = "Word8";-    };+instance TypeName Bool where+    typeName _ = "Bool" -    instance TypeName Integer where-    {-        typeName _ = "Integer";-    };+instance TypeName Word8 where+    typeName _ = "Word8" -    instance TypeName a => TypeName (Maybe a) where-    {-        typeName _ = "Maybe " ++ (typeName (Proxy :: Proxy a));-    };+instance TypeName Integer where+    typeName _ = "Integer" -    instance TypeName a => TypeName [a] where-    {-        typeName _ = "[" ++ (typeName (Proxy :: Proxy a)) ++ "]";-    };+instance TypeName a => TypeName (Maybe a) where+    typeName _ = "Maybe " ++ (typeName (Proxy :: Proxy a)) -    instance (TypeName a,TypeName b) => TypeName (a -> b) where-    {-        typeName _ = (typeName (Proxy :: Proxy a)) ++ "->" ++ (typeName (Proxy :: Proxy b));-    };-}+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))