master..8f86b64 · typeable/control-has

git.iko.soy/typeable/control-has

on 8f86b64 help sign in

5 files changed+66−72

since splitsnapshots

unifiedsplit

.gitignore−1 LICENSE−2 control-has.cabal+37−39 src/Control/EnvT.hs+18−15 src/Control/Has.hs+11−15

.gitignoredeleted−1

@@ -1 +0,0 @@

1−.stack-work

LICENSEdeleted−2

@@ -1,2 +0,0 @@

control-has.cabal+37−39

@@ -1,41 +1,39 @@

1−cabal-version: 2.4

2−name: control-has

3−version: 0.2.0.0

4−synopsis: Typeclass for things that have parts

5−license-file: LICENSE

6−build-type: Simple

1+name: control-has

2+version: 0.1.0.0

3+synopsis: Typeclass for things that have parts

4+license: AllRightsReserved

5+build-type: Simple

6+cabal-version: >=1.10

88library

9− hs-source-dirs: src

10− ghc-options: -Wall

11− exposed-modules:

12− Control.EnvT

13− Control.Has

14−

15− build-depends:

16− , base >=4.10

17− , exceptions

18− , lens

19− , monad-control

20− , mtl

21− , resourcet

22− , transformers-base

23−

24− default-language: Haskell2010

25− default-extensions:

26− ConstraintKinds

27− DataKinds

28− DefaultSignatures

29− DerivingStrategies

30− FlexibleContexts

31− FlexibleInstances

32− FunctionalDependencies

33− GADTs

34− GeneralizedNewtypeDeriving

35− KindSignatures

36− RankNTypes

37− StandaloneDeriving

38− TypeFamilies

39− TypeOperators

40− UndecidableInstances

41− UndecidableSuperClasses

9+ hs-source-dirs: src

10+ ghc-options: -Wall

11+ exposed-modules: Control.Has

12+ Control.EnvT

13+ build-depends: base

14+ , exceptions

15+ , lens

16+ , monad-control

17+ , mtl

18+ , resourcet

19+ , transformers-base

20+ if !impl(ghcjs)

21+ build-depends: katip

22+ , missing-lens

23+ default-language: Haskell2010

24+ default-extensions: ConstraintKinds

25+ , DataKinds

26+ , DefaultSignatures

27+ , DerivingStrategies

28+ , FlexibleContexts

29+ , FlexibleInstances

30+ , FunctionalDependencies

31+ , GADTs

32+ , GeneralizedNewtypeDeriving

33+ , KindSignatures

34+ , RankNTypes

35+ , StandaloneDeriving

36+ , TypeOperators

37+ , TypeFamilies

38+ , UndecidableInstances

39+ , UndecidableSuperClasses

src/Control/EnvT.hs+18−15

@@ -1,10 +1,8 @@

