├── .gitignore
├── README.md
├── shell.nix
└── src
    ├── AlgorithmW_ConstrainedRows.hs
    ├── AlgorithmW_Effects.hs
    └── AlgorithmW_Records.hs


/.gitignore:
--------------------------------------------------------------------------------
 1 | dist
 2 | cabal-dev
 3 | *.o
 4 | *.hi
 5 | *.chi
 6 | *.chs.h
 7 | .virtualenv
 8 | .hsenv
 9 | .cabal-sandbox/
10 | cabal.sandbox.config
11 | cabal.config
12 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | row-polymorphism
 2 | ================
 3 | 
 4 | Example row-polymorphism implementations.
 5 | 
 6 | * AlgorithmW_Records.hs - an implementation of Daan Leijen's "Extensible Records with Scoped Labels".
 7 | * AlgorithmW_ConstrainedRows.hs - an implementation of extensible records and variants using type variable constraints to prevent repeated labels.
 8 | * AlgorithmW_Effects.hs - an implementation of row-polymorphic effect types using the above constrained-rows implementation.
 9 | 
10 | NOTE:
11 | -----
12 | 
13 | For a more complete example of a language with row-polymorphism, checkout the Expresso project: https://github.com/willtim/Expresso
14 | 


--------------------------------------------------------------------------------
/shell.nix:
--------------------------------------------------------------------------------
 1 | { nixpkgs ? import <nixpkgs> {}, compiler ? "default" }:
 2 | 
 3 | let
 4 | 
 5 |   inherit (nixpkgs) pkgs;
 6 | 
 7 |   f = { mkDerivation, base, containers, hashable, mtl, stdenv
 8 |       , template-haskell, unordered-containers, wl-pprint
 9 |       , parsec
10 |       }:
11 |       mkDerivation {
12 |         pname = "query";
13 |         version = "0.1.0.0";
14 |         src = ./.;
15 |         isLibrary = false;
16 |         isExecutable = true;
17 |         executableHaskellDepends = [
18 |           base containers hashable mtl template-haskell unordered-containers
19 |           wl-pprint
20 |           parsec
21 |         ];
22 |         homepage = "https://github.com/githubuser/query#readme";
23 |         description = "Language integrated query experiments";
24 |         license = stdenv.lib.licenses.bsd3;
25 |       };
26 | 
27 |   haskellPackages = if compiler == "default"
28 |                        then pkgs.haskellPackages
29 |                        else pkgs.haskell.packages.${compiler};
30 | 
31 |   drv = haskellPackages.callPackage f {};
32 | 
33 | in
34 | 
35 |   if pkgs.lib.inNixShell then drv.env else drv
36 | 


