1 module InferMonad (Infer, returnI, eachI, thenI, guardI, useI, getSubI, 2 substituteI, unifyI, freshI, freshesI) 3 where 4 5 import MaybeM (Maybe, returnM, eachM, thenM, failM, guardM, theM, existsM, useM) 6 import StateX (StateX, returnSX, eachSX, thenSX, toSX, putSX, getSX, useSX) 7 import Type (TVarId, TConId, MonoType (TVar, TCon), freeTVarMono) 8 import Substitution (Sub, applySub, lookupSub, emptySub, extendSub, domSub, unifySub) 9 type Counter = Int 10 data Infer x = MkI (StateX Sub (StateX Counter (Maybe ((x, Sub), Counter)))) 11 rep (MkI xJ) = xJ 12 returnI :: x -> Infer x 13 returnI x = MkI (returnSX (returnSX returnM) x) 14 eachI :: Infer x -> (x -> y) -> Infer y 15 xI `eachI` f = MkI (eachSX (eachSX eachM) (rep xI) f) 16 thenI :: Infer x -> (x -> Infer y) -> Infer y 17 xI `thenI` kI = MkI (thenSX (thenSX thenM) (rep xI) (rep . kI)) 18 failI :: Infer x 19 failI = MkI (toSX (eachSX eachM) (toSX eachM failM)) 20 useI :: x -> Infer x -> x 21 useI xfail = useM xfail 22 . useSX eachM 0 23 . useSX (eachSX eachM) emptySub 24 . rep 25 guardI :: Bool -> Infer x -> Infer x 26 guardI b xI = if b then xI else failI 27 putSubI :: Sub -> Infer () 28 putSubI s = MkI (putSX (returnSX returnM) s) 29 getSubI :: Infer Sub 30 getSubI = MkI (getSX (returnSX returnM)) 31 putCounterI :: Counter -> Infer () 32 putCounterI c = MkI (toSX (eachSX eachM) (putSX returnM c)) 33 getCounterI :: Infer Counter 34 getCounterI = MkI (toSX (eachSX eachM) (getSX returnM)) 35 substituteI :: MonoType -> Infer MonoType 36 substituteI t = getSubI `thenI` (\ s -> 37 returnI (applySub s t)) 38 unifyI :: MonoType -> MonoType -> Infer () 39 unifyI t u = getSubI `thenI` (\ s -> 40 let sM = unifySub t u s 41 in 42 existsM sM `guardI` ( 43 putSubI (theM sM) `thenI` (\ () -> 44 returnI ()))) 45 freshI :: Infer MonoType 46 freshI = getCounterI `thenI` (\c -> 47 putCounterI (c+1) `thenI` (\() -> 48 returnI (TVar ("a" ++ show c)))) 49 freshesI :: Int -> Infer [MonoType] 50 freshesI 0 = returnI [] 51 freshesI n = freshI `thenI` (\x -> 52 freshesI (n-1) `thenI` (\xs -> 53 returnI (x:xs)))