Fix spacing and printing to text

src/Swarm/Doc/Gen.hs

@@ -55,7 +55,7 @@ import Swarm.Language.Key (specialKeyNames)
 import Swarm.Language.Pretty (prettyText)
 import Swarm.Language.Syntax (Const (..))
 import Swarm.Language.Syntax qualified as Syntax
-import Swarm.Language.Text.Markdown as Markdown (toText)
+import Swarm.Language.Text.Markdown as Markdown (docToMark)
 import Swarm.Language.Typecheck (inferConst)
 import Swarm.Util (both, listEnums, quote)
 import Swarm.Util.Effect (simpleErrorHandle)
@@ -360,7 +360,7 @@ entityToSection e =
       <> [" - Properties: " <> T.intercalate ", " (map tshow $ toList props) | not $ null props]
       <> [" - Capabilities: " <> T.intercalate ", " (Capability.capabilityName <$> caps) | not $ null caps]
       <> ["\n"]
-      <> [Markdown.toText $ view E.entityDescription e]
+      <> [Markdown.docToMark $ view E.entityDescription e]
  where
   props = view E.entityProperties e
   caps = Set.toList $ view E.entityCapabilities e

src/Swarm/Doc/Pedagogy.hs

@@ -90,7 +90,7 @@ extractCommandUsages idx siPair@(s, _si) =
 getDescCommands :: Scenario -> Set Const
 getDescCommands s = S.fromList $ concatMap filterConst allCode
  where
-  goalTextParagraphs = concatMap (view objectiveGoal) $ view scenarioObjectives s
+  goalTextParagraphs = view objectiveGoal <$> view scenarioObjectives s
   allCode = concatMap findCode goalTextParagraphs
   filterConst :: Syntax -> [Const]
   filterConst sx = mapMaybe toConst $ universe (sx ^. sTerm)

src/Swarm/Game/Entity.hs

@@ -110,7 +110,7 @@ import Swarm.Game.Location
 import Swarm.Game.ResourceLoading (getDataFileNameSafe)
 import Swarm.Language.Capability
 import Swarm.Language.Syntax (Syntax)
-import Swarm.Language.Text.Markdown (Document, toText)
+import Swarm.Language.Text.Markdown (Document, docToText)
 import Swarm.Util (binTuples, failT, findDup, plural, (?))
 import Swarm.Util.Effect (withThrow)
 import Swarm.Util.Yaml
@@ -248,7 +248,7 @@ instance Hashable Entity where
       `hashWithSalt` disp
       `hashWithSalt` nm
       `hashWithSalt` pl
-      `hashWithSalt` toText descr
+      `hashWithSalt` docToText descr
       `hashWithSalt` orient
       `hashWithSalt` grow
       `hashWithSalt` yld

src/Swarm/Game/Scenario/Objective.hs

@@ -66,7 +66,7 @@ instance FromJSON PrerequisiteConfig where
 -- | An objective is a condition to be achieved by a player in a
 --   scenario.
 data Objective = Objective
-  { _objectiveGoal :: [Markdown.Document Syntax]
+  { _objectiveGoal :: Markdown.Document Syntax
   , _objectiveTeaser :: Maybe Text
   , _objectiveCondition :: ProcessedTerm
   , _objectiveId :: Maybe ObjectiveLabel
@@ -84,7 +84,7 @@ instance ToSample Objective where
 
 -- | An explanation of the goal of the objective, shown to the player
 --   during play.  It is represented as a list of paragraphs.
-objectiveGoal :: Lens' Objective [Markdown.Document Syntax]
+objectiveGoal :: Lens' Objective (Markdown.Document Syntax)
 
 -- | A very short (3-5 words) description of the goal for
 -- displaying on the left side of the Objectives modal.
@@ -122,7 +122,7 @@ objectiveAchievement :: Lens' Objective (Maybe AchievementInfo)
 instance FromJSON Objective where
   parseJSON = withObject "objective" $ \v ->
     Objective
-      <$> (v .:? "goal" .!= [])
+      <$> (v .:? "goal" .!= mempty)
       <*> (v .:? "teaser")
       <*> (v .: "condition")
       <*> (v .:? "id")

src/Swarm/Language/Text/Markdown.hs

@@ -21,6 +21,8 @@ module Swarm.Language.Text.Markdown (
   TxtAttr (..),
   fromTextM,
   fromText,
+  docToText,
+  docToMark,
 
   -- ** Token stream
   StreamNode' (..),
@@ -41,7 +43,6 @@ import Control.Lens ((%~), (&), _head, _last)
 import Control.Monad (void)
 import Data.Char (isSpace)
 import Data.Functor.Identity (Identity (..))
-import Data.List qualified as List
 import Data.List.Split (chop)
 import Data.Maybe (catMaybes)
 import Data.Set (Set)
@@ -55,7 +56,7 @@ import GHC.Exts qualified (IsList (..), IsString (..))
 import Swarm.Language.Module (moduleAST)
 import Swarm.Language.Parse (readTerm)
 import Swarm.Language.Pipeline (ProcessedTerm (..), processParsedTerm)
-import Swarm.Language.Pretty (prettyText, prettyTypeErrText)
+import Swarm.Language.Pretty (prettyText, prettyTypeErrText, PrettyPrec (..))
 import Swarm.Language.Syntax (Syntax)
 
 -- | The top-level markdown document.
@@ -187,7 +188,7 @@ instance ToJSON (Paragraph Syntax) where
   toJSON = String . toText
 
 instance ToJSON (Document Syntax) where
-  toJSON = String . toText
+  toJSON = String . docToMark
 
 instance FromJSON (Document Syntax) where
   parseJSON v = parseDoc v <|> parsePars v
@@ -223,6 +224,13 @@ fromTextPure t = do
 -- DIY STREAM
 --------------------------------------------------------------
 
+-- | Convert 'Document' to 'Text'.
+--
+-- Note that this will strip some markdown, emphasis and bold marks.
+-- If you want to get markdown again, use 'docToMark'.
+docToText :: PrettyPrec a => Document a -> Text
+docToText = T.intercalate "\n\n" . map toText . paragraphs
+
 -- | This is the naive and easy way to get text from markdown document.
 toText :: ToStream a => a -> Text
 toText = streamToText . toStream
@@ -234,7 +242,6 @@ data StreamNode' t
   = TextNode (Set TxtAttr) t
   | CodeNode t
   | RawNode String t
-  | ParagraphBreak
   deriving (Eq, Show, Functor)
 
 type StreamNode = StreamNode' Text
@@ -244,11 +251,8 @@ unStream = \case
   TextNode a t -> (TextNode a, t)
   CodeNode t -> (CodeNode, t)
   RawNode a t -> (RawNode a, t)
-  ParagraphBreak -> error "Logic error: Paragraph break can not be unstreamed!"
 
 -- | Get chunks of nodes not exceeding length and broken at word boundary.
---
--- The split will end when no more nodes (then words) can fit or on 'ParagraphBreak'.
 chunksOf :: Int -> [StreamNode] -> [[StreamNode]]
 chunksOf n = chop (splitter True n)
  where
@@ -257,7 +261,6 @@ chunksOf n = chop (splitter True n)
   splitter :: Bool -> Int -> [StreamNode] -> ([StreamNode], [StreamNode])
   splitter start i = \case
     [] -> ([], [])
-    (ParagraphBreak : ss) -> ([ParagraphBreak], ss)
     (tn : ss) ->
       let l = nodeLength tn
        in if l <= i
@@ -294,7 +297,6 @@ streamToText = T.concat . map nodeToText
     TextNode _a t -> t
     RawNode _s t -> t
     CodeNode stx -> stx
-    ParagraphBreak -> "\n\n"
 
 -- | Convert elements to one dimensional stream of nodes,
 -- that is easy to format and layout.
@@ -304,15 +306,36 @@ streamToText = T.concat . map nodeToText
 class ToStream a where
   toStream :: a -> [StreamNode]
 
-instance ToStream (Node Syntax) where
+instance PrettyPrec a => ToStream (Node a) where
   toStream = \case
-    LeafText a t -> TextNode a <$> T.lines t
-    LeafCode t -> CodeNode <$> T.lines (prettyText t)
-    LeafRaw s t -> RawNode s <$> T.lines t
-    LeafCodeBlock _i t -> ParagraphBreak : (CodeNode <$> T.lines (prettyText t)) <> [ParagraphBreak]
+    LeafText a t -> [TextNode a t]
+    LeafCode t -> [CodeNode (prettyText t)]
+    LeafRaw s t -> [RawNode s t]
+    LeafCodeBlock _i t -> [CodeNode (prettyText t)]
 
-instance ToStream (Paragraph Syntax) where
+instance PrettyPrec a => ToStream (Paragraph a) where
   toStream = concatMap toStream . nodes
 
-instance ToStream (Document Syntax) where
-  toStream = List.intercalate [ParagraphBreak] . map toStream . paragraphs
+--------------------------------------------------------------
+-- Markdown 
+--------------------------------------------------------------
+
+nodeToMark :: PrettyPrec a => Node a -> Text
+nodeToMark = \case
+  LeafText a t -> foldl attr t a
+  LeafRaw _ c -> wrap "`" c
+  LeafCode c -> wrap "`" (prettyText c)
+  LeafCodeBlock f c -> codeBlock f $ prettyText c
+ where
+  codeBlock f t = "```" <> T.pack f <> "\n" <> t <> "\n```"
+  wrap c t = c <> t <> c
+  attr t a = case a of
+    Emphasis -> wrap "_" t
+    Strong -> wrap "**" t
+
+paragraphToMark :: PrettyPrec a => Paragraph a -> Text
+paragraphToMark = foldMap nodeToMark . nodes
+
+-- | Convert 'Document' to markdown text.
+docToMark :: PrettyPrec a => Document a -> Text
+docToMark = T.intercalate "\n\n" . map paragraphToMark . paragraphs

src/Swarm/TUI/View/Objective.hs

@@ -15,7 +15,6 @@ import Control.Lens hiding (Const, from)
 import Data.List (intercalate)
 import Data.List.NonEmpty qualified as NE
 import Data.Map.Strict qualified as M
-import Data.Maybe (listToMaybe)
 import Data.Vector qualified as V
 import Swarm.Game.Scenario.Objective
 import Swarm.Language.Text.Markdown qualified as Markdown
@@ -88,11 +87,11 @@ drawGoalListItem _isSelected e = case e of
   Header gs -> withAttr boldAttr $ str $ show gs
   Goal gs obj -> getCompletionIcon obj gs <+> titleWidget
    where
-    textSource = obj ^. objectiveTeaser <|> obj ^. objectiveId <|> listToMaybe (Markdown.toText <$> obj ^. objectiveGoal)
+    textSource = obj ^. objectiveTeaser <|> obj ^. objectiveId <|> Just (Markdown.docToText $ obj ^. objectiveGoal)
     titleWidget = maybe (txt "?") (withEllipsis End) textSource
 
 singleGoalDetails :: GoalEntry -> Widget Name
 singleGoalDetails = \case
-  Goal _gs obj -> layoutParagraphs $ drawMarkdown <$> obj ^. objectiveGoal
+  Goal _gs obj -> drawMarkdown $ obj ^. objectiveGoal
   -- Only Goal entries are selectable, so we should never see this:
   _ -> emptyWidget

src/Swarm/TUI/View/Util.hs

@@ -124,14 +124,13 @@ drawMarkdown d = do
   Widget Greedy Fixed $ do
     ctx <- getContext
     let w = ctx ^. availWidthL
-    let docLines = Markdown.chunksOf w $ Markdown.toStream d
-    render $ vBox $ map (hBox . map mTxt) docLines
+    let docLines = Markdown.chunksOf w . Markdown.toStream <$> Markdown.paragraphs d
+    render . layoutParagraphs $ vBox . map (hBox . map mTxt) <$> docLines
  where
   mTxt = \case
     Markdown.TextNode as t -> foldr applyAttr (txt t) as
     Markdown.CodeNode t -> withAttr highlightAttr $ txt t
     Markdown.RawNode _f t -> withAttr highlightAttr $ txt t
-    Markdown.ParagraphBreak -> txt ""
   applyAttr a = withAttr $ case a of
     Markdown.Strong -> boldAttr
     Markdown.Emphasis -> italicAttr