7d50769 · elk · git.iko.soy

40 intercalate ", " (filter (isSuffixOf n) hints)

41 _ -> continue

42

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+

43constrain typeHints (Module _ _ imports stmts) = do

60constrain typeHints (Module _ _ imports stmts) = do

44 (ass,css,schemess) <- unzip3 `liftM` mapM stmtGen stmts

61 (ass,css,schemess) <- unzip3 `liftM` mapM stmtGen stmts

45 hints <- typeHints

62 hints <- typeHints

63+ (as', cs', schemes) <- mergeSchemes schemess

64+ let constraints = Set.unions (cs':css)

65+ as = unionsA (as':ass)

46− let extraImports = ("Time", Hiding ["read"]) : map (\n -> (n, Hiding []))

66+ extraImports = ("Time", Hiding ["read"]) : map (\n -> (n, Hiding []))

47 ["List","Signal","Text","Graphics","Color"]

67 ["List","Signal","Text","Graphics","Color"]

48− insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as

49 aliasHints = getAliases (imports ++ extraImports) hints

68 aliasHints = getAliases (imports ++ extraImports) hints

50− allHints = Map.fromList (aliasHints ++ 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

51− assumptions <- foldM insert (unionsA ass) $ map fst (concat schemess)

71+ assumptions <- foldM insert as (Map.keys schemes)

52 findAmbiguous (map fst hints) (map fst aliasHints) assumptions $ do

72 findAmbiguous (map fst hints) (map fst aliasHints) assumptions $ do

53 let f k s vs = map (\v -> C (Just k) NoSpan $ v :<<: s) vs

73 let f k s vs = map (\v -> C (Just k) NoSpan $ v :<<: s) vs

54 cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions

74 cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions

55 escapees = Map.keys $ Map.difference assumptions allHints

75 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

57

77

58type TVarMap = Map.Map String [X]

78type TVarMap = Map.Map String [X]

59type ConstraintSet = Set.Set (Context Constraint)

79type ConstraintSet = Set.Set (Context Constraint)

207 -> (Pattern, CExpr)

227 -> (Pattern, CExpr)

208 -> GuidCounter (TVarMap, ConstraintSet, Type)

228 -> GuidCounter (TVarMap, ConstraintSet, Type)

209caseGen tipe (p, ce@(C _ span e)) = do

229caseGen tipe (p, ce@(C _ span e)) = do

210− (as ,cs , t ) <- gen ce

230+ (as ,cs ,t) <- gen ce

211− (as',cs',[t']) <- patternGen (as,cs,[]) p

231+ (as',cs',_) <- patternGen (ctx p span) tipe as p

212− let cs'' = Set.union cs' . Set.singleton . ctx p span $ t' :=: tipe

213− return ( as', cs'', t )

232+ return ( as', Set.union cs cs', t )

214

233

215−patternGen :: (TVarMap, ConstraintSet, [Type])

234+patternGen :: (Constraint -> Context Constraint)

235+ -> Type

236+ -> TVarMap

216 -> Pattern

237 -> Pattern

217− -> GuidCounter (TVarMap, ConstraintSet, [Type])

238+ -> GuidCounter (TVarMap, ConstraintSet, Type)

218−patternGen (as,cs,ts) PAnything = ((,,) as cs . (\t -> ts++[t])) `liftM` beta

239+patternGen ctxt tipe as pattern =

240+ case pattern of

241+ PAnything -> do b <- beta ; return (Map.empty, Set.empty, b)

219−patternGen (as,cs,ts) (PVar v) = do

242+ PVar v -> do

220− b <- beta

243+ b <- beta

221− let cs' = map (\x -> ctx v NoSpan $ VarT x :=: b) $ Map.findWithDefault [] v as

244+ let cs = map (ctxt . (b :=:) . VarT) (Map.findWithDefault [] v as)

222− return ( Map.delete v as, Set.union cs $ Set.fromList cs', ts ++ [b] )

245+ return ( Map.delete v as, Set.fromList (ctxt (b :=: tipe) : cs), b )

223−patternGen (as,cs,ts) p@(PData name ps) = do

246+ PData name ps -> do

224− constr <- guid

247+ constr <- guid

225− output <- beta

248+ output <- beta

226− (as',cs',ts') <- foldM patternGen (as,cs,[]) ps

249+ let step (as,cs,tipe) p = do b <- beta

227− let t = foldr (==>) output ts'

250+ (as',cs',t) <- patternGen ctxt b as p

228− let getC | isTupleString name = do

251+ return (as', Set.union cs cs', t ==> tipe)

229− vs <- mapM (\_ -> beta) ps

252+ (as',cs, t) <- foldM step (as,Set.empty,tipe) (reverse 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])

253+ return ( Map.insert name [constr] as'

234− , Set.unions [cs',cs''

235− , Set.singleton . ctx p NoSpan $ VarT constr :=: t ]

254+ , Set.insert (ctxt (VarT constr :=: t)) cs

236− , ts ++ [output] )

255+ , output )

237

256

238

257

239defScheme :: Def -> GuidCounter (Map.Map String [X], Scheme)

258defScheme :: Def -> GuidCounter (Map.Map String [X], Scheme)

259 return ( as', Set.empty, (name, scheme) )

278 return ( as', Set.empty, (name, scheme) )

260

279

261

280

281+stmtGen :: Statement

262−stmtGen :: Statement -> GuidCounter (TVarMap, ConstraintSet, [(String,Scheme)])

282+ -> GuidCounter (TVarMap, ConstraintSet, Map.Map String Scheme)

263stmtGen stmt =

283stmtGen stmt =

264 case stmt of

284 case stmt of

265 Definition def -> do (as,cs,hint) <- defGen def

285 Definition def -> do (as,cs,hint) <- defGen def

266− return ( as, cs, [hint] )

286+ return ( as, cs, uncurry Map.singleton 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− [])

276

287

277 Datatype name xs tcs ->

288 Datatype name xs tcs ->

278− let toType ts = foldl (==>) (ADT name $ map VarT xs) ts in

289+ let toScheme ts = Forall xs [] (foldr (==>) (ADT name $ map VarT xs) ts)

279− do schemes <- mapM (toScheme . second toType) tcs

290+ in return (Map.empty, Set.empty, Map.fromList (map (second toScheme) tcs))

280− return (Map.empty, Set.empty, schemes)

281

291

282 ExportEvent js elm tipe ->

292 ExportEvent js elm tipe ->

283 do x <- guid

293 do x <- guid

284 return ( Map.singleton elm [x]

294 return ( Map.singleton elm [x]

285 , Set.singleton . ctx elm NoSpan $ VarT x :=: tipe

295 , Set.singleton . ctx elm NoSpan $ VarT x :=: tipe

286− , [] )

296+ , Map.empty )

287

297

288 ImportEvent js e@(C txt span base) elm tipe ->

298 ImportEvent js e@(C txt span base) elm tipe ->

289 do (as,cs,t) <- gen e

299 do (as,cs,t) <- gen e

290 return ( as

300 return ( as

291 , Set.insert (C txt span (signalOf t :=: tipe)) cs

301 , 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)

293

309

294−toScheme :: (String,Type) -> GuidCounter (String,Scheme)

295−toScheme (name,tipe) = do scheme <- generalize [] (Forall [] [] tipe)

296− return (name, scheme)