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 | RightArrow | 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 $ concatMap fromUrlChar stuff
 186
 187 --fromUrlChar (Tree "%" [(Tree a [] _),(Tree b [] _)] _) = chr $ (fst $ head $ readHex (a++b))
 188 -- FIXME: problem here is the "/" vs "%2F" issue, so we "leave urls urlencoded"
 189 fromUrlChar (Tree "%" [(Tree a [] _),(Tree b [] _)] _) = "%"++a++b
 190 fromUrlChar (Tree [c] []                            _) = [c]
 191 fromUrlChar t                                          = error $ "could not parse as an url char: " ++ (show t)
 192
 193 fromTreeChildren (Tree _ c _) = fromTrees c
 194 instance FromTrees URL where
 195  fromTrees (method:login:host:port:rest) =
 196    URL { url_method = fromTreeChildren method,
 197          url_host   = fromTree host,
 198          url_login  = Nothing,
 199          url_port   = case port of { (Tree "Port" port _) -> Just $ fromTrees port; _ -> Nothing },
 200          url_path   = case rest of { ((Tree "Path" p _):_) -> concatMap fromUrlChar p; _ -> "" },
 201          url_ref    = case rest of { (_:(Tree "Path" r _):_) -> Just $ fromTrees r; _ -> Nothing }
 202        }
 203  fromTrees x = error $ show x
 204
 205 instance Show Host where
 206  show (IP a b c d) = (show a)++"."++(show b)++"."++(show c)++"."++(show d)
 207  show (DNS host)   = join "." host
 208
 209 instance FromTree Host where
 210   fromTree (Tree "IP" (a:b:c:d:[]) _) =
 211       IP (fromTreeChildren a) (fromTreeChildren b) (fromTreeChildren c) (fromTreeChildren d)
 212   fromTree (Tree "DNS" parts _) = DNS $ map (\(Tree _ c _) -> fromTrees c) parts
 213
 214 urlEscape s = concatMap urlEscapeChar s
 215  where
 216   -- non-alphanumerics which may appear unescaped
 217   urlEscapeChar '$'                        = "$"
 218   urlEscapeChar '-'                        = "-"
 219   urlEscapeChar '_'                        = "_"
 220   urlEscapeChar '.'                        = "."
 221   urlEscapeChar '!'                        = "!"
 222   urlEscapeChar '*'                        = "*"
 223   urlEscapeChar '\''                       = "\'"
 224   urlEscapeChar '('                        = "("
 225   urlEscapeChar ')'                        = ")"
 226   urlEscapeChar ','                        = ","
 227
 228   -- technically these aren't allowed by RFC, but we include them anyways
 229   urlEscapeChar '/'                        = "/"
 230   urlEscapeChar ';'                        = ";"
 231   urlEscapeChar '&'                        = "&"
 232   urlEscapeChar '='                        = "="
 233   urlEscapeChar '$'                        = "$"
 234
 235   -- FIXME: this will wind up "disencoding" a %-encoded question mark
 236   urlEscapeChar '?'                        = "?"
 237
 238   urlEscapeChar c   | c >= 'a' && c <= 'z' = [c]
 239                     | c >= 'A' && c <= 'Z' = [c]
 240                     | c >= '0' && c <= '9' = [c]
 241
 242                     -- encoded
 243                     | otherwise            = '%':d1:d2:[]
 244                        where i  = ord c
 245                              d1 = head $ showHex ((i .&. 0xff) `shiftR` 4) ""
 246                              d2 = head $ showHex ((i .&. 0x0f))            ""
 247
 248 \end{code}