content: module TiFields where
  import HasBaseStruct
  import BaseSyntaxStruct
  import HsFieldsStruct
  import TI
  import MUtils
  --import SpecialNames -- debug
  
  instance (--IsSpecialName i, -- debug
  	  ValueId i,TypeVar i,Fresh i,TypeCheck i e (Typed i e2))
        => TypeCheck i (HsFieldsI i e) (Typed i (HsFieldsI i e2)) where
    tc fs=
      do fs:>:ts <- unzipTyped # mapM tc fs
         t <- allSame ts
         fs>:t
  
  instance (--IsSpecialName i, -- debug
            ValueId i,TypeVar i,Fresh i, TypeCheck i e (Typed i e2))
        => TypeCheck i (HsFieldI i e) (Typed i (HsFieldI i e2)) where
    tc=tcHsField
  
  tcHsField (HsField f e) =
    do ft <- inst_field (HsVar f)
       e':>:et <- tc e
       r <- tfresh
       hsTyFun r et =:= ft
       HsField f e'>:r
  
  tcFieldsPat c = tcFieldsCon' hsPRec c
  tcFieldsCon s c = tcFieldsCon' (hsRecConstr s) c
  
  tcFieldsCon' appf c = tcFields appf bM
    where
      bM = do tcon <- inst_field (HsCon c)
  	    c>:resultType tcon
      resultType (Typ t) =
        case t of
          HsTyFun _ t -> resultType t
  	_ -> Typ t
  
  tcFieldsUpd s bM = tcFields (hsRecUpdate s) bM
  
  tcFields c bM fields =
    do b:>:bt <- bM
       fs:>:ft <- tc fields
       bt=:=ft
       c b fs>:bt
  