{-# LANGUAGE DoAndIfThenElse #-}
module Main where
import Control.Applicative ((<$>), (<*>), (<*), (<$))
import Control.Monad (liftM)
import Control.Monad.State (State, runState)
import Control.Applicative ((<*))
import Text.Parsec hiding (State)
import Text.Parsec.Indent
import Text.Parsec.Pos
import Data.List (isPrefixOf, isInfixOf, intercalate, intersperse)
import qualified Data.Map as M
import Text.Regex.Posix
import System.Environment

type IParser a = ParsecT String () (State SourcePos) a

iParse :: IParser a -> SourceName -> String -> Either ParseError a
iParse p s inp = runIndent s $ runParserT p () s inp

data Tree = Tree Expression [Tree]
    deriving (Show)

type Attrs = [(String, String)]
data InlineContent = RubyInlineContent String 
    | PlainInlineContent String
    | NullInlineContent
    | HamlFilterContent String
    deriving (Show, Eq)


type IsFormTag = Bool

data Expression = 
      DocType String
    | Comment String 
    | PlainText String
    | RubyStartBlock String IsFormTag
    | RubyMidBlock String
    | RubySideEffect String
    | RubyExp String
    | Tag String Attrs InlineContent
    | GenericExpression String 
    deriving (Show)

container :: IParser Tree
container = do
  b <- withBlock Tree expression container
  spaces
  return b

expression :: IParser Expression
expression = docType <|> comment <|> hamlFilter <|> startPlainText <|> rubyBlock <|> rubyExp <|> tag <|>  genericExpression
  
rubyBlock = do
    char '-'
    spaces
    k <- rubyKeyword
    rest <- manyTill anyChar newline <* spaces
    if (k `elem` midBlockKeywords)
    then return (RubyMidBlock $ k ++ rest)
    -- TODO : we need to recognize Ruby expression expression included purely for a side effect,
    -- e.g. "- localvar = Time.now"
    else return (RubyStartBlock (k ++ rest) False)
  where midBlockKeywords = ["else", "elsif", "rescue", "ensure", "when", "end"]

rubyExp = do
  line <- ((:) <$> char '=' >> spaces >> manyTill anyChar newline <* spaces)
  return (RubyExp line)

tag :: IParser Expression
tag = do
    tag <- explicitTag <|> return "div"
    as <- many (dotClass <|> idHash)
    hs <- option [] (hashAttrs)
    many $ oneOf " \t"
    c <- parseInlineContent 
    spaces
    return $ Tag tag (attrs as hs) c
  where 
    attrs as hs = filter (\(k, v) -> v /= "") $ 
      M.toList $ 
      M.unionWith (\a b -> intercalate " " (filter (/= "") [a,b]))
        (M.fromList hs)
        (M.fromList (makeClassIdAttrs as)) 
    parseInlineContent = (RubyInlineContent <$> (char '=' >> spaces >> manyTill anyChar newline)) <|> 
        (PlainInlineContent <$> (manyTill anyChar newline)) 
        <|> return NullInlineContent

makeClassIdAttrs :: [String] -> [(String, String)]
makeClassIdAttrs cs = classes : [("id", ids)]
    where classes = ("class", intercalate " " $ map tail $ filter ("." `isPrefixOf`) cs )
          ids = intercalate " " $ map tail $ filter (isPrefixOf "#") cs


explicitTag = do
  char '%'
  tag <- many alphaNum
  return tag

dotClass = (:) <$> char '.' <*> cssClassOrId
idHash = (:) <$> char '#' <*> cssClassOrId

hashAttrs = do
  char '{' 
  xs <- kvPair `sepBy` (spaces >> char ',' >> spaces)
  char '}'
  return xs

cssClassOrId = many (alphaNum <|> oneOf "-_")
rubyIdentifier = many (alphaNum <|> char '_')

rubyKeyword = many alphaNum

singleQuotedStr = do
    between (char '\'') (char '\'') (many stringChar)
  where stringChar = ('\'' <$ string "\\'") <|> (noneOf "'")

doubleQuotedStr = do
    between (char '"') (char '"') (many stringChar)
  where stringChar = ('"' <$ string "\\\"") <|> (noneOf "\"")

--- Ruby interpolation delimiters crudley replaced by ERB style
rubyString = do
    between (char '"') (char '"') rString
  where 
    rString = liftM replaceInterpolationDelim $ many stringChar
    stringChar = ('"' <$ string "\\\"") <|> (noneOf "\"") 
    replaceInterpolationDelim = (replace "#{" "<%= ") . (replace "}" " %>")

rubySymbol =  char ':' >> rubyIdentifier
rubySymbolKey = rubyIdentifier <* char ':'

-- really, we need to parse full-blown Ruby expressions
rubyValue = do
    xs <- many (noneOf "},([ \t")  <* spaces
    rest <- ((lookAhead (oneOf ",}") >> return ""))
            <|> (betweenStuff '(' ')' )
            <|> (betweenStuff '[' ']' )
    return $ "<%= " ++ xs ++ rest ++ " %>"
  where 
    betweenStuff x y = do
      xs' <- between (char x) (char y) (many $ noneOf [y])
      return $ [x] ++ xs' ++ [y]

rocket = spaces >> string "=>" >> spaces 
aKey = (singleQuotedStr <* rocket)
  <|> (doubleQuotedStr <* rocket)
  <|> (rubySymbol <* rocket)
  <|> (rubySymbolKey <* spaces)

aValue = singleQuotedStr <|> rubyString <|> many1 digit <|> rubyValue

kvPair :: IParser (String, String)
kvPair = do
  k <- (many $ oneOf " \t") >> aKey 
  v <- spaces >> aValue <* (many $ oneOf " \t")
  return (k, v)

-- TODO HTML Comments are not rendered like HAML renders them
-- also HAML -# style comments could be rendered
comment :: IParser Expression
comment = do
  char '/' 
  s <- manyTill anyChar newline
  spaces
  return $ Comment s

docType :: IParser Expression
docType = do
    string "!!!"
    many $ char ' '
    s <- option [] $ many alphaNum
    newline
    return $ DocType s

filterBlock p = withPos $ do
    r <- many (checkIndent >> p)
    return r

hamlFilter = do
  withPos $ do
    char ':' 
    s <- many $ alphaNum
    many (oneOf " \t")
    newline
    xs <- indentedOrBlank
    return $ Tag (convertToTag s) [] (HamlFilterContent $ concat xs)
  where convertToTag "javascript" = "script"
        convertToTag s = s

indentedOrBlank = many1 (try blankLine <|> try indentedLine)

indentedLine :: IParser String
indentedLine = do
    a <- many $ oneOf " \t"
    indented
    xs <- manyTill anyChar newline 
    return $ a ++ xs ++ "\n"

blankLine = do
    a <- many $ oneOf " \t"
    newline 
    return $ a ++ "\n"

-- TODO; check how this deals with plain text that actually starts with these characters
-- Not sure what HAML's escaping rules are here; again HAML makes things unclear & make you
-- to look at docs

startPlainText = do 
  spaces
  a <- noneOf "-=.#%" 
  b <- manyTill anyChar newline
  spaces
  return $ PlainText (a:b)

genericExpression :: IParser Expression
genericExpression = do
  spaces
  s <- manyTill anyChar newline
  spaces
  return $ GenericExpression s


------------------------------------------------------------------------
-- output ERB
-- turn tree structure into an array of lines, including closing tags and indentation level


type Nesting = Int

-- This is the main processing entrypoint
processChildren :: Nesting -> [Tree] -> [String]
processChildren n xs = concat $ map (erb n) $ (rubyEnd xs)

erb ::  Nesting -> Tree -> [String]

erb n tree@(Tree (Tag t a i) []) 
    | t `elem` selfClosingTags = [pad n ++ selfClosingTag tree]
    -- basically ignores inline content
  where selfClosingTags = ["br", "img", "hr", "meta"]

-- no children; no padding, just tack closing tag on end
erb n tree@(Tree (Tag t a i) []) = [pad n ++ startTag tree ++ endTag 0 tree] 

erb n tree@(Tree (Tag t a i) xs) = (pad n ++ startTag tree) : ((processChildren (n + 1) xs) ++ [endTag n tree])

erb n tree@(Tree (RubyStartBlock s isform) xs) = 
    (pad n ++ (starttag isform) ++ s ++ " %>") : (processChildren (n + 1) xs)
  where 
    starttag True = "<%= "
    starttag False = "<% "


erb n tree@(Tree (RubyMidBlock s) xs) = 
    (pad n ++ "<% " ++ s ++ " %>") : (processChildren (n + 1) xs)

erb n tree@(Tree (RubyExp s) _) = [pad n ++ "<%= " ++ s ++ " %>"] 

erb n tree@(Tree (RubySideEffect s) []) = [pad n ++ "<% " ++ s ++ " %>"] 

erb n tree@(Tree (PlainText s) _) = [pad n ++ s] 
erb n tree@(Tree (Comment s) xs) = (pad n ++ "<!--" ++ s) : ((processChildren (n + 1) xs) ++ [pad n  ++ "-->"])

-- DocTypes
erb n tree@(Tree (DocType s) _) = [d s]
  where
    d "" = "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">"
    d "Strict" = "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
    d "Frameset" = "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">"
    d "1.1" = "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">"
    d "Basic" = "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML Basic 1.1//EN\" \"http://www.w3.org/TR/xhtml-basic/xhtml-basic11.dtd\">"
    d "Mobile" = "<!DOCTYPE html PUBLIC \"-//WAPFORUM//DTD XHTML Mobile 1.2//EN\" \"http://www.openmobilealliance.org/tech/DTD/xhtml-mobile12.dtd\">"
    d "RDFa" = "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML+RDFa 1.0//EN\" \"http://www.w3.org/MarkUp/DTD/xhtml-rdfa-1.dtd\">"
    d "5" = "<!DOCTYPE html>"


    d _ = "TEST"

erb n x@_ = [pad n ++ show x]


-- Ruby expressions with no output and no children; convert to RubySideEffect type
rubyEnd ((Tree (RubyStartBlock s False) []):xs) = rubyEnd $ (Tree (RubySideEffect s) []):xs 

-- Try to insert "<% end %>" tags correctly
rubyEnd (x@(Tree (RubyStartBlock _ _) _):y@(Tree (RubyMidBlock _) _):xs) = 
    x:(rubyEnd (y:xs))  -- just shift the cursor to the right
rubyEnd (x@(Tree (RubyMidBlock _) _):y@(Tree (RubyMidBlock _) _):xs) = 
    x:(rubyEnd (y:xs))
rubyEnd (x@(Tree (RubyStartBlock _ _) _):xs) = x:endTagTree:(rubyEnd xs)
rubyEnd (x@(Tree (RubyMidBlock _) _):xs) = x:endTagTree:(rubyEnd xs)

-- RubyExp with children is probably a form_for or the like; convert to a RubyStartBlock
rubyEnd (x@(Tree (RubyExp s) children@(c:cs)):xs) = rubyEnd $ (Tree (RubyStartBlock s True) children):xs

-- Move inline Ruby expressions to child tree
rubyEnd (x@(Tree (Tag t a (RubyInlineContent s)) ts):xs) = 
  (Tree (Tag t a NullInlineContent) ((Tree (RubyExp s) []):ts)):(rubyEnd xs)

-- erb content should pass through
rubyEnd (x@(Tree (Tag "erb" a (HamlFilterContent s)) ts):xs) = (Tree (PlainText s) []):(rubyEnd xs)

-- Move HamlFilterContent to child tree
rubyEnd (x@(Tree (Tag t a (HamlFilterContent s)) ts):xs) = (Tree (Tag t a NullInlineContent) ((Tree (PlainText ('\n':s)) []):ts)):(rubyEnd xs)

rubyEnd (x:xs) = x : (rubyEnd xs)
rubyEnd [] = []


endTagTree = Tree (PlainText "<% end %>") []


startTag :: Tree -> String
startTag (Tree (Tag t a i) _) = "<" ++ t ++ showAttrs a ++ ">" ++ showInlineContent i

endTag :: Int -> Tree -> String
endTag n (Tree (Tag t _ _) _) = pad n ++ "</" ++ t ++ ">"

selfClosingTag :: Tree -> String
selfClosingTag (Tree (Tag t a _) _) = "<" ++ t ++ showAttrs a ++ "/>"

showAttrs xs = case map makeAttr xs of 
      [] -> ""
      xs' -> " " ++ intercalate " " xs'
    where makeAttr (k,v) =  intercalate "=" [k, "\"" ++ v ++ "\"" ]

showInlineContent (PlainInlineContent s) = s
showInlineContent (NullInlineContent) = ""
-- should not be reached:
showInlineContent (RubyInlineContent s) = "RUBY: " ++ s 

showInlineContent s = "\nERROR: No showInlineContent for " ++ (show s) ++ "\n"

    
pad :: Int -> String
pad n = take (n * 2) $ repeat ' ' 

------------------------------------------------------------------------

mapEithers :: (a -> Either b c) -> [a] -> Either b [c]
mapEithers f (x:xs) = case mapEithers f xs of
    Left err -> Left err
    Right ys -> case f x of 
                  Left err -> Left err
                  Right y -> Right (y:ys)
mapEithers _ _ = Right []


-- the following functions are extracted from MissingH Data.List.Utils 
-- by John Goerzen <jgoerzen@complete.org>

replace :: Eq a => [a] -> [a] -> [a] -> [a]
replace old new l = join new . split old $ l

join :: [a] -> [[a]] -> [a]
join delim l = concat (intersperse delim l)

breakList :: ([a] -> Bool) -> [a] -> ([a], [a])
breakList func = spanList (not . func)

spanList :: ([a] -> Bool) -> [a] -> ([a], [a])

spanList _ [] = ([],[])
spanList func list@(x:xs) =
    if func list
       then (x:ys,zs)
       else ([],list)
    where (ys,zs) = spanList func xs

split :: Eq a => [a] -> [a] -> [[a]]
split _ [] = []
split delim str =
    let (firstline, remainder) = breakList (startswith delim) str
        in
        firstline : case remainder of
                                   [] -> []
                                   x -> if x == delim
                                        then [] : []
                                        else split delim
                                                 (drop (length delim) x)


startswith :: Eq a => [a] -> [a] -> Bool
startswith = isPrefixOf


------------------------------------------------------------------------

parse1 s = iParse container "" s 

-- http://stackoverflow.com/questions/15549050/haskell-parsec-how-do-you-use-the-functions-in-text-parsec-indent
runIndentParser :: (SourcePos -> SourcePos) 
          -> IndentParser String () a 
          -> String -> Either ParseError a
runIndentParser f p src = fst $ flip runState (f $ initialPos "") $ runParserT p () "" src

topLevelsParser1 = many1 (topLevelItem)

topLevelItem = do
  withPos $ do
    as <- manyTill anyChar newline
    xs <- option [] (try indentedOrBlank)
    return $ as ++ "\n" ++ concat xs

parseTopLevels s =
    case (runIndentParser id topLevelsParser1 s) of
      Left err -> putStrLn (show err)
      Right chunks -> do
        case (mapEithers parse1 chunks) of
          Left err -> putStrLn . show $ err
          Right trees -> do
            mapM_ putStrLn $ processChildren 0 trees

main = do
    args <- getArgs
    if (null args)
    then
      getContents >>= parseTopLevels 
    else
      mapM_ (\f -> readFile f >>= parseTopLevels) args