Parse comments

feedback.yaml

@@ -1,3 +1,3 @@
 loops:
   test: cabal test -j -O0 --test-show-details=direct swarm:swarm-integration swarm:swarm-unit
-  unit: cabal test -j -O0 --test-show-details=direct swarm:swarm-unit --fast
+  unit: cabal test -j -O0 --test-show-details=direct swarm:swarm-unit

src/swarm-doc/Swarm/Doc/Pedagogy.hs

@@ -136,7 +136,7 @@ getCommands (Just (ProcessedTerm (Module stx _) _ _)) =
  where
   nodelist :: [Syntax' Polytype]
   nodelist = universe stx
-  isCommand (Syntax' sloc t _) = case t of
+  isCommand (Syntax' sloc t _ _) = case t of
     TConst c -> guard (isConsidered c) >> Just (c, [sloc])
     _ -> Nothing
 

src/swarm-engine/Swarm/Game/Scenario/Scoring/CodeSize.hs

@@ -29,7 +29,7 @@ codeMetricsFromSyntax ::
   Data a =>
   Syntax' a ->
   ScenarioCodeMetrics
-codeMetricsFromSyntax s@(Syntax' srcLoc _ _) =
+codeMetricsFromSyntax s@(Syntax' srcLoc _ _ _) =
   ScenarioCodeMetrics (charCount srcLoc) (measureAstSize s)
  where
   charCount :: SrcLoc -> Int

src/swarm-engine/Swarm/Game/State.hs

@@ -167,7 +167,7 @@ parseCodeFile ::
   m CodeToRun
 parseCodeFile filepath = do
   contents <- sendIO $ TIO.readFile filepath
-  pt@(ProcessedTerm (Module (Syntax' srcLoc _ _) _) _ _) <-
+  pt@(ProcessedTerm (Module (Syntax' srcLoc _ _ _) _) _ _) <-
     either (throwError . CustomFailure) return (processTermEither contents)
   let strippedText = stripSrc srcLoc contents
       programBytestring = TL.encodeUtf8 $ TL.fromStrict strippedText

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

@@ -89,7 +89,6 @@ import Swarm.Game.Value
 import Swarm.Language.Capability
 import Swarm.Language.Context hiding (delete)
 import Swarm.Language.Key (parseKeyComboFull)
-import Swarm.Language.Parse (runParser)
 import Swarm.Language.Pipeline
 import Swarm.Language.Pretty (prettyText)
 import Swarm.Language.Requirement qualified as R
@@ -100,6 +99,7 @@ import Swarm.Log
 import Swarm.Util hiding (both)
 import Swarm.Util.Effect (throwToMaybe)
 import Swarm.Util.Lens (inherit)
+import Text.Megaparsec (runParser)
 import Witch (From (from), into)
 import Prelude hiding (Applicative (..), lookup)
 
@@ -1001,7 +1001,7 @@ execConst runChildProg c vs s k = do
       [VText msg] -> return $ Up (User msg) s k
       _ -> badConst
     Key -> case vs of
-      [VText ktxt] -> case runParser parseKeyComboFull ktxt of
+      [VText ktxt] -> case runParser parseKeyComboFull "" ktxt of
         Right kc -> return $ Out (VKey kc) s k
         Left _ -> return $ Up (CmdFailed Key (T.unwords ["Unknown key", quote ktxt]) Nothing) s k
       _ -> badConst

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

@@ -22,12 +22,12 @@ elaborate =
   -- Wrap all *free* variables in 'Force'.  Free variables must be
   -- referring to a previous definition, which are all wrapped in
   -- 'TDelay'.
-  (freeVarsS %~ \s -> Syntax' (s ^. sLoc) (SApp sForce s) (s ^. sType))
+  (freeVarsS %~ \s -> Syntax' (s ^. sLoc) (SApp sForce s) (s ^. sComments) (s ^. sType))
     -- Now do additional rewriting on all subterms.
     . transform rewrite
  where
   rewrite :: Syntax' Polytype -> Syntax' Polytype
-  rewrite (Syntax' l t ty) = Syntax' l (rewriteTerm t) ty
+  rewrite (Syntax' l t ty cs) = Syntax' l (rewriteTerm t) ty cs
 
   rewriteTerm :: Term' Polytype -> Term' Polytype
   rewriteTerm = \case
@@ -43,14 +43,14 @@ elaborate =
     -- bound by 'def'.
     SDef True x ty t1 -> SDef True x ty (wrapForce (lvVar x) t1)
     -- Rewrite @f $ x@ to @f x@.
-    SApp (Syntax' _ (SApp (Syntax' _ (TConst AppF) _) l) _) r -> SApp l r
+    SApp (Syntax' _ (SApp (Syntax' _ (TConst AppF) _ _) l) _ _) r -> SApp l r
     -- Leave any other subterms alone.
     t -> t
 
 wrapForce :: Var -> Syntax' Polytype -> Syntax' Polytype
-wrapForce x = mapFreeS x (\s@(Syntax' l _ ty) -> Syntax' l (SApp sForce s) ty)
+wrapForce x = mapFreeS x (\s@(Syntax' l _ ty cs) -> Syntax' l (SApp sForce s) ty cs)
 
 -- Note, TyUnit is not the right type, but I don't want to bother
 
 sForce :: Syntax' Polytype
-sForce = Syntax' NoLoc (TConst Force) (Forall ["a"] (TyDelay (TyVar "a") :->: TyVar "a"))
+sForce = Syntax' NoLoc (TConst Force) Nothing (Forall ["a"] (TyDelay (TyVar "a") :->: TyVar "a"))

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

@@ -26,9 +26,9 @@ import Data.Set (Set)
 import Data.Set qualified as S
 import Data.Text (Text)
 import Data.Text qualified as T
+import Data.Void
 import GHC.Generics hiding (from)
 import Graphics.Vty.Input.Events qualified as V
-import Swarm.Language.Parse
 import Text.Megaparsec
 import Text.Megaparsec.Char (char, string)
 import Text.Megaparsec.Char.Lexer (decimal)
@@ -47,27 +47,29 @@ deriving instance FromJSON V.Modifier
 deriving instance ToJSON V.Key
 deriving instance ToJSON V.Modifier
 
+type SParser = Parsec Void Text
+
 -- | Smart constructor for 'KeyCombo'.
 mkKeyCombo :: [V.Modifier] -> V.Key -> KeyCombo
 mkKeyCombo mods k = KeyCombo k (sort mods)
 
 -- | Parse a key combo with nothing after it.
-parseKeyComboFull :: Parser KeyCombo
+parseKeyComboFull :: SParser KeyCombo
 parseKeyComboFull = parseKeyCombo <* eof
 
 -- | Parse a key combo like @\"M-C-F5\"@, @\"Down\"@, or @\"C-x\"@.
-parseKeyCombo :: Parser KeyCombo
+parseKeyCombo :: SParser KeyCombo
 parseKeyCombo =
   mkKeyCombo <$> many (try (parseModifier <* char '-')) <*> parseKey
 
-parseModifier :: Parser V.Modifier
+parseModifier :: SParser V.Modifier
 parseModifier =
   V.MShift <$ string "S"
     <|> V.MCtrl <$ string "C"
     <|> V.MMeta <$ string "M"
     <|> V.MAlt <$ string "A"
 
-parseKey :: Parser V.Key
+parseKey :: SParser V.Key
 parseKey =
   -- For an explanation of the 'reverse', see Note [Key names are not prefix-free]
   (asum . map specialKeyParser . reverse . S.toList $ specialKeyNames)
@@ -90,13 +92,13 @@ parseKey =
 -- of key names (which are sorted alphabetically), it guarantees that
 -- longer names will come before names which are prefixes of them.
 
-parseFunctionKey :: Parser V.Key
+parseFunctionKey :: SParser V.Key
 parseFunctionKey = V.KFun <$> try (char 'F' *> decimal)
 
-parseCharKey :: Parser V.Key
+parseCharKey :: SParser V.Key
 parseCharKey = V.KChar <$> anySingle
 
-specialKeyParser :: Text -> Parser V.Key
+specialKeyParser :: Text -> SParser V.Key
 specialKeyParser t = read . ('K' :) . from @Text <$> string t
 
 -- https://stackoverflow.com/questions/51848587/list-constructor-names-using-generics-in-haskell

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

@@ -81,8 +81,8 @@ validateSwarmCode doc version content = do
   flushDiagnosticsBySource 0 (Just diagnosticSourcePrefix)
 
   let (parsingErrs, unusedVarWarnings) = case readTerm' content of
-        Right Nothing -> ([], [])
-        Right (Just term) -> (parsingErrors, unusedWarnings)
+        Right (Nothing, _) -> ([], [])
+        Right (Just term, _) -> (parsingErrors, unusedWarnings)
          where
           VU.Usage _ problems = VU.getUsage mempty term
           unusedWarnings = mapMaybe (VU.toErrPos content) problems

src/swarm-lang/Swarm/Language/LSP/Hover.hs

@@ -60,14 +60,14 @@ showHoverInfo ::
 showHoverInfo _ p vf@(VirtualFile _ _ myRope) =
   case readTerm' content of
     Left _ -> Nothing
-    Right Nothing -> Nothing
-    Right (Just stx) -> Just $ case processParsedTerm stx of
+    Right (Nothing, _) -> Nothing
+    Right (Just stx, _) -> Just $ case processParsedTerm stx of
       Left _e ->
         let found@(Syntax foundSloc _) = narrowToPosition stx $ fromIntegral absolutePos
             finalPos = posToRange myRope foundSloc
          in (,finalPos) . treeToMarkdown 0 $ explain found
       Right (ProcessedTerm modul _req _reqCtx) ->
-        let found@(Syntax' foundSloc _ _) = narrowToPosition (moduleAST modul) $ fromIntegral absolutePos
+        let found@(Syntax' foundSloc _ _ _) = narrowToPosition (moduleAST modul) $ fromIntegral absolutePos
             finalPos = posToRange myRope foundSloc
          in (,finalPos) . treeToMarkdown 0 $ explain found
  where
@@ -94,7 +94,7 @@ descend ::
   -- | next element to inspect
   Syntax' ty ->
   Maybe (Syntax' ty)
-descend pos s1@(Syntax' l1 _ _) = do
+descend pos s1@(Syntax' l1 _ _ _) = do
   guard $ withinBound pos l1
   return $ narrowToPosition s1 pos
 
@@ -107,12 +107,12 @@ narrowToPosition ::
   -- | absolute offset within the file
   Int ->
   Syntax' ty
-narrowToPosition s0@(Syntax' _ t ty) pos = fromMaybe s0 $ case t of
+narrowToPosition s0@(Syntax' _ t _ ty) pos = fromMaybe s0 $ case t of
   SLam lv _ s -> d (locVarToSyntax' lv $ getInnerType ty) <|> d s
   SApp s1 s2 -> d s1 <|> d s2
-  SLet _ lv _ s1@(Syntax' _ _ lty) s2 -> d (locVarToSyntax' lv lty) <|> d s1 <|> d s2
-  SDef _ lv _ s@(Syntax' _ _ lty) -> d (locVarToSyntax' lv lty) <|> d s
-  SBind mlv s1@(Syntax' _ _ lty) s2 -> (mlv >>= d . flip locVarToSyntax' (getInnerType lty)) <|> d s1 <|> d s2
+  SLet _ lv _ s1@(Syntax' _ _ _ lty) s2 -> d (locVarToSyntax' lv lty) <|> d s1 <|> d s2
+  SDef _ lv _ s@(Syntax' _ _ _ lty) -> d (locVarToSyntax' lv lty) <|> d s
+  SBind mlv s1@(Syntax' _ _ _ lty) s2 -> (mlv >>= d . flip locVarToSyntax' (getInnerType lty)) <|> d s1 <|> d s2
   SPair s1 s2 -> d s1 <|> d s2
   SDelay _ s -> d s
   SRcd m -> asum . map d . catMaybes . M.elems $ m
@@ -244,8 +244,8 @@ explain trm = case trm ^. sTerm of
 explainFunction :: ExplainableType ty => Syntax' ty -> Tree Text
 explainFunction s =
   case unfoldApps s of
-    (Syntax' _ (TConst Force) _ :| [innerT]) -> explain innerT
-    (Syntax' _ (TConst Force) _ :| f : params) -> explainF f params
+    (Syntax' _ (TConst Force) _ _ :| [innerT]) -> explain innerT
+    (Syntax' _ (TConst Force) _ _ :| f : params) -> explainF f params
     (f :| params) -> explainF f params
  where
   explainF f params =