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 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
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue