diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | CHANGELOG.md | 5 | ||||
| -rw-r--r-- | LICENSE | 20 | ||||
| -rw-r--r-- | Readme.md | 79 | ||||
| -rw-r--r-- | accessor-hs.cabal | 76 | ||||
| -rw-r--r-- | src/Accessor.hs | 94 | ||||
| -rw-r--r-- | test/AccessorTest.hs | 125 |
7 files changed, 400 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..48a004c --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist-newstyle diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..d507eeb --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for accessor-hs + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. @@ -0,0 +1,20 @@ +Copyright (c) 2025 Mistivia + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Readme.md b/Readme.md new file mode 100644 index 0000000..c3b408c --- /dev/null +++ b/Readme.md @@ -0,0 +1,79 @@ +# Accessor + +After trying very hard, I have to admit that my mind is too weak to understand lens. So I decided to roll my own data access library with no fancy categories but only getters, setters and fmaps chained together. + +To get started: + + import Accessor + +An accessors is a getter with a setter. + +For record fields, the accessors are defined as follow: + + data Point = Point {_x :: Int, _y :: Int} + + x = accessor _x (\elem record -> record {x = elem}) + y = accessor _y (\elem record -> record {y = elem}) + +With an accessor, you can view, set, and tranform data of the record: + + point = Point 1 2 + view x point -- 1 + set x 3 point -- Point 3 2 + over x (+1) point -- Point 2 2 + +For a nested record, accessors can be composed usine `(#)`: + + data Line = Line {_start :: Point, _end :: Point} + start = accessor _start (\elem record -> record {_start = elem}) + end = accessor _end (\elem record -> record {_end = elem}) + + + data Point = Point {_x :: Int, _y :: Int} + x = accessor _x (\elem record -> record {_x = elem}) + y = accessor _y (\elem record -> record {_y = elem}) + + line = Line (Point 1 2) (Point 3 4) + + start_x = view (start # x) line -- 1 + end_y = view (start # y) line -- 4 + +If the field is a functor, the accessor should be composed with the next accesor using `(#>)`. For exmaple: + + data Person = Person {_name :: String, _addr = Maybe Address } + name = accessor _name (\elem record -> record {_name = elem}) + addr= accessor _addr (\elem record -> record {_addr = elem}) + + data Address = Address {_detail :: String, _code :: String } + detail = accessor _detail (\elem record -> record {_detail = elem}) + code = accessor _code (\elem record -> record {_code = elem}) + +Let there be Alice living in Shanghai: + + alice = Person + { _name = "Alice" + , _addr = Just Address + { _detail = "Shanghai" + , _code = "200000" + } + } + +You can view/modify Alice's address detail: + + s = view (addr #> detail) alice -- Just "Shanghai" + +`fmap` will make sure `Nothing` be handled properly. + +Aceesor of the nth element of a list is `listAt n`, and for 0~9, there are shortcuts `_0`~`_9`. + + view _1 [1,2,3] -- 2 + view (_1 # _1) [[1,2,3], [4,5,6]] -- 5 + set _0 42 [1,2,3] -- [42,2,3] + over _1 (+1) [1,2,3] -- [1,3,3] + +Lists are also functors, so you can `fmap` over it using `(#>)`, which is the same as `map`: + + over (self #> self) (+1) [1,2,3] -- [2,3,4] + over (_1 #> self) (+1) [[1,2], [2,3]] -- [[1,2],[4,5]] + + diff --git a/accessor-hs.cabal b/accessor-hs.cabal new file mode 100644 index 0000000..f5160b8 --- /dev/null +++ b/accessor-hs.cabal @@ -0,0 +1,76 @@ +cabal-version: 3.0 +-- The cabal-version field refers to the version of the .cabal specification, +-- and can be different from the cabal-install (the tool) version and the +-- Cabal (the library) version you are using. As such, the Cabal (the library) +-- version used must be equal or greater than the version stated in this field. +-- Starting from the specification version 2.2, the cabal-version field must be +-- the first thing in the cabal file. + +-- Initial package description 'accessor-hs' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: accessor-hs + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +-- synopsis: + +-- A longer description of the package. +-- description: + +-- The license under which the package is released. +license: MIT + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Mistivia + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: i@mistivia.com + +-- A copyright notice. +-- copyright: +category: Data +build-type: Simple + +-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. +extra-doc-files: CHANGELOG.md + +-- Extra source files to be distributed with the package, such as examples, or a tutorial module. +-- extra-source-files: + +common warnings + ghc-options: -Wall -dynamic + +library + import: warnings + + exposed-modules: Accessor + build-depends: base ^>=4.17.2.1 + + hs-source-dirs: src + + default-language: GHC2021 + +test-suite accessor-hs-test + import: warnings + type: exitcode-stdio-1.0 + main-is: AccessorTest.hs + default-language: GHC2021 + hs-source-dirs: test + build-depends: + base ^>=4.17.2.1, + HUnit, + accessor-hs 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) diff --git a/test/AccessorTest.hs b/test/AccessorTest.hs new file mode 100644 index 0000000..861a7a4 --- /dev/null +++ b/test/AccessorTest.hs @@ -0,0 +1,125 @@ +module Main where + +import Accessor +import Test.HUnit +import System.Exit + +testListSet_1 :: Test +testListSet_1 = TestCase (assertEqual "list set 1" expect result) where + result = + let lst = [1,2,3] :: [Int] + in set _0 42 lst + expect = [42,2,3] + +testListSet_2 :: Test +testListSet_2 = TestCase (assertEqual "list set 2" expect result) where + result = + let lst = [[1,2,3],[4,5,6],[7,8,9]] :: [[Int]] + in set (_1 # _1) 42 lst + expect = [[1,2,3],[4,42,6],[7,8,9]] + +testListSet_3 :: Test +testListSet_3 = TestCase (assertEqual "list set 3" expect result) where + result = + let lst = [[1,2,3],[4,5,6],[7,8,9]] :: [[Int]] + in over (_1 #> self) (+1) lst + expect = [[1,2,3],[5,6,7],[7,8,9]] + +testTuple_1 :: Test +testTuple_1 = TestCase (assertEqual "tuple 1" expect result) where + result = view (self #> sndAcc) $ Just (1 :: Int, 42 :: Int) + expect = Just 42 + +testTuple_2 :: Test +testTuple_2 = TestCase (assertEqual "tuple 2" expect result) where + result = view (self #> _1 # _2 # _3) Nothing :: Maybe Int + expect = Nothing + +data Person = Person + { _name :: String, + _address :: Maybe Address + } + deriving (Show) +name :: Accessor Person String String +name = accessor _name (\n x -> x {_name = n}) +address :: Accessor Person (Maybe Address) (Maybe Address) +address = accessor _address (\n x -> x {_address = n}) + +data Address = Address + { _city :: String, + _zipInfos :: [Maybe ZipInfo] + } + deriving (Show) +city :: Accessor Address String String +city = accessor _city (\n x -> x {_city = n}) +zipInfos :: Accessor Address [Maybe ZipInfo] [Maybe ZipInfo] +zipInfos = accessor _zipInfos (\n x -> x {_zipInfos = n}) + +data ZipInfo = ZipInfo + { _code :: String, + _extraInfo :: Maybe String + } + deriving (Show) +code :: Accessor ZipInfo String String +code = accessor _code (\n x -> x {_code = n}) +extraInfo :: Accessor ZipInfo (Maybe String) (Maybe String) +extraInfo = accessor _extraInfo (\n x -> x {_extraInfo = n}) + +recordTests :: [Test] +recordTests = + let + alice = Person + { _name = "Alice" + , _address = Just Address + { _city = "Shanghai" + , _zipInfos = + [ Just ZipInfo + { _code = "200000" + , _extraInfo = Nothing + }, + Just ZipInfo + { _code = "200002" + , _extraInfo = Nothing + } + ] + } + } + in + [ let + tname = "record view" + result = view name alice + expect = "Alice" + in TestCase (assertEqual tname result expect) + , let + tname = "record fmap view" + result = view (address #> city) alice + expect = Just "Shanghai" + in TestCase (assertEqual tname result expect) + , let + tname = "record multiple fmap view" + result = view (address #> zipInfos #> self #> code) alice + expect = Just [Just "200000", Just "200002"] + in TestCase (assertEqual tname expect result) + , let + tname = "record multiple fmap edit" + newAlice = over (address #> zipInfos #> self #> code) (++ "uwu") alice + result = view (address #> zipInfos #> self #> code) newAlice + expect = Just [Just "200000uwu", Just "200002uwu"] + in TestCase (assertEqual tname expect result) + ] + +main :: IO () +main = do + let mytests = TestList $ + [ testListSet_1 + , testListSet_2 + , testListSet_3 + , testTuple_1 + , testTuple_2 + ] + ++ recordTests + results <- runTestTT mytests + if errors results + failures results == 0 then + exitSuccess + else + exitWith (ExitFailure 1) |