967e5f3c25249c779575864692935627004d3f9eChristian Maeder{- |

967e5f3c25249c779575864692935627004d3f9eChristian MaederModule : $Header$

81d182b21020b815887e9057959228546cf61b6bChristian MaederDescription : analyse var decls

f11f713bebd8e1e623a0a4361065df256033de47Christian MaederCopyright : (c) Christian Maeder and Uni Bremen 2002-2005

98890889ffb2e8f6f722b00e265a211f13b5a861Corneliu-Claudiu ProdescuLicense : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt

967e5f3c25249c779575864692935627004d3f9eChristian Maeder

3f69b6948966979163bdfe8331c38833d5d90ecdChristian MaederMaintainer : Christian.Maeder@dfki.de

967e5f3c25249c779575864692935627004d3f9eChristian MaederStability : provisional

89054b2b95a3f92e78324dc852f3d34704e2ca49Christian MaederPortability : portable

f3a94a197960e548ecd6520bb768cb0d547457bbChristian Maeder

717686b54b9650402e2ebfbaadf433eab8ba5171Christian Maederanalyse generic var (or type var) decls

717686b54b9650402e2ebfbaadf433eab8ba5171Christian Maeder

967e5f3c25249c779575864692935627004d3f9eChristian Maeder-}

967e5f3c25249c779575864692935627004d3f9eChristian Maeder

967e5f3c25249c779575864692935627004d3f9eChristian Maedermodule HasCASL.VarDecl where

967e5f3c25249c779575864692935627004d3f9eChristian Maeder

fd896e2068ad7e50aed66ac18c3720ea7ff2619fChristian Maederimport Data.Maybe

7221c71b38c871ce66eee4537cb681d468308dfbChristian Maederimport Data.List as List

ee93fb771fcf3000d73c8e2f2000adb4b9a5158cChristian Maederimport Control.Monad

ee93fb771fcf3000d73c8e2f2000adb4b9a5158cChristian Maederimport Text.ParserCombinators.Parsec (runParser, eof)

ee93fb771fcf3000d73c8e2f2000adb4b9a5158cChristian Maeder

ac19f8695aa1b2d2d1cd1319da2530edd8f46a96Christian Maederimport qualified Data.Map as Map

8b9fda012e5ee53b7b2320c0638896a0ff6e99f3Christian Maederimport qualified Data.Set as Set

ee93fb771fcf3000d73c8e2f2000adb4b9a5158cChristian Maederimport Common.Id

ee93fb771fcf3000d73c8e2f2000adb4b9a5158cChristian Maederimport Common.Lib.State

e1839fb37a3a2ccd457464cb0dcc5efd466dbe22Christian Maederimport Common.Result

4ef2a978e66e2246ff0b7f00c77deb7aabb28b8eChristian Maederimport Common.DocUtils

551af0e4ba6d96bb24f3555f3b30ed648e22e34aChristian Maederimport Common.Lexer

fd896e2068ad7e50aed66ac18c3720ea7ff2619fChristian Maederimport Common.AnnoState

967e5f3c25249c779575864692935627004d3f9eChristian Maeder

8e9c3881fb6e710b1e08bf5ac8ff9d393df2e74eChristian Maederimport HasCASL.ParseTerm

78eeae099616e255ccf2e5f9122387bb10c68338Christian Maederimport HasCASL.As

72b9099aeec0762bae4546db3bc4b48721027bf4Christian Maederimport HasCASL.AsUtils

72b9099aeec0762bae4546db3bc4b48721027bf4Christian Maederimport HasCASL.FoldType

72b9099aeec0762bae4546db3bc4b48721027bf4Christian Maederimport HasCASL.Le

ad187062b0009820118c1b773a232e29b879a2faChristian Maederimport HasCASL.ClassAna

ad270004874ce1d0697fb30d7309f180553bb315Christian Maederimport HasCASL.TypeAna

fd896e2068ad7e50aed66ac18c3720ea7ff2619fChristian Maederimport HasCASL.Unify

551af0e4ba6d96bb24f3555f3b30ed648e22e34aChristian Maederimport HasCASL.Merge

551af0e4ba6d96bb24f3555f3b30ed648e22e34aChristian Maederimport HasCASL.Builtin

551af0e4ba6d96bb24f3555f3b30ed648e22e34aChristian Maeder

72b9099aeec0762bae4546db3bc4b48721027bf4Christian MaederanaStarType :: Type -> State Env (Maybe Type)

551af0e4ba6d96bb24f3555f3b30ed648e22e34aChristian MaederanaStarType t = fmap (fmap snd) $ anaType (Just universe, t)

551af0e4ba6d96bb24f3555f3b30ed648e22e34aChristian Maeder

551af0e4ba6d96bb24f3555f3b30ed648e22e34aChristian MaederanaType :: (Maybe Kind, Type)

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder -> State Env (Maybe ((RawKind, Set.Set Kind), Type))

1a75698c909ad515d59c76e65bd783f015c21c4dChristian MaederanaType p = fromResult $ anaTypeM p

51fb5d7edd9369c367dda2f8b15ddd6f8a146606Christian Maeder

1a75698c909ad515d59c76e65bd783f015c21c4dChristian MaederanaTypeScheme :: TypeScheme -> State Env (Maybe TypeScheme)

1a75698c909ad515d59c76e65bd783f015c21c4dChristian MaederanaTypeScheme (TypeScheme tArgs ty p) =

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder do tvs <- gets localTypeVars -- save global variables

51fb5d7edd9369c367dda2f8b15ddd6f8a146606Christian Maeder mArgs <- mapM anaddTypeVarDecl tArgs

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder let newArgs = catMaybes mArgs

67d92da5e9610aabad39055a16031154b4dc3748Christian Maeder mt <- anaStarType ty

67d92da5e9610aabad39055a16031154b4dc3748Christian Maeder case mt of

67d92da5e9610aabad39055a16031154b4dc3748Christian Maeder Nothing -> do putLocalTypeVars tvs -- forget local variables

72b9099aeec0762bae4546db3bc4b48721027bf4Christian Maeder return Nothing

72b9099aeec0762bae4546db3bc4b48721027bf4Christian Maeder Just newTy -> do

67d92da5e9610aabad39055a16031154b4dc3748Christian Maeder let newSc = TypeScheme newArgs newTy p

67d92da5e9610aabad39055a16031154b4dc3748Christian Maeder gTy <- generalizeS newSc

67d92da5e9610aabad39055a16031154b4dc3748Christian Maeder putLocalTypeVars tvs -- forget local variables

67d92da5e9610aabad39055a16031154b4dc3748Christian Maeder return $ Just gTy

67d92da5e9610aabad39055a16031154b4dc3748Christian Maeder

7a879b08ae0ca30006f9be887a73212b07f10204Christian MaedergeneralizeS :: TypeScheme -> State Env TypeScheme

1a75698c909ad515d59c76e65bd783f015c21c4dChristian MaedergeneralizeS sc@(TypeScheme tArgs ty p) = do

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder let fvs = leaves (> 0) ty

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder svs = sortBy comp fvs

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder comp a b = compare (fst a) $ fst b

67d92da5e9610aabad39055a16031154b4dc3748Christian Maeder tvs <- gets localTypeVars

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder let newArgs = map ( \ (_, (i, _)) -> case Map.lookup i tvs of

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder Nothing -> error "generalizeS"

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder Just (TypeVarDefn v vk rk c) ->

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder TypeArg i v vk rk c Other nullRange) svs

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder newSc = TypeScheme (genTypeArgs newArgs) (generalize newArgs ty) p

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder if null tArgs then return newSc

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder else do

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder addDiags $ generalizable False sc

67d92da5e9610aabad39055a16031154b4dc3748Christian Maeder return newSc

7a879b08ae0ca30006f9be887a73212b07f10204Christian Maeder

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder-- | store type id and check kind arity (warn on redeclared types)

67d92da5e9610aabad39055a16031154b4dc3748Christian MaederaddTypeId :: Bool -> TypeDefn -> Kind -> Id -> State Env Bool

b66eb6038bfbcd2fe520d87c151bb4f1f510e985Christian MaederaddTypeId warn dfn k i = do

a89389521ddf76109168a0b339031575aafbd512Christian Maeder tvs <- gets localTypeVars

a89389521ddf76109168a0b339031575aafbd512Christian Maeder case Map.lookup i tvs of

a89389521ddf76109168a0b339031575aafbd512Christian Maeder Just _ -> do

a89389521ddf76109168a0b339031575aafbd512Christian Maeder if warn then addDiags[mkDiag Warning

a89389521ddf76109168a0b339031575aafbd512Christian Maeder "new type shadows type variable" i]

a89389521ddf76109168a0b339031575aafbd512Christian Maeder else return ()

a89389521ddf76109168a0b339031575aafbd512Christian Maeder putLocalTypeVars $ Map.delete i tvs

a89389521ddf76109168a0b339031575aafbd512Christian Maeder Nothing -> return()

a89389521ddf76109168a0b339031575aafbd512Christian Maeder cm <- gets classMap

54ff63bb3b23ef18efbdc51b053a2ca6f348329aChristian Maeder case Map.lookup i cm of

54ff63bb3b23ef18efbdc51b053a2ca6f348329aChristian Maeder Just _ -> do

54ff63bb3b23ef18efbdc51b053a2ca6f348329aChristian Maeder addDiags [mkDiag Error "class name used as type" i]

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder return False

54ff63bb3b23ef18efbdc51b053a2ca6f348329aChristian Maeder Nothing -> addTypeKind warn dfn i k

54ff63bb3b23ef18efbdc51b053a2ca6f348329aChristian Maeder

ceef5f7843a1f96fe5a62e0f6880e38b3d5f4708Christian Maeder-- | check if the kind only misses variance indicators of the known raw kind

54ff63bb3b23ef18efbdc51b053a2ca6f348329aChristian MaederisLiberalKind :: ClassMap -> Bool -> RawKind -> Kind -> Maybe Kind

54ff63bb3b23ef18efbdc51b053a2ca6f348329aChristian MaederisLiberalKind cm b ok k = case ok of

ceef5f7843a1f96fe5a62e0f6880e38b3d5f4708Christian Maeder ClassKind _ -> Just k

ceef5f7843a1f96fe5a62e0f6880e38b3d5f4708Christian Maeder FunKind ov fok aok _ -> case k of

ceef5f7843a1f96fe5a62e0f6880e38b3d5f4708Christian Maeder FunKind v fk ak ps -> do

54ff63bb3b23ef18efbdc51b053a2ca6f348329aChristian Maeder nfk <- isLiberalKind cm (not b) fok fk

ceef5f7843a1f96fe5a62e0f6880e38b3d5f4708Christian Maeder nak <- isLiberalKind cm b aok ak

54ff63bb3b23ef18efbdc51b053a2ca6f348329aChristian Maeder return $ FunKind (liberalVariance b ov v) nfk nak ps

ee93fb771fcf3000d73c8e2f2000adb4b9a5158cChristian Maeder ClassKind i -> case Map.lookup i cm of

e77eadd37125110f448dd5ddec7da5b78d35285fChristian Maeder Just ci -> maybe Nothing (const $ Just k) $ minRawKind "" ok

ee93fb771fcf3000d73c8e2f2000adb4b9a5158cChristian Maeder $ rawKind ci

54ff63bb3b23ef18efbdc51b053a2ca6f348329aChristian Maeder _ -> Nothing

54ff63bb3b23ef18efbdc51b053a2ca6f348329aChristian Maeder

54ff63bb3b23ef18efbdc51b053a2ca6f348329aChristian MaederliberalVariance :: Bool -> Variance -> Variance -> Variance

ceef5f7843a1f96fe5a62e0f6880e38b3d5f4708Christian MaederliberalVariance b v1 v2 = if b then minVariance v1 v2 else

