module Parser

where
import Text.ParserCombinators.Parsec
import Data.List
import Data.Char
import Control.Monad

debugParse :: Bool
debugParse = False

put :: String -> IO ()
put = if debugParse then putStrLn else const $ return ()


identifier = many ok
    where
        ok = alphaNum <|> char '_'

number =
    (try $ do
        string "0x"
        n <- many1 hexDigit
        return ("0x"++n)
    ) <|> (many1 digit)

run :: Show a => Parser a -> String -> IO a
run p input
        = case (parse p "" input) of
            Left err -> fail $ show err
            Right x  -> return x


---------------------------------------------------------------------------
-- Types

data Type = Base String | Array String Type | Pointer Type | IO_ Type deriving (Show, Eq)

parseType :: Parser [(String, Type)]
parseType = do
    typ <- parseRetType
    many space
    nam <- identifier
    nam' <- many (many space >> char ',' >> many space >> identifier)
    arr <- many array
    return $ map
        (\n -> (n, foldl (\x y -> y x) typ $ map Array arr))
        (nam:nam')
    where
        array = do
            many space
            char '['
            many space
            c <- option "" identifier
            many space
            char ']'
            return c

parseRetType :: Parser Type
parseRetType = do
    many (try $ many space >> modifier)
    many space
    typ <- identifier
    p <- many pointer
    return $ foldl (\x y -> y x) (Base typ) $ replicate (length p) Pointer
    where
        modifier = string "CONST" <|> string "const"
        pointer = try (many space >> char '*')


---------------------------------------------------------------------------
-- Enums

parseEnum :: String -> Parser [(String,String)]
parseEnum name = do
    manyTill anyChar (try start)
    c <- many1 $ try enumval
    return $ snd $ foldl gen (0,[]) $ filter ok c
    where
        gen (n,b) i@(name, value)
            | value=="" = (n+1, (name, show n):b)
            | otherwise = (n, i:b)
        start = string $ "<pre class=\"syntax\">typedef enum " ++ name ++ "\n{"
        enumval = do
            many space
            option "" $ string ","
            many space
            name <- many1 (alphaNum <|> char '_')
            value <- option "" valuep
            return (name, value)
        valuep = do
            many space
            char '='
            many space
            value <- number <?> "value"
            return value        
        ok (n,_) = not $ isSuffixOf "FORCE_DWORD" n


readEnum :: String -> String -> IO (String,[(String,String)])
readEnum path name = do
    put $ name ++ " from " ++ path ++ "/" ++ name ++ ".htm"
    values <- readFile (path++"/"++name++".htm") >>= run (parseEnum name)
    return (name, values)


---------------------------------------------------------------------------
-- interface

parseInterface :: Parser [String]
parseInterface = do
    manyTill anyChar (try start)
    many1 $ try method
    where
        start = string "<table><tr><th>Method</th><th>Description</th></tr><tr>"
        method = do
            manyTill anyChar $ try $ string "<td><a href=\""
            manyTill anyChar (string "\">")
            identifier


parseFunc :: Parser String
parseFunc = do
    manyTill anyChar (try start)
    f <- manyTill anyChar $ char ';'
    return $ clean f
    where
        start = string "<pre class=\"syntax\">"
        clean [] = []
        clean (x:xs)
            | x=='<' = clean' xs
            | x=='\n' = clean xs
            | otherwise = x:clean xs
        clean' [] = []
        clean' (x:xs)
            | x=='>' = clean xs
            | otherwise = clean' xs

parseSignature :: Parser (String, String, [String])
parseSignature = do
    many space
    ret <- identifier
    many space
    fun <- identifier
    many space
    string "("
    many space
    p <- many (try param)
    return (fun, ret, p)
    where 
        space_comma = do
            many space
            char ',' <|> char ')'
        param = do
            many space
            c <- manyTill anyChar $ try space_comma
            when (length c==0) $ fail "not long enough"
            return c

type Interface = (String, String, [(String,Type,[(String,Type)])])
readInterface :: String -> (String,String,Interface->Interface) -> IO Interface
readInterface path (name,base,f) = do
    put $ name ++ " from " ++ path ++ "/" ++ name ++ ".htm"
    values <- readFile (path++"/"++name++".htm") >>= run parseInterface >>= mapM getFunc
    return $ f (name, base, values)
    where
        getFunc fun = do
            put $ name ++ " from " ++ path ++ "/" ++ name ++ "__" ++ fun ++ ".htm"
            s <- readFile (path++"/"++name++"__"++fun++".htm") >>= run parseFunc
            put s
            (n, t, p) <- run parseSignature s
            put t
            t' <- run parseRetType t
            p' <- mapM (\x -> put x >> run parseType x) p
            return (n, t', concat p')

---------------------------------------------------------------------------
-- structures

parseStruct :: String -> Parser [String]
parseStruct name = do
    manyTill anyChar (try start)
    manyTill field $ try (many space >> char '}')
    where
        start = string $ "<pre class=\"syntax\">typedef struct " ++ name ++ " {"
        field = do
            many space
            option ' ' $ char '\n'
            many space
            manyTill anyChar $ try (many space >> char ';')

readStruct :: String -> String -> IO (String, [(String,Type)])
readStruct path name = do
    put $ name ++ " from " ++ path ++ "/" ++ name ++ ".htm"
    fields <- readFile (path++"/"++name++".htm") >>= run (parseStruct name)
    fields' <- mapM (\x -> put x >> run parseType x) fields
    return (name, concat fields')

---------------------------------------------------------------------------
-- Printing

c_decl :: [(String, a)] -> String
c_decl = concatMap p
    where
        p (x,_) = "typedef struct " ++ x ++ " " ++ x ++ ";\n"

c_decl3 :: [(String, a, b)] -> String
c_decl3 = concatMap p
    where
        p (x,_,_) = "typedef struct " ++ x ++ " " ++ x ++ ";\n"

c_type :: String -> Type -> String
c_type name t = arr t
    where
        arr (Array s t) = arr t ++ "[" ++ s ++ "]"
        arr t = ptr t ++ " " ++ name
        ptr (Pointer t) = ptr t ++ "*"
        ptr (Base s)
            | s=="D3DLight9"    = "D3DLIGHT9"
            | s=="LPD3DXFileSaveData" = "LPD3DXFILESAVEDATA"
            | s=="LpD3DDeviceXPMESH" = "LPD3DXPMESH"
            | otherwise         = s

c_fun :: (String, Type, [(String,Type)]) -> String
c_fun (n,ret,par) =
    c_type n ret ++ "(" ++ 
    (concat $ intersperse "," $ map (uncurry c_type) par)
    ++ ")"

c_def_i :: (String, String, [(String,Type,[(String,Type)])]) -> String
c_def_i (n, b, f) = concat[
    "struct vtbl",n," {\n",
    "struct vtbl",b," base;\n",
    concat $ intersperse ";\n" $ map fun f,
    ";\n};\n",
    "struct ", n, "{ struct vtbl",n," *vtbl; };\n",
    concatMap fun2 f,
    "\n"]
    where
        fun :: (String, Type, [(String,Type)]) -> String
        fun (n, t, p) = c_fun ("(__stdcall *"++n++")", t, p)
        fun2 (n',t,p) = concat $ 
            [c_type (n++"_"++n') t, "("] 
            ++ (intersperse "," $ map (uncurry c_type) (("object",Pointer (Base n)):p))
            ++ [") { return object->vtbl->", n', "(" ]
            ++ (intersperse "," $ map fst p)
            ++ ["); }\n"]

c_def_if ::  (String, String, [(String, Type, [(String,Type)])]) -> String
c_def_if (n,_,f) = concatMap fun f
    where
    {-
        fun (n',t,p) = concat $
            [c_type ("c_"++n++"_"++n') t, "("]
            ++ (intersperse "," $ map (uncurry c_type) (("object", Pointer $ Base n):p))
            ++ [") { return "]
            ++ [n,"_",n',"("]
            ++ (intersperse "," $ ("object": map fst p))
            ++ ["); }\n"]
            -}
        fun (n',t,p) = concat $
                [c_type ("c_"++n++"_"++n') t, "("]
            ++  (intersperse "," $ map (uncurry c_type) (("object", Pointer $ Base n):p))
            ++  [") { return object->lpVtbl->", n', "("]
            ++  (intersperse "," $ ("object":map fst p))
            ++  ["); }\n"]

c_def_e :: (String, [(String,String)]) -> String
c_def_e (e, v) = concat [
    "typedef enum ", e, " ", e, ";\n",
    "enum ", e, " {\n",
    concat $ intersperse ",\n" $ map val v,
    "\n};\n"]
    where
        val (n,v) = n ++ " = " ++ v
    
c_def_e2 :: (String, a) -> String
c_def_e2 (e,_) = "typedef DWORD " ++ e ++ ";\n"

h_type :: Type -> String
h_type t = case t of
    Pointer (Base s)    -> "Ptr " ++ trans s
    Array _ (Base s)    -> "Ptr " ++ trans s
    IO_ (Base s)        -> "IO " ++ trans s
    Pointer t           -> "Ptr (" ++ h_type t ++ ")"
    Array _ t           -> "Ptr (" ++ h_type t ++ ")"
    IO_ t               -> "IO (" ++ h_type t ++ ")"
    Base s              -> trans s
    where
        trans s
            | s=="void"     = "()"
            | s=="VOID"     = "()"
            | s=="float"    = "Float"
            | s=="char"     = "Char"
            | s=="int"      = "Int"
            | s=="D3DLight9" = "D3DLIGHT9"
            | s=="DOUBLE"   = "Double"
            | s=="LpD3DDeviceXPMESH" = "(Ptr ID3DXPMesh)"
            -- | isPrefixOf "LP" s = "(Ptr " ++ (trans $ drop 2 s) ++ ")"
            | otherwise     = s
    

h_fun :: Type -> [Type] -> String
h_fun ret p = concat $ intersperse " -> " $ map h_type (p ++ [ret])

h_def_i :: (String, String, [(String, Type, [(String, Type)])]) -> String
h_def_i (n,_,f) = concat $ [
    "data ", n, " = ", n, " deriving (Show)\n"]
    ++ (intersperse "\n" $ map fun f)
    ++ ["\n"]
    ++ pointer
    ++ ["\n\n"]
    where
        pointer = [
            "type LP", n, " = Ptr ", n, "\n",
            "type LP", map toUpper (tail n), " = Ptr ", n, "\n"]
        fun (n', t, p) = 
            "foreign import ccall unsafe \"fake.h c_" ++n++"_"++n'++"\"\n"
            ++"  c_"++n++"_"++n'++"::"++ h_fun (IO_ t) ((Pointer (Base n)):(map snd p))

h_def_s :: (String,[(String,Type)]) -> String
h_def_s (s,v) = concat [
    "data ", s, " = ", s, "{ ", 
    concat $ intersperse "," $ map constr v,
    " } deriving (Show,Eq,Ord)\n",
    pointer,
    storable]
    where
        typ :: Type -> String
        typ (Base t) =  "!" ++ h_type (Base t)
        typ t = "!(" ++ h_type t ++ ")"
        constr (n,t) = let
            (x:xs) = (s++"_"++n)
            n' = (toLower x):xs
            in n' ++ " :: " ++ typ t
        pointer = concat [
            "type LP", s, " = Ptr ", s, "\n"]
        storable = concat$[
            "instance Storable ", s, " where\n",
            " sizeOf _ = "] ++ (intersperse "+" $ map size v) ++ ["\n",
            " alignment = const 1\n",
            " poke b (",s," "]++ (intersperse " " $ params) ++[")\n",
            "  = return b >>= pokeHelp "] ++ (intersperse " >>= pokeHelp " params)
            ++ [" >> return()\n",
            " peek b = do\n"] ++ (init $ concatMap peek params)
            ++ ["  return (",s, " "] ++ (intersperse " " params) ++ [")\n\n"]
        size (_,t) = "(sizeOf (undefined::("++h_type t++")))"
        param p = "p" ++ show p
        params = map param [1..length v]
        peek p = ["  " ++ p ++ " <- peekByteOff b 0\n","  b <- return $ plusPtr b (sizeOf " ++ p ++ ")\n"]

h_def_e :: [(String,String)] -> (String, [(String, String)]) -> String
h_def_e types (e,v) = "type " ++ e ++ " = " ++ t ++ "\n" ++ (concatMap print v) ++ "\n"
    where
        print (n:n',v) = ((toLower n):n') ++ "::"++e++"\n" ++ ((toLower n):n') ++ "=" ++ v ++ "\n"
        t = case lookup e types of
            Just x -> x
            Nothing -> "DWORD"