module ReAssocBaseStruct where
import BaseSyntaxStruct
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 = HsPInfixApp
isInfixApp p =
case p of
HsPInfixApp p1 op p2 -> Just (p1,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 i ds) where
getInfixDecls (HsModule _ _ _ ds) = getInfixDecls ds
instance (Eq i,DefinedNames i ds,HasInfixDecls i ds,ReAssoc i ds)
=> ReAssoc i (HsModuleI i ds) where
reAssoc env (HsModule n e i ds) = HsModule 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 p e stmt -> HsGenerator (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 op p2
_ -> mapPI id (reAssoc env) p
extendOps env ds = extend2 (defaultOps env ns) (getInfixDecls ds)
where
ns = definedVars ds