DataAna.hs revision 0551888eaa2644528f6d483c2822de3f3c858723
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederModule : $Header$
bb83db66bd9b3b4ce67be66419daf29886175276Andy GimblettCopyright : (c) Christian Maeder and Uni Bremen 2002-2003
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederLicence : similar to LGPL, see HetCATS/LICENCE.txt or LIZENZ.txt
98890889ffb2e8f6f722b00e265a211f13b5a861Corneliu-Claudiu ProdescuMaintainer : hets@tzi.de
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus RoggenbachStability : provisional
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederPortability : non-portable (MonadState)
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbachanalyse alternatives of data types
1538a6e8d77301d6de757616ffc69ee61f1482e4Andy GimblettanaAlts :: [(Id, Type)] -> Type -> [Alternative] -> State Env [AltDefn]
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus RoggenbachanaAlts tys dt alts =
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbach do ll <- mapM (anaAlt tys dt) alts
70a691ea12f53381209a3709cdd325df5fc0a0c8Christian Maeder let l = concat ll
a79fe3aad8743ea57e473ea5f66a723244cb9c0eMarkus Roggenbach addDiags (checkUniqueness $ map ( \ (Construct i _ _ _) -> i) l)
0ea916d1e6aea10fd7b84f802fb5148a79d8c20aAndy GimblettanaAlt :: [(Id, Type)] -> Type -> Alternative -> State Env [AltDefn]
04ceed96d1528b939f2e592d0656290d81d1c045Andy GimblettanaAlt _ _ (Subtype ts ps) =
d9e78002fb0bf01a9b72d3d3415fdf9790bdfee8Andy Gimblett do mapM_ anaStarType ts
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly addDiags [Diag Warning "data subtype ignored" $ firstPos ts ps]
3b48e17c1da54ee669e70b626d9fbc32ce495b2cChristian MaederanaAlt tys dt (Constructor i cs p _) =
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly do newCs <- mapM (anaComps i tys dt) $ zip cs $ map (:[]) [1..]
9aeda2b3ae8ce0b018955521e4ca835a8ba8a27bLiam O'Reilly let mts = map fst newCs
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder if all isJust mts then
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder do let sels = concatMap snd newCs
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder con = Construct i (catMaybes mts) p sels
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder -- check for disjoint selectors
c4b2418421546a337f83332fe0db04742dcd735dAndy Gimblett addDiags (checkUniqueness $ map ( \ (Select s _ _) -> s ) sels)
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian Maeder else return []
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaedergetConstrType :: Type -> Partiality -> [Type] -> Type
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaedergetConstrType dt p = addPartiality p .
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder foldr ( \ c r -> FunType c FunArr r [] ) dt
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaederaddPartiality :: Partiality -> Type -> Type
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian MaederaddPartiality Total t = t
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian MaederaddPartiality Partial t = makePartial t
a78bb62cd6f0beb2dab862db865357fc9d3c25feChristian MaedermakePartial :: Type -> Type
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian MaedermakePartial t =
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian Maeder FunType t1 a t2 ps ->
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian Maeder FunType _ _ _ _ -> FunType t1 a (makePartial t2) ps
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian Maeder _ -> FunType t1 PFunArr t2 ps
bcd914850de931848b86d7728192a149f9c0108bChristian Maeder _ -> LazyType t []
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian MaederanaComps :: Id -> [(Id, Type)] -> Type -> ([Component], [Int])
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian Maeder -> State Env (Maybe Type, [Selector])
bcd914850de931848b86d7728192a149f9c0108bChristian MaederanaComps con tys rt (cs, i) =
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder do newCs <- mapM (anaComp con tys rt) $ zip cs $ map (:i) [1..]
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder let mts = map fst newCs
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder if all isJust mts then return (Just $ mkProductType (catMaybes mts) [],
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian Maeder concatMap snd newCs)
8db2221917c1bc569614f3481bcdb3b988facaedChristian Maeder else return (Nothing, [])
12b2ae689353ecbaad720a9af9f9be01c1a3fe2dChristian MaederanaComp :: Id -> [(Id, Type)] -> Type -> (Component, [Int])
e771539425f4a0abef9f94cf4b63690f3603f682Andy Gimblett -> State Env (Maybe Type, [Selector])
bb83db66bd9b3b4ce67be66419daf29886175276Andy GimblettanaComp _ tys rt (Selector s p t _ _, _) =
d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett do mt <- anaCompType tys rt t
2f35e5f6757968746dbab385be21fcae52378a3fLiam O'Reilly Just ct -> return (mt, [Select s ct p])
fbc0c2baf563fe5b664f0152674a8d3acecca58cAndy Gimblett _ -> return (Nothing, [])
31f039ffdb33d78cb31d24b71d3155b11a323975Andy GimblettanaComp con tys rt (NoSelector t, i) =
e771539425f4a0abef9f94cf4b63690f3603f682Andy Gimblett do mt <- anaCompType tys rt t
d326dac41dadbe2b84bb7021cbfd91f4dd4a19bcAndy Gimblett Just ct -> return (mt, [Select (simpleIdToId $ mkSimpleId
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder ("%(" ++ showPretty rt "." ++
f4a5178450076ee54f3a9adb4f91e241aea3ba75Christian Maeder showId con ".sel_" ++ show i ++ ")%"))
90047eafd2de482c67bcd13103c6064e9b0cb254Andy Gimblett _ -> return (Nothing, [])
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaedergetSelType :: Type -> Partiality -> Type -> Type
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaedergetSelType dt p rt = addPartiality p $ FunType dt FunArr rt []
d297a45fc73aa6c4a1f9d073c3170611415f324bAndy GimblettanaCompType :: [(Id, Type)] -> Type -> Type -> State Env (Maybe Type)
4314e26a12954cb1c9be4dea10aa8103edac5bbbChristian MaederanaCompType tys dt t = do
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder mt <- anaStarType t
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder Nothing -> return Nothing
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder Just ct -> do mt2 <- unboundTypevars (varsOf dt) ct
2a5b885d9350ec6dd8bc4992ee91d2f68aa592f4Christian Maeder Nothing -> return Nothing
842ae753ab848a8508c4832ab64296b929167a97Christian Maeder Just ct2 -> do
d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett (checkMonomorphRecursion ct2) tys
bb83db66bd9b3b4ce67be66419daf29886175276Andy Gimblett return $ if and ms then Just ct2
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian MaedercheckMonomorphRecursion :: Type -> (Id, Type) -> State Env Bool
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian MaedercheckMonomorphRecursion t (i, rt) =
dfc58f5ec6492d1a9b9babd9cdcdbb15baa6e657Christian Maeder if i `occursIn` t then
dfc58f5ec6492d1a9b9babd9cdcdbb15baa6e657Christian Maeder if t == rt then return True
05cc55892e6c93bdd7b9c3f100ab1bb65fe6a21eLiam O'Reilly else do addDiags [Diag Error ("illegal polymorphic recursion"
05cc55892e6c93bdd7b9c3f100ab1bb65fe6a21eLiam O'Reilly ++ expected rt t) $ getMyPos t]
05cc55892e6c93bdd7b9c3f100ab1bb65fe6a21eLiam O'Reilly else return True
05cc55892e6c93bdd7b9c3f100ab1bb65fe6a21eLiam O'ReillyunboundTypevars :: [TypeArg] -> Type -> State Env (Maybe Type)
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian MaederunboundTypevars args ct = do
7f24d24e63854a9a2539c2dac55198f746ad57dbChristian Maeder let restVars = varsOf ct \\ args
ad872d5e07383c8fec42bddf02a13d1fbcac52b2Christian Maeder if null restVars then do return $ Just ct
d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett else do addDiags [Diag Error ("unbound type variable(s)\n\t"
bb83db66bd9b3b4ce67be66419daf29886175276Andy Gimblett ++ showSepList ("," ++) showPretty
d297a45fc73aa6c4a1f9d073c3170611415f324bAndy Gimblett restVars "") $ posOf restVars]
bb83db66bd9b3b4ce67be66419daf29886175276Andy Gimblett return Nothing