\begin{code}
-- Copyright 2008 the Contributors, as shown in the revision logs.
-- Licensed under the Apache Public Source License 2.0 ("the License").
-- You may not use this file except in compliance with the License.

module Doc
where
import Numeric
import Data.Bits
import Data.Char
import Edu_Berkeley_Sbp_Haskell_SBP
import Util
import FromTree
import qualified Text.PrettyPrint.Leijen as PP

data Doc       = Doc Header [Section]
data Header    = Header        -- not yet specified

data Section   = Section
                 Int           -- heading level
                 [Text]        -- title
                 [Paragraph]   -- content

data Paragraph = Blockquote [Paragraph]
               | P          [Text]
               | OL         [[Paragraph]]  -- list of items; each item is a [Paragraph]
               | UL         [[Paragraph]]
               | HR

data Style     = TT | Underline | Superscript | Subscript
               | Strikethrough | Italic | Bold | Highlight

data Text      = WS
               | Chars            String
               | Quotes           [Text]
               | GlyphText        Glyph
               | Math             String
               | Command          String [Text]
               | Verbatim         String
               | Link             [Text] URL
               | Footnote         [Text]
               | Styled     Style [Text]
               | Keyword          [Text]
               | SubPar           [Paragraph]

data Glyph     = Euro | CircleR | CircleC | TradeMark | ServiceMark
               | Emdash | Ellipsis | Cent | Daggar | DoubleDaggar
               | Clover | Flat | Sharp | Natural | CheckMark | XMark
               | LeftArrow | DoubleLeftArrow | DoubleRightArrow
               | DoubleLeftRightArrow | LeftRightArrow | Degree

data Login     = Login String (Maybe String)
data URL       = URLPath String
               | Email String Host
               | URL { url_method :: String,
                       url_login  :: Maybe Login,
                       url_host   :: Host,
                       url_port   :: Maybe Int,
                       url_path   :: String,
                       url_ref    :: Maybe String }
data Host      = IP  Int Int Int Int 
               | DNS [String]

-- Doc ------------------------------------------------------------------------------

instance PP.Pretty Doc where
 pretty _ = PP.text $ "<not implemented>"

instance FromTree Doc where
  fromTree (Tree "Doc" [a,b]  _) = Doc Header $ fromTree b
  fromTree t                     = error $ "unable to create Doc from " ++ (show t)

-- Section ------------------------------------------------------------------------------

instance FromTree Section where
  fromTree (Tree "Section" ((Tree "SectionHeader" [(Tree "=" e _),c] _):p) _) =
        Section ((length e)-1) (fromTree c) $ concatMap fromTree p
  fromTree t = error $ "couldnt Section.FromTree on " ++ (show t)

-- Paragraph ------------------------------------------------------------------------------

instance FromTrees [Paragraph] where
  fromTrees ts = consolidate $ concatMap fromTree ts
instance FromTree [Paragraph] where
  fromTree t = consolidate $ fromTree' t
   where
    fromTree' (Tree "Verbatim"       [ident,v]         _) = [P [(Verbatim $ unindent ident $ unverbate v)]]
    fromTree' (Tree "TextParagraph"  [(Tree _ text _)] _) = [P  $ concatMap fromTree text]
    fromTree' (Tree "Pars"           pars              _) = concatMap fromTree pars
    fromTree' (Tree "HR"             _                 _) = [HR]
    fromTree' (Tree "OL"             a                 _) = [OL $ map (\(Tree "LI" x _) -> fromTrees x) a]
    fromTree' (Tree "UL"             a                 _) = [UL $ map (\(Tree "LI" x _) -> fromTrees x) a]
    fromTree' (Tree ""               _                 _) = []
    fromTree' (Tree "Blockquote"     pars              _) = [Blockquote $ fromTrees pars]
    fromTree' t = error $ "unable to create [Paragraph] from " ++ (show t)

consolidate []                = []
consolidate [a]               = [a]
consolidate ((OL []):x)       = consolidate x
consolidate ((UL []):x)       = consolidate x
consolidate ((OL a):(OL b):x) = consolidate ((OL $ a++b):x)
consolidate ((UL a):(UL b):x) = consolidate ((UL $ a++b):x)
consolidate (a:b)             = a:(consolidate b)

-- Verbatim ------------------------------------------------------------------------------

unverbate (Tree "Verbatim" x _)          = concatMap unverbate x
unverbate (Tree "VerbatimBrace" [x,y] _) = (unverbate x)++" "++(unverbate y)
unverbate (Tree t [] _)                  = t

unindent (Tree "I" indent _) v = unindent' ((length indent)+1) v
 where
  unindent' i ('\n':x) = '\n':(unindent' i (drop' i x))
  unindent' i (a:b)    = a:(unindent' i b)
  unindent' i [] = []
  drop' 0   x          = x
  drop' n   x@('\n':r) = x
  drop' n   []         = []
  drop' n   (a:b)      = drop' (n-1) b

-- Text ------------------------------------------------------------------------------

instance FromTree [Text] where
  fromTree (Tree "Word"    chars       _) = [Chars              $ concatMap fromTree chars]
  fromTree (Tree "Ordinal" x           _) = [Command "ordinal"  $ [Chars $ concatMap show x]]
  fromTree (Tree "Fraction" [n,d]      _) = [Command "fraction" $ [(Chars (show n)), (Chars (show d))]]
  fromTree (Tree "WS"     _            _) = [WS]
  fromTree (Tree "Quotes" [x]          _) = [Quotes $ fromTree x]
  fromTree (Tree "Pars" y              _) = [SubPar $ fromTrees y]
  fromTree (Tree "Command" [x,y]       _) = [Command (fromTree x) (fromTree y)]
  fromTree (Tree "Command" [x]         _) = [Command (fromTree x) []]
  fromTree (Tree "Link" [word,link]    _) = [Link (fromTree word) (fromTree link)]
  fromTree (Tree "Footnote" x          _) = [Footnote $ concatMap fromTree x]
  fromTree (Tree "Keyword" x           _) = [Keyword $ concatMap fromTree x]
  fromTree (Tree "Math" x              _) = [Math $ fromTrees x]
  fromTree (Tree "TT" x                _) = [Styled TT            $ concatMap fromTree x]
  fromTree (Tree "Italic" [x]          _) = [Styled Italic        $ fromTree x]
  fromTree (Tree "Bold" [x]            _) = [Styled Bold          $ fromTree x]
  fromTree (Tree "Highlight" [x]       _) = [Styled Highlight     $ fromTree x]
  fromTree (Tree "Strikethrough" x     _) = [Styled Strikethrough $ concatMap fromTree x]
  fromTree (Tree "Superscript" x       _) = [Styled Superscript   $ concatMap fromTree x]
  fromTree (Tree "Subscript" x         _) = [Styled Subscript     $ concatMap fromTree x]
  fromTree (Tree "Underline" x         _) = [Styled Underline     $ concatMap fromTree x]
  fromTree (Tree "(e)" _ _)               = [GlyphText Euro]
  fromTree (Tree "(r)" _ _)               = [GlyphText CircleR]
  fromTree (Tree "(c)" _ _)               = [GlyphText CircleC]
  fromTree (Tree "(tm)" _ _)              = [GlyphText TradeMark]
  fromTree (Tree "--" _ _)                = [GlyphText Emdash]
  fromTree (Tree "<-" _ _)                = [GlyphText LeftArrow]
  fromTree (Tree "<=" _ _)                = [GlyphText DoubleLeftArrow]
  fromTree (Tree "=>" _ _)                = [GlyphText DoubleRightArrow]
  fromTree (Tree "<=>" _ _)               = [GlyphText DoubleLeftRightArrow]
  fromTree (Tree "<->" _ _)               = [GlyphText LeftRightArrow]
  fromTree (Tree "^o" _ _)                = [GlyphText Degree]
  fromTree (Tree "..." _ _)               = [GlyphText Ellipsis]
  fromTree (Tree "Text" t  _)             = concatMap fromTree t
  fromTree (Tree ""     [] _)             = []
  fromTree t                              = error $ "unable to create [Text] from " ++ (show t)

-- URLs ------------------------------------------------------------------------------

instance Show Login where
 show (Login name Nothing)     = name
 show (Login name (Just pass)) = name++":"++(urlEscape pass)

instance Show URL where
 show (URLPath up) = up
 show (Email s h) = "mailto:" ++ s ++ "@" ++ (show h)
 show (URL { url_method=m, url_login=l, url_host=h, url_port=port, url_path=path, url_ref=ref }) =
     m++"://"++
     (case l of
       Nothing -> ""
       (Just log) -> (show log)++"@")
     ++(show h)
     ++"/"
     ++(urlEscape path)
     ++(case ref of
          Nothing -> ""
          (Just []) -> ""
          (Just j) -> "#"++(urlEscape j))

instance FromTree URL where
  fromTree (Tree "URL"   stuff                         _) = fromTrees stuff
  fromTree (Tree "Email" [(Tree "username" un _),host] _) = Email (fromTrees un) (fromTree host)
  fromTree (Tree "Path"  stuff                         _) = URLPath $ map fromUrlChar stuff
   where
    fromUrlChar (Tree "%" [(Tree a [] _),(Tree b [] _)] _) = chr $ (fst $ head $ readHex (a++b))
    fromUrlChar (Tree [c] []                            _) = c
    fromUrlChar t                                          = error $ "could not parse as an url char: " ++ (show t)

fromTreeChildren (Tree _ c _) = fromTrees c
instance FromTrees URL where
 fromTrees (method:login:host:port:rest) =
   URL { url_method = fromTreeChildren method,
         url_host   = fromTree host,
         url_login  = Nothing,
         url_port   = case port of { (Tree "Port" port _) -> Just $ fromTrees port; _ -> Nothing },
         url_path   = case rest of { ((Tree "Path" p _):_) -> fromTrees p; _ -> "" },
         url_ref    = case rest of { (_:(Tree "Path" r _):_) -> Just $ fromTrees r; _ -> Nothing }
       }
 fromTrees x = error $ show x

instance Show Host where
 show (IP a b c d) = (show a)++"."++(show b)++"."++(show c)++"."++(show d)
 show (DNS host)   = join "." host

instance FromTree Host where
  fromTree (Tree "IP" (a:b:c:d:[]) _) =
      IP (fromTreeChildren a) (fromTreeChildren b) (fromTreeChildren c) (fromTreeChildren d) 
  fromTree (Tree "DNS" parts _) = DNS $ map (\(Tree _ c _) -> fromTrees c) parts

urlEscape s = concatMap urlEscapeChar s
 where
  -- non-alphanumerics which may appear unescaped
  urlEscapeChar '$'                        = "$"
  urlEscapeChar '-'                        = "-"
  urlEscapeChar '_'                        = "_"
  urlEscapeChar '.'                        = "."
  urlEscapeChar '!'                        = "!"
  urlEscapeChar '*'                        = "*"
  urlEscapeChar '\''                       = "\'"
  urlEscapeChar '('                        = "("
  urlEscapeChar ')'                        = ")"
  urlEscapeChar ','                        = ","

  -- technically these aren't allowed by RFC, but we include them anyways
  urlEscapeChar '/'                        = "/"
  urlEscapeChar ';'                        = ";"
  urlEscapeChar '&'                        = "&"
  urlEscapeChar '='                        = "="
  urlEscapeChar '$'                        = "$"

  -- FIXME: this will wind up "disencoding" a %-encoded question mark
  urlEscapeChar '?'                        = "?"

  urlEscapeChar c   | c >= 'a' && c <= 'z' = [c]
                    | c >= 'A' && c <= 'Z' = [c]
                    | c >= '0' && c <= '9' = [c]

                    -- encoded
                    | otherwise            = '%':d1:d2:[]
                       where i  = ord c
                             d1 = head $ showHex ((i .&. 0xff) `shiftR` 4) ""
                             d2 = head $ showHex ((i .&. 0x0f))            ""

\end{code}