11{-# LANGUAGE CPP #-}

2−{-# LANGUAGE TemplateHaskell #-}

43module Control.EnvT

54 ( EnvT(..)

65 , runEnvT

7− , execEnvT

86 , module X

97 ) where

108

@@ -14,19 +12,17 @@ import Control.Lens

1412import Control.Monad.Base

1513import Control.Monad.Catch

1614import Control.Monad.Except

15+import Control.Monad.Fail

1716import Control.Monad.Reader as X

1817import Control.Monad.Trans.Control

1918import Control.Monad.Trans.Resource

2019import Control.Monad.Zip

21−

22−#if MIN_VERSION_mtl(2,3,0)

23−import Control.Monad

24−import Control.Monad.Fix

20+#ifndef ghcjs_HOST_OS

21+import Control.Lens.Missing

22+import Katip

23+import Katip.Monadic

2524#endif

2625

27−#if !MIN_VERSION_base(4,13,0)

28−import Control.Monad.Fail

29−#endif

3026

3127-- | The only reason this exists is that there are a lot of instances for

3228-- 'EnvT, which simply pass the implementation to the inner 'm'

@@ -56,15 +52,22 @@ deriving newtype instance

5652 (MonadBaseControl b m, Monad m)

5753 => MonadBaseControl b (EnvT r m)

5854

59−-- | Run 'EnvT' transformer.

6055runEnvT :: forall r m a. EnvT r m a -> r -> m a

6156runEnvT m r = flip runReaderT r . unEnvT $ m

62−{-# INLINE runEnvT #-}

6357

64−-- | Same as 'runEnvT' but with arguments flipped.

65−execEnvT :: forall r m a. r -> EnvT r m a -> m a

66−execEnvT = flip runEnvT

67−{-# INLINE execEnvT #-}

58+#ifndef ghcjs_HOST_OS

59+instance (Has KatipContextTState r, MonadIO m)

60+ => KatipContext (EnvT r m) where

61+ getKatipContext = view $ part . _ltsContext

62+ localKatipContext f = local (part . _ltsContext %~ f)

63+ getKatipNamespace = view $ part . _ltsNamespace

64+ localKatipNamespace f = local (part . _ltsNamespace %~ f)

65+

66+instance (Has KatipContextTState r, MonadIO m)

67+ => Katip (EnvT r m) where

68+ getLogEnv = view $ part . _ltsLogEnv

69+ localLogEnv f = local (part . _ltsLogEnv %~ f)

70+#endif

6871

6972instance MonadResource m => MonadResource (EnvT r m) where

7073 liftResourceT = lift . liftResourceT

src/Control/Has.hs+11−15

@@ -9,11 +9,7 @@ module Control.Has

99 ) where

1010

1111import Control.Lens

12−-- reexport all from Reader except Control.Monad etc

13−-- to correspond mtl-2.3+

1412import Control.Monad.Reader as X

15− ( MonadReader(..), asks, Reader, runReader, mapReader, withReader

16− , ReaderT(ReaderT), runReaderT, mapReaderT, withReaderT )

1713import Data.Kind

1814import GHC.Generics as G

1915

@@ -24,11 +20,11 @@ class Has x r where

2420instance {-# OVERLAPS #-} Has r r where

2521 part = id

2622

27−type family HasAll (xs :: [Type]) r :: Constraint where

23+type family HasAll (xs :: [*]) r :: Constraint where

2824 HasAll '[] r = ()

2925 HasAll (x ': xs) r = (Has x r, HasAll xs r)

3026

31−data LensList (r :: Type) (es :: [Type]) where

27+data LensList (r :: *) (es :: [*]) where

3228 LLNil :: LensList r '[]

3329 LLCons :: Lens r r e e -> LensList r es -> LensList r (e ': es)

3430

@@ -36,7 +32,7 @@ mapLL :: Lens s s r r -> LensList r es -> LensList s es

3632mapLL _ LLNil = LLNil

3733mapLL m (LLCons l ls) = LLCons (m . l) (mapLL m ls)

3834

39−type family (xs :: [Type]) ++ (ys :: [Type]) :: [Type] where

35+type family (xs :: [*]) ++ (ys :: [*]) :: [*] where

4036 '[] ++ ys = ys

4137 (x ': xs) ++ ys = x ': (xs ++ ys)

4238

@@ -47,7 +43,7 @@ concatLL (LLCons l ls) ys = LLCons l (concatLL ls ys)

4743-- borrowed from Data.HSet.Get

4844data N = Z | S N

4945

50−type family IndexOf (x :: Type) (xs :: [Type]) :: N where

46+type family IndexOf (x :: *) (xs :: [*]) :: N where

5147 IndexOf x (x ': _) = 'Z

5248 IndexOf x (_ ': xs) = 'S (IndexOf x xs)

5349

@@ -56,8 +52,8 @@ class (i ~ IndexOf e es) => GetLens e es i | i es -> e where

5652

5753type Elem e es = GetLens e es (IndexOf e es)

5854

59−class Fieldy (r :: Type) where

60− type Fields r :: [Type]

55+class Fieldy (r :: *) where

56+ type Fields r :: [*]

6157 type Fields r = GFields (Rep r)

6258 lensList :: LensList r (Fields r)

6359 default lensList

@@ -77,16 +73,16 @@ instance (GetLens e' es n, 'S n ~ IndexOf e' (e ': es))

7773 => GetLens e' (e ': es) ('S n) where

7874 getLens (LLCons _ ls) = getLens ls

7975

80−class GFieldy (r :: Type -> Type) where

81− type GFields r :: [Type]

76+class GFieldy (r :: * -> *) where

77+ type GFields r :: [*]

8278 glensList :: LensList (r x) (GFields r)

8379

8480instance GFieldyProduct r => GFieldy (D1 d (C1 c r)) where

8581 type GFields (D1 d (C1 c r)) = GFieldsProduct r

8682 glensList = mapLL (iso unM1 M1 . iso unM1 M1) glensListProduct

8783

88−class GFieldyProduct (r :: Type -> Type) where

89− type GFieldsProduct r :: [Type]

84+class GFieldyProduct (r :: * -> *) where

85+ type GFieldsProduct r :: [*]

9086 glensListProduct :: LensList (r x) (GFieldsProduct r)

9187

9288instance (GFieldyProduct r, GFieldyProduct s) => GFieldyProduct (r :*: s) where

@@ -105,7 +101,7 @@ instance GFieldyProduct (S1 s (K1 k r)) where

105101 type GFieldsProduct (S1 s (K1 k r)) = '[r]

106102 glensListProduct = LLCons (iso unM1 M1 . iso unK1 K1) LLNil

107103

108−type family AllElem (xs :: [Type]) (es :: [Type]) :: Constraint where

104+type family AllElem (xs :: [*]) (es :: [*]) :: Constraint where

109105 AllElem '[] _ = ()

110106 AllElem (x ': xs) es = (Elem x es, AllElem xs es)

111107