---------------------------------------------------------------------- -- | -- 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.Cmd import System.Directory import System.Environment import System.Locale import System.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 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) +", "", "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 -> "<" ++ 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