640b2adac05bb7f5e9fba064434c91852c3a72e6nd{- |

8e34905974b7a442a55adac3b3fdb196c389e807takashiModule : $Header$

640b2adac05bb7f5e9fba064434c91852c3a72e6ndCopyright : (c) Christian Maeder and Uni Bremen 2002-2003

640b2adac05bb7f5e9fba064434c91852c3a72e6ndLicence : All rights reserved.

8e34905974b7a442a55adac3b3fdb196c389e807takashi

640b2adac05bb7f5e9fba064434c91852c3a72e6ndMaintainer : hets@tzi.de

640b2adac05bb7f5e9fba064434c91852c3a72e6ndStability : provisional

8e34905974b7a442a55adac3b3fdb196c389e807takashiPortability : non-portable (MonadState)

8e34905974b7a442a55adac3b3fdb196c389e807takashi

640b2adac05bb7f5e9fba064434c91852c3a72e6ndanalyse alternatives of data types

640b2adac05bb7f5e9fba064434c91852c3a72e6nd

640b2adac05bb7f5e9fba064434c91852c3a72e6nd-}

640b2adac05bb7f5e9fba064434c91852c3a72e6nd

a27e9e05958bc51ea09edb8d8d862fe8b125313bslivemodule HasCASL.DataAna where

8e34905974b7a442a55adac3b3fdb196c389e807takashi

a27e9e05958bc51ea09edb8d8d862fe8b125313bsliveimport HasCASL.As

ef685e00a47967e27d89709461728a229d762172ndimport HasCASL.AsUtils

ef685e00a47967e27d89709461728a229d762172ndimport Common.Id

ef685e00a47967e27d89709461728a229d762172ndimport Common.Result

a27e9e05958bc51ea09edb8d8d862fe8b125313bsliveimport HasCASL.Le

51853aa2ebfdf9903a094467e1d02099f143639daaronimport Data.Maybe

51853aa2ebfdf9903a094467e1d02099f143639daaronimport HasCASL.TypeAna

a27e9e05958bc51ea09edb8d8d862fe8b125313bsliveimport HasCASL.Reader

51853aa2ebfdf9903a094467e1d02099f143639daaron

a27e9e05958bc51ea09edb8d8d862fe8b125313bsliveanaAlts :: Type -> [Alternative] -> ReadR (ClassMap, TypeMap) [AltDefn]

a27e9e05958bc51ea09edb8d8d862fe8b125313bsliveanaAlts dt alts = do l <- foldReadR (anaAlt dt) alts

a27e9e05958bc51ea09edb8d8d862fe8b125313bslive lift $ Result (checkUniqueness $ map

a27e9e05958bc51ea09edb8d8d862fe8b125313bslive ( \ (Construct i _ _) -> i) l)

8e34905974b7a442a55adac3b3fdb196c389e807takashi $ Just l

a27e9e05958bc51ea09edb8d8d862fe8b125313bslive

ef685e00a47967e27d89709461728a229d762172ndanaAlt :: Type -> Alternative -> ReadR (ClassMap, TypeMap) AltDefn

ef685e00a47967e27d89709461728a229d762172ndanaAlt _ (Subtype ts ps) =

a27e9e05958bc51ea09edb8d8d862fe8b125313bslive do kts <- mapM anaType $ map ( \ t -> (star, t)) ts

222f0f03c2f9ee6343c18f80f0cb6e9aad21bc58slive mapM ( \ (ki, ti) -> checkKindsR ti star ki) kts

222f0f03c2f9ee6343c18f80f0cb6e9aad21bc58slive lift $ Result [Diag Warning "data subtype ignored" $ firstPos ts ps]

a27e9e05958bc51ea09edb8d8d862fe8b125313bslive $ Nothing

a27e9e05958bc51ea09edb8d8d862fe8b125313bsliveanaAlt dt (Constructor i cs p _) =

a27e9e05958bc51ea09edb8d8d862fe8b125313bslive do newCs <- mapM (anaComp i dt) $ zip cs $ map (:[]) [1..]

a27e9e05958bc51ea09edb8d8d862fe8b125313bslive let rt = foldr ( \ c r -> FunType (fst c) FunArr r [] ) dt newCs

a27e9e05958bc51ea09edb8d8d862fe8b125313bslive prt = addPartiality p rt

