module HERMIT.Plugin.Renderer where
import Control.Arrow
import Control.Monad.State
import Data.List (isInfixOf, isPrefixOf, isSuffixOf)
import HERMIT.Dictionary (traceR)
import HERMIT.Kure
import HERMIT.Plugin.Types
import HERMIT.PrettyPrinter.Common
#ifdef mingw32_HOST_OS
import HERMIT.Win32.IO (hPutStr, hPutStrLn)
#endif
import Prelude.Compat
import System.Console.ANSI
#ifdef mingw32_HOST_OS
import System.IO hiding (hPutStr, hPutStrLn)
#else
import System.IO
#endif
import System.IO.Temp
import System.Process
changeRenderer :: String -> PluginM ()
changeRenderer renderer =
case lookup renderer shellRenderers of
Nothing -> fail "bad renderer option."
Just r -> modify $ \ st -> 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