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 LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Auxiliary (module Auxiliary) where module Auxiliary (module Auxiliary) where
import Control.Monad.Error.Class (liftEither) import Control.Monad.Error.Class (liftEither)
import Control.Monad.Except (MonadError) import Control.Monad.Except (MonadError)
import Data.Either.Combinators (maybeToRight) import Data.Either.Combinators (maybeToRight)
import TypeChecker.TypeCheckerIr (Type (TFun)) import Data.List (foldl')
import Grammar.Abs
import Prelude hiding ((>>), (>>=)) import Prelude hiding ((>>), (>>=))
(>>) a b = a ++ " " ++ b (>>) a b = a ++ " " ++ b
@ -26,3 +28,21 @@ mapAccumM f = go
(acc', x') <- f acc x (acc', x') <- f acc x
(acc'', xs') <- go acc' xs (acc'', xs') <- go acc' xs
pure (acc'', x' : 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 module TypeChecker.TypeCheckerBidir (typecheck, getVars) where
import Auxiliary (maybeToRightM, snoc) import Auxiliary (maybeToRightM, snoc, int, char)
import Control.Applicative (Alternative, Applicative (liftA2), import Control.Applicative (Alternative, Applicative (liftA2),
(<|>)) (<|>))
import Control.Monad.Except (ExceptT, MonadError (throwError), import Control.Monad.Except (ExceptT, MonadError (throwError),
@ -484,7 +484,7 @@ infer = \case
-- Γ ⊢ e₁ + e₂ ↓ Int ⊣ Δ -- Γ ⊢ e₁ + e₂ ↓ Int ⊣ Δ
EAdd e1 e2 -> do EAdd e1 e2 -> do
cxt <- get cxt <- get
let t = TLit "Int" let t = int
e1' <- check e1 t e1' <- check e1 t
put cxt put cxt
e2' <- check e2 t e2' <- check e2 t

View file

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