hm is compatible

src/Main.hs

@@ -2,87 +2,97 @@
 
 module Main where
 
-import           Control.Monad               (when)
+import Control.Monad (when)
-import           Data.Bool                   (bool)
+import Data.Bool (bool)
-import           Data.List.Extra             (isSuffixOf)
+import Data.List.Extra (isSuffixOf)
-import           Data.Maybe                  (fromJust, isNothing)
+import Data.Maybe (fromJust, isNothing)
-import           GHC.IO.Handle.Text          (hPutStrLn)
+import GHC.IO.Handle.Text (hPutStrLn)
-import           System.Console.GetOpt       (ArgDescr (NoArg, ReqArg),
+import System.Console.GetOpt (
-                                              ArgOrder (RequireOrder),
+    ArgDescr (NoArg, ReqArg),
-                                              OptDescr (Option), getOpt,
+    ArgOrder (RequireOrder),
-                                              usageInfo)
+    OptDescr (Option),
-import           System.Directory            (createDirectory, doesPathExist,
+    getOpt,
-                                              getDirectoryContents,
+    usageInfo,
-                                              removeDirectoryRecursive,
+ )
-                                              setCurrentDirectory)
+import System.Directory (
-import           System.Environment          (getArgs)
+    createDirectory,
-import           System.Exit                 (ExitCode (ExitFailure),
+    doesPathExist,
-                                              exitFailure, exitSuccess,
+    getDirectoryContents,
-                                              exitWith)
+    removeDirectoryRecursive,
-import           System.IO                   (stderr)
+    setCurrentDirectory,
+ )
+import System.Environment (getArgs)
+import System.Exit (
+    ExitCode (ExitFailure),
+    exitFailure,
+    exitSuccess,
+    exitWith,
+ )
+import System.IO (stderr)
 
-
+import Codegen.Codegen (generateCode)
-import           Codegen.Codegen             (generateCode)
+import Compiler (compile)
-import           Compiler                    (compile)
+import Grammar.ErrM (Err)
-import           Grammar.ErrM                (Err)
+import Grammar.Par (myLexer, pProgram)
-import           Grammar.Par                 (myLexer, pProgram)
+import Grammar.Print (printTree)
-import           Grammar.Print               (printTree)
+import LambdaLifter (lambdaLift)
-import           LambdaLifter                (lambdaLift)
+import Monomorphizer.Monomorphizer (monomorphize)
-import           Monomorphizer.Monomorphizer (monomorphize)
+import Renamer.Renamer (rename)
-import           Renamer.Renamer             (rename)
+import System.Process (spawnCommand, waitForProcess)
-import           System.Process              (spawnCommand, waitForProcess)
+import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck)
-import           TypeChecker.TypeChecker     (TypeChecker (Bi, Hm), typecheck)
 
 main :: IO ()
 main = getArgs >>= parseArgs >>= uncurry main'
 
 parseArgs :: [String] -> IO (Options, String)
 parseArgs argv = case getOpt RequireOrder flags argv of
-  (os, f:_, [])
+    (os, f : _, [])
-      | opts.help || isNothing opts.typechecker -> do
+        | opts.help || isNothing opts.typechecker -> do
-          hPutStrLn stderr (usageInfo header flags)
+            hPutStrLn stderr (usageInfo header flags)
-          exitSuccess
+            exitSuccess
-      | otherwise -> pure (opts, f)
+        | otherwise -> pure (opts, f)
-    where
+      where
-      opts = foldr ($) initOpts os
+        opts = foldr ($) initOpts os
-  (_, _, errs) -> do
+    (_, _, errs) -> do
-      hPutStrLn stderr (concat errs ++ usageInfo header flags)
+        hPutStrLn stderr (concat errs ++ usageInfo header flags)
-      exitWith (ExitFailure 1)
+        exitWith (ExitFailure 1)
   where
     header = "Usage: language [--help] [-d|--debug] [-t|type-checker bi/hm] FILE \n"
 
 flags :: [OptDescr (Options -> Options)]
 flags =
