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)))