diff --git a/app/Main.hs b/app/Main.hs index 8d6c14fb..a2743326 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,15 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} + module Main where -import Data.Text ( Text - , pack - ) -import qualified Data.Text.IO as Text -import Options.Applicative -import Swarm.App ( appMain ) -import Swarm.Language.LSP ( lspMain ) -import Swarm.Language.Pipeline ( processTerm ) -import System.Exit +import Data.Text ( + Text, + pack, + ) +import qualified Data.Text.IO as Text +import Options.Applicative +import Swarm.App (appMain) +import Swarm.Language.LSP (lspMain) +import Swarm.Language.Pipeline (processTerm) +import System.Exit data CLI = Run @@ -19,11 +21,12 @@ data CLI cliParser :: Parser CLI cliParser = subparser - ( command "format" (info format (progDesc "Format a file")) - <> command "lsp" (info (pure LSP) (progDesc "Start the LSP")) - ) + ( command "format" (info format (progDesc "Format a file")) + <> command "lsp" (info (pure LSP) (progDesc "Start the LSP")) + ) <|> pure Run - where format = Format <$> strArgument (metavar "FILE") + where + format = Format <$> strArgument (metavar "FILE") cliInfo :: ParserInfo CLI cliInfo = info (cliParser <**> helper) (fullDesc <> header "Swarm game") @@ -43,6 +46,6 @@ main :: IO () main = do cli <- execParser cliInfo case cli of - Run -> appMain + Run -> appMain Format fp -> formatFile fp =<< Text.readFile fp - LSP -> lspMain + LSP -> lspMain diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 00000000..f75f5813 --- /dev/null +++ b/fourmolu.yaml @@ -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 diff --git a/src/Swarm/App.hs b/src/Swarm/App.hs index 76d07a9d..fa7e1b50 100644 --- a/src/Swarm/App.hs +++ b/src/Swarm/App.hs @@ -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. diff --git a/src/Swarm/Game/CEK.hs b/src/Swarm/Game/CEK.hs index c0168178..c75c9e8e 100644 --- a/src/Swarm/Game/CEK.hs +++ b/src/Swarm/Game/CEK.hs @@ -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{} = "_ ∪ " -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 {} = "_ ∪ " +prettyFrame FLoadEnv {} = "loadEnv" +prettyFrame FExec = "exec _" +prettyFrame (FBind Nothing t _) = "_ ; " ++ prettyString t prettyFrame (FBind (Just x) t _) = from x ++ " <- _ ; " ++ prettyString t diff --git a/src/Swarm/Game/Display.hs b/src/Swarm/Game/Display.hs index c6cb1e3e..4cf9afac 100644 --- a/src/Swarm/Game/Display.hs +++ b/src/Swarm/Game/Display.hs @@ -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 + } diff --git a/src/Swarm/Game/Entity.hs b/src/Swarm/Game/Entity.hs index d12e439b..a09db9fb 100644 --- a/src/Swarm/Game/Entity.hs +++ b/src/Swarm/Game/Entity.hs @@ -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)] diff --git a/src/Swarm/Game/Exception.hs b/src/Swarm/Game/Exception.hs index e2a3d1c8..b54e65f6 100644 --- a/src/Swarm/Game/Exception.hs +++ b/src/Swarm/Game/Exception.hs @@ -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] diff --git a/src/Swarm/Game/Recipe.hs b/src/Swarm/Game/Recipe.hs index f2751469..ec5686bb 100644 --- a/src/Swarm/Game/Recipe.hs +++ b/src/Swarm/Game/Recipe.hs @@ -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 diff --git a/src/Swarm/Game/Robot.hs b/src/Swarm/Game/Robot.hs index c169d717..a8c43246 100644 --- a/src/Swarm/Game/Robot.hs +++ b/src/Swarm/Game/Robot.hs @@ -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 diff --git a/src/Swarm/Game/State.hs b/src/Swarm/Game/State.hs index 6583d6f1..ca30ae1c 100644 --- a/src/Swarm/Game/State.hs +++ b/src/Swarm/Game/State.hs @@ -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) diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index daaea6af..a36c9175 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -1,4 +1,14 @@ ----------------------------------------------------------------------------- +----------------------------------------------------------------------------- +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + -- | -- Module : Swarm.Game.Step -- Copyright : Brent Yorgey @@ -8,54 +18,42 @@ -- -- Facilities for stepping the robot CEK machines, /i.e./ the actual -- interpreter for the Swarm language. --- ------------------------------------------------------------------------------ - -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - module Swarm.Game.Step where -import Control.Arrow ((***)) -import Control.Lens hiding (Const, from, parts) -import Control.Monad.Except -import Control.Monad.State -import Data.Bool (bool) -import Data.Either (rights) -import Data.Int (Int64) -import Data.List (find) -import qualified Data.Map as M -import Data.Maybe (isNothing, listToMaybe, mapMaybe) -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import Linear -import Prelude hiding (lookup) -import System.Random (randomRIO) -import Witch +import Control.Arrow ((***)) +import Control.Lens hiding (Const, from, parts) +import Control.Monad.Except +import Control.Monad.State +import Data.Bool (bool) +import Data.Either (rights) +import Data.Int (Int64) +import Data.List (find) +import qualified Data.Map as M +import Data.Maybe (isNothing, listToMaybe, mapMaybe) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import Linear +import System.Random (randomRIO) +import Witch +import Prelude hiding (lookup) -import Swarm.Game.CEK -import Swarm.Game.Display -import Swarm.Game.Entity hiding (empty, lookup, singleton) -import qualified Swarm.Game.Entity as E -import Swarm.Game.Exception -import Swarm.Game.Recipe -import Swarm.Game.Robot -import Swarm.Game.State -import Swarm.Game.Value -import qualified Swarm.Game.World as W -import Swarm.Language.Capability -import Swarm.Language.Context -import Swarm.Language.Pipeline -import Swarm.Language.Pipeline.QQ (tmQ) -import Swarm.Language.Syntax -import Swarm.Util +import Swarm.Game.CEK +import Swarm.Game.Display +import Swarm.Game.Entity hiding (empty, lookup, singleton) +import qualified Swarm.Game.Entity as E +import Swarm.Game.Exception +import Swarm.Game.Recipe +import Swarm.Game.Robot +import Swarm.Game.State +import Swarm.Game.Value +import qualified Swarm.Game.World as W +import Swarm.Language.Capability +import Swarm.Language.Context +import Swarm.Language.Pipeline +import Swarm.Language.Pipeline.QQ (tmQ) +import Swarm.Language.Syntax +import Swarm.Util -- | The maximum number of CEK machine evaluation steps each robot is -- allowed during a single game tick. @@ -88,18 +86,18 @@ gameTick = do Just curRobot -> do curRobot' <- tickRobot curRobot case curRobot' ^. selfDestruct of - True -> robotMap %= M.delete rn + True -> robotMap %= M.delete rn False -> robotMap %= M.insert rn curRobot' -- See if the base is finished with a computation, and if so, record -- the result in the game state so it can be displayed by the REPL. mr <- use (robotMap . at "base") case mr of - Just r -> do + Just r -> do res <- use replStatus case res of REPLWorking ty Nothing -> replStatus .= REPLWorking ty (getResult r) - _otherREPLStatus -> return () + _otherREPLStatus -> return () Nothing -> return () -- Possibly update the view center. @@ -127,9 +125,11 @@ entityAt :: MonadState GameState m => V2 Int64 -> ExceptT Exn (StateT Robot m) ( entityAt loc = lift . lift $ zoomWorld (W.lookupEntityM (W.locToCoords loc)) -- | Modify the entity (if any) at a given location. -updateEntityAt - :: MonadState GameState m - => V2 Int64 -> (Maybe Entity -> Maybe Entity) -> ExceptT Exn (StateT Robot m) () +updateEntityAt :: + MonadState GameState m => + V2 Int64 -> + (Maybe Entity -> Maybe Entity) -> + ExceptT Exn (StateT Robot m) () updateEntityAt loc upd = lift . lift $ zoomWorld (W.updateM (W.locToCoords loc) upd) -- | Get the robot with a given name (if any). @@ -153,15 +153,15 @@ ensureCanExecute c = do sys <- use systemRobot robotCaps <- use robotCapabilities let missingCaps = constCaps c `S.difference` robotCaps - (sys || mode == Creative || S.null missingCaps) `holdsOr` - Incapable missingCaps (TConst c) + (sys || mode == Creative || S.null missingCaps) + `holdsOr` Incapable missingCaps (TConst c) -- | Ensure that either a robot has a given capability, OR we are in creative -- mode. hasCapabilityOr :: MonadState GameState m => Capability -> Exn -> ExceptT Exn (StateT Robot m) () hasCapabilityOr cap exn = do mode <- lift . lift $ use gameMode - sys <- use systemRobot + sys <- use systemRobot caps <- use robotCapabilities (sys || mode == Creative || cap `S.member` caps) `holdsOr` exn @@ -181,7 +181,7 @@ withExceptions k m = do res <- runExceptT m case res of Left exn -> return $ Up exn k - Right a -> return a + Right a -> return a ------------------------------------------------------------ -- Stepping robots @@ -200,7 +200,7 @@ tickRobot = tickRobotRec . (tickSteps .~ evalStepsPerTick) tickRobotRec :: (MonadState GameState m, MonadIO m) => Robot -> m Robot tickRobotRec r | not (isActive r) || r ^. tickSteps <= 0 = return r - | otherwise = stepRobot r >>= tickRobotRec + | otherwise = stepRobot r >>= tickRobotRec -- | Single-step a robot by decrementing its 'tickSteps' counter and -- running its CEK machine for one step. @@ -229,65 +229,59 @@ stepCEK cek = case cek of -- First some straightforward cases. These all immediately turn -- into values. - In TUnit _ k -> return $ Out VUnit k - In (TDir d) _ k -> return $ Out (VDir d) k - In (TInt n) _ k -> return $ Out (VInt n) k - In (TString s) _ k -> return $ Out (VString s) k - In (TBool b) _ k -> return $ Out (VBool b) k - + In TUnit _ k -> return $ Out VUnit k + In (TDir d) _ k -> return $ Out (VDir d) k + In (TInt n) _ k -> return $ Out (VInt n) k + In (TString s) _ k -> return $ Out (VString s) k + In (TBool b) _ k -> return $ Out (VBool b) k -- There should not be any antiquoted variables left at this point. - In (TAntiString v) _ k -> + In (TAntiString v) _ k -> return $ Up (Fatal (T.append "Antiquoted variable found at runtime: $str:" v)) k - In (TAntiInt v) _ k -> + In (TAntiInt v) _ k -> return $ Up (Fatal (T.append "Antiquoted variable found at runtime: $int:" v)) k - -- A constant is turned into a VCApp which might be waiting for arguments. - In (TConst c) _ k -> return $ Out (VCApp c []) k - + In (TConst c) _ k -> return $ Out (VCApp c []) k -- To evaluate a variable, just look it up in the context. - In (TVar x) e k -> withExceptions k $ do - v <- lookup x e `isJustOr` - Fatal (T.unwords ["Undefined variable", x, "encountered while running the interpreter."]) + In (TVar x) e k -> withExceptions k $ do + v <- + lookup x e + `isJustOr` Fatal (T.unwords ["Undefined variable", x, "encountered while running the interpreter."]) return $ Out v k -- To evaluate a pair, start evaluating the first component. - In (TPair t1 t2) e k -> return $ In t1 e (FSnd t2 e : k) + In (TPair t1 t2) e k -> return $ In t1 e (FSnd t2 e : k) -- Once that's done, evaluate the second component. - Out v1 (FSnd t2 e : k) -> return $ In t2 e (FFst v1 : k) + Out v1 (FSnd t2 e : k) -> return $ In t2 e (FFst v1 : k) -- Finally, put the results together into a pair value. - Out v2 (FFst v1 : k) -> return $ Out (VPair v1 v2) k - + Out v2 (FFst v1 : k) -> return $ Out (VPair v1 v2) k -- Lambdas immediately turn into closures. - In (TLam x _ t) e k -> return $ Out (VClo x t e) k - + In (TLam x _ t) e k -> return $ Out (VClo x t e) k -- To evaluate an application, start by focusing on the left-hand -- side and saving the argument for later. - In (TApp t1 t2) e k -> return $ In t1 e (FArg t2 e : k) + In (TApp t1 t2) e k -> return $ In t1 e (FArg t2 e : k) -- Once that's done, switch to evaluating the argument. - Out v1 (FArg t2 e : k) -> return $ In t2 e (FApp v1 : k) + Out v1 (FArg t2 e : k) -> return $ In t2 e (FApp v1 : k) -- We can evaluate an application of a closure in the usual way. - Out v2 (FApp (VClo x t e) : k) -> return $ In t (addBinding x v2 e) k + Out v2 (FApp (VClo x t e) : k) -> return $ In t (addBinding x v2 e) k -- We can also evaluate an application of a constant by collecting -- arguments, eventually dispatching to evalConst for function -- constants. Out v2 (FApp (VCApp c args) : k) - | not (isCmd c) && - arity c == length args + 1 -> evalConst c (reverse (v2 : args)) k - | otherwise -> return $ Out (VCApp c (v2 : args)) k + | not (isCmd c) + && arity c == length args + 1 -> + evalConst c (reverse (v2 : args)) k + | otherwise -> return $ Out (VCApp c (v2 : args)) k Out _ (FApp _ : _) -> badMachineState "FApp of non-function" - -- To evaluate let expressions, we start by focusing on the -- let-bound expression. Since it can be recursive, we wrap it in -- @VDelay@ (the elaboration step wrapped all recursive references -- in a corresponding @Force@). - In (TLet x _ t1 t2) e k -> + In (TLet x _ t1 t2) e k -> let e' = addBinding x (VDelay (Just x) t1 e) e - in return $ In t1 e' (FLet x t2 e : k) - + in return $ In t1 e' (FLet x t2 e : k) -- Once we've finished with the let-binding, we switch to evaluating -- the body in a suitably extended environment. - Out v1 (FLet x t2 e : k) -> return $ In t2 (addBinding x v1 e) k - + Out v1 (FLet x t2 e : k) -> return $ In t2 (addBinding x v1 e) k -- Definitions immediately turn into VDef values, awaiting execution. In tm@(TDef x _ t) e k -> withExceptions k $ do CEnv `hasCapabilityOr` Incapable (S.singleton CEnv) tm @@ -295,12 +289,10 @@ stepCEK cek = case cek of -- Bind expressions don't evaluate: just package it up as a value -- until such time as it is to be executed. - In (TBind mx t1 t2) e k -> return $ Out (VBind mx t1 t2 e) k - + In (TBind mx t1 t2) e k -> return $ Out (VBind mx t1 t2 e) k -- Delay expressions immediately turn into VDelay values, awaiting -- application of 'Force'. - In (TDelay t) e k -> return $ Out (VDelay Nothing t e) k - + In (TDelay t) e k -> return $ Out (VDelay Nothing t e) k ------------------------------------------------------------ -- Execution @@ -310,22 +302,22 @@ stepCEK cek = case cek of -- return value from the @def@ command itself (@unit@) together with -- the resulting environment (the variable bound to the delayed -- value). - Out (VDef x t e) (FExec : k) -> do + Out (VDef x t e) (FExec : k) -> do return $ Out (VResult VUnit (singleton x (VDelay (Just x) t e))) k -- To execute a constant application, delegate to the 'execConst' -- function. Set tickSteps to 0 if the command is supposed to take -- a tick, so the robot won't take any more steps this tick. - Out (VCApp c args) (FExec : k) -> do + Out (VCApp c args) (FExec : k) -> do when (takesTick c) $ tickSteps .= 0 res <- runExceptT (execConst c (reverse args) k) case res of - Left exn -> return $ Up exn k + Left exn -> return $ Up exn k Right cek' -> return cek' -- To execute a bind expression, evaluate and execute the first -- command, and remember the second for execution later. - Out (VBind mx c1 c2 e) (FExec : k) -> return $ In c1 e (FExec : FBind mx c2 e : k) + Out (VBind mx c1 c2 e) (FExec : k) -> return $ In c1 e (FExec : FBind mx c2 e : k) -- If first command completes with a value along with an environment -- resulting from definition commands, switch to evaluating the -- second command of the bind. Extend the environment with both the @@ -349,34 +341,29 @@ stepCEK cek = case cek of Out (VResult v e2) (FUnionEnv e1 : k) -> return $ Out (VResult v (e1 `union` e2)) k -- Or, if a command completes with no environment, but there is a -- previous environment to union with, just use that environment. - Out v (FUnionEnv e : k) -> return $ Out (VResult v e) k - + Out v (FUnionEnv e : k) -> return $ Out (VResult v e) k -- If the top of the continuation stack contains a 'FLoadEnv' frame, -- it means we are supposed to load up the resulting definition -- environment and type and capability contexts into the robot's -- top-level environment and contexts, so they will be available to -- future programs. - Out (VResult v e) (FLoadEnv ctx cctx : k) -> do + Out (VResult v e) (FLoadEnv ctx cctx : k) -> do robotEnv %= (`union` e) robotCtx %= ((`union` ctx) *** (`union` cctx)) return $ Out v k - Out v (FLoadEnv{} : k) -> return $ Out v k - + Out v (FLoadEnv {} : k) -> return $ Out v k -- Any other type of value wiwth an FExec frame is an error (should -- never happen). Out _ (FExec : _) -> badMachineState "FExec frame with non-executable value" - -- Any other frame with a VResult is an error (should never happen). Out (VResult _ _) _ -> badMachineState "no appropriate stack frame to catch a VResult" - ------------------------------------------------------------ -- Exception handling ------------------------------------------------------------ -- First, if we were running a try block but evaluation completed normally, -- just ignore the try block and continue. - Out v (FTry _ : k) -> return $ Out v k - + Out v (FTry _ : k) -> return $ Out v k -- If an exception rises all the way to the top level without being -- handled, turn it into an error message via the 'say' command. -- Note that (for now at least) the 'say' command requires no @@ -392,32 +379,28 @@ stepCEK cek = case cek of -- logging! Otherwise trying to exceute the Log command will -- generate another exception, which will be logged, which will -- generate an exception, ... etc. - Up exn [] -> return $ In (TApp (TConst Say) (TString (formatExn exn))) empty [FExec] - + Up exn [] -> return $ In (TApp (TConst Say) (TString (formatExn exn))) empty [FExec] -- Fatal errors and capability errors can't be caught; just throw -- away the continuation stack. - Up exn@Fatal{} _ -> return $ Up exn [] - Up exn@Incapable{} _ -> return $ Up exn [] - + Up exn@Fatal {} _ -> return $ Up exn [] + Up exn@Incapable {} _ -> return $ Up exn [] -- Otherwise, if we are raising an exception up the continuation -- stack and come to a Try frame, execute the associated catch -- block. - Up _ (FTry c : k ) -> return $ Out c (FExec : k) - + Up _ (FTry c : k) -> return $ Out c (FExec : k) -- Otherwise, keep popping from the continuation stack. - Up exn (_ : k) -> return $ Up exn k - + Up exn (_ : k) -> return $ Up exn k -- Finally, if we're done evaluating and the continuation stack is -- empty, return the machine unchanged. - done@(Out _ []) -> return done - - where - badMachineState msg = - let msg' = T.unlines + done@(Out _ []) -> return done + where + badMachineState msg = + let msg' = + T.unlines [ T.append "Bad machine state in stepRobot: " msg , from (prettyCEK cek) ] - in return $ Up (Fatal msg') [] + in return $ Up (Fatal msg') [] -- | Determine whether a constant should take up a tick or not when executed. takesTick :: Const -> Bool @@ -434,20 +417,22 @@ evalConst :: (MonadState GameState m, MonadIO m) => Const -> [Value] -> Cont -> evalConst c vs k = do res <- runExceptT $ execConst c vs k case res of - Left exn@Fatal{} -> return $ Up exn k - Left exn@Incapable{} -> return $ Up exn k + Left exn@Fatal {} -> return $ Up exn k + Left exn@Incapable {} -> return $ Up exn k Left exn -> do - let msg = T.unlines - [ "evalConst shouldn't be able to throw this kind of exception:" - , formatExn exn - ] + let msg = + T.unlines + [ "evalConst shouldn't be able to throw this kind of exception:" + , formatExn exn + ] return $ Up (Fatal msg) k Right cek' -> return cek' -- | A system program for a "seed robot", to regrow a growable entity -- after it is harvested. seedProgram :: Integer -> Integer -> Text -> ProcessedTerm -seedProgram minTime randTime thing = [tmQ| +seedProgram minTime randTime thing = + [tmQ| let repeat : int -> cmd () -> cmd () = \n.\c. if (n == 0) {} {c ; repeat (n-1) c} in { @@ -464,23 +449,21 @@ seedProgram minTime randTime thing = [tmQ| -- | Interpret the execution (or evaluation) of a constant application -- to some values. execConst :: (MonadState GameState m, MonadIO m) => Const -> [Value] -> Cont -> ExceptT Exn (StateT Robot m) CEK - execConst c vs k = do -- First, ensure the robot is capable of executing/evaluating this constant. ensureCanExecute c -- Now proceed to actually carry out the operation. case c of - Noop -> return $ Out VUnit k + Noop -> return $ Out VUnit k Return -> case vs of [v] -> return $ Out v k - _ -> badConst + _ -> badConst Wait -> return $ Out VUnit k Selfdestruct -> do selfDestruct .= True flagRedraw return $ Out VUnit k - Move -> do loc <- use robotLocation orient <- use robotOrientation @@ -491,8 +474,8 @@ execConst c vs k = do case me of Nothing -> return () Just e -> do - (not . (`hasProperty` Unwalkable)) e `holdsOr` - cmdExn Move ["There is a", e ^. entityName, "in the way!"] + (not . (`hasProperty` Unwalkable)) e + `holdsOr` cmdExn Move ["There is a", e ^. entityName, "in the way!"] -- Robots drown if they walk over liquid caps <- use robotCapabilities @@ -502,16 +485,14 @@ execConst c vs k = do robotLocation .= nextLoc flagRedraw return $ Out VUnit k - Grab -> do - -- Ensure there is an entity here. loc <- use robotLocation e <- entityAt loc >>= (`isJustOr` cmdExn Grab ["There is nothing here to grab."]) -- Ensure it can be picked up. - (e `hasProperty` Portable) `holdsOr` - cmdExn Grab ["The", e ^. entityName, "here can't be grabbed."] + (e `hasProperty` Portable) + `holdsOr` cmdExn Grab ["The", e ^. entityName, "here can't be grabbed."] -- Remove the entity from the world. updateEntityAt loc (const Nothing) @@ -519,24 +500,25 @@ execConst c vs k = do -- Possibly regrow the entity. when (e `hasProperty` Growable) $ do - let GrowthTime (minT, maxT) = (e ^. entityGrowth) ? defaultGrowthTime case maxT of -- Special case: if the growth time is zero, just add the -- entity back immediately. 0 -> updateEntityAt loc (const (Just e)) - -- Otherwise, grow a new entity from a seed. _ -> do let seedBot = - mkRobot "seed" loc (V2 0 0) + mkRobot + "seed" + loc + (V2 0 0) (initMachine (seedProgram minT (maxT - minT) (e ^. entityName)) empty) [] - & robotDisplay .~ - (defaultEntityDisplay '.' & displayAttr .~ (e ^. entityDisplay . displayAttr)) - & robotInventory .~ E.singleton e - & systemRobot .~ True + & robotDisplay + .~ (defaultEntityDisplay '.' & displayAttr .~ (e ^. entityDisplay . displayAttr)) + & robotInventory .~ E.singleton e + & systemRobot .~ True _ <- lift . lift $ addRobot seedBot return () @@ -545,13 +527,12 @@ execConst c vs k = do let yieldName = e ^. entityYields e' <- case yieldName of Nothing -> return e - Just n -> (?e) <$> (lift . lift $ uses entityMap (lookupEntityName n)) + Just n -> (?e) <$> (lift . lift $ uses entityMap (lookupEntityName n)) robotInventory %= insert e' -- Return the name of the item grabbed. return $ Out (VString (e ^. entityName)) k - Turn -> case vs of [VDir d] -> do -- "treads" `isInstalledOr` cmdExn Turn ["You need treads to turn."] @@ -560,7 +541,6 @@ execConst c vs k = do flagRedraw return $ Out VUnit k _ -> badConst - Place -> case vs of [VString s] -> do inv <- use robotInventory @@ -571,8 +551,9 @@ execConst c vs k = do nothingHere `holdsOr` cmdExn Place ["There is already an entity here."] -- Make sure the robot has the thing in its inventory - e <- listToMaybe (lookupByName s inv) `isJustOr` - cmdExn Place ["You don't have", indefinite s, "to place."] + e <- + listToMaybe (lookupByName s inv) + `isJustOr` cmdExn Place ["You don't have", indefinite s, "to place."] -- Place the entity and remove it from the inventory updateEntityAt loc (const (Just e)) @@ -580,25 +561,24 @@ execConst c vs k = do flagRedraw return $ Out VUnit k - _ -> badConst - Give -> case vs of [VString otherName, VString itemName] -> do - -- Make sure the other robot exists - other <- robotNamed otherName >>= - (`isJustOr` cmdExn Give ["There is no robot named", otherName, "."]) + other <- + robotNamed otherName + >>= (`isJustOr` cmdExn Give ["There is no robot named", otherName, "."]) -- Make sure it is in the same location loc <- use robotLocation - ((other ^. robotLocation) `manhattan` loc <= 1) `holdsOr` - cmdExn Give ["The robot named", otherName, "is not close enough."] + ((other ^. robotLocation) `manhattan` loc <= 1) + `holdsOr` cmdExn Give ["The robot named", otherName, "is not close enough."] -- Make sure we have the required item inv <- use robotInventory - item <- (listToMaybe . lookupByName itemName $ inv) `isJustOr` - cmdExn Give ["You don't have", indefinite itemName, "to give." ] + item <- + (listToMaybe . lookupByName itemName $ inv) + `isJustOr` cmdExn Give ["You don't have", indefinite itemName, "to give."] -- Giving something to ourself should be a no-op. We need -- this as a special case since it will not work to modify @@ -609,7 +589,6 @@ execConst c vs k = do myName <- use robotName focusedName <- lift . lift $ use focusedRobotName when (otherName /= myName) $ do - -- Make the exchange lift . lift $ robotMap . at otherName . _Just . robotInventory %= insert item robotInventory %= delete item @@ -618,34 +597,31 @@ execConst c vs k = do when (focusedName == myName || focusedName == otherName) flagRedraw return $ Out VUnit k - _ -> badConst - Install -> case vs of [VString otherName, VString itemName] -> do - -- Make sure the other robot exists - other <- robotNamed otherName >>= - (`isJustOr` cmdExn Install ["There is no robot named", otherName, "."]) + other <- + robotNamed otherName + >>= (`isJustOr` cmdExn Install ["There is no robot named", otherName, "."]) -- Make sure it is in the same location loc <- use robotLocation - ((other ^. robotLocation) `manhattan` loc <= 1) `holdsOr` - cmdExn Install ["The robot named", otherName, "is not close enough."] + ((other ^. robotLocation) `manhattan` loc <= 1) + `holdsOr` cmdExn Install ["The robot named", otherName, "is not close enough."] -- Make sure we have the required item inv <- use robotInventory - item <- (listToMaybe . lookupByName itemName $ inv) `isJustOr` - cmdExn Install ["You don't have", indefinite itemName, "to install." ] + item <- + (listToMaybe . lookupByName itemName $ inv) + `isJustOr` cmdExn Install ["You don't have", indefinite itemName, "to install."] myName <- use robotName focusedName <- lift . lift $ use focusedRobotName case otherName == myName of - -- We have to special case installing something on ourselves -- for the same reason as Give. True -> do - -- Don't do anything if the robot already has the device. already <- use (installedDevices . to (`E.contains` item)) unless already $ do @@ -654,7 +630,6 @@ execConst c vs k = do -- Flag the UI for a redraw if we are currently showing our inventory when (focusedName == myName) flagRedraw - False -> do let otherDevices = robotMap . at otherName . _Just . installedDevices already <- lift . lift $ preuse (otherDevices . to (`E.contains` item)) @@ -667,15 +642,14 @@ execConst c vs k = do when (focusedName == myName || focusedName == otherName) flagRedraw return $ Out VUnit k - _ -> badConst - Make -> case vs of [VString name] -> do inv <- use robotInventory em <- lift . lift $ use entityMap - e <- lookupEntityName name em `isJustOr` - cmdExn Make ["I've never heard of", indefiniteQ name, "."] + e <- + lookupEntityName name em + `isJustOr` cmdExn Make ["I've never heard of", indefiniteQ name, "."] outRs <- lift . lift $ use recipesOut @@ -684,20 +658,19 @@ execConst c vs k = do -- silly things like making copper pipes when the user says "make furnace". let recipes = filter increase (recipesFor outRs e) increase (Recipe ins outs) = countIn outs > countIn ins - countIn xs = maybe 0 fst (find ((==e) . snd) xs) - not (null recipes) `holdsOr` - cmdExn Make ["There is no known recipe for making", indefinite name, "."] + countIn xs = maybe 0 fst (find ((== e) . snd) xs) + not (null recipes) + `holdsOr` cmdExn Make ["There is no known recipe for making", indefinite name, "."] -- Now try each recipe and take the first one that we have the -- ingredients for. - inv' <- listToMaybe (rights (map (make inv) recipes)) `isJustOr` - cmdExn Make ["You don't have the ingredients to make", indefinite name, "."] + inv' <- + listToMaybe (rights (map (make inv) recipes)) + `isJustOr` cmdExn Make ["You don't have the ingredients to make", indefinite name, "."] robotInventory .= inv' return $ Out VUnit k - _ -> badConst - GetX -> do V2 x _ <- use robotLocation return $ Out (VInt (fromIntegral x)) k @@ -710,7 +683,6 @@ execConst c vs k = do let nextLoc = loc ^+^ (orient ? zero) me <- entityAt nextLoc return $ Out (VBool (maybe False (`hasProperty` Unwalkable) me)) k - Scan -> case vs of [VDir d] -> do loc <- use robotLocation @@ -719,49 +691,45 @@ execConst c vs k = do me <- entityAt scanLoc case me of Nothing -> return () - Just e -> robotInventory %= insertCount 0 e + Just e -> robotInventory %= insertCount 0 e return $ Out VUnit k _ -> badConst - Upload -> case vs of [VString otherName] -> do - -- Make sure the other robot exists - other <- robotNamed otherName >>= - (`isJustOr` cmdExn Upload ["There is no robot named", otherName, "."]) + other <- + robotNamed otherName + >>= (`isJustOr` cmdExn Upload ["There is no robot named", otherName, "."]) -- Make sure it is in the same location loc <- use robotLocation - ((other ^. robotLocation) `manhattan` loc <= 1) `holdsOr` - cmdExn Upload ["The robot named", otherName, "is not close enough."] + ((other ^. robotLocation) `manhattan` loc <= 1) + `holdsOr` cmdExn Upload ["The robot named", otherName, "is not close enough."] -- Upload knowledge of everything in our inventory inv <- use robotInventory - forM_ (elems inv) $ \(_,e) -> + forM_ (elems inv) $ \(_, e) -> lift . lift $ robotMap . at otherName . _Just . robotInventory %= insertCount 0 e return $ Out VUnit k - _ -> badConst - Random -> case vs of [VInt hi] -> do - n <- randomRIO (0, hi-1) + n <- randomRIO (0, hi -1) return $ Out (VInt n) k _ -> badConst - Say -> case vs of [VString s] -> do rn <- use robotName lift . lift $ emitMessage (T.concat [rn, ": ", s]) return $ Out VUnit k _ -> badConst - View -> case vs of [VString s] -> do - _ <- robotNamed s >>= - (`isJustOr` cmdExn View [ "There is no robot named ", s, " to view." ]) + _ <- + robotNamed s + >>= (`isJustOr` cmdExn View ["There is no robot named ", s, " to view."]) -- Only the base can actually change the view in the UI. Other robots can -- execute this command but it does nothing (at least for now). @@ -771,7 +739,6 @@ execConst c vs k = do return $ Out VUnit k _ -> badConst - Appear -> case vs of [VString s] -> do flagRedraw @@ -780,76 +747,64 @@ execConst c vs k = do robotDisplay . defaultChar .= dc robotDisplay . orientationMap .= M.empty return $ Out VUnit k - - [dc,nc,ec,sc,wc] -> do + [dc, nc, ec, sc, wc] -> do robotDisplay . defaultChar .= dc robotDisplay . orientationMap . ix North .= nc - robotDisplay . orientationMap . ix East .= ec + robotDisplay . orientationMap . ix East .= ec robotDisplay . orientationMap . ix South .= sc - robotDisplay . orientationMap . ix West .= wc + robotDisplay . orientationMap . ix West .= wc return $ Out VUnit k - _other -> raise Appear [quote s, "is not a valid appearance string."] - _ -> badConst - Create -> case vs of [VString name] -> do em <- lift . lift $ use entityMap - e <- lookupEntityName name em `isJustOr` - cmdExn Create ["I've never heard of", indefiniteQ name, "."] + e <- + lookupEntityName name em + `isJustOr` cmdExn Create ["I've never heard of", indefiniteQ name, "."] robotInventory %= insert e return $ Out VUnit k _ -> badConst - Ishere -> case vs of [VString s] -> do loc <- use robotLocation me <- entityAt loc case me of Nothing -> return $ Out (VBool False) k - Just e -> return $ Out (VBool (T.toLower (e ^. entityName) == T.toLower s)) k + Just e -> return $ Out (VBool (T.toLower (e ^. entityName) == T.toLower s)) k _ -> badConst - - Force -> case vs of - [VDelay Nothing t e] -> return $ In t e k + [VDelay Nothing t e] -> return $ In t e k [VDelay (Just x) t e] -> return $ In t (addBinding x (VDelay (Just x) t e) e) k - _ -> badConst - + _ -> badConst -- Note, if should evaluate the branches lazily, but since -- evaluation is eager, by the time we get here thn and els have -- already been fully evaluated --- what gives? The answer is that -- we rely on elaboration to add 'lazy' wrappers around the branches -- (and a 'force' wrapper around the entire if). If -> case vs of - [VBool b , thn, els] -> return $ Out (bool els thn b) k - _ -> badConst - + [VBool b, thn, els] -> return $ Out (bool els thn b) k + _ -> badConst Fst -> case vs of [VPair v _] -> return $ Out v k - _ -> badConst + _ -> badConst Snd -> case vs of [VPair _ v] -> return $ Out v k - _ -> badConst - + _ -> badConst Try -> case vs of [c1, c2] -> return $ Out c1 (FExec : FTry c2 : k) - _ -> badConst - + _ -> badConst Raise -> case vs of [VString s] -> return $ Up (User s) k - _ -> badConst - + _ -> badConst Build -> case vs of [VString name, VDelay _ cmd e] -> do r <- get em <- lift . lift $ use entityMap mode <- lift . lift $ use gameMode - let - -- Standard devices that are always installed. + let -- Standard devices that are always installed. -- XXX in the future, make a way to build these and just start the base -- out with a large supply of each? stdDeviceList = ["treads", "grabber", "solar panel", "detonator", "scanner"] @@ -878,8 +833,9 @@ execConst c vs k = do missingDevices = S.filter (not . deviceOK) capDevices -- Make sure we're not missing any required devices. - (mode == Creative || S.null missingDevices) `holdsOr` - cmdExn Build + (mode == Creative || S.null missingDevices) + `holdsOr` cmdExn + Build [ "this would require installing devices you don't have:\n" , commaList (map (^. entityName) (S.toList missingDevices)) ] @@ -905,93 +861,87 @@ execConst c vs k = do -- Flag the world for a redraw and return the name of the newly constructed robot. flagRedraw return $ Out (VString (newRobot' ^. robotName)) k - _ -> badConst - Run -> case vs of [VString fileName] -> do mf <- liftIO $ readFileMay (into fileName) f <- mf `isJustOr` cmdExn Run ["File not found:", fileName] - t <- processTerm (into @Text f)`isRightOr` \err -> - cmdExn Run ["Error in", fileName, "\n", err] + t <- + processTerm (into @Text f) `isRightOr` \err -> + cmdExn Run ["Error in", fileName, "\n", err] return $ initMachine' t empty k - _ -> badConst - Not -> case vs of [VBool b] -> return $ Out (VBool (not b)) k - _ -> badConst - + _ -> badConst Neg -> case vs of - [VInt n] -> return $ Out (VInt (-n)) k - _ -> badConst - - Eq -> returnEvalCmp + [VInt n] -> return $ Out (VInt (- n)) k + _ -> badConst + Eq -> returnEvalCmp Neq -> returnEvalCmp - Lt -> returnEvalCmp - Gt -> returnEvalCmp + Lt -> returnEvalCmp + Gt -> returnEvalCmp Leq -> returnEvalCmp Geq -> returnEvalCmp - Add -> returnEvalArith Sub -> returnEvalArith Mul -> returnEvalArith Div -> returnEvalArith Exp -> returnEvalArith - - where - badConst = throwError $ Fatal $ - T.unlines - [ "Bad application of execConst:" - , from (prettyCEK (Out (VCApp c vs) k)) - ] - returnEvalCmp = case vs of - [v1, v2] -> - case evalCmp c v1 v2 of - Nothing -> return $ Out (VBool False) k - Just b -> return $ Out (VBool b) k - _ -> badConst - returnEvalArith = case vs of - [VInt n1, VInt n2] -> return $ Out (VInt $ evalArith c n1 n2) k - _ -> badConst - + where + badConst = + throwError $ + Fatal $ + T.unlines + [ "Bad application of execConst:" + , from (prettyCEK (Out (VCApp c vs) k)) + ] + returnEvalCmp = case vs of + [v1, v2] -> + case evalCmp c v1 v2 of + Nothing -> return $ Out (VBool False) k + Just b -> return $ Out (VBool b) k + _ -> badConst + returnEvalArith = case vs of + [VInt n1, VInt n2] -> return $ Out (VInt $ evalArith c n1 n2) k + _ -> badConst -- | Evaluate the application of a comparison operator. Returns -- @Nothing@ if the application does not make sense. evalCmp :: Const -> Value -> Value -> Maybe Bool evalCmp c v1 v2 = decideCmp c $ compareValues v1 v2 - where + where decideCmp = \case - Eq -> fmap (== EQ) + Eq -> fmap (== EQ) Neq -> fmap (/= EQ) - Lt -> fmap (== LT) - Gt -> fmap (== GT) + Lt -> fmap (== LT) + Gt -> fmap (== GT) Leq -> fmap (/= GT) Geq -> fmap (/= LT) - _ -> const Nothing + _ -> const Nothing -- | Compare two values, returning an 'Ordering' if they can be -- compared, or @Nothing@ if they cannot. compareValues :: Value -> Value -> Maybe Ordering compareValues = \case - VUnit -> \case {VUnit -> Just EQ ; _ -> Nothing} - VInt n1 -> \case {VInt n2 -> Just (compare n1 n2); _ -> Nothing} - VString t1 -> \case {VString t2 -> Just (compare t1 t2); _ -> Nothing} - VDir d1 -> \case {VDir d2 -> Just (compare d1 d2); _ -> Nothing} - VBool b1 -> \case {VBool b2 -> Just (compare b1 b2); _ -> Nothing} - VPair v11 v12 -> \case { VPair v21 v22 - -> (<>) <$> compareValues v11 v21 <*> compareValues v12 v22 - ; _ -> Nothing - } - VClo{} -> const Nothing - VCApp{} -> const Nothing - VDef{} -> const Nothing - VResult{} -> const Nothing - VBind{} -> const Nothing - VDelay{} -> const Nothing + VUnit -> \case VUnit -> Just EQ; _ -> Nothing + VInt n1 -> \case VInt n2 -> Just (compare n1 n2); _ -> Nothing + VString t1 -> \case VString t2 -> Just (compare t1 t2); _ -> Nothing + VDir d1 -> \case VDir d2 -> Just (compare d1 d2); _ -> Nothing + VBool b1 -> \case VBool b2 -> Just (compare b1 b2); _ -> Nothing + VPair v11 v12 -> \case + VPair v21 v22 -> + (<>) <$> compareValues v11 v21 <*> compareValues v12 v22 + _ -> Nothing + VClo {} -> const Nothing + VCApp {} -> const Nothing + VDef {} -> const Nothing + VResult {} -> const Nothing + VBind {} -> const Nothing + VDelay {} -> const Nothing -- | Evaluate the application of an arithmetic operator. Note, we -- want to maintain the invariant that only executing commands can @@ -1004,12 +954,12 @@ compareValues = \case -- huge value. evalArith :: Const -> Integer -> Integer -> Integer evalArith = \case - Add -> (+) - Sub -> (-) - Mul -> (*) - Div -> safeDiv - Exp -> safeExp - _ -> (\_ _ -> 0xbadc0de) + Add -> (+) + Sub -> (-) + Mul -> (*) + Div -> safeDiv + Exp -> safeExp + _ -> (\_ _ -> 0xbadc0de) -- | Perform an integer division, but return 42 for division by zero. safeDiv :: Integer -> Integer -> Integer @@ -1019,5 +969,5 @@ safeDiv a b = a `div` b -- | Perform exponentiation, but return 42 if the power is negative. safeExp :: Integer -> Integer -> Integer safeExp a b - | b < 0 = 42 - | otherwise = a^b + | b < 0 = 42 + | otherwise = a ^ b diff --git a/src/Swarm/Game/Terrain.hs b/src/Swarm/Game/Terrain.hs index 03613b6f..2f55bdb2 100644 --- a/src/Swarm/Game/Terrain.hs +++ b/src/Swarm/Game/Terrain.hs @@ -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) + ] diff --git a/src/Swarm/Game/Value.hs b/src/Swarm/Game/Value.hs index b4640f41..310b4726 100644 --- a/src/Swarm/Game/Value.hs +++ b/src/Swarm/Game/Value.hs @@ -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 diff --git a/src/Swarm/Game/World.hs b/src/Swarm/Game/World.hs index f7b4350b..4fd56b2c 100644 --- a/src/Swarm/Game/World.hs +++ b/src/Swarm/Game/World.hs @@ -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) diff --git a/src/Swarm/Game/WorldGen.hs b/src/Swarm/Game/WorldGen.hs index 29933951..96ea853b 100644 --- a/src/Swarm/Game/WorldGen.hs +++ b/src/Swarm/Game/WorldGen.hs @@ -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 diff --git a/src/Swarm/Language/Capability.hs b/src/Swarm/Language/Capability.hs index 20faa9a4..19c357bd 100644 --- a/src/Swarm/Language/Capability.hs +++ b/src/Swarm/Language/Capability.hs @@ -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. diff --git a/src/Swarm/Language/Context.hs b/src/Swarm/Language/Context.hs index 134e019b..263ad261 100644 --- a/src/Swarm/Language/Context.hs +++ b/src/Swarm/Language/Context.hs @@ -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 diff --git a/src/Swarm/Language/Elaborate.hs b/src/Swarm/Language/Elaborate.hs index 415db887..47f9c8e0 100644 --- a/src/Swarm/Language/Elaborate.hs +++ b/src/Swarm/Language/Elaborate.hs @@ -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 diff --git a/src/Swarm/Language/LSP.hs b/src/Swarm/Language/LSP.hs index 65bca1cd..9e62499e 100644 --- a/src/Swarm/Language/LSP.hs +++ b/src/Swarm/Language/LSP.hs @@ -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 + ] diff --git a/src/Swarm/Language/Parse.hs b/src/Swarm/Language/Parse.hs index 04b54ef3..c09fd64a 100644 --- a/src/Swarm/Language/Parse.hs +++ b/src/Swarm/Language/Parse.hs @@ -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) "" -- : 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) diff --git a/src/Swarm/Language/Parse/QQ.hs b/src/Swarm/Language/Parse/QQ.hs index 03544572..515abd19 100644 --- a/src/Swarm/Language/Parse/QQ.hs +++ b/src/Swarm/Language/Parse/QQ.hs @@ -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 diff --git a/src/Swarm/Language/Pipeline.hs b/src/Swarm/Language/Pipeline.hs index 4c9cff88..5561508a 100644 --- a/src/Swarm/Language/Pipeline.hs +++ b/src/Swarm/Language/Pipeline.hs @@ -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, diff --git a/src/Swarm/Language/Pipeline/QQ.hs b/src/Swarm/Language/Pipeline/QQ.hs index 7377729a..ac71ce8a 100644 --- a/src/Swarm/Language/Pipeline/QQ.hs +++ b/src/Swarm/Language/Pipeline/QQ.hs @@ -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. diff --git a/src/Swarm/Language/Pretty.hs b/src/Swarm/Language/Pretty.hs index affb2e91..6beffdd2 100644 --- a/src/Swarm/Language/Pretty.hs +++ b/src/Swarm/Language/Pretty.hs @@ -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 diff --git a/src/Swarm/Language/Syntax.hs b/src/Swarm/Language/Syntax.hs index 45c85054..99480f81 100644 --- a/src/Swarm/Language/Syntax.hs +++ b/src/Swarm/Language/Syntax.hs @@ -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 diff --git a/src/Swarm/Language/Typecheck.hs b/src/Swarm/Language/Typecheck.hs index d225b53b..c3d27689 100644 --- a/src/Swarm/Language/Typecheck.hs +++ b/src/Swarm/Language/Typecheck.hs @@ -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 () diff --git a/src/Swarm/Language/Types.hs b/src/Swarm/Language/Types.hs index dea599de..43854f38 100644 --- a/src/Swarm/Language/Types.hs +++ b/src/Swarm/Language/Types.hs @@ -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) diff --git a/src/Swarm/TUI/Attr.hs b/src/Swarm/TUI/Attr.hs index 5425195b..65d7e10b 100644 --- a/src/Swarm/TUI/Attr.hs +++ b/src/Swarm/TUI/Attr.hs @@ -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 diff --git a/src/Swarm/TUI/Border.hs b/src/Swarm/TUI/Border.hs index 4a950140..c5f99c24 100644 --- a/src/Swarm/TUI/Border.hs +++ b/src/Swarm/TUI/Border.hs @@ -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 diff --git a/src/Swarm/TUI/Controller.hs b/src/Swarm/TUI/Controller.hs index 811d3063..606f819f 100644 --- a/src/Swarm/TUI/Controller.hs +++ b/src/Swarm/TUI/Controller.hs @@ -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' diff --git a/src/Swarm/TUI/List.hs b/src/Swarm/TUI/List.hs index 06c32fe9..e382c4b5 100644 --- a/src/Swarm/TUI/List.hs +++ b/src/Swarm/TUI/List.hs @@ -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 diff --git a/src/Swarm/TUI/Model.hs b/src/Swarm/TUI/Model.hs index 61de1e02..81573cc4 100644 --- a/src/Swarm/TUI/Model.hs +++ b/src/Swarm/TUI/Model.hs @@ -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 - ------------------------------------------------------------ -- diff --git a/src/Swarm/TUI/Panel.hs b/src/Swarm/TUI/Panel.hs index 388f6cc9..5e7915a9 100644 --- a/src/Swarm/TUI/Panel.hs +++ b/src/Swarm/TUI/Panel.hs @@ -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) diff --git a/src/Swarm/TUI/View.hs b/src/Swarm/TUI/View.hs index 3ebcb632..3d4f0d68 100644 --- a/src/Swarm/TUI/View.hs +++ b/src/Swarm/TUI/View.hs @@ -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 ", "Create a robot") - , ("make ", "Craft an item") - , ("move", "Move one step in the current direction") - , ("turn ", "Change the current direction") - , ("grab", "Grab whatver is available") - , ("give ", "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 ", "Create a robot") + , ("make ", "Craft an item") + , ("move", "Move one step in the current direction") + , ("turn ", "Change the current direction") + , ("grab", "Grab whatver is available") + , ("give ", "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 diff --git a/src/Swarm/Util.hs b/src/Swarm/Util.hs index 18a076ad..05502a32 100644 --- a/src/Swarm/Util.hs +++ b/src/Swarm/Util.hs @@ -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'. diff --git a/test/Unit.hs b/test/Unit.hs index ccd170a0..714ec2ce 100644 --- a/test/Unit.hs +++ b/test/Unit.hs @@ -3,13 +3,13 @@ -- | Swarm unit tests module Main where -import Data.Text (Text) -import Test.Tasty -import Test.Tasty.HUnit +import Data.Text (Text) +import Test.Tasty +import Test.Tasty.HUnit -import Swarm.Language.Pipeline -import Swarm.Language.Pretty -import Swarm.Language.Syntax +import Swarm.Language.Pipeline +import Swarm.Language.Pretty +import Swarm.Language.Syntax main :: IO () main = defaultMain tests @@ -23,79 +23,82 @@ parser = "Language - pipeline" [ testCase "end semicolon #79" (valid "def a = 41 end def b = a + 1 end def c = b + 2 end") ] - where - valid = flip process "" - process :: Text -> Text -> Assertion - process code expect = case processTerm code of - Left e | e == expect -> pure () - | otherwise -> error $ "Unexpected failure: " <> show e - Right _ | expect == "" -> pure () - | otherwise -> error "Unexpected success" + where + valid = flip process "" + process :: Text -> Text -> Assertion + process code expect = case processTerm code of + Left e + | e == expect -> pure () + | otherwise -> error $ "Unexpected failure: " <> show e + Right _ + | expect == "" -> pure () + | otherwise -> error "Unexpected success" prettyConst :: TestTree prettyConst = - testGroup "Language - pretty" - [ testCase "operators #8 - function application unchanged" - ( - equalPretty "f say" $ - TApp (TVar "f") (TConst Say) - ) - , testCase "operators #8 - double function application unchanged" - ( - equalPretty "f () ()" $ - TApp (TApp (TVar "f") TUnit) TUnit - ) - , testCase "operators #8 - embrace operator parameter" - ( - equalPretty "f (==)" $ - TApp (TVar "f") (TConst Eq) - ) - , testCase "operators #8 - unary negation" - ( - equalPretty "-3" $ - TApp (TConst Neg) (TInt 3) - ) - , testCase "operators #8 - double unary negation" - ( - equalPretty "-(-1)" $ - TApp (TConst Neg) $ TApp (TConst Neg) (TInt 1) - ) - , testCase "operators #8 - unary negation with strongly fixing binary operator" - ( - equalPretty "-1 ^ (-2)" $ - TApp (TConst Neg) $ mkOp Exp (TInt 1) $ TApp (TConst Neg) (TInt 2) - ) - , testCase "operators #8 - unary negation with weakly fixing binary operator" - ( - equalPretty "-(1 + -2)" $ - TApp (TConst Neg) $ mkOp Add (TInt 1) $ TApp (TConst Neg) (TInt 2) - ) - , testCase "operators #8 - simple infix operator" - ( - equalPretty "1 == 2" $ - mkOp Eq (TInt 1) (TInt 2) - ) - , testCase "operators #8 - infix operator with less fixing inner operator" - ( - equalPretty "1 * (2 + 3)" $ - mkOp Mul (TInt 1) (mkOp Add (TInt 2) (TInt 3)) - ) - , testCase "operators #8 - infix operator with more fixing inner operator" - ( - equalPretty "1 + 2 * 3" $ - mkOp Add (TInt 1) (mkOp Mul (TInt 2) (TInt 3)) - ) - , testCase "operators #8 - infix operator right associativity" - ( - equalPretty "2 ^ 4 ^ 8" $ - mkOp Exp (TInt 2) (mkOp Exp (TInt 4) (TInt 8)) - ) - , testCase "operators #8 - infix operator right associativity not applied to left" - ( - equalPretty "(2 ^ 4) ^ 8" $ - mkOp Exp (mkOp Exp (TInt 2) (TInt 4)) (TInt 8) - ) + testGroup + "Language - pretty" + [ testCase + "operators #8 - function application unchanged" + ( equalPretty "f say" $ + TApp (TVar "f") (TConst Say) + ) + , testCase + "operators #8 - double function application unchanged" + ( equalPretty "f () ()" $ + TApp (TApp (TVar "f") TUnit) TUnit + ) + , testCase + "operators #8 - embrace operator parameter" + ( equalPretty "f (==)" $ + TApp (TVar "f") (TConst Eq) + ) + , testCase + "operators #8 - unary negation" + ( equalPretty "-3" $ + TApp (TConst Neg) (TInt 3) + ) + , testCase + "operators #8 - double unary negation" + ( equalPretty "-(-1)" $ + TApp (TConst Neg) $ TApp (TConst Neg) (TInt 1) + ) + , testCase + "operators #8 - unary negation with strongly fixing binary operator" + ( equalPretty "-1 ^ (-2)" $ + TApp (TConst Neg) $ mkOp Exp (TInt 1) $ TApp (TConst Neg) (TInt 2) + ) + , testCase + "operators #8 - unary negation with weakly fixing binary operator" + ( equalPretty "-(1 + -2)" $ + TApp (TConst Neg) $ mkOp Add (TInt 1) $ TApp (TConst Neg) (TInt 2) + ) + , testCase + "operators #8 - simple infix operator" + ( equalPretty "1 == 2" $ + mkOp Eq (TInt 1) (TInt 2) + ) + , testCase + "operators #8 - infix operator with less fixing inner operator" + ( equalPretty "1 * (2 + 3)" $ + mkOp Mul (TInt 1) (mkOp Add (TInt 2) (TInt 3)) + ) + , testCase + "operators #8 - infix operator with more fixing inner operator" + ( equalPretty "1 + 2 * 3" $ + mkOp Add (TInt 1) (mkOp Mul (TInt 2) (TInt 3)) + ) + , testCase + "operators #8 - infix operator right associativity" + ( equalPretty "2 ^ 4 ^ 8" $ + mkOp Exp (TInt 2) (mkOp Exp (TInt 4) (TInt 8)) + ) + , testCase + "operators #8 - infix operator right associativity not applied to left" + ( equalPretty "(2 ^ 4) ^ 8" $ + mkOp Exp (mkOp Exp (TInt 2) (TInt 4)) (TInt 8) + ) ] - where - equalPretty :: String -> Term -> Assertion - equalPretty expected term = assertEqual "" expected . show $ ppr term + where + equalPretty :: String -> Term -> Assertion + equalPretty expected term = assertEqual "" expected . show $ ppr term