git.iko.soy/elk
on master help sign in
Add the ability to define custom infix operators.
1ad6801evancz
elm/src/Ast.hs+8−6
compare with master
unifiedsplit
@@ -34,17 +34,18 @@ data Expr = IntNum Int
34 | Fold Expr Expr Expr
34 | Fold Expr Expr Expr
35 | Async Expr
35 | Async Expr
36 | Input String
36 | Input String
37− | Let [Definition] Expr
37+ | Let [Def] Expr
38 | Var String
38 | Var String
39 | Case Expr [(Pattern,Expr)]
39 | Case Expr [(Pattern,Expr)]
40 | Data String [Expr]
40 | Data String [Expr]
41 | Markdown Pandoc.Pandoc
41 | Markdown Pandoc.Pandoc
42 deriving (Eq)
42 deriving (Eq)
43
43
44−data Definition = Definition String [String] Expr
44+data Def = FnDef String [String] Expr
45+ | OpDef String String String Expr
45 deriving (Eq)
46 deriving (Eq)
46
47
47−data Statement = Def String [String] Expr
48+data Statement = Definition Def
48 | Datatype String [X] [(String,[Type])]
49 | Datatype String [X] [(String,[Type])]
49 | ImportEvent String Expr String Type
50 | ImportEvent String Expr String Type
50 | ExportEvent String String Type
51 | ExportEvent String String Type
@@ -105,9 +106,10 @@ instance Show Expr where
105 show (Markdown _) = "[markdown| ... |]"
106 show (Markdown _) = "[markdown| ... |]"
106
107
107
108
108−instance Show Definition where
109+instance Show Def where
109− show (Definition v [] e) = v ++ " = " ++ show e
110+ show (FnDef v [] e) = v ++ " = " ++ show e
110− show (Definition f args e) = f ++ " " ++ intercalate " " args ++ " = " ++ show e
111+ show (FnDef f args e) = f ++ " " ++ intercalate " " args ++ " = " ++ show e
112+ show (OpDef op a1 a2 e) = intercalate " " [a1,op,a2] ++ " = " ++ show e
111
113
112getLambdas (Lambda x e) = (x:xs,e')
114getLambdas (Lambda x e) = (x:xs,e')
113 where (xs,e') = getLambdas e
115 where (xs,e') = getLambdas e
elm/src/Gen/CompileToJS.hs+102−79
@@ -7,7 +7,7 @@ import Control.Monad (liftM,(<=<),join,ap)
7import Data.Char (isAlpha,isDigit)
7import Data.Char (isAlpha,isDigit)
8import Data.List (intercalate,sortBy,inits,foldl')
8import Data.List (intercalate,sortBy,inits,foldl')
9import Data.Map (toList)
9import Data.Map (toList)
10−import Data.Maybe (mapMaybe)
10+import Data.Either (partitionEithers)
11import qualified Text.Pandoc as Pan
11import qualified Text.Pandoc as Pan
12
12
13import Initialize
13import Initialize
@@ -16,7 +16,7 @@ import Cases
16import Guid
16import Guid
17
17
18showErr :: String -> String
18showErr :: String -> String
19−showErr err = mainEquals $ "text(monospace(" ++ msg ++ "))"
19+showErr err = mainEquals $ "Elm.Graphics.text(Elm.Text.monospace(" ++ msg ++ "))"
20 where msg = show . concatMap (++"<br>") . lines $ err
20 where msg = show . concatMap (++"<br>") . lines $ err
21
21
22indent = concatMap f
22indent = concatMap f
@@ -55,7 +55,8 @@ tryBlock escapees names e =
55
55
56jsModule (escapees, Module names exports imports stmts) =
56jsModule (escapees, Module names exports imports stmts) =
57 tryBlock escapees (tail modNames) $ concat
57 tryBlock escapees (tail modNames) $ concat
58+ [ assign "$op" "{}"
58− [ "\nfor(this['i'] in Elm) { eval('var ' + this['i'] + '=Elm[this.i];'); }"
59+ , "\nfor(this['i'] in Elm){eval('var '+this['i']+'=Elm[this.i];');}"
59 , concatMap (\n -> globalAssign n $ n ++ " || {}") .
60 , concatMap (\n -> globalAssign n $ n ++ " || {}") .
60 map (intercalate ".") . drop 2 . inits $
61 map (intercalate ".") . drop 2 . inits $
61 take (length modNames - 1) modNames
62 take (length modNames - 1) modNames
@@ -71,22 +72,31 @@ jsModule (escapees, Module names exports imports stmts) =
71 export = getExports exports stmts
72 export = getExports exports stmts
72 exps = if null exports then ["main"] else exports
73 exps = if null exports then ["main"] else exports
73
74
74−getExports names stmts = ret . braces $ intercalate "," pairs
75+getExports names stmts = ret . braces $ intercalate ",\n" (op : map fnPair fns)
75− where pairs = mapMaybe pair $ concatMap get stmts
76+ where exNames n = either id id n `elem` names
76− pair x = if null names || y `elem` names then
77+ exports | null names = concatMap get stmts
77− Just $ y ++ ":" ++ x else Nothing
78+ | otherwise = filter exNames (concatMap get stmts)
78− where y = derename x
79+
79− get s = case s of Def x _ _ -> [x]
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 ]
80− Datatype _ _ tcs -> map fst tcs
90+ Datatype _ _ tcs -> map (Left . fst) tcs
81− ImportEvent _ _ x _ -> [x]
91+ ImportEvent _ _ x _ -> [ Left x ]
82 ExportEvent _ _ _ -> []
92 ExportEvent _ _ _ -> []
83
93
84
94
85jsImport (modul, how) =
95jsImport (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 '"
87 , drop 1 (dropWhile (/='.') modul)
97 , drop 1 (dropWhile (/='.') modul)
88 , "' is missing. Compile with --make flag or load missing "
98 , "' is missing. Compile with --make flag or load missing "
89− , "module in a separate JavaScript file.\";}" ] ++
99+ , "module in a separate JavaScript file.\");\n}" ] ++
90 jsImport' (modul, how)
100 jsImport' (modul, how)
91
101
92jsImport' (modul, As name) = assign name modul
102jsImport' (modul, As name) = assign name modul
@@ -95,44 +105,56 @@ jsImport' (modul, Importing vs) =
95jsImport' (modul, Hiding vs) =
105jsImport' (modul, Hiding vs) =
96 concat [ assign "hiddenVars" . ("{"++) . (++"}") . intercalate "," $
106 concat [ assign "hiddenVars" . ("{"++) . (++"}") . intercalate "," $
97 map (\v -> v ++ ":true") vs
107 map (\v -> v ++ ":true") vs
98− , "\nfor(this['i'] in " ++ modul ++ "){"
108+ , "\nfor (this['i'] in " ++ modul ++ ") "
109+ , braces . indent . concat $
99− , indent $ "\nif (hiddenVars[i]) continue;"
110+ [ "\nif (hiddenVars[this['i']]) continue;"
100− , indent $ "\neval('var ' + this['i'] + ' = " ++ modul ++ "[this.i];');"
111+ , "\neval('var ' + this['i'] + ' = "
101− , "}" ]
112+ , modul, "[this.i];');" ]
113+ ]
102
114
103stmtsToJS :: [Statement] -> String
115stmtsToJS :: [Statement] -> String
104−stmtsToJS stmts = concatMap stmtToJS (sortBy cmpStmt stmts)
116+stmtsToJS stmts = run (concat `liftM` mapM toJS (sortBy cmpStmt stmts))
105 where cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
117 where cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
106− valueOf s = case s of Datatype _ _ _ -> 1
118+ valueOf s = case s of Datatype _ _ _ -> 1
107− ImportEvent _ _ _ _ -> 3
119+ ImportEvent _ _ _ _ -> 3
108− Def _ [] _ -> 3
120+ Definition (FnDef _ [] _) -> 3
109− Def _ _ _ -> 4
121+ Definition (OpDef _ _ _ _) -> 3
122+ Definition _ -> 4
110− ExportEvent _ _ _ -> 5
123+ ExportEvent _ _ _ -> 5
111−
124+
112−stmtToJS :: Statement -> String
125+class ToJS a where
126+ toJS :: a -> GuidCounter String
127+
128+instance ToJS Def where
113−stmtToJS (Def name [] e) = assign name (toJS e)
129+ toJS (FnDef x [] e) = assign x `liftM` toJS e
114−stmtToJS (Def name (a:as) e) = "\nfunction " ++ name ++ parens a ++
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) =
115− braces (indent . ret . toJS $ foldr Lambda e as) ++ ";"
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
116−stmtToJS (Datatype _ _ tcs) = concatMap (stmtToJS . toDef) tcs
139+ toJS (Datatype _ _ tcs) = concat `liftM` mapM (toJS . toDef) tcs
140+ where toDef (name,args) =
117− where toDef (name,args) = Def name vars $ Data (derename name) (map Var vars)
141+ Definition . FnDef name vars $ Data (derename name) (map Var vars)
118− where vars = map (('a':) . show) [1..length args]
142+ where vars = map (('a':) . show) [1..length args]
119−stmtToJS (ImportEvent js base elm _) =
143+ toJS (ImportEvent js base elm _) =
144+ do v <- toJS base
120− concat [ "\nvar " ++ elm ++ " = Elm.Signal.constant(" ++ toJS base ++ ");"
145+ return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal.constant(" ++ v ++ ");"
121− , "\nValue.addListener(document, '" ++ js
146+ , "\nValue.addListener(document, '" ++ js
122− , "', function(e) { Dispatcher.notify(" ++ elm
147+ , "', function(e) { Dispatcher.notify(" ++ elm
123− , ".id, e.value); });" ]
148+ , ".id, e.value); });" ]
124−stmtToJS (ExportEvent js elm _) =
149+ toJS (ExportEvent js elm _) =
150+ return $ concat [ "\nlift(function(v) { "
125− concat [ "\nlift(function(v) { var e = document.createEvent('Event');"
151+ , "var e = document.createEvent('Event');"
126− , "e.initEvent('" ++ js ++ "', true, true);"
152+ , "e.initEvent('", js, "', true, true);"
127− , "e.value = v;"
153+ , "e.value = v;"
128− , "document.dispatchEvent(e); return v; })(" ++ elm ++ ");"
154+ , "document.dispatchEvent(e); return v; })(", elm, ");" ]
129− ]
155+
130−
156+instance ToJS Expr where
131−
132−toJS = run . toJS'
133−
134−toJS' :: Expr -> GuidCounter String
135−toJS' expr =
157+ toJS expr =
136 case expr of
158 case expr of
137 IntNum n -> return $ show n
159 IntNum n -> return $ show n
138 FloatNum n -> return $ show n
160 FloatNum n -> return $ show n
@@ -140,18 +162,18 @@ toJS' expr =
140 Chr c -> return $ show c
162 Chr c -> return $ show c
141 Str s -> return $ "Value.str" ++ parens (show s)
163 Str s -> return $ "Value.str" ++ parens (show s)
142 Boolean b -> return $ if b then "true" else "false"
164 Boolean b -> return $ if b then "true" else "false"
143− Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
165+ Range lo hi -> jsRange `liftM` toJS lo `ap` toJS hi
144− Access e lbl -> (\s -> s ++ "." ++ lbl) `liftM` toJS' e
166+ Access e lbl -> (\s -> s ++ "." ++ lbl) `liftM` toJS e
145− Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
167+ 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)
168+ 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)
169+ Lambda v e -> liftM (jsFunc v . ret) (toJS e)
148 App (Var "toText") (Str s) -> return $ "toText" ++ parens (show s)
170 App (Var "toText") (Str s) -> return $ "toText" ++ parens (show s)
149 App (Var "link") (Str s) -> return $ "link(" ++ show s ++ ")"
171 App (Var "link") (Str s) -> return $ "link(" ++ show s ++ ")"
150 App (Var "plainText") (Str s) -> return $ "plainText(" ++ show s ++ ")"
172 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)
152 Let defs e -> jsLet defs e
174 Let defs e -> jsLet defs e
153 Case e cases -> caseToJS e cases
175 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
155 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
177 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
156 where md = formatMarkdown $ Pan.writeHtmlString Pan.defaultWriterOptions doc
178 where md = formatMarkdown $ Pan.writeHtmlString Pan.defaultWriterOptions doc
157 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
179 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
@@ -163,20 +185,17 @@ formatMarkdown = concatMap f
163 f c = [c]
185 f c = [c]
164
186
165jsLet defs e' = do
187jsLet defs e' = do
166− body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS' e')
188+ body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS e')
167 return $ jsFunc "" body ++ "()"
189 return $ jsFunc "" body ++ "()"
168
190
169−jsDefs defs = concat `liftM` mapM toDef (sortBy f defs)
191+jsDefs defs = concat `liftM` mapM toJS (sortBy f defs)
170 where f a b = compare (valueOf a) (valueOf b)
192 where f a b = compare (valueOf a) (valueOf b)
171− valueOf (Definition _ args _) = min 1 (length args)
193+ valueOf (FnDef _ args _) = min 1 (length args)
172− toDef (Definition x [] e) = assign x `liftM` toJS' e
194+ valueOf (OpDef _ _ _ _) = 1
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) ++ ";"
176
195
177caseToJS e ps = do
196caseToJS e ps = do
178 match <- caseToMatch ps
197 match <- caseToMatch ps
179− e' <- toJS' e
198+ e' <- toJS e
180 (match',stmt) <- case (match,e) of
199 (match',stmt) <- case (match,e) of
181 (Match name _ _, Var x) -> return (matchSubst [(name,x)] match, "")
200 (Match name _ _, Var x) -> return (matchSubst [(name,x)] match, "")
182 (Match name _ _, _ ) -> return (match, assign name e')
201 (Match name _ _, _ ) -> return (match, assign name e')
@@ -190,7 +209,7 @@ matchToJS (Match name clauses def) = do
190 return $ concat [ "\nswitch(", name, "[0]){", indent cases, "\n}", finally ]
209 return $ concat [ "\nswitch(", name, "[0]){", indent cases, "\n}", finally ]
191matchToJS Fail = return "\nthrow \"Non-exhaustive pattern match in case\";"
210matchToJS Fail = return "\nthrow \"Non-exhaustive pattern match in case\";"
192matchToJS Break = return "break;"
211matchToJS Break = return "break;"
193−matchToJS (Other e) = ret `liftM` toJS' e
212+matchToJS (Other e) = ret `liftM` toJS e
194matchToJS (Seq ms) = concat `liftM` mapM matchToJS ms
213matchToJS (Seq ms) = concat `liftM` mapM matchToJS ms
195
214
196clauseToJS var (Clause name vars e) = do
215clauseToJS var (Clause name vars e) = do
@@ -207,20 +226,24 @@ jsRange e1 e2 = (++"()") . jsFunc "" $
207
226
208binop (o:p) e1 e2
227binop (o:p) e1 e2
209 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
228 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
210− | otherwise = case o:p of
229+ | otherwise =
230+ let ops = ["+","-","*","/","&&","||"] in
231+ case o:p of
211− ":" -> jsCons e1 e2
232+ ":" -> jsCons e1 e2
212− "++" -> append e1 e2
233+ "++" -> append e1 e2
213− "$" -> e1 ++ parens e2
234+ "$" -> e1 ++ parens e2
214− "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
235+ "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
215− "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
236+ "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
216− "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
237+ "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
217− "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
238+ "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
218− "<" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'LT')"
239+ "<" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'LT')"
219− ">" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'GT')"
240+ ">" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'GT')"
220− "<=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0]; return ord === 'LT' || ord === 'EQ'; }()"
241+ "<=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
242+ e2 ++ ")[0]; return ord==='LT' || ord==='EQ'; }()"
221− ">=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0]; return ord === 'GT' || ord === 'EQ'; }()"
243+ ">=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
222− ">>>" -> "composeAuto(" ++ e1 ++ ")(" ++ e2 ++ ")"
244+ e2 ++ ")[0]; return ord==='GT' || ord==='EQ'; }()"
223− "<<<" -> "composeAuto(" ++ e2 ++ ")(" ++ e1 ++ ")"
224− _ -> parens (e1 ++ (o:p) ++ e2)
245+ _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
246+ | otherwise -> concat [ "$op['", o:p, "']"
247+ , parens e1, parens e2 ]
225
248
226append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)
249append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)
elm/src/Gen/ExtractNoscript.hs+32−13
@@ -1,37 +1,56 @@
1
1
2−module ExtractNoscript (extract) where
2+module ExtractNoscript (extractNoscript) where
3
3
4import Ast
4import Ast
5import qualified Text.Pandoc as Pan
5import qualified Text.Pandoc as Pan
6
6
7−extract (Module _ _ _ stmts) =
7+extractNoscript :: Module -> String
8− concatMap (\s -> "<p>" ++ s ++ "</p>") (concatMap stmtExtract stmts)
8+extractNoscript modul = concat (extract modul)
9− where stmtExtract (Def _ _ e) = extract' e
10− stmtExtract _ = []
11
9
10+class Extract a where
12−extract' expr =
11+ extract :: a -> [String]
12+
13+instance Extract Module where
14+ extract (Module _ _ _ stmts) =
15+ map (\s -> "<p>" ++ s ++ "</p>") (concatMap extract stmts)
16+
17+instance Extract Statement where
18+ extract (Definition d) = extract d
19+ extract _ = []
20+
21+instance Extract Def where
22+ extract (FnDef _ _ e) = extract e
23+ extract (OpDef _ _ _ e) = extract e
24+
25+instance Extract Expr where
26+ extract expr =
13− let f = extract' in
27+ let f = extract in
14 case expr of
28 case expr of
15 Str s -> [s]
29 Str s -> [s]
16 Binop op e1 e2 -> case (op, f e1, f e2) of
30 Binop op e1 e2 -> case (op, f e1, f e2) of
17 ("++", [s1], [s2]) -> [s1 ++ s2]
31 ("++", [s1], [s2]) -> [s1 ++ s2]
18 (_ , ss1 , ss2 ) -> ss1 ++ ss2
32 (_ , ss1 , ss2 ) -> ss1 ++ ss2
19 Lambda v e -> f e
33 Lambda v e -> f e
20− App (App (Var "link") src) txt ->
34+ App (App (Var "link") src) txt -> linkExtract src txt
21− case (f src, f txt) of
35+ App (App (Var "Graphics.link") src) txt -> linkExtract src txt
22− ([s1],[s2]) -> [ "<a href=\"" ++ s1 ++ "\">" ++ s2 ++ "</a>" ]
36+ App (App (Var "Text.link") src) txt -> linkExtract src txt
23− ( ss1, ss2) -> ss1 ++ ss2
24 App (Var "header") e -> tag "h1" e
37 App (Var "header") e -> tag "h1" e
25 App (Var "bold") e -> tag "b" e
38 App (Var "bold") e -> tag "b" e
26 App (Var "italic") e -> tag "i" e
39 App (Var "italic") e -> tag "i" e
27 App (Var "monospace") e -> tag "code" e
40 App (Var "monospace") e -> tag "code" e
28 App e1 e2 -> f e1 ++ f e2
41 App e1 e2 -> f e1 ++ f e2
29 If eb et ef -> f et ++ f ef
42 If eb et ef -> f et ++ f ef
30− Let defs e -> concatMap (\(Definition _ _ d) -> f d) defs ++ f e
43+ Let defs e -> concatMap extract defs ++ f e
31 Var _ -> []
44 Var _ -> []
32 Case e cases -> concatMap (f . snd) cases
45 Case e cases -> concatMap (f . snd) cases
33 Data _ es -> concatMap f es
46 Data _ es -> concatMap f es
34 Markdown doc -> [ Pan.writeHtmlString Pan.defaultWriterOptions doc ]
47 Markdown doc -> [ Pan.writeHtmlString Pan.defaultWriterOptions doc ]
35 _ -> []
48 _ -> []
36
49
50+linkExtract src txt =
51+ case (extract src, extract txt) of
52+ ([s1],[s2]) -> [ "<a href=\"" ++ s1 ++ "\">" ++ s2 ++ "</a>" ]
53+ ( ss1, ss2) -> ss1 ++ ss2
54+
55+
37−tag t e = map (\s -> concat [ "<", t, ">", s, "</", t, ">" ]) (extract' e)
56+tag t e = map (\s -> concat [ "<", t, ">", s, "</", t, ">" ]) (extract e)
elm/src/Gen/GenerateHtml.hs+3−2
@@ -49,10 +49,11 @@ generateHtml libLoc title source =
49 Right (escs, modul) -> modulesToHtml Readable title libLoc [] True [(escs,modul)]
49 Right (escs, modul) -> modulesToHtml Readable title libLoc [] True [(escs,modul)]
50
50
51
51
52−modulesToHtml jsStyle title libLoc jss nscrpt pairs = createHtml jsStyle libLoc title' js noscript
52+modulesToHtml jsStyle title libLoc jss nscrpt pairs =
53+ createHtml jsStyle libLoc title' js noscript
53 where modules = map snd pairs
54 where modules = map snd pairs
54 js = Right $ jss ++ concatMap jsModule pairs
55 js = Right $ jss ++ concatMap jsModule pairs
55− noscript = if nscrpt then extract $ last modules else ""
56+ noscript = if nscrpt then extractNoscript $ last modules else ""
56 title' = if null title then altTitle else title
57 title' = if null title then altTitle else title
57 altTitle = (\(Module names _ _ _) -> intercalate "." names) $
58 altTitle = (\(Module names _ _ _) -> intercalate "." names) $
58 last modules
59 last modules
elm/src/Initialize.hs+1−2
@@ -14,10 +14,9 @@ import Optimize
14
14
15
15
16initialize str =
16initialize str =
17− let nameOf (Definition n _ _) = n in
18 do modul@(Module name ex im stmts) <- parseProgram str
17 do modul@(Module name ex im stmts) <- parseProgram str
19 (escapees, subs) <- unify hints modul
18 (escapees, subs) <- unify hints modul
20− let modul' = optimize . rename $ Module name ex im' stmts
19+ let modul' = optimize . renameModule $ Module name ex im' stmts
21 where im' | any ((=="Prelude") . fst) im = im
20 where im' | any ((=="Prelude") . fst) im = im
22 | otherwise = ("Prelude", Hiding []) : im
21 | otherwise = ("Prelude", Hiding []) : im
23 subs `seq` return (escapees, modul')
22 subs `seq` return (escapees, modul')
elm/src/Language/Elm.hs+1−1
@@ -79,4 +79,4 @@ toPartsHelper :: String -> (Html, Html, String)
79toPartsHelper source = (html, css, js)
79toPartsHelper source = (html, css, js)
80 where modul = initialize source
80 where modul = initialize source
81 js = either showErr jsModule modul
81 js = either showErr jsModule modul
82− html = widgetBody $ either id (extract . snd) modul
82+ html = widgetBody $ either id (extractNoscript . snd) modul
elm/src/Optimize.hs+17−8
@@ -9,13 +9,23 @@ optimize (Module name ims exs stmts) =
9 Module name ims exs (map optimizeStmt stmts)
9 Module name ims exs (map optimizeStmt stmts)
10
10
11optimizeStmt stmt = if stmt == stmt' then stmt' else optimizeStmt stmt'
11optimizeStmt stmt = if stmt == stmt' then stmt' else optimizeStmt stmt'
12− where stmt' = simpStmt stmt
12+ where stmt' = simp stmt
13− simpStmt (Def name args e) = Def name args (simp e)
14− simpStmt (ImportEvent js b elm t) = ImportEvent js (simp b) elm t
15− simpStmt stmt = stmt
16
13
14+class Simplify a where
17−simp :: Expr -> Expr
15+ simp :: a -> a
16+
17+instance Simplify Statement where
18+ simp (Definition def) = Definition (simp def)
19+ simp (ImportEvent js b elm t) = ImportEvent js (simp b) elm t
20+ simp stmt = stmt
21+
22+instance Simplify Def where
23+ simp (FnDef func args e) = FnDef func args (simp e)
24+ simp (OpDef op a1 a2 e) = OpDef op a1 a2 (simp e)
25+
26+
27+instance Simplify Expr where
18−simp expr =
28+ simp expr =
19 let f = simp in
29 let f = simp in
20 case expr of
30 case expr of
21 Range e1 e2 -> Range (f e1) (f e2)
31 Range e1 e2 -> Range (f e1) (f e2)
@@ -26,8 +36,7 @@ simp expr =
26 where { e1' = f e1 ; e2' = f e2 }
36 where { e1' = f e1 ; e2' = f e2 }
27 App e1 e2 -> App (f e1) (f e2)
37 App e1 e2 -> App (f e1) (f e2)
28 If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)
38 If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)
29− Let defs e -> Let (map simpDef defs) (f e)
39+ Let defs e -> Let (map simp defs) (f e)
30− where simpDef (Definition func args e) = Definition func args (f e)
31 Data name es -> Data name (map f es)
40 Data name es -> Data name (map f es)
32 Case e cases -> Case (f e) (map (second f) cases)
41 Case e cases -> Case (f e) (map (second f) cases)
33 _ -> expr
42 _ -> expr
elm/src/Parse/ParseExpr.hs+18−10
@@ -119,17 +119,25 @@ caseExpr = do
119expr = choice [ ifExpr, letExpr, caseExpr
119expr = choice [ ifExpr, letExpr, caseExpr
120 , lambdaExpr, binaryExpr ] <?> "an expression"
120 , lambdaExpr, binaryExpr ] <?> "an expression"
121
121
122+funcDef = do p1 <- try patternTerm ; infics p1 <|> func p1
123+ where func p@(PVar v) = (p:) <$> spacePrefix patternTerm
124+ func p = do try (lookAhead (whitespace >> string "="))
125+ return [p]
126+ infics p1 = do
127+ o:p <- try (whitespace >> anyOp)
128+ p2 <- (whitespace >> patternTerm)
129+ return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]
130+ else [ PVar (o:p), p1, p2 ]
131+
122assignExpr = do
132assignExpr = do
123− patterns <-
133+ fDefs <- try funcDef
124− choice [ try $ do v <- PVar <$> lowVar
125− notFollowedBy (whitespace >> char ':')
126− (v:) <$> spacePrefix patternTerm
127− , (:[]) <$> patternExpr
134+ <|> ((:[]) <$> patternExpr)
128− ] <?> "the definition of a variable (x = ...)"
135+ <?> "the definition of a variable (x = ...)"
129− whitespace; string "="; whitespace; exp <- expr
136+ whitespace; string "="; whitespace
137+ e <- expr
130− flattenPatterns patterns exp
138+ flattenPatterns fDefs e
131−
139+
132−def = map (\(Definition n as e) -> Def n as e) <$> assignExpr
140+def = map Definition <$> assignExpr
133
141
134
142
135parseDef str =
143parseDef str =
elm/src/Parse/ParseLib.hs+8−4
@@ -40,10 +40,14 @@ reserved word =
40 <?> "reserved word '" ++ word ++ "'"
40 <?> "reserved word '" ++ word ++ "'"
41
41
42anyOp :: (Monad m) => ParsecT [Char] u m String
42anyOp :: (Monad m) => ParsecT [Char] u m String
43−anyOp = betwixt '`' '`' var <|>
43+anyOp = betwixt '`' '`' var <|> symOp <?> "infix operator (e.g. +, *, ||)"
44− (do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")
44+
45+isOp c = isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"
46+
47+symOp :: (Monad m) => ParsecT [Char] u m String
48+symOp = do op <- many1 (satisfy isOp)
45− guard (op `notElem` [ "=", "..", "->", "--" ])
49+ guard (op `notElem` [ "=", "..", "->", "--" ])
46− return op) <?> "infix operator (e.g. +, *, ||)"
50+ return op
47
51
48arrow :: (Monad m) => ParsecT [Char] u m String
52arrow :: (Monad m) => ParsecT [Char] u m String
49arrow = string "->" <|> string "\8594" <?> "arrow (->)"
53arrow = string "->" <|> string "\8594" <?> "arrow (->)"
elm/src/Parse/Patterns.hs+9−4
@@ -38,17 +38,22 @@ makeBody pats body = foldr func body pats
38 func (PVar x) e = e
38 func (PVar x) e = e
39 func p e = Case (Var $ getName p) [(p,e)]
39 func p e = Case (Var $ getName p) [(p,e)]
40
40
41−flattenPatterns (PVar f : args) exp =
41+flattenPatterns (PVar f : args) exp
42+ | isOp (head f) = let [a,b] = (map getName args) in
43+ return [ OpDef f a b (makeBody args exp) ]
42− return [ Definition f (map getName args) (makeBody args exp) ]
44+ | otherwise = return [ FnDef f (map getName args) (makeBody args exp) ]
45+
46+
43flattenPatterns [p] exp = return $ matchSingle p exp p
47flattenPatterns [p] exp = return $ matchSingle p exp p
48+
44flattenPatterns ps _ =
49flattenPatterns ps _ =
45 fail $ "Pattern (" ++ unwords (map show ps) ++
50 fail $ "Pattern (" ++ unwords (map show ps) ++
46 ") cannot be used on the left-hand side of an assign statement."
51 ") cannot be used on the left-hand side of an assign statement."
47
52
48matchSingle pat exp p@(PData _ ps) =
53matchSingle pat exp p@(PData _ ps) =
49− (Definition v [] exp) : concatMap (matchSingle p $ Var v) ps
54+ (FnDef v [] exp) : concatMap (matchSingle p $ Var v) ps
50 where v = getName p
55 where v = getName p
51−matchSingle pat exp (PVar x) = [ Definition x [] (Case exp [(pat,Var x)]) ]
56+matchSingle pat exp (PVar x) = [ FnDef x [] (Case exp [(pat,Var x)]) ]
52matchSingle pat exp PAnything = []
57matchSingle pat exp PAnything = []
53
58
54getName p = f p
59getName p = f p
elm/src/Rename.hs+47−35
@@ -1,5 +1,5 @@
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2−module Rename (rename, derename) where
2+module Rename (renameModule, derename) where
3
3
4import Ast
4import Ast
5import Control.Arrow (first)
5import Control.Arrow (first)
@@ -12,29 +12,45 @@ derename var
12 | isDigit (last var) = reverse . tail . dropWhile isDigit $ reverse var
12 | isDigit (last var) = reverse . tail . dropWhile isDigit $ reverse var
13 | otherwise = var
13 | otherwise = var
14
14
15−rename :: Module -> Module
15+renameModule :: Module -> Module
16−rename (Module name ex im stmts) =
16+renameModule modul = run (rename deprime modul)
17− Module name ex im . run $ renameStatements deprime stmts
17+
18−
18+class Rename a where
19+ rename :: (String -> String) -> a -> GuidCounter a
20+
21+instance Rename Module where
22+ rename env (Module name ex im stmts) = do stmts' <- renameStmts env stmts
23+ return (Module name ex im stmts')
24+
25+instance Rename Def where
26+ rename env (OpDef op a1 a2 e) =
27+ do env' <- extends env [a1,a2]
28+ OpDef op (env' a1) (env' a2) `liftM` rename env' e
29+ rename env (FnDef f args e) =
30+ do env' <- extends env args
31+ FnDef (env f) (map env' args) `liftM` rename env' e
32+
33+instance Rename Statement where
34+ rename env (Definition def) = Definition `liftM` rename env def
35+ rename env (Datatype name args tcs) =
36+ return $ Datatype name args $ map (first env) tcs
37+ rename env (ImportEvent js base elm tipe) =
38+ do base' <- rename env base
39+ return $ ImportEvent js base' (env elm) tipe
40+ rename env (ExportEvent js elm tipe) =
41+ return $ ExportEvent js (env elm) tipe
42+
19−renameStatements env stmts = do env' <- extends env $ concatMap getNames stmts
43+renameStmts env stmts = do env' <- extends env $ concatMap getNames stmts
20− mapM (renameStmt env') stmts
44+ mapM (rename env') stmts
21− where getNames stmt = case stmt of Def n _ _ -> [n]
45+ where getNames stmt = case stmt of
46+ Definition (FnDef n _ _) -> [n]
22− Datatype _ _ tcs -> map fst tcs
47+ Datatype _ _ tcs -> map fst tcs
23− ImportEvent _ _ n _ -> [n]
48+ ImportEvent _ _ n _ -> [n]
24− ExportEvent _ _ _ -> []
49+ _ -> []
25− renameStmt env (Def name args e) =
50+
26− do env' <- extends env args
51+instance Rename Expr where
27− Def (env name) (map env' args) `liftM` rename' env' e
28− renameStmt env (Datatype name args tcs) =
29− return $ Datatype name args $ map (first env) tcs
30− renameStmt env (ImportEvent js base elm tipe) =
31− do base' <- rename' env base
32− return $ ImportEvent js base' (env elm) tipe
33− renameStmt env (ExportEvent js elm tipe) =
34− return $ ExportEvent js (env elm) tipe
35−
36−rename' :: (String -> String) -> Expr -> GuidCounter Expr
37−rename' env expr =
52+ rename env expr =
53+ let rnm = rename env in
38 case expr of
54 case expr of
39
55
40 Range e1 e2 -> Range `liftM` rnm e1
56 Range e1 e2 -> Range `liftM` rnm e1
@@ -52,7 +68,7 @@ rename' env expr =
52
68
53 Lambda x e -> do
69 Lambda x e -> do
54 (rx, env') <- extend env x
70 (rx, env') <- extend env x
55− Lambda rx `liftM` rename' env' e
71+ Lambda rx `liftM` rename env' e
56
72
57 App e1 e2 -> App `liftM` rnm e1
73 App e1 e2 -> App `liftM` rnm e1
58 `ap` rnm e2
74 `ap` rnm e2
@@ -81,8 +97,6 @@ rename' env expr =
81
97
82 _ -> return expr
98 _ -> return expr
83
99
84− where rnm = rename' env
85−
86deprime = map (\c -> if c == '\'' then '_' else c)
100deprime = map (\c -> if c == '\'' then '_' else c)
87
101
88extend :: (String -> String) -> String -> GuidCounter (String, String -> String)
102extend :: (String -> String) -> String -> GuidCounter (String, String -> String)
@@ -107,13 +121,11 @@ patternExtend pattern env =
107patternRename :: (String -> String) -> (Pattern, Expr) -> GuidCounter (Pattern, Expr)
121patternRename :: (String -> String) -> (Pattern, Expr) -> GuidCounter (Pattern, Expr)
108patternRename env (p,e) = do
122patternRename env (p,e) = do
109 (rp,env') <- patternExtend p env
123 (rp,env') <- patternExtend p env
110− re <- rename' env' e
124+ re <- rename env' e
111 return (rp,re)
125 return (rp,re)
112
126
113−renameLet env defs e = do env' <- extends env $ map getNames defs
127+renameLet env defs e = do env' <- extends env $ concatMap getNames defs
114− defs' <- mapM (renameDef env') defs
128+ defs' <- mapM (rename env') defs
115− Let defs' `liftM` rename' env' e
129+ Let defs' `liftM` rename env' e
116− where getNames (Definition n _ _) = n
130+ where getNames (FnDef n _ _) = [n]
117− renameDef env (Definition name args e) =
131+ getNames (OpDef _ _ _ _) = []
118− do env' <- extends env args
119− Definition (env name) (map env' args) `liftM` rename' env' e
elm/src/Substitute.hs+2−1
@@ -19,7 +19,8 @@ subst old new expr =
19 Async e -> Async (f e)
19 Async e -> Async (f e)
20 Input _ -> expr
20 Input _ -> expr
21 Let defs e -> Let (map substDef defs) (f e)
21 Let defs e -> Let (map substDef defs) (f e)
22− where substDef (Definition name vs e) = Definition name vs (f e)
22+ where substDef (FnDef name vs e) = FnDef name vs (f e)
23+ substDef (OpDef op a1 a2 e) = OpDef op a1 a2 (f e)
23 Var x -> if x == old then new else expr
24 Var x -> if x == old then new else expr
24 Case e cases -> Case (f e) $ map (second f) cases
25 Case e cases -> Case (f e) $ map (second f) cases
25 Data name es -> Data name (map f es)
26 Data name es -> Data name (map f es)
elm/src/Types/Constrain.hs+26−22
@@ -81,8 +81,10 @@ gen (Let defs e) =
81 do (as,cs,t) <- gen e
81 do (as,cs,t) <- gen e
82 (ass, schemes) <- liftM unzip (mapM defScheme defs)
82 (ass, schemes) <- liftM unzip (mapM defScheme defs)
83 let assumptions = unionsA (as:ass)
83 let assumptions = unionsA (as:ass)
84+ getName (FnDef f _ _) = f
85+ getName (OpDef op _ _ _) = op
84− let names = map (\(Definition x _ _) -> x) defs
86+ names = map getName defs
85− let genCs name s = do
87+ genCs name s = do
86 v <- guid
88 v <- guid
87 let vs = Map.findWithDefault [v] name assumptions
89 let vs = Map.findWithDefault [v] name assumptions
88 return $ map (\x -> ctx (Var name) $ x :<<: s) vs
90 return $ map (\x -> ctx (Var name) $ x :<<: s) vs
@@ -157,26 +159,28 @@ patternGen (as,cs,ts) p@(PData name ps) = do
157 , ts ++ [output] )
159 , ts ++ [output] )
158
160
159
161
160−defScheme :: Definition -> GuidCounter (Map.Map String [X], Scheme)
162+defScheme :: Def -> GuidCounter (Map.Map String [X], Scheme)
161−defScheme (Definition name args e) = do
162− (as,cs,hint) <- defGen name args e
163+defScheme def = do (as,cs,hint) <- defGen def
163− return ( as, snd hint )
164+ return ( as, snd hint )
164−
165+
166+defGen def = case def of FnDef f args e -> defGen' f args e
167+ OpDef op a1 a2 e -> defGen' op [a1,a2] e
165−defGen name args e = do
168+ where defGen' name args e = do
166− argDict <- mapM (\a -> liftM ((,) a) guid) args
169+ argDict <- mapM (\a -> liftM ((,) a) guid) args
167− (as,cs,t) <- gen e
170+ (as,cs,t) <- gen e
168− let genCs (arg,x) = do
169− v <- guid
170− return . map (\y -> Context arg $ VarT x :=: VarT y) $ Map.findWithDefault [v] arg as
171− cs' <- concat `liftM` mapM genCs argDict
172− let as' = foldr Map.delete as args
171+ let as' = foldr Map.delete as args
173− let tipe = foldr (==>) t $ map (VarT . snd) argDict
172+ tipe = foldr (==>) t $ map (VarT . snd) argDict
173+ genCs (arg,x) = do
174+ v <- guid
175+ let as' = Map.findWithDefault [v] arg as
176+ return $ map (\y -> Context arg $ VarT x :=: VarT y) as'
177+ cs' <- concat `liftM` mapM genCs argDict
174− scheme <- generalize (concat $ Map.elems as') $
178+ scheme <- generalize (concat $ Map.elems as') $
175− Forall (map snd argDict) (cs' ++ Set.toList cs) tipe
179+ Forall (map snd argDict) (cs' ++ Set.toList cs) tipe
176− return ( as', Set.empty, (name, scheme) )
180+ return ( as', Set.empty, (name, scheme) )
177−
181+
178−stmtGen (Def name args e) = do (as,cs,hint) <- defGen name args e
182+stmtGen (Definition def) = do (as,cs,hint) <- defGen def
179− return ( as, cs, [hint] )
183+ return ( as, cs, [hint] )
180
184
181stmtGen (Datatype name xs tcs) = do schemes <- mapM gen' tcs'
185stmtGen (Datatype name xs tcs) = do schemes <- mapM gen' tcs'
182 return (Map.empty, Set.empty, schemes)
186 return (Map.empty, Set.empty, schemes)