Removed adhoc tests
This commit is contained in:
sebastianselander
parent
a9f54dbca1
commit
f2e8a02255
3 changed files with 64 additions and 79 deletions
85
src/Main.hs
85
src/Main.hs
|
|
@ -1,47 +1,50 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Grammar.Par (myLexer, pProgram)
|
||||
import Grammar.Print (printTree)
|
||||
import System.Environment (getArgs)
|
||||
import System.Exit (exitFailure, exitSuccess)
|
||||
import Grammar.Par (myLexer, pProgram)
|
||||
-- import TypeChecker.TypeChecker (typecheck)
|
||||
import TypeChecker.Unification (typecheck)
|
||||
import Renamer.Renamer (rename)
|
||||
import Grammar.Print (prt)
|
||||
|
||||
import Grammar.Print (printTree)
|
||||
import Renamer.Renamer (rename)
|
||||
import System.Environment (getArgs)
|
||||
import System.Exit (exitFailure, exitSuccess)
|
||||
import TypeChecker.TypeChecker (typecheck)
|
||||
|
||||
main :: IO ()
|
||||
main = getArgs >>= \case
|
||||
[] -> print "Required file path missing"
|
||||
(x:_) -> do
|
||||
file <- readFile x
|
||||
case pProgram (myLexer file) of
|
||||
Left err -> do
|
||||
putStrLn "SYNTAX ERROR"
|
||||
putStrLn err
|
||||
exitFailure
|
||||
Right prg -> do
|
||||
putStrLn ""
|
||||
putStrLn " ----- PARSER ----- "
|
||||
putStrLn ""
|
||||
putStrLn . printTree $ prg
|
||||
case rename prg of
|
||||
Left err -> do
|
||||
putStrLn "FAILED RENAMING"
|
||||
putStrLn . show $ err
|
||||
exitFailure
|
||||
Right prg ->do
|
||||
putStrLn ""
|
||||
putStrLn " ----- RENAMER ----- "
|
||||
putStrLn ""
|
||||
putStrLn . printTree $ prg
|
||||
case typecheck prg of
|
||||
Left err -> do
|
||||
putStrLn "TYPECHECK ERROR"
|
||||
putStrLn . show $ err
|
||||
exitFailure
|
||||
Right prg -> do
|
||||
putStrLn ""
|
||||
putStrLn " ----- TYPECHECKER ----- "
|
||||
putStrLn ""
|
||||
putStrLn . show $ prg
|
||||
main =
|
||||
getArgs >>= \case
|
||||
[] -> print "Required file path missing"
|
||||
(x : _) -> do
|
||||
file <- readFile x
|
||||
case pProgram (myLexer file) of
|
||||
Left err -> do
|
||||
putStrLn "SYNTAX ERROR"
|
||||
putStrLn err
|
||||
exitFailure
|
||||
Right prg -> do
|
||||
putStrLn ""
|
||||
putStrLn " ----- PARSER ----- "
|
||||
putStrLn ""
|
||||
putStrLn . printTree $ prg
|
||||
case rename prg of
|
||||
Left err -> do
|
||||
putStrLn "FAILED RENAMING"
|
||||
print err
|
||||
exitFailure
|
||||
Right prg -> do
|
||||
putStrLn ""
|
||||
putStrLn " ----- RENAMER ----- "
|
||||
putStrLn ""
|
||||
putStrLn . printTree $ prg
|
||||
case typecheck prg of
|
||||
Left err -> do
|
||||
putStrLn "TYPECHECK ERROR"
|
||||
print err
|
||||
exitFailure
|
||||
Right prg -> do
|
||||
putStrLn ""
|
||||
putStrLn " ----- TYPECHECKER ----- "
|
||||
putStrLn ""
|
||||
putStrLn . printTree $ prg
|
||||
exitSuccess
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ import TypeChecker.TypeCheckerIr
|
|||
|
||||
data Ctx = Ctx
|
||||
{ vars :: Map Integer Type
|
||||
, sigs :: Map Ident Type
|
||||
, sigs :: Map Ident (RBind, Maybe Type)
|
||||
, nextFresh :: Int
|
||||
}
|
||||
deriving (Show)
|
||||
|
|
@ -52,12 +52,16 @@ inferPrg (RProgram xs) = do
|
|||
xs' <- mapM inferBind xs
|
||||
return $ TProgram xs'
|
||||
|
||||
-- Binds are not correctly added to the context.
|
||||
-- Can't type check programs with more than one function currently
|
||||
inferBind :: RBind -> Infer TBind
|
||||
inferBind (RBind name e) = do
|
||||
inferBind b@(RBind name e) = do
|
||||
insertSigs name b Nothing
|
||||
(t, e') <- inferExp e
|
||||
insertSigs name t
|
||||
return $ TBind name t e'
|
||||
|
||||
-- Have to figure out a way to coerce polymorphic types to monomorphic ones where necessary
|
||||
-- { \x. \y. x + y } will have the type { a -> b -> Int }
|
||||
inferExp :: RExp -> Infer (Type, TExp)
|
||||
inferExp = \case
|
||||
RAnn expr typ -> do
|
||||
|
|
@ -68,8 +72,14 @@ inferExp = \case
|
|||
t <- lookupVars num
|
||||
return (t, TBound num name t)
|
||||
RFree name -> do
|
||||
t <- lookupSigs name
|
||||
return (t, TFree name t)
|
||||
(b@(RBind name _), t) <- lookupSigs name
|
||||
t' <- case t of
|
||||
Nothing -> do
|
||||
(TBind _ a _) <- inferBind b
|
||||
insertSigs name b (Just a)
|
||||
return a
|
||||
Just a -> return a
|
||||
return (t', TFree name t')
|
||||
RConst (CInt i) -> return (TMono "Int", TConst (CInt i) (TMono "Int"))
|
||||
RConst (CStr str) -> return (TMono "Str", TConst (CStr str) (TMono "Str"))
|
||||
RAdd expr1 expr2 -> do
|
||||
|
|
@ -126,17 +136,17 @@ insertVars i t = do
|
|||
st <- St.get
|
||||
St.put (st {vars = M.insert i t st.vars})
|
||||
|
||||
lookupSigs :: Ident -> Infer Type
|
||||
lookupSigs :: Ident -> Infer (RBind, Maybe Type)
|
||||
lookupSigs i = do
|
||||
st <- St.gets sigs
|
||||
case M.lookup i st of
|
||||
Just t -> return t
|
||||
Nothing -> throwError $ UnboundVar "lookupSigs"
|
||||
|
||||
insertSigs :: Ident -> Type -> Infer ()
|
||||
insertSigs i t = do
|
||||
insertSigs :: Ident -> RBind -> Maybe Type -> Infer ()
|
||||
insertSigs i b t = do
|
||||
st <- St.get
|
||||
St.put (st {sigs = M.insert i t st.sigs})
|
||||
St.put (st {sigs = M.insert i (b, t) st.sigs})
|
||||
|
||||
{-# WARNING todo "TODO IN CODE" #-}
|
||||
todo :: a
|
||||
|
|
@ -151,29 +161,3 @@ data Error
|
|||
| AnnotatedMismatch String
|
||||
| Default String
|
||||
deriving (Show)
|
||||
|
||||
-- Tests
|
||||
|
||||
-- (\x. x + 1) 1
|
||||
app_lambda :: RExp
|
||||
app_lambda = app lambda one
|
||||
|
||||
lambda :: RExp
|
||||
lambda = RAbs 0 "x" $ add bound one
|
||||
|
||||
add :: RExp -> RExp -> RExp
|
||||
add = RAdd
|
||||
|
||||
bound = RBound 0 "x"
|
||||
|
||||
app :: RExp -> RExp -> RExp
|
||||
app = RApp
|
||||
|
||||
one :: RExp
|
||||
one = RConst (CInt 1)
|
||||
|
||||
fn_t = TArrow (TPoly (Ident "0")) (TMono (Ident "Int"))
|
||||
|
||||
arr_t = TArrow (TMono "Int") (TPoly "1")
|
||||
|
||||
f_x = RAbs 0 "f" (RAbs 1 "x" (RApp (RBound 0 "f") (RBound 1 "x")))
|
||||
|
|
|
|||
|
|
@ -1,3 +1 @@
|
|||
apply w x = \y. \z. w + x + y + z ;
|
||||
|
||||
main = apply 1 2 3 4 ;
|
||||
apply = \x. \y. (x : Mono Int)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue