carettah 0.1.1 → 0.1.2
raw patch · 3 files changed
+77/−36 lines, 3 files
Files
- FormatPangoMarkup.hs +43/−19
- Render.hs +33/−16
- carettah.cabal +1/−1
FormatPangoMarkup.hs view
@@ -1,27 +1,51 @@-module FormatPangoMarkup (formatPangoMarkup) where+module FormatPangoMarkup (formatPangoMarkup, formatPangoMarkupWhite) where import Text.Highlighting.Kate import Graphics.Rendering.Pango -- TODO: should use blaze-builder -tagTok :: Token -> String-tagTok (KeywordTok, s) = "<span foreground=\"#007020\" font_weight=\"bold\">" ++ escapeMarkup s ++ "</span>"-tagTok (DataTypeTok, s) = "<span foreground=\"#902000\">" ++ escapeMarkup s ++ "</span>"-tagTok (DecValTok, s) = "<span foreground=\"#40a070\">" ++ escapeMarkup s ++ "</span>"-tagTok (BaseNTok, s) = "<span foreground=\"#40a070\">" ++ escapeMarkup s ++ "</span>"-tagTok (FloatTok, s) = "<span foreground=\"#40a070\">" ++ escapeMarkup s ++ "</span>"-tagTok (CharTok, s) = "<span foreground=\"#4070a0\">" ++ escapeMarkup s ++ "</span>"-tagTok (StringTok, s) = "<span foreground=\"#4070a0\">" ++ escapeMarkup s ++ "</span>"-tagTok (CommentTok, s) = "<span foreground=\"#60a0b0\" background=\"lightgray\" font_style=\"italic\">" ++ escapeMarkup s ++ "</span>"-tagTok (OtherTok, s) = "<span foreground=\"#007020\">" ++ escapeMarkup s ++ "</span>"-tagTok (AlertTok, s) = "<span foreground=\"red\" font_weight=\"bold\">" ++ escapeMarkup s ++ "</span>"-tagTok (FunctionTok, s) = "<span foreground=\"#06287e\">" ++ escapeMarkup s ++ "</span>"-tagTok (RegionMarkerTok, s) = escapeMarkup s-tagTok (ErrorTok, s) = "<span foreground=\"red\" font_weight=\"bold\">" ++ escapeMarkup s ++ "</span>"-tagTok (NormalTok, s) = escapeMarkup s -tagLine :: SourceLine -> [String]-tagLine = fmap tagTok+tokColor :: TokenType -> String+tokColor KeywordTok = "<span foreground=\"#007020\">"+tokColor DataTypeTok = "<span foreground=\"#902000\">"+tokColor DecValTok = "<span foreground=\"#40a070\">"+tokColor BaseNTok = "<span foreground=\"#40a070\">"+tokColor FloatTok = "<span foreground=\"#40a070\">"+tokColor CharTok = "<span foreground=\"#4070a0\">"+tokColor StringTok = "<span foreground=\"#4070a0\">"+tokColor CommentTok = "<span foreground=\"#60a0b0\">"+tokColor OtherTok = "<span foreground=\"#007020\">"+tokColor AlertTok = "<span foreground=\"red\">"+tokColor FunctionTok = "<span foreground=\"#06287e\">"+tokColor RegionMarkerTok = "<span>"+tokColor ErrorTok = "<span foreground=\"red\">"+tokColor NormalTok = "<span>" +tokShape :: TokenType -> String+tokShape KeywordTok = "<span font_weight=\"bold\">"+tokShape DataTypeTok = "<span>"+tokShape DecValTok = "<span>"+tokShape BaseNTok = "<span>"+tokShape FloatTok = "<span>"+tokShape CharTok = "<span>"+tokShape StringTok = "<span>"+tokShape CommentTok = "<span font_style=\"italic\">"+tokShape OtherTok = "<span>"+tokShape AlertTok = "<span font_weight=\"bold\">"+tokShape FunctionTok = "<span>"+tokShape RegionMarkerTok = "<span>"+tokShape ErrorTok = "<span font_weight=\"bold\">"+tokShape NormalTok = "<span>"++tagTok, tagTokShape :: Token -> String+tagTok (t, s) = tokColor t ++ tokShape t ++ escapeMarkup s ++ "</span></span>"+tagTokShape (t, s) = tokShape t ++ escapeMarkup s ++ "</span>"+ formatPangoMarkup :: String -> String -> String-formatPangoMarkup lang = unlines . fmap (concat . tagLine) . highlightAs lang+formatPangoMarkup lang = unlines . fmap (concat . fmap tagTok) . highlightAs lang++formatPangoMarkupWhite :: String -> String -> String+formatPangoMarkupWhite lang text =+ "<span foreground=\"white\">" ++ + (unlines . fmap (concat . fmap tagTokShape) . highlightAs lang) text ++ + "</span>"
Render.hs view
@@ -24,11 +24,12 @@ toDouble = fromIntegral type LayoutFunc = G.PangoLayout -> G.Markup -> IO ()+type LayoutFuncGlowing = String -> CXy -> Double -> String -> IO (G.PangoLayout, G.PangoLayout, Double, Double) stringToLayout :: String -> LayoutFunc -> CXy -> Double -> String -> IO (G.PangoLayout, Double, Double)-stringToLayout fname lFun (x, _) fsize text = do+stringToLayout fname func (x, _) fsize text = do lay <- G.cairoCreateContext Nothing >>= G.layoutEmpty- void $ lFun lay text+ void $ func lay text G.layoutSetWrap lay G.WrapPartialWords setAW lay x fd <- liftIO G.fontDescriptionNew@@ -53,30 +54,46 @@ truePosition _ _ (x', y') = error $ "called with x=" ++ show x' ++ " y=" ++ show y' -renderLayout' :: String -> LayoutFunc -> CXy -> Double -> String -> C.Render Double-renderLayout' fname lFun (x, y) fsize text = do+stringToLayoutGlowing :: LayoutFunc -> LayoutFunc -> LayoutFuncGlowing+stringToLayoutGlowing funcBack funcFront fname xy fsize text = do+ (layB, _, _) <- stringToLayout fname funcBack xy fsize text+ (lay, lw, lh) <- stringToLayout fname funcFront xy fsize text+ return (layB, lay, lw, lh)++renderLayout' :: String -> LayoutFuncGlowing -> CXy -> Double -> String -> C.Render Double+renderLayout' fname func (x, y) fsize text = do C.save- (lay, lw, lh) <- liftIO $ stringToLayout fname lFun (x, y) fsize text+ (layB, lay, lw, lh) <- liftIO $ func fname (x, y) fsize text let (xt, yt) = truePosition fsize lw (x, y)- C.moveTo xt yt- G.showLayout lay+ mapM_ (moveShowLayout layB) + [(xt + xd, yt + yd) | xd <- [-0.7, 0.7], yd <- [-0.7, 0.7]]+ moveShowLayout lay (xt, yt) C.restore return $ yt + lh+ where+ moveShowLayout l (x', y') = C.moveTo x' y' >> G.showLayout l renderLayoutM :: CXy -> Double -> String -> C.Render Double-renderLayoutM = renderLayout' "IPA P明朝" G.layoutSetText+renderLayoutM = + renderLayout' "IPA P明朝" (stringToLayoutGlowing fb ff)+ where+ fb l t = void $ G.layoutSetMarkup l ("<span foreground=\"white\">" ++ G.escapeMarkup t ++ "</span>")+ ff = G.layoutSetText -renderLayoutG' :: LayoutFunc -> CXy -> Double -> String -> C.Render Double+renderLayoutG' :: LayoutFuncGlowing -> CXy -> Double -> String -> C.Render Double renderLayoutG' = renderLayout' "IPAゴシック" renderLayoutG :: Attr -> CXy -> Double -> String -> C.Render Double-renderLayoutG (_, [], _) xy fs txt = - renderLayoutG' G.layoutSetText xy fs txt-renderLayoutG (_, classs, _) xy fs txt =- renderLayoutG' f xy fs txt'- where- txt' = formatPangoMarkup (head classs) txt- f l t = void $ G.layoutSetMarkup l t+renderLayoutG (_, [], _) = + renderLayoutG' (stringToLayoutGlowing fb ff)+ where+ fb l t = void $ G.layoutSetMarkup l ("<span foreground=\"white\">" ++ G.escapeMarkup t ++ "</span>")+ ff = G.layoutSetText+renderLayoutG (_, classs, _) =+ renderLayoutG' (stringToLayoutGlowing fb ff)+ where+ fb l t = void $ G.layoutSetMarkup l (formatPangoMarkupWhite (head classs) t)+ ff l t = void $ G.layoutSetMarkup l (formatPangoMarkup (head classs) t) renderSurface :: Double -> Double -> Double -> C.Surface -> C.Render () renderSurface x y alpha surface = do
carettah.cabal view
@@ -1,5 +1,5 @@ Name: carettah-Version: 0.1.1+Version: 0.1.2 Author: Kiwamu Okabe <kiwamu@debian.or.jp> Maintainer: Kiwamu Okabe <kiwamu@debian.or.jp> License: GPL-2