pro-abstract 0.2.0.0 → 0.2.1.0

raw patch · 15 files changed

+270/−34 lines, 15 filesdep +hedgehog-opticsPVP ok

version bump matches the API change (PVP)

Dependencies added: hedgehog-optics

API changes (from Hackage documentation)

Files

• changelog.txt +3/−0
• library/pro-abstract-prelude/Containers.hs +25/−1
• library/pro-abstract-prelude/Prelude.hs +4/−2
• library/pro-abstract/ProAbstract.hs +4/−0
• library/pro-abstract/ProAbstract/Datatypes.hs +1/−1
• library/pro-abstract/ProAbstract/Metadata.hs +3/−0
• library/pro-abstract/ProAbstract/Metadata/HasMetadataOptics.hs +10/−3
• library/pro-abstract/ProAbstract/Metadata/MetaItem.hs +33/−0
• library/pro-abstract/ProAbstract/Metadata/MetaList.hs +17/−0
• library/pro-abstract/ProAbstract/Metadata/MetaValue.hs +84/−0
• library/pro-abstract/ProAbstract/Metadata/MetadataOptics.hs +14/−3
• library/pro-abstract/ProAbstract/Optics.hs +14/−22
• library/pro-abstract/ProAbstract/Types.hs +2/−0
• pro-abstract.cabal +5/−1
• test-suite/test-pro-abstract/Main.hs +51/−1

@@ -18,3 +18,6 @@ v0.2.0.0 - Remove:     - prism 'blockTag' -- use 'tagged' instead     - prism 'paragraph' -- use 'bare' instead++v0.2.1.0 - Add:+    MetaItem, MetaValue, metaMap, metaList

@@ -1,6 +1,6 @@ module Containers where -import BasePrelude (Applicative, Bool, Foldable, Maybe (..), Ord, Semigroup, maybe, pure, (.), (<*>), (<>))+import BasePrelude (Applicative, Bool, Either, Foldable, Maybe (..), Monoid, Ord, Semigroup, maybe, pure, (.), (<*>), (<>)) import Data.Foldable (fold, toList) import Data.Function (fix, id) import Optics.Core (Prism', prism')@@ -24,6 +24,30 @@  mapInsert :: Ord k => k -> a -> Map k a -> Map k a mapInsert = Map.insert++mapFromSet :: (k -> a) -> Set k -> Map k a+mapFromSet = Map.fromSet++mapMapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c)+mapMapEither = Map.mapEither++mapMapMaybe :: (a -> Maybe b) -> Map k a -> Map k b+mapMapMaybe = Map.mapMaybe++mapKeysSet :: Map k a -> Set k+mapKeysSet = Map.keysSet++mapUnionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a+mapUnionWith = Map.unionWith++mapFilter :: (a -> Bool) -> Map k a -> Map k a+mapFilter = Map.filter++mapToList :: Map k a -> [(k, a)]+mapToList = Map.toAscList++mapFoldMapWithKey :: Monoid m => (k -> a -> m) -> Map k a -> m+mapFoldMapWithKey = Map.foldMapWithKey  setMember :: Ord a => a -> Set a -> Bool setMember = Set.member

@@ -1,6 +1,8 @@ module Prelude (module X) where +import Control.Applicative as X ((<|>)) import Control.DeepSeq as X (NFData)+import Data.Function as X (on) import Data.Functor as X ((<&>)) import Data.Functor.Identity as X (Identity (Identity), runIdentity) import Data.Hashable as X (Hashable)@@ -15,7 +17,7 @@  import Containers as X -import BasePrelude as X (Applicative, Bool (..), Either (..), Eq, Foldable, Functor, Maybe (..), Monad, Monoid (mempty), Ord, Semigroup (..), Show, Traversable, const, either, fmap, maybe, not, pure, traverse, ($), (.), (<$>), (<*>), (=<<), (>>=))+import BasePrelude as X (Applicative, Bool (..), Either (..), Eq ((==)), Foldable, Functor, Maybe (..), Monad, Monoid (mempty), Ord (compare), Ordering (EQ), Semigroup (..), Show, Traversable, const, either, fmap, maybe, not, pure, traverse, ($), (&&), (.), (<$>), (<*>), (=<<), (>>=), (||)) -import Optics.Core as X (A_Fold, A_Getter, A_Lens, A_Traversal, AffineFold, AffineTraversal, AffineTraversal', An_AffineFold, An_AffineTraversal, An_Iso, Is, Iso, Iso', JoinKinds, Lens, Lens', NoIx, Optic, Optic', OpticKind, Prism', Traversal, Traversal', _Just, _Left, _Right, adjoin, afailing, afolding, atraversal, castOptic, coerced, equality, iso, lens, matching, over, preview, prism', re, review, set, simple, to, traversalVL, traverseOf, traversed, view, (%))+import Optics.Core as X (A_Fold, A_Getter, A_Lens, A_Traversal, AffineFold, AffineTraversal, AffineTraversal', An_AffineFold, An_AffineTraversal, An_Iso, Getter, Is, Iso, Iso', JoinKinds, Lens, Lens', NoIx, Optic, Optic', OpticKind, Prism', Traversal, Traversal', _1, _2, _Just, _Left, _Right, adjoin, afailing, afolding, atraversal, castOptic, coerced, equality, iso, lens, matching, over, preview, prism', re, review, set, simple, to, traversalVL, traverseOf, traversed, view, (%)) import Optics.Empty.Core as X (_Empty, pattern Empty)

@@ -125,6 +125,8 @@ - 'metadata' targets the metadata of a node; it is either a lens or an affine traversal, depending on the node type. - 'atSetting' and 'hasProperty' target specific parts of metadata by name. - The 'allMetadata' traversal targets every metadata at and under a node.+- 'metaMap' gives properties and settings combined into a single 'Map' 'Text' 'MetaValue'+- 'metaList' gives properties and settings combined into a list of 'MetaItem'   === Content@@ -254,6 +256,8 @@     {- * Metadata -} Metadata (..), HasMetadata (..), HasManyMetadata (..),     {- ** Properties -} properties, hasProperty,     {- ** Settings -} settings, atSetting,+    {- ** Item list -} MetaItem (..), metaList,+    {- ** Value map -} MetaValue (..), metaMap,      {- * Content -} Content, HasContent (..), HasContent',     {- ** Contents -} Contents, HasContents (..), HasContents',

@@ -19,7 +19,7 @@     , Fragment (..), PlainBlock (..)      -- * Metadata-    , Metadata (..)+    , Metadata (..), MetaItem (..), MetaValue (..)      ) where 

@@ -1,9 +1,12 @@ module ProAbstract.Metadata   ( Metadata (..), HasMetadata (..), HasManyMetadata (..)   , properties, settings, hasProperty, atSetting+  , MetaItem (..), MetaValue (..), metaMap, metaList   ) where  import ProAbstract.Metadata.HasManyMetadata import ProAbstract.Metadata.HasMetadata import ProAbstract.Metadata.HasMetadataOptics+import ProAbstract.Metadata.MetaItem+import ProAbstract.Metadata.MetaValue import ProAbstract.Metadata.MetadataType

@@ -1,9 +1,10 @@-module ProAbstract.Metadata.HasMetadataOptics-    ( properties, settings, hasProperty, atSetting-    ) where+module ProAbstract.Metadata.HasMetadataOptics where  import ProAbstract.Metadata.HasMetadata+import ProAbstract.Metadata.MetaItem+import ProAbstract.Metadata.MetaValue +import qualified ProAbstract.Metadata.MetaList as Meta import qualified ProAbstract.Metadata.MetadataOptics as Meta  -- | Fetch all properties from items which contain metadata.@@ -21,3 +22,9 @@ -- | Select a setting from an item attached to metadata. Returns 'Nothing' if no value is set. atSetting :: (HasMetadata m, JoinKinds (MetadataOpticKind m) A_Lens k) => Text -> Optic' k NoIx m (Maybe Text) atSetting k = metadata % Meta.atSetting k++metaMap :: (HasMetadata m, JoinKinds (MetadataOpticKind m) An_Iso k) => Optic' k NoIx m (Map Text MetaValue)+metaMap = metadata % Meta.metaMap++metaList :: (HasMetadata m, Is (MetadataOpticKind m) An_AffineFold) => Getter m [MetaItem]+metaList = to $ maybe [] (view Meta.metaList) . preview metadata

@@ -0,0 +1,33 @@+module ProAbstract.Metadata.MetaItem where++data MetaItem =+    Property+        Text -- ^ key+  | Setting+        Text -- ^ key+        Text -- ^ value+    deriving stock (Show, Generic)+    deriving anyclass (NFData, Hashable)++instance Ord MetaItem where+    compare = compare `on` \case+        Property x -> (x, Nothing)+        Setting x y -> (x, Just y)++instance Eq MetaItem where+    a == b = EQ == compare a b++metaKeyValue :: Iso' MetaItem (Text, Maybe Text)+metaKeyValue = iso f g+  where+    f = \case Property x -> (x, Nothing); Setting x y -> (x, Just y)+    g = \case (x, Nothing) -> Property x; (x, Just y) -> Setting x y++metaKey :: Lens' MetaItem Text+metaKey = metaKeyValue % _1++metaValueMaybe :: Lens' MetaItem (Maybe Text)+metaValueMaybe = metaKeyValue % _2++metaValue :: AffineTraversal' MetaItem Text+metaValue = metaValueMaybe % _Just

