reinstate run for now

Author: byorgey

src/swarm-engine/Swarm/Game/Step/Const.hs

@@ -17,7 +17,7 @@ import Control.Effect.Error
 import Control.Effect.Lens
 import Control.Effect.Lift
 import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=))
-import Control.Monad (filterM, forM, forM_, guard, unless, when)
+import Control.Monad (filterM, forM, forM_, guard, msum, unless, when)
 import Data.Bifunctor (second)
 import Data.Bool (bool)
 import Data.Char (chr, ord)
@@ -35,7 +35,7 @@ import Data.List.NonEmpty qualified as NE
 import Data.Map qualified as M
 import Data.Map.NonEmpty qualified as NEM
 import Data.Map.Strict qualified as MS
-import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, mapMaybe)
+import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe)
 import Data.MonoidMap qualified as MM
 import Data.Ord (Down (Down))
 import Data.Sequence qualified as Seq
@@ -46,6 +46,7 @@ import Data.Text qualified as T
 import Data.Tuple (swap)
 import Linear (V2 (..), perp, zero)
 import Swarm.Effect as Effect (Time, getNow)
+import Swarm.Failure (SystemFailure, AssetData(Script))
 import Swarm.Game.Achievement.Definitions
 import Swarm.Game.CESK
 import Swarm.Game.Cosmetic.Attribute (readAttribute)
@@ -89,14 +90,17 @@ import Swarm.Game.Value
 import Swarm.Language.Capability
 import Swarm.Language.Key (parseKeyComboFull)
 import Swarm.Language.Parser.Value (readValue)
+import Swarm.Language.Pipeline (processTerm)
 import Swarm.Language.Requirements qualified as R
 import Swarm.Language.Syntax
 import Swarm.Language.Syntax.Direction
 import Swarm.Language.Text.Markdown qualified as Markdown
 import Swarm.Language.Value
 import Swarm.Log
 import Swarm.Pretty (prettyText)
+import Swarm.ResourceLoading (getDataFileNameSafe)
 import Swarm.Util hiding (both)
+import Swarm.Util.Effect (throwToMaybe)
 import Swarm.Util.Lens (inherit)
 import Text.Megaparsec (runParser)
 import Witch (From (from), into)
@@ -1212,6 +1216,28 @@ execConst runChildProg c vs s k = do
             time <- use $ temporal . ticks
             return $ Waiting (addTicks (numItems + 1) time) (mkReturn ())
       _ -> badConst
+    -- run can take both types of text inputs
+    -- with and without file extension as in
+    -- "./path/to/file.sw" and "./path/to/file"
+    Run -> case vs of
+      [VText fileName] -> do
+        let filePath = into @String fileName
+        sData <- throwToMaybe @SystemFailure $ getDataFileNameSafe Script filePath
+        sDataSW <- throwToMaybe @SystemFailure $ getDataFileNameSafe Script (filePath <> ".sw")
+        mf <- sendIO $ mapM readFileMay $ [filePath, filePath <> ".sw"] <> catMaybes [sData, sDataSW]
+
+        f <- msum mf `isJustOrFail` ["File not found:", fileName]
+
+        res <- sendIO $ processTerm (into @Text f)
+        mt <- res `isRightOr` \err -> cmdExn Run ["Error in", fileName, "\n", prettyText err]
+
+        case mt of
+          Nothing -> return $ mkReturn ()
+          Just (_, t) -> do
+            void $ traceLog CmdStatus Info "run: OK."
+            cesk <- use machine
+            return $ continue M.empty t cesk
+      _ -> badConst
     Not -> case vs of
       [VBool b] -> return $ Out (VBool (not b)) s k
       _ -> badConst

src/swarm-lang/Swarm/Language/Capability.hs

@@ -126,6 +126,10 @@ constCaps = \case
   Undefined -> Nothing
   Use -> Nothing -- Recipes alone shall dictate whether things can be "used"
   View -> Nothing -- TODO: #17 should require equipping an antenna
+  -- TODO: #495
+  --   the require command will be inlined once the Issue is fixed
+  --   so the capabilities of the run commands will be checked instead
+  Run -> Nothing
   -- Some God-like abilities.
   As -> Just CGod
   Create -> Just CGod

src/swarm-lang/Swarm/Language/Syntax/Comments.hs

@@ -56,7 +56,7 @@ data Comment = Comment
   , commentSituation :: CommentSituation
   , commentText :: Text
   }
-  deriving (Eq, Show, Generic, Data, ToJSON, Hashable)
+             deriving (Eq, Show, Generic, Data, ToJSON, FromJSON, Hashable)
 
 instance PrettyPrec Comment where
   prettyPrec _ (Comment _ LineComment _ txt) = "//" <> pretty txt
@@ -78,6 +78,10 @@ instance ToJSON Comments where
     Empty -> True
     _ -> False
 
+instance FromJSON Comments where
+  parseJSON = A.genericParseJSON A.defaultOptions
+  omittedField = Just Empty
+
 instance Semigroup Comments where
   Comments b1 a1 <> Comments b2 a2 = Comments (b1 <> b2) (a1 <> a2)
 

src/swarm-lang/Swarm/Language/Syntax/Constants.hs

@@ -204,6 +204,10 @@ data Const
     Setname
   | -- | Get a uniformly random integer.
     Random
+  | -- Modules
+
+    -- | Run a program loaded from a file.
+    Run
   | -- Language built-ins
 
     -- | If-expressions.
@@ -778,6 +782,7 @@ constInfo c = case c of
   Random ->
     command 1 Intangible . doc (Set.singleton $ Query PRNG) "Get a uniformly random integer." $
       ["The random integer will be chosen from the range 0 to n-1, exclusive of the argument."]
+  Run -> command 1 long $ shortDoc (Set.singleton $ Mutation $ RobotChange BehaviorChange) "Run a program loaded from a file."
   Pure -> command 1 Intangible $ shortDoc Set.empty "Create a pure `Cmd a`{=type} computation that yields the given value."
   Try -> command 2 Intangible $ shortDoc Set.empty "Execute a command, catching errors."
   Undefined -> function 0 $ shortDoc Set.empty "A value of any type, that is evaluated as error."

src/swarm-lang/Swarm/Language/Typecheck.hs

@@ -29,6 +29,7 @@ module Swarm.Language.Typecheck (
   LocatedTCFrame (..),
   TCStack,
   withFrame,
+  popFrame,
 
   -- * Typechecking monad
   fresh,
@@ -133,6 +134,13 @@ type TCStack = [LocatedTCFrame]
 withFrame :: Has (Reader TCStack) sig m => SrcLoc -> TCFrame -> m a -> m a
 withFrame l f = local (LocatedTCFrame l f :)
 
+-- | Locally pop a frame from the typechecking stack.
+popFrame :: Has (Reader TCStack) sig m => m a -> m a
+popFrame = local @TCStack pop
+  where
+    pop (_ : fs) = fs
+    pop [] = []
+
 ------------------------------------------------------------
 -- Type source
 
@@ -1214,6 +1222,7 @@ inferConst c = run . runReader @TVCtx Ctx.empty . quantify $ case c of
   Whoami -> [tyQ| Cmd Text |]
   Setname -> [tyQ| Text -> Cmd Unit |]
   Random -> [tyQ| Int -> Cmd Int |]
+  Run -> [tyQ| Text -> Cmd Unit |]
   If -> [tyQ| Bool -> {a} -> {a} -> a |]
   Inl -> [tyQ| a -> a + b |]
   Inr -> [tyQ| b -> a + b |]
@@ -1369,52 +1378,57 @@ check s@(CSyntax l t cs) expected = addLocToTypeErr l $ case t of
     let Syntax _ tt1 _ _ = t1
         reqs = requirements tdCtx reqCtx tt1
 
-    -- If we are checking a 'def', ensure t2 has a command type.  This ensures that
-    -- something like 'def ... end; x + 3' is not allowed, since this
-    -- would result in the whole thing being wrapped in pure, like
-    -- 'pure (def ... end; x + 3)', which means the def would be local and
-    -- not persist to the next REPL input, which could be surprising.
-    --
-    -- On the other hand, 'let x = y in x + 3' is perfectly fine.
-    when (ls == LSDef) $ void $ decomposeCmdTy t2 (Expected, expected)
-
-    -- Now check the type of the body, under a context extended with
-    -- the type and requirements of the bound variable.
-    t2' <-
-      withBinding (lvVar x) upty $
-        withBinding (lvVar x) reqs $
-          check t2 expected
-
-    -- Make sure none of the generated skolem variables have escaped.
-    ask @UCtx >>= traverse_ (noSkolems l skolems)
-
-    -- Annotate a 'def' with requirements, but not 'let'.  The reason
-    -- is so that let introduces truly "local" bindings which never
-    -- persist, but def introduces "global" bindings.  Variables bound
-    -- in the environment can only be used to typecheck future REPL
-    -- terms if the environment holds not only a value but also a type
-    -- + requirements for them.  For example:
-    --
-    -- > def x : Int = 3 end; pure (x + 2)
-    -- 5
-    -- > x
-    -- 3
-    -- > let y : Int = 3 in y + 2
-    -- 5
-    -- > y
-    -- 1:1: Unbound variable y
-    -- > let y = 3 in def x = 5 end; pure (x + y)
-    -- 8
-    -- > y
-    -- 1:1: Unbound variable y
-    -- > x
-    -- 5
-    let mreqs = case ls of
-          LSDef -> Just reqs
-          LSLet -> Nothing
-
-    -- Return the annotated let.
-    return $ Syntax l (SLet ls r x mxTy mqxTy mreqs t1' t2') cs expected
+    -- Locally pop the typechecking frame that said we were checking
+    -- the definition of a let while typechecking the body.  Even
+    -- though the body is a syntactic subterm of the let, we don't
+    -- want to see a bunch of nested typechecking frames.
+    popFrame $ do
+      -- If we are checking a 'def', ensure t2 has a command type.  This ensures that
+      -- something like 'def ... end; x + 3' is not allowed, since this
+      -- would result in the whole thing being wrapped in pure, like
+      -- 'pure (def ... end; x + 3)', which means the def would be local and
+      -- not persist to the next REPL input, which could be surprising.
+      --
+      -- On the other hand, 'let x = y in x + 3' is perfectly fine.
+      when (ls == LSDef) $ void $ decomposeCmdTy t2 (Expected, expected)
+
+      -- Now check the type of the body, under a context extended with
+      -- the type and requirements of the bound variable.
+      t2' <-
+        withBinding (lvVar x) upty $
+          withBinding (lvVar x) reqs $
+            check t2 expected
+
+      -- Make sure none of the generated skolem variables have escaped.
+      ask @UCtx >>= traverse_ (noSkolems l skolems)
+
+      -- Annotate a 'def' with requirements, but not 'let'.  The reason
+      -- is so that let introduces truly "local" bindings which never
+      -- persist, but def introduces "global" bindings.  Variables bound
+      -- in the environment can only be used to typecheck future REPL
+      -- terms if the environment holds not only a value but also a type
+      -- + requirements for them.  For example:
+      --
+      -- > def x : Int = 3 end; pure (x + 2)
+      -- 5
+      -- > x
+      -- 3
+      -- > let y : Int = 3 in y + 2
+      -- 5
+      -- > y
+      -- 1:1: Unbound variable y
+      -- > let y = 3 in def x = 5 end; pure (x + y)
+      -- 8
+      -- > y
+      -- 1:1: Unbound variable y
+      -- > x
+      -- 5
+      let mreqs = case ls of
+            LSDef -> Just reqs
+            LSLet -> Nothing
+
+      -- Return the annotated let.
+      return $ Syntax l (SLet ls r x mxTy mqxTy mreqs t1' t2') cs expected
 
   -- Kind-check a type definition and then check the body under an
   -- extended context.