Compile to binary executable file

.gitignore

@@ -21,3 +21,5 @@ cabal.project.local
 cabal.project.local~
 .HTF/
 .ghc.environment.*
+a.out
+a.out.ll

.vscode/extensions.json

@@ -0,0 +1,7 @@
+{
+    "recommendations": [
+        "gattytto.phoityne-vscode",
+        "haskell.haskell",
+        "justusadam.language-haskell"
+    ]
+}

.vscode/launch.json

@@ -0,0 +1,46 @@
+{
+    // Use IntelliSense to learn about possible attributes.
+    // Hover to view descriptions of existing attributes.
+    // For more information, visit: https://go.microsoft.com/fwlink/?linkid=830387
+    "version": "0.2.0",
+    "configurations": [
+        {
+            "type": "ghc",
+            "request": "launch",
+            "name": "haskell(stack)",
+            "internalConsoleOptions": "openOnSessionStart",
+            "workspace": "${workspaceFolder}",
+            "startup": "${workspaceFolder}/test/Spec.hs",
+            "startupFunc": "",
+            "startupArgs": "",
+            "stopOnEntry": false,
+            "mainArgs": "",
+            "ghciPrompt": "H>>= ",
+            "ghciInitialPrompt": "Prelude>",
+            "ghciCmd": "stack ghci --test --no-load --no-build --main-is TARGET",
+            "ghciEnv": {},
+            "logFile": "${workspaceFolder}/.vscode/phoityne.log",
+            "logLevel": "WARNING",
+            "forceInspect": false
+        },
+        {
+            "type": "ghc",
+            "request": "launch",
+            "name": "haskell(cabal)",
+            "internalConsoleOptions": "openOnSessionStart",
+            "workspace": "${workspaceFolder}",
+            "startup": "${workspaceFolder}/Main.hs",
+            "startupFunc": "",
+            "startupArgs": "",
+            "stopOnEntry": false,
+            "mainArgs": "",
+            "ghciPrompt": "H>>= ",
+            "ghciInitialPrompt": "Prelude>",
+            "ghciCmd": "cabal exec -- ghci-dap --interactive -i -i${workspaceFolder}",
+            "ghciEnv": {},
+            "logFile": "${workspaceFolder}/.vscode/phoityne.log",
+            "logLevel": "WARNING",
+            "forceInspect": false
+        }
+    ]
+}

.vscode/tasks.json

@@ -0,0 +1,50 @@
+
+{
+  // Automatically created by phoityne-vscode extension.
+
+  "version": "2.0.0",
+  "presentation": {
+    "reveal": "always",
+    "panel": "new"
+  },
+  "tasks": [
+    {
+      // F7
+      "group": {
+        "kind": "build",
+        "isDefault": true
+      },
+      "label": "haskell build",
+      "type": "shell",
+      //"command": "cabal configure && cabal build"
+      "command": "stack build"
+    },
+    {
+      // F6
+      "group": "build",
+      "type": "shell",
+      "label": "haskell clean & build",
+      //"command": "cabal clean && cabal configure && cabal build"
+      "command": "stack clean && stack build"
+      //"command": "stack clean ; stack build"  // for powershell
+    },
+    {
+      // F8
+      "group": {
+        "kind": "test",
+        "isDefault": true
+      },
+      "type": "shell",
+      "label": "haskell test",
+      //"command": "cabal test"
+      "command": "stack test"
+    },
+    {
+      // F6
+      "isBackground": true,
+      "type": "shell",
+      "label": "haskell watch",
+      "command": "stack build --test --no-run-tests --file-watch"
+    }
+  ]
+}

README.md

@@ -11,6 +11,10 @@ Main repo: https://git.sudoer.ch/me/really-bad-compiler-in-haskell
 - Use `ghcup` to install `stack 2.9.3`, `HLS 2.2.0.0`, `GHC 9.2.8`, and `cabal 3.6.2.0`.
 - Use `stack run <file>` to run the program (for example, `stack run example/1`).
 
+## To edit
+
+I recommend using VSCodium, which is preconfigured to have syntax highlighting and (currently broken) debugging features and will automatically suggest the Haskell extensions to install.
+
 ## Known bugs
 
 ### Building
@@ -41,7 +45,7 @@ Main repo: https://git.sudoer.ch/me/really-bad-compiler-in-haskell
 
 - Language: Haskell
 - Haskell tools: GHCup, Stack, Cabal, GHC 9.2
