{-# LANGUAGE TupleSections, QuasiQuotes #-} module Language.Java.Paragon.NameResolution (resolveNames) where import Language.Java.Paragon.Syntax import Language.Java.Paragon.Pretty import Language.Java.Paragon.QuasiQuoter import Language.Java.Paragon.Interaction import Language.Java.Paragon.NameResolution.Monad --import System.FilePath -- import System.Exit import qualified Data.Map as Map --import Control.Monad (liftM, ap) import Control.Applicative import Data.Traversable import Data.List (nub) import Prelude hiding (mapM) nameResModule :: String nameResModule = libraryBase ++ ".NameResolution" ------------------------------------------ -- Resolving names (top level exported function) resolveNames :: PiPath -- PIPATH -> CompilationUnit () -- Compilation unit to transform -> BaseM (CompilationUnit ()) resolveNames piPath (CompilationUnit _ _pkg imps [td]) = runPiReader piPath $ do (_, javaLangExpnMap) <- buildMapFromImportName [impDeclQQ| import java.lang.*; |] (imps', impExpnMap) <- buildMapFromImports imps piExpnMap <- buildMapFromPiPath let jipExpnMap = unionExpnMaps [javaExpnMap, javaLangExpnMap, impExpnMap, piExpnMap] (tnExpnMap,supExpnMap) <- buildMapFromTd td jipExpnMap -- We need to take the current name take precedence let expnMap = Map.union tnExpnMap (unionExpnMaps [jipExpnMap,supExpnMap]) -- debugPrint $ "Expansions: " ++ show expnMap td' <- runNameRes (rnTypeDecl td) expnMap return $ CompilationUnit () _pkg imps' [td'] resolveNames _ _ = fail "Encountered multiple type declarations in the same file" ------------------------------------------- -- Resolving names throughout the AST -- Boiler plate alert!! type Resolve ast = ast () -> NameRes (ast ()) mkTpsExpn :: [TypeParam ()] -> Expansion mkTpsExpn tps = let acts = [ aI | ActorParam _ aI <- tps ] pols = [ pI | PolicyParam _ pI <- tps ] lsts = [ lI | LockStateParam _ lI <- tps ] typs = [ tI | TypeParam _ tI _ <- tps ] expns = Map.fromList $ concatMap mkEExpansion acts ++ concatMap mkEExpansion pols ++ concatMap mkLExpansion lsts ++ concatMap mkTExpansion typs in expns rnTypeDecl :: Resolve TypeDecl rnTypeDecl (ClassTypeDecl _ (ClassDecl _ ms ci tps mSuper impls cb)) = do extendExpansion (mkTpsExpn tps) $ ClassTypeDecl () <$> (ClassDecl () <$> mapM rnModifier ms <*> pure ci <*> mapM rnTypeParam tps -- relevant because of wildcards <*> mapM rnClassType mSuper <*> mapM rnClassType impls <*> rnClassBody cb) rnTypeDecl (InterfaceTypeDecl _ (InterfaceDecl _ ms ii tps supers ib)) = do extendExpansion (mkTpsExpn tps) $ InterfaceTypeDecl () <$> (InterfaceDecl () <$> mapM rnModifier ms <*> pure ii <*> mapM rnTypeParam tps -- relevant because of wildcards <*> mapM rnClassType supers <*> rnInterfaceBody ib) rnTypeDecl _ = fail "Enum declarations not yet supported" rnClassBody :: Resolve ClassBody rnClassBody (ClassBody _ ds) = do let fns = [ vI | MemberDecl _ (FieldDecl _ _ _ vds ) <- ds , VarDecl _ (VarId _ vI) _ <- vds ] mns = nub [ mI | MemberDecl _ (MethodDecl _ _ _ _ mI _ _ _) <- ds ] lns = [ lI | MemberDecl _ (LockDecl _ _ lI _ _ ) <- ds ] expns = Map.fromList $ concatMap mkEExpansion fns ++ concatMap mkMExpansion mns ++ concatMap mkLExpansion lns extendExpansion expns $ do -- left-biased ClassBody () <$> mapM rnDecl ds rnInterfaceBody :: Resolve InterfaceBody rnInterfaceBody (InterfaceBody _ mds) = do let fns = [ vI | FieldDecl _ _ _ vds <- mds , VarDecl _ (VarId _ vI) _ <- vds ] mns = nub [ mI | MethodDecl _ _ _ _ mI _ _ _ <- mds ] lns = [ lI | LockDecl _ _ lI _ _ <- mds ] expns = Map.fromList $ concatMap mkEExpansion fns ++ concatMap mkMExpansion mns ++ concatMap mkLExpansion lns extendExpansion expns $ -- left-biased InterfaceBody () <$> mapM rnMemberDecl mds rnDecl :: Resolve Decl rnDecl (InitDecl _ static bl) = InitDecl () static <$> rnBlock bl rnDecl (MemberDecl _ md) = MemberDecl () <$> rnMemberDecl md rnModifier :: Resolve Modifier rnModifier md = case md of Reads _ pol -> Reads () <$> rnExp pol Writes _ pol -> Writes () <$> rnExp pol Opens _ ls -> Opens () <$> mapM rnLock ls Closes _ ls -> Closes () <$> mapM rnLock ls Expects _ ls -> Expects () <$> mapM rnLock ls _ -> return md rnMemberDecl :: Resolve MemberDecl rnMemberDecl md = do -- debugPrint $ "Resolving member decl: " ++ prettyPrint md -- debugPrint $ show md ++ "\n" case md of FieldDecl _ ms t vds -> FieldDecl () <$> mapM rnModifier ms <*> rnType t <*> mapM rnVarDecl vds MethodDecl _ ms tps ret mI fps exns mbody -> do let ps = [ pI | FormalParam _ _ _ _ (VarId _ pI) <- fps ] paramsE = Map.fromList $ concatMap mkEExpansion ps extendExpansion paramsE $ MethodDecl () <$> mapM rnModifier ms <*> mapM rnTypeParam tps <*> rnReturnType ret <*> pure mI <*> mapM rnFormalParam fps <*> mapM rnExceptionSpec exns <*> rnMethodBody mbody ConstructorDecl _ ms tps cI fps exns cbody -> do let ps = [ pI | FormalParam _ _ _ _ (VarId _ pI) <- fps ] paramsE = Map.fromList $ concatMap mkEExpansion ps extendExpansion paramsE $ ConstructorDecl () <$> mapM rnModifier ms <*> mapM rnTypeParam tps <*> pure cI <*> mapM rnFormalParam fps <*> mapM rnExceptionSpec exns <*> rnConstructorBody cbody LockDecl _ ms lI arity mProps -> LockDecl () <$> mapM rnModifier ms <*> pure lI <*> pure arity <*> mapM rnLockProperties mProps _ -> do -- debugPrint $ show md fail $ "Inner types not supported" rnConstructorBody :: Resolve ConstructorBody rnConstructorBody (ConstructorBody _ mECI bss) = ConstructorBody () <$> mapM rnExplConstrInv mECI <*> rnBlockStmts bss rnExplConstrInv :: Resolve ExplConstrInv rnExplConstrInv eci = case eci of ThisInvoke _ nwtas as -> ThisInvoke () <$> mapM rnNonWildTypeArgument nwtas <*> mapM rnExp as SuperInvoke _ nwtas as -> SuperInvoke () <$> mapM rnNonWildTypeArgument nwtas <*> mapM rnExp as PrimarySuperInvoke _ e nwtas as -> PrimarySuperInvoke () <$> rnExp e <*> mapM rnNonWildTypeArgument nwtas <*> mapM rnExp as rnMethodBody :: Resolve MethodBody rnMethodBody (MethodBody _ mBl) = MethodBody () <$> mapM rnBlock mBl rnFormalParam :: Resolve FormalParam rnFormalParam (FormalParam _ ms t ell vdi) = FormalParam () <$> mapM rnModifier ms <*> rnType t <*> pure ell <*> pure vdi rnVarDecl :: Resolve VarDecl rnVarDecl (VarDecl _ vdi mInit) = do VarDecl () vdi <$> mapM rnVarInit mInit rnVarInit :: Resolve VarInit rnVarInit (InitExp _ e ) = InitExp () <$> rnExp e rnVarInit (InitArray _ aInit) = InitArray () <$> rnArrayInit aInit rnArrayInit :: Resolve ArrayInit rnArrayInit (ArrayInit _ vInits) = ArrayInit () <$> mapM rnVarInit vInits rnExceptionSpec :: Resolve ExceptionSpec rnExceptionSpec (ExceptionSpec _ ms et) = ExceptionSpec () <$> mapM rnModifier ms <*> rnRefType et rnBlock :: Resolve Block rnBlock (Block _ bss) = Block () <$> rnBlockStmts bss rnBlockStmts :: [BlockStmt ()] -> NameRes [BlockStmt ()] rnBlockStmts [] = return [] rnBlockStmts (bs:bss) = do (bs', bss') <- rnBlockStmt bs $ rnBlockStmts bss return $ bs':bss' rnBlockStmt :: BlockStmt () -> NameRes a -> NameRes (BlockStmt (), a) rnBlockStmt bs cont = case bs of BlockStmt _ stmt -> (,) <$> (BlockStmt () <$> rnStmt stmt) <*> cont LocalVars _ ms t vds -> do lvf <- LocalVars () <$> mapM rnModifier ms <*> rnType t (vds', a) <- rnVarDecls vds cont return (lvf vds', a) _ -> fail "Local classes or locks not yet supported" rnVarDecls :: [VarDecl ()] -> NameRes a -> NameRes ([VarDecl ()], a) rnVarDecls = rnVarDeclsAcc [] rnVarDeclsAcc :: [VarDecl ()] -- Accumulator (reversed) -> [VarDecl ()] -- List to resolve -> NameRes a -- What to do when all vardecls have been resolved -> NameRes ([VarDecl ()], a) -- Result (re-reversed) rnVarDeclsAcc acc [] cont = (reverse acc,) <$> cont rnVarDeclsAcc acc (vd@(VarDecl _ (VarId _ i) _) : vds) cont = do let expn = Map.fromList $ mkEExpansion i extendExpansion expn $ do vd' <- rnVarDecl vd rnVarDeclsAcc (vd':acc) vds cont rnVarDeclsAcc _ (vd:_) _ = fail $ "Deprecated array syntax not supported: " ++ prettyPrint vd rnStmt :: Resolve Stmt rnStmt stmt = case stmt of StmtBlock _ bl -> StmtBlock () <$> rnBlock bl IfThen _ ec th -> IfThen () <$> rnExp ec <*> rnStmt th IfThenElse _ ec th el -> IfThenElse () <$> rnExp ec <*> rnStmt th <*> rnStmt el While _ ec st -> While () <$> rnExp ec <*> rnStmt st BasicFor _ mForInit mTest mUps st -> do (mfi, f) <- rnForInit mForInit $ (\mT mU s mfi -> BasicFor () mfi mT mU s) <$> mapM rnExp mTest <*> mapM (mapM rnExp) mUps <*> rnStmt st return $ f mfi EnhancedFor _ ms t i e st -> EnhancedFor () <$> mapM rnModifier ms <*> rnType t <*> pure i <*> rnExp e <*> extendExpansion (Map.fromList $ mkEExpansion i) (rnStmt st) ExpStmt _ e -> ExpStmt () <$> rnExp e Assert _ e mE -> Assert () <$> rnExp e <*> mapM rnExp mE Switch _ e sbs -> Switch () <$> rnExp e <*> mapM rnSwitchBlock sbs Do _ st ec -> Do () <$> rnStmt st <*> rnExp ec Return _ mE -> Return () <$> mapM rnExp mE Synchronized _ e bl -> Synchronized () <$> rnExp e <*> rnBlock bl Throw _ e -> Throw () <$> rnExp e Try _ bl cas mFin -> Try () <$> rnBlock bl <*> mapM rnCatch cas <*> mapM rnBlock mFin Labeled _ i st -> Labeled () i <$> rnStmt st Open _ l -> Open () <$> rnLock l Close _ l -> Close () <$> rnLock l OpenBlock _ l bl -> OpenBlock () <$> rnLock l <*> rnBlock bl CloseBlock _ l bl -> CloseBlock () <$> rnLock l <*> rnBlock bl _ -> return stmt rnCatch :: Resolve Catch rnCatch (Catch _ fp bl) = case fp of FormalParam _ _ _ _ (VarId _ pI) -> extendExpansion (Map.fromList $ mkEExpansion pI) $ Catch () <$> rnFormalParam fp <*> rnBlock bl _ -> fail $ "Deprecated array syntax not supported: " ++ prettyPrint fp rnSwitchBlock :: Resolve SwitchBlock rnSwitchBlock (SwitchBlock _ slbl bss) = SwitchBlock () <$> rnSwitchLabel slbl <*> rnBlockStmts bss rnSwitchLabel :: Resolve SwitchLabel rnSwitchLabel (SwitchCase _ e) = SwitchCase () <$> rnExp e rnSwitchLabel d = return d rnForInit :: Maybe (ForInit ()) -> NameRes a -> NameRes (Maybe (ForInit ()), a) rnForInit Nothing cont = (Nothing,) <$> cont rnForInit (Just (ForInitExps _ es)) cont = (,) <$> (Just . ForInitExps () <$> mapM rnExp es) <*> cont rnForInit (Just (ForLocalVars _ ms t vds)) cont = do flvf <- ForLocalVars () <$> mapM rnModifier ms <*> rnType t (vds', a) <- rnVarDecls vds $ cont return (Just $ flvf vds', a) rnExp :: Resolve Exp rnExp expr = case expr of ClassLit _ mt -> ClassLit () <$> mapM rnType mt ThisClass _ n -> ThisClass () <$> rnName n Paren _ e -> Paren () <$> rnExp e InstanceCreation _ tas ct as mcb -> InstanceCreation () <$> mapM rnTypeArgument tas <*> rnClassType ct <*> mapM rnExp as <*> mapM rnClassBody mcb QualInstanceCreation _ _e _tas _i _as _mcb -> fail "Inner classes not yet supported" ArrayCreate _ t dimExprs dims -> ArrayCreate () <$> rnType t <*> (let (es, ps) = unzip dimExprs in pure zip <*> mapM rnExp es <*> mapM (mapM rnExp) ps) <*> mapM (mapM rnExp) dims ArrayCreateInit _ t dims aInit -> ArrayCreateInit () <$> rnType t <*> mapM (mapM rnExp) dims <*> rnArrayInit aInit FieldAccess _ fa -> FieldAccess () <$> rnFieldAccess fa MethodInv _ mi -> MethodInv () <$> rnMethodInvocation mi ArrayAccess _ ai -> ArrayAccess () <$> rnArrayIndex ai ExpName _ n -> ExpName () <$> rnName n PostIncrement _ e -> PostIncrement () <$> rnExp e PostDecrement _ e -> PostDecrement () <$> rnExp e PreIncrement _ e -> PreIncrement () <$> rnExp e PreDecrement _ e -> PreDecrement () <$> rnExp e PrePlus _ e -> PrePlus () <$> rnExp e PreMinus _ e -> PreMinus () <$> rnExp e PreBitCompl _ e -> PreBitCompl () <$> rnExp e PreNot _ e -> PreNot () <$> rnExp e Cast _ t e -> Cast () <$> rnType t <*> rnExp e BinOp _ e1 op e2 -> BinOp () <$> rnExp e1 <*> pure op <*> rnExp e2 InstanceOf _ e rt -> InstanceOf () <$> rnExp e <*> rnRefType rt Cond _ ec eth eel -> Cond () <$> rnExp ec <*> rnExp eth <*> rnExp eel Assign _ lhs aop rhs -> Assign () <$> rnLhs lhs <*> pure aop <*> rnExp rhs PolicyExp _ pe -> PolicyExp () <$> rnPolicyExp pe LockExp _ l -> LockExp () <$> rnLock l -- does this even exist? _ -> return expr rnLhs :: Resolve Lhs rnLhs lhs = case lhs of NameLhs _ n -> NameLhs () <$> rnName n FieldLhs _ fa -> FieldLhs () <$> rnFieldAccess fa ArrayLhs _ ai -> ArrayLhs () <$> rnArrayIndex ai rnArrayIndex :: Resolve ArrayIndex rnArrayIndex (ArrayIndex _ arr eI) = ArrayIndex () <$> rnExp arr <*> rnExp eI rnFieldAccess :: Resolve FieldAccess rnFieldAccess fa = case fa of PrimaryFieldAccess _ e i -> PrimaryFieldAccess () <$> rnExp e <*> pure i ClassFieldAccess _ n i -> ClassFieldAccess () <$> rnName n <*> pure i sfa -> return sfa rnMethodInvocation :: Resolve MethodInvocation rnMethodInvocation mi = case mi of MethodCallOrLockQuery _ n as -> do -- debugPrint $ "rnMethodInvocation: " ++ show n MethodCallOrLockQuery () <$> rnName n <*> mapM rnExp as PrimaryMethodCall _ e nwtas i as -> PrimaryMethodCall () <$> rnExp e <*> mapM rnNonWildTypeArgument nwtas <*> pure i <*> mapM rnExp as SuperMethodCall _ nwtas i as -> SuperMethodCall () <$> mapM rnNonWildTypeArgument nwtas <*> pure i <*> mapM rnExp as ClassMethodCall _ n nwtas i as -> ClassMethodCall () <$> rnName n <*> mapM rnNonWildTypeArgument nwtas <*> pure i <*> mapM rnExp as TypeMethodCall _ n nwtas i as -> TypeMethodCall () <$> rnName n <*> mapM rnNonWildTypeArgument nwtas <*> pure i <*> mapM rnExp as rnLock :: Resolve Lock rnLock (Lock _ n as) = Lock () <$> rnName n <*> mapM rnActorName as rnLock lv = return lv rnLockProperties :: Resolve LockProperties rnLockProperties (LockProperties _ lcs) = LockProperties () <$> mapM rnLClause lcs rnLClause :: Resolve LClause rnLClause (LClause _ a as) = LClause () <$> rnAtom a <*> mapM rnAtom as rnClause :: Resolve Clause rnClause (Clause _ a as) = Clause () <$> rnActor a <*> mapM rnAtom as rnActor :: Resolve Actor rnActor (Actor _ an) = Actor () <$> rnActorName an rnActor av = return av rnActorName :: Resolve ActorName rnActorName (ActorName _ n) = ActorName () <$> rnName n rnActorName atv = return atv rnAtom :: Resolve Atom rnAtom (Atom _ n as) = Atom () <$> rnName n <*> mapM rnActor as rnPolicyExp :: Resolve PolicyExp rnPolicyExp pe = case pe of PolicyLit _ cs -> PolicyLit () <$> mapM rnClause cs PolicyOf _ i -> do -- just see if it exists _ <- rnName (Name () EName Nothing i) return pe PolicyTypeVar _ i -> do _ <- rnName (Name () EName Nothing i) return pe _ -> return pe -- Types rnReturnType :: Resolve ReturnType rnReturnType (Type _ t) = Type () <$> rnType t rnReturnType rt = return rt rnType :: Resolve Type rnType (RefType _ rt) = RefType () <$> rnRefType rt rnType t = return t rnRefType :: Resolve RefType rnRefType rt = case rt of ClassRefType _ ct -> ClassRefType () <$> rnClassType ct ArrayType _ t dims -> do t' <- rnType t ArrayType () t' <$> mapM (mapM rnExp) dims _ -> return rt rnClassType :: Resolve ClassType rnClassType (ClassType _ n tas) = do n' <- rnName n ClassType () n' <$> mapM rnTypeArgument tas rnTypeParam :: Resolve TypeParam rnTypeParam (TypeParam _ i rts) = TypeParam () i <$> mapM rnRefType rts rnTypeParam tp = return tp rnTypeArgument :: Resolve TypeArgument rnTypeArgument (ActualArg _ nwta) = ActualArg () <$> rnNonWildTypeArgument nwta rnTypeArgument _ = fail "Wildcards not yet supported" rnNonWildTypeArgument :: Resolve NonWildTypeArgument rnNonWildTypeArgument nwta = case nwta of ActualName _ n -> ActualName () <$> rnName n -- type, exp or lock - careful! ActualType _ rt -> ActualType () <$> rnRefType rt ActualExp _ e -> ActualExp () <$> rnExp e ActualLockState _ ls -> ActualLockState () <$> mapM rnLock ls -- Where the wild things are... rnName :: Resolve Name -- If the name has no prefix, we should resolve it through expansion. -- If no expansion exists, then we should try (if applicable) to -- resolve it as a package. rnName (Name _ nt Nothing i) = do expn <- getExpansion case Map.lookup (i,nt) expn of Just nrAction -> do (mPre, resNt) <- liftEither nrAction return $ Name () resNt mPre i Nothing -> do {- debugPrint $ "Unexpanded: " ++ show nam -- TODO: Optimize to check lazily, and store results let pName = Name () PName Nothing i tName = Name () TName Nothing i isP <- doesPkgExist pName isT <- doesTypeExist tName case () of _ | nt `elem` [AmbName, POrTName, PName] && isP -> return pName | nt `elem` [AmbName, POrTName, TName] && isT -> return tName | otherwise -> do -} debugPrint $ "Expansion: " ++ show expn fail $ "Unresolved name: " ++ prettyPrint nt ++ " " ++ prettyPrint i ++ " not in scope" rnName (Name _ nt (Just pre) i) = do preRaw <- rnName pre -- If the prefix could be either expression or lock, -- then only the former is truly possible since locks cannot be prefixes. let pre' = if nameType preRaw == EOrLName then setNameType EName preRaw else preRaw nam = Name () nt (Just pre') i case nt of -- Resolving ambiguous names (w prefix) AmbName -> do case nameType pre' of PName -> do isP <- doesPkgExist pre' if isP then do let tNam = setNameType TName nam isF <- doesTypeExist tNam if isF then return tNam else return $ setNameType PName nam else fail $ "Package not in scope: " ++ prettyPrint pre' -- This is the only possibility since we don't allow inner types. -- Type-checking will determine if such a field actually exists. TName -> return $ setNameType EName nam EName -> return $ setNameType EName nam LName -> fail $ "Cannot dereference lock: " ++ prettyPrint nam MName -> fail $ "Cannot dereference method: " ++ prettyPrint nam MOrLName -> fail $ "Cannot dereference method or lock: " ++ prettyPrint nam _ -> panic (nameResModule ++ ".rnName") $ "Unexpected name: " ++ show nam -- Resolving package names (w prefix, which can only be PName) PName -> do isP <- doesPkgExist nam if isP then return nam else fail $ "Package not in scope: " ++ prettyPrint nam -- Resolving package-or-type names (w prefix) POrTName -> do let tNam = setNameType TName nam isT <- doesTypeExist tNam if isT then return tNam else do let pNam = setNameType PName nam isP <- doesPkgExist pNam if isP then return pNam else fail $ "Package or type not in scope: " ++ prettyPrint nam -- Resolving type names (w prefix) TName -> do isT <- doesTypeExist nam if isT then return nam else fail $ "Type not in scope: " ++ prettyPrint nam et | et `elem` [EOrLName, EName] -> do case nameType pre' of PName -> fail $ "Package " ++ prettyPrint pre' ++ " cannot have field, variable or lock " ++ prettyPrint i ++ " as a direct member." -- We need to leave EOrLName unresolved until typechecking! TName -> return nam EName -> return nam _ -> panic (nameResModule ++ ".rnName") $ "Unexpected name: " ++ show nam mt | mt `elem` [MName, MOrLName] -> do case nameType pre' of PName -> fail $ "Package " ++ prettyPrint pre' ++ " cannot have method or lock " ++ prettyPrint i ++ " as a direct member." TName -> do -- We need to leave MOrLName unresolved until typechecking! return nam EName -> return nam _ -> panic (nameResModule ++ ".rnName") $ "Unexpected name: " ++ show nam LName -> do case nameType pre' of PName -> fail $ "Package " ++ prettyPrint pre' ++ " cannot have lock " ++ prettyPrint i ++ " as a direct member." TName -> do -- TODO: Check here that pi file contains at least one member with name i, -- which must be a lock. return nam EName -> return nam -- defer to type checker _ -> panic (nameResModule ++ ".rnName") $ "Unexpected name: " ++ show nam _ -> panic (nameResModule ++ ".rnName") $ "Unexpected name: " ++ show nam rnName n = return n -- Union maps, but inject a suspended failure if -- we encounter the same name several times, ambiguously unionExpnMaps :: [Expansion] -> Expansion unionExpnMaps expns = flip unionsWithKey expns (\(i, nt) r1 r2 -> do (mPre1,_) <- r1 (mPre2,_) <- r2 check (mPre1 == mPre2) $ "Ambiguous " ++ prettyPrint nt ++ " " ++ prettyPrint i ++ "\nCould refer to either of:" ++ "\n " ++ prettyPrint (Name () AmbName mPre1 i) ++ "\n " ++ prettyPrint (Name () AmbName mPre2 i) r1) -- The package name 'java' is always in scope. javaExpnMap :: Expansion javaExpnMap = Map.fromList $ mkPExpansion (Ident () "java") {- buildMapFromCurrentPkg :: FilePath -> PiReader Expansion buildMapFromCurrentPkg currentPkg = do liftIO $ detailPrint $ "Resolving current package:" ++ show currentPkg files <- liftIO $ getDirectoryContents currentPkg let fnses = map splitExtension files piTypeIdents = [ Ident () str | (str, ".pi") <- fnses ] resExpn = Map.fromList $ concatMap mkTExpansion piTypeIdents return resExpn -} buildMapFromPiPath :: PiReader Expansion buildMapFromPiPath = do (tys,pkgs) <- getPiPathContents return $ Map.fromList $ concatMap mkPExpansion pkgs ++ concatMap mkTExpansion tys buildMapFromTd :: TypeDecl () -> Expansion -> PiReader (Expansion, Expansion) buildMapFromTd td expn = do --return . Map.fromList $ (i, tps, supers) <- case td of ClassTypeDecl _ (ClassDecl _ _ i tps mSuper _ _) -> return (i, tps, maybe [] (:[]) mSuper) InterfaceTypeDecl _ (InterfaceDecl _ _ i tps supers _ ) -> return (i, tps, supers) _ -> fail $ "Enums not yet supported" rnSups <- runNameRes (mapM rnClassType supers) (Map.union expn (mkTpsExpn tps)) superExpns <- mapM buildMapFromSuper rnSups let iExpn = Map.fromList $ mkTExpansion i return $ (iExpn, unionExpnMaps superExpns) where buildMapFromSuper :: ClassType () -> PiReader Expansion buildMapFromSuper (ClassType _ n@(Name _ _ mPre i) _) = do mPre' <- resolvePre mPre let resName = Name () TName mPre' i isT <- doesTypeExist resName if isT then do -- resolve as type CompilationUnit _ _ _ [superTd] <- getTypeContents resName (supSups, mDs) <- case superTd of ClassTypeDecl _ (ClassDecl _ _ _ _ mSupSup _ (ClassBody _ ds)) -> return $ (maybe [] (:[]) mSupSup, unMemberDecls ds) InterfaceTypeDecl _ (InterfaceDecl _ _ _ _ supSups (InterfaceBody _ mds)) -> return (supSups, mds) _ -> fail $ "Enums not yet supported" supExpns <- mapM buildMapFromSuper supSups let fns = [ vI | FieldDecl _ _ _ vds <- mDs , VarDecl _ (VarId _ vI) _ <- vds ] mns = nub [ mI | MethodDecl _ _ _ _ mI _ _ _ <- mDs ] lns = [ lI | LockDecl _ _ lI _ _ <- mDs ] resExpn = Map.fromList $ concatMap mkEExpansion fns ++ concatMap mkMExpansion mns ++ concatMap mkLExpansion lns return (unionExpnMaps $ resExpn:supExpns) else fail $ "Unknown type: " ++ prettyPrint n buildMapFromSuper n = panic (nameResModule ++ ".buildMapFromTd") $ show n unMemberDecls [] = [] unMemberDecls (MemberDecl _ d:ds) = d : unMemberDecls ds unMemberDecls (_:ds) = unMemberDecls ds -- Build an expansion map from explicit (or implicit) imports -- (or, incidentally, for implicit import of local package) buildMapFromImports :: [ImportDecl ()] -> PiReader ([ImportDecl ()], Expansion) buildMapFromImports imps = do (imps', expns) <- unzip <$> mapM buildMapFromImportName imps return (imps', unionExpnMaps expns) buildMapFromImportName :: ImportDecl () -> PiReader (ImportDecl (), Expansion) buildMapFromImportName imp = do finePrint $ "Resolving import: " ++ prettyPrint imp -- debugPrint $ show imp case imp of SingleTypeImport _ tn@(Name _ TName mPre i) -> do mPre' <- resolvePre mPre let resName = Name () TName mPre' i resImp = SingleTypeImport () resName resExpn = Map.fromList $ [((i, TName ), return (mPre', TName)), ((i, POrTName), return (mPre', TName)), ((i, AmbName ), return (mPre', TName))] isTy <- doesTypeExist resName if isTy then return $ (resImp, resExpn) else fail $ case mPre' of Nothing -> "Unknown type " ++ prettyPrint tn Just pre -> "Package " ++ prettyPrint pre ++ " does not contain a subpackage or type \ \with name " ++ prettyPrint i TypeImportOnDemand _ n@(Name _ nt mPre i) | nt `elem` [POrTName, PName] -> do mPre' <- resolvePre mPre -- Next lines only true because we don't yet support nested TName let resName = Name () PName mPre' i resImp = TypeImportOnDemand () resName isP <- doesPkgExist resName if isP then do -- resolve as package --debugPrint $ "Package exists: " ++ show resName piTypeIdents <- getPkgContents resName let resExpn = Map.fromList $ concatMap (\x -> [((x, TName ), return (Just resName, TName)), ((x, POrTName), return (Just resName, TName)), ((x, AmbName ), return (Just resName, TName))]) piTypeIdents return (resImp, resExpn) else fail $ "Unknown package: " ++ prettyPrint n TypeImportOnDemand _ n@(Name _ TName mPre i) -> do mPre' <- resolvePre mPre let resName = Name () TName mPre' i resImp = TypeImportOnDemand () resName isT <- doesTypeExist resName if isT then do -- resolve as type _ast <- getTypeContents resName -- TODO: This is currently bu let resExpn = Map.empty {- let resExpn = Map.fromList $ concatMap (\x -> [((x, TName ), return (Just resName, TName)), ((x, POrTName), return (Just resName, TName)), ((x, AmbName ), return (Just resName, TName))]) piTypeIdents -} return (resImp, resExpn) >> fail $ "Inner types not supported: " ++ prettyPrint imp else fail $ "Unknown package: " ++ prettyPrint n _ -> do fail $ "Static imports not yet supported: " ++ prettyPrint imp -- Always resolve prefix as package name for now resolvePre :: Maybe (Name ()) -> PiReader (Maybe (Name ())) resolvePre Nothing = return Nothing resolvePre (Just (Name _ nt mPre i)) | nt `elem` [PName, POrTName] = do mPre' <- resolvePre mPre return $ Just (Name () PName mPre' i) resolvePre n = panic (nameResModule ++ ".resolvePre") $ "Unexpected name: " ++ show n --------------- -- Map utils type Map = Map.Map unionsWithKey :: Ord k => (k -> a -> a -> a) -> [Map k a] -> Map k a unionsWithKey f = foldl (Map.unionWithKey f) Map.empty