Nested sum type for directions (#949)

Code simplification, improved type safety (see [this comment](#876 (comment))).

This technique may also simplify the implementation of `CReverse` (see #950) if we choose to do so.

editors/emacs/swarm-mode.el

@@ -96,14 +96,14 @@
                "robotnamed"
                "robotnumbered"
                "knows"
-               "left"
-               "right"
-               "back"
-               "forward"
                "north"
                "south"
                "east"
                "west"
+               "left"
+               "right"
+               "back"
+               "forward"
                "down"
              ))
              (x-types '("int" "text" "dir" "bool" "cmd" "void" "unit" "actor"))

editors/vscode/syntaxes/swarm.tmLanguage.json

@@ -89,7 +89,7 @@
 			"patterns": [
 				{
 				"name": "variable.language.dir",
-				"match": "\\b(?i)(left|right|back|forward|north|south|east|west|down)\\b"
+				"match": "\\b(?i)(north|south|east|west|left|right|back|forward|down)\\b"
 				},
 				{
 				"name": "variable.parameter",

src/Swarm/Game/Display.hs

@@ -44,9 +44,9 @@ import Data.Map qualified as M
 import Data.Maybe (fromMaybe, isJust)
 import Data.Yaml
 import GHC.Generics (Generic)
-import Swarm.Language.Syntax (Direction (..))
+import Swarm.Language.Syntax (AbsoluteDir (..), Direction (..))
 import Swarm.TUI.Attr (entityAttr, robotAttr, worldPrefix)
-import Swarm.Util (maxOn, (?))
+import Swarm.Util (maxOn)
 import Swarm.Util.Yaml (FromJSONE (..), With (runE), getE, liftE, withObjectE)
 
 -- | Display priority.  Entities with higher priority will be drawn on
@@ -60,7 +60,7 @@ instance Hashable AttrName
 -- | A record explaining how to display an entity in the TUI.
 data Display = Display
   { _defaultChar :: Char
-  , _orientationMap :: Map Direction Char
+  , _orientationMap :: Map AbsoluteDir Char
   , _curOrientation :: Maybe Direction
   , _displayAttr :: AttrName
   , _displayPriority :: Priority
@@ -83,7 +83,7 @@ defaultChar :: Lens' Display Char
 --   optionally associates different display characters with
 --   different orientations.  If an orientation is not in the map,
 --   the 'defaultChar' will be used.
-orientationMap :: Lens' Display (Map Direction Char)
+orientationMap :: Lens' Display (Map AbsoluteDir Char)
 
 -- | The display caches the current orientation of the entity, so we
 --   know which character to use from the orientation map.
@@ -128,9 +128,9 @@ instance ToJSON Display where
 
 -- | Look up the character that should be used for a display.
 displayChar :: Display -> Char
-displayChar disp = case disp ^. curOrientation of
-  Nothing -> disp ^. defaultChar
-  Just dir -> M.lookup dir (disp ^. orientationMap) ? (disp ^. defaultChar)
+displayChar disp = fromMaybe (disp ^. defaultChar) $ do
+  DAbsolute d <- disp ^. curOrientation
+  M.lookup d (disp ^. orientationMap)
 
 -- | Render a display as a UI widget.
 renderDisplay :: Display -> Widget n

src/Swarm/Game/Step.hs

@@ -1011,9 +1011,9 @@ execConst c vs s k = do
         drill <- preferredDrill `isJustOr` Fatal "Drill is required but not installed?!"
 
         let directionText = case d of
-              DDown -> "under"
-              DForward -> "ahead of"
-              DBack -> "behind"
+              DRelative DDown -> "under"
+              DRelative DForward -> "ahead of"
+              DRelative DBack -> "behind"
               _ -> dirSyntax (dirInfo d) <> " of"
 
         (nextLoc, nextME) <- lookInDirection d

src/Swarm/Language/Syntax.hs

@@ -15,6 +15,8 @@
 module Swarm.Language.Syntax (
   -- * Directions
   Direction (..),
+  AbsoluteDir (..),
+  RelativeDir (..),
   DirInfo (..),
   applyTurn,
   toDirection,
@@ -71,13 +73,13 @@ module Swarm.Language.Syntax (
   mapFree1,
 ) where
 
+import Control.Arrow (Arrow ((&&&)))
 import Control.Lens (Plated (..), Traversal', (%~))
 import Data.Aeson.Types
 import Data.Data (Data)
 import Data.Data.Lens (uniplate)
 import Data.Hashable (Hashable)
 import Data.Map qualified as M
-import Data.Maybe (fromMaybe, isJust, mapMaybe)
 import Data.Set qualified as S
 import Data.String (IsString (fromString))
 import Data.Text hiding (filter, map)
@@ -93,50 +95,64 @@ import Witch.From (from)
 -- Constants
 ------------------------------------------------------------
 
--- | The type of directions. Used /e.g./ to indicate which way a robot
---   will turn.
-data Direction = DLeft | DRight | DBack | DForward | DNorth | DSouth | DEast | DWest | DDown
+data AbsoluteDir = DNorth | DSouth | DEast | DWest
   deriving (Eq, Ord, Show, Read, Generic, Data, Hashable, ToJSON, FromJSON, Enum, Bounded)
 
-instance ToJSONKey Direction where
+instance ToJSONKey AbsoluteDir where
   toJSONKey = genericToJSONKey defaultJSONKeyOptions
 
-instance FromJSONKey Direction where
+instance FromJSONKey AbsoluteDir where
   fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
 
+data RelativeDir = DLeft | DRight | DBack | DForward | DDown
+  deriving (Eq, Ord, Show, Read, Generic, Data, Hashable, ToJSON, FromJSON, Enum, Bounded)
+
+-- | The type of directions. Used /e.g./ to indicate which way a robot
+--   will turn.
+data Direction = DAbsolute AbsoluteDir | DRelative RelativeDir
+  deriving (Eq, Ord, Show, Read, Generic, Data, Hashable, ToJSON, FromJSON)
+
 data DirInfo = DirInfo
   { dirSyntax :: Text
-  , -- absolute direction if it exists
-    dirAbs :: Maybe Heading
-  , -- the turning for the direction
-    dirApplyTurn :: Heading -> Heading
+  , dirApplyTurn :: Heading -> Heading
+  -- ^ the turning for the direction
   }
 
 allDirs :: [Direction]
-allDirs = Util.listEnums
+allDirs = map DAbsolute Util.listEnums <> map DRelative Util.listEnums
+
+toHeading :: AbsoluteDir -> Heading
+toHeading = \case
+  DNorth -> north
+  DSouth -> south
+  DEast -> east
+  DWest -> west
 
 -- | Information about all directions
 dirInfo :: Direction -> DirInfo
 dirInfo d = case d of
-  DLeft -> relative (\(V2 x y) -> V2 (-y) x)
-  DRight -> relative (\(V2 x y) -> V2 y (-x))
-  DBack -> relative (\(V2 x y) -> V2 (-x) (-y))
-  DDown -> relative (const down)
-  DForward -> relative id
-  DNorth -> cardinal north
-  DSouth -> cardinal south
-  DEast -> cardinal east
-  DWest -> cardinal west
+  DRelative e -> case e of
+    DLeft -> relative (\(V2 x y) -> V2 (-y) x)
+    DRight -> relative (\(V2 x y) -> V2 y (-x))
+    DBack -> relative (\(V2 x y) -> V2 (-x) (-y))
+    DDown -> relative (const down)
+    DForward -> relative id
+  DAbsolute e -> cardinal $ toHeading e
  where
   -- name is generate from Direction data constuctor
   -- e.g. DLeft becomes "left"
-  directionSyntax = toLower . T.tail . from . show $ d
-  cardinal v2 = DirInfo directionSyntax (Just v2) (const v2)
-  relative = DirInfo directionSyntax Nothing
+  directionSyntax = toLower . T.tail . from $ case d of
+    DAbsolute x -> show x
+    DRelative x -> show x
+
+  cardinal = DirInfo directionSyntax . const
+  relative = DirInfo directionSyntax
 
 -- | Check if the direction is absolute (e.g. 'north' or 'south').
 isCardinal :: Direction -> Bool
-isCardinal = isJust . dirAbs . dirInfo
+isCardinal = \case
+  DAbsolute _ -> True
+  _ -> False
 
 -- | The cardinal direction north = @V2 0 1@.
 north :: Heading
@@ -165,12 +181,10 @@ applyTurn :: Direction -> Heading -> Heading
 applyTurn = dirApplyTurn . dirInfo
 
 -- | Mapping from heading to their corresponding cardinal directions.
---   Only directions with a 'dirAbs' value are mapped.
+--   Only absolute directions are mapped.
 cardinalDirs :: M.Map Heading Direction
 cardinalDirs =
-  M.fromList
-    . mapMaybe (\d -> (,d) <$> (dirAbs . dirInfo $ d))
-    $ allDirs
+  M.fromList $ map (toHeading &&& DAbsolute) Util.listEnums
 
 -- | Possibly convert a heading into a 'Direction'---that is, if the
 --   vector happens to be a unit vector in one of the cardinal
@@ -182,7 +196,9 @@ toDirection v = M.lookup v cardinalDirs
 --   this only does something reasonable for 'DNorth', 'DSouth', 'DEast',
 --   and 'DWest'---other 'Direction's return the zero vector.
 fromDirection :: Direction -> Heading
-fromDirection = fromMaybe (V2 0 0) . dirAbs . dirInfo
+fromDirection = \case
+  DAbsolute x -> toHeading x
+  _ -> V2 0 0
 
 -- | Constants, representing various built-in functions and commands.
 --