diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -11,6 +11,7 @@ cabal.config .stack-work .bash_history +dist-newstyle # ========================= # Operating System Files diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -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 diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,8 @@ -extensible -====================== +![logo](https://github.com/fumieval/extensible/blob/master/artwork/logo.png?raw=true) -[![Build Status](https://travis-ci.org/fumieval/extensible.svg?branch=master)](https://travis-ci.org/fumieval/extensible) +![Haskell CI](https://github.com/fumieval/extensible/workflows/Haskell%20CI/badge.svg) [![Hackage](https://img.shields.io/hackage/v/extensible.svg)](https://hackage.haskell.org/package/extensible) +[![Discord](https://img.shields.io/discord/664807830116892674?color=%237095ec&label=Discord&style=plastic)](https://discord.gg/DG93Tgs) This package provides extensible poly-kinded records, variants and effects. diff --git a/examples/eff.hs b/examples/eff.hs deleted file mode 100644 --- a/examples/eff.hs +++ /dev/null @@ -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)) diff --git a/examples/nullable.hs b/examples/nullable.hs new file mode 100644 --- /dev/null +++ b/examples/nullable.hs @@ -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}") diff --git a/extensible.cabal b/extensible.cabal --- a/extensible.cabal +++ b/extensible.cabal @@ -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 for tutorials. -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Fumiaki Kinoshita maintainer: Fumiaki Kinoshita -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 diff --git a/src/Data/Extensible.hs b/src/Data/Extensible.hs --- a/src/Data/Extensible.hs +++ b/src/Data/Extensible.hs @@ -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 diff --git a/src/Data/Extensible/Bits.hs b/src/Data/Extensible/Bits.hs --- a/src/Data/Extensible/Bits.hs +++ b/src/Data/Extensible/Bits.hs @@ -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 #-} diff --git a/src/Data/Extensible/Class.hs b/src/Data/Extensible/Class.hs --- a/src/Data/Extensible/Class.hs +++ b/src/Data/Extensible/Class.hs @@ -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 diff --git a/src/Data/Extensible/Dictionary.hs b/src/Data/Extensible/Dictionary.hs --- a/src/Data/Extensible/Dictionary.hs +++ b/src/Data/Extensible/Dictionary.hs @@ -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)) diff --git a/src/Data/Extensible/Effect.hs b/src/Data/Extensible/Effect.hs deleted file mode 100644 --- a/src/Data/Extensible/Effect.hs +++ /dev/null @@ -1,463 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Extensible.Effect --- Copyright : (c) Fumiaki Kinoshita 2018 --- License : BSD3 --- --- Maintainer : Fumiaki Kinoshita --- --- 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 diff --git a/src/Data/Extensible/Effect/Default.hs b/src/Data/Extensible/Effect/Default.hs deleted file mode 100644 --- a/src/Data/Extensible/Effect/Default.hs +++ /dev/null @@ -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 --- --- 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 #-} diff --git a/src/Data/Extensible/Field.hs b/src/Data/Extensible/Field.hs --- a/src/Data/Extensible/Field.hs +++ b/src/Data/Extensible/Field.hs @@ -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 @== diff --git a/src/Data/Extensible/HList.hs b/src/Data/Extensible/HList.hs deleted file mode 100644 --- a/src/Data/Extensible/HList.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} -{-# LANGUAGE Trustworthy #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Extensible.HList --- Copyright : (c) Fumiaki Kinoshita 2018 --- License : BSD3 --- --- Maintainer : Fumiaki Kinoshita --- --- 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 #-} diff --git a/src/Data/Extensible/Inclusion.hs b/src/Data/Extensible/Inclusion.hs --- a/src/Data/Extensible/Inclusion.hs +++ b/src/Data/Extensible/Inclusion.hs @@ -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 #-} diff --git a/src/Data/Extensible/Internal.hs b/src/Data/Extensible/Internal.hs deleted file mode 100644 --- a/src/Data/Extensible/Internal.hs +++ /dev/null @@ -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 --- --- 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 diff --git a/src/Data/Extensible/Internal/Rig.hs b/src/Data/Extensible/Internal/Rig.hs --- a/src/Data/Extensible/Internal/Rig.hs +++ b/src/Data/Extensible/Internal/Rig.hs @@ -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 #-} diff --git a/src/Data/Extensible/Label.hs b/src/Data/Extensible/Label.hs --- a/src/Data/Extensible/Label.hs +++ b/src/Data/Extensible/Label.hs @@ -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 diff --git a/src/Data/Extensible/Match.hs b/src/Data/Extensible/Match.hs --- a/src/Data/Extensible/Match.hs +++ b/src/Data/Extensible/Match.hs @@ -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` diff --git a/src/Data/Extensible/Nullable.hs b/src/Data/Extensible/Nullable.hs --- a/src/Data/Extensible/Nullable.hs +++ b/src/Data/Extensible/Nullable.hs @@ -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 #-} diff --git a/src/Data/Extensible/Plain.hs b/src/Data/Extensible/Plain.hs --- a/src/Data/Extensible/Plain.hs +++ b/src/Data/Extensible/Plain.hs @@ -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 #-} diff --git a/src/Data/Extensible/Product.hs b/src/Data/Extensible/Product.hs --- a/src/Data/Extensible/Product.hs +++ b/src/Data/Extensible/Product.hs @@ -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 , (<:) , ( 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 :* xs -> h :* (x ': xs) +( xs :& h -> (x ': xs) :& h ( 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 #-} diff --git a/src/Data/Extensible/Record.hs b/src/Data/Extensible/Record.hs --- a/src/Data/Extensible/Record.hs +++ b/src/Data/Extensible/Record.hs @@ -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 diff --git a/src/Data/Extensible/Struct.hs b/src/Data/Extensible/Struct.hs --- a/src/Data/Extensible/Struct.hs +++ b/src/Data/Extensible/Struct.hs @@ -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 diff --git a/src/Data/Extensible/Sum.hs b/src/Data/Extensible/Sum.hs --- a/src/Data/Extensible/Sum.hs +++ b/src/Data/Extensible/Sum.hs @@ -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' diff --git a/src/Data/Extensible/TH.hs b/src/Data/Extensible/TH.hs --- a/src/Data/Extensible/TH.hs +++ b/src/Data/Extensible/TH.hs @@ -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) diff --git a/src/Data/Extensible/Tangle.hs b/src/Data/Extensible/Tangle.hs --- a/src/Data/Extensible/Tangle.hs +++ b/src/Data/Extensible/Tangle.hs @@ -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 #-} diff --git a/src/Data/Extensible/Wrapper.hs b/src/Data/Extensible/Wrapper.hs --- a/src/Data/Extensible/Wrapper.hs +++ b/src/Data/Extensible/Wrapper.hs @@ -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 diff --git a/tests/effects.hs b/tests/effects.hs deleted file mode 100644 --- a/tests/effects.hs +++ /dev/null @@ -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 ()