TiClassInst.hs

module TiClassInst where
import List((\\))
import Maybe(fromMaybe)

import HasBaseStruct(hsClassDecl,hsInstDecl,hsId,hsLit,hsApp,hsPId,hsPatBind)
import HsLiteral
import HsGuardsStruct
--import TiPrelude(prelError)
--import SrcLoc(SrcLoc,srcLoc)
import TI
--import TiDkc(Dinst)
--import TiSolve(matches)
import PrettyPrint
import MUtils
import TiClassInst2(tcInstOrClassDecl'')

tcClassDecl src ctx cl fdeps ds = -- a quick hack...
  do mnames <- methodNames cl -- or extract mnames from msigs...
     prelError <- prelValue "error"
     let (msigs,defaults) = splitMethodSigs ds
	 lacksDefault = mnames \\ definedValueNames ds
         defaultDefaults = toDefs (map (defaultDefault prelError) lacksDefault)
	 defds = defaults `appendDef` defaultDefaults
     ds' <- mapDefinedNames defaultName # tcClassDecl' src [cl] cl defds
     msigs':>:_ <- tcLocalDecls msigs -- kind check + type conversion
     return $
       hsClassDecl src ctx cl fdeps (rmDeclsType msigs') `consDef` ds'
  where
    defaultDefault prelError m = hsPatBind src (hsPId m) (HsBody body) noDef
       where
         body = hsId prelError `hsApp`
                hsLit src (HsString ("No default for method "++pp m))

tcInstDecl src optn ictx inst ds =
  do mnames <- methodNames inst
     let lacksDef = mnames \\ definedValueNames ds
         defds = toDefs (map useDefault lacksDef)
	 mds = ds `appendDef` defds
     ds' <- tcInstDecl' src ictx inst mds
     modmap <- getModule
     let n = fromMaybe (instName' modmap src inst) optn
     return $ oneDef $ hsInstDecl src (Just n) ictx inst ds'
  where
    useDefault m@(HsVar v) = hsPatBind src (hsPId m) (HsBody (hsId dm)) noDef
      where dm = HsVar (defaultName v)

methodNames cl =
  do Class _ _ _ ms <- snd # env kenv (definedType cl)
     let mnames:>:_ = unzipTyped ms
     return mnames

tcInstDecl' = tcInstOrClassDecl' False
tcClassDecl' = tcInstOrClassDecl' True

{-
tcInstOrClassDecl'
  :: (TypeId i,Printable i,Fresh i,
      Printable dsin, DefinedNames i dsin,
      TypeCheckDecls i dsin dsout)
  => Bool -> SrcLoc -> [Pred i] -> Type i -> dsin -> TI i dsout
-}
tcInstOrClassDecl' isClass src ictx inst ds =
  snd # tcInstOrClassDecl'' isClass src ictx inst ds
{-
tcInstOrClassDecl' isClass src ictx inst ds =
  do let cname = definedType inst
     (k,Class super0 cvs0 fundeps0 ms0) <- env kenv cname
     let cl0 = appT (ty cname:map tyvar cvs0)
     (cl,ms) <- allfresh (cl0,ms0) --since `matches` requires disjoint vars
     let ims = definedValueNames ds
	 ns:>:_ = unzipTyped ms
     case ims \\ ns of
       badms@(_:_) ->
         fail ("Extra bindings in "++dkind++" declaration: "++pp badms)
       [] -> errmap (("In "++dkind++" "++pp inst++"\n")++) $
             do s <- inst `matches` cl =<< getKEnv
		let mts = (map.fmap) (addctx (apply s ictx))
			             (apply s ms)
		ds' <-
		  --errmap (("Method signatures:\n"++pp mSigs++"\n")++) $
		  tcInstDecls mts ds -- (toDefs mSigs `appendDef` ds)
	        return ds'
  where
    dkind = if isClass then "class" else "instance"
    addctx ictx (Forall vs (ctx:=>t)) = uscheme ((ictx++ctx):=>t)
--  mSig m@(HsVar n) = do Forall vs (ctx:=>t) <- sch m
--		          return $ hsTypeSig src [n] (ictx++ctx) t
-}