You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 

233 lines
8.1 KiB

{-|
Module : Prosidy.Optics.Types
Description : Optics for definitions in 'Prosidy.Types'.
Copyright : ©2020 James Alexander Feldman-Crough
License : MPL-2.0
Maintainer : alex@fldcr.com
-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
module Prosidy.Optics.Types
( -- * Classy optics
-- ** Items with 'Metadata'
HasMetadata(..)
, properties
, settings
, hasProperty
, atSetting
-- ** Items wrapping content
, HasContent(..)
-- * Accessors for fields not otherwise covered
, tag
-- * Conversion between 'Tag's and 'Region's.
, tagged
-- * Prisms on 'Block' contexts
, _BlockTag
, _BlockLiteral
, _BlockParagraph
-- * Prisms on 'Inline' contexts
, _InlineTag
, _Text
, _Break
-- * Optics on common types
, key
, _Assoc
, _NonEmpty
, _Series
, _SeriesNE
, _Set
)
where
import Prosidy.Types
import Prosidy.Types.Assoc ( toHashMap
, fromHashMap
)
import Prosidy.Types.Series ( toSeq
, fromSeq
, toSeqNE
, fromSeqNE
)
import Prosidy.Types.Set ( toHashSet
, fromHashSet
)
import Prosidy.Optics.Internal
import Data.Text ( Text )
import Data.Sequence ( Seq )
import Data.HashMap.Strict ( HashMap )
import Data.HashSet ( HashSet )
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
-------------------------------------------------------------------------------
-- | A classy optic for focusing on items with 'Metadata', including 'Tag's,
-- 'Region's, and 'Document's.
class HasMetadata t where
metadata :: Lens' t Metadata
instance HasMetadata Document where
metadata = lens documentMetadata (\d m -> d { documentMetadata = m })
{-# INLINE metadata #-}
instance HasMetadata (Tag a) where
metadata = lens tagMetadata (\d m -> d { tagMetadata = m })
{-# INLINE metadata #-}
instance HasMetadata (Region a) where
metadata = lens regionMetadata (\d m -> d { regionMetadata = m })
{-# INLINE metadata #-}
instance HasMetadata Metadata where
metadata = id
{-# INLINE metadata #-}
-- | Fetch all properties from items which contain metadata.
properties :: HasMetadata m => Lens' m (Set Key)
properties =
metadata . lens metadataProperties (\m p -> m { metadataProperties = p })
{-# INLINABLE properties #-}
{-# SPECIALIZE INLINE properties :: Lens' Metadata (Set Key) #-}
{-# SPECIALIZE INLINE properties :: Lens' Document (Set Key) #-}
{-# SPECIALIZE INLINE properties :: Lens' (Tag a) (Set Key) #-}
{-# SPECIALIZE INLINE properties :: Lens' (Region a) (Set Key) #-}
-- | Fetch all settings defined on items which contain metadata.
settings :: HasMetadata m => Lens' m (Assoc Key Text)
settings =
metadata . lens metadataSettings (\m s -> m { metadataSettings = s })
{-# INLINABLE settings #-}
{-# SPECIALIZE INLINE settings :: Lens' Metadata (Assoc Key Text) #-}
{-# SPECIALIZE INLINE settings :: Lens' Document (Assoc Key Text) #-}
{-# SPECIALIZE INLINE settings :: Lens' (Tag a) (Assoc Key Text) #-}
{-# SPECIALIZE INLINE settings :: Lens' (Region a) (Assoc Key Text) #-}
-- | Check if a property is attached to an item with metadata. Using this
-- optic as a setter will add a property if set to 'True' and remove the
-- property when set to 'False'.
hasProperty :: HasMetadata m => Key -> Lens' m Bool
hasProperty k = properties . _Set . lens
(HS.member k)
(\hs b -> (if b then HS.insert else HS.delete) k hs)
{-# INLINE hasProperty #-}
-- | Select a setting from an item attached to metadata. Returns 'Nothing' if
-- no value is set.
atSetting :: HasMetadata m => Key -> Lens' m (Maybe Text)
atSetting k = settings . _Assoc . lens
(HM.lookup k)
(\hm x -> maybe (HM.delete k) (HM.insert k) x hm)
{-# INLINE atSetting #-}
-------------------------------------------------------------------------------
-- | An optic for selecting children of an item in a recursive structure.
class HasContent t where
-- | The type of /all/ of the children collectively. For instance,
-- @type Content Document = Series Block@, as 'Document' has zero or more
-- contained 'Block's.
type Content t
content :: Lens' t (Content t)
instance HasContent Document where
type Content Document = Series Block
content = lens documentContent (\d c -> d { documentContent = c })
{-# INLINE content #-}
instance HasContent (Tag a) where
type Content (Tag a) = a
content = lens tagContent (\t c -> t { tagContent = c })
{-# INLINE content #-}
instance HasContent (Region a) where
type Content (Region a) = a
content = lens regionContent (\t c -> t { regionContent = c })
{-# INLINE content #-}
instance HasContent Paragraph where
type Content Paragraph = SeriesNE Inline
content = lens paragraphContent (\t c -> t { paragraphContent = c })
{-# INLINE content #-}
-------------------------------------------------------------------------------
-- | Focus on the name of a 'Tag'.
tag :: Lens' (Tag a) Key
tag = lens tagName (\t n -> t { tagName = n })
{-# INLINE tag #-}
-------------------------------------------------------------------------------
-- | Focus on the inner 'Region' of 'Tag's with a name. This can be used to
-- filter 'Tag's to a specific subset for manipulation.
tagged :: Key -> Prism' (Tag a) (Region a)
tagged k = prism' (regionToTag k)
$ \tag -> if tagName tag == k then Just $ tagToRegion tag else Nothing
{-# INLINE tagged #-}
-------------------------------------------------------------------------------
-- | Focus only on block tags.
_BlockTag :: Prism' Block BlockTag
_BlockTag = prism' BlockTag $ \case
BlockTag t -> Just t
_ -> Nothing
-- | Focus only on paragraphs'
_BlockParagraph :: Prism' Block Paragraph
_BlockParagraph = prism' BlockParagraph $ \case
BlockParagraph p -> Just p
_ -> Nothing
-- | Focus only on literal tags.
_BlockLiteral :: Prism' Block LiteralTag
_BlockLiteral = prism' BlockLiteral $ \case
BlockLiteral t -> Just t
_ -> Nothing
-- | Focus only on inline tags.
_InlineTag :: Prism' Inline InlineTag
_InlineTag = prism' InlineTag $ \case
InlineTag t -> Just t
_ -> Nothing
-- | Focus only on text nodes.
_Text :: Prism' Inline Text
_Text = prism' InlineText $ \case
InlineText t -> Just t
_ -> Nothing
-- | Focus only on breaks.
_Break :: Prism' Inline ()
_Break = prism' (const Break) $ \case
Break -> Just ()
_ -> Nothing
-------------------------------------------------------------------------------
-- | A Prism from 'Text' into a valid 'Key'.
key :: Prism' Text Key
key = prism' rawKey (either (const Nothing) Just . makeKey)
{-# INLINE key #-}
-- | An isomorphism between Prosidy's 'Assoc' wrapper and 'HashMap'.
_Assoc :: Iso (Assoc k v) (Assoc k' v') (HashMap k v) (HashMap k' v')
_Assoc = iso toHashMap fromHashMap
{-# INLINE _Assoc #-}
-- | A prism between possibly-empty and non-empty containers.
_NonEmpty :: Prism' (Series a) (SeriesNE a)
_NonEmpty = prism' (fromSeq . toSeqNE) (fromSeqNE . toSeq)
{-# INLINE _NonEmpty #-}
-- | An isomorpism between Prosidy's 'Series' wrapper and 'Seq'.
_Series :: Iso (Series a) (Series b) (Seq a) (Seq b)
_Series = iso toSeq fromSeq
{-# INLINE _Series #-}
-- | A prism from a non-empty 'Seq' into a 'SeriesNE'.
_SeriesNE :: Prism' (Seq a) (SeriesNE a)
_SeriesNE = prism' toSeqNE fromSeqNE
{-# INLINE _SeriesNE #-}
-- | An isomorphism between Prosidy's 'Set' wrapper and 'HashSet'.
_Set :: Iso (Set a) (Set b) (HashSet a) (HashSet b)
_Set = iso toHashSet fromHashSet
{-# INLINE _Set #-}