add html output highlighting
This commit is contained in:
parent
040a1862c3
commit
c48b7be559
3 changed files with 57 additions and 22 deletions
16
exe/Main.idr
16
exe/Main.idr
|
|
@ -27,13 +27,18 @@ die opts err = do
|
|||
ignore $ fPutStr stderr $ render opts err
|
||||
exitFailure
|
||||
|
||||
private
|
||||
hlFor : HLType -> OutFile -> HL -> Highlight
|
||||
hlFor Guess Console = highlightSGR
|
||||
hlFor Guess _ = noHighlight
|
||||
hlFor NoHL _ = noHighlight
|
||||
hlFor Term _ = highlightSGR
|
||||
hlFor Html _ = highlightHtml
|
||||
|
||||
private
|
||||
runPretty : Options -> Eff Pretty a -> a
|
||||
runPretty opts act =
|
||||
let doColor = opts.color && opts.outFile == Console
|
||||
hl = if doColor then highlightSGR else noHighlight
|
||||
in
|
||||
runPrettyWith Outer opts.flavor hl 2 act
|
||||
runPrettyWith Outer opts.flavor (hlFor opts.hlType opts.outFile) 2 act
|
||||
|
||||
private
|
||||
putErrLn : HasIO io => String -> io ()
|
||||
|
|
@ -133,7 +138,7 @@ private
|
|||
outputStr : Lazy String -> Eff Compile ()
|
||||
outputStr str =
|
||||
case !(asksAt OPTS outFile) of
|
||||
None => pure ()
|
||||
NoOut => pure ()
|
||||
Console => putStr str
|
||||
File f => do
|
||||
res <- withFile f WriteTruncate pure $ \h => fPutStr h str
|
||||
|
|
@ -187,6 +192,7 @@ oneMain [] = throw NoMain
|
|||
oneMain [x] = pure x
|
||||
oneMain mains = throw $ MultipleMains mains
|
||||
|
||||
|
||||
private
|
||||
processFile : String -> Eff Compile ()
|
||||
processFile file = withEarlyStop $ do
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ import Derive.Prelude
|
|||
%language ElabReflection
|
||||
|
||||
public export
|
||||
data OutFile = File String | Console | None
|
||||
data OutFile = File String | Console | NoOut
|
||||
%name OutFile f
|
||||
%runElab derive "OutFile" [Eq, Ord, Show]
|
||||
|
||||
|
|
@ -28,10 +28,15 @@ allPhases = %runElab do
|
|||
cs <- getCons $ fst !(lookupName "Phase")
|
||||
traverse (check . var) cs
|
||||
|
||||
||| "guess" is Term for a terminal and NoHL for a file
|
||||
public export
|
||||
data HLType = Guess | NoHL | Term | Html
|
||||
%runElab derive "HLType" [Eq, Ord, Show]
|
||||
|
||||
public export
|
||||
record Options where
|
||||
constructor MkOpts
|
||||
color : Bool
|
||||
hlType : HLType
|
||||
outFile : OutFile
|
||||
until : Maybe Phase
|
||||
flavor : Pretty.Flavor
|
||||
|
|
@ -49,7 +54,7 @@ defaultWidth = do
|
|||
export
|
||||
defaultOpts : IO Options
|
||||
defaultOpts = pure $ MkOpts {
|
||||
color = True,
|
||||
hlType = Guess,
|
||||
outFile = Console,
|
||||
until = Nothing,
|
||||
flavor = Unicode,
|
||||
|
|
@ -66,7 +71,7 @@ data OptAction = ShowHelp HelpType | Err String | Ok (Options -> Options)
|
|||
|
||||
private
|
||||
toOutFile : String -> OptAction
|
||||
toOutFile "" = Ok {outFile := None}
|
||||
toOutFile "" = Ok {outFile := NoOut}
|
||||
toOutFile "-" = Ok {outFile := Console}
|
||||
toOutFile f = Ok {outFile := File f}
|
||||
|
||||
|
|
@ -85,6 +90,14 @@ toWidth s = case parsePositive s of
|
|||
Just n => Ok {width := n}
|
||||
Nothing => Err "invalid width: \{show s}"
|
||||
|
||||
private
|
||||
toHLType : String -> OptAction
|
||||
toHLType str = case toLower str of
|
||||
"none" => Ok {hlType := NoHL}
|
||||
"term" => Ok {hlType := Term}
|
||||
"html" => Ok {hlType := Html}
|
||||
_ => Err "unknown highlighting type \{str}\ntypes: term, html, none"
|
||||
|
||||
private
|
||||
commonOptDescrs' : List (OptDescr OptAction)
|
||||
commonOptDescrs' = [
|
||||
|
|
@ -105,10 +118,8 @@ extraOptDescrs = [
|
|||
"use ascii syntax when printing",
|
||||
MkOpt [] ["width"] (ReqArg toWidth "<width>")
|
||||
"max output width (defaults to terminal width)",
|
||||
MkOpt [] ["color", "colour"] (NoArg $ Ok {color := True})
|
||||
"use colour output (default)",
|
||||
MkOpt [] ["no-color", "no-colour"] (NoArg $ Ok {color := False})
|
||||
"don't use colour output"
|
||||
MkOpt [] ["color", "colour"] (ReqArg toHLType "<type>")
|
||||
"select highlighting type"
|
||||
]
|
||||
|
||||
private
|
||||
|
|
@ -123,10 +134,10 @@ allOptDescrs = commonOptDescrs' ++ extraOptDescrs ++ helpOptDescrs
|
|||
|
||||
export
|
||||
usageHeader : String
|
||||
usageHeader = joinBy "\n" [
|
||||
"quox [options] [file.quox ...]",
|
||||
"rawr"
|
||||
]
|
||||
usageHeader = trim """
|
||||
quox [options] [file.quox ...]
|
||||
rawr
|
||||
"""
|
||||
|
||||
export
|
||||
usage : List (OptDescr _) -> IO a
|
||||
|
|
|
|||
|
|
@ -92,14 +92,32 @@ export %inline
|
|||
highlightSGR : HL -> Highlight
|
||||
highlightSGR h = MkHighlight (escapeSGR $ toSGR h) (escapeSGR [Reset])
|
||||
|
||||
export %inline
|
||||
toClass : HL -> String
|
||||
toClass Delim = "dl"
|
||||
toClass Free = "fr"
|
||||
toClass TVar = "tv"
|
||||
toClass TVarErr = "tv err"
|
||||
toClass Dim = "dc"
|
||||
toClass DVar = "dv"
|
||||
toClass DVarErr = "dv err"
|
||||
toClass Qty = "qt"
|
||||
toClass Universe = "un"
|
||||
toClass Syntax = "sy"
|
||||
toClass Constant = "co"
|
||||
|
||||
export %inline
|
||||
highlightHtml : HL -> Highlight
|
||||
highlightHtml h = MkHighlight #"<span class="\#{toClass h}">"# "</span>"
|
||||
|
||||
|
||||
export %inline
|
||||
runPrettyHL : (HL -> Highlight) -> Eff Pretty a -> a
|
||||
runPrettyHL f = runPrettyWith Outer Unicode f 2
|
||||
|
||||
export %inline
|
||||
runPretty : Eff Pretty a -> a
|
||||
runPretty = runPrettyWith Outer Unicode noHighlight 2
|
||||
|
||||
export %inline
|
||||
runPrettyColor : Eff Pretty a -> a
|
||||
runPrettyColor = runPrettyWith Outer Unicode highlightSGR 2
|
||||
runPretty = runPrettyHL noHighlight
|
||||
|
||||
|
||||
export %inline
|
||||
|
|
|
|||
Loading…
Reference in a new issue