hm is compatible
This commit is contained in:
parent
6e54378327
commit
d5ce73beae
4 changed files with 106 additions and 69 deletions
42
src/Main.hs
42
src/Main.hs
|
|
@ -7,21 +7,29 @@ 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 (
|
||||||
|
ArgDescr (NoArg, ReqArg),
|
||||||
ArgOrder (RequireOrder),
|
ArgOrder (RequireOrder),
|
||||||
OptDescr (Option), getOpt,
|
OptDescr (Option),
|
||||||
usageInfo)
|
getOpt,
|
||||||
import System.Directory (createDirectory, doesPathExist,
|
usageInfo,
|
||||||
|
)
|
||||||
|
import System.Directory (
|
||||||
|
createDirectory,
|
||||||
|
doesPathExist,
|
||||||
getDirectoryContents,
|
getDirectoryContents,
|
||||||
removeDirectoryRecursive,
|
removeDirectoryRecursive,
|
||||||
setCurrentDirectory)
|
setCurrentDirectory,
|
||||||
|
)
|
||||||
import System.Environment (getArgs)
|
import System.Environment (getArgs)
|
||||||
import System.Exit (ExitCode (ExitFailure),
|
import System.Exit (
|
||||||
exitFailure, exitSuccess,
|
ExitCode (ExitFailure),
|
||||||
exitWith)
|
exitFailure,
|
||||||
|
exitSuccess,
|
||||||
|
exitWith,
|
||||||
|
)
|
||||||
import System.IO (stderr)
|
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)
|
||||||
|
|
@ -38,7 +46,7 @@ main = getArgs >>= parseArgs >>= uncurry main'
|
||||||
|
|
||||||
parseArgs :: [String] -> IO (Options, String)
|
parseArgs :: [String] -> IO (Options, String)
|
||||||
parseArgs argv = case getOpt RequireOrder flags argv of
|
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
|
||||||
|
|
@ -59,19 +67,21 @@ flags =
|
||||||
]
|
]
|
||||||
|
|
||||||
initOpts :: Options
|
initOpts :: Options
|
||||||
initOpts = Options { help = False
|
initOpts =
|
||||||
|
Options
|
||||||
|
{ help = False
|
||||||
, debug = False
|
, debug = False
|
||||||
, typechecker = Nothing
|
, typechecker = Nothing
|
||||||
}
|
}
|
||||||
|
|
||||||
enableHelp :: Options -> Options
|
enableHelp :: Options -> Options
|
||||||
enableHelp opts = opts { help = True }
|
enableHelp opts = opts{help = True}
|
||||||
|
|
||||||
enableDebug :: Options -> Options
|
enableDebug :: Options -> Options
|
||||||
enableDebug opts = opts { debug = True }
|
enableDebug opts = opts{debug = True}
|
||||||
|
|
||||||
chooseTypechecker :: String -> Options -> Options
|
chooseTypechecker :: String -> Options -> Options
|
||||||
chooseTypechecker s options = options { typechecker = tc }
|
chooseTypechecker s options = options{typechecker = tc}
|
||||||
where
|
where
|
||||||
tc = case s of
|
tc = case s of
|
||||||
"hm" -> pure Hm
|
"hm" -> pure Hm
|
||||||
|
|
@ -110,12 +120,12 @@ main' opts s = do
|
||||||
--
|
--
|
||||||
printToErr "\n -- Compiler --"
|
printToErr "\n -- Compiler --"
|
||||||
generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked)
|
generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked)
|
||||||
--putStrLn generatedCode
|
-- putStrLn generatedCode
|
||||||
|
|
||||||
check <- doesPathExist "output"
|
check <- doesPathExist "output"
|
||||||
when check (removeDirectoryRecursive "output")
|
when check (removeDirectoryRecursive "output")
|
||||||
createDirectory "output"
|
createDirectory "output"
|
||||||
when debug $ do
|
when opts.debug $ do
|
||||||
_ <- writeFile "output/llvm.ll" generatedCode
|
_ <- writeFile "output/llvm.ll" generatedCode
|
||||||
debugDotViz
|
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 NoImplicitPrelude #-}
|
|
||||||
{-# LANGUAGE QualifiedDo #-}
|
{-# LANGUAGE QualifiedDo #-}
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
|
||||||
module TestTypeCheckerHm (testTypeCheckerHm) where
|
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,
|
|
||||||
not, ($), (.))
|
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
|
import Prelude (
|
||||||
|
Bool (..),
|
||||||
|
Either (..),
|
||||||
|
IO,
|
||||||
|
fmap,
|
||||||
|
not,
|
||||||
|
($),
|
||||||
|
(.),
|
||||||
|
)
|
||||||
|
|
||||||
-- import Test.QuickCheck
|
-- import Test.QuickCheck
|
||||||
import TypeChecker.TypeCheckerHm (typecheck)
|
import TypeChecker.TypeCheckerHm (typecheck)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
testTypeCheckerHm = describe "Hillner Milner type checker test" $ do
|
testTypeCheckerHm = describe "Hillner Milner type checker test" $ do
|
||||||
ok1
|
ok1
|
||||||
ok2
|
ok2
|
||||||
bad1
|
bad1
|
||||||
bad2
|
bad2
|
||||||
-- bad3
|
|
||||||
|
|
||||||
|
-- bad3
|
||||||
|
|
||||||
ok1 =
|
ok1 =
|
||||||
specify "Basic polymorphism with multiple type variables" $
|
specify "Basic polymorphism with multiple type variables" $
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue