mu-optics 0.2.0.0 → 0.3.0.0

raw patch · 2 files changed

+90/−104 lines, 2 filesdep ~mu-schemaPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: mu-schema

API changes (from Hackage documentation)

Files

• mu-optics.cabal +2/−5
• src/Mu/Schema/Optics.hs +88/−99

@@ -1,5 +1,5 @@ name:          mu-optics-version:       0.2.0.0+version:       0.3.0.0 synopsis:      Optics for @mu-schema@ terms description:   With @mu-schema@ you can describe schemas using type-level constructs, and derive serializers from those. This package provides convenient access using @optics@.@@ -21,13 +21,10 @@  library   exposed-modules:  Mu.Schema.Optics--  -- other-modules:-  -- other-extensions:   build-depends:       base         >=4.12  && <5     , containers-    , mu-schema    >=0.2.0+    , mu-schema    >=0.3.0     , optics-core     , sop-core 

@@ -1,5 +1,6 @@ {-# language AllowAmbiguousTypes    #-} {-# language DataKinds              #-}+{-# language FlexibleContexts       #-} {-# language FlexibleInstances      #-} {-# language FunctionalDependencies #-} {-# language GADTs                  #-}@@ -36,96 +37,64 @@ , _U0, _Next, _U1, _U2, _U3   -- * Re-exported for convenience. , module Optics.Core+  -- * Additional utilities.+, is ) where -import           Data.Functor.Identity import           Data.Kind import           Data.Map+import           Data.Maybe   (isJust) import           Data.Proxy import           GHC.TypeLits import           Optics.Core  import           Mu.Schema -instance {-# OVERLAPS #-}-         (FieldLabel Identity sch args fieldName r)+instance (FieldLabel sch args fieldName r)          => LabelOptic fieldName A_Lens-                       (Term Identity sch ('DRecord name args))-                       (Term Identity sch ('DRecord name args))+                       (Term sch ('DRecord name args))+                       (Term sch ('DRecord name args))                        r r where-  labelOptic = lens (\(TRecord r) -> runIdentity $ fieldLensGet (Proxy @fieldName) r)-                    (\(TRecord r) x -> TRecord $ fieldLensSet (Proxy @fieldName) r (Identity x))--instance {-# OVERLAPPABLE #-}-         (FieldLabel w sch args fieldName r, t ~ w r)-         => LabelOptic fieldName A_Lens-                       (Term w sch ('DRecord name args))-                       (Term w sch ('DRecord name args))-                       t t where   labelOptic = lens (\(TRecord r) -> fieldLensGet (Proxy @fieldName) r)                     (\(TRecord r) x -> TRecord $ fieldLensSet (Proxy @fieldName) r x) -record :: BuildRecord w sch args r => r -> Term w sch ('DRecord name args)+-- | Build a Mu record 'Term' from a tuple of its values.+--+--   Note: if the record has exactly _one_ field,+--   you must use 'record1' instead.+record :: BuildRecord sch args r => r -> Term sch ('DRecord name args) record values = TRecord $ buildR values -record1 :: BuildRecord1 w sch arg r => r -> Term w sch ('DRecord name '[arg])-record1 value = TRecord $ buildR1 value--class BuildRecord1 (w :: Type -> Type)-                   (sch :: Schema Symbol Symbol)-                   (arg :: FieldDef Symbol Symbol)-                   (r :: Type) | w sch arg -> r where-  buildR1 :: r -> NP (Field w sch) '[arg]--instance {-# OVERLAPPABLE #-} (Functor w, TypeLabel w sch t1 r1)-         => BuildRecord1 w sch ('FieldDef x1 t1) (w r1) where-  buildR1 v = Field (typeLensSet <$> v) :* Nil--instance {-# OVERLAPS #-} (TypeLabel Identity sch t1 r1)-         => BuildRecord1 Identity sch ('FieldDef x1 t1) r1 where-  buildR1 v = Field (typeLensSet <$> Identity v) :* Nil+-- | Build a Mu record 'Term' with exactly one field.+record1 :: TypeLabel sch t1 r1 => r1 -> Term sch ('DRecord name '[ 'FieldDef x1 t1 ])+record1 value = TRecord $ Field (typeLensSet value) :* Nil -class BuildRecord (w :: Type -> Type)-                  (sch :: Schema Symbol Symbol)+class BuildRecord (sch :: Schema Symbol Symbol)                   (args :: [FieldDef Symbol Symbol])-                  (r :: Type) | w sch args -> r where-  buildR :: r -> NP (Field w sch) args+                  (r :: Type) | sch args -> r where+  buildR :: r -> NP (Field sch) args -instance BuildRecord w sch '[] () where+instance BuildRecord sch '[] () where   buildR _ = Nil -instance {-# OVERLAPPABLE #-} (Functor w, TypeLabel w sch t1 r1, TypeLabel w sch t2 r2)-         => BuildRecord w sch '[ 'FieldDef x1 t1, 'FieldDef x2 t2 ] (w r1, w r2) where-  buildR (v1, v2) = Field (typeLensSet <$> v1)-                  :* Field (typeLensSet <$> v2) :* Nil--instance {-# OVERLAPS #-} (TypeLabel Identity sch t1 r1, TypeLabel Identity sch t2 r2)-         => BuildRecord Identity sch '[ 'FieldDef x1 t1, 'FieldDef x2 t2 ] (r1, r2) where-  buildR (v1, v2) = Field (typeLensSet <$> Identity v1)-                  :* Field (typeLensSet <$> Identity v2) :* Nil--instance {-# OVERLAPPABLE #-} (Functor w, TypeLabel w sch t1 r1, TypeLabel w sch t2 r2, TypeLabel w sch t3 r3)-         => BuildRecord w sch-                        '[ 'FieldDef x1 t1, 'FieldDef x2 t2, 'FieldDef x3 t3 ]-                        (w r1, w r2, w r3) where-  buildR (v1, v2, v3) = Field (typeLensSet <$> v1)-                      :* Field (typeLensSet <$> v2)-                      :* Field (typeLensSet <$> v3) :* Nil+instance  (TypeLabel sch t1 r1, TypeLabel sch t2 r2)+         => BuildRecord sch '[ 'FieldDef x1 t1, 'FieldDef x2 t2 ] (r1, r2) where+  buildR (v1, v2) = Field (typeLensSet v1)+                  :* Field (typeLensSet v2) :* Nil -instance {-# OVERLAPS #-} (TypeLabel Identity sch t1 r1, TypeLabel Identity sch t2 r2, TypeLabel Identity sch t3 r3)-         => BuildRecord Identity sch+instance (TypeLabel sch t1 r1, TypeLabel sch t2 r2, TypeLabel sch t3 r3)+         => BuildRecord sch                         '[ 'FieldDef x1 t1, 'FieldDef x2 t2, 'FieldDef x3 t3 ] (r1, r2, r3) where-  buildR (v1, v2, v3) = Field (typeLensSet <$> Identity v1)-                      :* Field (typeLensSet <$> Identity v2)-                      :* Field (typeLensSet <$> Identity v3) :* Nil+  buildR (v1, v2, v3) = Field (typeLensSet v1)+                      :* Field (typeLensSet v2)+                      :* Field (typeLensSet v3) :* Nil -class FieldLabel (w :: Type -> Type)-                 (sch :: Schema Symbol Symbol)+class FieldLabel (sch :: Schema Symbol Symbol)                  (args :: [FieldDef Symbol Symbol])                  (fieldName :: Symbol) (r :: Type)-                 | w sch args fieldName -> r where-  fieldLensGet :: Proxy fieldName -> NP (Field w sch) args -> w r-  fieldLensSet :: Proxy fieldName -> NP (Field w sch) args -> w r -> NP (Field w sch) args+                 | sch args fieldName -> r where+  fieldLensGet :: Proxy fieldName -> NP (Field sch) args -> r+  fieldLensSet :: Proxy fieldName -> NP (Field sch) args -> r -> NP (Field sch) args  {- Removed due to FunDeps instance TypeError ('Text "cannot find field " ':<>: 'ShowType f)@@ -133,58 +102,68 @@   fieldLensGet = error "this should never be run"   fieldLensSet = error "this should never be run" -}-instance {-# OVERLAPS #-} (Functor w, TypeLabel w sch t r)-         => FieldLabel w sch ('FieldDef f t ': rest) f r where-  fieldLensGet _ (Field x :* _) = typeLensGet <$> x-  fieldLensSet _ (_ :* r) new = Field (typeLensSet <$> new) :* r-instance {-# OVERLAPPABLE #-} FieldLabel w sch rest g t-         => FieldLabel w sch (f ': rest) g t where+instance {-# OVERLAPS #-} (TypeLabel sch t r)+         => FieldLabel sch ('FieldDef f t ': rest) f r where+  fieldLensGet _ (Field x :* _) = typeLensGet x+  fieldLensSet _ (_ :* r) new = Field (typeLensSet new) :* r+instance {-# OVERLAPPABLE #-} FieldLabel sch rest g t+         => FieldLabel sch (f ': rest) g t where   fieldLensGet p (_ :* r) = fieldLensGet p r   fieldLensSet p (x :* r) new = x :* fieldLensSet p r new -class TypeLabel w (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) (r :: Type)-      | w sch t -> r where-  typeLensGet :: FieldValue w sch t -> r-  typeLensSet :: r -> FieldValue w sch t+class TypeLabel (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) (r :: Type)+      | sch t -> r where+  typeLensGet :: FieldValue sch t -> r+  typeLensSet :: r -> FieldValue sch t -instance TypeLabel w sch ('TPrimitive t) t where+instance TypeLabel sch ('TPrimitive t) t where   typeLensGet (FPrimitive x) = x   typeLensSet = FPrimitive -instance (r ~ (sch :/: t)) => TypeLabel w sch ('TSchematic t) (Term w sch r) where+instance (r ~ (sch :/: t)) => TypeLabel sch ('TSchematic t) (Term sch r) where   typeLensGet (FSchematic x) = x   typeLensSet = FSchematic -instance (TypeLabel w sch o r', r ~ Maybe r')-         => TypeLabel w sch ('TOption o) r where+instance (TypeLabel sch o r', r ~ Maybe r')+         => TypeLabel sch ('TOption o) r where   typeLensGet (FOption x) = typeLensGet <$> x   typeLensSet new = FOption (typeLensSet <$> new) -instance (TypeLabel w sch o r', r ~ [r'])-         => TypeLabel w sch ('TList o) r where+instance (TypeLabel sch o r', r ~ [r'])+         => TypeLabel sch ('TList o) r where   typeLensGet (FList x) = typeLensGet <$> x   typeLensSet new = FList (typeLensSet <$> new) -instance ( TypeLabel w sch k k', TypeLabel w sch v v'-         , r ~ Map k' v', Ord k', Ord (FieldValue w sch k) )-         => TypeLabel w sch ('TMap k v) r where+instance ( TypeLabel sch k k', TypeLabel sch v v'+         , r ~ Map k' v', Ord k', Ord (FieldValue sch k) )+         => TypeLabel sch ('TMap k v) r where   typeLensGet (FMap x) = mapKeys typeLensGet (typeLensGet <$> x)   typeLensSet new = FMap (mapKeys typeLensSet (typeLensSet <$> new)) -instance (r ~ NS (FieldValue w sch) choices)-         => TypeLabel w sch ('TUnion choices) r where+instance (r ~ NS (FieldValue sch) choices)+         => TypeLabel sch ('TUnion choices) r where   typeLensGet (FUnion x) = x   typeLensSet = FUnion -enum :: forall (choiceName :: Symbol) choices w sch name.+-- | Build a Mu enumeration 'Term' from the name of the choice.+enum :: forall (choiceName :: Symbol) choices sch name.         EnumLabel choices choiceName-     => Term w sch ('DEnum name choices)+     => Term sch ('DEnum name choices) enum = TEnum $ enumPrismBuild (Proxy @choiceName) +-- Useful utility to check whether a value+-- matches a given enumeration choice.+--+-- > f e | e `is` #sunny = ...+-- >     | e `is` #rainy = ...+is :: Is k An_AffineFold => s -> Optic' k is s a -> Bool+is s k = isJust (preview k s)+{-# INLINE is #-}+ instance (EnumLabel choices choiceName, r ~ ())          => LabelOptic choiceName A_Prism-                       (Term w sch ('DEnum name choices))-                       (Term w sch ('DEnum name choices))+                       (Term sch ('DEnum name choices))+                       (Term sch ('DEnum name choices))                        r r where   labelOptic = prism' (\_ -> TEnum $ enumPrismBuild (Proxy @choiceName))                      (\(TEnum r) -> enumPrismMatch (Proxy @choiceName) r)@@ -208,27 +187,37 @@   enumPrismMatch _ (Z _) = Nothing   enumPrismMatch p (S x) = enumPrismMatch p x -_U0 :: forall w (sch :: Schema') x xs r. TypeLabel w sch x r-    => Prism' (NS (FieldValue w sch) (x ': xs)) r+-- | Prism to access the first choice of a union.+_U0 :: forall (sch :: Schema') x xs r. TypeLabel sch x r+    => Prism' (NS (FieldValue sch) (x ': xs)) r _U0 = prism' (Z . typeLensSet)              (\case (Z x) -> Just $ typeLensGet x                     (S _) -> Nothing) -_Next :: forall w (sch :: Schema') x xs.-         Prism' (NS (FieldValue w sch) (x ': xs))-                (NS (FieldValue w sch) xs)+-- | Prism to access all other choices of a union+--   except for the first. Intended to use be used+--   iteratively until you reach the desired choice+--   with '_U0'.+--+--   > _Next % _Next % _U0  -- access third choice+_Next :: forall (sch :: Schema') x xs.+         Prism' (NS (FieldValue sch) (x ': xs))+                (NS (FieldValue sch) xs) _Next = prism' S                (\case (Z _) -> Nothing                       (S x) -> Just x) -_U1 :: forall w (sch :: Schema') a b xs r. TypeLabel w sch b r-    => Prism' (NS (FieldValue w sch) (a ': b ': xs)) r+-- | Prism to access the second choice of a union.+_U1 :: forall (sch :: Schema') a b xs r. TypeLabel sch b r+    => Prism' (NS (FieldValue sch) (a ': b ': xs)) r _U1 = _Next % _U0 -_U2 :: forall w (sch :: Schema') a b c xs r. TypeLabel w sch c r-    => Prism' (NS (FieldValue w sch) (a ': b ': c ': xs)) r+-- | Prism to access the third choice of a union.+_U2 :: forall (sch :: Schema') a b c xs r. TypeLabel sch c r+    => Prism' (NS (FieldValue sch) (a ': b ': c ': xs)) r _U2 = _Next % _U1 -_U3 :: forall w (sch :: Schema') a b c d xs r. TypeLabel w sch d r-    => Prism' (NS (FieldValue w sch) (a ': b ': c ': d ': xs)) r+-- | Prism to access the fourth choice of a union.+_U3 :: forall (sch :: Schema') a b c d xs r. TypeLabel sch d r+    => Prism' (NS (FieldValue sch) (a ': b ': c ': d ': xs)) r _U3 = _Next % _U2