extensible 0.4.10.1 → 0.9.2
raw patch · 30 files changed
Files
- .gitignore +1/−0
- .travis.yml +0/−120
- CHANGELOG.md +86/−0
- README.md +3/−3
- examples/eff.hs +0/−23
- examples/nullable.hs +20/−0
- extensible.cabal +40/−31
- src/Data/Extensible.hs +5/−6
- src/Data/Extensible/Bits.hs +30/−27
- src/Data/Extensible/Class.hs +33/−76
- src/Data/Extensible/Dictionary.hs +162/−204
- src/Data/Extensible/Effect.hs +0/−463
- src/Data/Extensible/Effect/Default.hs +0/−157
- src/Data/Extensible/Field.hs +55/−126
- src/Data/Extensible/HList.hs +0/−48
- src/Data/Extensible/Inclusion.hs +8/−14
- src/Data/Extensible/Internal.hs +0/−211
- src/Data/Extensible/Internal/Rig.hs +4/−0
- src/Data/Extensible/Label.hs +4/−23
- src/Data/Extensible/Match.hs +3/−4
- src/Data/Extensible/Nullable.hs +39/−15
- src/Data/Extensible/Plain.hs +4/−5
- src/Data/Extensible/Product.hs +107/−47
- src/Data/Extensible/Record.hs +53/−59
- src/Data/Extensible/Struct.hs +29/−22
- src/Data/Extensible/Sum.hs +20/−22
- src/Data/Extensible/TH.hs +6/−166
- src/Data/Extensible/Tangle.hs +22/−22
- src/Data/Extensible/Wrapper.hs +55/−38
- tests/effects.hs +0/−22
.gitignore view
@@ -11,6 +11,7 @@ cabal.config .stack-work .bash_history+dist-newstyle # ========================= # Operating System Files
− .travis.yml
@@ -1,120 +0,0 @@-# This Travis job script has been generated by a script via-#-# runghc make_travis_yml_2.hs 'extensible.cabal'-#-# For more information, see https://github.com/hvr/multi-ghc-travis-#-language: c-sudo: false--git:- submodules: false # whether to recursively clone submodules--cache:- directories:- - $HOME/.cabal/packages- - $HOME/.cabal/store--before_cache:- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log- # remove files that are regenerated by 'cabal update'- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx-- - rm -rfv $HOME/.cabal/packages/head.hackage--matrix:- include:- - compiler: "ghc-7.10.3"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.10.3], sources: [hvr-ghc]}}- - compiler: "ghc-8.0.2"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}}- - compiler: "ghc-8.2.1"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}}- - compiler: "ghc-8.4.1"- env: GHCHEAD=true- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.4.1], sources: [hvr-ghc]}}--before_install:- - HC=${CC}- - HCPKG=${HC/ghc/ghc-pkg}- - unset CC- - ROOTDIR=$(pwd)- - mkdir -p $HOME/.local/bin- - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"- - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))- - echo $HCNUMVER--install:- - cabal --version- - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"- - BENCH=${BENCH---enable-benchmarks}- - TEST=${TEST---enable-tests}- - HADDOCK=${HADDOCK-true}- - INSTALLED=${INSTALLED-true}- - GHCHEAD=${GHCHEAD-false}- - travis_retry cabal update -v- - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"- - rm -fv cabal.project cabal.project.local- # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage- - |- if $GHCHEAD; then- sed -i.bak 's/-- allow-newer:.*/allow-newer: *:base, *:template-haskell, *:ghc, *:Cabal/' ${HOME}/.cabal/config-- echo 'repository head.hackage' >> ${HOME}/.cabal/config- echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config- echo ' secure: True' >> ${HOME}/.cabal/config- echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config- echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config- echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config- echo ' key-threshold: 3' >> ${HOME}/.cabal.config-- cabal new-update head.hackage -v- fi- - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'- - "printf 'packages: \".\"\\n' > cabal.project"- - cat cabal.project- - if [ -f "./configure.ac" ]; then- (cd "." && autoreconf -i);- fi- - rm -f cabal.project.freeze- - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all- - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all- - rm -rf .ghc.environment.* "."/dist- - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)--# 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:- # test that source-distributions can be generated- - (cd "." && cabal sdist)- - mv "."/dist/extensible-*.tar.gz ${DISTDIR}/- - cd ${DISTDIR} || false- - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;- - "printf 'packages: extensible-*/*.cabal\\n' > cabal.project"- - cat cabal.project- # this builds all libraries and executables (without tests/benchmarks)- - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all-- # Build with installed constraints for packages in global-db- - if $INSTALLED; then echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks $(${HCPKG} list --global --simple-output --names-only | sed 's/\([a-zA-Z0-9-]\{1,\}\) */--constraint="\1 installed" /g') all | sh; else echo "Not building with installed constraints"; fi-- # build & run tests, build benchmarks- - cabal new-build -w ${HC} ${TEST} ${BENCH} all- - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi-- # cabal check- - (cd extensible-* && cabal check)-- # haddock- - rm -rf ./dist-newstyle- - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi--# REGENDATA ["extensible.cabal"]-# EOF
CHANGELOG.md view
@@ -1,3 +1,89 @@+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
README.md view
@@ -1,8 +1,8 @@-extensible-======================+ -[](https://travis-ci.org/fumieval/extensible)+ [](https://hackage.haskell.org/package/extensible)+[](https://discord.gg/DG93Tgs) This package provides extensible poly-kinded records, variants and effects.
− examples/eff.hs
@@ -1,23 +0,0 @@-{-# LANGUAGE TypeApplications, OverloadedLabels, PolyKinds, DataKinds, ScopedTypeVariables, Rank2Types #-}-import Data.Extensible--import Prelude hiding (readFile)-import Control.Exception-import Data.ByteString (ByteString)--data FileSystem r where- ReadFile- :: FilePath- -> FileSystem (Either SomeException ByteString)--readFile- :: forall xs- . (Associate "fs" FileSystem xs- , Associate "fs_error" (EitherEff SomeException) xs)- => FilePath- -> Eff xs ByteString-readFile fp = liftEff #fs (ReadFile fp)- >>= either (throwEff #fs_error) pure--foo :: forall xs. Associate "fs" FileSystem xs => Eff xs (Either SomeException ByteString)-foo = castEff (runEitherEff @ "fs_error" (readFile "foo") :: Eff '["fs" >: FileSystem] (Either SomeException ByteString))
+ 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}")
extensible.cabal view
@@ -1,5 +1,6 @@+cabal-version: 2.4 name: extensible-version: 0.4.10.1+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@@ -7,28 +8,41 @@ 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: BSD3+license: BSD-3-Clause license-file: LICENSE author: Fumiaki Kinoshita maintainer: Fumiaki Kinoshita <fumiexcel@gmail.com>-copyright: Copyright (c) 2017 Fumiaki Kinoshita-category: Data, Records, Monads+copyright: Copyright (c) 2017-2022 Fumiaki Kinoshita+category: Data, Records build-type: Simple stability: experimental-Tested-With: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1, GHC == 8.4.1+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@@ -36,12 +50,8 @@ Data.Extensible.Class Data.Extensible.Dictionary Data.Extensible.Field- Data.Extensible.Effect- Data.Extensible.Effect.Default Data.Extensible.GetOpt- Data.Extensible.HList Data.Extensible.Inclusion- Data.Extensible.Internal Data.Extensible.Internal.Rig Data.Extensible.Label Data.Extensible.Match@@ -52,11 +62,12 @@ Data.Extensible.Struct Data.Extensible.Sum Data.Extensible.Tangle- Data.Extensible.Wrapper Data.Extensible.TH+ Data.Extensible.Wrapper default-extensions: TypeOperators , DeriveDataTypeable , DeriveGeneric+ , DeriveLift , GeneralizedNewtypeDeriving , KindSignatures , ConstraintKinds@@ -67,41 +78,39 @@ , FlexibleInstances , PolyKinds , CPP+ , NoStarIsType build-depends: base >= 4.8 && <5- , aeson+ , aeson >= 1.5 && <2.3 , bytestring- , cassava , comonad , constraints , deepseq- , exceptions , ghc-prim- , hashable- , monad-skeleton >= 0.1.2- , mtl- , prettyprinter+ , hashable >= 1.2 && <1.5+ , incremental >= 0.3.1+ , membership+ , prettyprinter ^>= 1.7 , primitive , profunctors- , resourcet , QuickCheck- , semigroups , StateVar , tagged , template-haskell , text- , th-lift+ , th-lift >= 0.8 , transformers , unordered-containers- , vector+ , 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- default-language: Haskell2010--test-suite effects- type: exitcode-stdio-1.0- main-is: effects.hs- build-depends: base, extensible- hs-source-dirs: tests+ ghc-options: -Wall -Wcompat default-language: Haskell2010 test-suite bits
src/Data/Extensible.hs view
@@ -30,13 +30,10 @@ 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.Label , module Data.Extensible.Match , module Data.Extensible.Nullable- , module Data.Extensible.Plain , module Data.Extensible.Product , module Data.Extensible.Record , module Data.Extensible.Sum@@ -45,17 +42,19 @@ , 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-import Data.Extensible.Label+#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
src/Data/Extensible/Bits.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE UndecidableInstances, ScopedTypeVariables, MultiParamTypeClasses, TypeFamilies #-} {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric #-}+#if __GLASGOW_HASKELL__ < 806+{-# LANGUAGE TypeInType #-}+#endif ----------------------------------------------------------------------- -- | -- Module : Data.Extensible.Bits@@ -21,17 +24,17 @@ , 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.Internal (getMemberId) import Data.Extensible.Field-import Data.Extensible.Wrapper 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@@ -42,10 +45,10 @@ import GHC.TypeLits -- | Bit-vector product. It has similar interface as @(:*)@ but fields are packed into @r@.-newtype BitProd r (h :: k -> *) (xs :: [k]) = BitProd { unBitProd :: 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 h xs) => Show (BitProd r h xs) where+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) @@ -130,51 +133,51 @@ 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 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, FromBits r (h (AssocValue x))) => FromBits r (Field h x) where- type BitWidth (Field h x) = BitWidth (h (AssocValue x))+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 h xs) where- type BitWidth (BitProd r h xs) = TotalBits h xs+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 h xs = (FromBits r r+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 h xs. BitFields r h xs => h :* xs -> BitProd r h xs+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 h xs. BitFields r h xs => BitProd r h xs -> h :* xs+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 h xs.- (BitFields r h xs, FromBits r (h x))- => Membership xs x -> BitProd r h xs -> h x+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 h xs.- (BitFields r h xs, FromBits r (h x))- => Membership xs x -> BitProd r h xs -> h x -> BitProd r h xs+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@@ -183,8 +186,8 @@ offset = bitOffsetAt (Proxy :: Proxy r) (Proxy :: Proxy h) (Proxy :: Proxy xs) $ getMemberId i {-# INLINE bupdate #-} -bitOffsetAt :: forall r h xs. Forall (Instance1 (FromBits r) h) xs- => Proxy (r :: *) -> Proxy (h :: k -> *) -> Proxy (xs :: [k]) -> Int -> Int+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)@@ -198,13 +201,13 @@ proxyBitWidth _ _ = Proxy -- | Bit-packed record-type BitRecordOf r h = BitProd r (Field h)+type BitRecordOf r h xs = BitProd r xs (Field h) -- | Bit-packed record-type BitRecord r = BitRecordOf r Identity+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) h xs x- = (BitFields r h xs, FromBits r (h x))+ 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,7 +1,7 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, TypeFamilies #-}-#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableSuperClasses #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Extensible.Class@@ -19,6 +19,7 @@ , itemAt , item , itemAssoc+ , itemKey -- * Membership , Membership , mkMembership@@ -27,12 +28,7 @@ , leadership -- * Member , Member(..)- , remember-#if __GLASGOW_HASKELL__ >= 800 , type (∈)-#else- , (∈)()-#endif , FindType -- * Generation , Generate(..)@@ -40,106 +36,67 @@ , ForallF -- * Association , Assoc(..)-#if __GLASGOW_HASKELL__ >= 800 , type (>:)-#else- , (>:)()-#endif- , Associate(..)- , FindAssoc- -- * Sugar- , Elaborate- , Elaborated(..)+ , Lookup(..)+ -- * Misc+ , Head+ , Last ) where import Data.Constraint-import Data.Extensible.HList-import Data.Extensible.Internal 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- type ExtensibleConstr t (h :: k -> *) (xs :: [k]) (x :: k) :: Constraint- type ExtensibleConstr t h xs x = ()- pieceAt :: ExtensibleConstr t h xs x => 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, ExtensibleConstr t h xs x) => 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, ExtensibleConstr t h xs (k ':> v)) => 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 #-} -- | Access a specified element through a wrapper.-itemAt :: (Wrapper h, Extensible f p t, ExtensibleConstr t h xs x) => Membership xs x -> Optic' p f (t h xs) (Repr h x)+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 #-} -- | Access an element through a wrapper.-item :: (Wrapper h, Extensible f p t, x ∈ xs, ExtensibleConstr t h xs x) => proxy x -> Optic' p f (t h xs) (Repr h x)+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 #-} -- | Access an element specified by the key type through a wrapper.-itemAssoc :: (Wrapper h, Extensible f p t, Associate k v xs, ExtensibleConstr t h xs (k ':> v))- => proxy k -> Optic' p f (t h xs) (Repr h (k ':> v))+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 #-} --- | Every type-level list is an instance of 'Generate'.-class Generate (xs :: [k]) where- -- | Enumerate all possible 'Membership's of @xs@.- henumerate :: (forall x. Membership xs x -> r -> r) -> r -> r-- -- | Count the number of memberships.- hcount :: proxy xs -> Int-- -- | Enumerate 'Membership's and construct an 'HList'.- hgenerateList :: Applicative f- => (forall x. Membership xs x -> f (h x)) -> f (HList h xs)--instance Generate '[] where- henumerate _ r = r-- hcount _ = 0-- hgenerateList _ = pure HNil--instance Generate xs => Generate (x ': xs) where- henumerate f r = f here $ henumerate (f . navNext) r-- hcount _ = 1 + hcount (Proxy :: Proxy xs)-- -- | Enumerate 'Membership's and construct an 'HList'.- hgenerateList f = HCons <$> f here <*> hgenerateList (f . navNext)---- | Every element in @xs@ satisfies @c@-class (ForallF c xs, Generate xs) => Forall (c :: k -> Constraint) (xs :: [k]) where- -- | Enumerate all possible 'Membership's of @xs@ with an additional context.- henumerateFor :: proxy c -> proxy' xs -> (forall x. c x => Membership xs x -> r -> r) -> r -> r-- hgenerateListFor :: Applicative f- => proxy c -> (forall x. c x => Membership xs x -> f (h x)) -> f (HList h xs)--instance Forall c '[] where- henumerateFor _ _ _ r = r-- hgenerateListFor _ _ = pure HNil--instance (c x, Forall c xs) => Forall c (x ': xs) where- henumerateFor p _ f r = f here $ henumerateFor p (Proxy :: Proxy xs) (f . navNext) r-- hgenerateListFor p f = HCons <$> f here <*> hgenerateListFor p (f . navNext)+-- | First element+type family Head (xs :: [k]) :: k where+ Head (x ': xs) = x --- | HACK: Without this, the constraints are not propagated well.-type family ForallF (c :: k -> Constraint) (xs :: [k]) :: Constraint where- ForallF c '[] = ()- ForallF c (x ': xs) = (c x, Forall c xs)+-- | Last element+type family Last (x :: [k]) :: k where+ Last '[x] = x+ Last (x ': xs) = Last xs
src/Data/Extensible/Dictionary.hs view
@@ -2,11 +2,10 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies, ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances, MultiParamTypeClasses #-}-#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE UndecidableSuperClasses #-}-{-# LANGUAGE TypeInType #-}-#endif+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE InstanceSigs #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------- -- |@@ -20,155 +19,154 @@ -- Also includes orphan instances. ----------------------------------------------------------------------- module Data.Extensible.Dictionary (library, WrapForall, Instance1, And) where-import Control.Applicative import Control.DeepSeq-import Control.Monad.Trans-import Control.Monad.Trans.Cont 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.Functor.Identity import Data.Hashable-import qualified Data.HashMap.Strict as HM-import Data.Semigroup-import Data.Text.Prettyprint.Doc-import Data.Typeable-#if __GLASGOW_HASKELL__ >= 800-import Data.Kind+#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 qualified Data.Vector as V-import qualified Data.Text as T+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 = hrepeatFor (Proxy :: Proxy c) $ Comp Dict+library :: forall c xs. Forall c xs => xs :& Compose Dict c+library = hrepeatFor (Proxy :: Proxy c) $ Compose Dict {-# INLINE library #-} class (f x, g x) => And f g x instance (f x, g x) => And f g x -instance WrapForall Show h xs => Show (h :* xs) where+instance WrapForall Show h xs => Show (xs :& h) where showsPrec d xs = showParen (d > 0)- $ henumerateFor (Proxy :: Proxy (Instance1 Show h)) xs+ $ henumerateFor (Proxy :: Proxy (Instance1 Show h)) (Proxy :: Proxy xs) (\i r -> showsPrec 0 (hlookup i xs) . showString " <: " . r) (showString "nil") -#if !MIN_VERSION_prettyprinter(1,2,1)-instance Pretty a => Pretty (Identity a) where- pretty = pretty . runIdentity--instance Pretty a => Pretty (Const a b) where- pretty = pretty . getConst-#endif--instance WrapForall Pretty h xs => Pretty (h :* xs) where+instance WrapForall Pretty h xs => Pretty (xs :& h) where pretty xs = align $ encloseSep (flatAlt "" "{ ") (flatAlt "" " }") (flatAlt "" "; ")- $ henumerateFor (Proxy :: Proxy (Instance1 Pretty h)) xs+ $ 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 = henumerateFor (Proxy :: Proxy (Instance1 Eq h)) xs++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 = henumerateFor (Proxy :: Proxy (Instance1 Ord h)) xs+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 Semigroup h xs => Semigroup (h :* xs) where- (<>) = hzipWith3 (\(Comp Dict) -> (<>))- (library :: Comp Dict (Instance1 Semigroup 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 (h :* xs) where+instance (WrapForall Semigroup h xs, WrapForall Monoid h xs) => Monoid (xs :& h) where mempty = hrepeatFor (Proxy :: Proxy (Instance1 Monoid h)) mempty {-# INLINE mempty #-}- mappend = hzipWith3 (\(Comp Dict) -> mappend)- (library :: Comp Dict (Instance1 Monoid h) :* xs)+ mappend = (<>) {-# INLINE mappend #-} -instance WrapForall Hashable h xs => Hashable (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 (h :* xs) where+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 -#if !MIN_VERSION_th_lift(0,7,9)-instance TH.Lift a => TH.Lift (Identity a) where- lift = appE (conE 'Identity) . TH.lift . runIdentity--instance TH.Lift a => TH.Lift (Const a b) where- lift = appE (conE 'Const) . TH.lift . getConst-#endif--instance WrapForall TH.Lift h xs => TH.Lift (h :* xs) where+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 (h :* xs) = MV_Product (Comp (U.MVector s) h :* xs)-newtype instance U.Vector (h :* xs) = V_Product (Comp U.Vector h :* xs)+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 -> Comp f g :* xs -> f (g a)-hlookupC i = getComp . hlookup i+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 (h :* (x ': xs)) where+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 -> Comp <$> G.basicUnsafeFreeze (hlookupC m v)+ $ \m -> Compose <$> G.basicUnsafeFreeze (hlookupC m v) basicUnsafeThaw (V_Product v) = fmap MV_Product $ hgenerateFor (Proxy :: Proxy (Instance1 U.Unbox h))- $ \m -> Comp <$> G.basicUnsafeThaw (hlookupC m v)- basicLength (V_Product v) = G.basicLength $ getComp $ hindex v here+ $ \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 -> Comp $ G.basicUnsafeSlice i n (hlookupC m v)+ $ \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 (h :* (x ': xs)) where- basicLength (MV_Product v) = M.basicLength $ getComp $ hindex v here+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 -> Comp $ M.basicUnsafeSlice i n (hlookupC m v)+ $ \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 $ Comp <$> M.basicUnsafeNew n)-#if MIN_VERSION_vector(0,11,0)+ (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 ())-#endif basicUnsafeReplicate n x = fmap MV_Product $ hgenerateFor (Proxy :: Proxy (Instance1 U.Unbox h))- $ \m -> fmap Comp $ M.basicUnsafeReplicate n $ hlookup m x+ $ \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 ())@@ -180,99 +178,112 @@ = 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 -> Comp <$> M.basicUnsafeGrow (hlookupC i v) n+ $ \i -> Compose <$> M.basicUnsafeGrow (hlookupC i v) n -instance WrapForall U.Unbox h (x ': xs) => U.Unbox (h :* (x ': xs))+instance WrapForall U.Unbox h (x ': xs) => U.Unbox ((x ': xs) :& h) -instance WrapForall Arbitrary h xs => Arbitrary (h :* xs) where+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 (h :* xs) where+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 #-} -instance WrapForall Csv.FromField h xs => Csv.FromRecord (h :* xs) where+#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 (KeyValue KnownSymbol (Instance1 Csv.FromField h)) xs => Csv.FromNamedRecord (Field h :* xs) where- parseNamedRecord rec = hgenerateFor (Proxy :: Proxy (KeyValue KnownSymbol (Instance1 Csv.FromField h)))- $ \i -> rec Csv..: BC.pack (symbolVal (proxyAssocKey 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 (h :* xs) where+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 (KeyValue KnownSymbol (Instance1 Csv.ToField h)) xs => Csv.ToNamedRecord (Field h :* xs) where- toNamedRecord = hfoldlWithIndexFor (Proxy :: Proxy (KeyValue KnownSymbol (Instance1 Csv.ToField h)))- (\k m v -> HM.insert (BC.pack (symbolVal (proxyAssocKey k))) (Csv.toField v) m)+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 (KeyValue KnownSymbol (Instance1 J.FromJSON h)) xs => J.FromJSON (Field h :* xs) where+instance Forall (KeyTargetAre KnownSymbol (Instance1 J.FromJSON h)) xs => J.FromJSON (xs :& Field h) where parseJSON = J.withObject "Object" $ \v -> hgenerateFor- (Proxy :: Proxy (KeyValue KnownSymbol (Instance1 J.FromJSON h)))- $ \m -> let k = symbolVal (proxyAssocKey m)- in fmap Field $ J.parseJSON $ maybe J.Null id $ HM.lookup (T.pack k) v+ (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 (KeyValue KnownSymbol (Instance1 J.ToJSON h)) xs => J.ToJSON (Field h :* xs) where+instance Forall (KeyTargetAre KnownSymbol (Instance1 J.ToJSON h)) xs => J.ToJSON (xs :& Field h) where toJSON = J.Object . hfoldlWithIndexFor- (Proxy :: Proxy (KeyValue KnownSymbol (Instance1 J.ToJSON h)))- (\k m v -> HM.insert (T.pack (symbolVal (proxyAssocKey k))) (J.toJSON v) m)- HM.empty+ (Proxy :: Proxy (KeyTargetAre KnownSymbol (Instance1 J.ToJSON h)))+ (\k m v -> KM.insert (stringKeyOf k) (J.toJSON v) m)+ KM.empty -instance Forall (KeyValue KnownSymbol (Instance1 J.FromJSON h)) xs => J.FromJSON (Nullable (Field h) :* xs) where+instance Forall (KeyTargetAre KnownSymbol (Instance1 J.FromJSON h)) xs => J.FromJSON (xs :& Nullable (Field h)) where parseJSON = J.withObject "Object" $ \v -> hgenerateFor- (Proxy :: Proxy (KeyValue KnownSymbol (Instance1 J.FromJSON h)))- $ \m -> let k = symbolVal (proxyAssocKey m)- in fmap Nullable $ traverse J.parseJSON $ HM.lookup (T.pack k) v+ (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 (KeyValue KnownSymbol (Instance1 J.ToJSON h)) xs => J.ToJSON (Nullable (Field h) :* xs) where+instance Forall (KeyTargetAre KnownSymbol (Instance1 J.ToJSON h)) xs => J.ToJSON (xs :& Nullable (Field h)) where toJSON = J.Object . hfoldlWithIndexFor- (Proxy :: Proxy (KeyValue KnownSymbol (Instance1 J.ToJSON h)))- (\k m (Nullable v) -> maybe id (HM.insert (T.pack $ symbolVal $ proxyAssocKey k) . J.toJSON) v m)- HM.empty+ (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 (h :| xs) where+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 (h :| xs) where- rnf (EmbedAt i h) = views (pieceAt i) (\(Comp Dict) -> rnf h) (library :: Comp Dict (Instance1 NFData h) :* xs)+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 Hashable h xs => Hashable (h :| xs) where+instance (WrapForall Eq h xs, WrapForall Hashable h xs) => Hashable (xs :/ h) where hashWithSalt s (EmbedAt i h) = views (pieceAt i)- (\(Comp Dict) -> s `hashWithSalt` i `hashWithSalt` h)- (library :: Comp Dict (Instance1 Hashable h) :* xs)+ (\(Compose Dict) -> s `hashWithSalt` i `hashWithSalt` h)+ (library :: xs :& Compose Dict (Instance1 Hashable h)) {-# INLINE hashWithSalt #-} -instance WrapForall TH.Lift h xs => TH.Lift (h :| xs) where+instance WrapForall TH.Lift h xs => TH.Lift (xs :/ h) where lift (EmbedAt i h) = views (pieceAt i)- (\(Comp Dict) -> conE 'EmbedAt `appE` TH.lift i `appE` TH.lift h)- (library :: Comp Dict (Instance1 TH.Lift h) :* xs)+ (\(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 (h :| xs) where+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)@@ -281,15 +292,15 @@ else r (i - 1)) (error "Impossible") shrink (EmbedAt i h) = views (pieceAt i)- (\(Comp Dict) -> EmbedAt i <$> shrink h)- (library :: Comp Dict (Instance1 Arbitrary h) :* xs)+ (\(Compose Dict) -> EmbedAt i <$> shrink h)+ (library :: xs :& Compose Dict (Instance1 Arbitrary h)) -instance WrapForall Pretty h xs => Pretty (h :| xs) where+instance WrapForall Pretty h xs => Pretty (xs :/ h) where pretty (EmbedAt i h) = "EmbedAt " <> pretty i <> " "- <> views (pieceAt i) (\(Comp Dict) -> pretty h)- (library :: Comp Dict (Instance1 Pretty h) :* xs)+ <> 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)@@ -298,101 +309,48 @@ class c (h x) => Instance1 c h x instance c (h x) => Instance1 c h x -#if !MIN_VERSION_vector(0,12,1)-newtype instance U.MVector s (Identity a) = MV_Identity (U.MVector s a)-newtype instance U.Vector (Identity a) = V_Identity (U.Vector a)+#ifdef BARBIES+instance FunctorB ((:&) xs) where+ bmap = hmap -instance (U.Unbox a) => M.MVector U.MVector (Identity a) 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_Identity v) = M.basicLength v- basicUnsafeSlice i n (MV_Identity v) = MV_Identity $ M.basicUnsafeSlice i n v- basicOverlaps (MV_Identity v1) (MV_Identity v2) = M.basicOverlaps v1 v2- basicUnsafeNew n = MV_Identity <$> M.basicUnsafeNew n-#if MIN_VERSION_vector(0,11,0)- basicInitialize (MV_Identity v) = M.basicInitialize v- {-# INLINE basicInitialize #-}-#endif- basicUnsafeReplicate n (Identity x) = MV_Identity <$> M.basicUnsafeReplicate n x- basicUnsafeRead (MV_Identity v) i = Identity <$> M.basicUnsafeRead v i- basicUnsafeWrite (MV_Identity v) i (Identity x) = M.basicUnsafeWrite v i x- basicClear (MV_Identity v) = M.basicClear v- basicSet (MV_Identity v) (Identity x) = M.basicSet v x- basicUnsafeCopy (MV_Identity v1) (MV_Identity v2) = M.basicUnsafeCopy v1 v2- basicUnsafeMove (MV_Identity v1) (MV_Identity v2) = M.basicUnsafeMove v1 v2- basicUnsafeGrow (MV_Identity v) n = MV_Identity <$> M.basicUnsafeGrow v n+instance FunctorB ((:/) xs) where+ bmap = hoist -instance (U.Unbox a) => G.Vector U.Vector (Identity a) where- {-# INLINE basicUnsafeFreeze #-}- {-# INLINE basicUnsafeThaw #-}- {-# INLINE basicLength #-}- {-# INLINE basicUnsafeSlice #-}- {-# INLINE basicUnsafeIndexM #-}- basicUnsafeFreeze (MV_Identity v) = V_Identity <$> G.basicUnsafeFreeze v- basicUnsafeThaw (V_Identity v) = MV_Identity <$> G.basicUnsafeThaw v- basicLength (V_Identity v) = G.basicLength v- basicUnsafeSlice i n (V_Identity v) = V_Identity $ G.basicUnsafeSlice i n v- basicUnsafeIndexM (V_Identity v) i = Identity <$> G.basicUnsafeIndexM v i- basicUnsafeCopy (MV_Identity mv) (V_Identity v) = G.basicUnsafeCopy mv v+instance TraversableB ((:&) xs) where+ btraverse = htraverse -instance (U.Unbox a) => U.Unbox (Identity a)+instance TraversableB ((:/) xs) where+ btraverse f (EmbedAt i x) = EmbedAt i <$> f x -newtype instance U.MVector s (Const' a b) = MV_Const (U.MVector s a)-newtype instance U.Vector (Const' a b) = V_Const (U.Vector a)+instance Generate xs => ApplicativeB ((:&) xs) where+ bprod = hzipWith Pair+ bpure = hrepeat -instance (U.Unbox a) => M.MVector U.MVector (Const' a b) 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_Const v) = M.basicLength v- basicUnsafeSlice i n (MV_Const v) = MV_Const $ M.basicUnsafeSlice i n v- basicOverlaps (MV_Const v1) (MV_Const v2) = M.basicOverlaps v1 v2- basicUnsafeNew n = MV_Const <$> M.basicUnsafeNew n-#if MIN_VERSION_vector(0,11,0)- basicInitialize (MV_Const v) = M.basicInitialize v- {-# INLINE basicInitialize #-}-#endif- basicUnsafeReplicate n (Const' x) = MV_Const <$> M.basicUnsafeReplicate n x- basicUnsafeRead (MV_Const v) i = Const' <$> M.basicUnsafeRead v i- basicUnsafeWrite (MV_Const v) i (Const' x) = M.basicUnsafeWrite v i x- basicClear (MV_Const v) = M.basicClear v- basicSet (MV_Const v) (Const' x) = M.basicSet v x- basicUnsafeCopy (MV_Const v1) (MV_Const v2) = M.basicUnsafeCopy v1 v2- basicUnsafeMove (MV_Const v1) (MV_Const v2) = M.basicUnsafeMove v1 v2- basicUnsafeGrow (MV_Const v) n = MV_Const <$> M.basicUnsafeGrow v n+instance ConstraintsB ((:&) xs) where+ type AllB c ((:&) xs) = Forall c xs+ baddDicts = bprod bdicts -instance (U.Unbox a) => G.Vector U.Vector (Const' a b) where- {-# INLINE basicUnsafeFreeze #-}- {-# INLINE basicUnsafeThaw #-}- {-# INLINE basicLength #-}- {-# INLINE basicUnsafeSlice #-}- {-# INLINE basicUnsafeIndexM #-}- basicUnsafeFreeze (MV_Const v) = V_Const <$> G.basicUnsafeFreeze v- basicUnsafeThaw (V_Const v) = MV_Const <$> G.basicUnsafeThaw v- basicLength (V_Const v) = G.basicLength v- basicUnsafeSlice i n (V_Const v) = V_Const $ G.basicUnsafeSlice i n v- basicUnsafeIndexM (V_Const v) i = Const' <$> G.basicUnsafeIndexM v i- basicUnsafeCopy (MV_Const mv) (V_Const v) = G.basicUnsafeCopy mv v+instance ConstraintsB ((:/) xs) where+ type AllB c ((:/) xs) = Forall c xs+ baddDicts (EmbedAt i x) = EmbedAt i (Pair (hlookup i bdicts) x) -instance (U.Unbox a) => U.Unbox (Const' a b) #endif -proxyApp :: Proxy f -> Proxy a -> Proxy (f a)-proxyApp _ _ = Proxy+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,463 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}--------------------------------------------------------------------------------- |--- Module : Data.Extensible.Effect--- Copyright : (c) Fumiaki Kinoshita 2018--- License : BSD3------ Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>------ Name-based extensible effects-------------------------------------------------------------------------------module Data.Extensible.Effect (- -- * Base- Instruction(..)- , Eff- , liftEff- , liftsEff- , hoistEff- , castEff- -- * Step-wise handling- , Interpreter(..)- , handleEff- -- * Peeling- , peelEff- , Rebinder- , rebindEff0- , peelEff0- , rebindEff1- , peelEff1- , rebindEff2- , leaveEff- , retractEff- -- * Anonymous actions- , Action(..)- , Function- , runAction- , (@!?)- , peelAction- , peelAction0- -- * transformers-compatible actions and handlers- -- ** Reader- , ReaderEff- , askEff- , asksEff- , localEff- , runReaderEff- -- ** State- , State- , getEff- , getsEff- , putEff- , modifyEff- , stateEff- , runStateEff- , execStateEff- , evalStateEff- -- ** Writer- , WriterEff- , writerEff- , tellEff- , listenEff- , passEff- , runWriterEff- , execWriterEff- -- ** Maybe- , MaybeEff- , nothingEff- , runMaybeEff- -- ** Either- , EitherEff- , throwEff- , catchEff- , runEitherEff- -- ** Iter- , Identity- , tickEff- , runIterEff- -- ** Cont- , ContT- , contEff- , runContEff- ) where--import Control.Applicative-import Control.Monad.Skeleton-import Control.Monad.Trans.State.Strict-import Control.Monad.Trans.Cont (ContT(..))-import Data.Extensible.Field-import Data.Extensible.Inclusion-import Data.Extensible.Internal-import Data.Extensible.Internal.Rig-import Data.Extensible.Product-import Data.Extensible.Class-import Data.Functor.Identity-import Data.Profunctor.Unsafe -- Trustworthy since 7.8-import Data.Typeable (Typeable)---- | A unit of named effects. This is a variant of @(':|')@ specialised for--- 'Type -> Type'.-data Instruction (xs :: [Assoc k (* -> *)]) a where- Instruction :: !(Membership xs kv) -> AssocValue kv a -> Instruction xs a- deriving Typeable---- | The extensible operational monad-type Eff xs = Skeleton (Instruction xs)---- | Lift an instruction onto an 'Eff' action.-liftEff :: forall s t xs a. Associate s t xs => Proxy s -> t a -> Eff xs a-liftEff p x = liftsEff p x id-{-# INLINE liftEff #-}---- | Lift an instruction onto an 'Eff' action and apply a function to the result.-liftsEff :: forall s t xs a r. Associate s t xs- => Proxy s -> t a -> (a -> r) -> Eff xs r-liftsEff _ x k = boned- $ Instruction (association :: Membership xs (s ':> t)) x :>>= return . k-{-# INLINE liftsEff #-}---- | Censor a specific type of effects in an action.-hoistEff :: forall 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 #-}---- | Upcast an action.-castEff :: IncludeAssoc ys xs => Eff xs a -> Eff ys a-castEff = hoistSkeleton- $ \(Instruction i t) -> Instruction (hlookup i inclusionAssoc) t---- | Build a relay-style handler from a triple of functions.------ @--- runStateEff = peelEff1 (\a s -> return (a, s))--- (\m k s -> let (a, s') = runState m s in k a s')--- @----peelEff :: forall k t xs a r- . Rebinder xs r -- ^ Re-bind an unrelated action- -> (a -> r) -- ^ return the result- -> (forall x. t x -> (x -> r) -> r) -- ^ Handle the foremost type of an action- -> Eff (k >: t ': xs) a -> r-peelEff pass ret wrap = go where- go m = case debone m of- Return a -> ret a- Instruction i t :>>= k -> leadership i- (\Refl -> wrap t (go . k))- (\j -> pass (Instruction j t) (go . k))-{-# INLINE peelEff #-}---- | 'peelEff' specialised for continuations with no argument-peelEff0 :: forall k t xs a r. (a -> Eff xs r) -- ^ return the result- -> (forall x. t x -> (x -> Eff xs r) -> Eff xs r) -- ^ Handle the foremost type of an action- -> Eff (k >: t ': xs) a -> Eff xs r-peelEff0 = peelEff rebindEff0-{-# INLINE peelEff0 #-}---- | 'peelEff' specialised for 1-argument continuation-peelEff1 :: forall k t xs a b r. (a -> b -> Eff xs r) -- ^ return the result- -> (forall x. t x -> (x -> b -> Eff xs r) -> b -> Eff xs r) -- ^ Handle the foremost type of an action- -> Eff (k >: t ': xs) a -> b -> Eff xs r-peelEff1 = peelEff rebindEff1-{-# INLINE peelEff1 #-}---- | A function to bind an 'Instruction' in 'peelEff'.-type Rebinder xs r = forall x. Instruction xs x -> (x -> r) -> r---- | A common value for the second argument of 'peelEff'. Binds an instruction--- directly.-rebindEff0 :: Rebinder xs (Eff xs r)-rebindEff0 i k = boned $ i :>>= k---- | A pre-defined value for the second argument of 'peelEff'.--- Preserves the argument of the continuation.-rebindEff1 :: Rebinder xs (a -> Eff xs r)-rebindEff1 i k a = boned $ i :>>= flip k a---- | A pre-defined value for the second argument of 'peelEff'.--- Preserves two arguments of the continuation.-rebindEff2 :: Rebinder xs (a -> b -> Eff xs r)-rebindEff2 i k a b = boned $ i :>>= \x -> k x a b---- | Reveal the final result of 'Eff'.-leaveEff :: Eff '[] a -> a-leaveEff m = case debone m of- Return a -> a- _ -> error "Impossible"---- | Tear down an action using the 'Monad' instance of the instruction.-retractEff :: forall k m a. Monad m => Eff '[k >: m] a -> m a-retractEff m = case debone m of- Return a -> return a- Instruction i t :>>= k -> leadership i- (\Refl -> t >>= retractEff . k)- $ error "Impossible"---- | Transformation between effects-newtype Interpreter f g = Interpreter { runInterpreter :: forall a. g a -> f a }- deriving Typeable---- | Process an 'Eff' action using a record of 'Interpreter's.-handleEff :: RecordOf (Interpreter m) xs -> Eff xs a -> MonadView m (Eff xs) a-handleEff hs m = case debone m of- Instruction i t :>>= k -> views (pieceAt i) (runInterpreter .# getField) hs t :>>= k- Return a -> Return a---- | Anonymous representation of instructions.-data Action (args :: [*]) a r where- AResult :: Action '[] a a- AArgument :: x -> Action xs a r -> Action (x ': xs) a r---- | @'Function' [a, b, c] r@ is @a -> b -> c -> r@-type family Function args r :: * where- Function '[] r = r- Function (x ': xs) r = x -> Function xs r---- | Pass the arguments of 'Action' to the supplied function.-runAction :: Function xs (f a) -> Action xs a r -> f r-runAction r AResult = r-runAction f (AArgument x a) = runAction (f x) a---- | Create a 'Field' of a 'Interpreter' for an 'Action'.-(@!?) :: FieldName k -> Function xs (f a) -> Field (Interpreter f) (k ':> Action xs a)-_ @!? f = Field $ Interpreter $ runAction f-infix 1 @!?---- | Specialised version of 'peelEff' for 'Action's.--- You can pass a function @a -> b -> ... -> (q -> r) -> r@ as a handler for--- @'Action' '[a, b, ...] q@.-peelAction :: forall k ps q xs a r- . (forall x. Instruction xs x -> (x -> r) -> r) -- ^ Re-bind an unrelated action- -> (a -> r) -- ^ return the result- -> Function ps ((q -> r) -> r) -- ^ Handle the foremost action- -> Eff (k >: Action ps q ': xs) a -> r-peelAction pass ret wrap = go where- go m = case debone m of- Return a -> ret a- Instruction i t :>>= k -> leadership i- (\Refl -> case t of- (_ :: Action ps q x) ->- let run :: forall t. Function t ((q -> r) -> r) -> Action t q x -> r- run f AResult = f (go . k)- run f (AArgument x a) = run (f x) a- in run wrap t)- $ \j -> pass (Instruction j t) (go . k)-{-# INLINE peelAction #-}---- | Non continuation-passing variant of 'peelAction'.-peelAction0 :: forall k ps q xs a. Function ps (Eff xs q) -- ^ Handle the foremost action- -> Eff (k >: Action ps q ': xs) a -> Eff xs a-peelAction0 wrap = go where- go m = case debone m of- Return a -> return a- Instruction i t :>>= k -> leadership i- (\Refl -> case t of- (_ :: Action ps q x) ->- let run :: forall t. Function t (Eff xs q) -> Action t q x -> Eff xs a- run f AResult = f >>= go . k- run f (AArgument x a) = run (f x) a- in run wrap t)- $ \j -> rebindEff0 (Instruction j t) (go . k)-{-# INLINE peelAction0 #-}---- | The reader monad is characterised by a type equality between the result--- type and the enviroment type.-type ReaderEff = (:~:)---- | Fetch the environment.-askEff :: forall k r xs. Associate k (ReaderEff r) xs- => Proxy k -> Eff xs r-askEff p = liftEff p Refl-{-# INLINE askEff #-}---- | Pass the environment to a function.-asksEff :: forall k r xs a. Associate k (ReaderEff r) xs- => Proxy k -> (r -> a) -> Eff xs a-asksEff p = liftsEff p Refl-{-# INLINE asksEff #-}---- | Modify the enviroment locally.-localEff :: forall k r xs a. Associate k (ReaderEff r) xs- => Proxy k -> (r -> r) -> Eff xs a -> Eff xs a-localEff _ f = go where- go m = case debone m of- Return a -> return a- Instruction i t :>>= k -> case compareMembership- (association :: Membership xs (k >: ReaderEff r)) i of- Left _ -> boned $ Instruction i t :>>= go . k- Right Refl -> case t of- Refl -> boned $ Instruction i t :>>= go . k . f-{-# INLINE localEff #-}---- | Run the frontal reader effect.-runReaderEff :: forall k r xs a. Eff (k >: ReaderEff r ': xs) a -> r -> Eff xs a-runReaderEff m r = peelEff0 return (\Refl k -> k r) m-{-# INLINE runReaderEff #-}---- | Get the current state.-getEff :: forall k s xs. Associate k (State s) xs- => Proxy k -> Eff xs s-getEff k = liftEff k get-{-# INLINE getEff #-}---- | Pass the current state to a function.-getsEff :: forall k s a xs. Associate k (State s) xs- => Proxy k -> (s -> a) -> Eff xs a-getsEff k = liftsEff k get-{-# INLINE getsEff #-}---- | Replace the state with a new value.-putEff :: forall k s xs. Associate k (State s) xs- => Proxy k -> s -> Eff xs ()-putEff k = liftEff k . put-{-# INLINE putEff #-}---- | Modify the state.-modifyEff :: forall k s xs. Associate k (State s) xs- => Proxy k -> (s -> s) -> Eff xs ()-modifyEff k f = liftEff k $ state $ \s -> ((), f s)-{-# INLINE modifyEff #-}---- | Lift a state modification function.-stateEff :: forall k s xs a. Associate k (State s) xs- => Proxy k -> (s -> (a, s)) -> Eff xs a-stateEff k = liftEff k . state-{-# INLINE stateEff #-}--contState :: State s a -> (a -> s -> r) -> s -> r-contState m k s = let (a, s') = runState m s in k a $! s'---- | Run the frontal state effect.-runStateEff :: forall k s xs a. Eff (k >: State s ': xs) a -> s -> Eff xs (a, s)-runStateEff = peelEff1 (\a s -> return (a, s)) contState-{-# INLINE runStateEff #-}---- | Run the frontal state effect and return the final state.-execStateEff :: forall k s xs a. Eff (k >: State s ': xs) a -> s -> Eff xs s-execStateEff = peelEff1 (const return) contState-{-# INLINE execStateEff #-}---- | Run the frontal state effect and return the final result.-evalStateEff :: forall k s xs a. Eff (k >: State s ': xs) a -> s -> Eff xs a-evalStateEff = peelEff1 (const . return) contState-{-# INLINE evalStateEff #-}---- | @(,)@ already is a writer monad.-type WriterEff w = (,) w---- | Write the second element and return the first element.-writerEff :: forall k w xs a. (Associate k (WriterEff w) xs)- => Proxy k -> (a, w) -> Eff xs a-writerEff k (a, w) = liftEff k (w, a)-{-# INLINE writerEff #-}---- | Write a value.-tellEff :: forall k w xs. (Associate k (WriterEff w) xs)- => Proxy k -> w -> Eff xs ()-tellEff k w = liftEff k (w, ())-{-# INLINE tellEff #-}---- | Squash the outputs into one step and return it.-listenEff :: forall k w xs a. (Associate k (WriterEff w) xs, Monoid w)- => Proxy k -> Eff xs a -> Eff xs (a, w)-listenEff p = go mempty where- go w m = case debone m of- Return a -> writerEff p ((a, w), w)- Instruction i t :>>= k -> case compareMembership (association :: Membership xs (k ':> (,) w)) i of- Left _ -> boned $ Instruction i t :>>= go w . k- Right Refl -> let (w', a) = t- !w'' = mappend w w' in go w'' (k a)-{-# INLINE listenEff #-}---- | Modify the output using the function in the result.-passEff :: forall k w xs a. (Associate k (WriterEff w) xs, Monoid w)- => Proxy k -> Eff xs (a, w -> w) -> Eff xs a-passEff p = go mempty where- go w m = case debone m of- Return (a, f) -> writerEff p (a, f w)- Instruction i t :>>= k -> case compareMembership (association :: Membership xs (k ':> (,) w)) i of- Left _ -> boned $ Instruction i t :>>= go w . k- Right Refl -> let (w', a) = t- !w'' = mappend w w' in go w'' (k a)-{-# INLINE passEff #-}--contWriter :: Monoid w => (w, a) -> (a -> w -> r) -> w -> r-contWriter (w', a) k w = k a $! mappend w w'---- | Run the frontal writer effect.-runWriterEff :: forall k w xs a. Monoid w => Eff (k >: WriterEff w ': xs) a -> Eff xs (a, w)-runWriterEff = peelEff1 (\a w -> return (a, w)) contWriter `flip` mempty-{-# INLINE runWriterEff #-}---- | Run the frontal state effect.-execWriterEff :: forall k w xs a. Monoid w => Eff (k >: WriterEff w ': xs) a -> Eff xs w-execWriterEff = peelEff1 (const return) contWriter `flip` mempty-{-# INLINE execWriterEff #-}---- | An effect with no result-type MaybeEff = Const ()---- | Break out of the computation. Similar to 'Nothing'.-nothingEff :: Associate k MaybeEff xs => Proxy k -> Eff xs a-nothingEff = flip throwEff ()---- | Run an effect which may fail in the name of @k@.-runMaybeEff :: forall k xs a. Eff (k >: MaybeEff ': xs) a -> Eff xs (Maybe a)-runMaybeEff = peelEff0 (return . Just) $ \_ _ -> return Nothing-{-# INLINE runMaybeEff #-}---- | Throwing an exception-type EitherEff = Const---- | Throw an exception @e@, throwing the rest of the computation away.-throwEff :: Associate k (EitherEff e) xs => Proxy k -> e -> Eff xs a-throwEff k = liftEff k . Const-{-# INLINE throwEff #-}---- | Attach a handler for an exception.-catchEff :: forall k e xs a. (Associate k (EitherEff e) xs)- => Proxy k -> Eff xs a -> (e -> Eff xs a) -> Eff xs a-catchEff _ m0 handler = go m0 where- go m = case debone m of- Return a -> return a- Instruction i t :>>= k -> case compareMembership (association :: Membership xs (k ':> Const e)) i of- Left _ -> boned $ Instruction i t :>>= go . k- Right Refl -> handler (getConst t)-{-# INLINE catchEff #-}---- | Run an action and abort on 'throwEff'.-runEitherEff :: forall k e xs a. Eff (k >: EitherEff e ': xs) a -> Eff xs (Either e a)-runEitherEff = peelEff0 (return . Right) $ \(Const e) _ -> return $ Left e-{-# INLINE runEitherEff #-}---- | Put a milestone on a computation.-tickEff :: Associate k Identity xs => Proxy k -> Eff xs ()-tickEff k = liftEff k $ Identity ()-{-# INLINE tickEff #-}---- | Run a computation until the first call of 'tickEff'.-runIterEff :: Eff (k >: Identity ': xs) a- -> Eff xs (Either a (Eff (k >: Identity ': xs) a))-runIterEff m = case debone m of- Return a -> return (Left a)- Instruction i t :>>= k -> leadership i- (\Refl -> return $ Right $ k $ runIdentity t)- $ \j -> boned $ Instruction j t :>>= runIterEff . k---- | Place a continuation-passing action.-contEff :: Associate k (ContT r m) xs => Proxy k- -> ((a -> m r) -> m r) -> Eff xs a-contEff k = liftEff k . ContT---- | Unwrap a continuation.-runContEff :: forall k r xs a. Eff (k >: ContT r (Eff xs) ': xs) a- -> (a -> Eff xs r)- -> Eff xs r-runContEff m cont = case debone m of- Return a -> cont a- Instruction i t :>>= k -> leadership i- (\Refl -> runContT t (flip runContEff cont . k))- $ \j -> boned $ Instruction j t :>>= flip runContEff cont . k
− src/Data/Extensible/Effect/Default.hs
@@ -1,157 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--------------------------------------------------------------------------------- |--- Module : Data.Extensible.Effect.Default--- Copyright : (c) Fumiaki Kinoshita 2018--- License : BSD3------ Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>------ Default monad runners and 'MonadIO', 'MonadReader', 'MonadWriter',--- 'MonadState', 'MonadError' instances-------------------------------------------------------------------------------module Data.Extensible.Effect.Default (- ReaderDef- , runReaderDef- , StateDef- , runStateDef- , evalStateDef- , execStateDef- , WriterDef- , runWriterDef- , execWriterDef- , MaybeDef- , runMaybeDef- , EitherDef- , runEitherDef-) where-import Control.Applicative-import Data.Extensible.Effect-import Data.Extensible.Internal-import Control.Monad.Except-import Control.Monad.Catch-import Control.Monad.Reader.Class-import Control.Monad.Skeleton-import Control.Monad.State.Strict-#if MIN_VERSION_resourcet(1,2,0)-import Control.Monad.Trans.Resource-#endif-import Control.Monad.Writer.Class--instance (MonadIO m, Associate "IO" m xs) => MonadIO (Eff xs) where- liftIO = liftEff (Proxy :: Proxy "IO") . liftIO--#if MIN_VERSION_resourcet(1,2,0)-instance (MonadResource m, Associate "IO" m xs) => MonadResource (Eff xs) where- liftResourceT = liftEff (Proxy :: Proxy "IO") . liftResourceT-#endif--instance (MonadThrow m, Associate "IO" m xs) => MonadThrow (Eff xs) where- throwM = liftEff (Proxy :: Proxy "IO") . throwM--instance (MonadCatch m, Associate "IO" m xs) => MonadCatch (Eff xs) where- catch m0 h = go m0 where- go m = case debone m of- Return a -> return a- Instruction i t :>>= k -> case compareMembership (association :: Membership xs ("IO" ':> m)) i of- Left _ -> boned $ Instruction i t :>>= go . k- Right Refl -> boned $ Instruction i (try t) :>>= go . either h k--pReader :: Proxy "Reader"-pReader = Proxy--instance Associate "Reader" ((:~:) r) xs => MonadReader r (Eff xs) where- ask = askEff pReader- local = localEff pReader- reader = asksEff pReader--pState :: Proxy "State"-pState = Proxy--instance Associate "State" (State s) xs => MonadState s (Eff xs) where- get = getEff pState- put = putEff pState- state = stateEff pState--pWriter :: Proxy "Writer"-pWriter = Proxy--instance (Monoid w, Associate "Writer" ((,) w) xs) => MonadWriter w (Eff xs) where- writer = writerEff pWriter- tell = tellEff pWriter- listen = listenEff pWriter- pass = passEff pWriter--pEither :: Proxy "Either"-pEither = Proxy--instance (Associate "Either" (Const e) xs) => MonadError e (Eff xs) where- throwError = throwEff pEither- catchError = catchEff pEither---- | A bit dubious-instance (Monoid e, Associate "Either" (Const e) xs) => Alternative (Eff xs) where- empty = throwError mempty- p <|> q = catchError p (const q)--instance (Monoid e, Associate "Either" (Const e) xs) => MonadPlus (Eff xs) where- mzero = empty- mplus = (<|>)---- | mtl-compatible reader-type ReaderDef r = "Reader" >: ReaderEff r---- | Specialised version of 'runReaderEff' compatible with the 'MonadReader' instance.-runReaderDef :: Eff (ReaderDef r ': xs) a -> r -> Eff xs a-runReaderDef = runReaderEff-{-# INLINE runReaderDef #-}---- | mtl-compatible state-type StateDef s = "State" >: State s---- | 'runStateEff' specialised for the 'MonadState' instance.-runStateDef :: Eff (StateDef s ': xs) a -> s -> Eff xs (a, s)-runStateDef = runStateEff-{-# INLINE runStateDef #-}---- | 'evalStateEff' specialised for the 'MonadState' instance.-evalStateDef :: Eff (StateDef s ': xs) a -> s -> Eff xs a-evalStateDef = evalStateEff-{-# INLINE evalStateDef #-}---- | 'execStateEff' specialised for the 'MonadState' instance.-execStateDef :: Eff (StateDef s ': xs) a -> s -> Eff xs s-execStateDef = execStateEff-{-# INLINE execStateDef #-}---- | mtl-compatible writer-type WriterDef w = "Writer" >: WriterEff w---- | 'runWriterDef' specialised for the 'MonadWriter' instance.-runWriterDef :: Monoid w => Eff (WriterDef w ': xs) a -> Eff xs (a, w)-runWriterDef = runWriterEff-{-# INLINE runWriterDef #-}---- | 'execWriterDef' specialised for the 'MonadWriter' instance.-execWriterDef :: Monoid w => Eff (WriterDef w ': xs) a -> Eff xs w-execWriterDef = execWriterEff-{-# INLINE execWriterDef #-}---- | Same as @'EitherDef' ()@-type MaybeDef = "Either" >: EitherEff ()---- | Similar to 'runMaybeT', but on 'Eff'-runMaybeDef :: Eff (MaybeDef ': xs) a -> Eff xs (Maybe a)-runMaybeDef = runMaybeEff-{-# INLINE runMaybeDef #-}---- | mtl-compatible either effect-type EitherDef e = "Either" >: EitherEff e---- | Similar to 'runExceptT', but on 'Eff'-runEitherDef :: Eff (EitherDef e ': xs) a -> Eff xs (Either e a)-runEitherDef = runEitherEff-{-# INLINE runEitherDef #-}
src/Data/Extensible/Field.hs view
@@ -4,9 +4,8 @@ {-# LANGUAGE ScopedTypeVariables, TypeFamilies #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-}-#if __GLASGOW_HASKELL__ >= 800-{-# LANGUAGE UndecidableSuperClasses, TypeInType #-}-#endif+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE PolyKinds #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Extensible.Field@@ -24,7 +23,7 @@ , (@:>) , (@==) , FieldOptic- , FieldName+ , xlb , liftField , liftField2 -- * Records and variants@@ -37,104 +36,56 @@ , matchWithField , matchField -- * Key / value- , AssocKey- , AssocValue- , KeyValue- , proxyAssocKey- , proxyAssocValue- , stringAssocKey+ , KeyOf+ , proxyKeyOf+ , stringKeyOf+ , TargetOf+ , proxyTargetOf , KeyIs- , ValueIs- -- * Internal- , LabelPhantom- , Labelling- , Inextensible+ , TargetIs+ , KeyTargetAre ) where import Control.DeepSeq (NFData) import qualified Data.Aeson as J import Data.Coerce-#if __GLASGOW_HASKELL__ < 802-import Data.Constraint-#endif+#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-#if __GLASGOW_HASKELL__ >= 800 import Data.Kind-#endif import Data.Profunctor.Unsafe import Data.Extensible.Wrapper+import Data.Functor.Compose import Data.Functor.Identity import Data.Hashable-import Data.Semigroup+import Data.Incremental (Incremental) import Data.String-import Data.Text.Prettyprint.Doc-import Data.Typeable (Typeable)+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 Language.Haskell.TH (appE, conE) import Test.QuickCheck.Arbitrary---- | Take the type of the key-type family AssocKey (kv :: Assoc k v) :: k where- AssocKey (k ':> v) = k---- | Proxy-level 'AssocKey'. This is useful when using 'symbolVal'.-proxyAssocKey :: proxy kv -> Proxy (AssocKey kv)-proxyAssocKey _ = Proxy---- | Proxy-level 'AssocValue'.-proxyAssocValue :: proxy kv -> Proxy (AssocValue kv)-proxyAssocValue _ = Proxy---- | Get a string from a proxy of @'Assoc' 'Symbol' v@.-stringAssocKey :: (IsString a, KnownSymbol (AssocKey kv)) => proxy kv -> a-stringAssocKey = fromString . symbolVal . proxyAssocKey-{-# INLINE stringAssocKey #-}---- | Take the type of the value-type family AssocValue (kv :: Assoc k v) :: v where- AssocValue (k ':> v) = v---- | Combined constraint for 'Assoc'-class (pk (AssocKey kv), pv (AssocValue kv)) => KeyValue pk pv kv where--instance (pk k, pv v) => KeyValue pk pv (k ':> v)---- | Constraint applied to 'AssocKey'-class (pk (AssocKey kv)) => KeyIs pk kv where--instance (pk k) => KeyIs pk (k ':> v)---- | Constraint applied to 'AssocValue'-class (pv (AssocValue kv)) => ValueIs pv kv where--instance (pv v) => ValueIs pv (k ':> v)-+import Type.Membership -- | A @'Field' h (k ':> v)@ is @h v@ annotated with the field name @k@. ----- @'Field' :: (v -> *) -> Assoc k v -> *@+-- @'Field' :: (v -> Type) -> Assoc k v -> Type@ ---#if __GLASGOW_HASKELL__ >= 800 newtype Field (h :: v -> Type) (kv :: Assoc k v)-#else-newtype Field (h :: v -> *) (kv :: Assoc k v)-#endif- = Field { getField :: h (AssocValue kv) }+ = Field { getField :: h (TargetOf kv) } - deriving (Typeable, Generic)+ deriving (Generic) -#define ND_Field(c) deriving instance c (h (AssocValue kv)) => c (Field h kv)+#define ND_Field(c) deriving instance c (h (TargetOf kv)) => c (Field h kv) ND_Field(Eq) ND_Field(Ord)@@ -153,15 +104,19 @@ ND_Field(NFData) ND_Field(Arbitrary) ND_Field(Hashable)-ND_Field(Csv.FromField)-ND_Field(Csv.ToField) 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) -newtype instance U.MVector s (Field h x) = MV_Field (U.MVector s (h (AssocValue x)))-newtype instance U.Vector (Field h x) = V_Field (U.Vector (h (AssocValue x)))+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))) -instance (U.Unbox (h (AssocValue x))) => M.MVector U.MVector (Field h x) where+instance (U.Unbox (h (TargetOf x))) => M.MVector U.MVector (Field h x) where {-# INLINE basicLength #-} {-# INLINE basicUnsafeSlice #-} {-# INLINE basicOverlaps #-}@@ -190,7 +145,7 @@ 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 (AssocValue x))) => G.Vector U.Vector (Field h x) where+instance (U.Unbox (h (TargetOf x))) => G.Vector U.Vector (Field h x) where {-# INLINE basicUnsafeFreeze #-} {-# INLINE basicUnsafeThaw #-} {-# INLINE basicLength #-}@@ -203,24 +158,21 @@ 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 (AssocValue x))) => U.Unbox (Field h x)--instance Lift (h (AssocValue x)) => Lift (Field h x) where- lift = appE (conE 'Field) . lift . getField+instance (U.Unbox (h (TargetOf x))) => U.Unbox (Field h x) -- | Lift a function for the content.-liftField :: (g (AssocValue kv) -> h (AssocValue kv)) -> Field g kv -> Field h kv+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 (AssocValue kv) -> g (AssocValue kv) -> h (AssocValue kv))+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 #-} @@ -237,21 +189,21 @@ -- | 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 '[]@@ -277,48 +229,25 @@ -- 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 -> Type) (v :: kind).-#else-type FieldOptic k = forall f p t xs (h :: kind -> *) (v :: kind).-#endif (Extensible f p t- , ExtensibleConstr t (Field h) xs (k ':> v)- , 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)--#if __GLASGOW_HASKELL__ >= 800--- | The trivial inextensible data type-data Inextensible (h :: k -> Type) (xs :: [k])-#else-data Inextensible (h :: k -> *) (xs :: [k])-#endif--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 ':> ()]) ()---- | Signifies a field name internally-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. --@@ -328,7 +257,7 @@ -- <: #str \@= "foo" -- <: nil -- @-(@=) :: Wrapper h => FieldName k -> Repr h v -> Field h (k ':> v)+(@=) :: Wrapper h => Proxy k -> Repr h v -> Field h (k ':> v) (@=) _ = Field #. review _Wrapper {-# INLINE (@=) #-} infix 1 @=@@ -342,18 +271,18 @@ -- <: #str \<\@=\> getLine -- <: nil -- @-(<@=>) :: (Functor f, Wrapper h) => FieldName k -> f (Repr h v) -> Comp f (Field h) (k ':> v)+(<@=>) :: (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 '@='-(@==) :: FieldName (k :: Symbol) -> v -> Field Identity (k ':> v)+(@==) :: Proxy (k :: Symbol) -> v -> Field Identity (k ':> v) (@==) = (@=) {-# INLINE (@==) #-} infix 1 @==
− src/Data/Extensible/HList.hs
@@ -1,48 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}-{-# LANGUAGE Trustworthy #-}--------------------------------------------------------------------------------- |--- Module : Data.Extensible.HList--- Copyright : (c) Fumiaki Kinoshita 2018--- License : BSD3------ Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>------ Heterogeneous list--------------------------------------------------------------------------module Data.Extensible.HList where--import Data.Extensible.Internal-import Unsafe.Coerce--data HList (h :: k -> *) (xs :: [k]) where- HNil :: HList h '[]- HCons :: h x -> HList h xs -> HList h (x ': xs)--infixr 5 `HCons`--htraverse :: Applicative f => (forall x. g x -> f (h x)) -> HList g xs -> f (HList h xs)-htraverse _ HNil = pure HNil-htraverse f (HCons h xs) = HCons <$> f h <*> htraverse f xs--htraverseWithIndex :: forall f g h xs. Applicative f- => (forall x. Membership xs x -> g x -> f (h x)) -> HList g xs -> f (HList h xs)-htraverseWithIndex f = go 0 where- go :: Int -> HList g t -> f (HList h t)- go !k (HCons x xs) = HCons <$> f (unsafeCoerce k) x <*> go (k + 1) xs- go _ HNil = pure HNil-{-# INLINE htraverseWithIndex #-}--hfoldrWithIndex :: forall h r xs. (forall x. Membership xs x -> h x -> r -> r) -> r -> HList h xs -> r-hfoldrWithIndex f r = go 0 where- go :: Int -> HList h t -> r- go !k (HCons x xs) = f (unsafeCoerce k) x $ go (k + 1) xs- go _ HNil = r-{-# INLINE hfoldrWithIndex #-}--hlength :: HList h xs -> Int-hlength = go 0 where- go :: Int -> HList h xs -> Int- go n HNil = n- go n (HCons _ xs) = let !n' = n + 1 in go n' xs-{-# INLINE hlength #-}
src/Data/Extensible/Inclusion.hs view
@@ -2,9 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE UndecidableSuperClasses #-}-#endif ------------------------------------------------------------------------ -- | -- Module : Data.Extensible.Inclusion@@ -16,11 +14,7 @@ ------------------------------------------------------------------------ module Data.Extensible.Inclusion ( -- * Inclusion-#if __GLASGOW_HASKELL__ >= 800 type (⊆)-#else- (⊆)()-#endif , Include , inclusion , shrink@@ -38,8 +32,8 @@ 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@@ -48,24 +42,24 @@ type Include ys = Forall (Member ys) -- | Reify the inclusion of type level sets.-inclusion :: forall xs ys. Include ys xs => Membership ys :* xs+inclusion :: forall xs ys. Include ys xs => xs :& Membership ys inclusion = hrepeatFor (Proxy :: Proxy (Member ys)) membership {-# INLINABLE inclusion #-} -- | /O(n)/ Select some elements.-shrink :: (xs ⊆ ys) => h :* ys -> h :* xs+shrink :: (xs ⊆ ys) => ys :& h -> xs :& h shrink h = hmap (hindex h) inclusion {-# INLINE shrink #-} -- | /O(1)/ Embed to a larger union.-spread :: (xs ⊆ ys) => h :| xs -> h :| ys+spread :: (xs ⊆ ys) => xs :/ h -> ys :/ h spread (EmbedAt i h) = views (pieceAt i) EmbedAt inclusion h {-# INLINE spread #-} ------------------------------------------------------------------ type family Associated' (xs :: [Assoc k v]) (t :: Assoc k v) :: Constraint where- Associated' xs (k ':> v) = Associate k v xs+ 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@@ -78,16 +72,16 @@ type IncludeAssoc ys = Forall (Associated ys) -- | Reify the inclusion of type level sets.-inclusionAssoc :: forall xs ys. IncludeAssoc ys xs => Membership ys :* xs+inclusionAssoc :: forall xs ys. IncludeAssoc ys xs => xs :& Membership ys inclusionAssoc = hrepeatFor (Proxy :: Proxy (Associated ys)) getAssociation {-# INLINABLE inclusionAssoc #-} -- | /O(n)/ Select some elements.-shrinkAssoc :: (IncludeAssoc ys xs) => h :* ys -> h :* xs+shrinkAssoc :: (IncludeAssoc ys xs) => ys :& h -> xs :& h shrinkAssoc h = hmap (hindex h) inclusionAssoc {-# INLINE shrinkAssoc #-} -- | /O(1)/ Embed to a larger union.-spreadAssoc :: (IncludeAssoc ys xs) => h :| xs -> h :| ys+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,211 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}--------------------------------------------------------------------------------- |--- Module : Data.Extensible.Inclusion--- Copyright : (c) Fumiaki Kinoshita 2018--- License : BSD3------ Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>------ A bunch of combinators that contains magic--------------------------------------------------------------------------module Data.Extensible.Internal (- -- * Membership- Membership- , getMemberId- , mkMembership- , reifyMembership- , leadership- , compareMembership- , impossibleMembership- , here- , navNext- -- * Member class- , Member(..)- , remember-#if __GLASGOW_HASKELL__ >= 800- , type (∈)-#else- , (∈)()-#endif- , FindType- -- * Association- , Assoc(..)-#if __GLASGOW_HASKELL__ >= 800- , type (>:)-#else- , (>:)()-#endif- , Associate(..)- , FindAssoc- -- * Sugar- , Elaborate- , Elaborated(..)- -- * Miscellaneous- , Head- , Last- , module Data.Type.Equality- , module Data.Proxy- ) where-import Control.DeepSeq (NFData)-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.Hashable-import Data.Text.Prettyprint.Doc-import Data.Typeable-import Language.Haskell.TH hiding (Pred)-import Language.Haskell.TH.Lift-import Data.Semigroup (Semigroup(..))-import GHC.TypeLits---- | 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 :: Int -- ^ get the position as an 'Int'.- } deriving (Typeable, NFData)--instance Lift (Membership xs x) where- lift (Membership i) = mkMembership i--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 #-}---- | @x@ is a member of @xs@-class Member xs x where- membership :: Membership xs x--instance (Elaborate x (FindType x xs) ~ 'Expecting pos, KnownNat pos) => Member xs x where- membership = Membership (fromInteger $ natVal (Proxy :: Proxy pos))- {-# INLINE membership #-}--instance Hashable (Membership xs x) where- hashWithSalt s = hashWithSalt s . getMemberId---- | Make up a 'Membership' from an integer.-reifyMembership :: Int -> (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 :>---- | A synonym for (':>')-type (>:) = '(:>)---- | @'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 0 k xs) ~ 'Expecting (n ':> v), KnownNat n) => Associate k v xs where- association = Membership (fromInteger $ natVal (Proxy :: Proxy n))---- | A readable type search result-data Elaborated k v = Expecting v | Missing k | Duplicate k---- | Make the result more readable-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---- | Find a type associated to the specified key.-type family FindAssoc (n :: Nat) (key :: k) (xs :: [Assoc k v]) where- FindAssoc n k ((k ':> v) ': xs) = (n ':> v) ': FindAssoc (1 + n) k xs- FindAssoc n k ((k' ':> v) ': xs) = FindAssoc (1 + n) k xs- FindAssoc n k '[] = '[]--instance Show (Membership xs x) where- show (Membership n) = "$(mkMembership " ++ show n ++ ")"--instance Pretty (Membership xs x) where- pretty (Membership n) = "$(mkMembership " <> pretty n <> ")"--instance Eq (Membership xs x) where- _ == _ = True--instance Ord (Membership xs x) where- compare _ _ = EQ--instance Semigroup (Membership xs x) where- x <> _ = x---- | Embodies a type equivalence to ensure that the 'Membership' points the first element.-leadership :: Membership (y ': xs) x -> (x :~: y -> r) -> (Membership xs x -> r) -> r-leadership (Membership 0) l _ = l (unsafeCoerce Refl)-leadership (Membership n) _ r = r (Membership (n - 1))-{-# INLINE leadership #-}---- | 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 #-}---- | There is no 'Membership' of an empty list.-impossibleMembership :: Membership '[] x -> r-impossibleMembership _ = error "Impossible"---- | 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 #-}---- | Unicode flipped alias for 'Member'-type x ∈ xs = Member xs x---- | First element-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) = 0 ': FindType x xs- FindType x (y ': ys) = MapSucc (FindType x ys)- FindType x '[] = '[]---- | Last element-type family Last (x :: [k]) :: k where- Last '[x] = x- Last (x ': xs) = Last xs---- | Ideally, it will be 'Map Succ'-type family MapSucc (xs :: [Nat]) :: [Nat] where- MapSucc '[] = '[]- MapSucc (x ': xs) = (1 + x) ': MapSucc xs
src/Data/Extensible/Internal/Rig.hs view
@@ -47,6 +47,10 @@ -- | 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 #-}
src/Data/Extensible/Label.hs view
@@ -10,9 +10,7 @@ -- -- Experimental API for OverloadedLabels. GHC 8.0+ only ------------------------------------------------------------------------------module Data.Extensible.Label where--#if __GLASGOW_HASKELL__ >= 800+module Data.Extensible.Label () where import Data.Extensible.Class import Data.Extensible.Field@@ -20,31 +18,14 @@ import GHC.OverloadedLabels import Data.Extensible.Wrapper -instance k ~ l => IsLabel k (Proxy l) where-#if __GLASGOW_HASKELL__ >= 802- fromLabel = Proxy-#else- fromLabel _ = Proxy-#endif---- | Specialised version of 'itemAssoc'.-訊 :: Proxy k -> FieldOptic k-訊 = itemAssoc- instance (Extensible f p e- , Associate k v xs- , Labelling k p+ , Lookup xs k v , Wrapper h- , ExtensibleConstr e (Field h) xs (k ':> v)+ , ExtensibleConstr e xs (Field h) (k ':> v) , rep ~ Repr h v- , s ~ e (Field h) xs+ , s ~ e xs (Field h) , s ~ t , rep ~ rep' ) => IsLabel k (p rep (f rep') -> p s (f t)) where-#if __GLASGOW_HASKELL__ >= 802 fromLabel = itemAssoc (Proxy :: Proxy k)-#else- fromLabel _ = itemAssoc (Proxy :: Proxy k)-#endif-#endif
src/Data/Extensible/Match.hs view
@@ -23,11 +23,10 @@ import Data.Extensible.Wrapper import Data.Typeable (Typeable) import Data.Profunctor.Unsafe-import Data.Semigroup 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 #-} @@ -37,12 +36,12 @@ {-# INLINE mapMatch #-} -- | /O(1)/ Perform pattern matching.-match :: Match h a :* xs -> h :| xs -> a+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`
src/Data/Extensible/Nullable.hs view
@@ -14,7 +14,11 @@ , wrench , retrench , Nullable(..)- , mapNullable) where+ , mapNullable+ , fromNullable+ , coinclusionAssoc+ , wrenchAssoc+ , retrenchAssoc) where import Control.DeepSeq (NFData) import Data.Extensible.Class@@ -27,31 +31,27 @@ import Data.Extensible.Wrapper import qualified Data.Extensible.Struct as S import Data.Profunctor.Unsafe-import Data.Semigroup+import Data.Maybe (fromMaybe) import GHC.Generics (Generic) import Language.Haskell.TH.Lift-import Language.Haskell.TH (appE, conE) import Test.QuickCheck.Arbitrary -- | Wrapped Maybe newtype Nullable h x = Nullable { getNullable :: Maybe (h x) }- deriving (Show, Eq, Ord, Typeable, Generic, NFData, Arbitrary, Hashable)+ 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- (<>) = mappend+ 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 (Nullable (Just a)) (Nullable (Just b)) = Nullable (Just (a <> b))- mappend a@(Nullable (Just _)) _ = a- mappend _ b = b--instance Lift (h a) => Lift (Nullable h a) where- lift = appE (conE 'Nullable) . lift . getNullable+ mappend = (<>) -- | Apply a function to its content. mapNullable :: (g x -> h y) -> Nullable g x -> Nullable h y@@ -59,22 +59,46 @@ {-# INLINE mapNullable #-} -- | The inverse of 'inclusion'.-coinclusion :: (Include ys xs, Generate ys) => Nullable (Membership xs) :* ys+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 => Nullable h :* xs+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
@@ -18,7 +18,6 @@ , (<%|) , accessing ) where-import Data.Extensible.Internal import Data.Extensible.Internal.Rig import Data.Extensible.Class import Data.Extensible.Product@@ -29,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 (<%) #-}@@ -56,6 +55,6 @@ infixr 1 <%| -- | An accessor for newtype constructors.-accessing :: (Coercible x a, x ∈ xs, Extensible f p t, ExtensibleConstr t Identity xs x) => (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,6 +1,8 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE ViewPatterns, ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-} ----------------------------------------------------------------------------- -- |@@ -13,16 +15,16 @@ ------------------------------------------------------------------------ module Data.Extensible.Product ( -- * Basic operations- (:*)+ (:&) , nil , (<:) , (<!)+ , (=<:) , hlength , type (++) , happend , hmap , hmapWithIndex- , hmapWithIndexFor , hzipWith , hzipWith3 , hfoldMap@@ -33,10 +35,17 @@ , htraverseWithIndex , hsequence -- * Constrained fold+ , hmapWithIndexFor , hfoldMapFor , hfoldMapWithIndexFor , hfoldrWithIndexFor , hfoldlWithIndexFor+ -- * Constraind fold without proxies+ , hfoldMapWith+ , hfoldMapWithIndexWith+ , hfoldrWithIndexWith+ , hfoldlWithIndexWith+ , hmapWithIndexWith -- * Evaluating , hforce -- * Update@@ -58,49 +67,56 @@ , Forall(..) , hgenerateFor , htabulateFor- , hrepeatFor) where+ , hrepeatFor+ , hgenerateWith+ , htabulateWith+ , hrepeatWith) where -import Data.Extensible.Internal+import Data.Extensible.Internal.Rig (review) import Data.Extensible.Struct import Data.Extensible.Sum-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif import Data.Extensible.Class-import qualified Data.Extensible.HList as HList 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 -> h :* xs -> h :* (x ': xs)+(<:) :: 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 -> h :* xs -> h :* (x ': xs)+(<!) :: h x -> xs :& h -> (x ': xs) :& h (<!) x = fromHList . (HList.HCons $! x) . toHList {-# INLINE (<!) #-} infixr 0 <! -- | An empty product.-nil :: h :* '[]+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 -> h :* xs+fromHList :: HList.HList h xs -> xs :& h fromHList xs = hfrozen (newFromHList xs) {-# INLINE fromHList #-} -- | Flipped 'hlookup'-hindex :: h :* xs -> Membership xs x -> h x+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) -> g :* xs -> h :* xs+hmapWithIndex :: (forall x. Membership xs x -> g x -> h x) -> xs :& g -> xs :& h hmapWithIndex t p = hfrozen (newFrom p t) {-# INLINE hmapWithIndex #-} @@ -108,105 +124,133 @@ hmapWithIndexFor :: Forall c xs => proxy c -> (forall x. c x => Membership xs x -> g x -> h x)- -> g :* xs -> h :* xs+ -> 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) -> g :* xs -> h :* xs+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) -> f :* xs -> g :* xs -> h :* xs+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) -> f :* xs -> g :* xs -> h :* xs -> i :* xs+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) -> h :* xs -> a+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) -> g :* xs -> 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 -> h :* xs -> r+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) => proxy c- -> (forall x. c x => Membership xs x -> h x -> r -> r) -> r -> h :* xs -> r-hfoldrWithIndexFor p f r xs = henumerateFor p xs (\i -> f i (hlookup i xs)) r+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 -> h :* xs -> r+ -> (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) -> h :* xs -> a+ -> (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) -> h :* xs -> a+ -> (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 (Comp . fmap g . f) ≡ Comp . fmap (htraverse g) . htraverse f+-- htraverse (Compose . fmap g . f) ≡ Compose . fmap (htraverse g) . htraverse f -- @-htraverse :: Applicative f => (forall x. g x -> f (h x)) -> g :* xs -> f (h :* xs)+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 => Comp f h :* xs -> f (h :* xs)-hsequence = htraverse getComp+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 -> h :* xs) -> f a -> Comp f h :* xs-hcollect f m = htabulate $ \i -> Comp $ fmap (hlookup i . f) m+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 (h :* xs) -> Comp f h :* xs+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)) -> g :* xs -> f (h :* xs)+ => (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) -> h :* xs+hrepeat :: Generate xs => (forall x. h x) -> xs :& h hrepeat x = hfrozen $ newRepeat x {-# INLINE hrepeat #-} @@ -217,37 +261,53 @@ -- 'htabulate' ('hindex' m) ≡ m -- 'hindex' ('htabulate' k) ≡ k -- @-htabulate :: Generate xs => (forall x. Membership xs x -> h x) -> h :* xs+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 (h :* xs)+ => (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) -> h :* xs+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) -> h :* xs+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 (h :* xs)+ => 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 -> g :| xs)+ => (a -> xs :/ g) -> (forall x. Membership xs x -> g x -> h x -> h x)- -> h :* xs -> f a -> h :* xs+ -> 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@@ -256,16 +316,16 @@ -- | @haccum = 'haccumMap' 'id'@ haccum :: Foldable f => (forall x. Membership xs x -> g x -> h x -> h x)- -> h :* xs -> f (g :| xs) -> h :* xs+ -> xs :& h -> f (xs :/ g) -> xs :& h haccum = haccumMap id {-# INLINE haccum #-} -- | Group sums by type.-hpartition :: (Foldable f, Generate xs) => (a -> h :| xs) -> f a -> Comp [] h :* xs-hpartition f = haccumMap f (\_ x (Comp xs) -> Comp (x:xs)) $ hrepeat $ Comp []+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 :: h :* xs -> h :* xs+hforce :: xs :& h -> xs :& h hforce p = hfoldrWithIndex (const seq) p p {-# INLINE hforce #-}
src/Data/Extensible/Record.hs view
@@ -1,4 +1,8 @@ {-# LANGUAGE LambdaCase, TemplateHaskell, TypeFamilies #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------ -- | -- Module : Data.Extensible.Record@@ -9,29 +13,73 @@ -- -- Bidirectional conversion from/to records -------------------------------------------------------------------------module Data.Extensible.Record (IsRecord(..), toRecord, fromRecord, record, deriveIsRecord) where+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.HList 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 *]+ type RecFields a :: [Assoc Symbol Type] recordFromList :: HList (Field Identity) (RecFields a) -> a recordToList :: a -> HList (Field Identity) (RecFields a) + 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)++ default recordToList :: (Generic a, GIsRecord (Rep a) '[], GRecFields (Rep a) '[] ~ RecFields a)+ => a -> HList (Field Identity) (RecFields a)+ recordToList x = recordToList' (from x) HNil+ instance IsRecord () where type RecFields () = '[] recordFromList _ = () recordToList _ = HNil +-- | 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)++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' #-}++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@@ -47,57 +95,3 @@ => Optic' p f a (Record (RecFields a)) record = dimap toRecord (fmap fromRecord) {-# INLINE record #-}--tvName :: TyVarBndr -> Name-tvName (PlainTV n) = n-tvName (KindedTV n _) = n---- | Create an 'IsRecord' instance for a normal record declaration.-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- 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 'recordFromList [Clause- [shape2Pat $ fmap (\x -> ConP 'Field [ConP 'Identity [VarP x]]) newNames]- (NormalB $ RecConE conName [(n, VarE n') | (n, n') <- zip names newNames])- []- ]- , FunD 'recordToList [Clause- [ConP conName (map VarP newNames)]- (NormalB $ shape2Exp [AppE (ConE 'Field)- $ AppE (ConE 'Identity)- $ VarE n- | n <- newNames])- []- ]- ]- ]- info -> fail $ "deriveIsRecord: Unsupported " ++ show info--shape2Pat :: [Pat] -> Pat-shape2Pat [] = ConP 'HNil []-shape2Pat (x : xs) = ConP 'HCons [x, shape2Pat xs]--shape2Exp :: [Exp] -> Exp-shape2Exp [] = ConE 'HNil-shape2Exp (x : xs) = ConE 'HCons `AppE` x `AppE` shape2Exp xs
src/Data/Extensible/Struct.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MagicHash, UnboxedTuples #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------ -- |@@ -32,6 +31,7 @@ , atomicModify_ , atomicModify'_ -- * Immutable product+ , (:&) , (:*) , unsafeFreeze , newFrom@@ -46,26 +46,28 @@ , 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 import Data.Extensible.Internal.Rig import Data.Extensible.Wrapper-import Control.Comonad import Data.Profunctor.Rep import Data.Profunctor.Sieve+import Data.Proxy+import Data.Kind (Type) import qualified Data.StateVar as V-import Data.Typeable (Typeable)-import qualified Data.Extensible.HList as L 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 -> *) (xs :: [k]) = Struct (SmallMutableArray# s Any)- deriving Typeable+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 ()@@ -137,7 +139,7 @@ WrappedPointer s i $~! f = liftIO $ void $ atomicModify'_ s i $ over _Wrapper f -- | Get a 'WrappedPointer' from a name.-(-$>) :: forall k h xs v s. (Associate k v xs) => Struct s h xs -> Proxy k -> WrappedPointer s h (Repr h (k ':> v))+(-$>) :: 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 (-$>) #-} @@ -202,23 +204,26 @@ -- | The type of extensible products. ----- @(:*) :: (k -> *) -> [k] -> *@+-- @(:&) :: [k] -> (k -> Type) -> Type@ ---data (h :: k -> *) :* (s :: [k]) = HProduct (SmallArray# Any)+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 (h :* xs)+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 => h :* xs -> m (Struct (PrimState m) h xs)+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 :: h :* xs -> Int+hlength :: xs :& h -> Int hlength (HProduct ar) = I# (sizeofSmallArray# ar) {-# INLINE hlength #-} @@ -230,7 +235,7 @@ infixr 5 ++ -- | Combine products.-happend :: (h :* xs) -> (h :* ys) -> (h :* (xs ++ ys))+happend :: xs :& h -> ys :& h -> (xs ++ ys) :& h happend (HProduct lhs) (HProduct rhs) = runST $ primitive $ \s0 -> let lhsSz = sizeofSmallArray# lhs rhsSz = sizeofSmallArray# rhs@@ -240,17 +245,19 @@ 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 -> h :* xs -> r+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. h :* xs -> L.HList h xs+toHList :: forall h xs. xs :& h -> L.HList h xs toHList p = go 0 where go :: Int -> L.HList h xs go i@@ -265,7 +272,7 @@ -- | Create a new 'Struct' using the contents of a product. newFrom :: forall g h m xs. (PrimMonad m)- => g :* xs+ => xs :& g -> (forall x. Membership xs x -> g x -> h x) -> m (Struct (PrimState m) h xs) newFrom hp@(HProduct ar) k = do@@ -294,18 +301,18 @@ . 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 -> h :* xs -> h x+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)) -> h :* xs+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 ()) -> h :* xs -> h :* xs+hmodify :: (forall s. Struct s h xs -> ST s ()) -> xs :& h -> xs :& h hmodify f m = runST $ do s <- thaw m f s@@ -315,9 +322,9 @@ {-# RULES "hmodify/batch" forall (a :: forall s. Struct s h xs -> ST s ()) (b :: forall s. Struct s h xs -> ST s ())- (x :: h :* xs). hmodify b (hmodify a x) = hmodify (\s -> a s >> b s) x #-}+ (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+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
src/Data/Extensible/Sum.hs view
@@ -13,7 +13,7 @@ -- ------------------------------------------------------------------------ module Data.Extensible.Sum (- (:|)(..)+ (:/)(..) , hoist , embed , strike@@ -23,47 +23,45 @@ , 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@@ -71,25 +69,25 @@ -- | /O(1)/ Naive pattern match (<:|) :: (h x -> r)- -> (h :| xs -> r)- -> h :| (x ': xs)+ -> (xs :/ h -> r)+ -> (x ': xs) :/ h -> r-(<:|) r c = \(EmbedAt i h) -> leadership i+(<:|) 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 #-} -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
@@ -9,25 +9,14 @@ -- ------------------------------------------------------------------------ module Data.Extensible.TH (mkField- , mkFieldAs- , decEffects- , decEffectSet- , decEffectSuite- , customDecEffects) where+ , mkFieldAs) where -import Data.Proxy-import Data.Extensible.Internal import Data.Extensible.Class (itemAssoc)-import Data.Extensible.Effect import Data.Extensible.Field-import Data.List (nub) 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:@@ -40,8 +29,10 @@ -- @ -- mkField :: String -> DecsQ-mkField str = fmap concat $ forM (words str) $ \s@(x:xs) ->- let name = mkName $ if isLower x then x : xs else '_' : x : xs+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@.@@ -53,154 +44,3 @@ , valD (varP name) (normalB $ varE 'itemAssoc `appE` lbl) [] , return $ PragmaD $ InlineP name Inline FunLike AllPhases ]---- | Generate named effects from a GADT declaration.------ @--- decEffects [d|--- data Blah a b x where--- Blah :: Int -> a -> Blah a b b--- |]--- @------ generates------ @--- type Blah a b = \"Blah\" >: Action '[Int, a] b--- blah :: forall xs a b--- . Associate \"Blah\" (Action '[Int, a] b) xs--- => Int -> a -> Eff xs b--- blah a0 a1--- = liftEff--- (Data.Proxy.Proxy :: Data.Proxy.Proxy \"Blah\")--- (AArgument a0 (AArgument a1 AResult))--- @-decEffects :: DecsQ -> DecsQ-decEffects = customDecEffects False True---- | Instead of making a type synonym for individual actions, it defines a list--- of actions.-decEffectSet :: DecsQ -> DecsQ-decEffectSet = customDecEffects True False---- | Generates type synonyms for the set of actions and also individual actions.-decEffectSuite :: DecsQ -> DecsQ-decEffectSuite = customDecEffects True True---- | Generate effect suite with custom settings.-customDecEffects :: Bool -- ^ generate a synonym of the set of actions- -> Bool -- ^ generate synonyms for individual actions- -> DecsQ -> DecsQ-customDecEffects synSet synActions decs = decs >>= \ds -> fmap concat $ forM ds $ \case-#if MIN_VERSION_template_haskell(2,11,0)- DataD _ dataName tparams _ cs _-#else- DataD _ dataName tparams cs _-#endif- -> do- (cxts, dcs) <- fmap unzip $ traverse (con2Eff tparams) cs-- let vars = map PlainTV $ nub $ concatMap (varsT . snd) cxts- return $ [TySynD dataName vars (typeListT $ map snd cxts) | synSet]- ++ [ TySynD k (map PlainTV $ nub $ varsT t) t | synActions, (k, t) <- cxts]- ++ concat dcs- _ -> fail "mkEffects accepts GADT declaration"--con2Eff :: [TyVarBndr] -> Con -> Q ((Name, Type), [Dec])-#if MIN_VERSION_template_haskell(2,11,0)-con2Eff _ (GadtC [name] st (AppT _ resultT))- = return $ effectFunD name (map snd st) resultT-#endif-con2Eff tparams (ForallC _ eqs (NormalC name st))- = return $ fromMangledGADT tparams eqs name st-con2Eff tparams (ForallC _ _ c) = con2Eff tparams c-con2Eff _ p = do- runIO (print p)- fail "Unsupported constructor"--fromMangledGADT :: [TyVarBndr] -> [Type] -> Name -> [(Strict, Type)] -> ((Name, Type), [Dec])-fromMangledGADT tyvars_ eqs con fieldTypes- = effectFunD con argumentsT result- where- getTV (PlainTV n) = n- getTV (KindedTV n _) = n-- tyvars = map getTV tyvars_-- dic_ = [(v, t) | AppT (AppT EqualityT (VarT v)) t <- eqs]- dic = dic_ ++ [(t, VarT v) | (v, VarT t) <- dic_]-- params' = do- (t, v) <- zip tyvars uniqueNames- case lookup t dic of- Just (VarT p) -> return (t, p)- _ -> return (t, v)-- argumentsT = map (\case- (_, VarT n) -> maybe (VarT n) VarT $ lookup n params'- (_, x) -> x) fieldTypes-- result = case lookup (last tyvars) dic of- Just (VarT v) -> case lookup v params' of- Just p -> VarT p- Nothing -> VarT v- Just t -> t- Nothing -> VarT $ mkName "x"--varsT :: Type -> [Name]-varsT (VarT v) = [v]-varsT (AppT s t) = varsT s ++ varsT t-varsT _ = []--effectFunD :: Name- -> [Type]- -> Type- -> ((Name, Type), [Dec])-effectFunD key argumentsT resultT = ((key, PromotedT '(:>) `AppT` nameT `AppT` actionT)- , [SigD fName typ, FunD fName [effClause nameT (length argumentsT)]]) where-- varList = mkName "xs"-- fName = let (ch : rest) = nameBase key in mkName $ toLower ch : rest-- typ = ForallT (map PlainTV $ varList : varsT resultT ++ concatMap varsT argumentsT)- [associateT nameT actionT varList]- $ effectFunT varList argumentsT resultT-- -- Action [a, B, C] R- actionT = ConT ''Action `AppT` typeListT argumentsT `AppT` resultT-- nameT = LitT $ StrTyLit $ nameBase key--effectFunT :: Name- -> [Type]- -> Type- -> Type-effectFunT varList argumentsT resultT- = foldr (\x y -> ArrowT `AppT` x `AppT` y) rt argumentsT where- rt = ConT ''Eff `AppT` VarT varList `AppT` resultT--uniqueNames :: [Name]-uniqueNames = map mkName $ concatMap (flip replicateM ['a'..'z']) [1..]--typeListT :: [Type] -> Type-typeListT = foldr (\x y -> PromotedConsT `AppT` x `AppT` y) PromotedNilT--associateT :: Type -- key- -> Type -- type- -> Name -- variable- -> Type-associateT nameT t xs = ConT ''Associate `AppT` nameT `AppT` t `AppT` VarT xs--effClause :: Type -- effect key- -> Int -- number of arguments- -> Clause-effClause nameT n = Clause (map VarP argNames) (NormalB rhs) [] where- -- liftEff (Proxy :: Proxy "Foo")- lifter = VarE 'liftEff `AppE` (ConE 'Proxy `SigE` AppT (ConT ''Proxy) nameT)-- argNames = map (mkName . ("a" ++) . show) [0..n-1]-- rhs = lifter `AppE` foldr (\x y -> ConE 'AArgument `AppE` x `AppE` y)- (ConE 'AResult)- (map VarE argNames)
src/Data/Extensible/Tangle.hs view
@@ -21,70 +21,70 @@ 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.Field import Data.Extensible.Product import Data.Extensible.Internal.Rig import Data.Extensible.Nullable import Data.Extensible.Wrapper-import Data.Semigroup+import Data.Proxy -- | @'TangleT' h xs m@ is the monad of computations that may depend on the elements in 'xs'.-newtype TangleT h xs m a = TangleT- { unTangleT :: RWST (Comp (TangleT h xs m) h :* xs) () (Nullable h :* xs) m a }+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 h xs) where+instance MonadTrans (TangleT xs h) where lift = TangleT . lift -instance (Monad m, Semigroup a) => Semigroup (TangleT h xs m a) where+instance (Monad m, Semigroup a) => Semigroup (TangleT xs h m a) where (<>) = liftA2 (<>) -instance (Monad m, Monoid a) => Monoid (TangleT h xs m a) where+instance (Monad m, Monoid a) => Monoid (TangleT xs h m a) where mempty = pure mempty- mappend = liftA2 mappend+ mappend = (<>) -- | Hitch an element associated to the 'FieldName' through a wrapper.-lasso :: forall k v m h xs. (Monad m, Associate k v xs, Wrapper h)- => FieldName k -> TangleT h xs m (Repr h (k ':> v))+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 h xs m (h x)+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 $ getComp $ hlookup k tangles+ 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- => Comp (TangleT h xs m) h :* xs- -> Nullable h :* xs- -> TangleT h xs m a- -> m (a, Nullable h :* xs)+ => 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- => Comp (TangleT h xs m) h :* xs- -> Nullable h :* xs- -> TangleT h xs m a+ => 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- => Comp (TangleT h xs m) h :* xs- -> Nullable h :* xs- -> m (h :* xs)+ => 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,6 +1,7 @@ {-# LANGUAGE DeriveTraversable, StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PatternSynonyms #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Extensible.Wrapper@@ -13,39 +14,51 @@ module Data.Extensible.Wrapper ( Wrapper(..) , _WrapperAs- , Const'(..)- , Comp(..)+ , 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.Semigroup-import Data.Text.Prettyprint.Doc+import Data.Kind (Type) import GHC.Generics (Generic)-import Language.Haskell.TH.Lift-import Language.Haskell.TH (conE, appE) import Test.QuickCheck.Arbitrary --- | The extensible data types should take @k -> *@ as a parameter.+-- | 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 -> *) where- -- | @'Repr' h v@ is the actual representation of @h v@.- type Repr h (v :: k) :: *+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)@@ -54,8 +67,10 @@ instance Wrapper Identity where type Repr Identity a = a- _Wrapper = dimap runIdentity (fmap Identity)- {-# INLINE _Wrapper #-}+ unwrap = runIdentity+ {-# INLINE unwrap #-}+ wrap = Identity+ {-# INLINE wrap #-} instance Wrapper Maybe where type Repr Maybe a = Maybe a@@ -69,40 +84,40 @@ type Repr [] a = [a] _Wrapper = id --- | Poly-kinded composition-newtype Comp (f :: j -> *) (g :: i -> j) (a :: i) = Comp { getComp :: f (g a) }- deriving (Show, Eq, Ord, Typeable, NFData, Generic, Semigroup, Monoid, Arbitrary, Hashable, Pretty)+type Comp = Compose -deriving instance (Functor f, Functor g) => Functor (Comp f g)-deriving instance (Foldable f, Foldable g) => Foldable (Comp f g)-deriving instance (Traversable f, Traversable g) => Traversable (Comp f g)+pattern Comp :: f (g a) -> Compose f g a+pattern Comp a = Compose a+{-# DEPRECATED Comp "Use Compose instead" #-} -instance Lift (f (g a)) => Lift (Comp f g a) where- lift = appE (conE 'Comp) . lift . getComp +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 -> Comp f g b-comp f = Comp #. fmap f+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 (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 g))+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 #-} --- | Poly-kinded Const-newtype Const' a x = Const' { getConst' :: a }- deriving (Show, Eq, Ord, Typeable, Generic, NFData, Semigroup, Monoid, Functor, Foldable, Traversable, Arbitrary, Hashable)--instance Wrapper (Const' a) where- type Repr (Const' a) b = a- _Wrapper = dimap getConst' (fmap Const')- {-# 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 = ()- _Wrapper = dimap (const ()) (fmap (const Proxy))- {-# INLINE _Wrapper #-}+ wrap _ = Proxy+ {-# INLINE wrap #-}+ unwrap _ = ()+ {-# INLINE unwrap #-} -- | Poly-kinded product data Prod f g a = Prod (f a) (g a)@@ -113,15 +128,17 @@ instance (Wrapper f, Wrapper g) => Wrapper (Prod f g) where type Repr (Prod f g) a = (Repr f a, Repr g a)- _Wrapper = dimap (\(Prod f g) -> (view _Wrapper f, view _Wrapper g))- $ fmap (\(a, b) -> review _Wrapper a `Prod` review _Wrapper b)+ 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- Prod a b `mappend` Prod c d = Prod (mappend a c) (mappend b d)+ mappend = (<>) instance (Arbitrary (f a), Arbitrary (g a)) => Arbitrary (Prod f g a) where arbitrary = Prod <$> arbitrary <*> arbitrary
− tests/effects.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE GADTs, DataKinds, FlexibleContexts, TemplateHaskell #-}-{-# OPTIONS_GHC -ddump-splices #-}-import Data.Extensible--decEffects [d|- data Example a b x where- Concrete :: Int -> Example a b ()- PolyArg :: a -> Example a b ()- PolyRes :: Example a b b- PolyArgRes :: a -> Example a b b- UnboundArg :: x -> Example a b ()- UnboundRes :: Example a b x--- ExtArg :: Show s => s -> Example a b ()--- ExtRes :: Read s => Example a b s- |]--decEffects [d|- data Simple x where- Simple :: Simple ()- |]--main = return ()