From f8a70b4cf400f817b51617b68878c71468690582 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Wed, 3 May 2023 17:58:50 +0200 Subject: [PATCH] Improved error messages --- src/AnnForall.hs | 90 +++++++++++++++++++++++--------------------- src/Codegen/Emits.hs | 52 ++++++++++++------------- 2 files changed, 74 insertions(+), 68 deletions(-) diff --git a/src/AnnForall.hs b/src/AnnForall.hs index 16222bd..f309a37 100644 --- a/src/AnnForall.hs +++ b/src/AnnForall.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} module AnnForall (annotateForall) where -import Auxiliary (partitionDefs) -import Control.Applicative (Applicative (liftA2)) -import Control.Monad.Except (throwError) -import Data.Function (on) -import Data.Set (Set) -import qualified Data.Set as Set -import Grammar.Abs -import Grammar.ErrM (Err) +import Auxiliary (partitionDefs) +import Control.Applicative (Applicative (liftA2)) +import Control.Monad.Except (throwError) +import Data.Function (on) +import Data.Set (Set) +import Data.Set qualified as Set +import Grammar.Abs +import Grammar.ErrM (Err) annotateForall :: Program -> Err Program annotateForall (Program defs) = do @@ -21,30 +21,31 @@ annotateForall (Program defs) = do ss' = map (DSig . annSig) ss (ds, ss, bs) = partitionDefs defs - annData :: Data -> Err Data annData (Data typ injs) = do - (typ', tvars) <- annTyp typ - pure (Data typ' $ map (annInj tvars) injs) - + (typ', tvars) <- annTyp typ + pure (Data typ' $ map (annInj tvars) injs) where annTyp typ = do (bounded, ts) <- boundedTVars mempty typ unbounded <- Set.fromList <$> mapM assertTVar ts let diff = unbounded Set.\\ bounded typ' = foldr TAll typ diff - (typ', ) . fst <$> boundedTVars mempty typ' + (typ',) . fst <$> boundedTVars mempty typ' where boundedTVars tvars typ = case typ of - TAll tvar t -> boundedTVars (Set.insert tvar tvars) t - TData _ ts -> pure (tvars, ts) - _ -> throwError "Misformed data declaration" + TAll tvar t -> boundedTVars (Set.insert tvar tvars) t + TData _ ts -> pure (tvars, ts) + _ -> throwError "Misformed data declaration" assertTVar typ = case typ of TVar tvar -> pure tvar - _ -> throwError $ unwords [ "Misformed data declaration:" - , "Non type variable argument" - ] + _ -> + throwError $ + unwords + [ "Misformed data declaration:" + , "Non type variable argument" + ] annInj tvars (Inj n t) = Inj n $ foldr TAll t (unboundedTVars t Set.\\ tvars) @@ -55,20 +56,22 @@ annBind :: Bind -> Err Bind annBind (Bind name vars exp) = Bind name vars <$> annExp exp where annExp = \case - EAnn e t -> flip EAnn (annType t) <$> annExp e - EApp e1 e2 -> liftA2 EApp (annExp e1) (annExp e2) - EAdd e1 e2 -> liftA2 EAdd (annExp e1) (annExp e2) + -- Annotated types should not be + -- foralled without the consent of the user + EAnn e t -> flip EAnn t <$> annExp e + EApp e1 e2 -> liftA2 EApp (annExp e1) (annExp e2) + EAdd e1 e2 -> liftA2 EAdd (annExp e1) (annExp e2) ELet bind e -> liftA2 ELet (annBind bind) (annExp e) - EAbs x e -> EAbs x <$> annExp e - ECase e bs -> liftA2 ECase (annExp e) (mapM annBranch bs) - e -> pure e + EAbs x e -> EAbs x <$> annExp e + ECase e bs -> liftA2 ECase (annExp e) (mapM annBranch bs) + e -> pure e annBranch (Branch p e) = Branch p <$> annExp e annType :: Type -> Type annType typ = go $ unboundedTVars typ where go us - | null us = typ + | null us = typ | otherwise = foldr TAll typ us unboundedTVars :: Type -> Set TVar @@ -79,22 +82,25 @@ unboundedTVars' bs typ = tvars.unbounded Set.\\ tvars.bounded where tvars = gatherTVars typ gatherTVars = \case - TAll tvar t -> TVars { bounded = Set.singleton tvar - , unbounded = unboundedTVars' (Set.insert tvar bs) t - } - TVar tvar -> uTVars $ Set.singleton tvar - TFun t1 t2 -> uTVars $ on Set.union (unboundedTVars' bs) t1 t2 - TData _ typs -> uTVars $ foldr (Set.union . unboundedTVars' bs) mempty typs - _ -> TVars { bounded = mempty, unbounded = mempty } + TAll tvar t -> + TVars + { bounded = Set.singleton tvar + , unbounded = unboundedTVars' (Set.insert tvar bs) t + } + TVar tvar -> uTVars $ Set.singleton tvar + TFun t1 t2 -> uTVars $ on Set.union (unboundedTVars' bs) t1 t2 + TData _ typs -> uTVars $ foldr (Set.union . unboundedTVars' bs) mempty typs + _ -> TVars{bounded = mempty, unbounded = mempty} data TVars = TVars - { bounded :: Set TVar - , unbounded :: Set TVar - } deriving (Eq, Show, Ord) + { bounded :: Set TVar + , unbounded :: Set TVar + } + deriving (Eq, Show, Ord) uTVars :: Set TVar -> TVars -uTVars us = TVars - { bounded = mempty - , unbounded = us - } - +uTVars us = + TVars + { bounded = mempty + , unbounded = us + } diff --git a/src/Codegen/Emits.hs b/src/Codegen/Emits.hs index 9eca23e..112839b 100644 --- a/src/Codegen/Emits.hs +++ b/src/Codegen/Emits.hs @@ -1,22 +1,22 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Codegen.Emits where -import Codegen.Auxillary -import Codegen.CompilerState -import Codegen.LlvmIr as LIR -import Control.Applicative ((<|>)) -import Control.Monad (when) -import Control.Monad.State (gets, modify) -import qualified Data.Bifunctor as BI -import Data.Char (ord) -import Data.Coerce (coerce) -import qualified Data.Map as Map -import Data.Maybe (fromJust, fromMaybe) -import Data.Tuple.Extra (dupe, first, second) -import Monomorphizer.MonomorphizerIr as MIR -import qualified TypeChecker.TypeCheckerIr as TIR +import Codegen.Auxillary +import Codegen.CompilerState +import Codegen.LlvmIr as LIR +import Control.Applicative ((<|>)) +import Control.Monad (when) +import Control.Monad.State (gets, modify) +import Data.Bifunctor qualified as BI +import Data.Char (ord) +import Data.Coerce (coerce) +import Data.Map qualified as Map +import Data.Maybe (fromJust, fromMaybe) +import Data.Tuple.Extra (dupe, first, second) +import Monomorphizer.MonomorphizerIr as MIR +import TypeChecker.TypeCheckerIr qualified as TIR compileScs :: [MIR.Def] -> CompilerState () compileScs [] = do @@ -148,12 +148,12 @@ lastMainContent False var = ] compileExp :: ExpT -> CompilerState () -compileExp (MIR.ELit lit, _t) = emitLit lit -compileExp (MIR.EAdd e1 e2, t) = emitAdd t e1 e2 -compileExp (MIR.EVar name, _t) = emitIdent name -compileExp (MIR.EApp e1 e2, t) = emitApp t e1 e2 +compileExp (MIR.ELit lit, _t) = emitLit lit +compileExp (MIR.EAdd e1 e2, t) = emitAdd t e1 e2 +compileExp (MIR.EVar name, _t) = emitIdent name +compileExp (MIR.EApp e1 e2, t) = emitApp t e1 e2 compileExp (MIR.ELet bind e, _) = emitLet bind e -compileExp (MIR.ECase e cs, t) = emitECased t e (map (t,) cs) +compileExp (MIR.ECase e cs, t) = emitECased t e (map (t,) cs) emitLet :: MIR.Bind -> ExpT -> CompilerState () emitLet (MIR.Bind id [] innerExp) e = do @@ -226,10 +226,10 @@ emitECased t e cases = do emit $ SetVariable deref (ExtractValue botT' (VIdent casted Ptr) i) emit $ SetVariable x (Load topT' Ptr deref) else emit $ SetVariable x (ExtractValue botT' (VIdent casted Ptr) i) - PLit (_l, _t) -> undefined - PInj _id _ps -> undefined + PLit (_l, _t) -> error "Nested pattern matching to be implemented" + PInj _id _ps -> error "Nested pattern matching to be implemented" PCatch -> pure () - PEnum _id -> undefined + PEnum _id -> error "Nested pattern matching to be implemented" ) cs val <- exprToValue exp @@ -239,7 +239,7 @@ emitECased t e cases = do emitCases _rt ty label stackPtr vs (Branch (MIR.PLit (i, ct), t) exp) = do emit $ Comment "Plit" let i' = case i of - MIR.LInt i -> VInteger i + MIR.LInt i -> VInteger i MIR.LChar i -> VChar (ord i) ns <- getNewVar lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel @@ -339,7 +339,7 @@ emitLit :: MIR.Lit -> CompilerState () emitLit i = do -- !!this should never happen!! let (i', t) = case i of - (MIR.LInt i'') -> (VInteger i'', I64) + (MIR.LInt i'') -> (VInteger i'', I64) (MIR.LChar i'') -> (VChar $ ord i'', I8) varCount <- getNewVar emit $ Comment "This should not have happened!" @@ -355,7 +355,7 @@ emitAdd t e1 e2 = do exprToValue :: ExpT -> CompilerState LLVMValue exprToValue = \case (MIR.ELit i, _t) -> pure $ case i of - (MIR.LInt i) -> VInteger i + (MIR.LInt i) -> VInteger i (MIR.LChar i) -> VChar $ ord i (MIR.EVar (TIR.Ident "True"), _t) -> pure $ VInteger 1 (MIR.EVar (TIR.Ident "False"), _t) -> pure $ VInteger 0