git.iko.soy/elk
on master help sign in
Add ability to add and remove fields from records:
c231fc3evancz
core-js/Value.js+24−12
compare with master
unifiedsplit
@@ -3,6 +3,11 @@ var Value = function(){
3
3
4 var eq = function(x,y) {
4 var eq = function(x,y) {
5 if (typeof x === "object") {
5 if (typeof x === "object") {
6+ if (x.hasOwnProperty('_')) {
7+ for (var i in x) { if (x[i] != y[i]) return false; }
8+ for (var i in y) { if (x[i] != y[i]) return false; }
9+ return true;
10+ }
6 if (x === y) return true;
11 if (x === y) return true;
7 if (x.length !== y.length) return false;
12 if (x.length !== y.length) return false;
8 for (var i = x.length; i--; ) {
13 for (var i = x.length; i--; ) {
@@ -159,20 +164,29 @@ var Value = function(){
159 }
164 }
160
165
161 var toString = function(v) {
166 var toString = function(v) {
162− if (typeof v === "boolean") {
167+ if (typeof v === "function") {
168+ return "<function>";
169+ } else if (typeof v === "boolean") {
163 return v ? "True" : "False";
170 return v ? "True" : "False";
164 } else if (typeof v === "number") {
171 } else if (typeof v === "number") {
165 return v+"";
172 return v+"";
166 } else if (typeof v === "string" && v.length < 2) {
173 } else if (typeof v === "string" && v.length < 2) {
167 return "'"+v+"'";
174 return "'"+v+"'";
175+ } else if (typeof v === "object" && v.hasOwnProperty('_')) {
176+ var output = []
177+ for (var k in v) {
178+ if (k == '_') continue;
179+ for (var i = v[k].length; i--; ) {
180+ output.push(k + " = " + toString(v[k][i]));
181+ }
182+ }
183+ if (output.length === 0) return "{}";
184+ return "{ " + output.join(", ") + " }";
168 } else if (v[0]) {
185 } else if (v[0]) {
169 if (v[0].substring(0,5) === "Tuple") {
186 if (v[0].substring(0,5) === "Tuple") {
170− var output = "";
187+ var output = new Array(v.length-1);
171− for (var i = v.length; --i; ) {
188+ for (var i = v.length; --i; ) { output[i-1] = toString(v[i]); }
172− output = "," + toString(v[i]) + output;
173− }
174− if (output[0] === ",") output = output.substring(1);
175− return "("+output+")";
189+ return "(" + output.join(",") + ")";
176 } else if (v[0] === "Cons") {
190 } else if (v[0] === "Cons") {
177 var start = (typeof v[1] === "string") ? '"' : "[";
191 var start = (typeof v[1] === "string") ? '"' : "[";
178 var end = (typeof v[1] === "string") ? '"' : "]";
192 var end = (typeof v[1] === "string") ? '"' : "]";
@@ -202,11 +216,9 @@ var Value = function(){
202 }
216 }
203 return "(" + name + ".fromList " + toString(list) + ")";
217 return "(" + name + ".fromList " + toString(list) + ")";
204 } else {
218 } else {
205− var output = "";
219+ var output = [];
206− for (var i = v.length; --i; ) {
220+ for (var i = v.length; --i; ) { output.push(toString(v[i])); }
207− output = " " + toString(v[i]) + output
208− }
209− output = v[0] + output;
221+ output = v[0] + ' ' + output.join(' ');
210 return (v.length > 1) ? "(" + output + ")" : output;
222 return (v.length > 1) ? "(" + output + ")" : output;
211 }
223 }
212 }
224 }
elm/src/Ast.hs+18−5
@@ -16,7 +16,10 @@ data ImportMethod = As String | Hiding [String] | Importing [String]
16 deriving (Eq,Ord)
16 deriving (Eq,Ord)
17
17
18
18
19−data Pattern = PData String [Pattern] | PVar String | PAnything
19+data Pattern = PData String [Pattern]
20+ | PRecord [String]
21+ | PVar String
22+ | PAnything
20 deriving (Eq)
23 deriving (Eq)
21
24
22type CExpr = Context Expr
25type CExpr = Context Expr
@@ -27,7 +30,9 @@ data Expr = IntNum Int
27 | Boolean Bool
30 | Boolean Bool
28 | Range CExpr CExpr
31 | Range CExpr CExpr
29 | Access CExpr String
32 | Access CExpr String
33+ | Remove CExpr String
34+ | Insert CExpr String CExpr
30− | Modify CExpr String CExpr
35+ | Modify CExpr [(String,CExpr)]
31 | Record [(String,[String],CExpr)]
36 | Record [(String,[String],CExpr)]
32 | Binop String CExpr CExpr
37 | Binop String CExpr CExpr
33 | Lambda String CExpr
38 | Lambda String CExpr
@@ -65,7 +70,10 @@ pnil = PData "Nil" []
65plist = foldr pcons pnil
70plist = foldr pcons pnil
66ptuple es = PData ("Tuple" ++ show (length es)) es
71ptuple es = PData ("Tuple" ++ show (length es)) es
67
72
73+brkt s = "{ " ++ s ++ " }"
74+
68instance Show Pattern where
75instance Show Pattern where
76+ show (PRecord fs) = brkt (intercalate ", " fs)
69 show (PVar x) = x
77 show (PVar x) = x
70 show PAnything = "_"
78 show PAnything = "_"
71 show (PData "Cons" [hd@(PData "Cons" _),tl]) =
79 show (PData "Cons" [hd@(PData "Cons" _),tl]) =
@@ -89,8 +97,13 @@ instance Show Expr where
89 Boolean b -> show b
97 Boolean b -> show b
90 Range e1 e2 -> "[" ++ show e1 ++ ".." ++ show e2 ++ "]"
98 Range e1 e2 -> "[" ++ show e1 ++ ".." ++ show e2 ++ "]"
91 Access e x -> show' e ++ "." ++ x
99 Access e x -> show' e ++ "." ++ x
100+ Remove e x -> brkt (show e ++ " - " ++ x)
101+ Insert (C _ _ (Remove e y)) x v ->
102+ brkt (show e ++ " - " ++ y ++ " | " ++ x ++ " = " ++ show v)
103+ Insert e x v -> brkt (show e ++ " | " ++ x ++ " = " ++ show v)
92− Modify e x e' -> "{ " ++ show e ++ " | " ++ x ++ " <- " ++ show e' ++ " }"
104+ Modify e fs -> brkt (show e ++" | "++ intercalate ", " (map field fs))
105+ where field (x,e) = x ++ " <- " ++ show e
93− Record r -> "{ " ++ intercalate ", " (map fields r) ++ " }"
106+ Record r -> brkt (intercalate ", " (map fields r))
94 where fields (f,args,e) = f ++ concatMap (' ':) args ++ " = " ++ show e
107 where fields (f,args,e) = f ++ concatMap (' ':) args ++ " = " ++ show e
95 Binop op e1 e2 -> show' e1 ++ " " ++ op ++ " " ++ show' e2
108 Binop op e1 e2 -> show' e1 ++ " " ++ op ++ " " ++ show' e2
96 Lambda x e -> let (xs,e') = getLambdas (noContext $ Lambda x e) in
109 Lambda x e -> let (xs,e') = getLambdas (noContext $ Lambda x e) in
@@ -102,7 +115,7 @@ instance Show Expr where
102 sep = concatMap ("\n | " ++)
115 sep = concatMap ("\n | " ++)
103 Let defs e -> "let { "++intercalate " ; " (map show defs)++" } in "++show e
116 Let defs e -> "let { "++intercalate " ; " (map show defs)++" } in "++show e
104 Var x -> x
117 Var x -> x
105− Case e pats -> "case "++ show e ++" of { "++ intercalate " ; " pats' ++" }"
118+ Case e pats -> "case "++ show e ++" of " ++ brkt (intercalate " ; " pats')
106 where pats' = map (\(p,e) -> show p ++ " -> " ++ show e) pats
119 where pats' = map (\(p,e) -> show p ++ " -> " ++ show e) pats
107 Data name es
120 Data name es
108 | name == "Cons" -> ("["++) . (++"]") . intercalate "," . map show $
121 | name == "Cons" -> ("["++) . (++"]") . intercalate "," . map show $
elm/src/Gen/CompileToJS.hs+69−48
@@ -6,7 +6,7 @@ import Control.Arrow (first)
6import Control.Monad (liftM,(<=<),join,ap)
6import 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')
9−import Data.Map (toList)
9+import qualified Data.Map as Map
10import Data.Either (partitionEithers)
10import Data.Either (partitionEithers)
11import qualified Text.Pandoc as Pan
11import qualified Text.Pandoc as Pan
12
12
@@ -175,54 +175,75 @@ toJS' (C txt span expr) =
175 Case e cases -> caseToJS span e cases
175 Case e cases -> caseToJS span e cases
176 _ -> toJS expr
176 _ -> toJS expr
177
177
178+recordToJS e loop cmds =
179+ do e' <- toJS' e
180+ return $ jsFunc "" (concat [ assign "r" "{_:[true]}"
181+ , assign "e" e'
182+ , "\nfor(var i in e){", loop, "}"
183+ , cmds
184+ , ret "r" ]) ++ "()"
185+
186+remove x = concat [ "\n if (i!='", x, "') { r[i]=e[i]; }"
187+ , "\n else if (e[i].length>1) { r[i]=e[i].slice(1); }" ]
188+addField (x,e) = ((++add) . assign "v") `liftM` toJS' e
189+ where add = concat [ "\nif (r.hasOwnProperty('", x, "')) {"
190+ , "\n r.", x, " = r.", x, ".slice(0);"
191+ , "\n r.", x, ".unshift(v);"
192+ , "\n} else { r.", x, " = [v]; }" ]
193+setField (x,e) = do
194+ set <- globalAssign ("r." ++ x ++ "[0]") `liftM` toJS' e
195+ return (globalAssign ("r." ++ x) ("r." ++ x ++ ".slice(0)") ++ set)
196+access x e = jsFunc "r" (ret body) ++ parens e
197+ where body = "r.hasOwnProperty('_') ? r." ++ x ++ "[0] : r." ++ x
198+makeRecord kvs = do
199+ kvs' <- (Map.toList . foldl' combine Map.empty) `liftM` mapM prep kvs
200+ let fs = map (\(k,vs) -> k ++ " : " ++ jsList vs) kvs' ++ ["_ : [true]"]
201+ return $ "\n " ++ braces (intercalate ",\n " fs)
202+ where combine r (k,v) = Map.insertWith (++) k v r
203+ prep (k, as, e@(C t s _)) =
204+ do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) e as)
205+ return (k,[v])
206+
207+
178instance ToJS Expr where
208instance ToJS Expr where
179− toJS expr =
209+ toJS expr =
180− case expr of
210+ case expr of
181− IntNum n -> return $ show n
211+ IntNum n -> return $ show n
182− FloatNum n -> return $ show n
212+ FloatNum n -> return $ show n
183− Var x -> return $ x
213+ Var x -> return $ x
184− Chr c -> return $ quoted [c]
214+ Chr c -> return $ quoted [c]
185− Str s -> return $ "Value.str" ++ parens (quoted s)
215+ Str s -> return $ "Value.str" ++ parens (quoted s)
186− Boolean b -> return $ if b then "true" else "false"
216+ Boolean b -> return $ if b then "true" else "false"
187− Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
217+ Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
188− Access e lbl -> (\s -> s ++ "." ++ lbl) `liftM` toJS' e
218+ Access e x -> access x `liftM` toJS' e
189−
219+ Remove e x -> recordToJS e (remove x) ""
190− Modify e lbl v -> do e' <- toJS' e
220+ Insert e x v -> recordToJS e "r[i]=e[i];" =<< addField (x,v)
191− v' <- toJS' v
221+ Modify e fs -> recordToJS e "r[i]=e[i];" . concat =<< mapM setField fs
192− let body = concat [ assign "r" e'
222+ Record fs -> makeRecord fs
193− , globalAssign ("r." ++ lbl) v'
194− , ret "r" ]
195− return $ jsFunc "" body ++ "()"
196−
197− Record fs -> (braces . intercalate ",\n") `liftM` mapM toField fs
198− where toField (f, as, ce@(C t s e)) =
199− do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) ce as)
200− return (f ++ " : " ++ v)
201−
202− Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
223+ Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
203−
224+
204− If eb et ef ->
225+ If eb et ef ->
205− parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
226+ parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
206−
227+
207− Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
228+ Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
208−
229+
209− App (C _ _ (Var "toText")) (C _ _ (Str s)) ->
230+ App (C _ _ (Var "toText")) (C _ _ (Str s)) ->
210− return $ "toText" ++ parens (quoted s)
231+ return $ "toText" ++ parens (quoted s)
211−
232+
212− App (C _ _ (Var "link")) (C _ _ (Str s)) ->
233+ App (C _ _ (Var "link")) (C _ _ (Str s)) ->
213− return $ "link(" ++ quoted s ++ ")"
234+ return $ "link(" ++ quoted s ++ ")"
214−
235+
215− App (C _ _ (Var "plainText")) (C _ _ (Str s)) ->
236+ App (C _ _ (Var "plainText")) (C _ _ (Str s)) ->
216− return $ "plainText(" ++ quoted s ++ ")"
237+ return $ "plainText(" ++ quoted s ++ ")"
217−
238+
218− App e1 e2 -> (++) `liftM` (toJS' e1) `ap` (parens `liftM` toJS' e2)
239+ App e1 e2 -> (++) `liftM` (toJS' e1) `ap` (parens `liftM` toJS' e2)
219− Let defs e -> jsLet defs e
240+ Let defs e -> jsLet defs e
220− Data name es -> (\ss -> jsList $ quoted name : ss) `liftM` mapM toJS' es
241+ Data name es -> (\ss -> jsList $ quoted name : ss) `liftM` mapM toJS' es
221−
242+
222− Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
243+ Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
223− where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
244+ where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
224− md = formatMarkdown $
245+ md = formatMarkdown $
225− Pan.writeHtmlString Pan.defaultWriterOptions doc
246+ Pan.writeHtmlString Pan.defaultWriterOptions doc
226
247
227formatMarkdown = concatMap f
248formatMarkdown = concatMap f
228 where f '\'' = "\\'"
249 where f '\'' = "\\'"
elm/src/Parse/Expr.hs+30−17
@@ -49,10 +49,10 @@ chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
49accessor :: IParser Expr
49accessor :: IParser Expr
50accessor = do
50accessor = do
51 start <- getPosition
51 start <- getPosition
52− label <- try (string "." >> lowVar)
52+ lbl <- try (string "." >> rLabel)
53− end <- getPosition
53+ end <- getPosition
54− let ctx e = addCtx ("." ++ label) (pos start end e)
54+ let ctx e = addCtx ("." ++ lbl) (pos start end e)
55− return (Lambda "r" (ctx $ Access (ctx $ Var "r") label))
55+ return (Lambda "r" (ctx $ Access (ctx $ Var "r") lbl))
56
56
57
57
58-------- Complex Terms --------
58-------- Complex Terms --------
@@ -92,27 +92,40 @@ parensTerm = parens $ choice
92 _ -> pos start end (tuple es)
92 _ -> pos start end (tuple es)
93 ]
93 ]
94
94
95−recordTerm :: IParser Expr
95+recordTerm :: IParser CExpr
96−recordTerm = brackets $ choice [ modify, record ]
96+recordTerm = brackets $ choice [ misc, addContext record ]
97 where field = do
97 where field = do
98− fDefs <- (:) <$> (PVar <$> lowVar) <*> spacePrefix patternTerm
98+ fDefs <- (:) <$> (PVar <$> rLabel) <*> spacePrefix patternTerm
99 whitespace
99 whitespace
100 e <- string "=" >> whitespace >> expr
100 e <- string "=" >> whitespace >> expr
101− flattenPatterns fDefs e
101+ run $ flattenPatterns fDefs e
102 extract [ FnDef f args exp ] = return (f,args,exp)
102 extract [ FnDef f args exp ] = return (f,args,exp)
103 extract _ = fail "Improperly formed record field."
103 extract _ = fail "Improperly formed record field."
104 record = Record <$> (mapM extract =<< commaSep field)
104 record = Record <$> (mapM extract =<< commaSep field)
105− modify = do
105+ change = do
106− record <- try $ do record <- addContext (Var <$> lowVar)
106+ lbl <- rLabel
107− whitespace >> string "|" >> whitespace
108− return record
109− label <- lowVar
110 whitespace >> string "<-" >> whitespace
107 whitespace >> string "<-" >> whitespace
111− Modify record label <$> expr
108+ (,) lbl <$> expr
109+ remove r = addContext (string "-" >> whitespace >> Remove r <$> rLabel)
110+ insert r = addContext $ do
111+ string "|" >> whitespace
112+ Insert r <$> rLabel <*>
113+ (whitespace >> string "=" >> whitespace >> expr)
114+ modify r = addContext
115+ (string "|" >> whitespace >> Modify r <$> commaSep1 change)
116+ misc = try $ do
117+ record <- addContext (Var <$> rLabel)
118+ whitespace
119+ opt <- optionMaybe (remove record)
120+ whitespace
121+ case opt of
122+ Just e -> try (insert e) <|> return e
123+ Nothing -> try (insert record) <|> try (modify record)
124+
112
125
113term :: IParser CExpr
126term :: IParser CExpr
114term = addContext (choice [ numTerm, strTerm, chrTerm, listTerm, accessor ])
127term = addContext (choice [ numTerm, strTerm, chrTerm, listTerm, accessor ])
115− <|> accessible (addContext varTerm <|> parensTerm <|> addContext recordTerm)
128+ <|> accessible (addContext varTerm <|> parensTerm <|> recordTerm)
116 <?> "basic term (4, x, 'c', etc.)"
129 <?> "basic term (4, x, 'c', etc.)"
117
130
118-------- Applications --------
131-------- Applications --------
@@ -147,7 +160,7 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
147 pats <- spaceSep1 patternTerm
160 pats <- spaceSep1 patternTerm
148 whitespace ; arrow ; whitespace
161 whitespace ; arrow ; whitespace
149 e <- expr
162 e <- expr
150− return $ makeLambda pats e
163+ return . run $ makeLambda pats e
151
164
152defSet :: IParser [Def]
165defSet :: IParser [Def]
153defSet = concat <$> block (do d <- assignExpr ; whitespace ; return d)
166defSet = concat <$> block (do d <- assignExpr ; whitespace ; return d)
@@ -190,7 +203,7 @@ assignExpr = withPos $ do
190 fDefs <- funcDef
203 fDefs <- funcDef
191 whitespace
204 whitespace
192 e <- string "=" >> whitespace >> expr
205 e <- string "=" >> whitespace >> expr
193− flattenPatterns fDefs e
206+ run $ flattenPatterns fDefs e
194
207
195def = map Definition <$> assignExpr
208def = map Definition <$> assignExpr
196
209
elm/src/Parse/Library.hs+18−9
@@ -6,7 +6,8 @@ import Context
6import Control.Applicative ((<$>),(<*>))
6import Control.Applicative ((<$>),(<*>))
7import Control.Monad
7import Control.Monad
8import Control.Monad.State
8import Control.Monad.State
9−import Data.Char (isSymbol)
9+import Data.Char (isSymbol,isUpper)
10+import Rename (deprime)
10import Text.Parsec hiding (newline,spaces,State)
11import Text.Parsec hiding (newline,spaces,State)
11import Text.Parsec.Indent
12import Text.Parsec.Indent
12
13
@@ -37,6 +38,9 @@ lowVar = makeVar (lower <?> "lower case variable")
37capVar :: IParser String
38capVar :: IParser String
38capVar = makeVar (upper <?> "upper case variable")
39capVar = makeVar (upper <?> "upper case variable")
39
40
41+rLabel :: IParser String
42+rLabel = deprime <$> lowVar
43+
40innerVarChar :: IParser Char
44innerVarChar :: IParser Char
41innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> ""
45innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> ""
42
46
@@ -127,14 +131,19 @@ addContext expr = do
127accessible :: IParser CExpr -> IParser CExpr
131accessible :: IParser CExpr -> IParser CExpr
128accessible expr = do
132accessible expr = do
129 start <- getPosition
133 start <- getPosition
130− e <- expr
134+ ce@(C s t e) <- expr
131− access <- optionMaybe . try $ (do { char '.' ; notFollowedBy (char '.') }
135+ let rest f = do
136+ let dot = char '.' >> notFollowedBy (char '.')
132− <?> "field access (e.g. List.map)")
137+ access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
133− case access of
138+ case access of
139+ Nothing -> return ce
140+ Just _ -> accessible $ do
134− Just _ -> accessible $ do v <- var <?> "field access (e.g. List.map)"
141+ v <- var <?> "field access (e.g. List.map)"
135− end <- getPosition
142+ end <- getPosition
136− return (pos start end (Access e v))
143+ return (pos start end (f v))
137− Nothing -> return e
144+ case e of Var (c:cs) | isUpper c -> rest (\v -> Var (c:cs ++ '.':v))
145+ | otherwise -> rest (Access ce)
146+ _ -> rest (Access ce)
138
147
139
148
140spaces :: IParser String
149spaces :: IParser String
elm/src/Parse/Patterns.hs+65−37
@@ -1,3 +1,4 @@
1+
1module Parse.Patterns (patternTerm, patternExpr, makeLambda, flattenPatterns) where
2module Parse.Patterns (patternTerm, patternExpr, makeLambda, flattenPatterns) where
2
3
3import Ast
4import Ast
@@ -6,6 +7,7 @@ import Control.Applicative ((<$>),(<*>))
6import Control.Monad
7import Control.Monad
7import Control.Monad.State
8import Control.Monad.State
8import Data.Char (isUpper)
9import Data.Char (isUpper)
10+import Guid
9import Text.Parsec hiding (newline,spaces,State)
11import Text.Parsec hiding (newline,spaces,State)
10import Text.Parsec.Indent
12import Text.Parsec.Indent
11import Parse.Library
13import Parse.Library
@@ -17,6 +19,9 @@ patternBasic =
17 return $ if isUpper c then PData x [] else PVar x
19 return $ if isUpper c then PData x [] else PVar x
18 ]
20 ]
19
21
22+patternRecord :: IParser Pattern
23+patternRecord = PRecord <$> brackets (commaSep1 lowVar)
24+
20patternTuple :: IParser Pattern
25patternTuple :: IParser Pattern
21patternTuple = do ps <- parens (commaSep patternExpr)
26patternTuple = do ps <- parens (commaSep patternExpr)
22 return $ case ps of { [p] -> p; _ -> ptuple ps }
27 return $ case ps of { [p] -> p; _ -> ptuple ps }
@@ -25,7 +30,8 @@ patternList :: IParser Pattern
25patternList = plist <$> braces (commaSep patternExpr)
30patternList = plist <$> braces (commaSep patternExpr)
26
31
27patternTerm :: IParser Pattern
32patternTerm :: IParser Pattern
28−patternTerm = patternTuple <|> patternList <|> patternBasic <?> "pattern"
33+patternTerm = choice [ patternRecord, patternTuple, patternList, patternBasic ]
34+ <?> "pattern"
29
35
30patternConstructor :: IParser Pattern
36patternConstructor :: IParser Pattern
31patternConstructor = PData <$> capVar <*> spacePrefix patternTerm
37patternConstructor = PData <$> capVar <*> spacePrefix patternTerm
@@ -33,39 +39,61 @@ patternConstructor = PData <$> capVar <*> spacePrefix patternTerm
33patternExpr :: IParser Pattern
39patternExpr :: IParser Pattern
34patternExpr = foldr1 pcons <$> consSep1 (patternConstructor <|> patternTerm) <?> "pattern"
40patternExpr = foldr1 pcons <$> consSep1 (patternConstructor <|> patternTerm) <?> "pattern"
35
41
36−makeLambda :: [Pattern] -> CExpr -> CExpr
42+makeLambda :: [Pattern] -> CExpr -> GuidCounter CExpr
37−makeLambda pats body =
43+makeLambda pats body = go (reverse pats) body
44+ where go [] body = return body
45+ go (p:ps) body@(C t s _) = do
46+ (x,e) <- extract p body
38− foldr (\x e -> noContext $ Lambda x e)
47+ go ps (C t s $ Lambda x e)
39− (makeBody pats body)
48+
40− (map getName pats)
49+extract :: Pattern -> CExpr -> GuidCounter (String, CExpr)
41−
50+extract pattern body@(C t s _) =
42−makeBody pats body = foldr func body pats
51+ let ctx = C t s in
43− where func PAnything e = e
52+ let fn x e = (x,e) in
44− func (PVar x) e = e
53+ case pattern of
45− func p (C t s e) = C t s $ Case (C t s . Var $ getName p) [(p,C t s e)]
54+ PAnything -> return $ fn "_" body
46−
55+ PVar x -> return $ fn x body
56+ PData name ps -> do
57+ x <- guid
58+ let a = 'a' : show x
59+ return . fn a . ctx $ Case (ctx (Var a)) [(pattern, body)]
60+ PRecord fs -> do
61+ x <- guid
62+ let a = 'a' : show x
63+ toDef f = FnDef f [] (ctx $ Access (ctx $ Var a) f)
64+ return . fn a . ctx $ Let (map toDef fs) body
65+
66+extracts :: [Pattern] -> CExpr -> GuidCounter ([String], CExpr)
67+extracts ps body = go [] (reverse ps) body
68+ where go args [] body = return (args, body)
69+ go args (p:ps) body = do (x,e) <- extract p body
70+ go (x:args) ps e
71+
47−flattenPatterns :: [Pattern] -> CExpr -> IParser [Def]
72+flattenPatterns :: [Pattern] -> CExpr -> GuidCounter (IParser [Def])
48−flattenPatterns (PVar f : args) exp
73+flattenPatterns patterns exp@(C t s _) =
74+ let ctx = C t s in
75+ case patterns of
76+ PVar f : args -> do
77+ (as,e) <- extracts args exp
78+ return . return $
49− | isOp (head f) = let [a,b] = (map getName args) in
79+ if isOp (head f) then let [a,b] = as in [ OpDef f a b e ]
50− return [ OpDef f a b (makeBody args exp) ]
80+ else [ FnDef f as e ]
51− | otherwise = return [ FnDef f (map getName args) (makeBody args exp) ]
81+
52−
53−
54−flattenPatterns [p] exp = return $ matchSingle p exp p
82+ [p] -> return `liftM` matchSingle p exp p
55−flattenPatterns ps _ =
83+
56− fail $ "Pattern (" ++ unwords (map show ps) ++
84+ _ -> return . fail $ "Pattern (" ++ unwords (map show patterns) ++
57− ") cannot be used on the left-hand side of an assign statement."
85+ ") cannot be used on the left-hand side of an assign statement."
58−
86+
59−matchSingle :: Pattern -> CExpr -> Pattern -> [Def]
87+matchSingle :: Pattern -> CExpr -> Pattern -> GuidCounter [Def]
60−matchSingle pat exp p@(PData _ ps) =
88+matchSingle pat exp@(C t s _) p =
89+ let ctx = C t s in
90+ case p of
91+ PData _ ps -> do x <- guid
92+ let v = 'a' : show x
61− (FnDef v [] exp) : concatMap (matchSingle p $ noContext $ Var v) ps
93+ dss <- mapM (matchSingle p . ctx $ Var v) ps
62− where v = getName p
94+ return (FnDef v [] exp : concat dss)
63−matchSingle pat exp (PVar x) =
95+
96+ PVar x ->
64− [ FnDef x [] (noContext $ Case exp [(pat, noContext $ Var x)]) ]
97+ return [ FnDef x [] (ctx $ Case exp [(pat, ctx $ Var x)]) ]
65−matchSingle pat exp PAnything = []
98+
66−
99+ PAnything -> return []
67−getName :: Pattern -> String
68−getName p = case p of
69− PData n ps -> n ++ "$" ++ concatMap getName ps
70− PAnything -> "_"
71− PVar x -> x
elm/src/Rename.hs+7−2
@@ -63,8 +63,13 @@ instance Rename Expr where
63 Access e x -> Access `liftM` rnm e
63 Access e x -> Access `liftM` rnm e
64 `ap` return x
64 `ap` return x
65
65
66+ Remove e x -> flip Remove x `liftM` rnm e
67+
68+ Insert e x v -> flip Insert x `liftM` rnm e
69+ `ap` rnm v
70+
66− Modify e f v -> flip Modify f `liftM` rnm e
71+ Modify e fs -> Modify `liftM` rnm e
67− `ap` rnm v
72+ `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs
68
73
69 Record fs -> Record `liftM` mapM frnm fs
74 Record fs -> Record `liftM` mapM frnm fs
70 where frnm (f,as,e) = do env' <- extends env as
75 where frnm (f,as,e) = do env' <- extends env as
elm/src/Substitute.hs+3−1
@@ -10,7 +10,9 @@ subst old new expr =
10 case expr of
10 case expr of
11 Range e1 e2 -> Range (f e1) (f e2)
11 Range e1 e2 -> Range (f e1) (f e2)
12 Access e x -> Access (f e) x
12 Access e x -> Access (f e) x
13− Modify r lbl v -> Modify (f r) lbl (f v)
13+ Remove e x -> Remove (f e) x
14+ Insert e x v -> Insert (f e) x (f v)
15+ Modify r fs -> Modify (f r) (map (second f) fs)
14 Record fs -> Record (map (\(lbl,as,e) -> (lbl,as,f e)) fs)
16 Record fs -> Record (map (\(lbl,as,e) -> (lbl,as,f e)) fs)
15 Binop op e1 e2 -> Binop op (f e1) (f e2)
17 Binop op e1 e2 -> Binop op (f e1) (f e2)
16 Lambda x e -> if x == old then expr else Lambda x (f e)
18 Lambda x e -> if x == old then expr else Lambda x (f e)
elm/src/Types/Constrain.hs+23−7
@@ -138,15 +138,28 @@ gen (C _ span expr) =
138 c = (ctx' (RecordT fs rtype' :=: rtype))
138 c = (ctx' (RecordT fs rtype' :=: rtype))
139 return (as, Set.insert c cs, t)
139 return (as, Set.insert c cs, t)
140
140
141− Modify record label value ->
141+ Remove e x ->
142− do (ras,rcs,rtype) <- gen record
142+ do (as,cs,rtype) <- gen e
143− (vas,vcs,vtype) <- gen value
144 t <- beta
143 t <- beta
145 rtype' <- beta
144 rtype' <- beta
146− let c = rtype :=: RecordT (Map.singleton label [t]) rtype'
145+ let c = (ctx' (RecordT (Map.singleton x [t]) rtype' :=: rtype))
146+ return (as, Set.insert c cs, rtype')
147+
148+ Insert e x v ->
149+ do (eas,ecs,etype) <- gen e
150+ (vas,vcs,vtype) <- gen v
147− return ( unionA ras vas
151+ return ( unionA eas vas
148− , Set.unions [Set.singleton (ctx' c), rcs, vcs]
152+ , Set.union ecs vcs
149− , RecordT (Map.singleton label [vtype]) rtype' )
153+ , RecordT (Map.singleton x [vtype]) etype )
154+
155+ Modify record fields ->
156+ do (ras,rcs,rtype) <- gen record
157+ (ass,css,newTs) <- unzip3 `liftM` mapM gen (map snd fields)
158+ oldTs <- mapM (\_ -> beta) fields
159+ rtype' <- beta
160+ let rT ts = RecordT (recordT (zip (map fst fields) ts)) rtype'
161+ c = Set.singleton (ctx' (rtype :=: rT oldTs))
162+ return ( unionsA (ras:ass), Set.unions (c : rcs : css), rT newTs )
150
163
151 Record fields ->
164 Record fields ->
152 let insert label tipe = Map.insertWith (++) label [tipe]
165 let insert label tipe = Map.insertWith (++) label [tipe]
@@ -281,3 +294,6 @@ getDatatypeInfo (Datatype name args tcs) =
281 Just (name, args, tcs)
294 Just (name, args, tcs)
282getDatatypeInfo _ = Nothing
295getDatatypeInfo _ = Nothing
283
296
297+recordT :: [(String,Type)] -> Map.Map String [Type]
298+recordT fields =
299+ foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields