module HERMIT.Plugin.Renderer where
import Control.Arrow
import Control.Monad.State
import Data.List (isInfixOf, isPrefixOf, isSuffixOf)
import Data.Monoid
import HERMIT.Dictionary (traceR)
import HERMIT.Kure
import HERMIT.Plugin.Types
import HERMIT.PrettyPrinter.Common
import System.Console.ANSI
import System.IO
import System.IO.Temp
import System.Process
changeRenderer :: String -> PluginM ()
changeRenderer renderer = modify $ \ st ->
case lookup renderer shellRenderers of
Nothing -> st
Just r -> st { ps_render = r }
shellRenderers :: [(String,Handle -> PrettyOptions -> Either String DocH -> IO ())]
shellRenderers = [ ("unicode-terminal", unicodeConsole) ]
++ [ (nm, \ h opts -> either (hPutStr h) (hPutStr h . fn opts)) | (nm,fn) <- coreRenders ]
newtype UnicodeTerminal = UnicodeTerminal (Handle -> Maybe PathH -> IO ())
instance RenderSpecial UnicodeTerminal where
renderSpecial sym = UnicodeTerminal $ \ h _ -> hPutStr h [ch]
where (Unicode ch) = renderSpecial sym
instance Monoid UnicodeTerminal where
mempty = UnicodeTerminal $ \ _ _ -> return ()
mappend (UnicodeTerminal f1) (UnicodeTerminal f2) = UnicodeTerminal $ \ h p -> f1 h p >> f2 h p
unicodeConsole :: Handle -> PrettyOptions -> Either String DocH -> IO ()
unicodeConsole h _ (Left str) = hPutStr h str
unicodeConsole h opts (Right doc) = let UnicodeTerminal r = renderCode opts doc
in r h $ po_focus opts
doSGR :: [SGR] -> UnicodeTerminal
doSGR cmds = UnicodeTerminal $ \ h _ -> hSetSGR h cmds
undoSGRWith :: [SGR] -> [Attr] -> UnicodeTerminal
undoSGRWith cmds stk = doSGR cmds `mappend` rDoHighlight Nothing stk
setHighlight :: PathH -> Handle -> Maybe PathH -> IO ()
setHighlight _ _ Nothing = return ()
setHighlight p h (Just fp) = hSetSGR h (if fp `isPrefixOf` p then [ SetUnderlining SingleUnderline ] else [ Reset ])
instance RenderCode UnicodeTerminal where
rPutStr txt = UnicodeTerminal $ \ h _ -> hPutStr h txt
rEnd = UnicodeTerminal $ \ h _ -> hSetSGR h [ Reset ] >> hPutStrLn h ""
rDoHighlight (Just (Color KeywordColor)) stk = undoSGRWith [SetConsoleIntensity NormalIntensity] stk
rDoHighlight (Just (Color WarningColor)) stk = undoSGRWith [SetSwapForegroundBackground False] stk
rDoHighlight _ [] = doSGR [ Reset ]
rDoHighlight _ (Color col:_) =
doSGR $ case col of
KeywordColor -> [ SetConsoleIntensity BoldIntensity
, SetColor Foreground Dull Blue
]
SyntaxColor -> [ SetColor Foreground Dull Red ]
IdColor -> []
CoercionColor -> [ SetColor Foreground Dull Yellow ]
TypeColor -> [ SetColor Foreground Dull Green ]
LitColor -> [ SetColor Foreground Dull Cyan ]
WarningColor -> [ SetSwapForegroundBackground True, SetColor Foreground Vivid Yellow ]
rDoHighlight o (_:rest) = rDoHighlight o rest
diffDocH :: (MonadCatch m, MonadIO m) => PrettyPrinter -> DocH -> DocH -> m String
diffDocH pp doc1 doc2 =
liftAndCatchIO $
withSystemTempFile "A.dump" $ \ fp1 h1 ->
withSystemTempFile "B.dump" $ \ fp2 h2 ->
withSystemTempFile "AB.diff" $ \ fp3 h3 -> do
let opts = pOptions pp
unicodeConsole h1 opts (Right doc1)
hFlush h1
unicodeConsole h2 opts (Right doc2)
hFlush h2
let cmd = unwords ["diff", "-b", "-U 5", fp1, fp2]
p = (shell cmd) { std_out = UseHandle h3 , std_err = UseHandle h3 }
(_,_,_,h) <- createProcess p
_ <- waitForProcess h
res <- readFile fp3
return $ unlines [ l | l <- lines res, not (fp1 `isInfixOf` l || fp2 `isInfixOf` l)
, not ("@@" `isPrefixOf` l && "@@" `isSuffixOf` l) ]
diffR :: Injection a CoreTC => PrettyPrinter -> String -> RewriteH a -> RewriteH a
diffR pp msg rr = do
let ppT = extractT $ liftPrettyH (pOptions pp) (pCoreTC pp)
runDiff b a = do
doc1 <- return b >>> ppT
doc2 <- return a >>> ppT
r <- diffDocH pp doc1 doc2
return a >>> traceR (msg ++ " diff:\n" ++ r)
(e,r) <- idR &&& attemptM rr
either fail (runDiff e) r