extensible 0.6 → 0.6.1

raw patch · 13 files changed

+77/−81 lines, 13 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• examples/nullable.hs +20/−0
• extensible.cabal +1/−1
• src/Data/Extensible/Class.hs +3/−2
• src/Data/Extensible/Effect.hs +6/−5
• src/Data/Extensible/Field.hs +2/−2
• src/Data/Extensible/Label.hs +9/−0
• src/Data/Extensible/Nullable.hs +8/−1
• src/Data/Extensible/Plain.hs +1/−1
• src/Data/Extensible/Record.hs +8/−61
• src/Data/Extensible/Struct.hs +2/−1
• src/Data/Extensible/Sum.hs +3/−2
• src/Data/Extensible/Wrapper.hs +6/−5

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

@@ -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}")

@@ -1,5 +1,5 @@ name:                extensible-version:             0.6+version:             0.6.1 synopsis:            Extensible, efficient, optics-friendly data types and effects homepage:            https://github.com/fumieval/extensible bug-reports:         http://github.com/fumieval/extensible/issues

@@ -46,13 +46,14 @@ 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-  type ExtensibleConstr t (xs :: [k]) (h :: k -> *) (x :: k) :: Constraint+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) 

@@ -95,6 +95,7 @@ import Data.Extensible.Internal.Rig import Data.Extensible.Product import Data.Extensible.Class+import Data.Kind (Type) import Data.Functor.Identity import Data.Profunctor.Unsafe -- Trustworthy since 7.8 import Data.Type.Equality@@ -102,7 +103,7 @@  -- | A unit of named effects. This is a variant of @(':|')@ specialised for -- 'Type -> Type'.-data Instruction (xs :: [Assoc k (* -> *)]) a where+data Instruction (xs :: [Assoc k (Type -> Type)]) a where   Instruction :: !(Membership xs kv) -> TargetOf kv a -> Instruction xs a  -- | The extensible operational monad@@ -208,12 +209,12 @@   Return a -> Return a  -- | Anonymous representation of instructions.-data Action (args :: [*]) a r where+data Action (args :: [Type]) a r where   AResult :: Action '[] a a   AArgument :: x -> Action xs a r -> Action (x ': xs) a r  -- | @'Function' [a, b, c] r@ is @a -> b -> c -> r@-type family Function args r :: * where+type family Function args r :: Type where   Function '[] r = r   Function (x ': xs) r = x -> Function xs r @@ -440,8 +441,8 @@ {-# INLINE tickEff #-}  mapHeadEff :: (forall x. s x -> t x) -> Eff ((k >: s) ': xs) a -> Eff ((k' >: t) ': xs) a-mapHeadEff f = hoistSkeleton $ \(Instruction i t) -> testMembership i -  (\Refl -> Instruction leadership $ f t) +mapHeadEff f = hoistSkeleton $ \(Instruction i t) -> testMembership i+  (\Refl -> Instruction leadership $ f t)   (\j -> Instruction (nextMembership j) t)  -- | Take a function and applies it to an Either effect iff the effect takes the form Left _.

@@ -238,8 +238,8 @@ -- 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.

@@ -14,8 +14,10 @@  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@@ -29,6 +31,10 @@ 訊 :: Proxy k -> FieldOptic k 訊 = itemAssoc +-- | Specialised version of 'itemAssoc'. Stands for "eXtensible LaBel"+xlb :: Proxy k -> FieldOptic k+xlb = itemAssoc+ instance (Extensible f p e   , Lookup xs k v   , Labelling k p@@ -45,3 +51,6 @@ #else   fromLabel _ = itemAssoc (Proxy :: Proxy k) #endif++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))

@@ -14,7 +14,8 @@   , wrench   , retrench   , Nullable(..)-  , mapNullable) where+  , mapNullable+  , fromNullable) where  import Control.DeepSeq (NFData) import Data.Extensible.Class@@ -27,6 +28,7 @@ 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 Language.Haskell.TH (appE, conE)@@ -77,3 +79,8 @@ 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 #-}

@@ -33,7 +33,7 @@ -- | Alias for plain sums 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 (<%) #-}

