hm is compatible
This commit is contained in:
sebastianselander
parent
6e54378327
commit
d5ce73beae
4 changed files with 106 additions and 69 deletions
124
src/Main.hs
124
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
|
||||
|
||||
|
|
|
|||
18
src/TypeChecker/TypeChecker.hs
Normal file
18
src/TypeChecker/TypeChecker.hs
Normal file
|
|
@ -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
|
||||
4
tests/DoStrings.hs
Normal file
4
tests/DoStrings.hs
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
module DoStrings where
|
||||
|
||||
(>>) str1 str2 = str1 ++ "\n" ++ str2
|
||||
(>>=) str1 f = f str1
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue