Rakarake/churf
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Improved error messages

Browse source
This commit is contained in:
sebastianselander 2023-05-03 17:58:50 +02:00
parent 4038f34cc5
commit f8a70b4cf4
2 changed files with 74 additions and 68 deletions
Download patch file Download diff file Expand all files Collapse all files

90
src/AnnForall.hs
View file

@ -1,16 +1,16 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedRecordDot #-}
module AnnForall (annotateForall) where module AnnForall (annotateForall) where
import Auxiliary (partitionDefs) import Auxiliary (partitionDefs)
import Control.Applicative (Applicative (liftA2)) import Control.Applicative (Applicative (liftA2))
import Control.Monad.Except (throwError) import Control.Monad.Except (throwError)
import Data.Function (on) import Data.Function (on)
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import Data.Set qualified as Set
import Grammar.Abs import Grammar.Abs
import Grammar.ErrM (Err) import Grammar.ErrM (Err)
annotateForall :: Program -> Err Program annotateForall :: Program -> Err Program
annotateForall (Program defs) = do annotateForall (Program defs) = do
@ -21,30 +21,31 @@ annotateForall (Program defs) = do
ss' = map (DSig . annSig) ss ss' = map (DSig . annSig) ss
(ds, ss, bs) = partitionDefs defs (ds, ss, bs) = partitionDefs defs
annData :: Data -> Err Data annData :: Data -> Err Data
annData (Data typ injs) = do annData (Data typ injs) = do
(typ', tvars) <- annTyp typ (typ', tvars) <- annTyp typ
pure (Data typ' $ map (annInj tvars) injs) pure (Data typ' $ map (annInj tvars) injs)
where where
annTyp typ = do annTyp typ = do
(bounded, ts) <- boundedTVars mempty typ (bounded, ts) <- boundedTVars mempty typ
unbounded <- Set.fromList <$> mapM assertTVar ts unbounded <- Set.fromList <$> mapM assertTVar ts
let diff = unbounded Set.\\ bounded let diff = unbounded Set.\\ bounded
typ' = foldr TAll typ diff typ' = foldr TAll typ diff
(typ', ) . fst <$> boundedTVars mempty typ' (typ',) . fst <$> boundedTVars mempty typ'
where where
boundedTVars tvars typ = case typ of boundedTVars tvars typ = case typ of
TAll tvar t -> boundedTVars (Set.insert tvar tvars) t TAll tvar t -> boundedTVars (Set.insert tvar tvars) t
TData _ ts -> pure (tvars, ts) TData _ ts -> pure (tvars, ts)
_ -> throwError "Misformed data declaration" _ -> throwError "Misformed data declaration"
assertTVar typ = case typ of assertTVar typ = case typ of
TVar tvar -> pure tvar 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) = annInj tvars (Inj n t) =
Inj n $ foldr TAll t (unboundedTVars t Set.\\ tvars) 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 annBind (Bind name vars exp) = Bind name vars <$> annExp exp
where where
annExp = \case annExp = \case
EAnn e t -> flip EAnn (annType t) <$> annExp e -- Annotated types should not be
EApp e1 e2 -> liftA2 EApp (annExp e1) (annExp e2) -- foralled without the consent of the user
EAdd e1 e2 -> liftA2 EAdd (annExp e1) (annExp e2) 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) ELet bind e -> liftA2 ELet (annBind bind) (annExp e)
EAbs x e -> EAbs x <$> annExp e EAbs x e -> EAbs x <$> annExp e
ECase e bs -> liftA2 ECase (annExp e) (mapM annBranch bs) ECase e bs -> liftA2 ECase (annExp e) (mapM annBranch bs)
e -> pure e e -> pure e
annBranch (Branch p e) = Branch p <$> annExp e annBranch (Branch p e) = Branch p <$> annExp e
annType :: Type -> Type annType :: Type -> Type
annType typ = go $ unboundedTVars typ annType typ = go $ unboundedTVars typ
where where
go us go us
| null us = typ | null us = typ
| otherwise = foldr TAll typ us | otherwise = foldr TAll typ us
unboundedTVars :: Type -> Set TVar unboundedTVars :: Type -> Set TVar
@ -79,22 +82,25 @@ unboundedTVars' bs typ = tvars.unbounded Set.\\ tvars.bounded
where where
tvars = gatherTVars typ tvars = gatherTVars typ
gatherTVars = \case gatherTVars = \case
TAll tvar t -> TVars { bounded = Set.singleton tvar TAll tvar t ->
, unbounded = unboundedTVars' (Set.insert tvar bs) t TVars
} { bounded = Set.singleton tvar
TVar tvar -> uTVars $ Set.singleton tvar , unbounded = unboundedTVars' (Set.insert tvar bs) t
TFun t1 t2 -> uTVars $ on Set.union (unboundedTVars' bs) t1 t2 }
TData _ typs -> uTVars $ foldr (Set.union . unboundedTVars' bs) mempty typs TVar tvar -> uTVars $ Set.singleton tvar
_ -> TVars { bounded = mempty, unbounded = mempty } 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 data TVars = TVars
{ bounded :: Set TVar { bounded :: Set TVar
, unbounded :: Set TVar , unbounded :: Set TVar
} deriving (Eq, Show, Ord) }
deriving (Eq, Show, Ord)
uTVars :: Set TVar -> TVars uTVars :: Set TVar -> TVars
uTVars us = TVars uTVars us =
{ bounded = mempty TVars
, unbounded = us { bounded = mempty
} , unbounded = us
}

52
src/Codegen/Emits.hs
View file

@ -1,22 +1,22 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Codegen.Emits where module Codegen.Emits where
import Codegen.Auxillary import Codegen.Auxillary
import Codegen.CompilerState import Codegen.CompilerState
import Codegen.LlvmIr as LIR import Codegen.LlvmIr as LIR
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Monad (when) import Control.Monad (when)
import Control.Monad.State (gets, modify) import Control.Monad.State (gets, modify)
import qualified Data.Bifunctor as BI import Data.Bifunctor qualified as BI
import Data.Char (ord) import Data.Char (ord)
import Data.Coerce (coerce) import Data.Coerce (coerce)
import qualified Data.Map as Map import Data.Map qualified as Map
import Data.Maybe (fromJust, fromMaybe) import Data.Maybe (fromJust, fromMaybe)
import Data.Tuple.Extra (dupe, first, second) import Data.Tuple.Extra (dupe, first, second)
import Monomorphizer.MonomorphizerIr as MIR import Monomorphizer.MonomorphizerIr as MIR
import qualified TypeChecker.TypeCheckerIr as TIR import TypeChecker.TypeCheckerIr qualified as TIR
compileScs :: [MIR.Def] -> CompilerState () compileScs :: [MIR.Def] -> CompilerState ()
compileScs [] = do compileScs [] = do
@ -148,12 +148,12 @@ lastMainContent False var =
] ]
compileExp :: ExpT -> CompilerState () compileExp :: ExpT -> CompilerState ()
compileExp (MIR.ELit lit, _t) = emitLit lit compileExp (MIR.ELit lit, _t) = emitLit lit
compileExp (MIR.EAdd e1 e2, t) = emitAdd t e1 e2 compileExp (MIR.EAdd e1 e2, t) = emitAdd t e1 e2
compileExp (MIR.EVar name, _t) = emitIdent name compileExp (MIR.EVar name, _t) = emitIdent name
compileExp (MIR.EApp e1 e2, t) = emitApp t e1 e2 compileExp (MIR.EApp e1 e2, t) = emitApp t e1 e2
compileExp (MIR.ELet bind e, _) = emitLet bind e 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 -> ExpT -> CompilerState ()
emitLet (MIR.Bind id [] innerExp) e = do 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 deref (ExtractValue botT' (VIdent casted Ptr) i)
emit $ SetVariable x (Load topT' Ptr deref) emit $ SetVariable x (Load topT' Ptr deref)
else emit $ SetVariable x (ExtractValue botT' (VIdent casted Ptr) i) else emit $ SetVariable x (ExtractValue botT' (VIdent casted Ptr) i)
PLit (_l, _t) -> undefined PLit (_l, _t) -> error "Nested pattern matching to be implemented"
PInj _id _ps -> undefined PInj _id _ps -> error "Nested pattern matching to be implemented"
PCatch -> pure () PCatch -> pure ()
PEnum _id -> undefined PEnum _id -> error "Nested pattern matching to be implemented"
) )
cs cs
val <- exprToValue exp 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 emitCases _rt ty label stackPtr vs (Branch (MIR.PLit (i, ct), t) exp) = do
emit $ Comment "Plit" emit $ Comment "Plit"
let i' = case i of let i' = case i of
MIR.LInt i -> VInteger i MIR.LInt i -> VInteger i
MIR.LChar i -> VChar (ord i) MIR.LChar i -> VChar (ord i)
ns <- getNewVar ns <- getNewVar
lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel
@ -339,7 +339,7 @@ emitLit :: MIR.Lit -> CompilerState ()
emitLit i = do emitLit i = do
-- !!this should never happen!! -- !!this should never happen!!
let (i', t) = case i of 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) (MIR.LChar i'') -> (VChar $ ord i'', I8)
varCount <- getNewVar varCount <- getNewVar
emit $ Comment "This should not have happened!" emit $ Comment "This should not have happened!"
@ -355,7 +355,7 @@ emitAdd t e1 e2 = do
exprToValue :: ExpT -> CompilerState LLVMValue exprToValue :: ExpT -> CompilerState LLVMValue
exprToValue = \case exprToValue = \case
(MIR.ELit i, _t) -> pure $ case i of (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.LChar i) -> VChar $ ord i
(MIR.EVar (TIR.Ident "True"), _t) -> pure $ VInteger 1 (MIR.EVar (TIR.Ident "True"), _t) -> pure $ VInteger 1
(MIR.EVar (TIR.Ident "False"), _t) -> pure $ VInteger 0 (MIR.EVar (TIR.Ident "False"), _t) -> pure $ VInteger 0