7e16a5919a6edfb40acc1e8a46375702661cb4c0rbowen sels = concatMap snd newCs

a27e9e05958bc51ea09edb8d8d862fe8b125313bslive con = Construct i (simpleTypeScheme prt) sels

17ca00f92106c825382359ebf0a754f8df21e316rbowen -- check for disjoint selectors

7e16a5919a6edfb40acc1e8a46375702661cb4c0rbowen lift $ Result (checkUniqueness $ map ( \ (Select s _) -> s ) sels)

7e16a5919a6edfb40acc1e8a46375702661cb4c0rbowen $ Just con

17ca00f92106c825382359ebf0a754f8df21e316rbowen

17ca00f92106c825382359ebf0a754f8df21e316rbowenaddPartiality :: Partiality -> Type -> Type

7e16a5919a6edfb40acc1e8a46375702661cb4c0rbowenaddPartiality Total t = t

a27e9e05958bc51ea09edb8d8d862fe8b125313bsliveaddPartiality Partial t = makePartial t

a27e9e05958bc51ea09edb8d8d862fe8b125313bslive

a27e9e05958bc51ea09edb8d8d862fe8b125313bslivemakePartial :: Type -> Type

a27e9e05958bc51ea09edb8d8d862fe8b125313bslivemakePartial t =

a27e9e05958bc51ea09edb8d8d862fe8b125313bslive case t of

8e34905974b7a442a55adac3b3fdb196c389e807takashi FunType t1 a t2 ps ->

a27e9e05958bc51ea09edb8d8d862fe8b125313bslive case t2 of

ef685e00a47967e27d89709461728a229d762172nd FunType _ _ _ _ -> FunType t1 a (makePartial t2) ps

ef685e00a47967e27d89709461728a229d762172nd _ -> FunType t1 PFunArr t2 ps

ef685e00a47967e27d89709461728a229d762172nd _ -> LazyType t []

a27e9e05958bc51ea09edb8d8d862fe8b125313bslive

761f3734f9e5a8761b9bef4f553bf11751f9a922sliveanaComp :: Id -> Type -> (Components, [Int])

761f3734f9e5a8761b9bef4f553bf11751f9a922slive -> ReadR (ClassMap, TypeMap) (Type, [Selector])

a27e9e05958bc51ea09edb8d8d862fe8b125313bsliveanaComp _ rt (Selector s p t _ _, _) =

a27e9e05958bc51ea09edb8d8d862fe8b125313bslive do (k, ct) <- anaType (star, t)

a27e9e05958bc51ea09edb8d8d862fe8b125313bslive checkKindsR t star k

222f0f03c2f9ee6343c18f80f0cb6e9aad21bc58slive return (ct, [Select s $ simpleTypeScheme

95e8cab14596a61826fa52477dcaebc07bfbad00colm $ addPartiality p $ FunType rt FunArr ct []])

8e34905974b7a442a55adac3b3fdb196c389e807takashianaComp con rt (NoSelector t, i) =

95e8cab14596a61826fa52477dcaebc07bfbad00colm do (k, ct) <- anaType (star, t)

95e8cab14596a61826fa52477dcaebc07bfbad00colm checkKindsR t star k

95e8cab14596a61826fa52477dcaebc07bfbad00colm return (ct, [Select (simpleIdToId $ mkSimpleId

95e8cab14596a61826fa52477dcaebc07bfbad00colm ("%(" ++ showPretty rt "." ++

95e8cab14596a61826fa52477dcaebc07bfbad00colm showId con ".sel_" ++ show i ++ ")%"))

95e8cab14596a61826fa52477dcaebc07bfbad00colm $ simpleTypeScheme $ FunType rt PFunArr ct []])

95e8cab14596a61826fa52477dcaebc07bfbad00colm

95e8cab14596a61826fa52477dcaebc07bfbad00colmanaComp con rt (NestedComponents cs ps, i) =

95e8cab14596a61826fa52477dcaebc07bfbad00colm do newCs <- mapM (anaComp con rt) $ zip cs $ map (:i) [1..]

95e8cab14596a61826fa52477dcaebc07bfbad00colm return (ProductType (map fst newCs) ps,

95e8cab14596a61826fa52477dcaebc07bfbad00colm concatMap snd newCs)

17efa6b5344b7574597eec03f02ef28103e19265nd