git.iko.soy/elk
on master help sign in
Add error messages for errors due to untyped native functions. Hopefully untyped native functions can be eliminated soon!
9b659ddevancz
elm/src/Compiler.hs+4−4
compare with master
unifiedsplit
@@ -68,12 +68,12 @@ fileTo get what jsFiles noscript rtLoc file = do
68 writeFile html . renderHtml $ linkedHtml rtLoc js ms
68 writeFile html . renderHtml $ linkedHtml rtLoc js ms
69 writeFile js $ jss ++ concatMap jsModule ms
69 writeFile js $ jss ++ concatMap jsModule ms
70
70
71−getModules :: [String] -> FilePath -> IO (Either String [Module])
71+getModules :: [String] -> FilePath -> IO (Either String [([String],Module)])
72getModules uses file = do
72getModules uses file = do
73 code <- readFile file
73 code <- readFile file
74 case initialize code of
74 case initialize code of
75 Left err -> return . Left $ "Error in " ++ file ++ ":\n" ++ err
75 Left err -> return . Left $ "Error in " ++ file ++ ":\n" ++ err
76− Right modul@(Module _ _ imports _) ->
76+ Right (escs, modul@(Module _ _ imports _)) ->
77 let imps = filter (`notElem` builtInModules) $ map fst imports in
77 let imps = filter (`notElem` builtInModules) $ map fst imports in
78 case intersect uses imps of
78 case intersect uses imps of
79 x:_ -> return . Left $ "Error: Cyclic dependency. Module " ++
79 x:_ -> return . Left $ "Error: Cyclic dependency. Module " ++
@@ -81,10 +81,10 @@ getModules uses file = do
81 [] -> do
81 [] -> do
82 ems <- mapM (getModules (uses ++ imps) . toFilePath) imps
82 ems <- mapM (getModules (uses ++ imps) . toFilePath) imps
83 return $ case lefts ems of
83 return $ case lefts ems of
84− [] -> Right $ concat (rights ems) ++ [modul]
84+ [] -> Right $ concat (rights ems) ++ [(escs,modul)]
85 errs -> Left $ intercalate "\n" errs
85 errs -> Left $ intercalate "\n" errs
86
86
87−getModule :: FilePath -> IO (Either String [Module])
87+getModule :: FilePath -> IO (Either String [([String],Module)])
88getModule file = do
88getModule file = do
89 code <- readFile file
89 code <- readFile file
90 return . fmap (:[]) $ initialize code
90 return . fmap (:[]) $ initialize code
elm/src/Gen/CompileToJS.hs+9−7
@@ -27,21 +27,23 @@ iff a b c = a ++ "?" ++ b ++ ":" ++ c
27mainEquals s = globalAssign "ElmCode.main" (jsFunc "" (ret s))
27mainEquals s = globalAssign "ElmCode.main" (jsFunc "" (ret s))
28globalAssign m s = "\n" ++ m ++ "=" ++ s ++ ";"
28globalAssign m s = "\n" ++ m ++ "=" ++ s ++ ";"
29
29
30−tryBlock names e =
30+tryBlock escapees names e =
31 concat [ "\ntry{\n" ++ e ++ "\n\n} catch (e) {"
31 concat [ "\ntry{\n" ++ e ++ "\n\n} catch (e) {"
32 , "ElmCode.main=function() {"
32 , "ElmCode.main=function() {"
33− , "var msg = ('<br><h2>Your browser may not be supported. " ++
33+ , "var msg = ('<br/><h2>Your browser may not be supported. " ++
34 "Are you using a modern browser?</h2>' +" ++
34 "Are you using a modern browser?</h2>' +" ++
35− " '<br><span style=\"color:grey\">Runtime Error in " ++
35+ " '<br/><span style=\"color:grey\">Runtime Error in " ++
36− intercalate "." names ++ " module:<br>' + e + '</span>');"
36+ intercalate "." names ++ " module:<br/>' + e + '" ++ msg ++ "</span>');"
37 , "document.body.innerHTML = Text.monospace(msg);"
37 , "document.body.innerHTML = Text.monospace(msg);"
38 , "throw e;"
38 , "throw e;"
39 , "};}"
39 , "};}"
40 ]
40 ]
41+ where msg | escapees /= [] = concat [ "<br/><br/>The problem may stem from an improper usage of:<br/>"
42+ , intercalate ", " escapees ]
43+ | otherwise = ""
41
44
42−
43−jsModule (Module names exports imports stmts) =
45+jsModule (escapees, Module names exports imports stmts) =
44− tryBlock (tail modNames) $ concat
46+ tryBlock escapees (tail modNames) $ concat
45 [ concatMap (\n -> globalAssign n $ n ++ " || {}") .
47 [ concatMap (\n -> globalAssign n $ n ++ " || {}") .
46 map (intercalate ".") . drop 2 . inits $
48 map (intercalate ".") . drop 2 . inits $
47 take (length modNames - 1) modNames
49 take (length modNames - 1) modNames
elm/src/Gen/GenerateHtml.hs+5−4
@@ -46,11 +46,12 @@ generateHtml :: String -- ^ Location of elm-min.js as expected by the browser
46generateHtml libLoc title source =
46generateHtml libLoc title source =
47 case initialize source of
47 case initialize source of
48 Left err -> createHtml libLoc title (Right $ showErr err) (H.noscript "")
48 Left err -> createHtml libLoc title (Right $ showErr err) (H.noscript "")
49− Right modul -> modulesToHtml title libLoc [] False [modul]
49+ Right (escs, modul) -> modulesToHtml title libLoc [] True [(escs,modul)]
50
50
51
51
52−modulesToHtml title libLoc jss nscrpt modules = createHtml libLoc title' js noscript
52+modulesToHtml title libLoc jss nscrpt pairs = createHtml libLoc title' js noscript
53+ where modules = map snd pairs
53− where js = Right $ jss ++ concatMap jsModule modules
54+ js = Right $ jss ++ concatMap jsModule pairs
54 noscript = if nscrpt then extract $ last modules else ""
55 noscript = if nscrpt then extract $ last modules else ""
55 title' = if null title then altTitle else title
56 title' = if null title then altTitle else title
56 altTitle = (\(Module names _ _ _) -> intercalate "." names) $
57 altTitle = (\(Module names _ _ _) -> intercalate "." names) $
@@ -60,7 +61,7 @@ modulesToHtml title libLoc jss nscrpt modules = createHtml libLoc title' js nosc
60linkedHtml rtLoc jsLoc modules =
61linkedHtml rtLoc jsLoc modules =
61 createHtml rtLoc title (Left jsLoc) (H.noscript "")
62 createHtml rtLoc title (Left jsLoc) (H.noscript "")
62 where title = (\(Module names _ _ _) -> intercalate "." names) $
63 where title = (\(Module names _ _ _) -> intercalate "." names) $
63− last modules
64+ snd (last modules)
64
65
65
66
66createHtml libLoc title js noscript =
67createHtml libLoc title js noscript =
elm/src/Initialize.hs+2−2
@@ -16,8 +16,8 @@ import Optimize
16initialize str =
16initialize str =
17 let nameOf (Definition n _ _) = n in
17 let nameOf (Definition n _ _) = n in
18 do modul@(Module name ex im stmts) <- parseProgram str
18 do modul@(Module name ex im stmts) <- parseProgram str
19− subs <- unify hints modul
19+ (escapees, subs) <- unify hints modul
20 let modul' = optimize . rename $ Module name ex im' stmts
20 let modul' = optimize . rename $ Module name ex im' stmts
21 where im' | any ((=="Prelude") . fst) im = im
21 where im' | any ((=="Prelude") . fst) im = im
22 | otherwise = ("Prelude", Importing []) : im
22 | otherwise = ("Prelude", Importing []) : im
23− subs `seq` return modul'
23+ subs `seq` return (escapees, modul')
elm/src/Language/Elm.hs+1−1
@@ -71,4 +71,4 @@ toPartsHelper :: String -> (Html, Html, String)
71toPartsHelper source = (html, css, js)
71toPartsHelper source = (html, css, js)
72 where modul = initialize source
72 where modul = initialize source
73 js = either showErr jsModule modul
73 js = either showErr jsModule modul
74− html = widgetBody $ either id extract modul
74+ html = widgetBody $ either id (extract . snd) modul
elm/src/Types/Constrain.hs+3−3
@@ -12,7 +12,7 @@ import Control.Monad.State (evalState)
12import Guid
12import Guid
13import Types.Substitutions
13import Types.Substitutions
14
14
15−import System.IO.Unsafe
15+--import System.IO.Unsafe
16
16
17prints xs v = v --} unsafePerformIO (putStrLn "~~~~~~~~~~" >> mapM print xs) `seq` v
17prints xs v = v --} unsafePerformIO (putStrLn "~~~~~~~~~~" >> mapM print xs) `seq` v
18
18
@@ -27,8 +27,8 @@ constrain hints (Module _ _ _ stmts) = do
27 assumptions <- foldM insert (unionsA ass) $ map fst (concat schemess)
27 assumptions <- foldM insert (unionsA ass) $ map fst (concat schemess)
28 let cs = let f k s vs = map (\v -> Context k $ v :<<: s) vs in
28 let cs = let f k s vs = map (\v -> Context k $ v :<<: s) vs in
29 concat . Map.elems $ Map.intersectionWithKey f allHints assumptions
29 concat . Map.elems $ Map.intersectionWithKey f allHints assumptions
30− let p = unsafePerformIO (mapM print . Map.toList $ Map.difference assumptions allHints)
30+ let escapees = Map.keys $ Map.difference assumptions allHints
31− seq p . return $ cs ++ Set.toList (Set.unions css)
31+ return . (,) escapees $ cs ++ Set.toList (Set.unions css)
32
32
33gen :: Expr -> GuidCounter (Map.Map String [X], Set.Set (Context String Constraint), Type)
33gen :: Expr -> GuidCounter (Map.Map String [X], Set.Set (Context String Constraint), Type)
34
34
elm/src/Types/Unify.hs+3−2
@@ -16,8 +16,9 @@ import Types.Substitutions
16prints xs v = v --} unsafePerformIO (putStrLn "----------" >> mapM print xs) `seq` v
16prints xs v = v --} unsafePerformIO (putStrLn "----------" >> mapM print xs) `seq` v
17
17
18unify hints modul = run $ do
18unify hints modul = run $ do
19− cs <- constrain hints modul
19+ (escapees, cs) <- constrain hints modul
20− prints cs $ solver cs Map.empty
20+ subs <- solver cs Map.empty
21+ prints cs $ return ((,) escapees `liftM` subs)
21
22
22eq ctx t1 t2 = Context ctx (t1 :=: t2)
23eq ctx t1 t2 = Context ctx (t1 :=: t2)
23
24