--------------------------------------------------------------------------------
/src/AlgorithmW_ConstrainedRows.hs:
--------------------------------------------------------------------------------
  1 | ----------------------------------------------------------------------
  2 | -- Polymorphic Extensible Records and Variants with Constrained Rows
  3 | ----------------------------------------------------------------------
  4 | 
  5 | {-# LANGUAGE TupleSections, OverloadedStrings, ViewPatterns #-}
  6 | 
  7 | module AlgorithmW_ConstrainedRows where
  8 | 
  9 | import qualified Data.List as L
 10 | import qualified Data.Map as M
 11 | import qualified Data.Set as S
 12 | 
 13 | import Control.Applicative ((<$>))
 14 | import Control.Arrow (first)
 15 | import Control.Monad.Error
 16 | import Control.Monad.Reader
 17 | import Control.Monad.State
 18 | import Data.String
 19 | import Text.PrettyPrint.Leijen hiding ((<$>))
 20 | 
 21 | type Name  = String
 22 | type Label = String
 23 | 
 24 | data Exp
 25 |   = EVar  Name
 26 |   | EPrim Prim
 27 |   | EApp  Exp Exp
 28 |   | EAbs  Name Exp
 29 |   | ELet  Name Exp Exp
 30 | 
 31 | data Prim
 32 |   = Int Integer
 33 |   | Bool Bool
 34 |   | Add
 35 |   | Cond
 36 |   | RecordEmpty
 37 |   | RecordSelect Label
 38 |   | RecordExtend Label
 39 |   | RecordRestrict Label
 40 |   | VariantInject Label
 41 |   | VariantEmbed Label
 42 |   | VariantElim Label
 43 |     deriving (Eq, Ord)
 44 | 
 45 | data Type
 46 |   = TVar TyVar
 47 |   | TInt
 48 |   | TBool
 49 |   | TFun Type Type
 50 |   | TRecord Type
 51 |   | TVariant Type
 52 |   | TRowEmpty
 53 |   | TRowExtend Label Type Type
 54 |     deriving (Eq, Ord)
 55 | 
 56 | data TyVar = TyVar
 57 |   { tyvarName       :: Name
 58 |   , tyvarKind       :: Kind
 59 |   , tyvarConstraint :: Constraint
 60 |   } deriving (Eq, Ord)
 61 | 
 62 | -- | row type variables may have constraints
 63 | data Kind = Star | Row deriving (Eq, Ord)
 64 | 
 65 | -- | labels the associated tyvar must lack, for types of kind row
 66 | type Constraint = S.Set Label
 67 | 
 68 | data Scheme = Scheme [TyVar] Type
 69 | 
 70 | class Types a where
 71 |   ftv :: a -> S.Set TyVar -- ^ free type variables
 72 |   apply :: Subst -> a -> a
 73 | 
 74 | instance Types Type where
 75 |   ftv (TVar v) = S.singleton v
 76 |   ftv TInt = S.empty
 77 |   ftv TBool = S.empty
 78 |   ftv (TFun t1 t2) = ftv t1 `S.union` ftv t2
 79 |   ftv (TRecord t) = ftv t
 80 |   ftv TRowEmpty = S.empty
 81 |   ftv (TRowExtend l t r) = ftv r `S.union` ftv t
 82 |   apply s (TVar v) = case M.lookup v s of
 83 |                        Nothing -> TVar v
 84 |                        Just t -> t
 85 |   apply s (TFun t1 t2) = TFun (apply s t1) (apply s t2)
 86 |   apply s (TRecord t) = TRecord (apply s t)
 87 |   apply s (TRowExtend l t r) = TRowExtend l (apply s t) (apply s r)
 88 |   apply s t = t
 89 | 
 90 | instance Types Scheme where
 91 |   ftv (Scheme vars t) = (ftv t) S.\\ (S.fromList vars)
 92 |   apply s (Scheme vars t) = Scheme vars (apply (foldr M.delete s vars) t)
 93 | 
 94 | instance Types a => Types [a] where
 95 |   apply s = map (apply s)
 96 |   ftv l = foldr S.union S.empty (map ftv l)
 97 | 
 98 | type Subst = M.Map TyVar Type
 99 | 
100 | nullSubst :: Subst
101 | nullSubst = M.empty
102 | 
103 | -- | apply s1 and then s2
104 | -- NB: order is very important, there were bugs in the original
105 | -- "Algorithm W Step-by-Step" paper related to substitution composition
106 | composeSubst :: Subst -> Subst -> Subst
107 | composeSubst s1 s2 = (M.map (apply s1) s2) `M.union` s1
108 | 
109 | newtype TypeEnv = TypeEnv (M.Map Name Scheme)
110 | 
111 | remove :: TypeEnv -> Name -> TypeEnv
112 | remove (TypeEnv env) var = TypeEnv (M.delete var env)
113 | 
114 | instance Types TypeEnv where
115 |   ftv (TypeEnv env) = ftv (M.elems env)
116 |   apply s (TypeEnv env) = TypeEnv (M.map (apply s) env)
117 | 
118 | -- | generalise abstracts a type over all type variables which are free
119 | -- in the type but not free in the given type environment.
120 | generalise :: TypeEnv -> Type -> Scheme
121 | generalise env t = Scheme vars t
122 |   where
123 |     vars = S.toList ((ftv t) S.\\ (ftv env))
124 | 
125 | data TIEnv = TIEnv {}
126 | data TIState = TIState {tiSupply :: Int, tiSubst :: Subst }
127 | 
128 | type TI a = ErrorT String (ReaderT TIEnv (StateT TIState IO)) a
129 | 
130 | runTI :: TI a -> IO (Either String a, TIState)
131 | runTI t = do
132 |   (res, st) <- runStateT (runReaderT (runErrorT t) initTIEnv) initTIState
133 |   return (res, st)
134 |   where
135 |     initTIEnv = TIEnv {}
136 | 
137 | initTIState = TIState { tiSupply = 0, tiSubst = M.empty }
138 | 
139 | newTyVar :: Char -> TI Type
140 | newTyVar = newTyVarWith Star S.empty
141 | 
142 | newTyVarWith :: Kind -> Constraint -> Char -> TI Type
143 | newTyVarWith k c prefix = do
144 |   s <- get
145 |   put s {tiSupply = tiSupply s + 1 }
146 |   let name = prefix : show (tiSupply s)
147 |   return (TVar $ TyVar name k c)
148 | 
149 | -- | The instantiation function replaces all bound type variables in a
150 | -- type scheme with fresh type variables.
151 | instantiate :: Scheme -> TI Type
152 | instantiate (Scheme vars t) = do
153 |   nvars <- mapM (\(TyVar (p:_) k c) -> newTyVarWith k c p) vars
154 |   let s = M.fromList (zip vars nvars)
155 |   return $ apply s t
156 | 
157 | unify :: Type -> Type -> TI Subst
158 | unify (TFun l r) (TFun l' r') = do
159 |   s1 <- unify l l'
160 |   s2 <- unify (apply s1 r) (apply s1 r')
161 |   return $ s2 `composeSubst` s1
162 | unify (TVar u) (TVar v) = unionConstraints u v
163 | unify (TVar v) t = varBind v t
164 | unify t (TVar v) = varBind v t
165 | unify TInt TInt = return nullSubst
166 | unify TBool TBool = return nullSubst
167 | unify (TRecord row1) (TRecord row2) = unify row1 row2
168 | unify (TVariant row1) (TVariant row2) = unify row1 row2
169 | unify TRowEmpty TRowEmpty = return nullSubst
170 | unify (TRowExtend label1 fieldTy1 rowTail1) row2@TRowExtend{} = do
171 |   (fieldTy2, rowTail2, theta1) <- rewriteRow row2 label1
172 |   -- ^ apply side-condition to ensure termination
173 |   case snd $ toList rowTail1 of
174 |     Just tv | M.member tv theta1 -> throwError "recursive row type"
175 |     _ -> do
176 |       theta2 <- unify (apply theta1 fieldTy1) (apply theta1 fieldTy2)
177 |       let s = theta2 `composeSubst` theta1
178 |       theta3 <- unify (apply s rowTail1) (apply s rowTail2)
179 |       return $ theta3 `composeSubst` s
180 | unify t1 t2 = throwError $ "types do not unify: " ++ show t1 ++ " vs. " ++ show t2
181 | 
182 | -- | in order to unify two type variables, we must union any lacks constraints
183 | unionConstraints :: TyVar -> TyVar -> TI Subst
184 | unionConstraints u v
185 |   | u == v    = return nullSubst
186 |   | otherwise =
187 |       case (tyvarKind u, tyvarKind v) of
188 |        (Star, Star) -> return $ M.singleton u (TVar v)
189 |        (Row,  Row)  -> do
190 |          let c = (tyvarConstraint u) `S.union` (tyvarConstraint v)
191 |          r <- newTyVarWith Row c 'r'
192 |          return $ M.fromList [ (u, r), (v, r) ]
193 |        _            -> throwError "kind mismatch!"
194 | 
195 | varBind :: TyVar -> Type -> TI Subst
196 | varBind u t
197 |   | u `S.member` ftv t = throwError $ "occur check fails: " ++ " vs. " ++ show t
198 |   | otherwise          = case tyvarKind u of
199 |                            Star -> return $ M.singleton u t
200 |                            Row  -> varBindRow u t
201 | 
202 | -- | bind the row tyvar to the row type, as long as the row type does not
203 | -- contain the labels in the tyvar lacks constraint; and propagate these
204 | -- label constraints to the row variable in the row tail, if there is one.
205 | varBindRow :: TyVar -> Type -> TI Subst
206 | varBindRow u t
207 |   = case S.toList (ls `S.intersection` ls') of
208 |       [] | Nothing <- mv -> return s1
209 |          | Just r1 <- mv -> do
210 |              let c = ls `S.union` (tyvarConstraint r1)
211 |              r2 <- newTyVarWith Row c 'r'
212 |              let s2 = M.singleton r1 r2
213 |              return $ s1 `composeSubst` s2
214 |       labels             -> throwError $ "repeated label(s): " ++ show labels
215 |   where
216 |     ls        = tyvarConstraint u
217 |     (ls', mv) = first (S.fromList . map fst) $ toList t
218 |     s1        = M.singleton u t
219 | 
220 | rewriteRow :: Type -> Label -> TI (Type, Type, Subst)
221 | rewriteRow TRowEmpty newLabel = throwError $ "label " ++ newLabel ++ " cannot be inserted"
222 | rewriteRow (TRowExtend label fieldTy rowTail) newLabel
223 |   | newLabel == label     = return (fieldTy, rowTail, nullSubst) -- ^ nothing to do
224 |   | TVar alpha <- rowTail = do
225 |       beta  <- newTyVarWith Row (lacks newLabel) 'r'
226 |       gamma <- newTyVar 'a'
227 |       s     <- varBindRow alpha $ TRowExtend newLabel gamma beta
228 |       return (gamma, apply s $ TRowExtend label fieldTy beta, s)
229 |   | otherwise   = do
230 |       (fieldTy', rowTail', s) <- rewriteRow rowTail newLabel
231 |       return (fieldTy', TRowExtend label fieldTy rowTail', s)
232 | rewriteRow ty _ = error $ "Unexpected type: " ++ show ty
233 | 
234 | -- | type-inference
235 | ti :: TypeEnv -> Exp -> TI (Subst, Type)
236 | ti (TypeEnv env) (EVar n) =
237 |   case M.lookup n env of
238 |     Nothing -> throwError $ "unbound variable: "++n
239 |     Just sigma -> do
240 |       t <- instantiate sigma
241 |       return (nullSubst, t)
242 | ti env (EPrim prim) = (nullSubst,) <$> tiPrim prim
243 | ti env (EAbs n e) = do
244 |   tv <- newTyVar 'a'
245 |   let TypeEnv env' = remove env n
246 |       env'' = TypeEnv (env' `M.union` (M.singleton n (Scheme [] tv)))
247 |   (s1, t1) <- ti env'' e
248 |   return (s1, TFun (apply s1 tv) t1)
249 | ti env (EApp e1 e2) = do
250 |   (s1, t1) <- ti env e1
251 |   (s2, t2) <- ti (apply s1 env) e2
252 |   tv <- newTyVar 'a'
253 |   s3 <- unify (apply s2 t1) (TFun t2 tv)
254 |   return (s3 `composeSubst` s2 `composeSubst` s1, apply s3 tv)
255 | ti env (ELet x e1 e2) = do
256 |   (s1, t1) <- ti env e1
257 |   let TypeEnv env' = remove env x
258 |       scheme = generalise (apply s1 env) t1
259 |       env''  = TypeEnv (M.insert x scheme env')
260 |   (s2, t2) <- ti (apply s1 env'') e2
261 |   return (s2 `composeSubst` s1, t2)
262 | 
263 | tiPrim :: Prim -> TI Type
264 | tiPrim p = case p of
265 |   (Int _)                -> return TInt
266 |   (Bool _)               -> return TBool
267 |   Add                    -> return $ TFun TInt (TFun TInt TInt)
268 |   Cond                   -> do
269 |     a <- newTyVar 'a'
270 |     return $ TFun TBool (TFun a (TFun a a))
271 |   RecordEmpty            -> return $ TRecord TRowEmpty
272 |   (RecordSelect label)   -> do
273 |     a <- newTyVar 'a'
274 |     r <- newTyVarWith Row (lacks label) 'r'
275 |     return $ TFun (TRecord $ TRowExtend label a r) a
276 |   (RecordExtend label)   -> do
277 |     a <- newTyVar 'a'
278 |     r <- newTyVarWith Row (lacks label) 'r'
279 |     return $ TFun a (TFun (TRecord r) (TRecord $ TRowExtend label a r))
280 |   (RecordRestrict label) -> do
281 |     a <- newTyVar 'a'
282 |     r <- newTyVarWith Row (lacks label) 'r'
283 |     return $ TFun (TRecord $ TRowExtend label a r) (TRecord r)
284 |   (VariantInject label)  -> do -- ^ dual of record select
285 |     a <- newTyVar 'a'
286 |     r <- newTyVarWith Row (lacks label) 'r'
287 |     return $ TFun a (TVariant $ TRowExtend label a r)
288 |   (VariantEmbed label)   -> do -- ^ dual of record restrict
289 |     a <- newTyVar 'a'
290 |     r <- newTyVarWith Row (lacks label) 'r'
291 |     return $ TFun (TVariant r) (TVariant $ TRowExtend label a r)
292 |   (VariantElim label)    -> do
293 |     a <- newTyVar 'a'
294 |     b <- newTyVar 'b'
295 |     r <- newTyVarWith Row (lacks label) 'r'
296 |     return $ TFun (TRecord $ TRowExtend label a r)
297 |                   (TFun (TFun a b) (TFun (TFun (TVariant r) b) b))
298 | 
299 | 
300 | typeInference :: M.Map String Scheme -> Exp -> TI Type
301 | typeInference env e = do
302 |   (s, t) <- ti (TypeEnv env) e
303 |   return $ apply s t
304 | 
305 | --  | decompose a row-type into its constituent parts
306 | toList :: Type -> ([(Label, Type)], Maybe TyVar)
307 | toList (TVar v)           = ([], Just v)
308 | toList TRowEmpty          = ([], Nothing)
309 | toList (TRowExtend l t r) = let (ls, mv) = toList r
310 |                             in ((l, t):ls, mv)
311 | lacks :: Label -> Constraint
312 | lacks = S.singleton
313 | 
314 | 
315 | ----------------------------------------------------------------------
316 | -- Examples
317 | 
318 | e1 = EApp (EApp (EPrim $ RecordExtend "y") (EPrim $ Int 2)) (EPrim RecordEmpty)
319 | e2 = EApp (EApp (EPrim $ RecordExtend "x") (EPrim $ Int 1)) e1
320 | e3 = EApp (EPrim $ RecordSelect "y") e2
321 | e4 = ELet "f" (EAbs "r" (EApp (EPrim $ RecordSelect "x") (EVar "r"))) (EVar "f")
322 | e5 = EAbs "r" (EApp (EPrim $ RecordSelect "x") (EVar "r"))
323 | e6 = EAbs "r" $ app (EPrim Add) [ EApp (EPrim $ RecordSelect "x") (EVar "r")
324 |                                 , EApp (EPrim $ RecordSelect "y") (EVar "r")]
325 | 
326 | -- Row tail unification soundness
327 | -- \r -> if True then { x = 1 | r } else { y = 2 | r }
328 | e7 = EAbs "r" $ app (EPrim Cond)
329 |        [ EPrim $ Bool True
330 |        , app (EPrim $ RecordExtend "x") [EPrim $ Int 1, EVar "r"]
331 |        , app (EPrim $ RecordExtend "y") [EPrim $ Int 2, EVar "r"]
332 |        ]
333 | 
334 | -- r: {x=1 | {y=2|r}}
335 | e8 = EAbs "r" $ app (EPrim $ RecordExtend "x")
336 |      [ EPrim $ Int 1
337 |      , app (EPrim $ RecordExtend "y")
338 |          [ EPrim $ Int 2
339 |          , EVar "r"
340 |          ]
341 |      ]
342 | 
343 | app :: Exp -> [Exp] -> Exp
344 | app f = foldl EApp f
345 | 
346 | -- -- Fail in empty row case
347 | -- \x -> case x of A -> 1, B -> 2, A -> 3
348 | -- -- Fail in row var case
349 | -- \x -> <A, B, A | x>
350 | -- -- Failed row rewrite due to row constraints
351 | -- let f = \x -> case <A|x> of B -> 1, _ -> 2 in
352 | -- let g = \x -> case <B|x> of A -> 1, _ -> 2 in
353 | -- \x -> f x + f x
354 | 
355 | 
356 | test :: Exp -> IO ()
357 | test e = do
358 |   (res,_) <- runTI $ typeInference M.empty e
359 |   case res of
360 |     Left err -> putStrLn $ show e ++ " :: error: " ++ err
361 |     Right t  -> putStrLn $ show e ++ " :: " ++ show (generalise (TypeEnv M.empty) t)
362 | 
363 | main :: IO ()
364 | main = do
365 |   mapM test [ e1, e2, e3, e4, e5, e6, e7, e8 ]
366 |   return ()
367 | 
368 | 
369 | ------------------------------------------------------------
370 | -- Pretty-printing
371 | 
372 | instance IsString Doc where
373 |   fromString = text
374 | 
375 | instance Show Type where
376 |   showsPrec _ x = shows $ ppType x
377 | 
378 | ppType :: Type -> Doc
379 | ppType (TVar v)    = text $ tyvarName v
380 | ppType TInt        = "Int"
381 | ppType TBool       = "Bool"
382 | ppType (TFun t s)  = ppParenType t <+> "->" <+> ppType s
383 | ppType (TRecord r) = braces $ (hsep $ punctuate comma $ map ppEntry ls)
384 |                        <> maybe empty (ppRowTail ls) mv
385 |   where
386 |     (ls, mv)       = toList r
387 |     ppRowVar r     = text (tyvarName r)
388 |     ppRowTail [] r = ppRowVar r
389 |     ppRowTail _  r = space <> "|" <+> ppRowVar r
390 |     ppEntry (l, t) = text l <+> "=" <+> ppType t
391 | ppType _ = error "Unexpected type"
392 | 
393 | ppParenType :: Type -> Doc
394 | ppParenType t =
395 |   case t of
396 |     TFun {} -> parens $ ppType t
397 |     _       -> ppType t
398 | 
399 | instance Show Exp where
400 |   showsPrec _ x = shows $ ppExp x
401 | 
402 | ppExp :: Exp -> Doc
403 | ppExp (EVar name)     = text name
404 | ppExp (EPrim prim)    = ppPrim prim
405 | ppExp (ELet x b body) = "let" <+> text x <+> "=" <+>
406 |                          ppExp b <+> "in" <//>
407 |                          indent 2 (ppExp body)
408 | ppExp (EApp e1 e2)    = ppExp e1 <+> ppParenExp e2
409 | ppExp (EAbs n e)      = char '\\' <> text n <+> "->" <+> ppExp e
410 | 
411 | ppParenExp :: Exp -> Doc
412 | ppParenExp t =
413 |   case t of
414 |     ELet {} -> parens $ ppExp t
415 |     EApp {} -> parens $ ppExp t
416 |     EAbs {} -> parens $ ppExp t
417 |     _       -> ppExp t
418 | 
419 | instance Show Prim where
420 |     showsPrec _ x = shows $ ppPrim x
421 | 
422 | ppPrim :: Prim -> Doc
423 | ppPrim (Int i)            = integer i
424 | ppPrim (Bool b)           = if b then "True" else "False"
425 | ppPrim Add                = "(+)"
426 | ppPrim Cond               = "(_?_:_)"
427 | ppPrim RecordEmpty        = "{}"
428 | ppPrim (RecordSelect l)   = "(_." <> text l <> ")"
429 | ppPrim (RecordExtend l)   = "{"   <> text l <>  "=_|_}"
430 | ppPrim (RecordRestrict l) = "(_-" <> text l <> ")"
431 | ppPrim (VariantInject l)  = "<" <> text l <> "=_>"
432 | ppPrim (VariantEmbed l)   = "<" <> text l <> "|_>"
433 | ppPrim (VariantElim l)    = "<" <> text l <> "==_?_:_>"
434 | 
435 | instance Show Scheme where
436 |   showsPrec _ x = shows $ ppScheme x
437 | 
438 | ppScheme :: Scheme -> Doc
439 | ppScheme (Scheme vars t) =
440 |   "forall" <+> hcat (punctuate space $ map (text . tyvarName) vars) <> "."
441 |            <+> parens (hcat $ punctuate comma $ concatMap ppConstraint vars) <+> "=>"
442 |            <+> ppType t
443 |   where
444 |     ppConstraint :: TyVar -> [Doc]
445 |     ppConstraint (TyVar n k c) =
446 |       case k of
447 |         Star            -> []
448 |         Row | null ls   -> []
449 |             | otherwise -> [hcat (punctuate "\\" $ text n : map text ls)]
450 |       where
451 |         ls = S.toList c
452 | 


--------------------------------------------------------------------------------
/src/AlgorithmW_Effects.hs:
--------------------------------------------------------------------------------
  1 | -------------------------------------------------------------------------
  2 | -- Row-polymorphic effect types using constrained rows
  3 | 
  4 | -- See "Koka: Programming with Row-polymorphic Effect Types" by D. Leijen
  5 | -- for a similar implementation using scoped-labels.
  6 | -------------------------------------------------------------------------
  7 | 
  8 | {-# LANGUAGE OverloadedStrings, ViewPatterns #-}
  9 | 
 10 | module AlgorithmW_Effects where
 11 | 
 12 | import qualified Data.List as L
 13 | import qualified Data.Map as M
 14 | import qualified Data.Set as S
 15 | 
 16 | import Control.Applicative ((<$>))
 17 | import Control.Arrow (first)
 18 | import Control.Monad.Error
 19 | import Control.Monad.Reader
 20 | import Control.Monad.State
 21 | import Data.String
 22 | import Text.PrettyPrint.Leijen hiding ((<$>))
 23 | 
 24 | type Name  = String
 25 | type Label = String
 26 | 
 27 | data Exp
 28 |   = EVar  Name
 29 |   | EPrim Prim
 30 |   | EApp  Exp Exp
 31 |   | EAbs  Name Exp
 32 |   | ELet  Name Exp Exp
 33 | 
 34 | data Prim
 35 |   = Unit
 36 |   | Int Integer
 37 |   | Bool Bool
 38 |   | Str String
 39 |   | Add
 40 |   | Sub
 41 |   | Mul
 42 |   | Div    -- ^ a partial function for integers
 43 |   | Catch  -- ^ catch and handle divide-by-zero exception
 44 |   | Total  -- ^ mark an expression as being free from partiality
 45 |   | Print  -- ^ does IO
 46 |   | Pure   -- ^ marks an expression as being free from IO
 47 |     deriving (Eq, Ord)
 48 | 
 49 | type Effect = Type
 50 | 
 51 | data Type
 52 |   = TVar TyVar
 53 |   | TUnit
 54 |   | TInt
 55 |   | TBool
 56 |   | TStr
 57 |   | TFun Type Effect Type
 58 |   | TRowEmpty
 59 |   | TRowExtend Label Type Type
 60 |     deriving (Eq, Ord)
 61 | 
 62 | data TyVar = TyVar
 63 |   { tyvarName       :: Name
 64 |   , tyvarKind       :: Kind
 65 |   , tyvarConstraint :: Constraint
 66 |   } deriving (Eq, Ord)
 67 | 
 68 | -- | row type variables may have constraints
 69 | data Kind = Star | Row deriving (Eq, Ord)
 70 | 
 71 | -- | labels the associated tyvar must lack, for types of kind row
 72 | type Constraint = S.Set Label
 73 | 
 74 | data Scheme = Scheme [TyVar] Type
 75 | 
 76 | class Types a where
 77 |   ftv :: a -> S.Set TyVar -- ^ free type variables
 78 |   apply :: Subst -> a -> a
 79 | 
 80 | instance Types Type where
 81 |   ftv (TVar v) = S.singleton v
 82 |   ftv TUnit = S.empty
 83 |   ftv TInt = S.empty
 84 |   ftv TBool = S.empty
 85 |   ftv TStr = S.empty
 86 |   ftv (TFun t1 eff t2) = S.unions [ftv t1, ftv eff, ftv t2]
 87 |   ftv TRowEmpty = S.empty
 88 |   ftv (TRowExtend l t r) = ftv r `S.union` ftv t
 89 |   apply s (TVar v) = case M.lookup v s of
 90 |                        Nothing -> TVar v
 91 |                        Just t -> t
 92 |   apply s (TFun t1 eff t2) = TFun (apply s t1) (apply s eff) (apply s t2)
 93 |   apply s (TRowExtend l t r) = TRowExtend l (apply s t) (apply s r)
 94 |   apply s t = t
 95 | 
 96 | instance Types Scheme where
 97 |   ftv (Scheme vars t) = (ftv t) S.\\ (S.fromList vars)
 98 |   apply s (Scheme vars t) = Scheme vars (apply (foldr M.delete s vars) t)
 99 | 
100 | instance Types a => Types [a] where
101 |   apply s = map (apply s)
102 |   ftv l = foldr S.union S.empty (map ftv l)
103 | 
104 | type Subst = M.Map TyVar Type
105 | 
106 | nullSubst :: Subst
107 | nullSubst = M.empty
108 | 
109 | emptyEff :: Effect
110 | emptyEff = TRowEmpty
111 | 
112 | -- | apply s1 and then s2
113 | -- NB: order is very important, there were bugs in the original
114 | -- "Algorithm W Step-by-Step" paper related to substitution composition
115 | composeSubst :: Subst -> Subst -> Subst
116 | composeSubst s1 s2 = (M.map (apply s1) s2) `M.union` s1
117 | 
118 | newtype TypeEnv = TypeEnv (M.Map Name Scheme)
119 | 
120 | remove :: TypeEnv -> Name -> TypeEnv
121 | remove (TypeEnv env) var = TypeEnv (M.delete var env)
122 | 
123 | instance Types TypeEnv where
124 |   ftv (TypeEnv env) = ftv (M.elems env)
125 |   apply s (TypeEnv env) = TypeEnv (M.map (apply s) env)
126 | 
127 | -- | generalise abstracts a type over all type variables which are free
128 | -- in the type but not free in the given type environment.
129 | generalise :: TypeEnv -> Type -> Scheme
130 | generalise env t = Scheme vars t
131 |   where
132 |     vars = S.toList ((ftv t) S.\\ (ftv env))
133 | 
134 | data TIEnv = TIEnv {}
135 | data TIState = TIState {tiSupply :: Int, tiSubst :: Subst }
136 | 
137 | type TI a = ErrorT String (ReaderT TIEnv (StateT TIState IO)) a
138 | 
139 | runTI :: TI a -> IO (Either String a, TIState)
140 | runTI t = do
141 |   (res, st) <- runStateT (runReaderT (runErrorT t) initTIEnv) initTIState
142 |   return (res, st)
143 |   where
144 |     initTIEnv = TIEnv {}
145 | 
146 | initTIState = TIState {tiSupply = 0, tiSubst = M.empty }
147 | 
148 | newTyVar :: Char -> TI Type
149 | newTyVar = newTyVarWith Star none
150 | 
151 | newTyVarWith :: Kind -> Constraint -> Char -> TI Type
152 | newTyVarWith k c prefix = do
153 |   s <- get
154 |   put s {tiSupply = tiSupply s + 1 }
155 |   let name = prefix : show (tiSupply s)
156 |   return (TVar $ TyVar name k c)
157 | 
158 | newEffect :: TI Effect
159 | newEffect = newEffectWith none
160 | 
161 | newEffectWith :: Constraint -> TI Effect
162 | newEffectWith c = newTyVarWith Row c 'e'
163 | 
164 | 
165 | -- | The instantiation function replaces all bound type variables in a
166 | -- type scheme with fresh type variables.
167 | instantiate :: Scheme -> TI Type
168 | instantiate (Scheme vars t) = do
169 |   nvars <- mapM (\(TyVar (p:_) k c) -> newTyVarWith k c p) vars
170 |   let s = M.fromList (zip vars nvars)
171 |   return $ apply s t
172 | 
173 | unify :: Type -> Type -> TI Subst
174 | unify (TFun l eff r) (TFun l' eff' r') = do
175 |   s1 <- unify l l'
176 |   s2 <- unify (apply s1 eff) (apply s1 eff')
177 |   let s = s2 `composeSubst` s1
178 |   s3 <- unify (apply s r) (apply s r')
179 |   return $ s3 `composeSubst` s
180 | unify (TVar u) (TVar v) = unionConstraints u v
181 | unify (TVar v) t  = varBind v t
182 | unify t (TVar v)  = varBind v t
183 | unify TUnit TUnit = return nullSubst
184 | unify TInt TInt   = return nullSubst
185 | unify TBool TBool = return nullSubst
186 | unify TStr  TStr  = return nullSubst
187 | unify TRowEmpty TRowEmpty = return nullSubst
188 | unify (TRowExtend label1 fieldTy1 rowTail1) row2@TRowExtend{} = do
189 |   (fieldTy2, rowTail2, theta1) <- rewriteRow row2 label1
190 |   -- ^ apply side-condition to ensure termination
191 |   case snd $ toList rowTail1 of
192 |     Just tv | M.member tv theta1 -> throwError "recursive row type"
193 |     _ -> do
194 |       theta2 <- unify (apply theta1 fieldTy1) (apply theta1 fieldTy2)
195 |       let s = theta2 `composeSubst` theta1
196 |       theta3 <- unify (apply s rowTail1) (apply s rowTail2)
197 |       return $ theta3 `composeSubst` s
198 | unify t1 t2 = throwError $ "types do not unify: " ++ show t1 ++ " vs. " ++ show t2
199 | 
200 | -- | in order to unify two type variables, we must union any lacks constraints
201 | unionConstraints :: TyVar -> TyVar -> TI Subst
202 | unionConstraints u v
203 |   | u == v    = return nullSubst
204 |   | otherwise =
205 |       case (tyvarKind u, tyvarKind v) of
206 |        (Star, Star) -> return $ M.singleton u (TVar v)
207 |        (Row,  Row)  -> do
208 |          let c = (tyvarConstraint u) `S.union` (tyvarConstraint v)
209 |          r <- newTyVarWith Row c 'e'
210 |          return $ M.fromList [ (u, r), (v, r) ]
211 |        _            -> throwError "kind mismatch!"
212 | 
213 | varBind :: TyVar -> Type -> TI Subst
214 | varBind u t
215 |   | u `S.member` ftv t = throwError $ "occur check fails: " ++ " vs. " ++ show t
216 |   | otherwise          = case tyvarKind u of
217 |                            Star -> return $ M.singleton u t
218 |                            Row  -> varBindRow u t
219 | 
220 | -- | bind the row tyvar to the row type, as long as the row type does not
221 | -- contain the labels in the tyvar lacks constraint; and propagate these
222 | -- label constraints to the row variable in the row tail, if there is one.
223 | varBindRow :: TyVar -> Type -> TI Subst
224 | varBindRow u t
225 |   = case S.toList (ls `S.intersection` ls') of
226 |       [] | Nothing <- mv -> return s1
227 |          | Just r1 <- mv -> do
228 |              let c = ls `S.union` (tyvarConstraint r1)
229 |              r2 <- newTyVarWith Row c 'e'
230 |              let s2 = M.singleton r1 r2
231 |              return $ s1 `composeSubst` s2
232 |       labels             -> throwError $ "illegal label(s): " ++ show labels
233 |   where
234 |     ls        = tyvarConstraint u
235 |     (ls', mv) = first (S.fromList . map fst) $ toList t
236 |     s1        = M.singleton u t
237 | 
238 | rewriteRow :: Type -> Label -> TI (Type, Type, Subst)
239 | rewriteRow TRowEmpty newLabel = throwError $ "label " ++ newLabel ++ " cannot be inserted"
240 | rewriteRow (TRowExtend label fieldTy rowTail) newLabel
241 |   | newLabel == label     = return (fieldTy, rowTail, nullSubst) -- ^ nothing to do
242 |   | TVar alpha <- rowTail = do
243 |       beta  <- newTyVarWith Row (lacks newLabel) 'e'
244 |       gamma <- newTyVar 'a'
245 |       s     <- varBindRow alpha $ TRowExtend newLabel gamma beta
246 |       return (gamma, apply s $ TRowExtend label fieldTy beta, s)
247 |   | otherwise   = do
248 |       (fieldTy', rowTail', s) <- rewriteRow rowTail newLabel
249 |       return (fieldTy', TRowExtend label fieldTy rowTail', s)
250 | rewriteRow ty _ = error $ "Unexpected type: " ++ show ty
251 | 
252 | -- | type-inference
253 | ti :: TypeEnv -> Exp -> TI (Subst, Type, Effect)
254 | ti (TypeEnv env) (EVar n) =
255 |   case M.lookup n env of
256 |     Nothing -> throwError $ "unbound variable: "++n
257 |     Just sigma -> do
258 |       t   <- instantiate sigma
259 |       eff <- newEffect
260 |       return (nullSubst, t, eff)
261 | ti env (EPrim prim) = do
262 |   t   <- tiPrim prim
263 |   eff <- newEffect
264 |   return (nullSubst, t, eff)
265 | ti env (EAbs n e) = do
266 |   tv <- newTyVar 'a'
267 |   let TypeEnv env' = remove env n
268 |       env'' = TypeEnv (env' `M.union` (M.singleton n (Scheme [] tv)))
269 |   (s1, t1, eff2) <- ti env'' e
270 |   eff <- newEffect
271 |   return (s1, TFun (apply s1 tv) eff2 t1, eff)
272 | ti env (EApp e1 e2) = do
273 |   (s1, t1, eff1) <- ti env e1
274 |   (s2, t2, eff2) <- ti (apply s1 env) e2
275 |   tv <- newTyVar 'a'
276 |   s3 <- unify (apply s2 t1) (TFun t2 eff2 tv)
277 |   s4 <- unify (apply (s3 `composeSubst` s2)  eff1) (apply s3 eff2)
278 |   return ( foldr1 composeSubst [s4, s3, s2 ,s1]
279 |          , apply (s4 `composeSubst` s3) tv
280 |          , apply (s4 `composeSubst` s3) eff2
281 |          )
282 | ti env (ELet x e1 e2) = do
283 |   (s1, t1, eff1) <- ti env e1
284 |   s2 <- unify eff1 emptyEff
285 |   let TypeEnv env' = remove env x
286 |       scheme = generalise (apply (s2 `composeSubst` s1) env) t1
287 |       env''  = TypeEnv (M.insert x scheme env')
288 |   (s3, t2, eff2) <- ti (apply (s2 `composeSubst` s1) env'') e2
289 |   return (s3 `composeSubst` s2 `composeSubst` s1, t2, eff2)
290 | 
291 | tiPrim :: Prim -> TI Type
292 | tiPrim p = case p of
293 |   Unit                   -> return TUnit
294 |   (Int _)                -> return TInt
295 |   (Bool _)               -> return TBool
296 |   (Str _)                -> return TStr
297 |   Add                    -> do
298 |     eff1 <- newEffect
299 |     eff2 <- newEffect
300 |     return $ TFun TInt eff1 (TFun TInt eff2 TInt)
301 |   Div                    -> do
302 |     eff1 <- newEffect
303 |     eff2 <- TRowExtend "par" TUnit <$> newEffectWith (lacks "par")
304 |     return $ TFun TInt eff1 (TFun TInt eff2 TInt)
305 |   Catch                  -> do
306 |     t1   <- newTyVar 'a'
307 |     eff1 <- newEffect
308 |     eff2 <- newEffectWith (lacks "par")
309 |     let action  = TFun TUnit (TRowExtend "par" TUnit eff2) t1
310 |         handler = TFun TUnit eff2 t1
311 |     return $ TFun action eff1 (TFun handler eff2 t1)
312 |   Total                  -> do
313 |     t1   <- newTyVar 'a'
314 |     eff1 <- newEffectWith (lacks "par")
315 |     eff2 <- newEffect
316 |     return $ TFun (TFun TUnit eff1 t1) eff2 t1
317 |   Print                  -> do
318 |     t1   <- newTyVar 'a'
319 |     eff1 <- newEffect
320 |     eff2 <- TRowExtend "io" TUnit <$> newEffectWith (lacks "io")
321 |     return $ TFun TStr eff1 (TFun t1 eff2 t1)
322 |   Pure                   -> do
323 |     t1   <- newTyVar 'a'
324 |     eff1 <- newEffectWith (lacks "io")
325 |     eff2 <- newEffect
326 |     return $ TFun (TFun TUnit eff1 t1) eff2 t1
327 | 
328 | typeInference :: M.Map String Scheme -> Exp -> TI (Type, Effect)
329 | typeInference env e = do
330 |   (s, t, eff) <- ti (TypeEnv env) e
331 |   return (apply s t, apply s eff)
332 | 
333 | --  | decompose a row-type into its constituent parts
334 | toList :: Type -> ([(Label, Type)], Maybe TyVar)
335 | toList (TVar v)           = ([], Just v)
336 | toList TRowEmpty          = ([], Nothing)
337 | toList (TRowExtend l t r) = let (ls, mv) = toList r
338 |                             in ((l, t):ls, mv)
339 | lacks :: Label -> Constraint
340 | lacks = S.singleton
341 | 
342 | none :: Constraint
343 | none = S.empty
344 | 
345 | 
346 | ----------------------------------------------------------------------
347 | -- Examples
348 | 
349 | delay e = EAbs "_" e
350 | 
351 | e1 = ELet "id" (EAbs "x" (EVar "x")) (EVar "id")
352 | e2 = EAbs "x" (EApp (EApp (EPrim Div) (EPrim $ Int 1)) (EVar "x"))
353 | e3 = ELet "f" e2 $
354 |        EApp (EApp (EPrim Catch) (EAbs "_" (EApp (EVar "f") (EPrim $ Int 0))))
355 |             (EAbs "_" (EPrim $ Int 0))
356 | e4 = EAbs "x" (EApp (EApp (EPrim Print) (EPrim $ Str "x is ")) (EVar "x"))
357 | e5 = ELet "f" e2 (EApp (EPrim Pure) (delay (EApp (EVar "f") (EPrim $ Int 0))))
358 | e6 = ELet "f" e4 (EApp (EPrim Pure) (delay (EApp (EVar "f") (EPrim $ Int 42))))
359 | e7 = ELet "f" e2 (EApp (EPrim Total) (EApp (EVar "f") (EPrim $ Int 42)))
360 | e8 = ELet "f" e2 (EApp (EVar "f") (EApp (EVar "f") (EPrim $ Int 0)))
361 | e9 = EAbs "f" (EApp (EApp (EPrim Print) (EPrim $ Str "argument is pure: ")) (EApp (EPrim Pure) (delay (EApp (EVar "f") (EPrim $ Int 42)))))
362 | 
363 | test :: Exp -> IO ()
364 | test e = do
365 |   (res,_) <- runTI $ typeInference M.empty e
366 |   case res of
367 |     Left err -> putStrLn $ show e ++ " :: error: " ++ err
368 |     Right (t,_eff) -> putStrLn $ show e ++ " :: " ++ show (generalise (TypeEnv M.empty) t)
369 | 
370 | main :: IO ()
371 | main = do
372 |   mapM test [ e1, e2, e3, e4, e5, e6, e7, e8, e9 ]
373 |   return ()
374 | 
375 | 
376 | ------------------------------------------------------------
377 | -- Pretty-printing
378 | 
379 | instance IsString Doc where
380 |   fromString = text
381 | 
382 | instance Show Type where
383 |   showsPrec _ x = shows $ ppType x
384 | 
385 | ppType :: Type -> Doc
386 | ppType (TVar v)       = text $ tyvarName v
387 | ppType TUnit          = parens empty
388 | ppType TInt           = "Int"
389 | ppType TBool          = "Bool"
390 | ppType TStr           = "String"
391 | ppType (TFun t eff s) = ppParenType t <+> "->" <+> ppEffect eff <+> ppParenType s
392 | ppType eff            = ppEffect eff
393 | 
394 | ppParenType :: Type -> Doc
395 | ppParenType t =
396 |   case t of
397 |     TFun {} -> parens $ ppType t
398 |     _       -> ppType t
399 | 
400 | ppEffect :: Effect -> Doc
401 | ppEffect r = braces $ (hsep $ punctuate comma $ map ppEntry ls)
402 |                <> maybe empty (ppRowTail ls) mv
403 |   where
404 |     (ls, mv)       = toList r
405 |     ppRowVar r     = text (tyvarName r)
406 |     ppRowTail [] r = ppRowVar r
407 |     ppRowTail _  r = space <> "|" <+> ppRowVar r
408 |     ppEntry (l, t) = case t of
409 |       TUnit -> text l
410 |       _     -> text l <+> "=" <+> ppType t
411 | 
412 | instance Show Exp where
413 |   showsPrec _ x = shows $ ppExp x
414 | 
415 | ppExp :: Exp -> Doc
416 | ppExp (EVar name)     = text name
417 | ppExp (EPrim prim)    = ppPrim prim
418 | ppExp (ELet x b body) = "let" <+> text x <+> "=" <+>
419 |                          ppExp b <+> "in" <//>
420 |                          indent 2 (ppExp body)
421 | ppExp (EApp e1 e2)    = ppExp e1 <+> ppParenExp e2
422 | ppExp (EAbs n e)      = char '\\' <> text n <+> "->" <+> ppExp e
423 | 
424 | ppParenExp :: Exp -> Doc
425 | ppParenExp t =
426 |   case t of
427 |     ELet {} -> parens $ ppExp t
428 |     EApp {} -> parens $ ppExp t
429 |     EAbs {} -> parens $ ppExp t
430 |     _       -> ppExp t
431 | 
432 | instance Show Prim where
433 |     showsPrec _ x = shows $ ppPrim x
434 | 
435 | ppPrim :: Prim -> Doc
436 | ppPrim Unit               = "()"
437 | ppPrim (Int i)            = integer i
438 | ppPrim (Bool b)           = if b then "True" else "False"
439 | ppPrim (Str s)            = "\"" <> text s <> "\""
440 | ppPrim Add                = "(+)"
441 | ppPrim Sub                = "(-)"
442 | ppPrim Mul                = "(*)"
443 | ppPrim Div                = "(/)"
444 | ppPrim Catch              = "catch"
445 | ppPrim Total              = "total"
446 | ppPrim Print              = "print"
447 | ppPrim Pure               = "pure"
448 | 
449 | instance Show Scheme where
450 |   showsPrec _ x = shows $ ppScheme x
451 | 
452 | ppScheme :: Scheme -> Doc
453 | ppScheme (Scheme vars t) =
454 |   "forall" <+> hcat (punctuate space $ map (text . tyvarName) vars) <> "."
455 |            <+> parens (hcat $ punctuate comma $ concatMap ppConstraint vars) <+> "=>"
456 |            <+> ppType t
457 |   where
458 |     ppConstraint :: TyVar -> [Doc]
459 |     ppConstraint (TyVar n k c) =
460 |       case k of
461 |         Star            -> []
462 |         Row | null ls   -> []
463 |             | otherwise -> [hcat (punctuate "\\" $ text n : map text ls)]
464 |       where
465 |         ls = S.toList c
466 | 


--------------------------------------------------------------------------------
/src/AlgorithmW_Records.hs:
--------------------------------------------------------------------------------
  1 | ----------------------------------------------------------------------
  2 | -- Polymorphic Extensible Records with Scoped labels
  3 | --
  4 | -- See "Extensible Records with Scoped labels" by Daan Leijen
  5 | -- Based on code from "Algorithm W Step-by-Step" by Martin Grabmuller
  6 | ----------------------------------------------------------------------
  7 | 
  8 | {-# LANGUAGE TupleSections, OverloadedStrings #-}
  9 | 
 10 | module AlgorithmW_Records where
 11 | 
 12 | import qualified Data.List as L
 13 | import qualified Data.Map as M
 14 | import qualified Data.Set as S
 15 | 
 16 | import Control.Applicative ((<$>))
 17 | import Control.Monad.Error
 18 | import Control.Monad.Reader
 19 | import Control.Monad.State
 20 | import Data.String
 21 | import Text.PrettyPrint.Leijen hiding ((<$>))
 22 | 
 23 | type Name  = String
 24 | type Label = String
 25 | 
 26 | data Exp
 27 |   = EVar  Name
 28 |   | EPrim Prim
 29 |   | EApp  Exp Exp
 30 |   | EAbs  Name Exp
 31 |   | ELet  Name Exp Exp
 32 | 
 33 | data Prim
 34 |   = Int Integer
 35 |   | Bool Bool
 36 |   | Cond
 37 |   | RecordSelect Label
 38 |   | RecordExtend Label
 39 |   | RecordRestrict Label
 40 |   | RecordEmpty
 41 |     deriving (Eq, Ord)
 42 | 
 43 | data Type
 44 |   = TVar Name
 45 |   | TInt
 46 |   | TBool
 47 |   | TFun Type Type
 48 |   | TRecord Type
 49 |   | TRowEmpty
 50 |   | TRowExtend Label Type Type
 51 |     deriving (Eq, Ord)
 52 | 
 53 | data Scheme = Scheme [Name] Type
 54 | 
 55 | class Types a where
 56 |   ftv :: a -> S.Set Name -- ^ free type variables
 57 |   apply :: Subst -> a -> a
 58 | 
 59 | instance Types Type where
 60 |   ftv (TVar n) = S.singleton n
 61 |   ftv TInt = S.empty
 62 |   ftv TBool = S.empty
 63 |   ftv (TFun t1 t2) = ftv t1 `S.union` ftv t2
 64 |   ftv (TRecord t) = ftv t
 65 |   ftv TRowEmpty = S.empty
 66 |   ftv (TRowExtend l t r) = ftv r `S.union` ftv t
 67 |   apply s (TVar n) = case M.lookup n s of
 68 |                        Nothing -> TVar n
 69 |                        Just t -> t
 70 |   apply s (TFun t1 t2) = TFun (apply s t1) (apply s t2)
 71 |   apply s (TRecord t) = TRecord (apply s t)
 72 |   apply s (TRowExtend l t r) = TRowExtend l (apply s t) (apply s r)
 73 |   apply s t = t
 74 | 
 75 | instance Types Scheme where
 76 |   ftv (Scheme vars t) = (ftv t) S.\\ (S.fromList vars)
 77 |   apply s (Scheme vars t) = Scheme vars (apply (foldr M.delete s vars) t)
 78 | 
 79 | instance Types a => Types [a] where
 80 |   apply s = map (apply s)
 81 |   ftv l = foldr S.union S.empty (map ftv l)
 82 | 
 83 | type Subst = M.Map Name Type
 84 | 
 85 | nullSubst :: Subst
 86 | nullSubst = M.empty
 87 | 
 88 | composeSubst :: Subst -> Subst -> Subst
 89 | composeSubst s1 s2 = (M.map (apply s1) s2) `M.union` s1
 90 | 
 91 | newtype TypeEnv = TypeEnv (M.Map Name Scheme)
 92 | 
 93 | remove :: TypeEnv -> Name -> TypeEnv
 94 | remove (TypeEnv env) var = TypeEnv (M.delete var env)
 95 | 
 96 | instance Types TypeEnv where
 97 |   ftv (TypeEnv env) = ftv (M.elems env)
 98 |   apply s (TypeEnv env) = TypeEnv (M.map (apply s) env)
 99 | 
100 | -- | generalize abstracts a type over all type variables which are free
101 | -- in the type but not free in the given type environment.
102 | generalize :: TypeEnv -> Type -> Scheme
103 | generalize env t = Scheme vars t
104 |   where
105 |     vars = S.toList ((ftv t) S.\\ (ftv env))
106 | 
107 | data TIEnv = TIEnv {}
108 | data TIState = TIState {tiSupply :: Int, tiSubst :: Subst }
109 | 
110 | type TI a = ErrorT String (ReaderT TIEnv (StateT TIState IO)) a
111 | 
112 | runTI :: TI a -> IO (Either String a, TIState)
113 | runTI t = do
114 |   (res, st) <- runStateT (runReaderT (runErrorT t) initTIEnv) initTIState
115 |   return (res, st)
116 |   where
117 |     initTIEnv = TIEnv {}
118 | 
119 | initTIState = TIState {tiSupply = 0, tiSubst = M.empty }
120 | 
121 | newTyVar :: Char -> TI Type
122 | newTyVar prefix = do
123 |   s <- get
124 |   put s {tiSupply = tiSupply s + 1 }
125 |   return (TVar $ prefix : show (tiSupply s))
126 | 
127 | -- | The instantiation function replaces all bound type variables in a
128 | -- type scheme with fresh type variables.
129 | instantiate :: Scheme -> TI Type
130 | instantiate (Scheme vars t) = do
131 |   nvars <- mapM (\(p:_) -> newTyVar p) vars
132 |   let s = M.fromList (zip vars nvars)
133 |   return $ apply s t
134 | 
135 | unify :: Type -> Type -> TI Subst
136 | unify (TFun l r) (TFun l' r') = do
137 |   s1 <- unify l l'
138 |   s2 <- unify (apply s1 r) (apply s1 r')
139 |   return $ s2 `composeSubst` s1
140 | unify (TVar u) t = varBind u t
141 | unify t (TVar u) = varBind u t
142 | unify TInt TInt = return nullSubst
143 | unify TBool TBool = return nullSubst
144 | unify (TRecord row1) (TRecord row2) = unify row1 row2
145 | unify TRowEmpty TRowEmpty = return nullSubst
146 | unify (TRowExtend label1 fieldTy1 rowTail1) row2@TRowExtend{} = do
147 |   (fieldTy2, rowTail2, theta1) <- rewriteRow row2 label1
148 |   -- ^ apply side-condition to ensure termination
149 |   case snd $ toList rowTail1 of
150 |     Just tv | M.member tv theta1 -> throwError "recursive row type"
151 |     _ -> do
152 |       theta2 <- unify (apply theta1 fieldTy1) (apply theta1 fieldTy2)
153 |       let s = theta2 `composeSubst` theta1
154 |       theta3 <- unify (apply s rowTail1) (apply s rowTail2)
155 |       return $ theta3 `composeSubst` s
156 | unify t1 t2 = throwError $ "types do not unify: " ++ show t1 ++ " vs. " ++ show t2
157 | 
158 | varBind :: String -> Type -> TI Subst
159 | varBind u t
160 |   | t == TVar u        = return nullSubst
161 |   | u `S.member` ftv t = throwError $ "occur check fails: " ++ " vs. " ++ show t
162 |   | otherwise          = return $ M.singleton u t
163 | 
164 | rewriteRow :: Type -> Label -> TI (Type, Type, Subst)
165 | rewriteRow TRowEmpty newLabel = throwError $ "label " ++ newLabel ++ " cannot be inserted"
166 | rewriteRow (TRowExtend label fieldTy rowTail) newLabel
167 |   | newLabel == label     = return (fieldTy, rowTail, nullSubst) -- ^ nothing to do
168 |   | TVar alpha <- rowTail = do
169 |       beta  <- newTyVar 'r'
170 |       gamma <- newTyVar 'a'
171 |       return ( gamma
172 |              , TRowExtend label fieldTy beta
173 |              , M.singleton alpha $ TRowExtend newLabel gamma beta
174 |              )
175 |   | otherwise   = do
176 |       (fieldTy', rowTail', s) <- rewriteRow rowTail newLabel
177 |       return ( fieldTy'
178 |              , TRowExtend label fieldTy rowTail'
179 |              , s
180 |              )
181 | rewriteRow ty _ = error $ "Unexpected type: " ++ show ty
182 | 
183 | -- | type-inference
184 | ti :: TypeEnv -> Exp -> TI (Subst, Type)
185 | ti (TypeEnv env) (EVar n) =
186 |   case M.lookup n env of
187 |     Nothing -> throwError $ "unbound variable: "++n
188 |     Just sigma -> do
189 |       t <- instantiate sigma
190 |       return (nullSubst, t)
191 | ti env (EPrim prim) = (nullSubst,) <$> tiPrim prim
192 | ti env (EAbs n e) = do
193 |   tv <- newTyVar 'a'
194 |   let TypeEnv env' = remove env n
195 |       env'' = TypeEnv (env' `M.union` (M.singleton n (Scheme [] tv)))
196 |   (s1, t1) <- ti env'' e
197 |   return (s1, TFun (apply s1 tv) t1)
198 | ti env (EApp e1 e2) = do
199 |   (s1, t1) <- ti env e1
200 |   (s2, t2) <- ti (apply s1 env) e2
201 |   tv <- newTyVar 'a'
202 |   s3 <- unify (apply s2 t1) (TFun t2 tv)
203 |   return (s3 `composeSubst` s2 `composeSubst` s1, apply s3 tv)
204 | ti env (ELet x e1 e2) = do
205 |   (s1, t1) <- ti env e1
206 |   let TypeEnv env' = remove env x
207 |       scheme = generalize (apply s1 env) t1
208 |       env''  = TypeEnv (M.insert x scheme env')
209 |   (s2, t2) <- ti (apply s1 env'') e2
210 |   return (s2 `composeSubst` s1, t2)
211 | 
212 | tiPrim :: Prim -> TI Type
213 | tiPrim p = case p of
214 |   (Int _)                -> return TInt
215 |   (Bool _)               -> return TBool
216 |   Cond                   -> do
217 |     a <- newTyVar 'a'
218 |     return $ TFun TBool (TFun a (TFun a a))
219 |   RecordEmpty            -> return $ TRecord TRowEmpty
220 |   (RecordSelect label)   -> do
221 |     a <- newTyVar 'a'
222 |     r <- newTyVar 'r'
223 |     return $ TFun (TRecord $ TRowExtend label a r) a
224 |   (RecordExtend label)   -> do
225 |     a <- newTyVar 'a'
226 |     r <- newTyVar 'r'
227 |     return $ TFun a (TFun (TRecord r) (TRecord $ TRowExtend label a r))
228 |   (RecordRestrict label) -> do
229 |     a <- newTyVar 'a'
230 |     r <- newTyVar 'r'
231 |     return $ TFun (TRecord $ TRowExtend label a r) (TRecord r)
232 | 
233 | typeInference :: M.Map String Scheme -> Exp -> TI Type
234 | typeInference env e = do
235 |   (s, t) <- ti (TypeEnv env) e
236 |   return $ apply s t
237 | 
238 | toList :: Type -> ([(Label, Type)], Maybe Name)
239 | toList (TVar r)           = ([], Just r)
240 | toList TRowEmpty          = ([], Nothing)
241 | toList (TRowExtend l t r) = let (ls, mv) = toList r
242 |                             in ((l, t):ls, mv)
243 | 
244 | 
245 | ----------------------------------------------------------------------
246 | -- Examples
247 | 
248 | e1 = EApp (EApp (EPrim $ RecordExtend "y") (EPrim $ Int 2)) (EPrim RecordEmpty)
249 | e2 = EApp (EApp (EPrim $ RecordExtend "x") (EPrim $ Int 1)) e1
250 | e3 = EApp (EPrim $ RecordSelect "y") e2
251 | e4 = ELet "f" (EAbs "r" (EApp (EPrim $ RecordSelect "x") (EVar "r"))) (EVar "f")
252 | e5 = EAbs "r" (EApp (EPrim $ RecordSelect "x") (EVar "r"))
253 | 
254 | -- Row tail unification soundness
255 | -- \r -> if True then { x = 1 | r } else { y = 2 | r }
256 | e6 = EAbs "r" $ app (EPrim Cond)
257 |        [ EPrim $ Bool True
258 |        , app (EPrim $ RecordExtend "x") [EPrim $ Int 1, EVar "r"]
259 |        , app (EPrim $ RecordExtend "y") [EPrim $ Int 2, EVar "r"]
260 |        ]
261 | 
262 | app :: Exp -> [Exp] -> Exp
263 | app f = foldl EApp f
264 | 
265 | test :: Exp -> IO ()
266 | test e = do
267 |   (res,_) <- runTI $ typeInference M.empty e
268 |   case res of
269 |     Left err -> putStrLn $ show e ++ " :: error: " ++ err
270 |     Right t  -> putStrLn $ show e ++ " :: " ++ show t
271 | 
272 | main :: IO ()
273 | main = do
274 |   mapM test [ e1, e2, e3, e4, e5, e6 ]
275 |   return ()
276 | 
277 | 
278 | ------------------------------------------------------------
279 | -- Pretty-printing
280 | 
281 | instance IsString Doc where
282 |   fromString = text
283 | 
284 | instance Show Type where
285 |   showsPrec _ x = shows $ ppType x
286 | 
287 | ppType :: Type -> Doc
288 | ppType (TVar n)    = text n
289 | ppType TInt        = "Int"
290 | ppType TBool       = "Bool"
291 | ppType (TFun t s)  = ppParenType t <+> "->" <+> ppType s
292 | ppType (TRecord r) = braces $ (hsep $ punctuate comma $ map ppEntry ls)
293 |                               <> maybe empty (ppRowTail ls) mv
294 |   where
295 |     (ls, mv)       = toList r
296 |     ppRowTail [] r = text r
297 |     ppRowTail _  r = space <> "|" <+> text r
298 |     ppEntry (l, t) = text l <+> "=" <+> ppType t
299 | ppType _ = error "Unexpected type"
300 | 
301 | ppParenType :: Type -> Doc
302 | ppParenType t =
303 |   case t of
304 |     TFun {} -> parens $ ppType t
305 |     _       -> ppType t
306 | 
307 | instance Show Exp where
308 |   showsPrec _ x = shows $ ppExp x
309 | 
310 | ppExp :: Exp -> Doc
311 | ppExp (EVar name)     = text name
312 | ppExp (EPrim prim)    = ppPrim prim
313 | ppExp (ELet x b body) = "let" <+> text x <+> "=" <+>
314 |                          ppExp b <+> "in" <//>
315 |                          indent 2 (ppExp body)
316 | ppExp (EApp e1 e2)    = ppExp e1 <+> ppParenExp e2
317 | ppExp (EAbs n e)      = char '\\' <> text n <+> "->" <+> ppExp e
318 | 
319 | ppParenExp :: Exp -> Doc
320 | ppParenExp t =
321 |   case t of
322 |     ELet {} -> parens $ ppExp t
323 |     EApp {} -> parens $ ppExp t
324 |     EAbs {} -> parens $ ppExp t
325 |     _       -> ppExp t
326 | 
327 | instance Show Prim where
328 |     showsPrec _ x = shows $ ppPrim x
329 | 
330 | ppPrim :: Prim -> Doc
331 | ppPrim (Int i)            = integer i
332 | ppPrim (Bool b)           = if b then "True" else "False"
333 | ppPrim Cond               = "(_?_:_)"
334 | ppPrim (RecordSelect l)   = "(_." <> text l <> ")"
335 | ppPrim (RecordExtend l)   = "{"   <> text l <>  "=_|_}"
336 | ppPrim (RecordRestrict l) = "(_-" <> text l <> ")"
337 | ppPrim RecordEmpty        = "{}"
338 | 
339 | instance Show Scheme where
340 |   showsPrec _ x = shows $ ppScheme x
341 | 
342 | ppScheme :: Scheme -> Doc
343 | ppScheme (Scheme vars t) =
344 |   "forall" <+> hcat (punctuate comma $ map text vars) <> "." <+> ppType t
345 | 


--------------------------------------------------------------------------------