{- | Renames identifiers (also patches fixity information) Also provides: * 'ctxs2NT' to transform syntax tree type into internal type * 'fixInstance' used by module "Derive" -} module Rename(ctxs2NT, fixInstance, rename) where import List import Syntax import Bind(bindPat,bindDecls,identPat) import RenameLib(ImportState,RenameState,RenameMonad ,keepRS,is2rs,renameError ,popScope,pushScope,globalTid,fixFixityRS,localTid,defineType ,transTypes,defineDataPrim,uniqueTid,defineDerived,defineData ,defineClass,transContext,defineDefault,defineVar,defineMethod ,transType,defineDefaultMethod,defineInstMethod,uniqueTVar ,defineField,defineConstr,checkPuns,bindNK) import Fixity(fixInfixList) import IExtract(tvPosTids,freeType,tvTids,countArrows,defFixFun) import TokenId(tTrue,t_noMethodError,extractV{-,tEval-},t_lessequal,t_subtract) import State import IdKind import Util.Extra import NT import IntState import qualified Data.Map as Map import SysDeps(PackedString,unpackPS) import SyntaxPos import SyntaxUtil(infixFun,isTypeVar) import MkSyntax(desugarListComp,desugarListEnum) import Id(Id) import Overlap(Overlap) import Flags(Flags) import Maybe import Error {- | Uniquely rename all identfiers (also patch fixity) -} rename :: Flags -> PackedString -> (TokenId -> [TokenId]) -> ((TokenId->Bool) -> TokenId -> IdKind -> IE) -> [(InfixClass TokenId,Int,[FixId TokenId])] -> Decls TokenId -- declarations of program -> ImportState -> Overlap -> Either [Error] ( Decls Id -- renamed declarations of program , IntState -- internal state with symbol table , (TokenId,IdKind) -> Id -- tidFun , (TokenId,IdKind) -> Maybe Id -- tidFunSafe , [(Id,[(Pos,Id)])] -- derived , Maybe [Id] -- userDefault , Map.Map (TokenId,IdKind) (Either [Pos] [Id]) -- rename tree? ) rename flags mrps qualFun expFun inf topdecls importState overlap = case is2rs flags mrps qualFun expFun overlap importState :: (Either [Error] (TokenId -> TokenId ,TokenId -> IdKind -> IE ,RenameState ,Map.Map (TokenId,IdKind) (Either [Pos] [Id]))) of Right (qualFun,expFun,state,irt) -> case renameTopDecls inf topdecls qualFun expFun state :: (Decls Id,RenameState) of (DeclsParse topdecls,state) -> case keepRS state of (unique,(tidFun,tidFunSafe),rps,ts,derived,userDefaults,[]) -> case mapS (fixInstance (tidFun (tTrue,Con))) topdecls () (IntState unique rps ts [] flags) of (topdecls,state) -> Right (DeclsParse topdecls,state,tidFun,tidFunSafe ,derived,userDefaults,irt) (unique,(tidFun,tidFunSafe),rps,st,derived,userDefaults,errors) -> Left errors Left errors -> Left errors ---- =============================== {- In the input of this function every equation is a function declaration of its own, as produced by the parser. This function groups succeeding equations for the same function/variable identifier into a single function declaration. -} groupFun :: Eq a => Decls a -> Decls a groupFun (DeclsParse decls) = DeclsParse (groupFun' decls) where groupFun' :: Eq a => [Decl a] -> [Decl a] groupFun' [] = [] groupFun' (d@(DeclFun _ _ [Fun [] _ _]):r) = d: groupFun' r groupFun' (DeclFun pos fun funs:r) = DeclFun (mergePos pos (getPos funs')) fun (funs++funs'): groupFun' r' where (funs',r') = groupFun'' fun [] r groupFun' (d@(DeclPat (Alt (ExpVar pos fun) gdexps w)):r) = groupFun' (DeclFun (mergePoss [pos,getPos gdexps,getPos w]) fun [Fun [] gdexps w]:r) groupFun' (d@(DeclPat (Alt (ExpInfixList pos es) gdexps w)):r) = case infixFun es of Nothing -> d: groupFun' r Just (e1,pos',fun',e2) -> groupFun' (DeclFun (mergePoss [pos,getPos gdexps,getPos w]) fun' [Fun [e1,e2] gdexps w]:r) groupFun' (d:r) = d: groupFun' r groupFun'' :: Eq a => a -> [Fun a] -> [Decl a] -> ([Fun a],[Decl a]) groupFun'' fun acc (DeclFun pos fun' funs:r) | fun == fun' = groupFun'' fun (acc++funs) r groupFun'' fun acc (d@(DeclPat (Alt (ExpVar pos fun') gdexps w)):r) = groupFun'' fun acc (DeclFun (mergePoss [pos,getPos gdexps,getPos w]) fun' [Fun [] gdexps w]:r) groupFun'' fun acc dr@(DeclPat (Alt (ExpInfixList pos es) gdexps w):r) = case infixFun es of Nothing -> (acc,dr) Just (e1,pos',fun',e2) -> groupFun'' fun acc (DeclFun (mergePoss [pos,getPos gdexps,getPos w]) fun' [Fun [e1,e2] gdexps w]:r) groupFun'' fun acc r = (acc,r) {- | Rename statements of a do expression -} renameStmts :: [Stmt TokenId] -> RenameMonad [Stmt Id] renameStmts (StmtExp exp:[]) = renameExp exp >>>= \ exp -> unitS [StmtExp exp] renameStmts (StmtExp exp:r) = renameExp exp >>>= \ exp -> renameStmts r >>>= \ r -> unitS (StmtExp exp:r) renameStmts (StmtBind pat exp:r) = if null r then renameError (ErrorRaw $ "Lambda statement at " ++ strPos (getPos pat) ++ " can not end statement list") [StmtExp (PatWildcard (getPos pat))] else renameExp exp >>>= \ exp -> pushScope >>> bindPat Var pat >>> renameExp pat >>>= \ pat -> renameStmts r >>>= \ r -> unitS (StmtBind pat exp:r) >>> popScope renameStmts (StmtLet decls':r) = if null r then renameError (ErrorRaw $ "Let statement at " ++ strPos (getPos decls') ++ " can not end statement list") [StmtExp (PatWildcard (getPos decls'))] else let decls = groupFun decls' in pushScope >>> bindDecls decls >>> renameDecls decls >>>= \ decls -> renameStmts r >>>= \ r -> unitS (StmtLet decls:r) >>> popScope ---- ============================== renameTopDecls :: [(InfixClass TokenId,Int,[FixId TokenId])] -> Decls TokenId -> (TokenId -> TokenId) -> (TokenId -> IdKind -> IE) -> RenameState -> (Decls Id,RenameState) renameTopDecls inf topdecls1 qualFun expFun state1 = let (DeclsParse topdecls') = groupFun topdecls1 -- group equations for same function definition together fixdecls = sepFixDecls topdecls' -- separate fixity declarations state2 = (pushScope >>> bindDecls (DeclsParse topdecls') ) (globalTid,qualFun,expFun) state1 -- store all defined term variables and class ids in a memo (fixity,state3) = fixFixityRS defFixFun state2 (inf++fixdecls) (topdecls2,state4) = (mapS renameDecl topdecls' >>> popScope ) (globalTid,qualFun,expFun,fixity) state3 in (DeclsParse topdecls2,state4) sepFixDecls :: [Decl id] -> [FixDecl id] sepFixDecls = concatMap (\decl-> case decl of DeclFixity f -> [f] _ -> []) renameDecls :: Decls TokenId -> RenameMonad (Decls Id) renameDecls (DeclsParse decls) (_,qualFun,expFun,fixity2) state3 = let (fixity3,state4) = fixFixityRS fixity2 state3 (sepFixDecls decls) in (unitS DeclsParse =>>> (mapS renameDecl) decls) (localTid,qualFun,\ _ _ -> IEnone,fixity3) state4 renameDecl :: Decl TokenId -> RenameMonad (Decl Id) renameDecl (DeclType (Simple pos tid tvs) typ) = let al = tvPosTids tvs in transTypes al (map snd al) [] [typ] >>>= \nt -> defineType tid nt >>>= \d -> -- extend symbol table unitS (DeclTypeRenamed pos d) -- new abstract syntax construct {- renameDecl (DeclType (Simple pos tid tvs) typ) = let al = tvPosTids tvs in transTypes al (map snd al) [] [typ] >>>= \nt -> defineType tid nt >>>= \d -> -- gross hack -- remove definition of type synonym from syntax tree -- unitS (DeclIgnore "Type Synonym") unitS (DeclAnnot (DeclIgnore "Type Synonym") [AnnotArity (pos, d) 0]) -- in a way such that it can still be recognised in DbgDataTrans -} renameDecl (DeclDataPrim pos tid size) = uniqueTid pos TCon tid >>>= \i -> defineDataPrim tid (NewType [] [] [] [mkNTcons i []]) size >>>= \d -> unitS (DeclConstrs pos d []) renameDecl (DeclData b ctxs (Simple pos tid tvs) constrs posidents) = let al = tvPosTids tvs free = map snd al in transTypes al free ctxs (map (uncurry TypeVar) tvs ++ [TypeCons pos tid (map (uncurry TypeVar) tvs)]) >>>= \nt@(NewType free [] ctxs nts) -> {- example: data Num a => Test a b = A a | B b nt = NewType [1,2] [] [(NumId, 1)] [mkNTvar 1, mkNTvar 2, mkNTcons TestId [mkNTvar 1, mkNTvar 2]] -} mapS (renameConstr tid al ctxs (last nts)) constrs >>>= \csfields -> let (cs,noargs,fields) = unzip3 csfields in defineData b tid nt cs >>>= \d -> renamePosIdents TCon ({-(pos,tEval):-}posidents) >>>= \ posis -> defineDerived d posis >>> (if b == Just True && length constrs > 1 && not (and noargs) then renameError (ErrorRaw $ "Unboxed data " ++ show tid ++ " at " ++ strPos pos ++ " is neither an enumeration nor a single constructor data type.") else unitS) (DeclConstrs pos d (concat fields)) renameDecl (DeclClass pos ctxs tid [tvar] [] decls') = let al = tvTids [tvar] (DeclsParse decls) = groupFun decls' in transTypes al (map snd al) ctxs [TypeCons pos tid [TypeVar pos tvar]] >>>= \nt -> transContext al (Context pos tid [(pos,tvar)]) >>>= \ctx@(c,t) -> fixClassMethods tid tvar ctx decls >>>= \declmds -> defineClass pos tid nt (map snd declmds) >>> unitS (DeclClass pos [] c [t] [] (DeclsParse (map fst declmds))) renameDecl (DeclClass pos ctxs tid (tvar:_) _ decls') = let al = tvTids [tvar] in transContext al (Context pos tid [(pos,tvar)]) >>>= \ctx@(c,t) -> renameError (ErrorRaw $ "Multi-parameter type-classes (used at "++strPos pos ++") are not supported.") (DeclClass pos [] c [t] [] (DeclsParse [])) renameDecl (DeclInstance pos ctxs tid [instanceType@(TypeCons _ tcon tvs)] instmethods') | all isTypeVar tvs = let al = tvTids (snub (freeType instanceType)) (DeclsParse instmethods) = groupFun instmethods' in mapS (renameCtx al) ctxs >>>= \ ctxs -> uniqueTid pos TClass tid >>>= \ c -> renameType al instanceType >>>= \ typ -> mapS (renameInstMethod) instmethods >>>= \ ims -> unitS (DeclInstance pos ctxs c [typ] (DeclsParse ims)) renameDecl (DeclInstance pos ctxs tid (inst:_) instmethods') = uniqueTid pos TClass tid >>>= \ c -> renameError (ErrorRaw $ "Multi-parameter type-classes (used at "++strPos pos ++") are not supported.") (DeclInstance pos [] c [] (DeclsParse [])) renameDecl (DeclDefault types) = mapS (renameType []) types >>>= \ types -> defineDefault types >>> unitS (DeclIgnore "Type Defaults") renameDecl (DeclVarsType posidents ctxs typ) = let al = (tvTids . snub . freeType) typ in unitS DeclVarsType =>>> renamePosIdents Var posidents =>>> mapS (renameCtx al) ctxs =>>> renameType al typ renameDecl (DeclPat alt) = unitS DeclPat =>>> renameDeclAlt alt renameDecl (DeclFun pos tid funs) = unitS (DeclFun pos) =>>> defineVar tid =>>> mapS renameFun funs renameDecl d@(DeclPrimitive pos tid arity typ) = let al = (tvTids . snub . freeType) typ in defineVar tid >>>= \ tid -> renameType al typ >>>= \ typ -> unitS (DeclPrimitive pos tid arity typ) renameDecl d@(DeclForeignImp pos callConv str tid arity cast typ _) = let al = (tvTids . snub . freeType) typ in defineVar tid >>>= \ tid -> renameType al typ >>>= \ typ -> unitS (DeclForeignImp pos callConv str tid arity cast typ tid) renameDecl d@(DeclForeignExp pos callConv str tid typ) = let al = (tvTids . snub . freeType) typ in defineVar tid >>>= \ tid -> renameType al typ >>>= \ typ -> unitS (DeclForeignExp pos callConv str tid typ) -- Used for unimplemented things renameDecl d@(DeclIgnore str) = unitS (DeclIgnore str) renameDecl d@(DeclError str) = unitS (DeclError str) renameDecl (DeclAnnot decl annots) = error "DeclAnnot" renameDecl d@(DeclFixity f) = unitS (DeclIgnore "fixity") {- ======================== Functions for renaming parts of a class definition -} {- | Rename all methods (type declarations and default definitions) of a class and make appropriate entries in the symbol table. -} fixClassMethods :: TokenId {- class name -} -> TokenId {- type variable of this class definition -} -> (Id,a) {- this class identifier, type variable identifier -} -> [Decl TokenId] {- declarations of the class definition -} -> RenameMonad [(Decl Id,(Id,Id))] {- returns with each default definition identifier of type declaration and identifier of default definition -} fixClassMethods cid tvar ctx decls = case partition isSignature decls of (sgn,def) -> mapS (renameMethod cid tvar ctx) sgn >>>= \ ms -> mapS renameDefault (pairDefault (concat ms) def) {- -- For type declaration of a method: -- Renames identifiers and translates type into internal type. -- Adds respective entries to symboltable. -- Note: the declaration may declare the type of several methods. -} renameMethod :: TokenId {- class name -} -> TokenId {- type variable of this class definition -} -> (Id,a) {- class predicate (class, type variable) -} -> Decl TokenId {- type declaration of method(s) -} -> RenameMonad [(Pos,TokenId,Id)] {- position, token and identifier of each method -} renameMethod cid tvar ctx@(c,tv) (DeclVarsType postids ctxs typ) = let al = tvTids (snub (tvar:freeType typ)) -- ^ necessary that type variable for the class context is the same! arity = countArrows typ in mapS (transContext al) ctxs >>>= \ ctxs -> transType al typ >>>= \ typ -> let free = map snd al nt = NewType free [] ({-ctx:-}ctxs) [anyNT [head free] typ] -- ^ The class context is not included in the type in mapS (\(pos,tid) -> defineMethod pos tid nt arity c cid >>>= \ m -> unitS (pos,tid,m)) postids renameDefault :: (Decl TokenId,a) -> RenameMonad (Decl Id,(a,Id)) {- returns with each default definition identifier of type declaration and identifier of default definition -} renameDefault (DeclFun pos tid funs,s) = defineDefaultMethod tid >>>= \ i -> mapS renameFun funs >>>= \ funs -> unitS (DeclFun pos i funs,(s,i)) {- -- Renames method definition of an instance definition. -} renameInstMethod :: Decl TokenId -> RenameMonad (Decl Id) renameInstMethod (DeclFun pos tid funs) = defineInstMethod tid >>>= \ i -> mapS renameFun funs >>>= \ funs -> unitS (DeclFun pos i funs) {- tests if declaration is type declaration -} isSignature :: Decl a -> Bool isSignature (DeclVarsType posidents ctxs typ) = True isSignature _ = False {- -- Pair each type declaration of a method (identifier referring to symboltable) -- with its default definition. -- Drop default definition, if no type declaration for it present (warning). -- Make default definition that will abort, if no default definition present. -} pairDefault :: [(Pos,TokenId,a)] -> [Decl TokenId] -> [(Decl TokenId,a)] pairDefault ms [] = map mkDMethod ms pairDefault ms (DeclPat alt:r) = error " Sorry no left hand patterns in classes:-(" pairDefault ms (d@(DeclFun pos tid funs):r) = case partition ((tid==).snd3) ms of ([],ms) -> strace ("Dropping function " ++ show tid ++ " at " ++ strPos pos ++ " without signature in class.") (pairDefault ms r) ([(p,m,i)],ms) -> (d,i) : pairDefault ms r -- covers all cases under assumption of no duplicate type declarations pairDefault ms (DeclIgnore str:r) = pairDefault ms r pairDefault ms (DeclFixity f:r) = pairDefault ms r {- -- Make default method out of thin air for given method identifier. -- The default method just calls "error" with suitable string. -} mkDMethod :: (Pos,TokenId,a) -> (Decl TokenId,a) mkDMethod (pos,tid,i) = (DeclFun noPos tid [Fun [] (mkNoDefault noPos tid) (DeclsParse [])],i) -- (DeclFun pos tid [Fun [] (mkNoDefault pos tid) (DeclsParse [])],i) mkNoDefault :: Pos -> TokenId -> Rhs TokenId mkNoDefault pos tid = Unguarded $ ExpApplication pos [ExpVar pos t_noMethodError ,ExpLit pos (LitString Boxed ("No default definition for class method " ++ show tid)) ] ---- ========================= renamePosIdents :: IdKind -> [(Pos, TokenId)] -> RenameMonad [(Pos, Id)] renamePosIdents kind posidents = mapS (renamePosIdent kind) posidents renamePosIdent :: IdKind -> (Pos, TokenId) -> RenameMonad (Pos, Id) renamePosIdent kind (pos,tid) = unitS (pair pos) =>>> uniqueTid pos kind tid renameFun :: Fun TokenId -> RenameMonad (Fun Id) renameFun (Fun pats rhs decls') = let decls = groupFun decls' in pushScope >>> mapS0 (bindPat Var) pats >>> pushScope >>> bindDecls decls >>> renameDecls decls >>>= \newdecls -> -- do first, to get infix right unitS Fun =>>> mapS renameExp pats =>>> renameRhs rhs =>>> unitS newdecls >>> popScope >>> popScope renameRhs :: Rhs TokenId -> RenameMonad (Rhs Id) renameRhs (Unguarded exp) = unitS Unguarded =>>> renameExp exp renameRhs (PatGuard gdExps) = unitS PatGuard =>>> mapS renamePatGuardExp gdExps renamePatGuardExp (quals,exp) = pushScope >>> renameQuals exp quals >>> popScope renameQuals rhs [] = renameExp rhs >>>= \ rhs -> unitS ([],rhs) renameQuals rhs (QualExp exp:r) = renameExp exp >>>= \ exp -> renameQuals rhs r >>>= \ (r,rhs) -> unitS (QualExp exp:r, rhs) renameQuals rhs (QualPatExp pat exp:r) = renameExp exp >>>= \ exp -> pushScope >>> bindPat Var pat >>> renameExp pat >>>= \ pat -> renameQuals rhs r >>>= \ (r, rhs) -> unitS (QualPatExp pat exp:r, rhs) >>> popScope renameQuals rhs (QualLet decls':r) = if null r then renameExp rhs >>>= \ rhs -> renameError (ErrorRaw $ "Let statement at " ++ strPos (getPos decls') ++ " can not end pattern guard") -- dubious of this ([QualExp (PatWildcard (getPos decls'))], rhs) else let decls = groupFun decls' in pushScope >>> bindDecls decls >>> renameDecls decls >>>= \ decls -> renameQuals rhs r >>>= \ (r, rhs) -> unitS (QualLet decls:r, rhs) >>> popScope renameDeclAlt :: Alt TokenId -> RenameMonad (Alt Id) renameDeclAlt (Alt pat rhs decls') = let decls = groupFun decls' in mapS (defineVar . snd) (identPat pat) >>>= \_ -> -- don't need the identifiers here pushScope >>> bindDecls decls >>> -- bindPat done earlier renameDecls decls >>>= \newdecls-> -- do first, to get infix right unitS Alt =>>> renameExp pat =>>> renameRhs rhs =>>> unitS newdecls >>> popScope renameCaseAlt :: Alt TokenId -> RenameMonad (Alt Id) renameCaseAlt (Alt pat rhs decls') = let decls = groupFun decls' in pushScope >>> bindPat Var pat >>> bindDecls decls >>> renameDecls decls >>>= \newdecls-> -- do first, to get infix right unitS Alt =>>> renameExp pat =>>> renameRhs rhs =>>> unitS newdecls >>> popScope renameType :: [(TokenId,Id)] -> Type TokenId -> RenameMonad (Type Id) renameType al (TypeApp t1 t2) = unitS TypeApp =>>> renameType al t1 =>>> renameType al t2 renameType al (TypeCons pos tid types) = unitS (TypeCons pos) =>>> uniqueTid pos TCon tid =>>> mapS (renameType al) types renameType al (TypeVar pos tid) = unitS (TypeVar pos) =>>> uniqueTVar pos al tid renameCtx :: [(TokenId,Id)] -> Context TokenId -> RenameMonad (Context Id) renameCtx al (Context pos tid [(p,t)]) = uniqueTid pos TClass tid >>>= \ i -> uniqueTVar p al t >>>= \ t -> unitS (Context pos i [(p,t)]) renameCtx al (Context pos tid _) = uniqueTid pos TClass tid >>>= \ i -> renameError (ErrorRaw $ "Multi-parameter type-classes (used at "++strPos pos ++") are not supported.") (Context pos i []) {- | For a constructor with type arguments as appearing on rhs of data or newtype: Make appropriate entries in symboltable. -} renameConstr :: TokenId {- ^ type constructor of data\/newtype def. -} -> [(TokenId,Id)] {- ^ canonically enumerated free type vars -} -> [(Id,Id)] {- ^ context of the data\/newtype def. -} -> NT {- ^ defined type (type constructor with vars)-} -> Constr TokenId {- ^ constructor with type arguments -} -> RenameMonad (Id,Bool,[(Pos,Id,Id)]) {- ^ constructor id, no arguments, fields -} renameConstr typtid al ctxs resType@(NTcons bt _ _) c@(Constr pos tid fieldtypes) = let e = [] -- no forall if Constr is used es = zip e [toEnum (1 + length al) .. ] in mapS (transFieldType (es++al)) fieldtypes >>>= \ntss -> let all = concat (ntss :: [[(Maybe (Pos,TokenId,Id),NT)]]) nts = map snd all ifs :: [Maybe Id] ifs = map ( (\v -> case v of Just (p,tid,i) -> Just i; _ -> Nothing) . fst) all exist = map snd es in defineConstr typtid tid (NewType (map snd al ++ exist) exist ctxs (nts++[resType])) ifs bt >>>= \ c -> mapS (defineField typtid bt c) (zip all [ 1:: Int ..]) >>>= \ fs -> unitS (c,null nts,map fromJust (filter isJust fs)) renameConstr typtid al ctxs resType@(NTcons bt _ _) (ConstrCtx forAll ectxs' pos tid fieldtypes) = let -- ce = map ( \( Context _ _ [(_,v)]) -> v) ectxs' e = map snd forAll -- filter (`notElem` (map fst al)) $ snub $ (ce ++) $ -- concat $ map (freeType . snd) fieldtypes es = zip e [toEnum (1 + length al) .. ] in mapS (transFieldType (es++al)) fieldtypes >>>= \ntss -> let all = concat ntss nts = map snd all ifs = map ( (\v -> case v of Just (p,tid,i) -> Just i; _ -> Nothing) . fst) all exist = map snd es in mapS (transContext (es++al)) ectxs' >>>= \ ectxs -> defineConstr typtid tid (NewType (map snd al ++ exist) exist ctxs (map ( \ (c,v) -> NTcontext c v) ectxs ++ nts++[resType])) ifs bt >>>= \ c -> mapS (defineField typtid bt c) (zip all [ 1:: Int ..]) >>>= \ fs -> unitS (c,null nts,map fromJust (filter isJust fs)) {- | For a type in the right hand side of a data\/newtype definition with possibly several field names: translate type into internal type 'NT' -} transFieldType :: [(TokenId,Id)] {- ^canonically ided free variables -} -> (Maybe [(Pos,TokenId)],Type TokenId) {- ^possibly several field names with a given type -} -> RenameMonad [(Maybe (Pos,TokenId,Id),NT)] {- ^possibly several field names with a given type -} transFieldType al (Nothing,typ) = -- nearly identical to transFieldType in IExtract!!! transType al typ >>>= \ typ -> unitS [(Nothing,typ)] transFieldType al (Just posidents,typ) = transType al typ >>>= \ typ -> mapS ( \ (p,v) -> uniqueTid p Field v >>>= \ i -> unitS (Just (p,v,i),typ)) posidents renameField :: Field TokenId -> RenameMonad (Field Id) renameField (FieldExp pos tid exp) = unitS (FieldExp pos) =>>> uniqueTid pos Field tid =>>> renameExp exp renameField (FieldPun pos tid) = checkPuns pos >>> unitS (FieldExp pos) =>>> uniqueTid pos Field tid =>>> (unitS (ExpVar pos) =>>> uniqueTid pos Var tid) renameExp :: Exp TokenId -> RenameMonad (Exp Id) renameExp (ExpScc str exp) = unitS (ExpScc str) =>>> renameExp exp renameExp (ExpLambda pos pats exp) = pushScope >>> mapS0 (bindPat Var) pats >>> unitS (ExpLambda pos) =>>> mapS renameExp pats =>>> renameExp exp >>> popScope renameExp (ExpDo pos stmts) = unitS (ExpDo pos) =>>> renameStmts stmts renameExp (ExpRecord exp fields) = unitS ExpRecord =>>> renameExp exp =>>> mapS renameField fields renameExp (ExpLet pos decls' exp) = let decls = groupFun decls' in pushScope >>> bindDecls decls >>> unitS (ExpLet pos) =>>> renameDecls decls =>>> renameExp exp >>> popScope renameExp (ExpCase pos exp alts) = unitS (ExpCase pos) =>>> renameExp exp =>>> mapS renameCaseAlt alts renameExp (ExpIf pos expCond expThen expElse) = unitS (ExpIf pos) =>>> renameExp expCond =>>> renameExp expThen =>>> renameExp expElse renameExp (ExpType pos exp ctxs typ) = let al = (tvTids . snub . freeType) typ in renameExp exp >>>= \ exp -> mapS (renameCtx al) ctxs >>>= \ ctxs -> renameType al typ >>>= \ typ -> unitS (ExpType pos exp ctxs typ) renameExp e@(ExpListComp pos _ _) = renameExp (desugarListComp e) renameExp e@(ExpListEnum pos _ _ _) = renameExp (desugarListEnum e) renameExp (ExpBrack pos exp) = renameExp exp --- Above only in expressions renameExp (ExpApplication pos exps) = unitS (ExpApplication pos) =>>> mapS renameExp exps renameExp (ExpInfixList pos exps) = fixInfixList exps >>>= \ exp -> renameExp exp renameExp (ExpVar pos tid) = unitS (ExpVar pos) =>>> uniqueTid pos Var tid renameExp (ExpCon pos tid) = unitS (ExpCon pos) =>>> uniqueTid pos Con tid renameExp (ExpVarOp pos tid) = unitS (ExpVarOp pos) =>>> uniqueTid pos Var tid renameExp (ExpConOp pos tid) = unitS (ExpConOp pos) =>>> uniqueTid pos Con tid renameExp e@(ExpLit pos lit) = unitS (ExpLit pos lit) --renameExp (ExpTuple pos exps) = -- unitS (ExpTuple pos) =>>> mapS renameExp exps renameExp (ExpList pos exps) = unitS (ExpList pos) =>>> mapS renameExp exps --- Below only in patterns renameExp (PatAs pos tid pat) = unitS (PatAs pos) =>>> uniqueTid pos Var tid =>>> renameExp pat renameExp e@(PatWildcard pos) = unitS (PatWildcard pos) renameExp (PatIrrefutable pos pat) = unitS (PatIrrefutable pos) =>>> renameExp pat renameExp (PatNplusK pos tid _ k _ _) = bindNK pos >>>= \ tid' -> let leq = ExpVar pos t_lessequal sub = ExpVar pos t_subtract n' = ExpVar pos tid' in unitS (PatNplusK pos) =>>> uniqueTid pos Var tid =>>> uniqueTid pos Var tid' =>>> renameExp k =>>> renameExp (ExpApplication pos [leq,k,n']) =>>> renameExp (ExpApplication pos [sub,k,n']) ----- =================== fixInstance :: Id -> Decl Id -> a -> IntState -> (Decl Id,IntState) fixInstance iTrue (DeclInstance pos ctxs i [instanceType@(TypeCons _ ti tvs)] (DeclsParse instmethods)) = ensureDefaults pos i >>>= \ cinfo -> mapS (\(m,d) -> getInfo m >>>= \minfo -> unitS (minfo,d)) (methodsI cinfo) >>>= \cmds -> getInfo ti >>>= \ tinfo -> getIntState >>>= \ state -> mapS (\(pos,i) -> getInfo i >>>= \info -> unitS (pos,info)) (map getI instmethods) >>>= \ ims -> let free = concatMap (\tv-> case tv of (TypeVar _ v) -> [v]; _ -> []) tvs ctxsNT = ctxs2NT ctxs nt = NewType free [] ctxsNT [mkNTcons ti (map mkNTvar free)] cmds' = map ( \ (info,d) -> (extractV (tidI info),(info,d))) cmds old = map ( \ (pos,info) -> (pos,extractV (tidI info),info)) ims dms = map snd3 old (err,upd) = ( partition isLeft . map ( \ (pos,rps,i) -> case lookup rps cmds' of Just (si,_) -> Right (uniqueI i,uniqueI si) Nothing -> Left (pos,rps)) ) old tidtyp = tidI tinfo tidcls = tidI cinfo mrps = mrpsIS state in instanceError (show tidcls) err >>> addInstance i ti mrps free ctxsNT >>> mapS (mkIMethod pos tidcls tidtyp iTrue nt) (filter ((`notElem` dms).fst) cmds') >>>= \ fill -> mapS0 ((\(im,m) -> updInstMethodNT tidcls tidtyp im nt m) . dropRight) upd >>> unitS (DeclInstance pos ctxs i [instanceType] (DeclsParse (fill++instmethods))) fixInstance iTrue d = unitS d instanceError :: String -> [Either (Pos, PackedString) b] -> State0 d IntState IntState instanceError cstr [] = unitS0 instanceError cstr (Left (pos,rps):xs) = (\ down state -> addError state ("The identifier " ++ reverse (unpackPS rps) ++ " instantiated at " ++ strPos pos ++ " does not belong to the class " ++ cstr ++ ".")) >>> instanceError cstr xs mkIMethod :: Pos -> TokenId -> TokenId -> t -> NewType -> (a, (Info, Id)) -> State d IntState (Decl Id) IntState mkIMethod pos tidcls tidtyp iTrue nt (rpsid,(minfo,d)) = let uniqueM = uniqueI minfo in addInstMethod tidcls tidtyp (tidI minfo) nt uniqueM >>>= \ mi -> unitS (DeclFun pos mi [Fun [] (Unguarded (ExpVar pos d)) (DeclsParse [])]) getI :: Decl id -> (Pos, id) getI (DeclFun pos i funs) = (pos,i) ctxs2NT :: [Context id] -> [(id, id)] ctxs2NT ctxs = map ctx2NT ctxs where ctx2NT (Context pos c [(p,v)]) = (c,v) ensureDefaults :: Pos -> Id -> State t IntState Info IntState ensureDefaults pos i down state = case lookupIS state i of Just info@(InfoClass u tid e nt ms ds inst) -> if length ms == length ds then (info,state) else case uniqueISs state ms of (mds,state) -> let newInfo = InfoClass u tid e nt ms (map snd mds) inst in (newInfo ,foldr (addDefaultMethod tid) (updateIS state i ( \ _ -> newInfo)) mds ) ------ ===================