-
Notifications
You must be signed in to change notification settings - Fork 0
/
PdfProc.hs
201 lines (175 loc) · 7.52 KB
/
PdfProc.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
{-
File : PdfProc.hs
Copyright : (c) Hangyi Wang (hangyi)
Md2pdf
-}
{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses #-}
module PdfProc (
generatePdfFile
)
where
import Block
import MdProc
import Graphics.PDF
import Data.Vector as DV
data MyVertStyles = NormalPara
| CodePara
| QuotePara
data MyParaStyles = Normal
| Bold
| Itali
| InlineC
| Cod
| Dotlist
| Hyperlnk
| HeadingFst
| HeadingSnd
| HeadingThi
| HeadingFor
| HeadingFif
| HeadingSix
instance ComparableStyle MyVertStyles where
isSameStyleAs NormalPara NormalPara = True
isSameStyleAs CodePara CodePara = True
isSameStyleAs QuotePara QuotePara = True
isSameStyleAs _ _ = False
instance ComparableStyle MyParaStyles where
isSameStyleAs Normal Normal = True
isSameStyleAs Bold Bold = True
isSameStyleAs Itali Itali = True
isSameStyleAs InlineC InlineC = True
isSameStyleAs Cod Cod = True
isSameStyleAs Dotlist Dotlist = True
isSameStyleAs Hyperlnk Hyperlnk = True
isSameStyleAs HeadingFst HeadingFst = True
isSameStyleAs HeadingSnd HeadingSnd = True
isSameStyleAs HeadingThi HeadingThi = True
isSameStyleAs HeadingFor HeadingFor = True
isSameStyleAs HeadingFif HeadingFif = True
isSameStyleAs HeadingSix HeadingSix = True
isSameStyleAs _ _ = False
instance Style MyParaStyles where
textStyle Normal = TextStyle (PDFFont Times_Roman 5) black black FillText 1.0 1.0 1.0 1.0
textStyle Bold = TextStyle (PDFFont Times_Bold 5) black black FillText 1.0 1.0 1.0 1.0
textStyle Itali = TextStyle (PDFFont Times_Italic 5) black black FillText 1.0 1.0 1.0 1.0
textStyle InlineC = TextStyle (PDFFont Helvetica_Oblique 5) blue blue FillText 1.0 1.0 1.0 1.0
textStyle Cod = TextStyle (PDFFont Helvetica_Oblique 5) black black FillText 1.0 1.0 1.0 1.0
textStyle Dotlist = TextStyle (PDFFont Times_BoldItalic 5) black black FillText 1.0 1.0 1.0 1.0
textStyle Hyperlnk = TextStyle (PDFFont Courier_Oblique 5) black black FillText 1.0 1.0 1.0 1.0
textStyle HeadingFst = TextStyle (PDFFont Courier_Bold 18) black black FillText 1.0 1.0 1.0 1.0
textStyle HeadingSnd = TextStyle (PDFFont Courier_Bold 12) black black FillText 1.0 1.0 1.0 1.0
textStyle HeadingThi = TextStyle (PDFFont Courier_Bold 10) black black FillText 1.0 1.0 1.0 1.0
textStyle HeadingFor = TextStyle (PDFFont Courier_Bold 9) black black FillText 1.0 1.0 1.0 1.0
textStyle HeadingFif = TextStyle (PDFFont Courier_Bold 8) black black FillText 1.0 1.0 1.0 1.0
textStyle HeadingSix = TextStyle (PDFFont Courier_Bold 7) black black FillText 1.0 1.0 1.0 1.0
instance ParagraphStyle MyVertStyles MyParaStyles where
lineWidth _ w _ = w
linePosition _ _ _ = 0.0
interline _ = Nothing
paragraphStyle CodePara = Just $ \(Rectangle (xa :+ ya) (xb :+ yb)) block -> do
let f = Rectangle ((xa-3) :+ (ya-3)) ((xb+3) :+ (yb+3))
fillColor $ Rgb 0.74 0.83 0.9
fill f
block
return ()
paragraphStyle QuotePara = Just $ \(Rectangle (xa :+ ya) (xb :+ yb)) block -> do
let f = Rectangle ((xa-3) :+ (ya-3)) ((xb+3) :+ (yb+3))
fillColor $ Rgb 0.96 0.96 0.86
fill f
block
return ()
paragraphStyle _ = Nothing
generateText :: Block -> Para MyParaStyles ()
generateText (Text str)
-- crude way
| Prelude.last str == '\n' = do
setStyle Normal
txt str
forceNewLine
| otherwise = do
setStyle Normal
txt str
generateHeading :: Block -> Para MyParaStyles ()
generateHeading (Heading ordNum (Text str)) = case ordNum of
1 -> do
setStyle HeadingFst
txt str
2 -> do
setStyle HeadingSnd
txt str
3 -> do
setStyle HeadingThi
txt str
4 -> do
setStyle HeadingFor
txt str
5 -> do
setStyle HeadingFif
txt str
_ -> do
setStyle HeadingSix
txt str
generateItalic :: Block -> Para MyParaStyles ()
generateItalic (Italic (Text str)) = do
setStyle Itali
txt str
generateEmphasis :: Block -> Para MyParaStyles ()
generateEmphasis (Emphasis (Text str)) = do
setStyle Bold
txt str
generateCode :: Block -> Para MyParaStyles ()
generateCode (Code (Text str)) = do
setStyle Cod
txt str
generateInlineCode :: Block -> Para MyParaStyles ()
generateInlineCode (InlineCode (Text str)) = do
setStyle InlineC
txt str
generateHyperlink :: Block -> Para MyParaStyles ()
generateHyperlink (Hyperlink (Text str)) = do
setStyle Hyperlnk
txt str
generateDotList :: Block -> Para MyParaStyles ()
generateDotList (DotList (Text str))
| Prelude.length str == 0 = do
setStyle Dotlist
txt "* "
| otherwise = do
setStyle Dotlist
txt $ "* " Prelude.++ str
forceNewLine
generateQuote :: Block -> Para MyParaStyles ()
generateQuote (Quote (Text str)) = do
setStyle Itali
txt str
generateParagraph :: Markdown Block -> [TM MyVertStyles MyParaStyles ()] -> Para MyParaStyles () -> [TM MyVertStyles MyParaStyles ()]
generateParagraph (Markdown v) lst ctx
| DV.length v == 0 = lst Prelude.++ [setParaStyle NormalPara >> paragraph ctx]
| otherwise = case DV.head v of
Text b -> generateParagraph (Markdown (DV.tail v)) lst (ctx >> (generateText $ DV.head v))
Italic b -> generateParagraph (Markdown (DV.tail v)) lst (ctx >> (generateItalic $ DV.head v))
Emphasis b -> generateParagraph (Markdown (DV.tail v)) lst (ctx >> (generateEmphasis $ DV.head v))
InlineCode b -> generateParagraph (Markdown (DV.tail v)) lst (ctx >> (generateInlineCode $ DV.head v))
Hyperlink b -> generateParagraph (Markdown (DV.tail v)) lst (ctx >> (generateHyperlink $ DV.head v))
(Heading ordNum b) -> generateParagraph (Markdown (DV.tail v)) (lst Prelude.++ [setParaStyle NormalPara >> paragraph ctx] Prelude.++ [setParaStyle NormalPara >> paragraph (generateHeading $ DV.head v)]) (txt "")
Code b -> generateParagraph (Markdown (DV.tail v)) (lst Prelude.++ [setParaStyle NormalPara >> paragraph ctx] Prelude.++ [setParaStyle CodePara >> paragraph (generateCode $ DV.head v)]) (txt "")
DotList b -> generateParagraph (Markdown (DV.tail v)) lst (ctx >> (generateDotList $ DV.head v))
Quote b -> generateParagraph (Markdown (DV.tail v)) (lst Prelude.++ [setParaStyle NormalPara >> paragraph ctx] Prelude.++ [setParaStyle QuotePara >> paragraph (generateQuote $ DV.head v)]) (txt "")
generatePage :: Markdown Block -> PDFReference PDFPage -> PDF ()
generatePage markdown page = do
drawWithPage page $ do
displayFormattedText (Rectangle (14 :+ 0) (208 :+ 305)) NormalPara Normal paragraphs where
paragraphs = Prelude.foldl (>>) (paragraph $ txt "") (generateParagraph markdown [] (txt ""))
{-
getOutputFileName: change "xxx.md" to "xxx.pdf"
-}
getOutputFileName :: String -> String
getOutputFileName inputMdFileName = (Prelude.reverse $ Prelude.drop 3 $ Prelude.reverse inputMdFileName) Prelude.++ ".pdf"
generatePdfFile :: String -> Markdown Block -> IO ()
generatePdfFile inputMdFileName markdown = do
let pdfFileName = getOutputFileName inputMdFileName
let documentInfo = standardDocInfo
let defaultPageSize = PDFRect 0 0 220 320
runPdf pdfFileName documentInfo defaultPageSize $ do
page <- addPage Nothing
generatePage markdown page