module Creole where
import Control.Monad.State
import Text.ParserCombinators.Parsec

data HTML = HTML [Node]
data Node = Element String [Attr] [Node] | Text String
data Attr = Attr String String

foldShow :: (Show a) => [a] -> String
foldShow = concatMap show

instance Show HTML where
    show (HTML []) = ""
    show (HTML (x:xs)) = foldShow (x:xs)
    
instance Show Node where
    show (Text t) = concatMap escapeChar t
    show (Element tag attrs []) = "<" ++ tag ++ (foldShow attrs) ++ "/>"
    show (Element tag attrs nodes) = "<" ++ tag ++ (foldShow attrs) ++ ">" ++ (foldShow nodes) ++ "</" ++ tag ++ ">"

instance Show Attr where
    show (Attr n v) = " " ++ n ++ "=" ++ "\"" ++ v ++ "\""

escapeChar :: Char -> String
escapeChar '&' = "&amp;"
escapeChar '<' = "&lt;"
escapeChar '>' = "&gt;"
escapeChar '"' = "&quot;"
escapeChar '\'' = "&#39;"
escapeChar c = [c]

parseHtml :: String -> HTML
parseHtml s = HTML $ parseBlock $ eofToLineFeed s

eofToLineFeed :: String -> String
eofToLineFeed s = reverse $ convert $ reverse s where
                    convert s | s !! 0 == '\n' && s !! 1 == '\n' = s
                               | s !! 0 == '\n' && s !! 1 /= '\n' = "\n" ++ s
                               | s !! 0 /= '\n' = "\n\n" ++ s


parseBlock :: String -> [Node]
parseBlock str = case parse block "" str of
                        Right nodes -> nodes
                        Left err -> [Text ("" ++ (show err))]

block :: Parser [Node]
block = many component
    where 
        component = do h <- try(heading)
                       return $ Element (fst h) [] [Text (snd h)]
                <|> do li <- try(uList)
                       return $ Element ("ul") [] (map (\l -> (Element "li" [] (parseInline l))) li)
                <|> do p <- paragraph
                       return $ Element "p" [] (parseInline p)
                <|> do e <- eof
                       return $ Text ""

heading :: Parser (String, String)
heading = do lv <- many1 $ char '='
             ws <- many1 $ char ' '
             h  <- manyTill anyChar $ try $ oneOf "=\n"
             ws2 <- option ' ' $ char ' '
             rest <- many $ char '='
             return ((headingLv (length lv)), (stripTail h)) where
                headingLv n | n <= 6 = "h" ++ (show n)
                            | otherwise = "h6"
                stripTail s = reverse $ dropWhile (== ' ') $ dropWhile (== '=') $ reverse s

uList :: Parser [String]
uList = do i <- many1 $ char '*'
           ws <- many1 $ char ' '
           s  <- manyTill anyChar $ try $ string "\n\n"
           lf <- option "" $ many $ char '\n'
           return $ parseList (s ++ "\n") '*'

parseList :: String -> Char -> [String]
parseList str symbol = case parse (listItem symbol) "" str of
                          Right items -> items
                          Left err -> ["error!"]

listItem :: Char -> Parser [String]
listItem symbol = many1 item
    where
        item = do i <- many1 $ char symbol
                  ws <- many1 $ char ' '
                  s  <- manyTill anyChar $ try $ string $ "\n" ++ [symbol]
                  lf <- char '\n'
                  return s

paragraph :: Parser String
paragraph = do p <- manyTill anyChar $ try $ string "\n\n"
               lf <- option "" $ many $ char '\n'
               return p

parseInline :: String -> [Node]
parseInline str = case parse inline "" str of
                       Right nodes -> nodes
                       Left err -> [Text "error!"]

inline :: Parser [Node]
inline = many component
    where
        component = do link <- try(hyperLink)
                       return (Element "a" [Attr "href" (fst link)] [Text (snd link)])
                <|> do url <- try(urlStr)
                       return (Element "a" [Attr "href" url] [Text url])
                <|> do t <- try(bold)
                       return (Element "strong" [] [Text t])
                <|> do t <- try(italic)
                       return (Element "em" [] [Text t])
                <|> do t <- try(linebreak)
                       return (Element "br" [] [])
                <|> do c <- anyChar
                       return (Text [c])

urlStr :: Parser String
urlStr = do a <- string "http"
            b <- option "" $ string "s"
            c <- string "://"
            d <- many1 urlChar
            return $ concat [a, b, c, d]
urlChar :: Parser Char
urlChar = alphaNum <|> oneOf "!@#$%^&*()-_=+~:;',./?"

hyperLink :: Parser (String, String)
hyperLink = do a <- string "[["
               b <- urlStr
               c <- string "|"
               d <- many1 $ satisfy $ \c -> c /= ']'
               e <- string "]]"
               return (b, d)

bold :: Parser String
bold = do a <- string "**"
          b <- manyTill anyChar (try (string "**"))
          return b

italic :: Parser String
italic = do a <- string "//"
            b <- manyTill anyChar (try (string "//"))
            return b

linebreak :: Parser String
linebreak = do a <- string "\\\\"
               return ""