ceef5f7843a1f96fe5a62e0f6880e38b3d5f4708Christian Maeder revVariance $ minVariance (revVariance v1) $ revVariance v2

ceef5f7843a1f96fe5a62e0f6880e38b3d5f4708Christian Maeder

54ff63bb3b23ef18efbdc51b053a2ca6f348329aChristian Maeder-- | lifted 'anaKindM'

54ff63bb3b23ef18efbdc51b053a2ca6f348329aChristian MaederanaKind :: Kind -> State Env RawKind

ee93fb771fcf3000d73c8e2f2000adb4b9a5158cChristian MaederanaKind k = do

67086e0fe40a985c5e8a3cf50e611f43234580c2Christian Maeder mrk <- fromResult $ anaKindM k . classMap

e77eadd37125110f448dd5ddec7da5b78d35285fChristian Maeder case mrk of

67d92da5e9610aabad39055a16031154b4dc3748Christian Maeder Nothing -> error "anaKind"

ee93fb771fcf3000d73c8e2f2000adb4b9a5158cChristian Maeder Just rk -> return rk

67086e0fe40a985c5e8a3cf50e611f43234580c2Christian Maeder

d4146229cf85928342dfd25ec8b579a7feb0d381Christian Maeder-- | store type as is (warn on redeclared types)

d4146229cf85928342dfd25ec8b579a7feb0d381Christian MaederaddTypeKind :: Bool -> TypeDefn -> Id -> Kind -> State Env Bool

717686b54b9650402e2ebfbaadf433eab8ba5171Christian MaederaddTypeKind warn d i k = do

d48085f765fca838c1d972d2123601997174583dChristian Maeder e <- get

d48085f765fca838c1d972d2123601997174583dChristian Maeder rk <- anaKind k

717686b54b9650402e2ebfbaadf433eab8ba5171Christian Maeder let tm = typeMap e

d48085f765fca838c1d972d2123601997174583dChristian Maeder cm = classMap e

d48085f765fca838c1d972d2123601997174583dChristian Maeder addTypeSym ck = if Map.member i bTypes then return () else

588c0c022a0f4e129a89c3bc569daf6a835e182dChristian Maeder addSymbol $ idToTypeSymbol e i ck

d48085f765fca838c1d972d2123601997174583dChristian Maeder if placeCount i <= kindArity rk then return () else

717686b54b9650402e2ebfbaadf433eab8ba5171Christian Maeder addDiags [mkDiag Error "wrong arity of" i]

717686b54b9650402e2ebfbaadf433eab8ba5171Christian Maeder case Map.lookup i tm of

e7ce154edb906685b3fa7f6c0a764e18a4658068Christian Maeder Nothing -> do

b66eb6038bfbcd2fe520d87c151bb4f1f510e985Christian Maeder addTypeSym rk

9b30898b139ee02f97ac933b6d935ef0a4206921Christian Maeder putTypeMap $ Map.insert i (TypeInfo rk (Set.singleton k) Set.empty d) tm

b66eb6038bfbcd2fe520d87c151bb4f1f510e985Christian Maeder return True

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder Just (TypeInfo ok oldks sups dfn) ->

b66eb6038bfbcd2fe520d87c151bb4f1f510e985Christian Maeder case minRawKind "" ok rk of

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder Nothing -> do

b66eb6038bfbcd2fe520d87c151bb4f1f510e985Christian Maeder addDiags $ diffKindDiag i ok rk

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder return False

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder Just r -> case isLiberalKind cm True r k of

b66eb6038bfbcd2fe520d87c151bb4f1f510e985Christian Maeder Just nk -> do

b66eb6038bfbcd2fe520d87c151bb4f1f510e985Christian Maeder let isNewInst = newKind cm nk oldks

d4146229cf85928342dfd25ec8b579a7feb0d381Christian Maeder insts = if isNewInst then addNewKind cm nk oldks else oldks

