@@ -40,20 +40,40 @@ findAmbiguous hints hints' assumptions continue =
4040 intercalate ", " (filter (isSuffixOf n) hints)
4141 _ -> continue
4242
43+mergeSchemes :: [Map.Map String Scheme]
44+ -> GuidCounter (TVarMap, ConstraintSet, Map.Map String Scheme)
45+mergeSchemes schmss = do (ass,css,sss) <- unzip3 `liftM` mapM split kvs
46+ return (Map.unions ass, Set.unions css, Map.unions sss)
47+ where
48+ kvs = Map.toList $ Map.unionsWith (++) (map (Map.map (:[])) schmss)
49+ split (k,vs) =
50+ let ps = zipWith (\s v -> (s++k,v)) (map (flip replicate '_') [0..]) vs
51+ eq t u = C (Just $ msg ++ k) NoSpan (VarT t :=: VarT u)
52+ msg = "the definition of "
53+ in do xs <- mapM (\_ -> guid) vs
54+ return ( Map.fromList $ zip (map fst ps) (map (:[]) xs)
55+ , case xs of
56+ t:ts -> Set.fromList $ zipWith eq (t:ts) ts
57+ [] -> Set.empty
58+ , Map.fromList ps )
59+
4360constrain typeHints (Module _ _ imports stmts) = do
4461 (ass,css,schemess) <- unzip3 `liftM` mapM stmtGen stmts
4562 hints <- typeHints
46− let extraImports = ("Time", Hiding ["read"]) : map (\n -> (n, Hiding []))
63+ (as', cs', schemes) <- mergeSchemes schemess
64+ let constraints = Set.unions (cs':css)
65+ as = unionsA (as':ass)
66+ extraImports = ("Time", Hiding ["read"]) : map (\n -> (n, Hiding []))
4767 ["List","Signal","Text","Graphics","Color"]
48− insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as
4968 aliasHints = getAliases (imports ++ extraImports) hints
50− allHints = Map.fromList (aliasHints ++ concat schemess)
51− assumptions <- foldM insert (unionsA ass) $ map fst (concat schemess)
69+ allHints = Map.union schemes (Map.fromList aliasHints)
70+ insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as
71+ assumptions <- foldM insert as (Map.keys schemes)
5272 findAmbiguous (map fst hints) (map fst aliasHints) assumptions $ do
5373 let f k s vs = map (\v -> C (Just k) NoSpan $ v :<<: s) vs
5474 cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions
5575 escapees = Map.keys $ Map.difference assumptions allHints
56− return . Right . (,) escapees $ cs ++ Set.toList (Set.unions css)
76+ return . Right . (,) escapees $ Set.toList constraints ++ cs
5777
5878type TVarMap = Map.Map String [X]
5979type ConstraintSet = Set.Set (Context Constraint)
@@ -207,33 +227,32 @@ caseGen :: Type
207227 -> (Pattern, CExpr)
208228 -> GuidCounter (TVarMap, ConstraintSet, Type)
209229caseGen tipe (p, ce@(C _ span e)) = do
210− (as ,cs , t ) <- gen ce
211− (as',cs',[t']) <- patternGen (as,cs,[]) p
212− let cs'' = Set.union cs' . Set.singleton . ctx p span $ t' :=: tipe
213− return ( as', cs'', t )
230+ (as ,cs ,t) <- gen ce
231+ (as',cs',_) <- patternGen (ctx p span) tipe as p
232+ return ( as', Set.union cs cs', t )
214233
215−patternGen :: (TVarMap, ConstraintSet, [Type])
234+patternGen :: (Constraint -> Context Constraint)
235+ -> Type
236+ -> TVarMap
216237 -> Pattern
217− -> GuidCounter (TVarMap, ConstraintSet, [Type])
218−patternGen (as,cs,ts) PAnything = ((,,) as cs . (\t -> ts++[t])) `liftM` beta
219−patternGen (as,cs,ts) (PVar v) = do
220− b <- beta
221− let cs' = map (\x -> ctx v NoSpan $ VarT x :=: b) $ Map.findWithDefault [] v as
222− return ( Map.delete v as, Set.union cs $ Set.fromList cs', ts ++ [b] )
223−patternGen (as,cs,ts) p@(PData name ps) = do
224− constr <- guid
225− output <- beta
226− (as',cs',ts') <- foldM patternGen (as,cs,[]) ps
227− let t = foldr (==>) output ts'
228− let getC | isTupleString name = do
229− vs <- mapM (\_ -> beta) ps
230− return . Set.singleton . C (Just $ show p) NoSpan $ output :=: ADT name vs
231− | otherwise = return Set.empty
232− cs'' <- getC
233− return ( unionA as' (Map.singleton name [constr])
234− , Set.unions [cs',cs''
235− , Set.singleton . ctx p NoSpan $ VarT constr :=: t ]
236− , ts ++ [output] )
238+ -> GuidCounter (TVarMap, ConstraintSet, Type)
239+patternGen ctxt tipe as pattern =
240+ case pattern of
241+ PAnything -> do b <- beta ; return (Map.empty, Set.empty, b)
242+ PVar v -> do
243+ b <- beta
244+ let cs = map (ctxt . (b :=:) . VarT) (Map.findWithDefault [] v as)
245+ return ( Map.delete v as, Set.fromList (ctxt (b :=: tipe) : cs), b )
246+ PData name ps -> do
247+ constr <- guid
248+ output <- beta
249+ let step (as,cs,tipe) p = do b <- beta
250+ (as',cs',t) <- patternGen ctxt b as p
251+ return (as', Set.union cs cs', t ==> tipe)
252+ (as',cs, t) <- foldM step (as,Set.empty,tipe) (reverse ps)
253+ return ( Map.insert name [constr] as'
254+ , Set.insert (ctxt (VarT constr :=: t)) cs
255+ , output )
237256
238257
239258defScheme :: Def -> GuidCounter (Map.Map String [X], Scheme)
@@ -259,38 +278,32 @@ defGenHelp name args e = do
259278 return ( as', Set.empty, (name, scheme) )
260279
261280
262−stmtGen :: Statement -> GuidCounter (TVarMap, ConstraintSet, [(String,Scheme)])
281+stmtGen :: Statement
282+ -> GuidCounter (TVarMap, ConstraintSet, Map.Map String Scheme)
263283stmtGen stmt =
264284 case stmt of
265285 Definition def -> do (as,cs,hint) <- defGen def
266− return ( as, cs, [hint] )
267−
268− TypeAlias alias t -> return (Map.empty, Set.empty, [])
269−
270− TypeAnnotation name t ->
271− do Forall _ _ t' <- generalize [] (Forall [] [] t)
272− x <- guid
273− return (Map.singleton name [x],
274− Set.singleton (ctx name NoSpan $ VarT x :=: t'),
275− [])
286+ return ( as, cs, uncurry Map.singleton hint )
276287
277288 Datatype name xs tcs ->
278− let toType ts = foldl (==>) (ADT name $ map VarT xs) ts in
279− do schemes <- mapM (toScheme . second toType) tcs
280− return (Map.empty, Set.empty, schemes)
289+ let toScheme ts = Forall xs [] (foldr (==>) (ADT name $ map VarT xs) ts)
290+ in return (Map.empty, Set.empty, Map.fromList (map (second toScheme) tcs))
281291
282292 ExportEvent js elm tipe ->
283293 do x <- guid
284294 return ( Map.singleton elm [x]
285295 , Set.singleton . ctx elm NoSpan $ VarT x :=: tipe
286− , [] )
296+ , Map.empty )
287297
288298 ImportEvent js e@(C txt span base) elm tipe ->
289299 do (as,cs,t) <- gen e
290300 return ( as
291301 , Set.insert (C txt span (signalOf t :=: tipe)) cs
292− , [ (elm, Forall [] [] tipe) ] )
302+ , Map.singleton elm (Forall [] [] tipe) )
303+
304+ TypeAnnotation name tipe ->
305+ do schm <- generalize [] (Forall [] [] tipe)
306+ return (Map.empty, Set.empty, Map.singleton name schm)
307+
308+ _ -> return (Map.empty, Set.empty, Map.empty)
293309
294−toScheme :: (String,Type) -> GuidCounter (String,Scheme)
295−toScheme (name,tipe) = do scheme <- generalize [] (Forall [] [] tipe)
296− return (name, scheme)