@@ -55,9 +55,9 @@ findAmbiguous hints assumptions continue =
5555 _ -> continue
5656
5757mergeSchemes :: [Map.Map String Scheme]
58− -> GuidCounter (TVarMap, ConstraintSet, Map.Map String Scheme)
58+ -> GuidCounter (TVarMap, Constraints, Map.Map String Scheme)
5959mergeSchemes schmss = do (ass,css,sss) <- unzip3 `liftM` mapM split kvs
60− return (Map.unions ass, Set.unions css, Map.unions sss)
60+ return (Map.unions ass, concat css, Map.unions sss)
6161 where
6262 kvs = Map.toList $ Map.unionsWith (++) (map (Map.map (:[])) schmss)
6363 split (k,vs) =
@@ -67,15 +67,15 @@ mergeSchemes schmss = do (ass,css,sss) <- unzip3 `liftM` mapM split kvs
6767 in do xs <- mapM (\_ -> guid) vs
6868 return ( Map.fromList $ zip (map fst ps) (map (:[]) xs)
6969 , case xs of
70− t:ts -> Set.fromList $ zipWith eq (t:ts) ts
71− [] -> Set.empty
70+ t:ts -> zipWith eq xs ts
71+ [] -> []
7272 , Map.fromList ps )
7373
7474constrain typeHints (Module _ _ imports stmts) = do
7575 (ass,css,schemess) <- unzip3 `liftM` mapM stmtGen stmts
7676 aliasHints <- getAliases imports `liftM` typeHints
7777 (as', cs', schemes) <- mergeSchemes schemess
78− let constraints = Set.unions (cs':css)
78+ let constraints = concat (cs':css)
7979 as = unionsA (as':ass)
8080 allHints = Map.union schemes (Map.fromList aliasHints)
8181 insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as
@@ -86,30 +86,29 @@ constrain typeHints (Module _ _ imports stmts) = do
8686 escapees = Map.keys $ Map.difference assumptions allHints
8787 msg = "Warning! Type-checker could not find variables:\n" ++ intercalate ", " escapees
8888 return $ case escapees of
89− [] -> Right (Set.toList constraints ++ cs)
90− _ -> unsafePerformIO (putStrLn msg) `seq` Right (Set.toList constraints ++ cs)
89+ [] -> Right (constraints ++ cs)
90+ _ -> unsafePerformIO (putStrLn msg) `seq` Right (constraints ++ cs)
9191 --_ -> Left ("Undefined variable(s): " ++ intercalate ", " escapees)
9292
9393type TVarMap = Map.Map String [X]
94−type ConstraintSet = Set.Set (Located Constraint)
94+type Constraints = [Located Constraint]
9595
9696loc e span = L (Just $ show e) span
9797
98−gen :: CExpr -> GuidCounter (TVarMap, ConstraintSet, Type)
98+gen :: CExpr -> GuidCounter (TVarMap, Constraints, Type)
9999gen (L _ span expr) =
100100 let loc' = L (Just $ show expr) span in
101101 case expr of
102102 Var x ->
103103 do b <- guid
104− return (Map.singleton x [b], Set.empty, VarT b)
104+ return (Map.singleton x [b], [], VarT b)
105105
106106 App e1 e2 ->
107107 do (a1,c1,t1) <- gen e1
108108 (a2,c2,t2) <- gen e2
109109 b <- beta
110110 return ( unionA a1 a2
111− , Set.unions [c1,c2
112− ,Set.singleton . loc' $ t1 :=: (LambdaT t2 b)]
111+ , c1 ++ c2 ++ [loc' $ t1 :=: (LambdaT t2 b)]
113112 , b )
114113
115114 Lambda x e ->
@@ -117,8 +116,7 @@ gen (L _ span expr) =
117116 b <- beta
118117 v <- guid
119118 return ( Map.delete x a
120− , Set.union c . Set.fromList .
121− map (\x -> loc' $ VarT x :=: b) $
119+ , (++) c . map (\x -> loc' $ VarT x :=: b) $
122120 Map.findWithDefault [v] x a
123121 , LambdaT b t )
124122
@@ -136,7 +134,7 @@ gen (L _ span expr) =
136134 return $ map (\x -> loc name span $ x :<<: s) vs
137135 cs' <- zipWithM genCs names schemes
138136 return ( foldr Map.delete assumptions names
139− , Set.union (Set.fromList . concat $ cs') cs
137+ , concat cs' ++ cs
140138 , t )
141139
142140 Case e cases ->
@@ -146,8 +144,8 @@ gen (L _ span expr) =
146144 , let cases' = map snd cases
147145 locs = zipWith epos cases' (tail cases')
148146 csts = zipWith (:=:) ts (tail ts)
149− cs' = Set.fromList (zipWith ($) locs csts)
150− in Set.unions $ cs' : cs : css
147+ cs' = zipWith ($) locs csts
148+ in concat $ cs' : cs : css
151149 , head ts)
152150
153151 If e1 e2 e3 ->
@@ -155,9 +153,7 @@ gen (L _ span expr) =
155153 (a2,c2,t2) <- gen e2
156154 (a3,c3,t3) <- gen e3
157155 return ( unionsA [a1,a2,a3]
158− , let c4 = Set.fromList [ loc e1 span (t1 :=: bool)
159− , loc' (t2 :=: t3) ]
160− in Set.unions [c1,c2,c3,c4]
156+ , c1 ++ c2 ++ c3 ++ [ loc e1 span (t1 :=: bool), loc' (t2 :=: t3) ]
161157 , t2 )
162158
163159 Data name es ->
@@ -172,20 +168,20 @@ gen (L _ span expr) =
172168 rtype' <- beta
173169 let fs = Map.singleton label [t]
174170 c = (loc' (RecordT fs rtype' :=: rtype))
175− return (as, Set.insert c cs, t)
171+ return (as, c:cs, t)
176172
177173 Remove e x ->
178174 do (as,cs,rtype) <- gen e
179175 t <- beta
180176 rtype' <- beta
181177 let c = (loc' (RecordT (Map.singleton x [t]) rtype' :=: rtype))
182− return (as, Set.insert c cs, rtype')
178+ return (as, c:cs, rtype')
183179
184180 Insert e x v ->
185181 do (eas,ecs,etype) <- gen e
186182 (vas,vcs,vtype) <- gen v
187183 return ( unionA eas vas
188− , Set.union ecs vcs
184+ , ecs ++ vcs
189185 , RecordT (Map.singleton x [vtype]) etype )
190186
191187 Modify record fields ->
@@ -194,8 +190,8 @@ gen (L _ span expr) =
194190 oldTs <- mapM (\_ -> beta) fields
195191 rtype' <- beta
196192 let rT ts = RecordT (recordT (zip (map fst fields) ts)) rtype'
197− c = Set.singleton (loc' (rtype :=: rT oldTs))
198− return ( unionsA (ras:ass), Set.unions (c : rcs : css), rT newTs )
193+ c = [ loc' (rtype :=: rT oldTs) ]
194+ return ( unionsA (ras:ass), concat (c : rcs : css), rT newTs )
199195
200196 Record fields ->
201197 let insert label tipe = Map.insertWith (++) label [tipe]
@@ -204,30 +200,28 @@ gen (L _ span expr) =
204200 return (as, cs, insert label tipe)
205201 in do (ass, css, fs) <- unzip3 `liftM` mapM getScheme fields
206202 return ( unionsA ass
207− , Set.fromList (concat css)
203+ , concat css
208204 , RecordT (foldr ($) Map.empty fs) EmptyRecord )
209205
210206 Range e1@(L w1 s1 _) e2@(L w2 s2 _) ->
211207 do (a1,c1,t1) <- gen e1
212208 (a2,c2,t2) <- gen e2
213209 return ( unionsA [a1,a2]
214− , Set.unions [ c1, c2, Set.fromList [ L w1 s1 (t1 :=: int)
215− , L w1 s2 (t2 :=: int) ] ]
210+ , c1 ++ c2 ++ [ L w1 s1 (t1 :=: int), L w1 s2 (t2 :=: int) ]
216211 , listOf int )
217212
218213 MultiIf ps -> do (ass,css,t:ts) <- unzip3 `liftM` mapM genPair ps
219− let cs = Set.fromList (map (loc' . (t :=:)) ts)
220− return (unionsA ass, Set.unions (cs:css), t)
214+ let cs = map (loc' . (t :=:)) ts
215+ return (unionsA ass, concat (cs:css), t)
221216 where genPair (b@(L t s _),e) = do
222217 (a1,c1,t1) <- gen b
223218 (a2,c2,t2) <- gen e
224219 return ( unionsA [a1,a2]
225− , Set.unions [ c1, c2
226− , Set.singleton (L t s (t1 :=: bool)) ]
220+ , c1 ++ c2 ++ [ L t s (t1 :=: bool) ]
227221 , t2 )
228222
229223 IntNum _ -> do t <- beta
230− return (Map.empty, Set.singleton (loc' $ t :<: number), t)
224+ return (Map.empty, [loc' $ t :<: number], t)
231225
232226 FloatNum _ -> primitive float
233227 Chr _ -> primitive char
@@ -236,38 +230,38 @@ gen (L _ span expr) =
236230 Markdown _ -> primitive element
237231
238232
239−primitive :: Type -> GuidCounter (TVarMap, ConstraintSet, Type)
240−primitive t = return (Map.empty, Set.empty, t)
233+primitive :: Type -> GuidCounter (TVarMap, Constraints, Type)
234+primitive t = return (Map.empty, [], t)
241235
242236caseGen :: Type
243237 -> (Pattern, CExpr)
244− -> GuidCounter (TVarMap, ConstraintSet, Type)
238+ -> GuidCounter (TVarMap, Constraints, Type)
245239caseGen tipe (p, ce@(L _ span e)) = do
246240 (as ,cs ,t) <- gen ce
247241 (as',cs',_) <- patternGen (loc p span) tipe as p
248− return ( as', Set.union cs cs', t )
242+ return ( as', cs ++ cs', t )
249243
250244patternGen :: (Constraint -> Located Constraint)
251245 -> Type -- Type of e in `case e of ...`
252246 -> TVarMap
253247 -> Pattern
254− -> GuidCounter (TVarMap, ConstraintSet, Type)
248+ -> GuidCounter (TVarMap, Constraints, Type)
255249patternGen loc tipe as pattern =
256250 case pattern of
257− PAnything -> do b <- beta ; return ( as, Set.empty, b )
251+ PAnything -> do b <- beta ; return ( as, [], b )
258252 PVar v -> do
259253 b <- beta
260254 let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)
261− return ( Map.delete v as, Set.fromList (loc (b :=: tipe) : cs), b )
255+ return ( Map.delete v as, loc (b :=: tipe) : cs, b )
262256 PData name ps -> do
263257 constr <- guid
264258 output <- beta
265259 let step (as,cs,tipe) p = do b <- beta
266260 (as',cs',t) <- patternGen loc b as p
267− return (as', Set.union cs cs', t ==> tipe)
268− (as',cs, t) <- foldM step (as,Set.empty,tipe) (reverse ps)
261+ return (as', cs ++ cs', t ==> tipe)
262+ (as',cs, t) <- foldM step (as,[],tipe) (reverse ps)
269263 return ( Map.insert name [constr] as'
270− , Set.insert (loc (VarT constr :=: t)) cs
264+ , loc (VarT constr :=: t) : cs
271265 , output )
272266 PRecord fs ->
273267 do pairs <- mapM (\f -> do b <- beta; return (f,b)) fs
@@ -276,7 +270,7 @@ patternGen loc tipe as pattern =
276270 mkCs (name,tipe) = map (loc . (tipe :=:) . VarT)
277271 (Map.findWithDefault [] name as)
278272 return ( foldr Map.delete as fs
279− , Set.fromList (loc (t :=: tipe) : concatMap mkCs pairs)
273+ , loc (t :=: tipe) : concatMap mkCs pairs
280274 , t )
281275
282276
@@ -289,7 +283,7 @@ defGen def = case def of
289283 OpDef op a1 a2 e -> defGenHelp op [a1,a2] e
290284 TypeAnnotation name tipe -> do
291285 schm <- Subs.generalize [] =<< Subs.superize name tipe
292− return (Map.empty, Set.empty, (name, schm))
286+ return (Map.empty, [], (name, schm))
293287
294288defGenHelp name args e = do
295289 argDict <- mapM (\a -> liftM ((,) a) guid) args
@@ -302,12 +296,12 @@ defGenHelp name args e = do
302296 return $ map (\y -> loc arg NoSpan $ VarT x :=: VarT y) as'
303297 cs' <- concat `liftM` mapM genCs argDict
304298 scheme <- Subs.generalize (concat $ Map.elems as') $
305− Forall (map snd argDict) (cs' ++ Set.toList cs) tipe
306− return ( as', Set.empty, (name, scheme) )
299+ Forall (map snd argDict) (cs' ++ cs) tipe
300+ return ( as', [], (name, scheme) )
307301
308302
309303stmtGen :: Statement
310− -> GuidCounter (TVarMap, ConstraintSet, Map.Map String Scheme)
304+ -> GuidCounter (TVarMap, Constraints, Map.Map String Scheme)
311305stmtGen stmt =
312306 case stmt of
313307 Definition def -> do (as,cs,hint) <- defGen def
@@ -315,18 +309,18 @@ stmtGen stmt =
315309
316310 Datatype name xs tcs ->
317311 let toScheme ts = Forall xs [] (foldr (==>) (ADT name $ map VarT xs) ts)
318− in return (Map.empty, Set.empty, Map.fromList (map (second toScheme) tcs))
312+ in return (Map.empty, [], Map.fromList (map (second toScheme) tcs))
319313
320314 ExportEvent js elm tipe ->
321315 do x <- guid
322316 return ( Map.singleton elm [x]
323− , Set.singleton . loc elm NoSpan $ VarT x :=: tipe
317+ , [ loc elm NoSpan $ VarT x :=: tipe ]
324318 , Map.empty )
325319
326320 ImportEvent js e@(L txt span base) elm tipe ->
327321 do (as,cs,t) <- gen e
328322 return ( as
329− , Set.insert (L txt span (signalOf t :=: tipe)) cs
323+ , L txt span (signalOf t :=: tipe) : cs
330324 , Map.singleton elm (Forall [] [] tipe) )
331325
332− TypeAlias _ _ _ -> return (Map.empty, Set.empty, Map.empty)
326+ TypeAlias _ _ _ -> return (Map.empty, [], Map.empty)