moved some funcs to aux, added a universal definition of int and char, updated usages in both tcs

This commit is contained in:
sebastianselander 2023-03-30 11:38:06 +02:00
parent 59676605cd
commit c4477d3df4
3 changed files with 25 additions and 23 deletions

View file

@ -1,11 +1,13 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Auxiliary (module Auxiliary) where
import Control.Monad.Error.Class (liftEither)
import Control.Monad.Except (MonadError)
import Data.Either.Combinators (maybeToRight)
import TypeChecker.TypeCheckerIr (Type (TFun))
import Data.List (foldl')
import Grammar.Abs
import Prelude hiding ((>>), (>>=))
(>>) a b = a ++ " " ++ b
@ -26,3 +28,21 @@ mapAccumM f = go
(acc', x') <- f acc x
(acc'', xs') <- go acc' xs
pure (acc'', x' : xs')
unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 =
foldl'
( \(as, bs, cs, ds) (a, b, c, d) ->
(as ++ [a], bs ++ [b], cs ++ [c], ds ++ [d])
)
([], [], [], [])
litType :: Lit -> Type
litType (LInt _) = int
litType (LChar _) = char
int = TLit "Int"
char = TLit "Char"
tupSequence :: Monad m => (m a, b) -> m (a, b)
tupSequence (ma, b) = (,b) <$> ma

View file

@ -6,7 +6,7 @@
module TypeChecker.TypeCheckerBidir (typecheck, getVars) where
import Auxiliary (maybeToRightM, snoc)
import Auxiliary (maybeToRightM, snoc, int, char)
import Control.Applicative (Alternative, Applicative (liftA2),
(<|>))
import Control.Monad.Except (ExceptT, MonadError (throwError),
@ -484,7 +484,7 @@ infer = \case
-- Γ ⊢ e₁ + e₂ ↓ Int ⊣ Δ
EAdd e1 e2 -> do
cxt <- get
let t = TLit "Int"
let t = int
e1' <- check e1 t
put cxt
e2' <- check e2 t

View file

@ -6,7 +6,7 @@
-- | A module for type checking and inference using algorithm W, Hindley-Milner
module TypeChecker.TypeCheckerHm where
import Auxiliary (maybeToRightM)
import Auxiliary (int, litType, maybeToRightM, tupSequence, unzip4)
import Auxiliary qualified as Aux
import Control.Monad.Except
import Control.Monad.Identity (Identity, runIdentity)
@ -706,9 +706,6 @@ solveUndecidable = do
)
composeAll <$> mapM (uncurry unify) ys
tupSequence :: Monad m => (m a, b) -> m (a, b)
tupSequence (ma, b) = (,b) <$> ma
getOriginal :: T.Ident -> T.Ident
getOriginal (T.Ident i) = coerce $ takeWhile (/= delim) $ drop 1 i
@ -725,13 +722,6 @@ typeLength :: Type -> Int
typeLength (TFun _ b) = 1 + typeLength b
typeLength _ = 1
litType :: Lit -> Type
litType (LInt _) = int
litType (LChar _) = char
int = TLit "Int"
char = TLit "Char"
{- | Catch an error if possible and add the given
expression as addition to the error message
-}
@ -794,14 +784,6 @@ dataErr ma d =
else throwError (err{catchable = False})
)
unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 =
foldl'
( \(as, bs, cs, ds) (a, b, c, d) ->
(as ++ [a], bs ++ [b], cs ++ [c], ds ++ [d])
)
([], [], [], [])
initCtx = Ctx mempty
initEnv = Env 0 'a' mempty mempty mempty "" mempty mempty mempty
@ -816,7 +798,7 @@ run' e c =
. flip evalStateT e
. runInfer
data Ctx = Ctx {vars :: Map T.Ident Type}
newtype Ctx = Ctx {vars :: Map T.Ident Type}
deriving (Show)
data Env = Env