-- Libraries: megaparsec, parser-combinators, text, llvm-hs-pure 15, llvm-hs-pretty-15
+- Libraries: megaparsec, parser-combinators, text, process, llvm-hs-pure 15, llvm-hs-pretty-15
 - Dependencies: llvm 15, clang 15
 - IDE: VSCodium
 - Git platform: Forgejo

main/Compiler/LLVMGen.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo #-}
+
+-- see https://gh.sudoer.ch/danieljharvey/mimsa/blob/trunk/llvm-calc/src/Calc/Compile/ToLLVM.hs
+
+module Compiler.LLVMGen (llvmGen) where
+
+-- import LLVM.Pretty
+
+import Data.ByteString (ByteString)
+import Debug.Trace
+import LLVM (moduleLLVMAssembly, withModuleFromAST, writeLLVMAssemblyToFile)
+import LLVM.AST hiding (function)
+import LLVM.AST.Type
+import LLVM.Context
+import LLVM.IRBuilder.Constant
+import LLVM.IRBuilder.Instruction
+import LLVM.IRBuilder.Module
+import LLVM.IRBuilder.Monad
+import Types.Expr as Expr
+
+getLLVM :: Expr -> Module
+getLLVM expr =
+  buildModule "program" $ mdo
+    -- TODO: better module name
+    printf <- externVarArgs "printf" [ptr] i32
+    function "main" [] i32 $ \_ -> mdo
+      numFormatStr <- globalStringPtr "%d\n" (mkName "str")
+      traceShow numFormatStr $ pure ()
+      ourExpression <- exprToLLVM expr
+      -- _ <- call (FunctionType i32 [i32])
+      _ <- call (FunctionType i32 [ptr] True) printf [(ConstantOperand numFormatStr, []), (ourExpression, [])]
+      ret (int32 0)
+
+exprToLLVM ::
+  ( MonadIRBuilder m,
+    MonadModuleBuilder m
+  ) =>
+  Expr ->
+  m Operand
+exprToLLVM (Lit prim) = pure $ primToLLVM prim
+exprToLLVM (Expr.Add a b) = mdo
+  lhs <- exprToLLVM a
+  rhs <- exprToLLVM b
+  add lhs rhs
+exprToLLVM (Expr.Sub a b) = mdo
+  lhs <- exprToLLVM a
+  rhs <- exprToLLVM b
+  sub lhs rhs
+exprToLLVM (Expr.Mul a b) = mdo
+  lhs <- exprToLLVM a
+  rhs <- exprToLLVM b
+  mul lhs rhs
+
+primToLLVM :: Int -> Operand
+primToLLVM i = int32 (fromIntegral i)
+
+llvmGen :: Expr -> IO ByteString
+llvmGen expr = do
+  let l = getLLVM expr
+  withContext
+    ( \c ->
+        withModuleFromAST c l moduleLLVMAssembly
+    )

main/Eval/Expr.hs

@@ -1,13 +0,0 @@
-module Eval.Expr (evalExpr) where
-
-import Types.Expr
-
-eval :: Expr -> Int
-eval (Lit x) = x
-eval (Add x y) = eval x + eval y
-eval (Sub x y) = eval x - eval y
-eval (Mul x y) = eval x * eval y
-eval (Div x y) = eval x `div` eval y
-
-evalExpr :: Expr -> Int
-evalExpr = eval

main/LLVMGen/Expr.hs

@@ -1,57 +0,0 @@
-{-# LANGUAGE ImportQualifiedPost #-}
-{-# LANGUAGE OverloadedStrings #-}
-
--- see https://gh.sudoer.ch/danieljharvey/mimsa/blob/trunk/llvm-calc/src/Calc/Compile/ToLLVM.hs
-
-module LLVMGen.Expr (getLLVMStr) where
-
-import Data.Text.Lazy
-import LLVM.AST hiding (function)
-import LLVM.AST.Type
-import LLVM.IRBuilder.Constant
-import LLVM.IRBuilder.Instruction
-import LLVM.IRBuilder.Module
-import LLVM.IRBuilder.Monad
-import LLVM.Pretty
-import Types.Expr as Expr
-
--- charStar :: LLVM.Type
--- charStar = LLVM.ptr LLVM.i8
-
-getLLVM :: Expr -> Module
-getLLVM expr =
-  buildModule "program" $ do
-    -- TODO: better naming
-    printf <- externVarArgs "printf" [ptr] i32 -- or LLVM.ptr LLVM.i8
-    let numFormatStr = globalStringPtr "%d\n" (mkName "str")
-    function "main" [] i32 $ \_ -> do
-      ourExpression <- exprToLLVM expr
-      nfs <- numFormatStr
-      _ <- call i32 printf [(ConstantOperand nfs, []), (ourExpression, [])]
-      ret (int32 0)
-
-exprToLLVM ::
-  ( MonadIRBuilder m,
-    MonadModuleBuilder m
-  ) =>
-  Expr ->
-  m Operand
-exprToLLVM (Lit prim) = pure $ primToLLVM prim
-exprToLLVM (Expr.Add a b) = do
-  lhs <- exprToLLVM a
-  rhs <- exprToLLVM b
-  add lhs rhs
-exprToLLVM (Expr.Sub a b) = do
-  lhs <- exprToLLVM a
-  rhs <- exprToLLVM b
-  sub lhs rhs
-exprToLLVM (Expr.Mul a b) = do
-  lhs <- exprToLLVM a
-  rhs <- exprToLLVM b
-  mul lhs rhs
-
-primToLLVM :: Int -> Operand
-primToLLVM i = int32 (fromIntegral i)
-
-getLLVMStr :: Expr -> Text
-getLLVMStr expr = ppllvm (getLLVM expr)

main/LLVMGen/Expr.hs.old

@@ -1,74 +0,0 @@
-module LLVMGen.Expr (getLLVM) where
-
-import qualified Objects.Expr as Expr
-
-import LLVM.AST
-import qualified LLVM.AST as AST
-import LLVM.AST.Global
-import LLVM.AST.Constant
-import LLVM.AST.Type
-import LLVM.AST.Name
-import LLVM.Context
-import LLVM.Module
-
-import Data.ByteString.Char8 as BS
-
-int :: Type
-int = IntegerType 32
-
-defMain :: Definition
-defMain = GlobalDefinition functionDefaults
-  { name = Name "main"
-  , parameters =
-      ( []
-      , False )
-  , returnType = int
-  , basicBlocks = [body]
-  }
-  where
-    body = BasicBlock
-        (Name "entry")
-        [ Name "calltmp" :=
-            Call
-            { tailCallKind = Nothing
-            , function = Right (ConstantOperand (GlobalReference (PointerType (FunctionType int [int, int] False) defaultAddrSpace) (Name "add")))
-            , arguments = [ (ConstantOperand (Int 32 10), []), (ConstantOperand (Int 32 20), []) ]
-            }
-        ]
-        (Do $ Ret (Just (ConstantOperand (Int 32 0))) [])
-
-defAdd :: Definition
-defAdd = GlobalDefinition functionDefaults
-  { name = Name "add"
-  , parameters =
-      ( [ Parameter int (Name "a") []
-        , Parameter int (Name "b") [] ]
-      , False )
-  , returnType = int
-  , basicBlocks = [body]
-  }
-  where
-    body = BasicBlock
-        (Name "entry")
-        [ Name "result" :=
-            AST.Add False  -- no signed wrap
-                False  -- no unsigned wrap
-                (LocalReference int (Name "a"))
-                (LocalReference int (Name "b"))
-                []]
-        (Do $ Ret (Just (LocalReference int (Name "result"))) [])
-
-module_ :: AST.Module
-module_ = defaultModule
-  { moduleName = "basic"
-  , moduleDefinitions = [defMain, defAdd]
-  }
-
-
-toLLVM :: AST.Module -> IO ()
-toLLVM modul = withContext $ \ctx -> do
-  llvm <- withModuleFromAST ctx modul moduleLLVMAssembly
-  BS.putStrLn llvm
-
-getLLVM :: IO ()
-getLLVM = toLLVM module_

main/Main.hs

@@ -3,23 +3,26 @@
 
 module Main (main) where
 
+-- import Compiler.ExeGen
+import Compiler.LLVMGen
+import Data.ByteString.Char8 qualified as B
 import Data.Text.Lazy.IO qualified as T
-import Eval.Expr
-import LLVMGen.Expr
 import Parser.Expr
 import System.Environment
+import System.Process
 import Types.Expr
 
 getRight :: ParseResult -> Expr
 getRight (Right r) = r
 
-getResult :: String -> Int
-getResult str = evalExpr (getRight (parseExpr str)) -- TODO: add error messages
-
 main :: IO ()
 main = do
   fileName <- fmap head getArgs
   contents <- readFile fileName
-  let result = getResult contents
-  print result
-  T.putStrLn (getLLVMStr (getRight (parseExpr contents)))
+  T.putStrLn "- Parsing file..."
+  let parsed = getRight (parseExpr contents)
+  T.putStrLn "- Generating LLVM to './a.out.ll'..."
+  llvmGen parsed >>= B.writeFile "a.out.ll"
+  T.putStrLn "- Compiling to executable './a.out'..."
+  callCommand "clang a.out.ll"
+  T.putStrLn "- Done."

main/Parser/Expr.hs

@@ -27,8 +27,8 @@ term = Lit <$> intParser
 
 table :: [[Operator Parser Expr]]
 table =
-  [ [ binaryOp "*" Mul,
-      binaryOp "/" Div
+  [ [ binaryOp "*" Mul
+  -- binaryOp "/" Div
     ],
     [ binaryOp "+" Add,
       binaryOp "-" Sub

main/Types/Expr.hs

@@ -5,5 +5,7 @@ data Expr
   | Add Expr Expr
   | Sub Expr Expr
   | Mul Expr Expr
-  | Div Expr Expr
-  deriving (Show)
+  deriving
+    ( -- | Div Expr Expr
+      Show
+    )

package.yaml

@@ -6,9 +6,10 @@ dependencies:
   - megaparsec >= 9.0.1 && < 10
   - parser-combinators
   - text
-  # - llvm-hs >= 15 && < 16
+  - process
+  - llvm-hs >= 15 && < 16
   - llvm-hs-pure >= 15 && < 16
-  - llvm-hs-pretty >= 15 && < 16
+  # - llvm-hs-pretty >= 15 && < 16
   - bytestring
 tested-with: GHC == 9.2.8
 category: Compilers/Interpreters

really-bad-compiler-in-haskell.cabal

@@ -16,8 +16,7 @@ tested-with:
 executable really-bad-compiler-in-haskell
   main-is: Main.hs
   other-modules:
-      Eval.Expr
-      LLVMGen.Expr
+      Compiler.LLVMGen
       Parser.Expr
       Types.Expr
       Paths_really_bad_compiler_in_haskell
@@ -29,9 +28,10 @@ executable really-bad-compiler-in-haskell
   build-depends:
       base >=4.14.3 && <5
     , bytestring
-    , llvm-hs-pretty ==15.*
+    , llvm-hs ==15.*
     , llvm-hs-pure ==15.*
     , megaparsec >=9.0.1 && <10
     , parser-combinators
+    , process
     , text
   default-language: Haskell2010

stack.yaml

@@ -9,7 +9,7 @@ extra-deps:
     commit: 5bca2c1a2a3aa98ecfb19181e7a5ebbf3e212b76
     subdirs:
       - llvm-hs-pure
-      # - llvm-hs
+      - llvm-hs
 nix:
   enable: true
   packages: [llvm_15, clang_15, libxml2]

stack.yaml.lock

@@ -28,6 +28,19 @@ packages:
   original:
     subdir: llvm-hs-pure
     url: https://github.com/llvm-hs/llvm-hs/archive/5bca2c1a2a3aa98ecfb19181e7a5ebbf3e212b76.tar.gz
+- completed:
+    name: llvm-hs
+    pantry-tree:
+      sha256: 21f74a6f51fae6c0a0fcf3e6620a59f341289ac743998b41ed3276fd1b7d8862
+      size: 12716
+    sha256: 526b67e2da9ce25b3856c221b6772e699a7593dbb5ba38e7ee2436349de70966
+    size: 9802209
+    subdir: llvm-hs
+    url: https://github.com/llvm-hs/llvm-hs/archive/5bca2c1a2a3aa98ecfb19181e7a5ebbf3e212b76.tar.gz
+    version: 15.0.0
+  original:
+    subdir: llvm-hs
+    url: https://github.com/llvm-hs/llvm-hs/archive/5bca2c1a2a3aa98ecfb19181e7a5ebbf3e212b76.tar.gz
 snapshots:
 - completed:
     sha256: 5a59b2a405b3aba3c00188453be172b85893cab8ebc352b1ef58b0eae5d248a2