Merge branch 'main' into move_wall

app/game/Swarm/App.hs

@@ -32,10 +32,10 @@ import Data.Text.IO qualified as T
 import GitHash (GitInfo)
 import Graphics.Vty qualified as V
 import Graphics.Vty.CrossPlatform qualified as V
-import Swarm.Game.Failure (SystemFailure)
+import Swarm.Failure (SystemFailure)
 import Swarm.Game.State.Runtime
-import Swarm.Language.Pretty (prettyText)
 import Swarm.Log (LogSource (SystemLog), Severity (..))
+import Swarm.Pretty (prettyText)
 import Swarm.TUI.Controller
 import Swarm.TUI.Model
 import Swarm.TUI.Model.StateUpdate

src/swarm-doc/Swarm/Doc/Command.hs

@@ -12,7 +12,6 @@ import Data.Set qualified as Set
 import GHC.Generics (Generic)
 import Servant.Docs qualified as SD
 import Swarm.Doc.Util
-import Swarm.Language.Pretty (unchainFun)
 import Swarm.Language.Syntax
 import Swarm.Language.Syntax.CommandMetadata
 import Swarm.Language.Typecheck (inferConst)

src/swarm-doc/Swarm/Doc/Gen.hs

@@ -44,9 +44,9 @@ import Swarm.Doc.Keyword
 import Swarm.Doc.Pedagogy
 import Swarm.Doc.Util
 import Swarm.Doc.Wiki.Cheatsheet
+import Swarm.Failure (simpleErrorHandle)
 import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityName, entityYields)
 import Swarm.Game.Entity qualified as E
-import Swarm.Game.Failure (simpleErrorHandle)
 import Swarm.Game.Land
 import Swarm.Game.Recipe (Recipe, recipeCatalysts, recipeInputs, recipeOutputs)
 import Swarm.Game.Robot (Robot, equippedDevices, robotInventory)

src/swarm-doc/Swarm/Doc/Pedagogy.hs

@@ -31,7 +31,7 @@ import Data.Set qualified as S
 import Data.Text (Text)
 import Data.Text qualified as T
 import Swarm.Constant
-import Swarm.Game.Failure (SystemFailure, simpleErrorHandle)
+import Swarm.Failure (SystemFailure, simpleErrorHandle)
 import Swarm.Game.Land
 import Swarm.Game.Scenario (
   Scenario,

src/swarm-doc/Swarm/Doc/Util.hs

@@ -12,7 +12,7 @@ import Control.Lens (view)
 import Data.Maybe (listToMaybe)
 import Data.Text (Text)
 import Data.Text qualified as T
-import Swarm.Game.Failure (SystemFailure (CustomFailure))
+import Swarm.Failure (SystemFailure (CustomFailure))
 import Swarm.Game.Robot (Robot)
 import Swarm.Game.Robot.Concrete (instantiateRobot)
 import Swarm.Game.Scenario (ScenarioLandscape, scenarioRobots)

src/swarm-doc/Swarm/Doc/Wiki/Cheatsheet.hs

@@ -28,20 +28,20 @@ import Swarm.Doc.Schema.Render
 import Swarm.Doc.Util
 import Swarm.Doc.Wiki.Matrix
 import Swarm.Doc.Wiki.Util
+import Swarm.Failure (simpleErrorHandle)
 import Swarm.Game.Device qualified as D
 import Swarm.Game.Display (displayChar)
 import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityDisplay, entityName, loadEntities)
 import Swarm.Game.Entity qualified as E
-import Swarm.Game.Failure (simpleErrorHandle)
 import Swarm.Game.Recipe (Recipe, loadRecipes, recipeCatalysts, recipeInputs, recipeOutputs, recipeTime, recipeWeight)
 import Swarm.Game.Terrain (loadTerrain, terrainByName)
 import Swarm.Language.Capability (Capability)
 import Swarm.Language.Capability qualified as Capability
