content: ----------------------------------------------------------------------
  -- |
  -- Maintainer  : AR
  -- Stability   : (stable)
  -- Portability : (portable)
  --
  -- > CVS $Date: 2005/04/16 05:40:50 $ 
  -- > CVS $Author: peb $
  -- > CVS $Revision: 1.7 $
  --
  -- produce a HTML document from a list of GF grammar files. AR 6\/10\/2002
  --
  -- Added @--!@ (NewPage) and @--*@ (Item) 21\/11\/2003
  -----------------------------------------------------------------------------
  
  module Main (main) where
  
  
  import Data.Char
  import Data.List
  import System.Process
  import System.Directory -- from package directory>=1.2
  import System.Environment
  import Data.Time -- from package time>=1.5
  --import System.Locale -- from package old-locale
  --import System.Time -- from package old-time
  
  -- to read files and write a file
  
  main :: IO ()
  main = do
    xx <- getArgs
    let 
     (typ,format,names) = case xx of
      "-latex"  : xs -> (0,doc2latex,xs)
      "-htmls"  : xs -> (2,doc2html,xs)
      "-txt"    : xs -> (3,doc2txt,xs)
      "-txt2"   : xs -> (3,doc2txt2,xs)
      "-txthtml": xs -> (4,doc2txt,xs)
      xs            -> (1,doc2html,xs)
    if null xx
       then do
         putStrLn welcome
         putStrLn help
       else flip mapM_ names (\name -> do  
         ss <- readFile name
         time <- modTime name
         let outfile = fileFormat typ name
         writeFile outfile $ format $ pDoc time ss)
    case typ of
       2 -> 
         mapM_ (\name -> system $ "htmls " ++ (fileFormat typ name)) names
       4 ->
         mapM_ (\name -> 
                 system $ "txt2tags -thtml --toc " ++ (fileFormat typ name)) names
       _ -> return ()
    return ()
  
  modTime :: FilePath -> IO ModTime
  -- Works with directory>=1.2, time>=1.5
  modTime name =
    do zt <- utcToLocalZonedTime =<< getModificationTime name
       let timeFmt = "%Y-%m-%d %H:%M:%S %Z"
       return $ formatTime defaultTimeLocale timeFmt zt
  {-
  -- Works with directory<1.2, old-time, old-locale
  modTime name =
      do
      t <- getModificationTime name
      ct <- toCalendarTime t
      let timeFmt = "%Y-%m-%d %H:%M:%S %Z"
      return $ formatCalendarTime defaultTimeLocale timeFmt ct
  -}
  
  welcome = unlines [
    "",
    "gfdoc - a rudimentary GF document generator.",
    "(c) Aarne Ranta (aarne@cs.chalmers.se) 2002 under GNU GPL."
    ]
  
  help = unlines $ [
    "",
    "Usage: gfdoc (-latex|-htmls|-txt|-txthtml) <file>+",
    "",
    "The program operates with lines in GF code, treating them into LaTeX",
    "(flag -latex), to a set of HTML documents (flag -htmls), to a txt2tags file",
    "(flag -txt), to HTML via txt (flag -txthtml), or to one",
    "HTML file (by default). The output is written in a file",
    "whose name is formed from the input file name by replacing its suffix",
    "with html or tex; in case of set of HTML files, the names are prefixed",
    "by 01-, 02-, etc, and each file has navigation links.",
    "",
    "The translation is line by line",
    "depending as follows on how the line begins",
    "",
    " --[Int]    heading of level Int",  
    " --         new paragraph",
    " --!        new page (in HTML, recognized by the htmls program)",
    " --.        end of document",
    " --*[Text]  Text paragraph starting with a bullet",
    " --[Text]   Text belongs to text paragraph",
    " [Text]     Text belongs to code paragraph",
    " --%        (in the end of a line): ignore this line",
    "",
    "Within a text paragraph, text enclosed between certain characters",
    "is treated specially:",
    "",
    " *[Text]*   emphasized (boldface)",
    " \"[Text]\"   example string (italics)",
    " $[Text]$   example code (courier)",
    "",
    "For other formatting and links, we recommend the txt2tags format."
    ]
  
  fileFormat typ x = body ++ suff where
    body = reverse $ dropWhile (/='.') $ reverse x
    suff = case typ of
      0 -> "tex"
      _ | typ < 3 -> "html"
      _ -> "txt"
  
  -- the document datatype
  
  data Doc = Doc Title ModTime [Paragraph]
  
  type ModTime = String
  
  type Title = [TextItem]
  
  data Paragraph = 
     Text [TextItem]         -- text line starting with --
   | List [[TextItem]]       -- 
   | Code String             -- other text line
   | Item [TextItem]         -- bulleted item: line prefixed by --*
   | New                     -- new paragraph: line consisting of --
   | NewPage                 -- new parage: line consisting of --!
   | Heading Int [TextItem]  -- text line starting with --n where n = 1,2,3,4
  
  data TextItem =
     Str String
   | Emp String  -- emphasized,     *...*
   | Lit String  -- string literal, "..."
   | Inl String  -- inlined code,   '...'
  
  
  -- parse document
  
  pDoc :: ModTime -> String -> Doc
  pDoc time s = case dropWhile emptyOrPragma (lines s) of
    ('-':'-':'1':title) : paras -> Doc (pItems title) time (map pPara (grp paras))
    paras -> Doc [] time (map pPara (grp paras))
   where
     grp ss = case ss of
       s : rest | ignore s      -> grp rest
                | isEnd s       -> []
                | begComment s  -> let (s1,s2) = getComment (drop 2 s : rest) 
                                   in map ("-- " ++) s1 ++ grp s2 
                | isComment s   -> s : grp rest
                | all isSpace s -> grp rest
       [] -> []
       _ -> unlines code : grp rest where (code,rest) = span (not . isComment) ss 
     pPara s = case s of
       '-':'-':d:text | isDigit d -> Heading (read [d]) (pItems text)
       '-':'-':'!':[]             -> NewPage
       '-':'-':[]                 -> New
       '-':'-':'*':text           -> Item (pItems (dropWhile isSpace text))
       '-':'-':text               -> Text (pItems (dropWhile isSpace text))
       _                          -> Code s
     pItems s = case s of
       '*'  : cs -> get 1 Emp (=='*')  cs
       '"'  : cs -> get 1 Lit (=='"')  cs
       '$'  : cs -> get 1 Inl (=='$') cs
       []        -> []
       _         -> get 0 Str (flip elem "*\"$") s
  
     get _ _   _     [] = []
     get k con isEnd cs = con beg : pItems (drop k rest) 
                      where (beg,rest) =  span (not . isEnd) cs
   
     isEnd s = case s of
       '-':'-':'.':_ -> True
       _ -> False
  
     emptyOrPragma s = all isSpace s || "--#" `isPrefixOf` s
  
  ignore s = case reverse s of
       '%':'-':'-':_ -> True
       _ -> False
  
  -- render in html
  
  doc2html :: Doc -> String
  doc2html (Doc title time paras) = unlines $
    tagXML "html" $
      tagXML "body" $
        unwords (tagXML "i" ["Produced by " ++ welcome]) :
        mkTagXML "p" :
        concat (tagXML "h1" [concat (map item2html title)]) :
        empty :
        map para2html paras
  
  para2html :: Paragraph -> String
  para2html p = case p of
    Text its      -> concat (map item2html its)
    Item its      -> mkTagXML "li" ++ concat (map item2html its)
    Code s        -> unlines $ tagXML "pre" $ map (indent 2) $ filter (not . ignore) $ 
                                                remEmptyLines $ lines $ spec s
    New           -> mkTagXML "p"
    NewPage       -> mkTagXML "p" ++ "\n" ++ mkTagXML "!-- NEW --"
    Heading i its -> concat $ tagXML ('h':show i) [concat (map item2html its)]
  
  item2html :: TextItem -> String
  item2html i = case i of
    Str s -> spec s
    Emp s -> concat $ tagXML "b" [spec s]
    Lit s -> concat $ tagXML "i" [spec s]
    Inl s -> concat $ tagXML "tt" [spec s]
  
  mkTagXML t = '<':t ++ ">"
  mkEndTagXML t = mkTagXML ('/':t)
  tagXML t ss = mkTagXML t : ss ++ [mkEndTagXML t]
  
  spec = elimLt
  
  elimLt s = case s of
    '<':cs -> "&lt;" ++ elimLt cs
    c  :cs -> c : elimLt cs
    _      -> s
  
  
  -- render in latex
  
  doc2latex :: Doc -> String
  doc2latex (Doc title time paras) = unlines $
    preludeLatex :
    funLatex "title"  [concat (map item2latex title)] :
    funLatex "author" [fontLatex "footnotesize" (welcome)] :
    envLatex "document" (
      funLatex "maketitle" [] :
      map para2latex paras)   
  
  para2latex :: Paragraph -> String
  para2latex p = case p of
    Text its      -> concat (map item2latex its)
    Item its      -> "\n\n$\\bullet$" ++ concat (map item2latex its) ++ "\n\n"
    Code s        -> unlines $ envLatex "verbatim" $ map (indent 2) $ 
                                                     remEmptyLines $ lines $ s
    New           -> "\n"
    NewPage       -> "\\newpage"
    Heading i its -> headingLatex i (concat (map item2latex its))
  
  item2latex :: TextItem -> String
  item2latex i = case i of
    Str s -> specl s
    Emp s -> fontLatex "bf" (specl s)
    Lit s -> fontLatex "it" (specl s)
    Inl s -> fontLatex "tt" (specl s)
  
  funLatex :: String -> [String] -> String
  funLatex f xs = "\\" ++ f ++ concat ["{" ++ x ++ "}" | x <- xs]
  
  envLatex :: String -> [String] -> [String]
  envLatex e ss = 
    funLatex "begin" [e] :
    ss ++
    [funLatex "end" [e]]
  
  headingLatex :: Int -> String -> String
  -- for slides
  -- headingLatex _ s = funLatex "newone" [] ++ "\n" ++ funLatex "heading" [s] 
  headingLatex i s = funLatex t [s] where 
    t = case i of
      2 -> "section"
      3 -> "subsection"
      _ -> "subsubsection"
  
  fontLatex :: String -> String -> String
  fontLatex f s = "{\\" ++ f ++ " " ++ s ++ "}"
  
  specl = eliml
  
  eliml s = case s of
    '|':cs -> mmath "mid" ++ elimLt cs
    '{':cs -> mmath "\\{" ++ elimLt cs
    '}':cs -> mmath "\\}" ++ elimLt cs
    _      -> s
  
  mmath s = funLatex "mbox" ["$" ++ s ++ "$"]
  
  preludeLatex = unlines $ [
    "\\documentclass[12pt]{article}",
    "\\usepackage{isolatin1}",
    "\\setlength{\\oddsidemargin}{0mm}",
    "\\setlength{\\evensidemargin}{-2mm}",
    "\\setlength{\\topmargin}{-16mm}",
    "\\setlength{\\textheight}{240mm}",
    "\\setlength{\\textwidth}{158mm}",
    "\\setlength{\\parskip}{2mm}",
    "\\setlength{\\parindent}{0mm}"
   ]
  
  -- render in txt2tags
  -- as main document (welcome, top-level subtitles)
  -- as chapter (no welcome, subtitle level + i)
  
  doc2txt :: Doc -> String
  doc2txt (Doc title time paras) = unlines $
    let tit = concat (map item2txt title) in
        tit:
        ("Last update: " ++ time):
        "":
        "% NOTE: this is a txt2tags file.":
        "% Create an html file from this file using:":
        ("% txt2tags " ++ tit):
        "\n":
        concat (["Produced by " ++ welcome]) :
        "\n" :
        empty :
        map (para2txt 0) paras
  
  doc2txt2 :: Doc -> String
  doc2txt2 (Doc title time paras) = unlines $
    let tit = concat (map item2txt title) in
        tit:
        "":
        concat (tagTxt (replicate 2 '=') [tit]):
        "\n":
        empty :
        map (para2txt 2) paras
  
  para2txt :: Int -> Paragraph -> String
  para2txt j p = case p of
    Text its      -> concat (map item2txt its)
    Item its      -> "- " ++ concat (map item2txt its)
    Code s        -> unlines $ tagTxt "```" $ map (indent 2) $ 
                                                remEmptyLines $ lines s
    New           -> "\n"
    NewPage       -> "\n" ++ "!-- NEW --"
    Heading i its -> 
      concat $ tagTxt (replicate (i + j) '=') [concat (map item2txt its)]
  
  item2txt :: TextItem -> String
  item2txt i = case i of
    Str s -> s
    Emp s -> concat $ tagTxt "**" [spec s]
    Lit s -> concat $ tagTxt "//" [spec s]
    Inl s -> concat $ tagTxt "``" [spec s]
  
  tagTxt t ss = t : ss ++ [t]
  
  
  
  -- auxiliaries
  
  empty = ""
  
  isComment = (== "--") . take 2
  
  begComment =  (== "{-") . take 2
  
  getComment ss = case ss of
    "-}":ls -> ([],ls)
    l:ls -> (l : s1, s2) where (s1,s2) = getComment ls
    _    -> ([],[])
  
  indent n = (replicate n ' ' ++)
  
  remEmptyLines = rem False where
    rem prevGood ls = case span empty ls of
      (_ :_, ss@(_ : _)) -> (if prevGood then ("":) else id) $ rem False ss
      (_,    [])         -> []
      (_,    s:ss)       -> s : rem True ss 
    empty = all isSpace
  