From eece0a87b331017731357635a8b0aa8c1a48e74b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 6 Aug 2023 01:16:50 +0200 Subject: [PATCH] Use markdown for entity description in haskell --- src/Swarm/Doc/Gen.hs | 3 ++- src/Swarm/Game/Entity.hs | 14 ++++++++------ src/Swarm/Game/Robot.hs | 6 ++++-- src/Swarm/Game/Step.hs | 7 ++++--- src/Swarm/Language/Text/Markdown.hs | 27 ++++++++++++++++++++++++--- src/Swarm/TUI/View.hs | 4 ++-- 6 files changed, 44 insertions(+), 17 deletions(-) diff --git a/src/Swarm/Doc/Gen.hs b/src/Swarm/Doc/Gen.hs index 2b19427c4..3a13bb06c 100644 --- a/src/Swarm/Doc/Gen.hs +++ b/src/Swarm/Doc/Gen.hs @@ -65,6 +65,7 @@ import Swarm.Util (both, guardRight, listEnums, quote, simpleErrorHandle) import Text.Dot (Dot, NodeId, (.->.)) import Text.Dot qualified as Dot import Witch (from) +import Swarm.Language.Text.Markdown as Markdown (toText) -- ============================================================================ -- MAIN ENTRYPOINT TO CLI DOCUMENTATION GENERATOR @@ -368,7 +369,7 @@ entityToSection e = <> [" - Properties: " <> T.intercalate ", " (map tshow $ toList props) | not $ null props] <> [" - Capabilities: " <> T.intercalate ", " (Capability.capabilityName <$> caps) | not $ null caps] <> ["\n"] - <> [T.intercalate "\n\n" $ view E.entityDescription e] + <> [Markdown.toText $ view E.entityDescription e] where props = view E.entityProperties e caps = Set.toList $ view E.entityCapabilities e diff --git a/src/Swarm/Game/Entity.hs b/src/Swarm/Game/Entity.hs index cdb65d86a..1831cc242 100644 --- a/src/Swarm/Game/Entity.hs +++ b/src/Swarm/Game/Entity.hs @@ -106,11 +106,13 @@ import Swarm.Game.Failure (AssetData (Entities), prettyFailure) import Swarm.Game.Location import Swarm.Game.ResourceLoading (getDataFileNameSafe) import Swarm.Language.Capability -import Swarm.Util (binTuples, failT, findDup, plural, quote, reflow, (?)) +import Swarm.Util (binTuples, failT, findDup, plural, quote, (?)) import Swarm.Util.Yaml import Text.Read (readMaybe) import Witch import Prelude hiding (lookup) +import Swarm.Language.Text.Markdown (Document, toText) +import Swarm.Language.Syntax (Syntax) ------------------------------------------------------------ -- Properties @@ -210,7 +212,7 @@ data Entity = Entity -- ^ The plural of the entity name, in case it is irregular. If -- this field is @Nothing@, default pluralization heuristics -- will be used (see 'plural'). - , _entityDescription :: [Text] + , _entityDescription :: Document Syntax -- ^ A longer-form description. Each 'Text' value is one -- paragraph. , _entityOrientation :: Maybe Heading @@ -242,7 +244,7 @@ instance Hashable Entity where `hashWithSalt` disp `hashWithSalt` nm `hashWithSalt` pl - `hashWithSalt` descr + `hashWithSalt` toText descr `hashWithSalt` orient `hashWithSalt` grow `hashWithSalt` yld @@ -271,7 +273,7 @@ mkEntity :: -- | Entity name Text -> -- | Entity description - [Text] -> + Document Syntax -> -- | Properties [EntityProperty] -> -- | Capabilities @@ -336,7 +338,7 @@ instance FromJSON Entity where <$> v .: "display" <*> v .: "name" <*> v .:? "plural" - <*> (map reflow <$> (v .: "description")) + <*> (v .: "description") <*> v .:? "orientation" <*> v .:? "growth" <*> v .:? "yields" @@ -423,7 +425,7 @@ entityNameFor _ = to $ \e -> -- | A longer, free-form description of the entity. Each 'Text' value -- represents a paragraph. -entityDescription :: Lens' Entity [Text] +entityDescription :: Lens' Entity (Document Syntax) entityDescription = hashedLens _entityDescription (\e x -> e {_entityDescription = x}) -- | The direction this entity is facing (if it has one). diff --git a/src/Swarm/Game/Robot.hs b/src/Swarm/Game/Robot.hs index 233ab5a8c..3213330ef 100644 --- a/src/Swarm/Game/Robot.hs +++ b/src/Swarm/Game/Robot.hs @@ -105,6 +105,8 @@ import Swarm.Language.Value as V import Swarm.Util.Lens (makeLensesExcluding) import Swarm.Util.Yaml import System.Clock (TimeSpec) +import Swarm.Language.Text.Markdown (Document) +import Swarm.Language.Syntax (Syntax) -- | A record that stores the information -- for all definitions stored in a 'Robot' @@ -444,7 +446,7 @@ mkRobot :: -- | Name of the robot. Text -> -- | Description of the robot. - [Text] -> + Document Syntax -> -- | Initial location. RobotLocation phase -> -- | Initial heading/direction. @@ -501,7 +503,7 @@ instance FromJSONE EntityMap TRobot where mkRobot () Nothing <$> liftE (v .: "name") - <*> liftE (v .:? "description" .!= []) + <*> liftE (v .:? "description" .!= mempty) <*> liftE (v .:? "loc") <*> liftE (v .:? "dir" .!= zero) <*> localE (const defDisplay) (v ..:? "display" ..!= defDisplay) diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index 52b2ad481..de7b5f8d5 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -85,6 +85,7 @@ import Swarm.Language.Capability import Swarm.Language.Context hiding (delete) import Swarm.Language.Key (parseKeyComboFull) import Swarm.Language.Parse (runParser) +import Swarm.Language.Text.Markdown qualified as Markdown import Swarm.Language.Pipeline import Swarm.Language.Pipeline.QQ (tmQ) import Swarm.Language.Pretty (BulletList (BulletList, bulletListItems), prettyText) @@ -384,7 +385,7 @@ hypotheticalRobot c = (-1) Nothing "hypothesis" - [] + mempty defaultCosmicLocation zero defaultRobotDisplay @@ -1082,7 +1083,7 @@ addSeedBot e (minT, maxT) loc ts = () Nothing "seed" - ["A growing seed."] + "A growing seed." (Just loc) zero ( defaultEntityDisplay '.' @@ -1958,7 +1959,7 @@ execConst c vs s k = do () (Just pid) displayName - ["A robot built by the robot named " <> r ^. robotName <> "."] + (Markdown.fromText $ "A robot built by the robot named " <> (r ^. robotName) <> ".") (Just (r ^. robotLocation)) ( ((r ^. robotOrientation) >>= \dir -> guard (dir /= zero) >> return dir) ? north diff --git a/src/Swarm/Language/Text/Markdown.hs b/src/Swarm/Language/Text/Markdown.hs index 7f558dccd..9ae8a67e7 100644 --- a/src/Swarm/Language/Text/Markdown.hs +++ b/src/Swarm/Language/Text/Markdown.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} -- | -- SPDX-License-Identifier: BSD-3-Clause @@ -19,6 +20,7 @@ module Swarm.Language.Text.Markdown ( Node (..), TxtAttr (..), fromTextM, + fromText, -- ** Token stream StreamNode' (..), @@ -52,6 +54,7 @@ import Swarm.Language.Parse (readTerm) import Swarm.Language.Pipeline (ProcessedTerm (..), processParsedTerm) import Swarm.Language.Pretty (prettyText, prettyTypeErrText) import Swarm.Language.Syntax (Syntax) +import GHC.Exts qualified (IsList(..), IsString(..)) -- | The top-level markdown document. newtype Document c = Document {paragraphs :: [Paragraph c]} @@ -108,13 +111,27 @@ instance Mark.Rangeable (Document c) where instance Mark.HasAttributes (Document c) where addAttributes _ = id +instance GHC.Exts.IsList (Document a) where + type Item (Document a) = Paragraph a + toList = paragraphs + fromList = Document + +instance GHC.Exts.IsString (Document Syntax) where + fromString = fromText . T.pack + +instance GHC.Exts.IsString (Paragraph Syntax) where + fromString s = case paragraphs $ GHC.Exts.fromString s of + [] -> mempty + [p] -> p + ps -> error $ "Error: expected one paragraph, but found " <> show (length ps) + -- | Surround some text in double quotes if it is not empty. quoteMaybe :: Text -> Text quoteMaybe t = if T.null t then t else T.concat ["\"", t, "\""] instance Mark.IsInline (Paragraph Text) where lineBreak = pureP $ txt "\n" - softBreak = mempty + softBreak = pureP $ txt " " str = pureP . txt entity = Mark.str escapedChar c = Mark.str $ T.pack ['\\', c] @@ -159,13 +176,17 @@ instance ToJSON (Document Syntax) where toJSON = String . toText instance FromJSON (Document Syntax) where - parseJSON v = parsePars v <|> parseDoc v + parseJSON v = parseDoc v <|> parsePars v where parseDoc = withText "markdown" fromTextM parsePars = withArray "markdown paragraphs" $ \a -> do (ts :: [Text]) <- mapM parseJSON $ toList a fromTextM $ T.intercalate "\n\n" ts +-- | Parse Markdown document, but throw on invalid code. +fromText :: Text -> Document Syntax +fromText = either error id . fromTextE + -- | Read Markdown document and parse&validate the code. -- -- If you want only the document with code as `Text`, @@ -255,7 +276,7 @@ streamToText = T.concat . map nodeToText TextNode _a t -> t RawNode _s t -> t CodeNode stx -> stx - ParagraphBreak -> "\n" + ParagraphBreak -> "\n\n" -- | Convert elements to one dimensional stream of nodes, -- that is easy to format and layout. diff --git a/src/Swarm/TUI/View.hs b/src/Swarm/TUI/View.hs index 6a6133d20..3689b7ddf 100644 --- a/src/Swarm/TUI/View.hs +++ b/src/Swarm/TUI/View.hs @@ -1105,7 +1105,7 @@ explainEntry :: AppState -> Entity -> Widget Name explainEntry s e = vBox $ [ displayProperties $ Set.toList (e ^. entityProperties) - , displayParagraphs (e ^. entityDescription) + , drawMarkdown (e ^. entityDescription) , explainRecipes s e ] <> [drawRobotMachine s False | e ^. entityCapabilities . Lens.contains CDebug] @@ -1251,7 +1251,7 @@ drawRecipe me inv (Recipe ins outs reqs time _weight) = -- | Ad-hoc entity to represent time - only used in recipe drawing timeE :: Entity -timeE = mkEntity (defaultEntityDisplay '.') "ticks" [] [] [] +timeE = mkEntity (defaultEntityDisplay '.') "ticks" mempty [] [] drawReqs :: IngredientList Entity -> Widget Name drawReqs = vBox . map (hCenter . drawReq)