diff --git a/markdown2svg.cabal b/markdown2svg.cabal --- a/markdown2svg.cabal +++ b/markdown2svg.cabal @@ -2,7 +2,7 @@ cabal-version: >=1.8 name: markdown2svg -version: 0.0.1.4 +version: 0.0.1.5 stability: Experimental author: Yoshikuni Jujo maintainer: Yoshikuni Jujo @@ -31,11 +31,11 @@ source-repository this type: git location: git://github.com/YoshikuniJujo/markdown2svg.git - tag: 0.0.1.4 + tag: 0.0.1.5 executable markdown2svg hs-source-dirs: src main-is: markdown2svg.hs - build-depends: base > 3 && < 5, yjsvg, papillon, filepath, monads-tf + build-depends: base > 3 && < 5, yjsvg, papillon, filepath, monads-tf, markdown-pap ghc-options: -Wall - other-modules: Text, Parser, SVG + other-modules: SVG diff --git a/src/Parser.hs b/src/Parser.hs deleted file mode 100644 --- a/src/Parser.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# 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 } - / l:list { return $ List l } - / c:code { return $ Code c } - / p:paras { return $ Paras p } - -header :: Text - = n:sharps _:* 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 :: () - = _:+ '.' - -paras :: [String] - = ps:para+ { return ps } - -para :: String - = ls:(!_:header !_:fourSpaces l:line '\n' { return l })+ _:('\n' / !_ / !_:para) !_:list - { return $ concat ls } - -shllw :: () - = _:dmmy[shallow] - / !_ - / !_:list - -dmmy :: () = - -|] diff --git a/src/SVG.hs b/src/SVG.hs --- a/src/SVG.hs +++ b/src/SVG.hs @@ -3,10 +3,12 @@ ) where import Control.Applicative +import Data.Maybe +import Data.List import Data.Char import Text.XML.YJSVG -import Text +import Text.Markdown.Pap headerFont, normalFont, codeFont :: String headerFont = "Kochi Gothic" @@ -153,3 +155,14 @@ where l = Text (TopLeft (codeLeftMargin r) (h + code r)) (code r) (ColorName "black") codeFont s (h', svgs) = codeToSVGData r (h + codeSep r) ss + +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 diff --git a/src/Text.hs b/src/Text.hs deleted file mode 100644 --- a/src/Text.hs +++ /dev/null @@ -1,26 +0,0 @@ -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 diff --git a/src/markdown2svg.hs b/src/markdown2svg.hs --- a/src/markdown2svg.hs +++ b/src/markdown2svg.hs @@ -5,7 +5,7 @@ import System.Console.GetOpt import System.Exit -import Parser +import Text.Markdown.Pap import SVG main :: IO ()