paragon-0.1.22: src/Language/Java/Paragon/NameResolution.hs
{-# 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 ())
rnTypeDecl :: Resolve TypeDecl
rnTypeDecl (ClassTypeDecl _ (ClassDecl _ ms ci tps mSuper impls cb)) = do
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
extendExpansion expns $
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
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
extendExpansion expns $
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 mRet 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
<*> mapM rnType mRet
<*> 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
_ -> return pe
-- Types
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, supers) <- case td of
ClassTypeDecl _ (ClassDecl _ _ i _ mSuper _ _) -> return (i, maybe [] (:[]) mSuper)
InterfaceTypeDecl _ (InterfaceDecl _ _ i _ supers _ ) -> return (i, supers)
_ -> fail $ "Enums not yet supported"
rnSups <- runNameRes (mapM rnClassType supers) expn
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