barlow-lens (empty) → 0.1.0.0

raw patch · 11 files changed

+977/−0 lines, 11 filesdep +barlow-lensdep +basedep +first-class-families

Dependencies added: barlow-lens, base, first-class-families, generic-lens, lens, profunctors, tasty, tasty-hunit

Files

CHANGELOG.md +11/−0
LICENSE +30/−0
README.hs +269/−0
README.md +271/−0
barlow-lens.cabal +84/−0
src/Data/Lens/Barlow.hs +18/−0
src/Data/Lens/Barlow/Classes.hs +46/−0
src/Data/Lens/Barlow/Construction.hs +52/−0
src/Data/Lens/Barlow/Parser.hs +109/−0
src/Data/Lens/Barlow/Types.hs +27/−0
test/Barlow/Main.hs +60/−0

+ CHANGELOG.md view

@@ -0,0 +1,11 @@+# Changelog for `haskell`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright value (c) 2022++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of value nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.hs view

@@ -0,0 +1,269 @@+{-+# barlow-lens++Barlow lens increases your magnification and lets you see star sparkles.++In other words, `barlow-lens` simplifies creating complex lenses such as record lenses.++This package is a port of [purescript-barlow-lens](https://github.com/sigma-andex/purescript-barlow-lens) based on [generic-lens](https://hackage.haskell.org/package/generic-lens).++## tl;dr+-}++{- FOURMOLU_DISABLE -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DuplicateRecordFields #-}++{- D -}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Use newtype instead of data" #-}++{- E -}+{- FOURMOLU_ENABLE -}++import Control.Lens ((%~), (&), (^.), (^..), (^?))+import Data.Char (toUpper)+import Data.Lens.Barlow+import GHC.Generics++{- D -}++main :: IO ()+main = putStrLn "hello"++{- E -}++{-+## Features++Barlow creates optics for the following types:++- 🥇 [`Records`](#tldr)+- 📦🐈 [`Maybe`](#maybe)+- 🤷🏽‍♀️ [`Either`](#either)+- 📜 [`Traversables`](#traversables)+- 🎁 [`Newtype`](#newtype)+- 🤖 [`Data types`](#data-types)++### Records++`zodiac` ~ field @"zodiac"+-}++data AlphaRecord = AlphaRecord {alpha :: String} deriving (Generic, Show)+data VirgoRecord = VirgoRecord {virgo :: AlphaRecord} deriving (Generic, Show)+data ZodiacRecord = ZodiacRecord {zodiac :: VirgoRecord} deriving (Generic, Show)++sky :: ZodiacRecord+sky = ZodiacRecord{zodiac = VirgoRecord{virgo = AlphaRecord{alpha = "Spica"}}}++spica :: String+spica = sky ^. (bw @"zodiac.virgo.alpha")++-- >>> spica+-- "Spica"++-- >>> alfa = sky ^. barlow @"zodiac.virgo.alfa"+-- The type AlphaRecord does not contain a field named 'alfa'.+-- In the second argument of `(^.)', namely+--   `barlow @"zodiac.virgo.alfa"'+-- In the expression: sky ^. barlow @"zodiac.virgo.alfa"+-- In an equation for `alfa':+--     alfa = sky ^. barlow @"zodiac.virgo.alfa"++{-+### Maybe++Use `?` to zoom into a `Maybe`.++- `?` ~ `_Just :: Prism (Maybe a) (Maybe b) a b`+-}++newtype AlphaMaybe = AlphaMaybe {alpha :: Maybe String} deriving (Generic, Show)+newtype VirgoMaybe = VirgoMaybe {virgo :: Maybe AlphaMaybe} deriving (Generic, Show)+newtype ZodiacMaybe = ZodiacMaybe {zodiac :: Maybe VirgoMaybe} deriving (Generic, Show)++skyMaybe :: ZodiacMaybe+skyMaybe = ZodiacMaybe{zodiac = Just VirgoMaybe{virgo = Just AlphaMaybe{alpha = Just "Spica"}}}++spicaMaybe :: Maybe String+spicaMaybe = skyMaybe ^? bw @"zodiac?.virgo?.alpha?"++-- >>> spicaMaybe+-- Just "Spica"++{-+### Either++Use `<` for `Left` and `>` for `Right` to zoom into an `Either`.++- `<` ~ `_Left :: Prism (Either a c) (Either b c) a b`+- `>` ~ `_Right :: Prism (Either c a) (Either c b) a b`+-}++newtype AlphaLeft = AlphaLeft {alpha :: Either String ()} deriving (Generic, Show)+newtype VirgoRight = VirgoRight {virgo :: Either () AlphaLeft} deriving (Generic, Show)+newtype ZodiacEither = ZodiacEither {zodiac :: Either VirgoRight VirgoRight} deriving (Generic, Show)++skyLeft :: ZodiacEither+skyLeft = ZodiacEither{zodiac = Left VirgoRight{virgo = Right AlphaLeft{alpha = Left "Spica"}}}++starLeftRightLeft :: Maybe String+starLeftRightLeft = skyLeft ^? bw @"zodiac<virgo>alpha<"++-- >>> starLeftRightLeft+-- Just "Spica"++starLeftLeft :: Maybe VirgoRight+starLeftLeft = skyLeft ^? bw @"zodiac>"++-- >>> starLeftLeft+-- Nothing++{-+### Traversables++Use `+` to zoom into `Traversable`s.++- `+` ~ `traversed :: Traversable f => IndexedTraversal Int (f a) (f b) a b`+-}++newtype AlphaLeftRight = AlphaLeftRight {alpha :: Either String String} deriving (Generic, Show)+newtype VirgoLeftRight = VirgoLeftRight {virgo :: Either AlphaLeftRight AlphaLeftRight} deriving (Generic, Show)+newtype ZodiacList = ZodiacList {zodiac :: [VirgoLeftRight]} deriving (Generic, Show)++skyList :: ZodiacList+skyList =+  ZodiacList+    { zodiac =+        [ VirgoLeftRight{virgo = Right AlphaLeftRight{alpha = Left "Spica1"}}+        , VirgoLeftRight{virgo = Right AlphaLeftRight{alpha = Right "Spica2"}}+        , VirgoLeftRight{virgo = Left AlphaLeftRight{alpha = Right "Spica3"}}+        , VirgoLeftRight{virgo = Left AlphaLeftRight{alpha = Left "Spica4"}}+        ]+    }++starList :: [String]+starList = skyList ^.. bw @"zodiac+virgo>alpha>" & bw @"++" %~ toUpper++-- >>> starList+-- ["SPICA2"]++alphaRight :: [AlphaLeftRight]+alphaRight = skyList ^.. bw @"zodiac+virgo>"++-- >>> alphaRight+-- [AlphaLeftRight {alpha = Left "Spica1"},AlphaLeftRight {alpha = Right "Spica2"}]++{-+### Newtype++Use `!` to zoom into a `newtype`.++- `!` ~ `wrappedIso :: Iso s t a b`+-}++newtype AlphaNewtype = AlphaNewtype {alpha :: String} deriving (Generic)+newtype VirgoNewtype = VirgoNewtype {virgo :: AlphaNewtype} deriving (Generic)+newtype ZodiacNewtype = ZodiacNewtype {zodiac :: VirgoNewtype} deriving (Generic)++skyNewtype :: ZodiacNewtype+skyNewtype = ZodiacNewtype (VirgoNewtype (AlphaNewtype "Spica"))++starNewtype :: [Char]+starNewtype = skyNewtype ^. bw @"zodiac!!"++-- >>> starNewtype+-- "Spica"++{-+### Data types++Barlow supports zooming into arbitrary sum and product types as long as there is a `Generic` instance.++Use `%<NAME>` to zoom into sum types, where `<NAME>` is the name of your data constructor. E.g. `%VirgoData` for the data constructor `VirgoData`.++Use `%<INDEX>` to zoom into product types, where `<INDEX>` is a natural number.+Note that counting for product types and tuples usually starts with 1 and not 0.+So the first element of a product is `%1`.++It is more readable if you separate your sum lens from your product lens with a `.` dot.++- `%<NAME>` ~ `_Ctor :: AsConstructor ctor s t a b => Prism s t a b`+- `%<INDEX>` ~ `position :: HasPosition i s t a b => Lens s t a b`+-}++data ZodiacData+  = CarinaData {alpha :: String}+  | VirgoData {alpha :: String, beta :: String, gamma :: String, delta :: String}+  | CanisMaiorData String+  deriving (Generic)++skyData :: ZodiacData+skyData = VirgoData{alpha = "Spica", beta = "Beta Vir", gamma = "Gamma Vir", delta = "Del Vir"}++starData :: [Char]+starData = skyData ^. bw @"%VirgoData%3"++-- >>> starData+-- "Gamma Vir"++{-++## Prerequisites++<details>++  <summary>Spoiler</summary>++- [flake.nix](./flake.nix) - code in this flake is extensively commented.+- [codium-haskell](https://github.com/deemp/flakes/tree/main/templates/codium/haskell#readme) - this flake.+- [codium-haskell-simple](https://github.com/deemp/flakes/tree/main/templates/codium/haskell-simple#readme) - a simplified version of this flake.+- [language-tools/haskell](https://github.com/deemp/flakes/blob/main/language-tools/haskell/flake.nix) - a flake that conveniently provides `Haskell` tools.+- [Conventions](https://github.com/deemp/flakes/blob/main/README/Conventions.md#dev-tools)+- [codium-generic](https://github.com/deemp/flakes/tree/main/templates/codium/generic#readme) - info just about `VSCodium` with extensions.+- [Haskell](https://github.com/deemp/flakes/blob/main/README/Haskell.md) - general info about `Haskell` tools.+- [Troubleshooting](https://github.com/deemp/flakes/blob/main/README/Troubleshooting.md)+- [Prerequisites](https://github.com/deemp/flakes#prerequisites)+- [Nixpkgs support for incremental Haskell builds](https://www.haskellforall.com/2022/12/nixpkgs-support-for-incremental-haskell.html)+- [flakes](https://github.com/deemp/flakes#readme) - my Nix flakes that may be useful for you.++</details>++## Quick start++1. Install Nix - see [how](https://github.com/deemp/flakes/blob/main/README/InstallNix.md).++1. In a new terminal, start a devshell, build and test the app.++    ```console+    nix develop+    cabal build+    cabal test+    ```++1. Write `settings.json` and start `VSCodium`.++    ```console+    nix run .#writeSettings+    nix run .#codium .+    ```++1. Open a `Haskell` file `app/Main.hs` and hover over a function.++1. Wait until `Haskell Language Server` (`HLS`) starts giving you type info.++1. Sometimes, `cabal` doesn't use the `Nix`-supplied packages ([issue](https://github.com/NixOS/nixpkgs/issues/130556#issuecomment-1114239002)). In this case, use `cabal v1-*` - commands.++## Configs++- [package.yaml](./package.yaml) - used by `stack` or `hpack` to generate a `.cabal`+- [.markdownlint.jsonc](./.markdownlint.jsonc) - for `markdownlint` from the extension `davidanson.vscode-markdownlint`+- [.ghcid](./.ghcid) - for [ghcid](https://github.com/ndmitchell/ghcid)+- [.envrc](./.envrc) - for [direnv](https://github.com/direnv/direnv)+- [fourmolu.yaml](./fourmolu.yaml) - for [fourmolu](https://github.com/fourmolu/fourmolu#configuration)+- [ci.yaml](.github/workflows/ci.yaml) - a generated `GitHub Actions` workflow. See [workflows](https://github.com/deemp/flakes/tree/main/workflows). Generate a workflow via `nix run .#writeWorkflows`.+- [hie.yaml](./hie.yaml) - a config for [hie-bios](https://github.com/haskell/hie-bios). Can be generated via [implicit-hie](https://github.com/Avi-D-coder/implicit-hie) to check the `Haskell Language Server` setup.+-}

+ README.md view

@@ -0,0 +1,271 @@+# barlow-lens++Barlow lens increases your magnification and let's you see the stars sparkles++In other words, barlow lens makes creating complex lenses such as record lenses super simple.++This package is a port of [purescript-barlow-lens](https://github.com/sigma-andex/purescript-barlow-lens) based on [generic-lens](https://hackage.haskell.org/package/generic-lens).++## tl;dr++<!-- FOURMOLU_DISABLE -->++```haskell+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DuplicateRecordFields #-}+```++<!-- D++{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Use newtype instead of data" #-}++E -->++<!-- FOURMOLU_ENABLE -->++```haskell+import Control.Lens ((%~), (&), (^.), (^..), (^?))+import Data.Char (toUpper)+import Data.Lens.Barlow+import GHC.Generics+```++<!-- D++main :: IO ()+main = putStrLn "hello"++E -->++## Features++Barlow creates optics for the following types:++- 🥇 [`Records`](#tldr)+- 📦🐈 [`Maybe`](#maybe)+- 🤷🏽‍♀️ [`Either`](#either)+- 📜 [`Traversables`](#traversables)+- 🎁 [`Newtype`](#newtype)+- 🤖 [`Data types`](#data-types)++### Records++`zodiac` ~ field @"zodiac"++```haskell+data AlphaRecord = AlphaRecord {alpha :: String} deriving (Generic, Show)+data VirgoRecord = VirgoRecord {virgo :: AlphaRecord} deriving (Generic, Show)+data ZodiacRecord = ZodiacRecord {zodiac :: VirgoRecord} deriving (Generic, Show)++sky :: ZodiacRecord+sky = ZodiacRecord{zodiac = VirgoRecord{virgo = AlphaRecord{alpha = "Spica"}}}++spica :: String+spica = sky ^. (bw @"zodiac.virgo.alpha")++-- >>> spica+-- "Spica"++-- >>> alfa = sky ^. barlow @"zodiac.virgo.alfa"+-- The type AlphaRecord does not contain a field named 'alfa'.+-- In the second argument of `(^.)', namely+--   `barlow @"zodiac.virgo.alfa"'+-- In the expression: sky ^. barlow @"zodiac.virgo.alfa"+-- In an equation for `alfa':+--     alfa = sky ^. barlow @"zodiac.virgo.alfa"+```++### Maybe++Use `?` to zoom into a `Maybe`.++- `?` ~ `_Just :: Prism (Maybe a) (Maybe b) a b`++```haskell+newtype AlphaMaybe = AlphaMaybe {alpha :: Maybe String} deriving (Generic, Show)+newtype VirgoMaybe = VirgoMaybe {virgo :: Maybe AlphaMaybe} deriving (Generic, Show)+newtype ZodiacMaybe = ZodiacMaybe {zodiac :: Maybe VirgoMaybe} deriving (Generic, Show)++skyMaybe :: ZodiacMaybe+skyMaybe = ZodiacMaybe{zodiac = Just VirgoMaybe{virgo = Just AlphaMaybe{alpha = Just "Spica"}}}++spicaMaybe :: Maybe String+spicaMaybe = skyMaybe ^? bw @"zodiac?.virgo?.alpha?"++-- >>> spicaMaybe+-- Just "Spica"+```++### Either++Use `<` for `Left` and `>` for `Right` to zoom into an `Either`.++- `<` ~ `_Left :: Prism (Either a c) (Either b c) a b`+- `>` ~ `_Right :: Prism (Either c a) (Either c b) a b`++```haskell+newtype AlphaLeft = AlphaLeft {alpha :: Either String ()} deriving (Generic, Show)+newtype VirgoRight = VirgoRight {virgo :: Either () AlphaLeft} deriving (Generic, Show)+newtype ZodiacEither = ZodiacEither {zodiac :: Either VirgoRight VirgoRight} deriving (Generic, Show)++skyLeft :: ZodiacEither+skyLeft = ZodiacEither{zodiac = Left VirgoRight{virgo = Right AlphaLeft{alpha = Left "Spica"}}}++starLeftRightLeft :: Maybe String+starLeftRightLeft = skyLeft ^? bw @"zodiac<virgo>alpha<"++-- >>> starLeftRightLeft+-- Just "Spica"++starLeftLeft :: Maybe VirgoRight+starLeftLeft = skyLeft ^? bw @"zodiac>"++-- >>> starLeftLeft+-- Nothing+```++### Traversables++Use `+` to zoom into `Traversable`s.++- `+` ~ `traversed :: Traversable f => IndexedTraversal Int (f a) (f b) a b`++```haskell+newtype AlphaLeftRight = AlphaLeftRight {alpha :: Either String String} deriving (Generic, Show)+newtype VirgoLeftRight = VirgoLeftRight {virgo :: Either AlphaLeftRight AlphaLeftRight} deriving (Generic, Show)+newtype ZodiacList = ZodiacList {zodiac :: [VirgoLeftRight]} deriving (Generic, Show)++skyList :: ZodiacList+skyList =+  ZodiacList+    { zodiac =+        [ VirgoLeftRight{virgo = Right AlphaLeftRight{alpha = Left "Spica1"}}+        , VirgoLeftRight{virgo = Right AlphaLeftRight{alpha = Right "Spica2"}}+        , VirgoLeftRight{virgo = Left AlphaLeftRight{alpha = Right "Spica3"}}+        , VirgoLeftRight{virgo = Left AlphaLeftRight{alpha = Left "Spica4"}}+        ]+    }++starList :: [String]+starList = skyList ^.. bw @"zodiac+virgo>alpha>" & bw @"++" %~ toUpper++-- >>> starList+-- ["SPICA2"]++alphaRight :: [AlphaLeftRight]+alphaRight = skyList ^.. bw @"zodiac+virgo>"++-- >>> alphaRight+-- [AlphaLeftRight {alpha = Left "Spica1"},AlphaLeftRight {alpha = Right "Spica2"}]+```++### Newtype++Use `!` to zoom into a `newtype`.++- `!` ~ `wrappedIso :: Iso s t a b`++```haskell+newtype AlphaNewtype = AlphaNewtype {alpha :: String} deriving (Generic)+newtype VirgoNewtype = VirgoNewtype {virgo :: AlphaNewtype} deriving (Generic)+newtype ZodiacNewtype = ZodiacNewtype {zodiac :: VirgoNewtype} deriving (Generic)++skyNewtype :: ZodiacNewtype+skyNewtype = ZodiacNewtype (VirgoNewtype (AlphaNewtype "Spica"))++starNewtype :: [Char]+starNewtype = skyNewtype ^. bw @"zodiac!!"++-- >>> starNewtype+-- "Spica"+```++### Data types++Barlow supports zooming into arbitrary sum and product types as long as there is a `Generic` instance.++Use `%<NAME>` to zoom into sum types, where `<NAME>` is the name of your data constructor. E.g. `%VirgoData` for the data constructor `VirgoData`.++Use `%<INDEX>` to zoom into product types, where `<INDEX>` is a natural number.+Note that counting for product types and tuples usually starts with 1 and not 0.+So the first element of a product is `%1`.++It is more readable if you separate your sum lens from your product lens with a `.` dot.++- `%<NAME>` ~ `_Ctor :: AsConstructor ctor s t a b => Prism s t a b`+- `%<INDEX>` ~ `position :: HasPosition i s t a b => Lens s t a b`++```haskell+data ZodiacData+  = CarinaData {alpha :: String}+  | VirgoData {alpha :: String, beta :: String, gamma :: String, delta :: String}+  | CanisMaiorData String+  deriving (Generic)++skyData :: ZodiacData+skyData = VirgoData{alpha = "Spica", beta = "Beta Vir", gamma = "Gamma Vir", delta = "Del Vir"}++starData :: [Char]+starData = skyData ^. bw @"%VirgoData%3"++-- >>> starData+-- "Gamma Vir"+```++## Prerequisites++<details>++  <summary>Spoiler</summary>++- [flake.nix](./flake.nix) - code in this flake is extensively commented.+- [codium-haskell](https://github.com/deemp/flakes/tree/main/templates/codium/haskell#readme) - this flake.+- [codium-haskell-simple](https://github.com/deemp/flakes/tree/main/templates/codium/haskell-simple#readme) - a simplified version of this flake.+- [language-tools/haskell](https://github.com/deemp/flakes/blob/main/language-tools/haskell/flake.nix) - a flake that conveniently provides `Haskell` tools.+- [Conventions](https://github.com/deemp/flakes/blob/main/README/Conventions.md#dev-tools)+- [codium-generic](https://github.com/deemp/flakes/tree/main/templates/codium/generic#readme) - info just about `VSCodium` with extensions.+- [Haskell](https://github.com/deemp/flakes/blob/main/README/Haskell.md) - general info about `Haskell` tools.+- [Troubleshooting](https://github.com/deemp/flakes/blob/main/README/Troubleshooting.md)+- [Prerequisites](https://github.com/deemp/flakes#prerequisites)+- [Nixpkgs support for incremental Haskell builds](https://www.haskellforall.com/2022/12/nixpkgs-support-for-incremental-haskell.html)+- [flakes](https://github.com/deemp/flakes#readme) - my Nix flakes that may be useful for you.++</details>++## Quick start++1. Install Nix - see [how](https://github.com/deemp/flakes/blob/main/README/InstallNix.md).++1. In a new terminal, start a devshell, build and test the app.++    ```console+    nix develop+    cabal build+    cabal test+    ```++1. Write `settings.json` and start `VSCodium`.++    ```console+    nix run .#writeSettings+    nix run .#codium .+    ```++1. Open a `Haskell` file `app/Main.hs` and hover over a function.++1. Wait until `Haskell Language Server` (`HLS`) starts giving you type info.++1. Sometimes, `cabal` doesn't use the `Nix`-supplied packages ([issue](https://github.com/NixOS/nixpkgs/issues/130556#issuecomment-1114239002)). In this case, use `cabal v1-*` - commands.++## Configs++- [package.yaml](./package.yaml) - used by `stack` or `hpack` to generate a `.cabal`+- [.markdownlint.jsonc](./.markdownlint.jsonc) - for `markdownlint` from the extension `davidanson.vscode-markdownlint`+- [.ghcid](./.ghcid) - for [ghcid](https://github.com/ndmitchell/ghcid)+- [.envrc](./.envrc) - for [direnv](https://github.com/direnv/direnv)+- [fourmolu.yaml](./fourmolu.yaml) - for [fourmolu](https://github.com/fourmolu/fourmolu#configuration)+- [ci.yaml](.github/workflows/ci.yaml) - a generated `GitHub Actions` workflow. See [workflows](https://github.com/deemp/flakes/tree/main/workflows). Generate a workflow via `nix run .#writeWorkflows`.+- [hie.yaml](./hie.yaml) - a config for [hie-bios](https://github.com/haskell/hie-bios). Can be generated via [implicit-hie](https://github.com/Avi-D-coder/implicit-hie) to check the `Haskell Language Server` setup.

+ barlow-lens.cabal view

@@ -0,0 +1,84 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name:           barlow-lens+version:        0.1.0.0+synopsis:       lens via string literals+description:    Please see the README on GitHub at <https://github.com/value/barlow-lens#readme>+category:       Generics, Records, Lens+homepage:       https://github.com/deemp/barlow-lens#readme+bug-reports:    https://github.com/deemp/barlow-lens/issues+author:         Danila Danko, +maintainer:     Danila Danko+copyright:      Danila Danko+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/deemp/barlow-lens++library+  exposed-modules:+      Data.Lens.Barlow+      Data.Lens.Barlow.Classes+      Data.Lens.Barlow.Construction+      Data.Lens.Barlow.Parser+      Data.Lens.Barlow.Types+  other-modules:+      Paths_barlow_lens+  hs-source-dirs:+      src+  default-extensions:+      ImportQualifiedPost+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wno-unticked-promoted-constructors+  build-depends:+      base >=4.7 && <5+    , first-class-families+    , generic-lens+    , lens+    , profunctors+  default-language: Haskell2010++test-suite barlow-lens+  type: exitcode-stdio-1.0+  main-is: test/Barlow/Main.hs+  other-modules:+      Paths_barlow_lens+  default-extensions:+      ImportQualifiedPost+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wno-unticked-promoted-constructors -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      barlow-lens+    , base >=4.7 && <5+    , first-class-families+    , generic-lens+    , lens+    , profunctors+    , tasty+    , tasty-hunit+  default-language: Haskell2010++test-suite readme+  type: exitcode-stdio-1.0+  main-is: README.hs+  other-modules:+      Paths_barlow_lens+  default-extensions:+      ImportQualifiedPost+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wno-unticked-promoted-constructors+  build-depends:+      barlow-lens+    , base >=4.7 && <5+    , first-class-families+    , generic-lens+    , lens+    , profunctors+  default-language: Haskell2010

+ src/Data/Lens/Barlow.hs view

@@ -0,0 +1,18 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Data.Lens.Barlow where++import Control.Lens (Optic)+import Data.Lens.Barlow.Construction ( ConstructBarlow(..) )+import Data.Lens.Barlow.Parser (Parse)++barlow :: forall path {p} {f} {s} {t} {a} {b}. (ConstructBarlow (Parse path) p f s t a b) => Optic p f s t a b+barlow = constructBarlow @(Parse path)++bw :: forall path {p} {f} {s} {t} {a} {b}. (ConstructBarlow (Parse path) p f s t a b) => Optic p f s t a b+bw = barlow @path

+ src/Data/Lens/Barlow/Classes.hs view

@@ -0,0 +1,46 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Lens.Barlow.Classes where++import Data.Data (Proxy (..))+import Data.Lens.Barlow.Parser (Parse)+import Data.Lens.Barlow.Types+import GHC.TypeLits (KnownNat, KnownSymbol, Symbol, symbolVal)+import GHC.TypeNats (natVal)++class KnownTag (a :: Tag) where+  tagVal :: TagVal++instance KnownTag Tag'QuestionMark where tagVal = TagVal'QuestionMark+instance KnownTag Tag'RightArrow where tagVal = TagVal'RightArrow+instance KnownTag Tag'LeftArrow where tagVal = TagVal'LeftArrow+instance KnownTag Tag'Plus where tagVal = TagVal'Plus+instance KnownTag Tag'ExclamationMark where tagVal = TagVal'ExclamationMark+instance (KnownSymbol a) => KnownTag (Tag'PercentageName a) where tagVal = TagVal'PercentageName (symbolVal (Proxy @a))+instance (KnownNat a) => KnownTag (Tag'PercentageNumber a) where tagVal = TagVal'PercentageNumber (natVal (Proxy @a))+instance (KnownSymbol a) => KnownTag (Tag'Name a) where tagVal = TagVal'Name (symbolVal (Proxy @a))++class KnownTags (a :: [Tag]) where+  tagVals :: [TagVal]++instance KnownTags '[] where+  tagVals = []++instance (KnownTag x, KnownTags xs) => KnownTags (x : xs) where+  tagVals = (tagVal @x) : tagVals @xs++class KnownSymbolTags (s :: Symbol) where+  symbolTagVals :: [TagVal]++instance (KnownTags (Parse s)) => KnownSymbolTags s where+  symbolTagVals = tagVals @(Parse s)

+ src/Data/Lens/Barlow/Construction.hs view

@@ -0,0 +1,52 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Lens.Barlow.Construction where++import Control.Lens (Optic, traversed, _Just, _Left, _Right)+import Control.Lens.Iso (Profunctor)+import Control.Lens.Prism (Choice)+import Data.Generics.Product.Fields (HasField (field))+import Data.Generics.Product.Positions (HasPosition (position))+import Data.Generics.Sum.Constructors (AsConstructor (_Ctor))+import Data.Generics.Wrapped (Wrapped (wrappedIso))+import Data.Lens.Barlow.Types (Tag (..))++-- Translated https://github.com/sigma-andex/purescript-barlow-lens/blob/main/src/Data/Lens/Barlow/Construction.purs++class ConstructBarlow (path :: [Tag]) p f s t a b | path s -> a, path t -> b where+  constructBarlow :: Optic p f s t a b++instance ConstructBarlow '[] p f s t s t where+  constructBarlow = id++instance (Choice p, ConstructBarlow path p f s t a b, Applicative f) => ConstructBarlow (Tag'RightArrow : path) p f (Either x s) (Either x t) a b where+  constructBarlow = _Right . constructBarlow @path++instance (Choice p, ConstructBarlow path p f s t a b, Applicative f) => ConstructBarlow (Tag'LeftArrow : path) p f (Either s x) (Either t x) a b where+  constructBarlow = _Left . constructBarlow @path++instance (Choice p, ConstructBarlow path p f q w a b, AsConstructor ctor s t q w, Applicative f) => ConstructBarlow (Tag'PercentageName ctor : path) p f s t a b where+  constructBarlow = _Ctor @ctor . constructBarlow @path++instance (p ~ (->), Applicative f, ConstructBarlow path p f s t a b, Traversable tr) => ConstructBarlow (Tag'Plus : path) p f (tr s) (tr t) a b where+  constructBarlow = traversed . constructBarlow @path++instance (Profunctor p, ConstructBarlow path p f q w a b, Functor f, Wrapped s t q w) => ConstructBarlow (Tag'ExclamationMark : path) p f s t a b where+  constructBarlow = wrappedIso . constructBarlow @path++instance (Choice p, ConstructBarlow path p f s t a b, Applicative f) => ConstructBarlow (Tag'QuestionMark : path) p f (Maybe s) (Maybe t) a b where+  constructBarlow = _Just . constructBarlow @path++instance (p ~ (->), Functor f, ConstructBarlow path p f q w a b, HasPosition pos s t q w) => ConstructBarlow (Tag'PercentageNumber pos : path) p f s t a b where+  constructBarlow = position @pos . constructBarlow @path++instance (p ~ (->), Functor f, ConstructBarlow path p f q w a b, HasField sym s t q w) => ConstructBarlow (Tag'Name sym : path) p f s t a b where+  constructBarlow = field @sym . constructBarlow @path

+ src/Data/Lens/Barlow/Parser.hs view

@@ -0,0 +1,109 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StarIsType #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoStarIsType #-}++module Data.Lens.Barlow.Parser where++-- Translated https://github.com/sigma-andex/purescript-barlow-lens/blob/main/src/Data/Lens/Barlow/Parser.purs++import Data.Lens.Barlow.Types+import Fcf (Eval, Exp, If, TyEq)+import Fcf.Class.Foldable (Or)+import Fcf.Data.List as DL (Elem, Filter, Reverse)+import GHC.TypeLits++type family FromChars1 (cs :: [Char]) (res :: Symbol) :: Symbol where+  FromChars1 '[] res = res+  FromChars1 (c : cs) res = FromChars1 cs (ConsSymbol c res)++type family FromCharsReverse (cs :: [Char]) :: Symbol where+  FromCharsReverse cs = FromChars1 cs ""++type family FromChars (cs :: [Char]) :: Symbol where+  FromChars cs = FromChars1 (Eval (Reverse cs)) ""++type family ToChars1 (s :: Maybe (Char, Symbol)) (r :: [Char]) :: [Char] where+  ToChars1 Nothing s = Eval (Reverse s)+  ToChars1 ('Just '(c, cs)) s = ToChars1 (UnconsSymbol cs) (c ': s)++type family ToChars (s :: Symbol) :: [Char] where+  ToChars s = ToChars1 (UnconsSymbol s) '[]++type family FromChar (c :: Char) :: Symbol where+  FromChar c = FromChars '[c]++type family AppendChar (s :: Symbol) (c :: Char) :: Symbol where+  AppendChar s c = AppendSymbol s (FromChar c)++type family CharBetween1 (c1 :: Ordering) (c2 :: Ordering) :: Bool where+  CharBetween1 EQ LT = True+  CharBetween1 LT EQ = True+  CharBetween1 LT LT = True+  CharBetween1 a b = False++type family CharBetween (c :: Char) (lowerBound :: Char) (upperBound :: Char) :: Bool where+  CharBetween c lowerBound upperBound = CharBetween1 (CmpChar lowerBound c) (CmpChar c upperBound)++type SpecialChars = '[ '.', '?', '>', '<', '+', '!', '%']++type IsSpecial (x :: Char) = Eval (Elem x SpecialChars)++type DigitNat d = (CharToNat d - CharToNat '0')++type family UnexpectedCharacterError (c :: Char) (expected :: Symbol) (prefix :: [Char]) (rest :: [Char]) :: k where+  UnexpectedCharacterError c expected prefix rest =+    TypeError+      ( (Text "Unexpected character: " :<>: Text (FromChar c) :<>: Text "\n")+          :<>: (Text expected :<>: Text "\n")+          :<>: (Text "in " :<>: Text (FromCharsReverse prefix) :<>: Text "\n")+          :<>: (Text "in " :<>: Text (AppendSymbol (FromCharsReverse prefix) (FromChars rest)))+      )++type family Parse1 (parsed :: [Char]) (rest :: [Char]) (tags :: [Tag]) :: [Tag] where+  Parse1 p '[] ts = ts+  Parse1 p ('.' : xs) ts = Parse1 ('.' : p) xs (Tag'Dot : ts)+  Parse1 p ('?' : xs) ts = Parse1 ('?' : p) xs (Tag'QuestionMark : ts)+  Parse1 p ('>' : xs) ts = Parse1 ('>' : p) xs (Tag'RightArrow : ts)+  Parse1 p ('<' : xs) ts = Parse1 ('<' : p) xs (Tag'LeftArrow : ts)+  Parse1 p ('+' : xs) ts = Parse1 ('+' : p) xs (Tag'Plus : ts)+  Parse1 p ('!' : xs) ts = Parse1 ('!' : p) xs (Tag'ExclamationMark : ts)+  Parse1 p ('%' : x : xs) ts =+    If+      (CharBetween x '1' '9')+      (Parse1 (x : '%' : p) xs (Tag'PercentageNumber (DigitNat x) : ts))+      ( If+          (IsSpecial x)+          (UnexpectedCharacterError x "Expected a letter or a digit\nafter '%'" p (x : xs))+          (Parse1 (x : '%' : p) xs (Tag'PercentageName (ConsSymbol x "") : ts))+      )+  -- TODO check x is upper when an appropriate function is available+  -- https://gitlab.haskell.org/ghc/ghc/-/issues/19634+  -- https://github.com/ghc-proposals/ghc-proposals/pull/509+  Parse1 p (x : xs) (Tag'PercentageName s : ts) = Parse1 (x : p) xs (Tag'PercentageName (AppendChar s x) : ts)+  Parse1 p (x : xs) (Tag'PercentageNumber n : ts) =+    If+      (CharBetween x '0' '9')+      (Parse1 (x : p) xs (Tag'PercentageNumber (n * 10 + DigitNat x) : ts))+      (UnexpectedCharacterError x "Expected a digit or a special character\nafter a digit" p (x : xs))+  Parse1 p (x : xs) (Tag'Name n : ts) = Parse1 (x : p) xs (Tag'Name (AppendChar n x) : ts)+  Parse1 p (x : xs) ts =+    If+      (Eval (Or '[CharBetween x '0' '9']))+      (UnexpectedCharacterError x "Expected a letter" p (x : xs))+      (Parse1 (x : p) xs (Tag'Name (FromChar x) : ts))+  Parse1 _ _ _ = TypeError (Text "cornercase!")++data DotFilter :: Tag -> Exp Bool++type instance Eval (DotFilter x) = If (Eval (TyEq x Tag'Dot)) False True++type family Parse (a :: Symbol) :: [Tag] where+  Parse a = Eval (Filter DotFilter (Eval (Reverse (Parse1 '[] (ToChars a) '[]))))

+ src/Data/Lens/Barlow/Types.hs view

@@ -0,0 +1,27 @@+module Data.Lens.Barlow.Types where++import GHC.TypeLits (Natural, Symbol)+import GHC.TypeNats (Nat)++data Tag+  = Tag'Dot+  | Tag'QuestionMark+  | Tag'RightArrow+  | Tag'LeftArrow+  | Tag'Plus+  | Tag'ExclamationMark+  | Tag'PercentageName Symbol+  | Tag'PercentageNumber Nat+  | Tag'Name Symbol++data TagVal+  = TagVal'Dot+  | TagVal'QuestionMark+  | TagVal'RightArrow+  | TagVal'LeftArrow+  | TagVal'Plus+  | TagVal'ExclamationMark+  | TagVal'PercentageName String+  | TagVal'PercentageNumber Natural+  | TagVal'Name String+  deriving (Show, Eq)

+ test/Barlow/Main.hs view

@@ -0,0 +1,60 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TypeApplications #-}++module Main where++import Control.Lens ((^?))+import Data.Data (Proxy (..))+import Data.Lens.Barlow (bw)+import Data.Lens.Barlow.Classes+import Data.Lens.Barlow.Types (TagVal (..))+import GHC.Generics (Generic)+import GHC.TypeLits (symbolVal)+import Test.Tasty+import Test.Tasty.HUnit++main :: IO ()+main = defaultMain tests++type T1 = "h1d.%Gb3?>..<+!%B3..%10"++tests :: TestTree+tests =+  testGroup+    "Tests"+    [ testCase (symbolVal (Proxy @T1)) $+        symbolTagVals @T1+          @?= [ TagVal'Name "h1d"+              , TagVal'PercentageName "Gb3"+              , TagVal'QuestionMark+              , TagVal'RightArrow+              , TagVal'LeftArrow+              , TagVal'Plus+              , TagVal'ExclamationMark+              , TagVal'PercentageName "B3"+              , TagVal'PercentageNumber 10+              ]+    , testCase+        ("get" <> symbolVal (Proxy @T1))+        $ (ex8 ^? bw @T1) @?= Just 10+    ]++newtype H = H {h1d :: G} deriving (Generic)+data G = Gb3 (Maybe F) | GaA4 deriving (Generic)+type F = Either C E+type E = Either D String+type D = [C]+newtype C = C B deriving (Generic)+data B = B3 A | B2 deriving (Generic)+data A = A Int Int Int Int Int Int Int Int Int Int deriving (Generic)++ex1 = A 1 2 3 4 5 6 7 8 9 10+ex2 = B3 ex1+ex3 = C ex2+ex4 = [ex3, ex3]+ex5 = Left ex4+ex6 = Right ex5+ex7 = Gb3 (Just ex6)+ex8 = H ex7