{-# LANGUAGE RecursiveDo #-}

import Text.Format.Cleartext
import Text.Parsers.Frisby
import Text.Parsers.Frisby.Char
import XmlOut
import System (getArgs, getProgName)
import System.Exit
import Data.List
import Text.Regex
import System.Directory
import System.Cmd (rawSystem)
import System.Process (readProcess)
import Control.OldException
import System.IO.Error
import System.IO (openTempFile, hClose)
import System.Posix.Process (getProcessID)
import System.Environment (getEnv)
import Data.Char (toLower, ord)
import qualified UTF8
import Control.Monad (liftM, msum, when)
import Network.CGI

-- TODO:
-- * give (inline) images their own style (center on baseline)
-- * proper table output (with styles according to colspecs)
-- * bibliography (support in Doc type, parser, and output)
-- * index terms (support in Doc type, parser, and output)
-- * get style config from somewhere

-- just a nice utility
s =~ r = maybe False (const True) (matchRegex r s)

main = do
    -- determine program mode (command line or cgi)
    gwenv <- handle (\_ -> return "") (getEnv "GATEWAY_INTERFACE")
    if "CGI/" `isPrefixOf` gwenv
        then runCGI (handleErrors main_cgi)
        else main_cmd

-- command line mode
main_cmd = do
    -- parse command line
    prog <- getProgName
    args <- getArgs
    (tfilename, ifilename) <- case args of
        [t,i] -> return (t,i)
        _     -> do putStrLn ("usage: "++prog++" template.odt input.txt")
                    exitWith (ExitFailure 1)
                    return undefined
    let ofilename = subRegex (mkRegex "(\\.(txt|ctxt?))$") ifilename "" ++ ".odt"

    input <- readFile ifilename
    putStrLn ("writing " ++ ofilename)
    copyFile tfilename ofilename
    instantiate_odt ofilename input

-- CGI script mode
main_cgi = do
    args <- getInputNames
    if all (`elem` args) ["input", "template"]
        then cgi_converter
        else cgi_form

    where
    cgi_converter :: CGIT IO CGIResult
    cgi_converter = do
        -- parameters
        Just input    <- getInput "input"
        Just template <- getInput "template"
        ifilename     <- liftM (maybe "document" id) (getInputFilename "input")

        -- prepare file paths
        when ('/' `elem` template) $ do
            fail "path delimiter in template name, you naughty boy"
        let ottfile = "templates/" ++ template ++ ".ott"
        (odtfile,h) <- liftIO $ openTempFile "/tmp" "ctxodfcgi.odt"
        liftIO $ hClose h

        -- copy template and instantiate
        liftIO $ copyFile ottfile odtfile
        liftIO $ instantiate_odt odtfile input

        -- generate output
        let ofilename = subRegex (mkRegex "(\\.(txt|ctxt?))$") ifilename "" ++ ".odt"
        setHeader "Content-Type" "application/vnd.oasis.opendocument.text"
        setHeader "Content-Disposition"
                  ("attachment; filename=\"" ++ urlEncode ofilename ++ "\"")
        result <- liftIO (readFile odtfile) >>= output

        -- cleanup
        liftIO (removeFile odtfile)
        return result

    cgi_form :: CGIT IO CGIResult
    cgi_form = do
        dir <- liftIO $ getDirectoryContents "templates"
        let re = mkRegex ("\\.ott$")
            templates = [ subRegex re f "" | f <- dir, f =~ re ]

        proguri <- progURI
        self <- scriptName
        output $ xmlout $
            [tag "html"
              [tag "head"
                [tag "style" ("type":="text/css")
                  [cdata "body {text-align:center;}\n\
                         \q {font-style:italic;font-size:small}\n\
                         \#logo {margin-top:2cm;margin-bottom:1cm;}\n\
                         \#input_sel {margin-bottom:0.2cm;}\n\
                         \#template_sel {margin-bottom:0.2cm;}\n\
                         \#generate_btn {margin-top:0.5cm;margin-bottom:0.5cm;}\n\
                         \#khjk {margin-top:1cm;font-size:small;font-family:monospace;}\n\
                         \#khjk a {text-decoration:none;color:grey;}\n"
                  ]
                ,tag "link" ("rel":="stylesheet") ("href":="ctxodf.css")
                 :: Element]
              ,tag "body"
                [tag "div" ("id":="logo")
                  [tag "img" ("src":="logo.png") ("alt":="[logo]") :: Element
                  ,tag "br", tag "q" [cdata "Look Mom, no OOo!"] :: Element]
                ,tag "form" ("action":=self) ("method":="post")
                            ("enctype":="multipart/form-data")
                  [tag "div" ("id":="input_sel")
                    [cdata "Input: "
                    ,tag "input" ("type":="file") ("name":="input")
                    ]
                  ,tag "div" ("id":="template_sel")
                    [cdata "Template: "
                    ,tag "select" ("name":="template") (map option templates)
                    ]
                  ,tag "div" ("id":="generate_btn")
                    [tag "input" ("type":="submit") ("value":="Generate!") :: Element
                    ] :: Element
                  ,tag "div" ("id":="khjk")
                    [tag "a" ("href":="http://www.khjk.org")
                      [cdata "khjk.org", tag "br", cdata "-/\\-"] :: Element
                    ] :: Element
                  ] :: Element
                ] :: Element
              ] :: Element
            ]
        where
        option x = tag "option" [cdata x] :: Element


-- instantiate the given (Cleartext) input into a target odt file (in place)
instantiate_odt :: String -> String -> IO ()
instantiate_odt odtfile input = do
    let doc = parsedoc (UTF8.decode (map (fromIntegral.ord) input))

    -- prepare temporary workdir
    tempdir <- mktempdir ("/tmp/ctxodf")
    curdir  <- getCurrentDirectory
    setCurrentDirectory tempdir
    let abspath p = case p of '/':_ -> p; _ -> curdir++'/':p
        abs_odtfile = abspath odtfile

    -- instantiate content.xml
    template <- readProcess "unzip" ["-p", abs_odtfile, "content.xml"] ""
    writeFile "content.xml" $ substitute doc template

    -- update zipfile with contents of tempdir
    rawSystem "zip" ["-qr", abs_odtfile, "."]

    -- clean up
    setCurrentDirectory curdir
    rawSystem "rm" ["-rf", tempdir]
    -- CAUTION: not using removeDirectoryRecursive because it follows symlinks!

    return ()

mktempdir prefix = do
    pid <- getProcessID
    let iter n = do
            let handler e
                    | isAlreadyExistsError e = iter (n+1)
                    | otherwise = ioError e
            handleJust ioErrors handler $ do
                let dir = prefix ++ "." ++ show pid ++ "-" ++ show n
                createDirectory dir
                return dir
    iter 1


substitute doc = bodysubst body . metasubst ctx (metadata doc)
    where
    (body, ctx) = doctoodf doc

metasubst ctx metas = mapRegex metaregex f
    where
    f _ [key] = maybe "" out (lookup key metas)
    out s = xmlout (txttoodf ctx anchors (parsetxt s))
    anchors = []            -- TODO: is this correct in metasubst?
metaregex = mkRegex "\\{\\{META:([a-zA-Z0-9_-]+)\\}\\}"

mapRegex regex f s = case matchRegexAll regex s of
    Nothing -> s
    Just (a,x,b,xs) -> a ++ f x xs ++ mapRegex regex f b

bodysubst body = xmltransform f
    where
    f ("text:p":_) attrs content
        | marker `isSubstringOf` content = Just (xmlout body')
        | otherwise = Nothing
        where
        body' = maybe id splice (lookup "text:style-name" attrs) body
    f _ _ _ = Nothing
    marker = "{{DOCUMENT-BODY}}"

    -- find the first text:p or text:h tag and add the style from the
    -- template in a class-names attribute
    splice style xs = maybe xs id (msplice xs)
        where
        msplice [] = Nothing
        msplice (Etag (Tag t a c) : xs) =
            msum [ if (t `elem` ["text:p", "text:h"])
                     then liftM (\a' -> Etag (Tag t a' c) : xs) (masplice a)
                     else Nothing
                 , liftM (\c' -> Etag (Tag t a c') : xs) (msplice c)
                 , liftM (\xs' -> Etag (Tag t a c) : xs') (msplice xs) ]

        msplice (x:xs) = liftM (x:) (msplice xs)
        masplice [] = Just ["text:class-names" := style]
        masplice (("text:class-names" := v) : as)
            | style `elem` words v = Nothing
            | otherwise = Just (("text:class-names" := (v++' ':style)) : as)
        masplice (a:as) = liftM (a:) (masplice as)

isSubstringOf a b = any (a `isPrefixOf`) (tails b)


---- quick and cheap XML transformation

type Path    = [String]            -- tag names, innermost at head
type Attrs   = [(String, String)]  -- (key,value)

xmltransform :: (Path -> Attrs -> String -> Maybe String) -> String -> String
xmltransform f input = runPeg p_xmltransform input f

p_xmltransform :: PM s (P s ((Path->Attrs->String->Maybe String) -> String))
p_xmltransform = mdo
    ws          <- newRule $ many space
    tagname     <- newRule $ many (alphaNum // oneOf ":_-")
    attrname    <- newRule $ many (alphaNum // oneOf ":_-")
    let quotchar q = doesNotMatch q ->> ((char '\\' ->> q) // anyChar)
        quoted q   = q ->> many (quotchar q) <<- q
    squotval    <- newRule $ quoted (char '\'')
    dquotval    <- newRule $ quoted (char '"')
    attrval     <- newRule $ squotval // dquotval
    tagattr     <- newRule $ ws ->> attrname <> (char '=' ->> attrval)
    tagstuff    <- newRule $ tagname <> many tagattr
    tagopen     <- newRule $ wC (char '<' ->> tagstuff <<- ws <<- char '>')
    tagclose    <- newRule $ wC (text "</" ->> tagname <<- ws <<- char '>')
    empty'      <- newRule $ wC (char '<' ->> tagstuff <<- ws <<- text "/>")
    empty       <- newRule $ empty' ## mkemp
    nonempty    <- newRule $ onlyIf (tagopen <> xml <> tagclose) match ## mktag
    tag         <- newRule $ empty // nonempty
    nontagchar  <- newRule $ dnm tag ->> dnm tagclose ->> anyChar
    whatever    <- newRule $ many1 nontagchar ## mkstr
    xml         <- newRule $ many (tag // whatever) ## mkxml
    return (xml ## ($ []))
    where
    mkxml xs = \p f -> concatMap (\x -> x p f) xs
    mkstr s = \p f -> s
    match ((((name,_),_), _), (name',_)) = name==name'
    mktag ((((name,atts),o), content), (name',c)) p f
        = maybe (o++content'++c) id (f p' atts content')
        where
        p' = name:p
        content' = content p' f
    mkemp ((name,atts),o) = \p f -> maybe o id (f (name:p) atts "")

wC = withConsumption
dnm = doesNotMatch

withConsumption :: P s a -> P s (a, String)
withConsumption p = peek rest <> getPos <> p <> getPos ## f
    where f (((r,i),x),j) = (x, take (j-i) r)

---- ODF output

-- style parameters
stdstyle        = "Standard"
emphstyle       = "Emphasis"
boldstyle       = "Strong_20_Emphasis"
headstyle level = "Heading_20_" ++ show level
outlinestyle    = "Outline"
codestyle       = "Source_20_Text"
codeblockstyle  = "Preformatted_20_Text"
quotstyle       = "Quotations"
numbstyle       = "Numbering_20_1"
graphicsstyle   = "Graphics"
framestyle _    = "Frame"   -- parameterized by flowmode
captionstyle    = "Caption"
footnotestyle   = "Footnote"
cellstyle       = "Table_20_Contents"

txttoodf :: TxtContext XML XML -> Anchors -> Txt -> [Element]
doctoodf :: Doc -> ([Element], TxtContext XML XML)

txttoodf ctx as = concatMap (ltoktoodf ctx as)

-- Because we need to know what kind of anchor a cross reference points to in
-- order to generate the right tag.
-- Also allows us to output correct numbering for figure and table anchors.
data AnchorDetail = SequenceAnchor String{-seq. name-} Int
                  | BookmarkAnchor
type Anchors = [(String, AnchorDetail)]

ltoktoodf :: TxtContext XML XML -> Anchors -> LTok -> [Element]
ltoktoodf ctx anchors tok = case tok of
    St s    -> [cdata s]
    Hy [] u -> ltoktoodf ctx anchors (Hy [St u] u)
    Hy t u  -> [tag "text:a" ("xlink:type" := "simple") ("xlink:href" := u)
                 [tag "text:span" ("text:style-name" := "Internet_20_link")
                   (tto t) :: Element]]
    Im u    -> [tag "draw:frame" ("draw:style-name" := graphicsstyle)
                                 ("text:anchor-type" := "as-char")
                 [tag "draw:image" ("xlink:href" := imref u) :: Element]]
    Nl      -> [tag "text:line-break"]
    Co s    -> [tag "text:span" ("text:style-name" := codestyle) s]
    Qu t    -> tto ([St "\x201e"] ++ t ++ [St "\x201c"])
    Em t    -> [tag "text:span" ("text:style-name" := emphstyle) (tto t)]
    Bd t    -> [tag "text:span" ("text:style-name" := boldstyle) (tto t)]
    An s    -> anchortag s
    Xr s    -> crossreftag s
    Fn s    -> [tag "text:note" ("text:id" := ("ftn_" ++ s))
                                ("text:note-class" := "footnote")
                 [tag "text:note-citation" [cdata s]
                 ,tag "text:note-body"
                   [nestpara footnotestyle
                     (maybe [] id (lookup s (txtfootnotes ctx)))] :: Element
                 ]
               ]
    --Ma e    -> [tag "math" ("xmlns" := mathml) (exptomathml e)]
    -- fallback
    x       -> [tag "text:span" ("text:style-name" := codestyle)
                    ("{{"++show x++"}}")]
    where
    tto = txttoodf ctx anchors
    mathml = "http://www.w3.org/1998/Math/MathML"
    imref u
        | looksabsolute u = u
        | otherwise = "../" ++ u
    looksabsolute ('/':_) = True
    looksabsolute u = u =~ mkRegex "^[a-zA-Z0-9_-]+://"

    anchortag s = case lookup s anchors of
        Nothing -> bmtag ("[??uncaught anchor "++show s++"??]")
        Just BookmarkAnchor -> bmtag ""
        Just (SequenceAnchor c n) ->
            [tag "text:sequence" ("text:ref-name" := s)
                                 ("text:name" := c)
                                 ("text:formula" := ("ooow:"++c++"+1"))
                                 ("style:num-format" := "1")
              [cdata (show n)]]
        where
        bmtag t =
            [tag "text:bookmark" ("text:name" := s)
            ,cdata t
            ,tag "text:bookmark-end" ("text:name" := s)]

    crossreftag s = case lookup s anchors of
        Nothing -> bmref ("[missing anchor "++show s++"]")
        Just BookmarkAnchor -> bmref "??" -- TODO: numbers for bookmark refs
        Just (SequenceAnchor c n) ->
            [tag "text:sequence-ref" ("text:reference-format" := "value")
                                      ("text:ref-name" := s)
              [cdata (show n)]]
        where
        bmref t =
            [tag "text:bookmark-ref" ("text:ref-name" := s)
                                     ("text:reference-format" := "chapter")
              [cdata t]]

-- A utility for nesting paragraph-structured content into an outer text:p tag
-- with a different style
nestpara :: String -> XML -> Element
nestpara style = tag "text:p" ("text:style-name" := style) . strip
    where
    -- ODF cannot nest block elements, so we rip away the p tags
    -- and put double line breaks between paragraphs as a best effort
    strip = concat . intersperse break . map strip1
    strip1 (Etag (Tag "text:p" atts content)) = content
    strip1 x = [x]
    break = replicate 2 (tag "text:line-break")

doctoodf doc = folddoctree_wc fl ft fc fq fb fn ftb ff fr fp fs fd doc
  where
  anchors = anchordetails doc
  fl ctx = txttoodf ctx anchors   -- text segment
  ft text =
    tag "text:p" ("text:style-name" := stdstyle) text :: Element
  fc code =
    tag "text:p" ("text:style-name" := codeblockstyle) code' :: Element
    where
    code' = intersperse (tag "text:line-break") (map Estr (lines code))
  fq = nestpara quotstyle
  fb bullets =
    tag "text:list" (map item bullets) :: Element
    where
    item bulletdoc = tag "text:list-item" bulletdoc :: Element
  fn items =
    tag "text:list" ("text:style-name" := numbstyle) (map item items) :: Element
    where
    item itemdoc = tag "text:list-item" itemdoc :: Element
  ftb (Table colspecs rows) =
    -- TODO: go through the hell of properly reproducing all table features
    -- this is *extremely* simplistic
    tag "table:table" (coltag : concatMap row rows) :: Element
    where
    cols = take ncols (colspecs ++ repeat Colleft)
    ncols = maximum (map rowlength rows)
    coltag = tag "table:table-column"
                 ("table:number-columns-repeated" := show ncols)
                 ([] :: [Element])
    rowlength r = case r of Row xs -> length xs; _ -> 0
    row Hrule = []
    row (Row xs) = [tag "table:table-row" (map cell xs) :: Element]
    cell (Cell txt) = tag "table:table-cell"
                        [tag "text:p" ("text:style-name" := cellstyle)
                          txt :: Element] :: Element
    cell _ = tag "table:table-cell" ([] :: [Element])
  ff mode float caption =
    -- Note: Flow modes only work if the template defines appropriate styles
    --       AND these are configured above in 'framestyle'.
    tag "text:p"
      [tag "draw:frame" ("draw:style-name" := framestyle mode)
                        ("fo:min-width" := "2cm")
                        ("text:anchor-type" := "paragraph")
        [tag "draw:text-box" ("fo:min-height" := "2cm")
          (float ++ [caption']) :: Element] :: Element
      ] :: Element
    where
    caption' :: Element
    caption' = tag "text:p" ("text:style-name" := captionstyle) caption
  fr = undefined    -- bibliography
  fp title content =
    title' ++ content :: XML
    where
    title'
      | null title = []
      | otherwise  = [tag "text:span" ("text:style-name" := boldstyle) title]
  fs level title subtitle content =
    (tag "text:list" ("xml:id" := "__outline_list")
                     ("text:continue-list" := "__outline_list")
                     ("text:style-name" := outlinestyle)
      [tag "text:list-item" $
        listcruft (level-1) $  -- generate a shell of nested lists
        [tag "text:h" ("text:style-name" := headstyle level)
                      ("text:outline-level" := show level)
             title :: Element] :: Element]
    -- TODO: output subtitles in ODF
    : content) :: XML
  fd metas paras sects = concat paras ++ concat sects :: XML

  listcruft :: Int -> XML -> XML
  listcruft 0 c = c
  listcruft n c = [tag "text:list" [tag "text:list-item" (listcruft (n-1) c)
                   :: Element] :: Element]


exptomathml :: Exp -> [Element]
exptomathml = error "TODO: exptomathml"


anchordetails :: Doc -> Anchors
anchordetails = numberanchors . concatMap btok
    where
    btok (TEXT txt) = [(x, BookmarkAnchor) | An x <- txt]
    btok (PARA txt) = [(x, BookmarkAnchor) | An x <- txt]
    btok (SECT _ txt) = [(x, BookmarkAnchor) | An x <- txt]
    -- TODO: recognize table anchors (as soon as we have tables ;))
    btok (FLOA _ d cap) = anchordetails d ++
                          [(x, SequenceAnchor seqname e) | An x <- cap]
        where
        e = error "EEP! unnumbered sequence anchor"
        seqname = case d of [TABL _] -> "Table"; _ -> "Illustration"
    btok (BULL xs) = concatMap (concatMap btok) xs
    btok (NUMB xs) = concatMap (concatMap btok) xs
    btok (QUOT d)  = concatMap btok d
    btok _ = []

    numberanchors :: Anchors -> Anchors
    numberanchors = concatMap number . groupBy eq . sortBy cmp
        where
        cmp (_,BookmarkAnchor) (_,BookmarkAnchor) = EQ
        cmp (_,SequenceAnchor x _) (_,SequenceAnchor y _) = compare x y
        cmp (_,BookmarkAnchor) _ = LT
        cmp _ _ = GT
        eq x y = cmp x y == EQ
        number = zipWith applynum [1..]
        applynum n (x, SequenceAnchor c _) = (x, SequenceAnchor c n)
        applynum _ a = a