git.iko.soy/typeable/control-has
on master help sign in
swap
8dc547411 ahead, 0 behind
.gitignorenew file+1
since splitsnapshots
unifiedsplit
@@ -0,0 +1 @@
1+.stack-work
LICENSEnew file+2
@@ -0,0 +1,2 @@
1+Copyright © 2020, Antorica LLC
2+All rights reserved
control-has.cabal+39−37
@@ -1,39 +1,41 @@
1+cabal-version: 2.4
1−name: control-has
2+name: control-has
2−version: 0.1.0.0
3+version: 0.2.0.0
3−synopsis: Typeclass for things that have parts
4+synopsis: Typeclass for things that have parts
4−license: AllRightsReserved
5+license-file: LICENSE
5−build-type: Simple
6+build-type: Simple
6−cabal-version: >=1.10
7
7
8library
8library
9− hs-source-dirs: src
9+ hs-source-dirs: src
10− ghc-options: -Wall
10+ ghc-options: -Wall
11− exposed-modules: Control.Has
11+ exposed-modules:
12− Control.EnvT
12+ Control.EnvT
13+ Control.Has
14+
13− build-depends: base
15+ build-depends:
16+ , base >=4.10
14− , exceptions
17+ , exceptions
15− , lens
18+ , lens
16− , monad-control
19+ , monad-control
17− , mtl
20+ , mtl
18− , resourcet
21+ , resourcet
19− , transformers-base
22+ , transformers-base
20− if !impl(ghcjs)
23+
21− build-depends: katip
22− , missing-lens
23− default-language: Haskell2010
24+ default-language: Haskell2010
24− default-extensions: ConstraintKinds
25+ default-extensions:
26+ ConstraintKinds
25− , DataKinds
27+ DataKinds
26− , DefaultSignatures
28+ DefaultSignatures
27− , DerivingStrategies
29+ DerivingStrategies
28− , FlexibleContexts
30+ FlexibleContexts
29− , FlexibleInstances
31+ FlexibleInstances
30− , FunctionalDependencies
32+ FunctionalDependencies
31− , GADTs
33+ GADTs
32− , GeneralizedNewtypeDeriving
34+ GeneralizedNewtypeDeriving
33− , KindSignatures
35+ KindSignatures
34− , RankNTypes
36+ RankNTypes
35− , StandaloneDeriving
37+ StandaloneDeriving
36− , TypeOperators
37− , TypeFamilies
38+ TypeFamilies
39+ TypeOperators
38− , UndecidableInstances
40+ UndecidableInstances
39− , UndecidableSuperClasses
41+ UndecidableSuperClasses
src/Control/EnvT.hs+15−18
@@ -1,8 +1,10 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2+{-# LANGUAGE TemplateHaskell #-}
2
3
3module Control.EnvT
4module Control.EnvT
4 ( EnvT(..)
5 ( EnvT(..)
5 , runEnvT
6 , runEnvT
7+ , execEnvT
6 , module X
8 , module X
7 ) where
9 ) where
8
10
@@ -12,17 +14,19 @@ import Control.Lens
12import Control.Monad.Base
14import Control.Monad.Base
13import Control.Monad.Catch
15import Control.Monad.Catch
14import Control.Monad.Except
16import Control.Monad.Except
15−import Control.Monad.Fail
16import Control.Monad.Reader as X
17import Control.Monad.Reader as X
17import Control.Monad.Trans.Control
18import Control.Monad.Trans.Control
18import Control.Monad.Trans.Resource
19import Control.Monad.Trans.Resource
19import Control.Monad.Zip
20import Control.Monad.Zip
20−#ifndef ghcjs_HOST_OS
21+
22+#if MIN_VERSION_mtl(2,3,0)
21−import Control.Lens.Missing
23+import Control.Monad
22−import Katip
24+import Control.Monad.Fix
23−import Katip.Monadic
24#endif
25#endif
25
26
27+#if !MIN_VERSION_base(4,13,0)
28+import Control.Monad.Fail
29+#endif
26
30
27-- | The only reason this exists is that there are a lot of instances for
31-- | The only reason this exists is that there are a lot of instances for
28-- 'EnvT, which simply pass the implementation to the inner 'm'
32-- 'EnvT, which simply pass the implementation to the inner 'm'
@@ -52,22 +56,15 @@ deriving newtype instance
52 (MonadBaseControl b m, Monad m)
56 (MonadBaseControl b m, Monad m)
53 => MonadBaseControl b (EnvT r m)
57 => MonadBaseControl b (EnvT r m)
54
58
59+-- | Run 'EnvT' transformer.
55runEnvT :: forall r m a. EnvT r m a -> r -> m a
60runEnvT :: forall r m a. EnvT r m a -> r -> m a
56runEnvT m r = flip runReaderT r . unEnvT $ m
61runEnvT m r = flip runReaderT r . unEnvT $ m
62+{-# INLINE runEnvT #-}
57
63
58−#ifndef ghcjs_HOST_OS
64+-- | Same as 'runEnvT' but with arguments flipped.
59−instance (Has KatipContextTState r, MonadIO m)
65+execEnvT :: forall r m a. r -> EnvT r m a -> m a
60− => KatipContext (EnvT r m) where
66+execEnvT = flip runEnvT
61− getKatipContext = view $ part . _ltsContext
67+{-# INLINE execEnvT #-}
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
71
68
72instance MonadResource m => MonadResource (EnvT r m) where
69instance MonadResource m => MonadResource (EnvT r m) where
73 liftResourceT = lift . liftResourceT
70 liftResourceT = lift . liftResourceT
src/Control/Has.hs+17−16
@@ -6,11 +6,14 @@ module Control.Has
6 , MonadHas
6 , MonadHas
7 , Fieldy
7 , Fieldy
8 , Generic
8 , Generic
9− )
10−where
9+ ) where
11
10
12import Control.Lens
11import Control.Lens
12+-- reexport all from Reader except Control.Monad etc
13+-- to correspond mtl-2.3+
13import Control.Monad.Reader as X
14import Control.Monad.Reader as X
15+ ( MonadReader(..), asks, Reader, runReader, mapReader, withReader
16+ , ReaderT(ReaderT), runReaderT, mapReaderT, withReaderT )
14import Data.Kind
17import Data.Kind
15import GHC.Generics as G
18import GHC.Generics as G
16
19
@@ -21,11 +24,11 @@ class Has x r where
21instance {-# OVERLAPS #-} Has r r where
24instance {-# OVERLAPS #-} Has r r where
22 part = id
25 part = id
23
26
24−type family HasAll (xs :: [*]) r :: Constraint where
27+type family HasAll (xs :: [Type]) r :: Constraint where
25 HasAll '[] r = ()
28 HasAll '[] r = ()
26 HasAll (x ': xs) r = (Has x r, HasAll xs r)
29 HasAll (x ': xs) r = (Has x r, HasAll xs r)
27
30
28−data LensList (r :: *) (es :: [*]) where
31+data LensList (r :: Type) (es :: [Type]) where
29 LLNil :: LensList r '[]
32 LLNil :: LensList r '[]
30 LLCons :: Lens r r e e -> LensList r es -> LensList r (e ': es)
33 LLCons :: Lens r r e e -> LensList r es -> LensList r (e ': es)
31
34
@@ -33,7 +36,7 @@ mapLL :: Lens s s r r -> LensList r es -> LensList s es
33mapLL _ LLNil = LLNil
36mapLL _ LLNil = LLNil
34mapLL m (LLCons l ls) = LLCons (m . l) (mapLL m ls)
37mapLL m (LLCons l ls) = LLCons (m . l) (mapLL m ls)
35
38
36−type family (xs :: [*]) ++ (ys :: [*]) :: [*] where
39+type family (xs :: [Type]) ++ (ys :: [Type]) :: [Type] where
37 '[] ++ ys = ys
40 '[] ++ ys = ys
38 (x ': xs) ++ ys = x ': (xs ++ ys)
41 (x ': xs) ++ ys = x ': (xs ++ ys)
39
42
@@ -44,7 +47,7 @@ concatLL (LLCons l ls) ys = LLCons l (concatLL ls ys)
44-- borrowed from Data.HSet.Get
47-- borrowed from Data.HSet.Get
45data N = Z | S N
48data N = Z | S N
46
49
47−type family IndexOf (x :: *) (xs :: [*]) :: N where
50+type family IndexOf (x :: Type) (xs :: [Type]) :: N where
48 IndexOf x (x ': _) = 'Z
51 IndexOf x (x ': _) = 'Z
49 IndexOf x (_ ': xs) = 'S (IndexOf x xs)
52 IndexOf x (_ ': xs) = 'S (IndexOf x xs)
50
53
@@ -53,8 +56,8 @@ class (i ~ IndexOf e es) => GetLens e es i | i es -> e where
53
56
54type Elem e es = GetLens e es (IndexOf e es)
57type Elem e es = GetLens e es (IndexOf e es)
55
58
56−class Fieldy (r :: *) where
59+class Fieldy (r :: Type) where
57− type Fields r :: [*]
60+ type Fields r :: [Type]
58 type Fields r = GFields (Rep r)
61 type Fields r = GFields (Rep r)
59 lensList :: LensList r (Fields r)
62 lensList :: LensList r (Fields r)
60 default lensList
63 default lensList
@@ -65,9 +68,7 @@ class Fieldy (r :: *) where
65instance {-# OVERLAPPABLE #-} (Fieldy r, Elem e (Fields r)) => Has e r where
68instance {-# OVERLAPPABLE #-} (Fieldy r, Elem e (Fields r)) => Has e r where
66 part = getLens lensList
69 part = getLens lensList
67
70
68−class (MonadReader r m, HasAll es r)
69− => MonadHas (es :: [*]) (r :: *) (m :: * -> *) | m -> r
70−instance (MonadReader r m, HasAll es r) => MonadHas es r m
71+type MonadHas es r m = (MonadReader r m, HasAll es r)
71
72
72instance GetLens e (e ': es) 'Z where
73instance GetLens e (e ': es) 'Z where
73 getLens (LLCons l _) = l
74 getLens (LLCons l _) = l
@@ -76,16 +77,16 @@ instance (GetLens e' es n, 'S n ~ IndexOf e' (e ': es))
76 => GetLens e' (e ': es) ('S n) where
77 => GetLens e' (e ': es) ('S n) where
77 getLens (LLCons _ ls) = getLens ls
78 getLens (LLCons _ ls) = getLens ls
78
79
79−class GFieldy (r :: * -> *) where
80+class GFieldy (r :: Type -> Type) where
80− type GFields r :: [*]
81+ type GFields r :: [Type]
81 glensList :: LensList (r x) (GFields r)
82 glensList :: LensList (r x) (GFields r)
82
83
83instance GFieldyProduct r => GFieldy (D1 d (C1 c r)) where
84instance GFieldyProduct r => GFieldy (D1 d (C1 c r)) where
84 type GFields (D1 d (C1 c r)) = GFieldsProduct r
85 type GFields (D1 d (C1 c r)) = GFieldsProduct r
85 glensList = mapLL (iso unM1 M1 . iso unM1 M1) glensListProduct
86 glensList = mapLL (iso unM1 M1 . iso unM1 M1) glensListProduct
86
87
87−class GFieldyProduct (r :: * -> *) where
88+class GFieldyProduct (r :: Type -> Type) where
88− type GFieldsProduct r :: [*]
89+ type GFieldsProduct r :: [Type]
89 glensListProduct :: LensList (r x) (GFieldsProduct r)
90 glensListProduct :: LensList (r x) (GFieldsProduct r)
90
91
91instance (GFieldyProduct r, GFieldyProduct s) => GFieldyProduct (r :*: s) where
92instance (GFieldyProduct r, GFieldyProduct s) => GFieldyProduct (r :*: s) where
@@ -104,7 +105,7 @@ instance GFieldyProduct (S1 s (K1 k r)) where
104 type GFieldsProduct (S1 s (K1 k r)) = '[r]
105 type GFieldsProduct (S1 s (K1 k r)) = '[r]
105 glensListProduct = LLCons (iso unM1 M1 . iso unK1 K1) LLNil
106 glensListProduct = LLCons (iso unM1 M1 . iso unK1 K1) LLNil
106
107
107−type family AllElem (xs :: [*]) (es :: [*]) :: Constraint where
108+type family AllElem (xs :: [Type]) (es :: [Type]) :: Constraint where
108 AllElem '[] _ = ()
109 AllElem '[] _ = ()
109 AllElem (x ': xs) es = (Elem x es, AllElem xs es)
110 AllElem (x ': xs) es = (Elem x es, AllElem xs es)
110
111