├── .github └── workflows │ └── ci.yml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── examples ├── Setup.hs ├── example-aeson.hs ├── example-checksum.hs ├── gds-examples.cabal └── generic-free-monad.hs ├── generic-data-surgery.cabal ├── src └── Generic │ └── Data │ ├── Surgery.hs │ └── Surgery │ └── Internal.hs ├── stack-default.yaml └── test ├── surgery.hs └── synthetic.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 | push: 7 | branches: [master] 8 | 9 | jobs: 10 | cabal: 11 | name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} 12 | runs-on: ${{ matrix.os }} 13 | strategy: 14 | matrix: 15 | os: [ubuntu-latest, macOS-latest, windows-latest] 16 | cabal: ["3.2"] 17 | ghc: 18 | - "8.0.2" 19 | - "8.2.2" 20 | - "8.4.4" 21 | - "8.6.5" 22 | - "8.8.4" 23 | - "8.10.2" 24 | exclude: 25 | - os: macOS-latest 26 | ghc: 8.8.4 27 | - os: macOS-latest 28 | ghc: 8.6.5 29 | - os: macOS-latest 30 | ghc: 8.4.4 31 | - os: macOS-latest 32 | ghc: 8.2.2 33 | - os: macOS-latest 34 | ghc: 8.0.2 35 | - os: windows-latest 36 | ghc: 8.10.2 37 | - os: windows-latest 38 | ghc: 8.6.5 39 | - os: windows-latest 40 | ghc: 8.4.4 41 | - os: windows-latest 42 | ghc: 8.2.2 43 | - os: windows-latest 44 | ghc: 8.0.2 45 | 46 | steps: 47 | - uses: actions/checkout@v2 48 | if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' 49 | 50 | - uses: actions/setup-haskell@v1.1.4 51 | id: setup-haskell-cabal 52 | name: Setup Haskell 53 | with: 54 | ghc-version: ${{ matrix.ghc }} 55 | cabal-version: ${{ matrix.cabal }} 56 | 57 | - name: Configure 58 | run: | 59 | cabal configure --enable-tests --enable-benchmarks --test-show-details=direct 60 | 61 | - name: Freeze 62 | run: | 63 | cabal freeze 64 | 65 | - uses: actions/cache@v2.1.3 66 | name: Cache ~/.cabal/store 67 | with: 68 | path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 69 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 70 | 71 | - name: Install dependencies 72 | run: | 73 | cabal build all --only-dependencies 74 | 75 | - name: Build 76 | run: | 77 | cabal build all --enable-tests --enable-benchmarks --write-ghc-environment-files=always 78 | 79 | - name: Test 80 | run: | 81 | cabal test all 82 | 83 | stack: 84 | name: stack / ghc ${{ matrix.ghc }} 85 | runs-on: ubuntu-latest 86 | strategy: 87 | matrix: 88 | stack: ["2.3.1"] 89 | ghc: ["8.8.4"] 90 | 91 | steps: 92 | - uses: actions/checkout@v2 93 | if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' 94 | 95 | - uses: actions/setup-haskell@v1.1.4 96 | name: Setup Haskell Stack 97 | with: 98 | ghc-version: ${{ matrix.ghc }} 99 | stack-version: ${{ matrix.stack }} 100 | 101 | - uses: actions/cache@v2.1.3 102 | name: Cache ~/.stack 103 | with: 104 | path: ~/.stack 105 | key: ${{ runner.os }}-${{ matrix.ghc }}-stack 106 | 107 | - name: Install dependencies 108 | run: | 109 | stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies --stack-yaml stack-default.yaml 110 | 111 | - name: Build 112 | run: | 113 | stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --stack-yaml stack-default.yaml 114 | 115 | - name: Test 116 | run: | 117 | stack test --system-ghc --stack-yaml stack-default.yaml 118 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 0.3.0.0 2 | 3 | - Make surgeries first-class at the type level (`MajorSurgery`) 4 | 5 | # 0.2.1.0 6 | 7 | - Add `toORLazy` and `fromORLazy`, to clean up data types with strictness 8 | annotations. (Thanks to blmage.) 9 | 10 | # 0.2.0.0 11 | 12 | - Compatibility with generic-data 0.4.0.0 13 | - Removed `onData` (moved to generic-data 0.4.0.0). 14 | 15 | # 0.1.0.0 16 | 17 | Initial version 18 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Li-yao Xia (c) 2018 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of 4 | this software and associated documentation files (the “Software”), to deal in 5 | the Software without restriction, including without limitation the rights to 6 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 7 | of the Software, and to permit persons to whom the Software is furnished to do 8 | so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 19 | SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Surgery for generic data types [![Hackage](https://img.shields.io/hackage/v/generic-data-surgery.svg)](https://hackage.haskell.org/package/generic-data-surgery) [![GitHub CI](https://github.com/Lysxia/generic-data-surgery/workflows/CI/badge.svg)](https://github.com/Lysxia/generic-data-surgery/actions) 2 | 3 | Modify, add, or remove constructors and fields in generic types, to be used 4 | with generic implementations. 5 | 6 | ## Example 7 | 8 | Here is a simple record type equipped with a `checksum` function: 9 | 10 | ```haskell 11 | data Foo = Foo { x, y, z :: Int } 12 | deriving (Eq, Generic, Show) 13 | 14 | checksum :: Foo -> Checksum 15 | ``` 16 | 17 | Let's encode it as a JSON object with an extra `"checksum"` key, 18 | looking like this, where `X`, `Y`, `Z` are integers: 19 | 20 | ``` 21 | { "x": X 22 | , "y": Y 23 | , "z": Z 24 | , "checksum": X + Y + Z 25 | } 26 | ``` 27 | 28 | We use `genericParseJSON`/`genericToJSON` to convert between JSON values 29 | and a generic 4-field record, and `removeRField`/`insertRField` to 30 | convert between that generic 4-field record and the 3-field `Foo`. 31 | 32 | ### Remove field 33 | 34 | When decoding, we check the checksum and then throw it away. 35 | 36 | ```haskell 37 | instance FromJSON Foo where 38 | parseJSON v = do 39 | 40 | r <- genericParseJSON defaultOptions v 41 | -- r: a generic 4-field record {x,y,z,checksum} (checksum at index 3). 42 | 43 | let (cs, f) = (fmap fromOR . removeRField @"checksum" @3 . toOR') r 44 | -- removeRField @"checksum" @3: split out the checksum field 45 | -- from the three other fields. (cs, f) :: (Checksum, Foo) 46 | 47 | if checksum f == cs then 48 | pure f 49 | else 50 | fail "Checksum failed" 51 | ``` 52 | 53 | ### Insert field 54 | 55 | When encoding, we must compute the checksum to write it out. We put the 56 | checksum in a pair `(checksum f, f)` with the original record, and 57 | `insertRField` can then wrap it into a 4-field record passed into 58 | `genericToJSON`. 59 | 60 | ```haskell 61 | instance ToJSON Foo where 62 | toJSON f = 63 | (genericToJSON defaultOptions . fromOR' . insertRField @"checksum" @3 . fmap toOR) 64 | (checksum f, f) 65 | ``` 66 | 67 | ## See also 68 | 69 | - [*Surgery for data types*](https://blog.poisson.chat/posts/2018-11-26-type-surgery.html), 70 | introductory blog post with another example. 71 | 72 | - The [`examples/`](https://github.com/Lysxia/generic-data-surgery/tree/master/examples) 73 | directory in the source repo. 74 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/example-aeson.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | DataKinds, 3 | DeriveFunctor, 4 | DeriveGeneric, 5 | DuplicateRecordFields, 6 | FlexibleInstances, 7 | OverloadedStrings, 8 | TypeApplications #-} 9 | 10 | import Data.Aeson 11 | import Data.Aeson.Types (omitNothingFields) 12 | import GHC.Generics (Generic) 13 | import Generic.Data.Surgery (fromOR, toOR', modifyRField) 14 | 15 | -- * The problem 16 | 17 | -- @Rec@ is some record we want to deserialize from JSON. 18 | -- Requirement: if the @"payload"@ field doesn't exist, make it the empty 19 | -- string. 20 | 21 | data Rec = Rec 22 | { iden :: Int 23 | , header1 :: Int 24 | , header2 :: Int 25 | , payload :: String 26 | } deriving (Eq, Generic, Show) 27 | 28 | -- ** Some unit tests 29 | 30 | -- Example parameterized by the @Rec@ constructor. 31 | example 32 | :: (Eq rec, Show rec, FromJSON rec) 33 | => (Int -> Int -> Int -> String -> rec) -> IO () 34 | example rec = do 35 | let ex1 = "{\"iden\":1,\"header1\":2,\"header2\":3}" 36 | ex2 = "{\"iden\":1,\"header1\":2,\"header2\":3,\"payload\":\"Nyalas\"}" 37 | assertEqual (Right (rec 1 2 3 "")) (eitherDecode ex1) 38 | assertEqual (Right (rec 1 2 3 "Nyalas")) (eitherDecode ex2) 39 | 40 | assertEqual :: (Eq a, Show a) => a -> a -> IO () 41 | assertEqual a b 42 | | a == b = pure () 43 | | otherwise = do 44 | putStrLn $ "Expected: " ++ show a 45 | putStrLn $ "Actual: " ++ show b 46 | fail "Assertion failed, not equal." 47 | 48 | -- This helper will be convenient to have. 49 | defString :: Maybe String -> String 50 | defString (Just s) = s 51 | defString Nothing = "" 52 | 53 | -- ** First solution 54 | 55 | -- Direct implementation, verbose but straightforward. 56 | instance FromJSON Rec where 57 | parseJSON = withObject "Rec" $ \o -> do 58 | i <- o .: "iden" 59 | h1 <- o .: "header1" 60 | h2 <- o .: "header2" 61 | p' <- o .:? "payload" 62 | return Rec{iden = i, header1 = h1, header2 = h2, payload = defString p'} 63 | 64 | -- ** Second solution using plain GHC.Generics 65 | 66 | -- One other basic solution, that uses aeson's generic deriving features, is to 67 | -- parameterize @Rec@ so the @payload@ field can be decoded differently than 68 | -- using the instance for @String@. 69 | -- 70 | -- More precisely, we decode it as @Maybe String@, with the option 71 | -- @omitNothingFields=True@. 72 | 73 | data Rec2_ string = Rec2 74 | { iden :: Int 75 | , header1 :: Int 76 | , header2 :: Int 77 | , payload :: string 78 | } deriving (Eq, Functor, Generic, Show) 79 | -- We can use the @DeriveFunctor@ extension to make mapping over the @payload@ 80 | -- field painless. 81 | 82 | type Rec2 = Rec2_ String 83 | 84 | instance FromJSON Rec2 where 85 | parseJSON 86 | = (fmap . fmap) defString 87 | . genericParseJSON defaultOptions{omitNothingFields=True} 88 | 89 | -- @genericParseJSON@ produces a @Parser (Rec2_ (Maybe String))@, 90 | -- the result type then becomes @Rec2@ (i.e., @Rec2_ String@) 91 | -- via @(fmap . fmap) defString@. 92 | 93 | -- ** Third solution using GHC.Generics and also generic-data-surgery 94 | 95 | -- This is exactly the same type as @Rec@, redeclared just so it can carry 96 | -- another instance. 97 | -- 98 | -- Instead of mangling our type like @Rec2@, generic-data-surgery creates a 99 | -- new generic type with which to instantiate @genericParseJSON@, that is 100 | -- isomorphic to @Rec2_ (Maybe String)@. 101 | 102 | data Rec3 = Rec3 103 | { iden :: Int 104 | , header1 :: Int 105 | , header2 :: Int 106 | , payload :: String 107 | } deriving (Eq, Generic, Show) 108 | 109 | instance FromJSON Rec3 where 110 | parseJSON 111 | = fmap (fromOR . modifyRField @"payload" defString . toOR') 112 | . genericParseJSON defaultOptions{omitNothingFields=True} 113 | 114 | -- @genericParseJSON@ produces a @Parser (Data ...)@, where @Data ...@ is a 115 | -- generic type constructed by generic-data-surgery, and as far as 116 | -- @GHC.Generics@ is concerned, that @Data ...@ is a record type with the same 117 | -- fields as @Rec3@, except the @payload@ field has type @Maybe String@. 118 | -- 119 | -- The @modifyRField@ function is a "surgery", which transforms the @payload@ field 120 | -- from @Maybe String@ to @String@ using @defString@, so the record can finally be 121 | -- converted to @Rec3@. 122 | -- 123 | -- The surgery is confined to an "operating room" (@OR@), that interfaces with 124 | -- regular Haskell data types on one side (via @fromOR@) and "synthetic generic 125 | -- types" (@Data@) on the other side (via @toOR'@). 126 | -- 127 | -- (@Data@ can be imported from @Generic.Data.Surgery@ but it actually comes 128 | -- from generic-data, module @Generic.Data.Types@, and this is just one of its 129 | -- many applications.) 130 | 131 | -- * Testing the examples 132 | 133 | main :: IO () 134 | main = do 135 | example Rec 136 | example Rec2 137 | example Rec3 138 | -------------------------------------------------------------------------------- /examples/example-checksum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | DataKinds, 3 | DeriveFunctor, 4 | DeriveGeneric, 5 | DuplicateRecordFields, 6 | FlexibleInstances, 7 | OverloadedStrings, 8 | TypeApplications #-} 9 | 10 | import Data.Aeson 11 | import GHC.Generics (Generic) 12 | import Generic.Data.Surgery (toOR, fromOR, toOR', fromOR', insertRField, removeRField) 13 | 14 | -- Example: Foo encoded as a JSON object with an extra "checksum" key. 15 | -- 16 | -- { "x": X 17 | -- , "y": Y 18 | -- , "z": Z 19 | -- , "checksum": X + Y + Z 20 | -- } 21 | 22 | data Foo = Foo { x, y, z :: Int } 23 | deriving (Eq, Generic, Show) 24 | 25 | checksum :: Foo -> Int 26 | checksum f = x f + y f + z f 27 | 28 | instance FromJSON Foo where 29 | parseJSON v = do 30 | r <- genericParseJSON defaultOptions v 31 | let (cs, f) = (fmap fromOR . removeRField @"checksum" @3 . toOR') r 32 | if checksum f == cs then 33 | pure f 34 | else 35 | fail "Checksum failed" 36 | 37 | instance ToJSON Foo where 38 | toJSON f = 39 | (genericToJSON defaultOptions . fromOR' . insertRField @"checksum" @3 . fmap toOR) 40 | (checksum f, f) 41 | 42 | assertEqual :: (Eq a, Show a) => a -> a -> IO () 43 | assertEqual a b 44 | | a == b = pure () 45 | | otherwise = do 46 | putStrLn $ "Expected: " ++ show a 47 | putStrLn $ "Actual: " ++ show b 48 | fail "Assertion failed, not equal." 49 | 50 | main :: IO () 51 | main = do 52 | let ex1 = "{\"x\":0,\"y\":1,\"z\":2,\"checksum\":3}" -- OK 53 | ex2 = "{\"x\":0,\"y\":1,\"z\":2,\"checksum\":4}" -- Bad checksum 54 | 55 | -- Test parseJSON 56 | assertEqual (Right (Foo 0 1 2)) 57 | (eitherDecode ex1) 58 | assertEqual (Left "Error in $: Checksum failed" :: Either String Foo) 59 | (eitherDecode ex2) 60 | 61 | -- Test toJSON 62 | assertEqual (eitherDecode ex1 :: Either String Value) 63 | (Right (toJSON (Foo 0 1 2))) 64 | -------------------------------------------------------------------------------- /examples/gds-examples.cabal: -------------------------------------------------------------------------------- 1 | name: gds-examples 2 | version: 0.0.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/Lysxia/examples#readme 6 | license: MIT 7 | author: Li-yao Xia 8 | maintainer: lysxia@gmail.com 9 | copyright: 2018-2021 Li-yao Xia 10 | category: Other 11 | build-type: Simple 12 | cabal-version: >=1.10 13 | 14 | library 15 | exposed-modules: 16 | build-depends: 17 | base >= 4.9 && < 5 18 | ghc-options: -Wall 19 | default-language: Haskell2010 20 | 21 | test-suite example-aeson 22 | main-is: example-aeson.hs 23 | build-depends: 24 | generic-data-surgery, 25 | aeson, 26 | base 27 | ghc-options: -Wall 28 | default-language: Haskell2010 29 | type: exitcode-stdio-1.0 30 | 31 | test-suite example-checksum 32 | main-is: example-checksum.hs 33 | build-depends: 34 | generic-data-surgery, 35 | aeson, 36 | base 37 | ghc-options: -Wall 38 | default-language: Haskell2010 39 | type: exitcode-stdio-1.0 40 | 41 | test-suite generic-free-monad 42 | main-is: generic-free-monad.hs 43 | build-depends: 44 | generic-data-surgery, 45 | generic-functor, 46 | base >= 4.13 47 | type: exitcode-stdio-1.0 48 | default-language: Haskell2010 49 | if !impl(ghc >= 8.8) 50 | buildable: False 51 | 52 | source-repository head 53 | type: git 54 | location: https://github.com/Lysxia/examples 55 | -------------------------------------------------------------------------------- /examples/generic-free-monad.hs: -------------------------------------------------------------------------------- 1 | {- Derive Monad for a type like @Pipe@, which is isomorphic to a @Free@ monad 2 | - using generic-data-surgery and generic-functor 3 | -} 4 | 5 | {-# LANGUAGE 6 | AllowAmbiguousTypes, 7 | ConstraintKinds, 8 | DataKinds, 9 | DeriveGeneric, 10 | DerivingVia, 11 | FlexibleInstances, 12 | GADTs, 13 | KindSignatures, 14 | MultiParamTypeClasses, 15 | PolyKinds, 16 | QuantifiedConstraints, 17 | RankNTypes, 18 | ScopedTypeVariables, 19 | StandaloneDeriving, 20 | TypeApplications, 21 | TypeFamilies, 22 | TypeOperators, 23 | UndecidableInstances 24 | #-} 25 | import Generic.Functor 26 | import Generic.Data.Surgery (Data) 27 | import qualified Generic.Data.Surgery as GDS 28 | import GHC.Generics (Generic(Rep), K1(..), M1(..)) 29 | 30 | import Data.Coerce (Coercible, coerce) 31 | import Data.Kind (Constraint, Type) 32 | import Data.Functor.Identity (Identity(..)) 33 | import GHC.TypeLits (Nat, Symbol) 34 | import Data.Type.Bool 35 | import Data.Type.Equality (type (==)) 36 | 37 | import Data.Bifunctor (first) 38 | import Control.Monad (ap) 39 | 40 | data Pipe i o a 41 | = Input (i -> Pipe i o a) 42 | | Output o (Pipe i o a) 43 | | Return a 44 | deriving Generic 45 | 46 | deriving via GenericFunctor (Pipe i o) instance Functor (Pipe i o) 47 | deriving via GenericFreeMonad "Return" (Pipe i o) instance Applicative (Pipe i o) 48 | deriving via GenericFreeMonad "Return" (Pipe i o) instance Monad (Pipe i o) 49 | 50 | -- 51 | 52 | example :: Pipe Int Bool () 53 | example = do 54 | x <- Input Return 55 | Output (x > 10) (Return ()) 56 | if x == 0 then Return () 57 | else example 58 | 59 | runPipe :: [i] -> Pipe i o r -> ([o], r) 60 | runPipe (i : is) (Input k) = runPipe is (k i) 61 | runPipe is (Output o k) = first (o :) (runPipe is k) 62 | runPipe is (Return r) = ([], r) 63 | runPipe [] (Input _) = error "Pipe burst" 64 | 65 | main :: IO () 66 | main = do 67 | let r = runPipe [1,11,2,22,0] example 68 | if r == ([False,True,False,True,False],()) then 69 | pure () 70 | else 71 | error ("Unexpected result :" ++ show r) 72 | 73 | -- Generic library 74 | 75 | {- = Recipe 76 | 77 | Given a type like @Pipe@, which is @Generic@, and a constructor name such as @Return@ 78 | provided as a @Symbol@, we implement @pure@ and @(>>=)@ generically. 79 | @pure@ is easy enough compared to @(>>=)@. 80 | 81 | To implement @(>>=)@, we define @(>>= k) :: m a -> m b@ recursively by case analysis 82 | on the first argument: 83 | 84 | 1. If the first argument is the constructor @Return@ with a single field @a@, then apply @k@ 85 | 2. For all other constructors, recursively apply @(>>= k)@ wherever it makes 86 | sense. 87 | 88 | We use the library generic-data-surgery (@InsertConstr@, @RemoveConstr@) to extract the 89 | @Return@ constructor (step 1), and generic-functor (@gsolomap@) to apply @(>>= k)@ everywhere 90 | else. 91 | -} 92 | 93 | -- 94 | 95 | newtype GenericFreeMonad (returnName :: Symbol) (m :: Type -> Type) (a :: Type) 96 | = GenericFreeMonad (m a) 97 | 98 | deriving via (m :: Type -> Type) instance Functor m => Functor (GenericFreeMonad returnName m) 99 | 100 | instance GMonad returnName m => Applicative (GenericFreeMonad returnName m) where 101 | (<*>) = ap 102 | pure = coercePure (gpure @returnName @m) where 103 | 104 | instance GMonad returnName m => Monad (GenericFreeMonad returnName m) where 105 | (>>=) = coerceBind (gbind @returnName @m) where 106 | 107 | coerceBind :: Coercible m n => (m a -> (a -> m b) -> m b) -> (n a -> (a -> n b) -> n b) 108 | coerceBind = coerce 109 | 110 | coercePure :: Coercible m n => (a -> m a) -> (a -> n a) 111 | coercePure = coerce 112 | 113 | -- 114 | 115 | class (Functor m, forall a. GPure returnName m a, forall a b. GBind returnName m a b) 116 | => GMonad (returnName :: Symbol) (m :: Type -> Type) 117 | instance (Functor m, forall a. GPure returnName m a, forall a b. GBind returnName m a b) 118 | => GMonad (returnName :: Symbol) (m :: Type -> Type) 119 | 120 | class GBind (returnName :: Symbol) (m :: Type -> Type) a b where 121 | gbind :: m a -> (a -> m b) -> m b 122 | 123 | -- 1. Separate the @Return@ constructor using the @RemoveConstr@ surgery 124 | -- 2. Apply @k@ to the single field of @Return@ (@LookupS "k"@) 125 | -- 3. Apply @(>>= k)@ to every field of every other constructor (@GSolomapS@) 126 | -- 3b. Clean up: restore the generic representation (@InsertConstr@) and 127 | -- convert back to the original type @m@. 128 | -- 129 | -- We have to manually generalize @l, lc, f, f', l', lc'@, otherwise GHC will specialize them 130 | -- to @Any@, which is bad. 131 | type GBindSurgery (returnName :: Symbol) (n :: Nat) (m :: Type -> Type) (a :: Type) (b :: Type) 132 | l lc f f' l' lc' = 133 | ((ToOR 134 | :>>> RemoveConstr @lc @() @l returnName n (Identity a) 135 | :>>> CaseEither 136 | (RunIdentity :>>> LookupS @a @(m b) "k") 137 | (FromOR' @l @() @f :>>> GSolomapS (LookupS @(m a) @(m b) "go_k") :>>> ToOR' @f' @() @l' 138 | :>>> RightS :>>> InsertConstr @l' @() @lc' returnName n (Identity b) :>>> FromOR)) 139 | :: m a ~~> m b) 140 | 141 | instance (s ~ GBindSurgery returnName n m a b l lc f f' l' lc', Apply s) 142 | => GBind returnName m a b where 143 | gbind u k = go_k u where 144 | go_k :: m a -> m b 145 | go_k = apply @(m a) @(m b) @s (Tagged @"k" @(a -> m b) k :+ Tagged @"go_k" @(m a -> m b) go_k :+ ()) 146 | 147 | class GPure (returnName :: Symbol) (m :: Type -> Type) a where 148 | gpure :: a -> m a 149 | 150 | type GPureSurgery (returnName :: Symbol) (n :: Nat) (m :: Type -> Type) (a :: Type) 151 | l lc = 152 | (IdentityS :>>> LeftS :>>> InsertConstr @l @() @lc returnName n (Identity a) :>>> FromOR 153 | :: a ~~> m a) 154 | 155 | instance (s ~ GPureSurgery returnName n m a l lc, Apply s) 156 | => GPure returnName m a where 157 | gpure = apply @a @(m a) @s () 158 | 159 | -- 160 | 161 | -- generic-data-surgery is currently a pain to use parametrically. 162 | -- We build a type-level language embedding generic-data-surgery 163 | -- in order to "postpone" some constraint solving to use sites of 164 | -- @gbind@/@gpure@/DerivingVia, where the monad is concretely known. 165 | 166 | type a ~~> b = (a -> b -> Type) 167 | 168 | class Apply (f :: a ~~> b) where 169 | type Env (f :: a ~~> b) (e :: Type) :: Constraint 170 | type Env f e = (() :: Constraint) 171 | apply :: Env f e => e -> a -> b 172 | 173 | data Id :: a ~~> a 174 | 175 | instance Apply Id where 176 | apply _ = id 177 | 178 | data (f :: a ~~> b) :>>> (g :: b ~~> c) :: a ~~> c 179 | 180 | instance (Apply f, Apply g) => Apply (f :>>> g) where 181 | type Env (f :>>> g) e = (Env f e, Env g e) 182 | apply e = apply @_ @_ @g e . apply @_ @_ @f e 183 | 184 | data CaseEither (f :: a ~~> c) (g :: b ~~> c) :: Either a b ~~> c 185 | 186 | instance (Apply f, Apply g) => Apply (CaseEither f g) where 187 | type Env (CaseEither f g) e = (Env f e, Env g e) 188 | apply e = either (apply @_ @_ @f e) (apply @_ @_ @g e) 189 | 190 | data ToOR_ (k :: GDS.OR l x ~~> d) :: a ~~> d 191 | type ToOR = ToOR_ Id 192 | 193 | instance (Apply k, Generic a, GDS.ToORRep a l) 194 | => Apply (ToOR_ (k :: GDS.OR l x ~~> d) :: a ~~> d) where 195 | type Env (ToOR_ k) e = Env k e 196 | apply e = apply @_ @_ @k e . GDS.toOR 197 | 198 | data FromOR_ (k :: d ~~> GDS.OR l x) :: d ~~> a 199 | type FromOR = FromOR_ Id 200 | 201 | instance (Apply k, Generic a, GDS.FromORRep a l) 202 | => Apply (FromOR_ (k :: d ~~> GDS.OR l x) :: d ~~> a) where 203 | type Env (FromOR_ k) e = Env k e 204 | apply e = GDS.fromOR . apply @_ @_ @k e 205 | 206 | data ToOR' :: Data f x ~~> GDS.OR l x 207 | 208 | instance (GDS.ToOR f l) 209 | => Apply (ToOR' :: Data f x ~~> GDS.OR l x) where 210 | apply _ = GDS.toOR' 211 | 212 | data FromOR' :: GDS.OR l x ~~> Data f x 213 | 214 | instance (GDS.FromOR f l) 215 | => Apply (FromOR' :: GDS.OR l x ~~> Data f x) where 216 | apply _ = GDS.fromOR' 217 | 218 | data InsertConstr (c :: Symbol) (n :: Nat) (t :: Type) :: Either t (GDS.OR l (x :: Type)) ~~> GDS.OR lc x 219 | 220 | instance (GDS.InsConstr c n t lc l) 221 | => Apply (InsertConstr c n t :: Either t (GDS.OR l x) ~~> GDS.OR lc x) where 222 | apply _ = GDS.insertConstr @c @n @t @lc @l 223 | 224 | data RemoveConstr (c :: Symbol) (n :: Nat) (t :: Type) :: GDS.OR lc x ~~> Either t (GDS.OR l x) 225 | 226 | instance (GDS.RmvConstr c n t lc l) 227 | => Apply (RemoveConstr c n t :: GDS.OR lc x ~~> Either t (GDS.OR l x)) where 228 | apply _ = GDS.removeConstr @c @n @t @lc @l 229 | 230 | newtype Tagged s a = Tagged a 231 | 232 | class Lookup s e where 233 | type Assoc s e :: Type 234 | lookupEnv :: e -> Assoc s e 235 | 236 | data SBool (b :: Bool) where 237 | SFalse :: SBool 'False 238 | STrue :: SBool 'True 239 | 240 | class IsBool b where 241 | demoteBool :: SBool b 242 | 243 | instance IsBool 'False where 244 | demoteBool = SFalse 245 | 246 | instance IsBool 'True where 247 | demoteBool = STrue 248 | 249 | instance (IsBool (s == s'), If (s == s') (() :: Constraint) (Lookup s b)) => Lookup s (Tagged s' a :+ b) where 250 | type Assoc s (Tagged s' a :+ b) = If (s == s') a (Assoc s b) 251 | lookupEnv (Tagged a :+ b) = case demoteBool @(s == s') of 252 | STrue -> a 253 | SFalse -> lookupEnv @s b 254 | 255 | data GSolomapS (k :: a ~~> b) :: x ~~> y 256 | 257 | instance (Apply k, Generic x, Generic y, GSolomap a b x y) => Apply (GSolomapS (k :: a ~~> b) :: x ~~> y) where 258 | type Env (GSolomapS k) e = Env k e 259 | apply e = gsolomap (apply @_ @_ @k e) 260 | 261 | data LookupS (s :: Symbol) :: a ~~> b 262 | 263 | instance Apply (LookupS s :: a ~~> b) where 264 | type Env (LookupS s) e = (Lookup s e, Assoc s e ~ (a -> b)) 265 | apply e = lookupEnv @s e 266 | 267 | data RunIdentity :: Identity a ~~> a 268 | 269 | instance Apply RunIdentity where 270 | apply _ = runIdentity 271 | 272 | data IdentityS :: a ~~> Identity a 273 | 274 | instance Apply IdentityS where 275 | apply _ = Identity 276 | 277 | data LeftS :: e ~~> Either e a 278 | 279 | instance Apply LeftS where 280 | apply _ = Left 281 | 282 | data RightS :: a ~~> Either e a 283 | 284 | instance Apply RightS where 285 | apply _ = Right 286 | -------------------------------------------------------------------------------- /generic-data-surgery.cabal: -------------------------------------------------------------------------------- 1 | name: generic-data-surgery 2 | version: 0.3.0.0 3 | synopsis: Surgery for generic data types 4 | description: 5 | Transform data types before passing them to generic functions. 6 | homepage: https://github.com/Lysxia/generic-data-surgery#readme 7 | license: MIT 8 | license-file: LICENSE 9 | author: Li-yao Xia 10 | maintainer: lysxia@gmail.com 11 | copyright: 2018 Li-yao Xia 12 | category: Other 13 | build-type: Simple 14 | extra-source-files: README.md, CHANGELOG.md 15 | cabal-version: >=1.10 16 | tested-with: 17 | GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.1, GHC == 8.6.3, GHC == 8.8.3, GHC == 8.10.1 18 | 19 | library 20 | hs-source-dirs: src 21 | exposed-modules: 22 | Generic.Data.Surgery 23 | Generic.Data.Surgery.Internal 24 | build-depends: 25 | generic-data >= 0.2, 26 | first-class-families >= 0.2, 27 | base >= 4.9 && < 5 28 | ghc-options: -Wall 29 | default-language: Haskell2010 30 | 31 | test-suite surgery-test 32 | hs-source-dirs: test 33 | main-is: surgery.hs 34 | build-depends: 35 | tasty, 36 | tasty-hunit, 37 | generic-data, 38 | generic-data-surgery, 39 | base 40 | ghc-options: -Wall 41 | default-language: Haskell2010 42 | type: exitcode-stdio-1.0 43 | 44 | test-suite synthetic-test 45 | hs-source-dirs: test 46 | main-is: synthetic.hs 47 | build-depends: 48 | tasty, 49 | tasty-hunit, 50 | generic-data, 51 | generic-data-surgery, 52 | show-combinators >= 0.2, 53 | -- ^ avoid a bug 54 | base 55 | if !impl(ghc >= 8.6) 56 | build-depends: 57 | contravariant 58 | ghc-options: -Wall 59 | default-language: Haskell2010 60 | type: exitcode-stdio-1.0 61 | 62 | source-repository head 63 | type: git 64 | location: https://github.com/Lysxia/generic-data-surgery 65 | -------------------------------------------------------------------------------- /src/Generic/Data/Surgery.hs: -------------------------------------------------------------------------------- 1 | -- | Surgery for generic data types: 2 | -- remove and insert constructors and fields. 3 | -- 4 | -- Functions in this module are expected to be used with visible type 5 | -- applications. Surgeries have a lot of type parameters, but usually only the 6 | -- first one to three type arguments need to be passed via @TypeApplications@. 7 | -- Functions are documented with informal \"functional dependencies\", 8 | -- clarifying which type parameters can be inferred from which others 9 | -- (click on \"Details\" under each function to see those). 10 | -- 11 | -- Remember that not all parameters to the left of a functional dependency 12 | -- arrow need to be annotated explicitly to determine those on the right. Some 13 | -- can also be inferred from the context. 14 | -- 15 | -- Note that constructors and fields are indexed from zero. 16 | 17 | module Generic.Data.Surgery 18 | ( -- * Surgeries from generic-data and generic-lens 19 | -- 20 | -- | The library 21 | -- has a "Generic.Data.Microsurgery" module (since 0.4.0.0) to modify some 22 | -- metadata of generic representations. 23 | -- 24 | -- If you only want to /update/ fields, rather than remove or insert them, 25 | -- see also the documentation in the above module, on making surgeries out of 26 | -- . 27 | 28 | -- * Synthetic data types 29 | 30 | Data 31 | 32 | , toData 33 | , fromData 34 | 35 | -- * Surgeries 36 | 37 | -- ** Getting into the operating room 38 | , OR 39 | 40 | , toOR 41 | , fromOR' 42 | , toOR' 43 | , fromOR 44 | 45 | , OROf 46 | 47 | , toORLazy 48 | , fromORLazy 49 | 50 | , OROfLazy 51 | 52 | -- ** Unnamed fields 53 | , removeCField 54 | , insertCField 55 | , insertCField' 56 | , modifyCField 57 | 58 | -- ** Named fields (records) 59 | , removeRField 60 | , insertRField 61 | , insertRField' 62 | , modifyRField 63 | 64 | -- ** Constructors 65 | 66 | -- | A constructor is extracted to a "tuple", which can be any 67 | -- 'GHC.Generics.Generic' single-constructor type with the same number of 68 | -- fields. 69 | -- 70 | -- Note that @()@ and 'Data.Functor.Identity.Identity' can be used as an 71 | -- empty and a singleton tuple type respectively. 72 | 73 | , removeConstr 74 | , insertConstr 75 | , modifyConstr 76 | 77 | -- *** Constructors as tuples 78 | -- 79 | -- When the tuple type can't be inferred and doesn't really matter, 80 | -- an alternative to explicit type annotations is to use the @...ConstrT@ 81 | -- variants of these surgeries, which are specialized to actual tuples 82 | -- (@()@, 'Data.Functor.Identity.Identity', @(,)@, @(,,)@, up to 7 --- 83 | -- because that's where 'GHC.Generics.Generic' instances currently stop). 84 | 85 | , removeConstrT 86 | , insertConstrT 87 | , modifyConstrT 88 | 89 | -- * Surgeries as type-level operations 90 | 91 | -- | Example usage: define a synthetic type which adds a @\"key\"@ field of type @Key@ 92 | -- to an existing record type. 93 | -- 94 | -- @ 95 | -- -- Define the surgery to insert a field (key :: Key) 96 | -- -- as the first field (index 0) of a record. 97 | -- type InsertId = ('InsertField' 0 (''Just' \"key\") Key :: 'MajorSurgery' k) 98 | -- 99 | -- -- Define a newtype for synthetic ('Data') types obtained from a real type @a@ 100 | -- -- using the @InsertId@ surgery we just defined. 101 | -- newtype WithKey a = WithKey ('Data' ('Operate' ('GHC.Generics.Rep' a) InsertId) ()) 102 | -- @ 103 | 104 | -- ** Types and composition 105 | 106 | -- | 107 | -- === Implementation notes 108 | -- 109 | -- The implementation of these type synonyms is hidden behind names 110 | -- suffixed with an underscore. Although they appear in the haddocks, 111 | -- these auxiliary names are internal and not exported by this module. 112 | 113 | , MajorSurgery 114 | , Perform 115 | , Operate 116 | , (:>>) 117 | , IdSurgery 118 | 119 | -- ** Surgeries 120 | , InsertField 121 | , RemoveField 122 | , RemoveRField 123 | , InsertConstrAt 124 | , RemoveConstr 125 | , Suture 126 | 127 | -- * Constraint synonyms 128 | 129 | -- | Hiding implementation details from the signatures above. 130 | 131 | -- ** Conversions 132 | 133 | , ToORRep 134 | , ToOR 135 | , ToORRepLazy 136 | , ToORLazy 137 | , FromORRep 138 | , FromOR 139 | , FromORRepLazy 140 | , FromORLazy 141 | 142 | -- ** Surgeries 143 | 144 | , RmvCField 145 | , InsCField 146 | , ModCField 147 | , RmvRField 148 | , InsRField 149 | , ModRField 150 | , RmvConstr 151 | , InsConstr 152 | , ModConstr 153 | , RmvConstrT 154 | , InsConstrT 155 | , ModConstrT 156 | ) where 157 | 158 | import Generic.Data.Types (Data(..), toData, fromData) 159 | 160 | import Generic.Data.Surgery.Internal 161 | -------------------------------------------------------------------------------- /src/Generic/Data/Surgery/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | AllowAmbiguousTypes, 3 | BangPatterns, 4 | ConstraintKinds, 5 | DataKinds, 6 | DeriveGeneric, 7 | FlexibleContexts, 8 | FlexibleInstances, 9 | LambdaCase, 10 | MultiParamTypeClasses, 11 | PolyKinds, 12 | ScopedTypeVariables, 13 | TypeApplications, 14 | TypeFamilies, 15 | TypeOperators, 16 | TypeInType, 17 | UndecidableInstances, 18 | UndecidableSuperClasses #-} 19 | 20 | -- | Operate on data types: insert\/modify\/delete fields and constructors. 21 | 22 | module Generic.Data.Surgery.Internal where 23 | 24 | import Control.Monad ((<=<)) 25 | import Data.Bifunctor (first, second) 26 | import Data.Coerce 27 | import Data.Functor.Identity (Identity) 28 | import Data.Kind (Constraint, Type) 29 | import Data.Type.Equality (type (==)) 30 | import GHC.Generics 31 | import GHC.TypeLits 32 | 33 | import Fcf 34 | ( Exp, Eval, If, Pure, Pure2, Bimap, Uncurry 35 | , type (@@), type (=<<), type (<=<), type (<$>) 36 | ) 37 | 38 | import Generic.Data (MetaOf, MetaConsName) 39 | import Generic.Data.Internal.Compat (Div) 40 | import Generic.Data.Internal.Data (Data(Data,unData)) 41 | import Generic.Data.Internal.Meta (UnM1) 42 | import Generic.Data.Internal.Utils (coerce', absurd1) 43 | 44 | -- | /A sterile Operating Room, where generic data comes to be altered./ 45 | -- 46 | -- Generic representation in a simplified shape @l@ at the type level 47 | -- (reusing the constructors from "GHC.Generics" for convenience). 48 | -- This representation makes it easy to modify fields and constructors. 49 | -- 50 | -- We may also refer to the representation @l@ as a "row" of constructors, 51 | -- if it represents a sum type, otherwise it is a "row" of unnamed fields or 52 | -- record fields for single-constructor types. 53 | -- 54 | -- @x@ corresponds to the last parameter of 'Rep', and is currently ignored by 55 | -- this module (no support for 'Generic1'). 56 | -- 57 | -- === General sketch 58 | -- 59 | -- > 60 | -- > toOR surgeries fromOR' 61 | -- > data MyType --------> OR (Rep MyType) ----------> OR alteredRep ---------> Data alteredRep 62 | -- > | 63 | -- > | myGenericFun :: Generic a => a -> a 64 | -- > fromOR surgeries toOR' v 65 | -- > data MyType <-------- OR (Rep MyType) <---------- OR alteredRep <--------- Data alteredRep 66 | -- > 67 | -- 68 | -- If instead @myGenericFun@ is only a consumer of @a@ (resp. producer), 69 | -- then you only need the top half of the diagram (resp. bottom half). 70 | -- For example, in aeson: 71 | -- @genericToJSON@ (consumer), @genericParseJSON@ (producer). 72 | newtype OR (l :: k -> Type) (x :: k) = OR { unOR :: l x } 73 | 74 | -- | /Move fresh data to the Operating Room, where surgeries can be applied./ 75 | -- 76 | -- Convert a generic type to a generic representation. 77 | -- 78 | -- When inserting or removing fields, there may be a mismatch with strict/unpacked fields. 79 | -- To work around this, you can switch to 'toORLazy', if your operations don't care about 80 | -- dealing with a normalized 'Rep' (in which all the strictness annotations have been 81 | -- replaced with lazy defaults). 82 | -- 83 | -- === __Details__ 84 | -- 85 | -- ==== Type parameters 86 | -- 87 | -- @ 88 | -- a :: 'Type' -- Generic type 89 | -- l :: k -> 'Type' -- Generic representation (simplified) 90 | -- x :: k -- Ignored 91 | -- @ 92 | -- 93 | -- ==== Functional dependencies 94 | -- 95 | -- @ 96 | -- a -> l 97 | -- @ 98 | toOR :: forall a l x. (Generic a, ToORRep a l) => a -> OR l x 99 | toOR = OR . gLinearize . from 100 | 101 | -- | /Move normalized data to the Operating Room, where surgeries can be applied./ 102 | -- 103 | -- Convert a generic type to a generic representation, in which all the strictness 104 | -- annotations have been normalized to lazy defaults. 105 | -- 106 | -- This variant is useful when one needs to operate on fields whose 'Rep' has different 107 | -- strictness annotations than the ones used by 'DefaultMetaSel'. 108 | -- 109 | -- === __Details__ 110 | -- 111 | -- ==== Type parameters 112 | -- 113 | -- @ 114 | -- a :: 'Type' -- Generic type 115 | -- l :: k -> 'Type' -- Generic representation (simplified and normalized) 116 | -- x :: k -- Ignored 117 | -- @ 118 | -- 119 | -- ==== Functional dependencies 120 | -- 121 | -- @ 122 | -- a -> l 123 | -- @ 124 | toORLazy :: forall a l x. (Generic a, ToORRepLazy a l) => a -> OR l x 125 | toORLazy = OR . gLinearize @(Arborify l) . coerce' . from 126 | 127 | -- | /Move altered data out of the Operating Room, to be consumed by/ 128 | -- /some generic function./ 129 | -- 130 | -- Convert a generic representation to a \"synthetic\" type that behaves 131 | -- like a generic type. 132 | -- 133 | -- === __Details__ 134 | -- 135 | -- ==== Type parameters 136 | -- 137 | -- @ 138 | -- f :: k -> 'Type' -- 'Generic' representation (proper) 139 | -- l :: k -> 'Type' -- Generic representation (simplified) 140 | -- x :: k -- Ignored 141 | -- @ 142 | -- 143 | -- ==== Functional dependencies 144 | -- 145 | -- @ 146 | -- f -> l 147 | -- l -> f 148 | -- @ 149 | -- 150 | -- ==== Implementation details 151 | -- 152 | -- The synthesized representation is made of balanced binary trees, 153 | -- corresponding closely to what GHC would generate for an actual data type. 154 | -- 155 | -- That structure assumed by at least one piece of code out there (@aeson@). 156 | fromOR' :: forall f l x. FromOR f l => OR l x -> Data f x 157 | fromOR' = Data . gArborify . unOR 158 | 159 | -- | /Move altered data, produced by some generic function, to the operating/ 160 | -- /room./ 161 | -- 162 | -- The inverse of 'fromOR''. 163 | -- 164 | -- === __Details__ 165 | -- 166 | -- ==== Type parameters 167 | -- 168 | -- @ 169 | -- f :: k -> 'Type' -- 'Generic' representation (proper) 170 | -- l :: k -> 'Type' -- Generic representation (simplified) 171 | -- x :: k -- Ignored 172 | -- @ 173 | -- 174 | -- ==== Functional dependencies 175 | -- 176 | -- @ 177 | -- f -> l 178 | -- l -> f 179 | -- @ 180 | toOR' :: forall f l x. ToOR f l => Data f x -> OR l x 181 | toOR' = OR . gLinearize . unData 182 | 183 | -- | /Move restored data out of the Operating Room and back to the real/ 184 | -- /world./ 185 | -- 186 | -- The inverse of 'toOR'. 187 | -- 188 | -- It may be useful to annotate the output type of 'fromOR', 189 | -- since the rest of the type depends on it and the only way to infer it 190 | -- otherwise is from the context. The following annotations are possible: 191 | -- 192 | -- @ 193 | -- 'fromOR' :: 'OROf' a -> a 194 | -- 'fromOR' \@a -- with TypeApplications 195 | -- @ 196 | -- 197 | -- When inserting or removing fields, there may be a mismatch with strict/unpacked fields. 198 | -- To work around this, you can switch to 'fromORLazy', if your operations don't care 199 | -- about dealing with a normalized 'Rep' (in which all the strictness annotations have 200 | -- been replaced with lazy defaults). 201 | -- 202 | -- === __Details__ 203 | -- 204 | -- ==== Type parameters 205 | -- 206 | -- @ 207 | -- a :: 'Type' -- Generic type 208 | -- l :: k -> 'Type' -- Generic representation (simplified) 209 | -- x :: k -- Ignored 210 | -- @ 211 | -- 212 | -- ==== Functional dependencies 213 | -- 214 | -- @ 215 | -- a -> l 216 | -- @ 217 | fromOR :: forall a l x. (Generic a, FromORRep a l) => OR l x -> a 218 | fromOR = to . gArborify . unOR 219 | 220 | -- | /Move normalized data out of the Operating Room and back to the real/ 221 | -- /world./ 222 | -- 223 | -- The inverse of 'toORLazy'. 224 | -- 225 | -- It may be useful to annotate the output type of 'fromORLazy', 226 | -- since the rest of the type depends on it and the only way to infer it 227 | -- otherwise is from the context. The following annotations are possible: 228 | -- 229 | -- @ 230 | -- 'fromORLazy' :: 'OROfLazy' a -> a 231 | -- 'fromORLazy' \@a -- with TypeApplications 232 | -- @ 233 | -- 234 | -- === __Details__ 235 | -- 236 | -- ==== Type parameters 237 | -- 238 | -- @ 239 | -- a :: 'Type' -- Generic type 240 | -- l :: k -> 'Type' -- Generic representation (simplified and normalized) 241 | -- x :: k -- Ignored 242 | -- @ 243 | -- 244 | -- ==== Functional dependencies 245 | -- 246 | -- @ 247 | -- a -> l 248 | -- @ 249 | fromORLazy :: forall a l x. (Generic a, FromORRepLazy a l) => OR l x -> a 250 | fromORLazy = to . coerce' . gArborify @(Lazify (Rep a)) . unOR 251 | 252 | -- | The simplified generic representation type of type @a@, 253 | -- that 'toOR' and 'fromOR' convert to and from. 254 | type OROf a = OR (Linearize (Rep a)) () 255 | 256 | -- | The simplified and normalized generic representation type of type @a@, 257 | -- that 'toORLazy' and 'fromORLazy' convert to and from. 258 | type OROfLazy a = OR (Linearize (Lazify (Rep a))) () 259 | 260 | -- | This constraint means that @a@ is convertible /to/ its simplified 261 | -- generic representation. Implies @'OROf' a ~ 'OR' l ()@. 262 | type ToORRep a l = ToOR (Rep a) l 263 | 264 | -- | This constraint means that @a@ is convertible /from/ its simplified 265 | -- generic representation. Implies @'OROf' a ~ 'OR' l ()@. 266 | type FromORRep a l = FromOR (Rep a) l 267 | 268 | -- | Similar to 'ToORRep', but as a constraint on the standard 269 | -- generic representation of @a@ directly, @f ~ 'Rep' a@. 270 | type ToOR f l = (GLinearize f, Linearize f ~ l, f ~ Arborify l) 271 | 272 | -- | Similar to 'FromORRep', but as a constraint on the standard 273 | -- generic representation of @a@ directly, @f ~ 'Rep' a@. 274 | type FromOR f l = (GArborify f, Linearize f ~ l, f ~ Arborify l) 275 | 276 | -- | This constraint means that @a@ is convertible /to/ its simplified 277 | -- and normalized generic representation (i.e., with all its strictness 278 | -- annotations normalized to lazy defaults). 279 | -- Implies @'OROfLazy' a ~ 'OR' l ()@. 280 | type ToORRepLazy a l = ToORLazy (Rep a) l 281 | 282 | -- | This constraint means that @a@ is convertible /from/ its simplified 283 | -- and normalized generic representation (i.e., with all its strictness 284 | -- annotations normalized to lazy defaults). 285 | -- Implies @'OROfLazy' a ~ 'OR' l ()@. 286 | type FromORRepLazy a l = FromORLazy (Rep a) l 287 | 288 | -- | Similar to 'FromLazyORRep', but as a constraint on the standard 289 | -- generic representation of @a@ directly, @f ~ 'Rep' a@. 290 | type FromORLazy f l = (FromOR (Lazify f) l, Coercible (Arborify l) f) 291 | 292 | -- | Similar to 'ToORRepLazy', but as a constraint on the standard 293 | -- generic representation of @a@ directly, @f ~ 'Rep' a@. 294 | type ToORLazy f l = (ToOR (Lazify f) l, Coercible f (Arborify l)) 295 | 296 | -- 297 | 298 | -- | @'removeCField' \@n \@t@: remove the @n@-th field, of type @t@, in a 299 | -- non-record single-constructor type. 300 | -- 301 | -- Inverse of 'insertCField'. 302 | -- 303 | -- === __Details__ 304 | -- 305 | -- ==== Type parameters 306 | -- 307 | -- @ 308 | -- n :: 'Nat' -- Field position 309 | -- t :: 'Type' -- Field type 310 | -- lt :: k -> 'Type' -- Row with field 311 | -- l :: k -> 'Type' -- Row without field 312 | -- x :: k -- Ignored 313 | -- @ 314 | -- 315 | -- ==== Signature 316 | -- 317 | -- @ 318 | -- 'OR' lt x -- Data with field 319 | -- -> 320 | -- (t, 'OR' l x) -- Field value × Data without field 321 | -- @ 322 | -- 323 | -- ==== Functional dependencies 324 | -- 325 | -- @ 326 | -- n lt -> t l 327 | -- n t l -> lt 328 | -- @ 329 | removeCField 330 | :: forall n t lt l x 331 | . RmvCField n t lt l 332 | => OR lt x -> (t, OR l x) 333 | removeCField (OR a) = OR <$> gRemoveField @n a 334 | 335 | -- | @'removeRField' \@\"fdName\" \@n \@t@: remove the field @fdName@ 336 | -- at position @n@ of type @t@ in a record type. 337 | -- 338 | -- Inverse of 'insertRField'. 339 | -- 340 | -- === __Details__ 341 | -- 342 | -- ==== Type parameters 343 | -- 344 | -- @ 345 | -- fd :: 'Symbol' -- Field name 346 | -- n :: 'Nat' -- Field position 347 | -- t :: 'Type' -- Field type 348 | -- lt :: k -> 'Type' -- Row with field 349 | -- l :: k -> 'Type' -- Row without field 350 | -- x :: k -- Ignored 351 | -- @ 352 | -- 353 | -- ==== Signature 354 | -- 355 | -- @ 356 | -- 'OR' lt x -- Data with field 357 | -- -> 358 | -- (t, 'OR' l x) -- Field value × Data without field 359 | -- @ 360 | -- 361 | -- ==== Functional dependencies 362 | -- 363 | -- @ 364 | -- fd lt -> n t l 365 | -- n lt -> fd t l 366 | -- fd n t l -> lt 367 | -- @ 368 | removeRField 369 | :: forall fd n t lt l x 370 | . RmvRField fd n t lt l 371 | => OR lt x -> (t, OR l x) 372 | removeRField (OR a) = OR <$> gRemoveField @n a 373 | 374 | -- | @'insertCField' \@n \@t@: insert a field of type @t@ 375 | -- at position @n@ in a non-record single-constructor type. 376 | -- 377 | -- Inverse of 'removeCField'. 378 | -- 379 | -- === __Details__ 380 | -- 381 | -- ==== Type parameters 382 | -- 383 | -- @ 384 | -- n :: 'Nat' -- Field position 385 | -- t :: 'Type' -- Field type 386 | -- lt :: k -> 'Type' -- Row with field 387 | -- l :: k -> 'Type' -- Row without field 388 | -- x :: k -- Ignored 389 | -- @ 390 | -- 391 | -- ==== Signature 392 | -- 393 | -- @ 394 | -- (t, 'OR' l x) -- Field value × Data without field 395 | -- -> 396 | -- 'OR' lt x -- Data with field 397 | -- @ 398 | -- 399 | -- ==== Functional dependencies 400 | -- 401 | -- @ 402 | -- n lt -> t l 403 | -- n t l -> lt 404 | -- @ 405 | insertCField 406 | :: forall n t lt l x 407 | . InsCField n t lt l 408 | => (t, OR l x) -> OR lt x 409 | insertCField = uncurry (insertCField' @n) 410 | 411 | -- | Curried 'insertCField'. 412 | insertCField' 413 | :: forall n t lt l x 414 | . InsCField n t lt l 415 | => t -> OR l x -> OR lt x 416 | insertCField' z (OR a) = OR (gInsertField @n z a) 417 | 418 | -- | @'insertRField' \@\"fdName\" \@n \@t@: insert a field 419 | -- named @fdName@ of type @t@ at position @n@ in a record type. 420 | -- 421 | -- Inverse of 'removeRField'. 422 | -- 423 | -- === __Details__ 424 | -- 425 | -- ==== Type parameters 426 | -- 427 | -- @ 428 | -- fd :: 'Symbol' -- Field name 429 | -- n :: 'Nat' -- Field position 430 | -- t :: 'Type' -- Field type 431 | -- lt :: k -> 'Type' -- Row with field 432 | -- l :: k -> 'Type' -- Row without field 433 | -- x :: k -- Ignored 434 | -- @ 435 | -- 436 | -- ==== Signature 437 | -- 438 | -- @ 439 | -- (t, 'OR' l x) -- Field value × Data without field 440 | -- -> 441 | -- 'OR' lt x -- Data with field 442 | -- @ 443 | -- 444 | -- ==== Functional dependencies 445 | -- 446 | -- @ 447 | -- fd lt -> n t l 448 | -- n lt -> fd t l 449 | -- fd n t l -> lt 450 | -- @ 451 | insertRField 452 | :: forall fd n t lt l x 453 | . InsRField fd n t lt l 454 | => (t, OR l x) -> OR lt x 455 | insertRField = uncurry (insertRField' @fd) 456 | 457 | -- | Curried 'insertRField'. 458 | insertRField' 459 | :: forall fd n t lt l x 460 | . InsRField fd n t lt l 461 | => t -> OR l x -> OR lt x 462 | insertRField' z (OR a) = OR (gInsertField @n z a) 463 | 464 | -- | @'modifyCField' \@n \@t \@t'@: modify the field at position @n@ in a 465 | -- non-record via a function @f :: t -> t'@ (changing the type of the field). 466 | -- 467 | -- === __Details__ 468 | -- 469 | -- ==== Type parameters 470 | -- 471 | -- @ 472 | -- n :: 'Nat' -- Field position 473 | -- t :: 'Type' -- Initial field type 474 | -- t' :: 'Type' -- Final field type 475 | -- lt :: k -> 'Type' -- Row with initial field 476 | -- lt' :: k -> 'Type' -- Row with final field 477 | -- l :: k -> 'Type' -- Row without field 478 | -- x :: k -- Ignored 479 | -- @ 480 | -- 481 | -- ==== Signature 482 | -- 483 | -- @ 484 | -- (t -> t') -- Field modification 485 | -- -> 486 | -- 'OR' lt x -- Data with field t 487 | -- -> 488 | -- 'OR' lt' x -- Data with field t' 489 | -- @ 490 | -- 491 | -- ==== Functional dependencies 492 | -- 493 | -- @ 494 | -- n lt -> t l 495 | -- n lt' -> t' l 496 | -- n t l -> lt 497 | -- n t' l -> lt' 498 | -- @ 499 | modifyCField 500 | :: forall n t t' lt lt' l x 501 | . ModCField n t t' lt lt' l 502 | => (t -> t') -> OR lt x -> OR lt' x 503 | modifyCField f = insertCField @n @t' . first f . removeCField @n @t 504 | 505 | -- | @'modifyRField' \@\"fdName\" \@n \@t \@t'@: modify the field 506 | -- @fdName@ at position @n@ in a record via a function @f :: t -> t'@ 507 | -- (changing the type of the field). 508 | -- 509 | -- === __Details__ 510 | -- 511 | -- ==== Type parameters 512 | -- 513 | -- @ 514 | -- fd :: 'Symbol' -- Field name 515 | -- n :: 'Nat' -- Field position 516 | -- t :: 'Type' -- Initial field type 517 | -- t' :: 'Type' -- Final field type 518 | -- lt :: k -> 'Type' -- Row with initial field 519 | -- lt' :: k -> 'Type' -- Row with final field 520 | -- l :: k -> 'Type' -- Row without field 521 | -- x :: k -- Ignored 522 | -- @ 523 | -- 524 | -- ==== Signature 525 | -- 526 | -- @ 527 | -- (t -> t') -- Field modification 528 | -- -> 529 | -- 'OR' lt x -- Data with field t 530 | -- -> 531 | -- 'OR' lt' x -- Data with field t' 532 | -- @ 533 | -- 534 | -- ==== Functional dependencies 535 | -- 536 | -- @ 537 | -- fd lt -> n t l 538 | -- fd lt' -> n t' l 539 | -- n lt -> fd t l 540 | -- n lt' -> fd t' l 541 | -- fd n t l -> lt 542 | -- fd n t' l -> lt' 543 | -- @ 544 | modifyRField 545 | :: forall fd n t t' lt lt' l x 546 | . ModRField fd n t t' lt lt' l 547 | => (t -> t') -> OR lt x -> OR lt' x 548 | modifyRField f = insertRField @fd @n @t' . first f . removeRField @fd @n @t 549 | 550 | -- | @'removeConstr' \@\"C\" \@n \@t@: remove the @n@-th constructor, named @C@, 551 | -- with contents isomorphic to the tuple @t@. 552 | -- 553 | -- Inverse of 'insertConstr'. 554 | -- 555 | -- === __Details__ 556 | -- 557 | -- ==== Type parameters 558 | -- 559 | -- @ 560 | -- c :: 'Symbol' -- Constructor name 561 | -- t :: 'Type' -- Tuple type to hold c's contents 562 | -- n :: 'Nat' -- Constructor position 563 | -- lc :: k -> 'Type' -- Row with constructor 564 | -- l :: k -> 'Type' -- Row without constructor 565 | -- l_t :: k -> 'Type' -- Field row of constructor c 566 | -- x :: k -- Ignored 567 | -- @ 568 | -- 569 | -- ==== Signature 570 | -- 571 | -- @ 572 | -- 'OR' lc x -- Data with constructor 573 | -- -> 574 | -- Either t ('OR' l x) -- Constructor (as a tuple) | Data without constructor 575 | -- @ 576 | -- 577 | -- ==== Functional dependencies 578 | -- 579 | -- @ 580 | -- c lc -> n l l_t 581 | -- n lc -> c l l_t 582 | -- c n l l_t -> lc 583 | -- @ 584 | -- 585 | -- Note that there is no dependency to determine @t@. 586 | removeConstr 587 | :: forall c n t lc l x 588 | . RmvConstr c n t lc l 589 | => OR lc x -> Either t (OR l x) 590 | removeConstr (OR a) = second OR (gRemoveConstr @n a) 591 | 592 | -- | A variant of 'removeConstr' that can infer the tuple type @t@ to hold 593 | -- the contents of the removed constructor. 594 | -- 595 | -- See 'removeConstr'. 596 | -- 597 | -- === __Details__ 598 | -- 599 | -- ==== Extra functional dependency 600 | -- 601 | -- @ 602 | -- l_t -> t 603 | -- @ 604 | removeConstrT 605 | :: forall c n t lc l x 606 | . RmvConstrT c n t lc l 607 | => OR lc x -> Either t (OR l x) 608 | removeConstrT = removeConstr @c @n @t 609 | 610 | -- | @'insertConstr' \@\"C\" \@n \@t@: insert a constructor @C@ at position @n@ 611 | -- with contents isomorphic to the tuple @t@. 612 | -- 613 | -- Inverse of 'removeConstr'. 614 | -- 615 | -- === __Details__ 616 | -- 617 | -- ==== Type parameters 618 | -- 619 | -- @ 620 | -- c :: 'Symbol' -- Constructor name 621 | -- t :: 'Type' -- Tuple type to hold c's contents 622 | -- n :: 'Nat' -- Constructor position 623 | -- lc :: k -> 'Type' -- Row with constructor 624 | -- l :: k -> 'Type' -- Row without constructor 625 | -- l_t :: k -> 'Type' -- Field row of constructor c 626 | -- x :: k -- Ignored 627 | -- @ 628 | -- 629 | -- ==== Signature 630 | -- 631 | -- @ 632 | -- Either t ('OR' l x) -- Constructor (as a tuple) | Data without constructor 633 | -- -> 634 | -- 'OR' lc x -- Data with constructor 635 | -- @ 636 | -- 637 | -- ==== Functional dependencies 638 | -- 639 | -- @ 640 | -- c lc -> n l l_t 641 | -- n lc -> c l l_t 642 | -- c n l l_t -> lc 643 | -- @ 644 | -- 645 | -- Note that there is no dependency to determine @t@. 646 | insertConstr 647 | :: forall c n t lc l x 648 | . InsConstr c n t lc l 649 | => Either t (OR l x) -> OR lc x 650 | insertConstr z = OR (gInsertConstr @n (second unOR z)) 651 | 652 | -- | A variant of 'insertConstr' that can infer the tuple type @t@ to hold 653 | -- the contents of the inserted constructor. 654 | -- 655 | -- See 'insertConstr'. 656 | -- 657 | -- === __Details__ 658 | -- 659 | -- ==== Extra functional dependency 660 | -- 661 | -- @ 662 | -- l_t -> t 663 | -- @ 664 | insertConstrT 665 | :: forall c n t lc l x 666 | . InsConstrT c n t lc l 667 | => Either t (OR l x) -> OR lc x 668 | insertConstrT = insertConstr @c @n @t 669 | 670 | -- | @'modifyConstr' \@\"C\" \@n \@t \@t'@: modify the @n@-th constructor, 671 | -- named @C@, with contents isomorphic to the tuple @t@, to another tuple @t'@. 672 | -- 673 | -- === __Details__ 674 | -- 675 | -- ==== Type parameters 676 | -- 677 | -- @ 678 | -- c :: 'Symbol' -- Constructor name 679 | -- t :: 'Type' -- Tuple type to hold c's initial contents 680 | -- t' :: 'Type' -- Tuple type to hold c's final contents 681 | -- n :: 'Nat' -- Constructor position 682 | -- lc :: k -> 'Type' -- Row with initial constructor 683 | -- lc' :: k -> 'Type' -- Row with final constructor 684 | -- l :: k -> 'Type' -- Row without constructor 685 | -- l_t :: k -> 'Type' -- Initial field row of constructor c 686 | -- l_t' :: k -> 'Type' -- Final field row of constructor c 687 | -- x :: k -- Ignored 688 | -- @ 689 | -- 690 | -- ==== Signature 691 | -- 692 | -- @ 693 | -- (t -> t') -- Constructor modification 694 | -- -> 695 | -- 'OR' lc x -- Data with initial constructor 696 | -- -> 697 | -- 'OR' lc' x -- Data with final constructor 698 | -- @ 699 | -- 700 | -- ==== Functional dependencies 701 | -- 702 | -- @ 703 | -- c lc -> n l l_t 704 | -- c lc' -> n l l_t' 705 | -- n lc -> c l l_t 706 | -- n lc' -> c l l_t' 707 | -- c n l l_t -> lc 708 | -- c n l l_t' -> lc' 709 | -- @ 710 | -- 711 | -- Note that there is no dependency to determine @t@ and @t'@. 712 | modifyConstr 713 | :: forall c n t t' lc lc' l x 714 | . ModConstr c n t t' lc lc' l 715 | => (t -> t') -> OR lc x -> OR lc' x 716 | modifyConstr f = insertConstr @c @n @t' . first f . removeConstr @c @n @t 717 | 718 | -- | A variant of 'modifyConstr' that can infer the tuple types @t@ and @t'@ to 719 | -- hold the contents of the inserted constructor. 720 | -- 721 | -- See 'modifyConstr'. 722 | -- 723 | -- === __Details__ 724 | -- 725 | -- ==== Extra functional dependencies 726 | -- 727 | -- @ 728 | -- l_t -> t 729 | -- l_t' -> t' 730 | -- @ 731 | modifyConstrT 732 | :: forall c n t t' lc lc' l x 733 | . ModConstrT c n t t' lc lc' l 734 | => (t -> t') -> OR lc x -> OR lc' x 735 | modifyConstrT = modifyConstr @c @n @t @t' 736 | 737 | -- 738 | 739 | -- | This constraint means that the (unnamed) field row @lt@ contains 740 | -- a field of type @t@ at position @n@, and removing it yields row @l@. 741 | type RmvCField n t lt l = 742 | ( GRemoveField n t lt l 743 | , CFieldSurgery n t lt l 744 | ) 745 | 746 | -- | This constraint means that the record field row @lt@ contains a field of 747 | -- type @t@ named @fd@ at position @n@, and removing it yields row @l@. 748 | type RmvRField fd n t lt l = 749 | ( GRemoveField n t lt l 750 | , RFieldSurgery fd n t lt l 751 | ) 752 | 753 | -- | This constraint means that inserting a field @t@ at position @n@ in the 754 | -- (unnamed) field row @l@ yields row @lt@. 755 | type InsCField n t lt l = 756 | ( GInsertField n t l lt 757 | , CFieldSurgery n t lt l 758 | ) 759 | 760 | -- | This constraint means that inserting a field @t@ named @fd@ at position 761 | -- @n@ in the record field row @l@ yields row @lt@. 762 | type InsRField fd n t lt l = 763 | ( GInsertField n t l lt 764 | , RFieldSurgery fd n t lt l 765 | ) 766 | 767 | -- | This constraint means that modifying a field @t@ to @t'@ at position @n@ 768 | -- in the (unnamed) field row @lt@ yields row @lt'@. 769 | -- @l@ is the row of fields common to @lt@ and @lt'@. 770 | type ModCField n t t' lt lt' l = 771 | ( RmvCField n t lt l 772 | , InsCField n t' lt' l 773 | ) 774 | 775 | -- | This constraint means that modifying a field @t@ named @fd@ at position @n@ 776 | -- to @t'@ in the record field row @lt@ yields row @lt'@. 777 | -- @l@ is the row of fields common to @lt@ and @lt'@. 778 | type ModRField fd n t t' lt lt' l = 779 | ( RmvRField fd n t lt l 780 | , InsRField fd n t' lt' l 781 | ) 782 | 783 | -- | This constraint means that the constructor row @lc@ contains a constructor 784 | -- named @c@ at position @n@, and removing it from @lc@ yields row @l@. 785 | -- Furthermore, constructor @c@ contains a field row @l_t@ compatible with the 786 | -- tuple type @t@. 787 | type RmvConstr c n t lc l = 788 | ( GRemoveConstr n t lc l 789 | , ConstrSurgery c n t lc l (Eval (ConstrAt n lc)) 790 | ) 791 | 792 | -- | A variant of 'RmvConstr' allowing @t@ to be inferred. 793 | type RmvConstrT c n t lc l = 794 | ( RmvConstr c n t lc l 795 | , IsTuple (Arity (Eval (ConstrAt n lc))) t 796 | ) 797 | 798 | -- | This constraint means that inserting a constructor @c@ at position @n@ 799 | -- in the constructor row @l@ yields row @lc@. 800 | -- Furthermore, constructor @c@ contains a field row @l_t@ compatible with the 801 | -- tuple type @t@. 802 | type InsConstr c n (t :: Type) lc l = 803 | ( GInsertConstr n t l lc 804 | , ConstrSurgery c n t lc l (Eval (ConstrAt n lc)) 805 | ) 806 | 807 | -- | A variant of 'InsConstr' allowing @t@ to be inferred. 808 | type InsConstrT c n t lc l = 809 | ( InsConstr c n t lc l 810 | , IsTuple (Arity (Eval (ConstrAt n lc))) t 811 | ) 812 | 813 | -- | This constraint means that the constructor row @lc@ contains a constructor 814 | -- named @c@ at position @n@ of type isomorphic to @t@, and modifying it to 815 | -- @t'@ yields row @lc'@. 816 | type ModConstr c n t t' lc lc' l = 817 | ( RmvConstr c n t lc l 818 | , InsConstr c n t' lc' l 819 | ) 820 | 821 | -- | A variant of 'ModConstr' allowing @t@ and @t'@ to be inferred. 822 | type ModConstrT c n t t' lc lc' l = 823 | ( ModConstr c n t t' lc lc' l 824 | , IsTuple (Arity (Eval (ConstrAt n lc ))) t 825 | , IsTuple (Arity (Eval (ConstrAt n lc'))) t' 826 | ) 827 | 828 | type FieldSurgery n t lt l = 829 | ( t ~ Eval (FieldTypeAt n lt) 830 | , l ~ Eval (RemoveField n t lt) 831 | ) 832 | 833 | type CFieldSurgery n t lt l = 834 | ( lt ~ Eval (InsertField n 'Nothing t l) 835 | , FieldSurgery n t lt l 836 | ) 837 | 838 | type RFieldSurgery fd n t lt l = 839 | ( n ~ Eval (FieldIndex fd lt) 840 | , lt ~ Eval (InsertField n ('Just fd) t l) 841 | , FieldSurgery n t lt l 842 | ) 843 | 844 | type ConstrSurgery c n t lc l l_t = 845 | ( Generic t 846 | , MatchFields (Linearize (UnM1 (Rep t))) l_t 847 | , n ~ Eval (ConstrIndex c lc) 848 | , c ~ MetaConsName (MetaOf l_t) 849 | , lc ~ Eval (InsertUConstrAtL n l_t l) 850 | , l ~ Eval (RemoveUConstrAt_ n lc) 851 | ) 852 | 853 | -- 854 | 855 | type family Linearize (f :: k -> Type) :: k -> Type 856 | type instance Linearize (M1 D m f) = M1 D m (LinearizeSum f V1) 857 | type instance Linearize (M1 C m f) = M1 C m (LinearizeProduct f U1) 858 | 859 | type family LinearizeSum (f :: k -> Type) (tl :: k -> Type) :: k -> Type 860 | type instance LinearizeSum V1 tl = tl 861 | type instance LinearizeSum (f :+: g) tl = LinearizeSum f (LinearizeSum g tl) 862 | type instance LinearizeSum (M1 c m f) tl = M1 c m (LinearizeProduct f U1) :+: tl 863 | 864 | type family LinearizeProduct (f :: k -> Type) (tl :: k -> Type) :: k -> Type 865 | type instance LinearizeProduct U1 tl = tl 866 | type instance LinearizeProduct (f :*: g) tl = LinearizeProduct f (LinearizeProduct g tl) 867 | type instance LinearizeProduct (M1 s m f) tl = M1 s m f :*: tl 868 | 869 | class GLinearize f where 870 | gLinearize :: f x -> Linearize f x 871 | 872 | instance GLinearizeSum f V1 => GLinearize (M1 D m f) where 873 | gLinearize (M1 a) = M1 (gLinearizeSum @_ @V1 (Left a)) 874 | 875 | instance GLinearizeProduct f U1 => GLinearize (M1 C m f) where 876 | gLinearize (M1 a) = M1 (gLinearizeProduct a U1) 877 | 878 | class GLinearizeSum f tl where 879 | gLinearizeSum :: Either (f x) (tl x) -> LinearizeSum f tl x 880 | 881 | instance GLinearizeSum V1 tl where 882 | gLinearizeSum (Left v) = absurd1 v 883 | gLinearizeSum (Right c) = c 884 | 885 | instance (GLinearizeSum g tl, GLinearizeSum f (LinearizeSum g tl)) 886 | => GLinearizeSum (f :+: g) tl where 887 | gLinearizeSum (Left (L1 a)) = gLinearizeSum @_ @(LinearizeSum g tl) (Left a) 888 | gLinearizeSum (Left (R1 b)) = gLinearizeSum @f (Right (gLinearizeSum @g @tl (Left b))) 889 | gLinearizeSum (Right c) = gLinearizeSum @f (Right (gLinearizeSum @g (Right c))) 890 | 891 | instance GLinearizeProduct f U1 => GLinearizeSum (M1 c m f) tl where 892 | gLinearizeSum (Left (M1 a)) = L1 (M1 (gLinearizeProduct a U1)) 893 | gLinearizeSum (Right c) = R1 c 894 | 895 | class GLinearizeProduct f tl where 896 | gLinearizeProduct :: f x -> tl x -> LinearizeProduct f tl x 897 | 898 | instance GLinearizeProduct U1 tl where 899 | gLinearizeProduct _ = id 900 | 901 | instance (GLinearizeProduct g tl, GLinearizeProduct f (LinearizeProduct g tl)) 902 | => GLinearizeProduct (f :*: g) tl where 903 | gLinearizeProduct (a :*: b) = gLinearizeProduct a . gLinearizeProduct b 904 | 905 | instance GLinearizeProduct (M1 s m f) tl where 906 | gLinearizeProduct = (:*:) 907 | 908 | class GArborify f where 909 | gArborify :: Linearize f x -> f x 910 | 911 | instance GArborifySum f V1 => GArborify (M1 D m f) where 912 | gArborify (M1 a) = case gArborifySum @_ @V1 a of 913 | Left a' -> M1 a' 914 | Right v -> absurd1 v 915 | 916 | instance GArborifyProduct f U1 => GArborify (M1 C m f) where 917 | gArborify (M1 a) = M1 (fst (gArborifyProduct @_ @U1 a)) 918 | 919 | class GArborifySum f tl where 920 | gArborifySum :: LinearizeSum f tl x -> Either (f x) (tl x) 921 | 922 | instance GArborifySum V1 tl where 923 | gArborifySum = Right 924 | 925 | instance (GArborifySum g tl, GArborifySum f (LinearizeSum g tl)) 926 | => GArborifySum (f :+: g) tl where 927 | gArborifySum = first R1 . gArborifySum <=< first L1 . gArborifySum 928 | 929 | instance GArborifyProduct f U1 => GArborifySum (M1 c m f) tl where 930 | gArborifySum (L1 (M1 a)) = Left (M1 (fst (gArborifyProduct @_ @U1 a))) 931 | gArborifySum (R1 c) = Right c 932 | 933 | class GArborifyProduct f tl where 934 | gArborifyProduct :: LinearizeProduct f tl x -> (f x, tl x) 935 | 936 | instance GArborifyProduct U1 tl where 937 | gArborifyProduct c = (U1, c) 938 | 939 | instance (GArborifyProduct g tl, GArborifyProduct f (LinearizeProduct g tl)) 940 | => GArborifyProduct (f :*: g) tl where 941 | gArborifyProduct abc = (a :*: b, c) where 942 | (a, bc) = gArborifyProduct abc 943 | (b, c) = gArborifyProduct bc 944 | 945 | instance GArborifyProduct (M1 s m f) tl where 946 | gArborifyProduct (a :*: c) = (a, c) 947 | 948 | type family Arborify (f :: k -> Type) :: k -> Type 949 | type instance Arborify (M1 D m f) = M1 D m (Eval (ArborifySum (CoArity f) f)) 950 | type instance Arborify (M1 C m f) = M1 C m (Eval (ArborifyProduct (Arity f) f)) 951 | 952 | data ArborifySum (n :: Nat) (f :: k -> Type) :: Exp (k -> Type) 953 | type instance Eval (ArborifySum n V1) = V1 954 | type instance Eval (ArborifySum n (f :+: g)) = 955 | Eval (If (n == 1) 956 | (ArborifyProduct (Arity f) f) 957 | (Arborify' ArborifySum (:+:) n (Div n 2) f g)) 958 | 959 | data ArborifyProduct (n :: Nat) (f :: k -> Type) :: Exp (k -> Type) 960 | type instance Eval (ArborifyProduct n (M1 C s f)) = M1 C s (Eval (ArborifyProduct n f)) 961 | type instance Eval (ArborifyProduct n U1) = U1 962 | type instance Eval (ArborifyProduct n (f :*: g)) = 963 | Eval (If (n == 1) 964 | (Pure f) 965 | (Arborify' ArborifyProduct (:*:) n (Div n 2) f g)) 966 | 967 | -- let nDiv2 = Div n 2 in ... 968 | type Arborify' arb op n nDiv2 f g = 969 | ( Uncurry (Pure2 op) 970 | <=< Bimap (arb nDiv2) (arb (n-nDiv2)) 971 | <=< SplitAt nDiv2 972 | ) (op f g) 973 | 974 | type family Lazify (f :: k -> Type) :: k -> Type 975 | type instance Lazify (M1 i m f) = M1 i (LazifyMeta m) (Lazify f) 976 | type instance Lazify (f :*: g) = Lazify f :*: Lazify g 977 | type instance Lazify (f :+: g) = Lazify f :+: Lazify g 978 | type instance Lazify (K1 i c) = K1 i c 979 | type instance Lazify U1 = U1 980 | type instance Lazify V1 = V1 981 | 982 | type family LazifyMeta (m :: Meta) :: Meta 983 | type instance LazifyMeta ('MetaData n m p nt) = 'MetaData n m p nt 984 | type instance LazifyMeta ('MetaCons n f s) = 'MetaCons n f s 985 | type instance LazifyMeta ('MetaSel mn su ss ds) 986 | = 'MetaSel mn 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy 987 | 988 | data SplitAt :: Nat -> (k -> Type) -> Exp (k -> Type, k -> Type) 989 | type instance Eval (SplitAt n (f :+: g)) = 990 | Eval (If (n == 0) 991 | (Pure '(V1, f :+: g)) 992 | (Bimap (Pure2 (:+:) f) Pure =<< SplitAt (n-1) g)) 993 | type instance Eval (SplitAt n (f :*: g)) = 994 | Eval (If (n == 0) 995 | (Pure '(U1, f :*: g)) 996 | (Bimap (Pure2 (:*:) f) Pure =<< SplitAt (n-1) g)) 997 | 998 | -- * Surgeries 999 | 1000 | -- | Kind of surgeries: operations on generic representations of types. 1001 | -- 1002 | -- Treat this as an abstract kind (don't pay attention to its definition). 1003 | -- 1004 | -- === __Implementation details__ 1005 | -- 1006 | -- The name @Surgery@ got taken first by generic-data. 1007 | -- 1008 | -- @k@ is the kind of the extra parameter reserved for @Generic1@, 1009 | -- which we just don't use. 1010 | type MajorSurgery k = MajorSurgery_ k 1011 | 1012 | -- Whenever you see 1013 | -- data ... :: MajorSurgery k 1014 | -- mentally expand it to 1015 | -- data ... (f :: k -> Type) :: Exp (k -> Type) 1016 | 1017 | -- | @Operate f s@. Apply a surgery @s@ to a generic representation @f@ 1018 | -- (e.g., @f = 'Rep' a@ for some 'Generic' type @a@). 1019 | -- 1020 | -- The first argument is the generic representation; 1021 | -- the second argument is the surgery, which typically has the more complex 1022 | -- syntax, which is why this reverse application order was chosen. 1023 | type Operate (f :: k -> Type) (s :: MajorSurgery k) = Operate_ f s 1024 | 1025 | -- | Internal definition of 'MajorSurgery'. 1026 | type MajorSurgery_ k = (k -> Type) -> Exp (k -> Type) 1027 | 1028 | -- | Internal definition of 'Operate'. 1029 | type Operate_ (f :: k -> Type) (s :: MajorSurgery k) = Arborify (OperateL (Linearize f) s) 1030 | 1031 | -- | Apply a surgery @s@ to a linearized generic representation @l@. 1032 | type OperateL (l :: k -> Type) (s :: MajorSurgery k) = Eval (s l) 1033 | 1034 | -- | Composition of surgeries (left-to-right). 1035 | -- 1036 | -- === Note 1037 | -- 1038 | -- Surgeries work on normalized representations, so 'Operate', which applies 1039 | -- a surgery to a generic representation, inserts normalization steps before 1040 | -- and after the surgery. This means that @'Operate' r (s1 ':>>' s2)@ is not quite 1041 | -- the same as @'Operate' ('Operate' r s1) s2@. Instead, the latter is 1042 | -- equivalent to @'Operate' r (s1 ':>>' 'Suture' ':>>' s2)@, where 'Suture' 1043 | -- inserts some intermediate normalization steps. 1044 | data (:>>) :: MajorSurgery k -> MajorSurgery k -> MajorSurgery k 1045 | type instance Eval ((s :>> t) l) = Eval (t (Eval (s l))) 1046 | -- Note: This is a specialization of @(>=>)@ in Fcf. 1047 | 1048 | type instance PerformL l (s :>> t) = (PerformL l s, PerformL (Eval (s l)) t) 1049 | 1050 | infixl 1 :>> 1051 | 1052 | -- | The identity surgery: doesn't do anything. 1053 | data IdSurgery :: MajorSurgery k 1054 | type instance Eval (IdSurgery l) = l 1055 | type instance PerformL l IdSurgery = () 1056 | 1057 | -- | Use this if a patient ever needs to go out and back into the operating 1058 | -- room, when it's not just to undo the surgery up to that point. 1059 | data Suture :: MajorSurgery k 1060 | type instance Eval (Suture l) = Linearize (Arborify l) 1061 | 1062 | -- Now we can compose surgeries into complex ones, we can relate the input and 1063 | -- output of a whole surgery. 1064 | -- 1065 | -- We still need to augment this with run-time information to 'Perform' the 1066 | -- surgery at the term level. 1067 | -- 1068 | -- We might also need to interpret surgeries backwards (this is not entirely 1069 | -- symmetrical, a "removal" contains less information than an "insertion"). 1070 | 1071 | type family PerformL (l :: k -> Type) (s :: MajorSurgery k) :: Constraint 1072 | 1073 | -- | A constraint @Perform r s@ means that the surgery @s@ can be applied to 1074 | -- the generic representation @r@. 1075 | class Perform_ r s => Perform (r :: k -> Type) (s :: MajorSurgery k) 1076 | instance Perform_ r s => Perform (r :: k -> Type) (s :: MajorSurgery k) 1077 | 1078 | type Perform_ (r :: k -> Type) (s :: MajorSurgery k) = 1079 | ( PerformL (Linearize r) s 1080 | , ToOR r (Linearize r) 1081 | , FromOR (Operate r s) (OperateL (Linearize r) s) 1082 | ) 1083 | 1084 | data FieldTypeAt (n :: Nat) (f :: k -> Type) :: Exp Type 1085 | type instance Eval (FieldTypeAt n (M1 i c f)) = Eval (FieldTypeAt n f) 1086 | type instance Eval (FieldTypeAt n (f :+: V1)) = Eval (FieldTypeAt n f) 1087 | type instance Eval (FieldTypeAt n (f :*: g)) = 1088 | Eval (If (n == 0) (Pure (FieldTypeOf f)) (FieldTypeAt (n-1) g)) 1089 | 1090 | type family FieldTypeOf (f :: k -> Type) :: Type 1091 | type instance FieldTypeOf (M1 s m (K1 i a)) = a 1092 | 1093 | data FieldNameAt (n :: Nat) (f :: k -> Type) :: Exp (Maybe Symbol) 1094 | type instance Eval (FieldNameAt n (M1 i c f)) = Eval (FieldNameAt n f) 1095 | type instance Eval (FieldNameAt n (f :+: V1)) = Eval (FieldNameAt n f) 1096 | type instance Eval (FieldNameAt n (f :*: g)) = 1097 | Eval (If (n == 0) (FieldNameOf f) (FieldNameAt (n-1) g)) 1098 | 1099 | data FieldNameOf (f :: k -> Type) :: Exp (Maybe Symbol) 1100 | type instance Eval (FieldNameOf (M1 S ('MetaSel mn _ _ _) _)) = mn 1101 | 1102 | data RemoveField (n :: Nat) (a :: Type) :: MajorSurgery k 1103 | type instance Eval (RemoveField n a f) = Eval (RemoveField_ n f) 1104 | 1105 | -- | Like 'RemoveField' but without the explicit field type. 1106 | data RemoveField_ (n :: Nat) :: MajorSurgery k 1107 | type instance Eval (RemoveField_ n (M1 i m f)) = M1 i m (Eval (RemoveField_ n f)) 1108 | type instance Eval (RemoveField_ n (f :+: V1)) = Eval (RemoveField_ n f) :+: V1 1109 | type instance Eval (RemoveField_ n (f :*: g)) = 1110 | Eval (If (n == 0) (Pure g) ((:*:) f <$> RemoveField_ (n-1) g)) 1111 | 1112 | type instance PerformL lt (RemoveField n a) = PerformL lt (RemoveFieldAt n (FieldNameAt n @@ lt) a) 1113 | 1114 | data RemoveFieldAt (n :: Nat) (fd :: Maybe Symbol) (a :: Type) :: MajorSurgery k 1115 | type instance PerformL lt (RemoveFieldAt n fd a) = 1116 | PerformLRemoveFieldAt n fd a lt (Eval (RemoveField_ n lt)) 1117 | 1118 | type PerformLRemoveFieldAt_ n fd t lt l = 1119 | ( GRemoveField n t lt l 1120 | , t ~ Eval (FieldTypeAt n lt) 1121 | , lt ~ Eval (InsertField n fd t l) 1122 | ) 1123 | 1124 | class PerformLRemoveFieldAt_ n fd t lt l => PerformLRemoveFieldAt n fd t lt l 1125 | instance PerformLRemoveFieldAt_ n fd t lt l => PerformLRemoveFieldAt n fd t lt l 1126 | 1127 | data RemoveRField (fd :: Symbol) (a :: Type) :: MajorSurgery k 1128 | type instance Eval (RemoveRField fd a f) = Eval (RemoveField_ (Eval (FieldIndex fd f)) f) 1129 | 1130 | type instance PerformL lt (RemoveRField fd a) = 1131 | PerformL lt (RemoveFieldAt (FieldIndex fd @@ lt) ('Just fd) a) 1132 | 1133 | type DefaultMetaSel field 1134 | = 'MetaSel field 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy 1135 | 1136 | data InsertField (n :: Nat) (fd :: Maybe Symbol) (t :: Type) :: MajorSurgery k 1137 | type instance Eval (InsertField n fd t (M1 D m f)) = M1 D m (Eval (InsertField n fd t f)) 1138 | type instance Eval (InsertField n fd t (M1 C m f)) = M1 C m (Eval (InsertField n fd t f)) 1139 | type instance Eval (InsertField n fd t (f :+: V1)) = Eval (InsertField n fd t f) :+: V1 1140 | type instance Eval (InsertField n fd t (f :*: g)) = 1141 | Eval (If (n == 0) 1142 | (Pure (M1 S (DefaultMetaSel fd) (K1 R t) :*: (f :*: g))) 1143 | ((:*:) f <$> InsertField (n-1) fd t g)) 1144 | type instance Eval (InsertField 0 fd t U1) = M1 S (DefaultMetaSel fd) (K1 R t) :*: U1 1145 | 1146 | type instance PerformL l (InsertField n fd t) = PerformLInsert n fd t l (Eval (InsertField n fd t l)) 1147 | 1148 | type PerformLInsert_ n fd t l tl = 1149 | ( GInsertField n t l tl 1150 | , l ~ Eval (RemoveField_ n tl) 1151 | , tl ~ Eval (InsertField n fd t l) 1152 | , CheckField n fd tl 1153 | , t ~ Eval (FieldTypeAt n tl) 1154 | ) 1155 | 1156 | class PerformLInsert_ n fd t l tl => PerformLInsert n fd t l tl 1157 | instance PerformLInsert_ n fd t l tl => PerformLInsert n fd t l tl 1158 | 1159 | type family CheckField (n :: Nat) (fd :: Maybe Symbol) (tl :: k -> Type) :: Constraint where 1160 | CheckField n 'Nothing tl = () 1161 | CheckField n ('Just fd) tl = (n ~ Eval (FieldIndex fd tl)) 1162 | 1163 | data Succ :: Nat -> Exp Nat 1164 | type instance Eval (Succ n) = 1 + n 1165 | 1166 | -- | Position of a record field 1167 | data FieldIndex (field :: Symbol) (f :: k -> Type) :: Exp Nat 1168 | type instance Eval (FieldIndex field (M1 D m f)) = Eval (FieldIndex field f) 1169 | type instance Eval (FieldIndex field (M1 C m f)) = Eval (FieldIndex field f) 1170 | type instance Eval (FieldIndex field (f :+: V1)) = Eval (FieldIndex field f) 1171 | type instance Eval (FieldIndex field (M1 S ('MetaSel ('Just field') su ss ds) f :*: g)) 1172 | = Eval (If (field == field') (Pure 0) (Succ =<< FieldIndex field g)) 1173 | 1174 | -- | Number of fields of a single constructor 1175 | type family Arity (f :: k -> Type) :: Nat 1176 | type instance Arity (M1 d m f) = Arity f 1177 | type instance Arity (f :+: V1) = Arity f 1178 | type instance Arity (f :*: g) = Arity f + Arity g 1179 | type instance Arity (K1 i c) = 1 1180 | type instance Arity U1 = 0 1181 | 1182 | -- | Number of constructors of a data type 1183 | type family CoArity (f :: k -> Type) :: Nat 1184 | type instance CoArity (M1 D m f) = CoArity f 1185 | type instance CoArity (M1 C m f) = 1 1186 | type instance CoArity V1 = 0 1187 | type instance CoArity (f :+: g) = CoArity f + CoArity g 1188 | 1189 | class GRemoveField (n :: Nat) a f g where 1190 | gRemoveField :: f x -> (a, g x) 1191 | 1192 | instance GRemoveField n a f g => GRemoveField n a (M1 i c f) (M1 i c g) where 1193 | gRemoveField (M1 a) = M1 <$> gRemoveField @n a 1194 | 1195 | -- Only single-constructor types are supported for the moment. 1196 | instance GRemoveField n a f g => GRemoveField n a (f :+: V1) (g :+: V1) where 1197 | gRemoveField (L1 a) = L1 <$> gRemoveField @n a 1198 | gRemoveField (R1 v) = absurd1 v 1199 | 1200 | instance GRemoveField 0 a (M1 s m (K1 i a) :*: f) f where 1201 | gRemoveField (M1 (K1 t) :*: b) = (t, b) 1202 | 1203 | instance {-# OVERLAPPABLE #-} 1204 | ( (n == 0) ~ 'False 1205 | , f0g ~ (f0 :*: g) 1206 | , GRemoveField (n-1) a f g 1207 | ) => GRemoveField n a (f0 :*: f) f0g where 1208 | gRemoveField (a :*: b) = (a :*:) <$> gRemoveField @(n-1) b 1209 | 1210 | class GInsertField (n :: Nat) a f g where 1211 | gInsertField :: a -> f x -> g x 1212 | 1213 | instance GInsertField n a f g => GInsertField n a (M1 i c f) (M1 i c g) where 1214 | gInsertField t (M1 a) = M1 (gInsertField @n t a) 1215 | 1216 | instance GInsertField n a f g => GInsertField n a (f :+: V1) (g :+: V1) where 1217 | gInsertField t (L1 a) = L1 (gInsertField @n t a) 1218 | gInsertField _ (R1 v) = absurd1 v 1219 | 1220 | instance GInsertField 0 a f (M1 s m (K1 i a) :*: f) where 1221 | gInsertField t ab = M1 (K1 t) :*: ab 1222 | 1223 | instance {-# OVERLAPPABLE #-} 1224 | ( (n == 0) ~ 'False 1225 | , f0f ~ (f0 :*: f) 1226 | , GInsertField (n-1) a f g 1227 | ) => GInsertField n a f0f (f0 :*: g) where 1228 | gInsertField t (a :*: b) = a :*: gInsertField @(n-1) t b 1229 | 1230 | data ConstrAt (n :: Nat) (f :: k -> Type) :: Exp (k -> Type) 1231 | type instance Eval (ConstrAt n (M1 i m f)) = Eval (ConstrAt n f) 1232 | type instance Eval (ConstrAt n (f :+: g)) = 1233 | Eval (If (n == 0) (Pure f) (ConstrAt (n-1) g)) 1234 | 1235 | data RemoveConstr (c :: Symbol) (t :: Type) :: MajorSurgery k 1236 | type instance Eval (RemoveConstr c t l) = Eval (RemoveConstrAt c (ConstrIndex c @@ l) t l) 1237 | 1238 | type instance PerformL lc (RemoveConstr c t) = PerformLRemoveConstr lc c (ConstrIndex c @@ lc) t 1239 | 1240 | type PerformLRemoveConstr lc c n (t :: Type) = 1241 | PerformLRemoveConstrAt c n t (Eval (ConstrAt n lc)) lc (Eval (RemoveUConstrAt_ n lc)) 1242 | 1243 | type PerformLRemoveConstrAt_ c n t l_t lc l = 1244 | ( GRemoveConstr n t lc l 1245 | -- , l_t ~ Linearize (Arborify l_t) 1246 | , c ~ MetaConsName (MetaOf l_t) 1247 | , lc ~ Eval (InsertUConstrAtL n l_t l) 1248 | , MatchFields (Linearize (UnM1 (Rep t))) l_t 1249 | , Arity l_t ~ Arity (Linearize (UnM1 (Rep t))) 1250 | ) 1251 | 1252 | class PerformLRemoveConstrAt_ c n t l_t lc l => PerformLRemoveConstrAt c n (t :: Type) l_t lc l 1253 | instance PerformLRemoveConstrAt_ c n t l_t lc l => PerformLRemoveConstrAt c n (t :: Type) l_t lc l 1254 | 1255 | data RemoveConstrAt (c :: Symbol) (n :: Nat) (t :: Type) :: MajorSurgery k 1256 | type instance Eval (RemoveConstrAt _ n t l) = Eval (RemoveUConstrAt n t l) 1257 | 1258 | data RemoveUConstrAt (n :: Nat) (t :: Type) :: MajorSurgery k 1259 | type instance Eval (RemoveUConstrAt n _ l) = Eval (RemoveUConstrAt_ n l) 1260 | 1261 | -- | Like 'RemoveConstr', but without the explicit constructor type. 1262 | data RemoveUConstrAt_ (n :: Nat) :: MajorSurgery k 1263 | type instance Eval (RemoveUConstrAt_ n (M1 i m f)) = M1 i m (Eval (RemoveUConstrAt_ n f)) 1264 | type instance Eval (RemoveUConstrAt_ n (f :+: g)) = 1265 | Eval (If (n == 0) (Pure g) ((:+:) f <$> RemoveUConstrAt_ (n-1) g)) 1266 | 1267 | -- | This is polymorphic to allow different ways of specifying the inserted constructor. 1268 | -- 1269 | -- If @sym@ (the kind of the constructor name @c@) is: 1270 | -- 1271 | -- - 'Symbol': treat it like a regular prefix constructor. 1272 | -- - TODO Infix constructors and their fixities. 1273 | -- 1274 | -- @t@ must be a single-constructor type, then we reuse its generic 1275 | -- representation for the new constructor, only replacing its constructor name 1276 | -- with @c@. 1277 | data InsertConstrAt (c :: sym) (n :: Nat) (t :: ty) :: MajorSurgery k 1278 | type instance Eval (InsertConstrAt c n t l) = Eval (InsertUConstrAtL n (ConGraft c t) l) 1279 | 1280 | type family ConGraft (c :: sym) (t :: ty) :: k -> Type 1281 | type instance ConGraft c (t :: Type) = RenameCon c (Linearize (UnM1 (Rep t))) 1282 | 1283 | type family RenameCon (c :: sym) (t :: k -> Type) :: k -> Type 1284 | type instance RenameCon c (M1 C m f) = M1 C (RenameMeta c m) f 1285 | 1286 | type family RenameMeta (c :: sym) (m :: Meta) :: Meta 1287 | type instance RenameMeta (s :: Symbol) ('MetaCons _ _ r) = 'MetaCons s 'PrefixI r 1288 | 1289 | type instance PerformL l (InsertConstrAt c n t) = PerformLInsertConstrAt0 l c n t 1290 | 1291 | type PerformLInsertConstrAt0 l c n t = 1292 | PerformLInsertConstrAt c n t (ConGraft c t) l (Eval (InsertUConstrAtL n (ConGraft c t) l)) 1293 | 1294 | type PerformLInsertConstrAt_ c n t l_t l lc = 1295 | ( GInsertConstr n t l lc 1296 | , c ~ MetaConsName (MetaOf l_t) 1297 | , n ~ (ConstrIndex c @@ lc) 1298 | , l_t ~ (ConstrAt n @@ lc) 1299 | , l ~ Eval (RemoveUConstrAt_ n lc) 1300 | , MatchFields (Linearize (UnM1 (Rep t))) l_t 1301 | ) 1302 | 1303 | class PerformLInsertConstrAt_ c n t l_t l lc => PerformLInsertConstrAt c n t l_t l lc 1304 | instance PerformLInsertConstrAt_ c n t l_t l lc => PerformLInsertConstrAt c n t l_t l lc 1305 | 1306 | data InsertUConstrAt (n :: Nat) (t :: Type) :: MajorSurgery k 1307 | type instance Eval (InsertUConstrAt n t l) = Eval (InsertUConstrAtL n (Linearize (UnM1 (Rep t))) l) 1308 | 1309 | data InsertUConstrAtL (n :: Nat) (t :: k -> Type) :: MajorSurgery k 1310 | type instance Eval (InsertUConstrAtL n t (M1 i m f)) = M1 i m (Eval (InsertUConstrAtL n t f)) 1311 | type instance Eval (InsertUConstrAtL n t (f :+: g)) = 1312 | Eval (If (n == 0) (Pure (t :+: (f :+: g))) ((:+:) f <$> InsertUConstrAtL (n-1) t g)) 1313 | type instance Eval (InsertUConstrAtL 0 t V1) = t :+: V1 1314 | 1315 | data ConstrIndex (con :: Symbol) (f :: k -> Type) :: Exp Nat 1316 | type instance Eval (ConstrIndex con (M1 D m f)) = Eval (ConstrIndex con f) 1317 | type instance Eval (ConstrIndex con (M1 C ('MetaCons con' fx s) f :+: g)) = 1318 | Eval (If (con == con') (Pure 0) (Succ =<< ConstrIndex con g)) 1319 | 1320 | class GRemoveConstr (n :: Nat) (t :: Type) f g where 1321 | gRemoveConstr :: f x -> Either t (g x) 1322 | 1323 | instance GRemoveConstr n t f g => GRemoveConstr n t (M1 i c f) (M1 i c g) where 1324 | gRemoveConstr (M1 a) = M1 <$> gRemoveConstr @n a 1325 | 1326 | type ConstrArborify t l = 1327 | ( Generic t 1328 | , Coercible (UnM1 (Rep t)) (Rep t) 1329 | , GArborify (UnM1 (Rep t)) 1330 | , Coercible l (Linearize (UnM1 (Rep t))) 1331 | ) 1332 | 1333 | constrArborify' :: forall t l x. ConstrArborify t l => l x -> t 1334 | constrArborify' = to @t @x . coerce (gArborify @(UnM1 (Rep t)) @x) 1335 | 1336 | instance ConstrArborify t l => GRemoveConstr 0 t (l :+: f) f where 1337 | gRemoveConstr (L1 a) = Left (constrArborify' a) 1338 | gRemoveConstr (R1 b) = Right b 1339 | 1340 | instance {-# OVERLAPPABLE #-} 1341 | ( GRemoveConstr (n-1) t f g, (n == 0) ~ 'False 1342 | , f0g ~ (f0 :+: g) 1343 | ) => GRemoveConstr n t (f0 :+: f) f0g where 1344 | gRemoveConstr (L1 a) = Right (L1 a) 1345 | gRemoveConstr (R1 b) = R1 <$> gRemoveConstr @(n-1) b 1346 | 1347 | class GInsertConstr (n :: Nat) (t :: Type) f g where 1348 | gInsertConstr :: Either t (f x) -> g x 1349 | 1350 | instance GInsertConstr n t f g => GInsertConstr n t (M1 i c f) (M1 i c g) where 1351 | gInsertConstr = M1 . gInsertConstr @n . fmap unM1 1352 | 1353 | type ConstrLinearize t l = 1354 | ( Generic t 1355 | , Coercible (Rep t) (UnM1 (Rep t)) 1356 | , GLinearize (UnM1 (Rep t)) 1357 | , Coercible (Linearize (UnM1 (Rep t))) l 1358 | ) 1359 | 1360 | constrLinearize' :: forall t l x. ConstrLinearize t l => t -> l x 1361 | constrLinearize' = coerce (gLinearize @(UnM1 (Rep t)) @x) . from @t @x 1362 | 1363 | instance ConstrLinearize t l => GInsertConstr 0 t f (l :+: f) where 1364 | gInsertConstr (Left a) = L1 (constrLinearize' a) 1365 | gInsertConstr (Right b) = R1 b 1366 | 1367 | instance {-# OVERLAPPABLE #-} 1368 | ( GInsertConstr (n-1) t f g, (n == 0) ~ 'False 1369 | , f0f ~ (f0 :+: f) 1370 | ) => GInsertConstr n t f0f (f0 :+: g) where 1371 | gInsertConstr (Left a) = R1 (gInsertConstr @(n-1) @t @f @g (Left a)) 1372 | gInsertConstr (Right (L1 a)) = L1 a 1373 | gInsertConstr (Right (R1 b)) = R1 (gInsertConstr @(n-1) @t @f @g (Right b)) 1374 | 1375 | -- | Equate two generic representations, but ignoring constructor and field metadata. 1376 | class MatchFields (f :: k -> Type) (g :: k -> Type) 1377 | instance (g ~ M1 D c g', MatchFields f' g') => MatchFields (M1 D c f') g 1378 | instance (g ~ M1 C ('MetaCons _x _y _z) g', MatchFields f' g') => MatchFields (M1 C c f') g 1379 | instance (g ~ M1 S ('MetaSel _w _x _y _z) g', MatchFields f' g') => MatchFields (M1 S c f') g 1380 | instance (g ~ (g1 :+: g2), MatchFields f1 g1, MatchFields f2 g2) => MatchFields (f1 :+: f2) g 1381 | instance (g ~ (g1 :*: g2), MatchFields f1 g1, MatchFields f2 g2) => MatchFields (f1 :*: f2) g 1382 | instance (g ~ K1 i a) => MatchFields (K1 i a) g 1383 | instance (g ~ U1) => MatchFields U1 g 1384 | instance (g ~ V1) => MatchFields V1 g 1385 | 1386 | class IsTuple (n :: Nat) (t :: k) 1387 | instance (t ~ ()) => IsTuple 0 t 1388 | instance (t ~ Identity a) => IsTuple 1 t 1389 | instance (t ~ (a, b)) => IsTuple 2 t 1390 | instance (t ~ (a, b, c)) => IsTuple 3 t 1391 | instance (t ~ (a, b, c, d)) => IsTuple 4 t 1392 | instance (t ~ (a, b, c, d, e)) => IsTuple 5 t 1393 | instance (t ~ (a, b, c, d, e, f)) => IsTuple 6 t 1394 | instance (t ~ (a, b, c, d, e, f, g)) => IsTuple 7 t 1395 | -------------------------------------------------------------------------------- /stack-default.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.31 2 | packages: 3 | - '.' 4 | - 'examples/' 5 | extra-deps: 6 | - 'ap-normalize-0.1.0.0' 7 | - 'generic-functor-0.2.0.0' 8 | -------------------------------------------------------------------------------- /test/surgery.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | CPP, 3 | DataKinds, 4 | DeriveGeneric, 5 | FlexibleContexts, 6 | TypeApplications, 7 | TypeOperators #-} 8 | 9 | {-# OPTIONS_GHC -Wno-unused-top-binds #-} 10 | 11 | -- Many of these tests are more about ensuring things typecheck than really 12 | -- comparing their runtime results. 13 | 14 | #if __GLASGOW_HASKELL__ >= 802 15 | import Data.Bifunctor (second) 16 | #endif 17 | import Data.Functor.Identity (Identity(..)) 18 | import GHC.Generics hiding (R) 19 | import Test.Tasty 20 | import Test.Tasty.HUnit 21 | 22 | import Generic.Data.Surgery 23 | 24 | import Generic.Data.Types (Data(Data)) 25 | 26 | data T = A | B Int | C Int Int Int Int Int deriving (Eq, Show, Generic) 27 | 28 | data P = P Int Int Int deriving (Eq, Show, Generic) 29 | data R = R { u, v, w :: Int } deriving (Eq, Show, Generic) 30 | data S = S { u' :: Int, v' :: !Int, w' :: {-# UNPACK #-} !Int } deriving (Eq, Show, Generic) 31 | 32 | main :: IO () 33 | main = defaultMain test 34 | 35 | show' :: Show (f ()) => f () -> String 36 | show' = show 37 | 38 | unit :: f () -> f () 39 | unit = id 40 | 41 | test :: TestTree 42 | test = testGroup "surgery" 43 | [ testRoundtrip 44 | , testConsumer 45 | , testProducer 46 | ] 47 | 48 | rt :: (Eq a, Show a) => a -> (a -> a) -> Assertion 49 | rt x f = x @?= f x 50 | 51 | testRoundtrip :: TestTree 52 | testRoundtrip = testGroup "roundtrip" 53 | [ testCase "to-from" $ rt (C 1 2 3 4 5) (fromOR . toOR) 54 | , testCase "CField-rmv-ins" $ 55 | rt (P 1 2 3) (fromOR . insertCField @1 . removeCField @1 . toOR) 56 | , testCase "CField-ins-rmv" $ 57 | rt ((), P 1 2 3) (fmap fromOR . removeCField @1 . insertCField @1 . fmap toOR) 58 | , testCase "RField-rmv-ins" $ 59 | rt (R 1 2 3) (fromOR . insertRField @"u" . removeRField @"u" . toOR) 60 | , testCase "RField-ins-rmv" $ 61 | rt ((), R 1 2 3) (fmap fromOR . removeRField @"t" . insertRField @"t" @1 . fmap toOR) 62 | , testCase "SField-rmv-ins" $ 63 | rt (S 1 2 3) (fromORLazy . insertRField @"u'" . removeRField @"u'" . toORLazy) 64 | , testCase "SField-ins-rmv" $ 65 | rt ((), S 1 2 3) (fmap fromORLazy . removeRField @"t" . insertRField @"t" @1 . fmap toORLazy) 66 | -- Type error on 8.2 and 8.4 67 | #if __GLASGOW_HASKELL__ <= 800 || __GLASGOW_HASKELL >= 806 68 | , testCase "Constr-rmv-ins" $ 69 | rt A (fromOR . insertConstrT @"A" . removeConstrT @"A" . toOR) 70 | , testCase "Constr-ins-rmv" $ 71 | rt (Right A) 72 | (fmap fromOR . removeConstrT @"Z" . insertConstrT @"Z" @0 @() . fmap toOR) 73 | #endif 74 | ] 75 | 76 | testConsumer :: TestTree 77 | testConsumer = testGroup "consumer" 78 | [ testCase "removeCField" $ 79 | "P 1 3" @?= 80 | (show' . fromOR' . snd . removeCField @1 . toOR) (P 1 2 3) 81 | 82 | , testCase "removeRField" $ 83 | "R {u = 1, w = 3}" @?= 84 | (show' . fromOR' . snd . removeRField @"v" . toOR) (R 1 2 3) 85 | 86 | , testCase "removeSField" $ 87 | "S {u' = 1, w' = 3}" @?= 88 | (show' . fromOR' . snd . removeRField @"v'" . toORLazy) (S 1 2 3) 89 | 90 | , testCase "insertCField" $ 91 | "P 1 () 2 3" @?= 92 | (show' . fromOR' . insertCField' @1 () . toOR) (P 1 2 3) 93 | 94 | , testCase "insertRField" $ 95 | "R {u = 1, n = (), v = 2, w = 3}" @?= 96 | (show' . fromOR' . insertRField' @"n" @1 () . toOR) (R 1 2 3) 97 | 98 | , testCase "insertSField" $ 99 | "S {u' = 1, n' = (), v' = 2, w' = 3}" @?= 100 | (show' . fromOR' . insertRField' @"n'" @1 () . toORLazy) (S 1 2 3) 101 | 102 | -- Loops on 8.0 103 | #if __GLASGOW_HASKELL__ >= 802 104 | -- N.B. Identity (for constructor B) is inferred. 105 | , testCase "removeConstr" $ 106 | "[Right A,Left (Identity 0),Right (C 1 2 3 4 5)]" @?= 107 | (show . fmap (second (unit . fromOR') . removeConstrT @"B" . toOR)) 108 | [A, B 0, C 1 2 3 4 5] 109 | #endif 110 | 111 | , testCase "insertConstr" $ 112 | "B 0" @?= (show . fromOR @T . insertConstrT @"B" . Left) (Identity 0) 113 | 114 | , testCase "insertConstr (record)" $ 115 | "R {u = 0, v = 0, w = 0}" @?= (show . fromOR @R . insertConstr @"R" . Left) (0, 0, 0) 116 | ] 117 | 118 | testProducer :: TestTree 119 | testProducer = testGroup "producer" 120 | [ testCase "removeCField" $ 121 | P 0 0 0 @?= 122 | (fromOR . snd . removeCField @1 @[Int] . toOR') def 123 | 124 | , testCase "removeRField" $ 125 | R 0 0 0 @?= 126 | (fromOR . snd . removeRField @"v" @1 @[Int] . toOR') def 127 | 128 | , testCase "removeSField" $ 129 | S 0 0 0 @?= 130 | (fromORLazy . snd . removeRField @"v'" @1 @[Int] . toOR') def 131 | 132 | , testCase "insertCField" $ 133 | P 0 9 0 @?= 134 | (fromOR . insertCField' @1 9 . toOR') def 135 | 136 | , testCase "insertRField" $ 137 | R 0 9 0 @?= 138 | (fromOR . insertRField' @"v" 9 . toOR') def 139 | 140 | , testCase "insertSField" $ 141 | S 0 9 0 @?= 142 | (fromORLazy . insertRField' @"v'" 9 . toOR') def 143 | 144 | , testCase "removeConstr" $ 145 | Right A @?= 146 | (fmap fromOR . removeConstrT @"D" @3 @() . toOR') def 147 | 148 | -- N.B. () (for constructor A) is inferred. 149 | , testCase "insertConstr" $ 150 | B 0 @?= 151 | (fromOR . insertConstrT @"A" . Right . toOR') def 152 | ] 153 | 154 | class Def a where 155 | def :: a 156 | 157 | instance Def Int where 158 | def = 0 159 | 160 | instance Def [a] where 161 | def = [] 162 | 163 | instance GDef f => Def (Data f x) where 164 | def = Data gdef 165 | 166 | class GDef f where 167 | gdef :: f x 168 | 169 | instance GDef f => GDef (M1 i c f) where 170 | gdef = M1 gdef 171 | 172 | instance GDef f => GDef (f :+: g) where 173 | gdef = L1 gdef 174 | 175 | instance (GDef f, GDef g) => GDef (f :*: g) where 176 | gdef = gdef :*: gdef 177 | 178 | instance Def a => GDef (K1 i a) where 179 | gdef = K1 def 180 | 181 | instance GDef U1 where 182 | gdef = U1 183 | -------------------------------------------------------------------------------- /test/synthetic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | CPP, 3 | DataKinds, 4 | DeriveGeneric, 5 | FlexibleContexts, 6 | GeneralizedNewtypeDeriving, 7 | KindSignatures, 8 | PolyKinds, 9 | ScopedTypeVariables, 10 | StandaloneDeriving, 11 | TypeApplications, 12 | TypeFamilies, 13 | TypeInType, 14 | TypeOperators, 15 | UndecidableInstances 16 | #-} 17 | #if __GLASGOW_HASKELL__ >= 806 18 | {-# LANGUAGE DerivingStrategies #-} 19 | #endif 20 | 21 | #if 806 > __GLASGOW_HASKELL__ 22 | import Data.Coerce (Coercible, coerce) 23 | #endif 24 | import Data.Functor.Contravariant (Contravariant) 25 | import Data.Functor.Identity (Identity(..)) 26 | import Data.Bifunctor (first, second, bimap) 27 | import GHC.Generics (Generic(..)) 28 | import qualified GHC.Generics -- Make constructors visible to Coercible 29 | import Test.Tasty 30 | import Test.Tasty.HUnit 31 | 32 | import Generic.Data (GShow1) 33 | import Generic.Data.Surgery 34 | 35 | data RowId = RowId 36 | deriving Show 37 | 38 | type InsertId = (InsertField 0 ('Just "pk") RowId :: MajorSurgery k) 39 | 40 | newtype WithId a = 41 | WithId (Data (Operate (Rep a) InsertId) ()) 42 | 43 | deriving instance GShow1 (Operate (Rep a) InsertId) => Show (WithId a) 44 | 45 | #if __GLASGOW_HASKELL__ >= 806 46 | deriving newtype instance 47 | ( Generic a 48 | , Functor (Operate (Rep a) InsertId) 49 | , Contravariant (Operate (Rep a) InsertId) 50 | ) => Generic (WithId a) 51 | #else 52 | -- Without DerivingStrategies, we do newtype deriving of Generic by hand. 53 | instance 54 | ( Generic a 55 | , Functor (Operate (Rep a) InsertId) 56 | , Contravariant (Operate (Rep a) InsertId) 57 | ) => Generic (WithId a) where 58 | type Rep (WithId a) = Operate (Rep a) InsertId 59 | to = to' 60 | from = from' 61 | 62 | to' :: forall a x. 63 | (Coercible a (Data (Rep a) ()), Functor (Rep a), Contravariant (Rep a)) => 64 | Rep a x -> a 65 | to' = coerce (to @(Data (Rep a) ()) @x) 66 | 67 | from' :: forall a x. 68 | (Coercible a (Data (Rep a) ()), Functor (Rep a), Contravariant (Rep a)) => 69 | a -> Rep a x 70 | from' = coerce (from @(Data (Rep a) ()) @x) 71 | #endif 72 | 73 | addKey :: 74 | ( Generic a 75 | , Perform (Rep a) InsertId 76 | ) => RowId -> a -> WithId a 77 | addKey i = WithId . fromOR' . insertRField' @"pk" @0 @RowId i . toOR 78 | 79 | data Woof = Waf { fluff :: Int } 80 | deriving Generic 81 | 82 | type SemiFluff = RemoveRField "fluff" Int 83 | 84 | type Fluffy = (SemiFluff :>> InsertField 0 ('Just "fluffy") Bool :: MajorSurgery k) 85 | 86 | unfluff :: (Generic a, Perform (Rep a) SemiFluff) 87 | => a -> (Int, Data (Operate (Rep a) SemiFluff) ()) 88 | unfluff = fmap fromOR' . removeRField @"fluff" . toOR 89 | 90 | fluffier :: (Generic a, Perform (Rep a) Fluffy) => a -> Data (Operate (Rep a) Fluffy) () 91 | fluffier = fromOR' . insertRField @"fluffy" @0 . first (>= 0) . removeRField @"fluff" . toOR 92 | 93 | data Meow = Miaou Int 94 | deriving Generic 95 | 96 | type UnMiaou = (RemoveConstr "Miaou" (Identity Int) :: MajorSurgery k) 97 | type Paw = InsertConstrAt "Paw" 1 (Bool, Bool) 98 | 99 | unMiaou :: (Generic a, Perform (Rep a) UnMiaou) 100 | => a -> Either Int (Data (Operate (Rep a) UnMiaou) ()) 101 | unMiaou = bimap runIdentity fromOR' . removeConstrT @"Miaou" . toOR 102 | 103 | purr :: (Generic a, Perform (Rep a) Paw) => 104 | Either (Bool, Bool) a -> Data (Operate (Rep a) Paw) () 105 | purr = fromOR' . insertConstrT @"Paw" @1 . second toOR 106 | 107 | type Aww = (Paw :>> UnMiaou :: MajorSurgery k) 108 | 109 | {- 110 | pat :: forall a. (Generic a, Perform (Rep a) Aww) => 111 | Either (Bool, Bool) a -> Either (Identity Int) (Data (Operate (Rep a) Aww) ()) 112 | pat = second fromOR' . removeConstrT @"Miaou" . insertConstrT @"Paw" @1 @(Bool, Bool) . second toOR 113 | -} 114 | 115 | main :: IO () 116 | main = defaultMain test 117 | 118 | test :: TestTree 119 | test = testGroup "synthetic" 120 | [ testCase "addKey" $ "WithId (Waf {pk = RowId, fluff = 77})" @?= show (addKey RowId (Waf 77)) 121 | , testCase "unfluff" $ "(33,Waf {})" @?= show (unfluff (Waf 33)) 122 | , testCase "fluffier" $ "Waf {fluffy = True}" @?= show (fluffier (Waf 33)) 123 | , testCase "unMiaou" $ "Left 3" @?= show (unMiaou (Miaou 3)) 124 | , testCase "purr" $ "Miaou 3" @?= show (purr (Right (Miaou 3))) 125 | ] 126 | --------------------------------------------------------------------------------