extensible 0.3.7 → 0.9.2
raw patch · 36 files changed
Files
- .gitignore +61/−59
- .travis.yml +0/−54
- CHANGELOG.md +204/−0
- LICENSE +30/−30
- README.md +7/−5
- Setup.hs +2/−2
- examples/aeson.hs +0/−16
- examples/effect.hs +42/−14
- examples/getopt.hs +13/−0
- examples/nullable.hs +20/−0
- examples/records.hs +22/−24
- examples/state.hs +3/−3
- examples/tangle.hs +33/−0
- extensible.cabal +69/−14
- src/Data/Extensible.hs +31/−7
- src/Data/Extensible/Bits.hs +213/−0
- src/Data/Extensible/Class.hs +50/−23
- src/Data/Extensible/Dictionary.hs +305/−44
- src/Data/Extensible/Effect.hs +0/−95
- src/Data/Extensible/Field.hs +178/−79
- src/Data/Extensible/GetOpt.hs +132/−0
- src/Data/Extensible/Inclusion.hs +25/−23
- src/Data/Extensible/Internal.hs +0/−281
- src/Data/Extensible/Internal/Rig.hs +9/−4
- src/Data/Extensible/Label.hs +31/−0
- src/Data/Extensible/Match.hs +8/−8
- src/Data/Extensible/Nullable.hs +63/−16
- src/Data/Extensible/Plain.hs +5/−8
- src/Data/Extensible/Product.hs +331/−267
- src/Data/Extensible/Record.hs +83/−65
- src/Data/Extensible/Struct.hs +331/−0
- src/Data/Extensible/Sum.hs +23/−33
- src/Data/Extensible/TH.hs +13/−103
- src/Data/Extensible/Tangle.hs +90/−0
- src/Data/Extensible/Wrapper.hs +145/−74
- tests/bits.hs +94/−0
.gitignore view
@@ -1,59 +1,61 @@-dist -cabal-dev -*.o -*.hi -*.chi -*.chs.h -.virtualenv -.hsenv -.cabal-sandbox/ -cabal.sandbox.config -cabal.config -.stack-work - -# ========================= -# Operating System Files -# ========================= - -# OSX -# ========================= - -.DS_Store -.AppleDouble -.LSOverride - -# Thumbnails -._* - -# Files that might appear on external disk -.Spotlight-V100 -.Trashes - -# Directories potentially created on remote AFP share -.AppleDB -.AppleDesktop -Network Trash Folder -Temporary Items -.apdisk - -# Windows -# ========================= - -# Windows image file caches -Thumbs.db -ehthumbs.db - -# Folder config file -Desktop.ini - -# Recycle Bin used on file shares -$RECYCLE.BIN/ - -# Windows Installer files -*.cab -*.msi -*.msm -*.msp - -# Windows shortcuts -*.lnk +dist+cabal-dev+*.o+*.hi+*.chi+*.chs.h+.virtualenv+.hsenv+.cabal-sandbox/+cabal.sandbox.config+cabal.config+.stack-work+.bash_history+dist-newstyle++# =========================+# Operating System Files+# =========================++# OSX+# =========================++.DS_Store+.AppleDouble+.LSOverride++# Thumbnails+._*++# Files that might appear on external disk+.Spotlight-V100+.Trashes++# Directories potentially created on remote AFP share+.AppleDB+.AppleDesktop+Network Trash Folder+Temporary Items+.apdisk++# Windows+# =========================++# Windows image file caches+Thumbs.db+ehthumbs.db++# Folder config file+Desktop.ini++# Recycle Bin used on file shares+$RECYCLE.BIN/++# Windows Installer files+*.cab+*.msi+*.msm+*.msp++# Windows shortcuts+*.lnk
− .travis.yml
@@ -1,54 +0,0 @@-# NB: don't set `language: haskell` here--# See also https://github.com/hvr/multi-ghc-travis for more information--# The following lines enable several GHC versions and/or HP versions-# to be tested; often it's enough to test only against the last-# release of a major GHC version. Setting HPVER implictly sets-# GHCVER. Omit lines with versions you don't need/want testing for.-env:- - CABALVER=1.22 GHCVER=7.10.1--# Note: the distinction between `before_install` and `install` is not-# important.-before_install:- - travis_retry sudo add-apt-repository -y ppa:hvr/ghc- - travis_retry sudo apt-get update- - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER- - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH--install:- - cabal --version- - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"- - travis_retry cabal update- - cabal install --only-dependencies --enable-tests --enable-benchmarks--# Here starts the actual work to be performed for the package under-# test; any command which exits with a non-zero exit code causes the-# build to fail.-script:- - if [ -f configure.ac ]; then autoreconf -i; fi- # -v2 provides useful information for debugging- - cabal configure --enable-tests --enable-benchmarks -v2-- # this builds all libraries and executables- # (including tests/benchmarks)- - cabal build-- - cabal test- - cabal check-- # tests that a source-distribution can be generated- - cabal sdist-- # check that the generated source-distribution can be built & installed- - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;- cd dist/;- if [ -f "$SRC_TGZ" ]; then- cabal install --force-reinstalls "$SRC_TGZ";- else- echo "expected '$SRC_TGZ' not found";- exit 1;- fi--# EOF
CHANGELOG.md view
@@ -1,3 +1,207 @@+0.9.2+------------------------------------------------++* Supported GHC 9.10 ([#40](https://github.com/fumieval/extensible/pull/40) by [@miguel-negrao](https://github.com/miguel-negrao))++0.9.1+------------------------------------------------++* Supported GHCs up to 9.8 ([#38](https://github.com/fumieval/extensible/pull/38) by [@kgtkr](https://github.com/kgtkr))+* Exported `Assoc`, `(>:)`, and `Lookup` from `Data.Extensible.Effect`+* Added `coinclusionAssoc`, `wrenchAssoc`, and `retrenchAssoc` ([#36](https://github.com/fumieval/extensible/pull/36) by [@At-sushi](https://github.com/At-sushi))++0.9+------------------------------------------------++* Removed `FieldName`, the relic of the old ages+ * `(@=)`, `@==`, `@!?` and `lasso` now take `Proxy` instead of `FieldName`. Those who are using `mkField` need to replace the operands with proxies (OverloadedLabels is recommended).+* Supported aeson 1.x+* Introduced `IsLabel` flag which toggles the presence of optics `OverloadedLabels`. By disabling it, this package can now coexist with other users of the `IsLabel` class, such as `generic-lens` and `relational-query`.++0.8.3+------------------------------------------------++* `Comp` is now a pattern synonym for `Compose`+* Added missing `liftTyped` implementations+* Supported aeson-2.0++0.8.1+------------------------------------------------+* Added `DefaultOrdered` and `Incremental` instances to `:&`+* Added an `Incremental` instance to `Field`++0.8+------------------------------------------------++* Removed `Associate`, `AssocKey`, `AssocValue`, `ValueIs`, `KeyIs`, `KeyValue`, `proxyAssocKey`, `proxyAssocValue`, `stringAssokKey`, `xlb`, `:*`, `:|`+* Reverted deprecation of `Data.Extensible.Tangle`++0.7.1+------------------------------------------------+* Removed `vector` and `prettyprinter` orphans+* Deprecated `Data.Extensible.Tangle`; use [tangle](https://hackage.haskell.org/package/tangle)+* `parseJSON` gives more informative failure messages on failure+* Supported `barbies ^>= 2`++0.7+-------------------------------------------------+* Moved `Data.Extensible.Effect` into new `extensible-skeleton` package+* Instances for barbies and cassava are now optional+* Deprecated 訊++0.6.1+-------------------------------------------------+* Added `fromNullable`+* Added `xlb`+* Added a `HasField` instance for `RecordOf`+* Removed `deriveIsRecord`+* Supported GHC 8.8++0.6+-------------------------------------------------+* Added a MonadCont instance for Eff+* `(:*)` and `(:|)` are deprecated in favour of `(:&)` and `(:*)` where their+ type parameters are flipped+* Flipped the type parameters of `BitProd` and `TangleT`+* Added `itemKey`, `hmapWithIndexWith`, `hfoldMapWith`, `hfoldMapWithIndexWith`,+ `hfoldrWithIndexWith`, `hfoldlWithIndexWith`, `hrepeatWith`, `htabulateWith`,+ and `hgenerateWith`++0.5.1+-------------------------------------------------+* Split `Data.Extensible.HList` and `Data.Extensible.Internal` to the+ `membership` package+* `AssocKey`, `AssocValue`, `ValueIs`, `KeyValue` and their related combinators+ are deprecated. Use ones from `membership`+* `IsRecord` now has a generic default implementation+* Deprecated `deriveIsRecord`++0.5+-------------------------------------------------+* GHC older than 8.4 is no longer supported+* Removed `Const'`+* `Data.Extensible.Plain` is no longer exported from `Data.Extensible`+* Added `wrap` and `unwrap` to `Wrapper`+* Added `(=<:)`++0.4.10.1+-------------------------------------------------+* Fixed build on GHC 8.6++0.4.10+-------------------------------------------------+* Added a `MonadResource`, `MonadThrow`, and `MonadCatch` instances for `Eff`+* `Proxy` and `KnownSymbol` are now reexported from `Data.Extensible`++0.4.9+-------------------------------------------------+* Generalised the `MonadIO` instance for `Eff` to `(MonadIO m, Associate "IO" m xs) => MonadIO (Eff xs)`+* Added `And :: (k -> Constraint) -> (k -> Constraint) -> k -> Constraint`+* Added `Semigroup` and `Monoid` instances for `Const'`+* Added `stringAssocKey :: (IsString a, KnownSymbol (AssocKey kv)) => proxy kv -> a`+* Added a `Wrapper` instance for `Either e`+* Added instances of `Pretty` and `Lift`+* Added `hmapWithIndexFor`++0.4.8+-------------------------------------------------+* Changed the `FromJSON` instance for `Record` to call `parseJSON Null` for missing fields+* Added `FromJSON` and `ToJSON` instances for `Nullable (Field h) :* xs`++0.4.7.2+-------------------------------------------------+* Added cassava's `ToNamedRecord`, `ToRecord`, `FromNamedRecord` and `FromRecord` instances+* Added `KeyIs` and `ValueIs`+* Added `FromJSON` and `ToJSON` instances for `(:*)`++0.4.7.1+-------------------------------------------------+* Fixed weird CPP errors on macOS 10.13.2 (#18)+* Added `optFlag`, `optLastArg`, and `optionOptArg`++0.4.7+-------------------------------------------------+* Made various optimisations to improve the compilation time+* Added trivial instances for `FromBits`+* Generalised the API of `Data.Extensible.GetOpt`++0.4.6+-------------------------------------------------+* New module `Data.Extensible.GetOpt`+* Added `fromBitProd`+* Added `Hashable` instances for `:*`, `:|`, `BitProd`, `Membership`, and various wrappers+* Added an `Unbox` instance for `:*`+* Added `hfoldlWithIndex` and `hfoldlWithIndexFor`++0.4.5+-------------------------------------------------+* Added `nothingEff`+* Added `happend`+* Added `Arbitrary` instances for `:*`, `:|`, and wrappers+* Added `Data.Extensible.Bits`++0.4.4+-------------------------------------------------+* Added `contEff` and `runContEff`+* Added `castEff`+* Added `evalStateEff`+* Added `Semigroup` and `Monoid` instances for `Match`, `Comp`, `Prod`+* Added `evalStateDef`, `execStateDef`, and `execWriterDef`+* Added `mkFieldAs`+* Added a `Bounded` instance for `:*`++0.4.3+-------------------------------------------------+* Added `WrappedPointer`+* Added `NFData` and `Generic` instances for `Comp`+* Added a `Semigroup` instance for `h :* xs` and `Membership xs x`+* Added `Prod`+* Added `peelEff0`+* Changed the `IsLabel` instance so that a function is always inferred as an optic+* `Data.Extensible.Class` now exports `compareMembership`+* Renamed `runMembership` to `leadership`++0.4.2+-------------------------------------------------+* Made `newFrom` strict+* `pieceAt` for `(:*)` is now strict+* Added `(<!)`+* Added `peelEff1`, `peelAction0`, `execStateEff`, `execWriterEff`+* Added atomic operations for `Struct`+* Added constrained variants of folds++0.4.1+--------------------------------------------------+* Added `hforce`+* Added an `NFData` instance for `(:*)` and `:|`+* Added a rule to fuse a chain of product updates+* Added a `Monoid` instance for `TangleT`+* Added `(@==)`+* `#foo` can now be overloaded as `FieldOptic "foo"`++0.4+---------------------------------------------------+* Added `Data.Extensible.Struct`+* Changed the representation of `(:*)` to use `SmallArray`+* Removed `(<:*)`. `hhead`, `htail`, `huncons`, `(*++*)`, `htrans`+* New functions: `hfoldrWithIndex`, `hrepeat`, `hrepeatFor`, `haccumMap`,+ `haccum`, `hpartition`, `henumerate`, `hlength`, `hcount`+* Added various derived instances for `Field`+* Added `liftField`, `liftField2`+* Added `Wrapper` instances for `Maybe` and `[]`+* Added `>:` as a synonym for `:>`+* `Data.Extensible.Effect`+ * Refined the API+ * Added `Data.Extensible.Effect.Default`+* Added `Data.Extensible.Tangle`+* Added `record`+* Type inference aids++0.3.7.1+----------------------------------------------------+* `pieceAt` for `(:*)` is now index-preserving+* Removed `sector`, `sectorAt`, `picked`+ 0.3.7 ----------------------------------------------------- * Support GHC 8.0
LICENSE view
@@ -1,30 +1,30 @@-Copyright (c) 2015, Fumiaki Kinoshita - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Fumiaki Kinoshita nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright (c) 2015, Fumiaki Kinoshita++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Fumiaki Kinoshita nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.md view
@@ -1,9 +1,11 @@-extensible-======================+ -[](https://travis-ci.org/fumieval/extensible)-[](https://hackage.haskell.org/package/extensible)++[](https://hackage.haskell.org/package/extensible)+[](https://discord.gg/DG93Tgs) -This package provides extensible poly-kind records and variants.+This package provides extensible poly-kinded records, variants and effects.++Several tutorials can be found at [School of Haskell](https://www.schoolofhaskell.com/user/fumieval/extensible). Bug reports and contributions are welcome!
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
− examples/aeson.hs
@@ -1,16 +0,0 @@-{-# LANGUAGE TypeOperators, DataKinds, FlexibleContexts, FlexibleInstances, UndecidableInstances, PolyKinds, TemplateHaskell #-}-import Data.Aeson (FromJSON(..), withObject)-import Data.Extensible (Record, Field(..), KeyValue, AssocKey, Forall, hgenerateFor)-import GHC.TypeLits (KnownSymbol, symbolVal)-import Data.Proxy-import Data.String (fromString)-import qualified Data.HashMap.Strict as HM--keyProxy :: proxy kv -> Proxy (AssocKey kv)-keyProxy _ = Proxy--instance Forall (KeyValue KnownSymbol FromJSON) xs => FromJSON (Record xs) where- parseJSON = withObject "Object" $ \v -> hgenerateFor (Proxy :: Proxy (KeyValue KnownSymbol FromJSON))- $ \m -> let k = symbolVal (keyProxy m) in case HM.lookup (fromString k) v of- Just a -> Field <$> return <$> parseJSON a- Nothing -> fail $ "Missing key: " ++ k
examples/effect.hs view
@@ -1,20 +1,48 @@-{-# LANGUAGE TemplateHaskell, DataKinds, FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell, DataKinds, TypeOperators, PolyKinds, FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-simplifiable-class-constraints#-} import Data.Extensible+import Control.Monad.IO.Class+import Control.Monad.Trans.Writer.Strict+import Control.Monad.Skeleton -decEffects [d|- data Example x where -- the name doesn't matter- Foo :: Int -> Example ()- Bar :: Example String- Baz :: Bool -> Bool -> Example Int+decEffectSuite [d|+ data Example x where+ Reset :: Int -> Example ()+ PrintString :: String -> Example ()+ Hello :: Example ()+ Count :: Example Int |] -mkField "Foo Bar Baz"+mkField "Reset PrintString Hello Count" -test :: (Associate "Foo" (Action '[Int] ()) xs- , Associate "Bar" (Action '[] String) xs- , Associate "Baz" (Action '[Bool, Bool] Int) xs) => Eff xs Int+test :: IncludeAssoc xs Example => Eff xs () test = do- foo 42- s <- bar- t <- bar- baz (s == "bar") (s == t)+ hello+ hello+ n <- count+ printString (show n)+ reset 0+ n' <- count+ printString (show n')++-- | Object-like stateful handler+newtype Methods xs m = Methods+ { getMethods :: RecordOf (Interpreter (WriterT (Methods xs m) m)) xs }++runMethods :: Monad m => Methods xs m -> Eff xs a -> m (a, Methods xs m)+runMethods rec eff = case handleEff (getMethods rec) eff of+ Return a -> return (a, rec)+ m :>>= k -> do+ (a, rec') <- runWriterT m+ runMethods rec' (k a)++example :: Int -> Methods Example IO+example n = Methods+ $ _Reset @!? do \n' -> writer ((), example n')+ <: _PrintString @!? do \str -> WriterT $ ((), example n) <$ putStrLn str+ <: _Hello @!? do WriterT $ ((), example $ n + 1) <$ putStrLn "Hello!"+ <: _Count @!? do writer (n, example n)+ <: nil++takePrintString :: MonadIO (Eff xs) => Eff (PrintString ': xs) a -> Eff xs a+takePrintString = peelAction0 $ liftIO . putStrLn
+ examples/getopt.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE OverloadedLabels, LambdaCase #-}+import Control.Lens+import Data.Extensible+import Data.Extensible.GetOpt++main :: IO ()+main = withGetOpt "" opts $ \r _args -> do+ putStrLn $ "verbose: " ++ show (r ^. #verbose > 0)+ putStrLn $ "extra: " ++ show (r ^? #extra. folded)+ where+ opts = #verbose @= optNoArg "v" ["verbose"] "verbose"+ <: #extra @= optReqArg "e" ["extra"] "ARG" "extra arguments"+ <: nil
+ examples/nullable.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE DataKinds, TypeOperators, OverloadedLabels, OverloadedStrings #-}+import Control.Lens+import qualified Data.Aeson as J+import Data.Extensible+import Data.Maybe (fromMaybe)++type ConfigRec = '[ "columns" >: Int, "language_extensions" >: [String] ]++defaultConfig :: Record ConfigRec+defaultConfig = #columns @= 80 <: #language_extensions @= [] <: nil++main :: IO ()+main = do+ config <- hzipWith fromNullable defaultConfig <$> readConfig "path/to/config.json"+ putStrLn $ "columns: " ++ (show $ config ^. #columns)+ putStrLn $ "language_extensions: " ++ (show $ config ^. #language_extensions)++-- dummy+readConfig :: FilePath -> IO (ConfigRec :& Nullable (Field Identity))+readConfig _path = pure $ fromMaybe vacancy (J.decode "{\"columns\": 100}")
examples/records.hs view
@@ -1,36 +1,34 @@-{-# LANGUAGE TemplateHaskell, DataKinds, TypeOperators, TypeFamilies, FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell, DataKinds, TypeOperators, TypeFamilies, FlexibleContexts, OverloadedLabels #-} import Data.Extensible import Control.Lens -mkField "name weight price description featured quantity"- type Stock c = Record '[- "name" :> String- , "weight" :> Float- , "price" :> c- , "featured" :> Bool- , "description" :> String- , "quantity" :> Int]+ "name" >: String+ , "weight" >: Float+ , "price" >: c+ , "featured" >: Bool+ , "description" >: String+ , "quantity" >: Int] s0 :: Num c => Stock c-s0 = name @= "DA-192H"- <: weight @= 260- <: price @= 120- <: featured @= True- <: description @= "High-quality (24bit 192kHz), lightweight portable DAC"- <: quantity @= 20- <: Nil+s0 = #name @= "DA-192H"+ <: #weight @= 260+ <: #price @= 120+ <: #featured @= True+ <: #description @= "High-quality (24bit 192kHz), lightweight portable DAC"+ <: #quantity @= 20+ <: emptyRecord -- Use shrinkAssoc to permute elements s1 :: Num c => Stock c s1 = shrinkAssoc- $ name @= "HHP-150"- <: featured @= False- <: description @= "Premium wooden headphone"- <: price @= 330- <: quantity @= 55- <: weight @= 200- <: Nil+ $ #name @= "HHP-150"+ <: #featured @= False+ <: #description @= "Premium wooden headphone"+ <: #price @= 330+ <: #quantity @= 55+ <: #weight @= 200+ <: emptyRecord -- If "quantity" is missing, -- Couldn't match type ‘Missing "quantity"’ with ‘Expecting one’@@ -39,4 +37,4 @@ -- Couldn't match type ‘Ambiguous "quantity"’ with ‘Expecting one’ printSummary :: (Associate "name" String s, Associate "description" String s) => Record s -> IO ()-printSummary s = putStrLn $ view name s ++ ": " ++ view description s+printSummary s = putStrLn $ view #name s ++ ": " ++ view #description s
examples/state.hs view
@@ -1,15 +1,15 @@ {-# LANGUAGE TypeOperators, DataKinds, TemplateHaskell, FlexibleContexts #-} import Data.Extensible import Control.Lens-import Control.Monad.State+import Control.Monad.State.Strict mkField "foo bar baz" -statefulStuff :: State (Record '["foo" :> Int, "bar" :> Int, "baz" :> Float]) ()+statefulStuff :: State (Record '["foo" >: Int, "bar" >: Int, "baz" >: Float]) () statefulStuff = do v <- use foo bar += v baz .= 42 main = print $ execState statefulStuff- $ foo @= 10 <: bar @= 0 <: baz @= 0 <: Nil+ $ foo @= 10 <: bar @= 0 <: baz @= 0 <: nil
+ examples/tangle.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE TypeOperators, PolyKinds, FlexibleContexts, FlexibleInstances, TemplateHaskell, DataKinds #-}+import Control.Monad.Trans.Class+import Data.Extensible+import Data.Functor.Identity+import Data.Proxy++mkField "foo bar baz"++type Rec = ["foo" :> String, "bar" :> Int, "baz" :> Double, "qux" :> Bool]++class MakeRec kv where+ make :: proxy kv -> TangleT (Field Identity) Rec IO (AssocValue kv)++instance MakeRec ("foo" :> String) where+ make _ = lift getLine++instance MakeRec ("bar" :> Int) where+ make _ = lift $ length <$> getLine++instance MakeRec ("baz" :> Double) where+ make _ = lift readLn++instance MakeRec ("qux" :> Bool) where+ make _ = do+ str <- lasso foo+ x <- lasso baz+ return $ str == show x++makeRec :: IO (Record Rec)+makeRec = runTangles+ (htabulateFor (Proxy :: Proxy MakeRec)+ $ \m -> Comp $ Field . pure <$> make m)+ (wrench nil)
extensible.cabal view
@@ -1,50 +1,74 @@+cabal-version: 2.4 name: extensible-version: 0.3.7-synopsis: Extensible, efficient, optics-friendly data types+version: 0.9.2+synopsis: Extensible, efficient, optics-friendly data types and effects homepage: https://github.com/fumieval/extensible bug-reports: http://github.com/fumieval/extensible/issues-description: Poly-kinded extensible records and variants-license: BSD3+description:+ This package provides a powerful framework to combine and manipulate various types of structures.+ .+ See also <https://www.schoolofhaskell.com/user/fumieval/extensible School of Haskell> for tutorials.+license: BSD-3-Clause license-file: LICENSE author: Fumiaki Kinoshita maintainer: Fumiaki Kinoshita <fumiexcel@gmail.com>-copyright: Copyright (C) 2016 Fumiaki Kinoshita+copyright: Copyright (c) 2017-2022 Fumiaki Kinoshita category: Data, Records build-type: Simple stability: experimental+Tested-With: GHC == 8.10.7, GHC == 9.0.1, GHC == 9.2.1, GHC == 9.10.1 extra-source-files: examples/*.hs .gitignore- .travis.yml README.md CHANGELOG.md-cabal-version: >=1.10 source-repository head type: git location: https://github.com/fumieval/extensible.git +flag barbies+ default: False+ description: "define instances for barbies"+ manual: True++flag cassava+ default: True+ description: "define instances for cassava"+ manual: True++flag IsLabel+ default: True+ description: "export the instance of IsLabel making optics (which could conflict with other packages such as generic-lens)"+ manual: True+ library exposed-modules: Data.Extensible+ Data.Extensible.Bits Data.Extensible.Class Data.Extensible.Dictionary Data.Extensible.Field- Data.Extensible.Effect+ Data.Extensible.GetOpt Data.Extensible.Inclusion- Data.Extensible.Internal Data.Extensible.Internal.Rig+ Data.Extensible.Label Data.Extensible.Match Data.Extensible.Nullable Data.Extensible.Plain Data.Extensible.Product Data.Extensible.Record+ Data.Extensible.Struct Data.Extensible.Sum- Data.Extensible.Wrapper+ Data.Extensible.Tangle Data.Extensible.TH+ Data.Extensible.Wrapper default-extensions: TypeOperators , DeriveDataTypeable+ , DeriveGeneric+ , DeriveLift+ , GeneralizedNewtypeDeriving , KindSignatures , ConstraintKinds , DataKinds@@ -54,13 +78,44 @@ , FlexibleInstances , PolyKinds , CPP- build-depends: base >= 4.7 && <5- , template-haskell+ , NoStarIsType+ build-depends: base >= 4.8 && <5+ , aeson >= 1.5 && <2.3+ , bytestring+ , comonad , constraints+ , deepseq+ , ghc-prim+ , hashable >= 1.2 && <1.5+ , incremental >= 0.3.1+ , membership+ , prettyprinter ^>= 1.7+ , primitive , profunctors+ , QuickCheck+ , StateVar , tagged+ , template-haskell+ , text+ , th-lift >= 0.8 , transformers- , monad-skeleton >= 0.1.2+ , unordered-containers+ , vector >= 0.12.1.2+ if flag(barbies)+ build-depends: barbies ^>= 2+ cpp-options: -DBARBIES+ if flag(cassava)+ build-depends: cassava+ cpp-options: -DCASSAVA+ if flag(IsLabel)+ cpp-options: -DISLABEL hs-source-dirs: src- ghc-options: -Wall+ ghc-options: -Wall -Wcompat+ default-language: Haskell2010++test-suite bits+ type: exitcode-stdio-1.0+ main-is: bits.hs+ build-depends: base, extensible, lens, QuickCheck, template-haskell+ hs-source-dirs: tests default-language: Haskell2010
src/Data/Extensible.hs view
@@ -1,41 +1,65 @@ ---------------------------------------------------------------------------- -- | -- Module : Data.Extensible--- Copyright : (c) Fumiaki Kinoshita 2015+-- Copyright : (c) Fumiaki Kinoshita 2018 -- License : BSD3 -- -- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability : experimental--- Portability : non-portable -- -- This module just reexports everything.+--+-- * Basic+--+-- * 'Data.Extensible.Class': basic membership operations.+-- * 'Data.Extensible.Product': Combinators for extensible products+-- * 'Data.Extensible.Sum': the basic interface for extensible sums+-- * 'Data.Extensible.Field': extensible records and variants+-- * 'Data.Extensible.Inclusion': shrinking records and widening variants+--+-- * Advanced+-- * 'Data.Extensible.Record': Conversion between regular records and+-- extensible records+-- * 'Data.Extensible.Nullable': Nullable records+-- * 'Data.Extensible.Tangle': Extensible tangle+-- * 'Data.Extensible.Effect': Extensible effects+-- * 'Data.Extensible.Match': Extensible pattern match+--+-- * Internal+-- * 'Data.Extensible.Wrapper': Stock wrappers ----------------------------------------------------------------------------- module Data.Extensible ( module Data.Extensible.Class , module Data.Extensible.Dictionary- , module Data.Extensible.Effect , module Data.Extensible.Field , module Data.Extensible.Inclusion , module Data.Extensible.Match , module Data.Extensible.Nullable- , module Data.Extensible.Plain , module Data.Extensible.Product , module Data.Extensible.Record , module Data.Extensible.Sum+ , module Data.Extensible.Tangle , module Data.Extensible.TH , module Data.Extensible.Wrapper+ , Proxy(..)+ , KnownSymbol+ , Compose(..) ) where +import Data.Functor.Compose import Data.Extensible.Class import Data.Extensible.Dictionary import Data.Extensible.Field-import Data.Extensible.Effect import Data.Extensible.Inclusion+#ifdef ISLABEL+import Data.Extensible.Label ()+#endif import Data.Extensible.Match import Data.Extensible.Nullable-import Data.Extensible.Plain import Data.Extensible.Product import Data.Extensible.Record import Data.Extensible.Sum+import Data.Extensible.Tangle import Data.Extensible.TH import Data.Extensible.Wrapper+import Data.Proxy+import GHC.TypeLits
+ src/Data/Extensible/Bits.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE UndecidableInstances, ScopedTypeVariables, MultiParamTypeClasses, TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric #-}+#if __GLASGOW_HASKELL__ < 806+{-# LANGUAGE TypeInType #-}+#endif+-----------------------------------------------------------------------+-- |+-- Module : Data.Extensible.Bits+-- Copyright : (c) Fumiaki Kinoshita 2018+-- License : BSD3+--+-- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>+--+-- Bit-packed records+-----------------------------------------------------------------------+module Data.Extensible.Bits (BitProd(..)+ , FromBits(..)+ , TotalBits+ , BitFields+ , blookup+ , bupdate+ , toBitProd+ , fromBitProd+ , BitRecordOf+ , BitRecord) where++import Control.Applicative+import Control.Comonad+import Data.Bits+import Data.Extensible.Class+import Data.Extensible.Dictionary+import Data.Extensible.Product+import Data.Extensible.Field+import Data.Functor.Identity+import Data.Hashable+import Data.Ix+import Data.Kind (Type)+import Data.Profunctor.Rep+import Data.Profunctor.Sieve+import Data.Proxy+import Data.Word+import Data.Int+import Foreign.Storable (Storable)+import GHC.Generics (Generic)+import GHC.TypeLits++-- | Bit-vector product. It has similar interface as @(:*)@ but fields are packed into @r@.+newtype BitProd r (xs :: [k]) (h :: k -> Type) = BitProd { unBitProd :: r }+ deriving (Eq, Ord, Enum, Bounded, Ix, Generic, Hashable, Storable)++instance (Forall (Instance1 Show h) xs, BitFields r xs h) => Show (BitProd r xs h) where+ showsPrec d x = showParen (d > 10)+ $ showString "toBitProd " . showsPrec 11 (fromBitProd x)++-- | Total 'BitWidth'+type family TotalBits h xs where+ TotalBits h '[] = 0+ TotalBits h (x ': xs) = BitWidth (h x) + TotalBits h xs++-- | Conversion between a value and a bit representation.+--+-- Instances of `FromBits` must satisfy the following laws:+--+-- > fromBits (x `shiftL` W .|. toBits a) ≡ a+-- > toBits a `shiftR` W == zeroBits+--+-- where W is the 'BitWidth'.+class (Bits r, KnownNat (BitWidth a)) => FromBits r a where+ type BitWidth a :: Nat+ fromBits :: r -> a+ toBits :: a -> r++instance Bits r => FromBits r () where+ type BitWidth () = 0+ fromBits _ = ()+ toBits _ = zeroBits++instance Bits r => FromBits r (Proxy a) where+ type BitWidth (Proxy a) = 0+ fromBits _ = Proxy+ toBits _ = zeroBits++instance FromBits Word64 Word64 where+ type BitWidth Word64 = 64+ fromBits = id+ toBits = id++instance FromBits Word64 Bool where+ type BitWidth Bool = 1+ fromBits = flip testBit 0+ toBits False = 0+ toBits True = 1++instance FromBits Word64 Word8 where+ type BitWidth Word8 = 8+ fromBits = fromIntegral+ toBits = fromIntegral++instance FromBits Word64 Word16 where+ type BitWidth Word16 = 16+ fromBits = fromIntegral+ toBits = fromIntegral++instance FromBits Word64 Word32 where+ type BitWidth Word32 = 32+ fromBits = fromIntegral+ toBits = fromIntegral++instance FromBits Word64 Int8 where+ type BitWidth Int8 = 8+ fromBits = fromIntegral+ toBits = fromIntegral . (fromIntegral :: Int8 -> Word8)++instance FromBits Word64 Int16 where+ type BitWidth Int16 = 16+ fromBits = fromIntegral+ toBits = fromIntegral . (fromIntegral :: Int16 -> Word16)++instance FromBits Word64 Int32 where+ type BitWidth Int32 = 32+ fromBits = fromIntegral+ toBits = fromIntegral . (fromIntegral :: Int32 -> Word32)++instance FromBits r a => FromBits r (Identity a) where+ type BitWidth (Identity a) = BitWidth a+ fromBits = Identity . fromBits+ toBits = toBits . runIdentity++instance (FromBits r a, FromBits r b, n ~ (BitWidth a + BitWidth b), n <= BitWidth r, KnownNat n) => FromBits r (a, b) where+ type BitWidth (a, b) = BitWidth a + BitWidth b+ fromBits r = (fromBits (unsafeShiftR r width), fromBits r) where+ width = fromInteger $ natVal (Proxy :: Proxy (BitWidth b))+ toBits (a, b) = unsafeShiftL (toBits a) width .|. toBits b where+ width = fromInteger $ natVal (Proxy :: Proxy (BitWidth b))++instance FromBits r a => FromBits r (Const a b) where+ type BitWidth (Const a b) = BitWidth a+ fromBits = Const . fromBits+ toBits = toBits . getConst++instance (Bits r, KnownNat (BitWidth (h (TargetOf x))), FromBits r (h (TargetOf x))) => FromBits r (Field h x) where+ type BitWidth (Field h x) = BitWidth (h (TargetOf x))+ fromBits = Field . fromBits+ toBits = toBits . getField++instance (Bits r, KnownNat (TotalBits h xs)) => FromBits r (BitProd r xs h) where+ type BitWidth (BitProd r xs h) = TotalBits h xs+ fromBits = BitProd+ toBits = unBitProd++-- | Fields are instances of 'FromBits' and fit in the representation.+type BitFields r xs h = (FromBits r r+ , TotalBits h xs <= BitWidth r+ , Forall (Instance1 (FromBits r) h) xs)++-- | Convert a normal extensible record into a bit record.+toBitProd :: forall r xs h. BitFields r xs h => xs :& h -> BitProd r xs h+toBitProd p = hfoldrWithIndexFor (Proxy :: Proxy (Instance1 (FromBits r) h))+ (\i v f r -> f $! bupdate i r v) id p (BitProd zeroBits)+{-# INLINE toBitProd #-}++-- | Convert a normal extensible record into a bit record.+fromBitProd :: forall r xs h. BitFields r xs h => BitProd r xs h -> xs :& h+fromBitProd p = htabulateFor (Proxy :: Proxy (Instance1 (FromBits r) h))+ $ flip blookup p+{-# INLINE fromBitProd #-}++-- | 'hlookup' for 'BitProd'+blookup :: forall x r xs h.+ (BitFields r xs h, FromBits r (h x))+ => Membership xs x -> BitProd r xs h -> h x+blookup i (BitProd r) = fromBits $ unsafeShiftR r+ $ bitOffsetAt (Proxy :: Proxy r) (Proxy :: Proxy h) (Proxy :: Proxy xs)+ $ getMemberId i+{-# INLINE blookup #-}++-- | Update a field of a 'BitProd'.+bupdate :: forall x r xs h.+ (BitFields r xs h, FromBits r (h x))+ => Membership xs x -> BitProd r xs h -> h x -> BitProd r xs h+bupdate i (BitProd r) a = BitProd $ r .&. mask+ .|. unsafeShiftL (toBits a) offset+ where+ mask = unsafeShiftL (complement zeroBits) width `rotateL` offset+ width = fromInteger $ natVal (Proxy :: Proxy (BitWidth (h x)))+ offset = bitOffsetAt (Proxy :: Proxy r) (Proxy :: Proxy h) (Proxy :: Proxy xs) $ getMemberId i+{-# INLINE bupdate #-}++bitOffsetAt :: forall k r h xs. Forall (Instance1 (FromBits r) h) xs+ => Proxy (r :: Type) -> Proxy (h :: k -> Type) -> Proxy (xs :: [k]) -> Int -> Int+bitOffsetAt _ ph _ = henumerateFor+ (Proxy :: Proxy (Instance1 (FromBits r) h))+ (Proxy :: Proxy xs)+ (\m r o i -> if i == 0+ then o+ else r (fromInteger (natVal (proxyBitWidth ph m)) + o) (i - 1))+ (error "Impossible") 0+{-# INLINE bitOffsetAt #-}++proxyBitWidth :: Proxy h -> proxy x -> Proxy (BitWidth (h x))+proxyBitWidth _ _ = Proxy++-- | Bit-packed record+type BitRecordOf r h xs = BitProd r xs (Field h)++-- | Bit-packed record+type BitRecord r xs = BitRecordOf r Identity xs++instance (Corepresentable p, Comonad (Corep p), Functor f) => Extensible f p (BitProd r) where+ type ExtensibleConstr (BitProd r) xs h x+ = (BitFields r xs h, FromBits r (h x))+ pieceAt i pafb = cotabulate $ \ws -> bupdate i (extract ws) <$> cosieve pafb (blookup i <$> ws)+ {-# INLINE pieceAt #-}
src/Data/Extensible/Class.hs view
@@ -1,13 +1,14 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableSuperClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Extensible.Class--- Copyright : (c) Fumiaki Kinoshita 2015+-- Copyright : (c) Fumiaki Kinoshita 2018 -- License : BSD3 -- -- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability : experimental--- Portability : MPTCs -- ----------------------------------------------------------------------------- module Data.Extensible.Class (@@ -18,58 +19,84 @@ , itemAt , item , itemAssoc+ , itemKey -- * Membership , Membership , mkMembership+ , getMemberId+ , compareMembership+ , leadership -- * Member , Member(..)- , remember-#if __GLASGOW_HASKELL__ >= 800 , type (∈)-#else- , (∈)()-#endif , FindType+ -- * Generation+ , Generate(..)+ , Forall(..)+ , ForallF -- * Association , Assoc(..)- , Associate(..)- , FindAssoc- -- * Sugar- , Elaborate- , Elaborated(..)+ , type (>:)+ , Lookup(..)+ -- * Misc+ , Head+ , Last ) where-import Data.Extensible.Internal+import Data.Constraint import Data.Extensible.Internal.Rig (Optic') import Data.Extensible.Wrapper+import Data.Kind import Data.Profunctor+import Type.Membership+import Type.Membership.Internal -- | This class allows us to use 'pieceAt' for both sums and products.-class (Functor f, Profunctor p) => Extensible f p (t :: (k -> *) -> [k] -> *) where- pieceAt :: Membership xs x -> Optic' p f (t h xs) (h x)+class (Functor f, Profunctor p) => Extensible f p (t :: [k] -> (k -> Type) -> Type) where+ type ExtensibleConstr t (xs :: [k]) (h :: k -> Type) (x :: k) :: Constraint+ type ExtensibleConstr t xs h x = ()+ pieceAt :: ExtensibleConstr t xs h x => Membership xs x -> Optic' p f (t xs h) (h x) -- | Accessor for an element.-piece :: (x ∈ xs, Extensible f p t) => Optic' p f (t h xs) (h x)+piece :: (x ∈ xs, Extensible f p t, ExtensibleConstr t xs h x) => Optic' p f (t xs h) (h x) piece = pieceAt membership {-# INLINE piece #-} -- | Like 'piece', but reckon membership from its key.-pieceAssoc :: (Associate k v xs, Extensible f p t) => Optic' p f (t h xs) (h (k ':> v))+pieceAssoc :: (Lookup xs k v, Extensible f p t, ExtensibleConstr t xs h (k ':> v)) => Optic' p f (t xs h) (h (k ':> v)) pieceAssoc = pieceAt association {-# INLINE pieceAssoc #-} -itemAt :: (Wrapper h, Extensible f p t) => Membership xs x -> Optic' p f (t h xs) (Repr h x)+-- | Access a specified element through a wrapper.+itemAt :: (Wrapper h, Extensible f p t, ExtensibleConstr t xs h x) => Membership xs x -> Optic' p f (t xs h) (Repr h x) itemAt m = pieceAt m . _Wrapper {-# INLINE itemAt #-} -item :: (Wrapper h, Extensible f p t, x ∈ xs) => proxy x -> Optic' p f (t h xs) (Repr h x)+-- | Access an element through a wrapper.+item :: (Wrapper h, Extensible f p t, x ∈ xs, ExtensibleConstr t xs h x) => proxy x -> Optic' p f (t xs h) (Repr h x) item p = piece . _WrapperAs p {-# INLINE item #-} -itemAssoc :: (Wrapper h, Extensible f p t, Associate k v xs)- => proxy k -> Optic' p f (t h xs) (Repr h (k ':> v))+-- | Access an element specified by the key type through a wrapper.+itemAssoc :: (Wrapper h, Extensible f p t, Lookup xs k v, ExtensibleConstr t xs h (k ':> v))+ => proxy k -> Optic' p f (t xs h) (Repr h (k ':> v)) itemAssoc p = pieceAssoc . _WrapperAs (proxyKey p) {-# INLINE itemAssoc #-} +-- | Access an element specified by the key type through a wrapper.+itemKey :: forall k v xs h f p t. (Wrapper h, Extensible f p t, Lookup xs k v, ExtensibleConstr t xs h (k ':> v))+ => Optic' p f (t xs h) (Repr h (k ':> v))+itemKey = pieceAssoc . _WrapperAs (Proxy @(k ':> v))+{-# INLINE itemKey #-}+ proxyKey :: proxy k -> Proxy (k ':> v) proxyKey _ = Proxy {-# INLINE proxyKey #-}++-- | First element+type family Head (xs :: [k]) :: k where+ Head (x ': xs) = x++-- | Last element+type family Last (x :: [k]) :: k where+ Last '[x] = x+ Last (x ': xs) = Last xs
src/Data/Extensible/Dictionary.hs view
@@ -1,95 +1,356 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies, ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances, MultiParamTypeClasses #-}-#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE UndecidableSuperClasses #-}-#endif-+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE InstanceSigs #-} {-# OPTIONS_GHC -fno-warn-orphans #-} --------------------------------------------------------------------------+-- | -- Module : Data.Extensible.Dictionary--- Copyright : (c) Fumiaki Kinoshita 2015+-- Copyright : (c) Fumiaki Kinoshita 2018 -- License : BSD3 -- -- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability : experimental--- Portability : non-portable -- -- Reification of constraints using extensible data types. -- Also includes orphan instances. ------------------------------------------------------------------------module Data.Extensible.Dictionary (library, WrapForall, Instance1) where-import Data.Monoid+module Data.Extensible.Dictionary (library, WrapForall, Instance1, And) where+import Control.DeepSeq+import qualified Data.Aeson as J+import qualified Data.Aeson.Types as J+#ifdef CASSAVA+import qualified Data.Csv as Csv+import qualified Data.ByteString.Char8 as BC+import qualified Data.Vector as V+#endif import Data.Extensible.Class+import Data.Extensible.Field import Data.Extensible.Product import Data.Extensible.Sum-import Data.Extensible.Internal import Data.Extensible.Internal.Rig+import Data.Extensible.Nullable import Data.Constraint+import Data.Extensible.Struct import Data.Extensible.Wrapper-import Data.Profunctor.Unsafe+import Data.Hashable+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KM+#else+import qualified Data.HashMap.Strict as KM+#endif+import Data.Functor.Compose+import qualified Data.HashMap.Strict as HM+import Data.Incremental+import Data.Maybe (isJust)+import Data.Monoid (Any(..))+import Prettyprinter+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Generic.Mutable as M+import qualified Data.Vector.Unboxed as U+import Data.Type.Equality+import qualified Language.Haskell.TH.Lift as TH+#if MIN_VERSION_template_haskell(2,16,0)+import qualified Language.Haskell.TH.Syntax as TH+#endif+import Language.Haskell.TH hiding (Type)+import GHC.Records+import GHC.TypeLits+import Test.QuickCheck.Arbitrary+import Test.QuickCheck.Gen+import Type.Membership +#ifdef BARBIES+import Barbies+import Data.Functor.Product+#endif+ -- | Reify a collection of dictionaries, as you wish.-library :: forall c xs. Forall c xs => Comp Dict c :* xs-library = htabulateFor (Proxy :: Proxy c) $ const (Comp Dict)+library :: forall c xs. Forall c xs => xs :& Compose Dict c+library = hrepeatFor (Proxy :: Proxy c) $ Compose Dict {-# INLINE library #-} -newtype MergeList a = MergeList { getMerged :: [a] }+class (f x, g x) => And f g x+instance (f x, g x) => And f g x -instance Monoid (MergeList a) where- mempty = MergeList []- {-# INLINE mempty #-}- mappend (MergeList a) (MergeList b) = MergeList $ merge a b where- merge (x:xs) (y:ys) = x : y : merge xs ys- merge xs [] = xs- merge [] ys = ys- {-# INLINE mappend #-}+instance WrapForall Show h xs => Show (xs :& h) where+ showsPrec d xs = showParen (d > 0)+ $ henumerateFor (Proxy :: Proxy (Instance1 Show h)) (Proxy :: Proxy xs)+ (\i r -> showsPrec 0 (hlookup i xs) . showString " <: " . r)+ (showString "nil") -instance WrapForall Show h xs => Show (h :* xs) where- showsPrec d = showParen (d > 0)- . (.showString "Nil")- . foldr (.) id- . getMerged- . hfoldMap getConst'- . hzipWith (\(Comp Dict) h -> Const' $ MergeList [showsPrec 0 h . showString " <: "]) (library :: Comp Dict (Instance1 Show h) :* xs)+instance WrapForall Pretty h xs => Pretty (xs :& h) where+ pretty xs = align+ $ encloseSep (flatAlt "" "{ ") (flatAlt "" " }") (flatAlt "" "; ")+ $ henumerateFor (Proxy :: Proxy (Instance1 Pretty h)) (Proxy :: Proxy xs)+ (\i r -> pretty (hlookup i xs) : r)+ [] -instance WrapForall Eq h xs => Eq (h :* xs) where- xs == ys = getAll $ hfoldMap (All #. getConst')- $ hzipWith3 (\(Comp Dict) x y -> Const' $ x == y) (library :: Comp Dict (Instance1 Eq h) :* xs) xs ys++instance WrapForall Eq h xs => Eq (xs :& h) where+ xs == ys = henumerateFor (Proxy :: Proxy (Instance1 Eq h)) (Proxy :: Proxy xs)+ (\i r -> hlookup i xs == hlookup i ys && r) True {-# INLINE (==) #-} -instance (Eq (h :* xs), WrapForall Ord h xs) => Ord (h :* xs) where- compare xs ys = hfoldMap getConst'- $ hzipWith3 (\(Comp Dict) x y -> Const' $ compare x y) (library :: Comp Dict (Instance1 Ord h) :* xs) xs ys+instance (Eq (xs :& h), WrapForall Ord h xs) => Ord (xs :& h) where+ compare xs ys = henumerateFor (Proxy :: Proxy (Instance1 Ord h)) (Proxy :: Proxy xs)+ (\i r -> (hlookup i xs `compare` hlookup i ys) `mappend` r) mempty {-# INLINE compare #-} -instance WrapForall Monoid h xs => Monoid (h :* xs) where- mempty = hmap (\(Comp Dict) -> mempty) (library :: Comp Dict (Instance1 Monoid h) :* xs)+instance WrapForall Semigroup h xs => Semigroup (xs :& h) where+ (<>) = hzipWith3 (\(Compose Dict) -> (<>))+ (library :: xs :& Compose Dict (Instance1 Semigroup h))+ {-# INLINE (<>) #-}++instance (WrapForall Semigroup h xs, WrapForall Monoid h xs) => Monoid (xs :& h) where+ mempty = hrepeatFor (Proxy :: Proxy (Instance1 Monoid h)) mempty {-# INLINE mempty #-}- mappend xs ys = hzipWith3 (\(Comp Dict) -> mappend) (library :: Comp Dict (Instance1 Monoid h) :* xs) xs ys+ mappend = (<>) {-# INLINE mappend #-} -instance WrapForall Show h xs => Show (h :| xs) where+instance (WrapForall Eq h xs, WrapForall Hashable h xs) => Hashable (xs :& h) where+ hashWithSalt = hfoldlWithIndexFor (Proxy :: Proxy (Instance1 Hashable h))+ (const hashWithSalt)+ {-# INLINE hashWithSalt #-}++instance WrapForall Bounded h xs => Bounded (xs :& h) where+ minBound = hrepeatFor (Proxy :: Proxy (Instance1 Bounded h)) minBound+ maxBound = hrepeatFor (Proxy :: Proxy (Instance1 Bounded h)) maxBound++instance WrapForall TH.Lift h xs => TH.Lift (xs :& h) where+ lift = hfoldrWithIndexFor (Proxy :: Proxy (Instance1 TH.Lift h))+ (\_ x xs -> infixE (Just $ TH.lift x) (varE '(<:)) (Just xs)) (varE 'nil)+#if MIN_VERSION_template_haskell(2,17,0) + liftTyped e = TH.Code $ TH.TExp <$> TH.lift e+#elif MIN_VERSION_template_haskell(2,16,0)+ liftTyped e = TH.TExp <$> TH.lift e+#endif++newtype instance U.MVector s (xs :& h) = MV_Product (xs :& Compose (U.MVector s) h)+newtype instance U.Vector (xs :& h) = V_Product (xs :& Compose U.Vector h)++hlookupC :: Membership xs a -> xs :& Compose f g -> f (g a)+hlookupC i = getCompose . hlookup i++instance WrapForall U.Unbox h (x ': xs) => G.Vector U.Vector ((x ': xs) :& h) where+ basicUnsafeFreeze (MV_Product v) = fmap V_Product+ $ hgenerateFor (Proxy :: Proxy (Instance1 U.Unbox h))+ $ \m -> Compose <$> G.basicUnsafeFreeze (hlookupC m v)+ basicUnsafeThaw (V_Product v) = fmap MV_Product+ $ hgenerateFor (Proxy :: Proxy (Instance1 U.Unbox h))+ $ \m -> Compose <$> G.basicUnsafeThaw (hlookupC m v)+ basicLength (V_Product v) = G.basicLength $ getCompose $ hindex v leadership+ basicUnsafeSlice i n (V_Product v) = V_Product+ $ htabulateFor (Proxy :: Proxy (Instance1 U.Unbox h))+ $ \m -> Compose $ G.basicUnsafeSlice i n (hlookupC m v)+ basicUnsafeIndexM (V_Product v) i = hgenerateFor (Proxy :: Proxy (Instance1 U.Unbox h))+ $ \m -> G.basicUnsafeIndexM (hlookupC m v) i+ basicUnsafeCopy (MV_Product v) (V_Product w)+ = henumerateFor (Proxy :: Proxy (Instance1 U.Unbox h)) (Proxy :: Proxy (x ': xs)) ((>>) . \i -> G.basicUnsafeCopy (hlookupC i v) (hlookupC i w)) (return ())++instance WrapForall U.Unbox h (x ': xs) => M.MVector U.MVector ((x ': xs) :& h) where+ basicLength (MV_Product v) = M.basicLength $ getCompose $ hindex v leadership+ basicUnsafeSlice i n (MV_Product v) = MV_Product+ $ htabulateFor (Proxy :: Proxy (Instance1 U.Unbox h))+ $ \m -> Compose $ M.basicUnsafeSlice i n (hlookupC m v)+ basicOverlaps (MV_Product v1) (MV_Product v2) = henumerateFor+ (Proxy :: Proxy (Instance1 U.Unbox h)) (Proxy :: Proxy (x ': xs))+ (\i -> (||) $ M.basicOverlaps (hlookupC i v1) (hlookupC i v2))+ False+ basicUnsafeNew n = fmap MV_Product+ $ hgenerateFor (Proxy :: Proxy (Instance1 U.Unbox h))+ (const $ Compose <$> M.basicUnsafeNew n)+ basicInitialize (MV_Product v) = henumerateFor (Proxy :: Proxy (Instance1 U.Unbox h)) (Proxy :: Proxy (x ': xs)) ((>>) . \i -> M.basicInitialize $ hlookupC i v) (return ())+ basicUnsafeReplicate n x = fmap MV_Product+ $ hgenerateFor (Proxy :: Proxy (Instance1 U.Unbox h))+ $ \m -> fmap Compose $ M.basicUnsafeReplicate n $ hlookup m x+ basicUnsafeRead (MV_Product v) i = hgenerateFor (Proxy :: Proxy (Instance1 U.Unbox h))+ (\m -> M.basicUnsafeRead (hlookupC m v) i)+ basicUnsafeWrite (MV_Product v) i x = henumerateFor (Proxy :: Proxy (Instance1 U.Unbox h)) (Proxy :: Proxy (x ': xs)) ((>>) . \m -> M.basicUnsafeWrite (hlookupC m v) i (hlookup m x)) (return ())+ basicClear (MV_Product v) = henumerateFor (Proxy :: Proxy (Instance1 U.Unbox h)) (Proxy :: Proxy (x ': xs)) ((>>) . \i -> M.basicClear $ hlookupC i v) (return ())+ basicSet (MV_Product v) x = henumerateFor (Proxy :: Proxy (Instance1 U.Unbox h)) (Proxy :: Proxy (x ': xs)) ((>>) . \i -> M.basicSet (hlookupC i v) (hlookup i x)) (return ())+ basicUnsafeCopy (MV_Product v1) (MV_Product v2)+ = henumerateFor (Proxy :: Proxy (Instance1 U.Unbox h)) (Proxy :: Proxy (x ': xs)) ((>>) . \i -> M.basicUnsafeCopy (hlookupC i v1) (hlookupC i v2)) (return ())+ basicUnsafeMove (MV_Product v1) (MV_Product v2)+ = henumerateFor (Proxy :: Proxy (Instance1 U.Unbox h)) (Proxy :: Proxy (x ': xs)) ((>>) . \i -> M.basicUnsafeMove (hlookupC i v1) (hlookupC i v2)) (return ())+ basicUnsafeGrow (MV_Product v) n = fmap MV_Product+ $ hgenerateFor (Proxy :: Proxy (Instance1 U.Unbox h))+ $ \i -> Compose <$> M.basicUnsafeGrow (hlookupC i v) n++instance WrapForall U.Unbox h (x ': xs) => U.Unbox ((x ': xs) :& h)++instance WrapForall Arbitrary h xs => Arbitrary (xs :& h) where+ arbitrary = hgenerateFor (Proxy :: Proxy (Instance1 Arbitrary h)) (const arbitrary)+ shrink xs = henumerateFor (Proxy :: Proxy (Instance1 Arbitrary h))+ (Proxy :: Proxy xs) (\i -> (++)+ $ map (\x -> hmodify (\s -> set s i x) xs) $ shrink $ hindex xs i)+ []++instance WrapForall NFData h xs => NFData (xs :& h) where+ rnf xs = henumerateFor (Proxy :: Proxy (Instance1 NFData h)) (Proxy :: Proxy xs)+ (\i -> deepseq (hlookup i xs)) ()+ {-# INLINE rnf #-}++#ifdef CASSAVA+instance WrapForall Csv.FromField h xs => Csv.FromRecord (xs :& h) where+ parseRecord rec = hgenerateFor (Proxy :: Proxy (Instance1 Csv.FromField h))+ $ \i -> G.indexM rec (getMemberId i) >>= Csv.parseField++instance Forall (KeyTargetAre KnownSymbol (Instance1 Csv.FromField h)) xs => Csv.FromNamedRecord (xs :& Field h) where+ parseNamedRecord rec = hgenerateFor (Proxy :: Proxy (KeyTargetAre KnownSymbol (Instance1 Csv.FromField h)))+ $ \i -> rec Csv..: BC.pack (symbolVal (proxyKeyOf i)) >>= Csv.parseField++instance WrapForall Csv.ToField h xs => Csv.ToRecord (xs :& h) where+ toRecord = V.fromList+ . hfoldrWithIndexFor (Proxy :: Proxy (Instance1 Csv.ToField h))+ (\_ v -> (:) $ Csv.toField v) []++instance Forall (KeyTargetAre KnownSymbol (Instance1 Csv.ToField h)) xs => Csv.ToNamedRecord (xs :& Field h) where+ toNamedRecord = hfoldlWithIndexFor (Proxy :: Proxy (KeyTargetAre KnownSymbol (Instance1 Csv.ToField h)))+ (\k m v -> HM.insert (BC.pack (symbolVal (proxyKeyOf k))) (Csv.toField v) m)+ HM.empty++instance Forall (KeyIs KnownSymbol) xs => Csv.DefaultOrdered (RecordOf h xs) where+ headerOrder _ = V.fromList $ henumerateFor+ (Proxy :: Proxy (KeyIs KnownSymbol))+ (Proxy :: Proxy xs)+ (\k r -> stringKeyOf k : r) []+#endif++-- | @'parseJSON' 'J.Null'@ is called for missing fields.+instance Forall (KeyTargetAre KnownSymbol (Instance1 J.FromJSON h)) xs => J.FromJSON (xs :& Field h) where+ parseJSON = J.withObject "Object" $ \v -> hgenerateFor+ (Proxy :: Proxy (KeyTargetAre KnownSymbol (Instance1 J.FromJSON h)))+ $ \m -> let k = stringKeyOf m+ in fmap Field $ J.prependFailure ("parsing " ++ show k ++ ": ") $ J.parseJSON $ maybe J.Null id $ KM.lookup k v++instance Forall (KeyTargetAre KnownSymbol (Instance1 J.ToJSON h)) xs => J.ToJSON (xs :& Field h) where+ toJSON = J.Object . hfoldlWithIndexFor+ (Proxy :: Proxy (KeyTargetAre KnownSymbol (Instance1 J.ToJSON h)))+ (\k m v -> KM.insert (stringKeyOf k) (J.toJSON v) m)+ KM.empty++instance Forall (KeyTargetAre KnownSymbol (Instance1 J.FromJSON h)) xs => J.FromJSON (xs :& Nullable (Field h)) where+ parseJSON = J.withObject "Object" $ \v -> hgenerateFor+ (Proxy :: Proxy (KeyTargetAre KnownSymbol (Instance1 J.FromJSON h)))+ $ \m -> let k = stringKeyOf m+ in fmap Nullable $ traverse J.parseJSON $ KM.lookup k v++instance Forall (KeyTargetAre KnownSymbol (Instance1 J.ToJSON h)) xs => J.ToJSON (xs :& Nullable (Field h)) where+ toJSON = J.Object . hfoldlWithIndexFor+ (Proxy :: Proxy (KeyTargetAre KnownSymbol (Instance1 J.ToJSON h)))+ (\k m (Nullable v) -> maybe id (KM.insert (stringKeyOf k) . J.toJSON) v m)+ KM.empty++instance WrapForall Show h xs => Show (xs :/ h) where showsPrec d (EmbedAt i h) = showParen (d > 10) $ showString "EmbedAt " . showsPrec 11 i . showString " "- . views (pieceAt i) (\(Comp Dict) -> showsPrec 11 h) (library :: Comp Dict (Instance1 Show h) :* xs)+ . views (pieceAt i) (\(Compose Dict) -> showsPrec 11 h) (library :: xs :& Compose Dict (Instance1 Show h)) -instance WrapForall Eq h xs => Eq (h :| xs) where+instance WrapForall Eq h xs => Eq (xs :/ h) where EmbedAt p g == EmbedAt q h = case compareMembership p q of Left _ -> False- Right Refl -> views (pieceAt p) (\(Comp Dict) -> g == h) (library :: Comp Dict (Instance1 Eq h) :* xs)+ Right Refl -> views (pieceAt p) (\(Compose Dict) -> g == h) (library :: xs :& Compose Dict (Instance1 Eq h)) {-# INLINE (==) #-} -instance (Eq (h :| xs), WrapForall Ord h xs) => Ord (h :| xs) where+instance (Eq (xs :/ h), WrapForall Ord h xs) => Ord (xs :/ h) where EmbedAt p g `compare` EmbedAt q h = case compareMembership p q of Left x -> x- Right Refl -> views (pieceAt p) (\(Comp Dict) -> compare g h) (library :: Comp Dict (Instance1 Ord h) :* xs)+ Right Refl -> views (pieceAt p) (\(Compose Dict) -> compare g h) (library :: xs :& Compose Dict (Instance1 Ord h)) {-# INLINE compare #-} +instance WrapForall NFData h xs => NFData (xs :/ h) where+ rnf (EmbedAt i h) = views (pieceAt i) (\(Compose Dict) -> rnf h) (library :: xs :& Compose Dict (Instance1 NFData h))+ {-# INLINE rnf #-}++instance (WrapForall Eq h xs, WrapForall Hashable h xs) => Hashable (xs :/ h) where+ hashWithSalt s (EmbedAt i h) = views (pieceAt i)+ (\(Compose Dict) -> s `hashWithSalt` i `hashWithSalt` h)+ (library :: xs :& Compose Dict (Instance1 Hashable h))+ {-# INLINE hashWithSalt #-}++instance WrapForall TH.Lift h xs => TH.Lift (xs :/ h) where+ lift (EmbedAt i h) = views (pieceAt i)+ (\(Compose Dict) -> conE 'EmbedAt `appE` TH.lift i `appE` TH.lift h)+ (library :: xs :& Compose Dict (Instance1 TH.Lift h))+#if MIN_VERSION_template_haskell(2,17,0)+ liftTyped e = TH.Code $ TH.TExp <$> TH.lift e+#elif MIN_VERSION_template_haskell(2,16,0)+ liftTyped e = TH.TExp <$> TH.lift e+#endif++instance WrapForall Arbitrary h xs => Arbitrary (xs :/ h) where+ arbitrary = choose (0, hcount (Proxy :: Proxy xs)) >>= henumerateFor+ (Proxy :: Proxy (Instance1 Arbitrary h))+ (Proxy :: Proxy xs)+ (\m r i -> if i == 0+ then EmbedAt m <$> arbitrary+ else r (i - 1))+ (error "Impossible")+ shrink (EmbedAt i h) = views (pieceAt i)+ (\(Compose Dict) -> EmbedAt i <$> shrink h)+ (library :: xs :& Compose Dict (Instance1 Arbitrary h))++instance WrapForall Pretty h xs => Pretty (xs :/ h) where+ pretty (EmbedAt i h) = "EmbedAt "+ <> pretty i+ <> " "+ <> views (pieceAt i) (\(Compose Dict) -> pretty h)+ (library :: xs :& Compose Dict (Instance1 Pretty h))+ -- | Forall upon a wrapper type WrapForall c h = Forall (Instance1 c h) -- | Composition for a class and a wrapper class c (h x) => Instance1 c h x instance c (h x) => Instance1 c h x++#ifdef BARBIES+instance FunctorB ((:&) xs) where+ bmap = hmap++instance FunctorB ((:/) xs) where+ bmap = hoist++instance TraversableB ((:&) xs) where+ btraverse = htraverse++instance TraversableB ((:/) xs) where+ btraverse f (EmbedAt i x) = EmbedAt i <$> f x++instance Generate xs => ApplicativeB ((:&) xs) where+ bprod = hzipWith Pair+ bpure = hrepeat++instance ConstraintsB ((:&) xs) where+ type AllB c ((:&) xs) = Forall c xs+ baddDicts = bprod bdicts++instance ConstraintsB ((:/) xs) where+ type AllB c ((:/) xs) = Forall c xs+ baddDicts (EmbedAt i x) = EmbedAt i (Pair (hlookup i bdicts) x)++#endif++instance WrapForall Incremental h xs => Incremental (xs :& h) where+ type Delta (xs :& h) = xs :& WrapDelta h+ patch r =+ hmapWithIndexFor+ (Proxy :: Proxy (Instance1 Incremental h))+ (\i (WrapDelta d) -> maybe (hlookup i r) (patch (hlookup i r)) d)+ diff r =+ check+ . hmapWithIndexFor+ (Proxy :: Proxy (Instance1 Incremental h))+ (\i x -> WrapDelta (diff (hlookup i r) x))+ where+ check t+ | getAny $ hfoldMap (Any . isJust . unwrapDelta) t = Just t+ | otherwise = Nothing++instance (Lookup xs k v, Wrapper h, Repr h v ~ a) => HasField k (RecordOf h xs) a where+ getField = unwrap . hlookup (association :: Membership xs (k >: v))
− src/Data/Extensible/Effect.hs
@@ -1,95 +0,0 @@-{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances #-} -module Data.Extensible.Effect (Instruction(..) - , Eff - , liftEff - , hoistEff - , handleWith - , Handler(..) - -- * Unnamed actions - , Action(..) - , Function - , receive - -- * Successive handling - , (!-!!) - , squash - , nihility) where - -import Control.Monad.Skeleton -import Data.Extensible.Field -import Data.Extensible.Internal -import Data.Extensible.Internal.Rig -import Data.Extensible.Class -import Data.Profunctor.Unsafe -- Trustworthy since 7.8 - --- | Unnamed action -data Action (args :: [*]) a r where - AResult :: Action '[] a a - AArgument :: x -> Action xs a r -> Action (x ': xs) a r - -type family Function args r :: * where - Function '[] r = r - Function (x ': xs) r = x -> Function xs r - --- | Transformation between effects -newtype Handler f g = Handler { runHandler :: forall a. g a -> f a } - -receive :: Functor f => Function xs (f a) -> Handler f (Action xs a) -receive f0 = Handler (go f0) where - go :: Functor f => Function xs (f a) -> Action xs a r -> f r - go r AResult = r - go f (AArgument x a) = go (f x) a - ----------------------------------------------- - --- | A unit of effects -data Instruction (xs :: [Assoc k (* -> *)]) a where - Instruction :: !(Membership xs kv) -> AssocValue kv a -> Instruction xs a - --- | The extensible operational monad -type Eff xs = Skeleton (Instruction xs) - --- | Lift some effect to 'Eff' -liftEff :: forall proxy s t xs a. Associate s t xs => proxy s -> t a -> Eff xs a -liftEff _ x = bone (Instruction (association :: Membership xs (s ':> t)) x) -{-# INLINE liftEff #-} - -hoistEff :: forall proxy s t xs a. Associate s t xs => proxy s -> (forall x. t x -> t x) -> Eff xs a -> Eff xs a -hoistEff _ f = hoistSkeleton $ \(Instruction i t) -> case compareMembership (association :: Membership xs (s ':> t)) i of - Right Refl -> Instruction i (f t) - _ -> Instruction i t -{-# INLINABLE hoistEff #-} - -handleWith :: RecordOf (Handler m) xs -> Eff xs a -> MonadView m (Eff xs) a -handleWith hs m = case unbone m of - Instruction i t :>>= k -> views (pieceAt i) (runHandler .# getField) hs t :>>= k - Return a -> Return a -{-# INLINABLE handleWith #-} - -(!-!!) :: Monad m => (forall x. t x -> m x) - -> (forall x. Eff xs x -> m x) - -> Eff ((s ':> t) ': xs) a -> m a -f !-!! g = go where - go m = case unbone m of - Return a -> return a - Instruction i t :>>= k -> runMembership i - (\Refl -> f t >>= go . k) - (\j -> g (bone (Instruction j t)) >>= go . k) -{-# INLINE (!-!!) #-} -infixr 0 !-!! - -nihility :: Monad m => Eff '[] a -> m a -nihility m = case unbone m of - Return a -> return a - Instruction i _ :>>= _ -> impossibleMembership i - --- | @'squash' = ('!-!!' 'id')@ -squash :: (forall x. t x -> Eff xs x) -> Eff ((s ':> t) ': xs) a -> Eff xs a -squash f = go where - go m = case unbone m of - Return a -> return a - Instruction i t :>>= k -> runMembership i - (\Refl -> f t >>= go . k) - (\j -> boned $ Instruction j t :>>= go . k) -{-# INLINE squash #-}
src/Data/Extensible/Field.hs view
@@ -1,28 +1,31 @@ {-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ScopedTypeVariables, TypeFamilies #-}-#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableSuperClasses #-}-#endif+{-# LANGUAGE PolyKinds #-} ----------------------------------------------------------------------------- -- |--- Module : Data.Extensible.Record--- Copyright : (c) Fumiaki Kinoshita 2015+-- Module : Data.Extensible.Field+-- Copyright : (c) Fumiaki Kinoshita 2018 -- License : BSD3 -- -- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability : experimental--- Portability : non-portable -- -- Flexible records and variants--- Example: <https://github.com/fumieval/extensible/blob/master/examples/records.hs> ------------------------------------------------------------------------ module Data.Extensible.Field ( Field(..) , (@=) , (<@=>) , (@:>)+ , (@==) , FieldOptic- , FieldName+ , xlb+ , liftField+ , liftField2 -- * Records and variants , RecordOf , Record@@ -33,51 +36,143 @@ , matchWithField , matchField -- * Key / value- , AssocKey- , AssocValue- , KeyValue- , proxyAssocKey- -- * Internal- , LabelPhantom- , Labelling- , Inextensible+ , KeyOf+ , proxyKeyOf+ , stringKeyOf+ , TargetOf+ , proxyTargetOf+ , KeyIs+ , TargetIs+ , KeyTargetAre ) where+import Control.DeepSeq (NFData)+import qualified Data.Aeson as J+import Data.Coerce+#ifdef CASSAVA+import qualified Data.Csv as Csv+#endif import Data.Extensible.Class import Data.Extensible.Sum import Data.Extensible.Match import Data.Extensible.Product-import Data.Extensible.Internal import Data.Extensible.Internal.Rig+import Data.Kind import Data.Profunctor.Unsafe-import Data.Constraint import Data.Extensible.Wrapper+import Data.Functor.Compose import Data.Functor.Identity+import Data.Hashable+import Data.Incremental (Incremental)+import Data.String+import Prettyprinter+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Generic.Mutable as M+import qualified Data.Vector.Unboxed as U+import Foreign.Storable (Storable)+import GHC.OverloadedLabels+import GHC.Generics (Generic) import GHC.TypeLits hiding (Nat)+import Language.Haskell.TH.Lift+import Test.QuickCheck.Arbitrary+import Type.Membership --- | Take the type of the key-type family AssocKey (kv :: Assoc k v) :: k where- AssocKey (k ':> v) = k+-- | A @'Field' h (k ':> v)@ is @h v@ annotated with the field name @k@.+--+-- @'Field' :: (v -> Type) -> Assoc k v -> Type@+--+newtype Field (h :: v -> Type) (kv :: Assoc k v)+ = Field { getField :: h (TargetOf kv) } --- | Proxy-level 'AssocKey'. This is useful when using 'symbolVal'.-proxyAssocKey :: proxy kv -> Proxy (AssocKey kv)-proxyAssocKey _ = Proxy+ deriving (Generic) --- | Take the type of the value-type family AssocValue (kv :: Assoc k v) :: v where- AssocValue (k ':> v) = v+#define ND_Field(c) deriving instance c (h (TargetOf kv)) => c (Field h kv) -class (pk (AssocKey kv), pv (AssocValue kv)) => KeyValue pk pv kv where+ND_Field(Eq)+ND_Field(Ord)+ND_Field(Num)+ND_Field(Integral)+ND_Field(Fractional)+ND_Field(Floating)+ND_Field(Real)+ND_Field(RealFloat)+ND_Field(RealFrac)+ND_Field(Semigroup)+ND_Field(Storable)+ND_Field(Monoid)+ND_Field(Enum)+ND_Field(Bounded)+ND_Field(NFData)+ND_Field(Arbitrary)+ND_Field(Hashable)+ND_Field(J.FromJSON)+ND_Field(J.ToJSON)+#ifdef CASSAVA+ND_Field(Csv.FromField)+ND_Field(Csv.ToField)+#endif+ND_Field(Incremental)+ND_Field(Lift) -instance (pk k, pv v) => KeyValue pk pv (k ':> v)+newtype instance U.MVector s (Field h x) = MV_Field (U.MVector s (h (TargetOf x)))+newtype instance U.Vector (Field h x) = V_Field (U.Vector (h (TargetOf x))) --- | A @'Field' h (k ':> v)@ is @h v@ annotated with the field name @k@.------ @'Field' :: (v -> *) -> Assoc k v -> *@----newtype Field (h :: v -> *) (kv :: Assoc k v) = Field { getField :: h (AssocValue kv) }+instance (U.Unbox (h (TargetOf x))) => M.MVector U.MVector (Field h x) where+ {-# INLINE basicLength #-}+ {-# INLINE basicUnsafeSlice #-}+ {-# INLINE basicOverlaps #-}+ {-# INLINE basicUnsafeNew #-}+ {-# INLINE basicUnsafeReplicate #-}+ {-# INLINE basicUnsafeRead #-}+ {-# INLINE basicUnsafeWrite #-}+ {-# INLINE basicClear #-}+ {-# INLINE basicSet #-}+ {-# INLINE basicUnsafeCopy #-}+ {-# INLINE basicUnsafeGrow #-}+ basicLength (MV_Field v) = M.basicLength v+ basicUnsafeSlice i n (MV_Field v) = MV_Field $ M.basicUnsafeSlice i n v+ basicOverlaps (MV_Field v1) (MV_Field v2) = M.basicOverlaps v1 v2+ basicUnsafeNew n = MV_Field <$> M.basicUnsafeNew n+#if MIN_VERSION_vector(0,11,0)+ basicInitialize (MV_Field v) = M.basicInitialize v+ {-# INLINE basicInitialize #-}+#endif+ basicUnsafeReplicate n (Field x) = MV_Field <$> M.basicUnsafeReplicate n x+ basicUnsafeRead (MV_Field v) i = Field <$> M.basicUnsafeRead v i+ basicUnsafeWrite (MV_Field v) i (Field x) = M.basicUnsafeWrite v i x+ basicClear (MV_Field v) = M.basicClear v+ basicSet (MV_Field v) (Field x) = M.basicSet v x+ basicUnsafeCopy (MV_Field v1) (MV_Field v2) = M.basicUnsafeCopy v1 v2+ basicUnsafeMove (MV_Field v1) (MV_Field v2) = M.basicUnsafeMove v1 v2+ basicUnsafeGrow (MV_Field v) n = MV_Field <$> M.basicUnsafeGrow v n +instance (U.Unbox (h (TargetOf x))) => G.Vector U.Vector (Field h x) where+ {-# INLINE basicUnsafeFreeze #-}+ {-# INLINE basicUnsafeThaw #-}+ {-# INLINE basicLength #-}+ {-# INLINE basicUnsafeSlice #-}+ {-# INLINE basicUnsafeIndexM #-}+ basicUnsafeFreeze (MV_Field v) = V_Field <$> G.basicUnsafeFreeze v+ basicUnsafeThaw (V_Field v) = MV_Field <$> G.basicUnsafeThaw v+ basicLength (V_Field v) = G.basicLength v+ basicUnsafeSlice i n (V_Field v) = V_Field $ G.basicUnsafeSlice i n v+ basicUnsafeIndexM (V_Field v) i = Field <$> G.basicUnsafeIndexM v i+ basicUnsafeCopy (MV_Field mv) (V_Field v) = G.basicUnsafeCopy mv v++instance (U.Unbox (h (TargetOf x))) => U.Unbox (Field h x)++-- | Lift a function for the content.+liftField :: (g (TargetOf kv) -> h (TargetOf kv)) -> Field g kv -> Field h kv+liftField = coerce+{-# INLINE liftField #-}++-- | Lift a function for the content.+liftField2 :: (f (TargetOf kv) -> g (TargetOf kv) -> h (TargetOf kv))+ -> Field f kv -> Field g kv -> Field h kv+liftField2 = coerce+{-# INLINE liftField2 #-}+ instance Wrapper h => Wrapper (Field h) where- type Repr (Field h) kv = Repr h (AssocValue kv)+ type Repr (Field h) kv = Repr h (TargetOf kv) _Wrapper = dimap getField (fmap Field) . _Wrapper {-# INLINE _Wrapper #-} @@ -87,33 +182,32 @@ . showString " @= " . showsPrec 1 (view _Wrapper a) -instance Monoid (h (AssocValue kv)) => Monoid (Field h kv) where- mempty = Field mempty- {-# INLINE mempty #-}- Field a `mappend` Field b = Field (mappend a b)- {-# INLINE mappend #-}+instance (KnownSymbol k, Pretty (h v)) => Pretty (Field h (k ':> v)) where+ pretty (Field a) = fromString (symbolVal (Proxy :: Proxy k))+ <> ": "+ <> pretty a -- | The type of records which contain several fields. ----- @RecordOf :: (v -> *) -> [Assoc k v] -> *@+-- @RecordOf :: (v -> Type) -> [Assoc k v] -> Type@ ---type RecordOf h = (:*) (Field h)+type RecordOf h xs = xs :& Field h -- | The dual of 'RecordOf' ----- @VariantOf :: (v -> *) -> [Assoc k v] -> *@+-- @VariantOf :: (v -> Type) -> [Assoc k v] -> Type@ ---type VariantOf h = (:|) (Field h)+type VariantOf h xs = xs :/ Field h -- | Simple record-type Record = RecordOf Identity+type Record xs = RecordOf Identity xs -- | Simple variant-type Variant = VariantOf Identity+type Variant xs = VariantOf Identity xs -- | An empty 'Record'. emptyRecord :: Record '[]-emptyRecord = Nil+emptyRecord = nil {-# INLINE emptyRecord #-} -- | Select a corresponding field of a variant.@@ -121,6 +215,7 @@ matchWithField h = matchWith (\(Field x) (Field y) -> h x y) {-# INLINE matchWithField #-} +-- | Pattern matching on a 'Variant' matchField :: RecordOf (Match h r) xs -> VariantOf h xs -> r matchField = matchWithField runMatch {-# INLINE matchField #-}@@ -134,56 +229,60 @@ -- for 'Variant's. -- -- @--- 'FieldOptic' "foo" = Associate "foo" a xs => Lens' ('Record' xs) a--- 'FieldOptic' "foo" = Associate "foo" a xs => Prism' ('Variant' xs) a+-- 'FieldOptic' "foo" = Lookup xs "foo" a => Lens' ('Record' xs) a+-- 'FieldOptic' "foo" = Lookup xs "foo" a => Prism' ('Variant' xs) a -- @ -- -- 'FieldOptic's can be generated using 'mkField' defined in the "Data.Extensible.TH" module. ---#if __GLASGOW_HASKELL__ >= 800-type FieldOptic k = forall kind. forall f p t xs (h :: kind -> *) (v :: kind).-#else-type FieldOptic k = forall f p t xs (h :: kind -> *) (v :: kind).-#endif+type FieldOptic k = forall kind. forall f p t xs (h :: kind -> Type) (v :: kind). (Extensible f p t- , Associate k v xs- , Labelling k p+ , ExtensibleConstr t xs (Field h) (k ':> v)+ , Lookup xs k v , Wrapper h)- => Optic' p f (t (Field h) xs) (Repr h v)---- | The trivial inextensible data type-data Inextensible (h :: k -> *) (xs :: [k])--instance (Functor f, Profunctor p) => Extensible f p Inextensible where- pieceAt _ _ = error "Impossible"---- | When you see this type as an argument, it expects a 'FieldLens'.--- This type is used to resolve the name of the field internally.-type FieldName k = Optic' (LabelPhantom k) Proxy (Inextensible (Field Proxy) '[k ':> ()]) ()--type family Labelling s p :: Constraint where- Labelling s (LabelPhantom t) = s ~ t- Labelling s p = ()+ => Optic' p f (t xs (Field h)) (Repr h v) --- | A ghostly type which spells the field name-data LabelPhantom s a b+instance k ~ l => IsLabel k (Proxy l) where+ fromLabel = Proxy -instance Profunctor (LabelPhantom s) where- dimap _ _ _ = error "Impossible"+-- | Specialised version of 'itemAssoc'. Stands for "eXtensible LaBel"+xlb :: Proxy k -> FieldOptic k+xlb t = itemAssoc t -- | Annotate a value by the field name.-(@=) :: Wrapper h => FieldName k -> Repr h v -> Field h (k ':> v)+--+-- @+-- foo :: 'Record' '["num" >: Int, "str" >: String]+-- foo = #num \@= 42+-- <: #str \@= "foo"+-- <: nil+-- @+(@=) :: Wrapper h => Proxy k -> Repr h v -> Field h (k ':> v) (@=) _ = Field #. review _Wrapper {-# INLINE (@=) #-} infix 1 @= -- | Lifted ('@=')-(<@=>) :: (Functor f, Wrapper h) => FieldName k -> f (Repr h v) -> Comp f (Field h) (k ':> v)-(<@=>) k = Comp #. fmap (k @=)+--+-- @+-- foo :: IO ('Record' '["num" >: Int, "str" >: String])+-- foo = hsequence+-- $ #num \<\@=\> readLn+-- <: #str \<\@=\> getLine+-- <: nil+-- @+(<@=>) :: (Functor f, Wrapper h) => Proxy k -> f (Repr h v) -> Compose f (Field h) (k ':> v)+(<@=>) k = comp (k @=) {-# INLINE (<@=>) #-} infix 1 <@=> -- | Annotate a value by the field name without 'Wrapper'.-(@:>) :: FieldName k -> h v -> Field h (k ':> v)+(@:>) :: Proxy k -> h v -> Field h (k ':> v) (@:>) _ = Field infix 1 @:>++-- | Kind-monomorphic, unwrapped version of '@='+(@==) :: Proxy (k :: Symbol) -> v -> Field Identity (k ':> v)+(@==) = (@=)+{-# INLINE (@==) #-}+infix 1 @==
+ src/Data/Extensible/GetOpt.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE TypeFamilies, LambdaCase, DeriveFunctor, StandaloneDeriving #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Extensible.GetOpt+-- Copyright : (c) Fumiaki Kinoshita 2018+-- License : BSD3+--+-- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>+--+-- A wrapper for 'System.Console.GetOpt'.+--+-- See also: <https://www.schoolofhaskell.com/user/fumieval/extensible/getopt-and-extensible-records GetOpt and extensible records - School of Haskell>+--+--------------------------------------------------------------------------------+module Data.Extensible.GetOpt (OptionDescr(..)+ , OptDescr'+ , getOptRecord+ , withGetOpt+ -- * Basic descriptors+ , optFlag+ , optLastArg+ -- * More generic descriptors+ , optNoArg+ , optReqArg+ , optionNoArg+ , optionReqArg+ , optionOptArg) where++import Control.Monad.IO.Class+import Data.Extensible.Class+import Data.Extensible.Field+import Data.Extensible.Internal.Rig+import Data.Extensible.Product+import Data.Extensible.Wrapper+import Data.Functor.Identity+import Data.List (foldl')+import System.Console.GetOpt+import System.Environment+import System.Exit+import System.IO++-- | 'OptDescr' with a default+data OptionDescr h a = forall s. OptionDescr (s -> h a) !s (OptDescr (s -> s))++deriving instance Functor h => Functor (OptionDescr h)++supplyOption :: Maybe String -> OptionDescr h a -> OptionDescr h a+supplyOption str od@(OptionDescr k s opt@(Option _ _ arg _)) = case (str, arg) of+ (Just a, ReqArg f _) -> OptionDescr k (f a s) opt+ (Nothing, NoArg f) -> OptionDescr k (f s) opt+ (a, OptArg f _) -> OptionDescr k (f a s) opt+ _ -> od++extendArg :: (Maybe String -> a -> b) -> ArgDescr a -> ArgDescr b+extendArg f (NoArg a) = NoArg $ f Nothing a+extendArg f (ReqArg a ph) = ReqArg (\s -> f (Just s) (a s)) ph+extendArg f (OptArg a ph) = OptArg (f <*> a) ph++-- | Simple option descriptor+type OptDescr' = OptionDescr Identity++instance Wrapper (OptionDescr h) where+ type Repr (OptionDescr h) a = OptionDescr h a+ _Wrapper = id++-- | Option without an argument; the result is the total count of this option.+optNoArg :: [Char] -- ^ short option+ -> [String] -- ^ long option+ -> String -- ^ explanation+ -> OptDescr' Int+optNoArg = optionNoArg Identity++-- | True when specified+optFlag :: [Char] -- ^ short option+ -> [String] -- ^ long option+ -> String -- ^ explanation+ -> OptDescr' Bool+optFlag = optionNoArg (pure . (>0))++-- | Wrapper-generic version of `optNoArg`+optionNoArg :: (Int -> h a) -> [Char] -> [String] -> String -> OptionDescr h a+optionNoArg f ss ls expl = OptionDescr f 0 $ Option ss ls (NoArg (+1)) expl++-- | Option with an argument+optReqArg :: [Char] -- ^ short option+ -> [String] -- ^ long option+ -> String -- ^ placeholder+ -> String -- ^ explanation+ -> OptDescr' [String]+optReqArg = optionReqArg Identity++-- | Takes the last argument when more than one is specified.+optLastArg :: [Char] -- ^ short option+ -> [String] -- ^ long option+ -> String -- ^ placeholder+ -> String -- ^ explanation+ -> OptDescr' (Maybe String)+optLastArg ss ls ph expl = OptionDescr pure Nothing $ Option ss ls (ReqArg (const . Just) ph) expl++-- | Wrapper-generic version of `optReqArg`+optionReqArg :: ([String] -> h a) -> [Char] -> [String] -> String -> String -> OptionDescr h a+optionReqArg f ss ls ph expl = OptionDescr f [] $ Option ss ls (ReqArg (:) ph) expl++-- | Construct an option with an optional argument+optionOptArg :: ([Maybe String] -> h a) -> [Char] -> [String] -> String -> String -> OptionDescr h a+optionOptArg f ss ls ph expl = OptionDescr f [] $ Option ss ls (OptArg (:) ph) expl++-- | Parse option arguments.+getOptRecord :: RecordOf (OptionDescr h) xs -- ^ a record of option descriptors+ -> [String] -- ^ arguments+ -> (RecordOf h xs, [String], [String], String -> String) -- ^ (result, remaining non-options, errors, usageInfo)+getOptRecord descs args = (result, rs, es, flip usageInfo updaters) where+ (fs, rs, es) = getOpt Permute updaters args+ updaters = hfoldrWithIndex+ (\i (Field (OptionDescr _ _ (Option ss ls arg expl))) -> (:)+ $ Option ss ls (extendArg (\a _ -> over (pieceAt i) (liftField (supplyOption a))) arg) expl)+ [] descs+ result = hmap (\(Field (OptionDescr k x _)) -> Field (k x))+ $ foldl' (flip id) descs fs++-- | An all-in-one utility function.+-- When there's an error, print it along with the usage info to stderr+-- and terminate with 'exitFailure'.+withGetOpt :: MonadIO m => String -- ^ Non-option usage+ -> RecordOf (OptionDescr h) xs -- ^ option desciptors+ -> (RecordOf h xs -> [String] -> m a) -- ^ the result and non-option arguments+ -> m a+withGetOpt nonOptUsage descs k = getOptRecord descs <$> liftIO getArgs >>= \case+ (r, xs, [], _) -> k r xs+ (_, _, errs, usage) -> liftIO $ do+ mapM_ (hPutStrLn stderr) errs+ getProgName >>= die . usage . (++ (' ' : nonOptUsage))
src/Data/Extensible/Inclusion.hs view
@@ -1,23 +1,20 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-} ------------------------------------------------------------------------ -- | -- Module : Data.Extensible.Inclusion--- Copyright : (c) Fumiaki Kinoshita 2015+-- Copyright : (c) Fumiaki Kinoshita 2018 -- License : BSD3 -- -- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability : experimental--- Portability : non-portable -- ------------------------------------------------------------------------ module Data.Extensible.Inclusion ( -- * Inclusion-#if __GLASGOW_HASKELL__ >= 800 type (⊆)-#else- (⊆)()-#endif , Include , inclusion , shrink@@ -25,16 +22,18 @@ -- * Key-value , IncludeAssoc , Associated+ , Associated' , inclusionAssoc , shrinkAssoc , spreadAssoc ) where +import Data.Constraint import Data.Extensible.Class import Data.Extensible.Product import Data.Extensible.Sum-import Data.Extensible.Internal import Data.Extensible.Internal.Rig+import Data.Proxy -- | Unicode alias for 'Include' type xs ⊆ ys = Include ys xs@@ -43,43 +42,46 @@ type Include ys = Forall (Member ys) -- | Reify the inclusion of type level sets.-inclusion :: forall xs ys. Include ys xs => Membership ys :* xs-inclusion = htabulateFor (Proxy :: Proxy (Member ys)) (const membership)+inclusion :: forall xs ys. Include ys xs => xs :& Membership ys+inclusion = hrepeatFor (Proxy :: Proxy (Member ys)) membership {-# INLINABLE inclusion #-} --- | /O(m log n)/ Select some elements.-shrink :: (xs ⊆ ys) => h :* ys -> h :* xs+-- | /O(n)/ Select some elements.+shrink :: (xs ⊆ ys) => ys :& h -> xs :& h shrink h = hmap (hindex h) inclusion {-# INLINE shrink #-} --- | /O(log n)/ Embed to a larger union.-spread :: (xs ⊆ ys) => h :| xs -> h :| ys+-- | /O(1)/ Embed to a larger union.+spread :: (xs ⊆ ys) => xs :/ h -> ys :/ h spread (EmbedAt i h) = views (pieceAt i) EmbedAt inclusion h {-# INLINE spread #-} ------------------------------------------------------------------ -class Associated xs t where+type family Associated' (xs :: [Assoc k v]) (t :: Assoc k v) :: Constraint where+ Associated' xs (k ':> v) = Lookup xs k v++-- | @'Associated' xs (k ':> v)@ is equivalent to @'Associate' k v xs@+class Associated' xs t => Associated xs t where getAssociation :: Membership xs t -instance Associate k v xs => Associated xs (k ':> v) where+instance (Associated' xs t, t ~ (k ':> v)) => Associated xs t where getAssociation = association- {-# INLINE getAssociation #-} -- | Similar to 'Include', but this focuses on keys. type IncludeAssoc ys = Forall (Associated ys) -- | Reify the inclusion of type level sets.-inclusionAssoc :: forall xs ys. IncludeAssoc ys xs => Membership ys :* xs-inclusionAssoc = htabulateFor (Proxy :: Proxy (Associated ys)) (const getAssociation)+inclusionAssoc :: forall xs ys. IncludeAssoc ys xs => xs :& Membership ys+inclusionAssoc = hrepeatFor (Proxy :: Proxy (Associated ys)) getAssociation {-# INLINABLE inclusionAssoc #-} --- | /O(m log n)/ Select some elements.-shrinkAssoc :: (IncludeAssoc ys xs) => h :* ys -> h :* xs+-- | /O(n)/ Select some elements.+shrinkAssoc :: (IncludeAssoc ys xs) => ys :& h -> xs :& h shrinkAssoc h = hmap (hindex h) inclusionAssoc {-# INLINE shrinkAssoc #-} --- | /O(log n)/ Embed to a larger union.-spreadAssoc :: (IncludeAssoc ys xs) => h :| xs -> h :| ys+-- | /O(1)/ Embed to a larger union.+spreadAssoc :: (IncludeAssoc ys xs) => xs :/ h -> ys :/ h spreadAssoc (EmbedAt i h) = views (pieceAt i) EmbedAt inclusionAssoc h {-# INLINE spreadAssoc #-}
− src/Data/Extensible/Internal.hs
@@ -1,281 +0,0 @@-{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances, FunctionalDependencies #-} -{-# LANGUAGE ScopedTypeVariables, BangPatterns, StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Extensible.Inclusion --- Copyright : (c) Fumiaki Kinoshita 2015 --- License : BSD3 --- --- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com> --- Stability : experimental --- Portability : non-portable --- --- A bunch of combinators that contains magic ------------------------------------------------------------------------- -module Data.Extensible.Internal ( - -- * Membership - Membership - , getMemberId - , mkMembership - , reifyMembership - , runMembership - , compareMembership - , impossibleMembership - -- * Member class - , Member(..) - , remember -#if __GLASGOW_HASKELL__ >= 800 - , type (∈) -#else - , (∈)() -#endif - , FindType - -- * Association - , Assoc(..) - , Associate(..) - , FindAssoc - -- * Sugar - , Elaborate - , Elaborated(..) - -- * Tree navigation - , NavHere(..) - , navigate - , here - , navNext - , navL - , navR - -- * Miscellaneous - , Nat(..) - , KnownPosition(..) - , Succ - , Half - , Head - , Tail - , Last -#if __GLASGOW_HASKELL__ >= 800 - , type (++) -#else - , (++)() -#endif - , Map - , Merge - , Concat - , module Data.Type.Equality - , module Data.Proxy - ) where -import Data.Type.Equality -import Data.Proxy -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -import Data.Word -#endif -import Control.Monad -import Unsafe.Coerce -import Data.Typeable -import Language.Haskell.TH hiding (Pred) -import Data.Bits - --- | Generates a 'Membership' that corresponds to the given ordinal (0-origin). -mkMembership :: Int -> Q Exp -mkMembership n = do - let names = map mkName $ take (n + 1) $ concatMap (flip replicateM ['a'..'z']) [1..] - let rest = mkName "any" - let cons x xs = PromotedConsT `AppT` x `AppT` xs - let t = foldr cons (VarT rest) (map VarT names) - sigE (conE 'Membership `appE` litE (IntegerL $ toInteger n)) - $ forallT (PlainTV rest : map PlainTV names) (pure []) - $ conT ''Membership `appT` pure t `appT` varT (names !! n) - --- | The position of @x@ in the type level set @xs@. -newtype Membership (xs :: [k]) (x :: k) = Membership { getMemberId :: Word } deriving Typeable - -newtype Remembrance xs x r = Remembrance (Member xs x => r) - --- | Remember that @Member xs x@ from 'Membership'. -remember :: forall xs x r. Membership xs x -> (Member xs x => r) -> r -remember i r = unsafeCoerce (Remembrance r :: Remembrance xs x r) i -{-# INLINE remember #-} - -class Member xs x where - membership :: Membership xs x - -instance (Elaborate x (FindType x xs) ~ 'Expecting pos, KnownPosition pos) => Member xs x where - membership = Membership (theInt (Proxy :: Proxy pos)) - {-# INLINE membership #-} - -reifyMembership :: Word -> (forall x. Membership xs x -> r) -> r -reifyMembership n k = k (Membership n) - --- | The kind of key-value pairs -data Assoc k v = k :> v -infix 0 :> - --- | @'Associate' k v xs@ is essentially identical to @(k :> v) ∈ xs@ --- , but the type @v@ is inferred from @k@ and @xs@. -class Associate k v xs | k xs -> v where - association :: Membership xs (k ':> v) - -instance (Elaborate k (FindAssoc k xs) ~ 'Expecting (n ':> v), KnownPosition n) => Associate k v xs where - association = Membership (theInt (Proxy :: Proxy n)) - -data Elaborated k v = Expecting v | Missing k | Duplicate k - -type family Elaborate (key :: k) (xs :: [v]) :: Elaborated k v where - Elaborate k '[] = 'Missing k - Elaborate k '[x] = 'Expecting x - Elaborate k xs = 'Duplicate k - -type family FindAssoc (key :: k) (xs :: [Assoc k v]) where - FindAssoc k ((k ':> v) ': xs) = ('Zero ':> v) ': MapSuccKey (FindAssoc k xs) - FindAssoc k ((k' ':> v) ': xs) = MapSuccKey (FindAssoc k xs) - FindAssoc k '[] = '[] - -type family MapSuccKey (xs :: [Assoc Nat v]) :: [Assoc Nat v] where - MapSuccKey '[] = '[] - MapSuccKey ((k ':> x) ': xs) = (Succ k ':> x) ': MapSuccKey xs - -instance Show (Membership xs x) where - show (Membership n) = "$(mkMembership " ++ show n ++ ")" - -instance Eq (Membership xs x) where - _ == _ = True - -instance Ord (Membership xs x) where - compare _ _ = EQ - --- | Embodies a type equivalence to ensure that the 'Membership' points the first element. -runMembership :: Membership (y ': xs) x -> (x :~: y -> r) -> (Membership xs x -> r) -> r -runMembership (Membership 0) l _ = l (unsafeCoerce Refl) -runMembership (Membership n) _ r = r (Membership (n - 1)) -{-# INLINE runMembership #-} - --- | Compare two 'Membership's. -compareMembership :: Membership xs x -> Membership xs y -> Either Ordering (x :~: y) -compareMembership (Membership m) (Membership n) = case compare m n of - EQ -> Right (unsafeCoerce Refl) - x -> Left x -{-# INLINE compareMembership #-} - -impossibleMembership :: Membership '[] x -> r -impossibleMembership _ = error "Impossible" - --- | PRIVILEGED: Navigate a tree. -navigate :: (NavHere xs x -> r) - -> (Membership (Half (Tail xs)) x -> r) - -> (Membership (Half (Tail (Tail xs))) x -> r) - -> Membership xs x - -> r -navigate h nl nr = \case - Membership 0 -> h (unsafeCoerce Here) - Membership n -> if n .&. 1 == 0 - then nr (Membership (unsafeShiftR (n - 1) 1)) - else nl (Membership (unsafeShiftR (n - 1) 1)) -{-# INLINE navigate #-} - --- | Ensure that the first element of @xs@ is @x@ -data NavHere xs x where - Here :: NavHere (x ': xs) x - --- | The 'Membership' points the first element -here :: Membership (x ': xs) x -here = Membership 0 -{-# INLINE here #-} - --- | The next membership -navNext :: Membership xs y -> Membership (x ': xs) y -navNext (Membership n) = Membership (n + 1) -{-# INLINE navNext #-} - --- | Describes the relation of 'Membership' within a tree -navL :: Membership (Half xs) y -> Membership (x ': xs) y -navL (Membership x) = Membership (x * 2 + 1) -{-# INLINE navL #-} - --- | Describes the relation of 'Membership' within a tree -navR :: Membership (Half (Tail xs)) y -> Membership (x ': xs) y -navR (Membership x) = Membership (x * 2 + 2) -{-# INLINE navR #-} - --- | Unicode flipped alias for 'Member' -type x ∈ xs = Member xs x - -type family Head (xs :: [k]) :: k where - Head (x ': xs) = x - --- | FindType types -type family FindType (x :: k) (xs :: [k]) :: [Nat] where - FindType x (x ': xs) = 'Zero ': FindType x xs - FindType x (y ': ys) = MapSucc (FindType x ys) - FindType x '[] = '[] - --- | Interleaved list -type family Half (xs :: [k]) :: [k] where - Half '[] = '[] - Half (x ': y ': zs) = x ': Half zs - Half (x ': '[]) = '[x] - --- | Type-level tail -type family Tail (xs :: [k]) :: [k] where - Tail (x ': xs) = xs - Tail '[] = '[] - -type family Last (x :: [k]) :: k where - Last '[x] = x - Last (x ': xs) = Last xs - --- | Type level binary number -data Nat = Zero | DNat Nat | SDNat Nat - --- | Converts type naturals into 'Word'. -class KnownPosition n where - theInt :: proxy n -> Word - -instance KnownPosition 'Zero where - theInt _ = 0 - {-# INLINE theInt #-} - -instance KnownPosition n => KnownPosition ('DNat n) where - theInt _ = theInt (Proxy :: Proxy n) `unsafeShiftL` 1 - {-# INLINE theInt #-} - -instance KnownPosition n => KnownPosition ('SDNat n) where - theInt _ = (theInt (Proxy :: Proxy n) `unsafeShiftL` 1) + 1 - {-# INLINE theInt #-} - --- | The successor of the number -type family Succ (x :: Nat) :: Nat where - Succ 'Zero = 'SDNat 'Zero - Succ ('DNat n) = 'SDNat n - Succ ('SDNat n) = 'DNat (Succ n) - --- | Ideally, it will be 'Map Succ' -type family MapSucc (xs :: [Nat]) :: [Nat] where - MapSucc '[] = '[] - MapSucc (x ': xs) = Succ x ': MapSucc xs - --- | Type level map -type family Map (f :: k -> k) (xs :: [k]) :: [k] where - Map f '[] = '[] - Map f (x ': xs) = f x ': Map f xs - --- | Type level ++ -type family (++) (xs :: [k]) (ys :: [k]) :: [k] where - '[] ++ ys = ys - (x ': xs) ++ ys = x ': xs ++ ys - -infixr 5 ++ - --- | Type level concat -type family Concat (xs :: [[k]]) :: [k] where - Concat '[] = '[] - Concat (x ': xs) = x ++ Concat xs - --- | Type level merging -type family Merge (xs :: [k]) (ys :: [k]) :: [k] where - Merge (x ': xs) (y ': ys) = x ': y ': Merge xs ys - Merge xs '[] = xs - Merge '[] ys = ys
src/Data/Extensible/Internal/Rig.hs view
@@ -1,13 +1,11 @@ {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- |--- Module : Data.Extensible.Rig--- Copyright : (c) Fumiaki Kinoshita 2015+-- Module : Data.Extensible.Internal.Rig+-- Copyright : (c) Fumiaki Kinoshita 2018 -- License : BSD3 -- -- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability : experimental--- Portability : portable -- -- Re-implementation of lens combinators ------------------------------------------------------------------------@@ -46,17 +44,24 @@ over = coerce {-# INLINE over #-} +-- | Reifies the structure of 'Iso's data Exchange a b s t = Exchange (s -> a) (b -> t) +instance Functor (Exchange a b s) where+ fmap f (Exchange sa bt) = Exchange sa (f . bt)+ {-# INLINE fmap #-}+ instance Profunctor (Exchange a b) where dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt) {-# INLINE dimap #-} +-- | Recover tho functions from an Iso/ withIso :: Optic (Exchange a b) Identity s t a b -> ((s -> a) -> (b -> t) -> r) -> r withIso l r = case l (Exchange id Identity) of Exchange f g -> r f (coerce g) {-# INLINE withIso #-} +-- | @'review' :: AReview s a -> a -> s@ review :: Optic' Tagged Identity s a -> a -> s review = coerce {-# INLINE review #-}
+ src/Data/Extensible/Label.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE CPP, TypeFamilies, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Extensible.Label+-- Copyright : (c) Fumiaki Kinoshita 2018+-- License : BSD3+--+-- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>+--+-- Experimental API for OverloadedLabels. GHC 8.0+ only+-----------------------------------------------------------------------------+module Data.Extensible.Label () where++import Data.Extensible.Class+import Data.Extensible.Field+import Data.Proxy+import GHC.OverloadedLabels+import Data.Extensible.Wrapper++instance (Extensible f p e+ , Lookup xs k v+ , Wrapper h+ , ExtensibleConstr e xs (Field h) (k ':> v)+ , rep ~ Repr h v+ , s ~ e xs (Field h)+ , s ~ t+ , rep ~ rep'+ )+ => IsLabel k (p rep (f rep') -> p s (f t)) where+ fromLabel = itemAssoc (Proxy :: Proxy k)
src/Data/Extensible/Match.hs view
@@ -2,12 +2,10 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Extensible.League--- Copyright : (c) Fumiaki Kinoshita 2015+-- Copyright : (c) Fumiaki Kinoshita 2018 -- License : BSD3 -- -- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability : experimental--- Portability : non-portable -- -- Pattern matching ------------------------------------------------------------------------@@ -25,9 +23,10 @@ import Data.Extensible.Wrapper import Data.Typeable (Typeable) import Data.Profunctor.Unsafe+import GHC.Generics (Generic) -- | Retrieve the contents so that they matches and pass both to the given function.-matchWith :: (forall x. f x -> g x -> r) -> f :* xs -> g :| xs -> r+matchWith :: (forall x. f x -> g x -> r) -> xs :& f -> xs :/ g -> r matchWith f p = \(EmbedAt i h) -> views (pieceAt i) f p h {-# INLINE matchWith #-} @@ -36,19 +35,20 @@ mapMatch f = Match #. (f.) .# runMatch {-# INLINE mapMatch #-} --- | /O(log n)/ Perform pattern matching.-match :: Match h a :* xs -> h :| xs -> a+-- | /O(1)/ Perform pattern matching.+match :: xs :& Match h a -> xs :/ h -> a match = matchWith runMatch {-# INLINE match #-} -- | Flipped `match`-caseOf :: h :| xs -> Match h a :* xs -> a+caseOf :: xs :/ h -> xs :& Match h a -> a caseOf = flip match {-# INLINE caseOf #-} infix 0 `caseOf` -- | Turn a wrapper type into a clause for it.-newtype Match h r x = Match { runMatch :: h x -> r } deriving Typeable+newtype Match h r x = Match { runMatch :: h x -> r }+ deriving (Typeable, Generic, Semigroup, Monoid) instance Wrapper h => Wrapper (Match h r) where type Repr (Match h r) x = Repr h x -> r
src/Data/Extensible/Nullable.hs view
@@ -1,57 +1,104 @@-{-# LANGUAGE LambdaCase, TypeFamilies #-}+{-# LANGUAGE LambdaCase, TypeFamilies, TemplateHaskell #-} ------------------------------------------------------------------------ -- | -- Module : Data.Extensible.Nullable--- Copyright : (c) Fumiaki Kinoshita 2015+-- Copyright : (c) Fumiaki Kinoshita 2018 -- License : BSD3 -- -- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability : experimental--- Portability : non-portable -- ------------------------------------------------------------------------ module Data.Extensible.Nullable (- coinclusion+ vacancy+ , coinclusion , wrench , retrench , Nullable(..)- , mapNullable) where+ , mapNullable+ , fromNullable+ , coinclusionAssoc+ , wrenchAssoc+ , retrenchAssoc) where +import Control.DeepSeq (NFData) import Data.Extensible.Class import Data.Extensible.Product import Data.Extensible.Sum import Data.Extensible.Inclusion import Data.Extensible.Internal.Rig+import Data.Hashable import Data.Typeable (Typeable)-import Data.Monoid import Data.Extensible.Wrapper+import qualified Data.Extensible.Struct as S import Data.Profunctor.Unsafe+import Data.Maybe (fromMaybe)+import GHC.Generics (Generic)+import Language.Haskell.TH.Lift+import Test.QuickCheck.Arbitrary --- | Poly-kinded Maybe-newtype Nullable h x = Nullable { getNullable :: Maybe (h x) } deriving (Show, Eq, Ord, Typeable)+-- | Wrapped Maybe+newtype Nullable h x = Nullable { getNullable :: Maybe (h x) }+ deriving (Show, Eq, Ord, Typeable, Generic, NFData, Arbitrary, Hashable, Lift) instance Wrapper h => Wrapper (Nullable h) where type Repr (Nullable h) x = Maybe (Repr h x) _Wrapper = withIso _Wrapper $ \f g -> dimap (fmap f . getNullable) (fmap (Nullable . fmap g)) +instance Semigroup (h x) => Semigroup (Nullable h x) where+ Nullable (Just a) <> Nullable (Just b) = Nullable (Just (a <> b))+ a@(Nullable (Just _)) <> _ = a+ _ <> b = b++instance Semigroup (h x) => Monoid (Nullable h x) where+ mempty = Nullable Nothing+ mappend = (<>)+ -- | Apply a function to its content. mapNullable :: (g x -> h y) -> Nullable g x -> Nullable h y mapNullable f = Nullable #. fmap f .# getNullable {-# INLINE mapNullable #-} -- | The inverse of 'inclusion'.-coinclusion :: (Include ys xs, Generate ys) => Nullable (Membership xs) :* ys-coinclusion = flip appEndo (htabulate $ const $ Nullable Nothing)- $ hfoldMap getConst'- $ hmapWithIndex (\src dst -> Const' $ Endo $ pieceAt dst `over` const (Nullable $ Just src))- $ inclusion+coinclusion :: (Include ys xs, Generate ys) => ys :& Nullable (Membership xs)+coinclusion = S.hfrozen $ do+ s <- S.newRepeat $ Nullable Nothing+ hfoldrWithIndex+ (\i m cont -> S.set s m (Nullable $ Just i) >> cont) (return s) inclusion +-- | A product filled with @'Nullable' 'Nothing'@+vacancy :: Generate xs => xs :& Nullable h+vacancy = hrepeat $ Nullable Nothing+ -- | Extend a product and fill missing fields by 'Null'.-wrench :: (Generate ys, xs ⊆ ys) => h :* xs -> Nullable h :* ys+wrench :: (Generate ys, xs ⊆ ys) => xs :& h -> ys :& Nullable h wrench xs = mapNullable (flip hlookup xs) `hmap` coinclusion {-# INLINE wrench #-} -- | Narrow the range of the sum, if possible.-retrench :: (Generate ys, xs ⊆ ys) => h :| ys -> Nullable ((:|) h) xs+retrench :: (Generate ys, xs ⊆ ys) => ys :/ h -> Nullable ((:/) xs) h retrench (EmbedAt i h) = views (pieceAt i) (mapNullable (`EmbedAt`h)) coinclusion {-# INLINE retrench #-}++-- | 'fromMaybe' for 'Nullable'.+fromNullable :: h x -> Nullable h x -> h x+fromNullable def = fromMaybe def . getNullable+{-# INLINE fromNullable #-}++------------------------------------------------------------------++-- | The inverse of 'inclusionAssoc'.+coinclusionAssoc :: (IncludeAssoc ys xs, Generate ys) => ys :& Nullable (Membership xs)+coinclusionAssoc = S.hfrozen $ do+ s <- S.newRepeat $ Nullable Nothing+ hfoldrWithIndex+ (\i m cont -> S.set s m (Nullable $ Just i) >> cont) (return s) inclusionAssoc++-- | Extend a product and fill missing fields by 'Null'.+wrenchAssoc :: (Generate ys, IncludeAssoc ys xs) => xs :& h -> ys :& Nullable h+wrenchAssoc xs = mapNullable (flip hlookup xs) `hmap` coinclusionAssoc+{-# INLINE wrenchAssoc #-}++-- | Narrow the range of the sum, if possible.+retrenchAssoc :: (Generate ys, IncludeAssoc ys xs) => ys :/ h -> Nullable ((:/) xs) h+retrenchAssoc (EmbedAt i h) = views (pieceAt i) (mapNullable (`EmbedAt`h)) coinclusionAssoc+{-# INLINE retrenchAssoc #-}
src/Data/Extensible/Plain.hs view
@@ -3,12 +3,10 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Extensible.Plain--- Copyright : (c) Fumiaki Kinoshita 2015+-- Copyright : (c) Fumiaki Kinoshita 2018 -- License : BSD3 -- -- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability : experimental--- Portability : non-portable -- ------------------------------------------------------------------------ module Data.Extensible.Plain (@@ -20,7 +18,6 @@ , (<%|) , accessing ) where-import Data.Extensible.Internal import Data.Extensible.Internal.Rig import Data.Extensible.Class import Data.Extensible.Product@@ -31,12 +28,12 @@ import Data.Profunctor.Unsafe -- | Alias for plain products-type AllOf xs = Identity :* xs+type AllOf xs = xs :& Identity -- | Alias for plain sums-type OneOf xs = Identity :| xs+type OneOf xs = xs :/ Identity --- | /O(log n)/ Add a plain value to a product.+-- | Add a plain value to a product. (<%) :: x -> AllOf xs -> AllOf (x ': xs) (<%) = (<:) .# Identity {-# INLINE (<%) #-}@@ -58,6 +55,6 @@ infixr 1 <%| -- | An accessor for newtype constructors.-accessing :: (Coercible x a, x ∈ xs, Extensible f p t) => (a -> x) -> Optic' p f (t Identity xs) a+accessing :: (Coercible x a, x ∈ xs, Extensible f p t, ExtensibleConstr t xs Identity x) => (a -> x) -> Optic' p f (t xs Identity) a accessing c = piece . _Wrapper . dimap coerce (fmap c) {-# INLINE accessing #-}
src/Data/Extensible/Product.hs view
@@ -1,267 +1,331 @@-{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Extensible.Product --- Copyright : (c) Fumiaki Kinoshita 2015 --- License : BSD3 --- --- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com> --- Stability : experimental --- Portability : non-portable --- ------------------------------------------------------------------------- -module Data.Extensible.Product ( - -- * Basic operations - (:*)(..) - , (<:) - , (<:*) - , (*++*) - , hhead - , htail - , huncons - , hmap - , hmapWithIndex - , htrans - , hzipWith - , hzipWith3 - , hfoldMap - , htraverse - , htraverseWithIndex - , hsequence - , hcollect - , hdistribute - -- * Lookup - , hlookup - , hindex - , sectorAt - , sector - -- * Generation - , Generate(..) - , htabulate - , Forall(..) - , htabulateFor) where - -import Data.Extensible.Internal -import Data.Extensible.Internal.Rig -import Unsafe.Coerce -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif -import Data.Monoid -import Data.Typeable (Typeable) -import Data.Extensible.Class -import Data.Functor.Identity -import Data.Extensible.Wrapper -import Data.Profunctor.Unsafe - --- | The type of extensible products. --- --- @(:*) :: (k -> *) -> [k] -> *@ --- -data (h :: k -> *) :* (s :: [k]) where - Nil :: h :* '[] - Tree :: !(h x) - -> h :* Half xs - -> h :* Half (Tail xs) - -> h :* (x ': xs) - -deriving instance Typeable (:*) - --- | /O(1)/ Extract the head element. -hhead :: h :* (x ': xs) -> h x -hhead (Tree a _ _) = a -{-# INLINE hhead #-} - --- | /O(log n)/ Extract the tail of the product. -htail :: h :* (x ': xs) -> h :* xs -htail (Tree _ a@(Tree h _ _) b) = unsafeCoerce (Tree h) b (htail a) -htail (Tree _ Nil _) = unsafeCoerce Nil - --- | Split a product to the head and the tail. -huncons :: forall h x xs. h :* (x ': xs) -> (h x, h :* xs) -huncons t@(Tree a _ _) = (a, htail t) -{-# INLINE huncons #-} - --- | An alias for ('<:'). -(<:*) :: forall h x xs. h x -> h :* xs -> h :* (x ': xs) -a <:* Tree b c d = Tree a (lemmaHalfTail (Proxy :: Proxy (Tail xs)) $ b <: d) c -a <:* Nil = Tree a Nil Nil -infixr 0 <:* - --- | /O(log n)/ Add an element to a product. -(<:) :: h x -> h :* xs -> h :* (x ': xs) -(<:) = (<:*) -{-# INLINE (<:) #-} -infixr 0 <: - --- | Transform every elements in a product, preserving the order. --- --- @ --- 'hmap' 'id' ≡ 'id' --- 'hmap' (f . g) ≡ 'hmap' f . 'hmap' g --- @ -hmap :: (forall x. g x -> h x) -> g :* xs -> h :* xs -hmap t (Tree h a b) = Tree (t h) (hmap t a) (hmap t b) -hmap _ Nil = Nil - --- | Transform every elements in a product, preserving the order. -htrans :: (forall x. g x -> h (t x)) -> g :* xs -> h :* Map t xs -htrans t (Tree h a b) = unsafeCoerce (Tree (t h)) (htrans t a) (htrans t b) -htrans _ Nil = Nil - --- | Combine products. -(*++*) :: h :* xs -> h :* ys -> h :* (xs ++ ys) -(*++*) Nil ys = ys -(*++*) xs'@(Tree x _ _) ys = let xs = htail xs' in x <:* (xs *++* ys) -infixr 0 *++* - --- | 'zipWith' for heterogeneous product -hzipWith :: (forall x. f x -> g x -> h x) -> f :* xs -> g :* xs -> h :* xs -hzipWith t (Tree f a b) (Tree g c d) = Tree (t f g) (hzipWith t a c) (hzipWith t b d) -hzipWith _ Nil _ = Nil -hzipWith _ _ Nil = Nil - --- | 'zipWith3' for heterogeneous product -hzipWith3 :: (forall x. f x -> g x -> h x -> i x) -> f :* xs -> g :* xs -> h :* xs -> i :* xs -hzipWith3 t (Tree f a b) (Tree g c d) (Tree h e f') = Tree (t f g h) (hzipWith3 t a c e) (hzipWith3 t b d f') -hzipWith3 _ Nil _ _ = Nil -hzipWith3 _ _ Nil _ = Nil -hzipWith3 _ _ _ Nil = Nil - --- | Map elements to a monoid and combine the results. --- --- @'hfoldMap' f . 'hmap' g ≡ 'hfoldMap' (f . g)@ -hfoldMap :: Monoid a => (forall x. h x -> a) -> h :* xs -> a -hfoldMap f (Tree h a b) = f h <> hfoldMap f a <> hfoldMap f b -hfoldMap _ Nil = mempty - --- | Traverse all elements and combine the result sequentially. --- @ --- htraverse (fmap f . g) ≡ fmap (hmap f) . htraverse g --- htraverse pure ≡ pure --- htraverse (Comp . fmap g . f) ≡ Comp . fmap (htraverse g) . htraverse f --- @ -htraverse :: Applicative f => (forall x. g x -> f (h x)) -> g :* xs -> f (h :* xs) -htraverse f (Tree h a b) = Tree <$> f h <*> htraverse f a <*> htraverse f b -htraverse _ Nil = pure Nil - --- | 'sequence' analog for extensible products -hsequence :: Applicative f => Comp f h :* xs -> f (h :* xs) -hsequence = htraverse getComp -{-# INLINE hsequence #-} - --- | The dual of 'htraverse' -hcollect :: (Functor f, Generate xs) => (a -> h :* xs) -> f a -> Comp f h :* xs -hcollect f m = htabulate $ \i -> Comp $ fmap (hlookup i . f) m -{-# INLINABLE hcollect #-} - --- | The dual of 'hsequence' -hdistribute :: (Functor f, Generate xs) => f (h :* xs) -> Comp f h :* xs -hdistribute = hcollect id -{-# INLINE hdistribute #-} - --- | /O(log n)/ Pick up an elemtnt. -hlookup :: Membership xs x -> h :* xs -> h x -hlookup = view . pieceAt -{-# INLINABLE hlookup #-} - --- | Flipped 'hlookup' -hindex :: h :* xs -> Membership xs x -> h x -hindex = flip hlookup -{-# INLINE hindex #-} - --- | 'hmap' with 'Membership's. -hmapWithIndex :: forall g h xs. (forall x. Membership xs x -> g x -> h x) -> g :* xs -> h :* xs -hmapWithIndex f = go id where - go :: (forall x. Membership t x -> Membership xs x) -> g :* t -> h :* t - go k (Tree g a b) = Tree (f (k here) g) (go (k . navL) a) (go (k . navR) b) - go _ Nil = Nil -{-# INLINE hmapWithIndex #-} - --- | 'htraverse' with 'Membership's. -htraverseWithIndex :: forall f g h xs. Applicative f - => (forall x. Membership xs x -> g x -> f (h x)) -> g :* xs -> f (h :* xs) -htraverseWithIndex f = go id where - go :: (forall x. Membership t x -> Membership xs x) -> g :* t -> f (h :* t) - go k (Tree g a b) = Tree <$> f (k here) g <*> go (k . navL) a <*> go (k . navR) b - go _ Nil = pure Nil -{-# INLINE htraverseWithIndex #-} - -instance Functor f => Extensible f (->) (:*) where - -- | /O(log n)/ A lens for a value in a known position. - pieceAt = pieceAt_ - {-# INLINE pieceAt #-} - -pieceAt_ :: forall (xs :: [k]) (x :: k) (h :: k -> *) (f :: * -> *). Functor f - => Membership xs x -> (h x -> f (h x)) -> h :* xs -> f (h :* xs) -pieceAt_ i f = flip go i where - go :: forall t. h :* t -> Membership t x -> f (h :* t) - go (Tree h a b) = navigate - (\Here -> fmap (\h' -> Tree h' a b) (f h)) - (fmap (\a' -> Tree h a' b) . go a) - (fmap (\b' -> Tree h a b') . go b) - go Nil = error "Impossible" -{-# INLINE pieceAt_ #-} - -{-# DEPRECATED sectorAt "Use pieceAt" #-} --- | The legacy name for 'pieceAt' -sectorAt :: Functor f => Membership xs x -> (h x -> f (h x)) -> h :* xs -> f (h :* xs) -sectorAt = pieceAt - -{-# DEPRECATED sector "Use piece" #-} --- | The legacy name for 'piece' -sector :: (Functor f, x ∈ xs) => (h x -> f (h x)) -> h :* xs -> f (h :* xs) -sector = piece - --- | Given a function that maps types to values, we can "collect" entities all you want. -class Generate (xs :: [k]) where - -- | /O(n)/ Generate a product with the given function. - hgenerate :: Applicative f => (forall x. Membership xs x -> f (h x)) -> f (h :* xs) - -instance Generate '[] where - hgenerate _ = pure Nil - {-# INLINE hgenerate #-} - -instance (Generate (Half xs), Generate (Half (Tail xs))) => Generate (x ': xs) where - hgenerate f = Tree <$> f here <*> hgenerate (f . navL) <*> hgenerate (f . navR) - {-# INLINE hgenerate #-} - --- | Pure version of 'hgenerate'. --- --- @ --- 'hmap' f ('htabulate' g) ≡ 'htabulate' (f . g) --- 'htabulate' ('hindex' m) ≡ m --- 'hindex' ('htabulate' k) ≡ k --- @ -htabulate :: Generate xs => (forall x. Membership xs x -> h x) -> h :* xs -htabulate f = runIdentity (hgenerate (Identity #. f)) -{-# INLINE htabulate #-} - --- | Guarantees the all elements satisfies the predicate. -class Forall c (xs :: [k]) where - -- | /O(n)/ Analogous to 'hgenerate', but it also supplies a context @c x@ for every elements in @xs@. - hgenerateFor :: Applicative f => proxy c -> (forall x. c x => Membership xs x -> f (h x)) -> f (h :* xs) - -instance Forall c '[] where - hgenerateFor _ _ = pure Nil - {-# INLINE hgenerateFor #-} - -instance (c x, Forall c (Half xs), Forall c (Half (Tail xs))) => Forall c (x ': xs) where - hgenerateFor proxy f = Tree - <$> f here - <*> hgenerateFor proxy (f . navL) - <*> hgenerateFor proxy (f . navR) - {-# INLINE hgenerateFor #-} - --- | Pure version of 'hgenerateFor'. -htabulateFor :: Forall c xs => proxy c -> (forall x. c x => Membership xs x -> h x) -> h :* xs -htabulateFor p f = runIdentity (hgenerateFor p (Identity #. f)) -{-# INLINE htabulateFor #-} - --- | GHC can't prove this -lemmaHalfTail :: proxy xs -> h :* (x ': Half (Tail xs)) -> h :* (Half (x ': xs)) -lemmaHalfTail _ = unsafeCoerce -{-# INLINE lemmaHalfTail #-} +{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ViewPatterns, ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Extensible.Product+-- Copyright : (c) Fumiaki Kinoshita 2018+-- License : BSD3+--+-- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>+--+------------------------------------------------------------------------+module Data.Extensible.Product (+ -- * Basic operations+ (:&)+ , nil+ , (<:)+ , (<!)+ , (=<:)+ , hlength+ , type (++)+ , happend+ , hmap+ , hmapWithIndex+ , hzipWith+ , hzipWith3+ , hfoldMap+ , hfoldMapWithIndex+ , hfoldrWithIndex+ , hfoldlWithIndex+ , htraverse+ , htraverseWithIndex+ , hsequence+ -- * Constrained fold+ , hmapWithIndexFor+ , hfoldMapFor+ , hfoldMapWithIndexFor+ , hfoldrWithIndexFor+ , hfoldlWithIndexFor+ -- * Constraind fold without proxies+ , hfoldMapWith+ , hfoldMapWithIndexWith+ , hfoldrWithIndexWith+ , hfoldlWithIndexWith+ , hmapWithIndexWith+ -- * Evaluating+ , hforce+ -- * Update+ , haccumMap+ , haccum+ , hpartition+ -- * Lookup+ , hlookup+ , hindex+ -- * Generation+ , Generate(..)+ , hgenerate+ , htabulate+ , hrepeat+ , hcollect+ , hdistribute+ , fromHList+ , toHList+ , Forall(..)+ , hgenerateFor+ , htabulateFor+ , hrepeatFor+ , hgenerateWith+ , htabulateWith+ , hrepeatWith) where++import Data.Extensible.Internal.Rig (review)+import Data.Extensible.Struct+import Data.Extensible.Sum+import Data.Extensible.Class+import Data.Extensible.Wrapper+import Data.Functor.Compose+import Data.Proxy+import qualified Type.Membership.HList as HList++-- | O(n) Prepend an element onto a product.+-- Expressions like @a <: b <: c <: nil@ are transformed to a single 'fromHList'.+(<:) :: h x -> xs :& h -> (x ': xs) :& h+(<:) x = fromHList . HList.HCons x . toHList+{-# INLINE (<:) #-}+infixr 0 <:++(=<:) :: Wrapper h => Repr h x -> xs :& h -> (x ': xs) :& h+(=<:) = (<:) . review _Wrapper+{-# INLINE (=<:) #-}+infixr 0 =<:++-- | Strict version of ('<:').+(<!) :: h x -> xs :& h -> (x ': xs) :& h+(<!) x = fromHList . (HList.HCons $! x) . toHList+{-# INLINE (<!) #-}+infixr 0 <!++-- | An empty product.+nil :: '[] :& h+nil = hfrozen $ new $ error "Impossible"+{-# NOINLINE nil #-}+{-# RULES "toHList/nil" toHList nil = HList.HNil #-}++-- | Convert 'HList.HList' into a product.+fromHList :: HList.HList h xs -> xs :& h+fromHList xs = hfrozen (newFromHList xs)+{-# INLINE fromHList #-}++-- | Flipped 'hlookup'+hindex :: xs :& h -> Membership xs x -> h x+hindex = flip hlookup+{-# INLINE hindex #-}++-- | Map a function to every element of a product.+hmapWithIndex :: (forall x. Membership xs x -> g x -> h x) -> xs :& g -> xs :& h+hmapWithIndex t p = hfrozen (newFrom p t)+{-# INLINE hmapWithIndex #-}++-- | Map a function to every element of a product.+hmapWithIndexFor :: Forall c xs+ => proxy c+ -> (forall x. c x => Membership xs x -> g x -> h x)+ -> xs :& g -> xs :& h+hmapWithIndexFor c t p = hfrozen $ newFor c $ \i -> t i $ hlookup i p+{-# INLINE hmapWithIndexFor #-}++hmapWithIndexWith :: forall c xs g h. Forall c xs+ => (forall x. c x => Membership xs x -> g x -> h x)+ -> xs :& g -> xs :& h+hmapWithIndexWith = hmapWithIndexFor (Proxy @c)++-- | Transform every element in a product, preserving the order.+--+-- @+-- 'hmap' 'id' ≡ 'id'+-- 'hmap' (f . g) ≡ 'hmap' f . 'hmap' g+-- @+hmap :: (forall x. g x -> h x) -> xs :& g -> xs :& h+hmap f = hmapWithIndex (const f)+{-# INLINE hmap #-}++-- | 'zipWith' for heterogeneous product+hzipWith :: (forall x. f x -> g x -> h x) -> xs :& f -> xs :& g -> xs :& h+hzipWith t xs = hmapWithIndex (\i -> t (hlookup i xs))+{-# INLINE hzipWith #-}++-- | 'zipWith3' for heterogeneous product+hzipWith3 :: (forall x. f x -> g x -> h x -> i x) -> xs :& f -> xs :& g -> xs :& h -> xs :& i+hzipWith3 t xs ys = hmapWithIndex (\i -> t (hlookup i xs) (hlookup i ys))+{-# INLINE hzipWith3 #-}++-- | Map elements to a monoid and combine the results.+--+-- @'hfoldMap' f . 'hmap' g ≡ 'hfoldMap' (f . g)@+hfoldMap :: Monoid a => (forall x. h x -> a) -> xs :& h -> a+hfoldMap f = hfoldMapWithIndex (const f)+{-# INLINE hfoldMap #-}++-- | 'hfoldMap' with the membership of elements.+hfoldMapWithIndex :: Monoid a+ => (forall x. Membership xs x -> g x -> a) -> xs :& g -> a+hfoldMapWithIndex f = hfoldrWithIndex (\i -> mappend . f i) mempty+{-# INLINE hfoldMapWithIndex #-}++-- | Perform a strict left fold over the elements.+hfoldlWithIndex :: (forall x. Membership xs x -> r -> h x -> r) -> r -> xs :& h -> r+hfoldlWithIndex f r xs = hfoldrWithIndex (\i x c a -> c $! f i a x) id xs r+{-# INLINE hfoldlWithIndex #-}++-- | 'hfoldrWithIndex' with a constraint for each element.+hfoldrWithIndexFor :: forall c xs h r proxy. (Forall c xs) => proxy c+ -> (forall x. c x => Membership xs x -> h x -> r -> r) -> r -> xs :& h -> r+hfoldrWithIndexFor p f r xs = henumerateFor p (Proxy :: Proxy xs) (\i -> f i (hlookup i xs)) r+{-# INLINE hfoldrWithIndexFor #-}++hfoldrWithIndexWith :: forall c xs h r. (Forall c xs)+ => (forall x. c x => Membership xs x -> h x -> r -> r) -> r -> xs :& h -> r+hfoldrWithIndexWith f r xs = henumerateFor (Proxy @c) (Proxy @xs) (\i -> f i (hlookup i xs)) r+{-# INLINE hfoldrWithIndexWith #-}++-- | Constrained 'hfoldlWithIndex'+hfoldlWithIndexFor :: (Forall c xs) => proxy c+ -> (forall x. c x => Membership xs x -> r -> h x -> r) -> r -> xs :& h -> r+hfoldlWithIndexFor p f r xs = hfoldrWithIndexFor p (\i x c a -> c $! f i a x) id xs r+{-# INLINE hfoldlWithIndexFor #-}++-- | Constrained 'hfoldlWithIndex'+hfoldlWithIndexWith :: forall c xs h r. (Forall c xs)+ => (forall x. c x => Membership xs x -> r -> h x -> r) -> r -> xs :& h -> r+hfoldlWithIndexWith f r xs = hfoldrWithIndexWith @c (\i x c a -> c $! f i a x) id xs r+{-# INLINE hfoldlWithIndexWith #-}++-- | 'hfoldMapWithIndex' with a constraint for each element.+hfoldMapWithIndexFor :: (Forall c xs, Monoid a) => proxy c+ -> (forall x. c x => Membership xs x -> h x -> a) -> xs :& h -> a+hfoldMapWithIndexFor p f = hfoldrWithIndexFor p (\i -> mappend . f i) mempty+{-# INLINE hfoldMapWithIndexFor #-}++-- | 'hfoldMapWithIndex' with a constraint for each element.+hfoldMapWithIndexWith :: forall c xs h a. (Forall c xs, Monoid a)+ => (forall x. c x => Membership xs x -> h x -> a) -> xs :& h -> a+hfoldMapWithIndexWith f = hfoldrWithIndexWith @c (\i -> mappend . f i) mempty+{-# INLINE hfoldMapWithIndexWith #-}++-- | Constrained 'hfoldMap'+hfoldMapFor :: (Forall c xs, Monoid a) => proxy c+ -> (forall x. c x => h x -> a) -> xs :& h -> a+hfoldMapFor p f = hfoldMapWithIndexFor p (const f)+{-# INLINE hfoldMapFor #-}++-- | Constrained 'hfoldMap'+hfoldMapWith :: forall c xs h a. (Forall c xs, Monoid a)+ => (forall x. c x => h x -> a) -> xs :& h -> a+hfoldMapWith f = hfoldMapWithIndexFor (Proxy @c) (const f)+{-# INLINE hfoldMapWith #-}++-- | Traverse all elements and combine the result sequentially.+-- @+-- htraverse (fmap f . g) ≡ fmap (hmap f) . htraverse g+-- htraverse pure ≡ pure+-- htraverse (Compose . fmap g . f) ≡ Compose . fmap (htraverse g) . htraverse f+-- @+htraverse :: Applicative f => (forall x. g x -> f (h x)) -> xs :& g -> f (xs :& h)+htraverse f = fmap fromHList . HList.htraverse f . toHList+{-# INLINE htraverse #-}++-- | 'sequence' analog for extensible products+hsequence :: Applicative f => xs :& Compose f h -> f (xs :& h)+hsequence = htraverse getCompose+{-# INLINE hsequence #-}++-- | The dual of 'htraverse'+hcollect :: (Functor f, Generate xs) => (a -> xs :& h) -> f a -> xs :& Compose f h+hcollect f m = htabulate $ \i -> Compose $ fmap (hlookup i . f) m+{-# INLINABLE hcollect #-}++-- | The dual of 'hsequence'+hdistribute :: (Functor f, Generate xs) => f (xs :& h) -> xs :& Compose f h+hdistribute = hcollect id+{-# INLINE hdistribute #-}++-- | 'htraverse' with 'Membership's.+htraverseWithIndex :: Applicative f+ => (forall x. Membership xs x -> g x -> f (h x)) -> xs :& g -> f (xs :& h)+htraverseWithIndex f = fmap fromHList . HList.htraverseWithIndex f . toHList+{-# INLINE htraverseWithIndex #-}++-- | A product filled with the specified value.+hrepeat :: Generate xs => (forall x. h x) -> xs :& h+hrepeat x = hfrozen $ newRepeat x+{-# INLINE hrepeat #-}++-- | Construct a product using a function which takes a 'Membership'.+--+-- @+-- 'hmap' f ('htabulate' g) ≡ 'htabulate' (f . g)+-- 'htabulate' ('hindex' m) ≡ m+-- 'hindex' ('htabulate' k) ≡ k+-- @+htabulate :: Generate xs => (forall x. Membership xs x -> h x) -> xs :& h+htabulate f = hfrozen $ new f+{-# INLINE htabulate #-}++-- | 'Applicative' version of 'htabulate'.+hgenerate :: (Generate xs, Applicative f)+ => (forall x. Membership xs x -> f (h x)) -> f (xs :& h)+hgenerate f = fmap fromHList $ hgenerateList f+{-# INLINE hgenerate #-}++-- | Pure version of 'hgenerateFor'.+htabulateFor :: Forall c xs => proxy c -> (forall x. c x => Membership xs x -> h x) -> xs :& h+htabulateFor p f = hfrozen $ newFor p f+{-# INLINE htabulateFor #-}++-- | Pure version of 'hgenerateFor'.+htabulateWith :: forall c xs h. Forall c xs => (forall x. c x => Membership xs x -> h x) -> xs :& h+htabulateWith f = hfrozen $ newFor (Proxy @c) f+{-# INLINE htabulateWith #-}++-- | A product filled with the specified value.+hrepeatFor :: Forall c xs => proxy c -> (forall x. c x => h x) -> xs :& h+hrepeatFor p f = htabulateFor p (const f)+{-# INLINE hrepeatFor #-}++-- | A product filled with the specified value.+hrepeatWith :: forall c xs h. Forall c xs => (forall x. c x => h x) -> xs :& h+hrepeatWith f = htabulateFor (Proxy @c) (const f)+{-# INLINE hrepeatWith #-}++-- | 'Applicative' version of 'htabulateFor'.+hgenerateFor :: (Forall c xs, Applicative f)+ => proxy c -> (forall x. c x => Membership xs x -> f (h x)) -> f (xs :& h)+hgenerateFor p f = fmap fromHList $ hgenerateListFor p f+{-# INLINE hgenerateFor #-}++-- | 'Applicative' version of 'htabulateFor'.+hgenerateWith :: forall c xs f h. (Forall c xs, Applicative f)+ => (forall x. c x => Membership xs x -> f (h x)) -> f (xs :& h)+hgenerateWith f = fmap fromHList $ hgenerateListFor (Proxy @c) f+{-# INLINE hgenerateWith #-}++-- | Accumulate sums on a product.+haccumMap :: Foldable f+ => (a -> xs :/ g)+ -> (forall x. Membership xs x -> g x -> h x -> h x)+ -> xs :& h -> f a -> xs :& h+haccumMap f g p0 xs = hmodify+ (\s -> mapM_ (\x -> case f x of EmbedAt i v -> get s i >>= set s i . g i v) xs)+ p0+{-# INLINE haccumMap #-}++-- | @haccum = 'haccumMap' 'id'@+haccum :: Foldable f+ => (forall x. Membership xs x -> g x -> h x -> h x)+ -> xs :& h -> f (xs :/ g) -> xs :& h+haccum = haccumMap id+{-# INLINE haccum #-}++-- | Group sums by type.+hpartition :: (Foldable f, Generate xs) => (a -> xs :/ h) -> f a -> xs :& Compose [] h+hpartition f = haccumMap f (\_ x (Compose xs) -> Compose (x:xs)) $ hrepeat $ Compose []+{-# INLINE hpartition #-}++-- | Evaluate every element in a product.+hforce :: xs :& h -> xs :& h+hforce p = hfoldrWithIndex (const seq) p p+{-# INLINE hforce #-}
src/Data/Extensible/Record.hs view
@@ -1,79 +1,97 @@-{-# LANGUAGE LambdaCase, TemplateHaskell, TypeFamilies, DeriveFunctor #-}-module Data.Extensible.Record (IsRecord(..), deriveIsRecord) where+{-# LANGUAGE LambdaCase, TemplateHaskell, TypeFamilies #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+------------------------------------------------------------------------+-- |+-- Module : Data.Extensible.Record+-- Copyright : (c) Fumiaki Kinoshita 2018+-- License : BSD3+--+-- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>+--+-- Bidirectional conversion from/to records+------------------------------------------------------------------------+module Data.Extensible.Record (IsRecord(..), toRecord, fromRecord, record) where -import Language.Haskell.TH-import Data.Extensible.Internal+import Data.Extensible.Internal.Rig import Data.Extensible.Product import Data.Extensible.Field import Data.Functor.Identity+import Data.Kind (Type)+import Data.Profunctor+import GHC.Generics import GHC.TypeLits+import Type.Membership+import Type.Membership.HList -- | The class of types that can be converted to/from a 'Record'. class IsRecord a where- type RecFields a :: [Assoc Symbol *]- fromRecord :: Record (RecFields a) -> a- toRecord :: a -> Record (RecFields a)+ type RecFields a :: [Assoc Symbol Type]+ recordFromList :: HList (Field Identity) (RecFields a) -> a+ recordToList :: a -> HList (Field Identity) (RecFields a) -tvName :: TyVarBndr -> Name-tvName (PlainTV n) = n-tvName (KindedTV n _) = n+ type RecFields a = GRecFields (Rep a) '[]+ default recordFromList :: (Generic a, GIsRecord (Rep a) '[], GRecFields (Rep a) '[] ~ RecFields a)+ => HList (Field Identity) (RecFields a) -> a+ recordFromList xs = recordFromList' xs (\x (HNil :: HList (Field Identity) '[]) -> to x) -deriveIsRecord :: Name -> DecsQ-deriveIsRecord name = reify name >>= \case-#if MIN_VERSION_template_haskell(2,11,0)- TyConI (DataD _ _ vars _ [RecC conName vst] _) -> do-#else- TyConI (DataD _ _ vars [RecC conName vst] _) -> do-#endif- rec <- newName "rec"- let names = [x | (x, _, _) <- vst]- newNames <- traverse (newName . nameBase) names- let tvmap = [(tvName tv, VarT (mkName $ "p" ++ show i)) | (i, tv) <- zip [0 :: Int ..] vars]- let ty = foldl AppT (ConT name) $ map snd tvmap- let refineTV (VarT t) | Just t' <- lookup t tvmap = t'- refineTV (AppT a b) = refineTV a `AppT` refineTV b- refineTV t = t- return-#if MIN_VERSION_template_haskell(2,11,0)- [InstanceD Nothing [] (ConT ''IsRecord `AppT` ty)-#else- [InstanceD [] (ConT ''IsRecord `AppT` ty)-#endif- [ TySynInstD ''RecFields $ TySynEqn [ty] $ foldr- (\(v, _, t) r -> PromotedConsT `AppT` (PromotedT '(:>) `AppT` LitT (StrTyLit $ nameBase v) `AppT` refineTV t) `AppT` r)- PromotedNilT- vst- , FunD 'fromRecord [Clause- [shape2Pat $ fmap (\x -> ConP 'Field [ConP 'Identity [VarP x]]) $ foldr consShape SNil newNames]- (NormalB $ RecConE conName [(n, VarE n') | (n, n') <- zip names newNames])- []- ]- , FunD 'toRecord [Clause- [VarP rec]- (NormalB $ shape2Exp- $ foldr consShape SNil- [AppE (ConE 'Field)- $ AppE (ConE 'Identity)- $ VarE n `AppE` VarE rec- | n <- names])- []- ]- ]- ]- info -> fail $ "deriveAsRecord: Unsupported " ++ show info+ default recordToList :: (Generic a, GIsRecord (Rep a) '[], GRecFields (Rep a) '[] ~ RecFields a)+ => a -> HList (Field Identity) (RecFields a)+ recordToList x = recordToList' (from x) HNil -shape2Pat :: Shape Pat -> Pat-shape2Pat SNil = ConP 'Nil []-shape2Pat (STree p l r) = ConP 'Tree [p, shape2Pat l, shape2Pat r]+instance IsRecord () where+ type RecFields () = '[]+ recordFromList _ = ()+ recordToList _ = HNil -shape2Exp :: Shape Exp -> Exp-shape2Exp SNil = ConE 'Nil-shape2Exp (STree e l r) = ConE 'Tree `AppE` e `AppE` shape2Exp l `AppE` shape2Exp r+-- | The class of types that can be converted to/from a 'Record'.+class GIsRecord f r where+ type GRecFields f (r :: [Assoc Symbol Type]) :: [Assoc Symbol Type]+ recordFromList' :: HList (Field Identity) (GRecFields f r) -> (f x -> HList (Field Identity) r -> cont) -> cont+ recordToList' :: f x -> HList (Field Identity) r -> HList (Field Identity) (GRecFields f r) -data Shape a = SNil- | STree a (Shape a) (Shape a)- deriving Functor+instance (GIsRecord f (GRecFields g r), GIsRecord g r) => GIsRecord (f :*: g) r where+ type GRecFields (f :*: g) r = GRecFields f (GRecFields g r)+ recordFromList' xs cont = recordFromList' xs $ \l ys -> recordFromList' ys $ \r zs -> cont (l :*: r) zs+ {-# INLINE recordFromList' #-}+ recordToList' (f :*: g) = recordToList' f . recordToList' g+ {-# INLINE recordToList' #-} -consShape :: a -> Shape a -> Shape a-consShape a SNil = STree a SNil SNil-consShape a (STree b l r) = STree a (consShape b r) l+instance GIsRecord (S1 ('MetaSel ('Just name) su ss ds) (K1 i a)) r where+ type GRecFields (S1 ('MetaSel ('Just name) su ss ds) (K1 i a)) r = (name >: a) ': r+ recordFromList' (HCons (Field (Identity a)) xs) cont = cont (M1 (K1 a)) xs+ {-# INLINE recordFromList' #-}+ recordToList' (M1 (K1 a)) = HCons (Field (Identity a))+ {-# INLINE recordToList' #-}++instance GIsRecord f r => GIsRecord (C1 i f) r where+ type GRecFields (C1 i f) r = GRecFields f r+ recordFromList' xs cont = recordFromList' xs $ cont . M1+ {-# INLINE recordFromList' #-}+ recordToList' (M1 f) = recordToList' f+ {-# INLINE recordToList' #-}++instance GIsRecord f r => GIsRecord (D1 i f) r where+ type GRecFields (D1 i f) r = GRecFields f r+ recordFromList' xs cont = recordFromList' xs $ cont . M1+ {-# INLINE recordFromList' #-}+ recordToList' (M1 f) = recordToList' f+ {-# INLINE recordToList' #-}++-- | Convert a value into a 'Record'.+toRecord :: IsRecord a => a -> Record (RecFields a)+toRecord = fromHList . recordToList+{-# INLINE toRecord #-}++-- | Convert a 'Record' to a value.+fromRecord :: IsRecord a => Record (RecFields a) -> a+fromRecord = recordFromList . toHList+{-# INLINE fromRecord #-}++-- | @record :: IsRecord a => Iso' a (Record (RecFields a)) @+record :: (IsRecord a, Functor f, Profunctor p)+ => Optic' p f a (Record (RecFields a))+record = dimap toRecord (fmap fromRecord)+{-# INLINE record #-}
+ src/Data/Extensible/Struct.hs view
@@ -0,0 +1,331 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns, BangPatterns #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MagicHash, UnboxedTuples #-}+{-# LANGUAGE UndecidableInstances #-}+------------------------------------------------------------------------+-- |+-- Module : Data.Extensible.Struct+-- Copyright : (c) Fumiaki Kinoshita 2018+-- License : BSD3+--+-- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>+--+-- Mutable structs+------------------------------------------------------------------------+module Data.Extensible.Struct (+ -- * Mutable struct+ Struct+ , set+ , get+ , new+ , newRepeat+ , newFor+ , newFromHList+ , WrappedPointer(..)+ , (-$>)+ -- ** Atomic operations+ , atomicModify+ , atomicModify'+ , atomicModify_+ , atomicModify'_+ -- * Immutable product+ , (:&)+ , (:*)+ , unsafeFreeze+ , newFrom+ , hlookup+ , hlength+ , type (++)+ , happend+ , hfoldrWithIndex+ , thaw+ , hfrozen+ , hmodify+ , toHList) where++import GHC.Prim+import Control.Comonad+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Primitive+import Control.Monad.ST+import Data.Constraint+import Data.Extensible.Class+import Data.Extensible.Internal.Rig+import Data.Extensible.Wrapper+import Data.Profunctor.Rep+import Data.Profunctor.Sieve+import Data.Proxy+import Data.Kind (Type)+import qualified Data.StateVar as V+import GHC.Types+import qualified Type.Membership.HList as L+#if __GLASGOW_HASKELL__ >= 900+import Unsafe.Coerce+#endif++-- | Mutable type-indexed struct.+data Struct s (h :: k -> Type) (xs :: [k]) = Struct (SmallMutableArray# s Any)++-- | Write a value in a 'Struct'.+set :: PrimMonad m => Struct (PrimState m) h xs -> Membership xs x -> h x -> m ()+set (Struct m) (getMemberId -> I# i) e = primitive+ $ \s -> case unsafeCoerce# writeSmallArray# m i e s of+ s' -> (# s', () #)+{-# INLINE set #-}++-- | Read a value from a 'Struct'.+get :: PrimMonad m => Struct (PrimState m) h xs -> Membership xs x -> m (h x)+get (Struct m) (getMemberId -> I# i) = primitive $ unsafeCoerce# readSmallArray# m i+{-# INLINE get #-}++-- | Atomically modify an element in a 'Struct'.+atomicModify :: PrimMonad m+ => Struct (PrimState m) h xs -> Membership xs x -> (h x -> (h x, a)) -> m a+atomicModify (Struct m) (getMemberId -> I# i) f = primitive+ $ \s0 -> case readSmallArray# m i s0 of+ (# s, x #) -> retry x s+ where+ retry x s = let p = unsafeCoerce# f x in+ case casSmallArray# m i x (fst p) s of+ (# s', b, y #) -> case b of+ 0# -> (# s', snd p #)+ _ -> retry y s'+{-# INLINE atomicModify #-}++-- | Strict version of 'atomicModify'.+atomicModify' :: PrimMonad m+ => Struct (PrimState m) h xs -> Membership xs x -> (h x -> (h x, a)) -> m a+atomicModify' s i f = atomicModify s i+ (\x -> let (y, a) = f x in (y, y `seq` a))+ >>= (return $!)+{-# INLINE atomicModify' #-}++-- | Apply a function to an element atomically.+atomicModify_ :: PrimMonad m+ => Struct (PrimState m) h xs -> Membership xs x -> (h x -> h x) -> m (h x)+atomicModify_ (Struct m) (getMemberId -> I# i) f = primitive+ $ \s0 -> case readSmallArray# m i s0 of+ (# s, x #) -> retry x s+ where+ retry x s = case casSmallArray# m i x (unsafeCoerce# f x) s of+ (# s', b, y #) -> case b of+ 0# -> (# s', unsafeCoerce# y #)+ _ -> retry y s'+{-# INLINE atomicModify_ #-}++-- | Strict version of 'atomicModify_'.+atomicModify'_ :: PrimMonad m+ => Struct (PrimState m) h xs -> Membership xs x -> (h x -> h x) -> m (h x)+atomicModify'_ s i f = atomicModify_ s i f >>= (return $!)+{-# INLINE atomicModify'_ #-}++-- | A pointer to an element in a 'Struct'.+data WrappedPointer s h a where+ WrappedPointer :: !(Struct s h xs)+ -> !(Membership xs x)+ -> WrappedPointer s h (Repr h x)++instance (s ~ RealWorld, Wrapper h) => V.HasGetter (WrappedPointer s h a) a where+ get (WrappedPointer s i) = liftIO $ view _Wrapper <$> get s i++instance (s ~ RealWorld, Wrapper h) => V.HasSetter (WrappedPointer s h a) a where+ WrappedPointer s i $= v = liftIO $ set s i $ review _Wrapper v++instance (s ~ RealWorld, Wrapper h) => V.HasUpdate (WrappedPointer s h a) a a where+ WrappedPointer s i $~ f = liftIO $ void $ atomicModify_ s i $ over _Wrapper f+ WrappedPointer s i $~! f = liftIO $ void $ atomicModify'_ s i $ over _Wrapper f++-- | Get a 'WrappedPointer' from a name.+(-$>) :: forall k h xs v s. (Lookup xs k v) => Struct s h xs -> Proxy k -> WrappedPointer s h (Repr h (k ':> v))+s -$> _ = WrappedPointer s (association :: Membership xs (k ':> v))+{-# INLINE (-$>) #-}++-- | Create a new 'Struct' using the supplied initializer.+new :: forall h m xs. (PrimMonad m, Generate xs)+ => (forall x. Membership xs x -> h x)+ -> m (Struct (PrimState m) h xs)+new = newDict Dict+{-# INLINE new #-}++newDict :: PrimMonad m+ => Dict (Generate xs)+ -> (forall x. Membership xs x -> h x)+ -> m (Struct (PrimState m) h xs)+newDict Dict k = do+ m <- newRepeat undefined+ henumerate (\i cont -> set m i (k i) >> cont) $ return m+{-# NOINLINE[0] newDict #-}++-- | Create a 'Struct' full of the specified value.+newRepeat :: forall h m xs. (PrimMonad m, Generate xs)+ => (forall x. h x)+ -> m (Struct (PrimState m) h xs)+newRepeat x = do+ let !(I# n) = hcount (Proxy :: Proxy xs)+ primitive $ \s -> case newSmallArray# n (unsafeCoerce# x) s of+ (# s', a #) -> (# s', Struct a #)+{-# INLINE newRepeat #-}++-- | Create a new 'Struct' using the supplied initializer with a context.+newFor :: forall proxy c h m xs. (PrimMonad m, Forall c xs)+ => proxy c+ -> (forall x. c x => Membership xs x -> h x)+ -> m (Struct (PrimState m) h xs)+newFor = newForDict Dict+{-# INLINE newFor #-}++newForDict :: forall proxy c h m xs. (PrimMonad m)+ => Dict (Forall c xs)+ -> proxy c+ -> (forall x. c x => Membership xs x -> h x)+ -> m (Struct (PrimState m) h xs)+newForDict Dict p k = do+ m <- newRepeat undefined+ henumerateFor p (Proxy :: Proxy xs) (\i cont -> set m i (k i) >> cont) $ return m+{-# NOINLINE[0] newForDict #-}++-- | Create a new 'Struct' from an 'HList'.+newFromHList :: forall h m xs. PrimMonad m => L.HList h xs -> m (Struct (PrimState m) h xs)+newFromHList l = do+ let !(I# size) = L.hlength l+ m <- primitive $ \s -> case newSmallArray# size undefined s of+ (# s', a #) -> (# s', Struct a #)++ let go :: Int -> L.HList h t -> m ()+ go _ L.HNil = return ()+ go i (L.HCons x xs) = set m (unsafeMembership i) x >> go (i + 1) xs++ go 0 l+ return m+{-# NOINLINE newFromHList #-}++-- | The type of extensible products.+--+-- @(:&) :: [k] -> (k -> Type) -> Type@+--+data (s :: [k]) :& (h :: k -> Type) = HProduct (SmallArray# Any)++type h :* xs = xs :& h+{-# DEPRECATED (:*) "Use :& instead" #-}++-- | Turn 'Struct' into an immutable product. The original 'Struct' may not be used.+unsafeFreeze :: PrimMonad m => Struct (PrimState m) h xs -> m (xs :& h)+unsafeFreeze (Struct m) = primitive $ \s -> case unsafeFreezeSmallArray# m s of+ (# s', a #) -> (# s', HProduct a #)+{-# INLINE unsafeFreeze #-}++-- | Create a new 'Struct' from a product.+thaw :: PrimMonad m => xs :& h -> m (Struct (PrimState m) h xs)+thaw (HProduct ar) = primitive $ \s -> case thawSmallArray# ar 0# (sizeofSmallArray# ar) s of+ (# s', m #) -> (# s', Struct m #)++-- | The size of a product.+hlength :: xs :& h -> Int+hlength (HProduct ar) = I# (sizeofSmallArray# ar)+{-# INLINE hlength #-}++-- | Concatenate type level lists+type family (++) (xs :: [k]) (ys :: [k]) :: [k] where+ '[] ++ ys = ys+ (x ': xs) ++ ys = x ': xs ++ ys++infixr 5 ++++-- | Combine products.+happend :: xs :& h -> ys :& h -> (xs ++ ys) :& h+happend (HProduct lhs) (HProduct rhs) = runST $ primitive $ \s0 ->+ let lhsSz = sizeofSmallArray# lhs+ rhsSz = sizeofSmallArray# rhs+ in case newSmallArray# (lhsSz +# rhsSz) undefined s0 of { (# s1, a #) ->+ case copySmallArray# lhs 0# a 0# lhsSz s1 of { s2 ->+ case copySmallArray# rhs 0# a lhsSz rhsSz s2 of { s3 ->+ case unsafeFreezeSmallArray# a s3 of { (# s4, frz #) ->+ (# s4, HProduct frz #) }}}}++infixr 5 `happend`++unsafeMembership :: Int -> Membership xs x+unsafeMembership = unsafeCoerce#++-- | Right-associative fold of a product.+hfoldrWithIndex :: (forall x. Membership xs x -> h x -> r -> r) -> r -> xs :& h -> r+hfoldrWithIndex f r p = foldr+ (\i -> let m = unsafeMembership i in f m (hlookup m p)) r [0..hlength p - 1]+{-# INLINE hfoldrWithIndex #-}++-- | Convert a product into an 'HList'.+toHList :: forall h xs. xs :& h -> L.HList h xs+toHList p = go 0 where+ go :: Int -> L.HList h xs+ go i+ | i == hlength p = unknownHList L.HNil+ | otherwise = unknownHList $ L.HCons (hlookup (unsafeMembership i) p) (go (i + 1))++ unknownHList :: L.HList h ys -> L.HList h zs+ unknownHList = unsafeCoerce#+{-# NOINLINE toHList #-}++{-# RULES "toHList/fromHList" forall x. toHList (hfrozen (newFromHList x)) = x #-}++-- | Create a new 'Struct' using the contents of a product.+newFrom :: forall g h m xs. (PrimMonad m)+ => xs :& g+ -> (forall x. Membership xs x -> g x -> h x)+ -> m (Struct (PrimState m) h xs)+newFrom hp@(HProduct ar) k = do+ let !n = sizeofSmallArray# ar+ st <- primitive $ \s -> case newSmallArray# n undefined s of+ (# s', a #) -> (# s', Struct a #)+ let go i+ | i == I# n = return st+ | otherwise = do+ let !m = unsafeMembership i+ set st m $! k m (hlookup m hp)+ go (i + 1)+ go 0+{-# NOINLINE newFrom #-}++{-# RULES "newFrom/newFrom" forall p (f :: forall x. Membership xs x -> f x -> g x)+ (g :: forall x. Membership xs x -> g x -> h x)+ . newFrom (hfrozen (newFrom p f)) g = newFrom p (\i x -> g i (f i x)) #-}++{-# RULES "newFrom/newDict" forall d (f :: forall x. Membership xs x -> g x)+ (g :: forall x. Membership xs x -> g x -> h x)+ . newFrom (hfrozen (newDict d f)) g = newDict d (\i -> g i (f i)) #-}++{-# RULES "newFrom/newForDict" forall d p (f :: forall x. Membership xs x -> g x)+ (g :: forall x. Membership xs x -> g x -> h x)+ . newFrom (hfrozen (newForDict d p f)) g = newForDict d p (\i -> g i (f i)) #-}++-- | Get an element in a product.+hlookup :: Membership xs x -> xs :& h -> h x+hlookup (getMemberId -> I# i) (HProduct ar) = case indexSmallArray# ar i of+ (# a #) -> unsafeCoerce# a+{-# INLINE hlookup #-}++-- | Create a product from an 'ST' action which returns a 'Struct'.+hfrozen :: (forall s. ST s (Struct s h xs)) -> xs :& h+hfrozen m = runST $ m >>= unsafeFreeze+{-# INLINE[0] hfrozen #-}++-- | Turn a product into a 'Struct' temporarily.+hmodify :: (forall s. Struct s h xs -> ST s ()) -> xs :& h -> xs :& h+hmodify f m = runST $ do+ s <- thaw m+ f s+ unsafeFreeze s+{-# INLINE[0] hmodify #-}++{-# RULES "hmodify/batch" forall+ (a :: forall s. Struct s h xs -> ST s ())+ (b :: forall s. Struct s h xs -> ST s ())+ (x :: xs :& h). hmodify b (hmodify a x) = hmodify (\s -> a s >> b s) x #-}++instance (Corepresentable p, Comonad (Corep p), Functor f) => Extensible f p (:&) where+ -- | A lens for a value in a known position.+ pieceAt i pafb = cotabulate $ \ws -> sbt (extract ws) <$> cosieve pafb (hlookup i <$> ws) where+ sbt xs !x = hmodify (\s -> set s i x) xs+ {-# INLINE pieceAt #-}
src/Data/Extensible/Sum.hs view
@@ -6,98 +6,88 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Extensible.Sum--- Copyright : (c) Fumiaki Kinoshita 2015+-- Copyright : (c) Fumiaki Kinoshita 2018 -- License : BSD3 -- -- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability : experimental--- Portability : non-portable -- ------------------------------------------------------------------------ module Data.Extensible.Sum (- (:|)(..)+ (:/)(..) , hoist , embed , strike , strikeAt , (<:|) , exhaust- , picked , embedAssoc ) where -import Data.Extensible.Internal-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif-import Data.Typeable import Data.Extensible.Class+import Data.Kind (Type) import Data.Profunctor+import Data.Proxy+import Data.Type.Equality+import Type.Membership -- | The extensible sum type ----- @(:|) :: (k -> *) -> [k] -> *@+-- @(:/) :: [k] -> (k -> Type) -> Type@ ---data (h :: k -> *) :| (s :: [k]) where- EmbedAt :: !(Membership xs x) -> h x -> h :| xs-deriving instance Typeable (:|)+data (xs :: [k]) :/ (h :: k -> Type) where+ EmbedAt :: !(Membership xs x) -> h x -> xs :/ h -instance Enum (Proxy :| xs) where+instance Enum (xs :/ Proxy) where fromEnum (EmbedAt m _) = fromIntegral $ getMemberId m toEnum i = reifyMembership (fromIntegral i) $ \m -> EmbedAt m Proxy -instance (Last xs ∈ xs) => Bounded (Proxy :| xs) where+instance (Last xs ∈ xs) => Bounded (xs :/ Proxy) where minBound = reifyMembership 0 $ \m -> EmbedAt m Proxy maxBound = EmbedAt (membership :: Membership xs (Last xs)) Proxy -- | Change the wrapper.-hoist :: (forall x. g x -> h x) -> g :| xs -> h :| xs+hoist :: (forall x. g x -> h x) -> xs :/ g -> xs :/ h hoist f (EmbedAt p h) = EmbedAt p (f h) {-# INLINE hoist #-} -- | /O(1)/ lift a value.-embed :: (x ∈ xs) => h x -> h :| xs+embed :: (x ∈ xs) => h x -> xs :/ h embed = EmbedAt membership {-# INLINE embed #-} -- | Try to extract something you want.-strike :: forall h x xs. (x ∈ xs) => h :| xs -> Maybe (h x)+strike :: forall h x xs. (x ∈ xs) => xs :/ h -> Maybe (h x) strike = strikeAt membership {-# INLINE strike #-} -- | Try to extract something you want.-strikeAt :: forall h x xs. Membership xs x -> h :| xs -> Maybe (h x)+strikeAt :: forall h x xs. Membership xs x -> xs :/ h -> Maybe (h x) strikeAt q (EmbedAt p h) = case compareMembership p q of Right Refl -> Just h _ -> Nothing {-# INLINE strikeAt #-} -- | /O(1)/ Naive pattern match-(<:|) :: (h x -> r) -> (h :| xs -> r) -> h :| (x ': xs) -> r-(<:|) r c = \(EmbedAt i h) -> runMembership i+(<:|) :: (h x -> r)+ -> (xs :/ h -> r)+ -> (x ': xs) :/ h+ -> r+(<:|) r c = \(EmbedAt i h) -> testMembership i (\Refl -> r h) (\j -> c (EmbedAt j h)) infixr 1 <:| {-# INLINE (<:|) #-} -- | There is no empty union.-exhaust :: h :| '[] -> r+exhaust :: '[] :/ h -> r exhaust _ = error "Impossible" -- | Embed a value, but focuses on its key.-embedAssoc :: Associate k a xs => h (k ':> a) -> h :| xs+embedAssoc :: Lookup xs k a => h (k ':> a) -> xs :/ h embedAssoc = EmbedAt association {-# INLINE embedAssoc #-} -{-# DEPRECATED picked "Use piece instead" #-}--- | A traversal that tries to point a specific element.-picked :: forall f h x xs. (x ∈ xs, Applicative f) => (h x -> f (h x)) -> h :| xs -> f (h :| xs)-picked f u@(EmbedAt i h) = case compareMembership (membership :: Membership xs x) i of- Right Refl -> fmap (EmbedAt i) (f h)- _ -> pure u-{-# INLINE picked #-}--instance (Applicative f, Choice p) => Extensible f p (:|) where+instance (Applicative f, Choice p) => Extensible f p (:/) where pieceAt m = dimap (\t@(EmbedAt i h) -> case compareMembership i m of Right Refl -> Right h Left _ -> Left t) (either pure (fmap (EmbedAt m))) . right'
src/Data/Extensible/TH.hs view
@@ -2,28 +2,21 @@ ------------------------------------------------------------------------ -- | -- Module : Data.Extensible.TH--- Copyright : (c) Fumiaki Kinoshita 2015+-- Copyright : (c) Fumiaki Kinoshita 2018 -- License : BSD3 -- -- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability : experimental--- Portability : non-portable -- -------------------------------------------------------------------------module Data.Extensible.TH (mkField, decEffects) where+module Data.Extensible.TH (mkField+ , mkFieldAs) where -import Data.Proxy-import Data.Extensible.Internal import Data.Extensible.Class (itemAssoc)-import Data.Extensible.Effect import Data.Extensible.Field import Language.Haskell.TH import Data.Char import Control.Monad--#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (foldMap)-#endif+import Type.Membership -- | Generate fields using 'itemAssoc'. -- @'mkField' "foo Bar"@ defines:@@ -36,101 +29,18 @@ -- @ -- mkField :: String -> DecsQ-mkField str = fmap concat $ forM (words str) $ \s@(x:xs) -> do+mkField str = fmap concat $ forM (words str) $ \s ->+ let name = mkName $ case s of+ x : xs -> if isLower x then x : xs else '_' : x : xs+ _ -> error "Impossible"+ in mkFieldAs name s++-- | @'mkFieldAs' (mkName "foo") "bar"@ defines a field for "bar" as @foo@.+mkFieldAs :: Name -> String -> DecsQ+mkFieldAs name s = do let st = litT (strTyLit s)- let name = mkName $ if isLower x then x : xs else '_' : x : xs let lbl = conE 'Proxy `sigE` (conT ''Proxy `appT` st) sequence [sigD name $ conT ''FieldOptic `appT` st , valD (varP name) (normalB $ varE 'itemAssoc `appE` lbl) [] , return $ PragmaD $ InlineP name Inline FunLike AllPhases ]---- | Generate named effects from a GADT declaration.-decEffects :: DecsQ -> DecsQ-decEffects decs = decs >>= \ds -> fmap concat $ forM ds $ \case-#if MIN_VERSION_template_haskell(2,11,0)- DataD _ _ (fmap getTV -> tyvars) _ cs _-#else- DataD _ _ (fmap getTV -> tyvars) cs _-#endif- | not (null tyvars) -> fmap concat $ forM cs $ \case- NormalC con st -> mk tyvars [] con st- ForallC _ eqs (NormalC con st) -> mk tyvars eqs con st- p -> do- runIO (print p)- fail "Unsupported constructor"- _ -> fail "mkEffects accepts GADT declaration"- where- mk tyvars eqs con (fmap snd -> argTypes) = do-#if MIN_VERSION_template_haskell(2,10,0)- let dic_ = [(v, t) | AppT (AppT EqualityT (VarT v)) t <- eqs]-#else- let dic_ = [(v, t) | EqualP (VarT v) t <- eqs]-#endif- let dic = dic_ ++ [(t, VarT v) | (v, VarT t) <- dic_]-- let tvs = map mkName $ concatMap (flip replicateM ['a'..'z']) [1..]-- let params' = do- (t, v) <- zip tyvars tvs- case lookup t dic of- Just (VarT p) -> return (t, p)- _ -> return (t, v)-- let (_, fts) = foldMap (\(p, t) -> maybe ([VarT t], [t]) (\case- VarT _ -> ([VarT t], [t])- x -> ([x], [])) (lookup p dic)) (init params')-- let argTypes' = map (\case- VarT n -> maybe (VarT n) VarT $ lookup n params'- x -> x) argTypes-- let (extra, result) = case lookup (last tyvars) dic of- Just (VarT v) -> (id, case lookup v params' of- Just p -> VarT p- Nothing -> VarT v)- Just t -> (id, t)- Nothing -> ((PlainTV (mkName "x"):), VarT $ mkName "x")-- -- Eff xs R- let rt = ConT ''Eff `AppT` VarT (mkName "xs") `AppT` result-- -- a -> B -> C -> Eff xs R- let fun = foldr (\x y -> ArrowT `AppT` x `AppT` y) rt argTypes'-- -- Action [a, B, C] R- let eff = ConT ''Action- `AppT` foldr (\x y -> PromotedConsT `AppT` x `AppT` y) PromotedNilT argTypes'- `AppT` result-- -- "Foo"- let nameT = LitT $ StrTyLit $ nameBase con-- -- Associate "Foo" (Foo a B C) xs-#if MIN_VERSION_template_haskell(2,10,0)- let cx = ConT ''Associate- `AppT` nameT- `AppT` eff- `AppT` VarT (mkName "xs")-#else- let cx = ClassP ''Associate [nameT, eff, VarT (mkName "xs")]-#endif-- let typ = ForallT (PlainTV (mkName "xs") : extra (map PlainTV fts)) [cx] fun-- -- liftEff (Proxy :: Proxy "Foo")- let lifter = VarE 'liftEff `AppE` (ConE 'Proxy `SigE` AppT (ConT ''Proxy) nameT)-- let argNames = map (mkName . ("a" ++) . show) [0..length argTypes-1]-- let ex = lifter- `AppE` foldr (\x y -> ConE 'AArgument `AppE` x `AppE` y)- (ConE 'AResult)- (map VarE argNames)-- let fName = let (ch : rest) = nameBase con in mkName $ toLower ch : rest- return [SigD fName typ- , FunD fName [Clause (map VarP argNames) (NormalB ex) []]]-- getTV (PlainTV n) = n- getTV (KindedTV n _) = n
+ src/Data/Extensible/Tangle.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE ScopedTypeVariables #-}+------------------------------------------------------------------------+-- |+-- Module : Data.Extensible.Struct+-- Copyright : (c) Fumiaki Kinoshita 2018+-- License : BSD3+--+-- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>+--+-- Extensible tangles+------------------------------------------------------------------------+module Data.Extensible.Tangle+ ( TangleT(..)+ , lasso+ , hitchAt+ , runTangleT+ , evalTangleT+ , runTangles+ ) where++import Control.Applicative+import Control.Monad.Trans.RWS.Strict+import Control.Monad.Trans.Class+import Data.Functor.Compose+import Data.Extensible.Class+import Data.Extensible.Product+import Data.Extensible.Internal.Rig+import Data.Extensible.Nullable+import Data.Extensible.Wrapper+import Data.Proxy++-- | @'TangleT' h xs m@ is the monad of computations that may depend on the elements in 'xs'.+newtype TangleT xs h m a = TangleT+ { unTangleT :: RWST (xs :& Compose (TangleT xs h m) h) () (xs :& Nullable h) m a }+ deriving (Functor, Applicative, Monad)++instance MonadTrans (TangleT xs h) where+ lift = TangleT . lift++instance (Monad m, Semigroup a) => Semigroup (TangleT xs h m a) where+ (<>) = liftA2 (<>)++instance (Monad m, Monoid a) => Monoid (TangleT xs h m a) where+ mempty = pure mempty+ mappend = (<>)++-- | Hitch an element associated to the 'FieldName' through a wrapper.+lasso :: forall k v m h xs. (Monad m, Lookup xs k v, Wrapper h)+ => Proxy k -> TangleT xs h m (Repr h (k ':> v))+lasso _ = view _Wrapper <$> hitchAt (association :: Membership xs (k ':> v))+{-# INLINE lasso #-}++-- | Take a value from the tangles. The result is memoized.+hitchAt :: Monad m => Membership xs x -> TangleT xs h m (h x)+hitchAt k = TangleT $ do+ mem <- get+ case getNullable $ hlookup k mem of+ Just a -> return a+ Nothing -> do+ tangles <- ask+ a <- unTangleT $ getCompose $ hlookup k tangles+ modify $ over (pieceAt k) $ const $ Nullable $ Just a+ return a++-- | Run a 'TangleT' action and return the result and the calculated values.+runTangleT :: Monad m+ => xs :& Compose (TangleT xs h m) h+ -> xs :& Nullable h+ -> TangleT xs h m a+ -> m (a, xs :& Nullable h)+runTangleT tangles rec0 (TangleT m) = (\(a, s, _) -> (a, s))+ <$> runRWST m tangles rec0+{-# INLINE runTangleT #-}++-- | Run a 'TangleT' action.+evalTangleT :: Monad m+ => xs :& Compose (TangleT xs h m) h+ -> xs :& Nullable h+ -> TangleT xs h m a+ -> m a+evalTangleT tangles rec0 (TangleT m) = fst <$> evalRWST m tangles rec0+{-# INLINE evalTangleT #-}++-- | Run tangles and collect all the results as a 'Record'.+runTangles :: Monad m+ => xs :& Compose (TangleT xs h m) h+ -> xs :& Nullable h+ -> m (xs :& h)+runTangles ts vs = evalTangleT ts vs $ htraverseWithIndex (const . hitchAt) vs+{-# INLINE runTangles #-}
src/Data/Extensible/Wrapper.hs view
@@ -1,74 +1,145 @@-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -{-# LANGUAGE TypeFamilies #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Extensible.Wrapper --- Copyright : (c) Fumiaki Kinoshita 2015 --- License : BSD3 --- --- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com> --- Stability : experimental --- Portability : non-portable --- ------------------------------------------------------------------------------ -module Data.Extensible.Wrapper ( - Wrapper(..) - , _WrapperAs - , Const'(..) - , Comp(..) - , comp - ) where - -import Data.Typeable (Typeable) -import Data.Proxy (Proxy(..)) -import Data.Profunctor.Unsafe (Profunctor(..)) -import Data.Functor.Identity (Identity(..)) -import Data.Extensible.Internal.Rig (Optic', withIso) - --- | The extensible data types should take @k -> *@ as a parameter. --- This class allows us to take a shortcut for direct representation. -class Wrapper (h :: k -> *) where - -- | @'Repr' h v@ is the actual representation of @h v@. - type Repr h (v :: k) :: * - - -- | This is an isomorphism between @h v@ and @'Repr' h v@. - -- - -- @_Wrapper :: Iso' (h v) (Repr h v)@ - -- - _Wrapper :: (Functor f, Profunctor p) => Optic' p f (h v) (Repr h v) - --- | Restricted version of '_Wrapper'. --- It is useful for eliminating ambiguousness. -_WrapperAs :: (Functor f, Profunctor p, Wrapper h) => proxy v -> Optic' p f (h v) (Repr h v) -_WrapperAs _ = _Wrapper -{-# INLINE _WrapperAs #-} - -instance Wrapper Identity where - type Repr Identity a = a - _Wrapper = dimap runIdentity (fmap Identity) - {-# INLINE _Wrapper #-} - --- | Poly-kinded composition -newtype Comp (f :: j -> *) (g :: i -> j) (a :: i) = Comp { getComp :: f (g a) } deriving (Show, Eq, Ord, Typeable) - -comp :: Functor f => (a -> g b) -> f a -> Comp f g b -comp f = Comp #. fmap f -{-# INLINE comp #-} - -instance (Functor f, Wrapper g) => Wrapper (Comp f g) where - type Repr (Comp f g) x = f (Repr g x) - _Wrapper = withIso _Wrapper $ \f g -> dimap (fmap f .# getComp) (fmap (Comp #. fmap g)) - {-# INLINE _Wrapper #-} - --- | Poly-kinded Const -newtype Const' a x = Const' { getConst' :: a } deriving (Show, Eq, Ord, Typeable) - -instance Wrapper (Const' a) where - type Repr (Const' a) b = a - _Wrapper = dimap getConst' (fmap Const') - {-# INLINE _Wrapper #-} - -instance Wrapper Proxy where - type Repr Proxy x = () - _Wrapper = dimap (const ()) (fmap (const Proxy)) - {-# INLINE _Wrapper #-} +{-# LANGUAGE DeriveTraversable, StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PatternSynonyms #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Extensible.Wrapper+-- Copyright : (c) Fumiaki Kinoshita 2018+-- License : BSD3+--+-- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>+--+-----------------------------------------------------------------------------+module Data.Extensible.Wrapper (+ Wrapper(..)+ , _WrapperAs+ , type Comp+ , pattern Comp+ , getComp+ , comp+ , Prod(..)+ ) where++import Control.Applicative+import Control.DeepSeq+import Data.Typeable (Typeable)+import Data.Proxy (Proxy(..))+import Data.Profunctor.Unsafe (Profunctor(..))+import Data.Functor.Compose+import Data.Functor.Identity (Identity(..))+import Data.Extensible.Internal.Rig+import Data.Hashable+import Data.Kind (Type)+import GHC.Generics (Generic)+import Test.QuickCheck.Arbitrary+++-- | The extensible data types should take @k -> Type@ as a parameter.+-- This class allows us to take a shortcut for direct representation.+class Wrapper (h :: k -> Type) where+ -- | @'Repr' h v@ is the user-facing representation of @h v@.+ type Repr h (v :: k) :: Type++ -- | This is an isomorphism between @h v@ and @'Repr' h v@.+ --+ -- @_Wrapper :: Iso' (h v) (Repr h v)@+ --+ _Wrapper :: (Functor f, Profunctor p) => Optic' p f (h v) (Repr h v)+ _Wrapper = dimap unwrap (fmap wrap)+ {-# INLINE _Wrapper #-}++ wrap :: Repr h v -> h v+ wrap = review _Wrapper+ {-# INLINE wrap #-}++ unwrap :: h v -> Repr h v+ unwrap = view _Wrapper+ {-# INLINE unwrap #-}++ {-# MINIMAL wrap, unwrap | _Wrapper #-}++-- | Restricted version of '_Wrapper'.+-- It is useful for eliminating ambiguousness.+_WrapperAs :: (Functor f, Profunctor p, Wrapper h) => proxy v -> Optic' p f (h v) (Repr h v)+_WrapperAs _ = _Wrapper+{-# INLINE _WrapperAs #-}++instance Wrapper Identity where+ type Repr Identity a = a+ unwrap = runIdentity+ {-# INLINE unwrap #-}+ wrap = Identity+ {-# INLINE wrap #-}++instance Wrapper Maybe where+ type Repr Maybe a = Maybe a+ _Wrapper = id++instance Wrapper (Either e) where+ type Repr (Either e) a = Either e a+ _Wrapper = id++instance Wrapper [] where+ type Repr [] a = [a]+ _Wrapper = id++type Comp = Compose++pattern Comp :: f (g a) -> Compose f g a+pattern Comp a = Compose a+{-# DEPRECATED Comp "Use Compose instead" #-}+++getComp :: Compose f g a -> f (g a)+getComp = getCompose+{-# DEPRECATED getComp "Use getCompose instead" #-}++-- | Wrap a result of 'fmap'+comp :: Functor f => (a -> g b) -> f a -> Compose f g b+comp f = Compose #. fmap f+{-# INLINE comp #-}++instance (Functor f, Wrapper g) => Wrapper (Compose f g) where+ type Repr (Compose f g) x = f (Repr g x)+ _Wrapper = withIso _Wrapper $ \f g -> dimap (fmap f .# getCompose) (fmap (comp g))+ {-# INLINE _Wrapper #-}++instance Wrapper (Const a) where+ type Repr (Const a) b = a+ wrap = Const+ {-# INLINE wrap #-}+ unwrap = getConst+ {-# INLINE unwrap #-}++instance Wrapper Proxy where+ type Repr Proxy x = ()+ wrap _ = Proxy+ {-# INLINE wrap #-}+ unwrap _ = ()+ {-# INLINE unwrap #-}++-- | Poly-kinded product+data Prod f g a = Prod (f a) (g a)+ deriving (Show, Eq, Ord, Typeable, Generic, Functor, Foldable, Traversable)++instance (NFData (f a), NFData (g a)) => NFData (Prod f g a)+instance (Hashable (f a), Hashable (g a)) => Hashable (Prod f g a)++instance (Wrapper f, Wrapper g) => Wrapper (Prod f g) where+ type Repr (Prod f g) a = (Repr f a, Repr g a)+ unwrap (Prod f g) = (unwrap f, unwrap g)+ {-# INLINE unwrap #-}+ wrap (f, g) = wrap f `Prod` wrap g+ {-# INLINE wrap #-}++instance (Semigroup (f a), Semigroup (g a)) => Semigroup (Prod f g a) where+ Prod a b <> Prod c d = Prod (a <> c) (b <> d)++instance (Monoid (f a), Monoid (g a)) => Monoid (Prod f g a) where+ mempty = Prod mempty mempty+ mappend = (<>)++instance (Arbitrary (f a), Arbitrary (g a)) => Arbitrary (Prod f g a) where+ arbitrary = Prod <$> arbitrary <*> arbitrary+ shrink (Prod a b) = Prod a `map` shrink b ++ flip Prod b `map` shrink a
+ tests/bits.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies, FlexibleContexts #-}+{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++import Control.Lens+import Data.Bits+import Data.Extensible+import Data.Extensible.Bits+import Data.Int+import Data.Proxy+import Data.Word+import GHC.TypeLits+import Language.Haskell.TH (mkName)+import Test.QuickCheck++type Fields = ["a" >: Bool, "b" >: Word8, "c" >: Bool]++mkFieldAs (mkName "_a") "a"+mkFieldAs (mkName "_b") "b"+mkFieldAs (mkName "_c") "c"+++prop_lensA1 x r = set _a x (BitProd r :: Rec) ^. _a == x+prop_lensA2 b = let r = BitProd b :: Rec+ in set _a (r ^. _a) r == r+prop_lensA3 b x y = let r = BitProd b :: Rec+ in set _a x (set _a y r) == set _a x r++prop_lensB1 x r = set _b x (BitProd r :: Rec) ^. _b == x+prop_lensB2 b = let r = BitProd b :: Rec+ in set _b (r ^. _b) r == r+prop_lensB3 b x y = let r = BitProd b :: Rec+ in set _b x (set _b y r) == set _b x r++prop_lensC1 x r = set _c x (BitProd r :: Rec) ^. _c == x+prop_lensC2 b = let r = BitProd b :: Rec+ in set _c (r ^. _c) r == r+prop_lensC3 b x y = let r = BitProd b :: Rec+ in set _c x (set _c y r) == set _c x r++type Rec = BitRecord Word64 Fields++focus :: forall a. (Eq a, Show a) => FromBits Word64 a => Word64 -> a -> Property+focus x a = let w = fromIntegral $ natVal (Proxy :: Proxy (BitWidth a))+ in fromBits (x `shiftL` w .|. toBits a) === a++clean :: forall a. Eq a => FromBits Word64 a => a -> Property+clean a = let w = fromIntegral $ natVal (Proxy :: Proxy (BitWidth a))+ in toBits a `shiftR` w === (zeroBits :: Word64)++prop_focus_Word8 :: Word64 -> Word8 -> Property+prop_focus_Word8 = focus++prop_clean_Word8 :: Word8 -> Property+prop_clean_Word8 = clean++prop_focus_Word16 :: Word64 -> Word16 -> Property+prop_focus_Word16 = focus++prop_clean_Word16 :: Word16 -> Property+prop_clean_Word16 = clean++prop_focus_Word32 :: Word64 -> Word32 -> Property+prop_focus_Word32 = focus++prop_clean_Word32 :: Word32 -> Property+prop_clean_Word32 = clean++prop_focus_Int8 :: Word64 -> Int8 -> Property+prop_focus_Int8 = focus++prop_clean_Int8 :: Int8 -> Property+prop_clean_Int8 = clean++prop_focus_Int16 :: Word64 -> Int16 -> Property+prop_focus_Int16 = focus++prop_clean_Int16 :: Int16 -> Property+prop_clean_Int16 = clean++prop_focus_Int32 :: Word64 -> Int32 -> Property+prop_focus_Int32 = focus++prop_clean_Int32 :: Int32 -> Property+prop_clean_Int32 = clean++prop_focus_Bool :: Word64 -> Bool -> Property+prop_focus_Bool = focus++prop_clean_Bool :: Bool -> Property+prop_clean_Bool = clean++return []+main = $quickCheckAll