Commit f04ae367 authored by André Pacak's avatar André Pacak

transformed record type checker in haskell

parent cae4687d
module ProductTypes.Base where
import Prelude hiding ((>=), (<=), lookup)
import Data.List(find)
import Data.Map (Map)
import qualified Data.Map as Map (lookup)
import ProductTypes.Language
import Util.ErrorMessages
type Error = String
data Infer a
= Inferred a
| NotInferred Error deriving (Eq, Show)
type Check = Infer ()
instance Functor Infer where
fmap _ (NotInferred err) = NotInferred err
fmap f (Inferred ty) = Inferred $ f ty
instance Applicative Infer where
pure = Inferred
(NotInferred err) <*> _ = NotInferred err
(Inferred a) <*> something = fmap a something
instance Monad Infer where
return = Inferred
(Inferred ty) >>= f = f ty
(NotInferred err) >>= _ = NotInferred err
fail = NotInferred
-- matching functions that extract the inner types if possible
-- one problem is that we do not get as good error messages, because term is not known in these functions
matchNat :: Type -> String -> Check
matchNat Nat _ = return ()
matchNat ty err = fail $ natError ty err
matchFun :: Type -> String -> Infer (Type, Type)
matchFun (Fun ty1 ty2) _ = return (ty1, ty2)
matchFun ty err = fail $ funError ty err
matchProd :: Type -> String -> Infer (Type, Type)
matchProd (Prod ty1 ty2) _ = return (ty1, ty2)
matchProd ty err = fail $ prodError ty err
matchType :: Type -> Type -> String -> Check
matchType ty1 ty2 _
| ty1 == ty2 = return ()
matchType ty1 ty2 err = fail $ generalError (show ty1) ty2 err
matchRecord :: Type -> String -> Infer (Map Name Type)
matchRecord (Record pairs) _ = return pairs
matchRecord ty err = fail $ recordError ty err
liftMaybe :: Monad m => Maybe a -> String -> m a
liftMaybe (Just a) _ = return a
liftMaybe Nothing err = fail err
lookup :: Ctx -> Name -> Infer Type
lookup Empty x = fail $ "Unbound variable " ++ show x
lookup (Bind c x t) y
| x == y = return t
| otherwise = lookup c y
inferType :: Ctx -> Term -> Infer Type
inferType _ (Zero _) = return Nat
inferType ctx (Succ t _) = do
checkType ctx t Nat
return Nat
inferType ctx (Add t1 t2 _) = do
checkType ctx t1 Nat
checkType ctx t2 Nat
return Nat
inferType ctx (Mult t1 t2 _) = do
checkType ctx t1 Nat
checkType ctx t2 Nat
return Nat
inferType ctx (Var name _) = lookup ctx name
inferType ctx (Let name t body _) = do
tyt <- inferType ctx t
inferType (Bind ctx name tyt) body
inferType ctx (Anno term ty _) = do
checkType ctx term ty
return ty
inferType ctx (App t1 t2 _) = do
ty <- inferType ctx t1
(ty1, ty2) <- matchFun ty (show t1)
checkType ctx t2 ty1
return ty2
inferType ctx (Fst t _) = do
ty <- inferType ctx t
(ty1, _) <- matchProd ty (show t)
return ty1
inferType ctx (Snd t _) = do
ty <- inferType ctx t
(_, ty2) <- matchProd ty (show t)
return ty2
inferType ctx (Sel n t _) = do
ty <- inferType ctx t
typairs <- matchRecord ty (show t)
liftMaybe (Map.lookup n typairs) $ "Could not project" ++ (show n)
inferType _ t = fail $ "Cannot infer type of term " ++ show t
checkType :: Ctx -> Term -> Type -> Check
checkType ctx p@(Lam name t _) ty = do
(ty1, ty2) <- matchFun ty (show p)
checkType (Bind ctx name ty1) t ty2
checkType ctx p@(Pair t1 t2 _) ty = do
(ty1, ty2) <- matchProd ty (show p)
checkType ctx t1 ty1
checkType ctx t2 ty2
checkType ctx p@(Rec tpairs _) ty = do
typairs <- matchRecord ty (show p)
if length tpairs == length typairs
then do
let subresults = map (\(tl, t) -> do
lty <- liftMaybe (Map.lookup tl typairs) ""
checkType ctx t lty
) tpairs
foldl (>>) (return ()) subresults
else
fail "Length of term labels and type labels does not match"
checkType ctx t ty = do
ty' <- inferType ctx t
matchType ty ty' (show t)
{-# LANGUAGE ConstraintKinds, TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RebindableSyntax #-}
module ProductTypes.ContinueAfterCheckFail where
import Prelude hiding (Monad(..), (>=), (<=), lookup)
import GHC.Exts (Constraint)
import Data.List(find)
import Data.Map (Map)
import qualified Data.Map as Map
import ProductTypes.Language
import Util.ErrorMessages
import Util.PartialOrd
-- is needed because we use the RebindableSyntax extension
ifThenElse :: Bool -> a -> a -> a
ifThenElse True thn _ = thn
ifThenElse False _ els = els
type Error = [String]
data Infer a = Inferred a | NotInferred Error
type Check = Infer ()
instance Functor Infer where
fmap _ (NotInferred err) = NotInferred err
fmap f (Inferred ty) = Inferred $ f ty
instance Applicative Infer where
pure = Inferred
(NotInferred err) <*> _ = NotInferred err
(Inferred a) <*> something = fmap a something
class WithTop a where
top :: a
instance WithTop Type where
top = AnyType
instance WithTop () where
top = ()
instance (WithTop a, WithTop b) => WithTop (a, b) where
top = (top, top)
instance WithTop a => WithTop [a] where
top = [top]
instance WithTop a => WithTop (Map Name a) where
top = Map.empty
-- Had to define an own monad type class.
-- It is not possible otherwise to get the type constraint WithTop a.
-- We use the extension ConstraintKinds to support this.
-- Could not find a simpler solution for this problem.
-- The restricted monad problem is common.
class RMonad m where
type RMonadCtx m a :: Constraint
return :: RMonadCtx m a => a -> m a
(>>=) :: (RMonadCtx m a, RMonadCtx m b) => m a -> (a -> m b) -> m b
(>>) :: (RMonadCtx m a, RMonadCtx m b) => m a -> m b -> m b
m >> k = m >>= \_ -> k
fail :: [String] -> m a
instance RMonad Infer where
type RMonadCtx Infer a = WithTop a
return = Inferred
(Inferred ty) >>= f = f ty
NotInferred err1 >>= f =
-- we know that top is Inferred AnyType, (AnyType, AnyType) or () by definition
case f top of
Inferred _ -> fail err1
NotInferred err2 -> fail $ err1 ++ err2
fail = NotInferred
-- matching functions that extract the inner types if possible
matchNat :: Type -> String -> Check
matchNat Nat _ = return ()
matchNat ty err = fail [natError ty err]
matchFun :: Type -> String -> Infer (Type, Type)
matchFun (Fun ty1 ty2) _ = return (ty1, ty2)
matchFun ty err = fail [funError ty err]
matchProd :: Type -> String -> Infer (Type, Type)
matchProd (Prod ty1 ty2) _ = return (ty1, ty2)
matchProd ty err = fail [prodError ty err]
matchType :: Type -> Type -> String -> Check
matchType ty1 ty2 _ | ty1 >= ty2 = return ()
matchType ty1 ty2 err = fail [generalError (show ty1) ty2 err]
matchRecord :: Type -> String -> Infer (Map Name Type)
matchRecord (Record pairs) _ = return pairs
matchRecord ty err = fail [recordError ty err]
liftMaybe :: WithTop a => Maybe a -> String -> Infer a
liftMaybe (Just a) _ = return a
liftMaybe Nothing err = fail [err]
lookup :: Ctx -> Name -> Infer Type
lookup Empty x = fail ["Unbound variable " ++ show x]
lookup (Bind c x t) y | x == y = return t
| otherwise = lookup c y
inferType :: Ctx -> Term -> Infer Type
inferType _ (Zero _) = return Nat
inferType ctx (Succ t _) = do
checkType ctx t Nat
return Nat
inferType ctx (Add t1 t2 _) = do
checkType ctx t1 Nat
checkType ctx t2 Nat
return Nat
inferType ctx (Mult t1 t2 _) = do
checkType ctx t1 Nat
checkType ctx t2 Nat
return Nat
inferType ctx (Var name _) = lookup ctx name
inferType ctx (Let name t body _) = do
tyt <- inferType ctx t
inferType (Bind ctx name tyt) body
inferType ctx (Anno term ty _) = do
checkType ctx term ty
return ty
inferType ctx (App t1 t2 _) = do
ty <- inferType ctx t1
(ty1, ty2) <- matchFun ty (show t1)
checkType ctx t2 ty1
return ty2
inferType ctx (Fst t _) = do
ty <- inferType ctx t
(ty1, _) <- matchProd ty (show t)
return ty1
inferType ctx (Snd t _) = do
ty <- inferType ctx t
(_, ty2) <- matchProd ty (show t)
return ty2
inferType ctx (Sel n t _) = do
ty <- inferType ctx t
typairs <- matchRecord ty (show t)
liftMaybe (Map.lookup n typairs) $ "Could not project" ++ (show n)
inferType _ t = fail ["Cannot infer type of term " ++ show t]
checkType :: Ctx -> Term -> Type -> Check
checkType ctx p@(Lam name t _) ty = do
(ty1, ty2) <- matchFun ty (show p)
checkType(Bind ctx name ty1) t ty2
checkType ctx p@(Pair t1 t2 _) ty = do
(ty1, ty2) <- matchProd ty (show p)
checkType ctx t1 ty1
checkType ctx t2 ty2
checkType ctx p@(Rec tpairs _) ty = do
typairs <- matchRecord ty (show p)
if length tpairs == length typairs
then do
let subresults = map (\(tl, t) -> do
lty <- liftMaybe (Map.lookup tl typairs) ""
checkType ctx t lty
) tpairs
foldl (>>) (return ()) subresults
else
fail ["Length of term labels and type labels does not match"]
checkType ctx t ty = do
ty' <- inferType ctx t
matchType ty ty' (show t)
{-# LANGUAGE ConstraintKinds, TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RebindableSyntax #-}
module ProductTypes.EliminateContextArgument where
import Prelude hiding (Monad(..), (>=), (<=), lookup)
import GHC.Exts (Constraint)
import Data.List(find)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (isJust, fromJust)
import ProductTypes.Language
import Util.ErrorMessages
import Util.PartialOrd
-- is needed because we use the RebindableSyntax extension
ifThenElse :: Bool -> a -> a -> a
ifThenElse True thn _ = thn
ifThenElse False _ els = els
type Error = [String]
data Infer a = Inferred a | NotInferred Error
type Check = Infer ()
instance Functor Infer where
fmap _ (NotInferred err) = NotInferred err
fmap f (Inferred ty) = Inferred $ f ty
instance Applicative Infer where
pure = Inferred
(NotInferred err) <*> _ = NotInferred err
(Inferred a) <*> something = fmap a something
class WithTop a where
top :: a
instance WithTop Type where
top = AnyType
instance WithTop () where
top = ()
instance (WithTop a, WithTop b) => WithTop (a, b) where
top = (top, top)
instance WithTop Ctx where
top = Empty
instance WithTop a => WithTop [a] where
top = [top]
instance WithTop a => WithTop (Map Name a) where
top = Map.empty
-- Had to define an own monad type class.
-- It is not possible otherwise to get the type constraint WithTop a.
-- We use the extension ConstraintKinds to support this.
-- Could not find a simpler solution for this problem.
-- The restricted monad problem is common.
class RMonad m where
type RMonadCtx m a :: Constraint
return :: RMonadCtx m a => a -> m a
(>>=) :: (RMonadCtx m a, RMonadCtx m b) => m a -> (a -> m b) -> m b
(>>) :: (RMonadCtx m a, RMonadCtx m b) => m a -> m b -> m b
m >> k = m >>= \_ -> k
fail :: [String] -> m a
instance RMonad Infer where
type RMonadCtx Infer a = WithTop a
return = Inferred
(Inferred ty) >>= f = f ty
NotInferred err1 >>= f =
-- we know that top is Inferred AnyType, (AnyType, AnyType) or () by definition
case f top of
Inferred _ -> fail err1
NotInferred err2 -> fail $ err1 ++ err2
fail = NotInferred
-- matching functions that extract the inner types if possible
matchNat :: Type -> String -> Infer Type
matchNat Nat _ = Inferred Nat
matchNat ty err = NotInferred [natError ty err]
matchFun :: Type -> String -> Infer (Type, Type)
matchFun (Fun ty1 ty2) _ = Inferred (ty1, ty2)
matchFun ty err = NotInferred [funError ty err]
matchProd :: Type -> String -> Infer (Type, Type)
matchProd (Prod ty1 ty2) _ = Inferred (ty1, ty2)
matchProd ty err = NotInferred [prodError ty err]
matchType :: Type -> Type -> String -> Check
matchType ty1 ty2 _ | ty1 >= ty2 = Inferred ()
matchType ty1 ty2 err = NotInferred [generalError (show ty1) ty2 err]
matchRecord :: Type -> String -> Infer (Map Name Type)
matchRecord (Record pairs) _ = return pairs
matchRecord ty err = fail [recordError ty err]
liftMaybe :: WithTop a => Maybe a -> String -> Infer a
liftMaybe (Just a) _ = return a
liftMaybe Nothing err = fail [err]
-- try to inline lookup
-- assume that ctx != Empty if not otherwise stated because this case was already covered in the previous step
-- if there is a bind replace lookup definition with it
-- replace ctx of lookup with argument passed to context
lookup :: Term -> Name -> Infer Type
lookup t x = case parent t of
Just p@(Succ t _) -> do
lookup p x
Just p@(Add t1 t2 _) | t == t1 -> do
lookup p x
Just p@(Add t1 t2 _) | t == t2 -> do
lookup p x
Just p@(Mult t1 t2 _) | t == t1 -> do
lookup p x
Just p@(Mult t1 t2 _) | t == t2 -> do
lookup p x
Just p@(Var name _) -> do
lookup p x
Just p@(Let name term body _) | t == term -> do
lookup p x
Just p@(Let name term body _) | t == body ->
if name == x
then do
ty <- inferType term
return ty
else lookup p x
Just p@(Anno term ty _) -> do
lookup p x
Just p@(App t1 t2 _) | t == t1 -> do
lookup p x
Just p@(App t1 t2 _) | t == t2 -> do
lookup p x
Just p@(Fst t _) -> do
lookup p x
Just p@(Snd t _) -> do
lookup p x
Just p@(Lam name term _) ->
if name == x
then do
ty <- requiredType p
(ty1, ty2) <- matchFun ty (show p)
return ty1
else lookup p x
Just p@(Pair t1 t2 _) | t == t1 -> do
lookup p x
Just p@(Pair t1 t2 _) | t == t2 -> do
lookup p x
Just p@(Sel n term _) | t == term -> do
lookup p x
-- For every term we just call lookup on parent because the contex is not extended
-- Thus we have a single case without a guard simply call lookup on parent
-- because every entry of list has same parent
-- TODO: what would happen if the context is extended in different ways?
Just p@(Rec tpairs _) -> do
lookup p x
Just p -> do
lookup p x
Nothing -> fail ["Unbound variable " ++ show x]
inferType :: Term -> Infer Type
inferType (Zero _) = return Nat
inferType (Succ t _) = do
checkType t
return Nat
inferType (Add t1 t2 _) = do
checkType t1
checkType t2
return Nat
inferType (Mult t1 t2 _) = do
checkType t1
checkType t2
return Nat
inferType p@(Var name _) = lookup p name
inferType (Let name t body _) = do
tyt <- inferType t
inferType body
inferType (Anno term ty _) = do
checkType term
return ty
inferType (App t1 t2 _) = do
ty <- inferType t1
(ty1, ty2) <- matchFun ty (show t1)
checkType t2
return ty2
inferType (Fst t _) = do
ty <- inferType t
(ty1, _) <- matchProd ty (show t)
return ty1
inferType (Snd t _) = do
ty <- inferType t
(_, ty2) <- matchProd ty (show t)
return ty2
inferType (Sel n t _) = do
ty <- inferType t
typairs <- matchRecord ty (show t)
liftMaybe (Map.lookup n typairs) $ "Could not project" ++ (show n)
inferType t = fail ["Cannot infer type of term " ++ show t]
checkType :: Term -> Check
checkType p@(Lam name t _) = do
ty <- requiredType p
(ty1, ty2) <- matchFun ty (show p)
checkType t
checkType p@(Pair t1 t2 _) = do
ty <- requiredType p
(ty1, ty2) <- matchProd ty (show p)
checkType t1
checkType t2
checkType p@(Rec tpairs _) = do
ty <- requiredType p
typairs <- matchRecord ty (show p)
if length tpairs == length typairs
then do
let subresults = map (\(tl, t) -> do
lty <- liftMaybe (Map.lookup tl typairs) ""
checkType t
) tpairs
foldl (>>) (return ()) subresults
else fail ["Length of term labels and type labels does not match"]
checkType t = do
ty <- requiredType t
ty' <- inferType t
matchType ty ty' (show t)
requiredType :: Term -> Infer Type
requiredType t = case parent t of
Just (Succ t' _) | t == t' -> return Nat
Just (Add t1 t2 _) | t == t1 ->
return Nat
Just (Add t1 t2 _) | t == t2 ->
return Nat
Just (Mult t1 t2 _) | t == t1 ->
return Nat
Just (Mult t1 t2 _) | t == t2 ->
return Nat
Just (Anno term ty _) | t == term -> return ty
Just (App t1 t2 _) | t == t2 -> do
ty <- inferType t1
(ty1, ty2) <- matchFun ty (show t1)
return ty1
Just p@(Lam name term _) | t == term -> do
ty <- requiredType p
(ty1, ty2) <- matchFun ty (show p)
return ty2
Just p@(Pair t1 t2 _) | t == t1 -> do
ty <- requiredType p
(ty1, ty2) <- matchProd ty (show p)
return ty1
Just p@(Pair t1 t2 _) | t == t2 -> do
ty <- requiredType p
(ty1, ty2) <- matchProd ty (show p)
return ty2
Just p@(Rec tpairs _) -> do
ty <- requiredType p
typairs <- matchRecord ty (show p)
if length tpairs == length typairs
then do
-- TODO what happens if two labels have the same term?
-- TODO what happens if a label is used twice in a record?
let labeledterm = find (\(l, lt) -> lt == t) tpairs
if isJust labeledterm
then liftMaybe (Map.lookup (fst $ fromJust labeledterm) typairs) ""
else fail ["label associated with term not found"]
else fail ["Length of term labels and type labels does not match"]
_ -> fail ["Wrong arg passed"]
{-# LANGUAGE ConstraintKinds, TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RebindableSyntax #-}
module ProductTypes.EliminateTypeArgumentOfCheck where
import Prelude hiding (Monad(..), (>=), (<=), lookup)
import GHC.Exts (Constraint)
import Data.List(find)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (isJust, fromJust)
import ProductTypes.Language
import Util.ErrorMessages
import Util.PartialOrd
-- is needed because we use the RebindableSyntax extension
ifThenElse :: Bool -> a -> a -> a
ifThenElse True thn _ = thn
ifThenElse False _ els = els
type Error = [String]
data Infer a = Inferred a | NotInferred Error
type Check = Infer ()
instance Functor Infer where
fmap _ (NotInferred err) = NotInferred err
fmap f (Inferred ty) = Inferred $ f ty
instance Applicative Infer where
pure = Inferred
(NotInferred err) <*> _ = NotInferred err
(Inferred a) <*> something = fmap a something
class WithTop a where
top :: a
instance WithTop Type where
top = AnyType
instance WithTop () where
top = ()
instance (WithTop a, WithTop b) => WithTop (a, b) where
top = (top, top)
instance WithTop a => WithTop [a] where
top = [top]
instance WithTop a => WithTop (Map Name a) where
top = Map.empty
-- Had to define an own monad type class.
-- It is not possible otherwise to get the type constraint WithTop a.
-- We use the extension ConstraintKinds to support this.
-- Could not find a simpler solution for this problem.
-- The restricted monad problem is common.
class RMonad m where
type RMonadCtx m a :: Constraint
return :: RMonadCtx m a => a -> m a
(>>=) :: (RMonadCtx m a, RMonadCtx m b) => m a -> (a -> m b) -> m b
(>>) :: (RMonadCtx m a, RMonadCtx m b) => m a -> m b -> m b
m >> k = m >>= \_ -> k
fail :: [String] -> m a
instance RMonad Infer where
type RMonadCtx Infer a = WithTop a
return = Inferred
(Inferred ty) >>= f = f ty
NotInferred err1 >>= f =
-- we know that top is Inferred AnyType, (AnyType, AnyType) or () by definition