├── .github └── workflows │ └── ci.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.lhs ├── README.md ├── Setup.hs ├── cabal.project ├── higgledy.cabal ├── src └── Data │ └── Generic │ ├── HKD.hs │ └── HKD │ ├── Build.hs │ ├── Construction.hs │ ├── Labels.hs │ ├── Named.hs │ └── Types.hs └── test ├── Doctest.hs └── Main.hs /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | # Trigger the workflow on push or pull request, but only for the master branch 4 | on: 5 | pull_request: 6 | branches: 7 | - "**" 8 | push: 9 | branches: 10 | - "master" 11 | 12 | jobs: 13 | build: 14 | name: ghc ${{ matrix.ghc }} 15 | runs-on: ubuntu-latest 16 | strategy: 17 | matrix: 18 | ghc: 19 | - "8.10.7" 20 | - "9.2.5" 21 | - "9.4.4" 22 | 23 | steps: 24 | - uses: actions/checkout@v2 25 | if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' 26 | 27 | - uses: haskell/actions/setup@v2 28 | name: Setup Haskell 29 | with: 30 | ghc-version: ${{ matrix.ghc }} 31 | cabal-version: ${{ matrix.cabal }} 32 | 33 | - uses: actions/cache@v1 34 | name: Cache ~/.cabal/store 35 | with: 36 | path: ~/.cabal/store 37 | key: ${{ runner.os }}-${{ matrix.ghc }}-cabal 38 | 39 | - name: Build 40 | run: | 41 | cabal v2-update 42 | cabal v2-build --enable-tests --enable-benchmarks 43 | 44 | - name: Test 45 | run: | 46 | cabal v2-test --enable-tests 47 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .ghc.* 2 | dist* 3 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for higgledy 2 | 3 | ## 0.4.2.1 -- 2023-03-04 4 | 5 | * Support for GHC 9.4 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019 Tom Harding 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.lhs: -------------------------------------------------------------------------------- 1 | README.md -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Higgledy 📚 2 | 3 | [![GitHub CI](https://github.com/i-am-tom/higgledy/workflows/CI/badge.svg)](https://github.com/i-am-tom/higgledy/actions) 4 | 5 | Higher-kinded data via generics: all\* the benefits, but none\* of the 6 | boilerplate. 7 | 8 | ## Introduction 9 | 10 | When we work with [higher-kinded 11 | data](https://reasonablypolymorphic.com/blog/higher-kinded-data), we find 12 | ourselves writing types like: 13 | 14 | ```{haskell, ignore} 15 | data User f 16 | = User 17 | { name :: f String 18 | , age :: f Int 19 | , ... 20 | } 21 | ``` 22 | 23 | This is good - we can use `f ~ Maybe` for partial data, `f ~ Identity` for 24 | complete data, etc - but it introduces a fair amount of noise, and we have a 25 | lot of boilerplate deriving to do. Wouldn't it be nice if we could get back to 26 | writing simple types as we know and love them, and get all this stuff for 27 | _free_? 28 | 29 | ```{haskell, ignore} 30 | data User 31 | = User 32 | { name :: String 33 | , age :: Int 34 | , ... 35 | } 36 | deriving Generic 37 | 38 | -- HKD for free! 39 | type UserF f = HKD User f 40 | ``` 41 | 42 | As an added little bonus, any `HKD`-wrapped object is automatically an instance 43 | of all the [Barbie](https://hackage.haskell.org/package/barbies) classes, so no 44 | need to derive anything more than `Generic`! 45 | 46 | ## API 47 | 48 | All examples below were compiled with the following extensions, modules, and 49 | example data types: 50 | 51 | ```haskell 52 | {-# LANGUAGE DataKinds #-} 53 | {-# LANGUAGE DeriveGeneric #-} 54 | {-# LANGUAGE TypeApplications #-} 55 | {-# LANGUAGE OverloadedLabels #-} 56 | {-# LANGUAGE TypeOperators #-} 57 | module Main where 58 | 59 | import Control.Applicative (Alternative (empty)) 60 | import Control.Lens ((.~), (^.), (&), Const (..), Identity, anyOf) 61 | import Data.Generic.HKD 62 | import Data.Maybe (isJust, isNothing) 63 | import Data.Monoid (Last (..)) 64 | import GHC.Generics (Generic) 65 | import Named ((:!), (!)) 66 | 67 | -- An example of a record (with named fields): 68 | data User 69 | = User 70 | { name :: String 71 | , age :: Int 72 | , likesDogs :: Bool 73 | } 74 | deriving (Generic, Show) 75 | 76 | user :: User 77 | user = User "Tom" 26 True 78 | 79 | -- An example of a product (without named fields): 80 | data Triple 81 | = Triple Int () String 82 | deriving (Generic, Show) 83 | 84 | triple :: Triple 85 | triple = Triple 123 () "ABC" 86 | ``` 87 | 88 | ### The HKD type constructor 89 | 90 | The `HKD` type takes two parameters: your model type, and the functor in which 91 | we want to wrap all our inputs. By picking different functors for the second 92 | parameter, we can recover various behaviours: 93 | 94 | ```haskell 95 | type Partial a = HKD a Last -- Fields may be missing. 96 | type Bare a = HKD a Identity -- All must be present. 97 | type Labels a = HKD a (Const String) -- Every field holds a string. 98 | ``` 99 | 100 | _NB: as of GHC 8.8, the `Last` monoid will be removed in favour of `Compose 101 | Maybe Last` (using the `Last` in `Data.Semigroup`). Until then, I'll use `Last` 102 | for brevity, but you may wish to use this suggestion for future-proofing._ 103 | 104 | ### Fresh objects 105 | 106 | When we want to start working with the `HKD` interface, we have a couple of 107 | options, depending on the functor in question. The first option is to use 108 | `mempty`: 109 | 110 | ```haskell 111 | eg0 :: Partial User 112 | eg0 = mempty 113 | -- User 114 | -- { name = Last {getLast = Nothing} 115 | -- , age = Last {getLast = Nothing} 116 | -- , likesDogs = Last {getLast = Nothing} 117 | -- } 118 | ``` 119 | 120 | Other 'Alternative'-style functors lead to very different results: 121 | 122 | ```haskell 123 | eg1 :: Labels Triple 124 | eg1 = mempty 125 | -- Triple 126 | -- Const "" 127 | -- Const "" 128 | -- Const "" 129 | ``` 130 | 131 | Of course, this method requires every field to be monoidal. If we try with 132 | `Identity`, for example, we're in trouble if all our fields aren't themselves 133 | monoids: 134 | 135 | ```{haskell, ignore} 136 | eg2 :: Bare Triple 137 | eg2 = mempty 138 | -- error: 139 | -- • No instance for (Monoid Int) arising from a use of ‘mempty’ 140 | ``` 141 | 142 | The other option is to `deconstruct` a complete object. This effectively lifts 143 | a type into the `HKD` structure with `pure` applied to each field: 144 | 145 | ```haskell 146 | eg3 :: Bare User 147 | eg3 = deconstruct user 148 | -- User 149 | -- { name = Identity "Tom" 150 | -- , age = Identity 26 151 | -- , likesDogs = Identity True 152 | -- } 153 | ``` 154 | 155 | This approach works with any applicative we like, so we can recover the other 156 | behaviours: 157 | 158 | ```haskell 159 | eg4 :: Partial Triple 160 | eg4 = deconstruct @Last triple 161 | -- Triple 162 | -- Last {getLast = Just 123} 163 | -- Last {getLast = Just ()} 164 | -- Last {getLast = Just "ABC"} 165 | ``` 166 | 167 | There's also `construct` for when we want to escape our `HKD` wrapper, and 168 | attempt to _construct_ our original type: 169 | 170 | ```haskell 171 | eg5 :: Last Triple 172 | eg5 = construct eg4 173 | -- Last {getLast = Just (Triple 123 () "ABC")} 174 | ``` 175 | 176 | If none of the above suit your needs, maybe you want to try `build` on for 177 | size. This function constructs an `HKD`-wrapped version of the type supplied to 178 | it by taking all its parameters. In other words: 179 | 180 | ```haskell 181 | eg6 :: f Int -> f () -> f String -> HKD Triple f 182 | eg6 = build @Triple 183 | 184 | eg7 :: HKD Triple [] 185 | eg7 = eg6 [1] [] ["Tom", "Tim"] 186 | -- Triple [1] [] ["Tom","Tim"] 187 | ``` 188 | 189 | Should we need to work with records, we can exploit the label trickery of the 190 | [`named`](https://hackage.haskell.org/package/named) package. The `record` 191 | function behaves exactly as `build` does, but produces a function compatible 192 | with the `named` interface. After that, we can use the function with labels 193 | (and with no regard for the internal order): 194 | 195 | ```haskell 196 | eg8 :: "name" :! f [Char] 197 | -> "age" :! f Int 198 | -> "likesDogs" :! f Bool 199 | -> HKD User f 200 | eg8 = record @User 201 | 202 | eg9 :: HKD User Maybe 203 | eg9 = eg8 ! #name (Just "Tom") 204 | ! #likesDogs (Just True) 205 | ! #age (Just 26) 206 | ``` 207 | 208 | If you're _still_ not satisfied, check out the 209 | [`buniq`](https://hackage.haskell.org/package/barbies-1.1.2.1/docs/Data-Barbie.html#v:buniq) 210 | method hiding in `barbies`: 211 | 212 | ```haskell 213 | eg10 :: HKD Triple [] 214 | eg10 = bpure empty 215 | -- Triple [] [] [] 216 | ``` 217 | 218 | ### Field Access 219 | 220 | The `field` lens, when given a type-applied field name, allows us to focus on 221 | fields within a record: 222 | 223 | ```haskell 224 | eg11 :: Last Int 225 | eg11 = eg0 ^. field @"age" 226 | -- Last {getLast = Nothing} 227 | ``` 228 | 229 | As this is a true `Lens`, it also means that we can _set_ values within our 230 | record (note that these set values will _also_ need to be in our functor of 231 | choice): 232 | 233 | ```haskell 234 | eg12 :: Partial User 235 | eg12 = eg0 & field @"name" .~ pure "Evil Tom" 236 | & field @"likesDogs" .~ pure False 237 | -- User 238 | -- { name = Last {getLast = Just "Evil Tom"} 239 | -- , age = Last {getLast = Nothing} 240 | -- , likesDogs = Last {getLast = Just False} 241 | -- } 242 | ``` 243 | 244 | This also means, for example, we can check whether a particular value has been 245 | completed for a given partial type: 246 | 247 | ```haskell 248 | eg13 :: Bool 249 | eg13 = anyOf (field @"name") (isJust . getLast) eg0 250 | -- False 251 | ``` 252 | 253 | Finally, thanks to the fact that this library exploits some of the internals of 254 | `generic-lens`, we'll also get a nice type error when we mention a field that 255 | doesn't exist in our type: 256 | 257 | ```{haskell, ignore} 258 | eg14 :: Identity () 259 | eg14 = eg3 ^. field @"oops" 260 | -- error: 261 | -- • The type User does not contain a field named 'oops'. 262 | ``` 263 | 264 | ### Position Access 265 | 266 | Just as with field names, we can use positions when working with non-record 267 | product types: 268 | 269 | ```haskell 270 | eg15 :: Labels Triple 271 | eg15 = mempty & position @1 .~ Const "hello" 272 | & position @2 .~ Const "world" 273 | -- Triple 274 | -- Const "hello" 275 | -- Const "world" 276 | -- Const "" 277 | ``` 278 | 279 | Again, this is a `Lens`, so we can just as easily _set_ values: 280 | 281 | ```haskell 282 | eg16 :: Partial User 283 | eg16 = eg12 & position @2 .~ pure 26 284 | -- User 285 | -- { name = Last {getLast = Just "Evil Tom"} 286 | -- , age = Last {getLast = Just 26} 287 | -- , likesDogs = Last {getLast = Just False} 288 | -- } 289 | ``` 290 | 291 | Similarly, the internals here come to us courtesy of `generic-lens`, so the 292 | type errors are a delight: 293 | 294 | ```{haskell, ignore} 295 | eg17 :: Identity () 296 | eg17 = deconstruct @Identity triple ^. position @4 297 | -- error: 298 | -- • The type Triple does not contain a field at position 4 299 | ``` 300 | 301 | ### Labels 302 | 303 | One neat trick we can do - thanks to the generic representation - is get the 304 | names of the fields into the functor we're using. The `label` value gives us 305 | this interface: 306 | 307 | ```haskell 308 | eg18 :: Labels User 309 | eg18 = label 310 | -- User 311 | -- { name = Const "name" 312 | -- , age = Const "age" 313 | -- , likesDogs = Const "likesDogs" 314 | -- } 315 | ``` 316 | 317 | By combining this with some of the 318 | [Barbies](https://hackage.haskell.org/package/barbies) interface (the entirety 319 | of which is available to any `HKD`-wrapped type) such as `bprod` and `bmap`, we 320 | can implement functions such as `labelsWhere`, which returns the names of all 321 | fields whose values satisfy some predicate: 322 | 323 | ```haskell 324 | eg19 :: [String] 325 | eg19 = labelsWhere (isNothing . getLast) eg12 326 | -- ["age"] 327 | ``` 328 | 329 | ### Documentation 330 | 331 | All the docs in this library are tested on `cabal new-test`. Furthermore, this 332 | README is tested by `markdown-unlit`. 333 | 334 | 340 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Distribution.Extra.Doctest (defaultMainWithDoctests) 4 | 5 | main :: IO () 6 | main = defaultMainWithDoctests "doctests" 7 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /higgledy.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | build-type: Custom 3 | name: higgledy 4 | version: 0.4.2.1 5 | synopsis: Partial types as a type constructor. 6 | description: Use the generic representation of an ADT to get a higher-kinded data-style interface automatically. 7 | homepage: https://github.com/i-am-tom/higgledy 8 | license: MIT 9 | license-file: LICENSE 10 | author: Tom Harding 11 | maintainer: tom.harding@habito.com 12 | category: Data 13 | extra-source-files: CHANGELOG.md 14 | , README.md 15 | 16 | custom-setup 17 | setup-depends: 18 | base < 5, 19 | Cabal < 4, 20 | cabal-doctest ^>= 1.0 21 | 22 | library 23 | exposed-modules: Data.Generic.HKD 24 | Data.Generic.HKD.Build 25 | Data.Generic.HKD.Construction 26 | Data.Generic.HKD.Labels 27 | Data.Generic.HKD.Named 28 | Data.Generic.HKD.Types 29 | build-depends: base >= 4.12 && < 5 30 | , barbies >= 2.0 && < 2.2 31 | , generic-lens >= 2.1 && < 3.0 32 | , generic-lens-core >= 2.1 && < 3.0 33 | , QuickCheck >= 2.12.6 && < 2.15 34 | , named ^>= 0.3.0.0 35 | hs-source-dirs: src 36 | default-language: Haskell2010 37 | 38 | test-suite doctests 39 | build-depends: base 40 | , base-compat >= 0.11 && < 0.13 41 | , doctest >= 0.17 && < 0.22 42 | , higgledy 43 | , lens 44 | , QuickCheck 45 | , template-haskell 46 | main-is: Doctest.hs 47 | type: exitcode-stdio-1.0 48 | hs-source-dirs: test 49 | ghc-options: -Wall -Wextra -threaded 50 | default-language: Haskell2010 51 | 52 | test-suite test 53 | build-depends: base 54 | , barbies 55 | , higgledy 56 | , hspec >= 2.6.1 && < 2.11 57 | , lens >= 4.17 && < 5.3 58 | , QuickCheck 59 | main-is: Main.hs 60 | type: exitcode-stdio-1.0 61 | hs-source-dirs: test 62 | default-language: Haskell2010 63 | 64 | test-suite readme 65 | build-depends: base 66 | , barbies 67 | , lens >= 4.17 && < 5.3 68 | , higgledy 69 | , named ^>= 0.3.0.0 70 | main-is: README.lhs 71 | type: exitcode-stdio-1.0 72 | default-language: Haskell2010 73 | ghc-options: -pgmL markdown-unlit -Wall 74 | build-tool-depends: markdown-unlit:markdown-unlit 75 | 76 | source-repository head 77 | type: git 78 | location: https://github.com/i-am-tom/higgledy 79 | -------------------------------------------------------------------------------- /src/Data/Generic/HKD.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MonoLocalBinds #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | {-| 8 | Module : Data.Generic.HKD 9 | Description : A generic-based HKD decorator for ADTs. 10 | Copyright : (c) Tom Harding, 2019 11 | License : MIT 12 | Maintainer : tom.harding@habito.com 13 | Stability : experimental 14 | -} 15 | module Data.Generic.HKD 16 | ( module Exports 17 | 18 | , Barbies.ApplicativeB (..) 19 | , Barbies.ConstraintsB (..) 20 | , Barbies.FunctorB (..) 21 | , Barbies.TraversableB (..) 22 | 23 | , position 24 | , field 25 | ) where 26 | 27 | import Data.Generic.HKD.Build as Exports 28 | import Data.Generic.HKD.Construction as Exports 29 | import Data.Generic.HKD.Labels as Exports 30 | import Data.Generic.HKD.Named as Exports 31 | import Data.Generic.HKD.Types as Exports 32 | 33 | import qualified Barbies 34 | 35 | import qualified Data.Generics.Internal.VL.Lens as G 36 | import qualified Data.Generics.Product as G 37 | 38 | -- | When we work with records, all the fields are named, and we can refer to 39 | -- them using these names. This class provides a lens from our HKD structure to 40 | -- any @f@-wrapped field. 41 | -- 42 | -- >>> :set -XDataKinds -XDeriveGeneric -XTypeApplications 43 | -- >>> import Control.Lens ((&), (.~)) 44 | -- >>> import Data.Monoid (Last) 45 | -- >>> import GHC.Generics 46 | -- 47 | -- >>> data User = User { name :: String, age :: Int } deriving (Generic, Show) 48 | -- >>> type Partial a = HKD a Last 49 | -- 50 | -- We can create an empty partial @User@ and set its name to \"Tom\" (which, in 51 | -- this case, is @pure \"Tom\" :: Last String@): 52 | -- 53 | -- >>> mempty @(Partial User) & field @"name" .~ pure "Tom" 54 | -- User {name = Last {getLast = Just "Tom"}, age = Last {getLast = Nothing}} 55 | -- 56 | -- Thanks to some @generic-lens@ magic, we also get some pretty magical type 57 | -- errors! If we create a (complete) partial user: 58 | -- 59 | -- >>> import Data.Generic.HKD.Construction (deconstruct) 60 | -- >>> total = deconstruct @Last (User "Tom" 25) 61 | -- 62 | -- ... and then try to access a field that isn't there, we get a friendly 63 | -- message to point us in the right direction: 64 | -- 65 | -- >>> total & field @"oops" .~ pure () 66 | -- ... 67 | -- ... error: 68 | -- ... The type HKD User Last does not contain a field named 'oops'. 69 | -- ... 70 | field 71 | :: forall field f structure inner 72 | . G.HasField' field (HKD structure f) (f inner) 73 | => G.Lens' (HKD structure f) (f inner) 74 | 75 | field 76 | = G.field' @field 77 | 78 | -- | Product types /without/ named fields can't be addressed by field name (for 79 | -- very obvious reason), so we instead need to address them with their 80 | -- "position" index. This is a one-indexed type-applied natural: 81 | -- 82 | -- >>> import Control.Lens ((^.)) 83 | -- 84 | -- >>> :t mempty @(HKD (Int, String) []) ^. position @1 85 | -- mempty @(HKD (Int, String) []) ^. position @1 :: [Int] 86 | -- 87 | -- As we're using the wonderful @generic-lens@ library under the hood, we also 88 | -- get some beautiful error messages when things go awry: 89 | -- 90 | -- >>> import Data.Generic.HKD.Construction 91 | -- >>> deconstruct ((), True) ^. position @4 92 | -- ... 93 | -- ... error: 94 | -- ... The type HKD ((), Bool) f does not contain a field at position 4 95 | -- ... 96 | position 97 | :: forall index f structure inner 98 | . G.HasPosition' index (HKD structure f) (f inner) 99 | => G.Lens' (HKD structure f) (f inner) 100 | 101 | position 102 | = G.position' @index 103 | -------------------------------------------------------------------------------- /src/Data/Generic/HKD/Build.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | {-# LANGUAGE AllowAmbiguousTypes #-} 4 | {-# LANGUAGE BlockArguments #-} 5 | {-# LANGUAGE DataKinds #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE FunctionalDependencies #-} 9 | {-# LANGUAGE GADTs #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE UndecidableInstances #-} 15 | 16 | {-| 17 | Module : Data.Generic.HKD.Build 18 | Description : Construct an HKD structure with its component parameters. 19 | Copyright : (c) Tom Harding, 2019 20 | License : MIT 21 | Maintainer : tom.harding@habito.com 22 | Stability : experimental 23 | -} 24 | module Data.Generic.HKD.Build 25 | ( Build (..) 26 | ) where 27 | 28 | import Data.Kind (Type) 29 | import Data.Generics.Product.Internal.HList (HList (..)) 30 | import Data.Generic.HKD.Types (HKD (..), GHKD_) 31 | import GHC.Generics 32 | import Prelude hiding (uncurry) 33 | 34 | class Fill (f :: Type -> Type) (structure :: Type) (types :: [Type]) 35 | | structure f -> types, types -> f where 36 | fill :: HList types -> HKD structure f 37 | 38 | class GFill (f :: Type -> Type) (xs :: [Type]) (ys :: [Type]) (rep :: Type -> Type) 39 | | xs rep -> ys, ys f rep -> xs, xs -> f where 40 | gfill :: HList xs -> (HList ys, GHKD_ f rep p) 41 | 42 | instance GFill f xs ys inner 43 | => GFill f xs ys (M1 index meta inner) where 44 | gfill = fmap M1 . gfill @f 45 | 46 | instance (GFill f xs ys left, GFill f ys zs right) 47 | => GFill f xs zs (left :*: right) where 48 | gfill xs = do 49 | let (ys, left) = gfill @f xs 50 | (zs, right) = gfill @f ys 51 | 52 | (zs, left :*: right) 53 | 54 | instance GFill f (f x ': xs) xs (Rec0 x) where 55 | gfill (x :> xs) = (xs, K1 x) 56 | 57 | instance (Generic shape, GFill f with '[] (Rep shape)) 58 | => Fill f shape with where 59 | fill = HKD . snd . gfill @f @_ @'[] 60 | 61 | -- | With many HKD applications, we're working with types like 'Maybe' where it 62 | -- makes sense for us to start with 'mempty' and add values in as we go. 63 | -- 64 | -- This isn't always the case, however: if all the component parts of our type 65 | -- are gathered using some 'IO' action, we'd like to construct something like 66 | -- @HKD MyType IO@, and @IO a@ isn't a 'Monoid' for all types @a@. When this 67 | -- happens, we need to pass in our parameters /when/ we build our structure. 68 | -- 69 | -- The 'build' function lets us construct our type by passing explicit values 70 | -- for each parameter: 71 | -- 72 | -- >>> :set -XDeriveGeneric -XTypeApplications 73 | -- 74 | -- >>> :{ 75 | -- data User 76 | -- = User { name :: String, age :: Int, likesDogs :: Bool } 77 | -- deriving Generic 78 | -- :} 79 | -- 80 | -- >>> :{ 81 | -- test :: _ 82 | -- test = build @User 83 | -- :} 84 | -- ... 85 | -- ... Found type wildcard ... 86 | -- ... standing for ...f [Char] -> f Int -> f Bool -> HKD User f... 87 | -- ... 88 | -- 89 | -- Once we call the 'build' function, and indicate the type we want to build, 90 | -- we are free to pick whichever @f@ we like and get to work! 91 | class Build (structure :: Type) (f :: Type -> Type) (k :: Type) 92 | | f structure -> k where 93 | build :: k 94 | 95 | class GBuild (f :: Type -> Type) (structure :: Type) (xs :: [Type]) (k :: Type) 96 | | f structure xs -> k where 97 | gbuild :: (HList xs -> HKD structure f) -> k 98 | 99 | instance GBuild f structure xs k 100 | => GBuild f structure (x ': xs) (x -> k) where 101 | gbuild k x = gbuild @_ @_ @xs \xs -> k (x :> xs) 102 | 103 | instance GBuild f structure '[] (HKD structure f) where 104 | gbuild k = k Nil 105 | 106 | instance (Fill f structure xs, GBuild f structure xs k) 107 | => Build structure f k where 108 | build = gbuild @f @structure @xs fill 109 | -------------------------------------------------------------------------------- /src/Data/Generic/HKD/Construction.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | {-# LANGUAGE AllowAmbiguousTypes #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE MonoLocalBinds #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeOperators #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | 15 | {-| 16 | Module : Data.Generic.HKD.Construction 17 | Description : Convert to and from the generic HKD structure. 18 | Copyright : (c) Tom Harding, 2019 19 | License : MIT 20 | Maintainer : tom.harding@habito.com 21 | Stability : experimental 22 | -} 23 | module Data.Generic.HKD.Construction 24 | ( Construct (..) 25 | ) where 26 | 27 | import Data.Generic.HKD.Types (HKD (..), GHKD_) 28 | import Data.Kind (Type) 29 | import GHC.Generics 30 | 31 | -- | When working with the HKD representation, it is useful to have a way to 32 | -- convert to and from our original type. To do this, we can: 33 | -- 34 | -- * @construct@ the original type from our HKD representation, and 35 | -- 36 | -- * @deconstruct@ the original type /into/ our HKD representation. 37 | -- 38 | -- As an example, we can try (unsuccessfully) to construct an @(Int, Bool)@ 39 | -- tuple from an unpopulated partial structure. 40 | -- 41 | -- >>> :set -XTypeApplications 42 | -- >>> import Data.Monoid (Last) 43 | -- 44 | -- >>> construct (mempty @(HKD (Int, Bool) Last)) 45 | -- Last {getLast = Nothing} 46 | -- 47 | -- We can also /deconstruct/ a tuple into a partial structure: 48 | -- 49 | -- >>> deconstruct @[] ("Hello", True) 50 | -- (,) ["Hello"] [True] 51 | -- 52 | -- These two methods also satisfy the round-tripping property: 53 | -- 54 | -- prop> construct (deconstruct x) == [ x :: (Int, Bool, String) ] 55 | class Construct (f :: Type -> Type) (structure :: Type) where 56 | construct :: HKD structure f -> f structure 57 | deconstruct :: structure -> HKD structure f 58 | 59 | class GConstruct (f :: Type -> Type) (rep :: Type -> Type) where 60 | gconstruct :: GHKD_ f rep p -> f (rep p) 61 | gdeconstruct :: rep p -> GHKD_ f rep p 62 | 63 | instance (Functor f, GConstruct f inner) 64 | => GConstruct f (M1 index meta inner) where 65 | gconstruct = fmap M1 . gconstruct . unM1 66 | gdeconstruct = M1 . gdeconstruct @f . unM1 67 | 68 | instance (Applicative f, GConstruct f left, GConstruct f right) 69 | => GConstruct f (left :*: right) where 70 | gconstruct (l :*: r) = (:*:) <$> gconstruct l <*> gconstruct r 71 | gdeconstruct (l :*: r) = gdeconstruct @f l :*: gdeconstruct @f r 72 | 73 | instance Applicative f => GConstruct f (K1 index inner) where 74 | gconstruct (K1 x) = fmap K1 x 75 | gdeconstruct (K1 x) = K1 (pure x) 76 | 77 | instance (Applicative f, Generic structure, GConstruct f (Rep structure)) 78 | => Construct f structure where 79 | construct = fmap to . gconstruct . runHKD 80 | deconstruct = HKD . gdeconstruct @f . from 81 | -------------------------------------------------------------------------------- /src/Data/Generic/HKD/Labels.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE KindSignatures #-} 7 | {-# LANGUAGE MonoLocalBinds #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | module Data.Generic.HKD.Labels 14 | ( Label (..) 15 | , labelsWhere 16 | ) where 17 | 18 | import Barbies (ApplicativeB (..), TraversableB (..)) 19 | import Data.Functor.Const (Const (..)) 20 | import Data.Functor.Product (Product (..)) 21 | import Data.Generic.HKD.Types (HKD (..), GHKD_) 22 | import Data.Kind (Type) 23 | import Data.Proxy (Proxy (..)) 24 | import GHC.Generics 25 | import GHC.TypeLits (ErrorMessage (..), KnownSymbol, TypeError, symbolVal) 26 | 27 | -- | For any record type, we can extract the labels generically using the 28 | -- `Const` functor. 29 | -- 30 | -- >>> import Data.Generic.HKD 31 | -- >>> import Data.Functor.Identity (Identity (..)) 32 | -- 33 | -- >>> data User = User { name :: String, age :: Int } deriving Generic 34 | -- >>> label @User 35 | -- User {name = Const "name", age = Const "age"} 36 | class Label (structure :: Type) where 37 | label :: HKD structure (Const String) 38 | 39 | class GLabels (rep :: Type -> Type) where 40 | glabel :: GHKD_ (Const String) rep p 41 | 42 | instance GLabels inner => GLabels (D1 meta inner) where 43 | glabel = M1 glabel 44 | 45 | instance GLabels inner 46 | => GLabels (C1 ('MetaCons name fixity 'True) inner) where 47 | glabel = M1 glabel 48 | 49 | instance TypeError ('Text "You can't collect labels for a non-record type!") 50 | => GLabels (C1 ('MetaCons name fixity 'False) inner) where 51 | glabel = undefined 52 | 53 | instance KnownSymbol name 54 | => GLabels (S1 ('MetaSel ('Just name) i d c) (K1 index inner)) where 55 | glabel = M1 (K1 (Const (symbolVal (Proxy @name)))) 56 | 57 | instance (GLabels left, GLabels right) => GLabels (left :*: right) where 58 | glabel = glabel :*: glabel 59 | 60 | instance (Generic structure, GLabels (Rep structure)) => Label structure where 61 | label = HKD glabel 62 | 63 | -- | Because all HKD types are valid barbies, and we have the above mechanism 64 | -- for extracting field names, we can ask some pretty interesting questions. 65 | -- 66 | -- >>> import Control.Lens 67 | -- >>> import Data.Maybe (isNothing) 68 | -- >>> import Data.Monoid (Last (..)) 69 | -- >>> import Data.Generic.HKD 70 | -- 71 | -- Let's imagine, for example, that we're half way through filling in a user's 72 | -- details: 73 | -- 74 | -- >>> data User = User { name :: String, age :: Int } deriving Generic 75 | -- >>> test = mempty @(HKD User Last) & field @"name" .~ pure "Tom" 76 | -- 77 | -- We want to send a JSON response back to the client containing the fields 78 | -- that have yet to be finished. All we need to do is pick the fields where the 79 | -- values are @Last Nothing@: 80 | -- 81 | -- >>> labelsWhere (isNothing . getLast) test 82 | -- ["age"] 83 | labelsWhere 84 | :: forall structure f 85 | . ( Label structure 86 | , ApplicativeB (HKD structure) 87 | , TraversableB (HKD structure) 88 | ) 89 | => (forall a. f a -> Bool) 90 | -> HKD structure f 91 | -> [String] 92 | 93 | labelsWhere p 94 | = getConst . btraverse go . bprod label 95 | where 96 | go :: Product (Const String) f a -> (Const [String]) (Maybe a) 97 | go (Pair (Const key) value) = Const if p value then [key] else [] 98 | -------------------------------------------------------------------------------- /src/Data/Generic/HKD/Named.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | {-# LANGUAGE AllowAmbiguousTypes #-} 4 | {-# LANGUAGE BlockArguments #-} 5 | {-# LANGUAGE DataKinds #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE FunctionalDependencies #-} 9 | {-# LANGUAGE KindSignatures #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE TypeOperators #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | 17 | {-| 18 | Module : Data.Generic.HKD.Named 19 | Description : Construct an HKD record with named parameters. 20 | Copyright : (c) Tom Harding, 2019 21 | License : MIT 22 | Maintainer : tom.harding@habito.com 23 | Stability : experimental 24 | -} 25 | module Data.Generic.HKD.Named 26 | ( Record (..) 27 | ) where 28 | 29 | import Data.Functor.Contravariant (Contravariant (..)) 30 | import Data.Generic.HKD.Types (HKD, HKD_) 31 | import Data.Generics.Product.Internal.Subtype (GUpcast (..)) 32 | import Data.Kind (Type) 33 | import GHC.Generics 34 | import Named ((:!), NamedF (..)) 35 | 36 | type family Append (xs :: Type -> Type) (ys :: Type -> Type) :: Type -> Type where 37 | Append (S1 meta head) tail = S1 meta head :*: tail 38 | Append (left :*: right) other = left :*: Append right other 39 | 40 | type family Rearrange (i :: Type -> Type) :: Type -> Type where 41 | Rearrange (S1 m inner) = S1 m (Rearrange inner) 42 | Rearrange (M1 index m inner) = M1 index m (Rearrange inner) 43 | Rearrange (left :*: right) = Append (Rearrange left) (Rearrange right) 44 | Rearrange (Rec0 inner) = Rec0 inner 45 | 46 | -- | The 'Data.Generic.HKD.record' function lets us supply arguments to a type 47 | -- one by one, but can cause confusion when working with a record. If the 48 | -- record contains two fields of the same type, for example, we've introduced 49 | -- an opportunity for bugs and confusion. The @record@ function uses the 50 | -- wonderful @named@ package to help us: 51 | -- 52 | -- >>> :set -XDeriveGeneric -XTypeApplications 53 | -- 54 | -- >>> :{ 55 | -- data User 56 | -- = User { name :: String, enemy :: String } 57 | -- deriving Generic 58 | -- :} 59 | -- 60 | -- >>> :{ 61 | -- test :: _ 62 | -- test = record @User 63 | -- :} 64 | -- ... 65 | -- ... Found type wildcard ... 66 | -- ... standing for ...("name" :! f [Char]) 67 | -- ... -> ("enemy" :! f [Char]) -> HKD User f... 68 | -- ... 69 | class Record (structure :: Type) (f :: Type -> Type) (k :: Type) 70 | | f structure -> k where 71 | record :: k 72 | 73 | class GRecord (rep :: Type -> Type) (f :: Type -> Type) (structure :: Type) (k :: Type) 74 | | f structure rep -> k where 75 | grecord :: (forall p. rep p -> HKD structure f) -> k 76 | 77 | instance GRecord inner f structure k 78 | => GRecord (D1 meta inner) f structure k where 79 | grecord rebuild = grecord (rebuild . M1) 80 | 81 | instance GRecord inner f structure k 82 | => GRecord (C1 meta inner) f structure k where 83 | grecord rebuild = grecord (rebuild . M1) 84 | 85 | instance 86 | ( rec ~ (Rec0 inner) 87 | , k ~ (name :! inner -> HKD structure f) 88 | , meta ~ 'MetaSel ('Just name) i d c 89 | ) 90 | => GRecord (S1 meta rec) f structure k where 91 | grecord fill = \(Arg inner) -> fill (M1 (K1 inner)) 92 | 93 | instance 94 | ( GRecord right f structure k' 95 | , rec ~ Rec0 x 96 | , left ~ S1 ('MetaSel ('Just name) i d c) rec 97 | , k ~ (name :! x -> k') 98 | ) 99 | => GRecord (left :*: right) f structure k where 100 | grecord fill = \(Arg left) -> grecord \right -> fill (M1 (K1 left) :*: right) 101 | 102 | instance 103 | ( Contravariant (HKD_ f structure) 104 | , Functor (HKD_ f structure) 105 | 106 | , list ~ Rearrange (HKD_ f structure) 107 | , GUpcast list (HKD_ f structure) 108 | , GRecord list f structure k 109 | ) 110 | => Record structure f k where 111 | record = grecord @_ @f @structure (to . gupcast @list @(HKD_ f structure)) 112 | -------------------------------------------------------------------------------- /src/Data/Generic/HKD/Types.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | {-# LANGUAGE AllowAmbiguousTypes #-} 4 | {-# LANGUAGE ConstraintKinds #-} 5 | {-# LANGUAGE DataKinds #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE FunctionalDependencies #-} 9 | {-# LANGUAGE InstanceSigs #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE TypeFamilyDependencies #-} 15 | {-# LANGUAGE TypeOperators #-} 16 | {-# LANGUAGE UndecidableInstances #-} 17 | 18 | {-| 19 | Module : Data.Generic.HKD.Types 20 | Description : Type declarations for the HKD structure. 21 | Copyright : (c) Tom Harding, 2019 22 | License : MIT 23 | Maintainer : tom.harding@habito.com 24 | Stability : experimental 25 | -} 26 | module Data.Generic.HKD.Types 27 | ( HKD (..) 28 | 29 | , HKD_ 30 | , GHKD_ 31 | 32 | , Tuple (..) 33 | ) where 34 | 35 | import Barbies (ConstraintsB (..), FunctorB (..), ApplicativeB (..), TraversableB (..)) 36 | import Barbies.Constraints (Dict (..)) 37 | import Data.Function (on) 38 | import Data.Functor.Contravariant (Contravariant (..), phantom) 39 | import Data.Functor.Product (Product (..)) 40 | import Data.Kind (Constraint, Type) 41 | import Data.Proxy (Proxy (..)) 42 | import Data.Void (Void) 43 | import GHC.Generics 44 | import GHC.TypeLits (KnownSymbol, symbolVal) 45 | import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..)) 46 | import Test.QuickCheck.Function (Function (..), functionMap) 47 | 48 | -- | Higher-kinded data (HKD) is the design pattern in which every field in our 49 | -- type is wrapped in some functor @f@: 50 | -- 51 | -- @ 52 | -- data User f 53 | -- = User 54 | -- { name :: f String 55 | -- , age :: f Int 56 | -- } 57 | -- @ 58 | -- 59 | -- Depending on the functor, we can get different behaviours: with 'Maybe', we 60 | -- get a partial structure; with 'Validation', we get a piecemeal validator; 61 | -- and so on. The @HKD@ newtype allows us to lift any type into an HKD-style 62 | -- API via its generic representation. 63 | -- 64 | -- >>> :set -XDeriveGeneric -XTypeApplications 65 | -- >>> :{ 66 | -- data User 67 | -- = User { name :: String, age :: Int } 68 | -- deriving Generic 69 | -- :} 70 | -- 71 | -- The @HKD@ type is indexed by our choice of functor and the structure we're 72 | -- lifting. In other words, we can define a synonym for our behaviour: 73 | -- 74 | -- >>> import Data.Monoid (Last (..)) 75 | -- >>> type Partial a = HKD a Last 76 | -- 77 | -- ... and then we're ready to go! 78 | -- 79 | -- >>> mempty @(Partial User) 80 | -- User {name = Last {getLast = Nothing}, age = Last {getLast = Nothing}} 81 | -- 82 | -- >>> mempty @(HKD (Int, Bool) []) 83 | -- (,) [] [] 84 | newtype HKD (structure :: Type) (f :: Type -> Type) 85 | = HKD { runHKD :: HKD_ f structure Void } 86 | 87 | instance (Contravariant (HKD_ f structure), Functor (HKD_ f structure)) 88 | => Generic (HKD structure f) where 89 | type Rep (HKD structure f) = HKD_ f structure 90 | 91 | from = phantom . runHKD 92 | to = HKD . phantom 93 | 94 | ------------------------------------------------------------------------------- 95 | 96 | -- | Calculate the "partial representation" of a type. 97 | type HKD_ (f :: Type -> Type) (structure :: Type) 98 | = GHKD_ f (Rep structure) 99 | 100 | -- | Calculate the "partial representation" of a generic rep. 101 | type family GHKD_ (f :: Type -> Type) (rep :: Type -> Type) 102 | = (output :: Type -> Type) | output -> f rep where 103 | GHKD_ f (M1 index meta inner) = M1 index meta (GHKD_ f inner) 104 | GHKD_ f (left :*: right) = GHKD_ f left :*: GHKD_ f right 105 | GHKD_ f (K1 index value) = K1 index (f value) 106 | GHKD_ f (left :+: right) = GHKD_ f left :+: GHKD_ f right 107 | 108 | ------------------------------------------------------------------------------- 109 | 110 | instance (Eq tuple, Generic xs, Tuple f xs tuple) 111 | => Eq (HKD xs f) where 112 | (==) = (==) `on` toTuple 113 | 114 | instance (Ord tuple, Generic xs, Tuple f xs tuple) 115 | => Ord (HKD xs f) where 116 | compare = compare `on` toTuple 117 | 118 | instance (Semigroup tuple, Generic xs, Tuple f xs tuple) 119 | => Semigroup (HKD xs f) where 120 | x <> y = fromTuple (toTuple x <> toTuple y) 121 | 122 | instance (Monoid tuple, Generic xs, Tuple f xs tuple) 123 | => Monoid (HKD xs f) where 124 | mempty = fromTuple mempty 125 | 126 | ------------------------------------------------------------------------------- 127 | 128 | instance (Arbitrary tuple, GToTuple (HKD_ f structure) tuple) 129 | => Arbitrary (HKD structure f) where 130 | arbitrary = fmap (HKD . gfromTuple) arbitrary 131 | 132 | instance (CoArbitrary tuple, GToTuple (HKD_ f structure) tuple) 133 | => CoArbitrary (HKD structure f) where 134 | coarbitrary (HKD x) = coarbitrary (gtoTuple x) 135 | 136 | instance (Generic structure, Function tuple, Tuple f structure tuple) 137 | => Function (HKD structure f) where 138 | function = functionMap toTuple fromTuple 139 | 140 | ------------------------------------------------------------------------------- 141 | 142 | class GShow (named :: Bool) (rep :: Type -> Type) where 143 | gshow :: rep p -> String 144 | 145 | instance GShow named inner => GShow named (D1 meta inner) where 146 | gshow = gshow @named . unM1 147 | 148 | instance (GShow 'True inner, KnownSymbol name) 149 | => GShow any (C1 ('MetaCons name fixity 'True) inner) where 150 | gshow (M1 x) = symbolVal (Proxy @name) <> " {" <> gshow @'True x <> "}" 151 | 152 | instance (GShow 'False inner, KnownSymbol name) 153 | => GShow any (C1 ('MetaCons name fixity 'False) inner) where 154 | gshow (M1 x) = symbolVal (Proxy @name) <> " " <> gshow @'False x 155 | 156 | instance (GShow 'True left, GShow 'True right) 157 | => GShow 'True (left :*: right) where 158 | gshow (left :*: right) = gshow @'True left <> ", " <> gshow @'True right 159 | 160 | instance (GShow 'False left, GShow 'False right) 161 | => GShow 'False (left :*: right) where 162 | gshow (left :*: right) = gshow @'False left <> " " <> gshow @'False right 163 | 164 | instance (GShow 'True inner, KnownSymbol field) 165 | => GShow 'True (S1 ('MetaSel ('Just field) i d c) inner) where 166 | gshow (M1 inner) = symbolVal (Proxy @field) <> " = " <> gshow @'True inner 167 | 168 | instance GShow 'False inner => GShow 'False (S1 meta inner) where 169 | gshow (M1 inner) = gshow @'False inner 170 | 171 | instance (Show (f inner)) => GShow named (K1 R (f inner)) where 172 | gshow (K1 x) = show x 173 | 174 | instance (Generic structure, GShow 'True (HKD_ f structure)) 175 | => Show (HKD structure f) where 176 | show (HKD x) = gshow @'True x 177 | 178 | ------------------------------------------------------------------------------- 179 | 180 | -- | Often, we can get instances by using an 'HKD' type's isomorphism with a 181 | -- certain size of tuple. This class witnesses the isomorphism with a certain 182 | -- tuple (specifically a nested tree of pairs) to allow us to derive "via" 183 | -- these shapes. 184 | class Tuple (f :: Type -> Type) (structure :: Type) (tuple :: Type) 185 | | f structure -> tuple where 186 | toTuple :: HKD structure f -> tuple 187 | fromTuple :: tuple -> HKD structure f 188 | 189 | class GToTuple (rep :: Type -> Type) (tuple :: Type) 190 | | rep -> tuple where 191 | gfromTuple :: tuple -> rep p 192 | gtoTuple :: rep p -> tuple 193 | 194 | instance GToTuple inner tuple 195 | => GToTuple (M1 index meta inner) tuple where 196 | gfromTuple = M1 . gfromTuple 197 | gtoTuple = gtoTuple . unM1 198 | 199 | instance (GToTuple left left', GToTuple right right') 200 | => GToTuple (left :*: right) (left', right') where 201 | gfromTuple (x, y) = gfromTuple x :*: gfromTuple y 202 | gtoTuple (x :*: y) = (gtoTuple x, gtoTuple y) 203 | 204 | instance GToTuple (K1 index inner) inner where 205 | gfromTuple = K1 206 | gtoTuple = unK1 207 | 208 | instance (Generic structure, GToTuple (HKD_ f structure) tuple) 209 | => Tuple f structure tuple where 210 | toTuple = gtoTuple . runHKD 211 | fromTuple = HKD . gfromTuple 212 | 213 | ------------------------------------------------------------------------------- 214 | 215 | class GFunctorB (rep :: Type -> Type) where 216 | gbmap :: (forall a. f a -> g a) -> GHKD_ f rep p -> GHKD_ g rep p 217 | 218 | instance GFunctorB inner => GFunctorB (M1 index meta inner) where 219 | gbmap f = M1 . gbmap @inner f . unM1 220 | 221 | instance (GFunctorB left, GFunctorB right) 222 | => GFunctorB (left :*: right) where 223 | gbmap f (left :*: right) = gbmap @left f left :*: gbmap @right f right 224 | 225 | instance GFunctorB (K1 index inner) where 226 | gbmap f (K1 x) = K1 (f x) 227 | 228 | instance GFunctorB (Rep structure) => FunctorB (HKD structure) where 229 | bmap f = HKD . gbmap @(Rep structure) f . runHKD 230 | 231 | ------------------------------------------------------------------------------- 232 | 233 | class GTraversableB (rep :: Type -> Type) where 234 | gbtraverse 235 | :: Applicative t 236 | => (forall a. f a -> t (g a)) 237 | -> GHKD_ f rep p -> t (GHKD_ g rep p) 238 | 239 | instance GTraversableB inner => GTraversableB (M1 index meta inner) where 240 | gbtraverse f = fmap M1 . gbtraverse @inner f . unM1 241 | 242 | instance (GTraversableB left, GTraversableB right) 243 | => GTraversableB (left :*: right) where 244 | gbtraverse f (left :*: right) 245 | = (:*:) <$> gbtraverse @left f left 246 | <*> gbtraverse @right f right 247 | 248 | instance GTraversableB (K1 index inner) where 249 | gbtraverse f (K1 x) = fmap K1 (f x) 250 | 251 | instance (FunctorB (HKD structure), GTraversableB (Rep structure)) 252 | => TraversableB (HKD structure) where 253 | btraverse f = fmap HKD . gbtraverse @(Rep structure) f . runHKD 254 | 255 | ------------------------------------------------------------------------------- 256 | 257 | class GApplicativeB (rep :: Type -> Type) where 258 | gbprod :: GHKD_ f rep p -> GHKD_ g rep p -> GHKD_ (f `Product` g) rep p 259 | gbpure :: (forall a. f a) -> GHKD_ f rep p 260 | 261 | instance GApplicativeB inner => GApplicativeB (M1 index meta inner) where 262 | gbprod (M1 x) (M1 y) = M1 (gbprod @inner x y) 263 | gbpure zero = M1 (gbpure @inner zero) 264 | 265 | instance (GApplicativeB left, GApplicativeB right) 266 | => GApplicativeB (left :*: right) where 267 | gbprod (leftX :*: rightX) (leftY :*: rightY) 268 | = gbprod @left leftX leftY :*: gbprod @right rightX rightY 269 | 270 | gbpure zero 271 | = gbpure @left zero :*: gbpure @right zero 272 | 273 | instance GApplicativeB (K1 index inner) where 274 | gbprod (K1 x) (K1 y) = K1 (Pair x y) 275 | gbpure zero = K1 zero 276 | 277 | instance (FunctorB (HKD structure), GApplicativeB (Rep structure)) 278 | => ApplicativeB (HKD structure) where 279 | bprod (HKD x) (HKD y) = HKD (gbprod @(Rep structure) x y) 280 | bpure zero = HKD (gbpure @(Rep structure) zero) 281 | 282 | ------------------------------------------------------------------------------- 283 | 284 | class GAllBC (rep :: Type -> Type) where 285 | type GAllB (c :: Type -> Constraint) rep :: Constraint 286 | 287 | class GConstraintsB (rep :: Type -> Type) where 288 | gbaddDicts :: GAllB c rep => GHKD_ f rep p -> GHKD_ (Dict c `Product` f) rep p 289 | 290 | instance GAllBC inner => GAllBC (M1 index meta inner) where 291 | type GAllB c (M1 index meta inner) = GAllB c inner 292 | 293 | instance GConstraintsB inner => GConstraintsB (M1 index meta inner) where 294 | gbaddDicts (M1 x) = M1 (gbaddDicts @inner x) 295 | 296 | instance (GAllBC left, GAllBC right) => GAllBC (left :*: right) where 297 | type GAllB c (left :*: right) = (GAllB c left, GAllB c right) 298 | 299 | instance (GConstraintsB left, GConstraintsB right) 300 | => GConstraintsB (left :*: right) where 301 | gbaddDicts (left :*: right) 302 | = gbaddDicts @left left :*: gbaddDicts @right right 303 | 304 | instance GAllBC (K1 index inner) where 305 | type GAllB c (K1 index inner) = c inner 306 | 307 | instance GConstraintsB (K1 index inner) where 308 | gbaddDicts (K1 x) = K1 (Pair Dict x) 309 | 310 | instance 311 | ( FunctorB (HKD structure) 312 | , GConstraintsB (Rep structure) 313 | , GAllBC (Rep structure) 314 | ) 315 | => ConstraintsB (HKD structure) where 316 | type AllB c (HKD structure) = GAllB c (Rep structure) 317 | 318 | baddDicts 319 | :: forall c f 320 | . AllB c (HKD structure) 321 | => HKD structure f 322 | -> HKD structure (Dict c `Product` f) 323 | baddDicts (HKD x) 324 | = HKD (gbaddDicts @(Rep structure) x) 325 | -------------------------------------------------------------------------------- /test/Doctest.hs: -------------------------------------------------------------------------------- 1 | import Build_doctests (flags, pkgs, module_sources) 2 | import System.Environment.Compat (unsetEnv) 3 | import Test.DocTest (doctest) 4 | 5 | main :: IO () 6 | main = unsetEnv "GHC_ENVIRONMENT" >> doctest args 7 | where args = flags ++ pkgs ++ module_sources 8 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE BlockArguments #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE MonoLocalBinds #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | module Main where 12 | 13 | import Control.Lens (Lens', (.~), (^.)) 14 | import Barbies.Constraints (Dict) 15 | import Data.Function ((&), on) 16 | import Data.Functor.Identity (Identity (..)) 17 | import Data.Functor.Product (Product (..)) 18 | import Data.Generic.HKD 19 | import Data.Monoid (Last (..)) 20 | import GHC.Generics 21 | import Test.Hspec 22 | import Test.QuickCheck 23 | 24 | type Partial a = HKD a Last 25 | type WTF a = HKD a [] 26 | 27 | main :: IO () 28 | main = hspec do 29 | describe "Unnamed" do 30 | eq @(Partial Triple) 31 | ord @(Partial Triple) 32 | semigroup @(Partial Triple) 33 | idempotent @(Partial Triple) 34 | monoid @(Partial Triple) 35 | 36 | eq @(WTF Triple) 37 | ord @(WTF Triple) 38 | semigroup @(WTF Triple) 39 | monoid @(WTF Triple) 40 | 41 | lens @(Partial Triple) (position @1) 42 | lens @(Partial Triple) (position @2) 43 | lens @(Partial Triple) (position @3) 44 | 45 | lens @(WTF Triple) (position @1) 46 | lens @(WTF Triple) (position @2) 47 | lens @(WTF Triple) (position @3) 48 | 49 | describe "Named" do 50 | eq @(Partial Person) 51 | ord @(Partial Person) 52 | semigroup @(Partial Person) 53 | idempotent @(Partial Person) 54 | monoid @(Partial Person) 55 | 56 | eq @(WTF Person) 57 | ord @(WTF Person) 58 | semigroup @(WTF Person) 59 | monoid @(WTF Person) 60 | 61 | lens @(WTF Person) (position @1) 62 | lens @(WTF Person) (position @2) 63 | lens @(WTF Person) (position @3) 64 | 65 | lens @(Partial Person) (field @"name") 66 | lens @(Partial Person) (field @"age") 67 | lens @(Partial Person) (field @"likesDogs") 68 | 69 | lens @(WTF Person) (field @"name") 70 | lens @(WTF Person) (field @"age") 71 | lens @(WTF Person) (field @"likesDogs") 72 | 73 | ------------------------------------------------------------------------------- 74 | 75 | data Person 76 | = Person 77 | { name :: String 78 | , age :: Int 79 | , likesDogs :: Bool 80 | } 81 | deriving (Eq, Generic, Ord, Show) 82 | 83 | data Triple 84 | = Triple String Bool () 85 | deriving (Eq, Generic, Ord, Show) 86 | 87 | instance Arbitrary Person where 88 | arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary 89 | 90 | instance CoArbitrary Person 91 | instance Function Person 92 | 93 | instance Arbitrary Triple where 94 | arbitrary = Triple <$> arbitrary <*> arbitrary <*> arbitrary 95 | 96 | instance CoArbitrary Triple 97 | instance Function Triple 98 | 99 | ------------------------------------------------------------------------------- 100 | 101 | eq 102 | :: forall a. (Arbitrary a, CoArbitrary a, Eq a, Function a, Show a) 103 | => SpecWith () 104 | 105 | eq = describe "Eq" do 106 | it "is reflexive" $ property \(x :: a) -> 107 | x == x 108 | 109 | it "is symmetric" $ property \(x :: a) y -> 110 | (x == y) == (y == x) 111 | 112 | it "is transitive" $ property \(x :: a) y z -> 113 | not (x == y && y == z) || (x == z) 114 | 115 | it "substitutes" $ property \(x :: a) y (Fun _ f :: Fun a Int) -> 116 | not (x == y) || (f x == f y) 117 | 118 | ord :: forall a. (Arbitrary a, Ord a, Show a) => SpecWith () 119 | ord = describe "Ord" do 120 | it "is transitive" $ property \(x :: a) y z -> 121 | not (x <= y && y <= z) || (x <= z) 122 | 123 | it "is reflexive" $ property \(x :: a) -> 124 | x <= x 125 | 126 | it "is antisymmetric" $ property \(x :: a) y -> 127 | not (x <= y && y <= x) || (x == y) 128 | 129 | semigroup :: forall a. (Arbitrary a, Eq a, Semigroup a, Show a) => SpecWith () 130 | semigroup = describe "Semigroup" do 131 | it "is associative" $ property \(x :: a) y z -> 132 | x <> (y <> z) == (x <> y) <> z 133 | 134 | idempotent :: forall a. (Arbitrary a, Eq a, Semigroup a, Show a) => SpecWith () 135 | idempotent = describe "Idempotence" do 136 | it "has right idempotence" $ property \(x :: a) y -> 137 | x <> y <> y == x <> y 138 | 139 | monoid :: forall a. (Arbitrary a, Eq a, Monoid a, Show a) => SpecWith () 140 | monoid = describe "Monoid" do 141 | it "has left identity" $ property \(x :: a) -> mempty <> x == x 142 | it "has right identity" $ property \(x :: a) -> x <> mempty == x 143 | 144 | lens 145 | :: forall s a 146 | . ( Arbitrary s, Arbitrary a 147 | , Show s, Show a 148 | , Eq a, Eq s 149 | ) 150 | => Lens' s a 151 | -> SpecWith () 152 | 153 | lens l = describe "Lens laws" do 154 | it "- get l . set l x == x" $ property \(s :: s) (a :: a) -> 155 | (s & l .~ a) ^. l == a 156 | 157 | it "- set l (get l s) == s" $ property \(s :: s) -> 158 | (s & l .~ (s ^. l)) == s 159 | 160 | it "- set l b . set l a == set l b" $ property \(s :: s) (a :: a) (b :: a) -> 161 | (s & l .~ a & l .~ b) == (s & l .~ b) 162 | 163 | ------------------------------------------------------------------------------- 164 | 165 | partials 166 | :: forall a 167 | . ( Arbitrary a 168 | , Show a 169 | , Ord a 170 | , Generic a 171 | , Construct Last a 172 | , Construct [] a 173 | , Ord (Partial a) 174 | , Ord (WTF a) 175 | ) 176 | => SpecWith () 177 | 178 | partials = describe "HKD" do 179 | describe "Eq" do 180 | it "is monotonic with respect to ordering (Partial)" $ property \(x :: a) y -> 181 | (x <= y) == ((<=) `on` deconstruct @Last) x y 182 | 183 | it "is monotonic with respect to ordering (WTF)" $ property \(x :: a) y -> 184 | (x <= y) == ((<=) `on` deconstruct @[]) x y 185 | 186 | it "round-trips" $ property \(x :: a) -> 187 | construct (deconstruct @Last x) == pure x 188 | 189 | it "round-trips" $ property \(x :: a) -> 190 | construct (deconstruct @[] x) == pure x 191 | 192 | -- Just to test that `baddDicts` does what it's told. 193 | data Y = Y { getY :: Int } deriving (Generic, Show) 194 | 195 | test :: HKD Y (Product (Dict Num) Identity) 196 | test = baddDicts test 197 | where 198 | test :: HKD Y Identity 199 | test = deconstruct @Identity (Y 10) 200 | --------------------------------------------------------------------------------