add copyright notices
[wix.git] / src / Doc.lhs
1 \begin{code}
2 -- Copyright 2008 the Contributors, as shown in the revision logs.
3 -- Licensed under the Apache Public Source License 2.0 ("the License").
4 -- You may not use this file except in compliance with the License.
5
6 module Doc
7 where
8 import Numeric
9 import Data.Bits
10 import Data.Char
11 import Edu_Berkeley_Sbp_Haskell_SBP
12 import Util
13 import FromTree
14 import qualified Text.PrettyPrint.Leijen as PP
15
16 data Doc       = Doc Header [Section]
17 data Header    = Header        -- not yet specified
18
19 data Section   = Section
20                  Int           -- heading level
21                  [Text]        -- title
22                  [Paragraph]   -- content
23
24 data Paragraph = Blockquote [Paragraph]
25                | P          [Text]
26                | OL         [[Paragraph]]  -- list of items; each item is a [Paragraph]
27                | UL         [[Paragraph]]
28                | HR
29
30 data Style     = TT | Underline | Superscript | Subscript
31                | Strikethrough | Italic | Bold | Highlight
32
33 data Text      = WS
34                | Chars            String
35                | Quotes           [Text]
36                | GlyphText        Glyph
37                | Math             String
38                | Command          String [Text]
39                | Verbatim         String
40                | Link             [Text] URL
41                | Footnote         [Text]
42                | Styled     Style [Text]
43                | Keyword          [Text]
44                | SubPar           [Paragraph]
45
46 data Glyph     = Euro | CircleR | CircleC | TradeMark | ServiceMark
47                | Emdash | Ellipsis | Cent | Daggar | DoubleDaggar
48                | Clover | Flat | Sharp | Natural | CheckMark | XMark
49                | LeftArrow | DoubleLeftArrow | DoubleRightArrow
50                | DoubleLeftRightArrow | LeftRightArrow | Degree
51
52 data Login     = Login String (Maybe String)
53 data URL       = URLPath String
54                | Email String Host
55                | URL { url_method :: String,
56                        url_login  :: Maybe Login,
57                        url_host   :: Host,
58                        url_port   :: Maybe Int,
59                        url_path   :: String,
60                        url_ref    :: Maybe String }
61 data Host      = IP  Int Int Int Int 
62                | DNS [String]
63
64 -- Doc ------------------------------------------------------------------------------
65
66 instance PP.Pretty Doc where
67  pretty _ = PP.text $ "<not implemented>"
68
69 instance FromTree Doc where
70   fromTree (Tree "Doc" [a,b]  _) = Doc Header $ fromTree b
71   fromTree t                     = error $ "unable to create Doc from " ++ (show t)
72
73 -- Section ------------------------------------------------------------------------------
74
75 instance FromTree Section where
76   fromTree (Tree "Section" ((Tree "SectionHeader" [(Tree "=" e _),c] _):p) _) =
77         Section ((length e)-1) (fromTree c) $ concatMap fromTree p
78   fromTree t = error $ "couldnt Section.FromTree on " ++ (show t)
79
80 -- Paragraph ------------------------------------------------------------------------------
81
82 instance FromTrees [Paragraph] where
83   fromTrees ts = consolidate $ concatMap fromTree ts
84 instance FromTree [Paragraph] where
85   fromTree t = consolidate $ fromTree' t
86    where
87     fromTree' (Tree "Verbatim"       [ident,v]         _) = [P [(Verbatim $ unindent ident $ unverbate v)]]
88     fromTree' (Tree "TextParagraph"  [(Tree _ text _)] _) = [P  $ concatMap fromTree text]
89     fromTree' (Tree "Pars"           pars              _) = concatMap fromTree pars
90     fromTree' (Tree "HR"             _                 _) = [HR]
91     fromTree' (Tree "OL"             a                 _) = [OL $ map (\(Tree "LI" x _) -> fromTrees x) a]
92     fromTree' (Tree "UL"             a                 _) = [UL $ map (\(Tree "LI" x _) -> fromTrees x) a]
93     fromTree' (Tree ""               _                 _) = []
94     fromTree' (Tree "Blockquote"     pars              _) = [Blockquote $ fromTrees pars]
95     fromTree' t = error $ "unable to create [Paragraph] from " ++ (show t)
96
97 consolidate []                = []
98 consolidate [a]               = [a]
99 consolidate ((OL []):x)       = consolidate x
100 consolidate ((UL []):x)       = consolidate x
101 consolidate ((OL a):(OL b):x) = consolidate ((OL $ a++b):x)
102 consolidate ((UL a):(UL b):x) = consolidate ((UL $ a++b):x)
103 consolidate (a:b)             = a:(consolidate b)
104
105 -- Verbatim ------------------------------------------------------------------------------
106
107 unverbate (Tree "Verbatim" x _)          = concatMap unverbate x
108 unverbate (Tree "VerbatimBrace" [x,y] _) = (unverbate x)++" "++(unverbate y)
109 unverbate (Tree t [] _)                  = t
110
111 unindent (Tree "I" indent _) v = unindent' ((length indent)+1) v
112  where
113   unindent' i ('\n':x) = '\n':(unindent' i (drop' i x))
114   unindent' i (a:b)    = a:(unindent' i b)
115   unindent' i [] = []
116   drop' 0   x          = x
117   drop' n   x@('\n':r) = x
118   drop' n   []         = []
119   drop' n   (a:b)      = drop' (n-1) b
120
121 -- Text ------------------------------------------------------------------------------
122
123 instance FromTree [Text] where
124   fromTree (Tree "Word"    chars       _) = [Chars              $ concatMap fromTree chars]
125   fromTree (Tree "Ordinal" x           _) = [Command "ordinal"  $ [Chars $ concatMap show x]]
126   fromTree (Tree "Fraction" [n,d]      _) = [Command "fraction" $ [(Chars (show n)), (Chars (show d))]]
127   fromTree (Tree "WS"     _            _) = [WS]
128   fromTree (Tree "Quotes" [x]          _) = [Quotes $ fromTree x]
129   fromTree (Tree "Pars" y              _) = [SubPar $ fromTrees y]
130   fromTree (Tree "Command" [x,y]       _) = [Command (fromTree x) (fromTree y)]
131   fromTree (Tree "Command" [x]         _) = [Command (fromTree x) []]
132   fromTree (Tree "Link" [word,link]    _) = [Link (fromTree word) (fromTree link)]
133   fromTree (Tree "Footnote" x          _) = [Footnote $ concatMap fromTree x]
134   fromTree (Tree "Keyword" x           _) = [Keyword $ concatMap fromTree x]
135   fromTree (Tree "Math" x              _) = [Math $ fromTrees x]
136   fromTree (Tree "TT" x                _) = [Styled TT            $ concatMap fromTree x]
137   fromTree (Tree "Italic" [x]          _) = [Styled Italic        $ fromTree x]
138   fromTree (Tree "Bold" [x]            _) = [Styled Bold          $ fromTree x]
139   fromTree (Tree "Highlight" [x]       _) = [Styled Highlight     $ fromTree x]
140   fromTree (Tree "Strikethrough" x     _) = [Styled Strikethrough $ concatMap fromTree x]
141   fromTree (Tree "Superscript" x       _) = [Styled Superscript   $ concatMap fromTree x]
142   fromTree (Tree "Subscript" x         _) = [Styled Subscript     $ concatMap fromTree x]
143   fromTree (Tree "Underline" x         _) = [Styled Underline     $ concatMap fromTree x]
144   fromTree (Tree "(e)" _ _)               = [GlyphText Euro]
145   fromTree (Tree "(r)" _ _)               = [GlyphText CircleR]
146   fromTree (Tree "(c)" _ _)               = [GlyphText CircleC]
147   fromTree (Tree "(tm)" _ _)              = [GlyphText TradeMark]
148   fromTree (Tree "--" _ _)                = [GlyphText Emdash]
149   fromTree (Tree "<-" _ _)                = [GlyphText LeftArrow]
150   fromTree (Tree "<=" _ _)                = [GlyphText DoubleLeftArrow]
151   fromTree (Tree "=>" _ _)                = [GlyphText DoubleRightArrow]
152   fromTree (Tree "<=>" _ _)               = [GlyphText DoubleLeftRightArrow]
153   fromTree (Tree "<->" _ _)               = [GlyphText LeftRightArrow]
154   fromTree (Tree "^o" _ _)                = [GlyphText Degree]
155   fromTree (Tree "..." _ _)               = [GlyphText Ellipsis]
156   fromTree (Tree "Text" t  _)             = concatMap fromTree t
157   fromTree (Tree ""     [] _)             = []
158   fromTree t                              = error $ "unable to create [Text] from " ++ (show t)
159
160 -- URLs ------------------------------------------------------------------------------
161
162 instance Show Login where
163  show (Login name Nothing)     = name
164  show (Login name (Just pass)) = name++":"++(urlEscape pass)
165
166 instance Show URL where
167  show (URLPath up) = up
168  show (Email s h) = "mailto:" ++ s ++ "@" ++ (show h)
169  show (URL { url_method=m, url_login=l, url_host=h, url_port=port, url_path=path, url_ref=ref }) =
170      m++"://"++
171      (case l of
172        Nothing -> ""
173        (Just log) -> (show log)++"@")
174      ++(show h)
175      ++"/"
176      ++(urlEscape path)
177      ++(case ref of
178           Nothing -> ""
179           (Just []) -> ""
180           (Just j) -> "#"++(urlEscape j))
181
182 instance FromTree URL where
183   fromTree (Tree "URL"   stuff                         _) = fromTrees stuff
184   fromTree (Tree "Email" [(Tree "username" un _),host] _) = Email (fromTrees un) (fromTree host)
185   fromTree (Tree "Path"  stuff                         _) = URLPath $ map fromUrlChar stuff
186    where
187     fromUrlChar (Tree "%" [(Tree a [] _),(Tree b [] _)] _) = chr $ (fst $ head $ readHex (a++b))
188     fromUrlChar (Tree [c] []                            _) = c
189     fromUrlChar t                                          = error $ "could not parse as an url char: " ++ (show t)
190
191 fromTreeChildren (Tree _ c _) = fromTrees c
192 instance FromTrees URL where
193  fromTrees (method:login:host:port:rest) =
194    URL { url_method = fromTreeChildren method,
195          url_host   = fromTree host,
196          url_login  = Nothing,
197          url_port   = case port of { (Tree "Port" port _) -> Just $ fromTrees port; _ -> Nothing },
198          url_path   = case rest of { ((Tree "Path" p _):_) -> fromTrees p; _ -> "" },
199          url_ref    = case rest of { (_:(Tree "Path" r _):_) -> Just $ fromTrees r; _ -> Nothing }
200        }
201  fromTrees x = error $ show x
202
203 instance Show Host where
204  show (IP a b c d) = (show a)++"."++(show b)++"."++(show c)++"."++(show d)
205  show (DNS host)   = join "." host
206
207 instance FromTree Host where
208   fromTree (Tree "IP" (a:b:c:d:[]) _) =
209       IP (fromTreeChildren a) (fromTreeChildren b) (fromTreeChildren c) (fromTreeChildren d) 
210   fromTree (Tree "DNS" parts _) = DNS $ map (\(Tree _ c _) -> fromTrees c) parts
211
212 urlEscape s = concatMap urlEscapeChar s
213  where
214   -- non-alphanumerics which may appear unescaped
215   urlEscapeChar '$'                        = "$"
216   urlEscapeChar '-'                        = "-"
217   urlEscapeChar '_'                        = "_"
218   urlEscapeChar '.'                        = "."
219   urlEscapeChar '!'                        = "!"
220   urlEscapeChar '*'                        = "*"
221   urlEscapeChar '\''                       = "\'"
222   urlEscapeChar '('                        = "("
223   urlEscapeChar ')'                        = ")"
224   urlEscapeChar ','                        = ","
225
226   -- technically these aren't allowed by RFC, but we include them anyways
227   urlEscapeChar '/'                        = "/"
228   urlEscapeChar ';'                        = ";"
229   urlEscapeChar '&'                        = "&"
230   urlEscapeChar '='                        = "="
231   urlEscapeChar '$'                        = "$"
232
233   -- FIXME: this will wind up "disencoding" a %-encoded question mark
234   urlEscapeChar '?'                        = "?"
235
236   urlEscapeChar c   | c >= 'a' && c <= 'z' = [c]
237                     | c >= 'A' && c <= 'Z' = [c]
238                     | c >= '0' && c <= '9' = [c]
239
240                     -- encoded
241                     | otherwise            = '%':d1:d2:[]
242                        where i  = ord c
243                              d1 = head $ showHex ((i .&. 0xff) `shiftR` 4) ""
244                              d2 = head $ showHex ((i .&. 0x0f))            ""
245
246 \end{code}