generic-maybe (empty) → 0.1.0.0
raw patch · 6 files changed
+679/−0 lines, 6 filesdep +basedep +bytestringdep +containersbuild-type:Customsetup-changed
Dependencies added: base, bytestring, containers, deepseq, directory, doctest, filepath, generic-deriving, hlint, lens, mtl, nats, parallel, semigroups, simple-reflect, split, text, unordered-containers, vector
Files
- LICENSE +30/−0
- Setup.lhs +52/−0
- generic-maybe.cabal +112/−0
- src/Generics/Maybe.hs +389/−0
- tests/doctests.hsc +73/−0
- tests/hlint.hs +23/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Jonathan Fischoff++All rights reserved.++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.++ * 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.++ * Neither the name of Jonathan Fischoff nor the names of other+ 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+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.
+ Setup.lhs view
@@ -0,0 +1,52 @@+#!/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 )+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 )+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+ }++haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath+haddockOutputDir flags pkg = destDir where+ baseDir = case haddockDistPref flags of+ NoFlag -> "."+ Flag x -> x+ destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)++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}
+ generic-maybe.cabal view
@@ -0,0 +1,112 @@+-- Initial generic-maybe.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: generic-maybe+version: 0.1.0.0+synopsis: A generic version of Data.Maybe+description:+ This module is a drop in replacement for 'Data.Maybe.Maybe'. It generalizes+ the functions to any types that share the same \"sum of products\" view+ of 'Data.Maybe.Maybe'.+ .+ To use the module for you type, enable GHC's DeriveGeneric extension and+ derive a Generic instance for your type.+ .+ > import GHC.Generics+ > + > data Result a = Success a | Fail+ > deriving (Show, Generic)+ .+ After which you can use the functions, like your type was 'Data.Maybe.Maybe'+ .+ >> fromMaybe 'a' Fail+ >Success 'a'+ . + >> fromMaybe 'a' $ Success 'b'+ >Success 'b'+homepage: https://github.com/jfischoff/generic-maybe+license: BSD3+license-file: LICENSE+author: Jonathan Fischoff+maintainer: jonathangfischoff@gmail.com+-- copyright: +category: Generics+build-type: Custom+-- extra-source-files: +cabal-version: >=1.10++-- You can disable the doctests test suite with -f-test-doctests+flag test-doctests+ default: True+ manual: True+ +-- You can disable the hlint test suite with -f-test-hlint+-- Disabled until the LambdaCase extension is added src-exts+flag test-hlint+ default: False+ manual: False+ +library+ exposed-modules: Generics.Maybe+ -- other-modules: + other-extensions: DeriveGeneric+ , TypeFamilies+ , TypeOperators+ , MultiParamTypeClasses+ , FunctionalDependencies+ , FlexibleContexts+ , LambdaCase+ , FlexibleInstances+ , ConstraintKinds+ build-depends: base >=4.6 && <4.7+ , lens >=3.10 && < 5.0+ hs-source-dirs: src+ default-language: Haskell2010+ + ghc-options: -Wall+ +test-suite doctests+ type: exitcode-stdio-1.0+ main-is: doctests.hs+ ghc-options: -Wall -threaded+ hs-source-dirs: tests+ default-language: Haskell2010++ if !flag(test-doctests)+ buildable: False+ else+ build-depends:+ base,+ bytestring,+ containers,+ directory >= 1.0,+ deepseq,+ doctest >= 0.9.1,+ filepath,+ generic-deriving,+ mtl,+ nats,+ parallel,+ semigroups >= 0.9,+ simple-reflect >= 0.3.1,+ split,+ text,+ unordered-containers,+ vector++ if impl(ghc<7.6.1)+ ghc-options: -Werror+ +test-suite hlint+ type: exitcode-stdio-1.0+ main-is: hlint.hs+ ghc-options: -w -threaded -rtsopts -with-rtsopts=-N+ hs-source-dirs: tests+ default-language: Haskell2010++ if !flag(test-hlint)+ buildable: False+ else+ build-depends:+ base,+ hlint >= 1.7
+ src/Generics/Maybe.hs view
@@ -0,0 +1,389 @@+{- | This module is a drop in replacement for 'Data.Maybe.Maybe'. It generalizes+ the functions to any types that share the same \"sum of products\" view+ of 'Data.Maybe.Maybe'.+ + To use the module for you type, enable GHC's DeriveGeneric extension and+ derive a Generic instance for your type.+ + @+import GHC.Generics+ + data Result a = Success a | Fail+ deriving (Show, Generic)++ data Nat = Zero | Succ Nat+ deriving (Show, Generic)+ @+ + After which you can use the function, like your type was 'Data.Maybe.Maybe'+-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FunctionalDependencies #-}+module Generics.Maybe + ( MaybeLike+ , fromMaybe+ , maybe+ , isJust+ , isNothing+ , fromJust+ , listToMaybe+ , maybeToList+ , catMaybes+ , mapMaybe+ -- * Exported for groking, but not for implementing.+ , GMaybeLike+ , G+ ) where+import GHC.Generics+ ( Generic(..),+ U1(..),+ K1(K1),+ M1(..),+ type (:+:)(..),+ Rec0,+ C1,+ S1 )+import Control.Lens ( Iso', Iso, over, iso, view )+import Generics.Deriving.Lens ( generic )+import qualified Control.Lens.Iso as Iso+import Prelude hiding (maybe)++-- DocTest setup++-- $setup+-- >>> :set -XDeriveGeneric+-- >>> data Nat = Zero | Succ Nat deriving (Show, Generic)+-- >>> data Result a = Success a | Fail deriving (Show, Generic)++-- | A constraint synonym to make the type signatures look better.+-- The 'd u m b y' type variables can be ignored.+type MaybeLike maybe a d u m b y = + ( Generic maybe+ , GMaybeLike (Rep maybe) (G d u m b y a)+ )++-- | A generalized version of 'Data.Maybe.fromMaybe'+--+-- > fromMaybe :: a -> Maybe a -> Maybe a+--+-- >>> fromMaybe 'a' Nothing+-- Just 'a'+-- +-- >>> fromMaybe 'a' $ Just 'b'+-- Just 'b'+-- +-- >>> fromMaybe 'a' Fail+-- Success 'a'+-- +-- >>> fromMaybe 'a' $ Success 'b'+-- Success 'b'+-- +-- >>> fromMaybe Zero Zero+-- Succ Zero+-- +-- >>> fromMaybe Zero $ Succ (Succ Zero)+-- Succ (Succ Zero)+fromMaybe :: MaybeLike maybe a d u m b y+ => a -> maybe -> maybe+fromMaybe x = over gsimple (fromMaybe' x) ++fromMaybe' :: a + -> (U1 :+: Rec0 a) b+ -> (U1 :+: Rec0 a) b+fromMaybe' def = \case + L1 U1 -> R1 $ K1 def+ x -> x +-- | A generalized version of 'Data.Maybe.maybe' +--+-- > maybe :: b -> (a -> b) -> Maybe a -> Maybe b+--+-- >>> maybe (1 :: Int) (+1) Nothing+-- 1+--+-- >>> maybe 1 (+1) $ Just 1+-- 2+--+-- >>> maybe (1 :: Int) (+1) Fail+-- 1+--+-- >>> maybe 1 (+1) $ Success 1+-- 2+--+-- >>> maybe (Succ Zero) Succ Zero+-- Succ Zero+--+-- >>> maybe (Succ Zero) Succ $ Succ (Succ Zero)+-- Succ (Succ Zero)+maybe :: MaybeLike maybe a d u m b' y+ => b -> (a -> b) -> maybe -> b+maybe def f = maybe' def f . view gsimple+ +maybe' :: b -> (a -> b) -> (U1 :+: Rec0 a) x -> b+maybe' def f = \case+ L1 U1 -> def+ R1 (K1 x) -> f x ++-- | A generalized version of 'Data.Maybe.isJust'+--+-- > isJust :: Maybe a -> Bool+--+-- >>> isJust Nothing+-- False+-- +-- >>> isJust $ Just 'a'+-- True+--+-- >>> isJust Fail+-- False+-- +-- >>> isJust $ Success 'a'+-- True+-- +-- >>> isJust Zero+-- False+-- +-- >>> isJust $ Succ Zero+-- True+isJust :: MaybeLike maybe a d u m b y+ => maybe -> Bool+isJust = isJust' . view gsimple++isJust' :: (U1 :+: Rec0 a) b -> Bool+isJust' = \case+ L1 {} -> False+ R1 {} -> True++-- | A generalized version of 'Data.Maybe.isNothing'+--+-- > isNothing :: Maybe a -> Bool+--+-- >>> isNothing Nothing+-- True+--+-- >>> isNothing $ Just 'a'+-- False+--+-- >>> isNothing Fail+-- True+--+-- >>> isNothing $ Success 'a'+-- False+-- +-- >>> isNothing Zero+-- True+-- +-- >>> isNothing $ Succ Zero+-- False+isNothing :: MaybeLike maybe a d u m b y+ => maybe -> Bool +isNothing = isNothing' . view gsimple+ +isNothing' :: (U1 :+: Rec0 a) b -> Bool+isNothing' = \case+ L1 {} -> True+ R1 {} -> False++-- | A generalized version of 'Data.Maybe.fromJust'+--+-- > fromJust :: Maybe a -> a+--+-- >>> fromJust Nothing+-- *** Exception: Generics.fromJust. You shouldn't really use this.+-- +-- >>> fromJust $ Just 'a'+-- 'a'+--+-- >>> fromJust Fail+-- *** Exception: Generics.fromJust. You shouldn't really use this.+-- +-- >>> fromJust $ Success 'a'+-- 'a'+--+-- >>> fromJust Zero+-- *** Exception: Generics.fromJust. You shouldn't really use this.+--+-- >>> fromJust $ Succ Zero+-- Zero+fromJust :: MaybeLike maybe a d u m b y+ => maybe -> a +fromJust = fromJust' . view gsimple+ +fromJust' :: (U1 :+: Rec0 a) b -> a+fromJust' (R1 (K1 x)) = x+fromJust' _ = error "Generics.fromJust. You shouldn't really use this."++-- | A generalized version of 'Data.Maybe.listToMaybe'+--+-- > listToMaybe :: [a] -> Maybe a+--+-- >>> listToMaybe ['a', 'b'] :: Maybe Char+-- Just 'a'+-- +-- >>> listToMaybe [] :: Maybe Char+-- Nothing+--+-- >>> listToMaybe ['a', 'b'] :: Result Char+-- Success 'a'+-- +-- >>> listToMaybe [] :: Result Char+-- Fail+--+-- >>> listToMaybe [Zero, Succ Zero] :: Nat+-- Succ Zero+--+-- >>> listToMaybe [] :: Nat+-- Zero+listToMaybe :: MaybeLike maybe a d u m b y+ => [a] -> maybe+listToMaybe = view (Iso.from gsimple) . listToMaybe' + +listToMaybe' :: [a] -> (U1 :+: Rec0 a) b+listToMaybe' = \case+ x:_ -> R1 $ K1 x+ [] -> L1 U1++-- | A generalized version of 'Data.Maybe.maybeToList'+--+-- > maybeToList :: Maybe a -> [a]+--+-- >>> maybeToList $ Just True+-- [True]+--+-- >>> maybeToList Nothing+-- []+--+-- >>> maybeToList $ Success True+-- [True]+--+-- >>> maybeToList Fail+-- []+-- +-- >>> maybeToList $ Succ Zero+-- [Zero]+-- +-- >>> maybeToList Zero+-- []+maybeToList :: MaybeLike maybe a d u m b y+ => maybe -> [a]+maybeToList = maybeToList' . view gsimple++maybeToList' :: (U1 :+: Rec0 a) b -> [a]+maybeToList' = \case+ L1 {} -> []+ R1 (K1 x) -> [x]++-- | A generalized version of 'Data.Maybe.catMaybes'+--+-- > catMaybes :: [Maybe a] -> [a]+--+-- >>> catMaybes [Just True, Nothing, Just False]+-- [True,False]+--+-- >>> catMaybes [Success True, Fail, Success False]+-- [True,False]+--+-- >>> catMaybes [Succ Zero, Zero, Succ Zero]+-- [Zero,Zero]+catMaybes :: MaybeLike maybe a d u m b y+ => [maybe] -> [a]+catMaybes = catMaybes' . map (view gsimple) ++catMaybes' :: [(U1 :+: Rec0 a) b] -> [a]+catMaybes' xs = [x | R1 (K1 x) <- xs]++-- | A generalized version of 'Data.Maybe.mapMaybe'+--+-- > mapMaybe :: (a -> Maybe b) -> [a] -> [b]+--+-- >>> mapMaybe (\x -> if x then Just "True" else Nothing) [True, False, True]+-- ["True","True"]+--+-- >>> mapMaybe (\x -> if x then Success "True" else Fail) [True, False, True]+-- ["True","True"]+-- +-- >>> mapMaybe (\x -> if x then Succ Zero else Zero) [True, False, True]+-- [Zero,Zero]+mapMaybe :: MaybeLike maybe a' d u m b y+ => (a -> maybe) -> [a] -> [a']+mapMaybe f = mapMaybe' (view gsimple . f) ++mapMaybe' :: (a -> (U1 :+: Rec0 b) x) -> [a] -> [b]+mapMaybe' _ [] = []+mapMaybe' f (x:xs) =+ let ys = mapMaybe' f xs in+ case f x of+ L1 {} -> ys+ R1 (K1 y) -> y:ys+-------------------------------------------------------------------------------+-- Utils+-------------------------------------------------------------------------------++-- | A silly type synonym to make the signatures look better.+-- None of the type variables matter except @any@.+-- Read @G@eneric maybe+type G m a y b e any = M1 m a (C1 y U1 :+: C1 b (S1 e (Rec0 any)))++m1 :: Iso (M1 i c f p) (M1 i' c' f' p') (f p) (f' p')+m1 = iso unM1 M1++commuteSum :: (f :+: g) p -> (g :+: f) p+commuteSum = \case + L1 x -> R1 x+ R1 x -> L1 x++-- | This type class is used to swap the order of constructors so+-- unit shows up first.+--+-- > (M1 m a (C1 b (S1 e (Rec0 any)) :+: C1 y U1)) +--+-- will become+-- +-- > (M1 m a (C1 y U1 :+: C1 b (S1 e (Rec0 any))))+-- +-- and+-- +-- > (M1 m a (C1 y U1 :+: C1 b (S1 e (Rec0 any))))+-- +-- is unchanged+-- +-- Thus, there are only two instances and should only be, forever+-- and always ... I think.+class GMaybeLike f g | f -> g where+ gmaybelike :: Iso' (f p) (g p)+ +instance GMaybeLike (G m a y b e any) (G m a y b e any) where+ gmaybelike = iso id id ++-- commute :+: +instance GMaybeLike (M1 m a (C1 b (S1 e (Rec0 any)) :+: C1 y U1)) + (G m a y b e any) where+ gmaybelike = iso invo invo where+ invo = over m1 commuteSum++-- Get rid of all the meta info+clean :: Iso (G m a y b e any p)+ (G m' a' y' b' e' any' p')+ ((U1 :+: Rec0 any) p)+ ((U1 :+: Rec0 any') p')+clean = iso fw bk where+ fw (M1 x) = case x of+ L1 (M1 l) -> L1 l+ R1 (M1 (M1 r)) -> R1 r+ bk = \case+ L1 l -> M1 $ L1 $ M1 $ l+ R1 r -> M1 $ R1 $ M1 $ M1 $ r++-- Convert to the simplified generic form+gsimple :: ( Generic maybe+ , GMaybeLike (Rep maybe) (G m a y b e any)+ )+ => Iso' maybe ((U1 :+: Rec0 any) p)+gsimple = generic . gmaybelike . clean
+ 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
+ tests/hlint.hs view
@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- Module : Main (hlint)+-- Copyright : (C) 2013-2014 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- This module runs HLint on the lens source tree.+-----------------------------------------------------------------------------+module Main where++import Control.Monad+import Language.Haskell.HLint+import System.Environment+import System.Exit++main :: IO ()+main = do+ args <- getArgs+ hints <- hlint $ ["src", "--cpp-define=HLINT", "--cpp-ansi"] ++ args+ unless (null hints) exitFailure