Skip to content

Commit ae8a0f4

Browse files
chamecobmcutler
chameco
authored and
bmcutler
committed
Interactive diagnostics (#58)
* Interactive diagnostics, a number of lexer fixes for C and Python, pretty-printed JSON diagnostics for tokens and nodes. * Minor fixes * danger-hlint fails silently if hlint is not on the PATH
1 parent b0f9d5b commit ae8a0f4

File tree

12 files changed

+327
-172
lines changed

12 files changed

+327
-172
lines changed

‎.travis.yml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -22,7 +22,7 @@ script:
2222
- stack test --only-dependencies
2323
- "./bin/hlint '--ignore=Parse error' src"
2424
- "./bin/hlint '--ignore=Parse error' app"
25-
- danger
25+
- PATH=./bin:$PATH danger
2626
deploy:
2727
provider: releases
2828
api_key:

‎lichen.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -47,6 +47,7 @@ library
4747

4848
, Lichen.Diagnostics.Main
4949
, Lichen.Diagnostics.Config
50+
, Lichen.Diagnostics.Render
5051
build-depends: base >= 4.7 && < 5
5152
, containers
5253
, split

‎src/Lichen/Count/Main.hs

Lines changed: 6 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -41,8 +41,11 @@ realMain ic = do
4141
flip runConfigured options $ do
4242
config <- ask
4343
t <- case toCount config of Just t -> return t; Nothing -> throwError $ InvocationError "No countable element specified"
44-
ps <- liftIO . mapM canonicalizePath $ sourceFiles config
45-
counts <- lift $ mapM (runCounter (counter config) (language config) t) ps
46-
liftIO . print $ sum counts
44+
if null $ sourceFiles config
45+
then throwError $ InvocationError "No source files provided"
46+
else do
47+
ps <- liftIO . mapM canonicalizePath $ sourceFiles config
48+
counts <- lift $ mapM (runCounter (counter config) (language config) t) ps
49+
liftIO . print $ sum counts
4750
where opts c = info (helper <*> parseOptions c)
4851
(fullDesc <> progDesc "Count occurences of a specific language feature" <> header "count - feature counting")

‎src/Lichen/Diagnostics/Config.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -10,18 +10,21 @@ import Lichen.Languages
1010

1111
data Config = Config { configFile :: FilePath
1212
, language :: Language
13+
, outputFormat :: String
1314
, sourceFiles :: [FilePath]
1415
}
1516
instance FromJSON Config where
1617
parseJSON = withObject "config_diagnostics" $ \o -> do
1718
configFile <- fromMaybe (configFile defaultConfig) <$> o .:? "config_file"
1819
language <- fromMaybe (language defaultConfig) <$> o .:? "language"
20+
outputFormat <- fromMaybe (outputFormat defaultConfig) <$> o .:? "output_format"
1921
sourceFiles <- fromMaybe (sourceFiles defaultConfig) <$> o .:? "source_files"
2022
return Config{..}
2123

2224
defaultConfig :: Config
2325
defaultConfig = Config { configFile = ".lichenrc"
2426
, language = langDummy
27+
, outputFormat = "json"
2528
, sourceFiles = []
2629
}
2730

‎src/Lichen/Diagnostics/Main.hs

Lines changed: 40 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -6,13 +6,17 @@ import System.Directory
66

77
import Data.Aeson
88
import Data.Aeson.Types (Pair)
9+
import Data.Aeson.Encode.Pretty (encodePretty)
910
import Data.Semigroup ((<>))
1011
import qualified Data.Text as T
1112
import qualified Data.Text.Lazy.Encoding as T.L.E
1213
import qualified Data.Text.Lazy.IO as T.L.IO
1314
import qualified Data.ByteString as BS
1415
import qualified Data.ByteString.Lazy as BS.L
1516

17+
import Text.Blaze.Html.Renderer.Utf8
18+
import qualified Text.Blaze.Html5 as H
19+
1620
import Control.Monad.Reader
1721
import Control.Monad.Except
1822

@@ -23,35 +27,57 @@ import Lichen.Error
2327
import Lichen.Config
2428
import Lichen.Languages
2529
import Lichen.Diagnostics.Config
30+
import Lichen.Diagnostics.Render
31+
32+
diagnosticsJSON :: Language -> FilePath -> Erring Pair
33+
diagnosticsJSON (Language _ _ _ lr pr) p = do
34+
src <- liftIO $ BS.readFile p
35+
tokens <- lr p src
36+
nodes <- pr p src
37+
return $ T.pack p .= object [ "tokens" .= toJSON tokens
38+
, "nodes" .= toJSON nodes
39+
]
2640

27-
diagnosticsToken :: Language -> FilePath -> Erring Pair
28-
diagnosticsToken (Language _ _ _ l _) p = do
41+
diagnosticsHTML :: Language -> FilePath -> Erring H.Html
42+
diagnosticsHTML (Language _ _ _ lr _) p = do
2943
src <- liftIO $ BS.readFile p
30-
tokens <- l p src
31-
return $ T.pack p .= toJSON tokens
44+
tokens <- lr p src
45+
tokensPage <- liftIO $ renderTokens p tokens
46+
return $ renderPage tokensPage
3247

3348
parseOptions :: Config -> Parser Config
3449
parseOptions dc = Config
3550
<$> strOption (long "config-file" <> short 'c' <> metavar "PATH" <> showDefault <> value (configFile dc) <> help "Configuration file")
3651
<*> (languageChoice (language dc) <$> (optional . strOption $ long "language" <> short 'l' <> metavar "LANG" <> help "Language of student code"))
52+
<*> strOption (long "output-format" <> short 'f' <> metavar "FORMAT" <> showDefault <> value (outputFormat dc) <> help "Output format")
3753
<*> many (argument str (metavar "SOURCE"))
3854

3955
realMain :: Config -> IO ()
4056
realMain ic = do
4157
iopts <- liftIO . execParser $ opts ic
4258
mcsrc <- readSafe BS.L.readFile Nothing $ configFile iopts
43-
options <- case mcsrc of Just csrc -> do
44-
c <- case eitherDecode csrc of Left e -> (printError . JSONDecodingError $ T.pack e) >> pure ic
45-
Right t -> pure t
46-
liftIO . execParser $ opts c
47-
Nothing -> pure iopts
59+
options <- case mcsrc of
60+
Just csrc -> do
61+
c <- case eitherDecode csrc of
62+
Left e -> (printError . JSONDecodingError $ T.pack e) >> pure ic
63+
Right t -> pure t
64+
liftIO . execParser $ opts c
65+
Nothing -> pure iopts
4866
flip runConfigured options $ do
4967
config <- ask
5068
if null $ sourceFiles config
51-
then throwError $ InvocationError "No source files provided"
52-
else do
53-
ps <- liftIO . mapM canonicalizePath $ sourceFiles config
54-
os <- lift $ mapM (diagnosticsToken (language config)) ps
55-
liftIO . T.L.IO.putStrLn . T.L.E.decodeUtf8 . encode $ object os
69+
then throwError $ InvocationError "No source files provided"
70+
else do
71+
ps <- liftIO . mapM canonicalizePath $ sourceFiles config
72+
case outputFormat config of
73+
"html" -> do
74+
page <- lift . diagnosticsHTML (language config) $ head ps
75+
liftIO . T.L.IO.putStrLn . T.L.E.decodeUtf8 $ renderHtml page
76+
"dense" -> do
77+
os <- lift $ mapM (diagnosticsJSON (language config)) ps
78+
liftIO . T.L.IO.putStrLn . T.L.E.decodeUtf8 . encode $ object os
79+
_ -> do
80+
os <- lift $ mapM (diagnosticsJSON (language config)) ps
81+
liftIO . T.L.IO.putStrLn . T.L.E.decodeUtf8 . encodePretty $ object os
5682
where opts c = info (helper <*> parseOptions c)
5783
(fullDesc <> progDesc "Output diagnostic information about source files" <> header "diagnostics - output assorted information about source code")

‎src/Lichen/Diagnostics/Render.hs

Lines changed: 91 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,91 @@
1+
{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
2+
3+
module Lichen.Diagnostics.Render where
4+
5+
import Data.List
6+
import Data.Monoid ((<>))
7+
import qualified Data.Text as T
8+
import qualified Data.Text.IO as T.IO
9+
10+
import Text.Megaparsec.Pos (unPos)
11+
import Text.Blaze.Html5 ((!))
12+
import qualified Text.Blaze.Html5 as H
13+
import qualified Text.Blaze.Html5.Attributes as A
14+
15+
import Clay ((?))
16+
import qualified Clay as C
17+
import qualified Clay.Render as C.R
18+
import qualified Clay.Text as C.T
19+
import qualified Clay.Font as C.F
20+
21+
import Language.Javascript.JMacro
22+
23+
import Lichen.Util
24+
import Lichen.Lexer
25+
26+
data Colored a = Uncolored T.Text | Colored a T.Text deriving (Show, Eq)
27+
28+
hs :: Show a => a -> H.Html
29+
hs = H.toHtml . sq
30+
31+
stylesheet :: C.Css
32+
stylesheet = mconcat [ ".centered" ? C.textAlign C.center
33+
, ".matches" ? C.color C.white <> C.backgroundColor C.grey
34+
, ".hovering" ? C.color C.white <> C.backgroundColor C.blue
35+
, ".pane" ? mconcat [ C.whiteSpace C.T.pre
36+
, C.fontFamily [] [C.F.monospace]
37+
]
38+
]
39+
40+
javascript :: JStat
41+
javascript = [jmacro|
42+
$(".matches").each(function () {
43+
$(this).hover(function () { $(this).toggleClass("hovering"); });
44+
});
45+
|]
46+
47+
colorize :: Show a => Colored a -> H.Html
48+
colorize (Uncolored t) = H.toHtml t
49+
colorize (Colored x t) = H.span ! A.class_ "matches" ! A.title (H.stringValue $ show x) $ H.toHtml t
50+
51+
splitInto :: T.Text -> [((Int, Int), a)] -> [Colored a]
52+
splitInto = go 0 where
53+
go _ s [] | T.null s = []
54+
| otherwise = [Uncolored s]
55+
go off s (((sp, ep), x):ps) = if T.null preTok then Colored x tok:go ep postTok ps else Uncolored preTok:Colored x tok:go ep postTok ps
56+
where (preTok, preTokRest) = T.splitAt (sp - off) s
57+
(tok, postTok) = T.splitAt (ep - sp) preTokRest
58+
59+
toPosList :: Show a => T.Text -> [Tagged a] -> [((Int, Int), a)]
60+
toPosList s p = sortBy (\a b -> compare (fst a) (fst b)) $ fmap convertPos p where
61+
ls = T.lines s
62+
convertPos :: Tagged a -> ((Int, Int), a)
63+
convertPos (Tagged x tp) = ((spos, epos), x) where
64+
spos = lineColToAbs (fromIntegral . unPos $ startLine tp) (fromIntegral . unPos $ startCol tp)
65+
epos = lineColToAbs (fromIntegral . unPos $ endLine tp) (fromIntegral . unPos $ endCol tp)
66+
lineColToAbs :: Int -> Int -> Int
67+
lineColToAbs l c = c + (l - 2) + sum (T.length <$> take (l - 1) ls)
68+
69+
renderTokens :: Show a => FilePath -> [Tagged a] -> IO H.Html
70+
renderTokens path ts = do
71+
s <- T.IO.readFile path
72+
let es = T.replace "\t" " " s
73+
return . mconcat . fmap colorize . splitInto es $ toPosList es ts
74+
75+
renderPage :: H.Html -> H.Html
76+
renderPage b =
77+
H.docTypeHtml $ mconcat
78+
[ H.head $ mconcat
79+
[ H.meta ! A.charset "utf-8"
80+
, H.meta ! A.httpEquiv "X-UA-Compatible" ! A.content "IE=edge"
81+
, H.meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1"
82+
, H.title "Interactive Diagnostics"
83+
, H.style . H.toHtml $ C.renderWith C.R.compact [] stylesheet
84+
]
85+
, H.body $ mconcat
86+
[ H.h1 "Token Diagnostics"
87+
, H.div ! A.class_ "pane" $ b
88+
, H.script ! A.src "https://ajax.googleapis.com/ajax/libs/jquery/1.12.4/jquery.min.js" $ ""
89+
, H.script . hs $ renderJs javascript
90+
]
91+
]

‎src/Lichen/Lexer.hs

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -45,6 +45,12 @@ wrapid p = do
4545
s <- p
4646
return . Tagged s $ TokPos (sourceLine pos) (sourceLine pos) (sourceColumn pos) (sourceColumn pos <> unsafePos (fromIntegral $ length s))
4747

48+
reserved :: String -> Parser String
49+
reserved s = try (string s >> notFollowedBy (alphaNumChar <|> char '_') >> pure s)
50+
51+
operator :: String -> Parser String
52+
operator = try . string
53+
4854
-- Parse a C-style character literal. Ex: 'a', '@'.
4955
charLit :: Parser String
5056
charLit = char '\'' *> manyTill (noneOf ['\'']) (char '\'' <|> (eof >> pure ' '))
@@ -53,6 +59,9 @@ charLit = char '\'' *> manyTill (noneOf ['\'']) (char '\'' <|> (eof >> pure ' ')
5359
strLit :: Parser String
5460
strLit = char '\"' *> manyTill (noneOf ['"']) (char '\"' <|> (eof >> pure ' '))
5561

62+
quote :: String -> String
63+
quote s = ('"':s) ++ ['"']
64+
5665
-- Parse a C-style identifier (letter or underscore followed by any number
5766
-- of letters, digits, and underscores).
5867
ident :: Parser String

‎src/Lichen/Lexer/C.hs

Lines changed: 51 additions & 54 deletions
Original file line numberDiff line numberDiff line change
@@ -38,13 +38,10 @@ instance Hashable Tok
3838
sc :: Parser ()
3939
sc = void (many spaceChar)
4040

41-
reserved :: String -> Parser String
42-
reserved = try . string
43-
4441
onetoken :: Parser (Tagged Tok)
45-
onetoken = wrap (reserved "//" *> manyTill anyChar (char '\r' <|> (head <$> eol))) Comment
46-
<|> wrap (reserved "#" *> manyTill anyChar (char '\r' <|> (head <$> eol))) Comment
47-
<|> wrap (reserved "/*" *> manyTill anyChar (head <$> reserved "*/")) Comment
42+
onetoken = wrap (("//"++) <$> (operator "//" *> manyTill anyChar (char '\r' <|> (head <$> eol)))) Comment
43+
<|> wrap (("#"++) <$> (operator "#" *> manyTill anyChar (char '\r' <|> (head <$> eol)))) Comment
44+
<|> wrap (("/**/"++) <$> (operator "/*" *> manyTill anyChar (head <$> operator "*/"))) Comment
4845
<|> wrap (reserved "auto") Auto
4946
<|> wrap (reserved "break") Break
5047
<|> wrap (reserved "case") Case
@@ -93,54 +90,54 @@ onetoken = wrap (reserved "//" *> manyTill anyChar (char '\r' <|> (head <$> eol)
9390
<|> wrap ident Identifier
9491
<|> wrap (show <$> L.integer) IntegerLiteral
9592
<|> wrap (show <$> L.float) FloatLiteral
96-
<|> wrap (show <$> strLit) StringLiteral
97-
<|> wrap (show <$> charLit) CharLiteral
98-
<|> wrap (reserved "...") Ellipsis
99-
<|> wrap (reserved ">>=") RightAssign
100-
<|> wrap (reserved "<<=") LeftAssign
101-
<|> wrap (reserved "+=") AddAssign
102-
<|> wrap (reserved "-=") SubAssign
103-
<|> wrap (reserved "*=") MulAssign
104-
<|> wrap (reserved "/=") DivAssign
105-
<|> wrap (reserved "%=") ModAssign
106-
<|> wrap (reserved "&=") AndAssign
107-
<|> wrap (reserved "^=") XorAssign
108-
<|> wrap (reserved "|=") OrAssign
109-
<|> wrap (reserved ">>") RightOp
110-
<|> wrap (reserved "<<") LeftOp
111-
<|> wrap (reserved "++") IncOp
112-
<|> wrap (reserved "--") DecOp
113-
<|> wrap (reserved "->") PtrOp
114-
<|> wrap (reserved "&&") AndOp
115-
<|> wrap (reserved "||") OrOp
116-
<|> wrap (reserved "<=") LeOp
117-
<|> wrap (reserved ">=") GeOp
118-
<|> wrap (reserved "==") EqOp
119-
<|> wrap (reserved "!=") NeOp
120-
<|> wrap (reserved ";") Semicolon
121-
<|> wrap (reserved "{" <|> reserved "<%") LeftCurly
122-
<|> wrap (reserved "}" <|> reserved "%>") RightCurly
123-
<|> wrap (reserved ",") Comma
124-
<|> wrap (reserved ":") Colon
125-
<|> wrap (reserved "=") Equal
126-
<|> wrap (reserved "(") LeftParen
127-
<|> wrap (reserved ")") RightParen
128-
<|> wrap (reserved "[" <|> reserved "<:") LeftSquare
129-
<|> wrap (reserved "]" <|> reserved ":>") RightSquare
130-
<|> wrap (reserved ".") Dot
131-
<|> wrap (reserved "&") Ampersand
132-
<|> wrap (reserved "!") Exclamation
133-
<|> wrap (reserved "~") Tilde
134-
<|> wrap (reserved "-") Minus
135-
<|> wrap (reserved "+") Plus
136-
<|> wrap (reserved "*") Asterisk
137-
<|> wrap (reserved "/") Slash
138-
<|> wrap (reserved "%") Percent
139-
<|> wrap (reserved "<") LessThan
140-
<|> wrap (reserved ">") GreaterThan
141-
<|> wrap (reserved "^") Caret
142-
<|> wrap (reserved "|") Pipe
143-
<|> wrap (reserved "?") Question
93+
<|> wrap (quote <$> strLit) StringLiteral
94+
<|> wrap (quote <$> charLit) CharLiteral
95+
<|> wrap (operator "...") Ellipsis
96+
<|> wrap (operator ">>=") RightAssign
97+
<|> wrap (operator "<<=") LeftAssign
98+
<|> wrap (operator "+=") AddAssign
99+
<|> wrap (operator "-=") SubAssign
100+
<|> wrap (operator "*=") MulAssign
101+
<|> wrap (operator "/=") DivAssign
102+
<|> wrap (operator "%=") ModAssign
103+
<|> wrap (operator "&=") AndAssign
104+
<|> wrap (operator "^=") XorAssign
105+
<|> wrap (operator "|=") OrAssign
106+
<|> wrap (operator ">>") RightOp
107+
<|> wrap (operator "<<") LeftOp
108+
<|> wrap (operator "++") IncOp
109+
<|> wrap (operator "--") DecOp
110+
<|> wrap (operator "->") PtrOp
111+
<|> wrap (operator "&&") AndOp
112+
<|> wrap (operator "||") OrOp
113+
<|> wrap (operator "<=") LeOp
114+
<|> wrap (operator ">=") GeOp
115+
<|> wrap (operator "==") EqOp
116+
<|> wrap (operator "!=") NeOp
117+
<|> wrap (operator ";") Semicolon
118+
<|> wrap (operator "{" <|> reserved "<%") LeftCurly
119+
<|> wrap (operator "}" <|> reserved "%>") RightCurly
120+
<|> wrap (operator ",") Comma
121+
<|> wrap (operator ":") Colon
122+
<|> wrap (operator "=") Equal
123+
<|> wrap (operator "(") LeftParen
124+
<|> wrap (operator ")") RightParen
125+
<|> wrap (operator "[" <|> reserved "<:") LeftSquare
126+
<|> wrap (operator "]" <|> reserved ":>") RightSquare
127+
<|> wrap (operator ".") Dot
128+
<|> wrap (operator "&") Ampersand
129+
<|> wrap (operator "!") Exclamation
130+
<|> wrap (operator "~") Tilde
131+
<|> wrap (operator "-") Minus
132+
<|> wrap (operator "+") Plus
133+
<|> wrap (operator "*") Asterisk
134+
<|> wrap (operator "/") Slash
135+
<|> wrap (operator "%") Percent
136+
<|> wrap (operator "<") LessThan
137+
<|> wrap (operator ">") GreaterThan
138+
<|> wrap (operator "^") Caret
139+
<|> wrap (operator "|") Pipe
140+
<|> wrap (operator "?") Question
144141
<|> wrap ((:[]) <$> anyChar) Unknown
145142

146143
lex :: Lexer Tok

0 commit comments

Comments
 (0)