├── README.md ├── LICENSE └── TinyOutsideIn.hs /README.md: -------------------------------------------------------------------------------- 1 | # Tiny OutsideIn(X) 2 | 3 | This is a simple reference implementation of 4 | [OutsideIn(X)](http://research.microsoft.com/apps/pubs/default.aspx?id=162516) 5 | type inference algorithm. The language supports size constraints but is 6 | otherwise **extremely** limited: 7 | * No parser -- only abstract syntax. 8 | * No evaluator. 9 | * We assume that top-level bindings have types provided for them. 10 | * No generalization of either let-expressions or top-level functions. However, 11 | that should not be too difficult to add. 12 | * The inference algorithm only produces a system of constraints. No attempts 13 | have been made to solve them. 14 | * Poorly documented and lazily coded (this really should be fixed). 15 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 Cybernetica AS 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. 22 | -------------------------------------------------------------------------------- /TinyOutsideIn.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | import Control.Applicative 5 | import Control.Arrow (first) 6 | import Control.Exception 7 | import Control.Monad 8 | import Control.Monad.IO.Class 9 | import Data.IORef 10 | import Data.List 11 | import Data.Map (Map) 12 | import Data.String 13 | import Data.Typeable 14 | import qualified Data.Map as Map 15 | 16 | type Name = String 17 | 18 | -- Levels are used to tell how deep in the implication tower was a meta 19 | -- variable born. In deeper levels we may not unify meta variables that were 20 | -- born in upper levels -- they are untouchable there. This is exactly the 21 | -- "outside-in" approach, unifications can only happen from outside to in. 22 | type Level = Int 23 | 24 | type Unique = Int 25 | 26 | {--------------------- 27 | -- Syntax of types -- 28 | ---------------------} 29 | 30 | data TyVar 31 | = VarCon Name -- rigid type variable 32 | | VarMeta (IORef TyMeta) -- unifiable (or linked to some type) 33 | deriving (Eq, Typeable) 34 | 35 | data TyMeta 36 | = MetaFlex Level Unique 37 | | MetaLink Type 38 | 39 | instance IsString TyVar where 40 | fromString = VarCon 41 | 42 | instance Show TyVar where 43 | show (VarCon x) = x 44 | show _ = "[]" 45 | 46 | isMetaVar :: TyVar -> Bool 47 | isMetaVar (VarMeta _) = True 48 | isMetaVar _ = False 49 | 50 | data Kind 51 | = KindType 52 | | KindSize 53 | deriving (Eq, Show, Typeable) 54 | 55 | data TypeCon 56 | = TyConInt -- t ::= int[s] 57 | | TyConBool -- | Bool 58 | | TyConFun -- | t1 -> t2 59 | | TyConList -- | [t] 60 | | TyConTuple -- | (t1, t2, ..., tn) 61 | | TyConSizeLit Int -- s ::= c (size literal) 62 | | TyConAdd -- | s1 + s2 63 | | TyConMul -- | s1 * s2 64 | | TyConDiv -- | s1 / s2 65 | | TyConSub -- | s1 - s2 66 | | TyConWidth -- | width s 67 | deriving (Show, Eq, Typeable) 68 | 69 | isSizeTyCon :: TypeCon -> Bool 70 | isSizeTyCon t = case t of 71 | TyConSizeLit _ -> True 72 | TyConAdd -> True 73 | TyConMul -> True 74 | TyConDiv -> True 75 | TyConSub -> True 76 | TyConWidth -> True 77 | _ -> False 78 | 79 | data TypePred 80 | = TruePred -- p ::= True 81 | | AndPred TypePred TypePred -- | p1 /\ p2 82 | | NotPred TypePred -- | ¬ p 83 | | HasFieldPred Type Int Type -- | t1.i : t2 84 | | EqPred Type Type -- | s1 = s2 85 | | LessPred Type Type -- | s1 < s2 86 | | LessEqualPred Type Type -- | s1 <= s2 87 | deriving (Eq, Typeable) 88 | 89 | instance Show TypePred where 90 | show TruePred = "true" 91 | show (AndPred p1 p2) = show p1 ++ " ∧ " ++ show p2 92 | show (NotPred p) = "¬(" ++ show p ++ ")" 93 | show (HasFieldPred t1 i t2) = "HasField " ++ show t1 ++ " " ++ show i ++ " " ++ show t2 94 | show (EqPred t1 t2) = show t1 ++ " = " ++ show t2 95 | show (LessPred t1 t2) = show t1 ++ " < " ++ show t2 96 | show (LessEqualPred t1 t2) = show t1 ++ " <= " ++ show t2 97 | 98 | andTypePreds :: [TypePred] -> TypePred 99 | andTypePreds = foldr andTypePred TruePred 100 | 101 | andTypePred :: TypePred -> TypePred -> TypePred 102 | andTypePred TruePred b = b 103 | andTypePred a TruePred = a 104 | andTypePred a b = AndPred a b 105 | 106 | data Type 107 | = TyVar Kind TyVar 108 | | TyApp TypeCon [Type] 109 | deriving (Eq, Typeable) 110 | 111 | instance Num Type where 112 | fromInteger n = mkSizeLit (fromInteger n) 113 | (+) = mkAddType 114 | (*) = mkMulType 115 | abs = id 116 | signum = id 117 | negate = error "Can not negate" 118 | 119 | instance Show Type where 120 | show (TyVar _ x) = show x 121 | show (TyApp con ts) 122 | | TyConInt <- con, [s] <- ts = "uint[" ++ show s ++ "]" 123 | | TyConBool <- con, [] <- ts = "bool" 124 | | TyConFun <- con, [t1, t2] <- ts = show t1 ++ " -> (" ++ show t2 ++ ")" 125 | | TyConList <- con, [t] <- ts = "[" ++ show t ++ "]" 126 | | TyConTuple <- con = "(" ++ concat (intersperse "," (map show ts)) ++ ")" 127 | | TyConSizeLit k <- con, [] <- ts = show k 128 | | TyConAdd <- con, [s1, s2] <- ts = "(" ++ show s1 ++ " + " ++ show s2 ++ ")" 129 | | TyConMul <- con, [s1, s2] <- ts = "(" ++ show s1 ++ " * " ++ show s2 ++ ")" 130 | | TyConDiv <- con, [s1, s2] <- ts = "(" ++ show s1 ++ " / " ++ show s2 ++ ")" 131 | | TyConSub <- con, [s1, s2] <- ts = "(" ++ show s1 ++ " - " ++ show s2 ++ ")" 132 | | TyConWidth <- con, [s] <- ts = "width " ++ show s 133 | | otherwise = "" 134 | 135 | mkIntType :: Type -> Type 136 | mkIntType s = TyApp TyConInt [s] 137 | 138 | mkTypeVarType :: Name -> Type 139 | mkTypeVarType = TyVar KindType . VarCon 140 | 141 | mkSizeVarType :: Name -> Type 142 | mkSizeVarType = TyVar KindSize . VarCon 143 | 144 | mkFunType :: Type -> Type -> Type 145 | mkFunType t1 t2 = TyApp TyConFun [t1, t2] 146 | 147 | mkListType :: Type -> Type 148 | mkListType t = TyApp TyConList [t] 149 | 150 | mkPairType :: Type -> Type -> Type 151 | mkPairType t1 t2 = TyApp TyConTuple [t1, t2] 152 | 153 | mkSizeLit :: Int -> Type 154 | mkSizeLit s = TyApp (TyConSizeLit s) [] 155 | 156 | mkAddType :: Type -> Type -> Type 157 | mkAddType t1 t2 = TyApp TyConAdd [t1, t2] 158 | 159 | mkSubType :: Type -> Type -> Type 160 | mkSubType t1 t2 = TyApp TyConSub [t1, t2] 161 | 162 | mkMulType :: Type -> Type -> Type 163 | mkMulType t1 t2 = TyApp TyConMul [t1, t2] 164 | 165 | mkDivType :: Type -> Type -> Type 166 | mkDivType t1 t2 = TyApp TyConDiv [t1, t2] 167 | 168 | mkWidthType :: Type -> Type 169 | mkWidthType t1 = TyApp TyConWidth [t1] 170 | 171 | {------------------- 172 | -- Kind checking -- 173 | -------------------} 174 | 175 | -- | Kind checking. Also verify that the type is well formed. 176 | kindCheck :: Kind -> Type -> Bool 177 | kindCheck k (TyVar k' _) = k == k' 178 | kindCheck KindType (TyApp con ts) 179 | | TyConInt <- con, [s] <- ts = isSizeType s 180 | | TyConBool <- con, [] <- ts = True 181 | | TyConFun <- con, [t1, t2] <- ts = kindCheck KindType t1 && kindCheck KindType t2 182 | | TyConList <- con, [t] <- ts = kindCheck KindType t 183 | | TyConTuple <- con = and $ map (kindCheck KindType) ts 184 | kindCheck KindSize (TyApp con ss) 185 | | TyConSizeLit _ <- con, [] <- ss = True 186 | | TyConAdd <- con, [s1, s2] <- ss = all isSizeType ss 187 | | TyConMul <- con, [s1, s2] <- ss = all isSizeType ss 188 | | TyConDiv <- con, [s1, s2] <- ss = all isSizeType ss 189 | | TyConSub <- con, [s1, s2] <- ss = all isSizeType ss 190 | | TyConWidth <- con, [s] <- ss = isSizeType s 191 | kindCheck _ _ = False 192 | 193 | -- | Check is given type is a size type. 194 | -- Expects kind checked type! 195 | isSizeType :: Type -> Bool 196 | isSizeType (TyVar KindSize) = True 197 | isSizeType (TyApp con _) = isSizeTyCon con 198 | isSizeType _ = False 199 | 200 | -- Note that we only allow equality predicate between size types in user 201 | -- written code and not equality between regular types. This is just a 202 | -- simplification, nothing fundamental stops us from supporting general type 203 | -- equality. During unification predicates between regular types may also be 204 | -- emitted. 205 | kindCheckPred :: TypePred -> Bool 206 | kindCheckPred TruePred = True 207 | kindCheckPred (AndPred p1 p2) = kindCheckPred p1 && kindCheckPred p2 208 | kindCheckPred (NotPred p) = kindCheckPred p 209 | kindCheckPred (HasFieldPred t1 _ t2) = kindCheck KindType t1 && kindCheck KindType t2 210 | kindCheckPred (EqPred t1 t2) = isSizeType t1 && isSizeType t2 211 | kindCheckPred (LessPred t1 t2) = isSizeType t1 && isSizeType t2 212 | kindCheckPred (LessEqualPred t1 t2) = isSizeType t1 && isSizeType t2 213 | 214 | data TypeScheme 215 | = TypeForall [Name] TypePred Type -- \forall a1 a2 ... an. p => t 216 | 217 | {----------------- 218 | -- Constraints -- 219 | -----------------} 220 | 221 | data Constr 222 | = ConstrEmpty -- c ::= \varepsilon 223 | | ConstrWanted TypePred -- | p 224 | | ConstrAnd Constr Constr -- | c1, c2 225 | | ConstrImpl TypePred Constr -- | p -> c 226 | deriving (Eq) 227 | 228 | instance Show Constr where 229 | show ConstrEmpty = "ɛ" 230 | show (ConstrWanted p) = show p 231 | show (ConstrAnd c1 c2) = show c1 ++ "\n" ++ show c2 232 | show (ConstrImpl p c) = show p ++ " ->\n" ++ unlines (map indent (lines (show c))) 233 | where indent = (" " ++) 234 | 235 | constrAnd :: Constr -> Constr -> Constr 236 | constrAnd c1 ConstrEmpty = c1 237 | constrAnd ConstrEmpty c2 = c2 238 | constrAnd c1 c2 = ConstrAnd c1 c2 239 | 240 | addWanted :: TypePred -> Constr -> Constr 241 | addWanted TruePred constr = constr 242 | addWanted tyPred ConstrEmpty = ConstrWanted tyPred 243 | addWanted tyPred constr = ConstrAnd constr (ConstrWanted tyPred) 244 | 245 | {------------------ 246 | -- Type unifier -- 247 | ------------------} 248 | 249 | -- this is not meant to be pretty 250 | data TypeError 251 | = ErrOccursCheck 252 | | ErrUnifFail Type Type 253 | | ErrKindMismatch Type Type 254 | | ErrVarKindMismatch Kind Name 255 | | ErrInvalidIfCondKind TypePred 256 | | ErrNotSizeType Type 257 | | ErrFreeVariableInTypeScheme Name 258 | | ErrFreeVariable Name 259 | | ErrICE -- internal compile error 260 | deriving (Show, Typeable) 261 | 262 | instance Exception TypeError 263 | 264 | -- | Type unification. Returns true if any meta variables have been unified. 265 | -- The first parameter is the expected type and the second one is what we are 266 | -- checking against. The type errors should be in the form "expected ty1, got 267 | -- ty2". Some care has been taken to make sure that those errors are in correct 268 | -- order. 269 | unifyTypes :: Type -> Type -> TcM Bool 270 | unifyTypes ty1 ty2 = go ty1 ty2 271 | where 272 | go (TyVar k x) (TyVar k' x') 273 | | k /= k' = tcThrow (ErrKindMismatch ty1 ty2) 274 | | x == x' = return True 275 | go (TyVar k (VarMeta x)) t2 = unifyMetaTyVar False k x t2 276 | go t1 (TyVar k (VarMeta y)) = unifyMetaTyVar True k y t1 277 | go t1 t2 | isSizeType t1, isSizeType t2 = delayUnif False t1 t2 >> return False 278 | go (TyApp c ts) (TyApp c' ts') 279 | | c == c', length ts == length ts' = or <$> zipWithM go ts ts' 280 | go t1 t2 = tcThrow (ErrUnifFail t1 t2) 281 | 282 | -- | Try to unify a meta variable "u" with type "t". Performs occurs check if needed. 283 | -- Size and type variables are handled differently by unification. Type 284 | -- variables can not be solved if occurs check fails and as we do not have 285 | -- dependent (only size dependent!) types we don't have to bother with 286 | -- tracking untouchable variables. 287 | unifyMetaTyVar :: Bool -> Kind -> IORef TyMeta -> Type -> TcM Bool 288 | unifyMetaTyVar swapped k u t = do 289 | uInfo <- tcReadRef u 290 | occ <- occursIn u t 291 | when (occ && k == KindType) $ 292 | tcThrow ErrOccursCheck 293 | case uInfo of 294 | MetaLink t' -> if swapped 295 | then unifyTypes t' t 296 | else unifyTypes t t' 297 | MetaFlex metaVarLevel _ -> do 298 | untouchable <- tcIsUntouchable metaVarLevel 299 | if occ || untouchable 300 | then delayUnif swapped (TyVar k (VarMeta u)) t >> return False 301 | else tcWriteRef u (MetaLink t) >> return True 302 | 303 | -- | Delay unification between to types until later solving. 304 | -- Equality of size types is definitely always delayed but also unification of 305 | -- untouchable variable is delayed. 306 | delayUnif :: Bool -> Type -> Type -> TcM () 307 | delayUnif True t1 t2 = tcAddWanted (EqPred t2 t1) 308 | delayUnif False t1 t2 = tcAddWanted (EqPred t1 t2) 309 | 310 | tcFreshMetaTyVar :: TcM TyVar 311 | tcFreshMetaTyVar = do 312 | flex <- MetaFlex <$> tcGetLevel <*> tcNextUnique 313 | VarMeta <$> tcNewRef flex 314 | 315 | -- | Occurs check. 316 | occursIn :: IORef TyMeta -> Type -> TcM Bool 317 | occursIn u = go 318 | where 319 | 320 | go (TyVar _ (VarCon _)) = return False 321 | go (TyVar _ (VarMeta v)) 322 | | u == v = return True 323 | | otherwise = do 324 | vInfo <- tcReadRef v 325 | case vInfo of 326 | MetaLink t -> go t 327 | MetaFlex _ _ -> return False 328 | go (TyApp con ts) = or <$> mapM go ts 329 | 330 | -- | Constraint simplification. It is not meant to solve all of the 331 | -- existentials. The resulting constaints are the ones that could not be 332 | -- solved. 333 | simplifyConstr :: Constr -> TcM Constr 334 | simplifyConstr origConstr = do 335 | continueRef <- tcNewRef False 336 | let 337 | goC ConstrEmpty = pure ConstrEmpty 338 | goC (ConstrWanted p) = goP p 339 | goC (ConstrAnd c1 c2) = constrAnd <$> goC c1 <*> goC c2 340 | goC (ConstrImpl p c) = ConstrImpl p <$> tcWithNextLevel (goC c) 341 | 342 | goP (EqPred t1 t2) = 343 | tcCollectWanted $ do 344 | b <- unifyTypes t1 t2 345 | when b $ 346 | tcWriteRef continueRef True 347 | goP (AndPred p1 p2) = constrAnd <$> goP p1 <*> goP p2 348 | goP p = pure (ConstrWanted p) 349 | 350 | loop c = do 351 | tcWriteRef continueRef False 352 | c' <- goC c 353 | b <- tcReadRef continueRef 354 | if b 355 | then loop c' 356 | else return c 357 | loop origConstr 358 | 359 | -- Replace flex type variable with something printable only used for a bit 360 | -- prettier printig. unifiable variables are denoted with "t". The name also 361 | -- mentions the type variable name. 362 | replaceFlex :: Constr -> TcM Constr 363 | replaceFlex = goC 364 | where 365 | 366 | goC ConstrEmpty = pure ConstrEmpty 367 | goC (ConstrWanted p) = ConstrWanted <$> goP p 368 | goC (ConstrAnd c1 c2) = constrAnd <$> goC c1 <*> goC c2 369 | goC (ConstrImpl p c) = ConstrImpl <$> goP p <*> goC c 370 | 371 | goP TruePred = return TruePred 372 | goP (AndPred p1 p2) = AndPred <$> goP p1 <*> goP p2 373 | goP (NotPred p1) = NotPred <$> goP p1 374 | goP (HasFieldPred t1 i t2) = HasFieldPred <$> goT t1 <*> pure i <*> goT t2 375 | goP (EqPred t1 t2) = EqPred <$> goT t1 <*> goT t2 376 | goP (LessPred t1 t2) = LessPred <$> goT t1 <*> goT t2 377 | goP (LessEqualPred t1 t2) = LessEqualPred <$> goT t1 <*> goT t2 378 | 379 | goT t@(TyVar k (VarMeta r)) = do 380 | vInfo <- tcReadRef r 381 | case vInfo of 382 | MetaFlex l u -> pure $ TyVar k (VarCon ("t" ++ show u ++ "{" ++ show l ++ "}")) 383 | MetaLink t' -> goT t' 384 | goT t@(TyVar _ x) = return t 385 | goT (TyApp con ts) = TyApp con <$> mapM goT ts 386 | 387 | 388 | {--------------------- 389 | -- Simple language -- 390 | ---------------------} 391 | 392 | data Expr 393 | = ExprVar Name -- e ::= x 394 | | ExprLam Name Expr -- | \x -> e 395 | | ExprApp Expr Expr -- | e1 e2 396 | | ExprLet Name (Maybe Type) Expr Expr -- | let x = e1 in e2 397 | | ExprSelect Expr Int -- | e.i 398 | | ExprTypeIf TypePred Expr Expr -- | if p then e1 else e2 399 | | ExprSlice Expr Type Type -- | e[s1 : s2] 400 | 401 | instance IsString Expr where 402 | fromString = ExprVar 403 | 404 | {------------------ 405 | -- Type checker -- 406 | ------------------} 407 | 408 | tcFreshVar :: Kind -> TcM Type 409 | tcFreshVar k = TyVar k <$> tcFreshMetaTyVar 410 | 411 | tcFreshTypeVar :: TcM Type 412 | tcFreshTypeVar = tcFreshVar KindType 413 | 414 | -- | Instantiate \forall bound variables in type scheme with fresh meta 415 | -- variables. 416 | -- TODO: for all size variables "n" in the type we need constaint "0 <= n". 417 | tcInstantiateScheme :: TypeScheme -> TcM (TypePred, Type) 418 | tcInstantiateScheme (TypeForall xs forallPred forallBody) = do 419 | envRef <- tcNewRef Map.empty 420 | let 421 | 422 | subTy :: Type -> TcM Type 423 | subTy (TyVar _ (VarCon x)) 424 | | notElem x xs = tcThrow (ErrFreeVariableInTypeScheme x) 425 | subTy (TyVar k (VarCon x)) = do 426 | env <- tcReadRef envRef 427 | case Map.lookup x env of 428 | Nothing -> do 429 | v <- tcFreshVar k 430 | tcWriteRef envRef (Map.insert x v env) 431 | return v 432 | Just v -> do 433 | if not (kindCheck k v) 434 | then tcThrow (ErrVarKindMismatch k x) 435 | else return v 436 | subTy (TyApp con ts) = TyApp con <$> mapM subTy ts 437 | 438 | subPred :: TypePred -> TcM TypePred 439 | subPred TruePred = pure TruePred 440 | subPred (NotPred p1) = NotPred <$> subPred p1 441 | subPred (AndPred p1 p2) = AndPred <$> subPred p1 <*> subPred p2 442 | subPred (HasFieldPred t1 i t2) = HasFieldPred <$> subTy t1 <*> pure i <*> subTy t2 443 | subPred (EqPred t1 t2) = EqPred <$> subTy t1 <*> subTy t2 444 | subPred (LessPred t1 t2) = LessPred <$> subTy t1 <*> subTy t2 445 | subPred (LessEqualPred t1 t2) = LessEqualPred <$> subTy t1 <*> subTy t2 446 | 447 | (,) <$> subPred forallPred <*> subTy forallBody 448 | 449 | -- | Check that "width" is computed of non-negative integers and 450 | -- devision-by-zero is impossible. For sake of simplicity we just check that 451 | -- the divisor is a positive integer. 452 | tcCheckType :: Type -> TcM () 453 | tcCheckType (TyVar _ _) = return () 454 | tcCheckType (TyApp con ts) = do 455 | case con of 456 | TyConWidth | [s] <- ts -> tcAddWanted (LessEqualPred 0 s) 457 | TyConDiv | [_, s2] <- ts -> tcAddWanted (LessPred 0 s2) 458 | _ -> return () 459 | mapM_ tcCheckType ts 460 | 461 | -- | Check that types inside a predicate are good (see tcCheckType). 462 | tcCheckTypePred :: TypePred -> TcM () 463 | tcCheckTypePred TruePred = return () 464 | tcCheckTypePred (NotPred p1) = tcCheckTypePred p1 465 | tcCheckTypePred (AndPred p1 p2) = tcCheckTypePred p1 >> tcCheckTypePred p2 466 | tcCheckTypePred (HasFieldPred t1 i t2) = tcCheckType t1 >> tcCheckType t2 467 | tcCheckTypePred (EqPred t1 t2) = tcCheckType t1 >> tcCheckType t2 468 | tcCheckTypePred (LessPred t1 t2) = tcCheckType t1 >> tcCheckType t2 469 | tcCheckTypePred (LessEqualPred t1 t2) = tcCheckType t1 >> tcCheckType t2 470 | 471 | -- | Expression type inference. 472 | tcInferExpr :: Expr -> TcM Type 473 | tcInferExpr e = do 474 | t <- tcFreshTypeVar 475 | tcExpr t e 476 | return t 477 | 478 | -- | Expression type checking. 479 | tcExpr :: Type -> Expr -> TcM () 480 | tcExpr resTy (ExprVar x) = do 481 | schemeTy <- tcLookupScheme x 482 | case schemeTy of 483 | Nothing -> do 484 | varTy <- tcFindVarTy x 485 | void (unifyTypes resTy varTy) 486 | Just ty -> do 487 | (pred, ty') <- tcInstantiateScheme ty 488 | tcAddWanted pred 489 | void (unifyTypes ty' resTy) 490 | tcExpr resTy (ExprLam x e) = do 491 | argTy <- tcFreshTypeVar 492 | retTy <- tcFreshTypeVar 493 | unifyTypes resTy (argTy `mkFunType` retTy) 494 | tcSetVarTy x argTy $ 495 | tcExpr retTy e 496 | tcExpr resTy (ExprApp e1 e2) = do 497 | e1Ty <- tcInferExpr e1 498 | e2Ty <- tcInferExpr e2 499 | void (unifyTypes (e2Ty `mkFunType` resTy) e1Ty) 500 | tcExpr resTy (ExprLet x Nothing e1 e2) = do 501 | t <- tcInferExpr e1 502 | tcSetVarTy x t $ 503 | tcExpr resTy e2 504 | tcExpr resTy (ExprLet x (Just t) e1 e2) = do 505 | tcExpr t e1 506 | tcSetVarTy x t $ 507 | tcExpr resTy e2 508 | tcExpr resTy (ExprSelect e i) = do 509 | structTy <- tcInferExpr e 510 | tcAddWanted (HasFieldPred structTy i resTy) 511 | tcExpr resTy (ExprTypeIf pred e1 e2) 512 | | not (kindCheckPred pred) = tcThrow (ErrInvalidIfCondKind pred) 513 | | otherwise = do 514 | tcCheckTypePred pred 515 | tcWithNextLevel $ do 516 | c1 <- tcCollectWanted (tcExpr resTy e1) 517 | c2 <- tcCollectWanted (tcExpr resTy e2) 518 | tcAddImpl pred c1 519 | tcAddImpl (NotPred pred) c2 520 | tcExpr resTy (ExprSlice e s1 s2) 521 | | not (isSizeType s1) = tcThrow (ErrNotSizeType s1) 522 | | not (isSizeType s2) = tcThrow (ErrNotSizeType s2) 523 | | otherwise = do 524 | tcCheckType s1 525 | tcCheckType s2 526 | n <- tcFreshVar KindSize 527 | tcExpr (mkIntType n) e 528 | unifyTypes resTy (mkIntType (mkSubType s2 s1)) 529 | -- 0 <= s1 <= s2 <= n 530 | tcAddWanted (LessEqualPred 0 s1) 531 | tcAddWanted (LessEqualPred s1 s2) 532 | tcAddWanted (LessEqualPred s2 n) 533 | 534 | {------------------ 535 | -- Example code -- 536 | ------------------} 537 | 538 | a, b, c, d :: Type 539 | a = mkTypeVarType "a" 540 | b = mkTypeVarType "b" 541 | c = mkTypeVarType "c" 542 | d = mkTypeVarType "d" 543 | 544 | i, n, m, k :: Type 545 | i = mkSizeVarType "i" 546 | n = mkSizeVarType "n" 547 | m = mkSizeVarType "m" 548 | k = mkSizeVarType "k" 549 | 550 | infixl 0 $$ 551 | ($$) :: Expr -> Expr -> Expr 552 | x $$ y = ExprApp x y 553 | 554 | infix 4 ~~ 555 | (~~) :: Type -> Type -> TypePred 556 | (~~) = EqPred 557 | 558 | addE :: Expr -> Expr -> Expr 559 | addE e1 e2 = "add" $$ e1 $$ e2 560 | 561 | catE :: Expr -> Expr -> Expr 562 | catE e1 e2 = "cat" $$ e1 $$ e2 563 | 564 | letT :: Name -> Type -> Expr -> Expr -> Expr 565 | letT x t e1 e2 = ExprLet x (Just t) e1 e2 566 | 567 | ifE :: TypePred -> Expr -> Expr -> Expr 568 | ifE = ExprTypeIf 569 | 570 | letE :: Name -> Expr -> Expr -> Expr 571 | letE x e1 e2 = ExprLet x Nothing e1 e2 572 | 573 | exFoo :: (Expr, Type) 574 | exFoo = (e, t) 575 | where 576 | t = mkIntType n `mkFunType` mkIntType n 577 | e = ExprLam "x" ("x" `addE` ifE (n ~~ 0) "zero" ("x" `addE` "one")) 578 | 579 | -- map (\x -> x.0) 580 | exFsts :: (Expr, Type) 581 | exFsts = (e, t) 582 | where 583 | t = mkListType (mkPairType a b) `mkFunType` mkListType a 584 | e = "map" $$ ExprLam "x" (ExprSelect "x" 0) 585 | 586 | -- PrefixOR, but uses sum (instead of OR) as what really matters are types. 587 | exPrefixOR :: (Expr, Type) 588 | exPrefixOR = (e, t) 589 | where 590 | t = mkIntType n `mkFunType` mkIntType n 591 | nHalf = mkDivType n 2 592 | e = ExprLam "p" $ 593 | ifE (n ~~ 0) "p" $ 594 | ifE (n ~~ 1) "p" $ 595 | letE "x" ("prefixOR" $$ ExprSlice "p" 0 nHalf) $ 596 | letE "y" ("prefixOR" $$ ExprSlice "p" nHalf n) $ 597 | letE "b" ("zext" $$ ExprSlice "y" 0 1) $ 598 | letE "r" (addE "x" "b") $ 599 | catE "r" "y" 600 | 601 | -- used to be a bug 602 | exTest1 :: (Expr, Type) 603 | exTest1 = (e, t) 604 | where 605 | e = letE "t" (ifE (n ~~ 0) "zero" "one") "t" 606 | t = mkIntType n 607 | 608 | exTest2 :: (Expr, Type) 609 | exTest2 = (e, t) 610 | where 611 | e = letE "x" ("zext" $$ "zero") $ ifE (n ~~ 0) "x" "x" 612 | t = mkIntType n 613 | 614 | -- run "printWanted exFoo" for instance 615 | printWanted :: (Expr, Type) -> IO () 616 | printWanted (e, t) = runTcM $ do 617 | tcExpr t e 618 | wanted <- replaceFlex =<< simplifyConstr =<< tcGetWanted 619 | liftIO $ putStrLn "System to solve:" 620 | tcPrint wanted 621 | 622 | initialTypeEnv :: [(Name, TypeScheme)] 623 | initialTypeEnv = 624 | [ ("add", TypeForall ["n"] TruePred (mkIntType n `mkFunType` (mkIntType n `mkFunType` mkIntType n))) 625 | , ("map", TypeForall ["a", "b"] TruePred ((a `mkFunType` b) `mkFunType` (mkListType a `mkFunType` mkListType b))) 626 | , ("zero", TypeForall [] TruePred (mkIntType (mkSizeLit 0))) 627 | , ("one", TypeForall ["n"] (LessPred (mkSizeLit 0) n) (mkIntType n)) 628 | , ("zext", TypeForall ["n", "m"] (LessEqualPred n m) (mkIntType n `mkFunType` mkIntType m)) 629 | , ("trunc", TypeForall ["n", "m"] (LessEqualPred m n) (mkIntType n `mkFunType` mkIntType m)) 630 | , ("prefixOR", TypeForall ["n"] TruePred (mkIntType n `mkFunType` mkIntType n)) 631 | , ("cat", TypeForall ["n", "m"] TruePred (mkIntType n `mkFunType` (mkIntType m `mkFunType` mkIntType (mkAddType n m)))) 632 | ] 633 | 634 | {-------------------------------- 635 | -- Simple type checking monad -- 636 | --------------------------------} 637 | 638 | data TcEnv = TcEnv { 639 | _tyLevel :: Int, 640 | _tyEnv :: Map Name Type, 641 | _tyPoly :: Map Name TypeScheme, 642 | _unique :: IORef Unique, 643 | _wanted :: IORef Constr 644 | } 645 | 646 | mkEmptyTcEnv :: IO TcEnv 647 | mkEmptyTcEnv = do 648 | wantedRef <- newIORef ConstrEmpty 649 | uniqueRef <- newIORef 0 650 | return $ TcEnv { 651 | _tyLevel = 0, 652 | _wanted = wantedRef, 653 | _tyEnv = Map.empty, 654 | _unique = uniqueRef, 655 | _tyPoly = Map.fromList initialTypeEnv 656 | } 657 | 658 | newtype TcM a = TcM { 659 | unTcM :: TcEnv -> IO a 660 | } 661 | 662 | runTcM :: TcM a -> IO a 663 | runTcM m = do 664 | emptyTcEnv <- mkEmptyTcEnv 665 | unTcM m emptyTcEnv 666 | 667 | instance Functor TcM where 668 | fmap f m = TcM $ \env -> f `fmap` unTcM m env 669 | 670 | instance Applicative TcM where 671 | pure x = TcM $ \_ -> pure x 672 | mf <*> mx = TcM $ \env -> unTcM mf env <*> unTcM mx env 673 | 674 | instance Monad TcM where 675 | return = pure 676 | mx >>= f = TcM $ \env -> unTcM mx env >>= \x -> unTcM (f x) env 677 | 678 | instance MonadIO TcM where 679 | liftIO act = TcM $ \_ -> act 680 | 681 | tcPrint :: Show a => a -> TcM () 682 | tcPrint = liftIO . print 683 | 684 | tcNewRef :: a -> TcM (IORef a) 685 | tcNewRef = liftIO . newIORef 686 | 687 | tcModifyRef :: IORef a -> (a -> a) -> TcM () 688 | tcModifyRef ioref f = liftIO (modifyIORef ioref f) 689 | 690 | tcReadRef :: IORef a -> TcM a 691 | tcReadRef = liftIO . readIORef 692 | 693 | tcWriteRef :: IORef a -> a -> TcM () 694 | tcWriteRef r x = liftIO $ writeIORef r x 695 | 696 | tcThrow :: Exception e => e -> TcM a 697 | tcThrow = liftIO . throwIO 698 | 699 | tcEnv :: TcM TcEnv 700 | tcEnv = TcM return 701 | 702 | tcWithEnv :: (TcEnv -> TcEnv) -> TcM a -> TcM a 703 | tcWithEnv f tc = TcM $ \env -> unTcM tc (f env) 704 | 705 | tcSetVarTy :: Name -> Type -> TcM a -> TcM a 706 | tcSetVarTy x t = tcWithEnv $ \env -> env { _tyEnv = Map.insert x t (_tyEnv env) } 707 | 708 | tcGetLevel :: TcM Level 709 | tcGetLevel = _tyLevel <$> tcEnv 710 | 711 | tcWithLevel :: Level -> TcM a -> TcM a 712 | tcWithLevel l = tcWithEnv (\env -> env { _tyLevel = l }) 713 | 714 | tcWithNextLevel :: TcM a -> TcM a 715 | tcWithNextLevel = tcWithEnv (\env -> env { _tyLevel = _tyLevel env + 1 }) 716 | 717 | tcLookupScheme :: Name -> TcM (Maybe TypeScheme) 718 | tcLookupScheme x = Map.lookup x . _tyPoly <$> tcEnv 719 | 720 | tcFindVarTy :: Name -> TcM Type 721 | tcFindVarTy x = do 722 | env <- _tyEnv <$> tcEnv 723 | case x `Map.lookup` env of 724 | Nothing -> tcThrow (ErrFreeVariable x) 725 | Just ty -> return ty 726 | 727 | tcGetWanted :: TcM Constr 728 | tcGetWanted = do 729 | wantedRef <- _wanted <$> tcEnv 730 | tcReadRef wantedRef 731 | 732 | tcAddImpl :: TypePred -> Constr -> TcM () 733 | tcAddImpl pred constr = do 734 | wantedRef <- _wanted <$> tcEnv 735 | tcModifyRef wantedRef (constrAnd (ConstrImpl pred constr)) 736 | 737 | tcAddWanted :: TypePred -> TcM () 738 | tcAddWanted pred = do 739 | wantedRef <- _wanted <$> tcEnv 740 | tcModifyRef wantedRef (addWanted pred) 741 | 742 | tcCollectWanted :: TcM () -> TcM Constr 743 | tcCollectWanted act = do 744 | newWantedRef <- tcNewRef ConstrEmpty 745 | tcWithEnv (\env -> env { _wanted = newWantedRef }) act 746 | tcReadRef newWantedRef 747 | 748 | tcNextUnique :: TcM Unique 749 | tcNextUnique = do 750 | uniqueRef <- _unique <$> tcEnv 751 | u <- tcReadRef uniqueRef 752 | tcWriteRef uniqueRef (u + 1) 753 | return u 754 | 755 | tcIsUntouchable :: Level -> TcM Bool 756 | tcIsUntouchable vl = (<) <$> pure vl <*> tcGetLevel 757 | --------------------------------------------------------------------------------