git.iko.soy/typeable/control-has
on master help sign in
Extract Common.Has into a separate package (#4755)
83199abYuras
Setup.hsnew file+2
compare with master
unifiedsplit
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
control-has.cabalnew file+39
@@ -0,0 +1,39 @@
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
7+
8+library
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.hsnew file+73
@@ -0,0 +1,73 @@
1+{-# LANGUAGE CPP #-}
2+
3+module Control.EnvT
4+ ( EnvT(..)
5+ , runEnvT
6+ , module X
7+ ) where
8+
9+import Control.Applicative
10+import Control.Has
11+import Control.Lens
12+import Control.Monad.Base
13+import Control.Monad.Catch
14+import Control.Monad.Except
15+import Control.Monad.Fail
16+import Control.Monad.Reader as X
17+import Control.Monad.Trans.Control
18+import Control.Monad.Trans.Resource
19+import Control.Monad.Zip
20+#ifndef ghcjs_HOST_OS
21+import Control.Lens.Missing
22+import Katip
23+import Katip.Monadic
24+#endif
25+
26+
27+-- | 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'
29+-- such as 'MonadLogger'.
30+newtype EnvT r m a = EnvT { unEnvT :: ReaderT r m a}
31+ deriving newtype (Functor, Applicative, Alternative, Monad
32+ , MonadFix, MonadFail, Contravariant, MonadZip, MonadIO, MonadPlus)
33+
34+instance MonadTrans (EnvT r) where
35+ lift = EnvT . lift
36+
37+deriving newtype instance Monad m => MonadReader r (EnvT r m)
38+deriving newtype instance MonadCatch m => MonadCatch (EnvT r m)
39+deriving newtype instance MonadThrow m => MonadThrow (EnvT r m)
40+deriving newtype instance MonadMask m => MonadMask (EnvT r m)
41+deriving newtype instance MonadError e m => MonadError e (EnvT r m)
42+
43+deriving newtype instance
44+ ( MonadBase b m
45+ , Applicative b
46+ , Applicative m
47+ , Monad b
48+ , Monad m )
49+ => MonadBase b (EnvT r m)
50+
51+deriving newtype instance
52+ (MonadBaseControl b m, Monad m)
53+ => MonadBaseControl b (EnvT r m)
54+
55+runEnvT :: forall r m a. EnvT r m a -> r -> m a
56+runEnvT m r = flip runReaderT r . unEnvT $ m
57+
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
71+
72+instance MonadResource m => MonadResource (EnvT r m) where
73+ liftResourceT = lift . liftResourceT
src/Control/Has.hsnew file+116
@@ -0,0 +1,116 @@
1+
2+module Control.Has
3+ ( module X
4+ , Has(..)
5+ , HasAll
6+ , MonadHas
7+ , Fieldy
8+ , Generic
9+ )
10+where
11+
12+import Control.Lens
13+import Control.Monad.Reader as X
14+import Data.Kind
15+import GHC.Generics as G
16+
17+
18+class Has x r where
19+ part :: Lens r r x x
20+
21+instance {-# OVERLAPS #-} Has r r where
22+ part = id
23+
24+type family HasAll (xs :: [*]) r :: Constraint where
25+ HasAll '[] r = ()
26+ HasAll (x ': xs) r = (Has x r, HasAll xs r)
27+
28+data LensList (r :: *) (es :: [*]) where
29+ LLNil :: LensList r '[]
30+ LLCons :: Lens r r e e -> LensList r es -> LensList r (e ': es)
31+
32+mapLL :: Lens s s r r -> LensList r es -> LensList s es
33+mapLL _ LLNil = LLNil
34+mapLL m (LLCons l ls) = LLCons (m . l) (mapLL m ls)
35+
36+type family (xs :: [*]) ++ (ys :: [*]) :: [*] where
37+ '[] ++ ys = ys
38+ (x ': xs) ++ ys = x ': (xs ++ ys)
39+
40+concatLL :: LensList r es1 -> LensList r es2 -> LensList r (es1 ++ es2)
41+concatLL LLNil ys = ys
42+concatLL (LLCons l ls) ys = LLCons l (concatLL ls ys)
43+
44+-- borrowed from Data.HSet.Get
45+data N = Z | S N
46+
47+type family IndexOf (x :: *) (xs :: [*]) :: N where
48+ IndexOf x (x ': _) = 'Z
49+ IndexOf x (_ ': xs) = 'S (IndexOf x xs)
50+
51+class (i ~ IndexOf e es) => GetLens e es i | i es -> e where
52+ getLens :: LensList r es -> Lens r r e e
53+
54+type Elem e es = GetLens e es (IndexOf e es)
55+
56+class Fieldy (r :: *) where
57+ type Fields r :: [*]
58+ type Fields r = GFields (Rep r)
59+ lensList :: LensList r (Fields r)
60+ default lensList
61+ :: (Generic r, GFieldy (Rep r), Fields r ~ (GFields (Rep r)))
62+ => LensList r (Fields r)
63+ lensList = mapLL (iso G.from G.to) glensList
64+
65+instance {-# OVERLAPPABLE #-} (Fieldy r, Elem e (Fields r)) => Has e r where
66+ part = getLens lensList
67+
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+
72+instance GetLens e (e ': es) 'Z where
73+ getLens (LLCons l _) = l
74+
75+instance (GetLens e' es n, 'S n ~ IndexOf e' (e ': es))
76+ => GetLens e' (e ': es) ('S n) where
77+ getLens (LLCons _ ls) = getLens ls
78+
79+class GFieldy (r :: * -> *) where
80+ type GFields r :: [*]
81+ glensList :: LensList (r x) (GFields r)
82+
83+instance GFieldyProduct r => GFieldy (D1 d (C1 c r)) where
84+ type GFields (D1 d (C1 c r)) = GFieldsProduct r
85+ glensList = mapLL (iso unM1 M1 . iso unM1 M1) glensListProduct
86+
87+class GFieldyProduct (r :: * -> *) where
88+ type GFieldsProduct r :: [*]
89+ glensListProduct :: LensList (r x) (GFieldsProduct r)
90+
91+instance (GFieldyProduct r, GFieldyProduct s) => GFieldyProduct (r :*: s) where
92+ type GFieldsProduct (r :*: s) = GFieldsProduct r ++ GFieldsProduct s
93+ glensListProduct =
94+ concatLL
95+ (mapLL (lens lget lset) glensListProduct)
96+ (mapLL (lens rget rset) glensListProduct)
97+ where
98+ lget (l :*: _) = l
99+ lset (_ :*: r) l = l :*: r
100+ rget (_ :*: r) = r
101+ rset (l :*: _) r = l :*: r
102+
103+instance GFieldyProduct (S1 s (K1 k r)) where
104+ type GFieldsProduct (S1 s (K1 k r)) = '[r]
105+ glensListProduct = LLCons (iso unM1 M1 . iso unK1 K1) LLNil
106+
107+type family AllElem (xs :: [*]) (es :: [*]) :: Constraint where
108+ AllElem '[] _ = ()
109+ AllElem (x ': xs) es = (Elem x es, AllElem xs es)
110+
111+instance Fieldy (a, b)
112+instance Fieldy (a, b, c)
113+instance Fieldy (a, b, c, d)
114+instance Fieldy (a, b, c, d, e)
115+instance Fieldy (a, b, c, d, e, f)
116+instance Fieldy (a, b, c, d, e, f, g)