Syntax highlighting suppport, but no colors in CSS yet

This commit is contained in:
fr33domlover 2016-04-12 11:21:14 +00:00
parent 3a0a7026d0
commit 05f537d288
4 changed files with 34 additions and 6 deletions

View file

@ -32,11 +32,14 @@ where
-- [x] write the git and mkdir parts that actually create the repo -- [x] write the git and mkdir parts that actually create the repo
-- [x] make repo view that shows a table of commits -- [x] make repo view that shows a table of commits
import ClassyPrelude.Conduit hiding (unpack) import ClassyPrelude.Conduit hiding (last, toStrict, unpack)
import Yesod hiding (Header, parseTime, (==.)) import Yesod hiding (Header, parseTime, (==.))
import Yesod.Auth import Yesod.Auth
import Prelude (last)
import Data.Byteable (toBytes) import Data.Byteable (toBytes)
import Data.ByteString.Lazy (toStrict)
import Data.Git.Graph import Data.Git.Graph
import Data.Git.Graph.Util import Data.Git.Graph.Util
import Data.Git.Named (RefName (..)) import Data.Git.Named (RefName (..))
@ -54,6 +57,8 @@ import Database.Esqueleto
import Data.Hourglass (timeConvert) import Data.Hourglass (timeConvert)
import System.Directory (createDirectoryIfMissing) import System.Directory (createDirectoryIfMissing)
import System.Hourglass (dateCurrent) import System.Hourglass (dateCurrent)
import Text.Highlighter (lexerFromFilename, runLexer, Lexer (lName))
import Text.Highlighter.Formatters.Html (format)
import qualified Data.DList as D import qualified Data.DList as D
import qualified Data.Set as S (member) import qualified Data.Set as S (member)
@ -181,9 +186,28 @@ getRepoSourceR user proj repo ref dir = do
( if isTree then "[D]" else "[F]" :: Text ( if isTree then "[D]" else "[F]" :: Text
, toText $ toBytes name , toText $ toBytes name
) )
display = case view of display <- case view of
Left b -> Left $ toTextL $ blobGetContent b Left b ->
Right v -> Right $ map mkrow v let lbs = blobGetContent b
bs = toStrict lbs
in Left <$>
case lexerFromFilename $ unpack $ last dir of
Nothing -> return $ Left $ toTextL lbs
Just lexer ->
case runLexer lexer bs of
Left err -> do
$logWarn $ mconcat
[ "Failed to highlight "
, ref
, " :: "
, intercalate "/" dir
, " with lexer "
, pack $ lName lexer
]
return $ Left $ toTextL lbs
Right tokens ->
return $ Right $ format True tokens
Right v -> return $ Right $ map mkrow v
defaultLayout $ do defaultLayout $ do
setTitle $ toHtml $ intercalate " > " $ setTitle $ toHtml $ intercalate " > " $
["Vervis", "People", user, "Projects", proj, "Repos", repo] ["Vervis", "People", user, "Projects", proj, "Repos", repo]

View file

@ -14,6 +14,7 @@ packages:
# Packages to be pulled from upstream that are not in the resolver (e.g., # Packages to be pulled from upstream that are not in the resolver (e.g.,
# acme-missiles-0.3) # acme-missiles-0.3)
extra-deps: extra-deps:
- highlighter2-0.2.5
- hit-graph-0.1 - hit-graph-0.1
- SimpleAES-0.4.2 - SimpleAES-0.4.2
# - ssh-0.3.2 # - ssh-0.3.2

View file

@ -28,9 +28,11 @@ $forall RefName tag <- tags
<h2>Files for #{ref} <h2>Files for #{ref}
$case display $case display
$of Left file $of Left (Left plain)
<pre> <pre>
<code>#{file} <code>#{plain}
$of Left (Right highlighted)
#{highlighted}
$of Right rows $of Right rows
<table> <table>
<tr> <tr>

View file

@ -103,6 +103,7 @@ library
, file-embed , file-embed
, filepath , filepath
, hashable , hashable
, highlighter2
, hit , hit
, hit-graph >= 0.1 , hit-graph >= 0.1
, hjsmin , hjsmin