module Pas2C where

import PascalParser
import Text.PrettyPrint.HughesPJ
import Data.Maybe
import Data.Char
import Text.Parsec.Prim
import Control.Monad.State
import System.IO
import System.Directory
import Control.Monad.IO.Class
import PascalPreprocessor
import Control.Exception
import System.IO.Error
import qualified Data.Set as Set


pas2C :: String -> IO String
pas2C = flip evalStateT initState . f
    where
    printLn = liftIO . hPutStrLn stderr
    initState = Set.empty
    f :: String -> StateT (Set.Set String) IO String
    f fileName = do
        liftIO $ setCurrentDirectory "../hedgewars/"
        
        fc' <- liftIO $ tryJust (guard . isDoesNotExistError) $ preprocess fileName
        case fc' of
            (Left a) -> return ""
            (Right fc) -> do
                modify $ Set.insert fileName
                printLn $ "Preprocessed " ++ fileName
                liftIO $ writeFile "debug.txt" fc
                let ptree = parse pascalUnit fileName fc
                case ptree of
                     (Left a) -> return (show a)
                     (Right a) -> (return . render . pascal2C) a
         
pascal2C :: PascalUnit -> Doc
pascal2C (Unit unitName interface implementation init fin) = 
    interface2C interface
    $+$ 
    implementation2C implementation
pascal2C (Program _ implementation mainFunction) =
    implementation2C implementation
    $+$
    tvar2C (FunctionDeclaration (Identifier "main") (SimpleType $ Identifier "int") (Just (TypesAndVars [], mainFunction)))
interface2C :: Interface -> Doc
interface2C (Interface uses tvars) = typesAndVars2C tvars

implementation2C :: Implementation -> Doc
implementation2C (Implementation uses tvars) = typesAndVars2C tvars


typesAndVars2C :: TypesAndVars -> Doc
typesAndVars2C (TypesAndVars ts) = vcat $ map tvar2C ts


tvar2C :: TypeVarDeclaration -> Doc
tvar2C (FunctionDeclaration (Identifier name) returnType Nothing) = 
    type2C returnType <+> text (name ++ "();")
tvar2C (FunctionDeclaration (Identifier name) returnType (Just (tvars, phrase))) = 
    type2C returnType <+> text (name ++ "()") 
    $$
    text "{" $+$ (nest 4 $ typesAndVars2C tvars)
    $+$
    phrase2C phrase
    $+$ 
    text "}"
tvar2C (TypeDeclaration (Identifier i) t) = text "type" <+> text i <+> type2C t <> text ";"
tvar2C (VarDeclaration isConst (ids, t) mInitExpr) = 
    if isConst then text "const" else empty
    <+>
    type2C t
    <+>
    (hsep . punctuate (char ',') . map (\(Identifier i) -> text i) $ ids)
    <+>
    initExpr mInitExpr
    <>
    text ";"
    where
    initExpr Nothing = empty
    initExpr (Just e) = text "=" <+> initExpr2C e

initExpr2C :: InitExpression -> Doc
initExpr2C (InitBinOp op expr1 expr2) = parens $ (initExpr2C expr1) <+> op2C op <+> (initExpr2C expr2)
initExpr2C (InitNumber s) = text s
initExpr2C (InitFloat s) = text s
initExpr2C (InitHexNumber s) = text "0x" <> (text . map toLower $ s)
initExpr2C (InitString s) = doubleQuotes $ text s 
initExpr2C (InitReference (Identifier i)) = text i


initExpr2C _ = text "<<expression>>"

type2C :: TypeDecl -> Doc
type2C UnknownType = text "void"
type2C (String l) = text $ "string" ++ show l
type2C (SimpleType (Identifier i)) = text i
type2C (PointerTo t) = type2C t <> text "*"
type2C (RecordType tvs) = text "{" $+$ (nest 4 . vcat . map tvar2C $ tvs) $+$ text "}"
type2C (RangeType r) = text "<<range type>>"
type2C (Sequence ids) = text "<<sequence type>>"
type2C (ArrayDecl r t) = text "<<array type>>"


phrase2C :: Phrase -> Doc
phrase2C (Phrases p) = text "{" $+$ (nest 4 . vcat . map phrase2C $ p) $+$ text "}"
phrase2C (ProcCall (Identifier name) params) = text name <> parens (hsep . punctuate (char ',') . map expr2C $ params) <> semi
phrase2C (IfThenElse (expr) phrase1 mphrase2) = text "if" <> parens (expr2C expr) $+$ (phrase2C . wrapPhrase) phrase1 $+$ elsePart
    where
    elsePart | isNothing mphrase2 = empty
             | otherwise = text "else" $$ (phrase2C . wrapPhrase) (fromJust mphrase2)
phrase2C (Assignment ref expr) = ref2C ref <> text " = " <> expr2C expr <> semi
phrase2C (WhileCycle expr phrase) = text "while" <> parens (expr2C expr) $$ (phrase2C $ wrapPhrase phrase)
phrase2C (SwitchCase expr cases mphrase) = text "switch" <> parens (expr2C expr) <> text "of" $+$ (nest 4 . vcat . map case2C) cases
    where
    case2C :: ([Expression], Phrase) -> Doc
    case2C (e, p) = text "case" <+> parens (hsep . punctuate (char ',') . map expr2C $ e) <> char ':' <> nest 4 (phrase2C p $+$ text "break;")
phrase2C (WithBlock ref p) = text "namespace" <> parens (ref2C ref) $$ (phrase2C $ wrapPhrase p)
phrase2C (ForCycle (Identifier i) e1 e2 p) = 
    text "for" <> (parens . hsep . punctuate (char ';') $ [text i <+> text "=" <+> expr2C e1, text i <+> text "<=" <+> expr2C e2, text "++" <> text i])
    $$
    phrase2C (wrapPhrase p)
phrase2C (RepeatCycle e p) = text "do" <+> phrase2C (Phrases p) <+> text "while" <> parens (text "!" <> parens (expr2C e))


wrapPhrase p@(Phrases _) = p
wrapPhrase p = Phrases [p]


expr2C :: Expression -> Doc
expr2C (Expression s) = text s
expr2C (BinOp op expr1 expr2) = parens $ (expr2C expr1) <+> op2C op <+> (expr2C expr2)
expr2C (NumberLiteral s) = text s
expr2C (HexNumber s) = text "0x" <> (text . map toLower $ s)
expr2C (StringLiteral s) = doubleQuotes $ text s 
expr2C (Reference ref) = ref2C ref
expr2C (PrefixOp op expr) = op2C op <+> expr2C expr
    {-
    | PostfixOp String Expression
    | CharCode String
    -}            
expr2C _ = empty


ref2C :: Reference -> Doc
ref2C (ArrayElement exprs ref) = ref2C ref <> (brackets . hcat) (punctuate comma $ map expr2C exprs)
ref2C (SimpleReference (Identifier name)) = text name
ref2C (RecordField (Dereference ref1) ref2) = ref2C ref1 <> text "->" <> ref2C ref2
ref2C (RecordField ref1 ref2) = ref2C ref1 <> text "." <> ref2C ref2
ref2C (Dereference ref) = parens $ text "*" <> ref2C ref
ref2C (FunCall params ref) = ref2C ref <> parens (hsep . punctuate (char ',') . map expr2C $ params)
ref2C (Address ref) = text "&" <> ref2C ref


op2C "or" = text "|"
op2C "and" = text "&"
op2C "not" = text "!"
op2C "xor" = text "^"
op2C "div" = text "/"
op2C "mod" = text "%"
op2C "shl" = text "<<"
op2C "shr" = text ">>"
op2C "<>" = text "!="
op2C "=" = text "=="
op2C a = text a

maybeVoid "" = "void"
maybeVoid a = a