markdown2svg 0.0.1.1 → 0.0.1.2
raw patch · 5 files changed
+321/−2 lines, 5 filessetup-changed
Files
- Setup.hs +2/−0
- markdown2svg.cabal +3/−2
- src/Parser.hs +135/−0
- src/SVG.hs +155/−0
- src/Text.hs +26/−0
Setup.hs view
@@ -1,2 +1,4 @@ import Distribution.Simple++main :: IO () main = defaultMain
markdown2svg.cabal view
@@ -2,7 +2,7 @@ cabal-version: >=1.8 name: markdown2svg-version: 0.0.1.1+version: 0.0.1.2 stability: Experimental author: Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer: Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -31,10 +31,11 @@ source-repository this type: git location: git://github.com/YoshikuniJujo/markdown2svg.git- tag: 0.0.1.1+ tag: 0.0.1.2 executable markdown2svg hs-source-dirs: src main-is: markdown2svg.hs build-depends: base > 3 && < 5, yjsvg, papillon, filepath, monads-tf ghc-options: -Wall+ other-modules: Text, Parser, SVG
+ src/Parser.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies, PackageImports #-}++module Parser (+ parseMrd+) where++import Control.Arrow+import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Error+import Data.Maybe+import Data.Char+import Text.Papillon++import Text++parseMrd :: String -> Maybe [Text]+parseMrd src = case flip runState (0, [- 1]) $ runErrorT $ markdown $ parse src of+ (Right (r, _), _) -> Just r+ _ -> Nothing++clear :: State (Int, [Int]) Bool+clear = put (0, [- 1]) >> return True++reset :: State (Int, [Int]) Bool+reset = modify (first $ const 0) >> return True++count :: State (Int, [Int]) ()+count = modify $ first (+ 1)++deeper :: State (Int, [Int]) Bool+deeper = do+ (n, n0 : ns) <- get+ if n > n0 then put (n, n : n0 : ns) >> return True else return False++same :: State (Int, [Int]) Bool+same = do+ (n, n0 : _) <- get+ return $ n == n0++shallow :: State (Int, [Int]) Bool+shallow = do+ (n, n0 : ns) <- get+ if n < n0 then put (n, ns) >> return True else return False++[papillon|++monad: State (Int, [Int])++markdown :: [Text]+ = md:(m:markdown1 _:dmmy[clear] { return m })* { return md }++markdown1 :: Text+ = h:header { return h }+ / c:code { return $ Code c }+ / l:list { return $ List l }+ / p:paras { return $ Paras p }++header :: Text+ = n:sharps _:<isSpace>* l:line '\n'+ { return $ Header n l }+ / l:line '\n' _:equals '\n'+ { return $ Header 1 l }+ / l:line '\n' _:hyphens '\n'+ { return $ Header 2 l }++sharps :: Int+ = '#' n:sharps { return $ n + 1 }+ / '#' { return 1 }++equals :: ()+ = '=' _:equals+ / '='++hyphens :: ()+ = '-' _:hyphens+ / '-'++line :: String+ = l:<(`notElem` "#\n")>+ { return l }++code :: String+ = l:fourSpacesLine c:code { return $ l ++ c }+ / l:fourSpacesLine { return l }++fourSpacesLine :: String+ = _:fourSpaces l:line '\n'+ { return $ l ++ "\n" }++fourSpaces :: ()+ = ' ' ' ' ' ' ' '++list :: List = _:cnt _:dmmy[deeper] l:list1 ls:list1'* _:shllw { return $ l : ls }+-- = _:cnt _:dmmy[deeper] l:list1 -- ls:list1'* _:shllw+-- { return $ l : ls }+{-+ = ls:(_:listHead ' ' l:line '\n' s:subList { return $ BulItem l s })++ { return ls }+ / ls:(_:nListHead ' ' l:line '\n' s:subList { return $ OrdItem l s })++ { return ls }+ -}++cnt :: () = _:dmmy[reset] _:(' ' { count })*++list1' :: List1+ = _:cnt _:dmmy[same] l:list1 { return l }++list1 :: List1+ = _:listHead ' ' l:line '\n' ls:list?+ { return $ BulItem l $ fromMaybe [] ls }+ / _:nListHead ' ' l:line '\n' ls:list?+ { return $ OrdItem l $ fromMaybe [] ls }++subList :: List+ = ls:subList1* { return ls }++subList1 :: List1+ = _:fourSpaces _:listHead ' ' l:line '\n' { return $ BulItem l [] }+ / _:fourSpaces _:nListHead ' ' l:line '\n' { return $ OrdItem l [] }++listHead :: ()+ = '*' / '-' / '+'++nListHead :: ()+ = _:<isDigit>+ '.'++paras :: [String]+ = ps:para+ { return ps }++para :: String+ = ls:(!_:header !_:fourSpaces l:line '\n' { return l })+ _:('\n' / !_ / !_:para) { return $ concat ls }++shllw :: ()+ = _:dmmy[shallow]+ / !_+ / !_:list++dmmy :: () =++|]
+ src/SVG.hs view
@@ -0,0 +1,155 @@+module SVG (+ textToSVG+) where++import Control.Applicative+import Data.Char+import Text.XML.YJSVG++import Text++headerFont, normalFont, codeFont :: String+headerFont = "Kochi Gothic"+normalFont = "Kochi Mincho"+-- normalFont = "Kochi Gothic"+codeFont = "Kochi Gothic"++textToSVG :: Bool -> Double -> [Text] -> [String]+textToSVG n r = map (showSVG (width r) (height r)) . textToSVGData r (topMargin r) .+ if n then addChapters [Nothing, Just 0, Just 0, Just 0, Nothing, Nothing] else id++width, height :: Double -> Double+width = (3535 *)+height = (5000 *)++topMargin, leftMargin, paraLeftMargin :: Double -> Double+topMargin = (400 *)+leftMargin = (400 *)+paraLeftMargin = (+) <$> leftMargin <*> (200 *)+codeLeftMargin = (+) <$> paraLeftMargin <*> (200 *)++bottomMargin :: Double -> Double+bottomMargin = (400 *)++bottomBorder :: Double -> Double+bottomBorder = (-) <$> height <*> bottomMargin++header :: Int -> Double -> Double+header i = ((1 / fromIntegral (i + 1)) * 560 *)+headerSep i = (* (4 / 3)) <$> header i++normal, normalSep :: Double -> Double+normal = (80 *)+normalSep = (* (4 / 3)) <$> normal++code, codeSep :: Double -> Double+code = (70 *)+codeSep = (* (4 / 3)) <$> code++lineChars :: Int+lineChars = 66++textToSVGData :: Double -> Double -> [Text] -> [[SVG]]+textToSVGData r h [] = [[]]+textToSVGData r h (Header n s : ts)+ | h > bottomBorder r - headerSep n r = [l] : all+ | otherwise = (l : one) : rest+ where+ l = Text (TopLeft (leftMargin r) (h + headerSep n r)) (header n r) (ColorName "black") headerFont s+ one : rest = textToSVGData r (h + headerSep n r * 5 / 4) ts+ all = textToSVGData r (topMargin r) ts+textToSVGData r h (Paras [] : ts) = textToSVGData r h ts+textToSVGData r h (Paras (p : ps) : ts)+ | h' > bottomBorder r = [] : (svgs' ++ one') : rest'+ | otherwise = (svgs ++ one) : rest+ where+ (h', svgs) = paraToSVGData r h p+ (h'', svgs') = paraToSVGData r (topMargin r) p+ one : rest = textToSVGData r h' (Paras ps : ts)+ one' : rest' = textToSVGData r h'' (Paras ps : ts)+textToSVGData r h (List l : ts)+ | h' > bottomBorder r = [] : (svgs' ++ one') : rest'+ | otherwise = (svgs ++ one) : rest+ where+ (_, h', svgs) = listToSVGData 1 "*+-------" r h (paraLeftMargin r) l+ (_, h'', svgs') = listToSVGData 1 "*+-------" r (topMargin r) (paraLeftMargin r) l+ one : rest = textToSVGData r h' ts+ one' : rest' = textToSVGData r h'' ts+textToSVGData r h (Code s : ts)+ | h' > bottomBorder r = [] : (svgs' ++ one') : rest'+ | otherwise = (svgs ++ one) : rest+ where+ (h', svgs) = codeToSVGData r (h + codeSep r) (lines s)+ (h'', svgs') = codeToSVGData r (topMargin r) (lines s)+ one : rest = textToSVGData r (h' + codeSep r) ts+ one' : rest' = textToSVGData r (h'' + codeSep r) ts++splitAtString :: Int -> String -> (String, String)+splitAtString len = sepStr 0+ where+ sepStr _ "" = ("", "")+ sepStr n (c : c'@('ー') : cs)+ | n > len = ([c, c'], cs)+ | otherwise = let (s, t) = sepStr (n + 4) cs in (c : c' : s, t)+ sepStr n (c : c'@('。') : cs)+ | n > len = ([c, c'], cs)+ | otherwise = let (s, t) = sepStr (n + 4) cs in (c : c' : s, t)+ sepStr n (c : cs)+ | n > len = ([c], cs)+ | isAscii c = let (s, t) = sepStr (n + 1) cs in (c : s, t)+ | otherwise = let (s, t) = sepStr (n + 2) cs in (c : s, t)++separateString :: Int -> String -> [String]+separateString len = sepStr 0+ where+ sepStr _ "" = [[]]+ sepStr n (c : c'@('ー') : cs)+ | n > len = [c, c'] : sepStr 0 cs+ | otherwise = let s : ss = sepStr (n + 4) cs in (c : c' : s) : ss+ sepStr n (c : c'@('。') : cs)+ | n > len = [c, c'] : sepStr 0 cs+ | otherwise = let s : ss = sepStr (n + 4) cs in (c : c' : s) : ss+ sepStr n (c : cs)+ | n > len = [c] : sepStr 0 cs+ | isAscii c = let s : ss = sepStr (n + 1) cs in (c : s) : ss+ | otherwise = let s : ss = sepStr (n + 2) cs in (c : s) : ss++paraToSVGData :: Double -> Double -> String -> (Double, [SVG])+paraToSVGData r h str = (h', l : svgs)+ where+ (s, t) = splitAtString (lineChars - 3) str+ l = Text (TopLeft (paraLeftMargin r + normal r) (h + normal r)) (normal r) (ColorName "black") normalFont s+ ls = separateString lineChars t+ (h', svgs) = strsToSVGData r (h + normalSep r) ls++strsToSVGData :: Double -> Double -> [String] -> (Double, [SVG])+strsToSVGData r h [] = (h, [])+strsToSVGData r h ([] : ss) = strsToSVGData r h ss+strsToSVGData r h (s : ss) = (h', l : svgs)+ where+ l = Text (TopLeft (paraLeftMargin r) (h + normal r)) (normal r) (ColorName "black") normalFont s+ (h', svgs) = strsToSVGData r (h + normalSep r) ss++listToSVGData :: Int -> String -> Double -> Double -> Double -> List -> (Int, Double, [SVG])+listToSVGData n sym r y x [] = (n, y, [])+listToSVGData n sym r y x (lst : lsts) = (n'', y'', svgs ++ svgs')+ where+ (n', y', svgs) = list1ToSVGData n sym r y x lst+ (n'', y'', svgs') = listToSVGData n' sym r y' x lsts++list1ToSVGData :: Int -> String -> Double -> Double -> Double -> List1 -> (Int, Double, [SVG])+list1ToSVGData n sym r y x (BulItem s lst) = (n, h', l : svgs)+ where+ l = Text (TopLeft x (y + normal r)) (normal r) (ColorName "black") normalFont $ head sym : ' ' : s+ (_, h', svgs) = listToSVGData n (tail sym) r (y + normalSep r) (x + normal r * 2) lst+list1ToSVGData n sym r y x (OrdItem s lst) = (n + 1, h', l : svgs)+ where+ l = Text (TopLeft x (y + normal r)) (normal r) (ColorName "black") normalFont $ show n ++ '.' : ' ' : s+ (_, h', svgs) = listToSVGData n (tail sym) r (y + normalSep r) (x + normal r * 2) lst++codeToSVGData :: Double -> Double -> [String] -> (Double, [SVG])+codeToSVGData _ h [] = (h, [])+codeToSVGData r h (s : ss) = (h', l : svgs)+ where+ l = Text (TopLeft (codeLeftMargin r) (h + code r)) (code r) (ColorName "black") codeFont s+ (h', svgs) = codeToSVGData r (h + codeSep r) ss
+ src/Text.hs view
@@ -0,0 +1,26 @@+module Text (Text(..), List, List1(..), addChapters) where++import Control.Applicative ((<$>))+import Data.Maybe+import Data.List++data Text+ = Header Int String+ | Paras [String]+ | Code String+ | List List+ deriving Show++type List = [List1]+data List1 = OrdItem String List | BulItem String List deriving Show++addChapters :: [Maybe Int] -> [Text] -> [Text]+addChapters _ [] = []+addChapters cs (Header n s : ts)+ | isJust $ cs !! (n - 1) =+ Header n (chaps ++ " " ++ s) : addChapters newCs ts+ | otherwise = Header n s : addChapters newCs ts+ where+ chaps = concatMap (++ ".") $ map show $ catMaybes $ take n newCs+ newCs = take (n - 1) cs ++ [(+ 1) <$> cs !! (n - 1)] ++ drop n cs+addChapters cs (t : ts) = t : addChapters cs ts