b66eb6038bfbcd2fe520d87c151bb4f1f510e985Christian Maeder Result ds mDef = mergeTypeDefn dfn d

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder if warn && not isNewInst && case (dfn, d) of

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder (PreDatatype, DatatypeDefn _) -> False

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder _ -> True

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder then addDiags [mkDiag Hint "redeclared type" i]

c5c193a80459071696b68baf835f1b88f0f8c82eChristian Maeder else return ()

0a8ea95bcf0e3f84fed0b725c049ec2a956a4a28Christian Maeder case mDef of

967e5f3c25249c779575864692935627004d3f9eChristian Maeder Just newDefn -> do

18b513ff41708f24e1a7407f36b719add813ffeaChristian Maeder addTypeSym r

dedabc954aa15f6ad0764472a9434dc6dafe3db2Christian Maeder putTypeMap $ Map.insert i (TypeInfo r insts sups newDefn) tm

a89e661aad28f1b39f4fc9f9f9a4d46074234123Christian Maeder return True

d4146229cf85928342dfd25ec8b579a7feb0d381Christian Maeder _ -> do

d4146229cf85928342dfd25ec8b579a7feb0d381Christian Maeder addDiags $ map (improveDiag i) ds

58b5ac21d1c88344246aaedab0c0bdc7b759d7c6Christian Maeder return False

3c8d067accf18572352351ec42ff905c7297a8a5Christian Maeder Nothing -> do

58b5ac21d1c88344246aaedab0c0bdc7b759d7c6Christian Maeder addDiags [mkDiag Error "cannot refine kind" i]

f2ee9fc53048ea92bad79e3f5d292d83efd7f8beMihai Codescu return False

3c8d067accf18572352351ec42ff905c7297a8a5Christian Maeder

81d182b21020b815887e9057959228546cf61b6bChristian MaedernonUniqueKind :: (PosItem a, Pretty a) => Set.Set Kind -> a ->

58b5ac21d1c88344246aaedab0c0bdc7b759d7c6Christian Maeder (Kind -> State Env (Maybe b)) -> State Env (Maybe b)

242397ba0f1cc490e892130bf0df239deeecf5daChristian MaedernonUniqueKind ks a f = case Set.toList ks of

2e9985cd67e4f2414becb670ef33b8f16513e41dChristian Maeder [k] -> f k

242397ba0f1cc490e892130bf0df239deeecf5daChristian Maeder _ -> do addDiags [mkDiag Error "non-unique kind for" a]

58b5ac21d1c88344246aaedab0c0bdc7b759d7c6Christian Maeder return Nothing

d769b9ca726a9b50d661847c0e58c41d6ef334b4Christian Maeder

551af0e4ba6d96bb24f3555f3b30ed648e22e34aChristian Maeder-- | analyse a type argument

58b5ac21d1c88344246aaedab0c0bdc7b759d7c6Christian MaederanaddTypeVarDecl :: TypeArg -> State Env (Maybe TypeArg)

551af0e4ba6d96bb24f3555f3b30ed648e22e34aChristian MaederanaddTypeVarDecl (TypeArg i v vk _ _ s ps) = do

551af0e4ba6d96bb24f3555f3b30ed648e22e34aChristian Maeder cm <- gets classMap

4072adb8c5d2c86123e8e1c1918263968f187829Christian Maeder case Map.lookup i cm of

4072adb8c5d2c86123e8e1c1918263968f187829Christian Maeder Just _ -> do

4072adb8c5d2c86123e8e1c1918263968f187829Christian Maeder addDiags [mkDiag Error "class used as type variable" i]

4072adb8c5d2c86123e8e1c1918263968f187829Christian Maeder return Nothing

4072adb8c5d2c86123e8e1c1918263968f187829Christian Maeder Nothing -> do

4072adb8c5d2c86123e8e1c1918263968f187829Christian Maeder c <- toEnvState inc

4072adb8c5d2c86123e8e1c1918263968f187829Christian Maeder case vk of

4072adb8c5d2c86123e8e1c1918263968f187829Christian Maeder VarKind k ->

4072adb8c5d2c86123e8e1c1918263968f187829Christian Maeder let Result ds (Just rk) = anaKindM k cm

