{- | Needs 'IdSupply'. -} module RenameLib(module RenameLib ,ImportState,NT,NewType,IE,Either,Info ,Maybe,Flags) where import List import TokenId(TokenId(..),t_Tuple,ensureM,mkQual2,visible,mkQual3,mkQualD ,rpsPrelude,forceM) import Syntax hiding (TokenId) import Scc import NT import Util.Extra import Maybe import qualified Data.Map as Map import ImportState hiding (TokenId) import IntState(checkNT) import IExtract(fixOne,fixFun) import State import IdKind import PreImp(sExp,sQual,sLG,sFix) import SysDeps(PackedString,unpackPS,trace) import Info hiding (TokenId) import SyntaxPos import TokenInt import Util.OsOnly(isPrelude) import Flags import Overlap -- added in H98 import Id import Error -- | Should be a record ... but should its field names be exported? data RenameState = RenameState Flags -- flags Id -- unique (Id,PackedString) -- modid [Map.Map (TokenId,IdKind) Id] -- stack of rename (name -> unique) (Map.Map (TokenId,IdKind) Id) -- active rename (name -> unique) (Map.Map Id Info) -- symboltable (unique -> info) [(Id,[(Pos,Id)])] -- derived [(con,[(pos,cls)])] (Maybe [Id]) -- defaults [Error] -- errors [Id] -- type Synonyms instance IdSupply RenameState where getUniqueId _ (RenameState flags unique rps rts rt st derived defaults errors needCheck) = (unique, RenameState flags (succ unique) rps rts rt st derived defaults errors needCheck) --- The selectors for (qualFun,expFun,fixity) are defined --- in PreImp and used here and in Fixity {- Used several times: -} type RenameToken = (PackedString -> Id -> TokenId -> TokenId ,TokenId -> TokenId ,TokenId -> IdKind -> IE ,TokenId -> (InfixClass TokenId, Int) ) type RenameToken2 = (PackedString -> Id -> TokenId -> TokenId ,TokenId -> TokenId ,TokenId -> IdKind -> IE ) type RenameMonad a = State RenameToken RenameState a RenameState type RenameRMonad a b = State a RenameState b RenameState type RenameMonadEmpty = State0 RenameToken RenameState RenameState type RenameRMonadEmpty a = State0 a RenameState RenameState {- | Destruct rename state to obtain all its elements we are interested in. Additionally checks some properties of types. -} keepRS :: RenameState -> (Id ,((TokenId,IdKind) -> Id,(TokenId,IdKind) -> Maybe Id) ,(Id,PackedString) ,Map.Map Id Info -- the symbol table ,[(Id,[(Pos,Id)])] -- derived ,Maybe [Id] -- user defined defaults for Num classes ,[Error]) -- errors keepRS (RenameState flags unique rps rts rt st derived defaults errors needCheck) = case checkTypes st needCheck of Right st -> (unique,getInts (lookupAll (rt:rts)),rps,st,derived,defaults,errors) Left x -> (unique,getInts (lookupAll (rt:rts)),rps,st,derived,defaults,errors ++ x) where checkTypes :: Map.Map Id Info -> [Id] -> Either [Error] (Map.Map Id Info) checkTypes st needCheck = case foldls (checkPrep st) ([],[]) needCheck of -- !!! Do these checks at defining site only !!! (synType,newType) -> -- first look for error in type synonym defs let keep = map fst synType sccSyn = sccDepend (map ( \ (u,d) -> (u,filter (`elem` keep) d)) synType) in case (filter isRec sccSyn) of x@(_:_) -> Left (map (err2 st) x) [] -> -- now look for error in newtype defs case foldls ( \ (st,err) (u,c) -> case isUnBoxedNT st newType [u] c of Just unboxed -> (Map.update (Just . updNewType unboxed) u st,err) -- WORKING ON Nothing -> (Map.update (Just . updNewType False) u st ,(ErrorCircularNewtype ((show . tidI . fromJust . flip Map.lookup st) u)) : err) ) (st,[]) newType of (st,err@(_:_)) -> Left err (st,[]) -> Right (snd (foldls fixDepth (0::Int,st) sccSyn)) fixDepth (d,st) (NoRec u) = let unboxed = isUnBoxedTS st u d' = 1 + max d (minDepth st u) in unboxed `seq` d' `seq` (d',Map.update (Just . updTypeSynonym unboxed d') u st) minDepth st c = -- called for type synonyms only case (ntI . fromJust . flip Map.lookup st) c of (NewType _ [] _ [nt]) -> (maximum . (0:) -- Ensures maximum works . map (safeDepthI . fromJust . flip Map.lookup st) . consNT) nt safeDepthI info = case depthI info of Nothing -> 0 Just d -> d {- | Determines for given newtype type constructor, if the renamed type is unboxed. Returns Nothing if definition is circular. -} isUnBoxedNT :: Map.Map Id Info -- ^ symboltable -> [(Id,Id)] -- ^ for every newtype type constructor -- the top type constructor of the renamed type -> [Id] -- ^ accumulates newtype type constructors -- that have already been visited to recognise -- circularity. -> Id -- ^ newtype type constructor that is tested -> Maybe Bool isUnBoxedNT st nt ac u = if u `elem` ac then -- already been here, so circular defn. Nothing else case Map.lookup u st of Just info -> if isRealData info then -- got the answer! Just (isDataUnBoxed info) else case depthI info of Just _ -> -- type synonym, so follow the chain case ntI info of (NewType free [] ctx [NTcons u' _ _]) -> isUnBoxedNT st nt (u:ac) u' Nothing -> -- newtype, so follow the chain case lookup u nt of Just u' -> isUnBoxedNT st nt (u:ac) u' -- defn in this module Nothing -> -- defn in an imported module -- error ("nhc98 needs a fix here, but I don't know how") case constrsI info of (coni:_) -> case (ntI . fromJust . flip Map.lookup st) coni of (NewType _ _ _ [NTcons u' _ _,_]) -> isUnBoxedNT st nt (u:ac) u' _ -> -- strace -- ("Warning: renaming newtype of imported newtype:\n"++ -- " Real type of "++show(tidI info)++ -- " is not visible.\n"++ -- " I might get boxed/unboxed info wrong.") (Just False) [] -> -- strace -- ("Warning: when renaming newtype of imported newtype:\n"++ -- " Real type of "++show(tidI info)++" is not visible.\n"++ -- " I might get boxed/unboxed info wrong.") (Just False) Nothing -> Nothing -- possibly not circular at all isUnBoxedTS st u = -- No circular dependency when this function is called case Map.lookup u st of Nothing -> -- FAKE This is a BUG but unboxed is not used anyway False Just info -> case depthI info of Just _ -> -- type synonym case ntI info of (NewType free [] ctx [NTcons u' _ _]) -> isUnBoxedTS st u' _ -> -- FAKE This is a BUG but unboxed is not used anyway False Nothing -> isDataUnBoxed info {- | Add some information about given type constructor to list, either to list about type synonyms or list about newtypes. Type constructor must be for type synonym or newtype. -} checkPrep :: Map.Map Id Info -- ^ symboltable -> ([(Id,[Id])],[(Id,Id)]) -- ^ -- > 1 synonym list: type constructor, type cons occuring in rhs -- > 2 newtype list: type constructor, top type constructor -- > of renamed type (eg. [] in newtype T = T [Int]) -> Id -- ^ type constructor -> ([(Id,[Id])],[(Id,Id)]) -- ^ same format as argument checkPrep st (synType,newType) u = case Map.lookup u st of Just info -> case depthI info of Just _ -> -- Only typeSyn has depth case ntI info of (NewType _ [] _ [nt]) -> ((u,consNT nt):synType,newType) Nothing -> -- If it isn't a typeSyn then it must be a newType case constrsI info of (coni:_) -> case (ntI . fromJust . flip Map.lookup st ) coni of (NewType _ [] _ [NTcons c _ _,res]) -> (synType,(u,c):newType) (NewType _ [] _ [NTvar v _,res]) -> (synType, newType) (NewType _ [] _ [NTapp v1 v2,res]) -> (synType,newType) -- MW hack: omits potential circularity check! (NewType _ [] _ (_:_:_)) -> error ("Invalid rhs of newtype: " ++ show (tidI info)++ "\nA newtype can rename only one type.") _ -> error ("Couldn't find rhs of newtype: " ++ show (tidI info)++ "\nTwo conflicting newtype definitions?") [] -> (synType,newType) -- !!! Not a good solution !!! Nothing -> error ("Couldn't find definition for newtype "++show u) err2 ts (Rec xs) = ErrorCircularType (map (show . tidI . fromJust . flip Map.lookup ts) xs) -- | Only important that it works for data, class, type and newtype thisModule :: PackedString -> TokenId -> Bool thisModule rps (TupleId _) = rps == rpsPrelude thisModule rps (Visible _) = False thisModule rps (Qualified rps' _) = rps == rps' thisModule rps (Qualified2 _ _ _) = False -- FIXME: ?? thisModule rps (Qualified3 _ _ _ _) = False {- | Basically transform the importState into a renameState -} is2rs :: Flags -> PackedString -> (TokenId -> [TokenId]) -> ((TokenId->Bool) -> a {- TokenId -> IdKind -> IE -}) -> Overlap -> ImportState -> Either [Error] (TokenId -> TokenId ,a ,RenameState ,Map.Map (TokenId, IdKind) (Either [Pos] [Id]) ) is2rs flags mrps qualFun expFun overlap (ImportState visible unique orps rps needI irt st insts fixity errors) = --case treeMapList undef irt of -- [] -> -- case foldls reorderFun (treeMap ( \ (k,Right (v:_)) -> (k,v)) irt -- ,addAT initAT ignore unique minfo) -- (listAT st) of -- (rt,ts) -> -- Right (qualFun -- ,expFun (\_->False) -- ,RenameState flags (unique+1) (unique,pmrps) [] rt ts [] -- Nothing errors [] -- ,irt) -- xs -> Left (map err1 xs) case deAlias qualFun overlap irt of ([],qf) -> case foldls reorderFun (Map.map deRight irt,Map.singleton unique minfo) (Map.toList st) of (rt,ts) -> Right (qf ,expFun (\_->False) ,RenameState flags (succ unique) (unique,pmrps) [] rt ts [] Nothing errors [] ,irt) (xs,_) -> Left $ map ErrorRaw xs where deRight (Right (v:_)) = v deRight (Left _) = error ("Tripped over aliased identifier") pmrps = if (isPrelude . reverse . unpackPS) mrps then rpsPrelude else mrps mtid = Visible pmrps minfo = InfoName unique mtid 0 mtid False --PHtprof reorderFun (rt,at) (key,info) = let u = uniqueI info rt' = if thisModule rps (fst key) then Map.insertWith ignore key u rt else rt in seq rt' (rt',Map.insertWith ignore u info at) ignore a b = b -- Happens due to mutally recursive modules -- undef (key,Left poss) err = Left (key,poss) : err -- undef (key,Right [x]) err = err -- undef (key,Right (x:xs)) err = -- if all (x==) xs then --- Tuples are entered twice -- err -- else -- Right (key,x:xs) : err -- -- err1 (Left ((tid,Method),poss)) = -- "The identifier " ++ show tid ++ " instantiated at " ++ -- mix "," (map strPos poss) ++ " does not belong to this class." -- err1 (Left ((tid,kind),poss)) = -- show kind ++ ' ':show tid ++ " used at " ++ -- mix "," (map strPos poss) ++ " is not defined." -- err1 (Right ((tid,kind),xs)) = -- show kind ++ ' ':show tid ++ -- " defined " ++ show (length xs) ++ " times." --fixFixityRS :: -- RenameState -> -- [(InfixClass TokenId, Int, [FixId TokenId])] -> -- (TokenId -> (InfixClass TokenId, Int), RenameState) -- --fixFixityRS (RenameState flags unique irps@(_,rps) rts rt st -- derived defaults errors needCheck) fixdecls = -- case foldr (fixOne rps) (initAT,[]) fixdecls of -- (fixAT,err) -> (fixFun fixAT -- ,RenameState flags unique irps rts rt st -- derived defaults (err++errors) needCheck) -- Changed in H98 to: fixFixityRS :: (TokenId -> (InfixClass TokenId, Int)) -> RenameState -> [(InfixClass TokenId, Int, [FixId TokenId])] -> (TokenId -> (InfixClass TokenId, Int), RenameState) fixFixityRS oldfix rs [] = (oldfix,rs) fixFixityRS oldfix (RenameState flags unique irps@(_,rps) rts rt st derived defaults errors needCheck) fixdecls = case foldr (fixOne rps) (Map.empty,[]) fixdecls of (fixAT,err) -> (fixFun fixAT oldfix ,RenameState flags unique irps rts rt st derived defaults (err++errors) needCheck) -------------------- End duplication getSymbolTableRS :: RenameState -> Map.Map Id Info getSymbolTableRS (RenameState flags unique rps rts rt st derived defaults errors needCheck) = st getErrorsRS :: RenameState -> (RenameState,[Error]) getErrorsRS (RenameState flags unique rps rts rt st derived defaults errors needCheck) = (RenameState flags unique rps rts rt st derived defaults [] needCheck ,errors) pushScope :: a -> RenameState -> RenameState pushScope _ (RenameState flags unique rps rts rt st derived defaults errors needCheck) = RenameState flags unique rps (rt:rts) Map.empty st derived defaults errors needCheck popScope :: a -> (b,RenameState) -> (b,RenameState) popScope _ (res, RenameState flags unique rps (rt:rts) _ st derived defaults errors needCheck) = (res ,RenameState flags unique rps rts rt st derived defaults errors needCheck) renameError :: Error -> a -> RenameMonad a renameError err r fix (RenameState flags unique rps rst rt st derived defaults errors needCheck) = (r ,RenameState flags unique rps rst rt st derived defaults (err:errors) needCheck) {- | Looks up identifier (given as token,kind) in list of trees. Returns first entry found. -} lookupAll :: [Map.Map (TokenId,IdKind) Id] -> (TokenId,IdKind) -> Maybe Id lookupAll [] key = Nothing lookupAll (t:ts) key = case Map.lookup key t of Nothing -> lookupAll ts key just -> just {- | Looks up id in rename table for identifier given through its kind and token. If no entry exists, new id is created but appropriate error message added to rename state. -} uniqueTid :: Pos -> IdKind -> TokenId -> RenameMonad Id uniqueTid pos kind tid down renameState@(RenameState flags unique rps rts rt st derived defaults errors needCheck) = let key = (sQual down tid,kind) in case lookupAll (rt:rts) key of Just u -> (u,renameState) Nothing -> (unique, RenameState flags (succ unique) rps rts (Map.insert key unique rt) st derived defaults ((ErrorRaw $ "Unbound " ++ show kind ++ " " ++ show tid ++ " at " ++ strPos pos ++ "\n\n" ++ show (rt:rts)) : errors) needCheck) fixTid :: IdKind -> TokenId -> RenameMonad (InfixClass TokenId,Int) fixTid kind tid down renameState@(RenameState flags unique rps rts rt st derived defaults errors needCheck) = let key = (sQual down tid,kind) --- !!! check if real name !!! in case lookupAll (rt:rts) key of Just u -> case Map.lookup u st of Nothing -> (sFix down (ensureM (snd rps) (fst key)),renameState) -- hack -- old code ((InfixL,9::Int),renameState) -- It's an argument, and I have lost the fixity information :-( Just info -> (fixityI info,renameState) Nothing -> (sFix down (ensureM (snd rps) (fst key)),renameState) -- hack -- old code ((InfixL,9::Int),renameState) {- | Adds the the given identifier (position, kind of id, token with name) to the active names in renameState. Adds error to renameState, if identifier is already an active name, that is, redefinition occurred. -} bindTid :: Pos -> IdKind -> TokenId -> a -> RenameState -> RenameState bindTid pos kind tid _ renameState@(RenameState flags unique irps@(_,rps) rts rt st derived defaults errors needCheck) = let key = (tid,kind) redefinedGlobal [rt] = Map.lookup (forceM rps tid,kind) rt redefinedGlobal _ = Nothing in case Map.lookup key rt of Just u -> (RenameState flags unique irps rts rt st derived defaults ((ErrorRaw $ "Redefinition of " ++ show kind ++ " " ++ show tid ++ " at " ++ strPos pos) : errors) needCheck) Nothing -> case redefinedGlobal rts of Nothing -> (RenameState flags (succ unique) irps rts (Map.insert key unique rt) st derived defaults errors needCheck) Just u -> (if sRedefine flags then id else strace ("Warning: " ++ show tid ++ " is both imported and defined")) $ (RenameState flags unique irps rts (Map.insert key u rt) -- catch same scope redef (Map.update (Just . clearI) u st) derived defaults errors needCheck) bindNK :: Pos -> RenameMonad TokenId bindNK pos _ renameState@(RenameState flags unique irps@(_,rps) rts rt st derived defaults errors needCheck) = let tid = visible (show unique) key = (tid,Var) in if sNplusK flags then case lookupAll (rt:rts) key of Nothing-> (tid ,RenameState flags (succ unique) irps rts (Map.insert key unique rt) st -- (addAT st (\a b->b) unique -- (InfoUsed unique [(Var,tid,rps,pos)])) -- (addAT st (\a b->b) unique -- (InfoName unique tid 0 tid)) -- (addAT st (\a b->b) unique -- (InfoVar unique tid IEall (InfixDef,9) -- (NewType [] [] [] [NTany 0]) -- (Just 0))) derived defaults errors needCheck) Just u -> (tid ,RenameState flags (succ unique) irps rts (Map.insert key unique rt) st derived defaults ((ErrorRaw $ "Binding (n+k) pattern to new unique "++ "identifier at "++strPos pos): errors) needCheck) else (tid ,RenameState flags (succ unique) irps rts (Map.insert key unique rt) st derived defaults ((ErrorRaw $ "(n+k) patterns are disabled - pattern at "++ strPos pos): errors) needCheck) checkPuns :: Pos -> t -> RenameState -> RenameState checkPuns pos down renameState@(RenameState flags unique irps rts rt st derived defaults errors needCheck) = if sPuns flags then renameState else RenameState flags unique irps rts rt st derived defaults ((ErrorRaw $ "Named field puns are not Haskell'98 - used at "++ strPos pos):errors) needCheck {- | Checks if given identifier (kind, token) is already known as active name. It is used to check if a field have already been included in the bindings -} checkTid :: Pos -> IdKind -> TokenId -> RenameRMonad a Bool checkTid pos kind tid _ renameState@(RenameState flags unique rps rts rt st derived defaults errors needCheck) = let key = (tid,kind) in case Map.lookup key rt of Just u -> (True,renameState) Nothing -> (False,renameState) ---- ================= {- | This function makes use of the ability of NewType to contain several types. -} transTypes :: [(TokenId,Id)] -> [Id] -> [Context TokenId] -> [Type TokenId] -> RenameMonad NewType transTypes al free ctxs ts = unitS (NewType free []) =>>> mapS (transContext al) ctxs =>>> mapS (transType al) ts transTVar :: Pos -> [(TokenId, Id)] -> TokenId -> RenameMonad NT transTVar pos al v = unitS mkNTvar =>>> uniqueTVar pos al v -- no KIND inference uniqueTVar :: (Eq a, Show a) => Pos -> [(a, Id)] -> a -> RenameMonad Id uniqueTVar pos al v = case lookup v al of Just v -> unitS v Nothing -> renameError (ErrorRaw $ "Unbound type variable " ++ show v ++ " at " ++ strPos pos) undefined transContext :: [(TokenId,Id)] -> Context TokenId -> RenameMonad (Id, Id) transContext al (Context pos cid [(vpos,vid)]) = unitS pair =>>> uniqueTid pos TClass cid =>>> uniqueTVar vpos al vid transType :: [(TokenId,Id)] -> Type TokenId -> RenameMonad NT transType al (TypeApp t1 t2) = unitS NTapp =>>> transType al t1 =>>> transType al t2 transType al (TypeCons pos hs types) = unitS mkNTcons =>>> uniqueTid pos TCon hs =>>> mapS (transType al) types transType al (TypeVar pos v) = transTVar pos al v transType al (TypeStrict pos t) = unitS NTstrict =>>> transType al t ----- ================================== {- | Adds list of default types to RenameState. Checks for illegal types and redefinition, extending error messages appropriately. -} defineDefault :: [Type Id] -> a -> RenameState -> RenameState defineDefault types down (RenameState flags unique rps rts rt st derived Nothing errors needCheck) = case partition (\nt-> case nt of TypeCons _ _ [] -> True TypeApp _ _ -> True _ -> False) types of (cs,[]) -> RenameState flags unique rps rts rt st derived (Just (map getCon types)) errors needCheck (_,es) -> RenameState flags unique rps rts rt st derived Nothing ((ErrorRaw ("Illegal type in default at " ++ strPos (getPos es))):errors) needCheck where getCon (TypeCons _ con _) = con getCon (TypeApp tf ta) = getCon tf -- not really sure about this. defineDefault types down (RenameState flags unique rps rts rt st derived defaults errors needCheck) = RenameState flags unique rps rts rt st derived defaults ((ErrorRaw ("Redefinition of defaults at " ++ strPos (getPos types))) :errors) needCheck {- | Add a type synonym to symboltable. (It must be already in renaming table.) -} defineType :: TokenId {- ^ type synonym -} -> NewType {- ^ the type it is defined to denote -} -> RenameMonad Id -- ^ id of the type synonym defineType tid nt down (RenameState flags unique irps@(_,rps) rts rt st derived defaults errors needCheck) = let realtid = ensureM rps tid key = (tid,TSyn) in case Map.lookup key rt of Just u -> (u, RenameState flags unique irps rts rt (Map.insertWith combInfo u {-(realtid,TSyn)-} (InfoData u realtid (sExp down tid TSyn) nt (DataTypeSynonym False 0)) st) derived defaults errors (u:needCheck)) {- | Add a class to symboltable. (It must be already in renaming table.) Also checks for duplicate predicates in context (=> extend error messages) -} defineClass :: Pos -> TokenId -> NewType {- ^ pseudo type built from class and type variable (type of dictionary?) -} -> [(Id,Id)] {- ^ (type info for method, default info for method) -} -> RenameToken -> RenameState -> RenameState defineClass pos tid nt mds down (RenameState flags unique irps@(_,rps) rts rt st derived defaults errors needCheck) = let realtid = ensureM rps tid key = (tid,TClass) (ms,ds) = unzip mds in case Map.lookup key rt of Just u -> let newst = Map.insertWith combInfo u {-(realtid,TClass)-} (InfoClass u realtid (sExp down tid TSyn) nt ms ds Map.empty) st in case checkNT pos (strAT st) nt of Nothing -> RenameState flags unique irps rts rt newst derived defaults errors needCheck Just err -> RenameState flags unique irps rts rt newst derived defaults (ErrorRaw err:errors) needCheck defineDataPrim :: TokenId -> NewType -> Int -> RenameMonad Id defineDataPrim tid nt size down (RenameState flags unique irps@(_,rps) rts rt st derived defaults errors needCheck) = let realtid = ensureM rps tid key = (tid,TCon) in case Map.lookup key rt of Just u -> (u,RenameState flags unique irps rts rt (Map.insertWith combInfo u {-(realtid,TCon)-} (InfoData u realtid (sExp down tid TCon) nt (DataPrimitive size)) st) derived defaults errors needCheck ) {- | Add entry for data or newtype declaration to symboltable. -} defineData :: Maybe Bool {- ^ @Nothing@: newtype, @Just False@: data unboxed, @Just True@: data (boxed) -} -> TokenId {- ^ type constructor -} -> NewType {- ^ defined type (coded with type variables) -} -> [Id] {- ^ data constructors -} -> RenameMonad Id defineData d tid nt cs down (RenameState flags unique irps@(_,rps) rts rt st derived defaults errors needCheck) = let realtid = ensureM rps tid key = (tid,TCon) in case Map.lookup key rt of Just u -> let (needCheck',dk,patch) = case d of Just unboxed -> (needCheck, Data unboxed cs, id) Nothing -> (u:needCheck, DataNewType False cs, patchIE) -- unboxed fixed by keepRS in (u,RenameState flags unique irps rts rt (Map.insertWith combInfo u {-(realtid,TCon)-} (InfoData u realtid (patch (sExp down tid TCon)) nt dk) st) derived defaults errors needCheck') {- | Add entry for type declaration of given method to symboltable. Return identifier for this entry. -} defineMethod :: Pos {- ^ position of type declaration -} -> TokenId {- ^ method id -} -> NewType {- ^ method type -} -> Int {- ^ method arity -} -> Id {- ^ class to which method belongs -} -> TokenId {- ^ class name -} -> RenameMonad Id defineMethod pos tid nt arity classId ctid down (RenameState flags unique irps@(_,rps) rts rt st derived defaults errors needCheck) = let realtid = ensureM rps tid key = (tid,Method) rex = case sExp down ctid TClass of IEall -> IEsel IEabs -> IEnone _ -> sExp down tid Method in case Map.lookup key rt of Just u -> let newst = Map.insertWith combInfo u {-(realtid,Method)-} (InfoMethod u realtid rex (sFix down realtid) nt (Just arity) classId) st in case checkMNT nt of Nothing -> (u,RenameState flags unique irps rts rt newst derived defaults errors needCheck) Just err -> (u,RenameState flags unique irps rts rt newst derived defaults (ErrorRaw err:errors) needCheck) where checkMNT nt@(NewType free@(cv:_) [] ctxs nts) = case filter ((cv==) . snd) ctxs of [] -> checkNT pos (strAT st) nt [x] -> Just ("Illegal restriction " ++ strAT st (fst x) ++ " for type variable in type signature at " ++ strPos pos) xs -> Just ("Illegal restriction " ++ mixCommaAnd (map (strAT st . fst) xs) ++ " for type variable in type signature at " ++ strPos pos) defineConstr :: TokenId -> TokenId -> NewType -> [Maybe Id] -> Id -> RenameMonad Id defineConstr typtid tid nt fields bt down (RenameState flags unique irps@(_,rps) rts rt st derived defaults errors needCheck) = let realtid = ensureM rps tid key = (tid,Con) rex = case sExp down typtid TCon of IEall -> IEsel IEabs -> IEnone _ -> sExp down tid Con in case Map.lookup key rt of Just u -> (u,RenameState flags unique irps rts rt (Map.insertWith combInfo u {-(realtid,Con)-} (InfoConstr u realtid rex (sFix down realtid) nt fields bt) st) derived defaults errors needCheck) defineField :: TokenId -> Id -> Id -> ((Maybe (Pos, TokenId, c), b), Int) -> (a, b1, TokenId -> IdKind -> IE, TokenId -> (InfixClass TokenId, Int)) -> RenameState -> (Maybe (Pos, Id, Id), RenameState) defineField typtid bt c ((Nothing,_),_) down up = (Nothing,up) defineField typtid bt c ((Just (p,tid,_),_),i) down up@(RenameState flags unique irps@(_,rps) rts rt st derived defaults errors needCheck) = let realtid = ensureM rps tid key = (tid,Field) in case Map.lookup key rt of Just u -> case Map.lookup u st of Just (InfoField u' realtid' ie cis' bt' iSel') -> if bt == bt' then (Nothing,RenameState flags unique irps rts rt (Map.insertWith fstOf u' {-(realtid,Field)-} (InfoField u' realtid' ie ((c,i):cis') bt' iSel') st) derived defaults errors needCheck) else (Nothing,RenameState flags unique irps rts rt st derived defaults ((ErrorRaw $ "Field " ++ show tid ++ " at " ++ strPos p ++ " is already defined"):errors) needCheck) Just u -> (Nothing,up) Nothing -> case Map.lookup (tid,Var) rt of Just selu -> ( Just (p,u,selu) , RenameState flags unique irps rts rt (Map.insertWith combInfo selu (InfoVar selu realtid (case sExp down typtid TCon of IEall -> IEsel -- IEsome -> sExp down tid Field -- IEabs -> sExp down tid Var _ -> sExp down tid Var) (sFix down realtid) NoType (Just 1)) (Map.insertWith combInfo u {-(realtid,Field)-} (InfoField u realtid IEnone -- Var gives true IEinfo [(c,i)] bt selu) st) ) derived defaults errors needCheck) {- | Creates token for instance methods for tuple type? Another nonsensicle application of tuple tokens... "gone wierd" -} localTid :: PackedString -> Id -> TokenId -> TokenId localTid rps id tid = mkQual3 rps (Visible rps) (t_Tuple (fromEnum id)) tid {- | if token is not qualified make it qualified with given module name -} globalTid :: PackedString -> Id -> TokenId -> TokenId globalTid rps id tid = ensureM rps tid defineVar :: TokenId -> RenameMonad Id defineVar tid down (RenameState flags unique irps@(_,rps) rts rt st derived defaults errors needCheck) = let key = (tid,Var) in case Map.lookup key rt of Just u -> let realtid = sLG down rps u tid in (u,RenameState flags unique irps rts rt (Map.insertWith combInfo u {-(realtid,Var)-} (InfoVar u realtid (sExp down tid Var) (sFix down (ensureM rps tid)) NoType Nothing) st) derived defaults errors needCheck) defineDefaultMethod :: TokenId -> RenameMonad Id defineDefaultMethod tid down (RenameState flags unique irps@(_,rps) rts rt st derived defaults errors needCheck) = let realtid = mkQualD rps tid skey = (tid,Method) in case Map.lookup skey rt of Nothing -> error ("***defineDefaultMethod(1) " ++ show skey ++ "\n" ++ show rt) Just u -> case Map.lookup u st of Nothing -> error ("***defineDefaultMethod(1) " ++ show skey ++ " " ++ show u ++ "\n" ++ show rt) Just (InfoMethod _ _ _ fix nt annot iClass) -> (unique,RenameState flags (succ unique) irps rts rt (Map.insertWith combInfo unique {-(realtid,MethodDefault)-} (InfoDMethod unique realtid nt annot iClass) st) derived defaults errors needCheck) Just _ -> (unique ,RenameState flags (succ unique) irps rts rt st derived defaults ((ErrorRaw $ "Default method declared outside class: " ++ show tid) :errors) needCheck) defineInstMethod :: TokenId -> RenameMonad Id defineInstMethod tid down (RenameState flags unique irps@(_,rps) rts rt st derived defaults errors needCheck) = let realtid = mkQual2 rps (t_Tuple (fromEnum unique)) (ensureM rps tid) -- this is obscure! why a tuple with the size of unique? -- FIXME: this does in fact make no sense! --SamB in (unique,RenameState flags (succ unique) irps rts rt (Map.insertWith combInfo unique {-(realtid,MethodInstance)-} (InfoIMethod unique realtid NoType Nothing (toEnum 0::Id)) st) derived defaults errors needCheck) defineDerived :: Id -> [(Pos,Id)] -> a -> RenameState -> RenameState defineDerived con posis down (RenameState flags unique rps rts rt st derived defaults errors needCheck) = RenameState flags unique rps rts rt st ((con,posis):derived) defaults errors needCheck strAT :: Ord a => Map.Map a Info -> a -> String strAT st i = (show . tidI . fromJust . flip Map.lookup st) i