Move Heading and conversions to Location module (#1103)

- remove the useless `DirInfo` type
- move the `Direction -> Heading` functions to the `Location` module
- split off from #1069
- part of #1043
- part of #707

bench/Benchmark.hs

@@ -20,7 +20,6 @@ import Swarm.Game.World (WorldFun (..), newWorld)
 import Swarm.Language.Context qualified as Context
 import Swarm.Language.Pipeline (ProcessedTerm)
 import Swarm.Language.Pipeline.QQ (tmQ)
-import Swarm.Language.Syntax (north)
 
 -- | The program of a robot that does nothing.
 idleProgram :: ProcessedTerm

src/Swarm/DocGen.hs

@@ -171,7 +171,7 @@ keywordsCommands e = editorList e $ map constSyntax commands
 
 -- | Get formatted list of directions.
 keywordsDirections :: EditorType -> Text
-keywordsDirections e = editorList e $ map (Syntax.dirSyntax . Syntax.dirInfo) Syntax.allDirs
+keywordsDirections e = editorList e $ map Syntax.directionSyntax Syntax.allDirs
 
 operatorNames :: Text
 operatorNames = T.intercalate "|" $ map (escape . constSyntax) operators

src/Swarm/Game/Location.hs

@@ -14,7 +14,17 @@
 module Swarm.Game.Location (
   Location,
   pattern Location,
+
+  -- ** Heading and Direction functions
   Heading,
+  applyTurn,
+  toDirection,
+  fromDirection,
+  isCardinal,
+  north,
+  south,
+  east,
+  west,
 
   -- ** utility functions
   manhattan,
@@ -26,14 +36,17 @@ module Swarm.Game.Location (
   origin,
 ) where
 
+import Control.Arrow ((&&&))
 import Data.Aeson (FromJSONKey, ToJSONKey)
 import Data.Function ((&))
 import Data.Int (Int32)
 import Data.Map (Map)
 import Data.Map qualified as M
 import Data.Yaml (FromJSON (parseJSON), ToJSON (toJSON))
-import Linear (V2 (..))
+import Linear (Additive (..), V2 (..), negated, perp)
 import Linear.Affine (Affine (..), Point (..), origin)
+import Swarm.Language.Syntax (AbsoluteDir (..), Direction (..), RelativeDir (..), isCardinal)
+import Swarm.Util qualified as Util
 
 -- $setup
 -- >>> import qualified Data.Map as Map
@@ -54,6 +67,12 @@ pattern Location x y = P (V2 x y)
 
 {-# COMPLETE Location #-}
 
+instance FromJSON Location where
+  parseJSON = fmap P . parseJSON
+
+instance ToJSON Location where
+  toJSON (P v) = toJSON v
+
 -- | A @Heading@ is a 2D vector, with 32-bit coordinates.
 --
 --   'Location' and 'Heading' are both represented using types from
@@ -71,11 +90,65 @@ deriving instance FromJSON (V2 Int32)
 deriving instance FromJSONKey (V2 Int32)
 deriving instance ToJSONKey (V2 Int32)
 
-instance FromJSON Location where
-  parseJSON = fmap P . parseJSON
-
-instance ToJSON Location where
-  toJSON (P v) = toJSON v
+toHeading :: AbsoluteDir -> Heading
+toHeading = \case
+  DNorth -> north
+  DSouth -> south
+  DEast -> east
+  DWest -> west
+
+-- | The cardinal direction north = @V2 0 1@.
+north :: Heading
+north = V2 0 1
+
+-- | The cardinal direction south = @V2 0 (-1)@.
+south :: Heading
+south = V2 0 (-1)
+
+-- | The cardinal direction east = @V2 1 0@.
+east :: Heading
+east = V2 1 0
+
+-- | The cardinal direction west = @V2 (-1) 0@.
+west :: Heading
+west = V2 (-1) 0
+
+-- | The direction for viewing the current cell = @V2 0 0@.
+down :: Heading
+down = zero
+
+-- | The 'applyTurn' function gives the meaning of each 'Direction' by
+--   turning relative to the given heading or by turning to an absolute
+--   heading
+applyTurn :: Direction -> Heading -> Heading
+applyTurn d = case d of
+  DRelative e -> case e of
+    DLeft -> perp
+    DRight -> negated . perp
+    DBack -> negated
+    DDown -> const down
+    DForward -> id
+  DAbsolute e -> const $ toHeading e
+
+-- | Mapping from heading to their corresponding cardinal directions.
+--   Only absolute directions are mapped.
+cardinalDirs :: M.Map Heading Direction
+cardinalDirs =
+  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
+--   directions.
+toDirection :: Heading -> Maybe Direction
+toDirection v = M.lookup v cardinalDirs
+
+-- | Convert a 'Direction' into a corresponding heading.  Note that
+--   this only does something reasonable for 'DNorth', 'DSouth', 'DEast',
+--   and 'DWest'---other 'Direction's return the zero vector.
+fromDirection :: Direction -> Heading
+fromDirection = \case
+  DAbsolute x -> toHeading x
+  _ -> zero
 
 -- | Manhattan distance between world locations.
 manhattan :: Location -> Location -> Int32

src/Swarm/Game/Robot.hs

@@ -93,12 +93,11 @@ import Linear
 import Swarm.Game.CESK
 import Swarm.Game.Display (Display, curOrientation, defaultRobotDisplay, invisible)
 import Swarm.Game.Entity hiding (empty)
-import Swarm.Game.Location
+import Swarm.Game.Location (Heading, Location, toDirection)
 import Swarm.Game.Log
 import Swarm.Language.Capability (Capability)
 import Swarm.Language.Context qualified as Ctx
 import Swarm.Language.Requirement (ReqCtx)
-import Swarm.Language.Syntax (toDirection)
 import Swarm.Language.Typed (Typed (..))
 import Swarm.Language.Types (TCtx)
 import Swarm.Language.Value as V

src/Swarm/Game/Step.hs

@@ -1112,7 +1112,7 @@ execConst c vs s k = do
               DRelative DDown -> "under"
               DRelative DForward -> "ahead of"
               DRelative DBack -> "behind"
-              _ -> dirSyntax (dirInfo d) <> " of"
+              _ -> directionSyntax d <> " of"
 
         (nextLoc, nextME) <- lookInDirection d
         nextE <-

src/Swarm/Language/Parse.hs

@@ -82,7 +82,7 @@ type ParserError = ParseErrorBundle Text Void
 reservedWords :: [Text]
 reservedWords =
   map (syntax . constInfo) (filter isUserFunc allConst)
-    ++ map (dirSyntax . dirInfo) allDirs
+    ++ map directionSyntax allDirs
     ++ [ "void"
        , "unit"
        , "int"
@@ -226,7 +226,7 @@ parseTypeAtom =
 parseDirection :: Parser Direction
 parseDirection = asum (map alternative allDirs) <?> "direction constant"
  where
-  alternative d = d <$ (reserved . dirSyntax . dirInfo) d
+  alternative d = d <$ (reserved . directionSyntax) d
 
 -- | Parse Const as reserved words (e.g. @Fail <$ reserved "fail"@)
 parseConst :: Parser Const

src/Swarm/Language/Pretty.hs

@@ -103,7 +103,7 @@ instance PrettyPrec t => PrettyPrec (Ctx t) where
     prettyBinding (x, ty) = pretty x <> ":" <+> ppr ty
 
 instance PrettyPrec Direction where
-  prettyPrec _ = pretty . dirSyntax . dirInfo
+  prettyPrec _ = pretty . directionSyntax
 
 instance PrettyPrec Capability where
   prettyPrec _ c = pretty $ T.toLower (from (tail $ show c))

src/Swarm/Language/Syntax.hs

@@ -20,17 +20,9 @@ module Swarm.Language.Syntax (
   Direction (..),
   AbsoluteDir (..),
   RelativeDir (..),
-  DirInfo (..),
-  applyTurn,
-  toDirection,
-  fromDirection,
-  allDirs,
+  directionSyntax,
   isCardinal,
-  dirInfo,
-  north,
-  south,
-  east,
-  west,
+  allDirs,
 
   -- * Constants
   Const (..),
@@ -90,7 +82,6 @@ module Swarm.Language.Syntax (
   locVarToSyntax',
 ) where
 
-import Control.Arrow (Arrow ((&&&)))
 import Control.Lens (Plated (..), Traversal', makeLenses, (%~), (^.))
 import Data.Aeson.Types
 import Data.Char qualified as C (toLower)
@@ -100,14 +91,11 @@ import Data.Hashable (Hashable)
 import Data.List qualified as L (tail)
 import Data.List.NonEmpty (NonEmpty)
 import Data.List.NonEmpty qualified as NonEmpty
-import Data.Map qualified as M
 import Data.Set qualified as S
 import Data.String (IsString (fromString))
 import Data.Text hiding (filter, map)
 import Data.Text qualified as T
 import GHC.Generics (Generic)
-import Linear
-import Swarm.Game.Location (Heading)
 import Swarm.Language.Types
 import Swarm.Util qualified as Util
 import Witch.From (from)
@@ -145,93 +133,21 @@ data RelativeDir = DLeft | DRight | DBack | DForward | DDown
 data Direction = DAbsolute AbsoluteDir | DRelative RelativeDir
   deriving (Eq, Ord, Show, Read, Generic, Data, Hashable, ToJSON, FromJSON)
 
-data DirInfo = DirInfo
-  { dirSyntax :: Text
-  , dirApplyTurn :: Heading -> Heading
-  -- ^ the turning for the direction
-  }
-
-allDirs :: [Direction]
-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
-  DRelative e -> case e of
-    DLeft -> relative perp
-    DRight -> relative (fmap negate . perp)
-    DBack -> relative (fmap negate)
-    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 $ case d of
-    DAbsolute x -> show x
-    DRelative x -> show x
-
-  cardinal = DirInfo directionSyntax . const
-  relative = DirInfo directionSyntax
+-- | Direction name is generated from Direction data constuctor
+-- e.g. DLeft becomes "left"
+directionSyntax :: Direction -> Text
+directionSyntax d = toLower . T.tail . from $ case d of
+  DAbsolute x -> show x
+  DRelative x -> show x
 
 -- | Check if the direction is absolute (e.g. 'north' or 'south').
 isCardinal :: Direction -> Bool
 isCardinal = \case
   DAbsolute _ -> True
   _ -> False
 
--- | The cardinal direction north = @V2 0 1@.
-north :: Heading
-north = V2 0 1
-
--- | The cardinal direction south = @V2 0 (-1)@.
-south :: Heading
-south = V2 0 (-1)
-
--- | The cardinal direction east = @V2 1 0@.
-east :: Heading
-east = V2 1 0
-
--- | The cardinal direction west = @V2 (-1) 0@.
-west :: Heading
-west = V2 (-1) 0
-
--- | The direction for viewing the current cell = @V2 0 0@.
-down :: Heading
-down = zero
-
--- | The 'applyTurn' function gives the meaning of each 'Direction' by
---   turning relative to the given heading or by turning to an absolute
---   heading
-applyTurn :: Direction -> Heading -> Heading
-applyTurn = dirApplyTurn . dirInfo
-
--- | Mapping from heading to their corresponding cardinal directions.
---   Only absolute directions are mapped.
-cardinalDirs :: M.Map Heading Direction
-cardinalDirs =
-  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
---   directions.
-toDirection :: Heading -> Maybe Direction
-toDirection v = M.lookup v cardinalDirs
-
--- | Convert a 'Direction' into a corresponding heading.  Note that
---   this only does something reasonable for 'DNorth', 'DSouth', 'DEast',
---   and 'DWest'---other 'Direction's return the zero vector.
-fromDirection :: Direction -> Heading
-fromDirection = \case
-  DAbsolute x -> toHeading x
-  _ -> zero
+allDirs :: [Direction]
+allDirs = map DAbsolute Util.listEnums <> map DRelative Util.listEnums
 
 ------------------------------------------------------------
 -- Constants