@@ -13,13 +13,13 @@ -- -- Bidirectional conversion from/to records -------------------------------------------------------------------------module Data.Extensible.Record (IsRecord(..), toRecord, fromRecord, record, deriveIsRecord) where+module Data.Extensible.Record (IsRecord(..), toRecord, fromRecord, record) where -import Language.Haskell.TH import Data.Extensible.Internal.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@@ -28,15 +28,17 @@  -- | The class of types that can be converted to/from a 'Record'. class IsRecord a where-  type RecFields a :: [Assoc Symbol *]+  type RecFields a :: [Assoc Symbol Type]   recordFromList :: HList (Field Identity) (RecFields a) -> a   recordToList :: a -> HList (Field Identity) (RecFields a)    type RecFields a = GRecFields (Rep a) '[]-  default recordFromList :: (Generic a, GIsRecord (Rep a) '[], GRecFields (Rep a) '[] ~ RecFields a) => HList (Field Identity) (RecFields a) -> a+  default recordFromList :: (Generic a, GIsRecord (Rep a) '[], GRecFields (Rep a) '[] ~ RecFields a)+    => HList (Field Identity) (RecFields a) -> a   recordFromList xs = recordFromList' xs (\x (HNil :: HList (Field Identity) '[]) -> to x) -  default recordToList :: (Generic a, GIsRecord (Rep a) '[], GRecFields (Rep a) '[] ~ RecFields a) => a -> HList (Field Identity) (RecFields a)+  default recordToList :: (Generic a, GIsRecord (Rep a) '[], GRecFields (Rep a) '[] ~ RecFields a)+    => a -> HList (Field Identity) (RecFields a)   recordToList x = recordToList' (from x) HNil  instance IsRecord () where@@ -46,7 +48,7 @@  -- | The class of types that can be converted to/from a 'Record'. class GIsRecord f r where-  type GRecFields f (r :: [Assoc Symbol *]) :: [Assoc Symbol *]+  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) @@ -93,58 +95,3 @@   => Optic' p f a (Record (RecFields a)) record = dimap toRecord (fmap fromRecord) {-# INLINE record #-}--tvName :: TyVarBndr -> Name-tvName (PlainTV n) = n-tvName (KindedTV n _) = n--{-# DEPRECATED deriveIsRecord "Use the generic default methods instead" #-}--- | Create an 'IsRecord' instance for a normal record declaration.-deriveIsRecord :: Name -> DecsQ-deriveIsRecord name = reify name >>= \case-#if MIN_VERSION_template_haskell(2,11,0)-  TyConI (DataD _ _ vars _ [RecC cName vst] _) -> do-#else-  TyConI (DataD _ _ vars [RecC cName vst] _) -> do-#endif-    let names = [x | (x, _, _) <- vst]-    newNames <- traverse (newName . nameBase) names-    let tvmap = [(tvName tv, VarT (mkName $ "p" ++ show i)) | (i, tv) <- zip [0 :: Int ..] vars]-    let ty = foldl AppT (ConT name) $ map snd tvmap-    let refineTV (VarT t) | Just t' <- lookup t tvmap = t'-        refineTV (AppT a b) = refineTV a `AppT` refineTV b-        refineTV t = t-    return-#if MIN_VERSION_template_haskell(2,11,0)-      [InstanceD Nothing [] (ConT ''IsRecord `AppT` ty)-#else-      [InstanceD [] (ConT ''IsRecord `AppT` ty)-#endif-        [ TySynInstD ''RecFields $ TySynEqn [ty] $ foldr-            (\(v, _, t) r -> PromotedConsT `AppT` (PromotedT '(:>) `AppT` LitT (StrTyLit $ nameBase v) `AppT` refineTV t) `AppT` r)-            PromotedNilT-            vst-        , FunD 'recordFromList [Clause-            [shape2Pat $ fmap (\x -> ConP 'Field [ConP 'Identity [VarP x]]) newNames]-            (NormalB $ RecConE cName [(n, VarE n') | (n, n') <- zip names newNames])-            []-            ]-        , FunD 'recordToList [Clause-            [ConP cName (map VarP newNames)]-            (NormalB $ shape2Exp [AppE (ConE 'Field)-                $ AppE (ConE 'Identity)-                $ VarE n-              | n <- newNames])-            []-            ]-        ]-      ]-  info -> fail $ "deriveIsRecord: Unsupported " ++ show info--shape2Pat :: [Pat] -> Pat-shape2Pat [] = ConP 'HNil []-shape2Pat (x : xs) = ConP 'HCons [x, shape2Pat xs]--shape2Exp :: [Exp] -> Exp-shape2Exp [] = ConE 'HNil-shape2Exp (x : xs) = ConE 'HCons `AppE` x `AppE` shape2Exp xs

@@ -59,12 +59,13 @@ 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  -- | Mutable type-indexed struct.-data Struct s (h :: k -> *) (xs :: [k]) = Struct (SmallMutableArray# s Any)+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 ()

@@ -25,6 +25,7 @@   ) where  import Data.Extensible.Class+import Data.Kind (Type) import Data.Profunctor import Data.Proxy import Data.Type.Equality@@ -32,9 +33,9 @@  -- | The extensible sum type ----- @(:|) :: (k -> *) -> [k] -> *@+-- @(:/) :: [k] -> (k -> Type) -> Type@ ---data (xs :: [k]) :/ (h :: k -> *) where+data (xs :: [k]) :/ (h :: k -> Type) where   EmbedAt :: !(Membership xs x) -> h x -> xs :/ h  type h :| xs = xs :/ h

@@ -26,6 +26,7 @@ import Data.Functor.Identity (Identity(..)) import Data.Extensible.Internal.Rig import Data.Hashable+import Data.Kind (Type) import Data.Text.Prettyprint.Doc import GHC.Generics (Generic) import Language.Haskell.TH.Lift@@ -33,11 +34,11 @@ import Test.QuickCheck.Arbitrary  --- | The extensible data types should take @k -> *@ as a parameter.+-- | The extensible data types should take @k -> Type@ as a parameter. -- This class allows us to take a shortcut for direct representation.-class Wrapper (h :: k -> *) where-  -- | @'Repr' h v@ is the actual representation of @h v@.-  type Repr h (v :: k) :: *+class Wrapper (h :: k -> Type) where+  -- | @'Repr' h v@ is the user-facing representation of @h v@.+  type Repr h (v :: k) :: Type    -- | This is an isomorphism between @h v@ and @'Repr' h v@.   --@@ -83,7 +84,7 @@   _Wrapper = id  -- | Poly-kinded composition-newtype Comp (f :: j -> *) (g :: i -> j) (a :: i) = Comp { getComp :: f (g a) }+newtype Comp (f :: j -> Type) (g :: i -> j) (a :: i) = Comp { getComp :: f (g a) }   deriving (Show, Eq, Ord, Typeable, NFData, Generic, Semigroup, Monoid, Arbitrary, Hashable, Pretty)  deriving instance (Functor f, Functor g) => Functor (Comp f g)