content: module ReAssocBaseStruct where
  import BaseSyntax
  import ReAssoc
  import HsAssoc
  --import TypedIds
  import DefinedNames
  --import DefinedNamesBaseStruct
  
  
  instance HasInfixApp i (EI i e p ds t c) e where
    infixApp = HsInfixApp
    isInfixApp e =
      case e of
        HsInfixApp e1 op e2 -> Just (e1,op,e2)
        _ -> Nothing
  
  instance HasInfixApp i (PI i p) p where
    infixApp p1 (HsCon c) p2 = HsPInfixApp p1 c p2
    isInfixApp p =
      case p of
        HsPInfixApp p1 op p2 -> Just (p1,HsCon op,p2)
        _ -> Nothing
  
  instance HasInfixDecls i (DI i e p ds t c tp) where
    getInfixDecls d =
      case d of
        HsInfixDecl s f ns -> OperatorEnv [(n,f)|n<-ns]
        _ -> OperatorEnv []
  
  instance HasInfixDecls i ds => HasInfixDecls i (HsModuleI m i ds) where
    getInfixDecls = getInfixDecls . hsModDecls
  
  instance (Eq i,DefinedNames i ds,HasInfixDecls i ds,ReAssoc i ds)
            => ReAssoc i (HsModuleI m i ds) where
    reAssoc env (HsModule s n e i ds) = HsModule s n e i (reAssoc env' ds)
      where env' = extendOps env ds
  
  instance (Eq i,ReAssoc i e,ReAssoc i p,DefinedNames i p,
            HasInfixDecls i ds,ReAssoc i ds,DefinedNames i ds)
  	  => ReAssoc i (DI i e p ds t c tp) where
    reAssoc env d =
       case d of
         HsFunBind s ms -> HsFunBind s (map r ms)
         HsPatBind s p rhs ds -> HsPatBind s (reAssoc env p) (r rhs) (r ds)
           where r x = reAssoc env' x
  	       env' = rhsOps env p ds
         _ -> mapDI id r r r id id id d
     where r x = reAssoc env x
  
  instance ReAssoc i e => ReAssoc i (HsRhs e) where
    reAssoc = mapRhs . reAssoc
  
  instance (Eq i,HasInfixApp i e e,ReAssoc i e,
  	  DefinedNames i p,HasInfixApp i p p,ReAssoc i p,
            ReAssoc i ds,HasInfixDecls i ds,DefinedNames i ds)
            => ReAssoc i (EI i e p ds t c) where
    reAssoc env e =
      case e of
        HsInfixApp e1 op e2 -> reAssocOp env e1 op e2
        HsLet ds e -> HsLet (reAssoc env' ds) (reAssoc env' e)
          where env' = extendOps env ds
        HsLambda ps e -> HsLambda ps (reAssoc env' e)
          where env' = defaultOps env (definedVars ps)
        HsCase e alts -> HsCase (r e) (map r alts)
        HsDo stmts -> HsDo (reAssoc env stmts)
        HsListComp stmts -> HsListComp (reAssoc env stmts)
        _ -> mapEI id r r r id id e
      where r x = reAssoc env x
  
  instance (Eq i,ReAssoc i e,ReAssoc i p,DefinedNames i p,
  	  ReAssoc i ds,DefinedNames i ds,HasInfixDecls i ds)
            => ReAssoc i (HsStmt e p ds) where
    reAssoc env stmt =
        case stmt of
  	HsGenerator s p e stmt -> HsGenerator s (r p) (r e) (r' stmt)
  	  where r' = reAssoc (defaultOps env (definedVars p))
  	HsQualifier   e stmt -> HsQualifier (r e) (r stmt)
  	HsLetStmt    ds stmt -> HsLetStmt   (r' ds) (r' stmt)
            where r' x = reAssoc (extendOps env ds) x
  	HsLast        e      -> HsLast      (r e)
      where r x = reAssoc env x
  
  instance (Eq i,ReAssoc i e,ReAssoc i p,DefinedNames i p,
  	  ReAssoc i ds,DefinedNames i ds,HasInfixDecls i ds)
  	  => ReAssoc i (HsAlt e p ds) where
    reAssoc env (HsAlt s p rhs ds) = HsAlt s (reAssoc env p) (r rhs) (r ds)
      where
        r x = reAssoc env' x
        env' = rhsOps env p ds
  
  instance (Eq i,ReAssoc i e,ReAssoc i p,DefinedNames i p,
  	  ReAssoc i ds,DefinedNames i ds,HasInfixDecls i ds)
  	  => ReAssoc i (HsMatchI i e p ds) where
    reAssoc env (HsMatch s n ps rhs ds) =
        HsMatch s n (map (reAssoc env) ps) (r rhs) (r ds)
      where
        r x = reAssoc env' x
        env' = rhsOps env ps ds
  
  rhsOps env p ds = extendOps (defaultOps env (definedVars p)) ds
  
  instance (Eq i,HasInfixApp i p p,ReAssoc i p) => ReAssoc i (PI i p) where
    reAssoc env p =
      case p of
        HsPInfixApp p1 op p2 -> reAssocOp env p1 (HsCon op) p2
        _ -> mapPI id (reAssoc env) p
  
  extendOps env ds = extend2 (defaultOps env ns) (getInfixDecls ds)
    where
      ns = definedValues ds
  