-import Swarm.Language.Pretty (prettyText, prettyTextLine)
 import Swarm.Language.Syntax (Const (..))
 import Swarm.Language.Syntax qualified as Syntax
 import Swarm.Language.Text.Markdown as Markdown (docToMark)
 import Swarm.Language.Typecheck (inferConst)
+import Swarm.Pretty (prettyText, prettyTextLine)
 import Swarm.Util (maximum0, showT)
 
 -- * Types

src/swarm-engine/Swarm/Game/Achievement/Persistence.hs

@@ -13,9 +13,9 @@ import Control.Effect.Lift
 import Control.Monad (forM_)
 import Data.Sequence (Seq)
 import Data.Yaml qualified as Y
+import Swarm.Failure
 import Swarm.Game.Achievement.Attainment
 import Swarm.Game.Achievement.Definitions
-import Swarm.Game.Failure
 import Swarm.Game.ResourceLoading (getSwarmAchievementsPath)
 import Swarm.Util.Effect (forMW)
 import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)

src/swarm-engine/Swarm/Game/CESK.hs

@@ -94,11 +94,11 @@ import Swarm.Game.Tick
 import Swarm.Game.World (WorldUpdate (..))
 import Swarm.Language.Context
 import Swarm.Language.Elaborate (insertSuspend)
-import Swarm.Language.Pretty
 import Swarm.Language.Requirements.Type (Requirements)
 import Swarm.Language.Syntax
 import Swarm.Language.Types
 import Swarm.Language.Value as V
+import Swarm.Pretty (PrettyPrec (..), pparens, ppr)
 import Swarm.Util.JSON (optionsMinimize)
 
 ------------------------------------------------------------

src/swarm-engine/Swarm/Game/Exception.hs

@@ -30,10 +30,10 @@ import Swarm.Game.Achievement.Definitions
 import Swarm.Game.Entity (EntityMap, devicesForCap, entityName)
 import Swarm.Language.Capability (Capability (CGod), capabilityName)
 import Swarm.Language.JSON ()
-import Swarm.Language.Pretty (prettyText)
 import Swarm.Language.Requirements.Type (Requirements (..))
 import Swarm.Language.Syntax (Const, Term)
 import Swarm.Log (Severity (..))
+import Swarm.Pretty (prettyText)
 import Swarm.Util
 import Witch (from)
 
@@ -139,7 +139,7 @@ formatIncapableFix = \case
 -- >>> import Data.Either (fromRight)
 -- >>> import Control.Carrier.Throw.Either (runThrow)
 -- >>> import Control.Algebra (run)
--- >>> import Swarm.Game.Failure (LoadingFailure)
+-- >>> import Swarm.Failure (LoadingFailure)
 -- >>> import qualified Data.Set as S
 -- >>> :set -XTypeApplications
 -- >>> w = mkEntity (defaultEntityDisplay 'l') "magic wand" mempty mempty (S.singleton $ CExecute Appear)

src/swarm-engine/Swarm/Game/ScenarioInfo.hs

@@ -56,7 +56,7 @@ import Data.Sequence (Seq)
 import Data.Sequence qualified as Seq
 import Data.Text (Text)
 import Data.Yaml as Y
-import Swarm.Game.Failure
+import Swarm.Failure
 import Swarm.Game.ResourceLoading (getDataDirSafe, getSwarmSavePath)
 import Swarm.Game.Scenario
 import Swarm.Game.Scenario.Scoring.CodeSize

src/swarm-engine/Swarm/Game/State.hs

@@ -98,9 +98,9 @@ import Data.Text.Lazy qualified as TL
 import Data.Text.Lazy.Encoding qualified as TL
 import Data.Tuple (swap)
 import GHC.Generics (Generic)
+import Swarm.Failure (SystemFailure (..))
 import Swarm.Game.CESK (Store, emptyStore, store, suspendedEnv)
 import Swarm.Game.Entity
-import Swarm.Game.Failure (SystemFailure (..))
 import Swarm.Game.Land
 import Swarm.Game.Location
 import Swarm.Game.Robot

