diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -39,7 +39,8 @@ install: - $CABAL install --dependencies-only --enable-tests - - $CABAL configure --enable-tests $MODE + - $CABAL install + - $CABAL configure --enable-tests script: - $CABAL build diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,8 @@ +0.2 +--- +* Use lazier boolean comparisons +* `transformers` 0.5 support + 0.1.0.1 ------- * `filepath` 1.4 support diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,7 +1,7 @@ search ====== -[![Build Status](https://secure.travis-ci.org/ekmett/search.png?branch=master)](http://travis-ci.org/ekmett/search) +[![Hackage](https://img.shields.io/hackage/v/search.svg)](https://hackage.haskell.org/package/search) [![Build Status](https://secure.travis-ci.org/ekmett/search.png?branch=master)](http://travis-ci.org/ekmett/search) This package provides a version of Martin Escardo's "J" monad for conducting "infinite search in finite time". diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,44 +1,7 @@ #!/usr/bin/runhaskell \begin{code} {-# OPTIONS_GHC -Wall #-} -module Main (main) where - -import Data.List ( nub ) -import Data.Version ( showVersion ) -import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) -import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) -import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) -import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) -import Distribution.Simple.BuildPaths ( autogenModulesDir ) -import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag ) -import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) -import Distribution.Verbosity ( Verbosity ) -import System.FilePath ( () ) - +import Distribution.Extra.Doctest ( defaultMainWithDoctests ) main :: IO () -main = defaultMainWithHooks simpleUserHooks - { buildHook = \pkg lbi hooks flags -> do - generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi - buildHook simpleUserHooks pkg lbi hooks flags - } - -generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () -generateBuildModule verbosity pkg lbi = do - let dir = autogenModulesDir lbi - createDirectoryIfMissingVerbose verbosity True dir - withLibLBI pkg lbi $ \_ libcfg -> do - withTestLBI pkg lbi $ \suite suitecfg -> do - rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines - [ "module Build_" ++ testName suite ++ " where" - , "deps :: [String]" - , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) - ] - where - formatdeps = map (formatone . snd) - formatone p = case packageName p of - PackageName n -> n ++ "-" ++ showVersion (packageVersion p) - -testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] -testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys - +main = defaultMainWithDoctests "doctests" \end{code} diff --git a/search.cabal b/search.cabal --- a/search.cabal +++ b/search.cabal @@ -1,6 +1,6 @@ name: search category: Math, Topology, Search -version: 0.1.0.1 +version: 0.2 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE @@ -20,22 +20,29 @@ CHANGELOG.markdown README.markdown +custom-setup + setup-depends: + base >= 4 && <5, + Cabal, + cabal-doctest >= 1 && <1.1 + source-repository head type: git location: git://github.com/ekmett/search.git library build-depends: - base >= 4.5 && < 5, + base >= 4.8 && < 5, ghc-prim, - profunctors >= 4 && < 5, - semigroupoids >= 4 && < 5, + profunctors >= 4 && < 6, + semigroupoids >= 4 && < 6, tagged >= 0.7 && < 1, - transformers >= 0.3 && < 0.5 + transformers >= 0.3 && < 0.6 exposed-modules: Data.Search Data.Search.Intensional + Data.Search.LazyBool ghc-options: -Wall -fwarn-tabs -O2 hs-source-dirs: src @@ -44,11 +51,11 @@ test-suite doctests type: exitcode-stdio-1.0 main-is: doctests.hs - ghc-options: -Wall -Werror -threaded + ghc-options: -Wall -threaded hs-source-dirs: tests build-depends: base, directory >= 1.0 && < 1.3, - doctest >= 0.8 && < 0.10, + doctest >= 0.8 && < 0.14, filepath >= 1.3 && < 1.5, search diff --git a/src/Data/Search.hs b/src/Data/Search.hs --- a/src/Data/Search.hs +++ b/src/Data/Search.hs @@ -4,7 +4,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} module Data.Search ( Search(..) , pessimum @@ -18,20 +20,23 @@ , best, worst , bestScore, worstScore -- * Boolean-valued search + , B(..) , every , exists ) where import Control.Applicative import Control.Monad.Trans.Cont +import Data.Coerce import Data.Function (on) import Data.Functor.Alt import Data.Functor.Bind import Data.Int -import Data.Monoid +import Data.Monoid (Any(..), All(..), Product(..), Sum(..), First(..), Last(..)) import Data.Ord import Data.Profunctor import Data.Proxy +import Data.Search.LazyBool import Data.Tagged import Data.Typeable import Data.Word @@ -150,7 +155,7 @@ -- | search for an optimal answer using Hilbert's epsilon -- --- >>> search (>4) :: Int8 +-- >>> best (>4) :: Int8 -- 5 best :: Hilbert a b => (b -> a) -> b best = optimum epsilon @@ -159,34 +164,34 @@ worst :: Hilbert (Down a) b => (b -> a) -> b worst = pessimum epsilon +pair :: Ord a => b -> b -> Search a b +pair = on () pure + +fromList :: Ord a => [b] -> Search a b +fromList = foldr1 () . map return + +-- | 'Search' is more powerful than 'Cont'. +-- +-- This provides a canonical monad homomorphism into 'Cont'. +cps :: Search a b -> Cont a b +cps = cont . optimalScore + bestScore :: Hilbert a b => (b -> a) -> a bestScore = optimalScore epsilon worstScore :: Hilbert (Down a) b => (b -> a) -> a worstScore = pessimalScore epsilon +union :: Ord a => Search a b -> Search a b -> Search a b +union = () + -- | does there exist an element satisfying the predicate? -- -- >>> exists (>(maxBound::Int8)) -- False -- -exists :: Hilbert Bool b => (b -> Bool) -> Bool -exists = bestScore - -every :: Hilbert Bool b => (b -> Bool) -> Bool -every p = not.p $ best $ not.p - -union :: Ord a => Search a b -> Search a b -> Search a b -union = () - -pair :: Ord a => b -> b -> Search a b -pair = on () pure - -fromList :: Ord a => [b] -> Search a b -fromList = foldr1 () . map return +exists :: forall b. Hilbert B b => (b -> Bool) -> Bool +exists = coerce (bestScore :: (b -> B) -> B) --- | 'Search' is more powerful than 'Cont'. --- --- This provides a canonical monad homomorphism into 'Cont'. -cps :: Search a b -> Cont a b -cps = cont . optimalScore +every :: forall b. Hilbert B b => (b -> Bool) -> Bool +every p = not.p $ coerce (best :: (b -> B) -> b) $ not.p diff --git a/src/Data/Search/Intensional.hs b/src/Data/Search/Intensional.hs --- a/src/Data/Search/Intensional.hs +++ b/src/Data/Search/Intensional.hs @@ -6,6 +6,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} module Data.Search.Intensional ( Search(..) , pessimumM @@ -27,15 +28,17 @@ import Control.Applicative import Control.Monad.Trans.Cont import Control.Monad (ap) +import Data.Coerce import Data.Function (on) import Data.Functor.Alt import Data.Functor.Bind import Data.Functor.Identity import Data.Int -import Data.Monoid +import Data.Monoid (Any(..), All(..), Product(..), Sum(..), First(..), Last(..)) import Data.Ord import Data.Profunctor import Data.Proxy +import Data.Search.LazyBool import Data.Tagged import Data.Typeable import Data.Word @@ -49,14 +52,14 @@ -- This rules out large score sets. -- -- @'Search' 'Bool'@ can be used for predicate searches. -newtype Search a b = Search { optimumM :: forall m. (Monad m, Applicative m) => (b -> m a) -> m b } +newtype Search a b = Search { optimumM :: forall m. Monad m => (b -> m a) -> m b } deriving Typeable optimum :: Search a b -> (b -> a) -> b optimum (Search k) f = runIdentity $ k (Identity . f) -- | Find the worst-scoring result of a search with monadic effects. -pessimumM :: (Monad m, Applicative m) => Search (Down a) b -> (b -> m a) -> m b +pessimumM :: Monad m => Search (Down a) b -> (b -> m a) -> m b pessimumM = optimumM . lmap Down -- | Find the worst-scoring result of a search. @@ -156,7 +159,7 @@ -- | search for an optimal answer using Hilbert's epsilon -- --- >>> search (>4) :: Int8 +-- >>> best (>4) :: Int8 -- 5 best :: Hilbert a b => (b -> a) -> b best = optimum epsilon @@ -176,11 +179,11 @@ -- >>> exists (>(maxBound::Int8)) -- False -- -exists :: Hilbert Bool b => (b -> Bool) -> Bool -exists = bestScore +exists :: forall b. Hilbert B b => (b -> Bool) -> Bool +exists = coerce (bestScore :: (b -> B) -> B) -every :: Hilbert Bool b => (b -> Bool) -> Bool -every p = not.p $ best $ not.p +every :: forall b. Hilbert B b => (b -> Bool) -> Bool +every p = not.p $ coerce (best :: (b -> B) -> b) $ not.p union :: Ord a => Search a b -> Search a b -> Search a b union = () diff --git a/src/Data/Search/LazyBool.hs b/src/Data/Search/LazyBool.hs new file mode 100644 --- /dev/null +++ b/src/Data/Search/LazyBool.hs @@ -0,0 +1,18 @@ +module Data.Search.LazyBool (B(..)) where + +-- | Bool with a lazier Ord as suggested +newtype B = B Bool deriving (Eq,Show,Read) + +instance Ord B where + B False <= _ = True + B _ <= B y = y + B False < B y = y + B _ < _ = False + B False >= B b = not b + B _ >= _ = True + B False > _ = False + B _ > B b = not b + min (B False) _ = B False + min _ b = b + max (B False) b = b + max _ _ = B True diff --git a/tests/doctests.hs b/tests/doctests.hs --- a/tests/doctests.hs +++ b/tests/doctests.hs @@ -1,30 +1,20 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Main (doctests) +-- Copyright : (C) 2012-17 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +-- This module provides doctests for a project based on the actual versions +-- of the packages it was built with. It requires a corresponding Setup.lhs +-- to be added to the project +----------------------------------------------------------------------------- module Main where -import Build_doctests (deps) -import Control.Applicative -import Control.Monad -import Data.List -import System.Directory -import System.FilePath +import Build_doctests (flags, pkgs, module_sources) import Test.DocTest main :: IO () -main = getSources >>= \sources -> doctest $ - "-isrc" - : "-idist/build/autogen" - : "-optP-include" - : "-optPdist/build/autogen/cabal_macros.h" - : "-hide-all-packages" - : map ("-package="++) deps ++ sources - -getSources :: IO [FilePath] -getSources = filter (isSuffixOf ".hs") <$> go "src" - where - go dir = do - (dirs, files) <- getFilesAndDirectories dir - (files ++) . concat <$> mapM go dirs - -getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) -getFilesAndDirectories dir = do - c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir - (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c +main = doctest $ flags ++ pkgs ++ module_sources