Improved error messages
This commit is contained in:
parent
4038f34cc5
commit
f8a70b4cf4
2 changed files with 74 additions and 68 deletions
|
|
@ -8,7 +8,7 @@ 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)
|
||||||
|
|
||||||
|
|
@ -21,12 +21,10 @@ 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
|
||||||
|
|
@ -42,7 +40,10 @@ annData (Data typ injs) = do
|
||||||
|
|
||||||
assertTVar typ = case typ of
|
assertTVar typ = case typ of
|
||||||
TVar tvar -> pure tvar
|
TVar tvar -> pure tvar
|
||||||
_ -> throwError $ unwords [ "Misformed data declaration:"
|
_ ->
|
||||||
|
throwError $
|
||||||
|
unwords
|
||||||
|
[ "Misformed data declaration:"
|
||||||
, "Non type variable argument"
|
, "Non type variable argument"
|
||||||
]
|
]
|
||||||
annInj tvars (Inj n t) =
|
annInj tvars (Inj n t) =
|
||||||
|
|
@ -55,7 +56,9 @@ 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
|
||||||
|
-- foralled without the consent of the user
|
||||||
|
EAnn e t -> flip EAnn t <$> annExp e
|
||||||
EApp e1 e2 -> liftA2 EApp (annExp e1) (annExp e2)
|
EApp e1 e2 -> liftA2 EApp (annExp e1) (annExp e2)
|
||||||
EAdd e1 e2 -> liftA2 EAdd (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)
|
||||||
|
|
@ -79,7 +82,9 @@ 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 ->
|
||||||
|
TVars
|
||||||
|
{ bounded = Set.singleton tvar
|
||||||
, unbounded = unboundedTVars' (Set.insert tvar bs) t
|
, unbounded = unboundedTVars' (Set.insert tvar bs) t
|
||||||
}
|
}
|
||||||
TVar tvar -> uTVars $ Set.singleton tvar
|
TVar tvar -> uTVars $ Set.singleton tvar
|
||||||
|
|
@ -90,11 +95,12 @@ unboundedTVars' bs typ = tvars.unbounded Set.\\ tvars.bounded
|
||||||
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 =
|
||||||
|
TVars
|
||||||
{ bounded = mempty
|
{ bounded = mempty
|
||||||
, unbounded = us
|
, unbounded = us
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -9,14 +9,14 @@ 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
|
||||||
|
|
@ -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
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue