swarm-game/swarm
1
1
Fork 0
mirror of https://github.com/swarm-game/swarm.git synced 2024-08-16 18:10:23 +03:00
Code Issues Projects Releases Wiki Activity

Reformat the haskell code with fourmolu (#146)

Browse Source 
This PR was generated using `find src/ app/ test/ -name "*.hs" | xargs fourmolu --mode=inplace`.

Fixes #103
This commit is contained in:
Tristan de Cacqueray 2021-10-02 18:40:24 +00:00 committed by GitHub
parent 4d3f3aa12a
commit a23212ae9d
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
36 changed files with 3558 additions and 3364 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
app/Main.hs
View File

@ -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
View 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

51
src/Swarm/App.hs
View File

@ -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.

198
src/Swarm/Game/CEK.hs
View File

@ -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

152
src/Swarm/Game/Display.hs
View File

@ -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
}

462
src/Swarm/Game/Entity.hs
View File

@ -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)]

79
src/Swarm/Game/Exception.hs
View File

@ -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]

125
src/Swarm/Game/Recipe.hs
View File

@ -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

229
src/Swarm/Game/Robot.hs
View File

@ -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

303
src/Swarm/Game/State.hs
View File

@ -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)

528
src/Swarm/Game/Step.hs
View File

File diff suppressed because it is too large Load Diff

45
src/Swarm/Game/Terrain.hs
View File

@ -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)
]

92
src/Swarm/Game/Value.hs
View File

@ -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

150
src/Swarm/Game/World.hs
View File

@ -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)

142
src/Swarm/Game/WorldGen.hs
View File

@ -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

350
src/Swarm/Language/Capability.hs
View File

@ -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.

44
src/Swarm/Language/Context.hs
View File

@ -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

76
src/Swarm/Language/Elaborate.hs
View File

@ -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

109
src/Swarm/Language/LSP.hs
View File

@ -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
]

397
src/Swarm/Language/Parse.hs
View File

@ -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)

42
src/Swarm/Language/Parse/QQ.hs
View File

@ -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

66
src/Swarm/Language/Pipeline.hs
View File

@ -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,

57
src/Swarm/Language/Pipeline/QQ.hs
View File

@ -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.

185
src/Swarm/Language/Pretty.hs
View File

@ -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

535
src/Swarm/Language/Syntax.hs
View File

@ -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

336
src/Swarm/Language/Typecheck.hs
View File

@ -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 ()

191
src/Swarm/Language/Types.hs
View File

@ -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)

149
src/Swarm/TUI/Attr.hs
View File

@ -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

126
src/Swarm/TUI/Border.hs
View File

@ -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

398
src/Swarm/TUI/Controller.hs
View File

@ -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'

120
src/Swarm/TUI/List.hs
View File

@ -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

280
src/Swarm/TUI/Model.hs
View File

@ -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
------------------------------------------------------------
--

60
src/Swarm/TUI/Panel.hs
View File

@ -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)

540
src/Swarm/TUI/View.hs
View File

@ -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

105
src/Swarm/Util.hs
View File

@ -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
View File

@ -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