@ -5,15 +5,16 @@ Copyright : ©2020 James Alexander Feldman-Crough
License : MPL - 2.0
Maintainer : alex @ fldcr . com
- }
{- # LANGUAGE Safe # -}
{- # LANGUAGE DeriveAnyClass # -}
{- # LANGUAGE DeriveGeneric # -}
{- # LANGUAGE DeriveFunctor # -}
{- # LANGUAGE DeriveFoldable # -}
{- # LANGUAGE DeriveTraversable # -}
{- # LANGUAGE DerivingStrategies # -}
{- # LANGUAGE DerivingVia # -}
{- # LANGUAGE FlexibleContexts # -}
{- # LANGUAGE FlexibleInstances # -}
{- # LANGUAGE GeneralizedNewtypeDeriving # -}
{- # LANGUAGE OverloadedStrings # -}
{- # LANGUAGE StrictData # -}
{- # LANGUAGE TypeApplications # -}
@ -49,6 +50,8 @@ module Prosidy.Types
)
where
import Prosidy.Internal.Classes
import Prosidy.Types.Assoc as X
( Assoc ( .. ) )
import Prosidy.Types.Key as X
@ -67,21 +70,10 @@ import Prosidy.Types.Set as X
import Prosidy.Source ( Location )
import Data.Text ( Text )
import GHC.Generics ( Generic )
import Control.DeepSeq ( NFData )
import Data.Binary ( Binary )
import Data.Hashable ( Hashable )
import Data.Aeson ( ToJSON ( .. )
, FromJSON ( .. )
, withObject
, withText
, ( .: )
, ( .= )
, object
, pairs
)
import qualified Data.Aeson as Aeson
import Data.Text.Prettyprint.Doc ( ( <+> ) )
import Data.Foldable ( toList )
import Prosidy.Types.Assoc ( toEntries )
import qualified Data.Text.Prettyprint.Doc as PP
-------------------------------------------------------------------------------
-- | A sum type enumerating allowed types inside of a block context.
@ -92,45 +84,10 @@ data Block =
deriving stock ( Eq , Show , Generic )
deriving anyclass ( Hashable , Binary , NFData )
instance FromJSON Block where
parseJSON = withObject " block " $ \ o -> do
ty <- o .: " type "
case ty :: Text of
" tag " -> do
subtype <- o .: " subtype "
case subtype :: Text of
" block " -> BlockTag <$> o .: " value "
" literal " -> BlockLiteral <$> o .: " value "
_ -> fail $ " unknown tag subtype: " <> show subtype
" paragraph " -> BlockParagraph <$> o .: " value "
_ -> fail $ " unknown block type: " <> show ty
instance ToJSON Block where
toEncoding b = pairs . mconcat $ case b of
BlockLiteral t ->
[ " type " .= ( " tag " :: Text )
, " subtype " .= ( " literal " :: Text )
, " value " .= t
]
BlockParagraph p -> [ " type " .= ( " paragraph " :: Text ) , " value " .= p ]
BlockTag t ->
[ " type " .= ( " tag " :: Text )
, " subtype " .= ( " block " :: Text )
, " value " .= t
]
toJSON b = object $ case b of
BlockLiteral t ->
[ " type " .= ( " tag " :: Text )
, " subtype " .= ( " literal " :: Text )
, " value " .= t
]
BlockParagraph p -> [ " type " .= ( " paragraph " :: Text ) , " value " .= p ]
BlockTag t ->
[ " type " .= ( " tag " :: Text )
, " subtype " .= ( " block " :: Text )
, " value " .= t
]
instance Pretty Block where
pretty ( BlockLiteral lit ) = pretty lit
pretty ( BlockParagraph pp ) = pretty pp
pretty ( BlockTag tag ) = pretty tag
-------------------------------------------------------------------------------
-- | A full Prosidy document.
@ -141,15 +98,8 @@ data Document = Document
deriving stock ( Eq , Show , Generic )
deriving anyclass ( Hashable , NFData , Binary )
instance FromJSON Document where
parseJSON = withObject " Document "
$ \ o -> Document <$> o .: " metadata " <*> o .: " content "
instance ToJSON Document where
toEncoding ( Document md ct ) =
pairs $ mconcat [ " metadata " .= md , " content " .= ct ]
toJSON ( Document md ct ) = object [ " metadata " .= md , " content " .= ct ]
instance Pretty Document where
pretty ( Document md ct ) = PP . nest 4 . PP . vsep $ [ pretty md , pretty ct ]
-- | Convert a 'Document' to a 'Region'. The resulting 'Region' will never have
-- a 'Location' attached.
@ -172,12 +122,8 @@ data Fragment = Fragment
deriving stock ( Eq , Show , Generic )
deriving anyclass ( Hashable , Binary , NFData )
instance FromJSON Fragment where
parseJSON = withText " Fragment " $ pure . flip Fragment Nothing
instance ToJSON Fragment where
toEncoding = toEncoding . fragmentText
toJSON = toJSON . fragmentText
instance Pretty Fragment where
pretty = pretty . fragmentText
-------------------------------------------------------------------------------
-- | A sum type enumerating allowed types inside of an inline context.
@ -196,33 +142,10 @@ data Inline =
deriving stock ( Eq , Show , Generic )
deriving anyclass ( Hashable , Binary , NFData )
instance FromJSON Inline where
parseJSON = withObject " Inline " $ \ o -> do
ty <- o .: " type "
case ty :: Text of
" break " -> pure Break
" tag " -> InlineTag <$> o .: " value "
" text " -> InlineText <$> o .: " value "
_ -> fail $ " unknown inline type: " <> show ty
instance ToJSON Inline where
toEncoding i = pairs . mconcat $ case i of
Break -> [ " type " .= ( " break " :: Text ) , " value " .= Aeson . Null ]
InlineTag t ->
[ " type " .= ( " tag " :: Text )
, " subtype " .= ( " inline " :: Text )
, " value " .= t
]
InlineText t -> [ " type " .= ( " text " :: Text ) , " value " .= t ]
toJSON i = object $ case i of
Break -> [ " type " .= ( " break " :: Text ) ]
InlineTag t ->
[ " type " .= ( " tag " :: Text )
, " subtype " .= ( " inline " :: Text )
, " value " .= t
]
InlineText t -> [ " type " .= ( " text " :: Text ) , " value " .= t ]
instance Pretty Inline where
pretty Break = " \ 9248 "
pretty ( InlineTag tag ) = pretty tag
pretty ( InlineText f ) = pretty f
-------------------------------------------------------------------------------
-- | A set of properties and settings, associated with a 'Region'.
@ -241,19 +164,21 @@ data Metadata = Metadata
instance Monoid Metadata where
mempty = Metadata mempty mempty
instance Pretty Metadata where
pretty ( Metadata props sets )
| null props && null sets
= " ∅ "
| otherwise
= let props' = fmap pretty . toList $ props
sets' =
fmap ( \ ( k , v ) -> pretty k <+> PP . equals <+> pretty v )
. toEntries
$ sets
in PP . list $ props' ++ sets'
instance Semigroup Metadata where
Metadata p1 s1 <> Metadata p2 s2 = Metadata ( p1 <> p2 ) ( s1 <> s2 )
instance FromJSON Metadata where
parseJSON = withObject " Metadata "
$ \ o -> Metadata <$> o .: " properties " <*> o .: " settings "
instance ToJSON Metadata where
toEncoding ( Metadata ps ss ) =
pairs $ mconcat [ " properties " .= ps , " settings " .= ss ]
toJSON ( Metadata ps ss ) = object [ " properties " .= ps , " settings " .= ss ]
-------------------------------------------------------------------------------
-- | A non-empty collection of 'Inline' items. A 'Paragraph' represents the
-- border between block and inline contexts. All ancestors of a paragraph are
@ -265,12 +190,8 @@ data Paragraph = Paragraph
deriving stock ( Eq , Show , Generic )
deriving anyclass ( Hashable , NFData , Binary )
instance FromJSON Paragraph where
parseJSON = fmap ( flip Paragraph Nothing ) . parseJSON
instance ToJSON Paragraph where
toEncoding ( Paragraph s _ ) = toEncoding s
toJSON ( Paragraph s _ ) = toJSON s
instance Pretty Paragraph where
pretty pg = " ¶ " PP .<+> pretty ( paragraphContent pg )
-------------------------------------------------------------------------------
-- | An untagged structural grouping of items with type @a@. Regions do not
@ -283,8 +204,8 @@ data Region a = Region
deriving stock ( Eq , Foldable , Functor , Show , Traversable , Generic )
deriving anyclass ( Hashable , NFData , Binary )
instance ToJSON a => ToJSON ( Region a ) where
toJSON ( Region md ct _ ) = Aeson . object [ " metadata " .= md , " content " .= ct ]
instance Pretty a => Pretty ( Region a ) where
pretty ( Region md ct _ ) = PP . nest 4 $ PP . vsep [ " § " , pretty md , pretty ct ]
-------------------------------------------------------------------------------
-- | A 'Region', annotated with a tag name.
@ -297,23 +218,9 @@ data Tag a = Tag
deriving stock ( Eq , Foldable , Functor , Show , Traversable , Generic )
deriving anyclass ( Hashable , NFData , Binary )
instance FromJSON a => FromJSON ( Tag a ) where
parseJSON = withObject " Tag " $ \ o ->
Tag
<$> o
.: " name "
<*> o
.: " metadata "
<*> o
.: " content "
<*> pure Nothing
instance ToJSON a => ToJSON ( Tag a ) where
toEncoding ( Tag nm md ct _ ) =
pairs $ mconcat [ " name " .= nm , " metadata " .= md , " content " .= ct ]
toJSON ( Tag nm md ct _ ) =
object [ " name " .= nm , " metadata " .= md , " content " .= ct ]
instance Pretty a => Pretty ( Tag a ) where
pretty ( Tag name md ct _ ) =
PP . nest 4 $ PP . vsep [ pretty name , pretty md , pretty ct ]
-- | A 'Tag' containing zero or more 'Block' items.
-- Specified in Prosidy source with the @#-@ sigil.