7 import Edu_Berkeley_Sbp_Haskell_SBP
10 import qualified Text.PrettyPrint.Leijen as PP
12 data Doc = Doc Header [Section]
13 data Header = Header -- not yet specified
15 data Section = Section
18 [Paragraph] -- content
20 data Paragraph = Blockquote [Paragraph]
22 | OL [[Paragraph]] -- list of items; each item is a [Paragraph]
26 data Style = TT | Underline | Superscript | Subscript
27 | Strikethrough | Italic | Bold | Highlight
34 | Command String [Text]
42 data Glyph = Euro | CircleR | CircleC | TradeMark | ServiceMark
43 | Emdash | Ellipsis | Cent | Daggar | DoubleDaggar
44 | Clover | Flat | Sharp | Natural | CheckMark | XMark
45 | LeftArrow | DoubleLeftArrow | DoubleRightArrow
46 | DoubleLeftRightArrow | LeftRightArrow | Degree
48 data Login = Login String (Maybe String)
49 data URL = URLPath String
51 | URL { url_method :: String,
52 url_login :: Maybe Login,
54 url_port :: Maybe Int,
56 url_ref :: Maybe String }
57 data Host = IP Int Int Int Int
60 -- Doc ------------------------------------------------------------------------------
62 instance PP.Pretty Doc where
63 pretty _ = PP.text $ "<not implemented>"
65 instance FromTree Doc where
66 fromTree (Tree "Doc" [a,b] _) = Doc Header $ fromTree b
67 fromTree t = error $ "unable to create Doc from " ++ (show t)
69 -- Section ------------------------------------------------------------------------------
71 instance FromTree Section where
72 fromTree (Tree "Section" ((Tree "SectionHeader" [(Tree "=" e _),c] _):p) _) =
73 Section ((length e)-1) (fromTree c) $ concatMap fromTree p
74 fromTree t = error $ "couldnt Section.FromTree on " ++ (show t)
76 -- Paragraph ------------------------------------------------------------------------------
78 instance FromTrees [Paragraph] where
79 fromTrees ts = consolidate $ concatMap fromTree ts
80 instance FromTree [Paragraph] where
81 fromTree t = consolidate $ fromTree' t
83 fromTree' (Tree "Verbatim" [ident,v] _) = [P [(Verbatim $ unindent ident $ unverbate v)]]
84 fromTree' (Tree "TextParagraph" [(Tree _ text _)] _) = [P $ concatMap fromTree text]
85 fromTree' (Tree "Pars" pars _) = concatMap fromTree pars
86 fromTree' (Tree "HR" _ _) = [HR]
87 fromTree' (Tree "OL" a _) = [OL $ map (\(Tree "LI" x _) -> fromTrees x) a]
88 fromTree' (Tree "UL" a _) = [UL $ map (\(Tree "LI" x _) -> fromTrees x) a]
89 fromTree' (Tree "" _ _) = []
90 fromTree' (Tree "Blockquote" pars _) = [Blockquote $ fromTrees pars]
91 fromTree' t = error $ "unable to create [Paragraph] from " ++ (show t)
95 consolidate ((OL []):x) = consolidate x
96 consolidate ((UL []):x) = consolidate x
97 consolidate ((OL a):(OL b):x) = consolidate ((OL $ a++b):x)
98 consolidate ((UL a):(UL b):x) = consolidate ((UL $ a++b):x)
99 consolidate (a:b) = a:(consolidate b)
101 -- Verbatim ------------------------------------------------------------------------------
103 unverbate (Tree "Verbatim" x _) = concatMap unverbate x
104 unverbate (Tree "VerbatimBrace" [x,y] _) = (unverbate x)++" "++(unverbate y)
105 unverbate (Tree t [] _) = t
107 unindent (Tree "I" indent _) v = unindent' ((length indent)+1) v
109 unindent' i ('\n':x) = '\n':(unindent' i (drop' i x))
110 unindent' i (a:b) = a:(unindent' i b)
113 drop' n x@('\n':r) = x
115 drop' n (a:b) = drop' (n-1) b
117 -- Text ------------------------------------------------------------------------------
119 instance FromTree [Text] where
120 fromTree (Tree "Word" chars _) = [Chars $ concatMap fromTree chars]
121 fromTree (Tree "Ordinal" x _) = [Command "ordinal" $ [Chars $ concatMap show x]]
122 fromTree (Tree "Fraction" [n,d] _) = [Command "fraction" $ [(Chars (show n)), (Chars (show d))]]
123 fromTree (Tree "WS" _ _) = [WS]
124 fromTree (Tree "Quotes" [x] _) = [Quotes $ fromTree x]
125 fromTree (Tree "Pars" y _) = [SubPar $ fromTrees y]
126 fromTree (Tree "Command" [x,y] _) = [Command (fromTree x) (fromTree y)]
127 fromTree (Tree "Command" [x] _) = [Command (fromTree x) []]
128 fromTree (Tree "Link" [word,link] _) = [Link (fromTree word) (fromTree link)]
129 fromTree (Tree "Footnote" x _) = [Footnote $ concatMap fromTree x]
130 fromTree (Tree "Keyword" x _) = [Keyword $ concatMap fromTree x]
131 fromTree (Tree "Math" x _) = [Math $ fromTrees x]
132 fromTree (Tree "TT" x _) = [Styled TT $ concatMap fromTree x]
133 fromTree (Tree "Italic" [x] _) = [Styled Italic $ fromTree x]
134 fromTree (Tree "Bold" [x] _) = [Styled Bold $ fromTree x]
135 fromTree (Tree "Highlight" [x] _) = [Styled Highlight $ fromTree x]
136 fromTree (Tree "Strikethrough" x _) = [Styled Strikethrough $ concatMap fromTree x]
137 fromTree (Tree "Superscript" x _) = [Styled Superscript $ concatMap fromTree x]
138 fromTree (Tree "Subscript" x _) = [Styled Subscript $ concatMap fromTree x]
139 fromTree (Tree "Underline" x _) = [Styled Underline $ concatMap fromTree x]
140 fromTree (Tree "(e)" _ _) = [GlyphText Euro]
141 fromTree (Tree "(r)" _ _) = [GlyphText CircleR]
142 fromTree (Tree "(c)" _ _) = [GlyphText CircleC]
143 fromTree (Tree "(tm)" _ _) = [GlyphText TradeMark]
144 fromTree (Tree "--" _ _) = [GlyphText Emdash]
145 fromTree (Tree "<-" _ _) = [GlyphText LeftArrow]
146 fromTree (Tree "<=" _ _) = [GlyphText DoubleLeftArrow]
147 fromTree (Tree "=>" _ _) = [GlyphText DoubleRightArrow]
148 fromTree (Tree "<=>" _ _) = [GlyphText DoubleLeftRightArrow]
149 fromTree (Tree "<->" _ _) = [GlyphText LeftRightArrow]
150 fromTree (Tree "^o" _ _) = [GlyphText Degree]
151 fromTree (Tree "..." _ _) = [GlyphText Ellipsis]
152 fromTree (Tree "Text" t _) = concatMap fromTree t
153 fromTree (Tree "" [] _) = []
154 fromTree t = error $ "unable to create [Text] from " ++ (show t)
156 -- URLs ------------------------------------------------------------------------------
158 instance Show Login where
159 show (Login name Nothing) = name
160 show (Login name (Just pass)) = name++":"++(urlEscape pass)
162 instance Show URL where
163 show (URLPath up) = up
164 show (Email s h) = "mailto:" ++ s ++ "@" ++ (show h)
165 show (URL { url_method=m, url_login=l, url_host=h, url_port=port, url_path=path, url_ref=ref }) =
169 (Just log) -> (show log)++"@")
176 (Just j) -> "#"++(urlEscape j))
178 instance FromTree URL where
179 fromTree (Tree "URL" stuff _) = fromTrees stuff
180 fromTree (Tree "Email" [(Tree "username" un _),host] _) = Email (fromTrees un) (fromTree host)
181 fromTree (Tree "Path" stuff _) = URLPath $ map fromUrlChar stuff
183 fromUrlChar (Tree "%" [(Tree a [] _),(Tree b [] _)] _) = chr $ (fst $ head $ readHex (a++b))
184 fromUrlChar (Tree [c] [] _) = c
185 fromUrlChar t = error $ "could not parse as an url char: " ++ (show t)
187 fromTreeChildren (Tree _ c _) = fromTrees c
188 instance FromTrees URL where
189 fromTrees (method:login:host:port:rest) =
190 URL { url_method = fromTreeChildren method,
191 url_host = fromTree host,
193 url_port = case port of { (Tree "Port" port _) -> Just $ fromTrees port; _ -> Nothing },
194 url_path = case rest of { ((Tree "Path" p _):_) -> fromTrees p; _ -> "" },
195 url_ref = case rest of { (_:(Tree "Path" r _):_) -> Just $ fromTrees r; _ -> Nothing }
197 fromTrees x = error $ show x
199 instance Show Host where
200 show (IP a b c d) = (show a)++"."++(show b)++"."++(show c)++"."++(show d)
201 show (DNS host) = join "." host
203 instance FromTree Host where
204 fromTree (Tree "IP" (a:b:c:d:[]) _) =
205 IP (fromTreeChildren a) (fromTreeChildren b) (fromTreeChildren c) (fromTreeChildren d)
206 fromTree (Tree "DNS" parts _) = DNS $ map (\(Tree _ c _) -> fromTrees c) parts
208 urlEscape s = concatMap urlEscapeChar s
210 -- non-alphanumerics which may appear unescaped
211 urlEscapeChar '$' = "$"
212 urlEscapeChar '-' = "-"
213 urlEscapeChar '_' = "_"
214 urlEscapeChar '.' = "."
215 urlEscapeChar '!' = "!"
216 urlEscapeChar '*' = "*"
217 urlEscapeChar '\'' = "\'"
218 urlEscapeChar '(' = "("
219 urlEscapeChar ')' = ")"
220 urlEscapeChar ',' = ","
222 -- technically these aren't allowed by RFC, but we include them anyways
223 urlEscapeChar '/' = "/"
224 urlEscapeChar ';' = ";"
225 urlEscapeChar '&' = "&"
226 urlEscapeChar '=' = "="
227 urlEscapeChar '$' = "$"
229 -- FIXME: this will wind up "disencoding" a %-encoded question mark
230 urlEscapeChar '?' = "?"
232 urlEscapeChar c | c >= 'a' && c <= 'z' = [c]
233 | c >= 'A' && c <= 'Z' = [c]
234 | c >= '0' && c <= '9' = [c]
237 | otherwise = '%':d1:d2:[]
239 d1 = head $ showHex ((i .&. 0xff) `shiftR` 4) ""
240 d2 = head $ showHex ((i .&. 0x0f)) ""