diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,6 +0,0 @@ -#!/usr/bin/runhaskell -> module Main where -> import Distribution.Simple -> main :: IO () -> main = defaultMain - diff --git a/countable.cabal b/countable.cabal --- a/countable.cabal +++ b/countable.cabal @@ -1,43 +1,52 @@ -cabal-version: >= 1.6 - -name: countable -version: 0.1 - -license: BSD3 -license-file: LICENSE -copyright: Ashley Yakeley -maintainer: Ashley Yakeley -author: Ashley Yakeley -category: Data -synopsis: Countable, Searchable, Finite, Empty classes +cabal-version: >=1.14 +name: countable +version: 0.2 +x-follows-version-policy: +license: BSD3 +license-file: LICENSE +copyright: Ashley Yakeley +author: Ashley Yakeley +maintainer: Ashley Yakeley +homepage: https://github.com/AshleyYakeley/countable +bug-reports: https://github.com/AshleyYakeley/countable/issues +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 . - . - * @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)@ / / + * @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 . + . + * @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)@ / / +category: Data +build-type: Simple -build-type: Simple -build-depends: base == 4.* -extensions: EmptyDataDecls ExistentialQuantification -hs-source-dirs: src -ghc-options: -Wall -exposed-modules: Data.Searchable Data.Countable Data.Empty +library + hs-source-dirs: src + default-language: Haskell98 + default-extensions: + EmptyDataDecls + ExistentialQuantification + build-depends: base ==4.* + exposed-modules: + Data.Expression + Data.Searchable + Data.Countable + Data.Empty + ghc-options: -Wall diff --git a/src/Data/Empty.hs b/src/Data/Empty.hs --- a/src/Data/Empty.hs +++ b/src/Data/Empty.hs @@ -2,6 +2,7 @@ { import Data.Countable; import Data.Searchable; + import Control.Applicative; class (Finite n) => Empty n where { @@ -42,6 +43,7 @@ instance Finite Nothing where { allValues = []; + assemble _ = pure never; }; instance Empty Nothing; diff --git a/src/Data/Expression.hs b/src/Data/Expression.hs new file mode 100644 --- /dev/null +++ b/src/Data/Expression.hs @@ -0,0 +1,30 @@ +module Data.Expression (Expression(..),expressionSym,runExpression) where +{ + import Control.Applicative; + + data Expression a b f r = ClosedExpression (f r) | OpenExpression a (Expression a b f (b -> r)); + + instance (Functor f) => Functor (Expression a b f) where + { + fmap pq (ClosedExpression fp) = ClosedExpression (fmap pq fp); + fmap pq (OpenExpression a ebp) = OpenExpression a (fmap (\bp -> pq . bp) ebp); + }; + + ffmap :: (Applicative f) => f (p -> q) -> Expression a b f p -> Expression a b f q; + ffmap fpq (ClosedExpression fp) = ClosedExpression (fpq <*> fp); + ffmap fpq (OpenExpression a ebp) = OpenExpression a (ffmap (fmap (\pq bp -> pq . bp) fpq) ebp); + + instance (Applicative f) => Applicative (Expression a b 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); + }; + + expressionSym :: a -> f (b -> r) -> Expression a b 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); +} diff --git a/src/Data/Searchable.hs b/src/Data/Searchable.hs --- a/src/Data/Searchable.hs +++ b/src/Data/Searchable.hs @@ -14,6 +14,7 @@ Finite(..),finiteSearch,finiteCountPrevious,finiteCountMaybeNext ) where { + import Data.Expression; import Data.Countable; import Data.Monoid; import Data.Maybe; @@ -260,16 +261,19 @@ 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 (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 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)))); }; setpair :: (Eq a) => (a,b) -> (a -> b) -> (a -> b); @@ -333,6 +337,11 @@ 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 + { + -- 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))) + }; }; instance (Show a,Finite a,Show b) => Show (a -> b) where