4072adb8c5d2c86123e8e1c1918263968f187829Christian Maeder in if null ds then do

dedabc954aa15f6ad0764472a9434dc6dafe3db2Christian Maeder addLocalTypeVar True (TypeVarDefn v vk rk c) i

842eedc62639561781b6c33533d1949693ef6cc5Christian Maeder return $ Just $ TypeArg i v vk rk c s ps

588c0c022a0f4e129a89c3bc569daf6a835e182dChristian Maeder else do addDiags ds

588c0c022a0f4e129a89c3bc569daf6a835e182dChristian Maeder return Nothing

588c0c022a0f4e129a89c3bc569daf6a835e182dChristian Maeder Downset t -> do

842eedc62639561781b6c33533d1949693ef6cc5Christian Maeder mt <- anaType (Nothing, t)

bfa9e03532243ceb487f0384d0f6a447f1ce7670Till Mossakowski case mt of

967e5f3c25249c779575864692935627004d3f9eChristian Maeder Nothing -> return Nothing

967e5f3c25249c779575864692935627004d3f9eChristian Maeder Just ((rk, ks), nt) ->

f2ee9fc53048ea92bad79e3f5d292d83efd7f8beMihai Codescu nonUniqueKind ks t $ \ k -> do

967e5f3c25249c779575864692935627004d3f9eChristian Maeder let nd = Downset (KindedType nt (Set.singleton k) nullRange)

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder addLocalTypeVar True (TypeVarDefn NonVar nd rk c) i

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder return $ Just $ TypeArg i v (Downset nt) rk c s ps

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder MissingKind -> do

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder tvs <- gets localTypeVars

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder case Map.lookup i tvs of

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder Nothing -> do

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder addDiags [mkDiag Error "unknown type variable" i]

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder let dvk = VarKind universe

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder addLocalTypeVar True (TypeVarDefn v dvk rStar c) i

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder return $ Just $ TypeArg i v dvk rStar c s ps

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder Just (TypeVarDefn v0 dvk rk _) -> do

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder addLocalTypeVar False (TypeVarDefn v0 dvk rk c) i

967e5f3c25249c779575864692935627004d3f9eChristian Maeder return $ Just $ TypeArg i v0 dvk rk c s ps

967e5f3c25249c779575864692935627004d3f9eChristian Maeder

ad187062b0009820118c1b773a232e29b879a2faChristian Maeder-- | get matching information of uninstantiated identifier

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian MaederfindOpId :: Env -> Id -> TypeScheme -> Maybe OpInfo

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian MaederfindOpId e i sc = listToMaybe $ Set.toList $ fst $ partitionOpId e i sc

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder-- | partition information of an uninstantiated identifier

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian MaederpartitionOpId :: Env -> Id -> TypeScheme -> (Set.Set OpInfo, Set.Set OpInfo)

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian MaederpartitionOpId e i sc =

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder Set.partition (isUnifiable (typeMap e) (counter e) sc . opType)

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder $ Map.findWithDefault Set.empty i $ assumps e

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian MaedercheckUnusedTypevars :: TypeScheme -> State Env TypeScheme

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian MaedercheckUnusedTypevars sc@(TypeScheme tArgs t ps) = do

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder let ls = map (fst . snd) $ leaves (< 0) t -- generic vars

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder rest = map getTypeVar tArgs List.\\ ls

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder if null rest then return ()

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder else addDiags [Diag Warning ("unused type variables: "

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder ++ show(ppWithCommas rest)) ps]

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder return sc

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder

1a75698c909ad515d59c76e65bd783f015c21c4dChristian MaedercheckPlaceCount :: Env -> Id -> TypeScheme -> [Diagnosis]

1a75698c909ad515d59c76e65bd783f015c21c4dChristian MaedercheckPlaceCount e i (TypeScheme _ ty _) =

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder if placeCount i > 1 then

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder let (fty, fargs) = getTypeAppl ty in

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder if length fargs == 2 && lesserType e fty (toFunType PFunArr) then

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder let (pty, ts) = getTypeAppl (head fargs)

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder n = length ts in