src/swarm-engine/Swarm/Game/State/Runtime.hs

@@ -32,7 +32,7 @@ import Control.Lens
 import Data.Map (Map)
 import Data.Sequence (Seq)
 import Data.Text (Text)
-import Swarm.Game.Failure (SystemFailure)
+import Swarm.Failure (SystemFailure)
 import Swarm.Game.Land
 import Swarm.Game.Recipe (loadRecipes)
 import Swarm.Game.ResourceLoading (initNameGenerator, readAppData)

src/swarm-engine/Swarm/Game/Step.hs

@@ -65,12 +65,12 @@ import Swarm.Game.Step.Util
 import Swarm.Game.Step.Util.Command
 import Swarm.Game.Tick
 import Swarm.Language.Capability
-import Swarm.Language.Pretty (BulletList (BulletList, bulletListItems), prettyText)
 import Swarm.Language.Requirements qualified as R
 import Swarm.Language.Syntax
 import Swarm.Language.Typed (Typed (..))
 import Swarm.Language.Value
 import Swarm.Log
+import Swarm.Pretty (BulletList (BulletList, bulletListItems), prettyText)
 import Swarm.Util hiding (both)
 import Swarm.Util.WindowedCounter qualified as WC
 import System.Clock (TimeSpec)

src/swarm-engine/Swarm/Game/Step/Const.hs

@@ -45,13 +45,13 @@ import Data.Text qualified as T
 import Data.Tuple (swap)
 import Linear (V2 (..), perp, zero)
 import Swarm.Effect as Effect (Time, getNow)
+import Swarm.Failure
 import Swarm.Game.Achievement.Definitions
 import Swarm.Game.CESK
 import Swarm.Game.Display
 import Swarm.Game.Entity hiding (empty, lookup, singleton, union)
 import Swarm.Game.Entity qualified as E
 import Swarm.Game.Exception
-import Swarm.Game.Failure
 import Swarm.Game.Land
 import Swarm.Game.Location
 import Swarm.Game.Recipe
@@ -88,13 +88,13 @@ import Swarm.Game.Value
 import Swarm.Language.Capability
 import Swarm.Language.Key (parseKeyComboFull)
 import Swarm.Language.Pipeline
-import Swarm.Language.Pretty (prettyText)
 import Swarm.Language.Requirements qualified as R
 import Swarm.Language.Syntax
 import Swarm.Language.Syntax.Direction
 import Swarm.Language.Text.Markdown qualified as Markdown
 import Swarm.Language.Value
 import Swarm.Log
+import Swarm.Pretty (prettyText)
 import Swarm.Util hiding (both)
 import Swarm.Util.Effect (throwToMaybe)
 import Swarm.Util.Lens (inherit)

src/swarm-lang/Swarm/Effect/Unify.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 -- |
 -- SPDX-License-Identifier: BSD-3-Clause
@@ -13,7 +14,9 @@ module Swarm.Effect.Unify where
 import Control.Algebra
 import Data.Kind (Type)
 import Data.Set (Set)
+import Prettyprinter
 import Swarm.Language.Types hiding (Type)
+import Swarm.Pretty (PrettyPrec (..), ppr, reportBug)
 
 -- | Data type representing available unification operations.
 data Unification (m :: Type -> Type) k where
@@ -56,3 +59,20 @@ data UnificationError where
   --   should never happen.
   UnexpandedRecTy :: TypeF UType -> UnificationError
   deriving (Show)
+
+instance PrettyPrec UnificationError where
+  prettyPrec _ = \case
+    Infinite x uty ->
+      vsep
+        [ "Encountered infinite type" <+> ppr x <+> "=" <+> ppr uty <> "."
+        , "Swarm will not infer recursive types; if you want a recursive type, add an explicit type annotation."
+        ]
+    UnifyErr ty1 ty2 ->
+      "Can't unify" <+> ppr ty1 <+> "and" <+> ppr ty2
+    UndefinedUserType ty ->
+      "Undefined user type" <+> ppr ty
+    UnexpandedRecTy ty ->
+      vsep
+        [ "Unexpanded recursive type" <+> ppr ty <+> "encountered in unifyF."
+        , reportBug
+        ]

