From 8910d8adc01eff7051fb89aa9c910d8de3ef1797 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 28 Mar 2023 17:13:51 +0200 Subject: [PATCH] temporary commit incase of breakage --- Grammar.cf | 1 + language.cabal | 3 +- src/Desugar/Desugar.hs | 32 +++++++++++++ src/Main.hs | 78 +++++++++++++++++++------------- src/TypeChecker/TypeCheckerHm.hs | 44 +++++++++++++++--- test_program.crf | 5 +- 6 files changed, 118 insertions(+), 45 deletions(-) create mode 100644 src/Desugar/Desugar.hs diff --git a/Grammar.cf b/Grammar.cf index 55763f4..9ca0db6 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -48,6 +48,7 @@ EVar. Exp3 ::= LIdent; EInj. Exp3 ::= UIdent; ELit. Exp3 ::= Lit; EApp. Exp2 ::= Exp2 Exp3; +EAppInf. Exp2 ::= Exp3 "`" Exp3 "`"; EAdd. Exp1 ::= Exp1 "+" Exp2; ELet. Exp ::= "let" Bind "in" Exp; EAbs. Exp ::= "\\" LIdent "." Exp; diff --git a/language.cabal b/language.cabal index 9785d75..922f873 100644 --- a/language.cabal +++ b/language.cabal @@ -44,9 +44,8 @@ executable language Codegen.LlvmIr Compiler Renamer.Renamer - --Codegen.Codegen - --Codegen.LlvmIr TreeConverter + Desugar.Desugar hs-source-dirs: src diff --git a/src/Desugar/Desugar.hs b/src/Desugar/Desugar.hs new file mode 100644 index 0000000..f67fa05 --- /dev/null +++ b/src/Desugar/Desugar.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE LambdaCase #-} + +module Desugar.Desugar where + +import Data.Function (on) +import Grammar.Abs + +desugar :: Program -> Program +desugar (Program defs) = Program (map desugarDef defs) + +desugarDef :: Def -> Def +desugarDef = \case + DBind b -> DBind (desugarBind b) + DSig sig -> DSig sig + DData d -> DData d + +desugarBind :: Bind -> Bind +desugarBind (Bind name args e) = Bind name args (desugarExp e) + +desugarExp :: Exp -> Exp +desugarExp = \case + EAppInf e2 e1 -> (EApp `on` desugarExp) e1 e2 + EApp e1 e2 -> (EApp `on` desugarExp) e1 e2 + EAdd e1 e2 -> (EAdd `on` desugarExp) e1 e2 + EAbs i e -> EAbs i (desugarExp e) + ELet b e -> ELet (desugarBind b) (desugarExp e) + ECase e br -> ECase (desugarExp e) (map desugarBranch br) + EAnn e t -> EAnn (desugarExp e) t + e -> e + +desugarBranch :: Branch -> Branch +desugarBranch (Branch p e) = Branch p (desugarExp e) diff --git a/src/Main.hs b/src/Main.hs index 1b02c09..32f4443 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,34 +2,44 @@ module Main where -import Codegen.Codegen (generateCode) -import Compiler (compile) -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 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.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 System.Process (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) +import Codegen.Codegen (generateCode) +import Compiler (compile) +import Control.Monad (when) +import Data.Bool (bool) +import Data.List.Extra (isSuffixOf) +import Data.Maybe (fromJust, isNothing) +import Desugar.Desugar (desugar) +import GHC.IO.Handle.Text (hPutStrLn) +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.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 System.Process (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) main :: IO () main = getArgs >>= parseArgs >>= uncurry main' @@ -76,11 +86,11 @@ chooseTypechecker s options = options{typechecker = tc} tc = case s of "hm" -> pure Hm "bi" -> pure Bi - _ -> Nothing + _ -> Nothing data Options = Options - { help :: Bool - , debug :: Bool + { help :: Bool + , debug :: Bool , typechecker :: Maybe TypeChecker } @@ -92,8 +102,12 @@ main' opts s = do parsed <- fromSyntaxErr . pProgram $ myLexer file bool (printToErr $ printTree parsed) (printToErr $ show parsed) opts.debug + printToErr "-- Desugar --" + let desugared = desugar parsed + bool (printToErr $ printTree desugared) (printToErr $ show desugared) opts.debug + printToErr "\n-- Renamer --" - renamed <- fromRenamerErr . rename $ parsed + renamed <- fromRenamerErr . rename $ desugared bool (printToErr $ printTree renamed) (printToErr $ show renamed) opts.debug printToErr "\n-- TypeChecker --" diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 0cb8a4a..13716cd 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -21,6 +21,7 @@ import Data.Map qualified as M import Data.Maybe (fromJust) import Data.Set (Set) import Data.Set qualified as S +import Debug.Trace (trace) import Grammar.Abs import Grammar.Print (printTree) import TypeChecker.TypeCheckerIr qualified as T @@ -96,7 +97,8 @@ checkBind (Bind name args e) = do s <- gets sigs case M.lookup (coerce name) s of Just (Just t') -> do - let fsig = apply sub0 t' + sab <- unify t' lambda_t + let fsig = apply (sab `compose` sub0) t' sub1 <- liftEither $ runIdentity $ runExceptT $ execStateT (typeEq fsig lambda_t) mempty sub2 <- liftEither $ runIdentity $ runExceptT $ execStateT (typeEq lambda_t fsig) mempty unless @@ -314,6 +316,7 @@ algoW = \case (subst, injs, ret_t) <- checkCase t injs let comp = subst `compose` sub return (comp, apply comp (T.ECase (e', t) injs, ret_t)) + EAppInf{} -> error "desugar phase failed" checkCase :: Type -> [Branch] -> Infer (Subst, [T.Branch' Type], Type) checkCase _ [] = catchableErr "Atleast one case required" @@ -687,15 +690,42 @@ typeEq (TVar (MkTVar a)) t@(TVar _) = do st <- get case M.lookup (coerce a) st of Nothing -> put $ M.insert (coerce a) t st - Just t' -> unless (t == t') (catchableErr "TYPE MISMATCH") + Just t' -> + unless + (t == t') + ( catchableErr $ Aux.do + quote $ printTree t + "does not match with" + quote $ printTree t' + ) typeEq (TFun l r) (TFun l' r') = typeEq l l' *> typeEq r r' typeEq (TAll _ l) (TAll _ r) = typeEq l r -typeEq (TLit a) (TLit b) = unless (a == b) (catchableErr "TYPE MISMATCH") -typeEq (TData nameL tL) (TData nameR tR) = do - unless (nameL == nameR) (catchableErr "TYPE MISMATCH") +typeEq t@(TLit a) t'@(TLit b) = + unless + (a == b) + ( catchableErr $ Aux.do + quote $ printTree t + "does not match with" + quote $ printTree t' + ) +typeEq t@(TData nameL tL) t'@(TData nameR tR) = do + unless + (nameL == nameR) + ( catchableErr $ Aux.do + quote $ printTree t + "does not match with" + quote $ printTree t' + ) zipWithM_ typeEq tL tR -typeEq (TEVar _) (TEVar _) = catchableErr "TYPE MISMATCH" -typeEq _ _ = catchableErr "TYPE MISMATCH" +typeEq t@(TEVar _) t'@(TEVar _) = + catchableErr $ Aux.do + quote $ printTree t + "does not match with" + quote $ printTree t' +typeEq t t' = catchableErr $ Aux.do + quote $ printTree t + "does not match with" + quote $ printTree t' {- | Catch an error if possible and add the given expression as addition to the error message diff --git a/test_program.crf b/test_program.crf index 8cee923..bdce08c 100644 --- a/test_program.crf +++ b/test_program.crf @@ -1,5 +1,2 @@ -id x = x; - +main = const 1 2 ; const x y = x ; - -main = const (id 0) (id 'a') ;