{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TupleSections #-} module Language.Java.Paragon.TypeCheck.Monad.TcDeclM ( module Language.Java.Paragon.Monad.PiReader, TcDeclM, runTcDeclM, MonadTcDeclM(..), MonadTcBaseM(..), callCC, withTypeMapAlways, fetchPkg, fetchType, getTypeMap, getThisType, evalSrcType, evalSrcRefType, evalSrcClsType, evalSrcTypeArg, evalSrcNWTypeArg, evalReturnType, evalPolicy, evalPolicyExp, evalLock, evalActor, 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.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) tcDeclMModule :: String tcDeclMModule = typeCheckerBase ++ ".Monad.TcDeclM" freshActorId :: String -> TcDeclM r ActorId freshActorId str = (liftIO . flip newFresh str) =<< getUniqRef aliasActorId :: TcDeclM r ActorId aliasActorId = (liftIO . newAlias) =<< getUniqRef fetchPkg :: Name () -> TcDeclM r () fetchPkg n = do debugPrint $ "Fetching package " ++ prettyPrint n ++ " ..." isP <- doesPkgExist n if not isP then fail $ "No such package: " ++ prettyPrint n else do withTypeMapAlways (extendTypeMapP n emptyTM) $ do debugPrint $ "Done fetching package " ++ prettyPrint n return () fetchType :: Name () -> TcDeclM r ([TypeParam ()], TypeSig) fetchType n@(Name _ _ _ typName) = 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 _super _impls (ClassBody _ ds)) -> do check (typName == cuName) $ "File name " ++ prettyPrint typName ++ " does not match class name " ++ prettyPrint cuName let tsig = TSig { tType = clsTypeWArg (mkSimpleName TName typName) [], tIsClass = True, tIsFinal = Final () `elem` ms, tSupers = [], -- TODO: evaluate tImpls = [], -- TODO: evaluate tMembers = emptyTM } res <- withTypeMapAlways (extendTypeMapT n tps tsig) $ do let mDs = map unMemberDecl ds -- These will be written directly into the right -- places in" the TM, using the 'always' trick fetchActors n mDs fetchLocks n mDs fetchPols n mDs fetchTypeMethods n mDs 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" debugPrint $ "Packages: " ++ show (packages tm) return res Nothing -> panic (tcDeclMModule ++ ".fetchType") $ "Just fetched type " ++ show n ++ " but now it doesn't exist!" tm <- getTypeMap debugPrint $ "Packages here: " ++ show (packages tm) ++ "\n" return res 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 let tsig = TSig { tType = clsTypeWArg (mkSimpleName TName typName) [], tIsClass = False, tIsFinal = Final () `elem` ms, tSupers = [], -- TODO: evaluate tImpls = [], -- TODO: evaluate tMembers = emptyTM } withTypeMapAlways (extendTypeMapT n tps tsig) $ do -- These will be written directly into the right -- places in the TM, using the 'always' trick fetchActors n mDs fetchLocks n mDs fetchPols n mDs fetchTypeMethods n mDs 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 -- Actors fetchActors :: Name () -> [MemberDecl ()] -> TcDeclM r () fetchActors n mDecls = do --debug "fetchActors" let acts = [ (ms, vd) | FieldDecl _ ms (PrimType _ (ActorT _)) vds <- mDecls , vd <- vds , Static () `elem` ms -- Only statics exist ?? ] let (sfs,unstables) = partition (\(ms, _) -> Final () `elem` ms) acts (spawns,stables) = partition (\(_,VarDecl _ _ initz) -> initz == Nothing) sfs (sas, svs) <- unzip <$> mapM spawnActorVd spawns (aas, avs) <- unzip <$> mapM aliasActorVd unstables (eas, evs) <- unzip <$> mapM evalActorVd stables withTypeMapAlways (extendTypeMapN n (\tm -> tm { actors = Map.fromList (sas ++ aas ++ eas), fields = Map.fromList (svs ++ avs ++ evs) })) $ do debugPrint "Actors fetched" return () where spawnActorVd, evalActorVd, aliasActorVd :: ([Modifier ()], VarDecl ()) -> TcDeclM r ((Ident (), ActorId), (Ident (),VarFieldSig)) -- 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 -- All non-final aliasActorVd (ms, VarDecl _ (VarId _ i) _) = do p <- getReadPolicy ms let vti = VSig actorT p False (Static () `elem` ms) (Final () `elem` ms) a <- aliasActorId return ((i,a),(i,vti)) aliasActorVd (_, 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 -> aliasActorId --fail "Internal error: no such actor" _ -> aliasActorId 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 r () fetchLocks n mds = do let lcs = [ (i, ms, mps) | LockDecl _ ms i mps _props <- mds ] lsigs <- flip mapM lcs $ \(i, ms, mps) -> do pol <- getLockPolicy ms return (i, LSig pol (length mps)) withTypeMapAlways (extendTypeMapN n (\tm -> tm { locks = Map.fromList lsigs })) $ do debugPrint $ "Locks fetched" return () -- end locks -- policies fetchPols :: Name () -> [MemberDecl ()] -> TcDeclM r () fetchPols n mds = do let pols = [ (i,initz) | FieldDecl _ ms (PrimType _ (PolicyT _)) vds <- mds, VarDecl _ (VarId _ i) (Just (InitExp _ initz)) <- vds, Static () `elem` ms, Final () `elem` ms ] ips <- mapM fetchPol pols withTypeMapAlways (extendTypeMapN n (\tm -> tm { policies = Map.fromList ips })) $ do debugPrint $ "Policies fetched" return () where fetchPol :: (Ident (), Exp ()) -> TcDeclM r (Ident (), TcPolicy) fetchPol (i,e) = (i,) <$> evalPolicy e -- end policies -- Working with typemethods fetchTypeMethods :: Name () -> [MemberDecl ()] -> TcDeclM r () fetchTypeMethods n mds = do let ipbs = [ (i,(ps,body)) | MethodDecl _ ms _ _ i ps _ (MethodBody _ (Just body)) <- mds, Typemethod () `elem` ms ] ipidbs <- mapM paramsToIdents ipbs withTypeMapAlways (extendTypeMapN n (\tm -> tm { typemethods = Map.fromList ipidbs })) $ do debugPrint "TypeMethods fetched" return () where paramsToIdents (i, (ps,b)) = do pids <- mapM paramIdent ps return (i, (pids,b)) paramIdent :: FormalParam () -> TcDeclM r (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 r () fetchSignatures n memDs = do fieldMap <- fetchFields memDs methodMap <- fetchMethods memDs constrMap <- fetchConstrs memDs withTypeMapAlways (extendTypeMapN n (\tm -> tm { fields = fieldMap, methods = methodMap, constrs = constrMap })) $ do debugPrint "Signatures fetched" return () where unVarDecl :: VarDecl () -> TcDeclM r (Ident ()) unVarDecl (VarDecl _ (VarId _ i) _) = return i unVarDecl arvid = fail $ "Deprecated array syntax not supported: " ++ prettyPrint arvid fetchFields :: [MemberDecl ()] -> TcDeclM r (Map (Ident ()) VarFieldSig) fetchFields = go Map.empty where go :: Map (Ident ()) VarFieldSig -> [MemberDecl ()] -> TcDeclM r (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 r (Map (Ident (),[TcType]) ([TypeParam ()], MethodSig)) fetchMethods = go Map.empty where go :: Map (Ident (), [TcType]) ([TypeParam ()], MethodSig) -> [MemberDecl ()] -> TcDeclM r (Map (Ident (), [TcType]) ([TypeParam ()], MethodSig)) 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, 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 } newMm = Map.insert (i, pTys) (tps,mti) mm go newMm mds _ -> go mm mds fetchConstrs = go Map.empty where go :: Map [TcType] ([TypeParam ()], ConstrSig) -> [MemberDecl ()] -> TcDeclM r (Map [TcType] ([TypeParam ()], ConstrSig)) go acc [] = return acc go cm (md:mds) = case md of 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 } newCm = Map.insert pTys (tps,cti) cm go newCm mds _ -> go cm mds eSpecToSig :: ExceptionSpec () -> TcDeclM r (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 r (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 withTypeParam :: TypeParam () -> TcDeclM r a -> TcDeclM r a withTypeParam tp tcba = case tp of ActorParam _ i -> do let vti = VSig actorT top False False True withTypeMap (\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 withTypeMap (\tm -> tm { policies = Map.insert i (TcRigidVar i) (policies tm), fields = Map.insert i vti (fields tm) }) $ tcba LockStateParam _ i -> do let vti = VSig (lockT []) top False False True withTypeMap (\tm -> tm { fields = Map.insert i vti (fields tm) }) $ tcba TypeParam _ _i _ -> do --withTypeMap (\tm -> -- tm { types = Map.insert i ([],Map.empty) (types tm) }) $ tcba {- fetchSignature :: MemberDecl () -> TcDeclM r a -> TcDeclM r 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 r (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 r (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 r TcPolicy 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 r TcPolicy 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 ()] -> [TcPolicy] -> TcDeclM r TcPolicy 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 () -> TcPolicy ofPol = TcRigidVar ------------------------------------------------------------------- -- Evaluating types evalReturnType :: Maybe (Type ()) -> TcDeclM r TcType evalReturnType = maybe (return voidT) evalSrcType evalSrcType :: Type () -> TcDeclM r 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 r 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 r TcClassType evalSrcClsType ct@(ClassType _ n tas) = do debugPrint $ "Evaluating class type: " ++ show ct baseTm <- getTypeMap debugPrint $ "Current type map: " ++ show baseTm (tps, _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 {- where aux :: TypeMap -- Typemap of outer type (or top-level) -> [(Ident (), [TcTypeArg])] -- Accumulated type (reversed) -> [(Ident (), [TypeArgument ()])] -- Type to traverse -> TcDeclM r [(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 r TcTypeArg evalSrcTypeArg tp (ActualArg _ a) = evalSrcNWTypeArg tp a evalSrcTypeArg _ _ = fail "evalSrcTypeArg: Wildcards not yet supported" evalSrcNWTypeArg :: TypeParam () -> NonWildTypeArgument () -> TcDeclM r 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 r TcPolicy 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 $ "Types: " ++ show (types tm) 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 r TcPolicy evalPolicyExp (PolicyLit _ cs) = TcPolicy <$> mapM evalClause cs evalPolicyExp (PolicyOf _ i) = return $ TcRigidVar i evalPolicyExp (PolicyThis _) = return $ TcThis evalPolicyExp (PolicyTypeVar _ i) = return $ TcRigidVar i evalClause :: Clause () -> TcDeclM r (TcClause TcActor) evalClause (Clause _ h b) = do h' <- evalActor h b' <- mapM evalAtom b return $ TcClause h' b' evalActorName :: ActorName () -> TcDeclM r ActorId evalActorName (ActorName _ n) = evalActorId n evalActorName (ActorTypeVar _ i) = return $ ActorTPVar i evalActor :: Actor () -> TcDeclM r TcActor evalActor (Actor _ n) = TcActor <$> evalActorName n evalActor (Var _ i) = return $ TcVar i evalActorId :: Name () -> TcDeclM r ActorId evalActorId n = do tm <- getTypeMap case lookupNamed actors n tm of Just aid -> return aid Nothing -> fail $ "evalActor: No such actor: " ++ prettyPrint n evalAtom :: Atom () -> TcDeclM r TcAtom evalAtom (Atom _ n as) = TcAtom n <$> mapM evalActor as evalLock :: Lock () -> TcDeclM r TcLock evalLock (Lock _ n ans) = do tm <- getTypeMap case lookupNamed locks n 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 getActor :: ActorName () -> TcDeclM r 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 ----------------------------------------------------- -- The continuation monad newtype TcDeclM r a = TcDeclM ((a -> TcBaseM r) -> TcBaseM r) runTcDeclM :: TcType -> TcDeclM a a -> PiReader a runTcDeclM ty (TcDeclM f) = runTcBaseM (f return) emptyTM ty 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 ----------------------------------------------- -- Underlying non-cont'ed monad newtype TcBaseM a = TcBaseM { runTcBaseM :: TypeMap -> TcType -> PiReader a } instance Monad TcBaseM where return = liftPR . return TcBaseM f >>= k = TcBaseM $ \tm ty -> do a <- f tm ty let TcBaseM g = k a g tm ty fail = liftPR . fail instance Functor TcBaseM where fmap = liftM instance MonadIO TcBaseM where liftIO = liftPR . liftIO instance MonadBase TcBaseM where liftBase = liftPR . liftBase withErrCtxt' prf (TcBaseM f) = TcBaseM $ \tm ty -> withErrCtxt' prf $ f tm ty instance MonadPR TcBaseM where liftPR pra = TcBaseM $ \_ _ -> pra class MonadPR m => MonadTcBaseM m where liftTcBaseM :: TcBaseM a -> m a withTypeMap :: (TypeMap -> TypeMap) -> m a -> m a instance MonadTcBaseM TcBaseM where liftTcBaseM = id withTypeMap = withTypeMapTB getTypeMap :: MonadTcBaseM m => m TypeMap getTypeMap = liftTcBaseM getTypeMapTB getThisType :: MonadTcBaseM m => m TcType getThisType = liftTcBaseM getThisTypeTB getTypeMapTB :: TcBaseM TypeMap getTypeMapTB = TcBaseM $ \tm _ -> return tm getThisTypeTB :: TcBaseM TcType getThisTypeTB = TcBaseM $ \_ ty -> return ty withTypeMapTB :: (TypeMap -> TypeMap) -> TcBaseM a -> TcBaseM a withTypeMapTB tmf (TcBaseM f) = TcBaseM $ \tm ty -> f (tmf tm) ty