ad187062b0009820118c1b773a232e29b879a2faChristian Maeder if n > 1 && lesserType e pty (toProdType n nullRange) then

ad187062b0009820118c1b773a232e29b879a2faChristian Maeder if placeCount i /= n then

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder [mkDiag Warning "wrong number of places in" i]

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder else []

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder else [mkDiag Warning "expected tuple argument for" i]

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder else [mkDiag Warning "expected function type for" i]

ad187062b0009820118c1b773a232e29b879a2faChristian Maeder else []

ad187062b0009820118c1b773a232e29b879a2faChristian Maeder

ad187062b0009820118c1b773a232e29b879a2faChristian Maeder-- | storing an operation

1a75698c909ad515d59c76e65bd783f015c21c4dChristian MaederaddOpId :: Id -> TypeScheme -> Set.Set OpAttr -> OpDefn -> State Env Bool

1a75698c909ad515d59c76e65bd783f015c21c4dChristian MaederaddOpId i oldSc attrs dfn = do

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder sc@(TypeScheme args1 ty _) <- checkUnusedTypevars oldSc

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder e <- get

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder let as = assumps e

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder tm = typeMap e

9659c509ce5e78adc51d7b02a76274eddcba9338Christian Maeder cm = classMap e

9659c509ce5e78adc51d7b02a76274eddcba9338Christian Maeder ds = checkPlaceCount e i sc

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder (l, r) = partitionOpId e i sc

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder oInfo = OpInfo sc attrs dfn

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder Result es mo = foldM (mergeOpInfo cm tm) oInfo $ Set.toList l

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder addDiags ds

9659c509ce5e78adc51d7b02a76274eddcba9338Christian Maeder addDiags $ map (improveDiag i) es

9659c509ce5e78adc51d7b02a76274eddcba9338Christian Maeder if i `elem` map fst bList then

551af0e4ba6d96bb24f3555f3b30ed648e22e34aChristian Maeder addDiags [mkDiag Warning "ignoring declaration for builtin identifier" i]

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder else case Set.toList l of

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder [] -> return ()

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder [OpInfo {opType = TypeScheme args2 ty2 _}] | eqStrippedType ty2 ty ->

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder addDiags [mkDiag Hint

83814002b4922114cbe7e9ba728472a0bf44aac5Christian Maeder ((if args1 == args2 then "repeated" else

83814002b4922114cbe7e9ba728472a0bf44aac5Christian Maeder if specializedScheme cm args2 args1

a95f5379cabb30d3beb0545002cf50e9e4fc2c86Christian Maeder then "more general" else

97ee7048e63953c5617342ce38c30cbcb35cc0beChristian Maeder if specializedScheme cm args1 args2 then

97ee7048e63953c5617342ce38c30cbcb35cc0beChristian Maeder "ignored specialized" else "uncomparable")

b66eb6038bfbcd2fe520d87c151bb4f1f510e985Christian Maeder ++ " declaration of '"

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder ++ showId i "' with type") ty]

b66eb6038bfbcd2fe520d87c151bb4f1f510e985Christian Maeder _ -> addDiags [mkDiag Warning "overlapping declaration of" i]

a74f814d3b445eadad6f68737a98a7a303698affChristian Maeder case mo of

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder Nothing -> return False

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder Just oi -> do

d4146229cf85928342dfd25ec8b579a7feb0d381Christian Maeder addSymbol $ idToOpSymbol e i $ opType oi

d4146229cf85928342dfd25ec8b579a7feb0d381Christian Maeder putAssumps $ Map.insert i (Set.insert oi r) as

a74f814d3b445eadad6f68737a98a7a303698affChristian Maeder return True

b66eb6038bfbcd2fe520d87c151bb4f1f510e985Christian Maeder

2dfc7b04f2db681992ca04175f2beb0f127c9844Christian Maeder-- | add a local variable with an analysed type (if True then warn)

