@@ -7,7 +7,7 @@ import Control.Monad (liftM,(<=<),join,ap)
77import Data.Char (isAlpha,isDigit)
88import Data.List (intercalate,sortBy,inits,foldl')
99import Data.Map (toList)
10−import Data.Maybe (mapMaybe)
10+import Data.Either (partitionEithers)
1111import qualified Text.Pandoc as Pan
1212
1313import Initialize
@@ -16,7 +16,7 @@ import Cases
1616import Guid
1717
1818showErr :: String -> String
19−showErr err = mainEquals $ "text(monospace(" ++ msg ++ "))"
19+showErr err = mainEquals $ "Elm.Graphics.text(Elm.Text.monospace(" ++ msg ++ "))"
2020 where msg = show . concatMap (++"<br>") . lines $ err
2121
2222indent = concatMap f
@@ -55,7 +55,8 @@ tryBlock escapees names e =
5555
5656jsModule (escapees, Module names exports imports stmts) =
5757 tryBlock escapees (tail modNames) $ concat
58− [ "\nfor(this['i'] in Elm) { eval('var ' + this['i'] + '=Elm[this.i];'); }"
58+ [ assign "$op" "{}"
59+ , "\nfor(this['i'] in Elm){eval('var '+this['i']+'=Elm[this.i];');}"
5960 , concatMap (\n -> globalAssign n $ n ++ " || {}") .
6061 map (intercalate ".") . drop 2 . inits $
6162 take (length modNames - 1) modNames
@@ -71,22 +72,31 @@ jsModule (escapees, Module names exports imports stmts) =
7172 export = getExports exports stmts
7273 exps = if null exports then ["main"] else exports
7374
74−getExports names stmts = ret . braces $ intercalate "," pairs
75− where pairs = mapMaybe pair $ concatMap get stmts
76− pair x = if null names || y `elem` names then
77− Just $ y ++ ":" ++ x else Nothing
78− where y = derename x
79− get s = case s of Def x _ _ -> [x]
80− Datatype _ _ tcs -> map fst tcs
81− ImportEvent _ _ x _ -> [x]
75+getExports names stmts = ret . braces $ intercalate ",\n" (op : map fnPair fns)
76+ where exNames n = either id id n `elem` names
77+ exports | null names = concatMap get stmts
78+ | otherwise = filter exNames (concatMap get stmts)
79+
80+ (fns,ops) = partitionEithers exports
81+
82+ opPair op = "'" ++ op ++ "' : $op['" ++ op ++ "']"
83+ fnPair fn = let fn' = derename fn in fn' ++ ":" ++ fn
84+
85+ op = ("$op : "++) . braces . intercalate ", " $ map opPair ops
86+
87+ get' (FnDef x _ _) = Left x
88+ get' (OpDef op _ _ _) = Right op
89+ get s = case s of Definition d -> [ get' d ]
90+ Datatype _ _ tcs -> map (Left . fst) tcs
91+ ImportEvent _ _ x _ -> [ Left x ]
8292 ExportEvent _ _ _ -> []
8393
8494
8595jsImport (modul, how) =
86− concat [ "\ntry{if (!(" ++ modul ++ " instanceof Object)) throw 'module not found'; } catch(e) {throw \"Module '"
96+ concat [ "\ntry{\n if (!(" ++ modul ++ " instanceof Object)) throw 'module not found';\n} catch(e) {\n throw (\"Module '"
8797 , drop 1 (dropWhile (/='.') modul)
8898 , "' is missing. Compile with --make flag or load missing "
89− , "module in a separate JavaScript file.\";}" ] ++
99+ , "module in a separate JavaScript file.\");\n}" ] ++
90100 jsImport' (modul, how)
91101
92102jsImport' (modul, As name) = assign name modul
@@ -95,44 +105,56 @@ jsImport' (modul, Importing vs) =
95105jsImport' (modul, Hiding vs) =
96106 concat [ assign "hiddenVars" . ("{"++) . (++"}") . intercalate "," $
97107 map (\v -> v ++ ":true") vs
98− , "\nfor(this['i'] in " ++ modul ++ "){"
99− , indent $ "\nif (hiddenVars[i]) continue;"
100− , indent $ "\neval('var ' + this['i'] + ' = " ++ modul ++ "[this.i];');"
101− , "}" ]
108+ , "\nfor (this['i'] in " ++ modul ++ ") "
109+ , braces . indent . concat $
110+ [ "\nif (hiddenVars[this['i']]) continue;"
111+ , "\neval('var ' + this['i'] + ' = "
112+ , modul, "[this.i];');" ]
113+ ]
102114
103115stmtsToJS :: [Statement] -> String
104−stmtsToJS stmts = concatMap stmtToJS (sortBy cmpStmt stmts)
116+stmtsToJS stmts = run (concat `liftM` mapM toJS (sortBy cmpStmt stmts))
105117 where cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
106− valueOf s = case s of Datatype _ _ _ -> 1
107− ImportEvent _ _ _ _ -> 3
108− Def _ [] _ -> 3
109− Def _ _ _ -> 4
110− ExportEvent _ _ _ -> 5
111−
112−stmtToJS :: Statement -> String
113−stmtToJS (Def name [] e) = assign name (toJS e)
114−stmtToJS (Def name (a:as) e) = "\nfunction " ++ name ++ parens a ++
115− braces (indent . ret . toJS $ foldr Lambda e as) ++ ";"
116−stmtToJS (Datatype _ _ tcs) = concatMap (stmtToJS . toDef) tcs
117− where toDef (name,args) = Def name vars $ Data (derename name) (map Var vars)
118− where vars = map (('a':) . show) [1..length args]
119−stmtToJS (ImportEvent js base elm _) =
120− concat [ "\nvar " ++ elm ++ " = Elm.Signal.constant(" ++ toJS base ++ ");"
121− , "\nValue.addListener(document, '" ++ js
122− , "', function(e) { Dispatcher.notify(" ++ elm
123− , ".id, e.value); });" ]
124−stmtToJS (ExportEvent js elm _) =
125− concat [ "\nlift(function(v) { var e = document.createEvent('Event');"
126− , "e.initEvent('" ++ js ++ "', true, true);"
127− , "e.value = v;"
128− , "document.dispatchEvent(e); return v; })(" ++ elm ++ ");"
129− ]
130−
131−
132−toJS = run . toJS'
133−
134−toJS' :: Expr -> GuidCounter String
135−toJS' expr =
118+ valueOf s = case s of Datatype _ _ _ -> 1
119+ ImportEvent _ _ _ _ -> 3
120+ Definition (FnDef _ [] _) -> 3
121+ Definition (OpDef _ _ _ _) -> 3
122+ Definition _ -> 4
123+ ExportEvent _ _ _ -> 5
124+
125+class ToJS a where
126+ toJS :: a -> GuidCounter String
127+
128+instance ToJS Def where
129+ toJS (FnDef x [] e) = assign x `liftM` toJS e
130+ toJS (FnDef f (a:as) e) =
131+ do body <- toJS (foldr Lambda e as)
132+ return $ concat ["\nfunction ",f,parens a, braces . indent $ ret body]
133+ toJS (OpDef op a1 a2 e) =
134+ do body <- toJS (foldr Lambda e [a1,a2])
135+ return $ concat [ "\n$op['", op, "'] = ", body, ";" ]
136+
137+instance ToJS Statement where
138+ toJS (Definition d) = toJS d
139+ toJS (Datatype _ _ tcs) = concat `liftM` mapM (toJS . toDef) tcs
140+ where toDef (name,args) =
141+ Definition . FnDef name vars $ Data (derename name) (map Var vars)
142+ where vars = map (('a':) . show) [1..length args]
143+ toJS (ImportEvent js base elm _) =
144+ do v <- toJS base
145+ return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal.constant(" ++ v ++ ");"
146+ , "\nValue.addListener(document, '" ++ js
147+ , "', function(e) { Dispatcher.notify(" ++ elm
148+ , ".id, e.value); });" ]
149+ toJS (ExportEvent js elm _) =
150+ return $ concat [ "\nlift(function(v) { "
151+ , "var e = document.createEvent('Event');"
152+ , "e.initEvent('", js, "', true, true);"
153+ , "e.value = v;"
154+ , "document.dispatchEvent(e); return v; })(", elm, ");" ]
155+
156+instance ToJS Expr where
157+ toJS expr =
136158 case expr of
137159 IntNum n -> return $ show n
138160 FloatNum n -> return $ show n
@@ -140,18 +162,18 @@ toJS' expr =
140162 Chr c -> return $ show c
141163 Str s -> return $ "Value.str" ++ parens (show s)
142164 Boolean b -> return $ if b then "true" else "false"
143− Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
144− Access e lbl -> (\s -> s ++ "." ++ lbl) `liftM` toJS' e
145− Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
146− If eb et ef -> parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
147− Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
165+ Range lo hi -> jsRange `liftM` toJS lo `ap` toJS hi
166+ Access e lbl -> (\s -> s ++ "." ++ lbl) `liftM` toJS e
167+ Binop op e1 e2 -> binop op `liftM` toJS e1 `ap` toJS e2
168+ If eb et ef -> parens `liftM` (iff `liftM` toJS eb `ap` toJS et `ap` toJS ef)
169+ Lambda v e -> liftM (jsFunc v . ret) (toJS e)
148170 App (Var "toText") (Str s) -> return $ "toText" ++ parens (show s)
149171 App (Var "link") (Str s) -> return $ "link(" ++ show s ++ ")"
150172 App (Var "plainText") (Str s) -> return $ "plainText(" ++ show s ++ ")"
151− App e1 e2 -> (++) `liftM` (toJS' e1) `ap` (parens `liftM` toJS' e2)
173+ App e1 e2 -> (++) `liftM` (toJS e1) `ap` (parens `liftM` toJS e2)
152174 Let defs e -> jsLet defs e
153175 Case e cases -> caseToJS e cases
154− Data name es -> (\ss -> jsList $ show name : ss) `liftM` mapM toJS' es
176+ Data name es -> (\ss -> jsList $ show name : ss) `liftM` mapM toJS es
155177 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
156178 where md = formatMarkdown $ Pan.writeHtmlString Pan.defaultWriterOptions doc
157179 pad = "<div style=\"height:0;width:0;\"> </div>"
@@ -163,20 +185,17 @@ formatMarkdown = concatMap f
163185 f c = [c]
164186
165187jsLet defs e' = do
166− body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS' e')
188+ body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS e')
167189 return $ jsFunc "" body ++ "()"
168190
169−jsDefs defs = concat `liftM` mapM toDef (sortBy f defs)
191+jsDefs defs = concat `liftM` mapM toJS (sortBy f defs)
170192 where f a b = compare (valueOf a) (valueOf b)
171− valueOf (Definition _ args _) = min 1 (length args)
172− toDef (Definition x [] e) = assign x `liftM` toJS' e
173− toDef (Definition f (a:as) e) = do
174− out <- toJS' $ foldr Lambda e as
175− return $ "\nfunction " ++ f ++ parens a ++ braces (indent $ ret out) ++ ";"
193+ valueOf (FnDef _ args _) = min 1 (length args)
194+ valueOf (OpDef _ _ _ _) = 1
176195
177196caseToJS e ps = do
178197 match <- caseToMatch ps
179− e' <- toJS' e
198+ e' <- toJS e
180199 (match',stmt) <- case (match,e) of
181200 (Match name _ _, Var x) -> return (matchSubst [(name,x)] match, "")
182201 (Match name _ _, _ ) -> return (match, assign name e')
@@ -190,7 +209,7 @@ matchToJS (Match name clauses def) = do
190209 return $ concat [ "\nswitch(", name, "[0]){", indent cases, "\n}", finally ]
191210matchToJS Fail = return "\nthrow \"Non-exhaustive pattern match in case\";"
192211matchToJS Break = return "break;"
193−matchToJS (Other e) = ret `liftM` toJS' e
212+matchToJS (Other e) = ret `liftM` toJS e
194213matchToJS (Seq ms) = concat `liftM` mapM matchToJS ms
195214
196215clauseToJS var (Clause name vars e) = do
@@ -207,20 +226,24 @@ jsRange e1 e2 = (++"()") . jsFunc "" $
207226
208227binop (o:p) e1 e2
209228 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
210− | otherwise = case o:p of
211− ":" -> jsCons e1 e2
212− "++" -> append e1 e2
213− "$" -> e1 ++ parens e2
214− "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
215− "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
216− "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
217− "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
218− "<" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'LT')"
219− ">" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'GT')"
220− "<=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0]; return ord === 'LT' || ord === 'EQ'; }()"
221− ">=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0]; return ord === 'GT' || ord === 'EQ'; }()"
222− ">>>" -> "composeAuto(" ++ e1 ++ ")(" ++ e2 ++ ")"
223− "<<<" -> "composeAuto(" ++ e2 ++ ")(" ++ e1 ++ ")"
224− _ -> parens (e1 ++ (o:p) ++ e2)
229+ | otherwise =
230+ let ops = ["+","-","*","/","&&","||"] in
231+ case o:p of
232+ ":" -> jsCons e1 e2
233+ "++" -> append e1 e2
234+ "$" -> e1 ++ parens e2
235+ "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
236+ "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
237+ "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
238+ "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
239+ "<" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'LT')"
240+ ">" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'GT')"
241+ "<=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
242+ e2 ++ ")[0]; return ord==='LT' || ord==='EQ'; }()"
243+ ">=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
244+ e2 ++ ")[0]; return ord==='GT' || ord==='EQ'; }()"
245+ _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
246+ | otherwise -> concat [ "$op['", o:p, "']"
247+ , parens e1, parens e2 ]
225248
226249append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)