packages feed

markdown2svg 0.0.1.9 → 0.0.1.10

raw patch · 7 files changed

+318/−28 lines, 7 filesdep +binary-filedep +directorydep +png-file

Dependencies added: binary-file, directory, png-file

Files

markdown2svg.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>=1.8  name:		markdown2svg-version:	0.0.1.9+version:	0.0.1.10 stability:	Experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -31,11 +31,13 @@ source-repository	this   type:		git   location:	git://github.com/YoshikuniJujo/markdown2svg.git-  tag:		0.0.1.9+  tag:		0.0.1.10  executable markdown2svg   hs-source-dirs:	src   main-is:		markdown2svg.hs-  build-depends:	base > 3 && < 5, yjsvg, papillon, filepath, monads-tf, markdown-pap+  build-depends:+    base > 3 && < 5, yjsvg, papillon, filepath, monads-tf, markdown-pap,+    binary-file, png-file, directory   ghc-options:		-Wall-  other-modules:	SVG, SepWords+  other-modules:	SVG, SepWords, Image, Image.PNG, Image.JPG, Image.SVG
+ src/Image.hs view
@@ -0,0 +1,30 @@+module Image (convertedSize, Size(..)) where++import Control.Arrow+import Image.PNG (isPNG, pngSize)+import Image.JPG (isJPG, jpgSize)+import Image.SVG (isSVG, svgSize)++data Size = Small | Medium | Large deriving Show++imageSize :: String -> Maybe (Double, Double)+imageSize src = case (isPNG src, isJPG src, isSVG src) of+		(True, _, _) -> pngSize src+		(_, True, _) -> jpgSize src+		(_, _, True) -> svgSize src+		_ -> Nothing++convertedSize :: String -> Size -> Maybe (Double, Double)+convertedSize src sml = case imageSize src of+		Just sz -> Just $ convert sz sml+		_ -> Nothing++root2 :: Double+root2 = 2 ** (1 / 2)++convert :: (Double, Double) -> Size -> (Double, Double)+convert (w, h) Large+	| w * root2 > h = (1, h / w)+	| otherwise = (w * root2 / h, root2)+convert sz Medium = (/ 3) *** (/ 3) $ convert sz Large+convert sz Small = (/ 10) *** (/ 10) $ convert sz Large
+ src/Image/JPG.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies, PackageImports, DoAndIfThenElse #-}++module Image.JPG (isJPG, jpgSize) where++import Control.Applicative+import Control.Arrow+import "monads-tf" Control.Monad.State++import Data.Maybe+import Data.Monoid++import File.Binary+import File.Binary.Instances+import File.Binary.Instances.BigEndian++isJPG :: String -> Bool+isJPG jpg = isJust (fromBinary () jpg :: Maybe (JPG, String))++jpgSize :: String -> Maybe (Double, Double)+jpgSize jpg = (,)+	<$> (fromIntegral . width <$> j)+	<*> (fromIntegral . height <$> j)+	where+	j = fst <$> fromBinary () jpg++newtype List a = List [a] deriving Show++instance Field a => Field (List a) where+	type FieldArgument (List a) = (a -> Bool, FieldArgument a)+	fromBits (p, a) ab = do+		(f, rest) <- fromBits a ab+		if p f+		then do	(List fs, rest') <- fromBits (p, a) rest+			return (List $ f : fs, rest')+		else do return (List [], ab)+	consToBits = error "not defined"++[binary|++JPG deriving Show++1: 0xff+1: 0xd8+iscxa {LSegment}: segments+1: 0xff+1: cx+2: cxSize+1: 8+2: height+2: width++|]++type LSegment = List Segment++iscxa = (not . iscx, ())++iscx :: Segment -> Bool+iscx Segment{ marker = m, eight = e } =+	m >= 0xc0 && m <= 0xcf && e == 8++[binary|++Segment deriving Show++1: 0xff+1: marker+2: size+1: eight+replicate (size - 3) (){String}: contents++|]
+ src/Image/PNG.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies #-}++module Image.PNG (isPNG, pngSize) where++import Data.Maybe+import File.Binary.PNG+import File.Binary+import File.Binary.Instances+import File.Binary.Instances.BigEndian++isPNG :: String -> Bool+isPNG img = isJust (fromBinary () img :: Maybe (PNGHeader, String))++pngSize :: String -> Maybe (Double, Double)+pngSize src = case getChunks src of+	Right cs -> Just+		(fromIntegral $ width $ ihdr cs, fromIntegral $ height $ ihdr cs)+	_ -> Nothing++[binary|++PNGHeader deriving Show++1: 0x89+3: "PNG"+2: "\r\n"+1: "\SUB"+1: "\n"++|]
+ src/Image/SVG.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE QuasiQuotes #-}++module Image.SVG (isSVG, svgSize) where++import Control.Applicative+import Text.Papillon+import Data.Char++doctype0 :: DocType+doctype0 = DocType "svg" "-//W3C//DTD SVG 1.1//EN" "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"++xmlns0 :: String+xmlns0 = "http://www.w3.org/2000/svg"++isSVG :: String -> Bool+isSVG svg = case getSVGHeader svg of+	Just (_, d, SVG s) -> d == doctype0 && isValueOf xmlns0 s "xmlns"+	_ -> False++svgSize :: String -> Maybe (Double, Double)+svgSize svg = case getSVGHeader svg of+	Just (_, _, SVG s) ->+		(,) <$> (read <$> lookup "width" s) <*> (read <$> lookup "height" s)+	_ -> Nothing++isValueOf :: String -> [(String, String)] -> String -> Bool+isValueOf v0 dict key = case lookup key dict of+	Just v -> v == v0+	_ -> False++getSVGHeader :: String -> Maybe (Header, DocType, SVG)+getSVGHeader src = case runError $ svgHeader $ parse src of+	Right (sh, _) -> Just sh+	_ -> Nothing++getHeader :: String -> Maybe Header+getHeader src = case runError $ header $ parse src of+	Right (h, _) -> Just h+	_ -> Nothing++getComment :: String -> Maybe String+getComment src = case runError $ comment $ parse src of+	Right (c, _) -> Just c+	_ -> Nothing++getDocType :: String -> Maybe DocType+getDocType src = case runError $ doctype $ parse src of+	Right (d, _) -> Just d+	_ -> Nothing++data Header = Header [(String, String)] deriving Show++data DocType = DocType String String String deriving (Eq, Show)++data SVG = SVG [(String, String)] deriving Show++[papillon|++svgHeader :: (Header, DocType, SVG)+	= h:header _:spccmm d:doctype _:spccmm s:svg+	{ (h, d, s) }+--	= h:header _:spccmm d:doctype _:spccmm s:svg+--	{ (h, d, s) }++header :: Header+	= '<' '?' 'x' 'm' 'l' _:space+ vss:(vs:varstr _:space* { vs })*+		'?' '>'+	{ Header vss }++varstr :: (String, String)+	= v:name '=' s:string		{ (v, s) }++name :: String+	= v:variable ':' n:name		{ v ++ ":" ++ n }+	/ v:variable			{ v }++variable :: String+	= v:<isLower>+			{ v }++string :: String+	= '\'' s:<(/= '\'')>+ '\''	{ s }+	/ '"' s:<(/= '"')>+ '"'		{ s }++spccmm :: () = _:(_:space / _:comment)*++space :: ()+	= _:<isSpace>++comment :: String+	= '<' '!' '-' '-' cm:(!_:('-' '-' '>') c { c })* '-' '-' '>'+					{ cm }++doctype :: DocType+	= '<' '!' 'D' 'O' 'C' 'T' 'Y' 'P' 'E' _:space+ v:variable _:space++		'P' 'U' 'B' 'L' 'I' 'C' _:space* s1:string _:space*+		s2:string _:space* '>'+		{ DocType v s1 s2 }++svg :: SVG+	= '<' 's' 'v' 'g' _:space+ vss:(vs:varstr _:space* { vs })* '>'+	{ SVG vss }++|]
src/SVG.hs view
@@ -5,10 +5,13 @@ import Control.Applicative import Data.Maybe import Data.Char-import Text.XML.YJSVG+import System.FilePath+import Text.XML.YJSVG hiding (Image)+import qualified Text.XML.YJSVG as SVG  import Text.Markdown.Pap import SepWords+import Image  headerFont, normalFont, codeFont :: String headerFont = "Kochi Gothic"@@ -16,8 +19,8 @@ -- normalFont = "Kochi Gothic" codeFont = "Kochi Gothic" -textToSVG :: Bool -> Double -> [Text] -> [String]-textToSVG n r = map (showSVG (width r) (height r)) . textToSVGData r (topMargin r) .+textToSVG :: [(FilePath, String)] -> Bool -> Double -> [Text] -> [String]+textToSVG fp n r = map (showSVG (width r) (height r)) . textToSVGData fp r (topMargin r) . 	preprocess . 	if n then addChapters [Nothing, Just 0, Just 0, Just 0, Nothing, Nothing] else id @@ -38,7 +41,7 @@ bottomBorder = (-) <$> height <*> bottomMargin  header :: Int -> Double -> Double-header i = ((1 / fromIntegral (i + 1)) * 560 *)+header i = ((1 / fromIntegral (i + 1)) * 450 *) headerSep i = (* (4 / 3)) <$> header i  normal, normalSep :: Double -> Double@@ -50,42 +53,57 @@ codeSep = (* (4 / 3)) <$> code  lineChars :: Int-lineChars = 66+lineChars = 60 -textToSVGData :: Double -> Double -> [Text] -> [[SVG]]-textToSVGData r h [] = [[]]-textToSVGData r h (Header n s : ts)+textToSVGData :: [(FilePath, String)] -> Double -> Double -> [Text] -> [[SVG]]+textToSVGData fp r h [] = [[]]+textToSVGData fp 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)+	one : rest = textToSVGData fp r (h + headerSep n r * 5 / 4) ts+	all = textToSVGData fp r (topMargin r) ts+textToSVGData fp r h (Paras [] : ts) = textToSVGData fp r h ts+textToSVGData fp 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)+	one : rest = textToSVGData fp r h' (Paras ps : ts)+	one' : rest' = textToSVGData fp r h'' (Paras ps : ts)+textToSVGData fp 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)+	one : rest = textToSVGData fp r h' ts+	one' : rest' = textToSVGData fp r h'' ts+textToSVGData fp 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+	one : rest = textToSVGData fp r (h' + codeSep r) ts+	one' : rest' = textToSVGData fp r (h'' + codeSep r) ts+textToSVGData fp r h (Image _ p ttl : ts)+	| h + ht > bottomBorder r =+		[] : (SVG.Image (TopLeft (leftMargin r) (topMargin r)) wt ht p : svg') : svgs'+	| otherwise = (SVG.Image (TopLeft (leftMargin r) h) wt ht p : svg) : svgs+	where+	svg : svgs = textToSVGData fp r (h + ht + r * 100) ts+	svg' : svgs' = textToSVGData fp r (topMargin r + ht + r * 100) ts+	size = case ttl of+		"small" -> Small+		"large" -> Large+		_ -> Medium+	(wt, ht) = case getSize fp p size of+		Just (w_, h_) -> (w_ * ratio, h_ * ratio)+		_ -> (r * 1000, r * 1000)+	ratio = width r - 2 * leftMargin r  splitAtString :: Int -> String -> (String, String) splitAtString len = sepStr 0@@ -178,3 +196,8 @@ remSpaces (c : ' ' : c' : cs) 	| not (isAscii c) || not (isAscii c') = c : c' : remSpaces cs remSpaces (c : cs) = c : remSpaces cs++getSize :: [(FilePath, String)] -> FilePath -> Size -> Maybe (Double, Double)+getSize dict fp sz = case lookup fp dict of+	Just src -> convertedSize src sz+	_ -> error $ show (map fst dict) ++ " " ++ show fp -- Nothing
src/markdown2svg.hs view
@@ -1,9 +1,12 @@ import Control.Applicative import Control.Monad+import Data.Maybe import System.Environment import System.FilePath import System.Console.GetOpt import System.Exit+import System.Directory+import File.Binary  import Text.Markdown.Pap import SVG@@ -15,9 +18,16 @@ 	when (not $ null emsgs) exitFailure 	let	size = getSizeR opts 		dir = getDir opts+		idir = getIDir opts 	cnt <- readFile fp+	is <- case idir of+		Just d -> do+			fps <- getImageFilePath d+			mapM pathCont fps+		_ -> return []+	copy (fromMaybe "." idir) (fromMaybe "." dir) $ map (takeFileName . fst) is 	case parse cnt of-		Just t -> forM_ (zip [1 ..] $ textToSVG True size t) $ \(i, s) ->+		Just t -> forM_ (zip [1 ..] $ textToSVG is True size t) $ \(i, s) -> 			writeFile (mkSVGFileName dir fp i) s 		_ -> return () @@ -30,19 +40,39 @@ 	where 	s = show x -data Option = Dir FilePath | Size Double deriving Show+data Option = Dir FilePath | Size Double | ImageDir FilePath deriving Show  options :: [OptDescr Option] options = [ 	Option "d" [] (ReqArg Dir "output directory") "set ouput directory",-	Option "s" [] (ReqArg (Size . read) "size ratio") "set size ratio" ]+	Option "s" [] (ReqArg (Size . read) "size ratio") "set size ratio",+	Option "i" [] (ReqArg ImageDir "image directory") "set image directory" ] -getDir :: [Option] -> Maybe FilePath+getDir, getIDir :: [Option] -> Maybe FilePath getDir [] = Nothing getDir (Dir d : _) = Just d getDir (_ : ops) = getDir ops +getIDir [] = Nothing+getIDir (ImageDir d : _) = Just d+getIDir (_ : ops) = getIDir ops+ getSizeR :: [Option] -> Double getSizeR [] = 0.15 getSizeR (Size sr : _) = sr getSizeR (_ : ops) = getSizeR ops++getImageFilePath :: FilePath -> IO [FilePath]+getImageFilePath fp = do+	fps <- getDirectoryContents fp+	return $ map (fp </>) $+		filter ((`elem` [".jpg", ".png", ".svg"]) . takeExtension) fps++pathCont :: FilePath -> IO (FilePath, String)+pathCont fp = do+	cnt <- readBinaryFile fp+	print $ takeFileName fp+	return (takeFileName fp, cnt)++copy :: FilePath -> FilePath -> [FilePath] -> IO ()+copy s d f = zipWithM_ copyFile (map (s </>) f) (map (d </>) f)