git.iko.soy/patch
on dpatch-map-inner-patch help sign in
patch/src/Data/Patch/Class.hs
171 lines 5.8 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DefaultSignatures #-}
3{-# LANGUAGE DerivingStrategies #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE PolyKinds #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE TypeOperators #-}
11-- | The interface for types which represent changes made to other types
12module Data.Patch.Class where
14import qualified Data.Semigroupoid as Cat
15import Data.Functor.Identity
16import Data.Functor.Misc
17import Data.Kind (Type)
18import Data.Maybe
19#if !MIN_VERSION_base(4,11,0)
20import Data.Semigroup (Semigroup(..))
21#endif
22import Data.Proxy
23import Data.Type.Equality ((:~:) (..))
25class PatchHet p where
26 type PatchSource p :: Type
27 type PatchTarget p :: Type
28 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
29 -- 'Nothing'.
30 applyHet
31 :: p
32 -> PatchSource p
33 -> Either (PatchSource p :~: PatchTarget p) (PatchTarget p)
34 default applyHet
35 :: Patch p
36 => p
37 -> PatchSource p
38 -> Either (PatchSource p :~: PatchTarget p) (PatchTarget p)
39 applyHet p a = case apply p a of
40 Nothing -> Left Refl
41 Just a' -> Right a'
43-- | Apply a 'PatchHet'; if it does nothing, return the original value
44applyAlwaysHet :: PatchHet p => p -> PatchSource p -> PatchTarget p
45applyAlwaysHet p t = case applyHet p t of
46 Left Refl -> t
47 Right t' -> t'
49-- | A 'Patch' type represents a kind of change made to a datastructure.
50--
51-- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey
52-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.
53class ( PatchHet p
54 , PatchSource p ~ PatchTarget p
55 ) => Patch p where
56 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
57 -- 'Nothing'.
58 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
60-- | Apply a 'Patch'; if it does nothing, return the original value
61applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p
62applyAlways p t = fromMaybe t $ apply p t
64-- | 'Identity' can be used as a 'Patch' that always fully replaces the value
65instance PatchHet (Identity a) where
66 type PatchSource (Identity a) = a
67 type PatchTarget (Identity a) = a
68instance Patch (Identity a) where
69 apply (Identity a) _ = Just a
71-- | 'Proxy' can be used as a 'Patch' that does nothing.
72instance forall (a :: Type). PatchHet (Proxy a) where
73 type PatchSource (Proxy a) = a
74 type PatchTarget (Proxy a) = a
75instance forall (a :: Type). Patch (Proxy a) where
76 apply ~Proxy _ = Nothing
78-- | Like '(.)', but composes functions that return patches rather than
79-- functions that return new values. The Semigroup instance for patches must
80-- apply patches right-to-left, like '(.)'.
81composePatchFunctions
82 :: (Patch p, Semigroup p)
83 => (PatchTarget p -> p)
84 -> (PatchTarget p -> p)
85 -> PatchTarget p -> p
86composePatchFunctions g f a =
87 let fp = f a
88 in g (applyAlways fp a) <> fp
91class PatchHet2Base (p :: k -> k -> *) where
92 type PatchSource1 p :: k -> *
93 type PatchTarget1 p :: k -> *
95class ( PatchHet2Base p
96 , PatchHet (p from to)
97 , PatchSource1 p from ~ PatchSource (p from to)
98 , PatchTarget1 p to ~ PatchTarget (p from to)
99 ) => PatchHet2Locally (p :: k -> k -> *) from to where
100instance ( PatchHet2Base p
101 , PatchHet (p from to)
102 , PatchSource1 p from ~ PatchSource (p from to)
103 , PatchTarget1 p to ~ PatchTarget (p from to)
104 ) => PatchHet2Locally (p :: k -> k -> *) from to where
106applyHet2Locally
107 :: PatchHet2Locally p from to
108 => p from to
109 -> PatchSource1 p from
110 -> Either (PatchSource1 p from :~: PatchTarget1 p to) (PatchTarget1 p to)
111applyHet2Locally = applyHet
113applyAlwaysHet2Locally
114 :: PatchHet2Locally p from to
115 => p from to
116 -> PatchSource1 p from
117 -> PatchTarget1 p to
118applyAlwaysHet2Locally = applyAlwaysHet
120-- TODO once we can use quantified constraints, perhaps combine PatchHet2Base and
121-- PatchHet2Locally, or at least get rid of this.
122class PatchHet2Base p => PatchHet2 (p :: k -> k -> *) where
123 applyHet2
124 :: p from to
125 -> PatchSource1 p from
126 -> Either (PatchSource1 p from :~: PatchTarget1 p to) (PatchTarget1 p to)
128applyAlwaysHet2
129 :: PatchHet2 p
130 => p from to
131 -> PatchSource1 p from
132 -> PatchTarget1 p to
133applyAlwaysHet2 p t = case applyHet2 p t of
134 Left Refl -> t
135 Right t' -> t'
137-- | Connect the classes without quanitified constraints
138newtype ProjectLocal p from to = ProjectLocal { unProjectLocal :: p from to }
139 deriving newtype Cat.Semigroupoid
141instance PatchHet2 p => PatchHet (ProjectLocal p from to) where
142 type PatchSource (ProjectLocal p from to) = PatchSource1 p from
143 type PatchTarget (ProjectLocal p from to) = PatchTarget1 p to
144 applyHet (ProjectLocal p) = applyHet2 p
146instance PatchHet2 p => PatchHet2Base (ProjectLocal p) where
147 type PatchSource1 (ProjectLocal p) = PatchSource1 p
148 type PatchTarget1 (ProjectLocal p) = PatchTarget1 p
150class ( PatchHet2Base p
151 , PatchSource1 p ~ PatchTarget1 p
152 ) => Patch2 p
153instance ( PatchHet2Base p
154 , PatchSource1 p ~ PatchTarget1 p
155 ) => Patch2 p
157-- | 'First2' can be used as a 'Patch' that always fully replaces the value
158instance PatchHet (First2 (t :: k -> *) (from :: k) (to :: k)) where
159 type PatchSource (First2 t from to) = t from
160 type PatchTarget (First2 t from to) = t to
161 applyHet (First2 val) _ = Right val
163-- | 'Proxy3' can be used as a 'Patch' that always does nothing
164instance PatchHet (Proxy3 (t :: k -> *) (a :: k) (a :: k)) where
165 type PatchSource (Proxy3 t a a) = t a
166 type PatchTarget (Proxy3 t a a) = t a
167 applyHet ~Proxy3 _ = Left Refl
169instance PatchHet2Base (Proxy3 (t :: k -> *) :: k -> k -> *) where
170 type PatchSource1 (Proxy3 t) = t
171 type PatchTarget1 (Proxy3 t) = t