git.iko.soy/typeable/control-has
on 32f4a77 help sign in
4 files changed+73−62
since splitsnapshots
unifiedsplit
.gitignore−1 control-has.cabal+36−39 src/Control/EnvT.hs+26−7 src/Control/Has.hs+11−15
.gitignoredeleted−1
@@ -1 +0,0 @@
1−.stack-work
control-has.cabal+36−39
@@ -1,41 +1,38 @@
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+cabal-version: 2.4
2+name: control-has
3+version: 0.1.0.0
4+synopsis: Typeclass for things that have parts
5+license-file: LICENSE
6+build-type: Simple
77
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+ default-language: Haskell2010
23+ default-extensions: ConstraintKinds
24+ , DataKinds
25+ , DefaultSignatures
26+ , DerivingStrategies
27+ , FlexibleContexts
28+ , FlexibleInstances
29+ , FunctionalDependencies
30+ , GADTs
31+ , GeneralizedNewtypeDeriving
32+ , KindSignatures
33+ , RankNTypes
34+ , StandaloneDeriving
35+ , TypeOperators
36+ , TypeFamilies
37+ , UndecidableInstances
38+ , UndecidableSuperClasses
src/Control/EnvT.hs+26−7
@@ -14,19 +14,16 @@ import Control.Lens
1414import Control.Monad.Base
1515import Control.Monad.Catch
1616import Control.Monad.Except
17+import Control.Monad.Fail
1718import Control.Monad.Reader as X
1819import Control.Monad.Trans.Control
1920import Control.Monad.Trans.Resource
2021import Control.Monad.Zip
21−
22−#if MIN_VERSION_mtl(2,3,0)
23−import Control.Monad
24−import Control.Monad.Fix
22+#ifndef ghcjs_HOST_OS
23+import Katip
24+import Katip.Monadic
2525#endif
2626
27−#if !MIN_VERSION_base(4,13,0)
28−import Control.Monad.Fail
29−#endif
3027
3128-- | The only reason this exists is that there are a lot of instances for
3229-- 'EnvT, which simply pass the implementation to the inner 'm'
@@ -66,5 +63,27 @@ execEnvT :: forall r m a. r -> EnvT r m a -> m a
6663execEnvT = flip runEnvT
6764{-# INLINE execEnvT #-}
6865
66+#ifndef ghcjs_HOST_OS
67+-- FIXME: These lens should probably be moved into a separate package
68+-- or sent to upstream katip.
69+makeLensesFor
70+ [ ("ltsLogEnv", "_ltsLogEnv")
71+ , ("ltsContext", "_ltsContext")
72+ , ("ltsNamespace", "_ltsNamespace")
73+ ] ''KatipContextTState
74+
75+instance (Has KatipContextTState r, MonadIO m)
76+ => KatipContext (EnvT r m) where
77+ getKatipContext = view $ part . _ltsContext
78+ localKatipContext f = local (part . _ltsContext %~ f)
79+ getKatipNamespace = view $ part . _ltsNamespace
80+ localKatipNamespace f = local (part . _ltsNamespace %~ f)
81+
82+instance (Has KatipContextTState r, MonadIO m)
83+ => Katip (EnvT r m) where
84+ getLogEnv = view $ part . _ltsLogEnv
85+ localLogEnv f = local (part . _ltsLogEnv %~ f)
86+#endif
87+
6988instance MonadResource m => MonadResource (EnvT r m) where
7089 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