-    [ Option ['d'] ["debug"]        (NoArg  enableDebug)                  "Print debug messages."
+    [ Option ['d'] ["debug"] (NoArg enableDebug) "Print debug messages."
     , Option ['t'] ["type-checker"] (ReqArg chooseTypechecker "bi/hm") "Choose type checker. Possible options are bi and hm"
-    , Option []    ["help"]         (NoArg  enableHelp)                   "Print this help message"
+    , Option [] ["help"] (NoArg enableHelp) "Print this help message"
     ]
 
 initOpts :: Options
-initOpts = Options { help        = False
+initOpts =
-                   , debug       = False
+    Options
-                   , typechecker = Nothing
+        { help = False
-                   }
+        , debug = False
+        , typechecker = Nothing
+        }
 
 enableHelp :: Options -> Options
-enableHelp opts = opts { help = True }
+enableHelp opts = opts{help = True}
 
 enableDebug :: Options -> Options
-enableDebug opts = opts { debug = True }
+enableDebug opts = opts{debug = True}
 
 chooseTypechecker :: String -> Options -> Options
-chooseTypechecker s options = options { typechecker = tc }
+chooseTypechecker s options = options{typechecker = tc}
   where
     tc = case s of
-           "hm" -> pure Hm
+        "hm" -> pure Hm
-           "bi" -> pure Bi
+        "bi" -> pure Bi
-           _    -> Nothing
+        _ -> Nothing
 
 data Options = Options
-  { help        :: Bool
+    { help :: Bool
-  , debug       :: Bool
+    , debug :: Bool
-  , typechecker :: Maybe TypeChecker
+    , typechecker :: Maybe TypeChecker
-  }
+    }
 
 main' :: Options -> String -> IO ()
 main' opts s = do
@@ -110,12 +120,12 @@ main' opts s = do
     --
     printToErr "\n -- Compiler --"
     generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked)
-    --putStrLn generatedCode
+    -- putStrLn generatedCode
 
     check <- doesPathExist "output"
     when check (removeDirectoryRecursive "output")
     createDirectory "output"
-    when debug $ do
+    when opts.debug $ do
         _ <- writeFile "output/llvm.ll" generatedCode
         debugDotViz
 

src/TypeChecker/TypeChecker.hs

@@ -0,0 +1,18 @@
+module TypeChecker.TypeChecker (typecheck, TypeChecker (..)) where
+
+import Control.Monad ((<=<))
+import Grammar.Abs
+import Grammar.ErrM (Err)
+import TypeChecker.RemoveTEVar (RemoveTEVar (rmTEVar))
+import TypeChecker.TypeCheckerBidir qualified as Bi
+import TypeChecker.TypeCheckerHm qualified as Hm
+import TypeChecker.TypeCheckerIr qualified as T
+
+data TypeChecker = Bi | Hm
+
+typecheck :: TypeChecker -> Program -> Err T.Program
+typecheck tc = rmTEVar <=< f
+  where
+    f = case tc of
+        Bi -> Bi.typecheck
+        Hm -> Hm.typecheck

tests/DoStrings.hs

@@ -0,0 +1,4 @@
+module DoStrings where
+
+(>>) str1 str2 = str1 ++ "\n" ++ str2
+(>>=) str1 f = f str1

tests/TestTypeCheckerHm.hs

@@ -1,27 +1,32 @@
+{-# LANGUAGE QualifiedDo #-}
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE QualifiedDo       #-}
 
 module TestTypeCheckerHm (testTypeCheckerHm) where
 
-import           Control.Monad             ((<=<))
+import Control.Monad ((<=<))
-import qualified DoStrings                 as D
+import DoStrings qualified as D
-import           Grammar.Par               (myLexer, pProgram)
+import Grammar.Par (myLexer, pProgram)
-import           Prelude                   (Bool (..), Either (..), IO, fmap,
+import Test.Hspec
-                                            not, ($), (.))
+import Prelude (
-import           Test.Hspec
+    Bool (..),
+    Either (..),
+    IO,
+    fmap,
+    not,
+    ($),
+    (.),
+ )
 
 -- import Test.QuickCheck
-import           TypeChecker.TypeCheckerHm (typecheck)
+import TypeChecker.TypeCheckerHm (typecheck)
-
-
 
 testTypeCheckerHm = describe "Hillner Milner type checker test" $ do
     ok1
     ok2
     bad1
     bad2
-    -- bad3
 
+-- bad3
 
 ok1 =
     specify "Basic polymorphism with multiple type variables" $
@@ -75,7 +80,7 @@ bad3 =
 run = typecheck <=< pProgram . myLexer
 
 ok (Right _) = True
-ok (Left _)  = False
+ok (Left _) = False
 
 bad = not . ok