Last active
January 14, 2020 15:22
-
-
Save chrisdone/213d55058ebe3fefc7fc3fed5fbcdcc6 to your computer and use it in GitHub Desktop.
Lexx - Show printer
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE DeriveFunctor #-} | |
{-# LANGUAGE OverloadedStrings #-} | |
{-# LANGUAGE FlexibleContexts #-} | |
{-# LANGUAGE LambdaCase #-} | |
-- | Show instance lexer and pretty-printer. | |
module Lexx where | |
import Control.Monad.State | |
import Control.Monad.Writer | |
import Data.Char | |
import Data.Maybe | |
import Data.String | |
import Lucid | |
import Rainbow | |
-- | Commands are actions that the renderer will do. | |
data Command token | |
= Type token | |
| Return | |
| Indent Int | |
| Deindent Int | |
deriving (Show, Eq, Functor) | |
-- | Tokens are very liberal and a small number of them. | |
data Token | |
= Constructor String | |
| Delimiter String | |
| String String | |
| Misc String | |
| Digits String | |
deriving (Show, Eq) | |
-- | Lex the input into commands. | |
lexx :: String -> [Command Token] | |
lexx = cleanUp . execWriter . go | |
where | |
go i = | |
case span (not . flip elem boundaries) i of | |
(before, after) -> do | |
unless | |
(null before) | |
(tell | |
[ Type | |
(if maybe False isUpper (listToMaybe before) | |
then Constructor before | |
else if all isDigit before | |
then Digits before | |
else Misc before) | |
]) | |
case after of | |
('[':']':rest) -> do | |
tell [Type (Delimiter "[]")] | |
go rest | |
('(':')':rest) -> do | |
tell [Type (Delimiter "()")] | |
go rest | |
(')':' ':'(':rest) -> do | |
tell [Type (Delimiter ")"), Return, Type (Delimiter "(")] | |
go rest | |
(c:rest) -> do | |
let tellNGo x = tell x *> go rest | |
case c of | |
'{' -> tellNGo [Type (Delimiter (pure c)), Indent 2, Return] | |
'}' -> tellNGo [Deindent 2, Return, Type (Delimiter (pure c))] | |
'[' -> tellNGo [Type (Delimiter (pure c)), Indent 1, Return] | |
']' -> tellNGo [Deindent 1, Return, Type (Delimiter (pure c))] | |
',' -> tellNGo [Type (Delimiter (pure c)), Return] | |
'=' -> tellNGo [Type (Delimiter (pure c))] | |
'(' -> tellNGo [Type (Delimiter (pure c)), Indent 1] | |
')' -> tellNGo [Type (Delimiter (pure c)), Deindent 1] | |
'"' -> | |
case reads (c : rest) of | |
[(string, rest')] -> do | |
tell [Type (String string)] | |
go rest' | |
_ -> tellNGo [Type (Misc (pure c))] | |
_ -> tellNGo [Type (Misc (pure c))] | |
[] -> pure () | |
boundaries = "={}[]()\"\"'', " :: String | |
-- | Get the plain string from a token. | |
tokenString :: Token -> String | |
tokenString = | |
\case | |
Delimiter s -> s | |
Digits s -> s | |
Constructor s -> s | |
String s -> show s | |
Misc s -> s | |
-- | Clean up redundancy. | |
cleanUp :: [Command Token] -> [Command Token] | |
cleanUp (Return:Type (Misc spaces):xs) | all isSpace spaces = cleanUp (Return:xs) | |
cleanUp (Return:Return:xs)= cleanUp (Return:xs) | |
cleanUp (x:xs) = x : cleanUp xs | |
cleanUp [] = [] | |
-- | Render to plain string. | |
commandsToString :: [Command String] -> String | |
commandsToString = execWriter . flip runStateT 0 . mapM_ go | |
where | |
go = | |
\case | |
Type str -> tell str | |
Return -> do | |
tell "\n" | |
c <- get | |
tell (replicate c ' ') | |
Indent i -> modify (+ i) | |
Deindent i -> modify (subtract i) | |
-- | Render to TTY colored terminal chunks. | |
commandsToRainbow :: [Command Token] -> [Rainbow.Chunk] | |
commandsToRainbow = execWriter . flip runStateT 0 . mapM_ go | |
where | |
go = | |
\case | |
Type token -> | |
tell | |
[ case token of | |
String str -> fore yellow (fromString (show str)) | |
Constructor str -> fore blue (fromString str) | |
Delimiter d -> fore green (fromString d) | |
Misc text -> fromString text | |
Digits d -> fore red (fromString d) | |
] | |
Return -> do | |
tell ["\n"] | |
c <- get | |
tell [fromString (replicate c ' ')] | |
Indent i -> modify (+ i) | |
Deindent i -> modify (subtract i) | |
-- | Render to HTML with class names. | |
commandsToHtml :: Monad m => [Command Token] -> HtmlT m () | |
commandsToHtml = flip evalStateT 0 . mapM_ go | |
where | |
go = | |
\case | |
Type token -> | |
case token of | |
String str -> fore' "string" (toHtml (show str)) | |
Constructor str -> fore' "constructor" (toHtml str) | |
Delimiter d -> fore' "delimiter" (toHtml d) | |
Digits d -> fore' "digits" (toHtml d) | |
Misc text -> fore' "misc" (toHtml text) | |
Return -> do | |
lift "\n" | |
c <- get | |
lift (fromString (replicate c ' ')) | |
Indent i -> modify (+ i) | |
Deindent i -> modify (subtract i) | |
fore' color inner = lift (span_ [class_ ("lexx-" <> color)] inner) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment