{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TupleSections, QuasiQuotes, BangPatterns #-} 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, getLocalTypeMap, 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.Strict as Map import qualified Data.ByteString.Char8 as B 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 ([B.ByteString], TypeSig) lookupTypeOfType ty = liftTcDeclM $ do tm <- getTypeMap -- debugPrint $ "lookupTypeOfType -- TypeMap:\n" ++ prettyPrint 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 ()],[B.ByteString],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 _ pkg _ [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 withFoldMap withTypeParam tps $ do 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 tnam = Name () TName (fmap (\(PackageDecl _ pn) -> pn) pkg) typName tsig = TSig { tType = TcClsRefT $ TcClassT tnam [], tIsClass = True, tIsFinal = Final () `elem` ms, tSupers = superTys, tImpls = implsTys, tMembers = superTm { constrs = Map.empty } } mDs = map unMemberDecl ds iaps = findImplActorParams mDs debugPrint $ "Adding for name: " ++ prettyPrint n extendGlobalTypeMap (extendTypeMapT n tps iaps tsig) when (not (pkg == Nothing)) $ extendGlobalTypeMap (extendTypeMapT (mkSimpleName TName cuName) tps iaps tsig) -- (rtps,rsig) <- withTypeMapAlways (extendTypeMapT n tps tsig) $ do -- withFoldMap withTypeParam tps $ do fetchActors n mDs $ do let mDss = map (:[]) mDs withFoldMap (fetchLTPs n) mDss $ 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 tnam = Name () TName (fmap (\(PackageDecl _ pn) -> pn) pkg) typName tsig = TSig { tType = TcClsRefT $ TcClassT tnam [], tIsClass = False, tIsFinal = Final () `elem` ms, tSupers = superTys, tImpls = [], tMembers = superTm } extendGlobalTypeMap (extendTypeMapT n tps [] tsig) when (not (pkg == Nothing)) $ extendGlobalTypeMap (extendTypeMapT (mkSimpleName TName cuName) 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 let mDss = map (:[]) mDs withFoldMap (fetchLTPs n) mDss $ 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 fetchLTPs :: Name () -> [MemberDecl ()] -> TcDeclM a -> TcDeclM a fetchLTPs n mDs tdma = do fetchLocks n mDs $ do fetchPols n mDs $ do fetchTypeMethods n mDs $ tdma findImplActorParams :: [MemberDecl ()] -> [B.ByteString] findImplActorParams mds = [ unIdent i | FieldDecl _ ms (PrimType _ (ActorT _)) 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 -- debugPrint $ "fetchActors: " ++ show 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 ((B.ByteString, ActorId), (B.ByteString,VarFieldSig)) -- Static, only Nothing for initializer spawnActorVd (ms, VarDecl _ (VarId _ i) _) = do a <- freshActorId (prettyPrint i) p <- RealPolicy <$> getReadPolicy ms let vti = VSig actorT p False (Static () `elem` ms) (Final () `elem` ms) return ((unIdent i,a),(unIdent i,vti)) spawnActorVd (_, VarDecl _ arvid _) = fail $ "Deprecated array syntax not supported: " ++ prettyPrint arvid paramActorVd (ms, VarDecl _ (VarId _ i) _) = do let a = ActorTPVar $ unIdent i p <- RealPolicy <$> getReadPolicy ms let vti = VSig actorT p False (Static () `elem` ms) (Final () `elem` ms) return ((unIdent i,a),(unIdent 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 <- RealPolicy <$> 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 ((unIdent i,a),(unIdent 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 ] when (not (null lcs)) $ debugPrint $ "fetchLocks: " ++ show lcs lsigs <- flip mapM lcs $ \(i, ms, mps, mProps) -> do pol <- getLockPolicy ms modPrs <- getLockModProps i ms prs <- evalSrcLockProps i mProps return (unIdent i, LSig (RealPolicy 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 lockN = mkSimpleName LName lockI varX = TcVar $ B.singleton 'x' varY = TcVar $ B.singleton 'y' varZ = TcVar $ B.singleton 'z' trans = TcClause (TcAtom lockN [varX, varY]) [TcAtom lockN [varX, varZ], TcAtom lockN [varZ, varY]] refl = TcClause (TcAtom lockN [varX, varX]) [] symm = TcClause (TcAtom lockN [varX, varY]) [TcAtom lockN [varY, varX]] return $ [ 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 = [ (unIdent 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 when (not (null pols)) $ do debugPrint $ "fetchPols: " mapM_ (debugPrint . (" " ++) . show) 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 :: (B.ByteString, Exp (), a) -> TcDeclM (B.ByteString, PrgPolicy TcActor) 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 = [ (unIdent 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 (B.ByteString) paramIdent (FormalParam _ _ _ _ (VarId _ i)) = return $ unIdent 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 (B.ByteString) unVarDecl (VarDecl _ (VarId _ i) _) = return $ unIdent i unVarDecl arvid = fail $ "Deprecated array syntax not supported: " ++ prettyPrint arvid fetchFields :: [MemberDecl ()] -> TcDeclM (Map (B.ByteString) VarFieldSig) fetchFields = go Map.empty where go :: Map (B.ByteString) VarFieldSig -> [MemberDecl ()] -> TcDeclM (Map (B.ByteString) 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 (RealPolicy 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 (B.ByteString) MethodMap) fetchMethods = go Map.empty where go :: Map (B.ByteString) MethodMap -> [MemberDecl ()] -> TcDeclM (Map (B.ByteString) 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 = RealPolicy rPol, mPars = pIs, mParBounds = map RealPolicy pPols, mWrites = RealPolicy 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 (unIdent 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, cParBounds = map RealPolicy pPols, cWrites = RealPolicy 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 = RealPolicy rPol, exnWrites = RealPolicy wPol, exnMods = (closes, opens) } return (ty, esig) paramInfo :: FormalParam () -> TcDeclM (TcType, B.ByteString, PrgPolicy TcActor) paramInfo (FormalParam _ ms ty _ (VarId _ i)) = do pPol <- getParamPolicy (unIdent i) ms pTy <- evalSrcType ty return (pTy, unIdent 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 bI = unIdent i withCurrentTypeMap (\tm -> tm { actors = Map.insert bI (ActorTPVar bI) (actors tm), fields = Map.insert bI vti (fields tm) }) $ tcba PolicyParam _ i -> do let vti = VSig policyT top False False True bI = unIdent i withCurrentTypeMap (\tm -> tm { policies = Map.insert bI (TcRigidVar False bI) (policies tm), fields = Map.insert bI vti (fields tm) }) $ tcba LockStateParam _ i -> do let lti = LSig top 0 [] withCurrentTypeMap (\tm -> tm { locks = Map.insert (unIdent 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 (PrgPolicy TcActor) 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 :: B.ByteString -> [Modifier ()] -> TcDeclM (PrgPolicy TcActor) getParamPolicy _i mods = case [pol | Reads _ pol <- mods ] of [pol] -> evalPolicy pol [] -> return $ TcRigidVar True _i -- IF GENERIC: top _ -> fail "At most one read modifier allowed per parameter" getReturnPolicy :: [Modifier ()] -> [PrgPolicy TcActor] -> TcDeclM (PrgPolicy TcActor) 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" ------------------------------------------------------------------- -- 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 $ unIdent i evalSrcRefType (ArrayType _ t mps) = do ty <- evalSrcType t pols <- map RealPolicy <$> 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 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 . RealPolicy <$> evalPolicy (ExpName () n) evalSrcNWTypeArg (PolicyParam {}) (ActualExp _ e) = TcActualPolicy . RealPolicy <$> 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 (PrgPolicy TcActor) 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 (PrgPolicy TcActor) evalPolicyExp (PolicyLit _ cs) = TcPolicy <$> mapM evalClause cs evalPolicyExp (PolicyOf _ i) = return $ TcRigidVar True (unIdent i) evalPolicyExp (PolicyThis _) = return $ TcThis evalPolicyExp (PolicyTypeVar _ i) = return $ TcRigidVar False (unIdent 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 $ unIdent i evalActor :: Actor () -> TcDeclM TcActor evalActor (Actor _ n) = TcActor <$> evalActorName n evalActor (Var _ i) = return $ TcVar (unIdent 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 (unIdent 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 $ unIdent 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 (unIdent i) freshActorId :: MonadBase m => String -> m ActorId freshActorId = liftBase . newFresh unknownActorId :: MonadBase m => m ActorId unknownActorId = liftBase newUnknown instanceActorId :: MonadBase m => Name () -> m ActorId instanceActorId = liftBase . newInstance {----------------------------------------------------- -- 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) getLocalTypeMap :: MonadTcDeclM m => m TypeMap getLocalTypeMap = liftTcDeclM $ TcDeclM $ \ctm gtm _ -> return (ctm, gtm) 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)