extensible 0.8.3 → 0.9.2

raw patch · 11 files changed

Files

• .gitignore +1/−0
• CHANGELOG.md +20/−0
• extensible.cabal +14/−5
• src/Data/Extensible.hs +3/−2
• src/Data/Extensible/Bits.hs +1/−1
• src/Data/Extensible/Dictionary.hs +12/−3
• src/Data/Extensible/Field.hs +13/−30
• src/Data/Extensible/Label.hs +1/−14
• src/Data/Extensible/Nullable.hs +23/−1
• src/Data/Extensible/TH.hs +4/−2
• src/Data/Extensible/Tangle.hs +2/−2

@@ -11,6 +11,7 @@ cabal.config .stack-work .bash_history+dist-newstyle  # ========================= # Operating System Files

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

@@ -1,6 +1,6 @@ cabal-version:       2.4 name:                extensible-version:             0.8.3+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@@ -12,11 +12,11 @@ license-file:        LICENSE author:              Fumiaki Kinoshita maintainer:          Fumiaki Kinoshita <fumiexcel@gmail.com>-copyright:           Copyright (c) 2017-2021 Fumiaki Kinoshita+copyright:           Copyright (c) 2017-2022 Fumiaki Kinoshita category:            Data, Records build-type:          Simple stability:           experimental-Tested-With:         GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.4, GHC == 9.0.1+Tested-With:         GHC == 8.10.7, GHC == 9.0.1, GHC == 9.2.1, GHC == 9.10.1  extra-source-files:   examples/*.hs@@ -31,11 +31,18 @@ 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@@ -73,13 +80,13 @@     , CPP     , NoStarIsType   build-depends:       base >= 4.8 && <5-    , aeson ^>= 2.0+    , aeson >= 1.5 && <2.3     , bytestring     , comonad     , constraints     , deepseq     , ghc-prim-    , hashable+    , hashable >= 1.2 && <1.5     , incremental >= 0.3.1     , membership     , prettyprinter ^>= 1.7@@ -100,6 +107,8 @@   if flag(cassava)     build-depends: cassava     cpp-options: -DCASSAVA+  if flag(IsLabel)+    cpp-options: -DISLABEL   hs-source-dirs:      src   ghc-options: -Wall -Wcompat   default-language:    Haskell2010

@@ -32,7 +32,6 @@   , module Data.Extensible.Dictionary   , module Data.Extensible.Field   , module Data.Extensible.Inclusion-  , module Data.Extensible.Label   , module Data.Extensible.Match   , module Data.Extensible.Nullable   , module Data.Extensible.Product@@ -51,7 +50,9 @@ import Data.Extensible.Dictionary import Data.Extensible.Field import Data.Extensible.Inclusion-import Data.Extensible.Label+#ifdef ISLABEL+import Data.Extensible.Label ()+#endif import Data.Extensible.Match import Data.Extensible.Nullable import Data.Extensible.Product

@@ -138,7 +138,7 @@   fromBits = Const . fromBits   toBits = toBits . getConst -instance (Bits r, FromBits r (h (TargetOf x))) => FromBits r (Field h x) where+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

@@ -3,7 +3,7 @@ {-# LANGUAGE TypeFamilies, ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances, MultiParamTypeClasses #-} {-# LANGUAGE UndecidableSuperClasses #-}-{-# LANGUAGE TypeInType #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE InstanceSigs #-} {-# OPTIONS_GHC -fno-warn-orphans #-}@@ -35,8 +35,13 @@ import Data.Extensible.Nullable import Data.Constraint import Data.Extensible.Struct+import Data.Extensible.Wrapper 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@@ -52,6 +57,7 @@ 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@@ -105,7 +111,7 @@   mappend = (<>)   {-# INLINE mappend #-} -instance WrapForall Hashable h xs => Hashable (xs :& h) 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 #-}@@ -261,7 +267,7 @@   rnf (EmbedAt i h) = views (pieceAt i) (\(Compose Dict) -> rnf h) (library :: xs :& Compose Dict (Instance1 NFData h))   {-# INLINE rnf #-} -instance WrapForall Hashable h xs => Hashable (xs :/ h) where+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))@@ -345,3 +351,6 @@       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))

@@ -4,7 +4,8 @@ {-# LANGUAGE ScopedTypeVariables, TypeFamilies #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE UndecidableSuperClasses, TypeInType #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE PolyKinds #-} ----------------------------------------------------------------------------- -- | -- Module      :  Data.Extensible.Field@@ -22,7 +23,7 @@   , (@:>)   , (@==)   , FieldOptic-  , FieldName+  , xlb   , liftField   , liftField2   -- * Records and variants@@ -43,10 +44,6 @@   , KeyIs   , TargetIs   , KeyTargetAre-  -- * Internal-  , LabelPhantom-  , Labelling-  , Inextensible   ) where import Control.DeepSeq (NFData) import qualified Data.Aeson as J@@ -72,6 +69,7 @@ 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@@ -241,30 +239,15 @@   (Extensible f p t   , ExtensibleConstr t xs (Field h) (k ':> v)   , Lookup xs k v-  , Labelling k p   , Wrapper h)   => Optic' p f (t xs (Field h)) (Repr h v) --- | The trivial inextensible data type-data Inextensible (xs :: [k]) (h :: k -> Type)--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 '[k ':> ()] (Field Proxy)) ()---- | Signifies a field name internally-type family Labelling s p :: Constraint where-  Labelling s (LabelPhantom t) = s ~ t-  Labelling s p = ()---- | 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. --@@ -274,7 +257,7 @@ --   <: #str \@= "foo" --   <: nil -- @-(@=) :: Wrapper h => FieldName k -> Repr h v -> Field h (k ':> v)+(@=) :: Wrapper h => Proxy k -> Repr h v -> Field h (k ':> v) (@=) _ = Field #. review _Wrapper {-# INLINE (@=) #-} infix 1 @=@@ -288,18 +271,18 @@ --   <: #str \<\@=\> getLine --   <: nil -- @-(<@=>) :: (Functor f, Wrapper h) => FieldName k -> f (Repr h v) -> Compose f (Field h) (k ':> v)+(<@=>) :: (Functor f, Wrapper h) => Proxy k -> f (Repr h v) -> Compose f (Field h) (k ':> v) (<@=>) k = comp (k @=) {-# INLINE (<@=>) #-} infix 1 <@=>  -- | Annotate a value by the field name without 'Wrapper'.-(@:>) :: FieldName k -> h v -> Field h (k ':> v)+(@:>) :: Proxy k -> h v -> Field h (k ':> v) (@:>) _ = Field infix 1 @:>  -- | Kind-monomorphic, unwrapped version of '@='-(@==) :: FieldName (k :: Symbol) -> v -> Field Identity (k ':> v)+(@==) :: Proxy (k :: Symbol) -> v -> Field Identity (k ':> v) (@==) = (@=) {-# INLINE (@==) #-} infix 1 @==

@@ -10,26 +10,16 @@ -- -- Experimental API for OverloadedLabels. GHC 8.0+ only ------------------------------------------------------------------------------module Data.Extensible.Label where+module Data.Extensible.Label () where  import Data.Extensible.Class import Data.Extensible.Field-import Data.Extensible.Product (hlookup) import Data.Proxy import GHC.OverloadedLabels-import GHC.Records import Data.Extensible.Wrapper -instance k ~ l => IsLabel k (Proxy l) where-  fromLabel = Proxy---- | Specialised version of 'itemAssoc'. Stands for "eXtensible LaBel"-xlb :: Proxy k -> FieldOptic k-xlb t = itemAssoc t- instance (Extensible f p e   , Lookup xs k v-  , Labelling k p   , Wrapper h   , ExtensibleConstr e xs (Field h) (k ':> v)   , rep ~ Repr h v@@ -39,6 +29,3 @@   )   => IsLabel k (p rep (f rep') -> p s (f t)) where   fromLabel = itemAssoc (Proxy :: Proxy k)--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))

@@ -15,7 +15,10 @@   , retrench   , Nullable(..)   , mapNullable-  , fromNullable) where+  , fromNullable+  , coinclusionAssoc+  , wrenchAssoc+  , retrenchAssoc) where  import Control.DeepSeq (NFData) import Data.Extensible.Class@@ -80,3 +83,22 @@ 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 #-}

@@ -29,8 +29,10 @@ -- @ -- mkField :: String -> DecsQ-mkField str = fmap concat $ forM (words str) $ \s@(x:xs) ->-  let name = mkName $ if isLower x then x : xs else '_' : x : xs+mkField str = fmap concat $ forM (words str) $ \s ->+  let name = mkName $ case s of+        x : xs -> if isLower x then x : xs else '_' : x : xs+        _ -> error "Impossible"   in mkFieldAs name s  -- | @'mkFieldAs' (mkName "foo") "bar"@ defines a field for "bar" as @foo@.

@@ -23,11 +23,11 @@ import Control.Monad.Trans.Class import Data.Functor.Compose import Data.Extensible.Class-import Data.Extensible.Field import Data.Extensible.Product import Data.Extensible.Internal.Rig import Data.Extensible.Nullable import Data.Extensible.Wrapper+import Data.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@@ -46,7 +46,7 @@  -- | 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)-  => FieldName k -> TangleT xs h m (Repr h (k ':> v))+  => Proxy k -> TangleT xs h m (Repr h (k ':> v)) lasso _ = view _Wrapper <$> hitchAt (association :: Membership xs (k ':> v)) {-# INLINE lasso #-}