src/swarm-lang/Swarm/Language/Capability.hs

@@ -33,8 +33,10 @@ import Data.Tuple (swap)
 import Data.Yaml
 import GHC.Generics (Generic)
 import Generic.Data (FiniteEnumeration (..))
+import Prettyprinter (pretty)
 import Swarm.Language.Syntax.Constants (Const (..), allConst, constInfo, syntax)
-import Swarm.Util (binTuples, failT)
+import Swarm.Pretty (PrettyPrec (..))
+import Swarm.Util (binTuples, failT, showEnum)
 import Witch (from)
 import Prelude hiding (lookup)
 
@@ -73,6 +75,9 @@ data Capability
   deriving (Eq, Ord, Show, Generic, Hashable, Data, FromJSONKey, ToJSONKey)
   deriving (Enum, Bounded) via (FiniteEnumeration Capability)
 
+instance PrettyPrec Capability where
+  prettyPrec _ c = pretty $ T.toLower (from (NE.tail $ showEnum c))
+
 -- | Get the name of the capability for use in UI and YAML.
 capabilityName :: Capability -> Text
 capabilityName = \case

src/swarm-lang/Swarm/Language/Context.hs

@@ -1,4 +1,7 @@
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- |
 -- SPDX-License-Identifier: BSD-3-Clause
@@ -9,14 +12,16 @@ module Swarm.Language.Context where
 
 import Control.Algebra (Has)
 import Control.Effect.Reader (Reader, ask, local)
-import Control.Lens.Empty (AsEmpty (..))
+import Control.Lens.Empty (AsEmpty (..), pattern Empty)
 import Control.Lens.Prism (prism)
 import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON)
 import Data.Data (Data)
 import Data.Map (Map)
 import Data.Map qualified as M
 import Data.Text (Text)
 import GHC.Generics (Generic)
+import Prettyprinter (brackets, emptyDoc, hsep, punctuate)
+import Swarm.Pretty (PrettyPrec (..), prettyBinding)
 import Swarm.Util.JSON (optionsUnwrapUnary)
 import Prelude hiding (lookup)
 
@@ -33,6 +38,10 @@ instance ToJSON t => ToJSON (Ctx t) where
 instance FromJSON t => FromJSON (Ctx t) where
   parseJSON = genericParseJSON optionsUnwrapUnary
 
+instance (PrettyPrec t) => PrettyPrec (Ctx t) where
+  prettyPrec _ Empty = emptyDoc
+  prettyPrec _ (assocs -> bs) = brackets (hsep (punctuate "," (map prettyBinding bs)))
+
 -- | The semigroup operation for contexts is /right/-biased union.
 instance Semigroup (Ctx t) where
   (<>) = union

src/swarm-lang/Swarm/Language/Format.hs

@@ -15,7 +15,7 @@ import Prettyprinter
 import Prettyprinter.Render.Text qualified as RT
 import Swarm.Language.Parser (readTerm')
 import Swarm.Language.Parser.Core (LanguageVersion, defaultParserConfig, languageVersion)
-import Swarm.Language.Pretty
+import Swarm.Pretty (ppr)
 import Swarm.Util ((?))
 import System.Console.Terminal.Size qualified as Term
 import System.Exit (exitFailure)

src/swarm-lang/Swarm/Language/JSON.hs

@@ -11,10 +11,10 @@ module Swarm.Language.JSON where
 import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON, withText)
 import Data.Aeson qualified as Ae
 import Swarm.Language.Pipeline (processTermEither)
-import Swarm.Language.Pretty (prettyText)
 import Swarm.Language.Syntax (Term)
 import Swarm.Language.Syntax.Pattern (Syntax, TSyntax)
 import Swarm.Language.Value (Env, Value)
+import Swarm.Pretty (prettyText)
 import Swarm.Util.JSON (optionsMinimize)
 import Witch (into)
 

