DataAna.hs revision 0ea85310d2beb8aa03cac481ad2a6564e6b8ddbc
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
bbae6e6ca0de7f2ffbb44d2c8da179f2b717237fChristian MaederModule : $Header$
81d182b21020b815887e9057959228546cf61b6bChristian MaederDescription : analysis of data type declarations
62ecb1e7f8fd9573eea8369657de12c7bf9f4f25Christian MaederCopyright : (c) Christian Maeder and Uni Bremen 2002-2005
97018cf5fa25b494adffd7e9b4e87320dae6bf47Christian MaederLicense : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt
3f69b6948966979163bdfe8331c38833d5d90ecdChristian MaederMaintainer : Christian.Maeder@dfki.de
bbae6e6ca0de7f2ffbb44d2c8da179f2b717237fChristian MaederStability : provisional
fbb66ee3e170624835b99f7aa91980753cb5b472Christian MaederPortability : portable
bbae6e6ca0de7f2ffbb44d2c8da179f2b717237fChristian Maederanalyse alternatives of data types
0ea85310d2beb8aa03cac481ad2a6564e6b8ddbcChristian Maeder ( DataPat(..)
0ea85310d2beb8aa03cac481ad2a6564e6b8ddbcChristian Maeder , makeDataSelEqs
0ea85310d2beb8aa03cac481ad2a6564e6b8ddbcChristian Maeder , inVarTypeArg
ad270004874ce1d0697fb30d7309f180553bb315Christian Maederimport qualified Data.Map as Map
ad270004874ce1d0697fb30d7309f180553bb315Christian Maederimport qualified Data.Set as Set
6e39bfd041946fce4982ac89834be73fd1bfb39aChristian Maeder-- | description of polymorphic data types
6e39bfd041946fce4982ac89834be73fd1bfb39aChristian Maederdata DataPat = DataPat Id [TypeArg] RawKind Type
0ea85310d2beb8aa03cac481ad2a6564e6b8ddbcChristian Maeder-- make type argument invariant
0ea85310d2beb8aa03cac481ad2a6564e6b8ddbcChristian MaederinVarTypeArg :: TypeArg -> TypeArg
0ea85310d2beb8aa03cac481ad2a6564e6b8ddbcChristian MaederinVarTypeArg (TypeArg i _ vk rk c o p) = (TypeArg i InVar vk rk c o p)
42c01284bba8d7c8d995c8dfb96ace57d28ed1bcTill MossakowskimkSelId :: Range -> String -> Int -> Int -> Id
2bf209888545860dc77b9c3f2198d00eeab30d20Christian MaedermkSelId p str n m = mkId
b645cf3dc1e449038ed291bbd11fcc6e02b2fc7fChristian Maeder [Token (str ++ "_" ++ show n ++ "_" ++ show m) p]
715ffaf874309df081d1e1cd8e05073fc1227729Christian MaedermkSelVar :: Int -> Int -> Type -> VarDecl
42c01284bba8d7c8d995c8dfb96ace57d28ed1bcTill MossakowskimkSelVar n m ty = VarDecl (mkSelId (getRange ty) "x" n m) ty Other nullRange
715ffaf874309df081d1e1cd8e05073fc1227729Christian MaedergenTuple :: Int -> Int -> [Selector] -> [VarDecl]
2bf209888545860dc77b9c3f2198d00eeab30d20Christian MaedergenTuple _ _ [] = []
2bf209888545860dc77b9c3f2198d00eeab30d20Christian MaedergenTuple n m (Select _ ty _ : sels) =
715ffaf874309df081d1e1cd8e05073fc1227729Christian Maeder mkSelVar n m ty : genTuple n (m + 1) sels
715ffaf874309df081d1e1cd8e05073fc1227729Christian MaedergenSelVars :: Int -> [[Selector]] -> [[VarDecl]]
715ffaf874309df081d1e1cd8e05073fc1227729Christian MaedergenSelVars _ [] = []
2bf209888545860dc77b9c3f2198d00eeab30d20Christian MaedergenSelVars n (ts:sels) =
715ffaf874309df081d1e1cd8e05073fc1227729Christian Maeder genTuple n 1 ts : genSelVars (n + 1) sels
2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian MaedermakeSelTupleEqs :: DataPat -> Term -> Int -> Int -> [Selector] -> [Named Term]
2bf209888545860dc77b9c3f2198d00eeab30d20Christian MaedermakeSelTupleEqs dt@(DataPat _ tArgs _ rt) ct n m (Select mi ty p : sels) =
0ea85310d2beb8aa03cac481ad2a6564e6b8ddbcChristian Maeder let sc = TypeScheme (map inVarTypeArg tArgs) (getSelType rt p ty) nullRange
0ea85310d2beb8aa03cac481ad2a6564e6b8ddbcChristian Maeder in (case mi of
ccf3de3d66b521a260e5c22d335c64a48e3f0195Christian Maeder Just i -> let
aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maeder vt = QualVar $ mkSelVar n m ty
2bf209888545860dc77b9c3f2198d00eeab30d20Christian Maeder eq = mkEqTerm eqId nullRange
2bf209888545860dc77b9c3f2198d00eeab30d20Christian Maeder (mkApplTerm (mkOpTerm i sc) [ct]) vt
c44c23429c72f3a709e22a18f2ed6f05fc8cc765Christian Maeder in [makeNamed ("ga_select_" ++ show i) eq]
2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian Maeder ++ makeSelTupleEqs dt ct n (m + 1) sels
2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian MaedermakeSelTupleEqs _ _ _ _ [] = []
2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian MaedermakeSelEqs :: DataPat -> Term -> Int -> [[Selector]] -> [Named Term]
2bf209888545860dc77b9c3f2198d00eeab30d20Christian MaedermakeSelEqs dt ct n (sel:sels) =
2bf209888545860dc77b9c3f2198d00eeab30d20Christian Maeder makeSelTupleEqs dt ct n 1 sel
2bf209888545860dc77b9c3f2198d00eeab30d20Christian Maeder ++ makeSelEqs dt ct (n + 1) sels
2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian MaedermakeSelEqs _ _ _ _ = []
2a598ff0c1b7b51c33aee7029b43bc5cfcbea6b8Christian MaedermakeAltSelEqs :: DataPat -> AltDefn -> [Named Term]
2bf209888545860dc77b9c3f2198d00eeab30d20Christian MaedermakeAltSelEqs dt@(DataPat _ args _ rt) (Construct mc ts p sels) =
715ffaf874309df081d1e1cd8e05073fc1227729Christian Maeder Nothing -> []
0ea85310d2beb8aa03cac481ad2a6564e6b8ddbcChristian Maeder Just c -> let sc = TypeScheme (map inVarTypeArg args)
0ea85310d2beb8aa03cac481ad2a6564e6b8ddbcChristian Maeder (getFunType rt p ts) nullRange
2bf209888545860dc77b9c3f2198d00eeab30d20Christian Maeder vars = genSelVars 1 sels
2bf209888545860dc77b9c3f2198d00eeab30d20Christian Maeder ars = map ( \ vs -> mkTupleTerm (map QualVar vs) nullRange)
2bf209888545860dc77b9c3f2198d00eeab30d20Christian Maeder ct = mkApplTerm (mkOpTerm c newSc) ars
715ffaf874309df081d1e1cd8e05073fc1227729Christian Maeder in map (mapNamed (mkForall (map GenTypeVarDecl args
aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maeder ++ map GenVarDecl (concat vars))))
aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maeder $ makeSelEqs dt ct 1 sels
0ea85310d2beb8aa03cac481ad2a6564e6b8ddbcChristian Maeder-- | create selector equations for a data type
62ecb1e7f8fd9573eea8369657de12c7bf9f4f25Christian MaedermakeDataSelEqs :: DataEntry -> Type -> [Named Sentence]
6e39bfd041946fce4982ac89834be73fd1bfb39aChristian MaedermakeDataSelEqs (DataEntry _ i _ args rk alts) rt =
2bf209888545860dc77b9c3f2198d00eeab30d20Christian Maeder map (mapNamed Formula) $
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder concatMap (makeAltSelEqs $ DataPat i args rk rt) $ Set.toList alts
0ea85310d2beb8aa03cac481ad2a6564e6b8ddbcChristian Maeder-- | analyse the alternatives of a data type
89dc77946055c0e4cb4671c4a74c3dcd55ed41a1Christian MaederanaAlts :: [DataPat] -> DataPat -> [Alternative] -> Env -> Result [AltDefn]
2bf209888545860dc77b9c3f2198d00eeab30d20Christian MaederanaAlts tys dt alts te =
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder do l <- mapM (anaAlt tys dt te) alts
2bf209888545860dc77b9c3f2198d00eeab30d20Christian Maeder Result (checkUniqueness $ catMaybes $
aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maeder map ( \ (Construct i _ _ _) -> i) l) $ Just ()
89dc77946055c0e4cb4671c4a74c3dcd55ed41a1Christian MaederanaAlt :: [DataPat] -> DataPat -> Env -> Alternative
2bf209888545860dc77b9c3f2198d00eeab30d20Christian Maeder -> Result AltDefn
2bf209888545860dc77b9c3f2198d00eeab30d20Christian MaederanaAlt _ _ te (Subtype ts _) =
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder do l <- mapM ( \ t -> anaStarTypeM t te) ts
149e43c4a2705a86a0e5fa301ba849fdf19db32eChristian Maeder return $ Construct Nothing (map snd l) Partial []
2bf209888545860dc77b9c3f2198d00eeab30d20Christian MaederanaAlt tys dt te (Constructor i cs p _) =
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder do newCs <- mapM (anaComps tys dt te) cs
5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maeder let sels = map snd newCs
2bf209888545860dc77b9c3f2198d00eeab30d20Christian Maeder Result (checkUniqueness $ catMaybes $
aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maeder map ( \ (Select s _ _) -> s ) $ concat sels) $ Just ()
5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maeder return $ Construct (Just i) (map fst newCs) p sels
89dc77946055c0e4cb4671c4a74c3dcd55ed41a1Christian MaederanaComps :: [DataPat] -> DataPat -> Env -> [Component]
2bf209888545860dc77b9c3f2198d00eeab30d20Christian Maeder -> Result (Type, [Selector])
36c6cc568751e4235502cfee00ba7b597dae78dcChristian MaederanaComps tys rt te cs =
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder do newCs <- mapM (anaComp tys rt te) cs
d48085f765fca838c1d972d2123601997174583dChristian Maeder return (mkProductType $ map fst newCs, map snd newCs)
89dc77946055c0e4cb4671c4a74c3dcd55ed41a1Christian MaederanaComp :: [DataPat] -> DataPat -> Env -> Component
aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maeder -> Result (Type, Selector)
3daa82a175c7cfabf22455aa77c4beda327404e4Christian MaederanaComp tys rt te (Selector s _ t _ _) =
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder do ct <- anaCompType tys rt t te
3daa82a175c7cfabf22455aa77c4beda327404e4Christian Maeder let (p, nct) = case getTypeAppl ct of
3daa82a175c7cfabf22455aa77c4beda327404e4Christian Maeder (TypeName i _ _, [lt]) | i == lazyTypeId -> (Partial, lt)
3daa82a175c7cfabf22455aa77c4beda327404e4Christian Maeder _ -> (Total, ct)
3daa82a175c7cfabf22455aa77c4beda327404e4Christian Maeder return (nct, Select (Just s) nct p)
36c6cc568751e4235502cfee00ba7b597dae78dcChristian MaederanaComp tys rt te (NoSelector t) =
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder do ct <- anaCompType tys rt t te
5e26bfc8d7b18cf3a3fa7b919b4450fb669f37a5Christian Maeder return (ct, Select Nothing ct Partial)
89dc77946055c0e4cb4671c4a74c3dcd55ed41a1Christian MaederanaCompType :: [DataPat] -> DataPat -> Type -> Env -> Result Type
6e39bfd041946fce4982ac89834be73fd1bfb39aChristian MaederanaCompType tys (DataPat _ tArgs _ _) t te = do
149e43c4a2705a86a0e5fa301ba849fdf19db32eChristian Maeder (_, ct) <- anaStarTypeM t te
2bf209888545860dc77b9c3f2198d00eeab30d20Christian Maeder let ds = unboundTypevars True tArgs ct
1738d16957389457347bee85075d3d33d002158fChristian Maeder if null ds then return () else Result ds Nothing
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder mapM (checkMonomorphRecursion ct te) tys
6e39bfd041946fce4982ac89834be73fd1bfb39aChristian Maeder return $ generalize tArgs ct
89dc77946055c0e4cb4671c4a74c3dcd55ed41a1Christian MaedercheckMonomorphRecursion :: Type -> Env -> DataPat -> Result ()
2bf209888545860dc77b9c3f2198d00eeab30d20Christian MaedercheckMonomorphRecursion t te (DataPat i _ _ rt) =
304c84f22dd78f7979efd81b8fc38c8d2197ed39Christian Maeder case filter (\ ty -> not (lesserType te ty rt || lesserType te rt ty))
304c84f22dd78f7979efd81b8fc38c8d2197ed39Christian Maeder $ findSubTypes (typeMap te) i t of
304c84f22dd78f7979efd81b8fc38c8d2197ed39Christian Maeder [] -> return ()
304c84f22dd78f7979efd81b8fc38c8d2197ed39Christian Maeder ty : _ -> Result [Diag Error ("illegal polymorphic recursion"
304c84f22dd78f7979efd81b8fc38c8d2197ed39Christian Maeder ++ expected rt ty) $ getRange ty] Nothing
7de39d39bc1700cc8a9bb9df90b920aad9e18d4aChristian MaederfindSubTypes :: TypeMap -> Id -> Type -> [Type]
e215ca0377dc79c9bcfb105157ecc4b958bec67bChristian MaederfindSubTypes tm i t = case getTypeAppl t of
e215ca0377dc79c9bcfb105157ecc4b958bec67bChristian Maeder (TypeName j _ _, args) -> if relatedTypeIds tm i j then [t]
e215ca0377dc79c9bcfb105157ecc4b958bec67bChristian Maeder else concatMap (findSubTypes tm i) args
e215ca0377dc79c9bcfb105157ecc4b958bec67bChristian Maeder (topTy, args) -> concatMap (findSubTypes tm i) $ topTy : args
7de39d39bc1700cc8a9bb9df90b920aad9e18d4aChristian MaederrelatedTypeIds :: TypeMap -> Id -> Id -> Bool
2bf209888545860dc77b9c3f2198d00eeab30d20Christian MaederrelatedTypeIds tm i1 i2 =
88ece6e49930670e8fd3ee79c89a2e918d2fbd0cChristian Maeder not $ Set.null $ Set.intersection (allRelIds tm i1) $ allRelIds tm i2
7de39d39bc1700cc8a9bb9df90b920aad9e18d4aChristian MaederallRelIds :: TypeMap -> Id -> Set.Set Id
2bf209888545860dc77b9c3f2198d00eeab30d20Christian MaederallRelIds tm i = Set.union (superIds tm i) $ subIds tm i
1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian MaedersubIds :: TypeMap -> Id -> Set.Set Id
1d589334ba6b4a4cbfb35307a7a732261e77b0cdChristian MaedersubIds tm i = foldr ( \ j s ->
aff01ee50b66032469c232e00c945d1fd4f57d1bChristian Maeder if Set.member i $ superIds tm j then