Start converting into monadic code using Reader monad (will be used to store information about namespace)
module Pas2C where
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.Map as Map
import Control.Monad.Reader
import PascalParser
import PascalUnitSyntaxTree
pas2C :: String -> IO ()
pas2C fn = do
setCurrentDirectory "../hedgewars/"
s <- flip execStateT initState $ f fn
mapM_ toCFiles (Map.toList s)
where
printLn = liftIO . hPutStrLn stderr
print = liftIO . hPutStr stderr
initState = Map.empty
f :: String -> StateT (Map.Map String PascalUnit) IO ()
f fileName = do
processed <- gets $ Map.member fileName
unless processed $ do
print ("Preprocessing '" ++ fileName ++ ".pas'... ")
fc' <- liftIO
$ tryJust (guard . isDoesNotExistError)
$ preprocess (fileName ++ ".pas")
case fc' of
(Left a) -> do
modify (Map.insert fileName System)
printLn "doesn't exist"
(Right fc) -> do
print "ok, parsing... "
let ptree = parse pascalUnit fileName fc
case ptree of
(Left a) -> do
liftIO $ writeFile "preprocess.out" fc
printLn $ show a ++ "\nsee preprocess.out for preprocessed source"
fail "stop"
(Right a) -> do
printLn "ok"
modify (Map.insert fileName a)
mapM_ f (usesFiles a)
toCFiles :: (String, PascalUnit) -> IO ()
toCFiles (_, System) = return ()
toCFiles p@(fn, pu) = do
hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..."
toCFiles' p
where
toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C . pascal2C) p
toCFiles' (fn, (Unit _ interface implementation _ _)) = do
writeFile (fn ++ ".h") $ "#pragma once\n" ++ (render2C . interface2C $ interface)
writeFile (fn ++ ".c") $ (render2C . implementation2C) implementation
system :: [(String, String)]
system = []
render2C = render . flip runReader system
usesFiles :: PascalUnit -> [String]
usesFiles (Program _ (Implementation uses _) _) = uses2List uses
usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = uses2List uses1 ++ uses2List uses2
pascal2C :: PascalUnit -> Reader a Doc
pascal2C (Unit _ interface implementation init fin) =
liftM2 ($+$) (interface2C interface) (implementation2C implementation)
pascal2C (Program _ implementation mainFunction) = do
impl <- implementation2C implementation
main <- tvar2C True
(FunctionDeclaration (Identifier "main" BTInt) (SimpleType $ Identifier "int" BTInt) [] (Just (TypesAndVars [], mainFunction)))
return $ impl $+$ main
interface2C :: Interface -> Reader a Doc
interface2C (Interface uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars)
implementation2C :: Implementation -> Reader a Doc
implementation2C (Implementation uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars)
typesAndVars2C :: Bool -> TypesAndVars -> Reader a Doc
typesAndVars2C b (TypesAndVars ts) = liftM vcat $ mapM (tvar2C b) ts
uses2C :: Uses -> Reader a Doc
uses2C uses = return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses
uses2List :: Uses -> [String]
uses2List (Uses ids) = map (\(Identifier i _) -> i) ids
tvar2C :: Bool -> TypeVarDeclaration -> Reader a Doc
tvar2C _ (FunctionDeclaration (Identifier name _) returnType params Nothing) = do
t <- type2C returnType
p <- liftM hcat $ mapM (tvar2C False) params
return $ t <+> text name <> parens p <> text ";"
tvar2C True (FunctionDeclaration (Identifier name _) returnType params (Just (tvars, phrase))) = do
t <- type2C returnType
p <- liftM hcat $ mapM (tvar2C False) params
ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase)
return $
t <+> text name <> parens p
$+$
text "{"
$+$
nest 4 ph
$+$
text "}"
where
phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p
phrase2C' p = phrase2C p
tvar2C False (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name
tvar2C _ (TypeDeclaration (Identifier i _) t) = do
tp <- type2C t
return $ text "type" <+> text i <+> tp <> 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
tvar2C f (OperatorDeclaration op _ ret params body) =
tvar2C f (FunctionDeclaration (Identifier ("<op " ++ op ++ ">") Unknown) ret params body)
initExpr2C :: InitExpression -> Reader a 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 -> Reader a 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 union) = text "{" $+$ (nest 4 . vcat . map (tvar2C False) $ tvs) $+$ text "}"
type2C (RangeType r) = text "<<range type>>"
type2C (Sequence ids) = text "<<sequence type>>"
type2C (ArrayDecl r t) = text "<<array type>>"
type2C (Set t) = text "<<set>>"
type2C (FunctionType returnType params) = text "<<function>>"
phrase2C :: Phrase -> Reader a Doc
phrase2C (Phrases p) = text "{" $+$ (nest 4 . vcat . map phrase2C $ p) $+$ text "}"
phrase2C (ProcCall f@(FunCall {}) []) = ref2C f <> semi
phrase2C (ProcCall ref params) = ref2C ref <> 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 :: ([InitExpression], Phrase) -> Doc
case2C (e, p) = text "case" <+> parens (hsep . punctuate (char ',') . map initExpr2C $ 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))
phrase2C NOP = text ";"
wrapPhrase p@(Phrases _) = p
wrapPhrase p = Phrases [p]
expr2C :: Expression -> Reader a Doc
expr2C (Expression s) = text s
expr2C (BinOp op expr1 expr2) = parens $ (expr2C expr1) <+> op2C op <+> (expr2C expr2)
expr2C (NumberLiteral s) = text s
expr2C (FloatLiteral 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
expr2C Null = text "NULL"
expr2C (BuiltInFunCall params ref) = ref2C ref <> parens (hsep . punctuate (char ',') . map expr2C $ params)
expr2C _ = text "<<expression>>"
ref2C :: Reference -> Reader a 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 "&" <> parens (ref2C ref)
ref2C (TypeCast (Identifier t _) expr) = parens (text t) <> expr2C expr
ref2C (RefExpression expr) = expr2C expr
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