src/Main.lhs

   1 \begin{code}
   2 module Main
   3 where
   4 import SBP
   5 main = do t <- parseFile "../wix/wix.g" "../wix/lasik.wix"
   6           putStrLn $ toHtml $ ((fromTree $ coalesceFlatHeadlessNodes t) :: Doc)
   7
   8 -- url crap
   9 -- ul/ol
  10 -- glyphs
  11
  12 ------------------------------------------------------------------------------
  13 data Doc       = Doc     Header [Section]
  14 data Section   = Section [Text]   [Paragraph]
  15 data Paragraph = Blockquote [Text]
  16                | HR
  17                | OL
  18                | P          [Text]
  19 data Text      = WS
  20                | Chars         String
  21                | Symbol        String
  22                | Quotes        [Text]
  23                | Block         [Text]
  24                | Command       String [Text]
  25                | Verbatim      String
  26                | Link          [Text] URL
  27                | Underline     [Text]
  28                | Footnote      [Text]
  29                | TT            [Text]
  30                | Citation      [Text]
  31                | Strikethrough [Text]
  32                | Superscript   [Text]
  33                | Subscript     [Text]
  34                | Smallcap      [Text]
  35                | Bold          [Text]
  36                | Keyword       [Text]
  37                | Italic        [Text]
  38 data Header    = Header
  39 data URL       = URL
  40   deriving Show
  41
  42 {-
  43 glyph         = euro::     "(e)"
  44               | r::        "(r)"
  45               | c::        "(c)"
  46               | tm::       "(tm)"
  47               | emdash::   "--"
  48               | ellipses:: "..."
  49               | cent::     "\\cent"
  50 -}
  51
  52 ------------------------------------------------------------------------------
  53 class FromTree a where
  54  fromTree  :: Tree   -> a
  55 class FromTrees a where
  56  fromTrees :: [Tree] -> a
  57 instance FromTree a => FromTree [a] where
  58  fromTree (Tree _ c _) = map fromTree c
  59
  60 instance FromTree Doc where
  61   fromTree (Tree "Doc" [a,b]  _) = Doc Header $ fromTree b
  62   fromTree (Tree "Doc" [b]    _) = Doc Header $ fromTree b
  63   fromTree _                     = error "top level must be Doc"
  64
  65 instance FromTree Section where
  66   fromTree (Tree "Section" [(Tree _ c _),(Tree _ paragraphs _)] _) =
  67      Section (map fromTree c) $ map fromTree paragraphs
  68
  69 instance FromTree Paragraph where
  70   fromTree (Tree "P"   [Tree _ text _] _) = P  $ map fromTree text
  71   fromTree (Tree "HR"  _ _)               = HR
  72
  73 instance FromTree Text where
  74   fromTree (Tree "Chars"  chars _)        = Chars  $ fromTrees chars
  75   fromTree (Tree "WS"     _     _)        = WS
  76   fromTree (Tree "Symbol" sym   _)        = Symbol $ fromTrees sym
  77   fromTree (Tree "Quotes" x     _)        = Quotes $ map fromTree x
  78   fromTree (Tree "Block" x     _)         = Block $ map fromTree x
  79   fromTree (Tree "Command" [x,y]     _)   = Command (fromTree x) (fromTree y)
  80   fromTree (Tree "Verbatim" x     _)      = Verbatim $ fromTrees x
  81   fromTree (Tree "Link" [word,link]   _)  = Link (fromTree word) (fromTree link)
  82   fromTree (Tree "Underline" x     _)     = Underline $ map fromTree x
  83   fromTree (Tree "Footnote" x     _)      = Footnote $ map fromTree x
  84   fromTree (Tree "TT" x     _)            = TT $ map fromTree x
  85   fromTree (Tree "Citation" x     _)      = Citation $ map fromTree x
  86   fromTree (Tree "Strikethrough" x     _) = Strikethrough $ map fromTree x
  87   fromTree (Tree "Superscript" x     _)   = Superscript $ map fromTree x
  88   fromTree (Tree "Subscript" x     _)     = Subscript $ map fromTree x
  89   fromTree (Tree "Smallcap" x     _)      = Smallcap $ map fromTree x
  90   fromTree (Tree "Bold" x     _)          = Bold $ map fromTree x
  91   fromTree (Tree "Keyword" x     _)       = Keyword $ map fromTree x
  92   fromTree (Tree "Italic" x     _)        = Italic $ map fromTree x
  93   fromTree (Tree x        _     _)        = Chars  $ x
  94
  95 instance FromTree URL where
  96   fromTree x = URL
  97
  98 instance FromTree  String where
  99   fromTree  (Tree h c _) = h++(concatMap fromTree c)
 100 instance FromTrees String where
 101   fromTrees ts           = concatMap (fromTree :: Tree -> String) ts
 102
 103 ------------------------------------------------------------------------------
 104 class ToHtml a where
 105   toHtml :: a -> String
 106 instance ToHtml a => ToHtml [a] where
 107   toHtml x = concatMap toHtml x
 108
 109 instance ToHtml Doc where
 110  toHtml (Doc h secs) = "<html><body>" ++ (toHtml secs) ++ "</body></html>"
 111 instance ToHtml Section where
 112  toHtml (Section header paragraphs) = "<h1>"++(toHtml header)++"</h1>"++(toHtml paragraphs)
 113 instance ToHtml Paragraph where
 114  toHtml (Blockquote t) = "<blockquote>"++(toHtml t)++"</blockquote>"
 115  toHtml HR             = "<hr/>"
 116  toHtml OL             = "<ol/>"
 117  toHtml (P t)          = "<p>"++(toHtml t)++"</p>"
 118 instance ToHtml Text where
 119  toHtml WS                = " "
 120  toHtml (Chars s)         = toHtml s
 121  toHtml (Symbol s)        = toHtml s
 122  toHtml (Quotes x)        = "\""++(toHtml x)++"\""
 123  toHtml (Block x)         = toHtml x
 124  toHtml (Verbatim x)      = "<pre>\n"++x++"\n</pre>"
 125  toHtml (Link t ref)      = "<a href='"++(show ref)++"'>"++(toHtml t)++"</a>"
 126  toHtml (Underline x)     = "<u>"++(toHtml x)++"</u>"
 127  toHtml (TT x)            = "<tt>"++(toHtml x)++"</tt>"
 128  toHtml (Citation x)      = "<i>"++(toHtml x)++"</i>"
 129  toHtml (Strikethrough x) = "<strike>"++(toHtml x)++"</strike>"
 130  toHtml (Superscript x)   = "<sup>"++(toHtml x)++"</sup>"
 131  toHtml (Subscript x)     = "<sub>"++(toHtml x)++"</sub>"
 132  toHtml (Smallcap x)      = "<sc>"++(toHtml x)++"</sc>"
 133  toHtml (Bold x)          = "<b>"++(toHtml x)++"</b>"
 134  toHtml (Keyword x)       = "<tt>"++(toHtml x)++"</tt>"
 135  toHtml (Italic x)        = "<i>"++(toHtml x)++"</i>"
 136  toHtml (Command x y)     = error $ "unsupported command "++(show x)
 137  toHtml (Footnote x)      = error $ "footnotes not supported"
 138
 139 instance ToHtml String where
 140   toHtml s = concatMap htmlEscapeChar s
 141    where
 142      htmlEscapeChar '<'  = "&lt;"
 143      htmlEscapeChar '>'  = "&gt;"
 144      htmlEscapeChar '&'  = "&amp;"
 145      htmlEscapeChar '\'' = "&apos;"
 146      htmlEscapeChar '\"' = "&quot;"
 147      htmlEscapeChar c    = [c]
 148
 149
 150
 151
 152
 153
 154 {-
 155
 156 Doc: { { Section: { { Chars: { 19 } Symbol: { - } Chars: { Nov } }
 157                     { P: { { Chars: { Two } WS Chars: { weeks } WS Chars: { ago } WS
 158                              Chars: { I } WS Chars: { had } WS Chars: { Lasik } WS
 159                              Chars: { performed } WS Chars: { at } WS
 160                              Link: { { Chars: { the } WS Chars: { Pacific } WS Chars: { Vision }
 161                                        WS Chars: { Institute } }
 162                                      URL: { http DNS: { { pacificvision org } } { . } } }
 163                              WS Chars: { The } WS Chars: { short } WS Chars: { story } WS
 164                              Chars: { is } WS Chars: { that } WS Chars: { it } WS
 165                              Chars: { rocks } Symbol: { , } WS Chars: { and } WS Chars: { I } WS
 166                                               Chars: { very } WS Chars: { highly } WS
 167                                               Chars: { recommend } WS Chars: { Dr } Symbol: { . } WS
 168                                                                                     Chars: { Faktorovich }
 169                                                                                     Symbol: { , } WS
 170                                                                                     Chars: { as } WS
 171                                                                                     Chars: { well }
 172                                                                                     WS Chars: { as }
 173                                                                                     WS
 174                                                                                     Chars: { the }
 175
 176 -}
 177 \end{code}
 178
 179
 180
 181