diff --git a/yaifl-gui/src/Main.hs b/yaifl-gui/src/Main.hs index 848f936..e1ac533 100644 --- a/yaifl-gui/src/Main.hs +++ b/yaifl-gui/src/Main.hs @@ -135,7 +135,7 @@ runLoop :: Game wm () runLoop = do ifM runOnce pass runLoop -getMessageBuffer :: forall wm. Game wm [StyledDoc] +getMessageBuffer :: forall wm. Game wm [StyledDoc MessageAnnotation] getMessageBuffer = gets @(World wm) (view $ #messageBuffer % #buffer) renderAll :: forall wm. Game wm () diff --git a/yaifl/run_no b/yaifl/run_no index 5d1d1b1..880ae56 100644 --- a/yaifl/run_no +++ b/yaifl/run_no @@ -1 +1 @@ -755 \ No newline at end of file +756 \ No newline at end of file diff --git a/yaifl/src/Yaifl/Std/Actions/Looking.hs b/yaifl/src/Yaifl/Std/Actions/Looking.hs index 6755453..d344232 100644 --- a/yaifl/src/Yaifl/Std/Actions/Looking.hs +++ b/yaifl/src/Yaifl/Std/Actions/Looking.hs @@ -26,8 +26,7 @@ import Yaifl.Std.Kinds.Animal import Yaifl.Std.Kinds.Supporter ( isSupporter ) import Yaifl.Core.Rules.RuleEffects import Yaifl.Text.AdaptiveNarrative -import Yaifl.Text.Print ( Print, setStyle, runOnLookingParagraph ) -import qualified Prettyprinter.Render.Terminal as PPTTY +import Yaifl.Text.Print ( Print, setStyle, runOnLookingParagraph, bold ) import Yaifl.Core.Kinds.AnyObject import Yaifl.Core.Kinds.Thing @@ -87,7 +86,7 @@ roomDescriptionHeading :: roomDescriptionHeading = makeRule "room description heading rule" forPlayer' (\a@Args{variables=(LookingActionVariables _ lvls _)} -> do -- say bold type; - setStyle (Just PPTTY.bold) + setStyle (Just bold) addAnnotation $ "levels " <> mconcat (map display lvls) let mbVisCeil = viaNonEmpty last lvls whenJust mbVisCeil $ addTag "visibility ceiling" . display diff --git a/yaifl/src/Yaifl/Std/Rulebooks/WhenPlayBegins.hs b/yaifl/src/Yaifl/Std/Rulebooks/WhenPlayBegins.hs index 59b4238..afe6aaa 100644 --- a/yaifl/src/Yaifl/Std/Rulebooks/WhenPlayBegins.hs +++ b/yaifl/src/Yaifl/Std/Rulebooks/WhenPlayBegins.hs @@ -4,7 +4,6 @@ module Yaifl.Std.Rulebooks.WhenPlayBegins import Yaifl.Prelude import qualified Data.Text as T -import qualified Prettyprinter.Render.Terminal as PPTTY import Breadcrumbs ( Breadcrumbs, addAnnotation ) import Yaifl.Std.Move ( move ) @@ -17,10 +16,11 @@ import Yaifl.Core.ObjectLike import Yaifl.Core.Query.Object ( getCurrentPlayer ) import Yaifl.Core.Rules.Rulebook import Yaifl.Core.Rules.RuleEffects -import Yaifl.Text.Print ( Print, setStyle, printText ) +import Yaifl.Text.Print import Yaifl.Core.Kinds.Room import Yaifl.Core.Query.Enclosing import Yaifl.Core.Actions.GoesWith +import Rogue.Colour whenPlayBeginsName :: Text whenPlayBeginsName = "when play begins" @@ -39,10 +39,10 @@ whenPlayBeginsRules = Rulebook sayIntroText :: State Metadata :> es - => Print :> es + => Print :> es => Eff es () sayIntroText = do - setStyle (Just (PPTTY.color PPTTY.Green <> PPTTY.bold)) + setStyle (Just (colour (Colour 0xff00ff22) <> bold)) t <- use #title printText $ introText t setStyle Nothing diff --git a/yaifl/src/Yaifl/Text/Print.hs b/yaifl/src/Yaifl/Text/Print.hs index 9c1b563..ffd67c2 100644 --- a/yaifl/src/Yaifl/Text/Print.hs +++ b/yaifl/src/Yaifl/Text/Print.hs @@ -5,6 +5,7 @@ module Yaifl.Text.Print ( -- * Types MessageBuffer (..) , MessageContext(..) + , MessageAnnotation(..) , Print(..) , Has(..) , PartialState @@ -21,18 +22,56 @@ module Yaifl.Text.Print , printIf , runPrintPure , runPrintIO + + , bold + , colour ) where import Yaifl.Prelude import qualified Prettyprinter as PP -import qualified Prettyprinter.Render.Terminal as PPTTY import Effectful.TH ( makeEffect ) import Effectful.Dispatch.Dynamic (interpret) import qualified Data.Text as T +import Rogue.Colour + +type StyledDoc style = PP.Doc style + +data Bold = Bold + deriving stock (Eq, Ord, Show, Generic) + +data Italics = Italics + deriving stock (Eq, Ord, Show, Generic) + +data Underlined = Underlined + deriving stock (Eq, Ord, Show, Generic) -type StyledDoc = PP.Doc PPTTY.AnsiStyle +data MessageAnnotation = MessageAnnotation + { foregroundAnnotation :: Maybe Colour -- ^ Set the foreground color, or keep the old one. + , backgroundAnnotation :: Maybe Colour -- ^ Set the background color, or keep the old one. + , boldAnnotation :: Maybe Bold -- ^ Switch on boldness, or don’t do anything. + , italics :: Maybe Italics -- ^ Switch on italics, or don’t do anything. + , underlined :: Maybe Underlined -- ^ Switch on underlining, or don’t do anything. + } deriving stock (Eq, Ord, Show, Generic) + +instance Monoid MessageAnnotation where + mempty = MessageAnnotation Nothing Nothing Nothing Nothing Nothing + +instance Semigroup MessageAnnotation where + (<>) m1 m2 = MessageAnnotation + { foregroundAnnotation = (foregroundAnnotation m1) <|> foregroundAnnotation m2 + , backgroundAnnotation = (backgroundAnnotation m1) <|> backgroundAnnotation m2 + , boldAnnotation = (boldAnnotation m1) <|> boldAnnotation m2 + , italics = (italics m1) <|> italics m2 + , underlined = (underlined m1) <|> underlined m2 + } + +colour :: Colour -> MessageAnnotation +colour c = mempty { foregroundAnnotation = Just c } + +bold :: MessageAnnotation +bold = mempty { boldAnnotation = Just Bold } data MessageContext = MessageContext { messageFromRule :: Text @@ -44,15 +83,15 @@ data MessageContext = MessageContext } deriving stock (Show, Ord, Generic, Eq) data Print :: Effect where - ModifyBuffer :: (MessageBuffer -> MessageBuffer) -> Print m MessageBuffer - PrintDoc :: Maybe MessageContext -> StyledDoc -> Print m () - SetStyle :: Maybe PPTTY.AnsiStyle -> Print m () + ModifyBuffer :: (MessageBuffer -> MessageBuffer) -> Print m (MessageBuffer) + PrintDoc :: Maybe MessageContext -> StyledDoc MessageAnnotation-> Print m () + SetStyle :: Maybe MessageAnnotation -> Print m () data MessageBuffer = MessageBuffer - { buffer :: [StyledDoc] -- ^ Current messages held before flushing. + { buffer :: [StyledDoc MessageAnnotation] -- ^ Current messages held before flushing. , lastMessageContext :: MessageContext -- ^ some metadata about the last printed message, to deal with pbreaks and lines - , style :: Maybe PPTTY.AnsiStyle -- ^ Current formatting; 'Nothing' = plain. - , context :: [StyledDoc] -- ^ Possibly nested prefixes before every message. + , style :: Maybe MessageAnnotation -- ^ Current formatting; 'Nothing' = plain. + , context :: [StyledDoc MessageAnnotation] -- ^ Possibly nested prefixes before every message. , ruleContext :: Text -- ^ the currently executing rule } deriving stock (Show, Generic) @@ -65,9 +104,9 @@ blankMessageBuffer = MessageBuffer [] (MessageContext "¬¬¬" False False False processDoc :: forall s es. - PartialState s MessageBuffer es - => StyledDoc - -> Eff es StyledDoc + PartialState s (MessageBuffer) es + => StyledDoc MessageAnnotation + -> Eff es (StyledDoc MessageAnnotation) processDoc msg = do (MessageBuffer _ _ style cxt _) <- use @s buf -- if we have no context, we just monoid it. @@ -86,14 +125,14 @@ instance Has s s where runPrintPure :: forall s es a. - PartialState s MessageBuffer es + PartialState s (MessageBuffer) es => Eff (Print : es) a -> Eff es a runPrintPure = interpret $ \_ -> \case PrintDoc mbMetadata doc -> do r <- processDoc doc - modify (\s -> s & buf % (#buffer @(Lens' MessageBuffer [StyledDoc])) %~ (r:)) - whenJust mbMetadata $ \metadata -> modify (\s -> s & buf % #lastMessageContext @(Lens' MessageBuffer MessageContext) .~ metadata) + modify (\s -> s & buf % (#buffer @(Lens' (MessageBuffer) [StyledDoc MessageAnnotation])) %~ (r:)) + whenJust mbMetadata $ \metadata -> modify (\s -> s & buf % #lastMessageContext @(Lens' (MessageBuffer) MessageContext) .~ metadata) SetStyle mbStyle -> setStyle' mbStyle ModifyBuffer f -> do modify (\s -> s & buf %~ f) @@ -102,13 +141,13 @@ runPrintPure = interpret $ \_ -> \case runPrintIO :: forall s es a. IOE :> es - => PartialState s MessageBuffer es + => PartialState s (MessageBuffer) es => Eff (Print : es) a -> Eff es a runPrintIO = interpret $ \_ -> \case PrintDoc mbMetadata doc -> do r <- processDoc doc - whenJust mbMetadata $ \metadata -> modify (\s -> s & (buf % #lastMessageContext @(Lens' MessageBuffer MessageContext) .~ metadata)) + whenJust mbMetadata $ \metadata -> modify (\s -> s & (buf % #lastMessageContext @(Lens' (MessageBuffer) MessageContext) .~ metadata)) print r SetStyle mbStyle -> setStyle' mbStyle ModifyBuffer f -> do @@ -196,7 +235,8 @@ printIf False = const pass -- | Update the style of a message buffer. Setting to 'Just' overwrites the style, -- | whereas 'Nothing' will remove it. This will not affect previous messages. setStyle' :: - PartialState s MessageBuffer es - => Maybe PPTTY.AnsiStyle -- ^ The updated style. + forall s es. + PartialState s (MessageBuffer) es + => Maybe MessageAnnotation -- ^ The updated style. -> Eff es () -setStyle' s = buf % (#style @(Lens' MessageBuffer (Maybe PPTTY.AnsiStyle))) .= s \ No newline at end of file +setStyle' s = buf % (#style @(Lens' (MessageBuffer) (Maybe MessageAnnotation))) .= s \ No newline at end of file diff --git a/yaifl/yaifl.cabal b/yaifl/yaifl.cabal index ca24062..073e668 100644 --- a/yaifl/yaifl.cabal +++ b/yaifl/yaifl.cabal @@ -187,6 +187,7 @@ library , megaparsec , prettyprinter , prettyprinter-ansi-terminal + , roguefunctor , split test-suite yaifl-test