66267bcb678a9c341272c323b299337bcfdb7cc5Christian Maeder{- |

5c933f3c61d2cfa7e76e4eb610a4b0bac988be47Christian MaederModule : $Header$

66267bcb678a9c341272c323b299337bcfdb7cc5Christian MaederCopyright : (c) Christian Maeder and Uni Bremen 2002-2003

66267bcb678a9c341272c323b299337bcfdb7cc5Christian MaederLicence : similar to LGPL, see HetCATS/LICENCE.txt or LIZENZ.txt

e7ce154edb906685b3fa7f6c0a764e18a4658068Christian Maeder

66267bcb678a9c341272c323b299337bcfdb7cc5Christian MaederMaintainer : hets@tzi.de

ffd01020a4f35f434b912844ad6e0d6918fadffdChristian MaederStability : provisional

66267bcb678a9c341272c323b299337bcfdb7cc5Christian MaederPortability : non-portable (MonadState)

66267bcb678a9c341272c323b299337bcfdb7cc5Christian Maeder

fb69cd512eab767747f109e40322df7cae2f7bdfChristian Maederanalyse alternatives of data types

fb69cd512eab767747f109e40322df7cae2f7bdfChristian Maeder

e8ffec0fa3d3061061bdc16e44247b9cf96b050fChristian Maeder-}

fb69cd512eab767747f109e40322df7cae2f7bdfChristian Maeder

e8ffec0fa3d3061061bdc16e44247b9cf96b050fChristian Maedermodule HasCASL.DataAna where

e8ffec0fa3d3061061bdc16e44247b9cf96b050fChristian Maeder

e8ffec0fa3d3061061bdc16e44247b9cf96b050fChristian Maederimport HasCASL.As

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederimport Common.Id

05e2a3161e4589a717c6fe5c7306820273a473c5Christian Maederimport Common.Lib.State

05e2a3161e4589a717c6fe5c7306820273a473c5Christian Maederimport Common.Result

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederimport HasCASL.Le

5d7e4bf173534e7eb3fc84dce7bb0151079d3f8aChristian Maederimport HasCASL.TypeAna

ad270004874ce1d0697fb30d7309f180553bb315Christian Maederimport HasCASL.AsUtils

ad270004874ce1d0697fb30d7309f180553bb315Christian Maederimport HasCASL.Unify

e8ffec0fa3d3061061bdc16e44247b9cf96b050fChristian Maederimport Data.Maybe

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederimport Data.List

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederanaAlts :: [(Id, Type)] -> Type -> [Alternative] -> State Env [AltDefn]

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederanaAlts tys dt alts =

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder do ll <- mapM (anaAlt tys dt) alts

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder let l = concat ll

e7ce154edb906685b3fa7f6c0a764e18a4658068Christian Maeder addDiags (checkUniqueness $ map ( \ (Construct i _ _ _) -> i) l)

e7ce154edb906685b3fa7f6c0a764e18a4658068Christian Maeder return l

e7ce154edb906685b3fa7f6c0a764e18a4658068Christian Maeder

05e2a3161e4589a717c6fe5c7306820273a473c5Christian MaederanaAlt :: [(Id, Type)] -> Type -> Alternative -> State Env [AltDefn]

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederanaAlt _ _ (Subtype ts ps) =

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder do mapM_ anaStarType ts

024621f43239cfe9629e35d35a8669fad7acbba2Christian Maeder addDiags [Diag Warning "data subtype ignored" $ firstPos ts ps]

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder return []

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder

36c6cc568751e4235502cfee00ba7b597dae78dcChristian MaederanaAlt tys dt (Constructor i cs p _) =

36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder do newCs <- mapM (anaComps i tys dt) $ zip cs $ map (:[]) [1..]

27912d626bf179b82fcb337077e5cd9653bb71cfChristian Maeder let mts = map fst newCs

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder if all isJust mts then

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder do let sels = concatMap snd newCs

5c933f3c61d2cfa7e76e4eb610a4b0bac988be47Christian Maeder con = Construct i (catMaybes mts) p sels

5c933f3c61d2cfa7e76e4eb610a4b0bac988be47Christian Maeder -- check for disjoint selectors

5c933f3c61d2cfa7e76e4eb610a4b0bac988be47Christian Maeder addDiags (checkUniqueness $ map ( \ (Select s _ _) -> s ) sels)

8c81b727b788d90ff3b8cbda7b0900c9009243bbChristian Maeder return [con]

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder else return []

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaedergetConstrType :: Type -> Partiality -> [Type] -> Type

76647324ed70f33b95a881b536d883daccf9568dChristian MaedergetConstrType dt p = addPartiality p .

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder foldr ( \ c r -> FunType c FunArr r [] ) dt

07b1bf56f3a486f26d69514d05b73100abb25a0eChristian Maeder

05e2a3161e4589a717c6fe5c7306820273a473c5Christian Maeder

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederaddPartiality :: Partiality -> Type -> Type

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederaddPartiality Total t = t

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederaddPartiality Partial t = makePartial t

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaedermakePartial :: Type -> Type

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaedermakePartial t =

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder case t of

c438c79d00fc438f99627e612498744bdc0d0c89Christian Maeder FunType t1 a t2 ps ->

c438c79d00fc438f99627e612498744bdc0d0c89Christian Maeder case t2 of

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder FunType _ _ _ _ -> FunType t1 a (makePartial t2) ps

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder _ -> FunType t1 PFunArr t2 ps

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder _ -> LazyType t []

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederanaComps :: Id -> [(Id, Type)] -> Type -> ([Component], [Int])

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder -> State Env (Maybe Type, [Selector])

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederanaComps con tys rt (cs, i) =

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder do newCs <- mapM (anaComp con tys rt) $ zip cs $ map (:i) [1..]

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder let mts = map fst newCs

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder if all isJust mts then

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder return (Just $ ProductType (catMaybes mts) [],

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder concatMap snd newCs)

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder else return (Nothing, [])

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederanaComp :: Id -> [(Id, Type)] -> Type -> (Component, [Int])

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder -> State Env (Maybe Type, [Selector])

36c6cc568751e4235502cfee00ba7b597dae78dcChristian MaederanaComp _ tys rt (Selector s p t _ _, _) =

36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder do mt <- anaCompType tys rt t

36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder case mt of

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder Just ct -> return (mt, [Select s ct p])

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder _ -> return (Nothing, [])

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederanaComp con tys rt (NoSelector t, i) =

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder do mt <- anaCompType tys rt t

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder case mt of

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder Just ct -> return (mt, [Select (simpleIdToId $ mkSimpleId

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder ("%(" ++ showPretty rt "." ++

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder showId con ".sel_" ++ show i ++ ")%"))

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder ct Partial])

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder _ -> return (Nothing, [])

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaedergetSelType :: Type -> Partiality -> Type -> Type

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaedergetSelType dt p rt = addPartiality p $ FunType dt FunArr rt []

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder

5c933f3c61d2cfa7e76e4eb610a4b0bac988be47Christian MaederanaCompType :: [(Id, Type)] -> Type -> Type -> State Env (Maybe Type)

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederanaCompType tys dt t = do

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder mt <- anaStarType t

5c933f3c61d2cfa7e76e4eb610a4b0bac988be47Christian Maeder case mt of

5c933f3c61d2cfa7e76e4eb610a4b0bac988be47Christian Maeder Nothing -> return Nothing

c438c79d00fc438f99627e612498744bdc0d0c89Christian Maeder Just ct -> do mt2 <- unboundTypevars (varsOf dt) ct

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder case mt2 of

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder Nothing -> return Nothing

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder Just ct2 -> do

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder ms <- mapM

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder (checkMonomorphRecursion ct2) tys

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder return $ if and ms then Just ct2

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder else Nothing

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaedercheckMonomorphRecursion :: Type -> (Id, Type) -> State Env Bool

76647324ed70f33b95a881b536d883daccf9568dChristian MaedercheckMonomorphRecursion t (i, rt) =

76647324ed70f33b95a881b536d883daccf9568dChristian Maeder if i `occursIn` t then

8aea46773664711e0910accc5cf80ef9ee1bcfbfChristian Maeder if t == rt then return True

8aea46773664711e0910accc5cf80ef9ee1bcfbfChristian Maeder else do addDiags [Diag Error ("illegal polymorphic recursion"

8aea46773664711e0910accc5cf80ef9ee1bcfbfChristian Maeder ++ expected rt t) $ getMyPos t]

c438c79d00fc438f99627e612498744bdc0d0c89Christian Maeder return False

8aea46773664711e0910accc5cf80ef9ee1bcfbfChristian Maeder else return True

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder

8aea46773664711e0910accc5cf80ef9ee1bcfbfChristian MaederunboundTypevars :: [TypeArg] -> Type -> State Env (Maybe Type)

8aea46773664711e0910accc5cf80ef9ee1bcfbfChristian MaederunboundTypevars args ct = do

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder let restVars = varsOf ct \\ args

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder if null restVars then do return $ Just ct

8aea46773664711e0910accc5cf80ef9ee1bcfbfChristian Maeder else do addDiags [Diag Error ("unbound type variable(s)\n\t"

8aea46773664711e0910accc5cf80ef9ee1bcfbfChristian Maeder ++ showSepList ("," ++) showPretty

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder restVars "") $ posOf restVars]

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder return Nothing

5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder