Add the option to output json in the juvix internal highlight command

app/App.hs

@@ -1,5 +1,6 @@
 module App where
 
+import Data.ByteString qualified as ByteString
 import GlobalOptions
 import Juvix.Compiler.Pipeline
 import Juvix.Data.Error qualified as Error
@@ -14,6 +15,7 @@ data App m a where
   RenderStdOut :: (HasAnsiBackend a, HasTextBackend a) => a -> App m ()
   RunPipelineEither :: Sem PipelineEff a -> App m (Either JuvixError a)
   Say :: Text -> App m ()
+  Raw :: ByteString -> App m ()
 
 makeSem ''App
 
@@ -33,6 +35,7 @@ runAppIO g = interpret $ \case
     (embed . hPutStrLn stderr . Error.render (not (g ^. globalNoColors)) (g ^. globalOnlyErrors)) e
     embed exitFailure
   ExitMsg exitCode t -> embed (putStrLn t >> exitWith exitCode)
+  Raw b -> embed (ByteString.putStr b)
 
 runPipeline :: Member App r => Sem PipelineEff a -> Sem r a
 runPipeline p = do

app/Commands/Dev.hs

@@ -13,12 +13,13 @@ import Commands.Dev.Internal
 import Commands.Dev.Parse
 import Commands.Dev.Scope
 import Commands.Dev.Termination
+import Juvix.Compiler.Concrete.Data.Highlight
 import Juvix.Prelude
 import Options.Applicative
 
 data InternalCommand
   = DisplayRoot
-  | Highlight
+  | Highlight HighlightOptions
   | Internal MicroCommand
   | MiniC
   | MiniHaskell
@@ -28,6 +29,10 @@ data InternalCommand
   | Termination TerminationCommand
   | Doc DocOptions
 
+newtype HighlightOptions = HighlightOptions
+  { _highlightBackend :: HighlightBackend
+  }
+
 parseInternalCommand :: Parser InternalCommand
 parseInternalCommand =
   hsubparser
@@ -56,8 +61,26 @@ commandHighlight :: Mod CommandFields InternalCommand
 commandHighlight =
   command "highlight" $
     info
-      (pure Highlight)
+      (Highlight <$> parseHighlight)
       (progDesc "Highlight a Juvix file")
+  where
+    parseHighlight :: Parser HighlightOptions
+    parseHighlight = do
+      _highlightBackend <-
+        option
+          (eitherReader parseBackend)
+          ( long "format"
+              <> metavar "FORMAT"
+              <> value Emacs
+              <> showDefault
+              <> help "selects a backend. FORMAT = emacs | json"
+          )
+      pure HighlightOptions {..}
+    parseBackend :: String -> Either String HighlightBackend
+    parseBackend s = case s of
+      "emacs" -> Right Emacs
+      "json" -> Right Json
+      _ -> Left $ "unrecognised theme: " <> s
 
 commandMiniC :: Mod CommandFields InternalCommand
 commandMiniC =

app/Main.hs

