mirror of
https://github.com/swarm-game/swarm.git
synced 2024-08-16 18:10:23 +03:00
Reformat the haskell code with fourmolu (#146)
This PR was generated using `find src/ app/ test/ -name "*.hs" | xargs fourmolu --mode=inplace`. Fixes #103
This commit is contained in:
parent
4d3f3aa12a
commit
a23212ae9d
33
app/Main.hs
33
app/Main.hs
@ -1,15 +1,17 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Data.Text ( Text
|
||||
, pack
|
||||
)
|
||||
import qualified Data.Text.IO as Text
|
||||
import Options.Applicative
|
||||
import Swarm.App ( appMain )
|
||||
import Swarm.Language.LSP ( lspMain )
|
||||
import Swarm.Language.Pipeline ( processTerm )
|
||||
import System.Exit
|
||||
import Data.Text (
|
||||
Text,
|
||||
pack,
|
||||
)
|
||||
import qualified Data.Text.IO as Text
|
||||
import Options.Applicative
|
||||
import Swarm.App (appMain)
|
||||
import Swarm.Language.LSP (lspMain)
|
||||
import Swarm.Language.Pipeline (processTerm)
|
||||
import System.Exit
|
||||
|
||||
data CLI
|
||||
= Run
|
||||
@ -19,11 +21,12 @@ data CLI
|
||||
cliParser :: Parser CLI
|
||||
cliParser =
|
||||
subparser
|
||||
( command "format" (info format (progDesc "Format a file"))
|
||||
<> command "lsp" (info (pure LSP) (progDesc "Start the LSP"))
|
||||
)
|
||||
( command "format" (info format (progDesc "Format a file"))
|
||||
<> command "lsp" (info (pure LSP) (progDesc "Start the LSP"))
|
||||
)
|
||||
<|> pure Run
|
||||
where format = Format <$> strArgument (metavar "FILE")
|
||||
where
|
||||
format = Format <$> strArgument (metavar "FILE")
|
||||
|
||||
cliInfo :: ParserInfo CLI
|
||||
cliInfo = info (cliParser <**> helper) (fullDesc <> header "Swarm game")
|
||||
@ -43,6 +46,6 @@ main :: IO ()
|
||||
main = do
|
||||
cli <- execParser cliInfo
|
||||
case cli of
|
||||
Run -> appMain
|
||||
Run -> appMain
|
||||
Format fp -> formatFile fp =<< Text.readFile fp
|
||||
LSP -> lspMain
|
||||
LSP -> lspMain
|
||||
|
8
fourmolu.yaml
Normal file
8
fourmolu.yaml
Normal file
@ -0,0 +1,8 @@
|
||||
indentation: 2
|
||||
comma-style: leading
|
||||
record-brace-space: true
|
||||
indent-wheres: false # 'false' means save space by only half-indenting the 'where' keyword
|
||||
diff-friendly-import-export: true
|
||||
respectful: true
|
||||
haddock-style: single-line
|
||||
newlines-between-decls: 1
|
@ -1,4 +1,7 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.App
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -7,35 +10,31 @@
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
--
|
||||
-- Main entry point for the Swarm application.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
|
||||
module Swarm.App where
|
||||
|
||||
import Control.Concurrent (forkIO, threadDelay)
|
||||
import Control.Concurrent (forkIO, threadDelay)
|
||||
|
||||
import Brick
|
||||
import Brick.BChan
|
||||
import qualified Graphics.Vty as V
|
||||
import Brick
|
||||
import Brick.BChan
|
||||
import qualified Graphics.Vty as V
|
||||
|
||||
import Control.Monad.Except
|
||||
import qualified Data.Text.IO as T
|
||||
import Swarm.TUI.Attr
|
||||
import Swarm.TUI.Controller
|
||||
import Swarm.TUI.Model
|
||||
import Swarm.TUI.View
|
||||
import Control.Monad.Except
|
||||
import qualified Data.Text.IO as T
|
||||
import Swarm.TUI.Attr
|
||||
import Swarm.TUI.Controller
|
||||
import Swarm.TUI.Model
|
||||
import Swarm.TUI.View
|
||||
|
||||
-- | The definition of the app used by the @brick@ library.
|
||||
app :: App AppState AppEvent Name
|
||||
app = App
|
||||
{ appDraw = drawUI
|
||||
, appChooseCursor = chooseCursor
|
||||
, appHandleEvent = handleEvent
|
||||
, appStartEvent = \s -> s <$ enablePasteMode
|
||||
, appAttrMap = const swarmAttrMap
|
||||
}
|
||||
app =
|
||||
App
|
||||
{ appDraw = drawUI
|
||||
, appChooseCursor = chooseCursor
|
||||
, appHandleEvent = handleEvent
|
||||
, appStartEvent = \s -> s <$ enablePasteMode
|
||||
, appAttrMap = const swarmAttrMap
|
||||
}
|
||||
|
||||
-- | The main @IO@ computation which initializes the state, sets up
|
||||
-- some communication channels, and runs the UI.
|
||||
@ -45,7 +44,6 @@ appMain = do
|
||||
case res of
|
||||
Left errMsg -> T.putStrLn errMsg
|
||||
Right s -> do
|
||||
|
||||
-- Send Frame events as at a reasonable rate for 30 fps. The
|
||||
-- game is responsible for figuring out how many steps to take
|
||||
-- each frame to achieve the desired speed, regardless of the
|
||||
@ -61,9 +59,10 @@ appMain = do
|
||||
-- and do another write.
|
||||
|
||||
chan <- newBChan 5
|
||||
_ <- forkIO $ forever $ do
|
||||
threadDelay 33_333 -- cap maximum framerate at 30 FPS
|
||||
writeBChan chan Frame
|
||||
_ <- forkIO $
|
||||
forever $ do
|
||||
threadDelay 33_333 -- cap maximum framerate at 30 FPS
|
||||
writeBChan chan Frame
|
||||
|
||||
-- Run the app.
|
||||
|
||||
|
@ -1,4 +1,8 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Game.CEK
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -44,44 +48,41 @@
|
||||
-- have to store the proper environment alongside so that when
|
||||
-- we eventually get around to evaluating it, we will be able to
|
||||
-- pull out the environment to use.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.Game.CEK (
|
||||
-- * Frames and continuations
|
||||
Frame (..),
|
||||
Cont,
|
||||
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
-- * CEK machine states
|
||||
CEK (..),
|
||||
|
||||
module Swarm.Game.CEK
|
||||
( -- * Frames and continuations
|
||||
Frame(..), Cont
|
||||
-- ** Construction
|
||||
initMachine,
|
||||
initMachine',
|
||||
idleMachine,
|
||||
|
||||
-- * CEK machine states
|
||||
-- ** Extracting information
|
||||
finalValue,
|
||||
|
||||
, CEK(..)
|
||||
-- ** Pretty-printing
|
||||
prettyFrame,
|
||||
prettyCont,
|
||||
prettyCEK,
|
||||
) where
|
||||
|
||||
-- ** Construction
|
||||
import Control.Lens.Combinators (pattern Empty)
|
||||
import Data.List (intercalate)
|
||||
import qualified Data.Set as S
|
||||
import Witch (from)
|
||||
|
||||
, initMachine, initMachine', idleMachine
|
||||
|
||||
-- ** Extracting information
|
||||
, finalValue
|
||||
|
||||
-- ** Pretty-printing
|
||||
, prettyFrame, prettyCont, prettyCEK
|
||||
) where
|
||||
|
||||
import Control.Lens.Combinators (pattern Empty)
|
||||
import Data.List (intercalate)
|
||||
import qualified Data.Set as S
|
||||
import Witch (from)
|
||||
|
||||
import Swarm.Game.Exception
|
||||
import Swarm.Game.Value as V
|
||||
import Swarm.Language.Capability (CapCtx)
|
||||
import Swarm.Language.Context
|
||||
import Swarm.Language.Pipeline
|
||||
import Swarm.Language.Pretty
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Language.Types
|
||||
import Swarm.Game.Exception
|
||||
import Swarm.Game.Value as V
|
||||
import Swarm.Language.Capability (CapCtx)
|
||||
import Swarm.Language.Context
|
||||
import Swarm.Language.Pipeline
|
||||
import Swarm.Language.Pretty
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Language.Types
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Frames and continuations
|
||||
@ -91,60 +92,50 @@ import Swarm.Language.Types
|
||||
-- what to do next after we finish evaluating the currently focused
|
||||
-- term.
|
||||
data Frame
|
||||
= FSnd Term Env
|
||||
-- ^ We were evaluating the first component of a pair; next, we
|
||||
-- should evaluate the second component which was saved in this
|
||||
-- frame (and push a 'FFst' frame on the stack to save the first component).
|
||||
|
||||
| FFst Value
|
||||
-- ^ We were evaluating the second component of a pair; when done,
|
||||
-- we should combine it with the value of the first component saved
|
||||
-- in this frame to construct a fully evaluated pair.
|
||||
|
||||
| FArg Term Env
|
||||
-- ^ @FArg t e@ says that we were evaluating the left-hand side of
|
||||
= -- | We were evaluating the first component of a pair; next, we
|
||||
-- should evaluate the second component which was saved in this
|
||||
-- frame (and push a 'FFst' frame on the stack to save the first component).
|
||||
FSnd Term Env
|
||||
| -- | We were evaluating the second component of a pair; when done,
|
||||
-- we should combine it with the value of the first component saved
|
||||
-- in this frame to construct a fully evaluated pair.
|
||||
FFst Value
|
||||
| -- | @FArg t e@ says that we were evaluating the left-hand side of
|
||||
-- an application, so the next thing we should do is evaluate the
|
||||
-- term @t@ (the right-hand side, /i.e./ argument of the
|
||||
-- application) in environment @e@. We will also push an 'FApp'
|
||||
-- frame on the stack.
|
||||
|
||||
| FApp Value
|
||||
-- ^ @FApp v@ says that we were evaluating the right-hand side of
|
||||
FArg Term Env
|
||||
| -- | @FApp v@ says that we were evaluating the right-hand side of
|
||||
-- an application; once we are done, we should pass the resulting
|
||||
-- value as an argument to @v@.
|
||||
|
||||
| FLet Var Term Env
|
||||
-- ^ @FLet x t2 e@ says that we were evaluating a term @t1@ in an
|
||||
FApp Value
|
||||
| -- | @FLet x t2 e@ says that we were evaluating a term @t1@ in an
|
||||
-- expression of the form @let x = t1 in t2@, that is, we were
|
||||
-- evaluating the definition of @x@; the next thing we should do
|
||||
-- is evaluate @t2@ in the environment @e@ extended with a binding
|
||||
-- for @x@.
|
||||
|
||||
| FTry Value
|
||||
-- ^ We are executing inside a 'Try' block. If an exception is
|
||||
FLet Var Term Env
|
||||
| -- | We are executing inside a 'Try' block. If an exception is
|
||||
-- raised, we will execute the stored term (the "catch" block).
|
||||
|
||||
| FUnionEnv Env
|
||||
-- ^ We were executing a command; next we should take any
|
||||
FTry Value
|
||||
| -- | We were executing a command; next we should take any
|
||||
-- environment it returned and union it with this one to produce
|
||||
-- the result of a bind expression.
|
||||
|
||||
| FLoadEnv TCtx CapCtx
|
||||
-- ^ We were executing a command that might have definitions; next
|
||||
FUnionEnv Env
|
||||
| -- | We were executing a command that might have definitions; next
|
||||
-- we should take the resulting 'Env' and add it to the robot's
|
||||
-- 'Swarm.Game.Robot.robotEnv', along with adding this accompanying 'Ctx' and
|
||||
-- 'CapCtx' to the robot's 'Swarm.Game.Robot.robotCtx'.
|
||||
|
||||
| FExec
|
||||
-- ^ An @FExec@ frame means the focused value is a command, which
|
||||
FLoadEnv TCtx CapCtx
|
||||
| -- | An @FExec@ frame means the focused value is a command, which
|
||||
-- we should now execute.
|
||||
|
||||
| FBind (Maybe Var) Term Env
|
||||
-- ^ We are in the process of executing the first component of a
|
||||
FExec
|
||||
| -- | We are in the process of executing the first component of a
|
||||
-- bind; once done, we should also execute the second component
|
||||
-- in the given environment (extended by binding the variable,
|
||||
-- if there is one, to the output of the first command).
|
||||
|
||||
FBind (Maybe Var) Term Env
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | A continuation is just a stack of frames.
|
||||
@ -162,14 +153,12 @@ type Cont = [Frame]
|
||||
-- approach from Harper's Practical Foundations of Programming
|
||||
-- Languages.
|
||||
data CEK
|
||||
= In Term Env Cont
|
||||
-- ^ When we are on our way "in/down" into a term, we have a
|
||||
= -- | When we are on our way "in/down" into a term, we have a
|
||||
-- currently focused term to evaluate in the environment, and a
|
||||
-- continuation. In this mode we generally pattern-match on the
|
||||
-- 'Term' to decide what to do next.
|
||||
|
||||
| Out Value Cont
|
||||
-- ^ Once we finish evaluating a term, we end up with a 'Value'
|
||||
In Term Env Cont
|
||||
| -- | Once we finish evaluating a term, we end up with a 'Value'
|
||||
-- and we switch into "out" mode, bringing the value back up
|
||||
-- out of the depths to the context that was expecting it. In
|
||||
-- this mode we generally pattern-match on the 'Cont' to decide
|
||||
@ -179,19 +168,19 @@ data CEK
|
||||
-- with variables to evaluate at the moment, and we maintain the
|
||||
-- invariant that any unevaluated terms buried inside a 'Value'
|
||||
-- or 'Cont' must carry along their environment with them.
|
||||
|
||||
| Up Exn Cont
|
||||
-- ^ An exception has been raised. Keep unwinding the
|
||||
Out Value Cont
|
||||
| -- | An exception has been raised. Keep unwinding the
|
||||
-- continuation stack (until finding an enclosing 'Try' in the
|
||||
-- case of a command failure or a user-generated exception, or
|
||||
-- until the stack is empty in the case of a fatal exception).
|
||||
Up Exn Cont
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Is the CEK machine in a final (finished) state? If so, extract
|
||||
-- the final value.
|
||||
finalValue :: CEK -> Maybe Value
|
||||
finalValue (Out v []) = Just v
|
||||
finalValue _ = Nothing
|
||||
finalValue _ = Nothing
|
||||
|
||||
-- | Initialize a machine state with a starting term along with its
|
||||
-- type; the term will be executed or just evaluated depending on
|
||||
@ -201,17 +190,18 @@ initMachine t e = initMachine' t e []
|
||||
|
||||
-- | Like 'initMachine', but also take a starting continuation.
|
||||
initMachine' :: ProcessedTerm -> Env -> Cont -> CEK
|
||||
initMachine' (ProcessedTerm t (Module (Forall _ (TyCmd _)) ctx) _ capCtx) e k
|
||||
= case ctx of
|
||||
Empty -> In t e (FExec : k)
|
||||
_ -> In t e (FExec : FLoadEnv ctx capCtx : k)
|
||||
initMachine' (ProcessedTerm t (Module (Forall _ (TyCmd _)) ctx) _ capCtx) e k =
|
||||
case ctx of
|
||||
Empty -> In t e (FExec : k)
|
||||
_ -> In t e (FExec : FLoadEnv ctx capCtx : k)
|
||||
initMachine' (ProcessedTerm t _ _ _) e k = In t e k
|
||||
|
||||
-- | A machine which does nothing.
|
||||
idleMachine :: CEK
|
||||
idleMachine = initMachine trivialTerm empty
|
||||
where
|
||||
trivialTerm = ProcessedTerm
|
||||
where
|
||||
trivialTerm =
|
||||
ProcessedTerm
|
||||
(TConst Noop)
|
||||
(trivMod (Forall [] (TyCmd TyUnit)))
|
||||
S.empty
|
||||
@ -225,30 +215,36 @@ idleMachine = initMachine trivialTerm empty
|
||||
-- | Very poor pretty-printing of CEK machine states, really just for
|
||||
-- debugging. At some point we should make a nicer version.
|
||||
prettyCEK :: CEK -> String
|
||||
prettyCEK (In c _ k) = unlines
|
||||
[ "▶ " ++ prettyString c
|
||||
, " " ++ prettyCont k ]
|
||||
prettyCEK (Out v k) = unlines
|
||||
[ "◀ " ++ from (prettyValue v)
|
||||
, " " ++ prettyCont k ]
|
||||
prettyCEK (Up e k) = unlines
|
||||
[ "! " ++ from (formatExn e)
|
||||
, " " ++ prettyCont k ]
|
||||
prettyCEK (In c _ k) =
|
||||
unlines
|
||||
[ "▶ " ++ prettyString c
|
||||
, " " ++ prettyCont k
|
||||
]
|
||||
prettyCEK (Out v k) =
|
||||
unlines
|
||||
[ "◀ " ++ from (prettyValue v)
|
||||
, " " ++ prettyCont k
|
||||
]
|
||||
prettyCEK (Up e k) =
|
||||
unlines
|
||||
[ "! " ++ from (formatExn e)
|
||||
, " " ++ prettyCont k
|
||||
]
|
||||
|
||||
-- | Poor pretty-printing of continuations.
|
||||
prettyCont :: Cont -> String
|
||||
prettyCont = ("["++) . (++"]") . intercalate " | " . map prettyFrame
|
||||
prettyCont = ("[" ++) . (++ "]") . intercalate " | " . map prettyFrame
|
||||
|
||||
-- | Poor pretty-printing of frames.
|
||||
prettyFrame :: Frame -> String
|
||||
prettyFrame (FSnd t _) = "(_, " ++ prettyString t ++ ")"
|
||||
prettyFrame (FFst v) = "(" ++ from (prettyValue v) ++ ", _)"
|
||||
prettyFrame (FArg t _) = "_ " ++ prettyString t
|
||||
prettyFrame (FApp v) = prettyString (valueToTerm v) ++ " _"
|
||||
prettyFrame (FLet x t _) = "let " ++ from x ++ " = _ in " ++ prettyString t
|
||||
prettyFrame (FTry c) = "try _ (" ++ from (prettyValue c) ++ ")"
|
||||
prettyFrame FUnionEnv{} = "_ ∪ <Env>"
|
||||
prettyFrame FLoadEnv{} = "loadEnv"
|
||||
prettyFrame FExec = "exec _"
|
||||
prettyFrame (FBind Nothing t _) = "_ ; " ++ prettyString t
|
||||
prettyFrame (FSnd t _) = "(_, " ++ prettyString t ++ ")"
|
||||
prettyFrame (FFst v) = "(" ++ from (prettyValue v) ++ ", _)"
|
||||
prettyFrame (FArg t _) = "_ " ++ prettyString t
|
||||
prettyFrame (FApp v) = prettyString (valueToTerm v) ++ " _"
|
||||
prettyFrame (FLet x t _) = "let " ++ from x ++ " = _ in " ++ prettyString t
|
||||
prettyFrame (FTry c) = "try _ (" ++ from (prettyValue c) ++ ")"
|
||||
prettyFrame FUnionEnv {} = "_ ∪ <Env>"
|
||||
prettyFrame FLoadEnv {} = "loadEnv"
|
||||
prettyFrame FExec = "exec _"
|
||||
prettyFrame (FBind Nothing t _) = "_ ; " ++ prettyString t
|
||||
prettyFrame (FBind (Just x) t _) = from x ++ " <- _ ; " ++ prettyString t
|
||||
|
@ -1,4 +1,13 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
-- Orphan Hashable instances needed to derive Hashable Display
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Game.Display
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -7,49 +16,39 @@
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
--
|
||||
-- Utilities for describing how to display in-game entities in the TUI.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.Game.Display (
|
||||
-- * The display record
|
||||
Priority,
|
||||
Display,
|
||||
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
-- ** Fields
|
||||
defaultChar,
|
||||
orientationMap,
|
||||
displayAttr,
|
||||
displayPriority,
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
-- Orphan Hashable instances needed to derive Hashable Display
|
||||
-- ** Lookup
|
||||
lookupDisplay,
|
||||
displayWidget,
|
||||
|
||||
module Swarm.Game.Display
|
||||
(
|
||||
-- * The display record
|
||||
Priority
|
||||
, Display
|
||||
-- ** Construction
|
||||
defaultTerrainDisplay,
|
||||
defaultEntityDisplay,
|
||||
defaultRobotDisplay,
|
||||
) where
|
||||
|
||||
-- ** Fields
|
||||
, defaultChar, orientationMap, displayAttr, displayPriority
|
||||
import Brick (AttrName, Widget, str, withAttr)
|
||||
import Control.Lens hiding (Const, from, (.=))
|
||||
import Data.Hashable
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
|
||||
-- ** Lookup
|
||||
, lookupDisplay
|
||||
, displayWidget
|
||||
import Data.Yaml
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
-- ** Construction
|
||||
, defaultTerrainDisplay
|
||||
, defaultEntityDisplay
|
||||
, defaultRobotDisplay
|
||||
|
||||
) where
|
||||
|
||||
import Brick (AttrName, Widget, str, withAttr)
|
||||
import Control.Lens hiding (Const, from, (.=))
|
||||
import Data.Hashable
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
|
||||
import Data.Yaml
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.TUI.Attr
|
||||
import Swarm.Util
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.TUI.Attr
|
||||
import Swarm.Util
|
||||
|
||||
-- | Display priority. Entities with higher priority will be drawn on
|
||||
-- top of entities with lower priority.
|
||||
@ -61,9 +60,9 @@ instance Hashable AttrName
|
||||
|
||||
-- | A record explaining how to display an entity in the TUI.
|
||||
data Display = Display
|
||||
{ _defaultChar :: Char
|
||||
, _orientationMap :: Map Direction Char
|
||||
, _displayAttr :: AttrName
|
||||
{ _defaultChar :: Char
|
||||
, _orientationMap :: Map Direction Char
|
||||
, _displayAttr :: AttrName
|
||||
, _displayPriority :: Priority
|
||||
}
|
||||
deriving (Eq, Ord, Show, Generic, Hashable)
|
||||
@ -87,26 +86,26 @@ displayAttr :: Lens' Display AttrName
|
||||
displayPriority :: Lens' Display Priority
|
||||
|
||||
instance FromJSON Display where
|
||||
parseJSON = withObject "Display" $ \v -> Display
|
||||
<$> v .: "char"
|
||||
<*> v .:? "orientationMap" .!= M.empty
|
||||
<*> v .:? "attr" .!= entityAttr
|
||||
<*> v .:? "priority" .!= 1
|
||||
parseJSON = withObject "Display" $ \v ->
|
||||
Display
|
||||
<$> v .: "char"
|
||||
<*> v .:? "orientationMap" .!= M.empty
|
||||
<*> v .:? "attr" .!= entityAttr
|
||||
<*> v .:? "priority" .!= 1
|
||||
|
||||
instance ToJSON Display where
|
||||
toJSON d = object $
|
||||
[ "char" .= (d ^. defaultChar)
|
||||
, "attr" .= (d ^. displayAttr)
|
||||
, "priority" .= (d ^. displayPriority)
|
||||
]
|
||||
++
|
||||
[ "orientationMap" .= (d ^. orientationMap) | not (M.null (d ^. orientationMap)) ]
|
||||
|
||||
toJSON d =
|
||||
object $
|
||||
[ "char" .= (d ^. defaultChar)
|
||||
, "attr" .= (d ^. displayAttr)
|
||||
, "priority" .= (d ^. displayPriority)
|
||||
]
|
||||
++ ["orientationMap" .= (d ^. orientationMap) | not (M.null (d ^. orientationMap))]
|
||||
|
||||
-- | Look up the character that should be used for a display, possibly
|
||||
-- given an orientation as input.
|
||||
lookupDisplay :: Maybe Direction -> Display -> Char
|
||||
lookupDisplay Nothing disp = disp ^. defaultChar
|
||||
lookupDisplay Nothing disp = disp ^. defaultChar
|
||||
lookupDisplay (Just v) disp = M.lookup v (disp ^. orientationMap) ? (disp ^. defaultChar)
|
||||
|
||||
-- | Given the (optional) orientation of an entity and its display,
|
||||
@ -117,32 +116,35 @@ displayWidget orient disp = withAttr (disp ^. displayAttr) $ str [lookupDisplay
|
||||
-- | The default way to display some terrain using the given character
|
||||
-- and attribute, with priority 0.
|
||||
defaultTerrainDisplay :: Char -> AttrName -> Display
|
||||
defaultTerrainDisplay c attr
|
||||
= defaultEntityDisplay c
|
||||
& displayPriority .~ 0
|
||||
& displayAttr .~ attr
|
||||
defaultTerrainDisplay c attr =
|
||||
defaultEntityDisplay c
|
||||
& displayPriority .~ 0
|
||||
& displayAttr .~ attr
|
||||
|
||||
-- | Construct a default display for an entity that uses only a single
|
||||
-- display character, the default entity attribute, and priority 1.
|
||||
defaultEntityDisplay :: Char -> Display
|
||||
defaultEntityDisplay c = Display
|
||||
{ _defaultChar = c
|
||||
, _orientationMap = M.empty
|
||||
, _displayAttr = entityAttr
|
||||
, _displayPriority = 1
|
||||
}
|
||||
defaultEntityDisplay c =
|
||||
Display
|
||||
{ _defaultChar = c
|
||||
, _orientationMap = M.empty
|
||||
, _displayAttr = entityAttr
|
||||
, _displayPriority = 1
|
||||
}
|
||||
|
||||
-- | Construct a default robot display, with display characters
|
||||
-- @"Ω^>v<"@, the default robot attribute, and priority 10.
|
||||
defaultRobotDisplay :: Display
|
||||
defaultRobotDisplay = Display
|
||||
{ _defaultChar = 'Ω'
|
||||
, _orientationMap = M.fromList
|
||||
[ (East, '>')
|
||||
, (West, '<')
|
||||
, (South, 'v')
|
||||
, (North, '^')
|
||||
]
|
||||
, _displayAttr = robotAttr
|
||||
, _displayPriority = 10
|
||||
}
|
||||
defaultRobotDisplay =
|
||||
Display
|
||||
{ _defaultChar = 'Ω'
|
||||
, _orientationMap =
|
||||
M.fromList
|
||||
[ (East, '>')
|
||||
, (West, '<')
|
||||
, (South, 'v')
|
||||
, (North, '^')
|
||||
]
|
||||
, _displayAttr = robotAttr
|
||||
, _displayPriority = 10
|
||||
}
|
||||
|
@ -1,4 +1,15 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Game.Entity
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -14,93 +25,95 @@
|
||||
-- This module also defines the 'Inventory' type, since the two types
|
||||
-- are mutually recursive (an inventory contains entities, which can
|
||||
-- have inventories).
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.Game.Entity (
|
||||
-- * Properties
|
||||
EntityProperty (..),
|
||||
GrowthTime (..),
|
||||
defaultGrowthTime,
|
||||
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
-- * Entities
|
||||
Entity,
|
||||
mkEntity,
|
||||
displayEntity,
|
||||
|
||||
module Swarm.Game.Entity
|
||||
( -- * Properties
|
||||
EntityProperty(..)
|
||||
, GrowthTime(..), defaultGrowthTime
|
||||
-- ** Lenses
|
||||
-- $lenses
|
||||
entityDisplay,
|
||||
entityName,
|
||||
entityPlural,
|
||||
entityNameFor,
|
||||
entityDescription,
|
||||
entityOrientation,
|
||||
entityGrowth,
|
||||
entityYields,
|
||||
entityProperties,
|
||||
hasProperty,
|
||||
entityCapabilities,
|
||||
entityInventory,
|
||||
entityHash,
|
||||
|
||||
-- * Entities
|
||||
, Entity, mkEntity
|
||||
, displayEntity
|
||||
-- ** Entity map
|
||||
EntityMap,
|
||||
loadEntities,
|
||||
lookupEntityName,
|
||||
deviceForCap,
|
||||
|
||||
-- ** Lenses
|
||||
-- $lenses
|
||||
, entityDisplay, entityName, entityPlural, entityNameFor
|
||||
, entityDescription, entityOrientation, entityGrowth, entityYields
|
||||
, entityProperties, hasProperty, entityCapabilities
|
||||
, entityInventory
|
||||
, entityHash
|
||||
-- * Inventories
|
||||
Inventory,
|
||||
Count,
|
||||
|
||||
-- ** Entity map
|
||||
, EntityMap
|
||||
, loadEntities
|
||||
, lookupEntityName, deviceForCap
|
||||
-- ** Construction
|
||||
empty,
|
||||
singleton,
|
||||
fromList,
|
||||
|
||||
-- * Inventories
|
||||
-- ** Lookup
|
||||
lookup,
|
||||
lookupByName,
|
||||
contains,
|
||||
elems,
|
||||
|
||||
, Inventory, Count
|
||||
-- ** Modification
|
||||
insert,
|
||||
insertCount,
|
||||
delete,
|
||||
deleteCount,
|
||||
deleteAll,
|
||||
) where
|
||||
|
||||
-- ** Construction
|
||||
import Brick (Widget)
|
||||
import Control.Arrow ((&&&))
|
||||
import Control.Lens (Getter, Lens', lens, to, view, (^.))
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Bifunctor (bimap, second)
|
||||
import Data.Char (toLower)
|
||||
import Data.Function (on)
|
||||
import Data.Hashable
|
||||
import Data.Int (Int64)
|
||||
import Data.IntMap (IntMap)
|
||||
import qualified Data.IntMap as IM
|
||||
import Data.IntSet (IntSet)
|
||||
import qualified Data.IntSet as IS
|
||||
import Data.List (foldl')
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics (Generic)
|
||||
import Linear
|
||||
import Text.Read (readMaybe)
|
||||
import Witch
|
||||
import Prelude hiding (lookup)
|
||||
|
||||
, empty, singleton, fromList
|
||||
import Data.Yaml
|
||||
|
||||
-- ** Lookup
|
||||
import Swarm.Game.Display
|
||||
import Swarm.Language.Capability
|
||||
import Swarm.Language.Syntax (toDirection)
|
||||
|
||||
, lookup, lookupByName, contains, elems
|
||||
|
||||
-- ** Modification
|
||||
, insert, insertCount
|
||||
, delete, deleteCount, deleteAll
|
||||
|
||||
)
|
||||
where
|
||||
|
||||
import Brick (Widget)
|
||||
import Control.Arrow ((&&&))
|
||||
import Control.Lens (Getter, Lens', lens, to, view, (^.))
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Bifunctor (bimap, second)
|
||||
import Data.Char (toLower)
|
||||
import Data.Function (on)
|
||||
import Data.Hashable
|
||||
import Data.Int (Int64)
|
||||
import Data.IntMap (IntMap)
|
||||
import qualified Data.IntMap as IM
|
||||
import Data.IntSet (IntSet)
|
||||
import qualified Data.IntSet as IS
|
||||
import Data.List (foldl')
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics (Generic)
|
||||
import Linear
|
||||
import Prelude hiding (lookup)
|
||||
import Text.Read (readMaybe)
|
||||
import Witch
|
||||
|
||||
import Data.Yaml
|
||||
|
||||
import Swarm.Game.Display
|
||||
import Swarm.Language.Capability
|
||||
import Swarm.Language.Syntax (toDirection)
|
||||
|
||||
import Paths_swarm
|
||||
import Swarm.Util (plural)
|
||||
import Paths_swarm
|
||||
import Swarm.Util (plural)
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Properties
|
||||
@ -109,10 +122,14 @@ import Swarm.Util (plural)
|
||||
-- | Various properties that an entity can have, which affect how
|
||||
-- robots can interact with it.
|
||||
data EntityProperty
|
||||
= Unwalkable -- ^ Robots can't move onto a cell containing this entity.
|
||||
| Portable -- ^ Robots can pick this up (via 'Swarm.Language.Syntax.Grab').
|
||||
| Growable -- ^ Regrows from a seed after it is grabbed.
|
||||
| Liquid -- ^ Robots drown if they walk on this.
|
||||
= -- | Robots can't move onto a cell containing this entity.
|
||||
Unwalkable
|
||||
| -- | Robots can pick this up (via 'Swarm.Language.Syntax.Grab').
|
||||
Portable
|
||||
| -- | Regrows from a seed after it is grabbed.
|
||||
Growable
|
||||
| -- | Robots drown if they walk on this.
|
||||
Liquid
|
||||
deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, Hashable)
|
||||
|
||||
instance ToJSON EntityProperty where
|
||||
@ -120,11 +137,11 @@ instance ToJSON EntityProperty where
|
||||
|
||||
instance FromJSON EntityProperty where
|
||||
parseJSON = withText "EntityProperty" tryRead
|
||||
where
|
||||
tryRead :: Text -> Parser EntityProperty
|
||||
tryRead t = case readMaybe . from . T.toTitle $ t of
|
||||
Just c -> return c
|
||||
Nothing -> fail $ "Unknown entity property " ++ from t
|
||||
where
|
||||
tryRead :: Text -> Parser EntityProperty
|
||||
tryRead t = case readMaybe . from . T.toTitle $ t of
|
||||
Just c -> return c
|
||||
Nothing -> fail $ "Unknown entity property " ++ from t
|
||||
|
||||
-- | How long an entity takes to regrow. This represents the minimum
|
||||
-- and maximum amount of time taken by one growth stage (there are
|
||||
@ -180,46 +197,56 @@ defaultGrowthTime = GrowthTime (100, 200)
|
||||
-- entities stored in the world that are the same will literally
|
||||
-- just be stored as pointers to the same shared record.
|
||||
data Entity = Entity
|
||||
{ _entityHash :: Int -- ^ A hash value computed
|
||||
-- from the other fields
|
||||
, _entityDisplay :: Display -- ^ The way this entity
|
||||
-- should be displayed on
|
||||
-- the world map.
|
||||
, _entityName :: Text -- ^ The name of the
|
||||
-- entity, used /e.g./ in
|
||||
-- an inventory display.
|
||||
, _entityPlural :: Maybe Text -- ^ The plural of the
|
||||
-- entity name, in case
|
||||
-- it is irregular. If
|
||||
-- this field is
|
||||
-- @Nothing@, default
|
||||
-- pluralization
|
||||
-- heuristics will be
|
||||
-- used (see 'plural').
|
||||
, _entityDescription :: [Text] -- ^ A longer-form
|
||||
-- description. Each
|
||||
-- 'Text' value is one
|
||||
-- paragraph.
|
||||
, _entityOrientation :: Maybe (V2 Int64) -- ^ The entity's
|
||||
-- orientation (if it has
|
||||
-- one). For example,
|
||||
-- when a robot moves, it
|
||||
-- moves in the direction
|
||||
-- of its orientation.
|
||||
, _entityGrowth :: Maybe GrowthTime -- ^ If this entity grows,
|
||||
-- how long does it take?
|
||||
, _entityYields :: Maybe Text -- ^ The name of a
|
||||
-- different entity
|
||||
-- obtained when this
|
||||
-- entity is grabbed.
|
||||
, _entityProperties :: [EntityProperty] -- ^ Properties of the entity.
|
||||
, _entityCapabilities :: [Capability] -- ^ Capabilities provided
|
||||
-- by this entity.
|
||||
, _entityInventory :: Inventory -- ^ Inventory of other
|
||||
-- entities held by this
|
||||
-- entity.
|
||||
{ -- | A hash value computed
|
||||
-- from the other fields
|
||||
_entityHash :: Int
|
||||
, -- | The way this entity
|
||||
-- should be displayed on
|
||||
-- the world map.
|
||||
_entityDisplay :: Display
|
||||
, -- | The name of the
|
||||
-- entity, used /e.g./ in
|
||||
-- an inventory display.
|
||||
_entityName :: Text
|
||||
, -- | The plural of the
|
||||
-- entity name, in case
|
||||
-- it is irregular. If
|
||||
-- this field is
|
||||
-- @Nothing@, default
|
||||
-- pluralization
|
||||
-- heuristics will be
|
||||
-- used (see 'plural').
|
||||
_entityPlural :: Maybe Text
|
||||
, -- | A longer-form
|
||||
-- description. Each
|
||||
-- 'Text' value is one
|
||||
-- paragraph.
|
||||
_entityDescription :: [Text]
|
||||
, -- | The entity's
|
||||
-- orientation (if it has
|
||||
-- one). For example,
|
||||
-- when a robot moves, it
|
||||
-- moves in the direction
|
||||
-- of its orientation.
|
||||
_entityOrientation :: Maybe (V2 Int64)
|
||||
, -- | If this entity grows,
|
||||
-- how long does it take?
|
||||
_entityGrowth :: Maybe GrowthTime
|
||||
, -- | The name of a
|
||||
-- different entity
|
||||
-- obtained when this
|
||||
-- entity is grabbed.
|
||||
_entityYields :: Maybe Text
|
||||
, -- | Properties of the entity.
|
||||
_entityProperties :: [EntityProperty]
|
||||
, -- | Capabilities provided
|
||||
-- by this entity.
|
||||
_entityCapabilities :: [Capability]
|
||||
, -- | Inventory of other
|
||||
-- entities held by this
|
||||
-- entity.
|
||||
_entityInventory :: Inventory
|
||||
}
|
||||
|
||||
-- Note that an entity does not have a location, because the
|
||||
-- location of an entity is implicit in the way it is stored (by
|
||||
-- location).
|
||||
@ -229,17 +256,17 @@ data Entity = Entity
|
||||
-- | The @Hashable@ instance for @Entity@ ignores the cached hash
|
||||
-- value and simply combines the other fields.
|
||||
instance Hashable Entity where
|
||||
hashWithSalt s (Entity _ disp nm pl descr orient grow yld props caps inv)
|
||||
= s `hashWithSalt` disp
|
||||
`hashWithSalt` nm
|
||||
`hashWithSalt` pl
|
||||
`hashWithSalt` descr
|
||||
`hashWithSalt` orient
|
||||
`hashWithSalt` grow
|
||||
`hashWithSalt` yld
|
||||
`hashWithSalt` props
|
||||
`hashWithSalt` caps
|
||||
`hashWithSalt` inv
|
||||
hashWithSalt s (Entity _ disp nm pl descr orient grow yld props caps inv) =
|
||||
s `hashWithSalt` disp
|
||||
`hashWithSalt` nm
|
||||
`hashWithSalt` pl
|
||||
`hashWithSalt` descr
|
||||
`hashWithSalt` orient
|
||||
`hashWithSalt` grow
|
||||
`hashWithSalt` yld
|
||||
`hashWithSalt` props
|
||||
`hashWithSalt` caps
|
||||
`hashWithSalt` inv
|
||||
|
||||
-- | Entities are compared by hash for efficiency.
|
||||
instance Eq Entity where
|
||||
@ -251,19 +278,23 @@ instance Ord Entity where
|
||||
|
||||
-- | Recompute an entity's hash value.
|
||||
rehashEntity :: Entity -> Entity
|
||||
rehashEntity e = e { _entityHash = hash e }
|
||||
rehashEntity e = e {_entityHash = hash e}
|
||||
|
||||
-- | Create an entity with no orientation, an empty inventory,
|
||||
-- providing no capabilities (automatically filling in the hash
|
||||
-- value).
|
||||
mkEntity
|
||||
:: Display -- ^ Display
|
||||
-> Text -- ^ Entity name
|
||||
-> [Text] -- ^ Entity description
|
||||
-> [EntityProperty] -- ^ Properties
|
||||
-> Entity
|
||||
mkEntity disp nm descr props
|
||||
= rehashEntity $ Entity 0 disp nm Nothing descr Nothing Nothing Nothing props [] empty
|
||||
mkEntity ::
|
||||
-- | Display
|
||||
Display ->
|
||||
-- | Entity name
|
||||
Text ->
|
||||
-- | Entity description
|
||||
[Text] ->
|
||||
-- | Properties
|
||||
[EntityProperty] ->
|
||||
Entity
|
||||
mkEntity disp nm descr props =
|
||||
rehashEntity $ Entity 0 disp nm Nothing descr Nothing Nothing Nothing props [] empty
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Entity map
|
||||
@ -274,7 +305,7 @@ mkEntity disp nm descr props
|
||||
-- capabilities they provide (if any).
|
||||
data EntityMap = EntityMap
|
||||
{ entitiesByName :: Map Text Entity
|
||||
, entitiesByCap :: Map Capability Entity
|
||||
, entitiesByCap :: Map Capability Entity
|
||||
}
|
||||
|
||||
-- | Find an entity with the given name.
|
||||
@ -290,51 +321,48 @@ deviceForCap cap = M.lookup cap . entitiesByCap
|
||||
-- this will be called once at startup, when loading the entities
|
||||
-- from a file; see 'loadEntities'.
|
||||
buildEntityMap :: [Entity] -> EntityMap
|
||||
buildEntityMap es = EntityMap
|
||||
{ entitiesByName = M.fromList . map (view entityName &&& id) $ es
|
||||
, entitiesByCap = M.fromList . concatMap (\e -> map (,e) (e ^. entityCapabilities)) $ es
|
||||
}
|
||||
buildEntityMap es =
|
||||
EntityMap
|
||||
{ entitiesByName = M.fromList . map (view entityName &&& id) $ es
|
||||
, entitiesByCap = M.fromList . concatMap (\e -> map (,e) (e ^. entityCapabilities)) $ es
|
||||
}
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Serialization
|
||||
------------------------------------------------------------
|
||||
|
||||
instance FromJSON Entity where
|
||||
parseJSON = withObject "Entity" $ \v -> rehashEntity <$>
|
||||
(Entity
|
||||
<$> pure 0
|
||||
<*> v .: "display"
|
||||
<*> v .: "name"
|
||||
<*> v .:? "plural"
|
||||
<*> (map reflow <$> (v .: "description"))
|
||||
<*> v .:? "orientation"
|
||||
<*> v .:? "growth"
|
||||
<*> v .:? "yields"
|
||||
<*> v .:? "properties" .!= []
|
||||
<*> v .:? "capabilities" .!= []
|
||||
<*> pure empty
|
||||
)
|
||||
where
|
||||
reflow = T.unwords . T.words
|
||||
parseJSON = withObject "Entity" $ \v ->
|
||||
rehashEntity
|
||||
<$> ( Entity
|
||||
<$> pure 0
|
||||
<*> v .: "display"
|
||||
<*> v .: "name"
|
||||
<*> v .:? "plural"
|
||||
<*> (map reflow <$> (v .: "description"))
|
||||
<*> v .:? "orientation"
|
||||
<*> v .:? "growth"
|
||||
<*> v .:? "yields"
|
||||
<*> v .:? "properties" .!= []
|
||||
<*> v .:? "capabilities" .!= []
|
||||
<*> pure empty
|
||||
)
|
||||
where
|
||||
reflow = T.unwords . T.words
|
||||
|
||||
instance ToJSON Entity where
|
||||
toJSON e = object $
|
||||
[ "display" .= (e ^. entityDisplay)
|
||||
, "name" .= (e ^. entityName)
|
||||
, "description" .= (e ^. entityDescription)
|
||||
]
|
||||
++
|
||||
[ "plural" .= (e ^. entityPlural) | isJust (e ^. entityPlural) ]
|
||||
++
|
||||
[ "orientation" .= (e ^. entityOrientation) | isJust (e ^. entityOrientation) ]
|
||||
++
|
||||
[ "growth" .= (e ^. entityGrowth) | isJust (e ^. entityGrowth) ]
|
||||
++
|
||||
[ "yields" .= (e ^. entityYields) | isJust (e ^. entityYields) ]
|
||||
++
|
||||
[ "properties" .= (e ^. entityProperties) | not . null $ e ^. entityProperties ]
|
||||
++
|
||||
[ "capabilities" .= (e ^. entityCapabilities) | not . null $ e ^. entityCapabilities ]
|
||||
toJSON e =
|
||||
object $
|
||||
[ "display" .= (e ^. entityDisplay)
|
||||
, "name" .= (e ^. entityName)
|
||||
, "description" .= (e ^. entityDescription)
|
||||
]
|
||||
++ ["plural" .= (e ^. entityPlural) | isJust (e ^. entityPlural)]
|
||||
++ ["orientation" .= (e ^. entityOrientation) | isJust (e ^. entityOrientation)]
|
||||
++ ["growth" .= (e ^. entityGrowth) | isJust (e ^. entityGrowth)]
|
||||
++ ["yields" .= (e ^. entityYields) | isJust (e ^. entityYields)]
|
||||
++ ["properties" .= (e ^. entityProperties) | not . null $ e ^. entityProperties]
|
||||
++ ["capabilities" .= (e ^. entityCapabilities) | not . null $ e ^. entityCapabilities]
|
||||
|
||||
-- | Load entities from a data file called @entities.yaml@, producing
|
||||
-- either an 'EntityMap' or a pretty-printed parse error.
|
||||
@ -366,16 +394,16 @@ entityHash = to _entityHash
|
||||
|
||||
-- | The 'Display' explaining how to draw this entity in the world display.
|
||||
entityDisplay :: Lens' Entity Display
|
||||
entityDisplay = hashedLens _entityDisplay (\e x -> e { _entityDisplay = x })
|
||||
entityDisplay = hashedLens _entityDisplay (\e x -> e {_entityDisplay = x})
|
||||
|
||||
-- | The name of the entity.
|
||||
entityName :: Lens' Entity Text
|
||||
entityName = hashedLens _entityName (\e x -> e { _entityName = x })
|
||||
entityName = hashedLens _entityName (\e x -> e {_entityName = x})
|
||||
|
||||
-- | The irregular plural version of the entity's name, if there is
|
||||
-- one.
|
||||
entityPlural :: Lens' Entity (Maybe Text)
|
||||
entityPlural = hashedLens _entityPlural (\e x -> e { _entityPlural = x })
|
||||
entityPlural = hashedLens _entityPlural (\e x -> e {_entityPlural = x})
|
||||
|
||||
-- | Get a version of the entity's name appropriate to the
|
||||
-- number---the singular name for 1, and a plural name for any other
|
||||
@ -391,24 +419,24 @@ entityNameFor _ = to $ \e ->
|
||||
-- | A longer, free-form description of the entity. Each 'Text' value
|
||||
-- represents a paragraph.
|
||||
entityDescription :: Lens' Entity [Text]
|
||||
entityDescription = hashedLens _entityDescription (\e x -> e { _entityDescription = x })
|
||||
entityDescription = hashedLens _entityDescription (\e x -> e {_entityDescription = x})
|
||||
|
||||
-- | The direction this entity is facing (if it has one).
|
||||
entityOrientation :: Lens' Entity (Maybe (V2 Int64))
|
||||
entityOrientation = hashedLens _entityOrientation (\e x -> e { _entityOrientation = x })
|
||||
entityOrientation = hashedLens _entityOrientation (\e x -> e {_entityOrientation = x})
|
||||
|
||||
-- | How long this entity takes to grow, if it regrows.
|
||||
entityGrowth :: Lens' Entity (Maybe GrowthTime)
|
||||
entityGrowth = hashedLens _entityGrowth (\e x -> e { _entityGrowth = x })
|
||||
entityGrowth = hashedLens _entityGrowth (\e x -> e {_entityGrowth = x})
|
||||
|
||||
-- | The name of a different entity yielded when this entity is
|
||||
-- grabbed, if any.
|
||||
entityYields :: Lens' Entity (Maybe Text)
|
||||
entityYields = hashedLens _entityYields (\e x -> e { _entityYields = x })
|
||||
entityYields = hashedLens _entityYields (\e x -> e {_entityYields = x})
|
||||
|
||||
-- | The properties enjoyed by this entity.
|
||||
entityProperties :: Lens' Entity [EntityProperty]
|
||||
entityProperties = hashedLens _entityProperties (\e x -> e { _entityProperties = x })
|
||||
entityProperties = hashedLens _entityProperties (\e x -> e {_entityProperties = x})
|
||||
|
||||
-- | Test whether an entity has a certain property.
|
||||
hasProperty :: Entity -> EntityProperty -> Bool
|
||||
@ -416,11 +444,11 @@ hasProperty e p = p `elem` (e ^. entityProperties)
|
||||
|
||||
-- | The capabilities this entity provides when installed.
|
||||
entityCapabilities :: Lens' Entity [Capability]
|
||||
entityCapabilities = hashedLens _entityCapabilities (\e x -> e { _entityCapabilities = x })
|
||||
entityCapabilities = hashedLens _entityCapabilities (\e x -> e {_entityCapabilities = x})
|
||||
|
||||
-- | The inventory of other entities carried by this entity.
|
||||
entityInventory :: Lens' Entity Inventory
|
||||
entityInventory = hashedLens _entityInventory (\e x -> e { _entityInventory = x })
|
||||
entityInventory = hashedLens _entityInventory (\e x -> e {_entityInventory = x})
|
||||
|
||||
-- | Display an entity as a single character.
|
||||
displayEntity :: Entity -> Widget n
|
||||
@ -438,10 +466,10 @@ type Count = Int
|
||||
-- it contains some entities, along with the number of times each
|
||||
-- occurs. Entities can be looked up directly, or by name.
|
||||
data Inventory = Inventory
|
||||
{ counts :: IntMap (Count, Entity) -- main map
|
||||
, byName :: Map Text IntSet -- Mirrors the main map; just
|
||||
-- caching the ability to
|
||||
-- look up by name.
|
||||
{ counts :: IntMap (Count, Entity) -- main map
|
||||
, byName :: Map Text IntSet -- Mirrors the main map; just
|
||||
-- caching the ability to
|
||||
-- look up by name.
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
@ -458,8 +486,8 @@ lookup e (Inventory cs _) = maybe 0 fst $ IM.lookup (e ^. entityHash) cs
|
||||
-- | Look up an entity by name in an inventory, returning a list of
|
||||
-- matching entities.
|
||||
lookupByName :: Text -> Inventory -> [Entity]
|
||||
lookupByName name (Inventory cs byN)
|
||||
= maybe [] (map (snd . (cs IM.!)) . IS.elems) (M.lookup (T.toLower name) byN)
|
||||
lookupByName name (Inventory cs byN) =
|
||||
maybe [] (map (snd . (cs IM.!)) . IS.elems) (M.lookup (T.toLower name) byN)
|
||||
|
||||
-- | The empty inventory.
|
||||
empty :: Inventory
|
||||
@ -482,10 +510,10 @@ fromList = foldl' (flip insert) empty
|
||||
-- If the inventory already contains this entity, then only its
|
||||
-- count will be incremented.
|
||||
insertCount :: Count -> Entity -> Inventory -> Inventory
|
||||
insertCount cnt e (Inventory cs byN)
|
||||
= Inventory
|
||||
(IM.insertWith (\(m,_) (n,_) -> (m+n,e)) (e ^. entityHash) (cnt,e) cs)
|
||||
(M.insertWith IS.union (T.toLower $ e ^. entityName) (IS.singleton (e ^. entityHash)) byN)
|
||||
insertCount cnt e (Inventory cs byN) =
|
||||
Inventory
|
||||
(IM.insertWith (\(m, _) (n, _) -> (m + n, e)) (e ^. entityHash) (cnt, e) cs)
|
||||
(M.insertWith IS.union (T.toLower $ e ^. entityName) (IS.singleton (e ^. entityHash)) byN)
|
||||
|
||||
-- | Check whether an inventory contains a given entity.
|
||||
contains :: Inventory -> Entity -> Bool
|
||||
@ -498,26 +526,26 @@ delete = deleteCount 1
|
||||
-- | Delete a specified number of copies of an entity from an inventory.
|
||||
deleteCount :: Count -> Entity -> Inventory -> Inventory
|
||||
deleteCount k e (Inventory cs byN) = Inventory cs' byN'
|
||||
where
|
||||
cs' = IM.alter removeCount (e ^. entityHash) cs
|
||||
newCount = lookup e (Inventory cs' byN)
|
||||
where
|
||||
cs' = IM.alter removeCount (e ^. entityHash) cs
|
||||
newCount = lookup e (Inventory cs' byN)
|
||||
|
||||
byN'
|
||||
| newCount == 0 = M.adjust (IS.delete (e ^. entityHash)) (e ^. entityName) byN
|
||||
| otherwise = byN
|
||||
byN'
|
||||
| newCount == 0 = M.adjust (IS.delete (e ^. entityHash)) (e ^. entityName) byN
|
||||
| otherwise = byN
|
||||
|
||||
removeCount :: Maybe (Count, a) -> Maybe (Count, a)
|
||||
removeCount Nothing = Nothing
|
||||
removeCount (Just (n, a))
|
||||
| k >= n = Nothing
|
||||
| otherwise = Just (n-k, a)
|
||||
removeCount :: Maybe (Count, a) -> Maybe (Count, a)
|
||||
removeCount Nothing = Nothing
|
||||
removeCount (Just (n, a))
|
||||
| k >= n = Nothing
|
||||
| otherwise = Just (n - k, a)
|
||||
|
||||
-- | Delete all copies of a certain entity from an inventory.
|
||||
deleteAll :: Entity -> Inventory -> Inventory
|
||||
deleteAll e (Inventory cs byN)
|
||||
= Inventory
|
||||
(IM.alter (const Nothing) (e ^. entityHash) cs)
|
||||
(M.adjust (IS.delete (e ^. entityHash)) (e ^. entityName) byN)
|
||||
deleteAll e (Inventory cs byN) =
|
||||
Inventory
|
||||
(IM.alter (const Nothing) (e ^. entityHash) cs)
|
||||
(M.adjust (IS.delete (e ^. entityHash)) (e ^. entityName) byN)
|
||||
|
||||
-- | Get the entities in an inventory and their associated counts.
|
||||
elems :: Inventory -> [(Count, Entity)]
|
||||
|
@ -1,4 +1,7 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Game.CEK
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -7,60 +10,56 @@
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
--
|
||||
-- Runtime exceptions for the Swarm language interpreter.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.Game.Exception (
|
||||
Exn (..),
|
||||
formatExn,
|
||||
) where
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
|
||||
module Swarm.Game.Exception
|
||||
( Exn(..)
|
||||
, formatExn
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Swarm.Language.Capability
|
||||
import Swarm.Language.Pretty (prettyText)
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Util
|
||||
import Swarm.Language.Capability
|
||||
import Swarm.Language.Pretty (prettyText)
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Util
|
||||
|
||||
-- | The type of exceptions that can be thrown by robot programs.
|
||||
data Exn
|
||||
-- | Something went very wrong. This is a bug in Swarm and cannot
|
||||
= -- | Something went very wrong. This is a bug in Swarm and cannot
|
||||
-- be caught by a @try@ block (but at least it will not crash
|
||||
-- the entire UI).
|
||||
= Fatal Text
|
||||
|
||||
-- | A robot tried to do something for which it does not have some
|
||||
Fatal Text
|
||||
| -- | A robot tried to do something for which it does not have some
|
||||
-- of the required capabilities. This cannot be caught by a
|
||||
-- @try@ block.
|
||||
| Incapable (Set Capability) Term
|
||||
|
||||
-- | A command failed in some "normal" way (/e.g./ a 'Move'
|
||||
Incapable (Set Capability) Term
|
||||
| -- | A command failed in some "normal" way (/e.g./ a 'Move'
|
||||
-- command could not move, or a 'Grab' command found nothing to
|
||||
-- grab, /etc./).
|
||||
| CmdFailed Const Text
|
||||
|
||||
-- | The user program explicitly called 'Raise'.
|
||||
| User Text
|
||||
CmdFailed Const Text
|
||||
| -- | The user program explicitly called 'Raise'.
|
||||
User Text
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Pretty-print an exception for displaying to the user.
|
||||
formatExn :: Exn -> Text
|
||||
formatExn (Fatal t) = T.unlines
|
||||
[ T.append "fatal error: " t
|
||||
, "Please report this as a bug at https://github.com/byorgey/swarm/issues/new ."
|
||||
]
|
||||
formatExn (Incapable caps tm) = T.unlines
|
||||
[ T.concat
|
||||
[ "missing ", number (S.size caps) "capability", " "
|
||||
, (commaList . map (squote . prettyText) . S.toList) caps, " needed to execute:"
|
||||
formatExn (Fatal t) =
|
||||
T.unlines
|
||||
[ T.append "fatal error: " t
|
||||
, "Please report this as a bug at https://github.com/byorgey/swarm/issues/new ."
|
||||
]
|
||||
formatExn (Incapable caps tm) =
|
||||
T.unlines
|
||||
[ T.concat
|
||||
[ "missing "
|
||||
, number (S.size caps) "capability"
|
||||
, " "
|
||||
, (commaList . map (squote . prettyText) . S.toList) caps
|
||||
, " needed to execute:"
|
||||
]
|
||||
, prettyText tm
|
||||
]
|
||||
, prettyText tm
|
||||
]
|
||||
formatExn (CmdFailed c t) = T.concat [prettyText c, ": ", t]
|
||||
formatExn (User t) = T.concat ["user exception: ", t]
|
||||
formatExn (User t) = T.concat ["user exception: ", t]
|
||||
|
@ -1,4 +1,13 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Game.Recipe
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -8,48 +17,41 @@
|
||||
--
|
||||
-- A recipe represents some kind of process for transforming
|
||||
-- some input entities into some output entities.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.Game.Recipe (
|
||||
-- * Ingredient lists and recipes
|
||||
IngredientList,
|
||||
Recipe (..),
|
||||
recipeInputs,
|
||||
recipeOutputs,
|
||||
prettyRecipe,
|
||||
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
-- * Loading recipes
|
||||
loadRecipes,
|
||||
outRecipeMap,
|
||||
inRecipeMap,
|
||||
|
||||
module Swarm.Game.Recipe
|
||||
( -- * Ingredient lists and recipes
|
||||
-- * Looking up recipes
|
||||
recipesFor,
|
||||
make,
|
||||
) where
|
||||
|
||||
IngredientList, Recipe(..), recipeInputs, recipeOutputs
|
||||
, prettyRecipe
|
||||
import Control.Lens hiding (from, (.=))
|
||||
import Control.Monad.Except
|
||||
import Data.Bifunctor (second)
|
||||
import Data.Either.Validation
|
||||
import Data.IntMap (IntMap)
|
||||
import qualified Data.IntMap as IM
|
||||
import Data.List (foldl')
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Witch
|
||||
|
||||
-- * Loading recipes
|
||||
, loadRecipes, outRecipeMap, inRecipeMap
|
||||
import Data.Yaml
|
||||
|
||||
-- * Looking up recipes
|
||||
, recipesFor, make
|
||||
|
||||
) where
|
||||
|
||||
import Control.Lens hiding (from, (.=))
|
||||
import Control.Monad.Except
|
||||
import Data.Bifunctor (second)
|
||||
import Data.Either.Validation
|
||||
import Data.IntMap (IntMap)
|
||||
import qualified Data.IntMap as IM
|
||||
import Data.List (foldl')
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Witch
|
||||
|
||||
import Data.Yaml
|
||||
|
||||
import Paths_swarm
|
||||
import Swarm.Game.Entity as E
|
||||
import Swarm.Util
|
||||
import Paths_swarm
|
||||
import Swarm.Game.Entity as E
|
||||
import Swarm.Util
|
||||
|
||||
-- | An ingredient list is a list of entities with multiplicity. It
|
||||
-- is polymorphic in the entity type so that we can use either
|
||||
@ -62,7 +64,7 @@ type IngredientList e = [(Count, e)]
|
||||
-- represents some kind of process where the inputs are
|
||||
-- transformed into the outputs.
|
||||
data Recipe e = Recipe
|
||||
{ _recipeInputs :: IngredientList e
|
||||
{ _recipeInputs :: IngredientList e
|
||||
, _recipeOutputs :: IngredientList e
|
||||
}
|
||||
deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
|
||||
@ -80,10 +82,11 @@ recipeOutputs :: Lens' (Recipe e) (IngredientList e)
|
||||
------------------------------------------------------------
|
||||
|
||||
instance ToJSON (Recipe Text) where
|
||||
toJSON (Recipe ins outs) = object
|
||||
[ "in" .= ins
|
||||
, "out" .= outs
|
||||
]
|
||||
toJSON (Recipe ins outs) =
|
||||
object
|
||||
[ "in" .= ins
|
||||
, "out" .= outs
|
||||
]
|
||||
|
||||
instance FromJSON (Recipe Text) where
|
||||
parseJSON = withObject "Recipe" $ \v ->
|
||||
@ -99,33 +102,34 @@ resolveRecipes em = (traverse . traverse) (\t -> maybe (Failure [t]) Success (lo
|
||||
-- recipes from the data file @recipes.yaml@.
|
||||
loadRecipes :: MonadIO m => EntityMap -> m (Either Text [Recipe Entity])
|
||||
loadRecipes em = runExceptT $ do
|
||||
fileName <- liftIO $ getDataFileName "recipes.yaml"
|
||||
res <- liftIO $ decodeFileEither @[Recipe Text] fileName
|
||||
textRecipes <- res `isRightOr` (from . prettyPrintParseException)
|
||||
resolveRecipes em textRecipes `isSuccessOr`
|
||||
(T.append "Unknown entities in recipe(s): " . T.intercalate ", ")
|
||||
fileName <- liftIO $ getDataFileName "recipes.yaml"
|
||||
res <- liftIO $ decodeFileEither @[Recipe Text] fileName
|
||||
textRecipes <- res `isRightOr` (from . prettyPrintParseException)
|
||||
resolveRecipes em textRecipes
|
||||
`isSuccessOr` (T.append "Unknown entities in recipe(s): " . T.intercalate ", ")
|
||||
|
||||
------------------------------------------------------------
|
||||
|
||||
-- | Pretty-print a recipe in the form @input1 + input2 -> output1 + output2@.
|
||||
prettyRecipe :: Recipe Entity -> Text
|
||||
prettyRecipe (Recipe ins outs) =
|
||||
T.concat [ prettyIngredientList ins, " -> ", prettyIngredientList outs ]
|
||||
T.concat [prettyIngredientList ins, " -> ", prettyIngredientList outs]
|
||||
|
||||
-- | Pretty-print an ingredient list in the form @n1 input1 + n2 input2 + ...@
|
||||
prettyIngredientList :: IngredientList Entity -> Text
|
||||
prettyIngredientList = T.intercalate " + " . map prettyIngredient
|
||||
where
|
||||
prettyIngredient (n,e) = T.concat [ into @Text (show n), " ", e ^. entityNameFor n ]
|
||||
where
|
||||
prettyIngredient (n, e) = T.concat [into @Text (show n), " ", e ^. entityNameFor n]
|
||||
|
||||
-- | Build a map of recipes either by inputs or outputs.
|
||||
buildRecipeMap
|
||||
:: Getter (Recipe Entity) (IngredientList Entity)
|
||||
-> [Recipe Entity] -> IntMap [Recipe Entity]
|
||||
buildRecipeMap ::
|
||||
Getter (Recipe Entity) (IngredientList Entity) ->
|
||||
[Recipe Entity] ->
|
||||
IntMap [Recipe Entity]
|
||||
buildRecipeMap select recipeList =
|
||||
IM.fromListWith (++) (map (second (:[])) (concatMap mk recipeList))
|
||||
where
|
||||
mk r = [(e ^. entityHash, r) | (_, e) <- r ^. select]
|
||||
IM.fromListWith (++) (map (second (: [])) (concatMap mk recipeList))
|
||||
where
|
||||
mk r = [(e ^. entityHash, r) | (_, e) <- r ^. select]
|
||||
|
||||
-- | Build a map of recipes indexed by output ingredients.
|
||||
outRecipeMap :: [Recipe Entity] -> IntMap [Recipe Entity]
|
||||
@ -145,8 +149,8 @@ inRecipeMap = buildRecipeMap recipeInputs
|
||||
-- | Figure out which ingredients (if any) are lacking from an
|
||||
-- inventory to be able to carry out the recipe.
|
||||
missingIngredientsFor :: Inventory -> Recipe Entity -> [(Count, Entity)]
|
||||
missingIngredientsFor inv (Recipe ins _)
|
||||
= filter ((>0) . fst) $ map (\(n,e) -> (n - E.lookup e inv, e)) ins
|
||||
missingIngredientsFor inv (Recipe ins _) =
|
||||
filter ((> 0) . fst) $ map (\(n, e) -> (n - E.lookup e inv, e)) ins
|
||||
|
||||
-- | Try to make a recipe, deleting the recipe's inputs from the
|
||||
-- inventory and adding the outputs. Return either a description of
|
||||
@ -154,6 +158,7 @@ missingIngredientsFor inv (Recipe ins _)
|
||||
-- sufficient inputs, or an updated inventory if it was successful.
|
||||
make :: Inventory -> Recipe Entity -> Either [(Count, Entity)] Inventory
|
||||
make inv r@(Recipe ins outs) = case missingIngredientsFor inv r of
|
||||
[] -> Right $
|
||||
foldl' (flip (uncurry insertCount)) (foldl' (flip (uncurry deleteCount)) inv ins) outs
|
||||
[] ->
|
||||
Right $
|
||||
foldl' (flip (uncurry insertCount)) (foldl' (flip (uncurry deleteCount)) inv ins) outs
|
||||
missing -> Left missing
|
||||
|
@ -1,4 +1,8 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Game.Robot
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -7,77 +11,82 @@
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
--
|
||||
-- A data type to represent robots.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.Game.Robot (
|
||||
-- * Robots
|
||||
Robot,
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
-- ** Lenses
|
||||
robotEntity,
|
||||
robotName,
|
||||
robotDisplay,
|
||||
robotLocation,
|
||||
robotOrientation,
|
||||
robotInventory,
|
||||
installedDevices,
|
||||
inventoryHash,
|
||||
robotCapabilities,
|
||||
robotCtx,
|
||||
robotEnv,
|
||||
machine,
|
||||
systemRobot,
|
||||
selfDestruct,
|
||||
tickSteps,
|
||||
|
||||
module Swarm.Game.Robot
|
||||
( -- * Robots
|
||||
-- ** Create
|
||||
mkRobot,
|
||||
baseRobot,
|
||||
|
||||
Robot
|
||||
-- ** Query
|
||||
isActive,
|
||||
getResult,
|
||||
) where
|
||||
|
||||
-- ** Lenses
|
||||
, robotEntity, robotName, robotDisplay, robotLocation, robotOrientation, robotInventory
|
||||
, installedDevices, inventoryHash, robotCapabilities
|
||||
, robotCtx, robotEnv, machine, systemRobot, selfDestruct, tickSteps
|
||||
import Control.Lens hiding (contains)
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (isNothing)
|
||||
import Data.Set (Set)
|
||||
import Data.Set.Lens (setOf)
|
||||
import Data.Text (Text)
|
||||
import Linear
|
||||
|
||||
-- ** Create
|
||||
|
||||
, mkRobot, baseRobot
|
||||
|
||||
-- ** Query
|
||||
|
||||
, isActive, getResult
|
||||
) where
|
||||
|
||||
import Control.Lens hiding (contains)
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (isNothing)
|
||||
import Data.Set (Set)
|
||||
import Data.Set.Lens (setOf)
|
||||
import Data.Text (Text)
|
||||
import Linear
|
||||
|
||||
import Data.Hashable (hashWithSalt)
|
||||
import Swarm.Game.CEK
|
||||
import Swarm.Game.Display
|
||||
import Swarm.Game.Entity hiding (empty)
|
||||
import Swarm.Game.Value as V
|
||||
import Swarm.Language.Capability
|
||||
import Swarm.Language.Context
|
||||
import Swarm.Language.Types (TCtx)
|
||||
import Data.Hashable (hashWithSalt)
|
||||
import Swarm.Game.CEK
|
||||
import Swarm.Game.Display
|
||||
import Swarm.Game.Entity hiding (empty)
|
||||
import Swarm.Game.Value as V
|
||||
import Swarm.Language.Capability
|
||||
import Swarm.Language.Context
|
||||
import Swarm.Language.Types (TCtx)
|
||||
|
||||
-- | A value of type 'Robot' is a record representing the state of a
|
||||
-- single robot.
|
||||
data Robot = Robot
|
||||
{ _robotEntity :: Entity
|
||||
, _installedDevices :: Inventory
|
||||
, _robotCapabilities :: Set Capability
|
||||
-- ^ A cached view of the capabilities this robot has.
|
||||
{ _robotEntity :: Entity
|
||||
, _installedDevices :: Inventory
|
||||
, -- | A cached view of the capabilities this robot has.
|
||||
-- Automatically generated from '_installedDevices'.
|
||||
|
||||
, _robotLocation :: V2 Int64
|
||||
, _robotCtx :: (TCtx, CapCtx)
|
||||
, _robotEnv :: Env
|
||||
, _machine :: CEK
|
||||
, _systemRobot :: Bool
|
||||
, _selfDestruct :: Bool
|
||||
, _tickSteps :: Int
|
||||
_robotCapabilities :: Set Capability
|
||||
, _robotLocation :: V2 Int64
|
||||
, _robotCtx :: (TCtx, CapCtx)
|
||||
, _robotEnv :: Env
|
||||
, _machine :: CEK
|
||||
, _systemRobot :: Bool
|
||||
, _selfDestruct :: Bool
|
||||
, _tickSteps :: Int
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- See https://byorgey.wordpress.com/2021/09/17/automatically-updated-cached-views-with-lens/
|
||||
-- for the approach used here with lenses.
|
||||
|
||||
let exclude = ['_robotCapabilities, '_installedDevices] in
|
||||
makeLensesWith
|
||||
(lensRules
|
||||
& generateSignatures .~ False
|
||||
& lensField . mapped . mapped %~ \fn n ->
|
||||
if n `elem` exclude then [] else fn n)
|
||||
''Robot
|
||||
let exclude = ['_robotCapabilities, '_installedDevices]
|
||||
in makeLensesWith
|
||||
( lensRules
|
||||
& generateSignatures .~ False
|
||||
& lensField . mapped . mapped %~ \fn n ->
|
||||
if n `elem` exclude then [] else fn n
|
||||
)
|
||||
''Robot
|
||||
|
||||
-- | Robots are not entities, but they have almost all the
|
||||
-- characteristics of one (or perhaps we could think of robots as
|
||||
@ -120,11 +129,12 @@ robotInventory = robotEntity . entityInventory
|
||||
-- see whether the robot has a certain capability (see 'robotCapabilities')
|
||||
installedDevices :: Lens' Robot Inventory
|
||||
installedDevices = lens _installedDevices setInstalled
|
||||
where
|
||||
setInstalled r inst =
|
||||
r { _installedDevices = inst
|
||||
, _robotCapabilities = inventoryCapabilities inst
|
||||
}
|
||||
where
|
||||
setInstalled r inst =
|
||||
r
|
||||
{ _installedDevices = inst
|
||||
, _robotCapabilities = inventoryCapabilities inst
|
||||
}
|
||||
|
||||
-- | A hash of a robot's entity record and installed devices, to
|
||||
-- facilitate quickly deciding whether we need to redraw the robot
|
||||
@ -201,54 +211,63 @@ selfDestruct :: Lens' Robot Bool
|
||||
tickSteps :: Lens' Robot Int
|
||||
|
||||
-- | Create a robot.
|
||||
mkRobot
|
||||
:: Text -- ^ Name of the robot. Precondition: it should not be the same as any
|
||||
-- other robot name.
|
||||
-> V2 Int64 -- ^ Initial location.
|
||||
-> V2 Int64 -- ^ Initial heading/direction.
|
||||
-> CEK -- ^ Initial CEK machine.
|
||||
-> [Entity] -- ^ Installed devices.
|
||||
-> Robot
|
||||
mkRobot name l d m devs = Robot
|
||||
{ _robotEntity = mkEntity
|
||||
defaultRobotDisplay
|
||||
name
|
||||
["A generic robot."]
|
||||
[]
|
||||
& entityOrientation ?~ d
|
||||
, _installedDevices = inst
|
||||
, _robotCapabilities = inventoryCapabilities inst
|
||||
, _robotLocation = l
|
||||
, _robotCtx = (empty, empty)
|
||||
, _robotEnv = empty
|
||||
, _machine = m
|
||||
, _systemRobot = False
|
||||
, _selfDestruct = False
|
||||
, _tickSteps = 0
|
||||
}
|
||||
where
|
||||
inst = fromList devs
|
||||
mkRobot ::
|
||||
-- | Name of the robot. Precondition: it should not be the same as any
|
||||
-- other robot name.
|
||||
Text ->
|
||||
-- | Initial location.
|
||||
V2 Int64 ->
|
||||
-- | Initial heading/direction.
|
||||
V2 Int64 ->
|
||||
-- | Initial CEK machine.
|
||||
CEK ->
|
||||
-- | Installed devices.
|
||||
[Entity] ->
|
||||
Robot
|
||||
mkRobot name l d m devs =
|
||||
Robot
|
||||
{ _robotEntity =
|
||||
mkEntity
|
||||
defaultRobotDisplay
|
||||
name
|
||||
["A generic robot."]
|
||||
[]
|
||||
& entityOrientation ?~ d
|
||||
, _installedDevices = inst
|
||||
, _robotCapabilities = inventoryCapabilities inst
|
||||
, _robotLocation = l
|
||||
, _robotCtx = (empty, empty)
|
||||
, _robotEnv = empty
|
||||
, _machine = m
|
||||
, _systemRobot = False
|
||||
, _selfDestruct = False
|
||||
, _tickSteps = 0
|
||||
}
|
||||
where
|
||||
inst = fromList devs
|
||||
|
||||
-- | The initial robot representing your "base".
|
||||
baseRobot :: [Entity] -> Robot
|
||||
baseRobot devs = Robot
|
||||
{ _robotEntity = mkEntity
|
||||
defaultRobotDisplay
|
||||
"base"
|
||||
["Your base of operations."]
|
||||
[]
|
||||
, _installedDevices = inst
|
||||
, _robotCapabilities = inventoryCapabilities inst
|
||||
, _robotLocation = V2 0 0
|
||||
, _robotCtx = (empty, empty)
|
||||
, _robotEnv = empty
|
||||
, _machine = idleMachine
|
||||
, _systemRobot = False
|
||||
, _selfDestruct = False
|
||||
, _tickSteps = 0
|
||||
}
|
||||
where
|
||||
inst = fromList devs
|
||||
baseRobot devs =
|
||||
Robot
|
||||
{ _robotEntity =
|
||||
mkEntity
|
||||
defaultRobotDisplay
|
||||
"base"
|
||||
["Your base of operations."]
|
||||
[]
|
||||
, _installedDevices = inst
|
||||
, _robotCapabilities = inventoryCapabilities inst
|
||||
, _robotLocation = V2 0 0
|
||||
, _robotCtx = (empty, empty)
|
||||
, _robotEnv = empty
|
||||
, _machine = idleMachine
|
||||
, _systemRobot = False
|
||||
, _selfDestruct = False
|
||||
, _tickSteps = 0
|
||||
}
|
||||
where
|
||||
inst = fromList devs
|
||||
|
||||
-- | Is the robot actively in the middle of a computation?
|
||||
isActive :: Robot -> Bool
|
||||
|
@ -1,4 +1,10 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Game.State
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -8,71 +14,73 @@
|
||||
--
|
||||
-- Definition of the record holding all the game-related state, and various related
|
||||
-- utility functions.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.Game.State (
|
||||
-- * Game state record
|
||||
ViewCenterRule (..),
|
||||
GameMode (..),
|
||||
REPLStatus (..),
|
||||
RunStatus (..),
|
||||
GameState,
|
||||
initGameState,
|
||||
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
-- ** GameState fields
|
||||
gameMode,
|
||||
runStatus,
|
||||
paused,
|
||||
robotMap,
|
||||
gensym,
|
||||
entityMap,
|
||||
recipesOut,
|
||||
recipesIn,
|
||||
world,
|
||||
viewCenterRule,
|
||||
viewCenter,
|
||||
needsRedraw,
|
||||
replStatus,
|
||||
messageQueue,
|
||||
focusedRobotName,
|
||||
|
||||
module Swarm.Game.State
|
||||
( -- * Game state record
|
||||
-- * Utilities
|
||||
applyViewCenterRule,
|
||||
recalcViewCenter,
|
||||
modifyViewCenter,
|
||||
viewingRegion,
|
||||
focusedRobot,
|
||||
ensureUniqueName,
|
||||
addRobot,
|
||||
emitMessage,
|
||||
) where
|
||||
|
||||
ViewCenterRule(..), GameMode(..), REPLStatus(..), RunStatus(..)
|
||||
import Control.Lens
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.State
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Int (Int64)
|
||||
import Data.IntMap (IntMap)
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Linear
|
||||
import Witch (into)
|
||||
|
||||
, GameState, initGameState
|
||||
|
||||
-- ** GameState fields
|
||||
|
||||
, gameMode, runStatus, paused, robotMap, gensym
|
||||
, entityMap, recipesOut, recipesIn, world
|
||||
, viewCenterRule, viewCenter
|
||||
, needsRedraw, replStatus, messageQueue
|
||||
, focusedRobotName
|
||||
|
||||
-- * Utilities
|
||||
|
||||
, applyViewCenterRule
|
||||
, recalcViewCenter
|
||||
, modifyViewCenter
|
||||
, viewingRegion
|
||||
|
||||
, focusedRobot
|
||||
, ensureUniqueName
|
||||
, addRobot
|
||||
|
||||
, emitMessage
|
||||
) where
|
||||
|
||||
import Control.Lens
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.State
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Int (Int64)
|
||||
import Data.IntMap (IntMap)
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Linear
|
||||
import Witch (into)
|
||||
|
||||
import Swarm.Game.Entity
|
||||
import Swarm.Game.Recipe
|
||||
import Swarm.Game.Robot
|
||||
import Swarm.Game.Value
|
||||
import qualified Swarm.Game.World as W
|
||||
import Swarm.Game.WorldGen (findGoodOrigin, testWorld2)
|
||||
import Swarm.Language.Types
|
||||
import Swarm.Util
|
||||
import Swarm.Game.Entity
|
||||
import Swarm.Game.Recipe
|
||||
import Swarm.Game.Robot
|
||||
import Swarm.Game.Value
|
||||
import qualified Swarm.Game.World as W
|
||||
import Swarm.Game.WorldGen (findGoodOrigin, testWorld2)
|
||||
import Swarm.Language.Types
|
||||
import Swarm.Util
|
||||
|
||||
-- | The 'ViewCenterRule' specifies how to determine the center of the
|
||||
-- world viewport.
|
||||
data ViewCenterRule
|
||||
= VCLocation (V2 Int64) -- ^ The view should be centered on an absolute position.
|
||||
| VCRobot Text -- ^ The view should be centered on a certain robot.
|
||||
= -- | The view should be centered on an absolute position.
|
||||
VCLocation (V2 Int64)
|
||||
| -- | The view should be centered on a certain robot.
|
||||
VCRobot Text
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
makePrisms ''ViewCenterRule
|
||||
@ -81,59 +89,62 @@ makePrisms ''ViewCenterRule
|
||||
-- At the moment, there are only two modes, but more will be added
|
||||
-- in the future.
|
||||
data GameMode
|
||||
= Classic -- ^ Explore an open world, gather resources, and upgrade your programming abilities.
|
||||
| Creative -- ^ Like 'Classic' mode, but there are no constraints on the programs you can write.
|
||||
= -- | Explore an open world, gather resources, and upgrade your programming abilities.
|
||||
Classic
|
||||
| -- | Like 'Classic' mode, but there are no constraints on the programs you can write.
|
||||
Creative
|
||||
deriving (Eq, Ord, Show, Read, Enum, Bounded)
|
||||
|
||||
-- | A data type to represent the current status of the REPL.
|
||||
data REPLStatus
|
||||
= REPLDone
|
||||
-- ^ The REPL is not doing anything actively at the moment.
|
||||
| REPLWorking Polytype (Maybe Value)
|
||||
-- ^ A command entered at the REPL is currently being run. The
|
||||
= -- | The REPL is not doing anything actively at the moment.
|
||||
REPLDone
|
||||
| -- | A command entered at the REPL is currently being run. The
|
||||
-- 'Polytype' represents the type of the expression that was
|
||||
-- entered. The @Maybe Value@ starts out as @Nothing@ and gets
|
||||
-- filled in with a result once the command completes.
|
||||
REPLWorking Polytype (Maybe Value)
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | A data type to keep track of the pause mode.
|
||||
data RunStatus
|
||||
= Running
|
||||
-- ^ The game is running.
|
||||
| ManualPause
|
||||
-- ^ The user paused the game, and it should stay pause after visiting the help.
|
||||
| AutoPause
|
||||
-- ^ The game got paused while visiting the help,
|
||||
= -- | The game is running.
|
||||
Running
|
||||
| -- | The user paused the game, and it should stay pause after visiting the help.
|
||||
ManualPause
|
||||
| -- | The game got paused while visiting the help,
|
||||
-- and it should unpause after returning back to the game.
|
||||
AutoPause
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | The main record holding the state for the game itself (as
|
||||
-- distinct from the UI). See the lenses below for access to its
|
||||
-- fields.
|
||||
data GameState = GameState
|
||||
{ _gameMode :: GameMode
|
||||
, _runStatus :: RunStatus
|
||||
, _robotMap :: Map Text Robot
|
||||
, _gensym :: Int
|
||||
, _entityMap :: EntityMap
|
||||
, _recipesOut :: IntMap [Recipe Entity]
|
||||
, _recipesIn :: IntMap [Recipe Entity]
|
||||
, _world :: W.World Int Entity
|
||||
, _viewCenterRule :: ViewCenterRule
|
||||
, _viewCenter :: V2 Int64
|
||||
, _needsRedraw :: Bool
|
||||
, _replStatus :: REPLStatus
|
||||
, _messageQueue :: [Text]
|
||||
{ _gameMode :: GameMode
|
||||
, _runStatus :: RunStatus
|
||||
, _robotMap :: Map Text Robot
|
||||
, _gensym :: Int
|
||||
, _entityMap :: EntityMap
|
||||
, _recipesOut :: IntMap [Recipe Entity]
|
||||
, _recipesIn :: IntMap [Recipe Entity]
|
||||
, _world :: W.World Int Entity
|
||||
, _viewCenterRule :: ViewCenterRule
|
||||
, _viewCenter :: V2 Int64
|
||||
, _needsRedraw :: Bool
|
||||
, _replStatus :: REPLStatus
|
||||
, _messageQueue :: [Text]
|
||||
, _focusedRobotName :: Text
|
||||
}
|
||||
|
||||
let exclude = ['_viewCenter, '_focusedRobotName, '_viewCenterRule] in
|
||||
makeLensesWith
|
||||
(lensRules
|
||||
& generateSignatures .~ False
|
||||
& lensField . mapped . mapped %~ \fn n ->
|
||||
if n `elem` exclude then [] else fn n)
|
||||
''GameState
|
||||
let exclude = ['_viewCenter, '_focusedRobotName, '_viewCenterRule]
|
||||
in makeLensesWith
|
||||
( lensRules
|
||||
& generateSignatures .~ False
|
||||
& lensField . mapped . mapped %~ \fn n ->
|
||||
if n `elem` exclude then [] else fn n
|
||||
)
|
||||
''GameState
|
||||
|
||||
-- | The current 'GameMode'.
|
||||
gameMode :: Lens' GameState GameMode
|
||||
@ -169,22 +180,21 @@ world :: Lens' GameState (W.World Int Entity)
|
||||
-- everything synchronize.
|
||||
viewCenterRule :: Lens' GameState ViewCenterRule
|
||||
viewCenterRule = lens getter setter
|
||||
where
|
||||
getter :: GameState -> ViewCenterRule
|
||||
getter = _viewCenterRule
|
||||
|
||||
-- The setter takes care of updating viewCenter and focusedRobotName
|
||||
-- So non of this fields get out of sync.
|
||||
setter :: GameState -> ViewCenterRule -> GameState
|
||||
setter g rule =
|
||||
case rule of
|
||||
VCLocation v2 -> g { _viewCenterRule = rule, _viewCenter = v2}
|
||||
VCRobot txt ->
|
||||
let robotcenter = g ^? robotMap . ix txt <&> view robotLocation -- retrive the loc of the robot if it exist, Nothing otherwise. sometimes, lenses are amazing...
|
||||
in case robotcenter of
|
||||
Nothing -> g
|
||||
Just v2 -> g { _viewCenterRule = rule, _viewCenter = v2, _focusedRobotName = txt}
|
||||
where
|
||||
getter :: GameState -> ViewCenterRule
|
||||
getter = _viewCenterRule
|
||||
|
||||
-- The setter takes care of updating viewCenter and focusedRobotName
|
||||
-- So non of this fields get out of sync.
|
||||
setter :: GameState -> ViewCenterRule -> GameState
|
||||
setter g rule =
|
||||
case rule of
|
||||
VCLocation v2 -> g {_viewCenterRule = rule, _viewCenter = v2}
|
||||
VCRobot txt ->
|
||||
let robotcenter = g ^? robotMap . ix txt <&> view robotLocation -- retrive the loc of the robot if it exist, Nothing otherwise. sometimes, lenses are amazing...
|
||||
in case robotcenter of
|
||||
Nothing -> g
|
||||
Just v2 -> g {_viewCenterRule = rule, _viewCenter = v2, _focusedRobotName = txt}
|
||||
|
||||
-- | The current center of the world view. Note that this cannot be
|
||||
-- modified directly, since it is calculated automatically from the
|
||||
@ -221,32 +231,34 @@ applyViewCenterRule (VCRobot name) m = m ^? at name . _Just . robotLocation
|
||||
-- simply leave the current 'viewCenter' as it is. Set 'needsRedraw'
|
||||
-- if the view center changes.
|
||||
recalcViewCenter :: GameState -> GameState
|
||||
recalcViewCenter g = g
|
||||
{ _viewCenter = newViewCenter }
|
||||
& (if newViewCenter /= oldViewCenter then needsRedraw .~ True else id)
|
||||
where
|
||||
oldViewCenter = g ^. viewCenter
|
||||
newViewCenter = fromMaybe oldViewCenter (applyViewCenterRule (g ^. viewCenterRule) (g ^. robotMap))
|
||||
recalcViewCenter g =
|
||||
g
|
||||
{ _viewCenter = newViewCenter
|
||||
}
|
||||
& (if newViewCenter /= oldViewCenter then needsRedraw .~ True else id)
|
||||
where
|
||||
oldViewCenter = g ^. viewCenter
|
||||
newViewCenter = fromMaybe oldViewCenter (applyViewCenterRule (g ^. viewCenterRule) (g ^. robotMap))
|
||||
|
||||
-- | Modify the 'viewCenter' by applying an arbitrary function to the
|
||||
-- current value. Note that this also modifies the 'viewCenterRule'
|
||||
-- to match. After calling this function the 'viewCenterRule' will
|
||||
-- specify a particular location, not a robot.
|
||||
modifyViewCenter :: (V2 Int64 -> V2 Int64) -> GameState -> GameState
|
||||
modifyViewCenter update g = g
|
||||
& case g ^. viewCenterRule of
|
||||
modifyViewCenter update g =
|
||||
g
|
||||
& case g ^. viewCenterRule of
|
||||
VCLocation l -> viewCenterRule .~ VCLocation (update l)
|
||||
VCRobot _ -> viewCenterRule .~ VCLocation (update (g ^. viewCenter))
|
||||
VCRobot _ -> viewCenterRule .~ VCLocation (update (g ^. viewCenter))
|
||||
|
||||
-- | Given a width and height, compute the region, centered on the
|
||||
-- 'viewCenter', that should currently be in view.
|
||||
viewingRegion :: GameState -> (Int64,Int64) -> (W.Coords, W.Coords)
|
||||
viewingRegion g (w,h) = (W.Coords (rmin,cmin), W.Coords (rmax,cmax))
|
||||
where
|
||||
V2 cx cy = g ^. viewCenter
|
||||
(rmin,rmax) = over both (+ (-cy - h`div`2)) (0, h-1)
|
||||
(cmin,cmax) = over both (+ (cx - w`div`2)) (0, w-1)
|
||||
|
||||
viewingRegion :: GameState -> (Int64, Int64) -> (W.Coords, W.Coords)
|
||||
viewingRegion g (w, h) = (W.Coords (rmin, cmin), W.Coords (rmax, cmax))
|
||||
where
|
||||
V2 cx cy = g ^. viewCenter
|
||||
(rmin, rmax) = over both (+ (- cy - h `div` 2)) (0, h -1)
|
||||
(cmin, cmax) = over both (+ (cx - w `div` 2)) (0, w -1)
|
||||
|
||||
-- | Find out which robot is currently specified by the
|
||||
-- 'viewCenterRule', if any.
|
||||
@ -292,34 +304,39 @@ initGameState = do
|
||||
recipes <- loadRecipes entities >>= (`isRightOr` id)
|
||||
|
||||
let baseDeviceNames =
|
||||
[ "solar panel", "3D printer", "dictionary", "workbench", "grabber"
|
||||
[ "solar panel"
|
||||
, "3D printer"
|
||||
, "dictionary"
|
||||
, "workbench"
|
||||
, "grabber"
|
||||
, "life support system"
|
||||
]
|
||||
baseDevices = mapMaybe (`lookupEntityName` entities) baseDeviceNames
|
||||
|
||||
let baseName = "base"
|
||||
|
||||
return $ GameState
|
||||
{ _gameMode = Classic
|
||||
, _runStatus = Running
|
||||
, _robotMap = M.singleton baseName (baseRobot baseDevices)
|
||||
, _gensym = 0
|
||||
, _entityMap = entities
|
||||
, _recipesOut = outRecipeMap recipes
|
||||
, _recipesIn = inRecipeMap recipes
|
||||
, _world =
|
||||
W.newWorld . fmap ((lkup entities <$>) . first fromEnum) . findGoodOrigin $ testWorld2
|
||||
, _viewCenterRule = VCRobot baseName
|
||||
, _viewCenter = V2 0 0
|
||||
, _needsRedraw = False
|
||||
, _replStatus = REPLDone
|
||||
, _messageQueue = []
|
||||
, _focusedRobotName = baseName
|
||||
}
|
||||
where
|
||||
lkup :: EntityMap -> Maybe Text -> Maybe Entity
|
||||
lkup _ Nothing = Nothing
|
||||
lkup em (Just t) = lookupEntityName t em
|
||||
return $
|
||||
GameState
|
||||
{ _gameMode = Classic
|
||||
, _runStatus = Running
|
||||
, _robotMap = M.singleton baseName (baseRobot baseDevices)
|
||||
, _gensym = 0
|
||||
, _entityMap = entities
|
||||
, _recipesOut = outRecipeMap recipes
|
||||
, _recipesIn = inRecipeMap recipes
|
||||
, _world =
|
||||
W.newWorld . fmap ((lkup entities <$>) . first fromEnum) . findGoodOrigin $ testWorld2
|
||||
, _viewCenterRule = VCRobot baseName
|
||||
, _viewCenter = V2 0 0
|
||||
, _needsRedraw = False
|
||||
, _replStatus = REPLDone
|
||||
, _messageQueue = []
|
||||
, _focusedRobotName = baseName
|
||||
}
|
||||
where
|
||||
lkup :: EntityMap -> Maybe Text -> Maybe Entity
|
||||
lkup _ Nothing = Nothing
|
||||
lkup em (Just t) = lookupEntityName t em
|
||||
|
||||
maxMessageQueueSize :: Int
|
||||
maxMessageQueueSize = 1000
|
||||
@ -328,4 +345,4 @@ maxMessageQueueSize = 1000
|
||||
emitMessage :: MonadState GameState m => Text -> m ()
|
||||
emitMessage msg = do
|
||||
q <- use messageQueue
|
||||
messageQueue %= (msg:) . (if length q >= maxMessageQueueSize then init else id)
|
||||
messageQueue %= (msg :) . (if length q >= maxMessageQueueSize then init else id)
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -1,7 +1,10 @@
|
||||
{-# LANGUAGE MagicHash #-}
|
||||
{-# LANGUAGE MagicHash #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Game.Terrain
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -10,24 +13,19 @@
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
--
|
||||
-- Terrain types and properties.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.Game.Terrain (
|
||||
-- * Terrain
|
||||
TerrainType (..),
|
||||
displayTerrain,
|
||||
terrainMap,
|
||||
) where
|
||||
|
||||
module Swarm.Game.Terrain
|
||||
( -- * Terrain
|
||||
import Brick (Widget)
|
||||
import Data.Map (Map, (!))
|
||||
import qualified Data.Map as M
|
||||
|
||||
TerrainType(..)
|
||||
, displayTerrain
|
||||
, terrainMap
|
||||
|
||||
) where
|
||||
|
||||
import Brick (Widget)
|
||||
import Data.Map (Map, (!))
|
||||
import qualified Data.Map as M
|
||||
|
||||
import Swarm.Game.Display
|
||||
import Swarm.TUI.Attr
|
||||
import Swarm.Game.Display
|
||||
import Swarm.TUI.Attr
|
||||
|
||||
-- | The different possible types of terrain. Unlike entities and
|
||||
-- robots, these are hard-coded into the game.
|
||||
@ -44,9 +42,10 @@ displayTerrain t = displayWidget Nothing (terrainMap ! t)
|
||||
|
||||
-- | A map containing a 'Display' record for each different 'TerrainType'.
|
||||
terrainMap :: Map TerrainType Display
|
||||
terrainMap = M.fromList
|
||||
[ (StoneT, defaultTerrainDisplay '░' rockAttr)
|
||||
, (DirtT, defaultTerrainDisplay '░' dirtAttr)
|
||||
, (GrassT, defaultTerrainDisplay '░' grassAttr)
|
||||
, (IceT, defaultTerrainDisplay ' ' iceAttr)
|
||||
]
|
||||
terrainMap =
|
||||
M.fromList
|
||||
[ (StoneT, defaultTerrainDisplay '░' rockAttr)
|
||||
, (DirtT, defaultTerrainDisplay '░' dirtAttr)
|
||||
, (GrassT, defaultTerrainDisplay '░' grassAttr)
|
||||
, (IceT, defaultTerrainDisplay ' ' iceAttr)
|
||||
]
|
||||
|
@ -1,4 +1,7 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE GADTs #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Game.Value
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -7,58 +10,45 @@
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
--
|
||||
-- Values and environments used for interpreting the Swarm language.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.Game.Value (
|
||||
-- * Values
|
||||
Value (..),
|
||||
prettyValue,
|
||||
valueToTerm,
|
||||
|
||||
{-# LANGUAGE GADTs #-}
|
||||
-- * Environments
|
||||
Env,
|
||||
) where
|
||||
|
||||
module Swarm.Game.Value
|
||||
( -- * Values
|
||||
import Data.List (foldl')
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
import Data.Set.Lens (setOf)
|
||||
import Data.Text (Text)
|
||||
|
||||
Value(..), prettyValue, valueToTerm
|
||||
|
||||
-- * Environments
|
||||
|
||||
, Env
|
||||
|
||||
) where
|
||||
|
||||
import Data.List (foldl')
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
import Data.Set.Lens (setOf)
|
||||
import Data.Text (Text)
|
||||
|
||||
import Swarm.Language.Context
|
||||
import Swarm.Language.Pretty (prettyText)
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Language.Context
|
||||
import Swarm.Language.Pretty (prettyText)
|
||||
import Swarm.Language.Syntax
|
||||
|
||||
-- | A /value/ is a term that cannot (or does not) take any more
|
||||
-- evaluation steps on its own.
|
||||
data Value where
|
||||
-- | The unit value.
|
||||
VUnit :: Value
|
||||
|
||||
VUnit :: Value
|
||||
-- | An integer.
|
||||
VInt :: Integer -> Value
|
||||
|
||||
VInt :: Integer -> Value
|
||||
-- | A literal string.
|
||||
VString :: Text -> Value
|
||||
|
||||
-- | A direction.
|
||||
VDir :: Direction -> Value
|
||||
|
||||
VDir :: Direction -> Value
|
||||
-- | A boolean.
|
||||
VBool :: Bool -> Value
|
||||
|
||||
VBool :: Bool -> Value
|
||||
-- | A pair.
|
||||
VPair :: Value -> Value -> Value
|
||||
|
||||
VPair :: Value -> Value -> Value
|
||||
-- | A /closure/, representing a lambda term along with an
|
||||
-- environment containing bindings for any free variables in the
|
||||
-- body of the lambda.
|
||||
VClo :: Var -> Term -> Env -> Value
|
||||
|
||||
VClo :: Var -> Term -> Env -> Value
|
||||
-- | An application of a constant to some value arguments,
|
||||
-- potentially waiting for more arguments. If a constant
|
||||
-- application is fully saturated (as defined by its 'arity'),
|
||||
@ -67,21 +57,17 @@ data Value where
|
||||
-- (e.g. 'Build'), it is a value, and awaits an 'Swarm.Game.CEK.FExec' frame
|
||||
-- which will cause it to execute. Otherwise (e.g. 'If'), it is
|
||||
-- not a value, and will immediately reduce.
|
||||
VCApp :: Const -> [Value] -> Value
|
||||
|
||||
VCApp :: Const -> [Value] -> Value
|
||||
-- | A definition, which is not evaluated until executed.
|
||||
VDef :: Var -> Term -> Env -> Value
|
||||
|
||||
-- | The result of a command, consisting of the result of the
|
||||
-- command as well as an environment of bindings from 'TDef'
|
||||
-- commands.
|
||||
VResult :: Value -> Env -> Value
|
||||
|
||||
-- | An unevaluated bind expression, waiting to be executed, of the
|
||||
-- form /i.e./ @c1 ; c2@ or @x <- c1; c2@. We also store an 'Env'
|
||||
-- in which to interpret the commands.
|
||||
VBind :: Maybe Var -> Term -> Term -> Env -> Value
|
||||
|
||||
VBind :: Maybe Var -> Term -> Term -> Env -> Value
|
||||
-- | A delayed term, along with its environment. If a term would
|
||||
-- otherwise be evaluated but we don't want it to be (/e.g./ as in
|
||||
-- the case of arguments to an 'if', or a recursive binding), we
|
||||
@ -94,7 +80,7 @@ data Value where
|
||||
-- @Term@ is evaluated, it should be evaluated in the given
|
||||
-- environment /plus/ a binding of the variable to the entire
|
||||
-- @VDelay@ itself.
|
||||
VDelay :: Maybe Var -> Term -> Env -> Value
|
||||
VDelay :: Maybe Var -> Term -> Env -> Value
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Pretty-print a value.
|
||||
@ -103,22 +89,22 @@ prettyValue = prettyText . valueToTerm
|
||||
|
||||
-- | Inject a value back into a term.
|
||||
valueToTerm :: Value -> Term
|
||||
valueToTerm VUnit = TUnit
|
||||
valueToTerm (VInt n) = TInt n
|
||||
valueToTerm (VString s) = TString s
|
||||
valueToTerm (VDir d) = TDir d
|
||||
valueToTerm (VBool b) = TBool b
|
||||
valueToTerm (VPair v1 v2) = TPair (valueToTerm v1) (valueToTerm v2)
|
||||
valueToTerm (VClo x t e) =
|
||||
valueToTerm VUnit = TUnit
|
||||
valueToTerm (VInt n) = TInt n
|
||||
valueToTerm (VString s) = TString s
|
||||
valueToTerm (VDir d) = TDir d
|
||||
valueToTerm (VBool b) = TBool b
|
||||
valueToTerm (VPair v1 v2) = TPair (valueToTerm v1) (valueToTerm v2)
|
||||
valueToTerm (VClo x t e) =
|
||||
M.foldrWithKey
|
||||
(\y v -> TLet y Nothing (valueToTerm v))
|
||||
(TLam x Nothing t)
|
||||
(M.restrictKeys (unCtx e) (S.delete x (setOf fv t)))
|
||||
valueToTerm (VCApp c vs) = foldl' TApp (TConst c) (reverse (map valueToTerm vs))
|
||||
valueToTerm (VDef x t _) = TDef x Nothing t
|
||||
valueToTerm (VResult v _) = valueToTerm v
|
||||
valueToTerm (VCApp c vs) = foldl' TApp (TConst c) (reverse (map valueToTerm vs))
|
||||
valueToTerm (VDef x t _) = TDef x Nothing t
|
||||
valueToTerm (VResult v _) = valueToTerm v
|
||||
valueToTerm (VBind mx c1 c2 _) = TBind mx c1 c2
|
||||
valueToTerm (VDelay _ t _) = TDelay t
|
||||
valueToTerm (VDelay _ t _) = TDelay t
|
||||
|
||||
-- | An environment is a mapping from variable names to values.
|
||||
type Env = Ctx Value
|
||||
|
@ -1,4 +1,14 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Game.World
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -14,50 +24,47 @@
|
||||
-- A world is technically finite but practically infinite (worlds are
|
||||
-- indexed by 64-bit signed integers, so they correspond to a
|
||||
-- \( 2^{64} \times 2^{64} \) torus).
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.Game.World (
|
||||
-- * World coordinates
|
||||
Coords (..),
|
||||
locToCoords,
|
||||
coordsToLoc,
|
||||
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
-- * Worlds
|
||||
WorldFun,
|
||||
World,
|
||||
|
||||
module Swarm.Game.World
|
||||
( -- * World coordinates
|
||||
Coords(..), locToCoords, coordsToLoc
|
||||
-- ** Tile management
|
||||
loadCell,
|
||||
loadRegion,
|
||||
|
||||
-- * Worlds
|
||||
, WorldFun, World
|
||||
-- ** World functions
|
||||
newWorld,
|
||||
lookupTerrain,
|
||||
lookupEntity,
|
||||
update,
|
||||
|
||||
-- ** Tile management
|
||||
, loadCell, loadRegion
|
||||
-- ** Monadic variants
|
||||
lookupTerrainM,
|
||||
lookupEntityM,
|
||||
updateM,
|
||||
) where
|
||||
|
||||
-- ** World functions
|
||||
, newWorld, lookupTerrain, lookupEntity, update
|
||||
import Control.Arrow ((&&&))
|
||||
import Control.Lens
|
||||
import Control.Monad.State.Class
|
||||
import qualified Data.Array as A
|
||||
import Data.Array.IArray
|
||||
import qualified Data.Array.Unboxed as U
|
||||
import Data.Bits
|
||||
import Data.Foldable (foldl')
|
||||
import Data.Int (Int64)
|
||||
import qualified Data.Map.Strict as M
|
||||
import GHC.Generics (Generic)
|
||||
import Linear
|
||||
import Prelude hiding (lookup)
|
||||
|
||||
-- ** Monadic variants
|
||||
, lookupTerrainM, lookupEntityM, updateM
|
||||
) where
|
||||
|
||||
import Control.Arrow ((&&&))
|
||||
import Control.Lens
|
||||
import Control.Monad.State.Class
|
||||
import qualified Data.Array as A
|
||||
import Data.Array.IArray
|
||||
import qualified Data.Array.Unboxed as U
|
||||
import Data.Bits
|
||||
import Data.Foldable (foldl')
|
||||
import Data.Int (Int64)
|
||||
import qualified Data.Map.Strict as M
|
||||
import GHC.Generics (Generic)
|
||||
import Linear
|
||||
import Prelude hiding (lookup)
|
||||
|
||||
import Swarm.Util
|
||||
import Swarm.Util
|
||||
|
||||
------------------------------------------------------------
|
||||
-- World coordinates
|
||||
@ -66,7 +73,7 @@ import Swarm.Util
|
||||
-- | World coordinates use (row,column) format, with the row
|
||||
-- increasing as we move down the screen. This format plays nicely
|
||||
-- with drawing the screen.
|
||||
newtype Coords = Coords { unCoords :: (Int64,Int64)}
|
||||
newtype Coords = Coords {unCoords :: (Int64, Int64)}
|
||||
deriving (Eq, Ord, Show, Ix, Generic)
|
||||
|
||||
instance Rewrapped Coords t
|
||||
@ -74,21 +81,21 @@ instance Wrapped Coords
|
||||
|
||||
-- | Convert an (x,y) location to a 'Coords' value.
|
||||
locToCoords :: V2 Int64 -> Coords
|
||||
locToCoords (V2 x y) = Coords (-y,x)
|
||||
locToCoords (V2 x y) = Coords (- y, x)
|
||||
|
||||
-- | Convert 'Coords' to an (x,y) location.
|
||||
coordsToLoc :: Coords -> V2 Int64
|
||||
coordsToLoc (Coords (r,c)) = V2 c (-r)
|
||||
coordsToLoc (Coords (r, c)) = V2 c (- r)
|
||||
|
||||
-- | A @WorldFun t e@ represents a 2D world with terrain of type @t@
|
||||
-- (exactly one per cell) and entities of type @e@ (at most one per
|
||||
-- cell).
|
||||
type WorldFun t e = Coords -> (t, Maybe e)
|
||||
|
||||
-- XXX Allow smaller, finite worlds Too? Maybe add a variant of
|
||||
-- newWorld that creates a finite world from an array. This could
|
||||
-- be used e.g. to create puzzle levels, which can be loaded from a
|
||||
-- file instead of generated via noise functions.
|
||||
-- XXX Allow smaller, finite worlds Too? Maybe add a variant of
|
||||
-- newWorld that creates a finite world from an array. This could
|
||||
-- be used e.g. to create puzzle levels, which can be loaded from a
|
||||
-- file instead of generated via noise functions.
|
||||
|
||||
-- | The number of bits we need in each coordinate to represent all
|
||||
-- the locations in a tile. In other words, each tile has a size of
|
||||
@ -109,7 +116,7 @@ tileMask = (1 `shiftL` tileBits) - 1
|
||||
-- | If we think of the world as a grid of /tiles/, we can assign each
|
||||
-- tile some coordinates in the same way we would if each tile was a
|
||||
-- single cell. These are the tile coordinates.
|
||||
newtype TileCoords = TileCoords { unTileCoords :: Coords}
|
||||
newtype TileCoords = TileCoords {unTileCoords :: Coords}
|
||||
deriving (Eq, Ord, Show, Ix, Generic)
|
||||
|
||||
instance Rewrapped TileCoords t
|
||||
@ -132,7 +139,7 @@ newtype TileOffset = TileOffset Coords
|
||||
-- | The offsets of the upper-left and lower-right corners of a tile:
|
||||
-- (0,0) to ('tileMask', 'tileMask').
|
||||
tileBounds :: (TileOffset, TileOffset)
|
||||
tileBounds = (TileOffset (Coords (0,0)), TileOffset (Coords (tileMask,tileMask)))
|
||||
tileBounds = (TileOffset (Coords (0, 0)), TileOffset (Coords (tileMask, tileMask)))
|
||||
|
||||
-- | Compute the offset of a given coordinate within its tile.
|
||||
tileOffset :: Coords -> TileOffset
|
||||
@ -145,7 +152,7 @@ tileOffset = TileOffset . over (_Wrapped . both) (.&. tileMask)
|
||||
-- that case the coordinates will end with all 0 bits, and we can
|
||||
-- add the tile offset just by doing a coordinatewise 'xor'.
|
||||
plusOffset :: Coords -> TileOffset -> Coords
|
||||
plusOffset (Coords (x1,y1)) (TileOffset (Coords (x2,y2))) = Coords (x1 `xor` x2, y1 `xor` y2)
|
||||
plusOffset (Coords (x1, y1)) (TileOffset (Coords (x2, y2))) = Coords (x1 `xor` x2, y1 `xor` y2)
|
||||
|
||||
instance Rewrapped TileOffset t
|
||||
instance Wrapped TileOffset
|
||||
@ -156,7 +163,7 @@ type TerrainTile t = U.UArray TileOffset t
|
||||
-- | An entity tile is an array of possible entity values. Note it
|
||||
-- cannot be an unboxed array since entities are complex records
|
||||
-- which have to be boxed.
|
||||
type EntityTile e = A.Array TileOffset (Maybe e)
|
||||
type EntityTile e = A.Array TileOffset (Maybe e)
|
||||
|
||||
-- | A 'World' consists of a 'WorldFun' that specifies the initial
|
||||
-- world, a cache of loaded square tiles to make lookups faster, and
|
||||
@ -170,11 +177,10 @@ type EntityTile e = A.Array TileOffset (Maybe e)
|
||||
-- for a while. Once tile loads can trigger robots to spawn, it
|
||||
-- would also make for some difficult decisions in terms of how to
|
||||
-- handle respawning.
|
||||
|
||||
data World t e = World
|
||||
{ _worldFun :: WorldFun t e
|
||||
{ _worldFun :: WorldFun t e
|
||||
, _tileCache :: M.Map TileCoords (TerrainTile t, EntityTile e)
|
||||
, _changed :: M.Map Coords (Maybe e)
|
||||
, _changed :: M.Map Coords (Maybe e)
|
||||
}
|
||||
|
||||
-- | Create a new 'World' from a 'WorldFun'.
|
||||
@ -188,8 +194,8 @@ newWorld f = World f M.empty M.empty
|
||||
-- This function does /not/ ensure that the tile containing the
|
||||
-- given coordinates is loaded. For that, see 'lookupTerrainM'.
|
||||
lookupTerrain :: IArray U.UArray t => Coords -> World t e -> t
|
||||
lookupTerrain i (World f t _)
|
||||
= ((U.! tileOffset i) . fst <$> M.lookup (tileCoords i) t)
|
||||
lookupTerrain i (World f t _) =
|
||||
((U.! tileOffset i) . fst <$> M.lookup (tileCoords i) t)
|
||||
? fst (f i)
|
||||
|
||||
-- | A stateful variant of 'lookupTerrain', which first loads the tile
|
||||
@ -208,10 +214,10 @@ lookupTerrainM c = do
|
||||
-- This function does /not/ ensure that the tile containing the
|
||||
-- given coordinates is loaded. For that, see 'lookupEntityM'.
|
||||
lookupEntity :: Coords -> World t e -> Maybe e
|
||||
lookupEntity i (World f t m)
|
||||
= M.lookup i m
|
||||
? ((A.! tileOffset i) . snd <$> M.lookup (tileCoords i) t)
|
||||
? snd (f i)
|
||||
lookupEntity i (World f t m) =
|
||||
M.lookup i m
|
||||
? ((A.! tileOffset i) . snd <$> M.lookup (tileCoords i) t)
|
||||
? snd (f i)
|
||||
|
||||
-- | A stateful variant of 'lookupTerrain', which first loads the tile
|
||||
-- containing the given coordinates if it is not already loaded,
|
||||
@ -224,8 +230,8 @@ lookupEntityM c = do
|
||||
-- | Update the entity (or absence thereof) at a certain location,
|
||||
-- returning an updated 'World'. See also 'updateM'.
|
||||
update :: Coords -> (Maybe e -> Maybe e) -> World t e -> World t e
|
||||
update i g w@(World f t m)
|
||||
= World f t (M.insert i (g (lookupEntity i w)) m)
|
||||
update i g w@(World f t m) =
|
||||
World f t (M.insert i (g (lookupEntity i w)) m)
|
||||
|
||||
-- | A stateful variant of 'update', which also ensures the tile
|
||||
-- containing the given coordinates is loaded.
|
||||
@ -234,22 +240,22 @@ updateM c g = modify $ update c g . loadCell c
|
||||
|
||||
-- | Load the tile containing a specific cell.
|
||||
loadCell :: IArray U.UArray t => Coords -> World t e -> World t e
|
||||
loadCell c = loadRegion (c,c)
|
||||
loadCell c = loadRegion (c, c)
|
||||
|
||||
-- | Load all the tiles which overlap the given rectangular region
|
||||
-- (specified as an upper-left and lower-right corner).
|
||||
loadRegion :: forall t e. IArray U.UArray t => (Coords, Coords) -> World t e -> World t e
|
||||
loadRegion reg (World f t m) = World f t' m
|
||||
where
|
||||
tiles = range (over both tileCoords reg)
|
||||
t' = foldl' (\hm (i,tile) -> maybeInsert i tile hm) t (map (id &&& loadTile) tiles)
|
||||
where
|
||||
tiles = range (over both tileCoords reg)
|
||||
t' = foldl' (\hm (i, tile) -> maybeInsert i tile hm) t (map (id &&& loadTile) tiles)
|
||||
|
||||
maybeInsert k v tm
|
||||
| k `M.member` tm = tm
|
||||
| otherwise = M.insert k v tm
|
||||
maybeInsert k v tm
|
||||
| k `M.member` tm = tm
|
||||
| otherwise = M.insert k v tm
|
||||
|
||||
loadTile :: TileCoords -> (TerrainTile t, EntityTile e)
|
||||
loadTile tc = (listArray tileBounds terrain, listArray tileBounds entities)
|
||||
where
|
||||
tileCorner = tileOrigin tc
|
||||
(terrain, entities) = unzip $ map (f . plusOffset tileCorner) (range tileBounds)
|
||||
loadTile :: TileCoords -> (TerrainTile t, EntityTile e)
|
||||
loadTile tc = (listArray tileBounds terrain, listArray tileBounds entities)
|
||||
where
|
||||
tileCorner = tileOrigin tc
|
||||
(terrain, entities) = unzip $ map (f . plusOffset tileCorner) (range tileBounds)
|
||||
|
@ -1,4 +1,7 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Game.WorldGen
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -7,102 +10,97 @@
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
--
|
||||
-- Procedural world generation via coherent noise.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Swarm.Game.WorldGen where
|
||||
|
||||
import Data.Bool
|
||||
import Data.Enumeration
|
||||
import Data.Hash.Murmur
|
||||
import Data.Int (Int64)
|
||||
import Data.List (find)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Numeric.Noise.Perlin
|
||||
import Witch
|
||||
import Data.Bool
|
||||
import Data.Enumeration
|
||||
import Data.Hash.Murmur
|
||||
import Data.Int (Int64)
|
||||
import Data.List (find)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Numeric.Noise.Perlin
|
||||
import Witch
|
||||
|
||||
import Swarm.Game.Terrain
|
||||
import Swarm.Game.World
|
||||
import Swarm.Game.Terrain
|
||||
import Swarm.Game.World
|
||||
|
||||
-- | A simple test world I used for a while during early development.
|
||||
testWorld1 :: WorldFun TerrainType Text
|
||||
testWorld1 (Coords (-5, 3)) = (StoneT, Just "flerb")
|
||||
testWorld1 (Coords (2, -1)) = (GrassT, Just "elephant")
|
||||
testWorld1 (Coords (i,j))
|
||||
testWorld1 (Coords (i, j))
|
||||
| noiseValue pn1 (fromIntegral i, fromIntegral j, 0) > 0 = (DirtT, Just "tree")
|
||||
| noiseValue pn2 (fromIntegral i, fromIntegral j, 0) > 0 = (StoneT, Just "rock")
|
||||
| otherwise = (GrassT, Nothing)
|
||||
where
|
||||
pn1, pn2 :: Perlin
|
||||
pn1 = perlin 0 5 0.05 0.5
|
||||
pn2 = perlin 0 5 0.05 0.75
|
||||
where
|
||||
pn1, pn2 :: Perlin
|
||||
pn1 = perlin 0 5 0.05 0.5
|
||||
pn2 = perlin 0 5 0.05 0.75
|
||||
|
||||
data Size = Small | Big deriving (Eq, Ord, Show, Read)
|
||||
data Hardness = Soft | Hard deriving (Eq, Ord, Show, Read)
|
||||
data Origin = Natural | Artificial deriving (Eq, Ord, Show, Read)
|
||||
data Size = Small | Big deriving (Eq, Ord, Show, Read)
|
||||
data Hardness = Soft | Hard deriving (Eq, Ord, Show, Read)
|
||||
data Origin = Natural | Artificial deriving (Eq, Ord, Show, Read)
|
||||
|
||||
-- | A more featureful test world.
|
||||
testWorld2 :: WorldFun TerrainType Text
|
||||
testWorld2 (Coords ix@(r,c))
|
||||
= genBiome
|
||||
testWorld2 (Coords ix@(r, c)) =
|
||||
genBiome
|
||||
(bool Small Big (sample ix pn0 > 0))
|
||||
(bool Soft Hard (sample ix pn1 > 0))
|
||||
(bool Natural Artificial (sample ix pn2 > 0))
|
||||
where
|
||||
h = murmur3 0 (into (show ix))
|
||||
where
|
||||
h = murmur3 0 (into (show ix))
|
||||
|
||||
genBiome Big Hard Natural
|
||||
| sample ix cl0 > 0.7 = (StoneT, Just "mountain")
|
||||
| h `mod` 30 == 0 = (StoneT, Just "boulder")
|
||||
| sample ix cl0 > 0 = (DirtT, Just "tree")
|
||||
| otherwise = (GrassT, Nothing)
|
||||
genBiome Small Hard Natural
|
||||
| h `mod` 10 == 0 = (StoneT, Just "rock")
|
||||
| otherwise = (StoneT, Nothing)
|
||||
genBiome Big Soft Natural
|
||||
| even (r+c) = (DirtT, Just "wavy water")
|
||||
| otherwise = (DirtT, Just "water")
|
||||
genBiome Small Soft Natural
|
||||
| h `mod` 10 == 0 = (GrassT, Just "flower")
|
||||
| otherwise = (GrassT, Nothing)
|
||||
genBiome Small Soft Artificial
|
||||
| h `mod` 10 == 0 = (GrassT, Just (T.concat ["bit (", from (show ((r+c) `mod` 2)), ")"]))
|
||||
| otherwise = (GrassT, Nothing)
|
||||
genBiome Big Soft Artificial
|
||||
| h `mod` 5000 == 0 = (DirtT, Just "linux")
|
||||
| sample ix cl0 > 0.5 = (GrassT, Nothing)
|
||||
| otherwise = (DirtT, Nothing)
|
||||
genBiome Small Hard Artificial
|
||||
| h `mod` 120 == 1 = (StoneT, Just "lambda")
|
||||
| otherwise = (StoneT, Nothing)
|
||||
genBiome Big Hard Artificial
|
||||
| sample ix cl0 > 0.85 = (StoneT, Just "copper ore")
|
||||
| otherwise = (StoneT, Nothing)
|
||||
genBiome Big Hard Natural
|
||||
| sample ix cl0 > 0.7 = (StoneT, Just "mountain")
|
||||
| h `mod` 30 == 0 = (StoneT, Just "boulder")
|
||||
| sample ix cl0 > 0 = (DirtT, Just "tree")
|
||||
| otherwise = (GrassT, Nothing)
|
||||
genBiome Small Hard Natural
|
||||
| h `mod` 10 == 0 = (StoneT, Just "rock")
|
||||
| otherwise = (StoneT, Nothing)
|
||||
genBiome Big Soft Natural
|
||||
| even (r + c) = (DirtT, Just "wavy water")
|
||||
| otherwise = (DirtT, Just "water")
|
||||
genBiome Small Soft Natural
|
||||
| h `mod` 10 == 0 = (GrassT, Just "flower")
|
||||
| otherwise = (GrassT, Nothing)
|
||||
genBiome Small Soft Artificial
|
||||
| h `mod` 10 == 0 = (GrassT, Just (T.concat ["bit (", from (show ((r + c) `mod` 2)), ")"]))
|
||||
| otherwise = (GrassT, Nothing)
|
||||
genBiome Big Soft Artificial
|
||||
| h `mod` 5000 == 0 = (DirtT, Just "linux")
|
||||
| sample ix cl0 > 0.5 = (GrassT, Nothing)
|
||||
| otherwise = (DirtT, Nothing)
|
||||
genBiome Small Hard Artificial
|
||||
| h `mod` 120 == 1 = (StoneT, Just "lambda")
|
||||
| otherwise = (StoneT, Nothing)
|
||||
genBiome Big Hard Artificial
|
||||
| sample ix cl0 > 0.85 = (StoneT, Just "copper ore")
|
||||
| otherwise = (StoneT, Nothing)
|
||||
|
||||
sample (i,j) noise = noiseValue noise (fromIntegral i / 2, fromIntegral j / 2, 0)
|
||||
sample (i, j) noise = noiseValue noise (fromIntegral i / 2, fromIntegral j / 2, 0)
|
||||
|
||||
pn :: Int -> Perlin
|
||||
pn seed = perlin seed 6 0.05 0.6
|
||||
pn :: Int -> Perlin
|
||||
pn seed = perlin seed 6 0.05 0.6
|
||||
|
||||
pn0 = pn 0
|
||||
pn1 = pn 1
|
||||
pn2 = pn 2
|
||||
pn0 = pn 0
|
||||
pn1 = pn 1
|
||||
pn2 = pn 2
|
||||
|
||||
clumps :: Int -> Perlin
|
||||
clumps seed = perlin seed 4 0.08 0.5
|
||||
clumps :: Int -> Perlin
|
||||
clumps seed = perlin seed 4 0.08 0.5
|
||||
|
||||
cl0 = clumps 0
|
||||
cl0 = clumps 0
|
||||
|
||||
-- | Offset the world so the base starts on a tree.
|
||||
findGoodOrigin :: WorldFun t Text -> WorldFun t Text
|
||||
findGoodOrigin f = \(Coords (r,c)) -> f (Coords (r + rOffset, c + cOffset))
|
||||
where
|
||||
int' :: Enumeration Int64
|
||||
int' = fromIntegral <$> int
|
||||
(rOffset, cOffset) = fromMaybe (error "the impossible happened, no offsets were found") offsets
|
||||
offsets = find isTree (enumerate (int' >< int'))
|
||||
isTree = (== Just "tree") . snd . f . Coords
|
||||
findGoodOrigin f = \(Coords (r, c)) -> f (Coords (r + rOffset, c + cOffset))
|
||||
where
|
||||
int' :: Enumeration Int64
|
||||
int' = fromIntegral <$> int
|
||||
(rOffset, cOffset) = fromMaybe (error "the impossible happened, no offsets were found") offsets
|
||||
offsets = find isTree (enumerate (int' >< int'))
|
||||
isTree = (== Just "tree") . snd . f . Coords
|
||||
|
@ -1,4 +1,9 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Language.Capability
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -10,62 +15,78 @@
|
||||
-- curious about how this works and/or thinking about creating some
|
||||
-- additional capabilities, you're encouraged to read the extensive
|
||||
-- comments in the source code.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.Language.Capability (
|
||||
Capability (..),
|
||||
CapCtx,
|
||||
requiredCaps,
|
||||
constCaps,
|
||||
) where
|
||||
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
import Data.Char (toLower)
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import Data.Set.Lens (setOf)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Text.Read (readMaybe)
|
||||
import Witch (from)
|
||||
import Prelude hiding (lookup)
|
||||
|
||||
module Swarm.Language.Capability
|
||||
( Capability(..), CapCtx
|
||||
, requiredCaps
|
||||
, constCaps
|
||||
) where
|
||||
import Data.Data (Data)
|
||||
import Data.Yaml
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
import Data.Char (toLower)
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import Data.Set.Lens (setOf)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Prelude hiding (lookup)
|
||||
import Text.Read (readMaybe)
|
||||
import Witch (from)
|
||||
|
||||
import Data.Data (Data)
|
||||
import Data.Yaml
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
import Swarm.Language.Context
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Language.Context
|
||||
import Swarm.Language.Syntax
|
||||
|
||||
-- | Various capabilities which robots can have.
|
||||
data Capability
|
||||
= CMove -- ^ Execute the 'Move' command
|
||||
| CTurn -- ^ Execute the 'Turn' command
|
||||
| CSelfdestruct -- ^ Execute the 'Selfdestruct' command
|
||||
| CGrab -- ^ Execute the 'Grab' command
|
||||
| CPlace -- ^ Execute the 'Place' command
|
||||
| CGive -- ^ Execute the 'Give' command
|
||||
| CInstall -- ^ Execute the 'Install' command
|
||||
| CMake -- ^ Execute the 'Make' command
|
||||
| CBuild -- ^ Execute the 'Build' command
|
||||
| CSenseloc -- ^ Execute the 'GetX' and 'GetY' commands
|
||||
| CSensefront -- ^ Execute the 'Blocked' command
|
||||
| CScan -- ^ Execute the 'Scan' command
|
||||
| CRandom -- ^ Execute the 'Random' command
|
||||
| CAppear -- ^ Execute the 'Appear' command
|
||||
| CCreate -- ^ Execute the 'Create' command
|
||||
| CFloat -- ^ Don't drown in liquid
|
||||
| CCond -- ^ Evaluate conditional expressions
|
||||
| CCompare -- ^ Evaluate comparison operations
|
||||
| CArith -- ^ Evaluate arithmetic operations
|
||||
| CEnv -- ^ Store and look up definitions in an environment
|
||||
| CLambda -- ^ Interpret lambda abstractions
|
||||
| CRecursion -- ^ Enable recursive definitions
|
||||
= -- | Execute the 'Move' command
|
||||
CMove
|
||||
| -- | Execute the 'Turn' command
|
||||
CTurn
|
||||
| -- | Execute the 'Selfdestruct' command
|
||||
CSelfdestruct
|
||||
| -- | Execute the 'Grab' command
|
||||
CGrab
|
||||
| -- | Execute the 'Place' command
|
||||
CPlace
|
||||
| -- | Execute the 'Give' command
|
||||
CGive
|
||||
| -- | Execute the 'Install' command
|
||||
CInstall
|
||||
| -- | Execute the 'Make' command
|
||||
CMake
|
||||
| -- | Execute the 'Build' command
|
||||
CBuild
|
||||
| -- | Execute the 'GetX' and 'GetY' commands
|
||||
CSenseloc
|
||||
| -- | Execute the 'Blocked' command
|
||||
CSensefront
|
||||
| -- | Execute the 'Scan' command
|
||||
CScan
|
||||
| -- | Execute the 'Random' command
|
||||
CRandom
|
||||
| -- | Execute the 'Appear' command
|
||||
CAppear
|
||||
| -- | Execute the 'Create' command
|
||||
CCreate
|
||||
| -- | Don't drown in liquid
|
||||
CFloat
|
||||
| -- | Evaluate conditional expressions
|
||||
CCond
|
||||
| -- | Evaluate comparison operations
|
||||
CCompare
|
||||
| -- | Evaluate arithmetic operations
|
||||
CArith
|
||||
| -- | Store and look up definitions in an environment
|
||||
CEnv
|
||||
| -- | Interpret lambda abstractions
|
||||
CLambda
|
||||
| -- | Enable recursive definitions
|
||||
CRecursion
|
||||
deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, Hashable, Data)
|
||||
|
||||
instance ToJSON Capability where
|
||||
@ -73,11 +94,11 @@ instance ToJSON Capability where
|
||||
|
||||
instance FromJSON Capability where
|
||||
parseJSON = withText "Capability" tryRead
|
||||
where
|
||||
tryRead :: Text -> Parser Capability
|
||||
tryRead t = case readMaybe . from . T.cons 'C' . T.toTitle $ t of
|
||||
Just c -> return c
|
||||
Nothing -> fail $ "Unknown capability " ++ from t
|
||||
where
|
||||
tryRead :: Text -> Parser Capability
|
||||
tryRead t = case readMaybe . from . T.cons 'C' . T.toTitle $ t of
|
||||
Just c -> return c
|
||||
Nothing -> fail $ "Unknown capability " ++ from t
|
||||
|
||||
-- | A capability context records the capabilities required by the
|
||||
-- definitions bound to variables.
|
||||
@ -96,7 +117,6 @@ type CapCtx = Ctx (Set Capability)
|
||||
-- will always be able to run the given program.
|
||||
requiredCaps :: CapCtx -> Term -> (Set Capability, CapCtx)
|
||||
requiredCaps ctx tm = case tm of
|
||||
|
||||
-- First, at the top level, we have to keep track of the
|
||||
-- capabilities needed by variables bound with the 'TDef' command.
|
||||
|
||||
@ -108,24 +128,20 @@ requiredCaps ctx tm = case tm of
|
||||
-- capabilities it requires.
|
||||
TDef x _ t ->
|
||||
let bodyCaps = (if x `S.member` setOf fv t then S.insert CRecursion else id) (requiredCaps' ctx t)
|
||||
in (S.singleton CEnv, singleton x bodyCaps)
|
||||
|
||||
in (S.singleton CEnv, singleton x bodyCaps)
|
||||
TBind _ t1 t2 ->
|
||||
|
||||
-- First, see what capabilities are required to execute the
|
||||
-- first command. It may also define some names, so we get a
|
||||
-- map of those names to their required capabilities.
|
||||
-- First, see what capabilities are required to execute the
|
||||
-- first command. It may also define some names, so we get a
|
||||
-- map of those names to their required capabilities.
|
||||
let (caps1, ctx1) = requiredCaps ctx t1
|
||||
|
||||
-- Now see what capabilities are required for the second
|
||||
-- command; use an extended context since it may refer to
|
||||
-- things defined in the first command.
|
||||
ctx' = ctx `union` ctx1
|
||||
ctx' = ctx `union` ctx1
|
||||
(caps2, ctx2) = requiredCaps ctx' t2
|
||||
|
||||
-- Finally return the union of everything.
|
||||
in (caps1 `S.union` caps2, ctx' `union` ctx2)
|
||||
|
||||
in -- Finally return the union of everything.
|
||||
(caps1 `S.union` caps2, ctx' `union` ctx2)
|
||||
-- Any other term can't bind variables with 'TDef', so we no longer
|
||||
-- need to worry about tracking a returned context.
|
||||
_ -> (requiredCaps' ctx tm, empty)
|
||||
@ -144,73 +160,63 @@ requiredCaps ctx tm = case tm of
|
||||
-- all.
|
||||
requiredCaps' :: CapCtx -> Term -> Set Capability
|
||||
requiredCaps' ctx = go
|
||||
where
|
||||
go tm = case tm of
|
||||
|
||||
-- Some primitive literals that don't require any special
|
||||
-- capability.
|
||||
TUnit -> S.empty
|
||||
TDir _ -> S.empty
|
||||
TInt _ -> S.empty
|
||||
TAntiInt _ -> S.empty
|
||||
TString _ -> S.empty
|
||||
TAntiString _ -> S.empty
|
||||
TBool _ -> S.empty
|
||||
|
||||
-- Look up the capabilities required by a function/command
|
||||
-- constants using 'constCaps'.
|
||||
TConst c -> constCaps c
|
||||
|
||||
-- Note that a variable might not show up in the context, and
|
||||
-- that's OK. In particular, only variables bound by 'TDef' go
|
||||
-- in the context; variables bound by a lambda or let will not
|
||||
-- be there.
|
||||
TVar x -> fromMaybe S.empty (lookup x ctx)
|
||||
|
||||
-- A lambda expression requires the 'CLambda' capability, and
|
||||
-- also all the capabilities of the body. We assume that the
|
||||
-- lambda will eventually get applied, at which point it will
|
||||
-- indeed require the body's capabilities (this is unnecessarily
|
||||
-- conservative if the lambda is never applied, but such a
|
||||
-- program could easily be rewritten without the unused
|
||||
-- lambda). We also don't do anything with the argument: we
|
||||
-- assume that it is used at least once within the body, and the
|
||||
-- capabilities required by any argument will be picked up at
|
||||
-- the application site. Again, this is overly conservative in
|
||||
-- the case that the argument is unused, but in that case the
|
||||
-- unused argument could be removed.
|
||||
TLam _ _ t -> S.insert CLambda $ go t
|
||||
|
||||
-- An application simply requires the union of the capabilities
|
||||
-- from the left- and right-hand sides. This assumes that the
|
||||
-- argument will be used at least once by the function.
|
||||
TApp t1 t2 -> go t1 `S.union` go t2
|
||||
|
||||
-- Similarly, for a let, we assume that the let-bound expression
|
||||
-- will be used at least once in the body.
|
||||
TLet x _ t1 t2 ->
|
||||
(if x `S.member` setOf fv t1 then S.insert CRecursion else id)
|
||||
$ S.insert CEnv $ go t1 `S.union` go t2
|
||||
|
||||
-- Everything else is straightforward.
|
||||
TPair t1 t2 -> go t1 `S.union` go t2
|
||||
TBind _ t1 t2 -> go t1 `S.union` go t2
|
||||
TDelay t -> go t
|
||||
|
||||
-- This case should never happen if the term has been
|
||||
-- typechecked; Def commands are only allowed at the top level,
|
||||
-- so simply returning S.empty is safe.
|
||||
TDef{} -> S.empty
|
||||
where
|
||||
go tm = case tm of
|
||||
-- Some primitive literals that don't require any special
|
||||
-- capability.
|
||||
TUnit -> S.empty
|
||||
TDir _ -> S.empty
|
||||
TInt _ -> S.empty
|
||||
TAntiInt _ -> S.empty
|
||||
TString _ -> S.empty
|
||||
TAntiString _ -> S.empty
|
||||
TBool _ -> S.empty
|
||||
-- Look up the capabilities required by a function/command
|
||||
-- constants using 'constCaps'.
|
||||
TConst c -> constCaps c
|
||||
-- Note that a variable might not show up in the context, and
|
||||
-- that's OK. In particular, only variables bound by 'TDef' go
|
||||
-- in the context; variables bound by a lambda or let will not
|
||||
-- be there.
|
||||
TVar x -> fromMaybe S.empty (lookup x ctx)
|
||||
-- A lambda expression requires the 'CLambda' capability, and
|
||||
-- also all the capabilities of the body. We assume that the
|
||||
-- lambda will eventually get applied, at which point it will
|
||||
-- indeed require the body's capabilities (this is unnecessarily
|
||||
-- conservative if the lambda is never applied, but such a
|
||||
-- program could easily be rewritten without the unused
|
||||
-- lambda). We also don't do anything with the argument: we
|
||||
-- assume that it is used at least once within the body, and the
|
||||
-- capabilities required by any argument will be picked up at
|
||||
-- the application site. Again, this is overly conservative in
|
||||
-- the case that the argument is unused, but in that case the
|
||||
-- unused argument could be removed.
|
||||
TLam _ _ t -> S.insert CLambda $ go t
|
||||
-- An application simply requires the union of the capabilities
|
||||
-- from the left- and right-hand sides. This assumes that the
|
||||
-- argument will be used at least once by the function.
|
||||
TApp t1 t2 -> go t1 `S.union` go t2
|
||||
-- Similarly, for a let, we assume that the let-bound expression
|
||||
-- will be used at least once in the body.
|
||||
TLet x _ t1 t2 ->
|
||||
(if x `S.member` setOf fv t1 then S.insert CRecursion else id) $
|
||||
S.insert CEnv $ go t1 `S.union` go t2
|
||||
-- Everything else is straightforward.
|
||||
TPair t1 t2 -> go t1 `S.union` go t2
|
||||
TBind _ t1 t2 -> go t1 `S.union` go t2
|
||||
TDelay t -> go t
|
||||
-- This case should never happen if the term has been
|
||||
-- typechecked; Def commands are only allowed at the top level,
|
||||
-- so simply returning S.empty is safe.
|
||||
TDef {} -> S.empty
|
||||
|
||||
-- | Capabilities needed to evaluate or execute a constant.
|
||||
constCaps :: Const -> Set Capability
|
||||
|
||||
-- Some built-in constants that don't require any special capability.
|
||||
constCaps Wait = S.empty
|
||||
constCaps Noop = S.empty
|
||||
constCaps Force = S.empty
|
||||
constCaps Return = S.empty
|
||||
|
||||
constCaps Wait = S.empty
|
||||
constCaps Noop = S.empty
|
||||
constCaps Force = S.empty
|
||||
constCaps Return = S.empty
|
||||
-- It's important that no capability is required for 'say', because
|
||||
-- this is how exceptions get reported. Requiring a capability for
|
||||
-- 'say' that a robot does not have will cause an infinite loop of
|
||||
@ -218,23 +224,21 @@ constCaps Return = S.empty
|
||||
-- later decide we do want to require a capability for 'say', we would
|
||||
-- have to include a special case in the interpreter to silently
|
||||
-- swallow exceptions if the robot doesn't have that capability.
|
||||
constCaps Say = S.empty
|
||||
|
||||
constCaps Say = S.empty
|
||||
-- Some straightforward ones.
|
||||
constCaps Selfdestruct = S.singleton CSelfdestruct
|
||||
constCaps Move = S.singleton CMove
|
||||
constCaps Turn = S.singleton CTurn
|
||||
constCaps Grab = S.singleton CGrab
|
||||
constCaps Place = S.singleton CPlace
|
||||
constCaps Give = S.singleton CGive
|
||||
constCaps Install = S.singleton CInstall
|
||||
constCaps Make = S.singleton CMake
|
||||
constCaps If = S.singleton CCond
|
||||
constCaps Create = S.singleton CCreate
|
||||
constCaps Blocked = S.singleton CSensefront
|
||||
constCaps Scan = S.singleton CScan
|
||||
constCaps Upload = S.singleton CScan
|
||||
|
||||
constCaps Move = S.singleton CMove
|
||||
constCaps Turn = S.singleton CTurn
|
||||
constCaps Grab = S.singleton CGrab
|
||||
constCaps Place = S.singleton CPlace
|
||||
constCaps Give = S.singleton CGive
|
||||
constCaps Install = S.singleton CInstall
|
||||
constCaps Make = S.singleton CMake
|
||||
constCaps If = S.singleton CCond
|
||||
constCaps Create = S.singleton CCreate
|
||||
constCaps Blocked = S.singleton CSensefront
|
||||
constCaps Scan = S.singleton CScan
|
||||
constCaps Upload = S.singleton CScan
|
||||
-- Build definitely requires a CBuild capability (provided by a 3D
|
||||
-- printer). However, it's possible we should do something more
|
||||
-- sophisticated here. After all, the argument to build won't be run
|
||||
@ -242,40 +246,36 @@ constCaps Upload = S.singleton CScan
|
||||
-- of already by the way we interpret the build command in the
|
||||
-- interpreter. However, I suspect things currently start to go
|
||||
-- haywire if you try to build a robot that builds other robots.
|
||||
constCaps Build = S.singleton CBuild
|
||||
|
||||
constCaps Build = S.singleton CBuild
|
||||
-- Some additional straightforward ones, which however currently
|
||||
-- cannot be used in classic mode since there is no craftable item
|
||||
-- which conveys their capability.
|
||||
constCaps Appear = S.singleton CAppear -- paint?
|
||||
constCaps GetX = S.singleton CSenseloc -- GPS?
|
||||
constCaps GetY = S.singleton CSenseloc
|
||||
constCaps Random = S.singleton CRandom -- randomness device (with bitcoins)?
|
||||
|
||||
constCaps Neg = S.singleton CArith -- ALU?
|
||||
constCaps Appear = S.singleton CAppear -- paint?
|
||||
constCaps GetX = S.singleton CSenseloc -- GPS?
|
||||
constCaps GetY = S.singleton CSenseloc
|
||||
constCaps Random = S.singleton CRandom -- randomness device (with bitcoins)?
|
||||
constCaps Neg = S.singleton CArith -- ALU?
|
||||
|
||||
-- comparator?
|
||||
constCaps Eq = S.singleton CCompare
|
||||
constCaps Neq = S.singleton CCompare
|
||||
constCaps Lt = S.singleton CCompare
|
||||
constCaps Gt = S.singleton CCompare
|
||||
constCaps Leq = S.singleton CCompare
|
||||
constCaps Geq = S.singleton CCompare
|
||||
|
||||
constCaps Add = S.singleton CArith
|
||||
constCaps Sub = S.singleton CArith
|
||||
constCaps Mul = S.singleton CArith
|
||||
constCaps Div = S.singleton CArith
|
||||
constCaps Exp = S.singleton CArith
|
||||
|
||||
constCaps Eq = S.singleton CCompare
|
||||
constCaps Neq = S.singleton CCompare
|
||||
constCaps Lt = S.singleton CCompare
|
||||
constCaps Gt = S.singleton CCompare
|
||||
constCaps Leq = S.singleton CCompare
|
||||
constCaps Geq = S.singleton CCompare
|
||||
constCaps Add = S.singleton CArith
|
||||
constCaps Sub = S.singleton CArith
|
||||
constCaps Mul = S.singleton CArith
|
||||
constCaps Div = S.singleton CArith
|
||||
constCaps Exp = S.singleton CArith
|
||||
-- Some more constants which *ought* to have their own capability but
|
||||
-- currently don't.
|
||||
constCaps View = S.empty -- XXX this should also require something.
|
||||
constCaps Ishere = S.empty -- XXX this should require a capability.
|
||||
constCaps Run = S.empty -- XXX this should also require a capability
|
||||
-- which the base starts out with.
|
||||
constCaps Not = S.empty -- XXX some kind of boolean logic cap?
|
||||
constCaps Fst = S.empty -- XXX should require cap for pairs
|
||||
constCaps Snd = S.empty
|
||||
constCaps Try = S.empty -- XXX these definitely need to require
|
||||
constCaps Raise = S.empty -- something.
|
||||
constCaps View = S.empty -- XXX this should also require something.
|
||||
constCaps Ishere = S.empty -- XXX this should require a capability.
|
||||
constCaps Run = S.empty -- XXX this should also require a capability
|
||||
-- which the base starts out with.
|
||||
constCaps Not = S.empty -- XXX some kind of boolean logic cap?
|
||||
constCaps Fst = S.empty -- XXX should require cap for pairs
|
||||
constCaps Snd = S.empty
|
||||
constCaps Try = S.empty -- XXX these definitely need to require
|
||||
constCaps Raise = S.empty -- something.
|
||||
|
@ -1,4 +1,11 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Language.Context
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -8,31 +15,22 @@
|
||||
--
|
||||
-- Generic contexts (mappings from variables to other things, such as
|
||||
-- types, values, or capability sets) used throughout the codebase.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module Swarm.Language.Context where
|
||||
|
||||
import Control.Lens.Empty (AsEmpty (..))
|
||||
import Control.Lens.Prism (prism)
|
||||
import Control.Monad.Reader (MonadReader, local)
|
||||
import Data.Data (Data)
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Text (Text)
|
||||
import Prelude hiding (lookup)
|
||||
import Control.Lens.Empty (AsEmpty (..))
|
||||
import Control.Lens.Prism (prism)
|
||||
import Control.Monad.Reader (MonadReader, local)
|
||||
import Data.Data (Data)
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Text (Text)
|
||||
import Prelude hiding (lookup)
|
||||
|
||||
-- | We use 'Text' values to represent variables.
|
||||
type Var = Text
|
||||
|
||||
-- | A context is a mapping from variable names to things.
|
||||
newtype Ctx t = Ctx { unCtx :: Map Var t}
|
||||
newtype Ctx t = Ctx {unCtx :: Map Var t}
|
||||
deriving (Eq, Show, Functor, Foldable, Traversable, Data)
|
||||
|
||||
-- | The semigroup operation for contexts is /right/-biased union.
|
||||
@ -45,10 +43,10 @@ instance Monoid (Ctx t) where
|
||||
|
||||
instance AsEmpty (Ctx t) where
|
||||
_Empty = prism (const empty) isEmpty
|
||||
where
|
||||
isEmpty (Ctx c)
|
||||
| M.null c = Right ()
|
||||
| otherwise = Left (Ctx c)
|
||||
where
|
||||
isEmpty (Ctx c)
|
||||
| M.null c = Right ()
|
||||
| otherwise = Left (Ctx c)
|
||||
|
||||
-- | The empty context.
|
||||
empty :: Ctx t
|
||||
@ -63,7 +61,7 @@ lookup :: Var -> Ctx t -> Maybe t
|
||||
lookup x (Ctx c) = M.lookup x c
|
||||
|
||||
-- | Get the list of key-value associations from a context.
|
||||
assocs :: Ctx t -> [(Var,t)]
|
||||
assocs :: Ctx t -> [(Var, t)]
|
||||
assocs = M.assocs . unCtx
|
||||
|
||||
-- | Add a key-value binding to a context (overwriting the old one if
|
||||
|
@ -1,6 +1,9 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Language.Elaborate
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -9,15 +12,11 @@
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
--
|
||||
-- Term elaboration which happens after type checking.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
module Swarm.Language.Elaborate where
|
||||
|
||||
import Control.Lens (transform, (%~))
|
||||
import Control.Lens (transform, (%~))
|
||||
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Language.Syntax
|
||||
|
||||
-- | Perform some elaboration / rewriting on a fully type-annotated
|
||||
-- term, given its top-level type. This currently performs such
|
||||
@ -27,42 +26,35 @@ import Swarm.Language.Syntax
|
||||
-- actual type they are used at, but currently that sort of thing
|
||||
-- tends to make type inference fall over.
|
||||
elaborate :: Term -> Term
|
||||
elaborate
|
||||
|
||||
elaborate =
|
||||
-- Wrap all *free* variables in 'Force'. Free variables must be
|
||||
-- referring to a previous definition, which are all wrapped in
|
||||
-- 'TDelay'.
|
||||
= (fvT %~ TApp (TConst Force))
|
||||
|
||||
-- Now do additional rewriting on all subterms.
|
||||
. transform rewrite
|
||||
|
||||
where
|
||||
-- if cond thn els ---> force (if cond (delay thn) (delay els))
|
||||
-- When if is evaluated, its arguments are eagerly evaluated, just
|
||||
-- like any function application. This ensures that evaluation of
|
||||
-- the arguments is delayed until one of them is chosen by the if.
|
||||
rewrite (TApp (TApp (TApp (TConst If) cond) thn) els)
|
||||
= TApp (TConst Force) (TApp (TApp (TApp (TConst If) cond) (TDelay thn)) (TDelay els))
|
||||
|
||||
-- Rewrite any recursive occurrences of x inside t1 to (force x).
|
||||
-- When interpreting t1, we will put a binding (x |-> delay t1)
|
||||
-- in the context.
|
||||
rewrite (TLet x ty t1 t2) = TLet x ty (mapFree1 x (TApp (TConst Force)) t1) t2
|
||||
|
||||
-- Rewrite any recursive occurrences of x inside t1 to (force x).
|
||||
-- When a TDef is encountered at runtime its body will immediately
|
||||
-- be wrapped in a VDelay. However, to make this work we also need
|
||||
-- to wrap all free variables in any term with 'force' --- since
|
||||
-- any such variables must in fact refer to things previously
|
||||
-- bound by 'def'.
|
||||
rewrite (TDef x ty t1) = TDef x ty (mapFree1 x (TApp (TConst Force)) t1)
|
||||
|
||||
-- Delay evaluation of the program argument to a 'Build' command,
|
||||
-- so it will be evaluated by the constructed robot instead of the one
|
||||
-- doing the constructing.
|
||||
rewrite (TApp (TApp (TConst Build) nm) prog)
|
||||
= TApp (TApp (TConst Build) nm) (TDelay prog)
|
||||
|
||||
-- Leave any other subterms alone.
|
||||
rewrite t = t
|
||||
(fvT %~ TApp (TConst Force))
|
||||
-- Now do additional rewriting on all subterms.
|
||||
. transform rewrite
|
||||
where
|
||||
-- if cond thn els ---> force (if cond (delay thn) (delay els))
|
||||
-- When if is evaluated, its arguments are eagerly evaluated, just
|
||||
-- like any function application. This ensures that evaluation of
|
||||
-- the arguments is delayed until one of them is chosen by the if.
|
||||
rewrite (TApp (TApp (TApp (TConst If) cond) thn) els) =
|
||||
TApp (TConst Force) (TApp (TApp (TApp (TConst If) cond) (TDelay thn)) (TDelay els))
|
||||
-- Rewrite any recursive occurrences of x inside t1 to (force x).
|
||||
-- When interpreting t1, we will put a binding (x |-> delay t1)
|
||||
-- in the context.
|
||||
rewrite (TLet x ty t1 t2) = TLet x ty (mapFree1 x (TApp (TConst Force)) t1) t2
|
||||
-- Rewrite any recursive occurrences of x inside t1 to (force x).
|
||||
-- When a TDef is encountered at runtime its body will immediately
|
||||
-- be wrapped in a VDelay. However, to make this work we also need
|
||||
-- to wrap all free variables in any term with 'force' --- since
|
||||
-- any such variables must in fact refer to things previously
|
||||
-- bound by 'def'.
|
||||
rewrite (TDef x ty t1) = TDef x ty (mapFree1 x (TApp (TConst Force)) t1)
|
||||
-- Delay evaluation of the program argument to a 'Build' command,
|
||||
-- so it will be evaluated by the constructed robot instead of the one
|
||||
-- doing the constructing.
|
||||
rewrite (TApp (TApp (TConst Build) nm) prog) =
|
||||
TApp (TApp (TConst Build) nm) (TDelay prog)
|
||||
-- Leave any other subterms alone.
|
||||
rewrite t = t
|
||||
|
@ -1,4 +1,7 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Language.Parse
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -8,48 +11,48 @@
|
||||
--
|
||||
-- Language Server Protocol (LSP) server for the Swarm language.
|
||||
-- See the docs/EDITORS.md to learn how to use it.
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Swarm.Language.LSP where
|
||||
|
||||
import Control.Lens ( (^.) )
|
||||
import Control.Monad ( void )
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Maybe ( fromMaybe )
|
||||
import Data.Text ( Text )
|
||||
import qualified Data.Text.IO as Text
|
||||
import System.IO ( stderr )
|
||||
import Control.Lens ((^.))
|
||||
import Control.Monad (void)
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text.IO as Text
|
||||
import System.IO (stderr)
|
||||
|
||||
import Language.LSP.Diagnostics
|
||||
import Language.LSP.Server
|
||||
import qualified Language.LSP.Types as J
|
||||
import qualified Language.LSP.Types.Lens as J
|
||||
|
||||
import Swarm.Language.Parse
|
||||
import Swarm.Language.Pipeline
|
||||
import Language.LSP.Diagnostics
|
||||
import Language.LSP.Server
|
||||
import qualified Language.LSP.Types as J
|
||||
import qualified Language.LSP.Types.Lens as J
|
||||
|
||||
import Swarm.Language.Parse
|
||||
import Swarm.Language.Pipeline
|
||||
|
||||
lspMain :: IO ()
|
||||
lspMain = void $ runServer $ ServerDefinition
|
||||
{ onConfigurationChange = const $ const $ Right ()
|
||||
, defaultConfig = ()
|
||||
, doInitialize = \env _req -> pure $ Right env
|
||||
, staticHandlers = handlers
|
||||
, interpretHandler = \env -> Iso (runLspT env) liftIO
|
||||
, options = defaultOptions
|
||||
{ -- set sync options to get DidSave event
|
||||
textDocumentSync = Just
|
||||
(J.TextDocumentSyncOptions
|
||||
(Just True)
|
||||
Nothing
|
||||
(Just False)
|
||||
(Just False)
|
||||
(Just $ J.InR $ J.SaveOptions $ Just True)
|
||||
)
|
||||
}
|
||||
}
|
||||
lspMain =
|
||||
void $
|
||||
runServer $
|
||||
ServerDefinition
|
||||
{ onConfigurationChange = const $ const $ Right ()
|
||||
, defaultConfig = ()
|
||||
, doInitialize = \env _req -> pure $ Right env
|
||||
, staticHandlers = handlers
|
||||
, interpretHandler = \env -> Iso (runLspT env) liftIO
|
||||
, options =
|
||||
defaultOptions
|
||||
{ -- set sync options to get DidSave event
|
||||
textDocumentSync =
|
||||
Just
|
||||
( J.TextDocumentSyncOptions
|
||||
(Just True)
|
||||
Nothing
|
||||
(Just False)
|
||||
(Just False)
|
||||
(Just $ J.InR $ J.SaveOptions $ Just True)
|
||||
)
|
||||
}
|
||||
}
|
||||
|
||||
debug :: MonadIO m => Text -> m ()
|
||||
debug msg = liftIO $ Text.hPutStrLn stderr $ "[swarm-lsp] " <> msg
|
||||
@ -58,8 +61,9 @@ sendDiagnostic :: J.NormalizedUri -> ((Int, Int), (Int, Int), Text) -> LspM () (
|
||||
sendDiagnostic fileUri ((startLine, startCol), (endLine, endCol), msg) = do
|
||||
let diags =
|
||||
[ J.Diagnostic
|
||||
(J.Range (J.Position startLine startCol)
|
||||
(J.Position endLine endCol)
|
||||
( J.Range
|
||||
(J.Position startLine startCol)
|
||||
(J.Position endLine endCol)
|
||||
)
|
||||
(Just J.DsWarning) -- severity
|
||||
Nothing -- code
|
||||
@ -78,23 +82,24 @@ validateSwarmCode doc content = do
|
||||
Right term -> case processParsedTerm' mempty mempty term of
|
||||
Right _ -> Nothing
|
||||
-- make the error span the whole document until we get source loc on type error
|
||||
Left e -> Just ((0, 0), (65535, 65535), e)
|
||||
Left e -> Just ((0, 0), (65535, 65535), e)
|
||||
Left e -> Just $ showErrorPos e
|
||||
-- debug $ "-> " <> from (show err)
|
||||
case err of
|
||||
Nothing -> pure ()
|
||||
Just e -> sendDiagnostic doc e
|
||||
Just e -> sendDiagnostic doc e
|
||||
|
||||
handlers :: Handlers (LspM ())
|
||||
handlers = mconcat
|
||||
[ notificationHandler J.SInitialized $ \_not -> do
|
||||
debug "Initialized"
|
||||
, notificationHandler J.STextDocumentDidSave $ \msg -> do
|
||||
let doc = msg ^. J.params . J.textDocument . J.uri
|
||||
content = fromMaybe "?" $ msg ^. J.params . J.text
|
||||
validateSwarmCode (J.toNormalizedUri doc) content
|
||||
, notificationHandler J.STextDocumentDidOpen $ \msg -> do
|
||||
let doc = msg ^. J.params . J.textDocument . J.uri
|
||||
content = msg ^. J.params . J.textDocument . J.text
|
||||
validateSwarmCode (J.toNormalizedUri doc) content
|
||||
]
|
||||
handlers =
|
||||
mconcat
|
||||
[ notificationHandler J.SInitialized $ \_not -> do
|
||||
debug "Initialized"
|
||||
, notificationHandler J.STextDocumentDidSave $ \msg -> do
|
||||
let doc = msg ^. J.params . J.textDocument . J.uri
|
||||
content = fromMaybe "?" $ msg ^. J.params . J.text
|
||||
validateSwarmCode (J.toNormalizedUri doc) content
|
||||
, notificationHandler J.STextDocumentDidOpen $ \msg -> do
|
||||
let doc = msg ^. J.params . J.textDocument . J.uri
|
||||
content = msg ^. J.params . J.textDocument . J.text
|
||||
validateSwarmCode (J.toNormalizedUri doc) content
|
||||
]
|
||||
|
@ -1,4 +1,12 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Language.Parse
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -11,45 +19,40 @@
|
||||
-- without also type checking it; use
|
||||
-- 'Swarm.Language.Pipeline.processTerm' instead, which parses,
|
||||
-- typechecks, elaborates, and capability checks a term all at once.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.Language.Parse (
|
||||
-- * Parsers
|
||||
Parser,
|
||||
parsePolytype,
|
||||
parseType,
|
||||
parseTerm,
|
||||
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
-- * Utility functions
|
||||
runParser,
|
||||
runParserTH,
|
||||
readTerm,
|
||||
readTerm',
|
||||
showShortError,
|
||||
showErrorPos,
|
||||
) where
|
||||
|
||||
module Swarm.Language.Parse
|
||||
( -- * Parsers
|
||||
import Control.Monad.Reader
|
||||
import Data.Bifunctor
|
||||
import Data.Char
|
||||
import qualified Data.List.NonEmpty (head)
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Data.Text (Text)
|
||||
import Data.Void
|
||||
import Witch
|
||||
|
||||
Parser, parsePolytype, parseType, parseTerm
|
||||
|
||||
-- * Utility functions
|
||||
|
||||
, runParser, runParserTH, readTerm, readTerm'
|
||||
, showShortError, showErrorPos
|
||||
) where
|
||||
|
||||
import Control.Monad.Reader
|
||||
import Data.Bifunctor
|
||||
import Data.Char
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Data.Text (Text)
|
||||
import Data.Void
|
||||
import qualified Data.List.NonEmpty (head)
|
||||
import Witch
|
||||
|
||||
import Control.Monad.Combinators.Expr
|
||||
import Text.Megaparsec hiding (runParser)
|
||||
import Text.Megaparsec.Char
|
||||
import qualified Text.Megaparsec.Char.Lexer as L
|
||||
import Control.Monad.Combinators.Expr
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Text.Megaparsec hiding (runParser)
|
||||
import Text.Megaparsec.Char
|
||||
import qualified Text.Megaparsec.Char.Lexer as L
|
||||
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Language.Types
|
||||
import Data.Foldable (asum)
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Language.Types
|
||||
|
||||
-- | When parsing a term using a quasiquoter (i.e. something in the
|
||||
-- Swarm source code that will be parsed at compile time), we want
|
||||
@ -69,21 +72,64 @@ type ParserError = ParseErrorBundle Text Void
|
||||
-- | List of reserved words that cannot be used as variable names.
|
||||
reservedWords :: [String]
|
||||
reservedWords =
|
||||
[ "left", "right", "back", "forward", "north", "south", "east", "west", "down"
|
||||
, "wait", "noop", "selfdestruct", "move", "turn", "grab", "place", "give", "make"
|
||||
, "build", "run", "getx", "gety", "scan", "upload", "blocked"
|
||||
, "random", "say", "view", "appear", "create", "ishere"
|
||||
, "int", "string", "dir", "bool", "cmd"
|
||||
, "let", "def", "end", "in", "if", "true", "false", "not", "fst", "snd"
|
||||
, "forall", "try", "raise"
|
||||
[ "left"
|
||||
, "right"
|
||||
, "back"
|
||||
, "forward"
|
||||
, "north"
|
||||
, "south"
|
||||
, "east"
|
||||
, "west"
|
||||
, "down"
|
||||
, "wait"
|
||||
, "noop"
|
||||
, "selfdestruct"
|
||||
, "move"
|
||||
, "turn"
|
||||
, "grab"
|
||||
, "place"
|
||||
, "give"
|
||||
, "make"
|
||||
, "build"
|
||||
, "run"
|
||||
, "getx"
|
||||
, "gety"
|
||||
, "scan"
|
||||
, "upload"
|
||||
, "blocked"
|
||||
, "random"
|
||||
, "say"
|
||||
, "view"
|
||||
, "appear"
|
||||
, "create"
|
||||
, "ishere"
|
||||
, "int"
|
||||
, "string"
|
||||
, "dir"
|
||||
, "bool"
|
||||
, "cmd"
|
||||
, "let"
|
||||
, "def"
|
||||
, "end"
|
||||
, "in"
|
||||
, "if"
|
||||
, "true"
|
||||
, "false"
|
||||
, "not"
|
||||
, "fst"
|
||||
, "snd"
|
||||
, "forall"
|
||||
, "try"
|
||||
, "raise"
|
||||
]
|
||||
|
||||
-- | Skip spaces and comments.
|
||||
sc :: Parser ()
|
||||
sc = L.space
|
||||
space1
|
||||
(L.skipLineComment "//")
|
||||
(L.skipBlockComment "/*" "*/")
|
||||
sc =
|
||||
L.space
|
||||
space1
|
||||
(L.skipLineComment "//")
|
||||
(L.skipBlockComment "/*" "*/")
|
||||
|
||||
-- | In general, we follow the convention that every token parser
|
||||
-- assumes no leading whitespace and consumes all trailing
|
||||
@ -107,12 +153,12 @@ reserved w = (lexeme . try) $ string' w *> notFollowedBy (alphaNumChar <|> char
|
||||
-- number.
|
||||
identifier :: Parser Text
|
||||
identifier = (lexeme . try) (p >>= check) <?> "variable name"
|
||||
where
|
||||
p = (:) <$> (letterChar <|> char '_') <*> many (alphaNumChar <|> char '_')
|
||||
check x
|
||||
| map toLower x `elem` reservedWords
|
||||
= fail $ "reserved word " ++ x ++ " cannot be used as variable name"
|
||||
| otherwise = return (into @Text x)
|
||||
where
|
||||
p = (:) <$> (letterChar <|> char '_') <*> many (alphaNumChar <|> char '_')
|
||||
check x
|
||||
| map toLower x `elem` reservedWords =
|
||||
fail $ "reserved word " ++ x ++ " cannot be used as variable name"
|
||||
| otherwise = return (into @Text x)
|
||||
|
||||
-- | Parse a string literal (including escape sequences) in double quotes.
|
||||
stringLiteral :: Parser Text
|
||||
@ -137,77 +183,78 @@ parens = between (symbol "(") (symbol ")")
|
||||
-- period) followed by a type. Note that anything accepted by
|
||||
-- 'parseType' is also accepted by 'parsePolytype'.
|
||||
parsePolytype :: Parser Polytype
|
||||
parsePolytype = Forall
|
||||
<$> (fromMaybe [] <$> optional (reserved "forall" *> some identifier <* symbol "."))
|
||||
<*> parseType
|
||||
parsePolytype =
|
||||
Forall
|
||||
<$> (fromMaybe [] <$> optional (reserved "forall" *> some identifier <* symbol "."))
|
||||
<*> parseType
|
||||
|
||||
-- | Parse a Swarm language (mono)type.
|
||||
parseType :: Parser Type
|
||||
parseType = makeExprParser parseTypeAtom table
|
||||
where
|
||||
table =
|
||||
[ [ InfixR ((:*:) <$ symbol "*") ]
|
||||
, [ InfixR ((:->:) <$ symbol "->") ]
|
||||
]
|
||||
where
|
||||
table =
|
||||
[ [InfixR ((:*:) <$ symbol "*")]
|
||||
, [InfixR ((:->:) <$ symbol "->")]
|
||||
]
|
||||
|
||||
parseTypeAtom :: Parser Type
|
||||
parseTypeAtom =
|
||||
TyUnit <$ symbol "()"
|
||||
<|> TyVar <$> identifier
|
||||
<|> TyInt <$ reserved "int"
|
||||
<|> TyString <$ reserved "string"
|
||||
<|> TyDir <$ reserved "dir"
|
||||
<|> TyBool <$ reserved "bool"
|
||||
<|> TyCmd <$> (reserved "cmd" *> parseTypeAtom)
|
||||
<|> parens parseType
|
||||
TyUnit <$ symbol "()"
|
||||
<|> TyVar <$> identifier
|
||||
<|> TyInt <$ reserved "int"
|
||||
<|> TyString <$ reserved "string"
|
||||
<|> TyDir <$ reserved "dir"
|
||||
<|> TyBool <$ reserved "bool"
|
||||
<|> TyCmd <$> (reserved "cmd" *> parseTypeAtom)
|
||||
<|> parens parseType
|
||||
|
||||
parseDirection :: Parser Direction
|
||||
parseDirection =
|
||||
Lft <$ reserved "left"
|
||||
<|> Rgt <$ reserved "right"
|
||||
<|> Back <$ reserved "back"
|
||||
<|> Fwd <$ reserved "forward"
|
||||
<|> North <$ reserved "north"
|
||||
<|> South <$ reserved "south"
|
||||
<|> East <$ reserved "east"
|
||||
<|> West <$ reserved "west"
|
||||
<|> Down <$ reserved "down"
|
||||
Lft <$ reserved "left"
|
||||
<|> Rgt <$ reserved "right"
|
||||
<|> Back <$ reserved "back"
|
||||
<|> Fwd <$ reserved "forward"
|
||||
<|> North <$ reserved "north"
|
||||
<|> South <$ reserved "south"
|
||||
<|> East <$ reserved "east"
|
||||
<|> West <$ reserved "west"
|
||||
<|> Down <$ reserved "down"
|
||||
|
||||
-- | Parse Const as reserved words (e.g. @Raise <$ reserved "raise"@)
|
||||
parseConst :: Parser Const
|
||||
parseConst = asum $ map alternative consts
|
||||
where
|
||||
consts = filter isUserFunc allConst
|
||||
alternative c = c <$ reserved (syntax $ constInfo c)
|
||||
where
|
||||
consts = filter isUserFunc allConst
|
||||
alternative c = c <$ reserved (syntax $ constInfo c)
|
||||
|
||||
parseTermAtom :: Parser Term
|
||||
parseTermAtom =
|
||||
TUnit <$ symbol "()"
|
||||
<|> TConst <$> parseConst
|
||||
<|> TVar <$> identifier
|
||||
<|> TDir <$> parseDirection
|
||||
<|> TInt <$> integer
|
||||
<|> TString <$> stringLiteral
|
||||
<|> TBool <$> ((True <$ reserved "true") <|> (False <$ reserved "false"))
|
||||
<|> TLam <$> (symbol "\\" *> identifier)
|
||||
<*> optional (symbol ":" *> parseType)
|
||||
<*> (symbol "." *> parseTerm)
|
||||
<|> TLet <$> (reserved "let" *> identifier)
|
||||
<*> optional (symbol ":" *> parsePolytype)
|
||||
<*> (symbol "=" *> parseTerm)
|
||||
<*> (reserved "in" *> parseTerm)
|
||||
<|> TDef <$> (reserved "def" *> identifier)
|
||||
<*> optional (symbol ":" *> parsePolytype)
|
||||
<*> (symbol "=" *> parseTerm <* reserved "end")
|
||||
<|> parens parseTerm
|
||||
<|> TConst Noop <$ try (symbol "{" *> symbol "}")
|
||||
<|> braces parseTerm
|
||||
<|> (ask >>= (guard . (==AllowAntiquoting)) >> parseAntiquotation)
|
||||
TUnit <$ symbol "()"
|
||||
<|> TConst <$> parseConst
|
||||
<|> TVar <$> identifier
|
||||
<|> TDir <$> parseDirection
|
||||
<|> TInt <$> integer
|
||||
<|> TString <$> stringLiteral
|
||||
<|> TBool <$> ((True <$ reserved "true") <|> (False <$ reserved "false"))
|
||||
<|> TLam <$> (symbol "\\" *> identifier)
|
||||
<*> optional (symbol ":" *> parseType)
|
||||
<*> (symbol "." *> parseTerm)
|
||||
<|> TLet <$> (reserved "let" *> identifier)
|
||||
<*> optional (symbol ":" *> parsePolytype)
|
||||
<*> (symbol "=" *> parseTerm)
|
||||
<*> (reserved "in" *> parseTerm)
|
||||
<|> TDef <$> (reserved "def" *> identifier)
|
||||
<*> optional (symbol ":" *> parsePolytype)
|
||||
<*> (symbol "=" *> parseTerm <* reserved "end")
|
||||
<|> parens parseTerm
|
||||
<|> TConst Noop <$ try (symbol "{" *> symbol "}")
|
||||
<|> braces parseTerm
|
||||
<|> (ask >>= (guard . (== AllowAntiquoting)) >> parseAntiquotation)
|
||||
|
||||
parseAntiquotation :: Parser Term
|
||||
parseAntiquotation =
|
||||
TAntiString <$> (lexeme . try) (symbol "$str:" *> identifier)
|
||||
<|> TAntiInt <$> (lexeme . try) (symbol "$int:" *> identifier)
|
||||
TAntiString <$> (lexeme . try) (symbol "$str:" *> identifier)
|
||||
<|> TAntiInt <$> (lexeme . try) (symbol "$int:" *> identifier)
|
||||
|
||||
-- | Parse a Swarm language term.
|
||||
parseTerm :: Parser Term
|
||||
@ -217,14 +264,13 @@ mkBindChain :: [Stmt] -> Parser Term
|
||||
mkBindChain stmts = case last stmts of
|
||||
Binder _ _ -> fail "Last command in a chain must not have a binder"
|
||||
BareTerm t -> return $ foldr mkBind t (init stmts)
|
||||
|
||||
where
|
||||
mkBind (BareTerm t1) t2 = TBind Nothing t1 t2
|
||||
mkBind (Binder x t1) t2 = TBind (Just x) t1 t2
|
||||
where
|
||||
mkBind (BareTerm t1) t2 = TBind Nothing t1 t2
|
||||
mkBind (Binder x t1) t2 = TBind (Just x) t1 t2
|
||||
|
||||
data Stmt
|
||||
= BareTerm Term
|
||||
| Binder Text Term
|
||||
= BareTerm Term
|
||||
| Binder Text Term
|
||||
deriving (Show)
|
||||
|
||||
parseStmt :: Parser Stmt
|
||||
@ -232,7 +278,7 @@ parseStmt =
|
||||
mkStmt <$> optional (try (identifier <* symbol "<-")) <*> parseExpr
|
||||
|
||||
mkStmt :: Maybe Text -> Term -> Stmt
|
||||
mkStmt Nothing = BareTerm
|
||||
mkStmt Nothing = BareTerm
|
||||
mkStmt (Just x) = Binder x
|
||||
|
||||
-- | When semicolons are missing between definitions, for example:
|
||||
@ -246,18 +292,20 @@ fixDefMissingSemis term =
|
||||
case nestedDefs term [] of
|
||||
[] -> term
|
||||
defs -> foldr1 (TBind Nothing) defs
|
||||
where
|
||||
nestedDefs term' acc = case term' of
|
||||
def@TDef {} -> def : acc
|
||||
TApp nestedTerm def@TDef {} -> nestedDefs nestedTerm (def : acc)
|
||||
-- Otherwise returns an empty list to keep the term unchanged
|
||||
_ -> []
|
||||
where
|
||||
nestedDefs term' acc = case term' of
|
||||
def@TDef {} -> def : acc
|
||||
TApp nestedTerm def@TDef {} -> nestedDefs nestedTerm (def : acc)
|
||||
-- Otherwise returns an empty list to keep the term unchanged
|
||||
_ -> []
|
||||
|
||||
parseExpr :: Parser Term
|
||||
parseExpr = fixDefMissingSemis <$> makeExprParser parseTermAtom table
|
||||
where
|
||||
table = snd <$> Map.toDescList tableMap
|
||||
tableMap = Map.unionsWith (++)
|
||||
where
|
||||
table = snd <$> Map.toDescList tableMap
|
||||
tableMap =
|
||||
Map.unionsWith
|
||||
(++)
|
||||
[ Map.singleton 9 [InfixL (TApp <$ string "")]
|
||||
, binOps
|
||||
, unOps
|
||||
@ -270,15 +318,16 @@ parseExpr = fixDefMissingSemis <$> makeExprParser parseTermAtom table
|
||||
-- fromList [(4,6),(6,2),(7,2),(8,1)]
|
||||
binOps :: Map.Map Int [Operator Parser Term]
|
||||
binOps = Map.unionsWith (++) $ mapMaybe binOpToTuple allConst
|
||||
where
|
||||
binOpToTuple c = do
|
||||
let ci = constInfo c
|
||||
ConstMBinOp assoc <- pure (constMeta ci)
|
||||
let assI = case assoc of
|
||||
L -> InfixL
|
||||
N -> InfixN
|
||||
R -> InfixR
|
||||
pure $ Map.singleton
|
||||
where
|
||||
binOpToTuple c = do
|
||||
let ci = constInfo c
|
||||
ConstMBinOp assoc <- pure (constMeta ci)
|
||||
let assI = case assoc of
|
||||
L -> InfixL
|
||||
N -> InfixN
|
||||
R -> InfixR
|
||||
pure $
|
||||
Map.singleton
|
||||
(fixity ci)
|
||||
[assI (mkOp c <$ symbol (syntax ci))]
|
||||
|
||||
@ -288,14 +337,15 @@ binOps = Map.unionsWith (++) $ mapMaybe binOpToTuple allConst
|
||||
-- fromList [(7,1)]
|
||||
unOps :: Map.Map Int [Operator Parser Term]
|
||||
unOps = Map.unionsWith (++) $ mapMaybe unOpToTuple allConst
|
||||
where
|
||||
unOpToTuple c = do
|
||||
let ci = constInfo c
|
||||
ConstMUnOp assoc <- pure (constMeta ci)
|
||||
let assI = case assoc of
|
||||
P -> Prefix
|
||||
S -> Postfix
|
||||
pure $ Map.singleton
|
||||
where
|
||||
unOpToTuple c = do
|
||||
let ci = constInfo c
|
||||
ConstMUnOp assoc <- pure (constMeta ci)
|
||||
let assI = case assoc of
|
||||
P -> Prefix
|
||||
S -> Postfix
|
||||
pure $
|
||||
Map.singleton
|
||||
(fixity ci)
|
||||
[assI (TApp (TConst c) <$ symbol (syntax ci))]
|
||||
|
||||
@ -314,25 +364,26 @@ runParserTH :: (Monad m, MonadFail m) => (String, Int, Int) -> Parser a -> Strin
|
||||
runParserTH (file, line, col) p s =
|
||||
case snd (runParser' (runReaderT (fully p) AllowAntiquoting) initState) of
|
||||
Left err -> fail $ errorBundlePretty err
|
||||
Right e -> return e
|
||||
where
|
||||
-- This is annoying --- megaparsec does not export its function to
|
||||
-- construct an initial parser state, so we can't just use that
|
||||
-- and then change the one field we need to be different (the
|
||||
-- pstateSourcePos). We have to copy-paste the whole thing.
|
||||
initState :: State Text Void
|
||||
initState = State
|
||||
{ stateInput = from s,
|
||||
stateOffset = 0,
|
||||
statePosState =
|
||||
Right e -> return e
|
||||
where
|
||||
-- This is annoying --- megaparsec does not export its function to
|
||||
-- construct an initial parser state, so we can't just use that
|
||||
-- and then change the one field we need to be different (the
|
||||
-- pstateSourcePos). We have to copy-paste the whole thing.
|
||||
initState :: State Text Void
|
||||
initState =
|
||||
State
|
||||
{ stateInput = from s
|
||||
, stateOffset = 0
|
||||
, statePosState =
|
||||
PosState
|
||||
{ pstateInput = from s,
|
||||
pstateOffset = 0,
|
||||
pstateSourcePos = SourcePos file (mkPos line) (mkPos col),
|
||||
pstateTabWidth = defaultTabWidth,
|
||||
pstateLinePrefix = ""
|
||||
},
|
||||
stateParseErrors = []
|
||||
{ pstateInput = from s
|
||||
, pstateOffset = 0
|
||||
, pstateSourcePos = SourcePos file (mkPos line) (mkPos col)
|
||||
, pstateTabWidth = defaultTabWidth
|
||||
, pstateLinePrefix = ""
|
||||
}
|
||||
, stateParseErrors = []
|
||||
}
|
||||
|
||||
-- | Run a parser "fully", consuming leading whitespace and ensuring
|
||||
@ -356,31 +407,31 @@ readTerm' = parse (runReaderT (fully parseTerm) DisallowAntiquoting) ""
|
||||
-- <line-nr>: <error-msg>
|
||||
showShortError :: ParserError -> String
|
||||
showShortError pe = show (line + 1) <> ": " <> from msg
|
||||
where
|
||||
((line, _), _, msg) = showErrorPos pe
|
||||
where
|
||||
((line, _), _, msg) = showErrorPos pe
|
||||
|
||||
-- | A utility for converting a ParseError into a range and error message.
|
||||
showErrorPos :: ParserError -> ((Int, Int), (Int, Int), Text)
|
||||
showErrorPos (ParseErrorBundle errs sourcePS) = (minusOne start, minusOne end, from msg)
|
||||
where
|
||||
-- convert megaparsec source pos to starts at 0
|
||||
minusOne (x, y) = (x - 1, y - 1)
|
||||
where
|
||||
-- convert megaparsec source pos to starts at 0
|
||||
minusOne (x, y) = (x - 1, y - 1)
|
||||
|
||||
-- get the first error position (ps) and line content (str)
|
||||
err = Data.List.NonEmpty.head errs
|
||||
offset = case err of
|
||||
TrivialError x _ _ -> x
|
||||
FancyError x _ -> x
|
||||
(str, ps) = reachOffset offset sourcePS
|
||||
msg = parseErrorTextPretty err
|
||||
-- get the first error position (ps) and line content (str)
|
||||
err = Data.List.NonEmpty.head errs
|
||||
offset = case err of
|
||||
TrivialError x _ _ -> x
|
||||
FancyError x _ -> x
|
||||
(str, ps) = reachOffset offset sourcePS
|
||||
msg = parseErrorTextPretty err
|
||||
|
||||
-- extract the error starting position
|
||||
line = unPos $ sourceLine $ pstateSourcePos ps
|
||||
col = unPos $ sourceColumn $ pstateSourcePos ps
|
||||
start = ( line, col )
|
||||
-- extract the error starting position
|
||||
line = unPos $ sourceLine $ pstateSourcePos ps
|
||||
col = unPos $ sourceColumn $ pstateSourcePos ps
|
||||
start = (line, col)
|
||||
|
||||
-- compute the ending position based on the word at starting position
|
||||
wordlength = case break (== ' ') . drop col <$> str of
|
||||
Just (word, _) -> length word + 1
|
||||
_ -> 0
|
||||
end = ( line, col + wordlength)
|
||||
-- compute the ending position based on the word at starting position
|
||||
wordlength = case break (== ' ') . drop col <$> str of
|
||||
Just (word, _) -> length word + 1
|
||||
_ -> 0
|
||||
end = (line, col + wordlength)
|
||||
|
@ -1,4 +1,7 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Language.Parse.QQ
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -7,21 +10,14 @@
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
--
|
||||
-- A quasiquoter for Swarm polytypes.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.Language.Parse.QQ (tyQ) where
|
||||
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
import Data.Generics
|
||||
import qualified Language.Haskell.TH as TH
|
||||
import Language.Haskell.TH.Quote
|
||||
|
||||
module Swarm.Language.Parse.QQ
|
||||
( tyQ )
|
||||
where
|
||||
|
||||
import Data.Generics
|
||||
import qualified Language.Haskell.TH as TH
|
||||
import Language.Haskell.TH.Quote
|
||||
|
||||
import Swarm.Language.Parse
|
||||
import Swarm.Util (liftText)
|
||||
import Swarm.Language.Parse
|
||||
import Swarm.Util (liftText)
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Quasiquoters
|
||||
@ -32,19 +28,21 @@ import Swarm.Util (liftText)
|
||||
-- syntax at compile time. This is used, for example, in writing down
|
||||
-- the concrete types of constants (see "Swarm.Language.Typecheck").
|
||||
tyQ :: QuasiQuoter
|
||||
tyQ = QuasiQuoter
|
||||
{ quoteExp = quoteTypeExp
|
||||
, quotePat = error "quotePat not implemented for polytypes"
|
||||
, quoteType = error "quoteType not implemented for polytypes"
|
||||
, quoteDec = error "quoteDec not implemented for polytypes"
|
||||
}
|
||||
tyQ =
|
||||
QuasiQuoter
|
||||
{ quoteExp = quoteTypeExp
|
||||
, quotePat = error "quotePat not implemented for polytypes"
|
||||
, quoteType = error "quoteType not implemented for polytypes"
|
||||
, quoteDec = error "quoteDec not implemented for polytypes"
|
||||
}
|
||||
|
||||
quoteTypeExp :: String -> TH.ExpQ
|
||||
quoteTypeExp s = do
|
||||
loc <- TH.location
|
||||
let pos =
|
||||
(TH.loc_filename loc,
|
||||
fst (TH.loc_start loc),
|
||||
snd (TH.loc_start loc))
|
||||
( TH.loc_filename loc
|
||||
, fst (TH.loc_start loc)
|
||||
, snd (TH.loc_start loc)
|
||||
)
|
||||
parsed <- runParserTH pos parsePolytype s
|
||||
dataToExpQ (fmap liftText . cast) parsed
|
||||
|
@ -1,4 +1,9 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Language.Pipeline
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -11,43 +16,40 @@
|
||||
-- checking, and elaboration. If you want to simply turn some raw
|
||||
-- text representing a Swarm program into something useful, this is
|
||||
-- probably the module you want.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.Language.Pipeline (
|
||||
ProcessedTerm (..),
|
||||
processTerm,
|
||||
processParsedTerm,
|
||||
processTerm',
|
||||
processParsedTerm',
|
||||
) where
|
||||
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Data (Data)
|
||||
import Data.Set (Set)
|
||||
import Data.Text (Text)
|
||||
|
||||
module Swarm.Language.Pipeline
|
||||
( ProcessedTerm(..)
|
||||
, processTerm
|
||||
, processParsedTerm
|
||||
, processTerm'
|
||||
, processParsedTerm'
|
||||
) where
|
||||
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Data (Data)
|
||||
import Data.Set (Set)
|
||||
import Data.Text (Text)
|
||||
|
||||
import Swarm.Language.Capability
|
||||
import Swarm.Language.Context
|
||||
import Swarm.Language.Elaborate
|
||||
import Swarm.Language.Parse
|
||||
import Swarm.Language.Pretty
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Language.Typecheck
|
||||
import Swarm.Language.Types
|
||||
import Swarm.Language.Capability
|
||||
import Swarm.Language.Context
|
||||
import Swarm.Language.Elaborate
|
||||
import Swarm.Language.Parse
|
||||
import Swarm.Language.Pretty
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Language.Typecheck
|
||||
import Swarm.Language.Types
|
||||
|
||||
-- | A record containing the results of the language processing
|
||||
-- pipeline. Put a 'Term' in, and get one of these out.
|
||||
data ProcessedTerm = ProcessedTerm
|
||||
Term -- ^ The elaborated term
|
||||
TModule -- ^ The type of the term (and of any embedded definitions)
|
||||
(Set Capability) -- ^ Capabilities required by the term
|
||||
CapCtx -- ^ Capability context for any definitions embedded in the term
|
||||
|
||||
data ProcessedTerm
|
||||
= ProcessedTerm
|
||||
Term
|
||||
-- ^ The elaborated term
|
||||
TModule
|
||||
-- ^ The type of the term (and of any embedded definitions)
|
||||
(Set Capability)
|
||||
-- ^ Capabilities required by the term
|
||||
CapCtx
|
||||
-- ^ Capability context for any definitions embedded in the term
|
||||
deriving (Data)
|
||||
|
||||
-- | Given a 'Text' value representing a Swarm program,
|
||||
|
@ -1,4 +1,7 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Language.Pipeline.QQ
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -7,24 +10,17 @@
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
--
|
||||
-- A quasiquoter for Swarm terms.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.Language.Pipeline.QQ (tmQ) where
|
||||
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
import Data.Generics
|
||||
import qualified Language.Haskell.TH as TH
|
||||
import Language.Haskell.TH.Quote
|
||||
import Witch (from)
|
||||
|
||||
module Swarm.Language.Pipeline.QQ
|
||||
( tmQ )
|
||||
where
|
||||
|
||||
import Data.Generics
|
||||
import qualified Language.Haskell.TH as TH
|
||||
import Language.Haskell.TH.Quote
|
||||
import Witch (from)
|
||||
|
||||
import Swarm.Language.Parse
|
||||
import Swarm.Language.Pipeline
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Util (liftText)
|
||||
import Swarm.Language.Parse
|
||||
import Swarm.Language.Pipeline
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Util (liftText)
|
||||
|
||||
-- | A quasiquoter for Swarm language terms, so we can conveniently
|
||||
-- write them down using concrete syntax and have them parsed into
|
||||
@ -35,24 +31,26 @@ import Swarm.Util (liftText)
|
||||
-- system robot programs (for example, see
|
||||
-- 'Swarm.Game.Step.seedProgram').
|
||||
tmQ :: QuasiQuoter
|
||||
tmQ = QuasiQuoter
|
||||
{ quoteExp = quoteTermExp
|
||||
, quotePat = error "quotePat not implemented for terms"
|
||||
, quoteType = error "quoteType not implemented for terms"
|
||||
, quoteDec = error "quoteDec not implemented for terms"
|
||||
}
|
||||
tmQ =
|
||||
QuasiQuoter
|
||||
{ quoteExp = quoteTermExp
|
||||
, quotePat = error "quotePat not implemented for terms"
|
||||
, quoteType = error "quoteType not implemented for terms"
|
||||
, quoteDec = error "quoteDec not implemented for terms"
|
||||
}
|
||||
|
||||
quoteTermExp :: String -> TH.ExpQ
|
||||
quoteTermExp s = do
|
||||
loc <- TH.location
|
||||
let pos =
|
||||
(TH.loc_filename loc,
|
||||
fst (TH.loc_start loc),
|
||||
snd (TH.loc_start loc))
|
||||
( TH.loc_filename loc
|
||||
, fst (TH.loc_start loc)
|
||||
, snd (TH.loc_start loc)
|
||||
)
|
||||
parsed <- runParserTH pos parseTerm s
|
||||
case processParsedTerm parsed of
|
||||
Left errMsg -> fail $ from errMsg
|
||||
Right ptm -> dataToExpQ ((fmap liftText . cast) `extQ` antiTermExp) ptm
|
||||
Right ptm -> dataToExpQ ((fmap liftText . cast) `extQ` antiTermExp) ptm
|
||||
|
||||
antiTermExp :: Term -> Maybe TH.ExpQ
|
||||
antiTermExp (TAntiString v) =
|
||||
@ -60,6 +58,7 @@ antiTermExp (TAntiString v) =
|
||||
antiTermExp (TAntiInt v) =
|
||||
Just $ TH.appE (TH.conE (TH.mkName "TInt")) (TH.varE (TH.mkName (from v)))
|
||||
antiTermExp _ = Nothing
|
||||
-- At the moment, only antiquotation of literal strings and ints are
|
||||
-- supported, because that's what we need for the seedProgram. But
|
||||
-- we can easily add more in the future.
|
||||
|
||||
-- At the moment, only antiquotation of literal strings and ints are
|
||||
-- supported, because that's what we need for the seedProgram. But
|
||||
-- we can easily add more in the future.
|
||||
|
@ -1,4 +1,13 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Language.Pretty
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -7,44 +16,32 @@
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
--
|
||||
-- Pretty-printing for the Swarm language.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Swarm.Language.Pretty where
|
||||
|
||||
import Control.Lens.Combinators (pattern Empty)
|
||||
import Data.Bool (bool)
|
||||
import Data.Functor.Fixedpoint (Fix, unFix)
|
||||
import Data.String (fromString)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Prettyprinter
|
||||
import Control.Lens.Combinators (pattern Empty)
|
||||
import Data.Bool (bool)
|
||||
import Data.Functor.Fixedpoint (Fix, unFix)
|
||||
import Data.String (fromString)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Prettyprinter
|
||||
import qualified Prettyprinter.Render.String as RS
|
||||
import qualified Prettyprinter.Render.Text as RT
|
||||
import Witch
|
||||
import qualified Prettyprinter.Render.Text as RT
|
||||
import Witch
|
||||
|
||||
import Control.Unification
|
||||
import Control.Unification.IntVar
|
||||
|
||||
import Swarm.Language.Capability
|
||||
import Swarm.Language.Context
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Language.Typecheck
|
||||
import Swarm.Language.Types
|
||||
import Control.Unification
|
||||
import Control.Unification.IntVar
|
||||
|
||||
import Swarm.Language.Capability
|
||||
import Swarm.Language.Context
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Language.Typecheck
|
||||
import Swarm.Language.Types
|
||||
|
||||
-- | Type class for things that can be pretty-printed, given a
|
||||
-- precedence level of their context.
|
||||
class PrettyPrec a where
|
||||
prettyPrec :: Int -> a -> Doc ann -- can replace with custom ann type later if desired
|
||||
prettyPrec :: Int -> a -> Doc ann -- can replace with custom ann type later if desired
|
||||
|
||||
-- | Pretty-print a thing, with a context precedence level of zero.
|
||||
ppr :: PrettyPrec a => a -> Doc ann
|
||||
@ -61,15 +58,15 @@ prettyString = RS.renderString . layoutPretty defaultLayoutOptions . ppr
|
||||
-- | Optionally surround a document with parentheses depending on the
|
||||
-- @Bool@ argument.
|
||||
pparens :: Bool -> Doc ann -> Doc ann
|
||||
pparens True = parens
|
||||
pparens True = parens
|
||||
pparens False = id
|
||||
|
||||
instance PrettyPrec BaseTy where
|
||||
prettyPrec _ BUnit = "()"
|
||||
prettyPrec _ BInt = "int"
|
||||
prettyPrec _ BDir = "dir"
|
||||
prettyPrec _ BUnit = "()"
|
||||
prettyPrec _ BInt = "int"
|
||||
prettyPrec _ BDir = "dir"
|
||||
prettyPrec _ BString = "string"
|
||||
prettyPrec _ BBool = "bool"
|
||||
prettyPrec _ BBool = "bool"
|
||||
|
||||
instance PrettyPrec IntVar where
|
||||
prettyPrec _ = pretty . mkVarName "u"
|
||||
@ -79,37 +76,39 @@ instance PrettyPrec (t (Fix t)) => PrettyPrec (Fix t) where
|
||||
|
||||
instance (PrettyPrec (t (UTerm t v)), PrettyPrec v) => PrettyPrec (UTerm t v) where
|
||||
prettyPrec p (UTerm t) = prettyPrec p t
|
||||
prettyPrec p (UVar v) = prettyPrec p v
|
||||
prettyPrec p (UVar v) = prettyPrec p v
|
||||
|
||||
instance PrettyPrec t => PrettyPrec (TypeF t) where
|
||||
prettyPrec _ (TyBaseF b) = ppr b
|
||||
prettyPrec _ (TyVarF v) = pretty v
|
||||
prettyPrec p (TyProdF ty1 ty2) = pparens (p > 2) $
|
||||
prettyPrec 3 ty1 <+> "*" <+> prettyPrec 2 ty2
|
||||
prettyPrec _ (TyBaseF b) = ppr b
|
||||
prettyPrec _ (TyVarF v) = pretty v
|
||||
prettyPrec p (TyProdF ty1 ty2) =
|
||||
pparens (p > 2) $
|
||||
prettyPrec 3 ty1 <+> "*" <+> prettyPrec 2 ty2
|
||||
prettyPrec p (TyCmdF ty) = pparens (p > 9) $ "cmd" <+> prettyPrec 10 ty
|
||||
prettyPrec p (TyFunF ty1 ty2) = pparens (p > 0) $
|
||||
prettyPrec 1 ty1 <+> "->" <+> prettyPrec 0 ty2
|
||||
prettyPrec p (TyFunF ty1 ty2) =
|
||||
pparens (p > 0) $
|
||||
prettyPrec 1 ty1 <+> "->" <+> prettyPrec 0 ty2
|
||||
|
||||
instance PrettyPrec Polytype where
|
||||
prettyPrec _ (Forall [] t) = ppr t
|
||||
prettyPrec _ (Forall xs t) = hsep ("∀" : map pretty xs) <> "." <+> ppr t
|
||||
|
||||
instance PrettyPrec t => PrettyPrec (Ctx t) where
|
||||
prettyPrec _ Empty = emptyDoc
|
||||
prettyPrec _ Empty = emptyDoc
|
||||
prettyPrec _ (assocs -> bs) = brackets (hsep (punctuate "," (map prettyBinding bs)))
|
||||
where
|
||||
prettyBinding (x,ty) = pretty x <> ":" <+> ppr ty
|
||||
where
|
||||
prettyBinding (x, ty) = pretty x <> ":" <+> ppr ty
|
||||
|
||||
instance PrettyPrec Direction where
|
||||
prettyPrec _ Lft = "left"
|
||||
prettyPrec _ Rgt = "right"
|
||||
prettyPrec _ Back = "back"
|
||||
prettyPrec _ Fwd = "forward"
|
||||
prettyPrec _ Lft = "left"
|
||||
prettyPrec _ Rgt = "right"
|
||||
prettyPrec _ Back = "back"
|
||||
prettyPrec _ Fwd = "forward"
|
||||
prettyPrec _ North = "north"
|
||||
prettyPrec _ South = "south"
|
||||
prettyPrec _ East = "east"
|
||||
prettyPrec _ West = "west"
|
||||
prettyPrec _ Down = "down"
|
||||
prettyPrec _ East = "east"
|
||||
prettyPrec _ West = "west"
|
||||
prettyPrec _ Down = "down"
|
||||
|
||||
instance PrettyPrec Capability where
|
||||
prettyPrec _ c = pretty $ T.toLower (from (tail $ show c))
|
||||
@ -118,16 +117,16 @@ instance PrettyPrec Const where
|
||||
prettyPrec p c = pparens (p > fixity (constInfo c)) $ pretty . syntax . constInfo $ c
|
||||
|
||||
instance PrettyPrec Term where
|
||||
prettyPrec _ TUnit = "()"
|
||||
prettyPrec p (TConst c) = prettyPrec p c
|
||||
prettyPrec _ (TDir d) = ppr d
|
||||
prettyPrec _ (TInt n) = pretty n
|
||||
prettyPrec _ (TAntiInt v) = "$int:" <> pretty v
|
||||
prettyPrec _ (TString s) = fromString (show s)
|
||||
prettyPrec _ TUnit = "()"
|
||||
prettyPrec p (TConst c) = prettyPrec p c
|
||||
prettyPrec _ (TDir d) = ppr d
|
||||
prettyPrec _ (TInt n) = pretty n
|
||||
prettyPrec _ (TAntiInt v) = "$int:" <> pretty v
|
||||
prettyPrec _ (TString s) = fromString (show s)
|
||||
prettyPrec _ (TAntiString v) = "$str:" <> pretty v
|
||||
prettyPrec _ (TBool b) = bool "false" "true" b
|
||||
prettyPrec _ (TVar s) = pretty s
|
||||
prettyPrec p (TDelay t) = pparens (p > 10) $ "delay" <+> prettyPrec 11 t
|
||||
prettyPrec _ (TBool b) = bool "false" "true" b
|
||||
prettyPrec _ (TVar s) = pretty s
|
||||
prettyPrec p (TDelay t) = pparens (p > 10) $ "delay" <+> prettyPrec 11 t
|
||||
prettyPrec _ (TPair t1 t2) = pparens True $ ppr t1 <> "," <+> ppr t2
|
||||
prettyPrec _ (TLam x mty body) =
|
||||
"\\" <> pretty x <> maybe "" ((":" <>) . ppr) mty <> "." <+> ppr body
|
||||
@ -135,56 +134,58 @@ instance PrettyPrec Term where
|
||||
prettyPrec p (TApp t@(TApp (TConst c) l) r) =
|
||||
let ci = constInfo c
|
||||
pC = fixity ci
|
||||
in case constMeta ci of
|
||||
ConstMBinOp assoc -> pparens (p > pC) $ hsep
|
||||
[ prettyPrec (pC + fromEnum (assoc == R)) l
|
||||
, ppr c
|
||||
, prettyPrec (pC + fromEnum (assoc == L)) r
|
||||
]
|
||||
_ -> prettyPrecApp p t r
|
||||
prettyPrec p (TApp t1 t2) = case t1 of
|
||||
TConst c ->
|
||||
let ci = constInfo c
|
||||
pC = fixity ci
|
||||
in case constMeta ci of
|
||||
ConstMUnOp P -> pparens (p > pC) $ ppr t1 <> prettyPrec (succ pC) t2
|
||||
ConstMUnOp S -> pparens (p > pC) $ prettyPrec (succ pC) t2 <> ppr t1
|
||||
_ -> prettyPrecApp p t1 t2
|
||||
_ -> prettyPrecApp p t1 t2
|
||||
in case constMeta ci of
|
||||
ConstMBinOp assoc ->
|
||||
pparens (p > pC) $
|
||||
hsep
|
||||
[ prettyPrec (pC + fromEnum (assoc == R)) l
|
||||
, ppr c
|
||||
, prettyPrec (pC + fromEnum (assoc == L)) r
|
||||
]
|
||||
_ -> prettyPrecApp p t r
|
||||
prettyPrec p (TApp t1 t2) = case t1 of
|
||||
TConst c ->
|
||||
let ci = constInfo c
|
||||
pC = fixity ci
|
||||
in case constMeta ci of
|
||||
ConstMUnOp P -> pparens (p > pC) $ ppr t1 <> prettyPrec (succ pC) t2
|
||||
ConstMUnOp S -> pparens (p > pC) $ prettyPrec (succ pC) t2 <> ppr t1
|
||||
_ -> 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]
|
||||
["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"]
|
||||
prettyPrec p (TBind Nothing t1 t2) = pparens (p > 0) $
|
||||
prettyPrec 1 t1 <> ";" <+> prettyPrec 0 t2
|
||||
prettyPrec p (TBind (Just x) t1 t2) = pparens (p > 0) $
|
||||
pretty x <+> "<-" <+> prettyPrec 1 t1 <> ";" <+> prettyPrec 0 t2
|
||||
["def", pretty x]
|
||||
++ maybe [] (\ty -> [":", ppr ty]) mty
|
||||
++ ["=", ppr t1, "end"]
|
||||
prettyPrec p (TBind Nothing t1 t2) =
|
||||
pparens (p > 0) $
|
||||
prettyPrec 1 t1 <> ";" <+> prettyPrec 0 t2
|
||||
prettyPrec p (TBind (Just x) t1 t2) =
|
||||
pparens (p > 0) $
|
||||
pretty x <+> "<-" <+> prettyPrec 1 t1 <> ";" <+> prettyPrec 0 t2
|
||||
|
||||
prettyPrecApp :: Int -> Term -> Term -> Doc a
|
||||
prettyPrecApp p t1 t2 = pparens (p > 10) $
|
||||
prettyPrec 10 t1 <+> prettyPrec 11 t2
|
||||
prettyPrecApp p t1 t2 =
|
||||
pparens (p > 10) $
|
||||
prettyPrec 10 t1 <+> prettyPrec 11 t2
|
||||
|
||||
appliedTermPrec :: Term -> Int
|
||||
appliedTermPrec (TApp f _) = case f of
|
||||
TConst c -> fixity $ constInfo c
|
||||
_ -> appliedTermPrec f
|
||||
_ -> appliedTermPrec f
|
||||
appliedTermPrec _ = 10
|
||||
|
||||
instance PrettyPrec TypeErr where
|
||||
prettyPrec _ (Mismatch ty1 ty2) =
|
||||
"Can't unify" <+> ppr ty1 <+> "and" <+> ppr ty2
|
||||
|
||||
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
|
||||
|
@ -1,4 +1,16 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Language.Syntax
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -7,53 +19,54 @@
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
--
|
||||
-- Abstract syntax for terms of the Swarm programming language.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.Language.Syntax (
|
||||
-- * Directions
|
||||
Direction (..),
|
||||
applyTurn,
|
||||
toDirection,
|
||||
fromDirection,
|
||||
north,
|
||||
south,
|
||||
east,
|
||||
west,
|
||||
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
-- * Constants
|
||||
Const (..),
|
||||
allConst,
|
||||
ConstInfo (..),
|
||||
ConstMeta (..),
|
||||
MBinAssoc (..),
|
||||
MUnAssoc (..),
|
||||
constInfo,
|
||||
arity,
|
||||
isCmd,
|
||||
isUserFunc,
|
||||
|
||||
module Swarm.Language.Syntax
|
||||
( -- * Directions
|
||||
-- * Terms
|
||||
Var,
|
||||
Term (..),
|
||||
mkOp,
|
||||
|
||||
Direction(..), applyTurn, toDirection, fromDirection, north, south, east, west
|
||||
-- * Term traversal
|
||||
fvT,
|
||||
fv,
|
||||
mapFree1,
|
||||
) where
|
||||
|
||||
-- * Constants
|
||||
, Const(..), allConst
|
||||
import Control.Lens (Plated (..), Traversal', (%~))
|
||||
import Data.Data.Lens (uniplate)
|
||||
import Data.Int (Int64)
|
||||
import qualified Data.Set as S
|
||||
import Data.Text
|
||||
import Linear
|
||||
|
||||
, ConstInfo(..), ConstMeta(..), MBinAssoc(..), MUnAssoc(..), constInfo, arity, isCmd, isUserFunc
|
||||
import Data.Aeson.Types
|
||||
import Data.Data (Data)
|
||||
import Data.Hashable (Hashable)
|
||||
import GHC.Generics (Generic)
|
||||
import Witch.From (from)
|
||||
|
||||
-- * Terms
|
||||
, Var, Term(..), mkOp
|
||||
|
||||
-- * Term traversal
|
||||
|
||||
, fvT, fv, mapFree1
|
||||
|
||||
) where
|
||||
|
||||
import Control.Lens (Plated (..), Traversal', (%~))
|
||||
import Data.Data.Lens (uniplate)
|
||||
import Data.Int (Int64)
|
||||
import qualified Data.Set as S
|
||||
import Data.Text
|
||||
import Linear
|
||||
|
||||
import Data.Aeson.Types
|
||||
import Data.Data (Data)
|
||||
import Data.Hashable (Hashable)
|
||||
import GHC.Generics (Generic)
|
||||
import Witch.From (from)
|
||||
|
||||
import Swarm.Language.Types
|
||||
import Swarm.Language.Types
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Constants
|
||||
@ -74,27 +87,27 @@ instance FromJSONKey Direction where
|
||||
-- turning relative to the given vector or by turning to an absolute
|
||||
-- direction vector.
|
||||
applyTurn :: Direction -> V2 Int64 -> V2 Int64
|
||||
applyTurn Lft (V2 x y) = V2 (-y) x
|
||||
applyTurn Rgt (V2 x y) = V2 y (-x)
|
||||
applyTurn Back (V2 x y) = V2 (-x) (-y)
|
||||
applyTurn Fwd v = v
|
||||
applyTurn North _ = north
|
||||
applyTurn South _ = south
|
||||
applyTurn East _ = east
|
||||
applyTurn West _ = west
|
||||
applyTurn Down _ = V2 0 0
|
||||
applyTurn Lft (V2 x y) = V2 (- y) x
|
||||
applyTurn Rgt (V2 x y) = V2 y (- x)
|
||||
applyTurn Back (V2 x y) = V2 (- x) (- y)
|
||||
applyTurn Fwd v = v
|
||||
applyTurn North _ = north
|
||||
applyTurn South _ = south
|
||||
applyTurn East _ = east
|
||||
applyTurn West _ = west
|
||||
applyTurn Down _ = V2 0 0
|
||||
|
||||
-- | Possibly convert a vector into a 'Direction'---that is, if the
|
||||
-- vector happens to be a unit vector in one of the cardinal
|
||||
-- directions.
|
||||
toDirection :: V2 Int64 -> Maybe Direction
|
||||
toDirection v = case v of
|
||||
V2 0 1 -> Just North
|
||||
toDirection v = case v of
|
||||
V2 0 1 -> Just North
|
||||
V2 0 (-1) -> Just South
|
||||
V2 1 0 -> Just East
|
||||
V2 1 0 -> Just East
|
||||
V2 (-1) 0 -> Just West
|
||||
V2 0 0 -> Just Down
|
||||
_ -> Nothing
|
||||
V2 0 0 -> Just Down
|
||||
_ -> Nothing
|
||||
|
||||
-- | Convert a 'Direction' into a corresponding vector. Note that
|
||||
-- this only does something reasonable for 'North', 'South', 'East',
|
||||
@ -103,9 +116,9 @@ fromDirection :: Direction -> V2 Int64
|
||||
fromDirection d = case d of
|
||||
North -> north
|
||||
South -> south
|
||||
East -> east
|
||||
West -> west
|
||||
_ -> V2 0 0
|
||||
East -> east
|
||||
West -> west
|
||||
_ -> V2 0 0
|
||||
|
||||
-- | The cardinal direction north = @V2 0 1@.
|
||||
north :: V2 Int64
|
||||
@ -117,80 +130,122 @@ south = V2 0 (-1)
|
||||
|
||||
-- | The cardinal direction east = @V2 1 0@.
|
||||
east :: V2 Int64
|
||||
east = V2 1 0
|
||||
east = V2 1 0
|
||||
|
||||
-- | The cardinal direction west = @V2 (-1) 0@.
|
||||
west :: V2 Int64
|
||||
west = V2 (-1) 0
|
||||
west = V2 (-1) 0
|
||||
|
||||
-- | Constants, representing various built-in functions and commands.
|
||||
data Const
|
||||
= -- Trivial actions
|
||||
|
||||
-- Trivial actions
|
||||
= Noop -- ^ Do nothing. This is different than 'Wait'
|
||||
-- in that it does not take up a time step.
|
||||
| Wait -- ^ Wait for one time step without doing anything.
|
||||
| Selfdestruct -- ^ Self-destruct.
|
||||
-- | Do nothing. This is different than 'Wait'
|
||||
-- in that it does not take up a time step.
|
||||
Noop
|
||||
| -- | Wait for one time step without doing anything.
|
||||
Wait
|
||||
| -- | Self-destruct.
|
||||
Selfdestruct
|
||||
| -- Basic actions
|
||||
|
||||
-- Basic actions
|
||||
| Move -- ^ Move forward one step.
|
||||
| Turn -- ^ Turn in some direction.
|
||||
| Grab -- ^ Grab an item from the current location.
|
||||
| Place -- ^ Try to place an item at the current location.
|
||||
| Give -- ^ Give an item to another robot at the current location.
|
||||
| Install -- ^ Install a device on a robot.
|
||||
| Make -- ^ Make an item.
|
||||
| Build -- ^ Construct a new robot.
|
||||
| Say -- ^ Emit a message.
|
||||
| View -- ^ View a certain robot.
|
||||
| Appear -- ^ Set what characters are used for display.
|
||||
| Create -- ^ Create an entity out of thin air. Only
|
||||
-- available in creative mode.
|
||||
-- | Move forward one step.
|
||||
Move
|
||||
| -- | Turn in some direction.
|
||||
Turn
|
||||
| -- | Grab an item from the current location.
|
||||
Grab
|
||||
| -- | Try to place an item at the current location.
|
||||
Place
|
||||
| -- | Give an item to another robot at the current location.
|
||||
Give
|
||||
| -- | Install a device on a robot.
|
||||
Install
|
||||
| -- | Make an item.
|
||||
Make
|
||||
| -- | Construct a new robot.
|
||||
Build
|
||||
| -- | Emit a message.
|
||||
Say
|
||||
| -- | View a certain robot.
|
||||
View
|
||||
| -- | Set what characters are used for display.
|
||||
Appear
|
||||
| -- | Create an entity out of thin air. Only
|
||||
-- available in creative mode.
|
||||
Create
|
||||
| -- Sensing / generation
|
||||
|
||||
-- Sensing / generation
|
||||
| GetX -- ^ Get the current x-coordinate.
|
||||
| GetY -- ^ Get the current y-coordinate.
|
||||
| Blocked -- ^ See if we can move forward or not.
|
||||
| Scan -- ^ Scan a nearby cell
|
||||
| Upload -- ^ Upload knowledge to another robot
|
||||
| Ishere -- ^ See if a specific entity is here. (This may be removed.)
|
||||
| Random -- ^ Get a uniformly random integer.
|
||||
-- | Get the current x-coordinate.
|
||||
GetX
|
||||
| -- | Get the current y-coordinate.
|
||||
GetY
|
||||
| -- | See if we can move forward or not.
|
||||
Blocked
|
||||
| -- | Scan a nearby cell
|
||||
Scan
|
||||
| -- | Upload knowledge to another robot
|
||||
Upload
|
||||
| -- | See if a specific entity is here. (This may be removed.)
|
||||
Ishere
|
||||
| -- | Get a uniformly random integer.
|
||||
Random
|
||||
| -- Modules
|
||||
|
||||
-- Modules
|
||||
| Run -- ^ Run a program loaded from a file.
|
||||
-- | Run a program loaded from a file.
|
||||
Run
|
||||
| -- Language built-ins
|
||||
|
||||
-- Language built-ins
|
||||
| If -- ^ If-expressions.
|
||||
| Fst -- ^ First projection.
|
||||
| Snd -- ^ Second projection.
|
||||
| Force -- ^ Force a delayed evaluation.
|
||||
| Return -- ^ Return for the cmd monad.
|
||||
| Try -- ^ Try/catch block
|
||||
| Raise -- ^ Raise an exception
|
||||
-- | If-expressions.
|
||||
If
|
||||
| -- | First projection.
|
||||
Fst
|
||||
| -- | Second projection.
|
||||
Snd
|
||||
| -- | Force a delayed evaluation.
|
||||
Force
|
||||
| -- | Return for the cmd monad.
|
||||
Return
|
||||
| -- | Try/catch block
|
||||
Try
|
||||
| -- | Raise an exception
|
||||
Raise
|
||||
| -- Arithmetic unary operators
|
||||
|
||||
-- Arithmetic unary operators
|
||||
| Not -- ^ Logical negation.
|
||||
| Neg -- ^ Arithmetic negation.
|
||||
-- | Logical negation.
|
||||
Not
|
||||
| -- | Arithmetic negation.
|
||||
Neg
|
||||
| -- Comparison operators (check for with isCmpBinOp)
|
||||
|
||||
-- Comparison operators (check for with isCmpBinOp)
|
||||
| Eq -- ^ Logical equality comparison
|
||||
| Neq -- ^ Logical unequality comparison
|
||||
| Lt -- ^ Logical lesser-then comparison
|
||||
| Gt -- ^ Logical greater-then comparison
|
||||
| Leq -- ^ Logical lesser-or-equal comparison
|
||||
| Geq -- ^ Logical greater-or-equal comparison
|
||||
|
||||
-- Arithmetic binary operators (check for with isArithBinOp)
|
||||
| Add -- ^ Arithmetic addition operator
|
||||
| Sub -- ^ Arithmetic subtraction operator
|
||||
| Mul -- ^ Arithmetic multiplication operator
|
||||
| Div -- ^ Arithmetic division operator
|
||||
| Exp -- ^ Arithmetic exponentiation operator
|
||||
-- | Logical equality comparison
|
||||
Eq
|
||||
| -- | Logical unequality comparison
|
||||
Neq
|
||||
| -- | Logical lesser-then comparison
|
||||
Lt
|
||||
| -- | Logical greater-then comparison
|
||||
Gt
|
||||
| -- | Logical lesser-or-equal comparison
|
||||
Leq
|
||||
| -- | Logical greater-or-equal comparison
|
||||
Geq
|
||||
| -- Arithmetic binary operators (check for with isArithBinOp)
|
||||
|
||||
-- | Arithmetic addition operator
|
||||
Add
|
||||
| -- | Arithmetic subtraction operator
|
||||
Sub
|
||||
| -- | Arithmetic multiplication operator
|
||||
Mul
|
||||
| -- | Arithmetic division operator
|
||||
Div
|
||||
| -- | Arithmetic exponentiation operator
|
||||
Exp
|
||||
deriving (Eq, Ord, Enum, Bounded, Data, Show)
|
||||
|
||||
allConst :: [Const]
|
||||
allConst = [minBound..maxBound]
|
||||
allConst = [minBound .. maxBound]
|
||||
|
||||
data ConstInfo = ConstInfo
|
||||
{ syntax :: Text
|
||||
@ -200,22 +255,30 @@ data ConstInfo = ConstInfo
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data ConstMeta
|
||||
= ConstMFunc Int Bool -- ^ Function with arity of which some are commands
|
||||
| ConstMUnOp MUnAssoc -- ^ Unary operator with fixity and associativity.
|
||||
| ConstMBinOp MBinAssoc -- ^ Binary operator with fixity and associativity.
|
||||
= -- | Function with arity of which some are commands
|
||||
ConstMFunc Int Bool
|
||||
| -- | Unary operator with fixity and associativity.
|
||||
ConstMUnOp MUnAssoc
|
||||
| -- | Binary operator with fixity and associativity.
|
||||
ConstMBinOp MBinAssoc
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
-- | The meta type representing associativity of binary operator.
|
||||
data MBinAssoc
|
||||
= L -- ^ Left associative binary operator (see 'Control.Monad.Combinators.Expr.InfixL')
|
||||
| N -- ^ Non-associative binary operator (see 'Control.Monad.Combinators.Expr.InfixN')
|
||||
| R -- ^ Right associative binary operator (see 'Control.Monad.Combinators.Expr.InfixR')
|
||||
= -- | Left associative binary operator (see 'Control.Monad.Combinators.Expr.InfixL')
|
||||
L
|
||||
| -- | Non-associative binary operator (see 'Control.Monad.Combinators.Expr.InfixN')
|
||||
N
|
||||
| -- | Right associative binary operator (see 'Control.Monad.Combinators.Expr.InfixR')
|
||||
R
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
-- | The meta type representing associativity of unary operator.
|
||||
data MUnAssoc
|
||||
= P -- ^ Prefix unary operator (see 'Control.Monad.Combinators.Expr.Prefix')
|
||||
| S -- ^ Suffix unary operator (see 'Control.Monad.Combinators.Expr.Suffix')
|
||||
= -- | Prefix unary operator (see 'Control.Monad.Combinators.Expr.Prefix')
|
||||
P
|
||||
| -- | Suffix unary operator (see 'Control.Monad.Combinators.Expr.Suffix')
|
||||
S
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
-- | The arity of a constant, /i.e./ how many arguments it expects.
|
||||
@ -247,56 +310,56 @@ isUserFunc c = case constMeta $ constInfo c of
|
||||
-- matching gives us warning if we add more constants.
|
||||
constInfo :: Const -> ConstInfo
|
||||
constInfo c = case c of
|
||||
Wait -> commandLow 0
|
||||
Noop -> commandLow 0
|
||||
Wait -> commandLow 0
|
||||
Noop -> commandLow 0
|
||||
Selfdestruct -> commandLow 0
|
||||
Move -> commandLow 0
|
||||
Turn -> commandLow 1
|
||||
Grab -> commandLow 0
|
||||
Place -> commandLow 1
|
||||
Give -> commandLow 2
|
||||
Install -> commandLow 2
|
||||
Make -> commandLow 1
|
||||
Build -> commandLow 2
|
||||
Say -> commandLow 1
|
||||
View -> commandLow 1
|
||||
Appear -> commandLow 1
|
||||
Create -> commandLow 1
|
||||
GetX -> commandLow 0
|
||||
GetY -> commandLow 0
|
||||
Blocked -> commandLow 0
|
||||
Scan -> commandLow 0
|
||||
Upload -> commandLow 1
|
||||
Ishere -> commandLow 1
|
||||
Random -> commandLow 1
|
||||
Run -> commandLow 1
|
||||
Return -> commandLow 1
|
||||
Try -> commandLow 2
|
||||
Raise -> commandLow 1
|
||||
If -> functionLow 3
|
||||
Fst -> functionLow 1
|
||||
Snd -> functionLow 1
|
||||
Force -> functionLow 1 -- TODO: make internal?!
|
||||
Not -> functionLow 1
|
||||
Neg -> unaryOp "-" 7 P
|
||||
Add -> binaryOp "+" 6 L
|
||||
Sub -> binaryOp "-" 6 L
|
||||
Mul -> binaryOp "*" 7 L
|
||||
Div -> binaryOp "/" 7 L
|
||||
Exp -> binaryOp "^" 8 R
|
||||
Eq -> binaryOp "==" 4 N
|
||||
Neq -> binaryOp "/=" 4 N
|
||||
Lt -> binaryOp "<" 4 N
|
||||
Gt -> binaryOp ">" 4 N
|
||||
Leq -> binaryOp "<=" 4 N
|
||||
Geq -> binaryOp ">=" 4 N
|
||||
where
|
||||
unaryOp s p side = ConstInfo {syntax=s, fixity=p, constMeta=ConstMUnOp side}
|
||||
binaryOp s p side = ConstInfo {syntax=s, fixity=p, constMeta=ConstMBinOp side}
|
||||
command s a = ConstInfo {syntax=s, fixity=11, constMeta=ConstMFunc a True}
|
||||
function s a = ConstInfo {syntax=s, fixity=11, constMeta=ConstMFunc a False}
|
||||
commandLow = command (lowShow c)
|
||||
functionLow = function (lowShow c)
|
||||
Move -> commandLow 0
|
||||
Turn -> commandLow 1
|
||||
Grab -> commandLow 0
|
||||
Place -> commandLow 1
|
||||
Give -> commandLow 2
|
||||
Install -> commandLow 2
|
||||
Make -> commandLow 1
|
||||
Build -> commandLow 2
|
||||
Say -> commandLow 1
|
||||
View -> commandLow 1
|
||||
Appear -> commandLow 1
|
||||
Create -> commandLow 1
|
||||
GetX -> commandLow 0
|
||||
GetY -> commandLow 0
|
||||
Blocked -> commandLow 0
|
||||
Scan -> commandLow 0
|
||||
Upload -> commandLow 1
|
||||
Ishere -> commandLow 1
|
||||
Random -> commandLow 1
|
||||
Run -> commandLow 1
|
||||
Return -> commandLow 1
|
||||
Try -> commandLow 2
|
||||
Raise -> commandLow 1
|
||||
If -> functionLow 3
|
||||
Fst -> functionLow 1
|
||||
Snd -> functionLow 1
|
||||
Force -> functionLow 1 -- TODO: make internal?!
|
||||
Not -> functionLow 1
|
||||
Neg -> unaryOp "-" 7 P
|
||||
Add -> binaryOp "+" 6 L
|
||||
Sub -> binaryOp "-" 6 L
|
||||
Mul -> binaryOp "*" 7 L
|
||||
Div -> binaryOp "/" 7 L
|
||||
Exp -> binaryOp "^" 8 R
|
||||
Eq -> binaryOp "==" 4 N
|
||||
Neq -> binaryOp "/=" 4 N
|
||||
Lt -> binaryOp "<" 4 N
|
||||
Gt -> binaryOp ">" 4 N
|
||||
Leq -> binaryOp "<=" 4 N
|
||||
Geq -> binaryOp ">=" 4 N
|
||||
where
|
||||
unaryOp s p side = ConstInfo {syntax = s, fixity = p, constMeta = ConstMUnOp side}
|
||||
binaryOp s p side = ConstInfo {syntax = s, fixity = p, constMeta = ConstMBinOp side}
|
||||
command s a = ConstInfo {syntax = s, fixity = 11, constMeta = ConstMFunc a True}
|
||||
function s a = ConstInfo {syntax = s, fixity = 11, constMeta = ConstMFunc a False}
|
||||
commandLow = command (lowShow c)
|
||||
functionLow = function (lowShow c)
|
||||
|
||||
-- | Make infix operation (e.g. @2 + 3@) a curried function
|
||||
-- application (@((+) 2) 3@).
|
||||
@ -307,64 +370,48 @@ mkOp c = TApp . TApp (TConst c)
|
||||
-- Terms
|
||||
|
||||
-- | Terms of the Swarm language.
|
||||
|
||||
data Term
|
||||
-- | The unit value.
|
||||
= TUnit
|
||||
|
||||
-- | A constant.
|
||||
| TConst Const
|
||||
|
||||
-- | A direction literal.
|
||||
| TDir Direction
|
||||
|
||||
-- | An integer literal.
|
||||
| TInt Integer
|
||||
|
||||
-- | An antiquoted Haskell variable name of type Integer.
|
||||
| TAntiInt Text
|
||||
|
||||
-- | A string literal.
|
||||
| TString Text
|
||||
|
||||
-- | An antiquoted Haskell variable name of type Text.
|
||||
| TAntiString Text
|
||||
|
||||
-- | A Boolean literal.
|
||||
| TBool Bool
|
||||
|
||||
-- | A variable.
|
||||
| TVar Var
|
||||
|
||||
-- | A pair.
|
||||
| TPair Term Term
|
||||
|
||||
-- | A lambda expression, with or without a type annotation on the
|
||||
= -- | The unit value.
|
||||
TUnit
|
||||
| -- | A constant.
|
||||
TConst Const
|
||||
| -- | A direction literal.
|
||||
TDir Direction
|
||||
| -- | An integer literal.
|
||||
TInt Integer
|
||||
| -- | An antiquoted Haskell variable name of type Integer.
|
||||
TAntiInt Text
|
||||
| -- | A string literal.
|
||||
TString Text
|
||||
| -- | An antiquoted Haskell variable name of type Text.
|
||||
TAntiString Text
|
||||
| -- | A Boolean literal.
|
||||
TBool Bool
|
||||
| -- | A variable.
|
||||
TVar Var
|
||||
| -- | A pair.
|
||||
TPair Term Term
|
||||
| -- | A lambda expression, with or without a type annotation on the
|
||||
-- binder.
|
||||
| TLam Var (Maybe Type) Term
|
||||
|
||||
-- | Function application.
|
||||
| TApp Term Term
|
||||
|
||||
-- | A (recursive) let expression, with or without a type
|
||||
TLam Var (Maybe Type) Term
|
||||
| -- | Function application.
|
||||
TApp Term Term
|
||||
| -- | A (recursive) let expression, with or without a type
|
||||
-- annotation on the variable.
|
||||
| TLet Var (Maybe Polytype) Term Term
|
||||
|
||||
-- | A (recursive) definition command, which binds a variable to a
|
||||
TLet Var (Maybe Polytype) Term Term
|
||||
| -- | A (recursive) definition command, which binds a variable to a
|
||||
-- value in subsequent commands.
|
||||
| TDef Var (Maybe Polytype) Term
|
||||
|
||||
-- | A monadic bind for commands, of the form @c1 ; c2@ or @x <- c1; c2@.
|
||||
| TBind (Maybe Var) Term Term
|
||||
|
||||
-- | Delay evaluation of a term. Swarm is an eager language, but
|
||||
TDef Var (Maybe Polytype) Term
|
||||
| -- | A monadic bind for commands, of the form @c1 ; c2@ or @x <- c1; c2@.
|
||||
TBind (Maybe Var) Term Term
|
||||
| -- | Delay evaluation of a term. Swarm is an eager language, but
|
||||
-- in some cases (e.g. for @if@ statements and recursive
|
||||
-- bindings) we need to delay evaluation. The counterpart to
|
||||
-- @delay@ is @force@, where @force (delay t) = t@. Note that
|
||||
-- 'Force' is just a constant, whereas 'TDelay' has to be a
|
||||
-- special syntactic form so its argument can get special
|
||||
-- treatment during evaluation.
|
||||
| TDelay Term
|
||||
TDelay Term
|
||||
deriving (Eq, Show, Data)
|
||||
|
||||
instance Plated Term where
|
||||
@ -374,35 +421,35 @@ instance Plated Term where
|
||||
-- variables.
|
||||
fvT :: Traversal' Term Term
|
||||
fvT f = go S.empty
|
||||
where
|
||||
go bound t = case t of
|
||||
TUnit -> pure t
|
||||
TConst{} -> pure t
|
||||
TDir{} -> pure t
|
||||
TInt{} -> pure t
|
||||
TAntiInt{} -> pure t
|
||||
TString{} -> pure t
|
||||
TAntiString{} -> pure t
|
||||
TBool{} -> pure t
|
||||
TVar x
|
||||
| x `S.member` bound -> pure t
|
||||
| otherwise -> f (TVar x)
|
||||
TLam x ty t1 -> TLam x ty <$> go (S.insert x bound) t1
|
||||
TApp t1 t2 -> TApp <$> go bound t1 <*> go bound t2
|
||||
TLet x ty t1 t2 ->
|
||||
let bound' = S.insert x bound
|
||||
in TLet x ty <$> go bound' t1 <*> go bound' t2
|
||||
TPair t1 t2 -> TPair <$> go bound t1 <*> go bound t2
|
||||
TDef x ty t1 -> TDef x ty <$> go (S.insert x bound) t1
|
||||
TBind mx t1 t2 ->
|
||||
TBind mx <$> go bound t1 <*> go (maybe id S.insert mx bound) t2
|
||||
TDelay t1 -> TDelay <$> go bound t1
|
||||
where
|
||||
go bound t = case t of
|
||||
TUnit -> pure t
|
||||
TConst {} -> pure t
|
||||
TDir {} -> pure t
|
||||
TInt {} -> pure t
|
||||
TAntiInt {} -> pure t
|
||||
TString {} -> pure t
|
||||
TAntiString {} -> pure t
|
||||
TBool {} -> pure t
|
||||
TVar x
|
||||
| x `S.member` bound -> pure t
|
||||
| otherwise -> f (TVar x)
|
||||
TLam x ty t1 -> TLam x ty <$> go (S.insert x bound) t1
|
||||
TApp t1 t2 -> TApp <$> go bound t1 <*> go bound t2
|
||||
TLet x ty t1 t2 ->
|
||||
let bound' = S.insert x bound
|
||||
in TLet x ty <$> go bound' t1 <*> go bound' t2
|
||||
TPair t1 t2 -> TPair <$> go bound t1 <*> go bound t2
|
||||
TDef x ty t1 -> TDef x ty <$> go (S.insert x bound) t1
|
||||
TBind mx t1 t2 ->
|
||||
TBind mx <$> go bound t1 <*> go (maybe id S.insert mx bound) t2
|
||||
TDelay t1 -> TDelay <$> go bound t1
|
||||
|
||||
-- | Traversal over the free variables of a term. Note that if you
|
||||
-- want to get the set of all free variables, you can do so via
|
||||
-- @'Data.Set.Lens.setOf' 'fv'@.
|
||||
fv :: Traversal' Term Var
|
||||
fv = fvT . (\f -> \case { TVar x -> TVar <$> f x ; t -> pure t })
|
||||
fv = fvT . (\f -> \case TVar x -> TVar <$> f x; t -> pure t)
|
||||
|
||||
-- | Apply a function to all free occurrences of a particular variable.
|
||||
mapFree1 :: Var -> (Term -> Term) -> Term -> Term
|
||||
|
@ -1,4 +1,19 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
-- For 'Ord IntVar' instance
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Language.Typecheck
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -9,68 +24,56 @@
|
||||
-- Type inference for the Swarm language. For the approach used here,
|
||||
-- see
|
||||
-- https://byorgey.wordpress.com/2021/09/08/implementing-hindley-milner-with-the-unification-fd-library/ .
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.Language.Typecheck (
|
||||
-- * Type errors
|
||||
TypeErr (..),
|
||||
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
-- * Inference monad
|
||||
Infer,
|
||||
runInfer,
|
||||
lookup,
|
||||
fresh,
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
-- For 'Ord IntVar' instance
|
||||
-- * Unification
|
||||
substU,
|
||||
(=:=),
|
||||
HasBindings (..),
|
||||
instantiate,
|
||||
skolemize,
|
||||
generalize,
|
||||
|
||||
module Swarm.Language.Typecheck
|
||||
( -- * Type errors
|
||||
TypeErr(..)
|
||||
-- * Type inferen
|
||||
inferTop,
|
||||
inferModule,
|
||||
infer,
|
||||
inferConst,
|
||||
check,
|
||||
decomposeCmdTy,
|
||||
decomposeFunTy,
|
||||
) where
|
||||
|
||||
-- * Inference monad
|
||||
import Control.Category ((>>>))
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import Data.Foldable (fold)
|
||||
import Data.Functor.Identity
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import Data.Set (Set, (\\))
|
||||
import qualified Data.Set as S
|
||||
import Prelude hiding (lookup)
|
||||
|
||||
, Infer, runInfer, lookup
|
||||
, fresh
|
||||
import Control.Unification hiding (applyBindings, (=:=))
|
||||
import qualified Control.Unification as U
|
||||
import Control.Unification.IntVar
|
||||
import Data.Functor.Fixedpoint (cata)
|
||||
|
||||
-- * Unification
|
||||
|
||||
, substU, (=:=), HasBindings(..)
|
||||
, instantiate, skolemize, generalize
|
||||
|
||||
-- * Type inferen
|
||||
|
||||
, inferTop, inferModule, infer, inferConst, check
|
||||
|
||||
, decomposeCmdTy
|
||||
, decomposeFunTy
|
||||
) where
|
||||
|
||||
|
||||
import Control.Category ((>>>))
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import Data.Foldable (fold)
|
||||
import Data.Functor.Identity
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import Data.Set (Set, (\\))
|
||||
import qualified Data.Set as S
|
||||
import Prelude hiding (lookup)
|
||||
|
||||
import Control.Unification hiding (applyBindings, (=:=))
|
||||
import qualified Control.Unification as U
|
||||
import Control.Unification.IntVar
|
||||
import Data.Functor.Fixedpoint (cata)
|
||||
|
||||
import Swarm.Language.Context hiding (lookup)
|
||||
import qualified Swarm.Language.Context as Ctx
|
||||
import Swarm.Language.Parse.QQ (tyQ)
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Language.Types
|
||||
import Swarm.Language.Context hiding (lookup)
|
||||
import qualified Swarm.Language.Context as Ctx
|
||||
import Swarm.Language.Parse.QQ (tyQ)
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Language.Types
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Inference monad
|
||||
@ -85,12 +88,12 @@ type Infer = ReaderT UCtx (ExceptT TypeErr (IntBindingT TypeF Identity))
|
||||
-- 'TypeErr' or a fully resolved 'TModule'.
|
||||
runInfer :: TCtx -> Infer UModule -> Either TypeErr TModule
|
||||
runInfer ctx =
|
||||
(>>= applyBindings) >>>
|
||||
(>>= \(Module uty uctx) -> Module <$> (fromU <$> generalize uty) <*> pure (fromU uctx)) >>>
|
||||
flip runReaderT (toU ctx) >>>
|
||||
runExceptT >>>
|
||||
evalIntBindingT >>>
|
||||
runIdentity
|
||||
(>>= applyBindings)
|
||||
>>> (>>= \(Module uty uctx) -> Module <$> (fromU <$> generalize uty) <*> pure (fromU uctx))
|
||||
>>> flip runReaderT (toU ctx)
|
||||
>>> runExceptT
|
||||
>>> evalIntBindingT
|
||||
>>> runIdentity
|
||||
|
||||
-- | Look up a variable in the ambient type context, either throwing
|
||||
-- an 'UnboundVar' error if it is not found, or opening its
|
||||
@ -118,16 +121,18 @@ class FreeVars a where
|
||||
-- | We can get the free variables of a type (which would consist of
|
||||
-- only type variables).
|
||||
instance FreeVars Type where
|
||||
freeVars = return . cata (\case {TyVarF x -> S.singleton (Left x); f -> fold f})
|
||||
freeVars = return . cata (\case TyVarF x -> S.singleton (Left x); f -> fold f)
|
||||
|
||||
-- | We can get the free variables of a 'UType' (which would consist
|
||||
-- of unification variables as well as type variables).
|
||||
instance FreeVars UType where
|
||||
freeVars ut = do
|
||||
fuvs <- fmap (S.fromList . map Right) . lift . lift $ getFreeVars ut
|
||||
let ftvs = ucata (const S.empty)
|
||||
(\case {TyVarF x -> S.singleton (Left x); f -> fold f})
|
||||
ut
|
||||
let ftvs =
|
||||
ucata
|
||||
(const S.empty)
|
||||
(\case TyVarF x -> S.singleton (Left x); f -> fold f)
|
||||
ut
|
||||
return $ fuvs `S.union` ftvs
|
||||
|
||||
-- | We can also get the free variables of a polytype.
|
||||
@ -147,12 +152,13 @@ fresh = UVar <$> lift (lift freeVar)
|
||||
-- any binding constructs, we don't have to worry about ignoring
|
||||
-- bound variables; all variables in a 'UType' are free.
|
||||
substU :: Map (Either Var IntVar) UType -> UType -> UType
|
||||
substU m = ucata
|
||||
(\v -> fromMaybe (UVar v) (M.lookup (Right v) m))
|
||||
(\case
|
||||
TyVarF v -> fromMaybe (UTyVar v) (M.lookup (Left v) m)
|
||||
f -> UTerm f
|
||||
)
|
||||
substU m =
|
||||
ucata
|
||||
(\v -> fromMaybe (UVar v) (M.lookup (Right v) m))
|
||||
( \case
|
||||
TyVarF v -> fromMaybe (UTyVar v) (M.lookup (Left v) m)
|
||||
f -> UTerm f
|
||||
)
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Lifted stuff from unification-fd
|
||||
@ -204,9 +210,9 @@ skolemize :: UPolytype -> Infer UType
|
||||
skolemize (Forall xs uty) = do
|
||||
xs' <- mapM (const fresh) xs
|
||||
return $ substU (M.fromList (zip (map Left xs) (map toSkolem xs'))) uty
|
||||
where
|
||||
toSkolem (UVar v) = UTyVar (mkVarName "s" v)
|
||||
toSkolem x = error $ "Impossible! Non-UVar in skolemize.toSkolem: " ++ show x
|
||||
where
|
||||
toSkolem (UVar v) = UTyVar (mkVarName "s" v)
|
||||
toSkolem x = error $ "Impossible! Non-UVar in skolemize.toSkolem: " ++ show x
|
||||
|
||||
-- | 'generalize' is the opposite of 'instantiate': add a 'Forall'
|
||||
-- which closes over all free type and unification variables.
|
||||
@ -214,10 +220,10 @@ generalize :: UType -> Infer UPolytype
|
||||
generalize uty = do
|
||||
uty' <- applyBindings uty
|
||||
ctx <- ask
|
||||
tmfvs <- freeVars uty'
|
||||
tmfvs <- freeVars uty'
|
||||
ctxfvs <- freeVars ctx
|
||||
let fvs = S.toList $ tmfvs \\ ctxfvs
|
||||
xs = map (either id (mkVarName "a")) fvs
|
||||
xs = map (either id (mkVarName "a")) fvs
|
||||
return $ Forall xs (substU (M.fromList (zip fvs (map UTyVar xs))) uty')
|
||||
|
||||
------------------------------------------------------------
|
||||
@ -229,18 +235,14 @@ generalize uty = do
|
||||
-- should be very much improved in the future); errors can then
|
||||
-- separately be pretty-printed to display them to the user.
|
||||
data TypeErr
|
||||
|
||||
-- | An undefined variable was encountered.
|
||||
= UnboundVar Var
|
||||
|
||||
= -- | An undefined variable was encountered.
|
||||
UnboundVar Var
|
||||
| Infinite IntVar UType
|
||||
|
||||
-- | The given term was expected to have a certain type, but has a
|
||||
-- different type instead.
|
||||
| Mismatch (TypeF UType) (TypeF UType)
|
||||
|
||||
-- | A definition was encountered not at the top level.
|
||||
| DefNotTopLevel Term
|
||||
| -- | The given term was expected to have a certain type, but has a
|
||||
-- different type instead.
|
||||
Mismatch (TypeF UType) (TypeF UType)
|
||||
| -- | A definition was encountered not at the top level.
|
||||
DefNotTopLevel Term
|
||||
|
||||
instance Fallible TypeF IntVar TypeErr where
|
||||
occursFailure = Infinite
|
||||
@ -259,7 +261,6 @@ inferTop ctx = runInfer ctx . inferModule
|
||||
-- contain definitions.
|
||||
inferModule :: Term -> Infer UModule
|
||||
inferModule = \case
|
||||
|
||||
-- For definitions with no type signature, make up a fresh type
|
||||
-- variable for the body, infer the body under an extended context,
|
||||
-- and unify the two. Then generalize the type and return an
|
||||
@ -283,7 +284,6 @@ inferModule = \case
|
||||
-- returned modules appropriately. Have to be careful to use the
|
||||
-- correct context when checking the right-hand side in particular.
|
||||
TBind mx c1 c2 -> do
|
||||
|
||||
-- First, infer the left side.
|
||||
Module cmda ctx1 <- inferModule c1
|
||||
a <- decomposeCmdTy cmda
|
||||
@ -295,18 +295,19 @@ inferModule = \case
|
||||
-- c1 could define something with the same name as x, in which
|
||||
-- case the bound x should shadow the defined one; hence, we apply
|
||||
-- that binding /after/ (i.e. /within/) the application of @ctx1@.
|
||||
withBindings ctx1 $ maybe id (`withBinding` Forall [] a) mx $ do
|
||||
Module cmdb ctx2 <- inferModule c2
|
||||
withBindings ctx1 $
|
||||
maybe id (`withBinding` Forall [] a) mx $ do
|
||||
Module cmdb ctx2 <- inferModule c2
|
||||
|
||||
-- We don't actually need the result type since we're just going
|
||||
-- to return cmdb, but it's important to ensure it's a command
|
||||
-- type anyway. Otherwise something like 'move; 3' would be
|
||||
-- accepted with type int.
|
||||
_ <- decomposeCmdTy cmdb
|
||||
-- We don't actually need the result type since we're just going
|
||||
-- to return cmdb, but it's important to ensure it's a command
|
||||
-- type anyway. Otherwise something like 'move; 3' would be
|
||||
-- accepted with type int.
|
||||
_ <- decomposeCmdTy cmdb
|
||||
|
||||
-- Ctx.union is right-biased, so ctx1 `union` ctx2 means later
|
||||
-- definitions will shadow previous ones.
|
||||
return $ Module cmdb (ctx1 `Ctx.union` ctx2)
|
||||
-- Ctx.union is right-biased, so ctx1 `union` ctx2 means later
|
||||
-- definitions will shadow previous ones.
|
||||
return $ Module cmdb (ctx1 `Ctx.union` ctx2)
|
||||
|
||||
-- In all other cases, there can no longer be any definitions in the
|
||||
-- term, so delegate to 'infer'.
|
||||
@ -314,29 +315,24 @@ inferModule = \case
|
||||
|
||||
-- | Infer the type of a term which does not contain definitions.
|
||||
infer :: Term -> Infer UType
|
||||
|
||||
infer TUnit = return UTyUnit
|
||||
infer (TConst c) = instantiate $ inferConst c
|
||||
infer (TDir _) = return UTyDir
|
||||
infer (TInt _) = return UTyInt
|
||||
infer (TAntiInt _) = return UTyInt
|
||||
infer (TString _) = return UTyString
|
||||
infer (TAntiString _) = return UTyString
|
||||
infer (TBool _) = return UTyBool
|
||||
|
||||
infer TUnit = return UTyUnit
|
||||
infer (TConst c) = instantiate $ inferConst c
|
||||
infer (TDir _) = return UTyDir
|
||||
infer (TInt _) = return UTyInt
|
||||
infer (TAntiInt _) = return UTyInt
|
||||
infer (TString _) = return UTyString
|
||||
infer (TAntiString _) = return UTyString
|
||||
infer (TBool _) = return UTyBool
|
||||
-- To infer the type of a pair, just infer both components.
|
||||
infer (TPair t1 t2) = UTyProd <$> infer t1 <*> infer t2
|
||||
|
||||
infer (TPair t1 t2) = UTyProd <$> infer t1 <*> infer t2
|
||||
-- delay t has the same type as t.
|
||||
infer (TDelay t) = infer t
|
||||
|
||||
infer (TDelay t) = infer t
|
||||
-- Just look up variables in the context.
|
||||
infer (TVar x) = lookup x
|
||||
|
||||
infer (TVar x) = lookup x
|
||||
-- To infer the type of a lambda if the type of the argument is
|
||||
-- provided, just infer the body under an extended context and return
|
||||
-- the appropriate function type.
|
||||
infer (TLam x (Just argTy) t) = do
|
||||
infer (TLam x (Just argTy) t) = do
|
||||
let uargTy = toU argTy
|
||||
resTy <- withBinding x (Forall [] uargTy) $ infer t
|
||||
return $ UTyFun uargTy resTy
|
||||
@ -349,8 +345,7 @@ infer (TLam x Nothing t) = do
|
||||
return $ UTyFun argTy resTy
|
||||
|
||||
-- To infer the type of an application:
|
||||
infer (TApp f x) = do
|
||||
|
||||
infer (TApp f x) = do
|
||||
-- Infer the type of the left-hand side and make sure it has a function type.
|
||||
fTy <- infer f
|
||||
(ty1, ty2) <- decomposeFunTy fTy
|
||||
@ -361,12 +356,12 @@ infer (TApp f x) = do
|
||||
|
||||
-- We can infer the type of a let whether a type has been provided for
|
||||
-- the variable or not.
|
||||
infer (TLet x Nothing t1 t2) = do
|
||||
infer (TLet x Nothing t1 t2) = do
|
||||
xTy <- fresh
|
||||
uty <- withBinding x (Forall [] xTy) $ infer t1
|
||||
xTy =:= uty
|
||||
upty <- generalize uty
|
||||
withBinding x upty $ infer t2
|
||||
withBinding x upty $ infer t2
|
||||
infer (TLet x (Just pty) t1 t2) = do
|
||||
let upty = toU pty
|
||||
-- If an explicit polytype has been provided, skolemize it and check
|
||||
@ -375,9 +370,7 @@ infer (TLet x (Just pty) t1 t2) = do
|
||||
withBinding x upty $ do
|
||||
check t1 uty
|
||||
infer t2
|
||||
|
||||
infer t@TDef {} = throwError $ DefNotTopLevel t
|
||||
|
||||
infer (TBind mx c1 c2) = do
|
||||
ty1 <- infer c1
|
||||
a <- decomposeCmdTy ty1
|
||||
@ -405,59 +398,52 @@ decomposeFunTy ty = do
|
||||
-- | Infer the type of a constant.
|
||||
inferConst :: Const -> UPolytype
|
||||
inferConst c = toU $ case c of
|
||||
Wait -> [tyQ| cmd () |]
|
||||
Noop -> [tyQ| cmd () |]
|
||||
Wait -> [tyQ| cmd () |]
|
||||
Noop -> [tyQ| cmd () |]
|
||||
Selfdestruct -> [tyQ| cmd () |]
|
||||
|
||||
Move -> [tyQ| cmd () |]
|
||||
Turn -> [tyQ| dir -> cmd () |]
|
||||
Grab -> [tyQ| cmd string |]
|
||||
Place -> [tyQ| string -> cmd () |]
|
||||
Give -> [tyQ| string -> string -> cmd () |]
|
||||
Install -> [tyQ| string -> string -> cmd () |]
|
||||
Make -> [tyQ| string -> cmd () |]
|
||||
Build -> [tyQ| forall a. string -> cmd a -> cmd string |]
|
||||
Say -> [tyQ| string -> cmd () |]
|
||||
View -> [tyQ| string -> cmd () |]
|
||||
Appear -> [tyQ| string -> cmd () |]
|
||||
Create -> [tyQ| string -> cmd () |]
|
||||
|
||||
GetX -> [tyQ| cmd int |]
|
||||
GetY -> [tyQ| cmd int |]
|
||||
Blocked -> [tyQ| cmd bool |]
|
||||
Scan -> [tyQ| dir -> cmd () |]
|
||||
Upload -> [tyQ| string -> cmd () |]
|
||||
Ishere -> [tyQ| string -> cmd bool |]
|
||||
Random -> [tyQ| int -> cmd int |]
|
||||
|
||||
Run -> [tyQ| string -> cmd () |]
|
||||
|
||||
If -> [tyQ| forall a. bool -> a -> a -> a |]
|
||||
Fst -> [tyQ| forall a b. a * b -> a |]
|
||||
Snd -> [tyQ| forall a b. a * b -> b |]
|
||||
Force -> [tyQ| forall a. a -> a |]
|
||||
Return -> [tyQ| forall a. a -> cmd a |]
|
||||
Try -> [tyQ| forall a. cmd a -> cmd a -> cmd a |]
|
||||
Raise -> [tyQ| forall a. string -> cmd a |]
|
||||
|
||||
Not -> [tyQ| bool -> bool |]
|
||||
Neg -> [tyQ| int -> int |]
|
||||
|
||||
Eq -> cmpBinT
|
||||
Neq -> cmpBinT
|
||||
Lt -> cmpBinT
|
||||
Gt -> cmpBinT
|
||||
Leq -> cmpBinT
|
||||
Geq -> cmpBinT
|
||||
|
||||
Add -> arithBinT
|
||||
Sub -> arithBinT
|
||||
Mul -> arithBinT
|
||||
Div -> arithBinT
|
||||
Exp -> arithBinT
|
||||
where
|
||||
cmpBinT = [tyQ| forall a. a -> a -> bool |]
|
||||
arithBinT = [tyQ| int -> int -> int |]
|
||||
Move -> [tyQ| cmd () |]
|
||||
Turn -> [tyQ| dir -> cmd () |]
|
||||
Grab -> [tyQ| cmd string |]
|
||||
Place -> [tyQ| string -> cmd () |]
|
||||
Give -> [tyQ| string -> string -> cmd () |]
|
||||
Install -> [tyQ| string -> string -> cmd () |]
|
||||
Make -> [tyQ| string -> cmd () |]
|
||||
Build -> [tyQ| forall a. string -> cmd a -> cmd string |]
|
||||
Say -> [tyQ| string -> cmd () |]
|
||||
View -> [tyQ| string -> cmd () |]
|
||||
Appear -> [tyQ| string -> cmd () |]
|
||||
Create -> [tyQ| string -> cmd () |]
|
||||
GetX -> [tyQ| cmd int |]
|
||||
GetY -> [tyQ| cmd int |]
|
||||
Blocked -> [tyQ| cmd bool |]
|
||||
Scan -> [tyQ| dir -> cmd () |]
|
||||
Upload -> [tyQ| string -> cmd () |]
|
||||
Ishere -> [tyQ| string -> cmd bool |]
|
||||
Random -> [tyQ| int -> cmd int |]
|
||||
Run -> [tyQ| string -> cmd () |]
|
||||
If -> [tyQ| forall a. bool -> a -> a -> a |]
|
||||
Fst -> [tyQ| forall a b. a * b -> a |]
|
||||
Snd -> [tyQ| forall a b. a * b -> b |]
|
||||
Force -> [tyQ| forall a. a -> a |]
|
||||
Return -> [tyQ| forall a. a -> cmd a |]
|
||||
Try -> [tyQ| forall a. cmd a -> cmd a -> cmd a |]
|
||||
Raise -> [tyQ| forall a. string -> cmd a |]
|
||||
Not -> [tyQ| bool -> bool |]
|
||||
Neg -> [tyQ| int -> int |]
|
||||
Eq -> cmpBinT
|
||||
Neq -> cmpBinT
|
||||
Lt -> cmpBinT
|
||||
Gt -> cmpBinT
|
||||
Leq -> cmpBinT
|
||||
Geq -> cmpBinT
|
||||
Add -> arithBinT
|
||||
Sub -> arithBinT
|
||||
Mul -> arithBinT
|
||||
Div -> arithBinT
|
||||
Exp -> arithBinT
|
||||
where
|
||||
cmpBinT = [tyQ| forall a. a -> a -> bool |]
|
||||
arithBinT = [tyQ| int -> int -> int |]
|
||||
|
||||
-- | @check t ty@ checks that @t@ has type @ty@.
|
||||
check :: Term -> UType -> Infer ()
|
||||
|
@ -1,4 +1,22 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
-- for the Data IntVar instance
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Language.Types
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -7,76 +25,73 @@
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
--
|
||||
-- Types for the Swarm programming language and related utilities.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.Language.Types (
|
||||
-- * Basic definitions
|
||||
BaseTy (..),
|
||||
Var,
|
||||
TypeF (..),
|
||||
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
-- * @Type@
|
||||
Type,
|
||||
pattern TyBase,
|
||||
pattern TyVar,
|
||||
pattern TyUnit,
|
||||
pattern TyInt,
|
||||
pattern TyString,
|
||||
pattern TyDir,
|
||||
pattern TyBool,
|
||||
pattern (:*:),
|
||||
pattern (:->:),
|
||||
pattern TyCmd,
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
-- for the Data IntVar instance
|
||||
-- * @UType@
|
||||
UType,
|
||||
pattern UTyBase,
|
||||
pattern UTyVar,
|
||||
pattern UTyUnit,
|
||||
pattern UTyInt,
|
||||
pattern UTyString,
|
||||
pattern UTyDir,
|
||||
pattern UTyBool,
|
||||
pattern UTyProd,
|
||||
pattern UTyFun,
|
||||
pattern UTyCmd,
|
||||
|
||||
module Swarm.Language.Types
|
||||
( -- * Basic definitions
|
||||
BaseTy(..), Var
|
||||
, TypeF(..)
|
||||
-- ** Utilities
|
||||
ucata,
|
||||
mkVarName,
|
||||
|
||||
-- * @Type@
|
||||
, Type
|
||||
-- * Polytypes
|
||||
Poly (..),
|
||||
Polytype,
|
||||
UPolytype,
|
||||
|
||||
, pattern TyBase, pattern TyVar
|
||||
, pattern TyUnit, pattern TyInt, pattern TyString, pattern TyDir, pattern TyBool
|
||||
, pattern (:*:), pattern (:->:)
|
||||
, pattern TyCmd
|
||||
-- * Contexts
|
||||
TCtx,
|
||||
UCtx,
|
||||
|
||||
-- * @UType@
|
||||
, UType
|
||||
, pattern UTyBase, pattern UTyVar
|
||||
, pattern UTyUnit, pattern UTyInt, pattern UTyString, pattern UTyDir, pattern UTyBool
|
||||
, pattern UTyProd, pattern UTyFun
|
||||
, pattern UTyCmd
|
||||
-- * Modules
|
||||
Module (..),
|
||||
TModule,
|
||||
UModule,
|
||||
trivMod,
|
||||
|
||||
-- ** Utilities
|
||||
-- * The 'WithU' class
|
||||
WithU (..),
|
||||
) where
|
||||
|
||||
, ucata, mkVarName
|
||||
import Control.Unification
|
||||
import Control.Unification.IntVar
|
||||
import Data.Data (Data)
|
||||
import Data.Functor.Fixedpoint
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.String (IsString (..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics (Generic1)
|
||||
import Witch
|
||||
|
||||
-- * Polytypes
|
||||
, Poly(..), Polytype, UPolytype
|
||||
|
||||
-- * Contexts
|
||||
, TCtx, UCtx
|
||||
|
||||
-- * Modules
|
||||
, Module(..), TModule, UModule, trivMod
|
||||
|
||||
-- * The 'WithU' class
|
||||
, WithU(..)
|
||||
|
||||
) where
|
||||
|
||||
import Control.Unification
|
||||
import Control.Unification.IntVar
|
||||
import Data.Data (Data)
|
||||
import Data.Functor.Fixedpoint
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.String (IsString (..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics (Generic1)
|
||||
import Witch
|
||||
|
||||
import Swarm.Language.Context
|
||||
import Swarm.Language.Context
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Types
|
||||
@ -84,11 +99,16 @@ import Swarm.Language.Context
|
||||
|
||||
-- | Base types.
|
||||
data BaseTy
|
||||
= BUnit -- ^ The unit type, with a single inhabitant.
|
||||
| BInt -- ^ Signed, arbitrary-size integers.
|
||||
| BString -- ^ Unicode strings.
|
||||
| BDir -- ^ Directions.
|
||||
| BBool -- ^ Booleans.
|
||||
= -- | The unit type, with a single inhabitant.
|
||||
BUnit
|
||||
| -- | Signed, arbitrary-size integers.
|
||||
BInt
|
||||
| -- | Unicode strings.
|
||||
BString
|
||||
| -- | Directions.
|
||||
BDir
|
||||
| -- | Booleans.
|
||||
BBool
|
||||
deriving (Eq, Ord, Show, Data)
|
||||
|
||||
-- | A "structure functor" encoding the shape of type expressions.
|
||||
@ -97,12 +117,17 @@ data BaseTy
|
||||
-- so that we can work with the @unification-fd@ package (see
|
||||
-- https://byorgey.wordpress.com/2021/09/08/implementing-hindley-milner-with-the-unification-fd-library/).
|
||||
data TypeF t
|
||||
= TyBaseF BaseTy -- ^ A base type.
|
||||
| TyVarF Var -- ^ A type variable.
|
||||
| TyCmdF t -- ^ Commands, with return type. Note that
|
||||
-- commands form a monad.
|
||||
| TyProdF t t -- ^ Product type.
|
||||
| TyFunF t t -- ^ Function type.
|
||||
= -- | A base type.
|
||||
TyBaseF BaseTy
|
||||
| -- | A type variable.
|
||||
TyVarF Var
|
||||
| -- | Commands, with return type. Note that
|
||||
-- commands form a monad.
|
||||
TyCmdF t
|
||||
| -- | Product type.
|
||||
TyProdF t t
|
||||
| -- | Function type.
|
||||
TyFunF t t
|
||||
deriving (Show, Eq, Functor, Foldable, Traversable, Generic1, Unifiable, Data)
|
||||
|
||||
-- | @Type@ is now defined as the fixed point of 'TypeF'. It would be
|
||||
@ -132,7 +157,7 @@ deriving instance Data IntVar
|
||||
-- @unification-fd@ package, but since it doesn't provide one, we
|
||||
-- define it here.
|
||||
ucata :: Functor t => (v -> a) -> (t a -> a) -> UTerm t v -> a
|
||||
ucata f _ (UVar v) = f v
|
||||
ucata f _ (UVar v) = f v
|
||||
ucata f g (UTerm t) = g (fmap (ucata f g) t)
|
||||
|
||||
-- | A quick-and-dirty method for turning an 'IntVar' (used internally
|
||||
@ -185,7 +210,7 @@ type UPolytype = Poly UType
|
||||
-- contain definitions ('Swarm.Language.Syntax.TDef'). A module
|
||||
-- contains the overall type of the expression, as well as the
|
||||
-- context giving the types of any defined variables.
|
||||
data Module s t = Module { moduleTy :: s, moduleCtx :: Ctx t }
|
||||
data Module s t = Module {moduleTy :: s, moduleCtx :: Ctx t}
|
||||
deriving (Show, Eq, Functor, Data)
|
||||
|
||||
-- | A 'TModule' is the final result of the type inference process on
|
||||
@ -226,7 +251,7 @@ class WithU t where
|
||||
-- | Convert from @t@ to its associated "@U@-version". This
|
||||
-- direction is always safe (we simply have no unification
|
||||
-- variables even though the type allows it).
|
||||
toU :: t -> U t
|
||||
toU :: t -> U t
|
||||
|
||||
-- | Convert from the associated "@U@-version" back to @t@.
|
||||
-- Generally, this direction requires somehow knowing that there
|
||||
@ -258,19 +283,19 @@ pattern TyVar :: Var -> Type
|
||||
pattern TyVar v = Fix (TyVarF v)
|
||||
|
||||
pattern TyUnit :: Type
|
||||
pattern TyUnit = Fix (TyBaseF BUnit)
|
||||
pattern TyUnit = Fix (TyBaseF BUnit)
|
||||
|
||||
pattern TyInt :: Type
|
||||
pattern TyInt = Fix (TyBaseF BInt)
|
||||
pattern TyInt = Fix (TyBaseF BInt)
|
||||
|
||||
pattern TyString :: Type
|
||||
pattern TyString = Fix (TyBaseF BString)
|
||||
|
||||
pattern TyDir :: Type
|
||||
pattern TyDir = Fix (TyBaseF BDir)
|
||||
pattern TyDir = Fix (TyBaseF BDir)
|
||||
|
||||
pattern TyBool :: Type
|
||||
pattern TyBool = Fix (TyBaseF BBool)
|
||||
pattern TyBool = Fix (TyBaseF BBool)
|
||||
|
||||
infixl 6 :*:
|
||||
|
||||
@ -292,19 +317,19 @@ pattern UTyVar :: Var -> UType
|
||||
pattern UTyVar v = UTerm (TyVarF v)
|
||||
|
||||
pattern UTyUnit :: UType
|
||||
pattern UTyUnit = UTerm (TyBaseF BUnit)
|
||||
pattern UTyUnit = UTerm (TyBaseF BUnit)
|
||||
|
||||
pattern UTyInt :: UType
|
||||
pattern UTyInt = UTerm (TyBaseF BInt)
|
||||
pattern UTyInt = UTerm (TyBaseF BInt)
|
||||
|
||||
pattern UTyString :: UType
|
||||
pattern UTyString = UTerm (TyBaseF BString)
|
||||
|
||||
pattern UTyDir :: UType
|
||||
pattern UTyDir = UTerm (TyBaseF BDir)
|
||||
pattern UTyDir = UTerm (TyBaseF BDir)
|
||||
|
||||
pattern UTyBool :: UType
|
||||
pattern UTyBool = UTerm (TyBaseF BBool)
|
||||
pattern UTyBool = UTerm (TyBaseF BBool)
|
||||
|
||||
pattern UTyProd :: UType -> UType -> UType
|
||||
pattern UTyProd ty1 ty2 = UTerm (TyProdF ty1 ty2)
|
||||
|
@ -1,4 +1,9 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.TUI.Attr
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -8,84 +13,90 @@
|
||||
--
|
||||
-- Rendering attributes (/i.e./ foreground and background colors,
|
||||
-- styles, /etc./) used by the Swarm TUI.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Swarm.TUI.Attr where
|
||||
|
||||
import Brick
|
||||
import Brick.Forms
|
||||
import Brick.Widgets.List
|
||||
import qualified Graphics.Vty as V
|
||||
import Brick
|
||||
import Brick.Forms
|
||||
import Brick.Widgets.List
|
||||
import qualified Graphics.Vty as V
|
||||
|
||||
import Data.Yaml
|
||||
import Witch (from)
|
||||
import Data.Yaml
|
||||
import Witch (from)
|
||||
|
||||
-- | A mapping from the defined attribute names to TUI attributes.
|
||||
swarmAttrMap :: AttrMap
|
||||
swarmAttrMap = attrMap V.defAttr
|
||||
|
||||
-- World rendering attributes
|
||||
[ (robotAttr, fg V.white `V.withStyle` V.bold)
|
||||
, (entityAttr, fg V.white)
|
||||
, (plantAttr, fg V.green)
|
||||
, (rockAttr, fg (V.rgbColor @Int 80 80 80))
|
||||
, (woodAttr, fg (V.rgbColor @Int 139 69 19))
|
||||
, (flowerAttr, fg (V.rgbColor @Int 200 0 200))
|
||||
, (copperAttr, fg V.yellow)
|
||||
, (snowAttr, fg V.white)
|
||||
, (fireAttr, fg V.red `V.withStyle` V.bold)
|
||||
, (deviceAttr, fg V.yellow `V.withStyle` V.bold)
|
||||
|
||||
-- Terrain attributes
|
||||
, (dirtAttr, fg (V.rgbColor @Int 165 42 42))
|
||||
, (grassAttr, fg (V.rgbColor @Int 0 32 0)) -- dark green
|
||||
, (stoneAttr, fg (V.rgbColor @Int 32 32 32))
|
||||
, (waterAttr, V.white `on` V.blue)
|
||||
, (iceAttr, bg V.white)
|
||||
|
||||
-- UI rendering attributes
|
||||
, (highlightAttr, fg V.cyan)
|
||||
, (invalidFormInputAttr, fg V.red)
|
||||
, (focusedFormInputAttr, V.defAttr)
|
||||
|
||||
, (listSelectedFocusedAttr, bg V.blue)
|
||||
, (infoAttr, fg (V.rgbColor @Int 50 50 50))
|
||||
|
||||
-- Default attribute
|
||||
, (defAttr, V.defAttr)
|
||||
]
|
||||
swarmAttrMap =
|
||||
attrMap
|
||||
V.defAttr
|
||||
-- World rendering attributes
|
||||
[ (robotAttr, fg V.white `V.withStyle` V.bold)
|
||||
, (entityAttr, fg V.white)
|
||||
, (plantAttr, fg V.green)
|
||||
, (rockAttr, fg (V.rgbColor @Int 80 80 80))
|
||||
, (woodAttr, fg (V.rgbColor @Int 139 69 19))
|
||||
, (flowerAttr, fg (V.rgbColor @Int 200 0 200))
|
||||
, (copperAttr, fg V.yellow)
|
||||
, (snowAttr, fg V.white)
|
||||
, (fireAttr, fg V.red `V.withStyle` V.bold)
|
||||
, (deviceAttr, fg V.yellow `V.withStyle` V.bold)
|
||||
, -- Terrain attributes
|
||||
(dirtAttr, fg (V.rgbColor @Int 165 42 42))
|
||||
, (grassAttr, fg (V.rgbColor @Int 0 32 0)) -- dark green
|
||||
, (stoneAttr, fg (V.rgbColor @Int 32 32 32))
|
||||
, (waterAttr, V.white `on` V.blue)
|
||||
, (iceAttr, bg V.white)
|
||||
, -- UI rendering attributes
|
||||
(highlightAttr, fg V.cyan)
|
||||
, (invalidFormInputAttr, fg V.red)
|
||||
, (focusedFormInputAttr, V.defAttr)
|
||||
, (listSelectedFocusedAttr, bg V.blue)
|
||||
, (infoAttr, fg (V.rgbColor @Int 50 50 50))
|
||||
, -- Default attribute
|
||||
(defAttr, V.defAttr)
|
||||
]
|
||||
|
||||
-- | Some defined attribute names used in the Swarm TUI.
|
||||
robotAttr, entityAttr, plantAttr, flowerAttr, copperAttr, snowAttr, rockAttr, baseAttr,
|
||||
fireAttr, woodAttr, deviceAttr,
|
||||
dirtAttr, grassAttr, stoneAttr, waterAttr, iceAttr,
|
||||
highlightAttr, sepAttr, infoAttr, defAttr :: AttrName
|
||||
dirtAttr = "dirt"
|
||||
grassAttr = "grass"
|
||||
stoneAttr = "stone"
|
||||
waterAttr = "water"
|
||||
iceAttr = "ice"
|
||||
robotAttr = "robot"
|
||||
entityAttr = "entity"
|
||||
plantAttr = "plant"
|
||||
flowerAttr = "flower"
|
||||
copperAttr = "copper"
|
||||
snowAttr = "snow"
|
||||
fireAttr = "fire"
|
||||
rockAttr = "rock"
|
||||
woodAttr = "wood"
|
||||
baseAttr = "base"
|
||||
deviceAttr = "device"
|
||||
robotAttr
|
||||
, entityAttr
|
||||
, plantAttr
|
||||
, flowerAttr
|
||||
, copperAttr
|
||||
, snowAttr
|
||||
, rockAttr
|
||||
, baseAttr
|
||||
, fireAttr
|
||||
, woodAttr
|
||||
, deviceAttr
|
||||
, dirtAttr
|
||||
, grassAttr
|
||||
, stoneAttr
|
||||
, waterAttr
|
||||
, iceAttr
|
||||
, highlightAttr
|
||||
, sepAttr
|
||||
, infoAttr
|
||||
, defAttr ::
|
||||
AttrName
|
||||
dirtAttr = "dirt"
|
||||
grassAttr = "grass"
|
||||
stoneAttr = "stone"
|
||||
waterAttr = "water"
|
||||
iceAttr = "ice"
|
||||
robotAttr = "robot"
|
||||
entityAttr = "entity"
|
||||
plantAttr = "plant"
|
||||
flowerAttr = "flower"
|
||||
copperAttr = "copper"
|
||||
snowAttr = "snow"
|
||||
fireAttr = "fire"
|
||||
rockAttr = "rock"
|
||||
woodAttr = "wood"
|
||||
baseAttr = "base"
|
||||
deviceAttr = "device"
|
||||
highlightAttr = "highlight"
|
||||
sepAttr = "sep"
|
||||
infoAttr = "info"
|
||||
defAttr = "def"
|
||||
sepAttr = "sep"
|
||||
infoAttr = "info"
|
||||
defAttr = "def"
|
||||
|
||||
instance ToJSON AttrName where
|
||||
toJSON = toJSON . head . attrNameComponents
|
||||
|
@ -1,4 +1,7 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.TUI.Border
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -8,35 +11,36 @@
|
||||
--
|
||||
-- Special border drawing functions that can include labels in more
|
||||
-- places than just the top center.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.TUI.Border (
|
||||
-- * Horizontal border labels
|
||||
HBorderLabels,
|
||||
plainHBorder,
|
||||
leftLabel,
|
||||
centerLabel,
|
||||
rightLabel,
|
||||
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
-- * Rectangular border labels
|
||||
BorderLabels,
|
||||
plainBorder,
|
||||
topLabels,
|
||||
bottomLabels,
|
||||
|
||||
module Swarm.TUI.Border
|
||||
( -- * Horizontal border labels
|
||||
HBorderLabels, plainHBorder, leftLabel, centerLabel, rightLabel
|
||||
-- * Border-drawing functions
|
||||
hBorderWithLabels,
|
||||
borderWithLabels,
|
||||
) where
|
||||
|
||||
-- * Rectangular border labels
|
||||
, BorderLabels, plainBorder, topLabels, bottomLabels
|
||||
|
||||
-- * Border-drawing functions
|
||||
, hBorderWithLabels
|
||||
, borderWithLabels
|
||||
)
|
||||
where
|
||||
|
||||
import Brick
|
||||
import Brick.Widgets.Border
|
||||
import Control.Lens (makeLenses, to, (^.))
|
||||
import qualified Graphics.Vty as V
|
||||
import Brick
|
||||
import Brick.Widgets.Border
|
||||
import Control.Lens (makeLenses, to, (^.))
|
||||
import qualified Graphics.Vty as V
|
||||
|
||||
-- | Labels for a horizontal border, with optional left, middle, and
|
||||
-- right labels.
|
||||
data HBorderLabels n = HBorderLabels
|
||||
{ _leftLabel :: Maybe (Widget n)
|
||||
{ _leftLabel :: Maybe (Widget n)
|
||||
, _centerLabel :: Maybe (Widget n)
|
||||
, _rightLabel :: Maybe (Widget n)
|
||||
, _rightLabel :: Maybe (Widget n)
|
||||
}
|
||||
|
||||
-- | A plain horizontal border with no labels.
|
||||
@ -46,7 +50,7 @@ plainHBorder = HBorderLabels Nothing Nothing Nothing
|
||||
-- | Labels for a rectangular border, with optional left, middle, and
|
||||
-- right labels on the top and bottom.
|
||||
data BorderLabels n = BorderLabels
|
||||
{ _topLabels :: HBorderLabels n
|
||||
{ _topLabels :: HBorderLabels n
|
||||
, _bottomLabels :: HBorderLabels n
|
||||
}
|
||||
|
||||
@ -64,8 +68,8 @@ makeLenses ''BorderLabels
|
||||
-- always be centered in the border overall, regardless of the width
|
||||
-- of the left and right labels. This ensures that when the labels
|
||||
-- change width, they do not cause the other labels to wiggle.
|
||||
hBorderWithLabels
|
||||
:: HBorderLabels n -> Widget n
|
||||
hBorderWithLabels ::
|
||||
HBorderLabels n -> Widget n
|
||||
hBorderWithLabels (HBorderLabels l c r) =
|
||||
Widget Greedy Fixed $ do
|
||||
let renderLabel = render . maybe emptyWidget (vLimit 1)
|
||||
@ -82,47 +86,49 @@ hBorderWithLabels (HBorderLabels l c r) =
|
||||
cw = V.imageWidth (image rc)
|
||||
|
||||
-- Now render the border with labels.
|
||||
render $ hBox
|
||||
[ hLimit 2 hBorder
|
||||
, Widget Fixed Fixed (return rl)
|
||||
|
||||
-- We calculate the specific width of border between the left
|
||||
-- and center labels needed to ensure that the center label is
|
||||
-- in the right place. Note, using (cw + 1) `div` 2, as
|
||||
-- opposed to cw `div` 2, means that the placement of the
|
||||
-- center label will be left-biased: if it does not fit
|
||||
-- exactly at the center it will be placed just to the left of
|
||||
-- center.
|
||||
, hLimit (w `div` 2 - 2 - lw - (cw + 1) `div` 2) hBorder
|
||||
, Widget Fixed Fixed (return rc)
|
||||
|
||||
-- The border between center and right greedily fills up any
|
||||
-- remaining width.
|
||||
, hBorder
|
||||
, Widget Fixed Fixed (return rr)
|
||||
, hLimit 2 hBorder
|
||||
]
|
||||
render $
|
||||
hBox
|
||||
[ hLimit 2 hBorder
|
||||
, Widget Fixed Fixed (return rl)
|
||||
, -- We calculate the specific width of border between the left
|
||||
-- and center labels needed to ensure that the center label is
|
||||
-- in the right place. Note, using (cw + 1) `div` 2, as
|
||||
-- opposed to cw `div` 2, means that the placement of the
|
||||
-- center label will be left-biased: if it does not fit
|
||||
-- exactly at the center it will be placed just to the left of
|
||||
-- center.
|
||||
hLimit (w `div` 2 - 2 - lw - (cw + 1) `div` 2) hBorder
|
||||
, Widget Fixed Fixed (return rc)
|
||||
, -- The border between center and right greedily fills up any
|
||||
-- remaining width.
|
||||
hBorder
|
||||
, Widget Fixed Fixed (return rr)
|
||||
, hLimit 2 hBorder
|
||||
]
|
||||
|
||||
-- | Put a rectangular border around the specified widget with the
|
||||
-- specified label widgets placed around the border.
|
||||
borderWithLabels :: BorderLabels n -> Widget n -> Widget n
|
||||
borderWithLabels labels wrapped =
|
||||
Widget (hSize wrapped) (vSize wrapped) $ do
|
||||
c <- getContext
|
||||
Widget (hSize wrapped) (vSize wrapped) $ do
|
||||
c <- getContext
|
||||
|
||||
middleResult <- render $ hLimit (c^.availWidthL - 2)
|
||||
$ vLimit (c^.availHeightL - 2)
|
||||
$ wrapped
|
||||
middleResult <-
|
||||
render $
|
||||
hLimit (c ^. availWidthL - 2) $
|
||||
vLimit (c ^. availHeightL - 2) $
|
||||
wrapped
|
||||
|
||||
let tl = joinableBorder (Edges False True False True)
|
||||
tr = joinableBorder (Edges False True True False)
|
||||
bl = joinableBorder (Edges True False False True)
|
||||
br = joinableBorder (Edges True False True False)
|
||||
top = tl <+> hBorderWithLabels (labels ^. topLabels) <+> tr
|
||||
bottom = bl <+> hBorderWithLabels (labels ^. bottomLabels) <+> br
|
||||
middle = vBorder <+> Widget Fixed Fixed (return middleResult) <+> vBorder
|
||||
total = top <=> middle <=> bottom
|
||||
let tl = joinableBorder (Edges False True False True)
|
||||
tr = joinableBorder (Edges False True True False)
|
||||
bl = joinableBorder (Edges True False False True)
|
||||
br = joinableBorder (Edges True False True False)
|
||||
top = tl <+> hBorderWithLabels (labels ^. topLabels) <+> tr
|
||||
bottom = bl <+> hBorderWithLabels (labels ^. bottomLabels) <+> br
|
||||
middle = vBorder <+> Widget Fixed Fixed (return middleResult) <+> vBorder
|
||||
total = top <=> middle <=> bottom
|
||||
|
||||
render $ hLimit (middleResult^.imageL.to V.imageWidth + 2)
|
||||
$ vLimit (middleResult^.imageL.to V.imageHeight + 2)
|
||||
$ total
|
||||
render $
|
||||
hLimit (middleResult ^. imageL . to V.imageWidth + 2) $
|
||||
vLimit (middleResult ^. imageL . to V.imageHeight + 2) $
|
||||
total
|
||||
|
@ -1,4 +1,13 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.TUI.Controller
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -7,120 +16,108 @@
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
--
|
||||
-- Event handlers for the TUI.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.TUI.Controller (
|
||||
-- * Event handling
|
||||
handleEvent,
|
||||
shutdown,
|
||||
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
-- ** Handling 'Frame' events
|
||||
runFrameUI,
|
||||
runFrame,
|
||||
runFrameTicks,
|
||||
runGameTickUI,
|
||||
runGameTick,
|
||||
updateUI,
|
||||
|
||||
module Swarm.TUI.Controller
|
||||
( -- * Event handling
|
||||
-- ** REPL panel
|
||||
handleREPLEvent,
|
||||
validateREPLForm,
|
||||
adjReplHistIndex,
|
||||
|
||||
handleEvent
|
||||
, shutdown
|
||||
-- ** World panel
|
||||
handleWorldEvent,
|
||||
keyToDir,
|
||||
scrollView,
|
||||
adjustTPS,
|
||||
|
||||
-- ** Handling 'Frame' events
|
||||
-- ** Info panel
|
||||
handleInfoPanelEvent,
|
||||
) where
|
||||
|
||||
, runFrameUI, runFrame, runFrameTicks
|
||||
, runGameTickUI, runGameTick
|
||||
, updateUI
|
||||
import Control.Lens
|
||||
import Control.Lens.Extras (is)
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.State
|
||||
import Data.Bits
|
||||
import Data.Either (isRight)
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (isJust)
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Text as T
|
||||
import Linear
|
||||
import System.Clock
|
||||
import Witch (into)
|
||||
|
||||
-- ** REPL panel
|
||||
import Brick hiding (Direction)
|
||||
import Brick.Focus
|
||||
import Brick.Forms
|
||||
import qualified Brick.Widgets.List as BL
|
||||
import qualified Graphics.Vty as V
|
||||
|
||||
, handleREPLEvent, validateREPLForm, adjReplHistIndex
|
||||
|
||||
-- ** World panel
|
||||
|
||||
, handleWorldEvent
|
||||
, keyToDir, scrollView
|
||||
, adjustTPS
|
||||
|
||||
-- ** Info panel
|
||||
|
||||
, handleInfoPanelEvent
|
||||
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens
|
||||
import Control.Lens.Extras (is)
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.State
|
||||
import Data.Bits
|
||||
import Data.Either (isRight)
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (isJust)
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Text as T
|
||||
import Linear
|
||||
import System.Clock
|
||||
import Witch (into)
|
||||
|
||||
import Brick hiding (Direction)
|
||||
import Brick.Focus
|
||||
import Brick.Forms
|
||||
import qualified Brick.Widgets.List as BL
|
||||
import qualified Graphics.Vty as V
|
||||
|
||||
import Swarm.Game.CEK (idleMachine, initMachine)
|
||||
import Swarm.Game.Entity hiding (empty)
|
||||
import Swarm.Game.Robot
|
||||
import Swarm.Game.State
|
||||
import Swarm.Game.Step (gameTick)
|
||||
import Swarm.Game.Value (Value (VUnit), prettyValue)
|
||||
import qualified Swarm.Game.World as W
|
||||
import Swarm.Language.Capability
|
||||
import Swarm.Language.Context
|
||||
import Swarm.Language.Pipeline
|
||||
import Swarm.Language.Pretty
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Language.Types
|
||||
import Swarm.TUI.List
|
||||
import Swarm.TUI.Model
|
||||
import Swarm.Util
|
||||
import Swarm.Game.CEK (idleMachine, initMachine)
|
||||
import Swarm.Game.Entity hiding (empty)
|
||||
import Swarm.Game.Robot
|
||||
import Swarm.Game.State
|
||||
import Swarm.Game.Step (gameTick)
|
||||
import Swarm.Game.Value (Value (VUnit), prettyValue)
|
||||
import qualified Swarm.Game.World as W
|
||||
import Swarm.Language.Capability
|
||||
import Swarm.Language.Context
|
||||
import Swarm.Language.Pipeline
|
||||
import Swarm.Language.Pretty
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Language.Types
|
||||
import Swarm.TUI.List
|
||||
import Swarm.TUI.Model
|
||||
import Swarm.Util
|
||||
|
||||
-- | Pattern synonyms to simplify brick event handler
|
||||
pattern ControlKey, MetaKey :: Char -> BrickEvent n e
|
||||
pattern ControlKey c = VtyEvent (V.EvKey (V.KChar c) [V.MCtrl])
|
||||
pattern MetaKey c = VtyEvent (V.EvKey (V.KChar c) [V.MMeta])
|
||||
pattern MetaKey c = VtyEvent (V.EvKey (V.KChar c) [V.MMeta])
|
||||
|
||||
pattern FKey :: Int -> BrickEvent n e
|
||||
pattern FKey c = VtyEvent (V.EvKey (V.KFun c) [])
|
||||
pattern FKey c = VtyEvent (V.EvKey (V.KFun c) [])
|
||||
|
||||
-- | The top-level event handler for the TUI.
|
||||
handleEvent :: AppState -> BrickEvent Name AppEvent -> EventM Name (Next AppState)
|
||||
handleEvent s (AppEvent Frame)
|
||||
| s ^. gameState . paused = continueWithoutRedraw s
|
||||
| otherwise = runFrameUI s
|
||||
|
||||
handleEvent s (VtyEvent (V.EvResize _ _)) = do
|
||||
| otherwise = runFrameUI s
|
||||
handleEvent s (VtyEvent (V.EvResize _ _)) = do
|
||||
invalidateCacheEntry WorldCache
|
||||
continue s
|
||||
handleEvent s (VtyEvent (V.EvKey (V.KChar '\t') [])) = continue $ s & uiState . uiFocusRing %~ focusNext
|
||||
handleEvent s (VtyEvent (V.EvKey V.KBackTab [])) = continue $ s & uiState . uiFocusRing %~ focusPrev
|
||||
handleEvent s (VtyEvent (V.EvKey V.KBackTab [])) = continue $ s & uiState . uiFocusRing %~ focusPrev
|
||||
handleEvent s (VtyEvent (V.EvKey V.KEsc []))
|
||||
| isJust (s ^. uiState . uiError) = continue $ s & uiState . uiError .~ Nothing
|
||||
handleEvent s ev = do
|
||||
-- intercept special keys that works on all panels
|
||||
case ev of
|
||||
ControlKey 'q' -> shutdown s
|
||||
MetaKey 'w' -> setFocus s WorldPanel
|
||||
MetaKey 'e' -> setFocus s InfoPanel
|
||||
MetaKey 'r' -> setFocus s REPLPanel
|
||||
FKey 1 -> toggleModal s HelpModal
|
||||
_anyOtherEvent | isJust (s ^. uiState . uiModal) -> continueWithoutRedraw s
|
||||
| otherwise ->
|
||||
-- and dispatch the other to the focused panel handler
|
||||
case focusGetCurrent (s ^. uiState . uiFocusRing) of
|
||||
Just REPLPanel -> handleREPLEvent s ev
|
||||
Just WorldPanel -> handleWorldEvent s ev
|
||||
Just InfoPanel -> handleInfoPanelEvent s ev
|
||||
_ -> continueWithoutRedraw s
|
||||
ControlKey 'q' -> shutdown s
|
||||
MetaKey 'w' -> setFocus s WorldPanel
|
||||
MetaKey 'e' -> setFocus s InfoPanel
|
||||
MetaKey 'r' -> setFocus s REPLPanel
|
||||
FKey 1 -> toggleModal s HelpModal
|
||||
_anyOtherEvent
|
||||
| isJust (s ^. uiState . uiModal) -> continueWithoutRedraw s
|
||||
| otherwise ->
|
||||
-- and dispatch the other to the focused panel handler
|
||||
case focusGetCurrent (s ^. uiState . uiFocusRing) of
|
||||
Just REPLPanel -> handleREPLEvent s ev
|
||||
Just WorldPanel -> handleWorldEvent s ev
|
||||
Just InfoPanel -> handleInfoPanelEvent s ev
|
||||
_ -> continueWithoutRedraw s
|
||||
|
||||
setFocus :: AppState -> Name -> EventM Name (Next AppState)
|
||||
setFocus s name = continue $ s & uiState . uiFocusRing %~ focusSetCurrent name
|
||||
@ -128,39 +125,39 @@ setFocus s name = continue $ s & uiState . uiFocusRing %~ focusSetCurrent name
|
||||
toggleModal :: AppState -> Modal -> EventM Name (Next AppState)
|
||||
toggleModal s modal = do
|
||||
curTime <- liftIO $ getTime Monotonic
|
||||
continue $ s & case s ^. uiState . uiModal of
|
||||
Nothing -> (uiState . uiModal ?~ modal) . ensurePause
|
||||
Just _ -> (uiState . uiModal .~ Nothing) . maybeUnpause . resetLastFrameTime curTime
|
||||
where
|
||||
-- Set the game to AutoPause if needed
|
||||
ensurePause
|
||||
| s ^. gameState . paused = id
|
||||
| otherwise = gameState . runStatus .~ AutoPause
|
||||
-- Set the game to Running if it was auto paused
|
||||
maybeUnpause
|
||||
| s ^. gameState . runStatus == AutoPause = gameState . runStatus .~ Running
|
||||
| otherwise = id
|
||||
-- When unpausing, it is critical to ensure the next frame doesn't
|
||||
-- catch up from the time spent in pause.
|
||||
-- TODO: manage unpause more safely to also cover
|
||||
-- the world event handler for the KChar 'p'.
|
||||
resetLastFrameTime curTime = uiState . lastFrameTime .~ curTime
|
||||
continue $
|
||||
s & case s ^. uiState . uiModal of
|
||||
Nothing -> (uiState . uiModal ?~ modal) . ensurePause
|
||||
Just _ -> (uiState . uiModal .~ Nothing) . maybeUnpause . resetLastFrameTime curTime
|
||||
where
|
||||
-- Set the game to AutoPause if needed
|
||||
ensurePause
|
||||
| s ^. gameState . paused = id
|
||||
| otherwise = gameState . runStatus .~ AutoPause
|
||||
-- Set the game to Running if it was auto paused
|
||||
maybeUnpause
|
||||
| s ^. gameState . runStatus == AutoPause = gameState . runStatus .~ Running
|
||||
| otherwise = id
|
||||
-- When unpausing, it is critical to ensure the next frame doesn't
|
||||
-- catch up from the time spent in pause.
|
||||
-- TODO: manage unpause more safely to also cover
|
||||
-- the world event handler for the KChar 'p'.
|
||||
resetLastFrameTime curTime = uiState . lastFrameTime .~ curTime
|
||||
|
||||
-- | Shut down the application. Currently all it does is write out
|
||||
-- the updated REPL history to a @.swarm_history@ file.
|
||||
shutdown :: AppState -> EventM Name (Next AppState)
|
||||
shutdown s = do
|
||||
let s' = s & uiState . uiReplHistory . traverse %~ markOld
|
||||
let s' = s & uiState . uiReplHistory . traverse %~ markOld
|
||||
hist = filter isEntry (s' ^. uiState . uiReplHistory)
|
||||
liftIO $ writeFile ".swarm_history" (show hist)
|
||||
halt s'
|
||||
where
|
||||
markOld (REPLEntry _ e) = REPLEntry False e
|
||||
markOld r = r
|
||||
|
||||
where
|
||||
markOld (REPLEntry _ e) = REPLEntry False e
|
||||
markOld r = r
|
||||
|
||||
isEntry REPLEntry{} = True
|
||||
isEntry _ = False
|
||||
isEntry REPLEntry {} = True
|
||||
isEntry _ = False
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Handling Frame events
|
||||
@ -207,10 +204,10 @@ runFrame = do
|
||||
-- Figure out how many ticks per second we're supposed to do,
|
||||
-- and compute the timestep `dt` for a single tick.
|
||||
lgTPS <- use (uiState . lgTicksPerSecond)
|
||||
let oneSecond = 1_000_000_000 -- one second = 10^9 nanoseconds
|
||||
let oneSecond = 1_000_000_000 -- one second = 10^9 nanoseconds
|
||||
dt
|
||||
| lgTPS >= 0 = oneSecond `div` (1 `shiftL` lgTPS)
|
||||
| otherwise = oneSecond * (1 `shiftL` abs lgTPS)
|
||||
| otherwise = oneSecond * (1 `shiftL` abs lgTPS)
|
||||
|
||||
-- Update TPS/FPS counters every second
|
||||
infoUpdateTime <- use (uiState . lastInfoTime)
|
||||
@ -248,7 +245,6 @@ runFrameTicks dt = do
|
||||
|
||||
-- Is there still time left?
|
||||
when (a >= dt) $ do
|
||||
|
||||
-- If so, do a tick, count it, subtract dt from the accumulated time,
|
||||
-- and loop!
|
||||
runGameTick
|
||||
@ -271,7 +267,6 @@ runGameTick = zoom gameState gameTick
|
||||
-- game for some number of ticks.
|
||||
updateUI :: StateT AppState (EventM Name) Bool
|
||||
updateUI = do
|
||||
|
||||
loadVisibleRegion
|
||||
|
||||
-- If the game state indicates a redraw is needed, invalidate the
|
||||
@ -280,12 +275,12 @@ updateUI = do
|
||||
when (g ^. needsRedraw) $ lift (invalidateCacheEntry WorldCache)
|
||||
|
||||
-- Check if the inventory list needs to be updated.
|
||||
listRobotHash <- fmap fst <$> use (uiState . uiInventory)
|
||||
-- The hash of the robot whose inventory is currently displayed (if any)
|
||||
listRobotHash <- fmap fst <$> use (uiState . uiInventory)
|
||||
-- The hash of the robot whose inventory is currently displayed (if any)
|
||||
|
||||
fr <- use (gameState . to focusedRobot)
|
||||
let focusedRobotHash = view inventoryHash <$> fr
|
||||
-- The hash of the focused robot (if any)
|
||||
-- The hash of the focused robot (if any)
|
||||
|
||||
-- If the hashes don't match (either because which robot (or
|
||||
-- whether any robot) is focused changed, or the focused robot's
|
||||
@ -299,7 +294,6 @@ updateUI = do
|
||||
|
||||
-- Now check if the base finished running a program entered at the REPL.
|
||||
replUpdated <- case g ^. replStatus of
|
||||
|
||||
-- It did, and the result was the unit value. Just reset replStatus.
|
||||
REPLWorking _ (Just VUnit) -> do
|
||||
gameState . replStatus .= REPLDone
|
||||
@ -325,14 +319,14 @@ loadVisibleRegion :: StateT AppState (EventM Name) ()
|
||||
loadVisibleRegion = do
|
||||
mext <- lift $ lookupExtent WorldExtent
|
||||
case mext of
|
||||
Nothing -> return ()
|
||||
Nothing -> return ()
|
||||
Just (Extent _ _ size) -> do
|
||||
gs <- use gameState
|
||||
gameState . world %= W.loadRegion (viewingRegion gs (over both fromIntegral size))
|
||||
|
||||
stripCmd :: Polytype -> Polytype
|
||||
stripCmd (Forall xs (TyCmd ty)) = Forall xs ty
|
||||
stripCmd pty = pty
|
||||
stripCmd pty = pty
|
||||
|
||||
------------------------------------------------------------
|
||||
-- REPL events
|
||||
@ -340,34 +334,36 @@ stripCmd pty = pty
|
||||
|
||||
-- | Handle a user input event for the REPL.
|
||||
handleREPLEvent :: AppState -> BrickEvent Name AppEvent -> EventM Name (Next AppState)
|
||||
handleREPLEvent s (VtyEvent (V.EvKey (V.KChar 'c') [V.MCtrl]))
|
||||
= continue $ s
|
||||
handleREPLEvent s (VtyEvent (V.EvKey (V.KChar 'c') [V.MCtrl])) =
|
||||
continue $
|
||||
s
|
||||
& gameState . robotMap . ix "base" . machine .~ idleMachine
|
||||
handleREPLEvent s (VtyEvent (V.EvKey V.KEnter []))
|
||||
= case processTerm' topCtx topCapCtx entry of
|
||||
Right t@(ProcessedTerm _ (Module ty _) _ _) ->
|
||||
continue $ s
|
||||
& uiState . uiReplForm %~ updateFormState ""
|
||||
& uiState . uiReplType .~ Nothing
|
||||
handleREPLEvent s (VtyEvent (V.EvKey V.KEnter [])) =
|
||||
case processTerm' topCtx topCapCtx entry of
|
||||
Right t@(ProcessedTerm _ (Module ty _) _ _) ->
|
||||
continue $
|
||||
s
|
||||
& uiState . uiReplForm %~ updateFormState ""
|
||||
& uiState . uiReplType .~ Nothing
|
||||
& uiState . uiReplHistory %~ (REPLEntry True entry :)
|
||||
& uiState . uiReplHistIdx .~ (-1)
|
||||
& gameState . replStatus .~ REPLWorking ty Nothing
|
||||
& gameState . robotMap . ix "base" . machine .~ initMachine t topEnv
|
||||
Left err ->
|
||||
continue $ s
|
||||
Left err ->
|
||||
continue $
|
||||
s
|
||||
& uiState . uiError ?~ txt err
|
||||
where
|
||||
-- XXX check that we have the capabilities needed to run the
|
||||
-- program before even starting?
|
||||
|
||||
-- XXX check that we have the capabilities needed to run the
|
||||
-- program before even starting?
|
||||
where
|
||||
entry = formState (s ^. uiState . uiReplForm)
|
||||
(topCtx, topCapCtx) = s ^. gameState . robotMap . ix "base" . robotCtx
|
||||
topEnv = s ^. gameState . robotMap . ix "base" . robotEnv
|
||||
|
||||
handleREPLEvent s (VtyEvent (V.EvKey V.KUp []))
|
||||
= continue $ s & adjReplHistIndex (+)
|
||||
handleREPLEvent s (VtyEvent (V.EvKey V.KDown []))
|
||||
= continue $ s & adjReplHistIndex (-)
|
||||
entry = formState (s ^. uiState . uiReplForm)
|
||||
(topCtx, topCapCtx) = s ^. gameState . robotMap . ix "base" . robotCtx
|
||||
topEnv = s ^. gameState . robotMap . ix "base" . robotEnv
|
||||
handleREPLEvent s (VtyEvent (V.EvKey V.KUp [])) =
|
||||
continue $ s & adjReplHistIndex (+)
|
||||
handleREPLEvent s (VtyEvent (V.EvKey V.KDown [])) =
|
||||
continue $ s & adjReplHistIndex (-)
|
||||
handleREPLEvent s ev = do
|
||||
f' <- handleFormEvent ev (s ^. uiState . uiReplForm)
|
||||
continue $ validateREPLForm (s & uiState . uiReplForm .~ f')
|
||||
@ -375,16 +371,17 @@ handleREPLEvent s ev = do
|
||||
-- | Validate the REPL input when it changes: see if it parses and
|
||||
-- typechecks, and set the color accordingly.
|
||||
validateREPLForm :: AppState -> AppState
|
||||
validateREPLForm s = s
|
||||
& uiState . uiReplForm %~ validate
|
||||
& uiState . uiReplType .~ theType
|
||||
where
|
||||
(topCtx, topCapCtx) = s ^. gameState . robotMap . ix "base" . robotCtx
|
||||
result = processTerm' topCtx topCapCtx (s ^. uiState . uiReplForm . to formState)
|
||||
theType = case result of
|
||||
Right (ProcessedTerm _ (Module ty _) _ _) -> Just ty
|
||||
_ -> Nothing
|
||||
validate = setFieldValid (isRight result) REPLInput
|
||||
validateREPLForm s =
|
||||
s
|
||||
& uiState . uiReplForm %~ validate
|
||||
& uiState . uiReplType .~ theType
|
||||
where
|
||||
(topCtx, topCapCtx) = s ^. gameState . robotMap . ix "base" . robotCtx
|
||||
result = processTerm' topCtx topCapCtx (s ^. uiState . uiReplForm . to formState)
|
||||
theType = case result of
|
||||
Right (ProcessedTerm _ (Module ty _) _ _) -> Just ty
|
||||
_ -> Nothing
|
||||
validate = setFieldValid (isRight result) REPLInput
|
||||
|
||||
-- | Update our current position in the REPL history.
|
||||
adjReplHistIndex :: (Int -> Int -> Int) -> AppState -> AppState
|
||||
@ -393,15 +390,15 @@ adjReplHistIndex (+/-) s =
|
||||
& (if curIndex == -1 then saveLastEntry else id)
|
||||
& (if newIndex /= curIndex then uiState . uiReplForm %~ updateFormState newEntry else id)
|
||||
& validateREPLForm
|
||||
where
|
||||
saveLastEntry = uiState . uiReplLast .~ formState (s ^. uiState . uiReplForm)
|
||||
entries = [e | REPLEntry _ e <- s ^. uiState . uiReplHistory]
|
||||
curIndex = s ^. uiState . uiReplHistIdx
|
||||
histLen = length entries
|
||||
newIndex = min (histLen - 1) (max (-1) (curIndex +/- 1))
|
||||
newEntry
|
||||
| newIndex == -1 = s ^. uiState . uiReplLast
|
||||
| otherwise = entries !! newIndex
|
||||
where
|
||||
saveLastEntry = uiState . uiReplLast .~ formState (s ^. uiState . uiReplForm)
|
||||
entries = [e | REPLEntry _ e <- s ^. uiState . uiReplHistory]
|
||||
curIndex = s ^. uiState . uiReplHistIdx
|
||||
histLen = length entries
|
||||
newIndex = min (histLen - 1) (max (-1) (curIndex +/- 1))
|
||||
newEntry
|
||||
| newIndex == -1 = s ^. uiState . uiReplLast
|
||||
| otherwise = entries !! newIndex
|
||||
|
||||
------------------------------------------------------------
|
||||
-- World events
|
||||
@ -412,12 +409,19 @@ worldScrollDist = 8
|
||||
|
||||
-- | Handle a user input event in the world view panel.
|
||||
handleWorldEvent :: AppState -> BrickEvent Name AppEvent -> EventM Name (Next AppState)
|
||||
|
||||
-- scrolling the world view
|
||||
handleWorldEvent s (VtyEvent (V.EvKey k []))
|
||||
| k `elem` [ V.KUp, V.KDown, V.KLeft, V.KRight
|
||||
, V.KChar 'h', V.KChar 'j', V.KChar 'k', V.KChar 'l' ]
|
||||
= scrollView s (^+^ (worldScrollDist *^ keyToDir k)) >>= continue
|
||||
| k
|
||||
`elem` [ V.KUp
|
||||
, V.KDown
|
||||
, V.KLeft
|
||||
, V.KRight
|
||||
, V.KChar 'h'
|
||||
, V.KChar 'j'
|
||||
, V.KChar 'k'
|
||||
, V.KChar 'l'
|
||||
] =
|
||||
scrollView s (^+^ (worldScrollDist *^ keyToDir k)) >>= continue
|
||||
handleWorldEvent s (VtyEvent (V.EvKey (V.KChar 'c') [])) = do
|
||||
invalidateCacheEntry WorldCache
|
||||
continue $ s & gameState . viewCenterRule .~ VCRobot "base"
|
||||
@ -425,37 +429,32 @@ handleWorldEvent s (VtyEvent (V.EvKey (V.KChar 'c') [])) = do
|
||||
-- pausing and stepping
|
||||
handleWorldEvent s (VtyEvent (V.EvKey (V.KChar 'p') [])) = do
|
||||
curTime <- liftIO $ getTime Monotonic
|
||||
continue $ s
|
||||
continue $
|
||||
s
|
||||
& gameState . runStatus %~ (\status -> if status == Running then ManualPause else Running)
|
||||
|
||||
-- Also reset the last frame time to now. If we are pausing, it
|
||||
-- doesn't matter; if we are unpausing, this is critical to
|
||||
-- ensure the next frame doesn't think it has to catch up from
|
||||
-- whenever the game was paused!
|
||||
& uiState . lastFrameTime .~ curTime
|
||||
|
||||
handleWorldEvent s (VtyEvent (V.EvKey (V.KChar 's') []))
|
||||
| s ^. gameState . paused = runGameTickUI s
|
||||
| otherwise = continueWithoutRedraw s
|
||||
|
||||
| otherwise = continueWithoutRedraw s
|
||||
-- speed controls
|
||||
handleWorldEvent s (VtyEvent (V.EvKey (V.KChar '<') []))
|
||||
= continue $ adjustTPS (-) s
|
||||
handleWorldEvent s (VtyEvent (V.EvKey (V.KChar '>') []))
|
||||
= continue $ adjustTPS (+) s
|
||||
handleWorldEvent s (VtyEvent (V.EvKey (V.KChar ',') []))
|
||||
= continue $ adjustTPS (-) s
|
||||
handleWorldEvent s (VtyEvent (V.EvKey (V.KChar '.') []))
|
||||
= continue $ adjustTPS (+) s
|
||||
|
||||
handleWorldEvent s (VtyEvent (V.EvKey (V.KChar '<') [])) =
|
||||
continue $ adjustTPS (-) s
|
||||
handleWorldEvent s (VtyEvent (V.EvKey (V.KChar '>') [])) =
|
||||
continue $ adjustTPS (+) s
|
||||
handleWorldEvent s (VtyEvent (V.EvKey (V.KChar ',') [])) =
|
||||
continue $ adjustTPS (-) s
|
||||
handleWorldEvent s (VtyEvent (V.EvKey (V.KChar '.') [])) =
|
||||
continue $ adjustTPS (+) s
|
||||
-- show fps
|
||||
handleWorldEvent s (VtyEvent (V.EvKey (V.KChar 'f') []))
|
||||
= continue $ (s & uiState . uiShowFPS %~ not)
|
||||
|
||||
handleWorldEvent s (VtyEvent (V.EvKey (V.KChar 'f') [])) =
|
||||
continue $ (s & uiState . uiShowFPS %~ not)
|
||||
-- for testing only: toggle between classic & creative modes
|
||||
handleWorldEvent s (VtyEvent (V.EvKey (V.KChar 'm') []))
|
||||
= continue (s & gameState . gameMode %~ cycleEnum)
|
||||
|
||||
handleWorldEvent s (VtyEvent (V.EvKey (V.KChar 'm') [])) =
|
||||
continue (s & gameState . gameMode %~ cycleEnum)
|
||||
-- Fall-through case: don't do anything.
|
||||
handleWorldEvent s _ = continueWithoutRedraw s
|
||||
|
||||
@ -471,15 +470,15 @@ scrollView s update = do
|
||||
|
||||
-- | Convert a directional key into a direction.
|
||||
keyToDir :: V.Key -> V2 Int64
|
||||
keyToDir V.KUp = north
|
||||
keyToDir V.KDown = south
|
||||
keyToDir V.KRight = east
|
||||
keyToDir V.KLeft = west
|
||||
keyToDir V.KUp = north
|
||||
keyToDir V.KDown = south
|
||||
keyToDir V.KRight = east
|
||||
keyToDir V.KLeft = west
|
||||
keyToDir (V.KChar 'h') = west
|
||||
keyToDir (V.KChar 'j') = south
|
||||
keyToDir (V.KChar 'k') = north
|
||||
keyToDir (V.KChar 'l') = east
|
||||
keyToDir _ = V2 0 0
|
||||
keyToDir _ = V2 0 0
|
||||
|
||||
-- | Adjust the ticks per second speed.
|
||||
adjustTPS :: (Int -> Int -> Int) -> AppState -> AppState
|
||||
@ -498,20 +497,21 @@ handleInfoPanelEvent s (VtyEvent (V.EvKey V.KEnter [])) = do
|
||||
Just (_, Separator _) -> continueWithoutRedraw s
|
||||
Just (_, InventoryEntry _ e) -> do
|
||||
let topEnv = s ^. gameState . robotMap . ix "base" . robotEnv
|
||||
mkTy = Forall [] $ TyCmd TyUnit
|
||||
mkTy = Forall [] $ TyCmd TyUnit
|
||||
mkProg = TApp (TConst Make) (TString (e ^. entityName))
|
||||
mkPT = ProcessedTerm mkProg (Module mkTy empty) (S.singleton CMake) empty
|
||||
mkPT = ProcessedTerm mkProg (Module mkTy empty) (S.singleton CMake) empty
|
||||
case isActive <$> (s ^. gameState . robotMap . at "base") of
|
||||
Just False -> continue $ s
|
||||
& gameState . replStatus .~ REPLWorking mkTy Nothing
|
||||
& gameState . robotMap . ix "base" . machine .~ initMachine mkPT topEnv
|
||||
_ -> continueWithoutRedraw s
|
||||
|
||||
Just False ->
|
||||
continue $
|
||||
s
|
||||
& gameState . replStatus .~ REPLWorking mkTy Nothing
|
||||
& gameState . robotMap . ix "base" . machine .~ initMachine mkPT topEnv
|
||||
_ -> continueWithoutRedraw s
|
||||
handleInfoPanelEvent s (VtyEvent ev) = do
|
||||
let mList = s ^? uiState . uiInventory . _Just . _2
|
||||
case mList of
|
||||
Nothing -> continueWithoutRedraw s
|
||||
Just l -> do
|
||||
Just l -> do
|
||||
l' <- handleListEventWithSeparators ev (is _Separator) l
|
||||
let s' = s & uiState . uiInventory . _Just . _2 .~ l'
|
||||
continue s'
|
||||
|
@ -1,4 +1,7 @@
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.TUI.List
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -8,52 +11,51 @@
|
||||
--
|
||||
-- A special modified version of 'Brick.Widgets.List.handleListEvent'
|
||||
-- to deal with skipping over separators.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.TUI.List (handleListEventWithSeparators) where
|
||||
|
||||
module Swarm.TUI.List
|
||||
( handleListEventWithSeparators )
|
||||
where
|
||||
import Control.Lens (set, (&), (^.))
|
||||
import Data.Foldable (toList)
|
||||
import Data.List (find)
|
||||
|
||||
import Control.Lens (set, (&), (^.))
|
||||
import Data.Foldable (toList)
|
||||
import Data.List (find)
|
||||
|
||||
import Brick (EventM)
|
||||
import Brick (EventM)
|
||||
import qualified Brick.Widgets.List as BL
|
||||
import qualified Graphics.Vty as V
|
||||
import qualified Graphics.Vty as V
|
||||
|
||||
-- | Handle a list event, taking an extra predicate to identify which
|
||||
-- list elements are separators; separators will be skipped if
|
||||
-- possible.
|
||||
handleListEventWithSeparators
|
||||
:: (Foldable t, BL.Splittable t, Ord n)
|
||||
=> V.Event
|
||||
-> (e -> Bool) -- ^ Is this element a separator?
|
||||
-> BL.GenericList n t e
|
||||
-> EventM n (BL.GenericList n t e)
|
||||
handleListEventWithSeparators ::
|
||||
(Foldable t, BL.Splittable t, Ord n) =>
|
||||
V.Event ->
|
||||
-- | Is this element a separator?
|
||||
(e -> Bool) ->
|
||||
BL.GenericList n t e ->
|
||||
EventM n (BL.GenericList n t e)
|
||||
handleListEventWithSeparators e isSep theList =
|
||||
case e of
|
||||
V.EvKey V.KUp [] -> return $ backward
|
||||
V.EvKey V.KUp [] -> return $ backward
|
||||
V.EvKey (V.KChar 'k') [] -> return $ backward
|
||||
V.EvKey V.KDown [] -> return $ forward
|
||||
V.EvKey V.KDown [] -> return $ forward
|
||||
V.EvKey (V.KChar 'j') [] -> return $ forward
|
||||
V.EvKey V.KHome [] ->
|
||||
return $ listFindByStrategy fwdInclusive isItem
|
||||
$ BL.listMoveToBeginning theList
|
||||
V.EvKey V.KEnd [] ->
|
||||
return $ listFindByStrategy bwdInclusive isItem
|
||||
-- work around https://github.com/jtdaugherty/brick/issues/337 for now
|
||||
$ BL.listMoveTo (max 0 $ length (BL.listElements theList) - 1) theList
|
||||
return $
|
||||
listFindByStrategy fwdInclusive isItem $
|
||||
BL.listMoveToBeginning theList
|
||||
V.EvKey V.KEnd [] ->
|
||||
return $
|
||||
listFindByStrategy bwdInclusive isItem
|
||||
-- work around https://github.com/jtdaugherty/brick/issues/337 for now
|
||||
$
|
||||
BL.listMoveTo (max 0 $ length (BL.listElements theList) - 1) theList
|
||||
V.EvKey V.KPageDown [] ->
|
||||
listFindByStrategy bwdInclusive isItem <$> BL.listMovePageDown theList
|
||||
V.EvKey V.KPageUp [] ->
|
||||
V.EvKey V.KPageUp [] ->
|
||||
listFindByStrategy fwdInclusive isItem <$> BL.listMovePageUp theList
|
||||
_ -> return theList
|
||||
where
|
||||
isItem = not . isSep
|
||||
backward = listFindByStrategy bwdExclusive isItem theList
|
||||
forward = listFindByStrategy fwdExclusive isItem theList
|
||||
_ -> return theList
|
||||
where
|
||||
isItem = not . isSep
|
||||
backward = listFindByStrategy bwdExclusive isItem theList
|
||||
forward = listFindByStrategy fwdExclusive isItem theList
|
||||
|
||||
-- | Which direction to search: forward or backward from the current location.
|
||||
data FindDir = FindFwd | FindBwd deriving (Eq, Ord, Show, Enum)
|
||||
@ -77,35 +79,33 @@ bwdExclusive = FindStrategy FindBwd ExcludeCurrent
|
||||
-- whether to search forward or backward from the selected element,
|
||||
-- and the 'FindStart' says whether the currently selected element
|
||||
-- should be included in the search or not.
|
||||
listFindByStrategy
|
||||
:: (Foldable t, BL.Splittable t)
|
||||
=> FindStrategy
|
||||
-> (e -> Bool)
|
||||
-> BL.GenericList n t e
|
||||
-> BL.GenericList n t e
|
||||
listFindByStrategy ::
|
||||
(Foldable t, BL.Splittable t) =>
|
||||
FindStrategy ->
|
||||
(e -> Bool) ->
|
||||
BL.GenericList n t e ->
|
||||
BL.GenericList n t e
|
||||
listFindByStrategy (FindStrategy dir cur) test l =
|
||||
-- Figure out what index to split on. We will call splitAt on
|
||||
-- (current selected index + adj).
|
||||
let adj
|
||||
-- If we're search forward, split on current index; if
|
||||
-- finding backward, split on current + 1 (so that the
|
||||
-- left-hand split will include the current index).
|
||||
= case dir of { FindFwd -> 0; FindBwd -> 1 }
|
||||
-- Figure out what index to split on. We will call splitAt on
|
||||
-- (current selected index + adj).
|
||||
let adj =
|
||||
-- If we're search forward, split on current index; if
|
||||
-- finding backward, split on current + 1 (so that the
|
||||
-- left-hand split will include the current index).
|
||||
case dir of FindFwd -> 0; FindBwd -> 1
|
||||
-- ... but if we're excluding the current index, swap that, so
|
||||
-- the current index will be excluded rather than included in
|
||||
-- the part of the split we're going to look at.
|
||||
& case cur of IncludeCurrent -> id; ExcludeCurrent -> (1 -)
|
||||
|
||||
-- ... but if we're excluding the current index, swap that, so
|
||||
-- the current index will be excluded rather than included in
|
||||
-- the part of the split we're going to look at.
|
||||
& case cur of { IncludeCurrent -> id; ExcludeCurrent -> (1-) }
|
||||
-- Split at the index we computed.
|
||||
start = maybe 0 (+ adj) (l ^. BL.listSelectedL)
|
||||
(h, t) = BL.splitAt start (l ^. BL.listElementsL)
|
||||
|
||||
-- Split at the index we computed.
|
||||
start = maybe 0 (+adj) (l ^. BL.listSelectedL)
|
||||
(h, t) = BL.splitAt start (l ^. BL.listElementsL)
|
||||
|
||||
-- Now look at either the right-hand split if searching
|
||||
-- forward, or the reversed left-hand split if searching
|
||||
-- backward.
|
||||
headResult = find (test . snd) . reverse . zip [0..] . toList $ h
|
||||
tailResult = find (test . snd) . zip [start..] . toList $ t
|
||||
result = case dir of {FindFwd -> tailResult; FindBwd -> headResult}
|
||||
|
||||
in maybe id (set BL.listSelectedL . Just . fst) result l
|
||||
-- Now look at either the right-hand split if searching
|
||||
-- forward, or the reversed left-hand split if searching
|
||||
-- backward.
|
||||
headResult = find (test . snd) . reverse . zip [0 ..] . toList $ h
|
||||
tailResult = find (test . snd) . zip [start ..] . toList $ t
|
||||
result = case dir of FindFwd -> tailResult; FindBwd -> headResult
|
||||
in maybe id (set BL.listSelectedL . Just . fst) result l
|
||||
|
@ -1,4 +1,11 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.TUI.Model
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -7,75 +14,81 @@
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
--
|
||||
-- Application state for the @brick@-based Swarm TUI.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.TUI.Model (
|
||||
-- * Custom UI label types
|
||||
-- $uilabel
|
||||
AppEvent (..),
|
||||
Name (..),
|
||||
Modal (..),
|
||||
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
-- * UI state
|
||||
REPLHistItem (..),
|
||||
InventoryEntry (..),
|
||||
_Separator,
|
||||
_InventoryEntry,
|
||||
UIState,
|
||||
|
||||
module Swarm.TUI.Model
|
||||
( -- * Custom UI label types
|
||||
-- $uilabel
|
||||
-- ** Fields
|
||||
uiFocusRing,
|
||||
uiReplForm,
|
||||
uiReplType,
|
||||
uiReplHistory,
|
||||
uiReplHistIdx,
|
||||
uiReplLast,
|
||||
uiInventory,
|
||||
uiError,
|
||||
uiModal,
|
||||
lgTicksPerSecond,
|
||||
lastFrameTime,
|
||||
accumulatedTime,
|
||||
tickCount,
|
||||
frameCount,
|
||||
lastInfoTime,
|
||||
uiShowFPS,
|
||||
uiTPF,
|
||||
uiFPS,
|
||||
|
||||
AppEvent(..), Name(..), Modal(..)
|
||||
-- ** Initialization
|
||||
initFocusRing,
|
||||
replPrompt,
|
||||
initReplForm,
|
||||
initLgTicksPerSecond,
|
||||
initUIState,
|
||||
|
||||
-- * UI state
|
||||
-- ** Updating
|
||||
populateInventoryList,
|
||||
|
||||
, REPLHistItem(..)
|
||||
, InventoryEntry(..), _Separator, _InventoryEntry
|
||||
, UIState
|
||||
-- * App state
|
||||
AppState,
|
||||
|
||||
-- ** Fields
|
||||
-- ** Fields
|
||||
gameState,
|
||||
uiState,
|
||||
|
||||
, uiFocusRing, uiReplForm, uiReplType, uiReplHistory, uiReplHistIdx, uiReplLast
|
||||
, uiInventory, uiError, uiModal, lgTicksPerSecond
|
||||
, lastFrameTime, accumulatedTime, tickCount, frameCount, lastInfoTime
|
||||
, uiShowFPS, uiTPF, uiFPS
|
||||
-- ** Initialization
|
||||
initAppState,
|
||||
) where
|
||||
|
||||
-- ** Initialization
|
||||
import Control.Lens
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.State
|
||||
import Data.List (findIndex, sortOn)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Vector as V
|
||||
import System.Clock
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
, initFocusRing
|
||||
, replPrompt
|
||||
, initReplForm
|
||||
, initLgTicksPerSecond
|
||||
, initUIState
|
||||
import Brick
|
||||
import Brick.Focus
|
||||
import Brick.Forms
|
||||
import qualified Brick.Widgets.List as BL
|
||||
|
||||
-- ** Updating
|
||||
|
||||
, populateInventoryList
|
||||
|
||||
-- * App state
|
||||
, AppState
|
||||
-- ** Fields
|
||||
, gameState, uiState
|
||||
-- ** Initialization
|
||||
, initAppState
|
||||
|
||||
) where
|
||||
|
||||
import Control.Lens
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.State
|
||||
import Data.List (findIndex, sortOn)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Vector as V
|
||||
import System.Clock
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
import Brick
|
||||
import Brick.Focus
|
||||
import Brick.Forms
|
||||
import qualified Brick.Widgets.List as BL
|
||||
|
||||
import Swarm.Game.Entity
|
||||
import Swarm.Game.Robot
|
||||
import Swarm.Game.State
|
||||
import Swarm.Language.Types
|
||||
import Swarm.Util
|
||||
import Swarm.Game.Entity
|
||||
import Swarm.Game.Robot
|
||||
import Swarm.Game.State
|
||||
import Swarm.Language.Types
|
||||
import Swarm.Util
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Custom UI label types
|
||||
@ -94,14 +107,21 @@ data AppEvent = Frame
|
||||
-- | 'Name' represents names to uniquely identify various components
|
||||
-- of the UI, such as forms, panels, caches, extents, and lists.
|
||||
data Name
|
||||
= REPLPanel -- ^ The panel containing the REPL.
|
||||
| WorldPanel -- ^ The panel containing the world view.
|
||||
| InfoPanel -- ^ The info panel on the left side.
|
||||
| REPLInput -- ^ The REPL input form.
|
||||
| WorldCache -- ^ The render cache for the world view.
|
||||
| WorldExtent -- ^ The cached extent for the world view.
|
||||
| InventoryList -- ^ The list of inventory items for the currently
|
||||
-- focused robot.
|
||||
= -- | The panel containing the REPL.
|
||||
REPLPanel
|
||||
| -- | The panel containing the world view.
|
||||
WorldPanel
|
||||
| -- | The info panel on the left side.
|
||||
InfoPanel
|
||||
| -- | The REPL input form.
|
||||
REPLInput
|
||||
| -- | The render cache for the world view.
|
||||
WorldCache
|
||||
| -- | The cached extent for the world view.
|
||||
WorldExtent
|
||||
| -- | The list of inventory items for the currently
|
||||
-- focused robot.
|
||||
InventoryList
|
||||
deriving (Eq, Ord, Show, Read, Enum, Bounded)
|
||||
|
||||
data Modal
|
||||
@ -114,14 +134,16 @@ data Modal
|
||||
|
||||
-- | An item in the REPL history.
|
||||
data REPLHistItem
|
||||
= REPLEntry Bool Text -- ^ Something entered by the user. The
|
||||
-- @Bool@ indicates whether it is
|
||||
-- something entered this session (it
|
||||
-- will be @False@ for entries that were
|
||||
-- loaded from the history file). This is
|
||||
-- so we know which ones to append to the
|
||||
-- history file on shutdown.
|
||||
| REPLOutput Text -- ^ A response printed by the system.
|
||||
= -- | Something entered by the user. The
|
||||
-- @Bool@ indicates whether it is
|
||||
-- something entered this session (it
|
||||
-- will be @False@ for entries that were
|
||||
-- loaded from the history file). This is
|
||||
-- so we know which ones to append to the
|
||||
-- history file on shutdown.
|
||||
REPLEntry Bool Text
|
||||
| -- | A response printed by the system.
|
||||
REPLOutput Text
|
||||
deriving (Eq, Ord, Show, Read)
|
||||
|
||||
-- | An entry in the inventory list displayed in the info panel. We
|
||||
@ -137,24 +159,24 @@ makePrisms ''InventoryEntry
|
||||
-- | The main record holding the UI state. For access to the fields,
|
||||
-- see the lenses below.
|
||||
data UIState = UIState
|
||||
{ _uiFocusRing :: FocusRing Name
|
||||
, _uiReplForm :: Form Text AppEvent Name
|
||||
, _uiReplType :: Maybe Polytype
|
||||
, _uiReplLast :: Text
|
||||
, _uiReplHistory :: [REPLHistItem]
|
||||
, _uiReplHistIdx :: Int
|
||||
, _uiInventory :: Maybe (Int, BL.List Name InventoryEntry)
|
||||
, _uiError :: Maybe (Widget Name)
|
||||
, _uiModal :: Maybe Modal
|
||||
, _uiShowFPS :: Bool
|
||||
, _uiTPF :: Double
|
||||
, _uiFPS :: Double
|
||||
{ _uiFocusRing :: FocusRing Name
|
||||
, _uiReplForm :: Form Text AppEvent Name
|
||||
, _uiReplType :: Maybe Polytype
|
||||
, _uiReplLast :: Text
|
||||
, _uiReplHistory :: [REPLHistItem]
|
||||
, _uiReplHistIdx :: Int
|
||||
, _uiInventory :: Maybe (Int, BL.List Name InventoryEntry)
|
||||
, _uiError :: Maybe (Widget Name)
|
||||
, _uiModal :: Maybe Modal
|
||||
, _uiShowFPS :: Bool
|
||||
, _uiTPF :: Double
|
||||
, _uiFPS :: Double
|
||||
, _lgTicksPerSecond :: Int
|
||||
, _tickCount :: Int
|
||||
, _frameCount :: Int
|
||||
, _lastFrameTime :: TimeSpec
|
||||
, _accumulatedTime :: TimeSpec
|
||||
, _lastInfoTime :: TimeSpec
|
||||
, _tickCount :: Int
|
||||
, _frameCount :: Int
|
||||
, _lastFrameTime :: TimeSpec
|
||||
, _accumulatedTime :: TimeSpec
|
||||
, _lastInfoTime :: TimeSpec
|
||||
}
|
||||
|
||||
makeLensesWith (lensRules & generateSignatures .~ False) ''UIState
|
||||
@ -238,13 +260,14 @@ replPrompt = "> "
|
||||
|
||||
-- | The initial state of the REPL entry form.
|
||||
initReplForm :: Form Text AppEvent Name
|
||||
initReplForm = newForm
|
||||
[(txt replPrompt <+>) @@= editTextField id REPLInput (Just 1)]
|
||||
""
|
||||
initReplForm =
|
||||
newForm
|
||||
[(txt replPrompt <+>) @@= editTextField id REPLInput (Just 1)]
|
||||
""
|
||||
|
||||
-- | The initial tick speed.
|
||||
initLgTicksPerSecond :: Int
|
||||
initLgTicksPerSecond = 3 -- 2^3 = 8 ticks / second
|
||||
initLgTicksPerSecond = 3 -- 2^3 = 8 ticks / second
|
||||
|
||||
-- | Initialize the UI state. This needs to be in the IO monad since
|
||||
-- it involves reading a REPL history file and getting the current
|
||||
@ -253,26 +276,27 @@ initUIState :: ExceptT Text IO UIState
|
||||
initUIState = liftIO $ do
|
||||
mhist <- (>>= readMaybe @[REPLHistItem]) <$> readFileMay ".swarm_history"
|
||||
startTime <- getTime Monotonic
|
||||
return $ UIState
|
||||
{ _uiFocusRing = initFocusRing
|
||||
, _uiReplForm = initReplForm
|
||||
, _uiReplType = Nothing
|
||||
, _uiReplHistory = mhist ? []
|
||||
, _uiReplHistIdx = -1
|
||||
, _uiReplLast = ""
|
||||
, _uiInventory = Nothing
|
||||
, _uiError = Nothing
|
||||
, _uiModal = Nothing
|
||||
, _uiShowFPS = False
|
||||
, _uiTPF = 0
|
||||
, _uiFPS = 0
|
||||
, _lgTicksPerSecond = initLgTicksPerSecond
|
||||
, _lastFrameTime = startTime
|
||||
, _accumulatedTime = 0
|
||||
, _lastInfoTime = 0
|
||||
, _tickCount = 0
|
||||
, _frameCount = 0
|
||||
}
|
||||
return $
|
||||
UIState
|
||||
{ _uiFocusRing = initFocusRing
|
||||
, _uiReplForm = initReplForm
|
||||
, _uiReplType = Nothing
|
||||
, _uiReplHistory = mhist ? []
|
||||
, _uiReplHistIdx = -1
|
||||
, _uiReplLast = ""
|
||||
, _uiInventory = Nothing
|
||||
, _uiError = Nothing
|
||||
, _uiModal = Nothing
|
||||
, _uiShowFPS = False
|
||||
, _uiTPF = 0
|
||||
, _uiFPS = 0
|
||||
, _lgTicksPerSecond = initLgTicksPerSecond
|
||||
, _lastFrameTime = startTime
|
||||
, _accumulatedTime = 0
|
||||
, _lastInfoTime = 0
|
||||
, _tickCount = 0
|
||||
, _frameCount = 0
|
||||
}
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Functions for updating the UI state
|
||||
@ -281,20 +305,21 @@ initUIState = liftIO $ do
|
||||
-- | Given the focused robot, populate the UI inventory list in the info
|
||||
-- panel with information about its inventory.
|
||||
populateInventoryList :: MonadState UIState m => Maybe Robot -> m ()
|
||||
populateInventoryList Nothing = uiInventory .= Nothing
|
||||
populateInventoryList Nothing = uiInventory .= Nothing
|
||||
populateInventoryList (Just r) = do
|
||||
mList <- preuse (uiInventory . _Just . _2)
|
||||
let mkInvEntry (n,e) = InventoryEntry n e
|
||||
itemList label
|
||||
= (\case { [] -> []; xs -> Separator label : xs })
|
||||
. map mkInvEntry
|
||||
. sortOn (view entityName . snd)
|
||||
. elems
|
||||
items = (r ^. robotInventory . to (itemList "Inventory"))
|
||||
++ (r ^. installedDevices . to (itemList "Installed devices"))
|
||||
let mkInvEntry (n, e) = InventoryEntry n e
|
||||
itemList label =
|
||||
(\case [] -> []; xs -> Separator label : xs)
|
||||
. map mkInvEntry
|
||||
. sortOn (view entityName . snd)
|
||||
. elems
|
||||
items =
|
||||
(r ^. robotInventory . to (itemList "Inventory"))
|
||||
++ (r ^. installedDevices . to (itemList "Installed devices"))
|
||||
|
||||
-- Attempt to keep the selected element steady.
|
||||
sel = mList >>= BL.listSelectedElement -- Get the currently selected element+index.
|
||||
sel = mList >>= BL.listSelectedElement -- Get the currently selected element+index.
|
||||
idx = case sel of
|
||||
-- If there is no currently selected element, just focus on
|
||||
-- index 1 (not 0, to avoid the separator).
|
||||
@ -319,7 +344,7 @@ populateInventoryList (Just r) = do
|
||||
-- | The 'AppState' just stores together the game state and UI state.
|
||||
data AppState = AppState
|
||||
{ _gameState :: GameState
|
||||
, _uiState :: UIState
|
||||
, _uiState :: UIState
|
||||
}
|
||||
|
||||
makeLensesWith (lensRules & generateSignatures .~ False) ''AppState
|
||||
@ -334,6 +359,5 @@ uiState :: Lens' AppState UIState
|
||||
initAppState :: ExceptT Text IO AppState
|
||||
initAppState = AppState <$> initGameState <*> initUIState
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
--
|
||||
|
@ -1,4 +1,9 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.TUI.Panel
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -11,26 +16,19 @@
|
||||
-- depending on whether the panel is currently focused. Panels exist
|
||||
-- within a 'FocusRing' such that the user can cycle between the
|
||||
-- panels (using /e.g./ the @Tab@ key).
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.TUI.Panel (
|
||||
panel,
|
||||
) where
|
||||
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
import Brick
|
||||
import Brick.Focus
|
||||
import Brick.Widgets.Border
|
||||
import Swarm.TUI.Border
|
||||
|
||||
module Swarm.TUI.Panel
|
||||
( panel
|
||||
) where
|
||||
|
||||
import Brick
|
||||
import Brick.Focus
|
||||
import Brick.Widgets.Border
|
||||
import Swarm.TUI.Border
|
||||
|
||||
import Control.Lens
|
||||
import Control.Lens
|
||||
|
||||
data Panel n = Panel
|
||||
{ _panelName :: n, _panelLabels :: BorderLabels n, _panelContent :: Widget n }
|
||||
{_panelName :: n, _panelLabels :: BorderLabels n, _panelContent :: Widget n}
|
||||
|
||||
makeLenses ''Panel
|
||||
|
||||
@ -39,18 +37,24 @@ instance Named (Panel n) n where
|
||||
|
||||
drawPanel :: Eq n => AttrName -> FocusRing n -> Panel n -> Widget n
|
||||
drawPanel attr fr = withFocusRing fr drawPanel'
|
||||
where
|
||||
drawPanel' :: Bool -> Panel n -> Widget n
|
||||
drawPanel' focused p
|
||||
= (if focused then overrideAttr borderAttr attr else id)
|
||||
$ borderWithLabels (p ^. panelLabels) (p ^. panelContent)
|
||||
where
|
||||
drawPanel' :: Bool -> Panel n -> Widget n
|
||||
drawPanel' focused p =
|
||||
(if focused then overrideAttr borderAttr attr else id) $
|
||||
borderWithLabels (p ^. panelLabels) (p ^. panelContent)
|
||||
|
||||
-- | Create a panel.
|
||||
panel :: Eq n
|
||||
=> AttrName -- ^ Border attribute to use when the panel is focused.
|
||||
-> FocusRing n -- ^ Focus ring the panel should be part of.
|
||||
-> n -- ^ The name of the panel. Must be unique.
|
||||
-> BorderLabels n -- ^ The labels to use around the border.
|
||||
-> Widget n -- ^ The content of the panel.
|
||||
-> Widget n
|
||||
panel ::
|
||||
Eq n =>
|
||||
-- | Border attribute to use when the panel is focused.
|
||||
AttrName ->
|
||||
-- | Focus ring the panel should be part of.
|
||||
FocusRing n ->
|
||||
-- | The name of the panel. Must be unique.
|
||||
n ->
|
||||
-- | The labels to use around the border.
|
||||
BorderLabels n ->
|
||||
-- | The content of the panel.
|
||||
Widget n ->
|
||||
Widget n
|
||||
panel attr fr nm labs w = drawPanel attr fr (Panel nm labs w)
|
||||
|
@ -1,4 +1,8 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-----------------------------------------------------------------------------
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.TUI.View
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -7,80 +11,72 @@
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
--
|
||||
-- Code for drawing the TUI.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.TUI.View (
|
||||
drawUI,
|
||||
drawTPS,
|
||||
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
-- * Error dialog
|
||||
errorDialog,
|
||||
drawDialog,
|
||||
chooseCursor,
|
||||
|
||||
module Swarm.TUI.View
|
||||
(
|
||||
drawUI
|
||||
, drawTPS
|
||||
-- * Key hint menu
|
||||
drawMenu,
|
||||
drawKeyCmd,
|
||||
|
||||
-- * Error dialog
|
||||
, errorDialog
|
||||
, drawDialog
|
||||
, chooseCursor
|
||||
-- * World
|
||||
drawWorld,
|
||||
drawCell,
|
||||
|
||||
-- * Key hint menu
|
||||
, drawMenu
|
||||
, drawKeyCmd
|
||||
-- * Info panel
|
||||
drawInfoPanel,
|
||||
drawMessageBox,
|
||||
explainFocusedItem,
|
||||
drawMessages,
|
||||
drawRobotInfo,
|
||||
drawItem,
|
||||
drawLabelledEntityName,
|
||||
|
||||
-- * World
|
||||
, drawWorld
|
||||
, drawCell
|
||||
-- * REPL
|
||||
drawREPL,
|
||||
) where
|
||||
|
||||
-- * Info panel
|
||||
import Control.Arrow ((&&&))
|
||||
import Control.Lens
|
||||
import Data.Array (range)
|
||||
import Data.List.Split (chunksOf)
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Linear
|
||||
import Text.Printf
|
||||
import Text.Wrap
|
||||
|
||||
, drawInfoPanel
|
||||
, drawMessageBox
|
||||
, explainFocusedItem
|
||||
, drawMessages
|
||||
, drawRobotInfo
|
||||
, drawItem
|
||||
, drawLabelledEntityName
|
||||
import Brick hiding (Direction)
|
||||
import Brick.Focus
|
||||
import Brick.Forms
|
||||
import Brick.Widgets.Border (hBorder, hBorderWithLabel)
|
||||
import Brick.Widgets.Center (center, hCenter)
|
||||
import Brick.Widgets.Dialog
|
||||
import qualified Brick.Widgets.List as BL
|
||||
import qualified Brick.Widgets.Table as BT
|
||||
|
||||
-- * REPL
|
||||
, drawREPL
|
||||
) where
|
||||
|
||||
import Control.Arrow ((&&&))
|
||||
import Control.Lens
|
||||
import Data.Array (range)
|
||||
import Data.List.Split (chunksOf)
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Linear
|
||||
import Text.Printf
|
||||
import Text.Wrap
|
||||
|
||||
import Brick hiding (Direction)
|
||||
import Brick.Focus
|
||||
import Brick.Forms
|
||||
import Brick.Widgets.Border (hBorder, hBorderWithLabel)
|
||||
import Brick.Widgets.Center (center, hCenter)
|
||||
import Brick.Widgets.Dialog
|
||||
import qualified Brick.Widgets.List as BL
|
||||
import qualified Brick.Widgets.Table as BT
|
||||
|
||||
import Swarm.Game.Display
|
||||
import Swarm.Game.Entity hiding (empty)
|
||||
import Swarm.Game.Recipe
|
||||
import Swarm.Game.Robot
|
||||
import Swarm.Game.State
|
||||
import Swarm.Game.Terrain (displayTerrain)
|
||||
import qualified Swarm.Game.World as W
|
||||
import Swarm.Language.Pretty (prettyText)
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Language.Types (Polytype)
|
||||
import Swarm.TUI.Attr
|
||||
import Swarm.TUI.Border
|
||||
import Swarm.TUI.Model
|
||||
import Swarm.TUI.Panel
|
||||
import Swarm.Util
|
||||
import Swarm.Game.Display
|
||||
import Swarm.Game.Entity hiding (empty)
|
||||
import Swarm.Game.Recipe
|
||||
import Swarm.Game.Robot
|
||||
import Swarm.Game.State
|
||||
import Swarm.Game.Terrain (displayTerrain)
|
||||
import qualified Swarm.Game.World as W
|
||||
import Swarm.Language.Pretty (prettyText)
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Language.Types (Polytype)
|
||||
import Swarm.TUI.Attr
|
||||
import Swarm.TUI.Border
|
||||
import Swarm.TUI.Model
|
||||
import Swarm.TUI.Panel
|
||||
import Swarm.Util
|
||||
|
||||
-- | The main entry point for drawing the entire UI. Generates a list
|
||||
-- of widgets, where each represents a layer. Right now we just
|
||||
@ -90,31 +86,39 @@ drawUI :: AppState -> [Widget Name]
|
||||
drawUI s =
|
||||
[ drawDialog (s ^. uiState)
|
||||
, joinBorders $
|
||||
hBox
|
||||
[ hLimitPercent 25 $ panel highlightAttr fr InfoPanel plainBorder $
|
||||
drawInfoPanel s
|
||||
, vBox
|
||||
[ panel highlightAttr fr WorldPanel
|
||||
(plainBorder & bottomLabels . rightLabel ?~ padLeftRight 1 (drawTPS s))
|
||||
(drawWorld $ s ^. gameState)
|
||||
, drawMenu
|
||||
(s ^. gameState . paused)
|
||||
((s ^. gameState . viewCenterRule) == VCRobot "base")
|
||||
(s ^. gameState . gameMode)
|
||||
(s ^. uiState)
|
||||
, panel highlightAttr fr REPLPanel
|
||||
( plainBorder
|
||||
& topLabels . rightLabel .~ (drawType <$> (s ^. uiState . uiReplType))
|
||||
)
|
||||
( vLimit replHeight $
|
||||
padBottom Max $ padLeftRight 1 $
|
||||
drawREPL s
|
||||
)
|
||||
]
|
||||
]
|
||||
hBox
|
||||
[ hLimitPercent 25 $
|
||||
panel highlightAttr fr InfoPanel plainBorder $
|
||||
drawInfoPanel s
|
||||
, vBox
|
||||
[ panel
|
||||
highlightAttr
|
||||
fr
|
||||
WorldPanel
|
||||
(plainBorder & bottomLabels . rightLabel ?~ padLeftRight 1 (drawTPS s))
|
||||
(drawWorld $ s ^. gameState)
|
||||
, drawMenu
|
||||
(s ^. gameState . paused)
|
||||
((s ^. gameState . viewCenterRule) == VCRobot "base")
|
||||
(s ^. gameState . gameMode)
|
||||
(s ^. uiState)
|
||||
, panel
|
||||
highlightAttr
|
||||
fr
|
||||
REPLPanel
|
||||
( plainBorder
|
||||
& topLabels . rightLabel .~ (drawType <$> (s ^. uiState . uiReplType))
|
||||
)
|
||||
( vLimit replHeight $
|
||||
padBottom Max $
|
||||
padLeftRight 1 $
|
||||
drawREPL s
|
||||
)
|
||||
]
|
||||
]
|
||||
]
|
||||
where
|
||||
fr = s ^. uiState . uiFocusRing
|
||||
where
|
||||
fr = s ^. uiState . uiFocusRing
|
||||
|
||||
-- | Render the type of the current REPL input to be shown to the user.
|
||||
drawType :: Polytype -> Widget Name
|
||||
@ -123,21 +127,23 @@ drawType = withAttr infoAttr . padLeftRight 1 . txt . prettyText
|
||||
-- | Draw info about the current number of ticks per second.
|
||||
drawTPS :: AppState -> Widget Name
|
||||
drawTPS s = hBox (tpsInfo : rateInfo)
|
||||
where
|
||||
tpsInfo
|
||||
| l >= 0 = hBox [str (show n), txt " ", txt (number n "tick"), txt " / s"]
|
||||
| otherwise = hBox [txt "1 tick / ", str (show n), txt " s"]
|
||||
where
|
||||
tpsInfo
|
||||
| l >= 0 = hBox [str (show n), txt " ", txt (number n "tick"), txt " / s"]
|
||||
| otherwise = hBox [txt "1 tick / ", str (show n), txt " s"]
|
||||
|
||||
rateInfo
|
||||
| s ^. uiState . uiShowFPS =
|
||||
[ txt " ("
|
||||
, str (printf "%0.1f" (s ^. uiState . uiTPF)), txt " tpf, "
|
||||
, str (printf "%0.1f" (s ^. uiState . uiFPS)), txt " fps)"
|
||||
]
|
||||
| otherwise = []
|
||||
rateInfo
|
||||
| s ^. uiState . uiShowFPS =
|
||||
[ txt " ("
|
||||
, str (printf "%0.1f" (s ^. uiState . uiTPF))
|
||||
, txt " tpf, "
|
||||
, str (printf "%0.1f" (s ^. uiState . uiFPS))
|
||||
, txt " fps)"
|
||||
]
|
||||
| otherwise = []
|
||||
|
||||
l = s ^. uiState . lgTicksPerSecond
|
||||
n = 2^abs l
|
||||
l = s ^. uiState . lgTicksPerSecond
|
||||
n = 2 ^ abs l
|
||||
|
||||
-- | The height of the REPL box. Perhaps in the future this should be
|
||||
-- configurable.
|
||||
@ -157,135 +163,142 @@ errorDialog = dialog (Just "Error") Nothing 80
|
||||
-- | Render a fullscreen widget with some padding
|
||||
renderModal :: Modal -> Widget Name
|
||||
renderModal modal = renderDialog (dialog (Just modalTitle) Nothing 500) modalWidget
|
||||
where
|
||||
modalWidget = Widget Fixed Fixed $ do
|
||||
ctx <- getContext
|
||||
let w = ctx ^. availWidthL
|
||||
h = ctx ^. availHeightL
|
||||
padding = 10
|
||||
render $ setAvailableSize (w - padding, h - padding) modalContent
|
||||
(modalTitle, modalContent) =
|
||||
case modal of
|
||||
HelpModal -> ("Help", helpWidget)
|
||||
where
|
||||
modalWidget = Widget Fixed Fixed $ do
|
||||
ctx <- getContext
|
||||
let w = ctx ^. availWidthL
|
||||
h = ctx ^. availHeightL
|
||||
padding = 10
|
||||
render $ setAvailableSize (w - padding, h - padding) modalContent
|
||||
(modalTitle, modalContent) =
|
||||
case modal of
|
||||
HelpModal -> ("Help", helpWidget)
|
||||
|
||||
helpWidget :: Widget Name
|
||||
helpWidget = (helpKeys <=> fill ' ') <+> (helpCommands <=> fill ' ')
|
||||
where
|
||||
helpKeys =
|
||||
vBox [ hCenter $ txt "Global Keybindings"
|
||||
, hCenter $ mkTable glKeyBindings
|
||||
]
|
||||
mkTable = BT.renderTable . BT.table . map toWidgets
|
||||
toWidgets (k, v) = [txt k, txt v]
|
||||
glKeyBindings =
|
||||
[ ("F1", "Help")
|
||||
, ("Ctrl-q", "quit the game")
|
||||
, ("Tab", "cycle panel focus")
|
||||
, ("Meta-w", "focus on the world map")
|
||||
, ("Meta-e", "focus on the info")
|
||||
, ("Meta-r", "focus on the REPL")
|
||||
where
|
||||
helpKeys =
|
||||
vBox
|
||||
[ hCenter $ txt "Global Keybindings"
|
||||
, hCenter $ mkTable glKeyBindings
|
||||
]
|
||||
helpCommands =
|
||||
vBox [ hCenter $ txt "Commands"
|
||||
, hCenter $ mkTable baseCommands
|
||||
]
|
||||
baseCommands =
|
||||
[ ("build <name> <commands>", "Create a robot")
|
||||
, ("make <name>", "Craft an item")
|
||||
, ("move", "Move one step in the current direction")
|
||||
, ("turn <dir>", "Change the current direction")
|
||||
, ("grab", "Grab whatver is available")
|
||||
, ("give <robot> <item>", "Give an item to another robot")
|
||||
mkTable = BT.renderTable . BT.table . map toWidgets
|
||||
toWidgets (k, v) = [txt k, txt v]
|
||||
glKeyBindings =
|
||||
[ ("F1", "Help")
|
||||
, ("Ctrl-q", "quit the game")
|
||||
, ("Tab", "cycle panel focus")
|
||||
, ("Meta-w", "focus on the world map")
|
||||
, ("Meta-e", "focus on the info")
|
||||
, ("Meta-r", "focus on the REPL")
|
||||
]
|
||||
helpCommands =
|
||||
vBox
|
||||
[ hCenter $ txt "Commands"
|
||||
, hCenter $ mkTable baseCommands
|
||||
]
|
||||
baseCommands =
|
||||
[ ("build <name> <commands>", "Create a robot")
|
||||
, ("make <name>", "Craft an item")
|
||||
, ("move", "Move one step in the current direction")
|
||||
, ("turn <dir>", "Change the current direction")
|
||||
, ("grab", "Grab whatver is available")
|
||||
, ("give <robot> <item>", "Give an item to another robot")
|
||||
]
|
||||
|
||||
-- | Draw the error dialog window, if it should be displayed right now.
|
||||
drawDialog :: UIState -> Widget Name
|
||||
drawDialog s = case s ^. uiModal of
|
||||
Just m -> renderModal m
|
||||
Nothing -> case s ^. uiError of
|
||||
Just d -> renderDialog errorDialog d
|
||||
Just d -> renderDialog errorDialog d
|
||||
Nothing -> emptyWidget
|
||||
|
||||
-- | Draw a menu explaining what key commands are available for the
|
||||
-- current panel. This menu is displayed as a single line in
|
||||
-- between the world panel and the REPL.
|
||||
drawMenu :: Bool -> Bool -> GameMode -> UIState -> Widget Name
|
||||
drawMenu isPaused viewingBase mode
|
||||
= vLimit 1
|
||||
. hBox . (++[gameModeWidget]) . map (padLeftRight 1 . drawKeyCmd)
|
||||
. (globalKeyCmds++) . keyCmdsFor . focusGetCurrent . view uiFocusRing
|
||||
where
|
||||
gameModeWidget
|
||||
= padLeft Max . padLeftRight 1
|
||||
. txt . (<> " mode")
|
||||
drawMenu isPaused viewingBase mode =
|
||||
vLimit 1
|
||||
. hBox
|
||||
. (++ [gameModeWidget])
|
||||
. map (padLeftRight 1 . drawKeyCmd)
|
||||
. (globalKeyCmds ++)
|
||||
. keyCmdsFor
|
||||
. focusGetCurrent
|
||||
. view uiFocusRing
|
||||
where
|
||||
gameModeWidget =
|
||||
padLeft Max . padLeftRight 1
|
||||
. txt
|
||||
. (<> " mode")
|
||||
$ case mode of
|
||||
Classic -> "Classic"
|
||||
Creative -> "Creative"
|
||||
globalKeyCmds =
|
||||
[ ("F1", "help")
|
||||
, ("Tab", "cycle panels")
|
||||
]
|
||||
keyCmdsFor (Just REPLPanel) =
|
||||
[ ("Enter", "execute")
|
||||
]
|
||||
keyCmdsFor (Just WorldPanel) =
|
||||
[ ("←↓↑→ / hjkl", "scroll")
|
||||
, ("<>", "slower/faster")
|
||||
, ("p", if isPaused then "unpause" else "pause")
|
||||
]
|
||||
++
|
||||
[ ("s", "step") | isPaused ]
|
||||
++
|
||||
[ ("c", "recenter") | not viewingBase ]
|
||||
|
||||
keyCmdsFor (Just InfoPanel) =
|
||||
[ ("↓↑/Pg{Up,Dn}/Home/End/jk", "navigate")
|
||||
, ("Enter", "make")
|
||||
]
|
||||
keyCmdsFor _ = []
|
||||
Classic -> "Classic"
|
||||
Creative -> "Creative"
|
||||
globalKeyCmds =
|
||||
[ ("F1", "help")
|
||||
, ("Tab", "cycle panels")
|
||||
]
|
||||
keyCmdsFor (Just REPLPanel) =
|
||||
[ ("Enter", "execute")
|
||||
]
|
||||
keyCmdsFor (Just WorldPanel) =
|
||||
[ ("←↓↑→ / hjkl", "scroll")
|
||||
, ("<>", "slower/faster")
|
||||
, ("p", if isPaused then "unpause" else "pause")
|
||||
]
|
||||
++ [("s", "step") | isPaused]
|
||||
++ [("c", "recenter") | not viewingBase]
|
||||
keyCmdsFor (Just InfoPanel) =
|
||||
[ ("↓↑/Pg{Up,Dn}/Home/End/jk", "navigate")
|
||||
, ("Enter", "make")
|
||||
]
|
||||
keyCmdsFor _ = []
|
||||
|
||||
-- | Draw a single key command in the menu.
|
||||
drawKeyCmd :: (Text, Text) -> Widget Name
|
||||
drawKeyCmd (key, cmd) = txt $ T.concat [ "[", key, "] ", cmd ]
|
||||
drawKeyCmd (key, cmd) = txt $ T.concat ["[", key, "] ", cmd]
|
||||
|
||||
-- | Draw the current world view.
|
||||
drawWorld :: GameState -> Widget Name
|
||||
drawWorld g
|
||||
= center
|
||||
$ cached WorldCache
|
||||
$ reportExtent WorldExtent
|
||||
$ Widget Fixed Fixed $ do
|
||||
ctx <- getContext
|
||||
let w = ctx ^. availWidthL
|
||||
h = ctx ^. availHeightL
|
||||
ixs = range (viewingRegion g (fromIntegral w, fromIntegral h))
|
||||
render . vBox . map hBox . chunksOf w . map drawLoc $ ixs
|
||||
where
|
||||
-- XXX update how this works! Gather all displays, all
|
||||
-- entities... Should make a Display remember which is the
|
||||
-- currently selected char (based on orientation); Entity lens for
|
||||
-- setting orientation updates the Display too. Then we can just
|
||||
-- get all the Displays for each cell, make a monoid based on
|
||||
-- priority.
|
||||
drawWorld g =
|
||||
center $
|
||||
cached WorldCache $
|
||||
reportExtent WorldExtent $
|
||||
Widget Fixed Fixed $ do
|
||||
ctx <- getContext
|
||||
let w = ctx ^. availWidthL
|
||||
h = ctx ^. availHeightL
|
||||
ixs = range (viewingRegion g (fromIntegral w, fromIntegral h))
|
||||
render . vBox . map hBox . chunksOf w . map drawLoc $ ixs
|
||||
where
|
||||
-- XXX update how this works! Gather all displays, all
|
||||
-- entities... Should make a Display remember which is the
|
||||
-- currently selected char (based on orientation); Entity lens for
|
||||
-- setting orientation updates the Display too. Then we can just
|
||||
-- get all the Displays for each cell, make a monoid based on
|
||||
-- priority.
|
||||
|
||||
robotsByLoc
|
||||
= M.fromListWith (maxOn (^. robotDisplay . displayPriority)) . map (view robotLocation &&& id)
|
||||
. M.elems $ g ^. robotMap
|
||||
drawLoc coords = case M.lookup (W.coordsToLoc coords) robotsByLoc of
|
||||
Just r -> withAttr (r ^. robotDisplay . displayAttr) $
|
||||
robotsByLoc =
|
||||
M.fromListWith (maxOn (^. robotDisplay . displayPriority)) . map (view robotLocation &&& id)
|
||||
. M.elems
|
||||
$ g ^. robotMap
|
||||
drawLoc coords = case M.lookup (W.coordsToLoc coords) robotsByLoc of
|
||||
Just r ->
|
||||
withAttr (r ^. robotDisplay . displayAttr) $
|
||||
str [lookupDisplay ((r ^. robotOrientation) >>= toDirection) (r ^. robotDisplay)]
|
||||
Nothing -> drawCell coords (g ^. world)
|
||||
Nothing -> drawCell coords (g ^. world)
|
||||
|
||||
-- | Draw a single cell of the world.
|
||||
drawCell :: W.Coords -> W.World Int Entity -> Widget Name
|
||||
drawCell i w = case W.lookupEntity i w of
|
||||
Just e -> displayEntity e
|
||||
Just e -> displayEntity e
|
||||
Nothing -> displayTerrain (toEnum (W.lookupTerrain i w))
|
||||
|
||||
-- | Draw the info panel on the left-hand side of the UI.
|
||||
drawInfoPanel :: AppState -> Widget Name
|
||||
drawInfoPanel s
|
||||
= vBox
|
||||
drawInfoPanel s =
|
||||
vBox
|
||||
[ drawRobotInfo s
|
||||
, hBorder
|
||||
, vLimitPercent 50 $ padBottom Max $ padAll 1 $ drawMessageBox s
|
||||
@ -297,42 +310,44 @@ drawInfoPanel s
|
||||
drawMessageBox :: AppState -> Widget Name
|
||||
drawMessageBox s = case s ^. uiState . uiFocusRing . to focusGetCurrent of
|
||||
Just InfoPanel -> explainFocusedItem s
|
||||
_ -> drawMessages (s ^. gameState . messageQueue)
|
||||
_ -> drawMessages (s ^. gameState . messageQueue)
|
||||
|
||||
-- | Display info about the currently focused inventory entity,
|
||||
-- such as its description and relevant recipes.
|
||||
explainFocusedItem :: AppState -> Widget Name
|
||||
explainFocusedItem s = case mItem of
|
||||
Nothing -> txt " "
|
||||
Just (Separator _) -> txt " "
|
||||
Just (InventoryEntry _ e) -> vBox $
|
||||
map (padBottom (Pad 1) . txtWrap) (e ^. entityDescription)
|
||||
++
|
||||
explainRecipes e
|
||||
where
|
||||
mList = s ^? uiState . uiInventory . _Just . _2
|
||||
mItem = mList >>= BL.listSelectedElement >>= (Just . snd)
|
||||
Nothing -> txt " "
|
||||
Just (Separator _) -> txt " "
|
||||
Just (InventoryEntry _ e) ->
|
||||
vBox $
|
||||
map (padBottom (Pad 1) . txtWrap) (e ^. entityDescription)
|
||||
++ explainRecipes e
|
||||
where
|
||||
mList = s ^? uiState . uiInventory . _Just . _2
|
||||
mItem = mList >>= BL.listSelectedElement >>= (Just . snd)
|
||||
|
||||
indent2 = defaultWrapSettings { fillStrategy = FillIndent 2 }
|
||||
indent2 = defaultWrapSettings {fillStrategy = FillIndent 2}
|
||||
|
||||
explainRecipes :: Entity -> [Widget Name]
|
||||
explainRecipes = map (txtWrapWith indent2 . prettyRecipe) . recipesWith
|
||||
explainRecipes :: Entity -> [Widget Name]
|
||||
explainRecipes = map (txtWrapWith indent2 . prettyRecipe) . recipesWith
|
||||
|
||||
recipesWith :: Entity -> [Recipe Entity]
|
||||
recipesWith e = S.toList . S.fromList $
|
||||
recipesFor (s ^. gameState . recipesOut) e
|
||||
++ recipesFor (s ^. gameState . recipesIn) e
|
||||
-- We remove duplicates by converting to and from a Set,
|
||||
-- because some recipes can have an item as both an input and an
|
||||
-- output (e.g. some recipes that require a furnace); those
|
||||
-- recipes would show up twice above.
|
||||
recipesWith :: Entity -> [Recipe Entity]
|
||||
recipesWith e =
|
||||
S.toList . S.fromList $
|
||||
recipesFor (s ^. gameState . recipesOut) e
|
||||
++ recipesFor (s ^. gameState . recipesIn) e
|
||||
|
||||
-- We remove duplicates by converting to and from a Set,
|
||||
-- because some recipes can have an item as both an input and an
|
||||
-- output (e.g. some recipes that require a furnace); those
|
||||
-- recipes would show up twice above.
|
||||
|
||||
-- | Draw a list of messages.
|
||||
drawMessages :: [Text] -> Widget Name
|
||||
drawMessages [] = txt " "
|
||||
drawMessages ms = Widget Fixed Fixed $ do
|
||||
ctx <- getContext
|
||||
let h = ctx ^. availHeightL
|
||||
let h = ctx ^. availHeightL
|
||||
render . vBox . map txt . reverse . take h $ ms
|
||||
|
||||
-- | Draw info about the currently focused robot, such as its name,
|
||||
@ -340,60 +355,65 @@ drawMessages ms = Widget Fixed Fixed $ do
|
||||
drawRobotInfo :: AppState -> Widget Name
|
||||
drawRobotInfo s = case (s ^. gameState . to focusedRobot, s ^. uiState . uiInventory) of
|
||||
(Just r, Just (_, lst)) ->
|
||||
let V2 x y = r ^. robotLocation in
|
||||
padBottom Max
|
||||
$ vBox
|
||||
[ hCenter $ hBox
|
||||
[ txt (r ^. robotName)
|
||||
, padLeft (Pad 2) $ str (printf "(%d, %d)" x y)
|
||||
, padLeft (Pad 2) $ displayEntity (r ^. robotEntity)
|
||||
]
|
||||
, padAll 1 (BL.renderListWithIndex (drawItem (lst ^. BL.listSelectedL)) isFocused lst)
|
||||
]
|
||||
let V2 x y = r ^. robotLocation
|
||||
in padBottom Max $
|
||||
vBox
|
||||
[ hCenter $
|
||||
hBox
|
||||
[ txt (r ^. robotName)
|
||||
, padLeft (Pad 2) $ str (printf "(%d, %d)" x y)
|
||||
, padLeft (Pad 2) $ displayEntity (r ^. robotEntity)
|
||||
]
|
||||
, padAll 1 (BL.renderListWithIndex (drawItem (lst ^. BL.listSelectedL)) isFocused lst)
|
||||
]
|
||||
_ -> padBottom Max $ str " "
|
||||
where
|
||||
isFocused = (s ^. uiState . uiFocusRing . to focusGetCurrent) == Just InfoPanel
|
||||
where
|
||||
isFocused = (s ^. uiState . uiFocusRing . to focusGetCurrent) == Just InfoPanel
|
||||
|
||||
-- | Draw an inventory entry.
|
||||
drawItem :: Maybe Int -- ^ The index of the currently selected inventory entry
|
||||
-> Int -- ^ The index of the entry we are drawing
|
||||
-> Bool -- ^ Whether this entry is selected; we can ignore this
|
||||
-- because it will automatically have a special attribute
|
||||
-- applied to it.
|
||||
-> InventoryEntry -- ^ The entry to draw.
|
||||
-> Widget Name
|
||||
drawItem sel i _ (Separator l)
|
||||
|
||||
drawItem ::
|
||||
-- | The index of the currently selected inventory entry
|
||||
Maybe Int ->
|
||||
-- | The index of the entry we are drawing
|
||||
Int ->
|
||||
-- | Whether this entry is selected; we can ignore this
|
||||
-- because it will automatically have a special attribute
|
||||
-- applied to it.
|
||||
Bool ->
|
||||
-- | The entry to draw.
|
||||
InventoryEntry ->
|
||||
Widget Name
|
||||
drawItem sel i _ (Separator l) =
|
||||
-- Make sure a separator right before the focused element is
|
||||
-- visible. Otherwise, when a separator occurs as the very first
|
||||
-- element of the list, once it scrolls off the top of the viewport
|
||||
-- it will never become visible again.
|
||||
-- See https://github.com/jtdaugherty/brick/issues/336#issuecomment-921220025
|
||||
= (if sel == Just (i+1) then visible else id) $ hBorderWithLabel (txt l)
|
||||
|
||||
(if sel == Just (i + 1) then visible else id) $ hBorderWithLabel (txt l)
|
||||
drawItem _ _ _ (InventoryEntry n e) = drawLabelledEntityName e <+> showCount n
|
||||
where
|
||||
showCount = padLeft Max . str . show
|
||||
where
|
||||
showCount = padLeft Max . str . show
|
||||
|
||||
-- | Draw the name of an entity, labelled with its visual
|
||||
-- representation as a cell in the world.
|
||||
drawLabelledEntityName :: Entity -> Widget Name
|
||||
drawLabelledEntityName e = hBox
|
||||
[ padRight (Pad 2) (displayEntity e)
|
||||
, txt (e ^. entityName)
|
||||
]
|
||||
drawLabelledEntityName e =
|
||||
hBox
|
||||
[ padRight (Pad 2) (displayEntity e)
|
||||
, txt (e ^. entityName)
|
||||
]
|
||||
|
||||
-- | Draw the REPL.
|
||||
drawREPL :: AppState -> Widget Name
|
||||
drawREPL s = vBox $
|
||||
map fmt (reverse (take (replHeight - 1) . filter newEntry $ (s ^. uiState . uiReplHistory)))
|
||||
++
|
||||
case isActive <$> (s ^. gameState . robotMap . at "base") of
|
||||
Just False -> [ renderForm (s ^. uiState . uiReplForm) ]
|
||||
_ -> [ padRight Max $ txt "..." ]
|
||||
where
|
||||
newEntry (REPLEntry False _) = False
|
||||
newEntry _ = True
|
||||
drawREPL s =
|
||||
vBox $
|
||||
map fmt (reverse (take (replHeight - 1) . filter newEntry $ (s ^. uiState . uiReplHistory)))
|
||||
++ case isActive <$> (s ^. gameState . robotMap . at "base") of
|
||||
Just False -> [renderForm (s ^. uiState . uiReplForm)]
|
||||
_ -> [padRight Max $ txt "..."]
|
||||
where
|
||||
newEntry (REPLEntry False _) = False
|
||||
newEntry _ = True
|
||||
|
||||
fmt (REPLEntry _ e) = txt replPrompt <+> txt e
|
||||
fmt (REPLOutput t) = txt t
|
||||
fmt (REPLEntry _ e) = txt replPrompt <+> txt e
|
||||
fmt (REPLOutput t) = txt t
|
||||
|
@ -1,13 +1,15 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskellQuotes #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
-- |
|
||||
-- Module : Swarm.Util
|
||||
-- Copyright : Brent Yorgey
|
||||
@ -17,42 +19,46 @@
|
||||
--
|
||||
-- A random collection of small, useful functions that are (or could
|
||||
-- be) used throughout the code base.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
module Swarm.Util (
|
||||
-- * Miscellaneous utilities
|
||||
(?),
|
||||
maxOn,
|
||||
readFileMay,
|
||||
cycleEnum,
|
||||
|
||||
module Swarm.Util
|
||||
( -- * Miscellaneous utilities
|
||||
-- * English language utilities
|
||||
quote,
|
||||
squote,
|
||||
commaList,
|
||||
indefinite,
|
||||
indefiniteQ,
|
||||
plural,
|
||||
number,
|
||||
|
||||
(?), maxOn, readFileMay, cycleEnum
|
||||
-- * Validation utilities
|
||||
holdsOr,
|
||||
isJustOr,
|
||||
isRightOr,
|
||||
isSuccessOr,
|
||||
|
||||
-- * English language utilities
|
||||
-- * Template Haskell utilities
|
||||
liftText,
|
||||
) where
|
||||
|
||||
, quote, squote, commaList, indefinite, indefiniteQ, plural, number
|
||||
|
||||
-- * Validation utilities
|
||||
|
||||
, holdsOr, isJustOr, isRightOr, isSuccessOr
|
||||
|
||||
-- * Template Haskell utilities
|
||||
|
||||
, liftText
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad (unless)
|
||||
import Control.Monad.Error.Class
|
||||
import Data.Either.Validation
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Yaml
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Syntax (lift)
|
||||
import Linear (V2)
|
||||
import qualified NLP.Minimorph.English as MM
|
||||
import NLP.Minimorph.Util ((<+>))
|
||||
import System.Directory (doesFileExist)
|
||||
import Control.Monad (unless)
|
||||
import Control.Monad.Error.Class
|
||||
import Data.Either.Validation
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Yaml
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Syntax (lift)
|
||||
import Linear (V2)
|
||||
import qualified NLP.Minimorph.English as MM
|
||||
import NLP.Minimorph.Util ((<+>))
|
||||
import System.Directory (doesFileExist)
|
||||
|
||||
infixr 1 ?
|
||||
|
||||
@ -81,14 +87,14 @@ readFileMay file = do
|
||||
b <- doesFileExist file
|
||||
case b of
|
||||
False -> return Nothing
|
||||
True -> Just <$> readFile file
|
||||
True -> Just <$> readFile file
|
||||
|
||||
-- | Take the successor of an 'Enum' type, wrapping around when it
|
||||
-- reaches the end.
|
||||
cycleEnum :: (Eq e, Enum e, Bounded e) => e -> e
|
||||
cycleEnum e
|
||||
| e == maxBound = minBound
|
||||
| otherwise = succ e
|
||||
| otherwise = succ e
|
||||
|
||||
--------------------------------------------------
|
||||
-- Some language-y stuff
|
||||
@ -105,9 +111,10 @@ indefiniteQ w = MM.indefiniteDet w <+> squote w
|
||||
-- | Pluralize a noun.
|
||||
plural :: Text -> Text
|
||||
plural = MM.defaultNounPlural
|
||||
-- For now, it is just MM.defaultNounPlural, which only uses heuristics;
|
||||
-- in the future, if we discover specific nouns that it gets wrong,
|
||||
-- we can add a lookup table.
|
||||
|
||||
-- For now, it is just MM.defaultNounPlural, which only uses heuristics;
|
||||
-- in the future, if we discover specific nouns that it gets wrong,
|
||||
-- we can add a lookup table.
|
||||
|
||||
-- | Either pluralize a noun or not, depending on the value of the
|
||||
-- number.
|
||||
@ -125,10 +132,10 @@ quote t = T.concat ["\"", t, "\""]
|
||||
|
||||
-- | Make a list of things with commas and the word "and".
|
||||
commaList :: [Text] -> Text
|
||||
commaList [] = ""
|
||||
commaList [t] = t
|
||||
commaList [s,t] = T.unwords [s, "and", t]
|
||||
commaList ts = T.unwords $ map (`T.append` ",") (init ts) ++ ["and", last ts]
|
||||
commaList [] = ""
|
||||
commaList [t] = t
|
||||
commaList [s, t] = T.unwords [s, "and", t]
|
||||
commaList ts = T.unwords $ map (`T.append` ",") (init ts) ++ ["and", last ts]
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Some orphan instances
|
||||
@ -145,14 +152,14 @@ holdsOr b e = unless b $ throwError e
|
||||
|
||||
-- | Require that a 'Maybe' value is 'Just', or throw an exception.
|
||||
isJustOr :: MonadError e m => Maybe a -> e -> m a
|
||||
Just a `isJustOr` _ = return a
|
||||
Just a `isJustOr` _ = return a
|
||||
Nothing `isJustOr` e = throwError e
|
||||
|
||||
-- | Require that an 'Either' value is 'Right', or throw an exception
|
||||
-- based on the value in the 'Left'.
|
||||
isRightOr :: MonadError e m => Either b a -> (b -> e) -> m a
|
||||
Right a `isRightOr` _ = return a
|
||||
Left b `isRightOr` f = throwError (f b)
|
||||
Left b `isRightOr` f = throwError (f b)
|
||||
|
||||
-- | Require that a 'Validation' value is 'Success', or throw an exception
|
||||
-- based on the value in the 'Failure'.
|
||||
|
159
test/Unit.hs
159
test/Unit.hs
@ -3,13 +3,13 @@
|
||||
-- | Swarm unit tests
|
||||
module Main where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Test.Tasty
|
||||
import Test.Tasty.HUnit
|
||||
import Data.Text (Text)
|
||||
import Test.Tasty
|
||||
import Test.Tasty.HUnit
|
||||
|
||||
import Swarm.Language.Pipeline
|
||||
import Swarm.Language.Pretty
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Language.Pipeline
|
||||
import Swarm.Language.Pretty
|
||||
import Swarm.Language.Syntax
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain tests
|
||||
@ -23,79 +23,82 @@ parser =
|
||||
"Language - pipeline"
|
||||
[ testCase "end semicolon #79" (valid "def a = 41 end def b = a + 1 end def c = b + 2 end")
|
||||
]
|
||||
where
|
||||
valid = flip process ""
|
||||
process :: Text -> Text -> Assertion
|
||||
process code expect = case processTerm code of
|
||||
Left e | e == expect -> pure ()
|
||||
| otherwise -> error $ "Unexpected failure: " <> show e
|
||||
Right _ | expect == "" -> pure ()
|
||||
| otherwise -> error "Unexpected success"
|
||||
where
|
||||
valid = flip process ""
|
||||
process :: Text -> Text -> Assertion
|
||||
process code expect = case processTerm code of
|
||||
Left e
|
||||
| e == expect -> pure ()
|
||||
| otherwise -> error $ "Unexpected failure: " <> show e
|
||||
Right _
|
||||
| expect == "" -> pure ()
|
||||
| otherwise -> error "Unexpected success"
|
||||
|
||||
prettyConst :: TestTree
|
||||
prettyConst =
|
||||
testGroup "Language - pretty"
|
||||
[ testCase "operators #8 - function application unchanged"
|
||||
(
|
||||
equalPretty "f say" $
|
||||
TApp (TVar "f") (TConst Say)
|
||||
)
|
||||
, testCase "operators #8 - double function application unchanged"
|
||||
(
|
||||
equalPretty "f () ()" $
|
||||
TApp (TApp (TVar "f") TUnit) TUnit
|
||||
)
|
||||
, testCase "operators #8 - embrace operator parameter"
|
||||
(
|
||||
equalPretty "f (==)" $
|
||||
TApp (TVar "f") (TConst Eq)
|
||||
)
|
||||
, testCase "operators #8 - unary negation"
|
||||
(
|
||||
equalPretty "-3" $
|
||||
TApp (TConst Neg) (TInt 3)
|
||||
)
|
||||
, testCase "operators #8 - double unary negation"
|
||||
(
|
||||
equalPretty "-(-1)" $
|
||||
TApp (TConst Neg) $ TApp (TConst Neg) (TInt 1)
|
||||
)
|
||||
, testCase "operators #8 - unary negation with strongly fixing binary operator"
|
||||
(
|
||||
equalPretty "-1 ^ (-2)" $
|
||||
TApp (TConst Neg) $ mkOp Exp (TInt 1) $ TApp (TConst Neg) (TInt 2)
|
||||
)
|
||||
, testCase "operators #8 - unary negation with weakly fixing binary operator"
|
||||
(
|
||||
equalPretty "-(1 + -2)" $
|
||||
TApp (TConst Neg) $ mkOp Add (TInt 1) $ TApp (TConst Neg) (TInt 2)
|
||||
)
|
||||
, testCase "operators #8 - simple infix operator"
|
||||
(
|
||||
equalPretty "1 == 2" $
|
||||
mkOp Eq (TInt 1) (TInt 2)
|
||||
)
|
||||
, testCase "operators #8 - infix operator with less fixing inner operator"
|
||||
(
|
||||
equalPretty "1 * (2 + 3)" $
|
||||
mkOp Mul (TInt 1) (mkOp Add (TInt 2) (TInt 3))
|
||||
)
|
||||
, testCase "operators #8 - infix operator with more fixing inner operator"
|
||||
(
|
||||
equalPretty "1 + 2 * 3" $
|
||||
mkOp Add (TInt 1) (mkOp Mul (TInt 2) (TInt 3))
|
||||
)
|
||||
, testCase "operators #8 - infix operator right associativity"
|
||||
(
|
||||
equalPretty "2 ^ 4 ^ 8" $
|
||||
mkOp Exp (TInt 2) (mkOp Exp (TInt 4) (TInt 8))
|
||||
)
|
||||
, testCase "operators #8 - infix operator right associativity not applied to left"
|
||||
(
|
||||
equalPretty "(2 ^ 4) ^ 8" $
|
||||
mkOp Exp (mkOp Exp (TInt 2) (TInt 4)) (TInt 8)
|
||||
)
|
||||
testGroup
|
||||
"Language - pretty"
|
||||
[ testCase
|
||||
"operators #8 - function application unchanged"
|
||||
( equalPretty "f say" $
|
||||
TApp (TVar "f") (TConst Say)
|
||||
)
|
||||
, testCase
|
||||
"operators #8 - double function application unchanged"
|
||||
( equalPretty "f () ()" $
|
||||
TApp (TApp (TVar "f") TUnit) TUnit
|
||||
)
|
||||
, testCase
|
||||
"operators #8 - embrace operator parameter"
|
||||
( equalPretty "f (==)" $
|
||||
TApp (TVar "f") (TConst Eq)
|
||||
)
|
||||
, testCase
|
||||
"operators #8 - unary negation"
|
||||
( equalPretty "-3" $
|
||||
TApp (TConst Neg) (TInt 3)
|
||||
)
|
||||
, testCase
|
||||
"operators #8 - double unary negation"
|
||||
( equalPretty "-(-1)" $
|
||||
TApp (TConst Neg) $ TApp (TConst Neg) (TInt 1)
|
||||
)
|
||||
, testCase
|
||||
"operators #8 - unary negation with strongly fixing binary operator"
|
||||
( equalPretty "-1 ^ (-2)" $
|
||||
TApp (TConst Neg) $ mkOp Exp (TInt 1) $ TApp (TConst Neg) (TInt 2)
|
||||
)
|
||||
, testCase
|
||||
"operators #8 - unary negation with weakly fixing binary operator"
|
||||
( equalPretty "-(1 + -2)" $
|
||||
TApp (TConst Neg) $ mkOp Add (TInt 1) $ TApp (TConst Neg) (TInt 2)
|
||||
)
|
||||
, testCase
|
||||
"operators #8 - simple infix operator"
|
||||
( equalPretty "1 == 2" $
|
||||
mkOp Eq (TInt 1) (TInt 2)
|
||||
)
|
||||
, testCase
|
||||
"operators #8 - infix operator with less fixing inner operator"
|
||||
( equalPretty "1 * (2 + 3)" $
|
||||
mkOp Mul (TInt 1) (mkOp Add (TInt 2) (TInt 3))
|
||||
)
|
||||
, testCase
|
||||
"operators #8 - infix operator with more fixing inner operator"
|
||||
( equalPretty "1 + 2 * 3" $
|
||||
mkOp Add (TInt 1) (mkOp Mul (TInt 2) (TInt 3))
|
||||
)
|
||||
, testCase
|
||||
"operators #8 - infix operator right associativity"
|
||||
( equalPretty "2 ^ 4 ^ 8" $
|
||||
mkOp Exp (TInt 2) (mkOp Exp (TInt 4) (TInt 8))
|
||||
)
|
||||
, testCase
|
||||
"operators #8 - infix operator right associativity not applied to left"
|
||||
( equalPretty "(2 ^ 4) ^ 8" $
|
||||
mkOp Exp (mkOp Exp (TInt 2) (TInt 4)) (TInt 8)
|
||||
)
|
||||
]
|
||||
where
|
||||
equalPretty :: String -> Term -> Assertion
|
||||
equalPretty expected term = assertEqual "" expected . show $ ppr term
|
||||
where
|
||||
equalPretty :: String -> Term -> Assertion
|
||||
equalPretty expected term = assertEqual "" expected . show $ ppr term
|
||||
|
Loading…
Reference in New Issue
Block a user