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