@@ -118,7 +118,7 @@ runCommand cmdWithOpts = do
                 let m = head (res ^. Scoper.resultModules)
                 embed (Html.genHtml Scoper.defaultOptions _htmlRecursive _htmlTheme _htmlOutputDir _htmlPrintMetadata m)
               (Dev cmd') -> case cmd' of
-                Highlight -> do
+                Highlight HighlightOptions {..} -> do
                   res <- runPipelineEither (upToScoping entryPoint)
                   case res of
                     Left err -> say (Highlight.goError (errorIntervals err))
@@ -134,7 +134,7 @@ runCommand cmdWithOpts = do
                                 { _highlightNames = names,
                                   _highlightParsed = items
                                 }
-                      say (Highlight.go hinput)
+                      raw (Highlight.go _highlightBackend hinput)
                 Parse localOpts -> do
                   m <-
                     head . (^. Parser.resultModules)

src/Juvix/Compiler/Concrete/Data/Highlight.hs

@@ -1,84 +1,50 @@
-module Juvix.Compiler.Concrete.Data.Highlight where
-
-import Juvix.Compiler.Concrete.Data.ParsedItem
+module Juvix.Compiler.Concrete.Data.Highlight
+  ( module Juvix.Compiler.Concrete.Data.Highlight,
+    module Juvix.Compiler.Concrete.Data.Highlight.Input,
+    module Juvix.Compiler.Concrete.Data.Highlight.Properties,
+  )
+where
+
+import Data.Aeson qualified as Aeson
+import Data.ByteString.Lazy qualified as ByteString
+import Data.Text.Encoding qualified as Text
+import Juvix.Compiler.Concrete.Data.Highlight.Input
+import Juvix.Compiler.Concrete.Data.Highlight.Properties
+import Juvix.Compiler.Concrete.Data.Highlight.SExp
 import Juvix.Compiler.Concrete.Data.ScopedName
-import Juvix.Extra.Strings qualified as Str
-import Juvix.Prelude
-import Prettyprinter
-import Prettyprinter.Render.Text
-
-data Face
-  = FaceConstructor
-  | FaceInductive
-  | FaceFunction
-  | FaceModule
-  | FaceAxiom
-  | FaceKeyword
-  | FaceString
-  | FaceNumber
-  | FaceComment
-  | FaceError
-
-newtype Property
-  = PropertyFace Face
-
-data Instruction = SetProperty
-  { _setPropertyInterval :: Interval,
-    _setPropertyProperty :: Property
-  }
-
-data HighlightInput = HighlightInput
-  { _highlightParsed :: [ParsedItem],
-    _highlightNames :: [AName]
-  }
+import Juvix.Prelude as Prelude hiding (show)
+import Prelude qualified
 
-makeLenses ''HighlightInput
+data HighlightBackend
+  = Emacs
+  | Json
 
-data SExp
-  = Symbol Text
-  | App [SExp]
-  | Pair SExp SExp
-  | Quote SExp
-  | Backquote SExp
-  | Int Word64
-  | String String
+instance Show HighlightBackend where
+  show = \case
+    Emacs -> "emacs"
+    Json -> "json"
 
-makeLenses ''Instruction
-
-filterInput :: FilePath -> HighlightInput -> HighlightInput
-filterInput absPth HighlightInput {..} =
-  HighlightInput
-    { _highlightNames = filterByLoc absPth _highlightNames,
-      _highlightParsed = filterByLoc absPth _highlightParsed
-    }
-
-filterByLoc :: HasLoc p => FilePath -> [p] -> [p]
-filterByLoc absPth = filter ((== absPth) . (^. intervalFile) . getLoc)
+go :: HighlightBackend -> HighlightInput -> ByteString
+go = \case
+  Emacs -> Text.encodeUtf8 . renderSExp . toSexp . buildProperties
+  Json -> ByteString.toStrict . Aeson.encode . rawProperties . buildProperties
 
 goError :: [Interval] -> Text
 goError l =
   renderSExp
     (progn (map goIntervalErr l))
   where
     goIntervalErr :: Interval -> SExp
-    goIntervalErr = instr FaceError
-
-go :: HighlightInput -> Text
-go HighlightInput {..} =
-  renderSExp
-    ( progn
-        ( map goParsedItem items
-            <> mapMaybe colorName names
-            <> map gotoDefName names
-        )
-    )
-  where
-    names = _highlightNames
-    items :: [ParsedItem]
-    items = _highlightParsed
-
-progn :: [SExp] -> SExp
-progn l = App (Symbol "progn" : l)
+    goIntervalErr i = toSexp (PropertyFace i FaceError)
+
+buildProperties :: HighlightInput -> Properties
+buildProperties HighlightInput {..} =
+  Properties
+    { _propertiesFace =
+        map goFaceParsedItem _highlightParsed
+          <> mapMaybe goFaceName _highlightNames,
+      _propertiesGoto = map goGotoProperty _highlightNames
+    }
 
 nameKindFace :: NameKind -> Maybe Face
 nameKindFace = \case
@@ -90,71 +56,27 @@ nameKindFace = \case
   KNameAxiom -> Just FaceAxiom
   KNameLocal -> Nothing
 
--- | Example instruction:
--- (add-text-properties 20 28
---  '(face juvix-highlight-constructor-face))
-instr :: Face -> Interval -> SExp
-instr f i =
-  App [Symbol "add-text-properties", start, end, face]
-  where
-    pos l = Int (succ (l ^. locOffset . unPos))
-    start = pos (i ^. intervalStart)
-    end = pos (i ^. intervalEnd)
-    face = Quote (App [Symbol "face", faceSymbol faceSymbolStr])
-    faceSymbolStr = case f of
-      FaceAxiom -> Str.axiom
-      FaceInductive -> Str.inductive
-      FaceConstructor -> Str.constructor
-      FaceModule -> Str.module_
-      FaceKeyword -> Str.keyword
-      FaceFunction -> Str.function
-      FaceNumber -> Str.number
-      FaceComment -> Str.comment
-      FaceString -> Str.string
-      FaceError -> Str.error
-
-faceSymbol :: Text -> SExp
-faceSymbol faceSymbolStr = Symbol ("juvix-highlight-" <> faceSymbolStr <> "-face")
-
-goParsedItem :: ParsedItem -> SExp
-goParsedItem i = instr face (getLoc i)
+goFaceParsedItem :: ParsedItem -> PropertyFace
+goFaceParsedItem i =
+  PropertyFace
+    { _faceFace = f,
+      _faceInterval = i ^. parsedLoc
+    }
   where
-    face = case i ^. parsedTag of
+    f = case i ^. parsedTag of
       ParsedTagKeyword -> FaceKeyword
       ParsedTagLiteralInt -> FaceNumber
       ParsedTagLiteralString -> FaceString
       ParsedTagComment -> FaceComment
 
-colorName :: AName -> Maybe SExp
-colorName n = do
+goFaceName :: AName -> Maybe PropertyFace
+goFaceName n = do
   f <- nameKindFace (getNameKind n)
-  return (instr f (getLoc n))
+  return (PropertyFace (getLoc n) f)
 
-gotoDefName :: AName -> SExp
-gotoDefName (AName n) =
-  App [Symbol "add-text-properties", start, end, goto]
+goGotoProperty :: AName -> PropertyGoto
+goGotoProperty (AName n) = PropertyGoto {..}
   where
-    i = getLoc n
-    targetPos = succ (n ^. nameDefined . intervalStart . locOffset . unPos)
-    targetFile = n ^. nameDefined . intervalFile
-    goto = Quote (App [Symbol "juvix-goto", gotoPair])
-    pos l = Int (succ (l ^. locOffset . unPos))
-    start = pos (i ^. intervalStart)
-    end = pos (i ^. intervalEnd)
-    gotoPair = Pair (String targetFile) (Int targetPos)
-
-renderSExp :: SExp -> Text
-renderSExp =
-  renderStrict
-    . layoutPretty defaultLayoutOptions
-    . pretty
-
-instance Pretty SExp where
-  pretty = \case
-    Symbol s -> pretty s
-    Int s -> pretty s
-    App l -> parens (sep (map pretty l))
-    Pair l r -> parens (pretty l <+> dot <+> pretty r)
-    Backquote l -> pretty '`' <> pretty l
-    Quote l -> pretty '\'' <> pretty l
-    String s -> dquotes (pretty s)
+    _gotoInterval = getLoc n
+    _gotoPos = n ^. nameDefined . intervalStart
+    _gotoFile = n ^. nameDefined . intervalFile

src/Juvix/Compiler/Concrete/Data/Highlight/Input.hs

@@ -0,0 +1,26 @@
+module Juvix.Compiler.Concrete.Data.Highlight.Input
+  ( module Juvix.Compiler.Concrete.Data.Highlight.Input,
+    module Juvix.Compiler.Concrete.Data.ParsedItem,
+  )
+where
+
+import Juvix.Compiler.Concrete.Data.ParsedItem
+import Juvix.Compiler.Concrete.Data.ScopedName
+import Juvix.Prelude
+
+data HighlightInput = HighlightInput
+  { _highlightParsed :: [ParsedItem],
+    _highlightNames :: [AName]
+  }
+
+makeLenses ''HighlightInput
+
+filterInput :: FilePath -> HighlightInput -> HighlightInput
+filterInput absPth HighlightInput {..} =
+  HighlightInput
+    { _highlightNames = filterByLoc absPth _highlightNames,
+      _highlightParsed = filterByLoc absPth _highlightParsed
+    }
+
+filterByLoc :: HasLoc p => FilePath -> [p] -> [p]
+filterByLoc absPth = filter ((== absPth) . (^. intervalFile) . getLoc)