Typeinference/checking on expressions done.
Simplified the typechecker a bit, removed GADT solution for now. Still not fully working
This commit is contained in:
sebastianselander
parent
b6b2dfa25f
commit
be3fcfc9e3
5 changed files with 153 additions and 63 deletions
|
|
@ -9,9 +9,9 @@ separator Type "->";
|
|||
|
||||
EId. Exp3 ::= Ident ;
|
||||
EInt. Exp3 ::= Integer ;
|
||||
-- EApp. Exp2 ::= Exp2 Exp3 ;
|
||||
EApp. Exp2 ::= Exp2 Exp3 ;
|
||||
EAdd. Exp1 ::= Exp1 "+" Exp2 ;
|
||||
-- EAbs. Exp ::= "\\" Ident ":" Type "." Exp ;
|
||||
EAbs. Exp ::= "\\" Ident ":" Type "." Exp ;
|
||||
coercions Exp 3 ;
|
||||
|
||||
TInt. Type1 ::= "Int" ;
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ extra-source-fiels:
|
|||
|
||||
|
||||
common warnings
|
||||
ghc-options: -Wall
|
||||
ghc-options: -W
|
||||
|
||||
executable language
|
||||
import: warnings
|
||||
|
|
@ -30,8 +30,10 @@ executable language
|
|||
Grammar.Par
|
||||
Grammar.Print
|
||||
Grammar.Skel
|
||||
Grammar.ErrM
|
||||
Interpreter
|
||||
TypeChecker
|
||||
NewAbs
|
||||
|
||||
hs-source-dirs: src
|
||||
|
||||
|
|
|
|||
30
src/Main.hs
30
src/Main.hs
|
|
@ -4,6 +4,7 @@ module Main where
|
|||
import Control.Monad.Except (runExcept)
|
||||
import Grammar.Par (myLexer, pProgram)
|
||||
import Interpreter (interpret)
|
||||
import TypeChecker (typecheck)
|
||||
import System.Environment (getArgs)
|
||||
import System.Exit (exitFailure, exitSuccess)
|
||||
|
||||
|
|
@ -13,18 +14,23 @@ main = getArgs >>= \case
|
|||
(x:_) -> do
|
||||
file <- readFile x
|
||||
case pProgram (myLexer file) of
|
||||
Left err -> do
|
||||
putStrLn "SYNTAX ERROR"
|
||||
putStrLn err
|
||||
exitFailure
|
||||
Right prg -> case runExcept $ interpret prg of
|
||||
Left err -> do
|
||||
putStrLn "INTERPRETER ERROR"
|
||||
putStrLn err
|
||||
exitFailure
|
||||
Right i -> do
|
||||
print i
|
||||
exitSuccess
|
||||
Left err -> do
|
||||
putStrLn "SYNTAX ERROR"
|
||||
putStrLn err
|
||||
exitFailure
|
||||
Right p -> case typecheck p of
|
||||
Left err -> do
|
||||
putStrLn "TYPECHECKING ERROR"
|
||||
putStrLn err
|
||||
exitFailure
|
||||
Right prg -> case runExcept $ interpret prg of
|
||||
Left err -> do
|
||||
putStrLn "INTERPRETER ERROR"
|
||||
putStrLn err
|
||||
exitFailure
|
||||
Right i -> do
|
||||
print i
|
||||
exitSuccess
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
29
src/NewAbs.hs
Normal file
29
src/NewAbs.hs
Normal file
|
|
@ -0,0 +1,29 @@
|
|||
{-# LANGUAGE GADTs, LambdaCase #-}
|
||||
|
||||
module NewAbs where
|
||||
|
||||
import Grammar.Abs ( Ident(..), Type )
|
||||
|
||||
data CExp where
|
||||
CId :: Type -> Ident -> CExp
|
||||
CInt :: Type -> Int -> CExp
|
||||
CAdd :: Type -> CExp -> CExp -> CExp
|
||||
CAbs :: Type -> Ident -> Type -> CExp -> CExp
|
||||
CApp :: Type -> CExp -> CExp -> CExp
|
||||
|
||||
instance Show CExp where
|
||||
show :: CExp -> String
|
||||
show = \case
|
||||
CId _ (Ident a) -> show a
|
||||
CInt _ i -> show i
|
||||
CAdd _ e1 e2 -> show e1 <> " + " <> show e2
|
||||
CAbs t1 i t2 e -> appendType t1 $ show "\\" <> show i <> " : " <> show t2 <> ". " <> show e
|
||||
CApp _ e1 e2 -> show e1 <> " " <> show e2
|
||||
|
||||
appendType :: Type -> String -> String
|
||||
appendType t s = s <> " : " <> show t
|
||||
|
||||
data CDef = CDef Ident Type Ident [Ident] CExp
|
||||
deriving Show
|
||||
|
||||
newtype CProgram = CProgram [CDef]
|
||||
|
|
@ -1,76 +1,129 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
|
||||
module TypeChecker where
|
||||
module TypeChecker (typecheck) where
|
||||
|
||||
import Grammar.Abs
|
||||
import Grammar.ErrM
|
||||
import Data.Kind qualified as T
|
||||
import Data.String qualified
|
||||
import Grammar.ErrM ( Err )
|
||||
import NewAbs
|
||||
import Data.Map (Map)
|
||||
import Data.Map qualified as Map
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Except
|
||||
import Data.List (isPrefixOf)
|
||||
import Control.Applicative ((<|>))
|
||||
|
||||
newtype Env = Env { signature :: Map Ident CType }
|
||||
type Check a = ReaderT Context Err a
|
||||
|
||||
type Check a = ReaderT Env Err a
|
||||
data Context = Ctx { sig :: Map Ident Type
|
||||
, env :: [Map Ident Type]
|
||||
}
|
||||
|
||||
initEnv :: Env
|
||||
initEnv = Env { signature = mempty }
|
||||
initEnv :: Context
|
||||
initEnv = Ctx { sig = mempty
|
||||
, env = mempty
|
||||
}
|
||||
|
||||
run :: Check a -> Either String a
|
||||
run = flip runReaderT initEnv
|
||||
|
||||
checkProg :: Program -> Check Program
|
||||
checkProg (Program ds) = Program <$> mapM checkDef ds
|
||||
typecheck :: Program -> Err Program
|
||||
typecheck prg = case run $ checkProg prg of
|
||||
Left err -> fail err
|
||||
Right _ -> pure prg
|
||||
|
||||
|
||||
checkProg :: Program -> Check CProgram
|
||||
checkProg (Program ds) = undefined
|
||||
|
||||
checkDef :: Def -> Check Def
|
||||
checkDef = \case
|
||||
(DExp n1 TInt n2 params e) -> undefined
|
||||
(DExp n1 (TPol (Ident t)) n2 params e) -> undefined
|
||||
(DExp n1 ts n2 params e) -> undefined
|
||||
checkDef :: Def -> Check CDef
|
||||
checkDef (DExp i1 TInt i2 args e) = undefined
|
||||
checkDef (DExp i1 (TPol i) i2 args e) = undefined
|
||||
checkDef (DExp i1 (TFun xs) i2 args e) = do
|
||||
when (i1 /= i2) (fail $ "Mismatched names: " <> show i1 <> " != " <> show i2)
|
||||
case compare (length xs - 1) (length args) of
|
||||
LT -> fail $ "Too many arguments, got " <> show (length args) <> " expected " <> show (length xs)
|
||||
_ -> do
|
||||
let vars = Map.fromList $ zip args xs
|
||||
e' <- local (\r -> r { env = [vars] }) (checkExp e)
|
||||
return $ CDef i1 (TFun xs) i2 args e'
|
||||
|
||||
class Typecheck a where
|
||||
checkExp :: Exp -> Check (CExp a)
|
||||
checkExp :: Exp -> Check CExp
|
||||
checkExp = \case
|
||||
|
||||
instance Typecheck Int where
|
||||
checkExp = \case
|
||||
EInt i -> pure $ CInt (fromIntegral i)
|
||||
EAdd e1 e2 -> do
|
||||
e1' <- checkExp @Int e1
|
||||
e2' <- checkExp @Int e2
|
||||
return $ CAdd e1' e2'
|
||||
EId (Ident i) -> asks (lookupSig (Ident i)) >>= liftEither >>= \case
|
||||
TCInt -> pure (CId (CIdent i))
|
||||
_ -> throwError $ "Unbound variable " <> show i
|
||||
EInt i -> pure $ CInt TInt (fromIntegral i)
|
||||
|
||||
data CExp :: T.Type -> T.Type where
|
||||
CId :: CIdent -> CExp a
|
||||
CInt :: Int -> CExp Int
|
||||
CAdd :: Num a => CExp a -> CExp a -> CExp a
|
||||
EAdd e1 e2 -> do
|
||||
e1' <- checkExp e1
|
||||
e2' <- checkExp e2
|
||||
let t1 = getType e1'
|
||||
let t2 = getType e2'
|
||||
when (t1 /= t2) (fail $ "Different types occured, got " <> show t1 <> " and " <> show t2)
|
||||
return $ CAdd t1 e1' e2'
|
||||
|
||||
instance Show (CExp a) where
|
||||
show = \case
|
||||
CId (CIdent a) -> show a
|
||||
CInt i -> show i
|
||||
CAdd e1 e2 -> show e1 <> " + " <> show e2
|
||||
EId i -> do
|
||||
asks (lookupEnv i) >>= \case
|
||||
Right t -> return $ CId t i
|
||||
Left _ -> asks (lookupSig i) >>= \case
|
||||
Right t -> return $ CId t i
|
||||
Left x -> fail x
|
||||
|
||||
data CDef a = CDef CIdent CType CIdent [CIdent] (CExp a)
|
||||
deriving Show
|
||||
EAbs i t e -> do
|
||||
e' <- local (\r -> r { env = Map.singleton i t : r.env }) (checkExp e)
|
||||
return $ CAbs (TFun [t, getType e']) i t e'
|
||||
|
||||
newtype CProgram = CProgram [Def]
|
||||
EApp e1 e2 -> do
|
||||
e1' <- checkExp e1
|
||||
e2' <- checkExp e2
|
||||
let retT = applyType (getType e1') (getType e2')
|
||||
case retT of
|
||||
Left x -> fail x
|
||||
Right t -> return $ CApp t e1' e2'
|
||||
|
||||
data CType = TCInt | TCPol Ident | TCFun Type Type
|
||||
deriving (Eq, Ord, Show, Read)
|
||||
lookupSig :: Ident -> Context -> Err Type
|
||||
lookupSig i (Ctx s _) = case Map.lookup i s of
|
||||
Nothing -> throwError $ "Undefined function: " <> show i
|
||||
Just x -> pure x
|
||||
|
||||
newtype CIdent = CIdent String
|
||||
deriving (Eq, Ord, Show, Read, Data.String.IsString)
|
||||
|
||||
lookupSig :: Ident -> Env -> Err CType
|
||||
lookupSig i (Env m) = case Map.lookup i m of
|
||||
Nothing -> throwError $ "Unbound variable: " <> show i
|
||||
lookupEnv :: Ident -> Context -> Err Type
|
||||
lookupEnv i (Ctx _ []) = throwError $ "Unbound variable: " <> show i
|
||||
lookupEnv i (Ctx s (e:es)) = case Map.lookup i e of
|
||||
Nothing -> lookupEnv i (Ctx s es)
|
||||
Just x -> pure x
|
||||
|
||||
|
||||
applyType :: Type -> Type -> Err Type
|
||||
applyType (TFun (x:xs)) t = case t of
|
||||
(TFun ys) -> if ys `isPrefixOf` (x:xs)
|
||||
then return . TFun $ drop (length ys) (x:xs)
|
||||
else fail $ "Mismatched types, expected " <> show x <> " got " <> show TInt
|
||||
applyType t1 t2 = fail $ "Can not apply " <> show t1 <> " to " <> show t2
|
||||
|
||||
class ExtractType a where
|
||||
getType :: a -> Type
|
||||
|
||||
instance ExtractType CExp where
|
||||
getType = \case
|
||||
CId t _ -> t
|
||||
CInt t _ -> t
|
||||
CAdd t _ _ -> t
|
||||
CAbs t _ _ _ -> t
|
||||
CApp t _ _ -> t
|
||||
|
||||
-- | λx : Int. x + 3 + 5
|
||||
customLambda1 :: Exp
|
||||
customLambda1 = EAbs (Ident "x") TInt (EAdd (EId (Ident "x")) (EAdd (EInt 3) (EInt 5)))
|
||||
|
||||
customLambda2 :: Exp
|
||||
customLambda2 = EAbs (Ident "x") (TFun [TInt, TInt]) (EId (Ident "f"))
|
||||
|
||||
-- | main : Int
|
||||
-- main = λx : Int. x + 3 + 5
|
||||
customPrg1 :: Program
|
||||
customPrg1 = Program [DExp (Ident "main") TInt (Ident "main") [] customLambda1]
|
||||
|
||||
-- | main : Int -> Int
|
||||
-- main = λx : Int. x + 3 + 5
|
||||
customPrg2 :: Program
|
||||
customPrg2 = Program [DExp (Ident "main") (TFun [TInt, TInt]) (Ident "main") [] customLambda2]
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue