1 files changed, 94 insertions, 0 deletions
diff --git a/src/Accessor.hs b/src/Accessor.hs
new file mode 100644
index 0000000..a1623fc
--- /dev/null
+++ b/src/Accessor.hs
@@ -0,0 +1,94 @@
+module Accessor
+    ( accessor
+    , Accessor
+    , view
+    , over
+    , set
+    , (#)
+    , (#>)
+    , listAcc
+    , fstAcc
+    , sndAcc
+    , self
+    , _0, _1, _2, _3, _4
+    , _5, _6, _7, _8, _9
+    )
+where
+
+type Accessor s a r = (a -> a) -> s -> (s, r)
+
+accessor :: (s -> a) -> (a -> s -> s) -> Accessor s a a
+accessor getter setter f x = (setter newVal x, getter x) where
+  newVal = f (getter x)
+
+view :: Accessor s a b -> s -> b
+view acc = snd . acc id
+
+over :: Accessor s a b -> (a -> a) -> s -> s
+over acc f = fst . acc f
+
+set :: Accessor s a b ->  a -> s -> s
+set acc x = over acc (const x)
+
+infixr #
+
+(#) ::
+    Accessor obj middle middle -> Accessor middle end end -> Accessor obj end end
+(#) = composeAccessors where
+  composeAccessors ac1 ac2 modifier obj =
+    (newObj, value)
+    where
+      newObj = over ac1 (over ac2 modifier) obj
+      value = view ac2 (view ac1 obj)
+
+infixr #>
+
+(#>) :: (Functor f) =>
+    Accessor obj (f middle) (f middle) -> Accessor middle end result
+    -> Accessor obj end (f result)
+(#>) = composeFunctorAccesors where
+  composeFunctorAccesors ac1 ac2 modifier obj =
+    (newObj, value)
+    where
+      newObj = over ac1 (fmap $ over ac2 modifier) obj
+      value = fmap (view ac2) (view ac1 obj)
+
+self :: Accessor a a a
+self = accessor id const 
+
+listAcc :: Int -> Accessor [a] a a
+listAcc idx = accessor getter setter where
+    getter = (!! max 0 idx)
+    setter n lst = take idx lst ++ [n] ++ drop (idx + 1) lst
+
+_0 :: Accessor [a] a a
+_1 :: Accessor [a] a a
+_2 :: Accessor [a] a a
+_3 :: Accessor [a] a a
+_4 :: Accessor [a] a a
+_5 :: Accessor [a] a a
+_6 :: Accessor [a] a a
+_7 :: Accessor [a] a a
+_8 :: Accessor [a] a a
+_9 :: Accessor [a] a a
+
+_0 = listAcc 0
+_1 = listAcc 1
+_2 = listAcc 2
+_3 = listAcc 3
+_4 = listAcc 4
+_5 = listAcc 5
+_6 = listAcc 6
+_7 = listAcc 7
+_8 = listAcc 8
+_9 = listAcc 9
+
+fstAcc :: Accessor (a, b) a a
+fstAcc = accessor getter setter where
+    getter (a, _) = a
+    setter n x = (n, snd x)
+
+sndAcc :: Accessor (a, b) b b
+sndAcc = accessor getter setter where
+    getter (_, b) = b
+    setter n x = (fst x, n)