src/swarm-lang/Swarm/Language/Kindcheck.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 -- |
 -- SPDX-License-Identifier: BSD-3-Clause
 --
@@ -13,7 +15,10 @@ import Control.Effect.Reader (Reader, ask)
 import Control.Effect.Throw (Throw, throwError)
 import Control.Monad.Extra (unlessM)
 import Data.Fix (Fix (..))
+import Prettyprinter (hsep, nest, pretty, vsep, (<+>))
 import Swarm.Language.Types
+import Swarm.Pretty (PrettyPrec (..), ppr)
+import Swarm.Util (number)
 
 -- | Kind checking errors that can occur.
 data KindError
@@ -30,6 +35,34 @@ data KindError
     VacuousRecTy Var Type
   deriving (Eq, Show)
 
+instance PrettyPrec KindError where
+  prettyPrec _ = \case
+    ArityMismatch c a tys ->
+      nest 2 . vsep $
+        [ "Kind error:"
+        , hsep
+            [ ppr c
+            , "requires"
+            , pretty a
+            , "type"
+            , pretty (number a "argument" <> ",")
+            , "but was given"
+            , pretty (length tys)
+            ]
+        ]
+          ++ ["in the type:" <+> ppr (TyConApp c tys) | not (null tys)]
+    UndefinedTyCon tc _ty -> "Undefined type" <+> ppr tc
+    TrivialRecTy x ty ->
+      nest 2 . vsep $
+        [ "Encountered trivial recursive type" <+> ppr (TyRec x ty)
+        , "Did you forget to use" <+> pretty x <+> "in the body of the type?"
+        ]
+    VacuousRecTy x ty ->
+      nest 2 . vsep $
+        [ "Encountered vacuous recursive type" <+> ppr (TyRec x ty)
+        , "Recursive types must be productive, i.e. must not expand to themselves."
+        ]
+
 -- | Check that a polytype is well-kinded.
 checkPolytypeKind :: (Has (Reader TDCtx) sig m, Has (Throw KindError) sig m) => Polytype -> m TydefInfo
 checkPolytypeKind pty@(Forall xs t) = TydefInfo pty (Arity $ length xs) <$ checkKind t

src/swarm-lang/Swarm/Language/LSP.hs

@@ -26,9 +26,9 @@ import Swarm.Language.Parser (readTerm')
 import Swarm.Language.Parser.Core (defaultParserConfig)
 import Swarm.Language.Parser.Util (getLocRange, showErrorPos)
 import Swarm.Language.Pipeline (processParsedTerm')
-import Swarm.Language.Pretty (prettyText)
 import Swarm.Language.Syntax (SrcLoc (..))
 import Swarm.Language.Typecheck (ContextualTypeErr (..))
+import Swarm.Pretty (prettyText)
 import System.IO (stderr)
 import Witch
 

src/swarm-lang/Swarm/Language/LSP/Hover.hs

@@ -34,10 +34,10 @@ import Swarm.Language.Context as Ctx
 import Swarm.Language.Parser (readTerm')
 import Swarm.Language.Parser.Core (defaultParserConfig)
 import Swarm.Language.Pipeline (processParsedTerm)
-import Swarm.Language.Pretty (prettyText, prettyTextLine)
 import Swarm.Language.Syntax
 import Swarm.Language.Typecheck (inferConst)
 import Swarm.Language.Types
+import Swarm.Pretty (prettyText, prettyTextLine)
 import Swarm.Util qualified as U
 
 withinBound :: Int -> SrcLoc -> Bool

src/swarm-lang/Swarm/Language/Pipeline.hs

@@ -28,7 +28,6 @@ import Data.Text qualified as T
 import Swarm.Language.Context qualified as Ctx
 import Swarm.Language.Elaborate
 import Swarm.Language.Parser (readTerm)
-import Swarm.Language.Pretty
 import Swarm.Language.Requirements.Type (ReqCtx)
 import Swarm.Language.Syntax
 import Swarm.Language.Typecheck