VarDecl.hs revision f8f78a2c8796a387a4348cc672ae08e8d9f69315
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian MaederModule : $Header$
81d182b21020b815887e9057959228546cf61b6bChristian MaederCopyright : (c) Christian Maeder and Uni Bremen 2002-2003
c438c79d00fc438f99627e612498744bdc0d0c89Christian MaederLicence : All rights reserved.
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian MaederMaintainer : hets@tzi.de
3f69b6948966979163bdfe8331c38833d5d90ecdChristian MaederStability : provisional
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian MaederPortability : non-portable (MonadState)
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maederanalyse generic var (or type var) decls
c2dead95fafd7ca36d06ddf07606a1292ead6d8aChristian Maederimport qualified Common.Lib.Map as Map
4ef2a978e66e2246ff0b7f00c77deb7aabb28b8eChristian Maederimport qualified Common.Lib.Set as Set
fc7df539e6d41b050161ed8f9ae6e444b1b5ab14Christian Maeder-- ---------------------------------------------------------------------------
3f63b98c111e5e2bb2cf13795cf6e084a78b0a8dChristian Maeder-- storing type ids with their kind and definition
2b9022bd5dfb351d1d80f61680336effeccfa23eChristian Maeder-- ---------------------------------------------------------------------------
0df692ce8b9293499b2e1768458613a63e7b5cd0Christian Maeder-- | store a complete type map
c438c79d00fc438f99627e612498744bdc0d0c89Christian MaederputTypeMap :: TypeMap -> State Env ()
0df692ce8b9293499b2e1768458613a63e7b5cd0Christian MaederputTypeMap tk = do { e <- get; put e { typeMap = tk } }
f4741f6b7da52b5417899c8fcbe4349b920b006eChristian Maeder-- | store type id and check the kind
04dada28736b4a237745e92063d8bdd49a362debChristian MaederaddTypeId :: TypeDefn -> Instance -> Kind -> Id -> State Env Bool
c438c79d00fc438f99627e612498744bdc0d0c89Christian Maeder-- type args not yet considered for kind construction
f4741f6b7da52b5417899c8fcbe4349b920b006eChristian MaederaddTypeId defn _ kind i =
f4741f6b7da52b5417899c8fcbe4349b920b006eChristian Maeder do nk <- expandKind kind
f4741f6b7da52b5417899c8fcbe4349b920b006eChristian Maeder if placeCount i <= kindArity TopLevel nk then
c438c79d00fc438f99627e612498744bdc0d0c89Christian Maeder do addTypeKind defn i kind
5334aa8fe0b0d1eb8a1cad40b741aa07172773c9Christian Maeder else do addDiags [mkDiag Error "wrong arity of" i]
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian Maeder-- | store prefix type ids both with and without following places
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian MaederaddTypeKind :: TypeDefn -> Id -> Kind -> State Env ()
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian MaederaddTypeKind d i k =
5334aa8fe0b0d1eb8a1cad40b741aa07172773c9Christian Maeder if isPrefix i then do addSingleTypeKind d i k
ce5ff829db5f0bb4f16ad4de150eed4401d6acd5Christian Maeder addSingleTypeKind d (stripFinalPlaces i) k
c438c79d00fc438f99627e612498744bdc0d0c89Christian Maeder else addSingleTypeKind d i k
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian Maeder-- | store type as is
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian MaederaddSingleTypeKind :: TypeDefn -> Id -> Kind -> State Env ()
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian MaederaddSingleTypeKind d i k =
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian Maeder do tk <- gets typeMap
f4741f6b7da52b5417899c8fcbe4349b920b006eChristian Maeder Nothing -> putTypeMap $ Map.insert i
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian Maeder (TypeInfo k [] [] d) tk
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian Maeder Just (TypeInfo ok ks sups defn) ->
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian Maeder -- check with merge
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian Maeder do checkKinds i k ok
f4741f6b7da52b5417899c8fcbe4349b920b006eChristian Maeder if any (==k) (ok:ks)
f4741f6b7da52b5417899c8fcbe4349b920b006eChristian Maeder then addDiags [mkDiag Warning
f4741f6b7da52b5417899c8fcbe4349b920b006eChristian Maeder "redeclared type" i]
04dada28736b4a237745e92063d8bdd49a362debChristian Maeder else putTypeMap $ Map.insert i
9ae2df7accdbf35839d56f90e1e8662be7112cdbChristian Maeder (k:ks) sups defn) tk
9ae2df7accdbf35839d56f90e1e8662be7112cdbChristian Maeder-- | analyse a type argument
9ae2df7accdbf35839d56f90e1e8662be7112cdbChristian MaederanaTypeVarDecl :: TypeArg -> State Env (Maybe TypeArg)
9ae2df7accdbf35839d56f90e1e8662be7112cdbChristian MaederanaTypeVarDecl(TypeArg t k s ps) =
9ae2df7accdbf35839d56f90e1e8662be7112cdbChristian Maeder do nk <- anaKind k
9ae2df7accdbf35839d56f90e1e8662be7112cdbChristian Maeder b <- addTypeId TypeVarDefn Plain nk t
9ae2df7accdbf35839d56f90e1e8662be7112cdbChristian Maeder return $ if b then Just $ TypeArg t nk s ps
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian Maeder-- | compute arity from a 'Kind'
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian MaederkindArity :: ApplMode -> Kind -> Int
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian MaederkindArity m (KindAppl k1 k2 _) =
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian Maeder TopLevel -> kindArity OnlyArg k1 +
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian Maeder kindArity TopLevel k2
c438c79d00fc438f99627e612498744bdc0d0c89Christian MaederkindArity m (ExtClass _ _ _) = case m of
c438c79d00fc438f99627e612498744bdc0d0c89Christian Maeder TopLevel -> 0
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder-- ---------------------------------------------------------------------------
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder-- for storing selectors and constructors
ab0f35d8b9012e459417e086773049ce33dda2a0Christian Maeder-- ---------------------------------------------------------------------------
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder-- | store assumptions
ab0f35d8b9012e459417e086773049ce33dda2a0Christian MaederputAssumps :: Assumps -> State Env ()
ab0f35d8b9012e459417e086773049ce33dda2a0Christian MaederputAssumps as = do { e <- get; put e { assumps = as } }
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder-- | find information for qualified operation
36c6cc568751e4235502cfee00ba7b597dae78dcChristian MaederpartitionOpId :: Assumps -> TypeMap -> Int -> UninstOpId -> TypeScheme
c438c79d00fc438f99627e612498744bdc0d0c89Christian Maeder -> ([OpInfo], [OpInfo])
ab0f35d8b9012e459417e086773049ce33dda2a0Christian MaederpartitionOpId as tm c i sc =
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder let l = Map.findWithDefault (OpInfos []) i as
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder in partition (isUnifiable tm c sc . opType) $ opInfos l
7dec34aee2b609b9535c48d060e0f7baf3536457Christian Maeder-- | storing an operation
c438c79d00fc438f99627e612498744bdc0d0c89Christian MaederaddOpId :: UninstOpId -> TypeScheme -> [OpAttr] -> OpDefn -> State Env Bool
e76e6a43f51438215737d6fc176c89da05bb86daChristian MaederaddOpId i sc attrs defn =
3f63b98c111e5e2bb2cf13795cf6e084a78b0a8dChristian Maeder do as <- gets assumps
0df692ce8b9293499b2e1768458613a63e7b5cd0Christian Maeder tm <- gets typeMap
0df692ce8b9293499b2e1768458613a63e7b5cd0Christian Maeder c <- gets counter
0df692ce8b9293499b2e1768458613a63e7b5cd0Christian Maeder let (l,r) = partitionOpId as tm c i sc
0b14ccc700093e203914052bf6aceda3164af730Christian Maeder oInfo = OpInfo sc attrs defn
0b14ccc700093e203914052bf6aceda3164af730Christian Maeder if null l then do putAssumps $ Map.insert i
0b14ccc700093e203914052bf6aceda3164af730Christian Maeder (OpInfos (oInfo : r )) as
9c03fbe72966fb21c99238c449efdb0126dae9deChristian Maeder else do let Result ds mo = merge (head l) oInfo
9c03fbe72966fb21c99238c449efdb0126dae9deChristian Maeder addDiags $ map (improveDiag i) ds
9c03fbe72966fb21c99238c449efdb0126dae9deChristian Maeder Nothing -> return False
7de39d39bc1700cc8a9bb9df90b920aad9e18d4aChristian Maeder Just oi -> do putAssumps $ Map.insert i
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian Maeder (OpInfos (oi : r )) as
9c03fbe72966fb21c99238c449efdb0126dae9deChristian Maeder----------------------------------------------------------------------------
c438c79d00fc438f99627e612498744bdc0d0c89Christian Maeder-----------------------------------------------------------------------------
c438c79d00fc438f99627e612498744bdc0d0c89Christian MaederanaGenVarDecl :: GenVarDecl -> State Env (Maybe GenVarDecl)
d48085f765fca838c1d972d2123601997174583dChristian MaederanaGenVarDecl(GenVarDecl v) = optAnaVarDecl v
c438c79d00fc438f99627e612498744bdc0d0c89Christian MaederanaGenVarDecl(GenTypeVarDecl t) =
c2dead95fafd7ca36d06ddf07606a1292ead6d8aChristian Maeder anaTypeVarDecl t >>= (return . fmap GenTypeVarDecl)
c2dead95fafd7ca36d06ddf07606a1292ead6d8aChristian MaederconvertTypeToClass :: Type -> State Env (Maybe Class)
c2dead95fafd7ca36d06ddf07606a1292ead6d8aChristian MaederconvertTypeToClass (TypeToken t) =
c2dead95fafd7ca36d06ddf07606a1292ead6d8aChristian Maeder if tokStr t == "Type" then return $ Just universe else do
c2dead95fafd7ca36d06ddf07606a1292ead6d8aChristian Maeder let ci = simpleIdToId t
c438c79d00fc438f99627e612498744bdc0d0c89Christian Maeder mk <- anaClassId ci
c438c79d00fc438f99627e612498744bdc0d0c89Christian Maeder Nothing -> do put e
c2dead95fafd7ca36d06ddf07606a1292ead6d8aChristian Maeder addDiags [mkDiag Hint "not a class" ci]
c438c79d00fc438f99627e612498744bdc0d0c89Christian Maeder return Nothing
c2dead95fafd7ca36d06ddf07606a1292ead6d8aChristian Maeder _ -> return $ Just $ Intersection (Set.single ci) []
c2dead95fafd7ca36d06ddf07606a1292ead6d8aChristian MaederconvertTypeToClass (BracketType Parens ts ps) =
a716971174535184da7713ed308423e355a4aa66Christian Maeder do cs <- mapM convertTypeToClass ts
a716971174535184da7713ed308423e355a4aa66Christian Maeder if all isJust cs then
a716971174535184da7713ed308423e355a4aa66Christian Maeder return $ Just $ Intersection (Set.unions $ map iclass $
c438c79d00fc438f99627e612498744bdc0d0c89Christian Maeder catMaybes cs) ps
c438c79d00fc438f99627e612498744bdc0d0c89Christian Maeder else return Nothing
c2dead95fafd7ca36d06ddf07606a1292ead6d8aChristian MaederconvertTypeToClass t =
c438c79d00fc438f99627e612498744bdc0d0c89Christian Maeder do addDiags [mkDiag Hint "not a class" t]
c2dead95fafd7ca36d06ddf07606a1292ead6d8aChristian Maeder return Nothing
793945d4ac7c0f22760589c87af8e71427c76118Christian MaederconvertTypeToKind :: Type -> State Env (Maybe Kind)
0f0aa53f11a0d1ab08c76428b9de73db5b17c977Christian MaederconvertTypeToKind (FunType t1 FunArr t2 ps) =
0f0aa53f11a0d1ab08c76428b9de73db5b17c977Christian Maeder do mk1 <- convertTypeToKind t1
0f0aa53f11a0d1ab08c76428b9de73db5b17c977Christian Maeder mk2 <- convertTypeToKind t2
0f0aa53f11a0d1ab08c76428b9de73db5b17c977Christian Maeder case (mk1, mk2) of
0f0aa53f11a0d1ab08c76428b9de73db5b17c977Christian Maeder (Just k1, Just k2) -> return $ Just $ KindAppl k1 k2 ps
a716971174535184da7713ed308423e355a4aa66Christian Maeder _ -> return Nothing
a716971174535184da7713ed308423e355a4aa66Christian MaederconvertTypeToKind (BracketType Parens [t] _) =
a716971174535184da7713ed308423e355a4aa66Christian Maeder do convertTypeToKind t
a716971174535184da7713ed308423e355a4aa66Christian MaederconvertTypeToKind ty@(MixfixType [t1, TypeToken t]) =
0f0aa53f11a0d1ab08c76428b9de73db5b17c977Christian Maeder let s = tokStr t
0f0aa53f11a0d1ab08c76428b9de73db5b17c977Christian Maeder v = case s of
0f0aa53f11a0d1ab08c76428b9de73db5b17c977Christian Maeder "-" -> ContraVar
0f0aa53f11a0d1ab08c76428b9de73db5b17c977Christian Maeder InVar -> do addDiags [mkDiag Hint "no kind" ty]
0b14ccc700093e203914052bf6aceda3164af730Christian Maeder return Nothing
cc8b603388a7deb7fb8045db0341f550f8be5844Christian Maeder _ -> do mk1 <- convertTypeToClass t1
f4741f6b7da52b5417899c8fcbe4349b920b006eChristian Maeder Just k1 -> return $ Just $ ExtClass k1 v [tokPos t]
c2dead95fafd7ca36d06ddf07606a1292ead6d8aChristian Maeder _ -> return Nothing
1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian MaederconvertTypeToKind t =
15c12a3ac049a4528da05b1017b78145f308aeb0Christian Maeder do mc <- convertTypeToClass t
c2dead95fafd7ca36d06ddf07606a1292ead6d8aChristian Maeder return $ fmap ( \ c -> ExtClass c InVar []) mc
c2dead95fafd7ca36d06ddf07606a1292ead6d8aChristian MaederoptAnaVarDecl :: VarDecl -> State Env (Maybe GenVarDecl)
c438c79d00fc438f99627e612498744bdc0d0c89Christian MaederoptAnaVarDecl vd@(VarDecl v t s q) =
c2dead95fafd7ca36d06ddf07606a1292ead6d8aChristian Maeder let varDecl = anaVarDecl vd >>= (return . fmap GenVarDecl) in
c2dead95fafd7ca36d06ddf07606a1292ead6d8aChristian Maeder if isSimpleId v then
c438c79d00fc438f99627e612498744bdc0d0c89Christian Maeder do mk <- convertTypeToKind t
0b14ccc700093e203914052bf6aceda3164af730Christian Maeder Just k -> anaTypeVarDecl(TypeArg v k s q) >>=
c2dead95fafd7ca36d06ddf07606a1292ead6d8aChristian Maeder (return . fmap GenTypeVarDecl)
c438c79d00fc438f99627e612498744bdc0d0c89Christian MaederanaVarDecl :: VarDecl -> State Env (Maybe VarDecl)
cc8b603388a7deb7fb8045db0341f550f8be5844Christian MaederanaVarDecl(VarDecl v oldT s ps) =
c2dead95fafd7ca36d06ddf07606a1292ead6d8aChristian Maeder do mt <- anaStarType oldT
1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian Maeder Nothing -> return Nothing
ad623ebb0fa505940a039fe967ecff8749719ac9Christian Maeder do let vd = VarDecl v t s ps
ad623ebb0fa505940a039fe967ecff8749719ac9Christian Maeder b <- addVarDecl (VarDecl v t s ps)
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian Maeder return $ if b then Just vd else Nothing
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian Maeder-- | add a local variable with an analysed type
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian MaederaddVarDecl :: VarDecl -> State Env Bool
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian MaederaddVarDecl(VarDecl v t _ _) =
6d96cc81e7926a65188fea5626e0e4e199f9d782Christian Maeder addOpId v (simpleTypeScheme t) [] VarDefn