Improved error messages
This commit is contained in:
sebastianselander
parent
4038f34cc5
commit
f8a70b4cf4
2 changed files with 74 additions and 68 deletions
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue