DataAna.hs revision 33a5d53a412ba0a4e5847f7538d6da2e22bd116c
facf4a8d7b59fde89a8662b4f4c73a758e6c402cllaiModule : $Header$
facf4a8d7b59fde89a8662b4f4c73a758e6c402cllaiCopyright : (c) Christian Maeder and Uni Bremen 2002-2003
facf4a8d7b59fde89a8662b4f4c73a758e6c402cllaiLicence : similar to LGPL, see HetCATS/LICENCE.txt or LIZENZ.txt
facf4a8d7b59fde89a8662b4f4c73a758e6c402cllaiMaintainer : hets@tzi.de
facf4a8d7b59fde89a8662b4f4c73a758e6c402cllaiStability : provisional
facf4a8d7b59fde89a8662b4f4c73a758e6c402cllaiPortability : non-portable (MonadState)
facf4a8d7b59fde89a8662b4f4c73a758e6c402cllaianalyse alternatives of data types
facf4a8d7b59fde89a8662b4f4c73a758e6c402cllaianaAlts :: [(Id, Type)] -> Type -> [Alternative] -> State Env [AltDefn]
facf4a8d7b59fde89a8662b4f4c73a758e6c402cllaianaAlts tys dt alts =
facf4a8d7b59fde89a8662b4f4c73a758e6c402cllai do ll <- mapM (anaAlt tys dt) alts
facf4a8d7b59fde89a8662b4f4c73a758e6c402cllai let l = concat ll
facf4a8d7b59fde89a8662b4f4c73a758e6c402cllai addDiags (checkUniqueness $ map ( \ (Construct i _ _ _) -> i) l)
facf4a8d7b59fde89a8662b4f4c73a758e6c402cllaianaAlt :: [(Id, Type)] -> Type -> Alternative -> State Env [AltDefn]
facf4a8d7b59fde89a8662b4f4c73a758e6c402cllaianaAlt _ _ (Subtype ts ps) =
facf4a8d7b59fde89a8662b4f4c73a758e6c402cllai do mapM_ anaStarType ts
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi addDiags [Diag Warning "data subtype ignored" $ firstPos ts ps]
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert MustacchianaAlt tys dt (Constructor i cs p _) =
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi do newCs <- mapM (anaComp i tys dt) $ zip cs $ map (:[]) [1..]
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi let mts = map fst newCs
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi if all isJust mts then
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi do let sels = concatMap snd newCs
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi con = Construct i (catMaybes mts) p sels
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi -- check for disjoint selectors
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi addDiags (checkUniqueness $ map ( \ (Select s _ _) -> s ) sels)
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi else return []
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert MustacchigetConstrType :: Type -> Partiality -> [Type] -> Type
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert MustacchigetConstrType dt p = addPartiality p .
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi foldr ( \ c r -> FunType c FunArr r [] ) dt
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert MustacchiaddPartiality :: Partiality -> Type -> Type
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert MustacchiaddPartiality Total t = t
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert MustacchiaddPartiality Partial t = makePartial t
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert MustacchimakePartial :: Type -> Type
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert MustacchimakePartial t =
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi FunType t1 a t2 ps ->
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi FunType _ _ _ _ -> FunType t1 a (makePartial t2) ps
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi _ -> FunType t1 PFunArr t2 ps
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi _ -> LazyType t []
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert MustacchianaComp :: Id -> [(Id, Type)] -> Type -> (Components, [Int])
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi -> State Env (Maybe Type, [Selector])
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert MustacchianaComp _ tys rt (Selector s p t _ _, _) =
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi do mt <- anaCompType tys rt t
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi Just ct -> return (mt, [Select s ct p])
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi _ -> return (Nothing, [])
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert MustacchianaComp con tys rt (NoSelector t, i) =
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi do mt <- anaCompType tys rt t
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi Just ct -> return (mt, [Select (simpleIdToId $ mkSimpleId
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi ("%(" ++ showPretty rt "." ++
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi showId con ".sel_" ++ show i ++ ")%"))
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi _ -> return (Nothing, [])
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert MustacchianaComp con tys rt (NestedComponents cs ps, i) =
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi do newCs <- mapM (anaComp con tys rt) $ zip cs $ map (:i) [1..]
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi let mts = map fst newCs
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi if all isJust mts then
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi return (Just $ ProductType (catMaybes mts) ps,
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi concatMap snd newCs)
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi else return (Nothing, [])
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert MustacchigetSelType :: Type -> Partiality -> Type -> Type
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert MustacchigetSelType dt p rt = addPartiality p $ FunType dt FunArr rt []
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert MustacchianaCompType :: [(Id, Type)] -> Type -> Type -> State Env (Maybe Type)
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert MustacchianaCompType tys dt t = do
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi mt <- anaStarType t
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi Nothing -> return Nothing
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi Just ct -> do mt2 <- unboundTypevars (varsOf dt) ct
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi Nothing -> return Nothing
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi Just ct2 -> do
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi (checkMonomorphRecursion ct2) tys
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi return $ if and ms then Just ct2
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert MustacchicheckMonomorphRecursion :: Type -> (Id, Type) -> State Env Bool
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert MustacchicheckMonomorphRecursion t (i, rt) =
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi if i `occursIn` t then
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi if t == rt then return True
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi else do addDiags [Diag Error ("illegal polymorphic recursion"
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi ++ expected rt t) $ getMyPos t]
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi else return True
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert MustacchiunboundTypevars :: [TypeArg] -> Type -> State Env (Maybe Type)
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert MustacchiunboundTypevars args ct = do
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi let restVars = varsOf ct \\ args
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi if null restVars then do return $ Just ct
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi else do addDiags [Diag Error ("unbound type variable(s)\n\t"
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi ++ showSepList ("," ++) showPretty
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi restVars "") $ posOf restVars]
9e5aa9d8a21f8efa8ba9c9e4a0aa6edc66d07eb2Robert Mustacchi return Nothing