diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,6 @@ # This Travis job script has been generated by a script via # -# make_travis_yml_2.hs 'extensible.cabal' +# runghc make_travis_yml_2.hs 'extensible.cabal' # # For more information, see https://github.com/hvr/multi-ghc-travis # @@ -24,6 +24,8 @@ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx + - rm -rfv $HOME/.cabal/packages/head.hackage + matrix: include: - compiler: "ghc-7.10.3" @@ -35,61 +37,84 @@ - compiler: "ghc-8.2.1" # env: TEST=--disable-tests BENCH=--disable-benchmarks addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}} + - compiler: "ghc-8.4.1" + env: GHCHEAD=true + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.4.1], sources: [hvr-ghc]}} before_install: - - HC=${CC} - - HCPKG=${HC/ghc/ghc-pkg} - - unset CC - - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH - - PKGNAME='extensible' + - HC=${CC} + - HCPKG=${HC/ghc/ghc-pkg} + - unset CC + - ROOTDIR=$(pwd) + - mkdir -p $HOME/.local/bin + - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" + - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) + - echo $HCNUMVER install: - - cabal --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - BENCH=${BENCH---enable-benchmarks} - - TEST=${TEST---enable-tests} - - HADDOCK=${HADDOCK-true} - - INSTALLED=${INSTALLED-true} - - travis_retry cabal update -v - - sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config - - rm -fv cabal.project.local - - "echo 'packages: .' > cabal.project" - - rm -f cabal.project.freeze - - cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j2 all - - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 all + - cabal --version + - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" + - BENCH=${BENCH---enable-benchmarks} + - TEST=${TEST---enable-tests} + - HADDOCK=${HADDOCK-true} + - INSTALLED=${INSTALLED-true} + - GHCHEAD=${GHCHEAD-false} + - travis_retry cabal update -v + - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" + - rm -fv cabal.project cabal.project.local + # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage + - | + if $GHCHEAD; then + sed -i.bak 's/-- allow-newer:.*/allow-newer: *:base, *:template-haskell, *:ghc, *:Cabal/' ${HOME}/.cabal/config + echo 'repository head.hackage' >> ${HOME}/.cabal/config + echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config + echo ' secure: True' >> ${HOME}/.cabal/config + echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config + echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config + echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config + echo ' key-threshold: 3' >> ${HOME}/.cabal.config + + cabal new-update head.hackage -v + fi + - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' + - "printf 'packages: \".\"\\n' > cabal.project" + - cat cabal.project + - if [ -f "./configure.ac" ]; then + (cd "." && autoreconf -i); + fi + - rm -f cabal.project.freeze + - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all + - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all + - rm -rf .ghc.environment.* "."/dist + - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) + # Here starts the actual work to be performed for the package under test; # any command which exits with a non-zero exit code causes the build to fail. script: - - if [ -f configure.ac ]; then autoreconf -i; fi - - rm -rf .ghc.environment.* dist/ - - cabal sdist # test that a source-distribution can be generated - - cd dist/ - - SRCTAR=(${PKGNAME}-*.tar.gz) - - SRC_BASENAME="${SRCTAR/%.tar.gz}" - - tar -xvf "./$SRC_BASENAME.tar.gz" - - cd "$SRC_BASENAME/" -## from here on, CWD is inside the extracted source-tarball - - rm -fv cabal.project.local - - "echo 'packages: .' > cabal.project" - # this builds all libraries and executables (without tests/benchmarks) - - rm -f cabal.project.freeze - - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all - # this builds all libraries and executables (including tests/benchmarks) - # - rm -rf ./dist-newstyle + # test that source-distributions can be generated + - (cd "." && cabal sdist) + - mv "."/dist/extensible-*.tar.gz ${DISTDIR}/ + - cd ${DISTDIR} || false + - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; + - "printf 'packages: extensible-*/*.cabal\\n' > cabal.project" + - cat cabal.project + # this builds all libraries and executables (without tests/benchmarks) + - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all - # Build with installed constraints for packages in global-db - - if $INSTALLED; then - echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks $(${HCPKG} list --global --simple-output --names-only | sed 's/\([a-zA-Z0-9-]\{1,\}\) */--constraint="\1 installed" /g') all | sh; - else echo "Not building with installed constraints"; fi + # Build with installed constraints for packages in global-db + - if $INSTALLED; then echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks $(${HCPKG} list --global --simple-output --names-only | sed 's/\([a-zA-Z0-9-]\{1,\}\) */--constraint="\1 installed" /g') all | sh; else echo "Not building with installed constraints"; fi - # build & run tests, build benchmarks - - cabal new-build -w ${HC} ${TEST} ${BENCH} all - - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} all; fi + # build & run tests, build benchmarks + - cabal new-build -w ${HC} ${TEST} ${BENCH} all + - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi - # haddock - - rm -rf ./dist-newstyle - - if $HADDOCK; then cabal new-haddock -w ${HC} --disable-tests --disable-benchmarks all; else echo "Skipping haddock generation";fi + # cabal check + - (cd extensible-* && cabal check) + + # haddock + - rm -rf ./dist-newstyle + - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi # REGENDATA ["extensible.cabal"] # EOF diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +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) diff --git a/examples/aeson.hs b/examples/aeson.hs deleted file mode 100644 --- a/examples/aeson.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -import Data.Aeson hiding (KeyValue) -import Data.Constraint -import Data.Extensible -import Data.Monoid -import Data.Proxy -import Data.String (fromString) -import GHC.TypeLits (KnownSymbol, symbolVal) -import qualified Data.HashMap.Strict as HM - -instance Forall (KeyValue KnownSymbol FromJSON) xs => FromJSON (Record xs) where - parseJSON = withObject "Object" $ \v -> hgenerateFor (Proxy :: Proxy (KeyValue KnownSymbol FromJSON)) - $ \m -> let k = symbolVal (proxyAssocKey m) in case HM.lookup (fromString k) v of - Just a -> Field <$> return <$> parseJSON a - Nothing -> fail $ "Missing key: " ++ k - -instance Forall (KeyValue KnownSymbol ToJSON) xs => ToJSON (Record xs) where - toJSON rec = Object $ HM.fromList $ flip appEndo [] $ hfoldMap getConst' - $ hzipWith (\(Comp Dict) v -> Const' $ Endo - ((fromString $ symbolVal $ proxyAssocKey v, toJSON $ getField v):)) - (library :: Comp Dict (KeyValue KnownSymbol ToJSON) :* xs) rec diff --git a/extensible.cabal b/extensible.cabal --- a/extensible.cabal +++ b/extensible.cabal @@ -1,9 +1,12 @@ name: extensible -version: 0.4.7.1 +version: 0.4.7.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, variants, effects, tangles +description: + This package provides a powerful framework to combine and manipulate various types of structures. + . + See also for tutorials. license: BSD3 license-file: LICENSE author: Fumiaki Kinoshita @@ -12,7 +15,7 @@ category: Data, Records, Monads build-type: Simple stability: experimental -Tested-With: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1 +Tested-With: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1, GHC == 8.4.1 extra-source-files: examples/*.hs @@ -65,22 +68,27 @@ , PolyKinds , CPP build-depends: base >= 4.8 && <5 - , template-haskell + , aeson + , bytestring + , cassava + , comonad , constraints + , deepseq , ghc-prim + , hashable + , monad-skeleton >= 0.1.2 + , mtl , primitive , profunctors + , QuickCheck , semigroups - , comonad - , deepseq - , hashable + , StateVar , tagged + , template-haskell + , text , transformers + , unordered-containers , vector - , mtl - , monad-skeleton >= 0.1.2 - , StateVar - , QuickCheck hs-source-dirs: src ghc-options: -Wall default-language: Haskell2010 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 @@ -18,7 +18,11 @@ ----------------------------------------------------------------------- module Data.Extensible.Dictionary (library, WrapForall, Instance1) where import Control.DeepSeq +import qualified Data.Aeson as J +import qualified Data.Csv as Csv +import qualified Data.ByteString.Char8 as BC import Data.Extensible.Class +import Data.Extensible.Field import Data.Extensible.Product import Data.Extensible.Sum import Data.Extensible.Internal @@ -28,10 +32,14 @@ import Data.Extensible.Wrapper import Data.Functor.Identity import Data.Hashable +import qualified Data.HashMap.Strict as HM import Data.Semigroup import qualified Data.Vector.Generic as G import qualified Data.Vector.Generic.Mutable as M import qualified Data.Vector.Unboxed as U +import qualified Data.Vector as V +import qualified Data.Text as T +import GHC.TypeLits import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen @@ -61,7 +69,7 @@ (library :: Comp Dict (Instance1 Semigroup h) :* xs) {-# INLINE (<>) #-} -instance WrapForall Monoid h xs => Monoid (h :* xs) where +instance (WrapForall Semigroup h xs, WrapForall Monoid h xs) => Monoid (h :* xs) where mempty = hrepeatFor (Proxy :: Proxy (Instance1 Monoid h)) mempty {-# INLINE mempty #-} mappend = hzipWith3 (\(Comp Dict) -> mappend) @@ -143,6 +151,37 @@ rnf xs = henumerateFor (Proxy :: Proxy (Instance1 NFData h)) (Proxy :: Proxy xs) (\i -> deepseq (hlookup i xs)) () {-# INLINE rnf #-} + +instance WrapForall Csv.FromField h xs => Csv.FromRecord (h :* xs) where + parseRecord rec = hgenerateFor (Proxy :: Proxy (Instance1 Csv.FromField h)) + $ \i -> G.indexM rec (getMemberId i) >>= Csv.parseField + +instance Forall (KeyValue KnownSymbol (Instance1 Csv.FromField h)) xs => Csv.FromNamedRecord (Field h :* xs) where + parseNamedRecord rec = hgenerateFor (Proxy :: Proxy (KeyValue KnownSymbol (Instance1 Csv.FromField h))) + $ \i -> rec Csv..: BC.pack (symbolVal (proxyAssocKey i)) >>= Csv.parseField + +instance WrapForall Csv.ToField h xs => Csv.ToRecord (h :* xs) where + toRecord = V.fromList + . hfoldrWithIndexFor (Proxy :: Proxy (Instance1 Csv.ToField h)) + (\_ v -> (:) $ Csv.toField v) [] + +instance Forall (KeyValue KnownSymbol (Instance1 Csv.ToField h)) xs => Csv.ToNamedRecord (Field h :* xs) where + toNamedRecord = hfoldlWithIndexFor (Proxy :: Proxy (KeyValue KnownSymbol (Instance1 Csv.ToField h))) + (\k m v -> HM.insert (BC.pack (symbolVal (proxyAssocKey k))) (Csv.toField v) m) + HM.empty + +instance Forall (KeyValue KnownSymbol (Instance1 J.FromJSON h)) xs => J.FromJSON (Field h :* xs) where + parseJSON = J.withObject "Object" $ \v -> hgenerateFor + (Proxy :: Proxy (KeyValue KnownSymbol (Instance1 J.FromJSON h))) + $ \m -> let k = symbolVal (proxyAssocKey m) in case HM.lookup (T.pack k) v of + Just a -> Field <$> J.parseJSON a + Nothing -> fail $ "Missing key: " ++ k + +instance Forall (KeyValue KnownSymbol (Instance1 J.ToJSON h)) xs => J.ToJSON (Field h :* xs) where + toJSON = J.Object . hfoldlWithIndexFor + (Proxy :: Proxy (KeyValue KnownSymbol (Instance1 J.ToJSON h))) + (\k m v -> HM.insert (T.pack (symbolVal (proxyAssocKey k))) (J.toJSON v) m) + HM.empty instance WrapForall Show h xs => Show (h :| xs) where showsPrec d (EmbedAt i h) = showParen (d > 10) $ showString "EmbedAt " 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 @@ -39,16 +39,21 @@ , AssocValue , KeyValue , proxyAssocKey + , proxyAssocValue + , KeyIs + , ValueIs -- * Internal , LabelPhantom , Labelling , Inextensible ) where import Control.DeepSeq (NFData) +import qualified Data.Aeson as J import Data.Coerce #if __GLASGOW_HASKELL__ < 802 import Data.Constraint #endif +import qualified Data.Csv as Csv import Data.Extensible.Class import Data.Extensible.Sum import Data.Extensible.Match @@ -80,6 +85,10 @@ proxyAssocKey :: proxy kv -> Proxy (AssocKey kv) proxyAssocKey _ = Proxy +-- | Proxy-level 'AssocKey'. This is useful when using 'symbolVal'. +proxyAssocValue :: proxy kv -> Proxy (AssocValue kv) +proxyAssocValue _ = Proxy + -- | Take the type of the value type family AssocValue (kv :: Assoc k v) :: v where AssocValue (k ':> v) = v @@ -89,6 +98,17 @@ instance (pk k, pv v) => KeyValue pk pv (k ':> v) +-- | Combined constraint for 'Assoc' +class (pk (AssocKey kv)) => KeyIs pk kv where + +instance (pk k) => KeyIs pk (k ':> v) + +-- | Combined constraint for 'Assoc' +class (pv (AssocValue kv)) => ValueIs pv kv where + +instance (pv v) => ValueIs pv (k ':> v) + + -- | A @'Field' h (k ':> v)@ is @h v@ annotated with the field name @k@. -- -- @'Field' :: (v -> *) -> Assoc k v -> *@ @@ -121,6 +141,10 @@ ND_Field(NFData) ND_Field(Arbitrary) ND_Field(Hashable) +ND_Field(Csv.FromField) +ND_Field(Csv.ToField) +ND_Field(J.FromJSON) +ND_Field(J.ToJSON) newtype instance U.MVector s (Field h x) = MV_Field (U.MVector s (h (AssocValue x))) newtype instance U.Vector (Field h x) = V_Field (U.Vector (h (AssocValue x))) 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 @@ -39,6 +39,9 @@ type Repr (Nullable h) x = Maybe (Repr h x) _Wrapper = withIso _Wrapper $ \f g -> dimap (fmap f . getNullable) (fmap (Nullable . fmap g)) +instance Semigroup (h x) => Semigroup (Nullable h x) where + (<>) = mappend + instance Semigroup (h x) => Monoid (Nullable h x) where mempty = Nullable Nothing mappend (Nullable (Just a)) (Nullable (Just b)) = Nullable (Just (a <> b))