diff --git a/data/entities.yaml b/data/entities.yaml index 92f5a246a..6aef51385 100644 --- a/data/entities.yaml +++ b/data/entities.yaml @@ -794,18 +794,16 @@ - Equipping treads on a robot allows it to move and turn. - The `move` command moves the robot forward one unit. - | - Example: - ``` - move; move; // move two units - ``` + For example to move two units: + - | + `move; move;` - The `turn` command takes a direction as an argument, which can be either absolute (north, west, east, south) or relative (left, right, forward, back, down). - | Example: - ``` - move; turn left; move; turn right - ``` + - | + `move; turn left; move; turn right` capabilities: [move, turn] properties: [portable] @@ -1229,16 +1227,15 @@ description: - | A compass gives a robot the ability to orient using the cardinal - directions north, south, west, and east; for example, `turn west; - move; turn north`. + directions north, south, west, and east. For example: + - | + `turn west; move; turn north` - | It also enables the `heading : cmd dir` command, which returns the robot's current heading. For example, the following code moves east and then restores the same heading as before: - | - ``` - d <- heading; turn east; move; turn d - ``` + `d <- heading; turn east; move; turn d` properties: [portable] capabilities: [orient] diff --git a/src/Swarm/Language/Pretty.hs b/src/Swarm/Language/Pretty.hs index 447881343..05bd3cc79 100644 --- a/src/Swarm/Language/Pretty.hs +++ b/src/Swarm/Language/Pretty.hs @@ -61,14 +61,18 @@ prettyString :: (PrettyPrec a) => a -> String prettyString = docToString . ppr -- | Optionally surround a document with parentheses depending on the --- @Bool@ argument. +-- @Bool@ argument and if it does not fit on line, indent the lines, +-- with the parens on separate lines. pparens :: Bool -> Doc ann -> Doc ann -pparens True = parens +pparens True = group . encloseWithIndent 2 lparen rparen pparens False = id +encloseWithIndent :: Int -> Doc ann -> Doc ann -> Doc ann -> Doc ann +encloseWithIndent i l r = nest i . enclose (l <> line') (nest (-2) $ line' <> r) + -- | Surround a document with backticks. bquote :: Doc ann -> Doc ann -bquote d = "`" <> d <> "`" +bquote = group . enclose "`" "`" -- | Turn a 'Show' instance into a @Doc@, lowercasing it in the -- process. @@ -78,6 +82,8 @@ prettyShowLow = pretty . showLowT -------------------------------------------------- -- Bullet lists +data Prec a = Prec Int a + data BulletList i = BulletList { bulletListHeader :: forall a. Doc a , bulletListItems :: [i] @@ -180,10 +186,9 @@ instance PrettyPrec Term where prettyPrec p (TRequire n e) = pparens (p > 10) $ "require" <+> pretty n <+> ppr @Term (TText e) prettyPrec p (TRequirements _ e) = pparens (p > 10) $ "requirements" <+> ppr e prettyPrec _ (TVar s) = pretty s - prettyPrec _ (TDelay _ t) = braces $ ppr t + prettyPrec _ (TDelay _ t) = group . encloseWithIndent 2 lbrace rbrace $ ppr t prettyPrec _ t@TPair {} = prettyTuple t - prettyPrec _ (TLam x mty body) = - "\\" <> pretty x <> maybe "" ((":" <>) . ppr) mty <> "." <+> ppr body + prettyPrec _ t@(TLam {}) = prettyLambdas t -- Special handling of infix operators - ((+) 2) 3 --> 2 + 3 prettyPrec p (TApp t@(TApp (TConst c) l) r) = let ci = constInfo c @@ -207,21 +212,33 @@ instance PrettyPrec Term where _ -> prettyPrecApp p t1 t2 _ -> prettyPrecApp p t1 t2 prettyPrec _ (TLet _ x mty t1 t2) = - hsep $ - ["let", pretty x] - ++ maybe [] (\ty -> [":", ppr ty]) mty - ++ ["=", ppr t1, "in", ppr t2] + group . vsep $ + [ hsep $ + ["let", pretty x] + ++ maybe [] (\ty -> [":", ppr ty]) mty + ++ ["=", ppr t1, "in"] + , ppr t2 + ] prettyPrec _ (TDef _ x mty t1) = - hsep $ - ["def", pretty x] - ++ maybe [] (\ty -> [":", ppr ty]) mty - ++ ["=", ppr t1, "end"] + let (t1rest, t1lams) = unchainLambdas t1 + in group . vsep $ + [ nest 2 $ + vsep + [ hsep $ + ["def", pretty x] + ++ maybe [] (\ty -> [":", ppr ty]) mty + ++ ["="] + ++ map prettyLambda t1lams + , ppr t1rest + ] + , "end" + ] prettyPrec p (TBind Nothing t1 t2) = pparens (p > 0) $ - prettyPrec 1 t1 <> ";" <+> prettyPrec 0 t2 + prettyPrec 1 t1 <> ";" <> line <> prettyPrec 0 t2 prettyPrec p (TBind (Just x) t1 t2) = pparens (p > 0) $ - pretty x <+> "<-" <+> prettyPrec 1 t1 <> ";" <+> prettyPrec 0 t2 + pretty x <+> "<-" <+> prettyPrec 1 t1 <> ";" <> line <> prettyPrec 0 t2 prettyPrec _ (TRcd m) = brackets $ hsep (punctuate "," (map prettyEquality (M.assocs m))) prettyPrec _ (TProj t x) = prettyPrec 11 t <> "." <> pretty x prettyPrec p (TAnnotate t pt) = @@ -233,7 +250,7 @@ prettyEquality (x, Nothing) = pretty x prettyEquality (x, Just t) = pretty x <+> "=" <+> ppr t prettyTuple :: Term -> Doc a -prettyTuple = pparens True . hsep . punctuate "," . map ppr . unnestTuple +prettyTuple = tupled . map ppr . unnestTuple where unnestTuple (TPair t1 t2) = t1 : unnestTuple t2 unnestTuple t = [t] @@ -249,6 +266,19 @@ appliedTermPrec (TApp f _) = case f of _ -> appliedTermPrec f appliedTermPrec _ = 10 +prettyLambdas :: Term -> Doc a +prettyLambdas t = hsep (prettyLambda <$> lms) <> softline <> ppr rest + where + (rest, lms) = unchainLambdas t + +unchainLambdas :: Term -> (Term, [(Var, Maybe Type)]) +unchainLambdas = \case + TLam x mty body -> ((x, mty) :) <$> unchainLambdas body + body -> (body, []) + +prettyLambda :: (Pretty a1, PrettyPrec a2) => (a1, Maybe a2) -> Doc ann +prettyLambda (x, mty) = "\\" <> pretty x <> maybe "" ((":" <>) . ppr) mty <> "." + ------------------------------------------------------------ -- Error messages @@ -271,37 +301,42 @@ prettyTypeErr code (CTE l tcStack te) = showLoc (r, c) = pretty r <> ":" <> pretty c instance PrettyPrec TypeErr where - prettyPrec _ (UnifyErr ty1 ty2) = - "Can't unify" <+> ppr ty1 <+> "and" <+> ppr ty2 - prettyPrec _ (Mismatch Nothing (getJoin -> (ty1, ty2))) = - "Type mismatch: expected" <+> ppr ty1 <> ", but got" <+> ppr ty2 - prettyPrec _ (Mismatch (Just t) (getJoin -> (ty1, ty2))) = - nest 2 . vcat $ - [ "Type mismatch:" - , "From context, expected" <+> bquote (ppr t) <+> "to" <+> typeDescription Expected ty1 <> "," - , "but it" <+> typeDescription Actual ty2 - ] - prettyPrec _ (LambdaArgMismatch (getJoin -> (ty1, ty2))) = - "Lambda argument has type annotation" <+> bquote (ppr ty2) <> ", but expected argument type" <+> bquote (ppr ty1) - prettyPrec _ (FieldsMismatch (getJoin -> (expFs, actFs))) = fieldMismatchMsg expFs actFs - prettyPrec _ (EscapedSkolem x) = - "Skolem variable" <+> pretty x <+> "would escape its scope" - prettyPrec _ (UnboundVar x) = - "Unbound variable" <+> pretty x - prettyPrec _ (Infinite x uty) = - "Infinite type:" <+> ppr x <+> "=" <+> ppr uty - prettyPrec _ (DefNotTopLevel t) = - "Definitions may only be at the top level:" <+> ppr t - prettyPrec _ (CantInfer t) = - "Couldn't infer the type of term (this shouldn't happen; please report this as a bug!):" <+> ppr t - prettyPrec _ (CantInferProj t) = - "Can't infer the type of a record projection:" <+> ppr t - prettyPrec _ (UnknownProj x t) = - "Record does not have a field with name" <+> pretty x <> ":" <+> ppr t - prettyPrec _ (InvalidAtomic reason t) = - "Invalid atomic block:" <+> ppr reason <> ":" <+> ppr t - prettyPrec _ Impredicative = - "Unconstrained unification type variables encountered, likely due to an impredicative type. This is a known bug; for more information see https://github.com/swarm-game/swarm/issues/351 ." + prettyPrec _ = \case + UnifyErr ty1 ty2 -> + "Can't unify" <+> ppr ty1 <+> "and" <+> ppr ty2 + Mismatch Nothing (getJoin -> (ty1, ty2)) -> + "Type mismatch: expected" <+> ppr ty1 <> ", but got" <+> ppr ty2 + Mismatch (Just t) (getJoin -> (ty1, ty2)) -> + nest 2 . vcat $ + [ "Type mismatch:" + , "From context, expected" <+> pprCode t <+> "to" <+> typeDescription Expected ty1 <> "," + , "but it" <+> typeDescription Actual ty2 + ] + LambdaArgMismatch (getJoin -> (ty1, ty2)) -> + "Lambda argument has type annotation" <+> pprCode ty2 <> ", but expected argument type" <+> pprCode ty1 + FieldsMismatch (getJoin -> (expFs, actFs)) -> + fieldMismatchMsg expFs actFs + EscapedSkolem x -> + "Skolem variable" <+> pretty x <+> "would escape its scope" + UnboundVar x -> + "Unbound variable" <+> pretty x + Infinite x uty -> + "Infinite type:" <+> ppr x <+> "=" <+> ppr uty + DefNotTopLevel t -> + "Definitions may only be at the top level:" <+> pprCode t + CantInfer t -> + "Couldn't infer the type of term (this shouldn't happen; please report this as a bug!):" <+> pprCode t + CantInferProj t -> + "Can't infer the type of a record projection:" <+> pprCode t + UnknownProj x t -> + "Record does not have a field with name" <+> pretty x <> ":" <+> pprCode t + InvalidAtomic reason t -> + "Invalid atomic block:" <+> ppr reason <> ":" <+> pprCode t + Impredicative -> + "Unconstrained unification type variables encountered, likely due to an impredicative type. This is a known bug; for more information see https://github.com/swarm-game/swarm/issues/351 ." + where + pprCode :: PrettyPrec a => a -> Doc ann + pprCode = bquote . ppr -- | Given a type and its source, construct an appropriate description -- of it to go in a type mismatch error message. diff --git a/src/Swarm/Language/Text/Markdown.hs b/src/Swarm/Language/Text/Markdown.hs index e75d797e9..21e951d03 100644 --- a/src/Swarm/Language/Text/Markdown.hs +++ b/src/Swarm/Language/Text/Markdown.hs @@ -53,10 +53,12 @@ import Data.Tuple.Extra (both, first) import Data.Vector (toList) import Data.Yaml import GHC.Exts qualified (IsList (..), IsString (..)) +import Prettyprinter (LayoutOptions (..), PageWidth (..), group, layoutPretty) +import Prettyprinter.Render.Text qualified as RT import Swarm.Language.Module (moduleAST) import Swarm.Language.Parse (readTerm) import Swarm.Language.Pipeline (ProcessedTerm (..), processParsedTerm) -import Swarm.Language.Pretty (PrettyPrec (..), prettyText, prettyTypeErrText) +import Swarm.Language.Pretty (PrettyPrec (..), ppr, prettyText, prettyTypeErrText) import Swarm.Language.Syntax (Syntax) -- | The top-level markdown document. @@ -309,9 +311,11 @@ class ToStream a where instance PrettyPrec a => ToStream (Node a) where toStream = \case LeafText a t -> [TextNode a t] - LeafCode t -> [CodeNode (prettyText t)] + LeafCode t -> [CodeNode (pprOneLine t)] LeafRaw s t -> [RawNode s t] LeafCodeBlock _i t -> [CodeNode (prettyText t)] + where + pprOneLine = RT.renderStrict . layoutPretty (LayoutOptions Unbounded) . group . ppr instance PrettyPrec a => ToStream (Paragraph a) where toStream = concatMap toStream . nodes diff --git a/test/unit/TestLanguagePipeline.hs b/test/unit/TestLanguagePipeline.hs index 15672e2ff..36425fb84 100644 --- a/test/unit/TestLanguagePipeline.hs +++ b/test/unit/TestLanguagePipeline.hs @@ -180,19 +180,19 @@ testLanguagePipeline = "atomic move+move" ( process "atomic (move; move)" - "1:8: Invalid atomic block: block could take too many ticks (2): move; move" + "1:8: Invalid atomic block: block could take too many ticks (2): `move; move`" ) , testCase "atomic lambda" ( process "atomic ((\\c. c;c) move)" - "1:9: Invalid atomic block: def, let, and lambda are not allowed: \\c. c; c" + "1:9: Invalid atomic block: def, let, and lambda are not allowed: `\\c. c; c`" ) , testCase "atomic non-simple" ( process "def dup = \\c. c; c end; atomic (dup (dup move))" - "1:33: Invalid atomic block: reference to variable with non-simple type ∀ a. cmd a -> cmd a: dup" + "1:33: Invalid atomic block: reference to variable with non-simple type ∀ a. cmd a -> cmd a: `dup`" ) , testCase "atomic nested" @@ -204,25 +204,25 @@ testLanguagePipeline = "atomic wait" ( process "atomic (wait 1)" - "1:9: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: wait" + "1:9: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: `wait`" ) , testCase "atomic make" ( process "atomic (make \"PhD thesis\")" - "1:9: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: make" + "1:9: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: `make`" ) , testCase "atomic drill" ( process "atomic (drill forward)" - "1:9: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: drill" + "1:9: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: `drill`" ) , testCase "atomic salvage" ( process "atomic (salvage)" - "1:8: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: salvage" + "1:8: Invalid atomic block: commands that can take multiple ticks to execute are not allowed: `salvage`" ) ] , testGroup @@ -396,7 +396,9 @@ testLanguagePipeline = process code expect = case processTerm code of Left e | not (T.null expect) && expect `T.isPrefixOf` e -> pure () - | otherwise -> error $ "Unexpected failure: " <> show e + | otherwise -> + error $ + "Unexpected failure:\n\n " <> show e <> "\n\nExpected:\n\n " <> show expect <> "\n" Right _ | expect == "" -> pure () | otherwise -> error "Unexpected success"