extensible 0.4.5 → 0.4.6

raw patch · 13 files changed

+439/−69 lines, 13 filesdep +hashabledep +vectorPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: hashable, vector

API changes (from Hackage documentation)

Files

• .travis.yml +68/−52
• CHANGELOG.md +8/−0
• examples/getopt.hs +13/−0
• extensible.cabal +5/−2
• src/Data/Extensible/Bits.hs +12/−2
• src/Data/Extensible/Dictionary.hs +165/−0
• src/Data/Extensible/Field.hs +70/−4
• src/Data/Extensible/GetOpt.hs +71/−0
• src/Data/Extensible/Internal.hs +4/−0
• src/Data/Extensible/Nullable.hs +2/−1
• src/Data/Extensible/Product.hs +11/−0
• src/Data/Extensible/Tangle.hs +6/−6
• src/Data/Extensible/Wrapper.hs +4/−2

@@ -1,79 +1,95 @@-# This file has been generated -- see https://github.com/hvr/multi-ghc-travis+# This Travis job script has been generated by a script via+#+#   make_travis_yml_2.hs 'extensible.cabal'+#+# For more information, see https://github.com/hvr/multi-ghc-travis+# language: c sudo: false +git:+  submodules: false  # whether to recursively clone submodules+ cache:   directories:-    - $HOME/.cabsnap     - $HOME/.cabal/packages+    - $HOME/.cabal/store  before_cache:   - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log-  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar+  # remove files that are regenerated by 'cabal update'+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx  matrix:   include:-    - env: CABALVER=1.22 GHCVER=7.10.3-      compiler: ": #GHC 7.10.3"-      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}}-    - env: CABALVER=1.24 GHCVER=8.0.1-      compiler: ": #GHC 8.0.1"-      addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}+    - compiler: "ghc-7.10.3"+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.10.3], sources: [hvr-ghc]}}+    - compiler: "ghc-8.0.2"+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}}+    - compiler: "ghc-8.2.1"+    # env: TEST=--disable-tests BENCH=--disable-benchmarks+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}}  before_install:+ - HC=${CC}+ - HCPKG=${HC/ghc/ghc-pkg}  - unset CC- - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH+ - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH+ - PKGNAME='extensible'  install:  - cabal --version- - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"- - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];-   then-     zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >-          $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;-   fi+ - 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 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config- - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt- - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt--# check whether current requested install-plan matches cached package-db snapshot- - if diff -u $HOME/.cabsnap/installplan.txt installplan.txt;-   then-     echo "cabal build-cache HIT";-     rm -rfv .ghc;-     cp -a $HOME/.cabsnap/ghc $HOME/.ghc;-     cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;-   else-     echo "cabal build-cache MISS";-     rm -rf $HOME/.cabsnap;-     mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;-     cabal install --only-dependencies --enable-tests --enable-benchmarks;-   fi--# snapshot package-db on cache miss- - if [ ! -d $HOME/.cabsnap ];-   then-      echo "snapshotting package-db to build-cache";-      mkdir $HOME/.cabsnap;-      cp -a $HOME/.ghc $HOME/.cabsnap/ghc;-      cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;-   fi+ - 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  # 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- - cabal configure --enable-tests --enable-benchmarks -v2  # -v2 provides useful information for debugging- - cabal build   # this builds all libraries and executables (including tests/benchmarks)- - cabal test- - cabal check- - cabal sdist   # tests that a source-distribution can be generated+ - 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 -# Check that the resulting source distribution can be built & installed.-# If there are no other `.tar.gz` files in `dist`, this can be even simpler:-# `cabal install --force-reinstalls dist/*-*.tar.gz`- - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&-   (cd dist && cabal install --force-reinstalls "$SRC_TGZ")+ # 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++ # haddock+ - rm -rf ./dist-newstyle+ - if $HADDOCK; then cabal new-haddock -w ${HC} --disable-tests --disable-benchmarks all; else echo "Skipping haddock generation";fi++# REGENDATA ["extensible.cabal"] # EOF

@@ -1,3 +1,11 @@+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`

@@ -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

@@ -1,5 +1,5 @@ name:                extensible-version:             0.4.5+version:             0.4.6 synopsis:            Extensible, efficient, optics-friendly data types and effects homepage:            https://github.com/fumieval/extensible bug-reports:         http://github.com/fumieval/extensible/issues@@ -12,7 +12,7 @@ category:            Data, Records, Monads build-type:          Simple stability:           experimental-Tested-With:         GHC == 7.10.3, GHC == 8.0.2+Tested-With:         GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1  extra-source-files:   examples/*.hs@@ -35,6 +35,7 @@     Data.Extensible.Field     Data.Extensible.Effect     Data.Extensible.Effect.Default+    Data.Extensible.GetOpt     Data.Extensible.HList     Data.Extensible.Inclusion     Data.Extensible.Internal@@ -72,8 +73,10 @@     , semigroups     , comonad     , deepseq+    , hashable     , tagged     , transformers+    , vector     , mtl     , monad-skeleton >= 0.1.2     , StateVar

@@ -1,6 +1,5 @@ {-# LANGUAGE UndecidableInstances, ScopedTypeVariables, MultiParamTypeClasses, TypeFamilies #-} {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric #-}-{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -dsuppress-all #-}  module Data.Extensible.Bits (BitProd(..)   , FromBits(..)@@ -9,6 +8,7 @@   , blookup   , bupdate   , toBitProd+  , fromBitProd   , BitRecordOf   , BitRecord) where @@ -20,6 +20,7 @@ import Data.Extensible.Internal (getMemberId) import Data.Extensible.Field import Data.Functor.Identity+import Data.Hashable import Data.Ix import Data.Profunctor.Rep import Data.Profunctor.Sieve@@ -31,8 +32,12 @@  -- | Bit-vector product. It has similar interface as @(:*)@ but fields are packed into @r@. newtype BitProd r (h :: k -> *) (xs :: [k]) = BitProd { unBitProd :: r }-  deriving (Eq, Ord, Enum, Bounded, Ix, Generic)+  deriving (Eq, Ord, Enum, Bounded, Ix, Generic, Hashable) +instance (Forall (Instance1 Show h) xs, BitFields r h xs) => Show (BitProd r h xs) where+  showsPrec d x = showParen (d > 10)+    $ showString "toBitProd " . showsPrec 11 (fromBitProd x)+ type family TotalBits h xs where   TotalBits h '[] = 0   TotalBits h (x ': xs) = BitWidth (h x) + TotalBits h xs@@ -115,6 +120,11 @@ toBitProd :: forall r h xs. BitFields r h xs => h :* xs -> BitProd r h xs toBitProd p = hfoldrWithIndexFor (Proxy :: Proxy (Instance1 (FromBits r) h))   (\i v f r -> f $! bupdate i r v) id p (BitProd zeroBits)++-- | Convert a normal extensible record into a bit record.+fromBitProd :: forall r h xs. BitFields r h xs => BitProd r h xs -> h :* xs+fromBitProd p = htabulateFor (Proxy :: Proxy (Instance1 (FromBits r) h))+  $ flip blookup p  -- | 'hlookup' for 'BitProd' blookup :: forall x r h xs.

@@ -26,7 +26,12 @@ import Data.Constraint import Data.Extensible.Struct import Data.Extensible.Wrapper+import Data.Functor.Identity+import Data.Hashable 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 Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen @@ -63,10 +68,72 @@     (library :: Comp Dict (Instance1 Monoid h) :* xs)   {-# INLINE mappend #-} +instance WrapForall Hashable h xs => Hashable (h :* xs) where+  hashWithSalt = hfoldlWithIndexFor (Proxy :: Proxy (Instance1 Hashable h))+    (const hashWithSalt)+  {-# INLINE hashWithSalt #-}+ instance WrapForall Bounded h xs => Bounded (h :* xs) where   minBound = hrepeatFor (Proxy :: Proxy (Instance1 Bounded h)) minBound   maxBound = hrepeatFor (Proxy :: Proxy (Instance1 Bounded h)) maxBound +newtype instance U.MVector s (h :* xs) = MV_Product (Comp (U.MVector s) h :* xs)+newtype instance U.Vector (h :* xs) = V_Product (Comp U.Vector h :* xs)++#define ENUM_EACH(expr) henumerateFor \+  (Proxy :: Proxy (Instance1 U.Unbox h)) (Proxy :: Proxy (x ': xs)) \+  ((>>) . (expr)) (return ())++hlookupC :: Membership xs a -> Comp f g :* xs -> f (g a)+hlookupC i = getComp . hlookup i++instance WrapForall U.Unbox h (x ': xs) => G.Vector U.Vector (h :* (x ': xs)) where+  basicUnsafeFreeze (MV_Product v) = fmap V_Product+    $ hgenerateFor (Proxy :: Proxy (Instance1 U.Unbox h))+    $ \m -> Comp <$> G.basicUnsafeFreeze (hlookupC m v)+  basicUnsafeThaw (V_Product v) = fmap MV_Product+    $ hgenerateFor (Proxy :: Proxy (Instance1 U.Unbox h))+    $ \m -> Comp <$> G.basicUnsafeThaw (hlookupC m v)+  basicLength (V_Product v) = G.basicLength $ getComp $ hindex v here+  basicUnsafeSlice i n (V_Product v) = V_Product+    $ htabulateFor (Proxy :: Proxy (Instance1 U.Unbox h))+    $ \m -> Comp $ 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)+    = ENUM_EACH(\i -> G.basicUnsafeCopy (hlookupC i v) (hlookupC i w))++instance WrapForall U.Unbox h (x ': xs) => M.MVector U.MVector (h :* (x ': xs)) where+  basicLength (MV_Product v) = M.basicLength $ getComp $ hindex v here+  basicUnsafeSlice i n (MV_Product v) = MV_Product+    $ htabulateFor (Proxy :: Proxy (Instance1 U.Unbox h))+    $ \m -> Comp $ M.basicUnsafeSlice i n (hlookupC m v)+  basicOverlaps (MV_Product v1) (MV_Product v2) = henumerateFor+    (Proxy :: Proxy (Instance1 U.Unbox h)) (Proxy :: Proxy (x ': xs))+    (\i -> (||) $ M.basicOverlaps (hlookupC i v1) (hlookupC i v2))+    False+  basicUnsafeNew n = fmap MV_Product+    $ hgenerateFor (Proxy :: Proxy (Instance1 U.Unbox h))+    (const $ Comp <$> M.basicUnsafeNew n)+  basicInitialize (MV_Product v) = ENUM_EACH(\i -> M.basicInitialize $ hlookupC i v)+  basicUnsafeReplicate n x = fmap MV_Product+    $ hgenerateFor (Proxy :: Proxy (Instance1 U.Unbox h))+    $ \m -> fmap Comp $ 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 = ENUM_EACH(\m -> M.basicUnsafeWrite (hlookupC m v) i (hlookup m x))+  basicClear (MV_Product v) = ENUM_EACH(\i -> M.basicClear $ hlookupC i v)+  basicSet (MV_Product v) x = ENUM_EACH(\i -> M.basicSet (hlookupC i v) (hlookup i x))+  basicUnsafeCopy (MV_Product v1) (MV_Product v2)+    = ENUM_EACH(\i -> M.basicUnsafeCopy (hlookupC i v1) (hlookupC i v2))+  basicUnsafeMove (MV_Product v1) (MV_Product v2)+    = ENUM_EACH(\i -> M.basicUnsafeMove (hlookupC i v1) (hlookupC i v2))+  basicUnsafeGrow (MV_Product v) n = fmap MV_Product+    $ hgenerateFor (Proxy :: Proxy (Instance1 U.Unbox h))+    $ \i -> Comp <$> M.basicUnsafeGrow (hlookupC i v) n++instance WrapForall U.Unbox h (x ': xs) => U.Unbox (h :* (x ': xs))+ instance WrapForall Arbitrary h xs => Arbitrary (h :* xs) where   arbitrary = hgenerateFor (Proxy :: Proxy (Instance1 Arbitrary h)) (const arbitrary)   shrink xs = henumerateFor (Proxy :: Proxy (Instance1 Arbitrary h))@@ -101,6 +168,12 @@   rnf (EmbedAt i h) = views (pieceAt i) (\(Comp Dict) -> rnf h) (library :: Comp Dict (Instance1 NFData h) :* xs)   {-# INLINE rnf #-} +instance WrapForall Hashable h xs => Hashable (h :| xs) where+  hashWithSalt s (EmbedAt i h) = views (pieceAt i)+    (\(Comp Dict) -> s `hashWithSalt` i `hashWithSalt` h)+    (library :: Comp Dict (Instance1 Hashable h) :* xs)+  {-# INLINE hashWithSalt #-}+ instance WrapForall Arbitrary h xs => Arbitrary (h :| xs) where   arbitrary = choose (0, hcount (Proxy :: Proxy xs)) >>= henumerateFor       (Proxy :: Proxy (Instance1 Arbitrary h))@@ -119,3 +192,95 @@ -- | Composition for a class and a wrapper class c (h x) => Instance1 c h x instance c (h x) => Instance1 c h x++#if !MIN_VERSION_vector(0,12,1)+newtype instance U.MVector s (Identity a) = MV_Identity (U.MVector s a)+newtype instance U.Vector (Identity a) = V_Identity (U.Vector a)++instance (U.Unbox a) => M.MVector U.MVector (Identity a) where+  {-# INLINE basicLength #-}+  {-# INLINE basicUnsafeSlice #-}+  {-# INLINE basicOverlaps #-}+  {-# INLINE basicUnsafeNew #-}+  {-# INLINE basicInitialize #-}+  {-# INLINE basicUnsafeReplicate #-}+  {-# INLINE basicUnsafeRead #-}+  {-# INLINE basicUnsafeWrite #-}+  {-# INLINE basicClear #-}+  {-# INLINE basicSet #-}+  {-# INLINE basicUnsafeCopy #-}+  {-# INLINE basicUnsafeGrow #-}+  basicLength (MV_Identity v) = M.basicLength v+  basicUnsafeSlice i n (MV_Identity v) = MV_Identity $ M.basicUnsafeSlice i n v+  basicOverlaps (MV_Identity v1) (MV_Identity v2) = M.basicOverlaps v1 v2+  basicUnsafeNew n = MV_Identity <$> M.basicUnsafeNew n+  basicInitialize (MV_Identity v) = M.basicInitialize v+  basicUnsafeReplicate n (Identity x) = MV_Identity <$> M.basicUnsafeReplicate n x+  basicUnsafeRead (MV_Identity v) i = Identity <$> M.basicUnsafeRead v i+  basicUnsafeWrite (MV_Identity v) i (Identity x) = M.basicUnsafeWrite v i x+  basicClear (MV_Identity v) = M.basicClear v+  basicSet (MV_Identity v) (Identity x) = M.basicSet v x+  basicUnsafeCopy (MV_Identity v1) (MV_Identity v2) = M.basicUnsafeCopy v1 v2+  basicUnsafeMove (MV_Identity v1) (MV_Identity v2) = M.basicUnsafeMove v1 v2+  basicUnsafeGrow (MV_Identity v) n = MV_Identity <$> M.basicUnsafeGrow v n++instance (U.Unbox a) => G.Vector U.Vector (Identity a) where+  {-# INLINE basicUnsafeFreeze #-}+  {-# INLINE basicUnsafeThaw #-}+  {-# INLINE basicLength #-}+  {-# INLINE basicUnsafeSlice #-}+  {-# INLINE basicUnsafeIndexM #-}+  basicUnsafeFreeze (MV_Identity v) = V_Identity <$> G.basicUnsafeFreeze v+  basicUnsafeThaw (V_Identity v) = MV_Identity <$> G.basicUnsafeThaw v+  basicLength (V_Identity v) = G.basicLength v+  basicUnsafeSlice i n (V_Identity v) = V_Identity $ G.basicUnsafeSlice i n v+  basicUnsafeIndexM (V_Identity v) i = Identity <$> G.basicUnsafeIndexM v i+  basicUnsafeCopy (MV_Identity mv) (V_Identity v) = G.basicUnsafeCopy mv v++instance (U.Unbox a) => U.Unbox (Identity a)++newtype instance U.MVector s (Const' a b) = MV_Const (U.MVector s a)+newtype instance U.Vector (Const' a b) = V_Const (U.Vector a)++instance (U.Unbox a) => M.MVector U.MVector (Const' a b) where+  {-# INLINE basicLength #-}+  {-# INLINE basicUnsafeSlice #-}+  {-# INLINE basicOverlaps #-}+  {-# INLINE basicUnsafeNew #-}+  {-# INLINE basicInitialize #-}+  {-# INLINE basicUnsafeReplicate #-}+  {-# INLINE basicUnsafeRead #-}+  {-# INLINE basicUnsafeWrite #-}+  {-# INLINE basicClear #-}+  {-# INLINE basicSet #-}+  {-# INLINE basicUnsafeCopy #-}+  {-# INLINE basicUnsafeGrow #-}+  basicLength (MV_Const v) = M.basicLength v+  basicUnsafeSlice i n (MV_Const v) = MV_Const $ M.basicUnsafeSlice i n v+  basicOverlaps (MV_Const v1) (MV_Const v2) = M.basicOverlaps v1 v2+  basicUnsafeNew n = MV_Const <$> M.basicUnsafeNew n+  basicInitialize (MV_Const v) = M.basicInitialize v+  basicUnsafeReplicate n (Const' x) = MV_Const <$> M.basicUnsafeReplicate n x+  basicUnsafeRead (MV_Const v) i = Const' <$> M.basicUnsafeRead v i+  basicUnsafeWrite (MV_Const v) i (Const' x) = M.basicUnsafeWrite v i x+  basicClear (MV_Const v) = M.basicClear v+  basicSet (MV_Const v) (Const' x) = M.basicSet v x+  basicUnsafeCopy (MV_Const v1) (MV_Const v2) = M.basicUnsafeCopy v1 v2+  basicUnsafeMove (MV_Const v1) (MV_Const v2) = M.basicUnsafeMove v1 v2+  basicUnsafeGrow (MV_Const v) n = MV_Const <$> M.basicUnsafeGrow v n++instance (U.Unbox a) => G.Vector U.Vector (Const' a b) where+  {-# INLINE basicUnsafeFreeze #-}+  {-# INLINE basicUnsafeThaw #-}+  {-# INLINE basicLength #-}+  {-# INLINE basicUnsafeSlice #-}+  {-# INLINE basicUnsafeIndexM #-}+  basicUnsafeFreeze (MV_Const v) = V_Const <$> G.basicUnsafeFreeze v+  basicUnsafeThaw (V_Const v) = MV_Const <$> G.basicUnsafeThaw v+  basicLength (V_Const v) = G.basicLength v+  basicUnsafeSlice i n (V_Const v) = V_Const $ G.basicUnsafeSlice i n v+  basicUnsafeIndexM (V_Const v) i = Const' <$> G.basicUnsafeIndexM v i+  basicUnsafeCopy (MV_Const mv) (V_Const v) = G.basicUnsafeCopy mv v++instance (U.Unbox a) => U.Unbox (Const' a b)+#endif

@@ -3,7 +3,7 @@ {-# LANGUAGE ScopedTypeVariables, TypeFamilies #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 800-{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE UndecidableSuperClasses, TypeInType #-} #endif ----------------------------------------------------------------------------- -- |@@ -46,18 +46,27 @@   ) where import Control.DeepSeq (NFData) import Data.Coerce+#if __GLASGOW_HASKELL__ < 802+import Data.Constraint+#endif import Data.Extensible.Class import Data.Extensible.Sum import Data.Extensible.Match import Data.Extensible.Product import Data.Extensible.Internal import Data.Extensible.Internal.Rig+#if __GLASGOW_HASKELL__ >= 800+import Data.Kind+#endif import Data.Profunctor.Unsafe-import Data.Constraint import Data.Extensible.Wrapper import Data.Functor.Identity+import Data.Hashable import Data.Semigroup import Data.Typeable (Typeable)+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.Generics (Generic) import GHC.TypeLits hiding (Nat)@@ -84,8 +93,15 @@ -- -- @'Field' :: (v -> *) -> Assoc k v -> *@ ---newtype Field (h :: v -> *) (kv :: Assoc k v) = Field { getField :: h (AssocValue kv) }+#if __GLASGOW_HASKELL__ >= 800+newtype Field (h :: v -> Type) (kv :: Assoc k v)+#else+newtype Field (h :: v -> *) (kv :: Assoc k v)+#endif+  = Field { getField :: h (AssocValue kv) }+   deriving (Typeable, Generic)+ #define ND_Field(c) deriving instance c (h (AssocValue kv)) => c (Field h kv)  ND_Field(Eq)@@ -104,7 +120,53 @@ ND_Field(Bounded) ND_Field(NFData) ND_Field(Arbitrary)+ND_Field(Hashable) +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)))++instance (U.Unbox (h (AssocValue x))) => M.MVector U.MVector (Field h x) where+  {-# INLINE basicLength #-}+  {-# INLINE basicUnsafeSlice #-}+  {-# INLINE basicOverlaps #-}+  {-# INLINE basicUnsafeNew #-}+  {-# INLINE basicInitialize #-}+  {-# 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+  basicInitialize (MV_Field v) = M.basicInitialize v+  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 (AssocValue 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 (AssocValue x))) => U.Unbox (Field h x)+ -- | Lift a function for the content. liftField :: (g (AssocValue kv) -> h (AssocValue kv)) -> Field g kv -> Field h kv liftField = coerce@@ -176,7 +238,7 @@ -- '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).+type FieldOptic k = forall kind. forall f p t xs (h :: kind -> Type) (v :: kind). #else type FieldOptic k = forall f p t xs (h :: kind -> *) (v :: kind). #endif@@ -187,8 +249,12 @@   , Wrapper h)   => Optic' p f (t (Field h) xs) (Repr h v) +#if __GLASGOW_HASKELL__ >= 800 -- | The trivial inextensible data type+data Inextensible (h :: k -> Type) (xs :: [k])+#else data Inextensible (h :: k -> *) (xs :: [k])+#endif  instance (Functor f, Profunctor p) => Extensible f p Inextensible where   pieceAt _ _ = error "Impossible"

@@ -0,0 +1,71 @@+{-# LANGUAGE TypeFamilies, LambdaCase #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Extensible.GetOpt+-- Copyright   :  (c) Fumiaki Kinoshita 2017+-- License     :  BSD3+--+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>+--+-- A wrapper for 'System.Console.GetOpt'+--------------------------------------------------------------------------------+module Data.Extensible.GetOpt (OptDescr'(..)+  , optNoArg+  , optReqArg+  , getOptRecord+  , withGetOpt) 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.List (foldl')+import System.Console.GetOpt+import System.Environment+import System.Exit+import System.IO++-- | 'OptDescr' with a default+data OptDescr' a = OptDescr' a (OptDescr (a -> a))++instance Wrapper OptDescr' where+  type Repr OptDescr' a = OptDescr' 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 ss ls expl = OptDescr' 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 ss ls ph expl = OptDescr' [] $ Option ss ls (ReqArg (:) ph) expl++getOptRecord :: RecordOf OptDescr' xs -- ^ a record of option descriptors+    -> [String] -- ^ arguments+    -> (Record xs, [String], [String], String -> String) -- ^ (result, remaining non-options, errors, usageInfo)+getOptRecord descs args = (foldl' (flip id) def fs, rs, es, flip usageInfo updaters) where+  (fs, rs, es) = getOpt Permute updaters args+  updaters = hfoldrWithIndex+      (\i (Field (OptDescr' _ opt)) -> (:)+          $ fmap (\f -> over (pieceAt i) (Field . fmap f . getField)) opt)+      [] descs+  def = hmap (\(Field (OptDescr' x _)) -> Field (pure x)) descs++-- | When there's an error, print it along with the usage info to stderr+-- and terminate with 'exitFailure'.+withGetOpt :: MonadIO m => RecordOf OptDescr' xs+  -> (Record xs -> [String] -> m a) -> m a+withGetOpt descs k = getOptRecord descs <$> liftIO getArgs >>= \case+  (r, xs, [], _) -> k r xs+  (_, _, errs, usage) -> liftIO $ do+    mapM_ (hPutStrLn stderr) errs+    getProgName >>= die . usage

@@ -65,6 +65,7 @@ #endif import Control.Monad import Unsafe.Coerce+import Data.Hashable import Data.Typeable import Language.Haskell.TH hiding (Pred) import Data.Bits@@ -98,6 +99,9 @@ instance (Elaborate x (FindType x xs) ~ 'Expecting pos, KnownPosition pos) => Member xs x where   membership = Membership (theInt (Proxy :: Proxy pos))   {-# INLINE membership #-}++instance Hashable (Membership xs x) where+  hashWithSalt s = hashWithSalt s . getMemberId  reifyMembership :: Int -> (forall x. Membership xs x -> r) -> r reifyMembership n k = k (Membership n)

@@ -22,6 +22,7 @@ import Data.Extensible.Sum import Data.Extensible.Inclusion import Data.Extensible.Internal.Rig+import Data.Hashable import Data.Typeable (Typeable) import Data.Extensible.Wrapper import qualified Data.Extensible.Struct as S@@ -32,7 +33,7 @@  -- | Wrapped Maybe newtype Nullable h x = Nullable { getNullable :: Maybe (h x) }-  deriving (Show, Eq, Ord, Typeable, Generic, NFData, Arbitrary)+  deriving (Show, Eq, Ord, Typeable, Generic, NFData, Arbitrary, Hashable)  instance Wrapper h => Wrapper (Nullable h) where   type Repr (Nullable h) x = Maybe (Repr h x)

@@ -27,6 +27,7 @@   , hfoldMap   , hfoldMapWithIndex   , hfoldrWithIndex+  , hfoldlWithIndex   , htraverse   , htraverseWithIndex   , hsequence@@ -34,6 +35,7 @@   , hfoldMapFor   , hfoldMapWithIndexFor   , hfoldrWithIndexFor+  , hfoldlWithIndexFor   -- * Evaluating   , hforce   -- * Update@@ -134,11 +136,20 @@ hfoldMapWithIndex f = hfoldrWithIndex (\i -> mappend . f i) mempty {-# INLINE hfoldMapWithIndex #-} +hfoldlWithIndex :: (forall x. Membership xs x -> r -> h x -> r) -> r -> h :* xs -> r+hfoldlWithIndex f r xs = hfoldrWithIndex (\i x c a -> c $! f i a x) id xs r+{-# INLINE hfoldlWithIndex #-}+ -- | 'hfoldrWithIndex' with a constraint for each element. hfoldrWithIndexFor :: (Forall c xs) => proxy c   -> (forall x. c x => Membership xs x -> h x -> r -> r) -> r -> h :* xs -> r hfoldrWithIndexFor p f r xs = henumerateFor p xs (\i -> f i (hlookup i xs)) r {-# INLINE hfoldrWithIndexFor #-}++hfoldlWithIndexFor :: (Forall c xs) => proxy c+  -> (forall x. c x => Membership xs x -> r -> h x -> r) -> r -> h :* xs -> r+hfoldlWithIndexFor p f r xs = hfoldrWithIndexFor p (\i x c a -> c $! f i a x) id xs r+{-# INLINE hfoldlWithIndexFor #-}  -- | 'hfoldMapWithIndex' with a constraint for each element. hfoldMapWithIndexFor :: (Forall c xs, Monoid a) => proxy c

@@ -57,8 +57,8 @@  -- | Run a 'TangleT' action and return the result and the calculated values. runTangleT :: Monad m-  => Comp (TangleT h xs m) h :* xs -- ^ tangle matrix-  -> Nullable h :* xs -- ^ pre-calculated values+  => Comp (TangleT h xs m) h :* xs+  -> Nullable h :* xs   -> TangleT h xs m a   -> m (a, Nullable h :* xs) runTangleT tangles rec0 (TangleT m) = (\(a, s, _) -> (a, s))@@ -67,8 +67,8 @@  -- | Run a 'TangleT' action. evalTangleT :: Monad m-  => Comp (TangleT h xs m) h :* xs -- ^ tangle matrix-  -> Nullable h :* xs -- ^ pre-calculated values+  => Comp (TangleT h xs m) h :* xs+  -> Nullable h :* xs   -> TangleT h xs m a   -> m a evalTangleT tangles rec0 (TangleT m) = fst <$> evalRWST m tangles rec0@@ -76,8 +76,8 @@  -- | Run tangles and collect all the results as a 'Record'. runTangles :: Monad m-  => Comp (TangleT h xs m) h :* xs -- ^ tangle matrix-  -> Nullable h :* xs -- ^ pre-calculated values+  => Comp (TangleT h xs m) h :* xs+  -> Nullable h :* xs   -> m (h :* xs) runTangles ts vs = evalTangleT ts vs $ htraverseWithIndex (const . hitchAt) vs {-# INLINE runTangles #-}

@@ -24,6 +24,7 @@ import Data.Profunctor.Unsafe (Profunctor(..)) import Data.Functor.Identity (Identity(..)) import Data.Extensible.Internal.Rig+import Data.Hashable import Data.Semigroup import GHC.Generics (Generic) import Test.QuickCheck.Arbitrary@@ -61,7 +62,7 @@  -- | Poly-kinded composition newtype Comp (f :: j -> *) (g :: i -> j) (a :: i) = Comp { getComp :: f (g a) }-  deriving (Show, Eq, Ord, Typeable, NFData, Generic, Semigroup, Monoid, Arbitrary)+  deriving (Show, Eq, Ord, Typeable, NFData, Generic, Semigroup, Monoid, Arbitrary, Hashable)  deriving instance (Functor f, Functor g) => Functor (Comp f g) deriving instance (Foldable f, Foldable g) => Foldable (Comp f g)@@ -79,7 +80,7 @@  -- | Poly-kinded Const newtype Const' a x = Const' { getConst' :: a }-  deriving (Show, Eq, Ord, Typeable, Generic, NFData, Functor, Foldable, Traversable, Arbitrary)+  deriving (Show, Eq, Ord, Typeable, Generic, NFData, Functor, Foldable, Traversable, Arbitrary, Hashable)  instance Wrapper (Const' a) where   type Repr (Const' a) b = a@@ -96,6 +97,7 @@   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)