moved some funcs to aux, added a universal definition of int and char, updated usages in both tcs
This commit is contained in:
parent
59676605cd
commit
c4477d3df4
3 changed files with 25 additions and 23 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue