From 44e48873e1ed51374c9952c4a717dad115dbcfab Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Thu, 11 Aug 2022 16:06:17 +0200 Subject: [PATCH 1/4] json output for the highlight command --- app/App.hs | 3 + app/Main.hs | 2 +- src/Juvix/Compiler/Concrete/Data/Highlight.hs | 172 +++++------------- .../Compiler/Concrete/Data/Highlight/Input.hs | 25 +++ .../Concrete/Data/Highlight/Properties.hs | 121 ++++++++++++ .../Compiler/Concrete/Data/Highlight/SExp.hs | 36 ++++ src/Juvix/Prelude/Base.hs | 2 +- 7 files changed, 229 insertions(+), 132 deletions(-) create mode 100644 src/Juvix/Compiler/Concrete/Data/Highlight/Input.hs create mode 100644 src/Juvix/Compiler/Concrete/Data/Highlight/Properties.hs create mode 100644 src/Juvix/Compiler/Concrete/Data/Highlight/SExp.hs diff --git a/app/App.hs b/app/App.hs index a867d48270..7455690f87 100644 --- a/app/App.hs +++ b/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 diff --git a/app/Main.hs b/app/Main.hs index c9120e2a7e..1bc5f959d4 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -134,7 +134,7 @@ runCommand cmdWithOpts = do { _highlightNames = names, _highlightParsed = items } - say (Highlight.go hinput) + raw (Highlight.go Highlight.Json hinput) Parse localOpts -> do m <- head . (^. Parser.resultModules) diff --git a/src/Juvix/Compiler/Concrete/Data/Highlight.hs b/src/Juvix/Compiler/Concrete/Data/Highlight.hs index dc00ec1e77..7751abfbe3 100644 --- a/src/Juvix/Compiler/Concrete/Data/Highlight.hs +++ b/src/Juvix/Compiler/Concrete/Data/Highlight.hs @@ -1,59 +1,23 @@ -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] - } - -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) +go :: HighlightBackend -> HighlightInput -> ByteString +go = \case + Emacs -> Text.encodeUtf8 . renderSExp . toSexp . buildProperties + Json -> ByteString.toStrict . Aeson.encode . rawProperties . buildProperties goError :: [Interval] -> Text goError l = @@ -61,24 +25,16 @@ goError l = (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 +46,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 = succ (n ^. nameDefined . intervalStart . locOffset . unPos) + _gotoFile = n ^. nameDefined . intervalFile diff --git a/src/Juvix/Compiler/Concrete/Data/Highlight/Input.hs b/src/Juvix/Compiler/Concrete/Data/Highlight/Input.hs new file mode 100644 index 0000000000..a0a3fd423a --- /dev/null +++ b/src/Juvix/Compiler/Concrete/Data/Highlight/Input.hs @@ -0,0 +1,25 @@ +module Juvix.Compiler.Concrete.Data.Highlight.Input ( +module Juvix.Compiler.Concrete.Data.Highlight.Input, +module Juvix.Compiler.Concrete.Data.ParsedItem, + ) where + +import Juvix.Prelude +import Juvix.Compiler.Concrete.Data.ParsedItem +import Juvix.Compiler.Concrete.Data.ScopedName + +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) diff --git a/src/Juvix/Compiler/Concrete/Data/Highlight/Properties.hs b/src/Juvix/Compiler/Concrete/Data/Highlight/Properties.hs new file mode 100644 index 0000000000..a1b98ebb8a --- /dev/null +++ b/src/Juvix/Compiler/Concrete/Data/Highlight/Properties.hs @@ -0,0 +1,121 @@ +module Juvix.Compiler.Concrete.Data.Highlight.Properties where + +import Juvix.Compiler.Concrete.Data.Highlight.SExp +import Juvix.Prelude.Pretty +import Juvix.Prelude +import Juvix.Extra.Strings qualified as Str +import Data.Aeson.TH +import Data.Aeson qualified as Aeson +import Data.Aeson (ToJSON) +import Lens.Micro.Platform qualified as Lens + +data HighlightBackend + = Emacs + | Json + +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 :: Word64 + } + +data PropertyFace = PropertyFace + { _faceInterval :: Interval, + _faceFace :: Face + } + +data Properties = Properties + { _propertiesGoto :: [PropertyGoto], + _propertiesFace :: [PropertyFace] + } + +type RawInterval = (FilePath, Word64, Word64) +type RawFace = (RawInterval, Face) +type RawGoto = (RawInterval, FilePath, Word64) + +data RawProperties = RawProperties { + _rawPropertiesFace :: [RawFace], + _rawPropertiesGoto :: [RawGoto] + } + +$(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, i ^. intervalStart . locOffset . unPos, i ^. intervalEnd . locOffset . unPos) + rawFace :: PropertyFace -> RawFace + rawFace PropertyFace {..} = (rawInterval _faceInterval, _faceFace) + rawGoto :: PropertyGoto -> RawGoto + rawGoto PropertyGoto {..} = (rawInterval _gotoInterval, _gotoFile, _gotoPos) + +-- | 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) + +instance ToSexp Properties where + toSexp Properties {..} = + progn + ( map toSexp _propertiesFace + <> map toSexp _propertiesGoto + ) diff --git a/src/Juvix/Compiler/Concrete/Data/Highlight/SExp.hs b/src/Juvix/Compiler/Concrete/Data/Highlight/SExp.hs new file mode 100644 index 0000000000..c584d429fe --- /dev/null +++ b/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) diff --git a/src/Juvix/Prelude/Base.hs b/src/Juvix/Prelude/Base.hs index 8f8c19bb4a..608bd0fc26 100644 --- a/src/Juvix/Prelude/Base.hs +++ b/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 From 1204806581cafd89a953fde695ccae9ed6116221 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Thu, 11 Aug 2022 16:42:44 +0200 Subject: [PATCH 2/4] adapt json output to fit vscode --- src/Juvix/Compiler/Concrete/Data/Highlight.hs | 2 +- .../Compiler/Concrete/Data/Highlight/Input.hs | 11 +-- .../Concrete/Data/Highlight/Properties.hs | 68 ++++++++++++------- src/Juvix/Data/Loc.hs | 5 +- 4 files changed, 54 insertions(+), 32 deletions(-) diff --git a/src/Juvix/Compiler/Concrete/Data/Highlight.hs b/src/Juvix/Compiler/Concrete/Data/Highlight.hs index 7751abfbe3..fcbca42991 100644 --- a/src/Juvix/Compiler/Concrete/Data/Highlight.hs +++ b/src/Juvix/Compiler/Concrete/Data/Highlight.hs @@ -68,5 +68,5 @@ goGotoProperty :: AName -> PropertyGoto goGotoProperty (AName n) = PropertyGoto {..} where _gotoInterval = getLoc n - _gotoPos = succ (n ^. nameDefined . intervalStart . locOffset . unPos) + _gotoPos = n ^. nameDefined . intervalStart _gotoFile = n ^. nameDefined . intervalFile diff --git a/src/Juvix/Compiler/Concrete/Data/Highlight/Input.hs b/src/Juvix/Compiler/Concrete/Data/Highlight/Input.hs index a0a3fd423a..3ba734ae0b 100644 --- a/src/Juvix/Compiler/Concrete/Data/Highlight/Input.hs +++ b/src/Juvix/Compiler/Concrete/Data/Highlight/Input.hs @@ -1,11 +1,12 @@ -module Juvix.Compiler.Concrete.Data.Highlight.Input ( -module Juvix.Compiler.Concrete.Data.Highlight.Input, -module Juvix.Compiler.Concrete.Data.ParsedItem, - ) where +module Juvix.Compiler.Concrete.Data.Highlight.Input + ( module Juvix.Compiler.Concrete.Data.Highlight.Input, + module Juvix.Compiler.Concrete.Data.ParsedItem, + ) +where -import Juvix.Prelude import Juvix.Compiler.Concrete.Data.ParsedItem import Juvix.Compiler.Concrete.Data.ScopedName +import Juvix.Prelude data HighlightInput = HighlightInput { _highlightParsed :: [ParsedItem], diff --git a/src/Juvix/Compiler/Concrete/Data/Highlight/Properties.hs b/src/Juvix/Compiler/Concrete/Data/Highlight/Properties.hs index a1b98ebb8a..bedd3c7732 100644 --- a/src/Juvix/Compiler/Concrete/Data/Highlight/Properties.hs +++ b/src/Juvix/Compiler/Concrete/Data/Highlight/Properties.hs @@ -1,12 +1,11 @@ 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.Prelude.Pretty -import Juvix.Prelude import Juvix.Extra.Strings qualified as Str -import Data.Aeson.TH -import Data.Aeson qualified as Aeson -import Data.Aeson (ToJSON) +import Juvix.Prelude import Lens.Micro.Platform qualified as Lens data HighlightBackend @@ -47,7 +46,7 @@ instance ToJSON Face where data PropertyGoto = PropertyGoto { _gotoInterval :: Interval, _gotoFile :: FilePath, - _gotoPos :: Word64 + _gotoPos :: FileLoc } data PropertyFace = PropertyFace @@ -60,31 +59,50 @@ data Properties = Properties _propertiesFace :: [PropertyFace] } -type RawInterval = (FilePath, Word64, Word64) +-- | (File, Row, Col, Length) +type RawInterval = (FilePath, Int, Int, Int) + type RawFace = (RawInterval, Face) -type RawGoto = (RawInterval, FilePath, Word64) -data RawProperties = RawProperties { - _rawPropertiesFace :: [RawFace], - _rawPropertiesGoto :: [RawGoto] - } +-- | (Interval, TargetFile, TargetLine, TargetColumn) +type RawGoto = (RawInterval, FilePath, Int, Int) -$(deriveToJSON defaultOptions{fieldLabelModifier = over Lens._head toLower . dropPrefix "_rawProperties", - constructorTagModifier = map toLower} ''RawProperties) +data RawProperties = RawProperties + { _rawPropertiesFace :: [RawFace], + _rawPropertiesGoto :: [RawGoto] + } +$( 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 - } +rawProperties Properties {..} = + RawProperties + { _rawPropertiesGoto = map rawGoto _propertiesGoto, + _rawPropertiesFace = map rawFace _propertiesFace + } where - rawInterval :: Interval -> RawInterval - rawInterval i = (i ^. intervalFile, i ^. intervalStart . locOffset . unPos, i ^. intervalEnd . locOffset . unPos) - rawFace :: PropertyFace -> RawFace - rawFace PropertyFace {..} = (rawInterval _faceInterval, _faceFace) - rawGoto :: PropertyGoto -> RawGoto - rawGoto PropertyGoto {..} = (rawInterval _gotoInterval, _gotoFile, _gotoPos) + 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 @@ -111,7 +129,7 @@ instance ToSexp PropertyGoto where pos l = Int (succ (l ^. locOffset . unPos)) start = pos (i ^. intervalStart) end = pos (i ^. intervalEnd) - gotoPair = Pair (String targetFile) (Int targetPos) + gotoPair = Pair (String targetFile) (Int (targetPos ^. locOffset . to (succ . fromIntegral))) instance ToSexp Properties where toSexp Properties {..} = diff --git a/src/Juvix/Data/Loc.hs b/src/Juvix/Data/Loc.hs index ca724fc3f1..5fa84ad1f1 100644 --- a/src/Juvix/Data/Loc.hs +++ b/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 From 038ee2207e2713471d83e6849d9854e6e89a1811 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Thu, 11 Aug 2022 23:06:37 +0200 Subject: [PATCH 3/4] add --format flag --- app/Commands/Dev.hs | 27 +++++++++++++++++-- app/Main.hs | 4 +-- src/Juvix/Compiler/Concrete/Data/Highlight.hs | 12 ++++++++- .../Concrete/Data/Highlight/Properties.hs | 14 ++++------ 4 files changed, 43 insertions(+), 14 deletions(-) diff --git a/app/Commands/Dev.hs b/app/Commands/Dev.hs index 26c5dceaa3..650d4429be 100644 --- a/app/Commands/Dev.hs +++ b/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 "THEME" + <> value Emacs + <> showDefault + <> help "selects a backend: 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 = diff --git a/app/Main.hs b/app/Main.hs index 1bc5f959d4..90e5216769 100644 --- a/app/Main.hs +++ b/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 } - raw (Highlight.go Highlight.Json hinput) + raw (Highlight.go _highlightBackend hinput) Parse localOpts -> do m <- head . (^. Parser.resultModules) diff --git a/src/Juvix/Compiler/Concrete/Data/Highlight.hs b/src/Juvix/Compiler/Concrete/Data/Highlight.hs index fcbca42991..784c7528b8 100644 --- a/src/Juvix/Compiler/Concrete/Data/Highlight.hs +++ b/src/Juvix/Compiler/Concrete/Data/Highlight.hs @@ -12,7 +12,17 @@ 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.Prelude +import Juvix.Prelude as Prelude hiding (show) +import Prelude qualified + +data HighlightBackend + = Emacs + | Json + +instance Show HighlightBackend where + show = \case + Emacs -> "emacs" + Json -> "json" go :: HighlightBackend -> HighlightInput -> ByteString go = \case diff --git a/src/Juvix/Compiler/Concrete/Data/Highlight/Properties.hs b/src/Juvix/Compiler/Concrete/Data/Highlight/Properties.hs index bedd3c7732..fb974108c3 100644 --- a/src/Juvix/Compiler/Concrete/Data/Highlight/Properties.hs +++ b/src/Juvix/Compiler/Concrete/Data/Highlight/Properties.hs @@ -8,10 +8,6 @@ import Juvix.Extra.Strings qualified as Str import Juvix.Prelude import Lens.Micro.Platform qualified as Lens -data HighlightBackend - = Emacs - | Json - data Face = FaceConstructor | FaceInductive @@ -59,6 +55,11 @@ data Properties = Properties _propertiesFace :: [PropertyFace] } +data RawProperties = RawProperties + { _rawPropertiesFace :: [RawFace], + _rawPropertiesGoto :: [RawGoto] + } + -- | (File, Row, Col, Length) type RawInterval = (FilePath, Int, Int, Int) @@ -67,11 +68,6 @@ type RawFace = (RawInterval, Face) -- | (Interval, TargetFile, TargetLine, TargetColumn) type RawGoto = (RawInterval, FilePath, Int, Int) -data RawProperties = RawProperties - { _rawPropertiesFace :: [RawFace], - _rawPropertiesGoto :: [RawGoto] - } - $( deriveToJSON defaultOptions { fieldLabelModifier = over Lens._head toLower . dropPrefix "_rawProperties", From 9d73d355cce3be2a9070f6c771a9aaff16761cb5 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Thu, 11 Aug 2022 23:29:35 +0200 Subject: [PATCH 4/4] fix help message --- app/Commands/Dev.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/app/Commands/Dev.hs b/app/Commands/Dev.hs index 650d4429be..720f6230e6 100644 --- a/app/Commands/Dev.hs +++ b/app/Commands/Dev.hs @@ -70,10 +70,10 @@ commandHighlight = option (eitherReader parseBackend) ( long "format" - <> metavar "THEME" + <> metavar "FORMAT" <> value Emacs <> showDefault - <> help "selects a backend: emacs | json" + <> help "selects a backend. FORMAT = emacs | json" ) pure HighlightOptions {..} parseBackend :: String -> Either String HighlightBackend