diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,4 +1,10 @@ # Revision history for boring + +## 0.1 + +- `streams`, `constraints`, `generics-sop` instances. +- Reversed dependency with `vec`, add `fin` instances. + ## 0 - First version. Released on an unsuspecting world. diff --git a/boring.cabal b/boring.cabal --- a/boring.cabal +++ b/boring.cabal @@ -1,5 +1,5 @@ name: boring -version: 0 +version: 0.1 synopsis: Boring and Absurd types description: * @Boring@ types are isomorphic to @()@. @@ -19,12 +19,11 @@ extra-source-files: ChangeLog.md cabal-version: >=1.10 tested-with: - GHC==7.4.2, - GHC==7.6.3, GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, - GHC==8.2.1 + GHC==8.2.2, + GHC==8.4.1 source-repository head type: git @@ -34,14 +33,21 @@ exposed-modules: Data.Boring build-depends: - base >=4.5 && <4.11, - adjunctions >=4.3 && <4.4, - tagged >=0.8.5 && <0.9, - transformers >=0.3 && <0.6 + base >=4.7 && <4.12, + base-compat >=0.9.3 && <0.11, + adjunctions >=4.4 && <4.5, + constraints ==0.4.1.3 || >=0.10 && <0.11, + fin >=0.0.1 && <0.1, + generics-sop >=0.3.2.0 && <0.4, + tagged >=0.8.5 && <0.9, + streams >=3.3 && <3.4, + transformers >=0.3 && <0.6, + transformers-compat >=0.5 && <0.7, + vec >=0.1 && <0.2 if !impl(ghc >= 8.0) build-depends: - semigroups >=0.18.3 && <0.19 + semigroups >=0.18.4 && <0.19 if !impl(ghc >= 7.10) build-depends: void >=0.7.2 && <0.8 diff --git a/src/Data/Boring.hs b/src/Data/Boring.hs --- a/src/Data/Boring.hs +++ b/src/Data/Boring.hs @@ -1,7 +1,10 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE UndecidableInstances #-} -- | 'Boring' and 'Absurd' classes. One approach. -- -- Different approach would be to have @@ -54,16 +57,31 @@ vacuous, boringRep, untainted, + devoid, + united, ) where +import Prelude () +import Prelude.Compat + import Control.Applicative (Const (..)) import Data.Functor.Identity (Identity (..)) +import Data.Functor.Compose (Compose (..)) +import Data.Functor.Product (Product (..)) +import Data.Functor.Sum (Sum (..)) import Data.Functor.Rep (Representable (..)) +import Data.Constraint (Dict (..)) import Data.List.NonEmpty (NonEmpty (..)) import Data.Proxy (Proxy (..)) import Data.Tagged (Tagged (..)) +import Data.Stream.Infinite (Stream (..)) -import qualified Data.Void as V +import qualified Data.Fin as Fin +import qualified Data.Nat as Nat +import qualified Data.Vec.Lazy as Vec +import qualified Data.Vec.Pull as Vec.Pull +import qualified Data.Void as V +import qualified Generics.SOP as SOP #if MIN_VERSION_base(4,7,0) import qualified Data.Type.Equality as Eq @@ -94,7 +112,7 @@ -- @('Boring' a, 'Absurd' b) => Either a b@ and -- @('Absurd' a, 'Boring' b) => Either a b@ would be valid instances. -- --- Another useful trick, is that you can rewrite computations with +-- Another useful trick, is that you can rewrite computations with -- 'Boring' results, for example @foo :: Int -> ()@, __if__ you are sure -- that @foo@ is __total__. -- @@ -117,12 +135,27 @@ instance Boring a => Boring (Const a b) where boring = Const boring -instance Boring b => Boring (Tagged a b) where +instance Boring b => Boring (Tagged a b) where boring = Tagged boring instance Boring a => Boring (Identity a) where boring = Identity boring +instance Boring a => Boring (SOP.I a) where + boring = SOP.I boring + +instance Boring b => Boring (SOP.K b a) where + boring = SOP.K boring + +instance Boring (f (g a)) => Boring (Compose f g a) where + boring = Compose boring + +instance (Boring (f a), Boring (g a)) => Boring (Product f g a) where + boring = Pair boring boring + +instance c => Boring (Dict c) where + boring = Dict + instance (Boring a, Boring b) => Boring (a, b) where boring = (boring, boring) @@ -135,6 +168,9 @@ instance (Boring a, Boring b, Boring c, Boring d, Boring e) => Boring (a, b, c, d, e) where boring = (boring, boring, boring, boring, boring) +instance Boring a => Boring (Stream a) where + boring = boring :> boring + -- | Recall regular expressions, kleene star of empty regexp is epsilon! instance Absurd a => Boring [a] where boring = [] @@ -149,6 +185,15 @@ boring = Eq.Refl #endif +instance n ~ 'Nat.Z => Boring (Vec.Vec n a) where + boring = Vec.empty + +instance n ~ 'Nat.Z => Boring (Vec.Pull.Vec n a) where + boring = Vec.Pull.empty + +instance n ~ ('Nat.S 'Nat.Z) => Boring (Fin.Fin n) where + boring = Fin.boring + ------------------------------------------------------------------------------- -- Absurd ------------------------------------------------------------------------------- @@ -172,9 +217,34 @@ instance Absurd a => Absurd (NonEmpty a) where absurd (x :| _) = absurd x +instance Absurd a => Absurd (Stream a) where + absurd (x :> _) = absurd x + instance Absurd a => Absurd (Identity a) where absurd = absurd . runIdentity +instance Absurd (f (g a)) => Absurd (Compose f g a) where + absurd = absurd . getCompose + +instance (Absurd (f a), Absurd (g a)) => Absurd (Sum f g a) where + absurd (InL fa) = absurd fa + absurd (InR ga) = absurd ga + +instance Absurd b => Absurd (Const b a) where + absurd = absurd . getConst + +instance Absurd a => Absurd (Tagged b a) where + absurd = absurd . unTagged + +instance Absurd a => Absurd (SOP.I a) where + absurd = absurd . SOP.unI + +instance Absurd b => Absurd (SOP.K b a) where + absurd = absurd . SOP.unK + +instance n ~ 'Nat.Z => Absurd (Fin.Fin n) where + absurd = Fin.absurd + ------------------------------------------------------------------------------- -- More interesting stuff ------------------------------------------------------------------------------- @@ -193,3 +263,20 @@ -- See also @Settable@ class in @lens@. untainted :: (Representable f, Boring (Rep f)) => f a -> a untainted = flip index boring + +-- | There is a field for every type in the 'Absurd'. Very zen. +-- +-- @ +-- 'devoid' :: 'Absurd' s => Over p f s s a b +-- @ +-- type Over p f s t a b = p a (f b) -> s -> f t +devoid :: Absurd s => p a (f b) -> s -> f s +devoid _ = absurd + +-- | We can always retrieve a 'Boring' value from any type. +-- +-- @ +-- 'united' :: 'Boring' a => Lens' s a +-- @ +united :: (Boring a, Functor f) => (a -> f a) -> s -> f s +united f v = v <$ f boring