packages feed

lens-action (empty) → 0.1

raw patch · 10 files changed

+713/−0 lines, 10 filesdep +basedep +comonaddep +contravariantbuild-type:Customsetup-changed

Dependencies added: base, comonad, contravariant, directory, doctest, filepath, lens, mtl, profunctors, semigroupoids, semigroups, transformers

Files

+ .ghci view
@@ -0,0 +1,1 @@+:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h
+ .gitignore view
@@ -0,0 +1,17 @@+dist/+.hsenv/+docs+wiki+TAGS+tags+wip+.DS_Store+.*.swp+.*.swo+*.o+*.hi+*~+*#+.cabal-sandbox/+cabal.sandbox.config+codex.tags
+ CHANGELOG.markdown view
@@ -0,0 +1,3 @@+0.1+----+* Initial split from lens package
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright 2012-2014 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++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.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.lhs view
@@ -0,0 +1,45 @@+#!/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), Package, PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref))+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )+import Distribution.Text ( display )+import Distribution.Verbosity ( Verbosity, normal )+import System.FilePath ( (</>) )++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++\end{code}
+ lens-action.cabal view
@@ -0,0 +1,75 @@+name:          lens-action+category:      Data, Lenses, Generics+version:       0.1+license:       BSD3+cabal-version: >= 1.8+license-file:  LICENSE+author:        Edward A. Kmett+maintainer:    Edward A. Kmett <ekmett@gmail.com>+stability:     provisional+homepage:      http://github.com/ekmett/lens-action/+bug-reports:   http://github.com/ekmett/lens-action/issues+copyright:     Copyright (C) 2012-2014 Edward A. Kmett+build-type:    Custom+-- build-tools:   cpphs+tested-with:   GHC == 7.8.3+synopsis:      Monadic Getters and Folds+description:+  This package contains combinators and types for working with+  monadic getters and folds as split off from the original+  lens package.++extra-source-files:+  .ghci+  .gitignore+  CHANGELOG.markdown++source-repository head+  type: git+  location: git://github.com/ekmett/lens-action.git++-- You can disable the doctests test suite with -f-test-doctests+flag test-doctests+  default: True+  manual: True++library+  build-depends:+    lens                      >= 4.7      && < 5,+    base                      >= 4.5      && < 5,+    comonad                   >= 4        && < 5,+    contravariant             >= 0.3      && < 2,+    profunctors               >= 4        && < 5,+    mtl                       >= 2.0.1    && < 2.3,+    semigroups                >= 0.8.4    && < 1,+    semigroupoids             >= 4        && < 5,+    transformers              >= 0.2      && < 0.5++  exposed-modules:+    Control.Lens.Action+    Control.Lens.Action.Internal+    Control.Lens.Action.Reified++  cpp-options: -traditional++  ghc-options: -Wall -fwarn-tabs -O2 -fdicts-cheap -funbox-strict-fields -fmax-simplifier-iterations=10+  hs-source-dirs: src++-- Verify the results of the examples+test-suite doctests+  type:           exitcode-stdio-1.0+  main-is:        doctests.hs+  ghc-options:    -Wall -threaded+  hs-source-dirs: tests++  if !flag(test-doctests)+    buildable: False+  else+    build-depends:+      base,+      doctest        >= 0.9.1,+      filepath,+      directory++  if impl(ghc<7.6.1)+    ghc-options: -Werror
+ src/Control/Lens/Action.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+#ifdef TRUSTWORTHY+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Lens.Action+-- Copyright   :  (C) 2012-14 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+----------------------------------------------------------------------------+module Control.Lens.Action+  (+  -- * Composable Actions+    Action+  , act+  , acts+  , perform+  , performs+  , liftAct+  , (^!)+  , (^!!)+  , (^!?)++  -- * Indexed Actions+  , IndexedAction+  , iact+  , iperform+  , iperforms+  , (^@!)+  , (^@!!)+  , (^@!?)++  -- * Folds with Effects+  , MonadicFold+  , IndexedMonadicFold++  -- * Implementation Details+  , Acting+  , IndexedActing+  , Effective+  ) where++import Control.Comonad+import Control.Lens.Internal.Fold+import Control.Lens.Internal.Indexed+import Control.Lens.Type+import Control.Monad (liftM)+import Control.Monad.Trans.Class+import Data.Profunctor+import Data.Profunctor.Rep+import Data.Profunctor.Unsafe++import Control.Lens.Action.Internal+import Control.Lens.Action.Type++-- $setup+-- >>> :set -XNoOverloadedStrings+-- >>> import Control.Lens++infixr 8 ^!, ^!!, ^@!, ^@!!, ^!?, ^@!?++-- | Used to evaluate an 'Action'.+type Acting m r s a = LensLike (Effect m r) s s a a++-- | Perform an 'Action'.+--+-- @+-- 'perform' ≡ 'flip' ('^!')+-- @+perform :: Monad m => Acting m a s a -> s -> m a+perform l = getEffect #. l (Effect #. return)+{-# INLINE perform #-}++-- | Perform an 'Action' and modify the result.+--+-- @+-- 'performs' :: 'Monad' m => 'Acting' m e s a -> (a -> e) -> s -> m e+-- @+performs :: (Profunctor p, Monad m) => Over p (Effect m e) s t a b -> p a e -> s -> m e+performs l f = getEffect #. l (rmap (Effect #. return) f)+{-# INLINE performs #-}++-- | Perform an 'Action'.+--+-- >>> ["hello","world"]^!folded.act putStrLn+-- hello+-- world+(^!) :: Monad m => s -> Acting m a s a -> m a+a ^! l = getEffect (l (Effect #. return) a)+{-# INLINE (^!) #-}++-- | Perform a 'MonadicFold' and collect all of the results in a list.+--+-- >>> ["ab","cd","ef"]^!!folded.acts+-- ["ace","acf","ade","adf","bce","bcf","bde","bdf"]+--+-- @+-- > [1,2]^!!folded.act (\i -> putStr (show i ++ ": ") >> getLine).each.to succ+-- 1: aa+-- 2: bb+-- "bbcc"+-- @+(^!!) :: Monad m => s -> Acting m [a] s a -> m [a]+a ^!! l = getEffect (l (Effect #. return . return) a)+{-# INLINE (^!!) #-}++-- | Perform a 'MonadicFold' and collect the leftmost result.+--+-- /Note:/ this still causes all effects for all elements.+--+-- >>> [Just 1, Just 2, Just 3]^!?folded.acts+-- Just (Just 1)+-- >>> [Just 1, Nothing]^!?folded.acts+-- Nothing+(^!?) :: Monad m => s -> Acting m (Leftmost a) s a -> m (Maybe a)+a ^!?  l = liftM getLeftmost .# getEffect $ l (Effect #. return . LLeaf) a+{-# INLINE (^!?) #-}++-- | Construct an 'Action' from a monadic side-effect.+--+-- >>> ["hello","world"]^!folded.act (\x -> [x,x ++ "!"])+-- ["helloworld","helloworld!","hello!world","hello!world!"]+--+-- @+-- 'act' :: 'Monad' m => (s -> m a) -> 'Action' m s a+-- 'act' sma afb a = 'effective' (sma a '>>=' 'ineffective' '.' afb)+-- @+act :: Monad m => (s -> m a) -> IndexPreservingAction m s a+act sma pafb = cotabulate $ \ws -> effective $ do+   a <- sma (extract ws)+   ineffective (corep pafb (a <$ ws))+{-# INLINE act #-}++-- | A self-running 'Action', analogous to 'Control.Monad.join'.+--+-- @+-- 'acts' ≡ 'act' 'id'+-- @+--+-- >>> (1,"hello")^!_2.acts.to succ+-- "ifmmp"+--+-- @+-- > (1,getLine)^!!_2.acts.folded.to succ+-- aa+-- "bb"+-- @+acts :: IndexPreservingAction m (m a) a+acts = act id+{-# INLINE acts #-}++-- | Apply a 'Monad' transformer to an 'Action'.+liftAct :: (MonadTrans trans, Monad m) => Acting m a s a -> IndexPreservingAction (trans m) s a+liftAct l = act (lift . perform l)+{-# INLINE liftAct #-}++-----------------------------------------------------------------------------+-- Indexed Actions+----------------------------------------------------------------------------++-- | Used to evaluate an 'IndexedAction'.+type IndexedActing i m r s a = Over (Indexed i) (Effect m r) s s a a++-- | Perform an 'IndexedAction'.+--+-- @+-- 'iperform' ≡ 'flip' ('^@!')+-- @+iperform :: Monad m => IndexedActing i m (i, a) s a -> s -> m (i, a)+iperform l = getEffect #. l (Indexed $ \i a -> Effect (return (i, a)))+{-# INLINE iperform #-}++-- | Perform an 'IndexedAction' and modify the result.+iperforms :: Monad m => IndexedActing i m e s a -> (i -> a -> e) -> s -> m e+iperforms l = performs l .# Indexed+{-# INLINE iperforms #-}++-- | Perform an 'IndexedAction'.+(^@!) :: Monad m => s -> IndexedActing i m (i, a) s a -> m (i, a)+s ^@! l = getEffect (l (Indexed $ \i a -> Effect (return (i, a))) s)+{-# INLINE (^@!) #-}++-- | Obtain a list of all of the results of an 'IndexedMonadicFold'.+(^@!!) :: Monad m => s -> IndexedActing i m [(i, a)] s a -> m [(i, a)]+s ^@!! l = getEffect (l (Indexed $ \i a -> Effect (return [(i, a)])) s)+{-# INLINE (^@!!) #-}++-- | Perform an 'IndexedMonadicFold' and collect the 'Leftmost' result.+--+-- /Note:/ this still causes all effects for all elements.+(^@!?) :: Monad m => s -> IndexedActing i m (Leftmost (i, a)) s a -> m (Maybe (i, a))+a ^@!?  l = liftM getLeftmost .# getEffect $ l (Indexed $ \i -> Effect #. return . LLeaf . (,) i) a+{-# INLINE (^@!?) #-}++-- | Construct an 'IndexedAction' from a monadic side-effect.+iact :: Monad m => (s -> m (i, a)) -> IndexedAction i m s a+iact smia iafb s = effective $ do+  (i, a) <- smia s+  ineffective (indexed iafb i a)+{-# INLINE iact #-}
+ src/Control/Lens/Action/Internal.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+#ifdef TRUSTWORTHY+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Lens.Internal.Action+-- Copyright   :  (C) 2012-2014 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  non-portable+--+----------------------------------------------------------------------------+module Control.Lens.Action.Internal+  (+  -- ** Actions+    Effective(..)+  , Effect(..)+  ) where++import Control.Applicative+import Control.Applicative.Backwards+import Control.Monad+import Data.Functor.Bind+import Data.Functor.Contravariant+import Data.Functor.Identity+import Data.Profunctor.Unsafe+import Data.Semigroup++import Control.Lens.Internal.Getter++-------------------------------------------------------------------------------+-- Programming with Effects+-------------------------------------------------------------------------------++-- | An 'Effective' 'Functor' ignores its argument and is isomorphic to a 'Monad' wrapped around a value.+--+-- That said, the 'Monad' is possibly rather unrelated to any 'Applicative' structure.+class (Monad m, Functor f, Contravariant f) => Effective m r f | f -> m r where+  effective :: m r -> f a+  ineffective :: f a -> m r++instance Effective m r f => Effective m (Dual r) (Backwards f) where+  effective = Backwards . effective . liftM getDual+  {-# INLINE effective #-}+  ineffective = liftM Dual . ineffective . forwards+  {-# INLINE ineffective #-}++instance Effective Identity r (Const r) where+  effective = Const #. runIdentity+  {-# INLINE effective #-}+  ineffective = Identity #. getConst+  {-# INLINE ineffective #-}++instance Effective m r f => Effective m r (AlongsideLeft f b) where+  effective = AlongsideLeft . effective+  {-# INLINE effective #-}+  ineffective = ineffective . getAlongsideLeft+  {-# INLINE ineffective #-}++instance Effective m r f => Effective m r (AlongsideRight f b) where+  effective = AlongsideRight . effective+  {-# INLINE effective #-}+  ineffective = ineffective . getAlongsideRight+  {-# INLINE ineffective #-}++------------------------------------------------------------------------------+-- Effect+------------------------------------------------------------------------------++-- | Wrap a monadic effect with a phantom type argument.+newtype Effect m r a = Effect { getEffect :: m r }+-- type role Effect representational nominal phantom++instance Functor (Effect m r) where+  fmap _ (Effect m) = Effect m+  {-# INLINE fmap #-}++instance Contravariant (Effect m r) where+  contramap _ (Effect m) = Effect m+  {-# INLINE contramap #-}++instance Monad m => Effective m r (Effect m r) where+  effective = Effect+  {-# INLINE effective #-}+  ineffective = getEffect+  {-# INLINE ineffective #-}++instance (Apply m, Semigroup r) => Semigroup (Effect m r a) where+  Effect ma <> Effect mb = Effect (liftF2 (<>) ma mb)+  {-# INLINE (<>) #-}++instance (Monad m, Monoid r) => Monoid (Effect m r a) where+  mempty = Effect (return mempty)+  {-# INLINE mempty #-}+  Effect ma `mappend` Effect mb = Effect (liftM2 mappend ma mb)+  {-# INLINE mappend #-}++instance (Apply m, Semigroup r) => Apply (Effect m r) where+  Effect ma <.> Effect mb = Effect (liftF2 (<>) ma mb)+  {-# INLINE (<.>) #-}++instance (Monad m, Monoid r) => Applicative (Effect m r) where+  pure _ = Effect (return mempty)+  {-# INLINE pure #-}+  Effect ma <*> Effect mb = Effect (liftM2 mappend ma mb)+  {-# INLINE (<*>) #-}
+ src/Control/Lens/Action/Reified.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+#ifdef TRUSTWORTHY+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Lens.Action.Reified+-- Copyright   :  (C) 2012-14 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+----------------------------------------------------------------------------+module Control.Lens.Action.Reified where++import Control.Applicative+import Control.Arrow+import qualified Control.Category as Cat+import Control.Lens hiding ((<.>))+import Control.Monad+import Control.Monad.Reader.Class+import Data.Functor.Bind+import Data.Functor.Plus+import Data.Profunctor+import Data.Semigroup++import Control.Lens.Action++------------------------------------------------------------------------------+-- MonadicFold+------------------------------------------------------------------------------++-- | Reify a 'MonadicFold' so it can be stored safely in a container.+--+newtype ReifiedMonadicFold m s a = MonadicFold { runMonadicFold :: MonadicFold m s a }++instance Profunctor (ReifiedMonadicFold m) where+  dimap f g l = MonadicFold (to f . runMonadicFold l . to g)+  {-# INLINE dimap #-}+  rmap g l = MonadicFold (runMonadicFold l . to g)+  {-# INLINE rmap #-}+  lmap f l = MonadicFold (to f . runMonadicFold l)+  {-# INLINE lmap #-}++instance Strong (ReifiedMonadicFold m) where+  first' l = MonadicFold $ \f (s,c) ->+    coerce $ runMonadicFold l (dimap (flip (,) c) coerce f) s+  {-# INLINE first' #-}+  second' l = MonadicFold $ \f (c,s) ->+    coerce $ runMonadicFold l (dimap ((,) c) coerce f) s+  {-# INLINE second' #-}++instance Choice (ReifiedMonadicFold m) where+  left' (MonadicFold l) = MonadicFold $+    to tuplify.beside (folded.l.to Left) (folded.to Right)+    where+      tuplify (Left lval) = (Just lval,Nothing)+      tuplify (Right rval) = (Nothing,Just rval)+  {-# INLINE left' #-}++instance Cat.Category (ReifiedMonadicFold m) where+  id = MonadicFold id+  l . r = MonadicFold (runMonadicFold r . runMonadicFold l)+  {-# INLINE (.) #-}++instance Arrow (ReifiedMonadicFold m) where+  arr f = MonadicFold (to f)+  {-# INLINE arr #-}+  first = first'+  {-# INLINE first #-}+  second = second'+  {-# INLINE second #-}++instance ArrowChoice (ReifiedMonadicFold m) where+  left = left'+  {-# INLINE left #-}+  right = right'+  {-# INLINE right #-}++instance ArrowApply (ReifiedMonadicFold m) where+  app = MonadicFold $ \cHandler (argFold,b) ->+     runMonadicFold (pure b >>> argFold) cHandler (argFold,b)+  {-# INLINE app #-}++instance Functor (ReifiedMonadicFold m s) where+  fmap f l = MonadicFold (runMonadicFold l.to f)+  {-# INLINE fmap #-}++instance Apply (ReifiedMonadicFold m s) where+  mf <.> ma = mf &&& ma >>> (MonadicFold $ to (uncurry ($)))+  {-# INLINE (<.>) #-}++instance Applicative (ReifiedMonadicFold m s) where+  pure a = MonadicFold $ folding $ \_ -> [a]+  {-# INLINE pure #-}+  mf <*> ma = mf <.> ma+  {-# INLINE (<*>) #-}++instance Alternative (ReifiedMonadicFold m s) where+  empty = MonadicFold ignored+  {-# INLINE empty #-}+  MonadicFold ma <|> MonadicFold mb = MonadicFold $ to (\x->(x,x)).beside ma mb+  {-# INLINE (<|>) #-}++instance Bind (ReifiedMonadicFold m s) where+  ma >>- f = ((ma >>^ f) &&& returnA) >>> app +  {-# INLINE (>>-) #-}++instance Monad (ReifiedMonadicFold m s) where+  return a = MonadicFold $ folding $ \_ -> [a]+  {-# INLINE return #-}+  ma >>= f = ((ma >>^ f) &&& returnA) >>> app +  {-# INLINE (>>=) #-}++instance MonadReader s (ReifiedMonadicFold m s) where+  ask = returnA+  {-# INLINE ask #-}+  local f ma = f ^>> ma +  {-# INLINE local #-}++instance MonadPlus (ReifiedMonadicFold m s) where+  mzero = empty+  {-# INLINE mzero #-}+  mplus = (<|>)+  {-# INLINE mplus #-}++instance Semigroup (ReifiedMonadicFold m s a) where+  (<>) = (<|>)+  {-# INLINE (<>) #-}++instance Monoid (ReifiedMonadicFold m s a) where+  mempty = MonadicFold ignored+  {-# INLINE mempty #-}+  mappend = (<|>)+  {-# INLINE mappend #-}++instance Alt (ReifiedMonadicFold m s) where+  (<!>) = (<|>)+  {-# INLINE (<!>) #-}++instance Plus (ReifiedMonadicFold m s) where+  zero = MonadicFold ignored+  {-# INLINE zero #-}+
+ tests/doctests.hsc view
@@ -0,0 +1,73 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Main (doctests)+-- Copyright   :  (C) 2012-14 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- 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 Test.DocTest++##if defined(mingw32_HOST_OS)+##if defined(i386_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##elif defined(x86_64_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##endif+##endif++-- | Run in a modified codepage where we can print UTF-8 values on Windows.+withUnicode :: IO a -> IO a+##ifdef USE_CP+withUnicode m = do+  cp <- c_GetConsoleCP+  (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp+##else+withUnicode m = m+##endif++main :: IO ()+main = withUnicode $ 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