Add the option to output json in the juvix internal highlight command (#1450)

* json output for the highlight command

* adapt json output to fit vscode

* add --format flag

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,59 +1,33 @@
-module Juvix.Compiler.Concrete.Data.Highlight where
+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 Juvix.Compiler.Concrete.Data.ParsedItem
+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 as Prelude hiding (show)
-import Juvix.Prelude
+import Prelude qualified
-import Prettyprinter
-import Prettyprinter.Render.Text
 
-data Face
+data HighlightBackend
-  = FaceConstructor
+  = Emacs
-  | FaceInductive
+  | Json
-  | FaceFunction
-  | FaceModule
-  | FaceAxiom
-  | FaceKeyword
-  | FaceString
-  | FaceNumber
-  | FaceComment
-  | FaceError
 
-newtype Property
+instance Show HighlightBackend where
-  = PropertyFace Face
+  show = \case
+    Emacs -> "emacs"
+    Json -> "json"
 
-data Instruction = SetProperty
+go :: HighlightBackend -> HighlightInput -> ByteString
-  { _setPropertyInterval :: Interval,
+go = \case
-    _setPropertyProperty :: Property
+  Emacs -> Text.encodeUtf8 . renderSExp . toSexp . buildProperties
-  }
+  Json -> ByteString.toStrict . Aeson.encode . rawProperties . buildProperties
-
-data HighlightInput = HighlightInput
-  { _highlightParsed :: [ParsedItem],
-    _highlightNames :: [AName]
-  }
-
-makeLenses ''HighlightInput
-
-data SExp
-  = Symbol Text
-  | App [SExp]
-  | Pair SExp SExp
-  | Quote SExp
-  | Backquote SExp
-  | Int Word64
-  | String String
-
-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)
 
 goError :: [Interval] -> Text
 goError l =
@@ -61,24 +35,16 @@ goError l =
     (progn (map goIntervalErr l))
   where
     goIntervalErr :: Interval -> SExp
-    goIntervalErr = instr FaceError
+    goIntervalErr i = toSexp (PropertyFace i FaceError)
 
-go :: HighlightInput -> Text
+buildProperties :: HighlightInput -> Properties
-go HighlightInput {..} =
+buildProperties HighlightInput {..} =
-  renderSExp
+  Properties
-    ( progn
+    { _propertiesFace =
-        ( map goParsedItem items
+        map goFaceParsedItem _highlightParsed
-            <> mapMaybe colorName names
+          <> mapMaybe goFaceName _highlightNames,
-            <> map gotoDefName names
+      _propertiesGoto = map goGotoProperty _highlightNames
-        )
+    }
-    )
-  where
-    names = _highlightNames
-    items :: [ParsedItem]
-    items = _highlightParsed
-
-progn :: [SExp] -> SExp
-progn l = App (Symbol "progn" : l)
 
 nameKindFace :: NameKind -> Maybe Face
 nameKindFace = \case
@@ -90,71 +56,27 @@ nameKindFace = \case
   KNameAxiom -> Just FaceAxiom
   KNameLocal -> Nothing
 
--- | Example instruction:
+goFaceParsedItem :: ParsedItem -> PropertyFace
--- (add-text-properties 20 28
+goFaceParsedItem i =
---  '(face juvix-highlight-constructor-face))
+  PropertyFace
-instr :: Face -> Interval -> SExp
+    { _faceFace = f,
-instr f i =
+      _faceInterval = i ^. parsedLoc
-  App [Symbol "add-text-properties", start, end, face]
+    }
   where
-    pos l = Int (succ (l ^. locOffset . unPos))
+    f = case i ^. parsedTag of
-    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)
-  where
-    face = case i ^. parsedTag of
       ParsedTagKeyword -> FaceKeyword
       ParsedTagLiteralInt -> FaceNumber
       ParsedTagLiteralString -> FaceString
       ParsedTagComment -> FaceComment
 
-colorName :: AName -> Maybe SExp
+goFaceName :: AName -> Maybe PropertyFace
-colorName n = do
+goFaceName n = do
   f <- nameKindFace (getNameKind n)
-  return (instr f (getLoc n))
+  return (PropertyFace (getLoc n) f)
 
-gotoDefName :: AName -> SExp
+goGotoProperty :: AName -> PropertyGoto
-gotoDefName (AName n) =
+goGotoProperty (AName n) = PropertyGoto {..}
-  App [Symbol "add-text-properties", start, end, goto]
   where
-    i = getLoc n
+    _gotoInterval = getLoc n
-    targetPos = succ (n ^. nameDefined . intervalStart . locOffset . unPos)
+    _gotoPos = n ^. nameDefined . intervalStart
-    targetFile = n ^. nameDefined . intervalFile
+    _gotoFile = 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)

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)

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

@@ -0,0 +1,135 @@
+module Juvix.Compiler.Concrete.Data.Highlight.Properties where
+
+import Data.Aeson (ToJSON)
+import Data.Aeson qualified as Aeson
+import Data.Aeson.TH
+import Juvix.Compiler.Concrete.Data.Highlight.SExp
+import Juvix.Extra.Strings qualified as Str
+import Juvix.Prelude
+import Lens.Micro.Platform qualified as Lens
+
+data Face
+  = FaceConstructor
+  | FaceInductive
+  | FaceFunction
+  | FaceModule
+  | FaceAxiom
+  | FaceKeyword
+  | FaceString
+  | FaceNumber
+  | FaceComment
+  | FaceError
+
+faceSymbolStr :: Face -> Text
+faceSymbolStr = \case
+  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 faceSymbolTxt = Symbol ("juvix-highlight-" <> faceSymbolTxt <> "-face")
+
+instance ToJSON Face where
+  toJSON = Aeson.String . faceSymbolStr
+
+data PropertyGoto = PropertyGoto
+  { _gotoInterval :: Interval,
+    _gotoFile :: FilePath,
+    _gotoPos :: FileLoc
+  }
+
+data PropertyFace = PropertyFace
+  { _faceInterval :: Interval,
+    _faceFace :: Face
+  }
+
+data Properties = Properties
+  { _propertiesGoto :: [PropertyGoto],
+    _propertiesFace :: [PropertyFace]
+  }
+
+data RawProperties = RawProperties
+  { _rawPropertiesFace :: [RawFace],
+    _rawPropertiesGoto :: [RawGoto]
+  }
+
+-- | (File, Row, Col, Length)
+type RawInterval = (FilePath, Int, Int, Int)
+
+type RawFace = (RawInterval, Face)
+
+-- | (Interval, TargetFile, TargetLine, TargetColumn)
+type RawGoto = (RawInterval, FilePath, Int, Int)
+
+$( deriveToJSON
+     defaultOptions
+       { fieldLabelModifier = over Lens._head toLower . dropPrefix "_rawProperties",
+         constructorTagModifier = map toLower
+       }
+     ''RawProperties
+ )
+
+rawProperties :: Properties -> RawProperties
+rawProperties Properties {..} =
+  RawProperties
+    { _rawPropertiesGoto = map rawGoto _propertiesGoto,
+      _rawPropertiesFace = map rawFace _propertiesFace
+    }
+  where
+    rawInterval :: Interval -> RawInterval
+    rawInterval i =
+      ( i ^. intervalFile,
+        fromIntegral (i ^. intervalStart . locLine),
+        fromIntegral (i ^. intervalStart . locCol),
+        intervalLength i
+      )
+    rawFace :: PropertyFace -> RawFace
+    rawFace PropertyFace {..} = (rawInterval _faceInterval, _faceFace)
+    rawGoto :: PropertyGoto -> RawGoto
+    rawGoto PropertyGoto {..} =
+      ( rawInterval _gotoInterval,
+        _gotoFile,
+        fromIntegral (_gotoPos ^. locLine),
+        fromIntegral (_gotoPos ^. locCol)
+      )
+
+-- | Example instruction:
+-- (add-text-properties 20 28
+--  '(face juvix-highlight-constructor-face))
+instance ToSexp PropertyFace where
+  toSexp PropertyFace {..} =
+    App [Symbol "add-text-properties", start, end, face]
+    where
+      i = _faceInterval
+      f = _faceFace
+      pos l = Int (succ (l ^. locOffset . unPos))
+      start = pos (i ^. intervalStart)
+      end = pos (i ^. intervalEnd)
+      face = Quote (App [Symbol "face", faceSymbol (faceSymbolStr f)])
+
+instance ToSexp PropertyGoto where
+  toSexp PropertyGoto {..} =
+    App [Symbol "add-text-properties", start, end, goto]
+    where
+      i = _gotoInterval
+      targetPos = _gotoPos
+      targetFile = _gotoFile
+      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 ^. locOffset . to (succ . fromIntegral)))
+
+instance ToSexp Properties where
+  toSexp Properties {..} =
+    progn
+      ( map toSexp _propertiesFace
+          <> map toSexp _propertiesGoto
+      )

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

@@ -0,0 +1,36 @@
+module Juvix.Compiler.Concrete.Data.Highlight.SExp where
+
+import Juvix.Prelude
+import Juvix.Prelude.Pretty
+import Prettyprinter.Render.Text
+
+class ToSexp a where
+  toSexp :: a -> SExp
+
+data SExp
+  = Symbol Text
+  | App [SExp]
+  | Pair SExp SExp
+  | Quote SExp
+  | Backquote SExp
+  | Int Word64
+  | String String
+
+progn :: [SExp] -> SExp
+progn l = App (Symbol "progn" : l)
+
+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)

src/Juvix/Data/Loc.hs

@@ -6,7 +6,7 @@ import Text.Megaparsec qualified as M
 
 newtype Pos = Pos {_unPos :: Word64}
   deriving stock (Show, Eq, Ord)
-  deriving newtype (Hashable)
+  deriving newtype (Hashable, Num, Enum, Real, Integral)
 
 instance Semigroup Pos where
   Pos x <> Pos y = Pos (x + y)
@@ -84,6 +84,9 @@ singletonInterval l =
       _intervalEnd = l ^. locFileLoc
     }
 
+intervalLength :: Interval -> Int
+intervalLength i = fromIntegral (i ^. intervalEnd . locOffset - i ^. intervalStart . locOffset) + 1
+
 intervalStartLoc :: Interval -> Loc
 intervalStartLoc i =
   Loc

src/Juvix/Prelude/Base.hs

@@ -72,7 +72,7 @@ import Control.Monad.Fix
 import Data.Bifunctor hiding (first, second)
 import Data.Bitraversable
 import Data.Bool
-import Data.ByteString.Lazy (ByteString)
+import Data.ByteString (ByteString)
 import Data.Char
 import Data.Char qualified as Char
 import Data.Data