fix-symbols-gitit 0.0.2 → 0.1.0
raw patch · 2 files changed
+58/−30 lines, 2 filesdep +containers
Dependencies added: containers
Files
fix-symbols-gitit.cabal view
@@ -1,5 +1,5 @@ Name: fix-symbols-gitit-Version: 0.0.2+Version: 0.1.0 Cabal-Version: >= 1.2 Synopsis: Gitit plugin: Turn some Haskell symbols into pretty math symbols. Category: Text@@ -12,11 +12,12 @@ License-File: COPYING Stability: experimental build-type: Simple+Package-Url: http://github.com/conal/fix-symbols-gitit Library hs-Source-Dirs: src Extensions:- Build-Depends: base<5, gitit+ Build-Depends: base<5, containers, gitit Exposed-Modules: Network.Gitit.Plugin.FixSymbols
src/Network/Gitit/Plugin/FixSymbols.hs view
@@ -1,4 +1,4 @@--- {-# LANGUAGE #-}+{-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -Wall #-} ---------------------------------------------------------------------- -- |@@ -12,12 +12,17 @@ -- Turn some Haskell symbols into pretty math symbols ---------------------------------------------------------------------- -module Network.Gitit.Plugin.FixSymbols (plugin) where+module Network.Gitit.Plugin.FixSymbols+ ( plugin, fixInline, fixBlock+ ) where import Network.Gitit.Interface -import Data.List (isPrefixOf)+import Data.Maybe (fromMaybe) +import qualified Data.Map as Map+import Data.Map (Map)+ plugin :: Plugin plugin = PageTransform $ return . processWith fixInline . processWith fixBlock @@ -26,38 +31,60 @@ fixInline :: Inline -> Inline-fixInline (Code s) = Code (codeSubst s)+fixInline (Code s) = Code (translate s) fixInline x = x fixBlock :: Block -> Block fixBlock (CodeBlock attr@(_,classes,_) s)- | "haskell" `elem` classes = CodeBlock attr (codeSubst s)+ | "haskell" `elem` classes = CodeBlock attr (translate s) fixBlock x = x --- TODO: transform lexemes instead of strings to avoid things like "-->"--- becoming "-→". Use the Text.Read.Lex module in Base. Hm. How to--- reconstruct white space & comments?+translate :: String -> String+translate = concat . fixInfix . map translateLex . lexString -codeSubst :: String -> String-codeSubst = substs [ ("forall","∀"),("->","→"),(":*","×")- , ("\\","λ")- , ("`lub`","⊔"),("`glb`","⊓"), ("lub","(⊔)"),("glb","(⊓)")- , ("undefined","⊥"), ("bottom","⊥")- , ("<-","←"), ("::","∷"), ("..","‥"), ("...","⋯")- ]+-- Turn "`(+)`" into "+", but before concat'ing+fixInfix :: [String] -> [String]+fixInfix [] = []+fixInfix ("`":s:"`":ss) | Just op <- stripParens s = op : fixInfix ss+fixInfix (s : ss) = s : fixInfix ss --- TODO: Faster substitution. Turn the from/to pairs into a single, fast--- automaton. I could also switch to a single-pass algorithm, instead of--- one pass per from/to pair.+stripParens :: String -> Maybe String+stripParens ('(':s) | not (null s) && last s == ')' = Just (init s)+stripParens _ = Nothing -subst :: String -> String -> String -> String-subst from to = sub- where- sub :: String -> String- sub "" = ""- sub str | from `isPrefixOf` str = to ++ sub (drop n str)- sub (c:cs) = c : sub cs- n = length from+translateLex :: String -> String+translateLex s = fromMaybe s $ Map.lookup s substMap -substs :: [(String, String)] -> String -> String-substs = foldr (.) id . map (uncurry subst)+substMap :: Map String String+substMap = Map.fromList $+ [ ("forall","∀"),("->","→"),(":*","×")+ , ("\\","λ")+ , ("lub","(⊔)"),("glb","(⊓)")+ , ("undefined","⊥"), ("bottom","⊥")+ , ("<-","←"), ("::","∷"), ("..","‥"), ("...","⋯")+ , ("==","≡"), ("/=","≠")+ + , ("alpha", "α"), ("iota", "ι"), ("varrho", "ϱ"), ("beta", "β")+ , ("kappa", "κ"), ("sigma", "σ"), ("gamma", "γ"), ("lambda", "λ")+ , ("varsigma", "ς"), ("delta", "δ"), ("mu", "μ"), ("tau", "τ")+ , ("epsilon", "ϵ"), ("nu", "ν"), ("upsilon", "υ"), ("varepsilon", "ε")+ , ("xi", "ξ"), ("phi", "ϕ"), ("zeta", "ζ"), ("o", "ο"), ("varphi", "φ")+ , ("eta", "η"), ("pi", "π"), ("chi", "χ"), ("theta", "θ"), ("varpi", "ϖ")+ , ("psi", "ψ"), ("vartheta", "ϑ"), ("rho", "ρ"), ("omega", "ω")+ + , ("Gamma", "Γ"), ("Xi", "Ξ"), ("Phi", "Φ"), ("Delta", "Δ"), ("Pi", "Π")+ , ("Psi", "Ψ"), ("Theta", "Θ"), ("Sigma", "Σ"), ("Omega", "Ω")+ , ("Lambda", "Λ"), ("Upsilon", "Υ") + ]++-- The 'reverse' is to apply earlier rewrites first. Or flip (.)++-- Experiments in string dissection. Simplified lexing.++-- | Dissect a string of haskell code into lexemes.+-- Mainly uses Prelude's 'lex', but preserves spaces.+lexString :: String -> [String]+lexString "" = []+lexString (c:s') | c `elem` " \n\t" = [c] : lexString s'+lexString s | [(h,t)] <- lex s = h : lexString t+lexString (c:s') = [c] : lexString s'