From d5ce73beaeb53bf04cfe1ff78a3ba4c8f338e871 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 27 Mar 2023 16:52:22 +0200 Subject: [PATCH] hm is compatible --- src/Main.hs | 124 ++++++++++++++++++--------------- src/TypeChecker/TypeChecker.hs | 18 +++++ tests/DoStrings.hs | 4 ++ tests/TestTypeCheckerHm.hs | 29 ++++---- 4 files changed, 106 insertions(+), 69 deletions(-) create mode 100644 src/TypeChecker/TypeChecker.hs create mode 100644 tests/DoStrings.hs diff --git a/src/Main.hs b/src/Main.hs index 210916d..19ef68c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,87 +2,97 @@ module Main where -import Control.Monad (when) -import Data.Bool (bool) -import Data.List.Extra (isSuffixOf) -import Data.Maybe (fromJust, isNothing) -import GHC.IO.Handle.Text (hPutStrLn) -import System.Console.GetOpt (ArgDescr (NoArg, ReqArg), - ArgOrder (RequireOrder), - OptDescr (Option), getOpt, - usageInfo) -import System.Directory (createDirectory, doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory) -import System.Environment (getArgs) -import System.Exit (ExitCode (ExitFailure), - exitFailure, exitSuccess, - exitWith) -import System.IO (stderr) +import Control.Monad (when) +import Data.Bool (bool) +import Data.List.Extra (isSuffixOf) +import Data.Maybe (fromJust, isNothing) +import GHC.IO.Handle.Text (hPutStrLn) +import System.Console.GetOpt ( + ArgDescr (NoArg, ReqArg), + ArgOrder (RequireOrder), + OptDescr (Option), + getOpt, + usageInfo, + ) +import System.Directory ( + createDirectory, + doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory, + ) +import System.Environment (getArgs) +import System.Exit ( + ExitCode (ExitFailure), + exitFailure, + exitSuccess, + exitWith, + ) +import System.IO (stderr) - -import Codegen.Codegen (generateCode) -import Compiler (compile) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) -import LambdaLifter (lambdaLift) -import Monomorphizer.Monomorphizer (monomorphize) -import Renamer.Renamer (rename) -import System.Process (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) +import Codegen.Codegen (generateCode) +import Compiler (compile) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import LambdaLifter (lambdaLift) +import Monomorphizer.Monomorphizer (monomorphize) +import Renamer.Renamer (rename) +import System.Process (spawnCommand, waitForProcess) +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:_, []) - | opts.help || isNothing opts.typechecker -> do - hPutStrLn stderr (usageInfo header flags) - exitSuccess - | otherwise -> pure (opts, f) - where - opts = foldr ($) initOpts os - (_, _, errs) -> do - hPutStrLn stderr (concat errs ++ usageInfo header flags) - exitWith (ExitFailure 1) + (os, f : _, []) + | opts.help || isNothing opts.typechecker -> do + hPutStrLn stderr (usageInfo header flags) + exitSuccess + | otherwise -> pure (opts, f) + where + opts = foldr ($) initOpts os + (_, _, errs) -> do + hPutStrLn stderr (concat errs ++ usageInfo header flags) + 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 - , debug = False - , typechecker = Nothing - } +initOpts = + Options + { 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 - "bi" -> pure Bi - _ -> Nothing + "hm" -> pure Hm + "bi" -> pure Bi + _ -> Nothing data Options = Options - { help :: Bool - , debug :: Bool - , typechecker :: Maybe TypeChecker - } + { help :: Bool + , debug :: Bool + , 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 diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs new file mode 100644 index 0000000..6c95a09 --- /dev/null +++ b/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 diff --git a/tests/DoStrings.hs b/tests/DoStrings.hs new file mode 100644 index 0000000..73580f8 --- /dev/null +++ b/tests/DoStrings.hs @@ -0,0 +1,4 @@ +module DoStrings where + +(>>) str1 str2 = str1 ++ "\n" ++ str2 +(>>=) str1 f = f str1 diff --git a/tests/TestTypeCheckerHm.hs b/tests/TestTypeCheckerHm.hs index b666701..ae298c8 100644 --- a/tests/TestTypeCheckerHm.hs +++ b/tests/TestTypeCheckerHm.hs @@ -1,27 +1,32 @@ +{-# LANGUAGE QualifiedDo #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE QualifiedDo #-} module TestTypeCheckerHm (testTypeCheckerHm) where -import Control.Monad ((<=<)) -import qualified DoStrings as D -import Grammar.Par (myLexer, pProgram) -import Prelude (Bool (..), Either (..), IO, fmap, - not, ($), (.)) -import Test.Hspec +import Control.Monad ((<=<)) +import DoStrings qualified as D +import Grammar.Par (myLexer, pProgram) +import Test.Hspec +import Prelude ( + 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