1 files changed, 114 insertions, 0 deletions
diff --git a/Language/C/Print.hs b/Language/C/Print.hs
new file mode 100644
index 0000000..e075b0e
--- /dev/null
+++ b/Language/C/Print.hs
@@ -0,0 +1,114 @@
+{-# LANGUAGE LambdaCase #-}
+module Language.C.Print where
+
+import Data.List (intersperse)
+
+import Language.C
+
+
+-- precedence -> tail -> string
+type PrintS = Int -> String -> String
+
+-- | The resulting program will need <stdlib.h> and <stdint.h>.
+printProgram :: Program -> PrintS
+printProgram (Program defs) = intercalates "\n" (map printFunDef defs)
+
+printFunDef :: FunDef -> PrintS
+printFunDef (FunDef rt n as (StExpr ss rete)) =
+    printType rt % printString " " % printName n
+    % printString "("
+    % intercalates ", " [printType t % printString " " % printName an | (t, an) <- as]
+    % printString ") {\n  "
+    % addIndent 2 (intercalates "\n" (map printStmt ss))
+    % printString "\n  return (" % printExpr rete % printString ");\n}"
+printFunDef (ProcDef n as ss) =
+    printString "void " % printName n
+    % printString "("
+    % intercalates ", " [printType t % printString " " % printName an | (t, an) <- as]
+    % printString ") " % printBlock ss
+
+printName :: Name -> PrintS
+printName (Name s) = printString s
+
+printType :: Type -> PrintS
+printType = printString . showType
+  where
+    showType :: Type -> String
+    showType = \case
+        TInt b -> "int" ++ printBits b ++ "_t"
+        TUInt b -> "uint" ++ printBits b ++ "_t"
+        TFloat -> "float"
+        TDouble -> "double"
+        TPtr t -> showType t ++ "*"
+      where
+        printBits :: Bits -> String
+        printBits B8 = "8"
+        printBits B16 = "16"
+        printBits B32 = "32"
+        printBits B64 = "64"
+
+printBlock :: [Stmt] -> PrintS
+printBlock ss =
+    printString "{\n  "
+    % addIndent 2 (intercalates "\n" (map printStmt ss))
+    % printString "\n}"
+
+printStmt :: Stmt -> PrintS
+printStmt (SDecl ty name rhs) =
+    printType ty % printString " "
+    % printName name
+    % maybe (printString "") (\e -> printString " = " % printExpr e) rhs
+    % printString ";"
+printStmt (SAsg name e) =
+    printName name % printString " = " % printExpr e % printString ";"
+printStmt (SStore name idx val) =
+    printName name % printString "[" % printExpr idx % printString "] = " % printExpr val % printString ";"
+printStmt (SCall name args) =
+    printName name % printString "(" % intercalates ", " (map printExpr args) % printString ");"
+printStmt (SFor ty name lo hi body) =
+    printString "for ("
+    % printType ty % printString " " % printName name % printString " = " % printExpr lo
+    % printString "; "
+    % printName name % printString " < (" % printExpr hi % printString ")"
+    % printString "; "
+    % printName name % printString "++) "
+    % printBlock body
+printStmt (SIf e b1 b2) =
+    printString "if (" % printExpr e % printString ") "
+    % printBlock b1 % printString " else " % printBlock b2
+
+printExpr :: Expr -> PrintS
+printExpr (EOp e1 op e2) =
+    printString "(" % printExpr e1 % printString (") " ++ op ++ " (")
+    % printExpr e2 % printString ")"
+printExpr (ENot e) =
+    printString "!(" % printExpr e % printString ")"
+printExpr (ELit s) = printString ("(" ++ s ++ ")")
+printExpr (EVar name) = printName name
+printExpr (ECall name args) =
+    printName name % printString "("
+    % intercalates ", " (map printExpr args) % printString ")"
+printExpr (EIndex name e) = printName name % printString "[" % printExpr e % printString "]"
+printExpr (EPtrTo e) = printString "&(" % printExpr e % printString ")"
+printExpr (ESizeOf t) = printString "(sizeof (" % printType t % printString "))"
+
+
+addIndent :: Int -> PrintS -> PrintS
+addIndent plusd f d = f (d + plusd)
+
+withIndent :: Int -> PrintS -> PrintS
+withIndent d f _ = f d
+
+intercalates :: String -> [PrintS] -> PrintS
+intercalates sep l = foldr (%) (\_ -> id) $ intersperse (printString sep) l
+
+(%) :: PrintS -> PrintS -> PrintS
+f % g = \d -> f d . g d
+
+printString :: String -> PrintS
+printString "" _ rest = rest
+printString ('\n' : s@('\n' : _)) d rest = '\n' : printString s d rest
+printString ('\n' : s) d rest = '\n' : replicate d ' ' ++ printString s d rest
+printString s d rest =
+    let (pre, post) = span (/= '\n') s
+    in pre ++ printString post d rest