d4146229cf85928342dfd25ec8b579a7feb0d381Christian MaederaddLocalVar :: Bool -> VarDecl -> State Env ()

d4146229cf85928342dfd25ec8b579a7feb0d381Christian MaederaddLocalVar warn (VarDecl v t _ _) =

a74f814d3b445eadad6f68737a98a7a303698affChristian Maeder do ass <- gets assumps

ad187062b0009820118c1b773a232e29b879a2faChristian Maeder vs <- gets localVars

ad187062b0009820118c1b773a232e29b879a2faChristian Maeder if warn then if Map.member v ass then

588c0c022a0f4e129a89c3bc569daf6a835e182dChristian Maeder addDiags [mkDiag Hint "variable shadows global name(s)" v]

1a75698c909ad515d59c76e65bd783f015c21c4dChristian Maeder else if Map.member v vs then

d4146229cf85928342dfd25ec8b579a7feb0d381Christian Maeder addDiags [mkDiag Hint "rebound variable" v]

d4146229cf85928342dfd25ec8b579a7feb0d381Christian Maeder else return ()

07b72edb610ee53b4832d132e96b0a3d8423f8ebChristian Maeder else return ()

putLocalVars $ Map.insert v (VarDefn t) vs

-- | add analysed local variable or type variable declaration

addGenVarDecl :: GenVarDecl -> State Env ()

addGenVarDecl(GenVarDecl v) = addLocalVar True v

addGenVarDecl(GenTypeVarDecl t) = addTypeVarDecl False t

-- | analyse and add local variable or type variable declaration

anaddGenVarDecl :: Bool -> GenVarDecl -> State Env (Maybe GenVarDecl)

anaddGenVarDecl warn gv = case gv of

GenVarDecl v -> optAnaddVarDecl warn v

GenTypeVarDecl t -> anaddTypeVarDecl t >>= (return . fmap GenTypeVarDecl)

convTypeToKind :: Type -> Maybe (Variance, Kind)

convTypeToKind ty = let s = showDoc ty "" in

case runParser (extKind << eof) (emptyAnnos ()) "" s of

Right (v, k) -> Just (v, k)

_ -> Nothing

convertTypeToKind :: Env -> Type -> Result (Variance, Kind)

convertTypeToKind e ty = case convTypeToKind ty of

Just (v, k) -> let Result ds _ = anaKindM k $ classMap e in

if null ds then return (v, k) else Result ds Nothing

_ -> fail $ "not a kind '" ++ showDoc ty "'"

-- | local variable or type variable declaration

optAnaddVarDecl :: Bool -> VarDecl -> State Env (Maybe GenVarDecl)

optAnaddVarDecl warn vd@(VarDecl v t s q) =

let varDecl = do mvd <- anaVarDecl vd

case mvd of

Nothing -> return Nothing

Just nvd -> do

let movd = makeMonomorph nvd

addLocalVar warn movd

return $ Just $ GenVarDecl movd

in if isSimpleId v then

do e <- get

let Result ds mk = convertTypeToKind e t

case mk of

Just (vv, k) -> do

addDiags [mkDiag Hint "is type variable" v]

tv <- anaddTypeVarDecl $ TypeArg v vv (VarKind k) rStar 0 s q

return $ fmap GenTypeVarDecl tv

_ -> do addDiags $ map ( \ d -> Diag Hint (diagString d) q) ds

varDecl

else varDecl

makeMonomorph :: VarDecl -> VarDecl

makeMonomorph (VarDecl v t sk ps) = VarDecl v (monoType t) sk ps

monoType :: Type -> Type

monoType = foldType mapTypeRec

{ foldTypeName = \ t i k n -> if n > 0 then TypeName i k 0 else t }

-- | analyse variable declaration

anaVarDecl :: VarDecl -> State Env (Maybe VarDecl)

anaVarDecl(VarDecl v oldT sk ps) =

do mt <- anaStarType oldT

return $ case mt of

Nothing -> Nothing

Just t -> Just $ VarDecl v t sk ps