DataAna.hs revision d0e5c119290395a9db5a2a22673e5b7a7f0d0573
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannModule : $Header$
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannCopyright : (c) Christian Maeder and Uni Bremen 2002-2003
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannLicence : similar to LGPL, see HetCATS/LICENCE.txt or LIZENZ.txt
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannMaintainer : hets@tzi.de
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannStability : provisional
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannPortability : non-portable (MonadState)
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmannanalyse alternatives of data types
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmannimport qualified Common.Lib.Set as Set
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannanaAlts :: [(Id, Type)] -> Type -> [Alternative] -> State Env [AltDefn]
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannanaAlts tys dt alts =
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann do ll <- mapM (anaAlt tys dt) alts
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann let l = concat ll
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann addDiags (checkUniqueness $ map ( \ (Construct i _ _ _) -> i) l)
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannanaAlt :: [(Id, Type)] -> Type -> Alternative -> State Env [AltDefn]
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannanaAlt _ _ (Subtype _ _) = return []
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannanaAlt tys dt (Constructor i cs p _) =
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann do newCs <- mapM (anaComps tys dt) cs
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann let mts = map fst newCs
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann if all isJust mts then
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann do let sels = concatMap snd newCs
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann con = Construct i (catMaybes mts) p sels
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann -- check for disjoint selectors
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann addDiags (checkUniqueness $ map ( \ (Select s _ _) -> s ) sels)
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann else return []
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmanngetConstrType :: Type -> Partiality -> [Type] -> Type
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmanngetConstrType dt p = addPartiality p .
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann foldr ( \ c r -> FunType c FunArr r [] ) dt
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannaddPartiality :: Partiality -> Type -> Type
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannaddPartiality Total t = t
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannaddPartiality Partial t = makePartial t
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannmakePartial :: Type -> Type
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannmakePartial t =
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann FunType t1 a t2 ps ->
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann FunType _ _ _ _ -> FunType t1 a (makePartial t2) ps
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann _ -> FunType t1 PFunArr t2 ps
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann _ -> LazyType t []
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannanaComps :: [(Id, Type)] -> Type -> [Component]
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann -> State Env (Maybe Type, [Selector])
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannanaComps tys rt cs =
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann do newCs <- mapM (anaComp tys rt) cs
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann let mts = map fst newCs
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann if all isJust mts then return (Just $ mkProductType (catMaybes mts) [],
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann concatMap snd newCs)
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann else return (Nothing, [])
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannanaComp :: [(Id, Type)] -> Type -> Component
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann -> State Env (Maybe Type, [Selector])
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannanaComp tys rt (Selector s p t _ _) =
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann do mt <- anaCompType tys rt t
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann Just ct -> return (mt, [Select s ct p])
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann _ -> return (Nothing, [])
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannanaComp tys rt (NoSelector t) =
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann do mt <- anaCompType tys rt t
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann return (mt, [])
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmanngetSelType :: Type -> Partiality -> Type -> Type
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmanngetSelType dt p rt = addPartiality p $ FunType dt FunArr rt []
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannanaCompType :: [(Id, Type)] -> Type -> Type -> State Env (Maybe Type)
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannanaCompType tys dt t = do
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann mt <- anaStarType t
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann Nothing -> return Nothing
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann Just ct -> do mt2 <- unboundTypevars (varsOf dt) ct
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann Nothing -> return Nothing
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann Just ct2 -> do
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann (checkMonomorphRecursion ct2) tys
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann return $ if and ms then Just ct2
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmanncheckMonomorphRecursion :: Type -> (Id, Type) -> State Env Bool
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmanncheckMonomorphRecursion t (i, rt) = do
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann tm <- gets typeMap
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann if occursIn tm i $ unalias tm t then
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann if equalSubs tm t rt
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann then return True
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann else do addDiags [Diag Error ("illegal polymorphic recursion"
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann ++ expected rt t) $ getMyPos t]
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann else return True
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannunboundTypevars :: Set.Set TypeArg -> Type -> State Env (Maybe Type)
2450a4210dee64b064499a3a1154129bdfc74981Daniel HausmannunboundTypevars args ct = do
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann let restVars = varsOf ct Set.\\ args
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann if Set.isEmpty restVars then do return $ Just ct
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann else do addDiags [mkDiag Error ("unbound type variable(s)\n\t"
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann ++ showSepList ("," ++) showPretty
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann (Set.toList restVars) " in") ct]
2450a4210dee64b064499a3a1154129bdfc74981Daniel Hausmann return Nothing