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