{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TupleSections, QuasiQuotes #-} module Language.Java.Paragon.TypeCheck.Monad.TcDeclM ( module Language.Java.Paragon.Monad.PiReader, TcDeclM, runTcDeclM, TypeCheck, MonadTcDeclM(..), -- MonadTcBaseM(..), fetchPkg, fetchType, getThisType, getThisStateType, getSuperType, getTypeMap, lookupTypeOfType, lookupTypeOfStateType, withTypeParam, extendGlobalTypeMap, evalSrcType, evalSrcRefType, evalSrcClsType, evalSrcTypeArg, evalSrcNWTypeArg, evalReturnType, evalPolicy, evalPolicyExp, evalLock, evalActor, evalSrcLockProps, freshActorId, unknownActorId, instanceActorId, getReadPolicy, getWritePolicy, getLockPolicy, getParamPolicy, getReturnPolicy, ) where import Language.Java.Paragon.Monad.PiReader import Language.Java.Paragon.Syntax import Language.Java.Paragon.Pretty import Language.Java.Paragon.Interaction import Language.Java.Paragon.NameResolution import Language.Java.Paragon.QuasiQuoter import Language.Java.Paragon.TypeCheck.TypeMap import Language.Java.Paragon.TypeCheck.Types import Language.Java.Paragon.TypeCheck.Actors import Language.Java.Paragon.TypeCheck.Policy import Language.Java.Paragon.TypeCheck.Locks import Control.Monad hiding (join) import Control.Applicative import qualified Data.Map as Map import Data.List (partition) import Data.Maybe (catMaybes) tcDeclMModule :: String tcDeclMModule = typeCheckerBase ++ ".Monad.TcDeclM" type TypeCheck m ast = ast () -> m (ast T) lookupTypeOfStateType :: MonadTcDeclM m => TcStateType -> m TypeSig lookupTypeOfStateType sty {-@(TcInstance{})-} = liftTcDeclM $ do tm <- getTypeMap case lookupTypeOfStateT sty tm of Right tsig -> return tsig Left Nothing -> fail $ "Unknown type: " ++ prettyPrint sty Left (Just err) -> fail err {- lookupTypeOfStateType _sty@(TcType ty) = liftTcDeclM $ do tm <- getTypeMap case lookupTypeOfT ty tm of Right (is, tsig) -> do ias <- mapM (instanceActorId . Name () EName -} lookupTypeOfType :: MonadTcDeclM m => TcType -> m ([Ident ()], TypeSig) lookupTypeOfType ty = liftTcDeclM $ do tm <- getTypeMap -- debugPrint $ "lookupTypeOfType -- TypeMap:\n" ++ show tm case lookupTypeOfT ty tm of Right tsig -> return tsig Left Nothing -> fail $ "Unknown type: " ++ prettyPrint ty Left (Just err) -> fail err fetchPkg :: Name () -> TcDeclM () fetchPkg n = do debugPrint $ "Fetching package " ++ prettyPrint n ++ " ..." isP <- doesPkgExist n if not isP then fail $ "No such package: " ++ prettyPrint n else do extendGlobalTypeMap (extendTypeMapP n emptyTM) debugPrint $ "Done fetching package " ++ prettyPrint n return () fetchType :: Name () -> TcDeclM ([TypeParam ()],[Ident ()],TypeSig) fetchType n@(Name _ _ _ typName) = do withFreshCurrentTypeMap $ do debugPrint $ "Fetching type " ++ prettyPrint n ++ " ..." isT <- doesTypeExist n if not isT then fail $ "No such type: " ++ prettyPrint n else do cUnit <- getTypeContents n pp <- getPiPath CompilationUnit _ _ _ [td] <- liftBase $ resolveNames pp cUnit case td of ClassTypeDecl _ (ClassDecl _ ms cuName tps mSuper impls (ClassBody _ ds)) -> do check (typName == cuName) $ "File name " ++ prettyPrint typName ++ " does not match class name " ++ prettyPrint cuName superTys <- --map (TcRefT . TcClsRefT) <$> mapM evalSrcClsType (maybe [] (:[]) mSuper) implsTys <- --map (TcRefT . TcClsRefT) <$> mapM evalSrcClsType impls -- Remove this line, and set tMembers to emptyTM, -- if using "clever lookup" instead of "clever setup" superTm <- case superTys of [] -> return emptyTM [superTy] -> tMembers . snd <$> lookupTypeOfType (clsTypeToType superTy) _ -> panic (tcDeclMModule ++ ".fetchType") $ "More than one super class for class:" ++ show superTys let tsig = TSig { tType = TcClsRefT $ TcClassT (mkSimpleName TName typName) [], tIsClass = True, tIsFinal = Final () `elem` ms, tSupers = superTys, tImpls = implsTys, tMembers = superTm { constrs = Map.empty } } mDs = map unMemberDecl ds iaps = findImplActorParams mDs extendGlobalTypeMap (extendTypeMapT n tps iaps tsig) -- (rtps,rsig) <- withTypeMapAlways (extendTypeMapT n tps tsig) $ do withFoldMap withTypeParam tps $ do fetchActors n mDs $ do fetchLocks n mDs $ do fetchPols n mDs $ do fetchTypeMethods n mDs $ do fetchSignatures n mDs tm <- getTypeMap case lookupNamed types n tm of Just res -> do debugPrint $ "Done fetching type: " ++ prettyPrint n debugPrint $ "Result: " ++ show res ++ "\n" return res Nothing -> panic (tcDeclMModule ++ ".fetchType") $ "Just fetched type " ++ show n ++ " but now it doesn't exist!" -- withTypeMapAlways (extendTypeMapT n rtps rsig) $ do -- tm <- getTypeMap -- debugPrint $ "TypeMap here: " ++ show tm ++ "\n" -- return (rtps,rsig) where unMemberDecl :: Decl () -> MemberDecl () unMemberDecl (MemberDecl _ md) = md unMemberDecl _ = panic (tcDeclMModule ++ ".fetchType") $ "Malformed PI-file contains initializer block" InterfaceTypeDecl _ (InterfaceDecl _ ms cuName tps supers (InterfaceBody _ mDs)) -> do check (typName == cuName) $ "File name " ++ prettyPrint typName ++ " does not match class name " ++ prettyPrint cuName superTys <- --map (TcRefT . TcClsRefT) <$> mapM evalSrcClsType supers -- Remove this line, and set tMembers to emptyTM, -- if using "clever lookup" instead of "clever setup" superTm <- foldl merge emptyTM <$> mapM ((tMembers . snd <$>) . lookupTypeOfType . clsTypeToType) superTys let tsig = TSig { tType = TcClsRefT $ TcClassT (mkSimpleName TName typName) [], tIsClass = False, tIsFinal = Final () `elem` ms, tSupers = superTys, tImpls = [], tMembers = superTm } extendGlobalTypeMap (extendTypeMapT n tps [] tsig) -- withTypeMapAlways (extendTypeMapT n tps tsig) $ do withFoldMap withTypeParam tps $ do -- These will be written directly into the right -- places in the TM, using the 'always' trick fetchActors n mDs $ do fetchLocks n mDs $ do fetchPols n mDs $ do fetchTypeMethods n mDs $ do fetchSignatures n mDs tm <- getTypeMap case lookupNamed types n tm of Just res -> return res Nothing -> panic (tcDeclMModule ++ ".fetchType") $ "Just fetched type " ++ show n ++ " but now it doesn't exist!" _ -> fail $ "Enums not yet supported" fetchType n = panic (tcDeclMModule ++ ".fetchType") $ show n findImplActorParams :: [MemberDecl ()] -> [Ident ()] findImplActorParams mds = [ i | FieldDecl _ ms [typeQQ| actor |] vds <- mds, Final () `elem` ms, not (Static () `elem` ms), VarDecl _ (VarId _ i) Nothing <- vds ] -- Actors fetchActors :: Name () -> [MemberDecl ()] -> TcDeclM a -> TcDeclM a fetchActors n mDecls tdra = do --debug "fetchActors" let acts = [ (ms, vd) | FieldDecl _ ms (PrimType _ (ActorT _)) vds <- mDecls , vd <- vds , Final () `elem` ms -- Static () `elem` ms ] let -- (sfs,unstables) = partition (\(ms, _) -> Final () `elem` ms) acts (spawns , stables ) = partition (\(_,VarDecl _ _ initz) -> initz == Nothing) acts -- sfs (sspawns , fspawns ) = partition (\(ms,_) -> Static () `elem` ms) spawns (sstables, fstables) = partition (\(ms,_) -> Static () `elem` ms) stables (ssas, ssvs) <- unzip <$> mapM spawnActorVd sspawns (fsas, fsvs) <- unzip <$> mapM paramActorVd fspawns (seas, sevs) <- unzip <$> mapM evalActorVd sstables (feas, fevs) <- unzip <$> mapM evalActorVd fstables -- (aas, avs) <- unzip <$> mapM unknownActorVd unstables -- (eas, evs) <- unzip <$> mapM evalActorVd stables let globTM = emptyTM { actors = Map.fromList (ssas ++ fsas ++ seas ++ feas), fields = Map.fromList (ssvs ++ fsvs ++ sevs ++ fevs) } loclTM = emptyTM { actors = Map.fromList (ssas ++ fsas ++ seas ++ feas), fields = Map.fromList (ssvs ++ fsvs ++ sevs ++ fevs) } extendGlobalTypeMap (extendTypeMapN n $ merge globTM) withCurrentTypeMap (merge loclTM) $ do -- debugPrint "Actors fetched" tdra where spawnActorVd, evalActorVd, paramActorVd --, unknownActorVd :: ([Modifier ()], VarDecl ()) -> TcDeclM ((Ident (), ActorId), (Ident (),VarFieldSig)) -- Static, only Nothing for initializer spawnActorVd (ms, VarDecl _ (VarId _ i) _) = do a <- freshActorId (prettyPrint i) p <- getReadPolicy ms let vti = VSig actorT p False (Static () `elem` ms) (Final () `elem` ms) return ((i,a),(i,vti)) spawnActorVd (_, VarDecl _ arvid _) = fail $ "Deprecated array syntax not supported: " ++ prettyPrint arvid paramActorVd (ms, VarDecl _ (VarId _ i) _) = do let a = ActorTPVar i p <- getReadPolicy ms let vti = VSig actorT p False (Static () `elem` ms) (Final () `elem` ms) return ((i,a),(i,vti)) paramActorVd (_, VarDecl _ arvid _) = fail $ "Deprecated array syntax not supported: " ++ prettyPrint arvid {- -- All non-final unknownActorVd (ms, VarDecl _ (VarId _ i) _) = do p <- getReadPolicy ms let vti = VSig actorT p False (Static () `elem` ms) (Final () `elem` ms) a <- unknownActorId return ((i,a),(i,vti)) unknownActorVd (_, VarDecl _ arvid _) = fail $ "Deprecated array syntax not supported: " ++ prettyPrint arvid -} -- Final, with explicit initializer evalActorVd (ms, VarDecl _ (VarId _ i) (Just (InitExp _ e))) = do p <- getReadPolicy ms let vti = VSig actorT p False (Static () `elem` ms) (Final () `elem` ms) a <- case e of ExpName _ nam -> do tm <- getTypeMap case lookupNamed actors nam tm of Just a -> return a Nothing -> unknownActorId --fail "Internal error: no such actor" _ -> unknownActorId return ((i,a),(i,vti)) evalActorVd (_, VarDecl _ _ Nothing) = panic (typeCheckerBase ++ ".evalActorVd") $ "No initializer" evalActorVd (_, VarDecl _ arvid _) = fail $ "Deprecated array syntax not supported: " ++ prettyPrint arvid -- end actors -- locks fetchLocks :: Name () -> [MemberDecl ()] -> TcDeclM a -> TcDeclM a fetchLocks n mds tdra = do let lcs = [ (i, ms, mps, mProps) | LockDecl _ ms i mps mProps <- mds ] lsigs <- flip mapM lcs $ \(i, ms, mps, mProps) -> do pol <- getLockPolicy ms modPrs <- getLockModProps i ms prs <- evalSrcLockProps i mProps return (i, LSig pol (length mps) (modPrs ++ prs)) let newTM = emptyTM { locks = Map.fromList lsigs } extendGlobalTypeMap (extendTypeMapN n $ merge newTM) withCurrentTypeMap (merge newTM) $ do -- debugPrint $ "Locks fetched" tdra getLockModProps :: Ident () -> [Modifier ()] -> TcDeclM [TcClause TcAtom] getLockModProps lockI ms = do let trans = evalSrcLockProps lockI $ Just [lockPropQQ| { #lockI('x,'y) : #lockI('x,'z), #lockI('z,'y) } |] refl = evalSrcLockProps lockI $ Just [lockPropQQ| { #lockI('x,'x) : } |] symm = evalSrcLockProps lockI $ Just [lockPropQQ| { #lockI('x,'y) : #lockI('y,'x) } |] concat <$> sequence ( [ trans | Transitive _ <- ms ] ++ [ refl | Reflexive _ <- ms ] ++ [ symm | Symmetric _ <- ms ]) -- end locks -- policies fetchPols :: Name () -> [MemberDecl ()] -> TcDeclM a -> TcDeclM a fetchPols n mds tdra = do let pols = [ (i,initz, Static () `elem` ms) | FieldDecl _ ms (PrimType _ (PolicyT _)) vds <- mds, VarDecl _ (VarId _ i) (Just (InitExp _ initz)) <- vds, Final () `elem` ms ] (spols, fpols) = partition (\(_,_,b) -> b) pols sips <- mapM fetchPol spols fips <- mapM fetchPol fpols -- TODO: Expand local locks! let globTM = emptyTM { policies = Map.fromList sips } loclTM = emptyTM { policies = Map.fromList $ sips ++ fips } extendGlobalTypeMap $ extendTypeMapN n $ merge globTM withCurrentTypeMap (merge loclTM) $ do -- withTypeMapAlways (extendTypeMapN n (merge $ emptyTM { policies = Map.fromList ips })) $ do -- debugPrint $ "Policies fetched" tdra where fetchPol :: (Ident (), Exp (), a) -> TcDeclM (Ident (), ActorPolicy) fetchPol (i,e,_) = (i,) <$> evalPolicy e -- end policies -- Working with typemethods fetchTypeMethods :: Name () -> [MemberDecl ()] -> TcDeclM a -> TcDeclM a fetchTypeMethods n mds tdra = do let ipbs = [ (i,(ps,body)) | MethodDecl _ ms _ _ i ps _ (MethodBody _ (Just body)) <- mds, Typemethod () `elem` ms ] ipidbs <- mapM paramsToIdents ipbs let newTM = emptyTM { typemethods = Map.fromList ipidbs } extendGlobalTypeMap $ extendTypeMapN n $ merge newTM withCurrentTypeMap (merge newTM) $ do -- withTypeMapAlways (extendTypeMapN n -- (merge $ emptyTM { typemethods = Map.fromList ipidbs })) $ do -- debugPrint "TypeMethods fetched" tdra where paramsToIdents (i, (ps,b)) = do pids <- mapM paramIdent ps return (i, (pids,b)) paramIdent :: FormalParam () -> TcDeclM (Ident ()) paramIdent (FormalParam _ _ _ _ (VarId _ i)) = return i paramIdent (FormalParam _ _ _ _ arvid) = fail $ "Deprecated array syntax not supported: " ++ prettyPrint arvid -- end typemethods -- signatures of fields, methods and constructors fetchSignatures :: Name () -> [MemberDecl ()] -> TcDeclM () fetchSignatures n memDs = do fieldMap <- fetchFields memDs methodMap <- fetchMethods memDs constrMap <- fetchConstrs memDs let newTM = emptyTM { fields = fieldMap, methods = methodMap, constrs = constrMap } extendGlobalTypeMap $ extendTypeMapN n $ merge newTM -- debugPrint "Signatures fetched" return () where unVarDecl :: VarDecl () -> TcDeclM (Ident ()) unVarDecl (VarDecl _ (VarId _ i) _) = return i unVarDecl arvid = fail $ "Deprecated array syntax not supported: " ++ prettyPrint arvid fetchFields :: [MemberDecl ()] -> TcDeclM (Map (Ident ()) VarFieldSig) fetchFields = go Map.empty where go :: Map (Ident ()) VarFieldSig -> [MemberDecl ()] -> TcDeclM (Map (Ident ()) VarFieldSig) go acc [] = return acc go fm (md:mds) = case md of FieldDecl _ ms ty vds -> do tcty <- evalSrcType ty pol <- getReadPolicy ms let vti = VSig tcty pol False (Static () `elem` ms) (Final () `elem` ms) ids <- mapM unVarDecl vds let newFm = foldl (\m i -> Map.insert i vti m) fm ids go newFm mds _ -> go fm mds fetchMethods :: [MemberDecl ()] -> TcDeclM (Map (Ident ()) MethodMap) fetchMethods = go Map.empty where go :: Map (Ident ()) MethodMap -> [MemberDecl ()] -> TcDeclM (Map (Ident ()) MethodMap) go acc [] = return acc go mm (md:mds) = case md of MethodDecl _ ms tps retT i ps exns _ -> do withFoldMap withTypeParam tps $ do tcty <- evalReturnType retT (pTys, pIs, pPols) <- unzip3 <$> mapM paramInfo ps rPol <- getReturnPolicy ms pPols wPol <- getWritePolicy ms exs <- mapM eSpecToSig exns expects <- mapM evalLock $ concat [ l | Expects _ l <- ms ] closes <- mapM evalLock $ concat [ l | Closes _ l <- ms ] opens <- mapM evalLock $ concat [ l | Opens _ l <- ms ] let mti = MSig { mRetType = tcty, mRetPol = rPol, mPars = pIs, mParPols = pPols, mWrites = wPol, mExpects = expects, mLMods = (closes, opens), mExns = exs } isVarArity = case reverse ps of [] -> False (FormalParam _ _ _ b _ : _) -> b newMethMap = Map.singleton (tps, pTys, isVarArity) mti newMm = Map.insertWith Map.union i newMethMap mm go newMm mds _ -> go mm mds fetchConstrs = go Map.empty where go :: ConstrMap -> [MemberDecl ()] -> TcDeclM ConstrMap go acc [] = return acc go cm (md:mds) = case md of ConstructorDecl _ ms tps _ ps exns _ -> do withFoldMap withTypeParam tps $ do (pTys, pIs, pPols) <- unzip3 <$> mapM paramInfo ps wPol <- getWritePolicy ms exs <- mapM eSpecToSig exns expects <- mapM evalLock $ concat [ l | Expects _ l <- ms ] closes <- mapM evalLock $ concat [ l | Closes _ l <- ms ] opens <- mapM evalLock $ concat [ l | Opens _ l <- ms ] let cti = CSig { cPars = pIs, cParPols = pPols, cWrites = wPol, cExpects = expects, cLMods = (closes, opens), cExns = exs } isVarArity = case reverse ps of [] -> False (FormalParam _ _ _ b _ : _) -> b newCm = Map.insert (tps, pTys, isVarArity) cti cm go newCm mds _ -> go cm mds eSpecToSig :: ExceptionSpec () -> TcDeclM (TcType, ExnSig) eSpecToSig (ExceptionSpec _ ms eType) = do ty <- evalSrcType (RefType () eType) -- should use evalSrcRefType rPol <- getReadPolicy ms wPol <- getWritePolicy ms opens <- mapM evalLock $ concat [ l | Opens _ l <- ms ] closes <- mapM evalLock $ concat [ l | Closes _ l <- ms ] let esig = ExnSig { exnReads = rPol, exnWrites = wPol, exnMods = (closes, opens) } return (ty, esig) paramInfo :: FormalParam () -> TcDeclM (TcType, Ident (), ActorPolicy) paramInfo (FormalParam _ ms ty _ (VarId _ i)) = do pPol <- getParamPolicy i ms pTy <- evalSrcType ty return (pTy, i, pPol) paramInfo (FormalParam _ _ _ _ arvid) = fail $ "Deprecated array syntax not supported: " ++ prettyPrint arvid withTypeParam :: TypeParam () -> TcDeclM a -> TcDeclM a withTypeParam tp tcba = case tp of ActorParam _ i -> do let vti = VSig actorT top False False True withCurrentTypeMap (\tm -> tm { actors = Map.insert i (ActorTPVar i) (actors tm), fields = Map.insert i vti (fields tm) }) $ tcba PolicyParam _ i -> do let vti = VSig policyT top False False True withCurrentTypeMap (\tm -> tm { policies = Map.insert i (RealPolicy $ TcRigidVar i) (policies tm), fields = Map.insert i vti (fields tm) }) $ tcba LockStateParam _ i -> do let lti = LSig top 0 [] withCurrentTypeMap (\tm -> tm { locks = Map.insert i lti (locks tm) }) $ tcba TypeParam _ _i _ -> do --withCurrentTypeMap (\tm -> -- tm { types = Map.insert i ([],Map.empty) (types tm) }) $ tcba {- fetchSignature :: MemberDecl () -> TcDeclM a -> TcDeclM a fetchSignature memDecl tcba = do --debug $ "fetchSignature: " ++ show memberDecl case memDecl of FieldDecl _ ms ty vds -> do tcty <- evalSrcType ty pol <- getReadPolicy ms let vti = VSig tcty pol False (Static () `elem` ms) (Final () `elem` ms) ids <- mapM unVarDecl vds withTypeMap (\tm -> tm { fields = foldl (\m i -> Map.insert i vti m) (fields tm) ids }) $ tcba MethodDecl _ ms tps retT i ps exns _ -> do withFoldMap withTypeParam tps $ do tcty <- evalReturnType retT (pTys, pPols) <- unzip <$> mapM paramInfo ps rPol <- getReturnPolicy ms pPols wPol <- getWritePolicy ms exs <- mapM eSpecToSig exns expects <- mapM evalLock $ concat [ l | Expects _ l <- ms ] closes <- mapM evalLock $ concat [ l | Closes _ l <- ms ] opens <- mapM evalLock $ concat [ l | Opens _ l <- ms ] let mti = MSig { mRetType = tcty, mRetPol = rPol, mPars = pPols, mWrites = wPol, mExpects = expects, mLMods = (closes, opens), mExns = exs } withTypeMap (\tm -> tm { methods = Map.insert (i, pTys) (tps,mti) (methods tm) }) $ tcba ConstructorDecl _ ms tps _ ps exns _ -> do withFoldMap withTypeParam tps $ do (pTys, pPols) <- unzip <$> mapM paramInfo ps wPol <- getWritePolicy ms exs <- mapM eSpecToSig exns expects <- mapM evalLock $ concat [ l | Expects _ l <- ms ] closes <- mapM evalLock $ concat [ l | Closes _ l <- ms ] opens <- mapM evalLock $ concat [ l | Opens _ l <- ms ] let cti = CSig { cPars = pPols, cWrites = wPol, cExpects = expects, cLMods = (closes, opens), cExns = exs } withTypeMap (\tm -> tm { constrs = Map.insert pTys (tps,cti) (constrs tm) }) $ tcba LockDecl _ ms i mps Nothing -> do pL <- getLockPolicy ms -- TODO: Store lock properties! let lsig = LSig pL (length mps) withTypeMap (\tm -> tm { locks = Map.insert i lsig (locks tm) }) $ tcba LockDecl {} -> fail "Lock properties not yet supported" _ -> fail "Inner classes not yet supported" where eSpecToSig :: ExceptionSpec () -> TcDeclM (TcType, ExnSig) eSpecToSig (ExceptionSpec _ ms eType) = do ty <- evalSrcType (RefType () eType) -- should use evalSrcRefType rPol <- getReadPolicy ms wPol <- getWritePolicy ms opens <- mapM evalLock $ concat [ l | Opens _ l <- ms ] closes <- mapM evalLock $ concat [ l | Closes _ l <- ms ] let esig = ExnSig { exnReads = rPol, exnWrites = wPol, exnMods = (closes, opens) } return (ty, esig) paramInfo :: FormalParam () -> TcDeclM (TcType, TcPolicy) paramInfo (FormalParam _ ms ty _ (VarId _ i)) = do pPol <- getParamPolicy i ms pTy <- evalSrcType ty return (pTy, pPol) paramInfo (FormalParam _ _ _ _ arvid) = fail $ "Deprecated array syntax not supported: " ++ prettyPrint arvid -} ------------------------------------------------------------ ------------------------------------------------------------------------------------- getReadPolicy, getWritePolicy, getLockPolicy :: [Modifier ()] -> TcDeclM ActorPolicy getReadPolicy mods = case [pol |Reads _ pol <- mods ] of -- !!0 -- Read Policy? what if no read policy? [pol] -> evalPolicy pol [] -> return bottom _ -> fail "At most one read modifier allowed per field" getWritePolicy mods = case [pol | Writes _ pol <- mods] of [pol] -> evalPolicy pol [] -> return top _ -> fail "At most one write modifier allowed per method" getLockPolicy mods = case [pol | Reads _ pol <- mods] of [pol] -> evalPolicy pol [] -> return top _ -> fail "At most one read modifier allowed per lock" getParamPolicy :: Ident () -> [Modifier ()] -> TcDeclM ActorPolicy getParamPolicy i mods = case [pol | Reads _ pol <- mods ] of [pol] -> evalPolicy pol [] -> return $ ofPol i _ -> fail "At most one read modifier allowed per parameter" getReturnPolicy :: [Modifier ()] -> [ActorPolicy] -> TcDeclM ActorPolicy getReturnPolicy mods pPols = case [pol | Reads _ pol <- mods ] of [pol] -> evalPolicy pol [] -> return $ foldl join bottom pPols _ -> fail "At most one return modifier allowed per method" ofPol :: Ident () -> ActorPolicy ofPol = RealPolicy . TcRigidVar ------------------------------------------------------------------- -- Evaluating types evalReturnType :: ReturnType () -> TcDeclM TcType evalReturnType (VoidType _) = return voidT evalReturnType (LockType _) = fail $ "lock as return type not yet implemented" -- return TcLockRetT evalReturnType (Type _ t) = evalSrcType t evalSrcType :: Type () -> TcDeclM TcType evalSrcType (PrimType _ pt) = return $ TcPrimT pt evalSrcType (RefType _ rt) = TcRefT <$> evalSrcRefType rt evalSrcType _ = panic (tcDeclMModule ++ ".evalSrcType") "AntiQType should not appear in AST being type-checked" evalSrcRefType :: RefType () -> TcDeclM TcRefType evalSrcRefType (TypeVariable _ i) = return $ TcTypeVar i evalSrcRefType (ArrayType _ t mps) = do ty <- evalSrcType t pols <- mapM (maybe (return bottom) evalPolicy) mps let (TcRefT arrTy) = mkArrayType ty pols return arrTy evalSrcRefType (ClassRefType _ ct) = TcClsRefT <$> evalSrcClsType ct evalSrcClsType :: ClassType () -> TcDeclM TcClassType evalSrcClsType ct@(ClassType _ n tas) = do debugPrint $ "Evaluating class type: " ++ show ct baseTm <- getTypeMap -- debugPrint $ "Current type map: " ++ show baseTm (tps,_iaps,_tsig) <- case lookupNamed types n baseTm of Nothing -> fetchType n -- fail $ "Unknown type: " ++ prettyPrint n Just res -> return res -- debugPrint $ "Type found" tArgs <- mapM (uncurry evalSrcTypeArg) (zip tps tas) -- debugPrint "Type arguments evaluated" return $ TcClassT n tArgs -- TODO: Is this where I evaluate? Likely not. {- where aux :: TypeMap -- Typemap of outer type (or top-level) -> [(Ident (), [TcTypeArg])] -- Accumulated type (reversed) -> [(Ident (), [TypeArgument ()])] -- Type to traverse -> TcDeclM [(Ident (), [TcTypeArg])] -- Result (re-reversed) aux _ accTy [] = return $ reverse accTy aux tm accTy ((i,tas):rest) = do debug $ "Looking up type: " ++ show i debug $ "Types field: " ++ show (types tm) (newTm, tArgs) <- case Map.lookup i (types tm) of Just (pars, tsig) -> do debug $ "Type found" tArgs <- mapM (uncurry evalSrcTypeArg) (zip pars tas) debug "Type arguments evaluated" return (instantiate (zip pars tArgs) (tMembers tsig), tArgs) Nothing -> case Map.lookup i (packages tm) of Just ptm -> do check (null tas) $ "Packages cannot have type arguments" return (ptm, []) Nothing -> fail $ "Unknown type: " ++ prettyPrint i debug $ "Rest of type to evaluate: " ++ show rest aux newTm ((i,tArgs):accTy) rest -- TcClassT <$> mapM (\(i,tas) -> (\ts -> (i, ts)) <$> mapM evalSrcTypeArg tas) iArgs -} evalSrcTypeArg :: TypeParam () -> TypeArgument () -> TcDeclM TcTypeArg evalSrcTypeArg tp (ActualArg _ a) = evalSrcNWTypeArg tp a evalSrcTypeArg _ _ = fail "evalSrcTypeArg: Wildcards not yet supported" evalSrcNWTypeArg :: TypeParam () -> NonWildTypeArgument () -> TcDeclM TcTypeArg -- Types may be names or types -- TODO: Check bounds evalSrcNWTypeArg (TypeParam {}) (ActualName _ n) = do TcActualType . TcClsRefT <$> evalSrcClsType (ClassType () n []) evalSrcNWTypeArg (TypeParam {}) (ActualType _ rt) = TcActualType <$> evalSrcRefType rt -- Actors may only be names -- TODO: must be final evalSrcNWTypeArg (ActorParam {}) (ActualName _ n) = TcActualActor <$> evalActorId n -- Policies may be names, or special expressions -- TODO: names must be final evalSrcNWTypeArg (PolicyParam {}) (ActualName _ n) = TcActualPolicy <$> evalPolicy (ExpName () n) evalSrcNWTypeArg (PolicyParam {}) (ActualExp _ e) = TcActualPolicy <$> evalPolicy e -- Lock states must be locks evalSrcNWTypeArg (LockStateParam {}) (ActualLockState _ ls) = TcActualLockState <$> mapM evalLock ls evalSrcNWTypeArg tp nwta = fail $ "Trying to instantiate type parameter " ++ prettyPrint tp ++ " with incompatible type argument " ++ prettyPrint nwta {- evalSrcNWTypeArg (ActualType _ rt) = TcActualType <$> evalSrcRefType rt evalSrcNWTypeArg (ActualPolicy _ p) = TcActualPolicy <$> evalPolicy p evalSrcNWTypeArg (ActualActor _ n) = TcActualActor <$> evalActorId n evalSrcNWTypeArg (ActualLockState _ ls) = TcActualLockState <$> mapM evalLock ls -} evalPolicy :: Exp () -> TcDeclM ActorPolicy evalPolicy e = case e of ExpName _ n -> do -- debug $ "evalPolicy: " ++ show n tm <- getTypeMap case lookupNamed policies n tm of Just p -> return p Nothing -> do debugPrint $ "TypeMap: " ++ show tm debugPrint $ "Name causing problem: " ++ show n fail $ "evalPolicy: no such policy: " ++ prettyPrint n PolicyExp _ pl -> evalPolicyExp pl BinOp _ p1 (Add _) p2 -> do pol1 <- evalPolicy p1 pol2 <- evalPolicy p2 return $ pol1 `meet` pol2 BinOp _ p1 (Mult _) p2 -> do pol1 <- evalPolicy p1 pol2 <- evalPolicy p2 return $ pol1 `join` pol2 Paren _ p -> evalPolicy p _ -> fail "evalPolicy: More here!" evalPolicyExp :: PolicyExp () -> TcDeclM ActorPolicy evalPolicyExp (PolicyLit _ cs) = (RealPolicy . TcPolicy) <$> mapM evalClause cs evalPolicyExp (PolicyOf _ i) = return $ RealPolicy $ TcRigidVar i evalPolicyExp (PolicyThis _) = return $ RealPolicy $ TcThis evalPolicyExp (PolicyTypeVar _ i) = return $ RealPolicy $ TcRigidVar i evalClause :: Clause () -> TcDeclM (TcClause TcActor) evalClause (Clause _ h b) = do h' <- evalActor h b' <- mapM evalAtom b return $ TcClause h' b' evalActorName :: ActorName () -> TcDeclM ActorId evalActorName (ActorName _ n) = evalActorId n evalActorName (ActorTypeVar _ i) = return $ ActorTPVar i evalActor :: Actor () -> TcDeclM TcActor evalActor (Actor _ n) = TcActor <$> evalActorName n evalActor (Var _ i) = return $ TcVar i evalActorId :: Name () -> TcDeclM ActorId evalActorId n = do tm <- getTypeMap case lookupNamed actors n tm of Just aid -> return aid Nothing -> unknownActorId -- fail $ "evalActor: No such actor: " ++ prettyPrint n evalAtom :: Atom () -> TcDeclM TcAtom evalAtom (Atom _ n as) = TcAtom n <$> mapM evalActor as evalLock :: Lock () -> TcDeclM TcLock evalLock (Lock _ n@(Name _ _nt mPre i) ans) = do tm <- case mPre of Nothing -> getTypeMap Just pre -> do let preT = ClassType () pre [] preTy <- evalSrcClsType preT tm <- getTypeMap case lookupTypeOfT (clsTypeToType preTy) tm of Left Nothing -> panic (tcDeclMModule ++ ".evalLock") $ "Just evaluated class type " ++ prettyPrint pre ++ " but now it doesn't exist!" Left (Just err) -> panic (tcDeclMModule ++ ".evalLock") $ err Right (_, tsig) -> return $ tMembers tsig case Map.lookup i $ locks tm of Just lsig -> do check (length ans == lArity lsig) $ "Lock " ++ prettyPrint n ++ " expects " ++ show (lArity lsig) ++ " arguments but has been given " ++ show (length ans) Nothing -> fail $ "No such lock: " ++ prettyPrint n aids <- mapM getActor ans return $ TcLock n aids evalLock (LockVar _ i) = return $ TcLockVar i evalLock l = panic (tcDeclMModule ++ ".evalLock") $ show l evalSrcLockProps :: Ident () -> Maybe (LockProperties ()) -> TcDeclM [TcClause TcAtom] evalSrcLockProps _ Nothing = return [] evalSrcLockProps i (Just (LockProperties _ lcs)) = do cs <- mapM (evalLClause i) lcs -- debugPrint $ "Properties: " ++ show cs return cs evalLClause :: Ident () -> LClause () -> TcDeclM (TcClause TcAtom) evalLClause i (LClause _ h b) = TcClause <$> evalSimpleAtom i h <*> mapM evalAtom b evalSimpleAtom :: Ident () -> Atom () -> TcDeclM TcAtom evalSimpleAtom i a@(Atom _ n _) = do case n of (Name _ _ Nothing aI) | aI == i -> evalAtom a _ -> fail $ "Lock property head does not match lock name: " ++ "\nExpected name: " ++ prettyPrint i ++ "\nFound name: " ++ prettyPrint n getActor :: ActorName () -> TcDeclM ActorId getActor (ActorName _ n) = do tm <- getTypeMap case lookupNamed actors n tm of Just aid -> return aid Nothing -> fail $ "getActor: No such actor: " ++ prettyPrint n getActor (ActorTypeVar _ i) = return $ ActorTPVar i freshActorId :: MonadBase m => String -> m ActorId freshActorId str = (liftIO . flip newFresh str) =<< getUniqRef unknownActorId :: MonadBase m => m ActorId unknownActorId = (liftIO . newUnknown) =<< getUniqRef instanceActorId :: MonadBase m => Name () -> m ActorId instanceActorId n = (liftIO . flip newInstance n) =<< getUniqRef {----------------------------------------------------- -- The continuation monad newtype TcDeclM r a = TcDeclM ((a -> TcBaseM r) -> TcBaseM r) instance Monad (TcDeclM r) where return x = TcDeclM $ \k -> k x TcDeclM f >>= h = TcDeclM $ \k -> f (\a -> let TcDeclM g = h a in g k) fail = liftTcBaseM . fail -- instances instance Functor (TcDeclM r) where fmap = liftM instance Applicative (TcDeclM r) where (<*>) = ap pure = return instance MonadTcBaseM (TcDeclM r) where liftTcBaseM dbma = TcDeclM $ \k -> dbma >>= k withTypeMap tmf (TcDeclM f) = TcDeclM $ \k -> do tm <- getTypeMap withTypeMap tmf $ f (\a -> withTypeMap (const tm) $ k a) instance MonadIO (TcDeclM r) where liftIO = liftTcBaseM . liftIO instance MonadBase (TcDeclM r) where liftBase = liftTcBaseM . liftBase withErrCtxt' ecf (TcDeclM f) = TcDeclM $ \k -> do ec <- liftBase getErrCtxt withErrCtxt' ecf $ f (\a -> (withErrCtxt' (const ec)) $ k a) instance MonadPR (TcDeclM r) where liftPR = liftTcBaseM . liftPR -- end instances class MonadTcDeclM m where liftTcDeclM :: TcDeclM r a -> m r a -- liftCallCC :: (((a -> TcDeclM r b) -> TcDeclM r a) -> TcDeclM r a) -- -> ((a -> m r b) -> m r c) -> m r c instance MonadTcDeclM TcDeclM where liftTcDeclM = id -- liftTcDeclMWith = id -- liftCallCC = id ----------------------------------------------- -- Here's the whole reason why we go through -- this lifting charade callCC :: ((a -> TcDeclM r b) -> TcDeclM r a) -> TcDeclM r a callCC cont = TcDeclM $ \k -> let TcDeclM g = cont (\a -> TcDeclM $ \_ -> k a) in g k withTypeMapAlways :: (TypeMap -> TypeMap) -> TcDeclM r a -> TcDeclM r a --withTypeMapAlways tmf tdm = callCC $ \cont -> do -- withTypeMap tmf $ tdm >>= cont withTypeMapAlways tmf (TcDeclM f) = TcDeclM $ \k -> do withTypeMap tmf $ f k -} ----------------------------------------------- -- Underlying non-cont'ed monad newtype TcDeclM a = TcDeclM (TypeMap -> TypeMap -> TcClassType -> PiReader (a, TypeMap) ) runTcDeclM :: TcClassType -> TcDeclM a -> PiReader a runTcDeclM ty (TcDeclM f) = fst <$> f emptyTM emptyTM ty instance Monad TcDeclM where return = liftPR . return TcDeclM f >>= k = TcDeclM $ \ctm gtm ty -> do (a, gtm') <- f ctm gtm ty let TcDeclM g = k a g ctm gtm' ty fail = liftPR . fail instance Functor TcDeclM where fmap = liftM instance Applicative TcDeclM where pure = return (<*>) = ap instance MonadIO TcDeclM where liftIO = liftPR . liftIO instance MonadBase TcDeclM where liftBase = liftPR . liftBase withErrCtxt' prf (TcDeclM f) = TcDeclM $ \ctm gtm ty -> withErrCtxt' prf $ f ctm gtm ty tryM (TcDeclM f) = TcDeclM $ \ctm gtm ty -> do esatm <- tryM (f ctm gtm ty) case esatm of Right (a, tm) -> return (Right a, tm) Left err -> return (Left err, gtm) instance MonadPR TcDeclM where liftPR pra = TcDeclM $ \_ gtm _ -> pra >>= \a -> return (a, gtm) class MonadPR m => MonadTcDeclM m where liftTcDeclM :: TcDeclM a -> m a withCurrentTypeMap :: (TypeMap -> TypeMap) -> m a -> m a instance MonadTcDeclM TcDeclM where liftTcDeclM = id withCurrentTypeMap = withCurrentTypeMapTB extendGlobalTypeMap :: MonadTcDeclM m => (TypeMap -> TypeMap) -> m () extendGlobalTypeMap = liftTcDeclM . extendGlobalTypeMapTB getTypeMap :: MonadTcDeclM m => m TypeMap getTypeMap = liftTcDeclM getTypeMapTB getThisType :: MonadTcDeclM m => m TcClassType getThisType = liftTcDeclM getThisTypeTB getThisStateType :: MonadTcDeclM m => m TcStateType getThisStateType = do ct <- getThisType (is, tsig) <- lookupTypeOfType $ clsTypeToType ct let aids = catMaybes $ map (\i -> Map.lookup i $ actors $ tMembers tsig) is return $ instanceT ct aids getSuperType :: MonadTcDeclM m => m TcClassType getSuperType = do thisTy <- getThisType (_, thisSig) <- lookupTypeOfType (clsTypeToType thisTy) case tSupers thisSig of [] -> return objectT [s] -> return s _ -> panic (tcDeclMModule ++ ".getSuperType") $ "Called on non-class with multiple super types" withFreshCurrentTypeMap :: TcDeclM a -> TcDeclM a withFreshCurrentTypeMap = withCurrentTypeMap (const emptyTM) getTypeMapTB :: TcDeclM TypeMap getTypeMapTB = TcDeclM $ \ctm gtm _ -> return $ (ctm `merge` gtm, gtm) getThisTypeTB :: TcDeclM TcClassType getThisTypeTB = TcDeclM $ \_ gtm ty -> return (ty, gtm) withCurrentTypeMapTB :: (TypeMap -> TypeMap) -> TcDeclM a -> TcDeclM a withCurrentTypeMapTB tmf (TcDeclM f) = TcDeclM $ \ctm gtm ty -> f (tmf ctm) gtm ty extendGlobalTypeMapTB :: (TypeMap -> TypeMap) -> TcDeclM () extendGlobalTypeMapTB tmf = TcDeclM $ \_ gtm _ -> return ((), tmf gtm)