@@ -0,0 +1,17 @@+module ProAbstract.Metadata.MetaList+    ( metaList+    ) where++import ProAbstract.Metadata.MetaItem+import ProAbstract.Metadata.MetaValue+import ProAbstract.Metadata.MetadataOptics+import ProAbstract.Metadata.MetadataType++metaList :: Getter Metadata [MetaItem]+metaList = metaMap % to (mapFoldMapWithKey metaValueList)++metaValueList :: Text -> MetaValue -> [MetaItem]+metaValueList k = \case+    MetaValue_Property -> [ Property k ]+    MetaValue_Setting v -> [ Setting k v ]+    MetaValue_PropertyAndSetting v -> [ Property k, Setting k v ]

@@ -0,0 +1,84 @@+module ProAbstract.Metadata.MetaValue+    ( MetaValueMaybe (..), MetaValue (..)+    , IsMetaValue (..)+    , isPropertyValue, settingValueMaybe+    , metaValueJust+    ) where++class IsMetaValue a where+    metaValue :: Prism' MetaValueMaybe a+    propertyValue :: a+    settingValue :: Text -> a++instance IsMetaValue MetaValueMaybe where+    metaValue = castOptic simple+    propertyValue = MetaValueMaybe True Nothing+    settingValue s = MetaValueMaybe False (Just s)++instance IsMetaValue MetaValue where+    metaValue = metaValueJust+    propertyValue = MetaValue_Property+    settingValue = MetaValue_Setting++isPropertyValue :: IsMetaValue a => a -> Bool+isPropertyValue = view $ re metaValue % to metaValueMaybe_property++settingValueMaybe :: IsMetaValue a => a -> Maybe Text+settingValueMaybe = view $ re metaValue % to metaValueMaybe_setting++data MetaValueMaybe =+  MetaValueMaybe+    { metaValueMaybe_property :: Bool+    , metaValueMaybe_setting :: Maybe Text+    }+    deriving stock (Eq, Ord, Show, Generic)+    deriving anyclass (NFData, Hashable)++instance Semigroup MetaValueMaybe where+    MetaValueMaybe p1 s1 <> MetaValueMaybe p2 s2 =+        MetaValueMaybe (p1 || p2) (s1 <|> s2)++instance Monoid MetaValueMaybe where+    mempty = MetaValueMaybe False Nothing++data MetaValue =+    MetaValue_Property+  | MetaValue_Setting+        Text -- ^ setting value+  | MetaValue_PropertyAndSetting+        Text -- ^ setting value+    deriving stock (Eq, Ord, Show, Generic)+    deriving anyclass (NFData, Hashable)++instance Semigroup MetaValue where++    x@MetaValue_PropertyAndSetting{} <> _ = x++    MetaValue_Property <> x = forceProperty x+    x <> MetaValue_Property = forceProperty x++    MetaValue_Setting s <> x = forceSetting s x++forceProperty :: MetaValue -> MetaValue+forceProperty = \case+    MetaValue_Setting s -> MetaValue_PropertyAndSetting s+    x -> x++forceSetting :: Text -> MetaValue -> MetaValue+forceSetting s = \case+    MetaValue_Setting _            -> MetaValue_Setting s+    MetaValue_Property             -> MetaValue_PropertyAndSetting s+    MetaValue_PropertyAndSetting _ -> MetaValue_PropertyAndSetting s++metaValueJust :: Prism' MetaValueMaybe MetaValue+metaValueJust = prism' f g+  where+    f = \case+        MetaValue_Property -> MetaValueMaybe True Nothing+        MetaValue_Setting s -> MetaValueMaybe False (Just s)+        MetaValue_PropertyAndSetting s -> MetaValueMaybe True (Just s)+    g = \case+        MetaValueMaybe True  Nothing  -> Just $ MetaValue_Property+        MetaValueMaybe False (Just s) -> Just $ MetaValue_Setting s+        MetaValueMaybe True  (Just s) -> Just $ MetaValue_PropertyAndSetting s+        MetaValueMaybe False Nothing  -> Nothing

@@ -1,7 +1,6 @@-module ProAbstract.Metadata.MetadataOptics-    ( properties, settings, hasProperty, atSetting-    ) where+module ProAbstract.Metadata.MetadataOptics where +import ProAbstract.Metadata.MetaValue import ProAbstract.Metadata.MetadataType  -- | Targets all properties from metadata.@@ -19,3 +18,15 @@ -- | Targets a setting from metadata. Returns 'Nothing' if no value is set. atSetting :: Text -> Lens' Metadata (Maybe Text) atSetting k = settings % lens (mapLookup k) (\m x -> maybe (mapDelete k) (mapInsert k) x m)++metaMap :: Iso' Metadata (Map Text MetaValue)+metaMap = iso f g+  where+    f x = mapUnionWith (<>) ps ss+      where+        ps = mapFromSet (const propertyValue) (metadataProperties x)+        ss = fmap settingValue (metadataSettings x)+    g x = Metadata ps ss+      where+        ps = mapKeysSet $ mapFilter isPropertyValue x+        ss = mapMapMaybe settingValueMaybe x

@@ -1,33 +1,25 @@ module ProAbstract.Optics     (-    -- * Lenses-      content, contents, tag, name--    -- ** Annotation-    , annotation+    -- * Content+      content, contents -    -- ** Metadata-    , metadata, atSetting, hasProperty, properties, settings+    -- * Tags+    , tag, name+    , allTags, allInlineTags, allBlockTags -    -- * Prisms-    , fork, plain, tagged, bare+    -- * Annotation+    , annotation, allAnnotations -    -- * Isomorphisms-    , taggedOrBare+    -- * Metadata+    , metadata+    , atSetting, hasProperty, properties, settings+    , allMetadata, metaList, metaMap -    -- * Traversals+    -- * Structure+    , fork, plain, tagged, bare, taggedOrBare     , allParagraphs, allPlainBlocks, allPlainInlines -    -- ** Annotation-    , allAnnotations--    -- ** Tags-    , allTags, allInlineTags, allBlockTags--    -- ** Metadata-    , allMetadata--    -- * Affine folds+    -- * Taglessness     , tagless, taglessContent, KindOfText (..)      ) where

@@ -13,6 +13,8 @@     , Line     , Lines     , Map+    , MetaItem+    , MetaValue     , Metadata     , Paragraph     , Plain

@@ -1,7 +1,7 @@ cabal-version: 3.0  name: pro-abstract-version: 0.2.0.0+version: 0.2.1.0  category: Language synopsis: Abstract syntax for writing documents@@ -86,6 +86,9 @@       , ProAbstract.Metadata.HasManyMetadata       , ProAbstract.Metadata.HasMetadata       , ProAbstract.Metadata.HasMetadataOptics+      , ProAbstract.Metadata.MetaItem+      , ProAbstract.Metadata.MetaList+      , ProAbstract.Metadata.MetaValue       , ProAbstract.Metadata.MetadataOptics       , ProAbstract.Metadata.MetadataType       , ProAbstract.Structure.Block@@ -146,3 +149,4 @@         pro-abstract       , neat-interpolation ^>= 0.5       , hedgehog ^>= 1.0 || ^>= 1.1+      , hedgehog-optics ^>= 1.0

@@ -6,9 +6,16 @@ import Prelude hiding (break)  import Control.Monad (when)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set import Data.Text (Text)-import Hedgehog (Property, checkParallel, discover, property, withTests, (===))+import Data.Traversable (for)+import Hedgehog (Gen, Property, checkParallel, discover, property, withTests, (===))+import qualified Hedgehog.Gen as Gen import System.Exit (exitFailure)+import Hedgehog.Optics  main :: IO () main = checkParallel $$discover >>= \ok -> when (not ok) exitFailure@@ -94,3 +101,46 @@ prop_ex12 = withTests 1 $ property $ do     x <- pure $ tbtag $ [para [[inlinePlain "abc", inlinePlain "def"], [inlinePlain "ghi"]]]     preview (fork % content % (tagless TextStanza)) x === Just ["abcdef", "ghi"]++genMetadata :: Gen Metadata+genMetadata = Metadata <$> genProperties <*> genSettings++genProperties :: Gen (Set Text)+genProperties = Set.fromList <$> genMetaKeys++metaKeyChoices :: [Text]+metaKeyChoices = ["one", "two", "three", "four", "five", "six", "seven"]++metaValueChoices :: [Text]+metaValueChoices = ["alpha", "beta", "delta", "gamma", "phi"]++genMetaKeys :: Gen [Text]+genMetaKeys = Gen.subsequence metaKeyChoices++genSettingValue :: Gen Text+genSettingValue = Gen.element metaValueChoices++genMetaKey :: Gen Text+genMetaKey = Gen.element metaKeyChoices++genSettings :: Gen (Map Text Text)+genSettings = do+    ks <- genMetaKeys+    kvs <- for ks \k -> genSettingValue >>= \v -> pure (k, v)+    pure $ Map.fromList kvs++genMetaMap :: Gen (Map Text MetaValue)+genMetaMap = do+    ks <- genMetaKeys+    kvs <- for ks \k -> genMetaValue >>= \v -> pure (k, v)+    pure $ Map.fromList kvs++genMetaValue :: Gen MetaValue+genMetaValue = Gen.choice+    [ pure MetaValue_Property+    , pure MetaValue_Setting <*> genSettingValue+    , pure MetaValue_PropertyAndSetting <*> genSettingValue+    ]++prop_metaMap :: Property+prop_metaMap = property $ wellFormedIso genMetadata genMetaMap metaMap