src/Doc.lhs

   1 \begin{code}
   2 module Doc
   3 where
   4 import Numeric
   5 import Data.Bits
   6 import Data.Char
   7 import Edu_Berkeley_Sbp_Haskell_SBP
   8 import Util
   9 import FromTree
  10 import qualified Text.PrettyPrint.Leijen as PP
  11
  12 data Doc       = Doc Header [Section]
  13 data Header    = Header        -- not yet specified
  14
  15 data Section   = Section
  16                  Int           -- heading level
  17                  [Text]        -- title
  18                  [Paragraph]   -- content
  19
  20 data Paragraph = Blockquote [Paragraph]
  21                | P          [Text]
  22                | OL         [[Paragraph]]  -- list of items; each item is a [Paragraph]
  23                | UL         [[Paragraph]]
  24                | HR
  25
  26 data Style     = TT | Underline | Superscript | Subscript
  27                | Strikethrough | Italic | Bold | Highlight
  28
  29 data Text      = WS
  30                | Chars            String
  31                | Quotes           [Text]
  32                | GlyphText        Glyph
  33                | Math             String
  34                | Command          String [Text]
  35                | Verbatim         String
  36                | Link             [Text] URL
  37                | Footnote         [Text]
  38                | Styled     Style [Text]
  39                | Keyword          [Text]
  40                | SubPar           [Paragraph]
  41
  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
  47
  48 data Login     = Login String (Maybe String)
  49 data URL       = URLPath String
  50                | Email String Host
  51                | URL { url_method :: String,
  52                        url_login  :: Maybe Login,
  53                        url_host   :: Host,
  54                        url_port   :: Maybe Int,
  55                        url_path   :: String,
  56                        url_ref    :: Maybe String }
  57 data Host      = IP  Int Int Int Int
  58                | DNS [String]
  59
  60 -- Doc ------------------------------------------------------------------------------
  61
  62 instance PP.Pretty Doc where
  63  pretty _ = PP.text $ "<not implemented>"
  64
  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)
  68
  69 -- Section ------------------------------------------------------------------------------
  70
  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)
  75
  76 -- Paragraph ------------------------------------------------------------------------------
  77
  78 instance FromTrees [Paragraph] where
  79   fromTrees ts = consolidate $ concatMap fromTree ts
  80 instance FromTree [Paragraph] where
  81   fromTree t = consolidate $ fromTree' t
  82    where
  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)
  92
  93 consolidate []                = []
  94 consolidate [a]               = [a]
  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)
 100
 101 -- Verbatim ------------------------------------------------------------------------------
 102
 103 unverbate (Tree "Verbatim" x _)          = concatMap unverbate x
 104 unverbate (Tree "VerbatimBrace" [x,y] _) = (unverbate x)++" "++(unverbate y)
 105 unverbate (Tree t [] _)                  = t
 106
 107 unindent (Tree "I" indent _) v = unindent' ((length indent)+1) v
 108  where
 109   unindent' i ('\n':x) = '\n':(unindent' i (drop' i x))
 110   unindent' i (a:b)    = a:(unindent' i b)
 111   unindent' i [] = []
 112   drop' 0   x          = x
 113   drop' n   x@('\n':r) = x
 114   drop' n   []         = []
 115   drop' n   (a:b)      = drop' (n-1) b
 116
 117 -- Text ------------------------------------------------------------------------------
 118
 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)
 155
 156 -- URLs ------------------------------------------------------------------------------
 157
 158 instance Show Login where
 159  show (Login name Nothing)     = name
 160  show (Login name (Just pass)) = name++":"++(urlEscape pass)
 161
 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 }) =
 166      m++"://"++
 167      (case l of
 168        Nothing -> ""
 169        (Just log) -> (show log)++"@")
 170      ++(show h)
 171      ++"/"
 172      ++(urlEscape path)
 173      ++(case ref of
 174           Nothing -> ""
 175           (Just []) -> ""
 176           (Just j) -> "#"++(urlEscape j))
 177
 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
 182    where
 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)
 186
 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,
 192          url_login  = Nothing,
 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 }
 196        }
 197  fromTrees x = error $ show x
 198
 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
 202
 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
 207
 208 urlEscape s = concatMap urlEscapeChar s
 209  where
 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 ','                        = ","
 221
 222   -- technically these aren't allowed by RFC, but we include them anyways
 223   urlEscapeChar '/'                        = "/"
 224   urlEscapeChar ';'                        = ";"
 225   urlEscapeChar '&'                        = "&"
 226   urlEscapeChar '='                        = "="
 227   urlEscapeChar '$'                        = "$"
 228
 229   -- FIXME: this will wind up "disencoding" a %-encoded question mark
 230   urlEscapeChar '?'                        = "?"
 231
 232   urlEscapeChar c   | c >= 'a' && c <= 'z' = [c]
 233                     | c >= 'A' && c <= 'Z' = [c]
 234                     | c >= '0' && c <= '9' = [c]
 235
 236                     -- encoded
 237                     | otherwise            = '%':d1:d2:[]
 238                        where i  = ord c
 239                              d1 = head $ showHex ((i .&. 0xff) `shiftR` 4) ""
 240                              d2 = head $ showHex ((i .&. 0x0f))            ""
 241
 242 \end{code}