b062631d2f72f0b2b2b6140bc5b0fccb66d1802bChristian Maeder{- |

e9458b1a7a19a63aa4c179f9ab20f4d50681c168Jens ElknerModule : $Header$

d53747c386354ff7db8629dfdf20f44a7c4d715dEugen KuksaCopyright : (c) Christian Maeder and Uni Bremen 2002-2003

cacbb5e3100fb85d23d1614cace3a8662801f2e6Eugen KuksaLicence : similar to LGPL, see HetCATS/LICENCE.txt or LIZENZ.txt

98890889ffb2e8f6f722b00e265a211f13b5a861Corneliu-Claudiu Prodescu

b062631d2f72f0b2b2b6140bc5b0fccb66d1802bChristian MaederMaintainer : hets@tzi.de

cacbb5e3100fb85d23d1614cace3a8662801f2e6Eugen KuksaStability : provisional

b062631d2f72f0b2b2b6140bc5b0fccb66d1802bChristian MaederPortability : non-portable (MonadState)

6d81916b9004f8d9b6032113c5987ab07da47015Karl Luc

b062631d2f72f0b2b2b6140bc5b0fccb66d1802bChristian Maederanalyse alternatives of data types

d53747c386354ff7db8629dfdf20f44a7c4d715dEugen Kuksa

b062631d2f72f0b2b2b6140bc5b0fccb66d1802bChristian Maeder-}

b062631d2f72f0b2b2b6140bc5b0fccb66d1802bChristian Maeder

6498fe9ab2cd00e3b52109c76faa2fac1849ddaaChristian Maedermodule HasCASL.DataAna where

b062631d2f72f0b2b2b6140bc5b0fccb66d1802bChristian Maeder

823ce7a568b0f653ebe83af7ab6ac9ec70f2cf8eKarl Lucimport HasCASL.As

b062631d2f72f0b2b2b6140bc5b0fccb66d1802bChristian Maederimport Common.Id

c51d1f5ff88cce030fe543e271ca6b85625b70d8Karl Lucimport Common.Lib.State

c51d1f5ff88cce030fe543e271ca6b85625b70d8Karl Lucimport Common.Result

1ea7fb6b0f66210bc0d3cb995f1b655277b33884Eugen Kuksaimport HasCASL.Le

b062631d2f72f0b2b2b6140bc5b0fccb66d1802bChristian Maederimport HasCASL.TypeAna

123c74ceb5c4d3f364323a015ecef3eaf0ab67d5Eugen Kuksaimport HasCASL.Unify

a18c1e9cec48e0a33df38b9bf6f5421af684f054Eugen Kuksaimport Data.Maybe

0fe5514fdf12b7559c1a470cf22d89737d55b0a0Eugen Kuksaimport Data.List

feeab95fdf7ec92bcce607c104d9dc98e0e6ea90Soeren D. Schulze

ba7f2ee11dafeea528830f6a5f9c98eac1f7eca5cmaeder

ba7f2ee11dafeea528830f6a5f9c98eac1f7eca5cmaederanaAlts :: [Type] -> Type -> [Alternative] -> State Env [AltDefn]

07f731e693fe433a238b5cc0aab6c5c99c1da798Karl LucanaAlts tys dt alts =

ff41d94839a36ce86291af5d83abe2bd39cce1d0Eugen Kuksa do ll <- mapM (anaAlt tys dt) alts

b3138d7e20d2d6dd26a325b844a8b21b0ecbb602Eugen Kuksa let l = concat ll

feeab95fdf7ec92bcce607c104d9dc98e0e6ea90Soeren D. Schulze addDiags (checkUniqueness $ map ( \ (Construct i _ _ _) -> i) l)

d5c6ddb570942f686319dcaf6c4b513a033e00ceEugen Kuksa return l

d5c6ddb570942f686319dcaf6c4b513a033e00ceEugen Kuksa

07f731e693fe433a238b5cc0aab6c5c99c1da798Karl LucanaAlt :: [Type] -> Type -> Alternative -> State Env [AltDefn]

1ea7fb6b0f66210bc0d3cb995f1b655277b33884Eugen KuksaanaAlt _ _ (Subtype ts ps) =

b062631d2f72f0b2b2b6140bc5b0fccb66d1802bChristian Maeder do mapM_ anaStarType ts

f03aa0b723e5545fddf7019e287368b9e208ca69Soeren D. Schulze addDiags [Diag Warning "data subtype ignored" $ firstPos ts ps]

b062631d2f72f0b2b2b6140bc5b0fccb66d1802bChristian Maeder return []

1ea7fb6b0f66210bc0d3cb995f1b655277b33884Eugen Kuksa

feeab95fdf7ec92bcce607c104d9dc98e0e6ea90Soeren D. SchulzeanaAlt tys dt (Constructor i cs p _) =

feeab95fdf7ec92bcce607c104d9dc98e0e6ea90Soeren D. Schulze do newCs <- mapM (anaComp i tys dt) $ zip cs $ map (:[]) [1..]

befbd45c1a4c171f2194b59016590b02bf4df750Eugen Kuksa let mts = map fst newCs

123c74ceb5c4d3f364323a015ecef3eaf0ab67d5Eugen Kuksa if all isJust mts then

befbd45c1a4c171f2194b59016590b02bf4df750Eugen Kuksa do let sels = concatMap snd newCs

123c74ceb5c4d3f364323a015ecef3eaf0ab67d5Eugen Kuksa con = Construct i (catMaybes mts) p sels

07f731e693fe433a238b5cc0aab6c5c99c1da798Karl Luc -- check for disjoint selectors

123c74ceb5c4d3f364323a015ecef3eaf0ab67d5Eugen Kuksa addDiags (checkUniqueness $ map ( \ (Select s _ _) -> s ) sels)

123c74ceb5c4d3f364323a015ecef3eaf0ab67d5Eugen Kuksa return [con]

befbd45c1a4c171f2194b59016590b02bf4df750Eugen Kuksa else return []

123c74ceb5c4d3f364323a015ecef3eaf0ab67d5Eugen Kuksa

eea1dfbc731d45f624bc3c14bada0617ebaa6eaaEugen KuksagetConstrType :: Type -> Partiality -> [Type] -> Type

c3cfa8f613684439642d59fd89c6bae83cdbf6f0Soeren D. SchulzegetConstrType dt p = addPartiality p .

eea1dfbc731d45f624bc3c14bada0617ebaa6eaaEugen Kuksa foldr ( \ c r -> FunType c FunArr r [] ) dt

07f731e693fe433a238b5cc0aab6c5c99c1da798Karl Luc

123c74ceb5c4d3f364323a015ecef3eaf0ab67d5Eugen Kuksa

befbd45c1a4c171f2194b59016590b02bf4df750Eugen KuksaaddPartiality :: Partiality -> Type -> Type

8b7e9bd07700b2fef4312835be342250347ad849Eugen KuksaaddPartiality Total t = t

6498fe9ab2cd00e3b52109c76faa2fac1849ddaaChristian MaederaddPartiality Partial t = makePartial t

0c4da1aef47757166486f7aa0b037ffa30b840cdEugen Kuksa

07f731e693fe433a238b5cc0aab6c5c99c1da798Karl LucmakePartial :: Type -> Type

123c74ceb5c4d3f364323a015ecef3eaf0ab67d5Eugen KuksamakePartial t =

d1e1be2881bf54b507313a6a2b4a254090cd92b7Eugen Kuksa case t of

123c74ceb5c4d3f364323a015ecef3eaf0ab67d5Eugen Kuksa FunType t1 a t2 ps ->

123c74ceb5c4d3f364323a015ecef3eaf0ab67d5Eugen Kuksa case t2 of

0c4da1aef47757166486f7aa0b037ffa30b840cdEugen Kuksa FunType _ _ _ _ -> FunType t1 a (makePartial t2) ps

07f731e693fe433a238b5cc0aab6c5c99c1da798Karl Luc _ -> FunType t1 PFunArr t2 ps

3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder _ -> LazyType t []

3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder

3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederanaComp :: Id -> [Type] -> Type -> (Components, [Int])

123c74ceb5c4d3f364323a015ecef3eaf0ab67d5Eugen Kuksa -> State Env (Maybe Type, [Selector])

64401a16f05d2b42fa52301ec3ce01569e2a8e19Eugen KuksaanaComp _ tys rt (Selector s p t _ _, _) =

d1e1be2881bf54b507313a6a2b4a254090cd92b7Eugen Kuksa do mt <- anaCompType tys rt t

123c74ceb5c4d3f364323a015ecef3eaf0ab67d5Eugen Kuksa case mt of

07f731e693fe433a238b5cc0aab6c5c99c1da798Karl Luc Just ct -> return (mt, [Select s ct p])

123c74ceb5c4d3f364323a015ecef3eaf0ab67d5Eugen Kuksa _ -> return (Nothing, [])

ead7fb0fe5492f65c8e47eaa9d5105bffde163f2Eugen KuksaanaComp con tys rt (NoSelector t, i) =

d1e1be2881bf54b507313a6a2b4a254090cd92b7Eugen Kuksa do mt <- anaCompType tys rt t

07f731e693fe433a238b5cc0aab6c5c99c1da798Karl Luc case mt of

07f731e693fe433a238b5cc0aab6c5c99c1da798Karl Luc Just ct -> return (mt, [Select (simpleIdToId $ mkSimpleId

123c74ceb5c4d3f364323a015ecef3eaf0ab67d5Eugen Kuksa ("%(" ++ showPretty rt "." ++

ead7fb0fe5492f65c8e47eaa9d5105bffde163f2Eugen Kuksa showId con ".sel_" ++ show i ++ ")%"))

d1e1be2881bf54b507313a6a2b4a254090cd92b7Eugen Kuksa ct Partial])

ae371d21b7a25f2ad233db70049f0b6f2edcf411Soeren D. Schulze _ -> return (Nothing, [])

123c74ceb5c4d3f364323a015ecef3eaf0ab67d5Eugen Kuksa

123c74ceb5c4d3f364323a015ecef3eaf0ab67d5Eugen KuksaanaComp con tys rt (NestedComponents cs ps, i) =

123c74ceb5c4d3f364323a015ecef3eaf0ab67d5Eugen Kuksa do newCs <- mapM (anaComp con tys rt) $ zip cs $ map (:i) [1..]

123c74ceb5c4d3f364323a015ecef3eaf0ab67d5Eugen Kuksa let mts = map fst newCs

123c74ceb5c4d3f364323a015ecef3eaf0ab67d5Eugen Kuksa if all isJust mts then

fe656923fef897857a32d6de89a3196571ca2427Eugen Kuksa return (Just $ ProductType (catMaybes mts) ps,

07f731e693fe433a238b5cc0aab6c5c99c1da798Karl Luc concatMap snd newCs)

fe656923fef897857a32d6de89a3196571ca2427Eugen Kuksa else return (Nothing, [])

ead7fb0fe5492f65c8e47eaa9d5105bffde163f2Eugen Kuksa

befbd45c1a4c171f2194b59016590b02bf4df750Eugen KuksagetSelType :: Type -> Partiality -> Type -> Type

123c74ceb5c4d3f364323a015ecef3eaf0ab67d5Eugen KuksagetSelType dt p rt = addPartiality p $ FunType dt FunArr rt []

64401a16f05d2b42fa52301ec3ce01569e2a8e19Eugen Kuksa

07f731e693fe433a238b5cc0aab6c5c99c1da798Karl LucanaCompType :: [Type] -> Type -> Type -> State Env (Maybe Type)

fe656923fef897857a32d6de89a3196571ca2427Eugen KuksaanaCompType tys dt t = do

fe656923fef897857a32d6de89a3196571ca2427Eugen Kuksa mt <- anaStarType t

7b2c06587c0e51d5f75e5fc856d164ee92f4ed78Eugen Kuksa case mt of

fe656923fef897857a32d6de89a3196571ca2427Eugen Kuksa Nothing -> return Nothing

fe656923fef897857a32d6de89a3196571ca2427Eugen Kuksa Just ct -> unboundTypevars (varsOf dt) ct

fe656923fef897857a32d6de89a3196571ca2427Eugen Kuksa

fe656923fef897857a32d6de89a3196571ca2427Eugen KuksaunboundTypevars :: [TypeArg] -> Type -> State Env (Maybe Type)

fe656923fef897857a32d6de89a3196571ca2427Eugen KuksaunboundTypevars args ct = do

fe656923fef897857a32d6de89a3196571ca2427Eugen Kuksa let restVars = varsOf ct \\ args

fe656923fef897857a32d6de89a3196571ca2427Eugen Kuksa if null restVars then do return $ Just ct

fe656923fef897857a32d6de89a3196571ca2427Eugen Kuksa else do addDiags [Diag Error ("unbound type variable(s)\n\t"

dc62afbf79603699b39b2387f48298634f642e67cmaeder ++ showSepList ("," ++) showPretty

fe656923fef897857a32d6de89a3196571ca2427Eugen Kuksa restVars "") $ posOf restVars]

fe656923fef897857a32d6de89a3196571ca2427Eugen Kuksa return Nothing

123c74ceb5c4d3f364323a015ecef3eaf0ab67d5Eugen Kuksa