content: module TFFMonad where
  
  import Syntax 
  import TypesTerms
  import Char(chr,ord)
  
  --------------------------------------------------------------------------------
  -- The monad
  --
  
  type Env        = [(HsName, Term)]
  type FreshVars  = (Int, Int, Int)   
  
  tvarCtr (x,_,_) = x
  funCtr  (_,x,_) = x
  valCtr  (_,_,x) = x
  
  incTvarCtr (x,y,z)  = (x+1, y, z)
  incFunCtr  (x,y,z)  = (x, y+1, z)
  incValCtr  (x,y,z)  = (x, y, z+1)
  
  valName fvs     = UnQual $ 'x' : show (valCtr fvs)
  funName fvs     = UnQual $ [chr (funCtr fvs + ord 'f')]
  tvarName fvs    = UnQual $ [chr (tvarCtr fvs + ord 'A')]
  
  
  newtype FM a    = FM ( (FreshVars, Env) -> (a, FreshVars) )
  
  instance Monad FM where
      return x        = FM (\(fvs, e) -> (x, fvs))
      FM f >>= g      = FM bind
          where
          bind (fvs, e) =  
              let (a, fvs')   = f (fvs, e)
                  FM h        = g a
              in h (fvs', e)
  
  inExtendedEnv :: HsName -> Term -> FM a -> FM a
  inExtendedEnv n t (FM f) = FM (\(fvs, e) -> f (fvs, (n, t):e))
  
  lookUp :: HsName -> FM Term
  lookUp n = FM (\(fvs, e) -> (maybe no id (lookup n e), fvs))
      where
      no = error $ "lookUp: " ++ (show n) ++ " not in environment."
  
  
  newVar :: Type -> FM Term
  newVar t = FM f
      where
      f (fvs, e) = if isFun t
          then ( (hsEVar (funName fvs) ,t) , incFunCtr fvs ) 
          else ( (hsEVar (valName fvs) ,t) , incValCtr fvs ) 
  
  newTVar :: FM Type
  newTVar = FM f
      where
      f (fvs, e)  = (mkTyVar (tvarName fvs), incTvarCtr fvs)
  
  
  run :: FM a -> a
  run (FM f) = let (v, _) = f ((0,0,0), []) in v
  
  
  --
  --------------------------------------------------------------------------------
  
  
  