diff --git a/exe/Main.idr b/exe/Main.idr index 2ee4c6d..45a377d 100644 --- a/exe/Main.idr +++ b/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 diff --git a/exe/Options.idr b/exe/Options.idr index 3efac83..a4f329f 100644 --- a/exe/Options.idr +++ b/exe/Options.idr @@ -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 "") "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 "") + "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 diff --git a/lib/Quox/Pretty.idr b/lib/Quox/Pretty.idr index ac62adb..11aab94 100644 --- a/lib/Quox/Pretty.idr +++ b/lib/Quox/Pretty.idr @@ -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 #""# "" + + +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