c231fc3 · elk · git.iko.soy

git.iko.soy/elk

Add ability to add and remove fields from records:

{ book - title } { book | pages = 100 } From these we can derive renaming fields and replacing values: { book - title | name = book.title } { book - title | title = "Harry Potter" } There is no syntactic short-cut to batch addition and removal of fields in a single expression. There is already a convenient syntax for record updates added in a previous push that lets you do batch updates: { book | title <- "Steppenwolf" , author <- "Hermann Hesse" }

commitc231fc35cd49166c2b3dce9202da7977f66700f0 authorevancz <info@elm-lang.org> dateWed 26 Dec 2012, 16:07 (14 years ago) parentde6cb46

9 files changed+257−138

compare with master

unifiedsplit

core-js/Value.js+24−12 elm/src/Ast.hs+18−5 elm/src/Gen/CompileToJS.hs+69−48 elm/src/Parse/Expr.hs+30−17 elm/src/Parse/Library.hs+18−9 elm/src/Parse/Patterns.hs+65−37 elm/src/Rename.hs+7−2 elm/src/Substitute.hs+3−1 elm/src/Types/Constrain.hs+23−7

core-js/Value.js+24−12

@@ -3,6 +3,11 @@ var Value = function(){

44 var eq = function(x,y) {

55 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+ }

611 if (x === y) return true;

712 if (x.length !== y.length) return false;

813 for (var i = x.length; i--; ) {

@@ -159,20 +164,29 @@ var Value = function(){

159164 }

160165

161166 var toString = function(v) {

162− if (typeof v === "boolean") {

167+ if (typeof v === "function") {

168+ return "<function>";

169+ } else if (typeof v === "boolean") {

163170 return v ? "True" : "False";

164171 } else if (typeof v === "number") {

165172 return v+"";

166173 } else if (typeof v === "string" && v.length < 2) {

167174 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(", ") + " }";

168185 } else if (v[0]) {

169186 if (v[0].substring(0,5) === "Tuple") {

170− var output = "";

171− for (var i = v.length; --i; ) {

172− output = "," + toString(v[i]) + output;

173− }

174− if (output[0] === ",") output = output.substring(1);

175− return "("+output+")";

187+ var output = new Array(v.length-1);

188+ for (var i = v.length; --i; ) { output[i-1] = toString(v[i]); }

189+ return "(" + output.join(",") + ")";

176190 } else if (v[0] === "Cons") {

177191 var start = (typeof v[1] === "string") ? '"' : "[";

178192 var end = (typeof v[1] === "string") ? '"' : "]";

@@ -202,11 +216,9 @@ var Value = function(){

202216 }

203217 return "(" + name + ".fromList " + toString(list) + ")";

204218 } else {

205− var output = "";

206− for (var i = v.length; --i; ) {

207− output = " " + toString(v[i]) + output

208− }

209− output = v[0] + output;

219+ var output = [];

220+ for (var i = v.length; --i; ) { output.push(toString(v[i])); }

221+ output = v[0] + ' ' + output.join(' ');

210222 return (v.length > 1) ? "(" + output + ")" : output;

211223 }

212224 }

elm/src/Ast.hs+18−5

@@ -16,7 +16,10 @@ data ImportMethod = As String | Hiding [String] | Importing [String]

1616 deriving (Eq,Ord)

1717

1818

19−data Pattern = PData String [Pattern] | PVar String | PAnything

19+data Pattern = PData String [Pattern]

20+ | PRecord [String]

21+ | PVar String

22+ | PAnything

2023 deriving (Eq)

2124

2225type CExpr = Context Expr

@@ -27,7 +30,9 @@ data Expr = IntNum Int

2730 | Boolean Bool

2831 | Range CExpr CExpr

2932 | Access CExpr String

30− | Modify CExpr String CExpr

33+ | Remove CExpr String

34+ | Insert CExpr String CExpr

35+ | Modify CExpr [(String,CExpr)]

3136 | Record [(String,[String],CExpr)]

3237 | Binop String CExpr CExpr

3338 | Lambda String CExpr

@@ -65,7 +70,10 @@ pnil = PData "Nil" []

6570plist = foldr pcons pnil

6671ptuple es = PData ("Tuple" ++ show (length es)) es

6772

73+brkt s = "{ " ++ s ++ " }"

74+

6875instance Show Pattern where

76+ show (PRecord fs) = brkt (intercalate ", " fs)

6977 show (PVar x) = x

7078 show PAnything = "_"

7179 show (PData "Cons" [hd@(PData "Cons" _),tl]) =

@@ -89,8 +97,13 @@ instance Show Expr where

8997 Boolean b -> show b

9098 Range e1 e2 -> "[" ++ show e1 ++ ".." ++ show e2 ++ "]"

9199 Access e x -> show' e ++ "." ++ x

92− Modify e x e' -> "{ " ++ show e ++ " | " ++ x ++ " <- " ++ show e' ++ " }"

93− Record r -> "{ " ++ intercalate ", " (map fields r) ++ " }"

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)

104+ Modify e fs -> brkt (show e ++" | "++ intercalate ", " (map field fs))

105+ where field (x,e) = x ++ " <- " ++ show e

106+ Record r -> brkt (intercalate ", " (map fields r))

94107 where fields (f,args,e) = f ++ concatMap (' ':) args ++ " = " ++ show e

95108 Binop op e1 e2 -> show' e1 ++ " " ++ op ++ " " ++ show' e2

96109 Lambda x e -> let (xs,e') = getLambdas (noContext $ Lambda x e) in

@@ -102,7 +115,7 @@ instance Show Expr where

102115 sep = concatMap ("\n | " ++)

103116 Let defs e -> "let { "++intercalate " ; " (map show defs)++" } in "++show e

104117 Var x -> x

105− Case e pats -> "case "++ show e ++" of { "++ intercalate " ; " pats' ++" }"

118+ Case e pats -> "case "++ show e ++" of " ++ brkt (intercalate " ; " pats')

106119 where pats' = map (\(p,e) -> show p ++ " -> " ++ show e) pats

107120 Data name es

108121 | name == "Cons" -> ("["++) . (++"]") . intercalate "," . map show $

elm/src/Gen/CompileToJS.hs+69−48

@@ -6,7 +6,7 @@ import Control.Arrow (first)

66import Control.Monad (liftM,(<=<),join,ap)

77import Data.Char (isAlpha,isDigit)

88import Data.List (intercalate,sortBy,inits,foldl')

9−import Data.Map (toList)

9+import qualified Data.Map as Map

1010import Data.Either (partitionEithers)

1111import qualified Text.Pandoc as Pan

1212

@@ -175,54 +175,75 @@ toJS' (C txt span expr) =

175175 Case e cases -> caseToJS span e cases

176176 _ -> toJS expr

177177

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+

178208instance ToJS Expr where

179− toJS expr =

180− case expr of

181− IntNum n -> return $ show n

182− FloatNum n -> return $ show n

183− Var x -> return $ x

184− Chr c -> return $ quoted [c]

185− Str s -> return $ "Value.str" ++ parens (quoted s)

186− Boolean b -> return $ if b then "true" else "false"

187− Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi

188− Access e lbl -> (\s -> s ++ "." ++ lbl) `liftM` toJS' e

189−

190− Modify e lbl v -> do e' <- toJS' e

191− v' <- toJS' v

192− let body = concat [ assign "r" e'

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

203−

204− If eb et ef ->

205− parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)

206−

207− Lambda v e -> liftM (jsFunc v . ret) (toJS' e)

208−

209− App (C _ _ (Var "toText")) (C _ _ (Str s)) ->

210− return $ "toText" ++ parens (quoted s)

211−

212− App (C _ _ (Var "link")) (C _ _ (Str s)) ->

213− return $ "link(" ++ quoted s ++ ")"

214−

215− App (C _ _ (Var "plainText")) (C _ _ (Str s)) ->

216− return $ "plainText(" ++ quoted s ++ ")"

217−

218− App e1 e2 -> (++) `liftM` (toJS' e1) `ap` (parens `liftM` toJS' e2)

219− Let defs e -> jsLet defs e

220− Data name es -> (\ss -> jsList $ quoted name : ss) `liftM` mapM toJS' es

221−

222− Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"

223− where pad = "<div style=\"height:0;width:0;\"> </div>"

224− md = formatMarkdown $

225− Pan.writeHtmlString Pan.defaultWriterOptions doc

209+ toJS expr =

210+ case expr of

211+ IntNum n -> return $ show n

212+ FloatNum n -> return $ show n

213+ Var x -> return $ x

214+ Chr c -> return $ quoted [c]

215+ Str s -> return $ "Value.str" ++ parens (quoted s)

216+ Boolean b -> return $ if b then "true" else "false"

217+ Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi

218+ Access e x -> access x `liftM` toJS' e

219+ Remove e x -> recordToJS e (remove x) ""

220+ Insert e x v -> recordToJS e "r[i]=e[i];" =<< addField (x,v)

221+ Modify e fs -> recordToJS e "r[i]=e[i];" . concat =<< mapM setField fs

222+ Record fs -> makeRecord fs

223+ Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2

224+

225+ If eb et ef ->

226+ parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)

227+

228+ Lambda v e -> liftM (jsFunc v . ret) (toJS' e)

229+

230+ App (C _ _ (Var "toText")) (C _ _ (Str s)) ->

231+ return $ "toText" ++ parens (quoted s)

232+

233+ App (C _ _ (Var "link")) (C _ _ (Str s)) ->

234+ return $ "link(" ++ quoted s ++ ")"

235+

236+ App (C _ _ (Var "plainText")) (C _ _ (Str s)) ->

237+ return $ "plainText(" ++ quoted s ++ ")"

238+

239+ App e1 e2 -> (++) `liftM` (toJS' e1) `ap` (parens `liftM` toJS' e2)

240+ Let defs e -> jsLet defs e

241+ Data name es -> (\ss -> jsList $ quoted name : ss) `liftM` mapM toJS' es

242+

243+ Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"

244+ where pad = "<div style=\"height:0;width:0;\"> </div>"

245+ md = formatMarkdown $

246+ Pan.writeHtmlString Pan.defaultWriterOptions doc

226247

227248formatMarkdown = concatMap f

228249 where f '\'' = "\\'"

elm/src/Parse/Expr.hs+30−17

@@ -49,10 +49,10 @@ chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))

4949accessor :: IParser Expr

5050accessor = do

5151 start <- getPosition

52− label <- try (string "." >> lowVar)

53− end <- getPosition

54− let ctx e = addCtx ("." ++ label) (pos start end e)

55− return (Lambda "r" (ctx $ Access (ctx $ Var "r") label))

52+ lbl <- try (string "." >> rLabel)

53+ end <- getPosition

54+ let ctx e = addCtx ("." ++ lbl) (pos start end e)

55+ return (Lambda "r" (ctx $ Access (ctx $ Var "r") lbl))

5656

5757

5858-------- Complex Terms --------

@@ -92,27 +92,40 @@ parensTerm = parens $ choice

9292 _ -> pos start end (tuple es)

9393 ]

9494

95−recordTerm :: IParser Expr

96−recordTerm = brackets $ choice [ modify, record ]

95+recordTerm :: IParser CExpr

96+recordTerm = brackets $ choice [ misc, addContext record ]

9797 where field = do

98− fDefs <- (:) <$> (PVar <$> lowVar) <*> spacePrefix patternTerm

98+ fDefs <- (:) <$> (PVar <$> rLabel) <*> spacePrefix patternTerm

9999 whitespace

100100 e <- string "=" >> whitespace >> expr

101− flattenPatterns fDefs e

101+ run $ flattenPatterns fDefs e

102102 extract [ FnDef f args exp ] = return (f,args,exp)

103103 extract _ = fail "Improperly formed record field."

104104 record = Record <$> (mapM extract =<< commaSep field)

105− modify = do

106− record <- try $ do record <- addContext (Var <$> lowVar)

107− whitespace >> string "|" >> whitespace

108− return record

109− label <- lowVar

105+ change = do

106+ lbl <- rLabel

110107 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+

112125

113126term :: IParser CExpr

114127term = addContext (choice [ numTerm, strTerm, chrTerm, listTerm, accessor ])

115− <|> accessible (addContext varTerm <|> parensTerm <|> addContext recordTerm)

128+ <|> accessible (addContext varTerm <|> parensTerm <|> recordTerm)

116129 <?> "basic term (4, x, 'c', etc.)"

117130

118131-------- Applications --------

@@ -147,7 +160,7 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

147160 pats <- spaceSep1 patternTerm

148161 whitespace ; arrow ; whitespace

149162 e <- expr

150− return $ makeLambda pats e

163+ return . run $ makeLambda pats e

151164

152165defSet :: IParser [Def]

153166defSet = concat <$> block (do d <- assignExpr ; whitespace ; return d)

@@ -190,7 +203,7 @@ assignExpr = withPos $ do

190203 fDefs <- funcDef

191204 whitespace

192205 e <- string "=" >> whitespace >> expr

193− flattenPatterns fDefs e

206+ run $ flattenPatterns fDefs e

194207

195208def = map Definition <$> assignExpr

196209

elm/src/Parse/Library.hs+18−9

@@ -6,7 +6,8 @@ import Context

66import Control.Applicative ((<$>),(<*>))

77import Control.Monad

88import Control.Monad.State

9−import Data.Char (isSymbol)

9+import Data.Char (isSymbol,isUpper)

10+import Rename (deprime)

1011import Text.Parsec hiding (newline,spaces,State)

1112import Text.Parsec.Indent

1213

@@ -37,6 +38,9 @@ lowVar = makeVar (lower <?> "lower case variable")

3738capVar :: IParser String

3839capVar = makeVar (upper <?> "upper case variable")

3940

41+rLabel :: IParser String

42+rLabel = deprime <$> lowVar

43+

4044innerVarChar :: IParser Char

4145innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> ""

4246

@@ -127,14 +131,19 @@ addContext expr = do

127131accessible :: IParser CExpr -> IParser CExpr

128132accessible expr = do

129133 start <- getPosition

130− e <- expr

131− access <- optionMaybe . try $ (do { char '.' ; notFollowedBy (char '.') }

132− <?> "field access (e.g. List.map)")

133− case access of

134− Just _ -> accessible $ do v <- var <?> "field access (e.g. List.map)"

135− end <- getPosition

136− return (pos start end (Access e v))

137− Nothing -> return e

134+ ce@(C s t e) <- expr

135+ let rest f = do

136+ let dot = char '.' >> notFollowedBy (char '.')

137+ access <- optionMaybe (try dot <?> "field access (e.g. List.map)")

138+ case access of

139+ Nothing -> return ce

140+ Just _ -> accessible $ do

141+ v <- var <?> "field access (e.g. List.map)"

142+ end <- getPosition

143+ return (pos start end (f v))

144+ case e of Var (c:cs) | isUpper c -> rest (\v -> Var (c:cs ++ '.':v))

145+ | otherwise -> rest (Access ce)

146+ _ -> rest (Access ce)

138147

139148

140149spaces :: IParser String

elm/src/Parse/Patterns.hs+65−37

@@ -1,3 +1,4 @@

12module Parse.Patterns (patternTerm, patternExpr, makeLambda, flattenPatterns) where

34import Ast

@@ -6,6 +7,7 @@ import Control.Applicative ((<$>),(<*>))

67import Control.Monad

78import Control.Monad.State

89import Data.Char (isUpper)

10+import Guid

911import Text.Parsec hiding (newline,spaces,State)

1012import Text.Parsec.Indent

1113import Parse.Library

@@ -17,6 +19,9 @@ patternBasic =

1719 return $ if isUpper c then PData x [] else PVar x

1820 ]

1921

22+patternRecord :: IParser Pattern

23+patternRecord = PRecord <$> brackets (commaSep1 lowVar)

24+

2025patternTuple :: IParser Pattern

2126patternTuple = do ps <- parens (commaSep patternExpr)

2227 return $ case ps of { [p] -> p; _ -> ptuple ps }

@@ -25,7 +30,8 @@ patternList :: IParser Pattern

2530patternList = plist <$> braces (commaSep patternExpr)

2631

2732patternTerm :: IParser Pattern

28−patternTerm = patternTuple <|> patternList <|> patternBasic <?> "pattern"

33+patternTerm = choice [ patternRecord, patternTuple, patternList, patternBasic ]

34+ <?> "pattern"

2935

3036patternConstructor :: IParser Pattern

3137patternConstructor = PData <$> capVar <*> spacePrefix patternTerm

@@ -33,39 +39,61 @@ patternConstructor = PData <$> capVar <*> spacePrefix patternTerm

3339patternExpr :: IParser Pattern

3440patternExpr = foldr1 pcons <$> consSep1 (patternConstructor <|> patternTerm) <?> "pattern"

3541

36−makeLambda :: [Pattern] -> CExpr -> CExpr

37−makeLambda pats body =

38− foldr (\x e -> noContext $ Lambda x e)

39− (makeBody pats body)

40− (map getName pats)

41−

42−makeBody pats body = foldr func body pats

43− where func PAnything e = e

44− func (PVar x) e = e

45− func p (C t s e) = C t s $ Case (C t s . Var $ getName p) [(p,C t s e)]

46−

47−flattenPatterns :: [Pattern] -> CExpr -> IParser [Def]

48−flattenPatterns (PVar f : args) exp

49− | isOp (head f) = let [a,b] = (map getName args) in

50− return [ OpDef f a b (makeBody args exp) ]

51− | otherwise = return [ FnDef f (map getName args) (makeBody args exp) ]

52−

53−

54−flattenPatterns [p] exp = return $ matchSingle p exp p

55−flattenPatterns ps _ =

56− fail $ "Pattern (" ++ unwords (map show ps) ++

57− ") cannot be used on the left-hand side of an assign statement."

58−

59−matchSingle :: Pattern -> CExpr -> Pattern -> [Def]

60−matchSingle pat exp p@(PData _ ps) =

61− (FnDef v [] exp) : concatMap (matchSingle p $ noContext $ Var v) ps

62− where v = getName p

63−matchSingle pat exp (PVar x) =

64− [ FnDef x [] (noContext $ Case exp [(pat, noContext $ Var x)]) ]

65−matchSingle pat exp PAnything = []

66−

67−getName :: Pattern -> String

68−getName p = case p of

69− PData n ps -> n ++ "$" ++ concatMap getName ps

70− PAnything -> "_"

71− PVar x -> x

42+makeLambda :: [Pattern] -> CExpr -> GuidCounter CExpr

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

47+ go ps (C t s $ Lambda x e)

48+

49+extract :: Pattern -> CExpr -> GuidCounter (String, CExpr)

50+extract pattern body@(C t s _) =

51+ let ctx = C t s in

52+ let fn x e = (x,e) in

53+ case pattern of

54+ PAnything -> return $ fn "_" body

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+

72+flattenPatterns :: [Pattern] -> CExpr -> GuidCounter (IParser [Def])

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 $

79+ if isOp (head f) then let [a,b] = as in [ OpDef f a b e ]

80+ else [ FnDef f as e ]

81+

82+ [p] -> return `liftM` matchSingle p exp p

83+

84+ _ -> return . fail $ "Pattern (" ++ unwords (map show patterns) ++

85+ ") cannot be used on the left-hand side of an assign statement."

86+

87+matchSingle :: Pattern -> CExpr -> Pattern -> GuidCounter [Def]

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

93+ dss <- mapM (matchSingle p . ctx $ Var v) ps

94+ return (FnDef v [] exp : concat dss)

95+

96+ PVar x ->

97+ return [ FnDef x [] (ctx $ Case exp [(pat, ctx $ Var x)]) ]

98+

99+ PAnything -> return []

elm/src/Rename.hs+7−2

@@ -63,8 +63,13 @@ instance Rename Expr where

6363 Access e x -> Access `liftM` rnm e

6464 `ap` return x

6565

66− Modify e f v -> flip Modify f `liftM` rnm e

67− `ap` rnm v

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+

71+ Modify e fs -> Modify `liftM` rnm e

72+ `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs

6873

6974 Record fs -> Record `liftM` mapM frnm fs

7075 where frnm (f,as,e) = do env' <- extends env as

elm/src/Substitute.hs+3−1

@@ -10,7 +10,9 @@ subst old new expr =

1010 case expr of

1111 Range e1 e2 -> Range (f e1) (f e2)

1212 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)

1416 Record fs -> Record (map (\(lbl,as,e) -> (lbl,as,f e)) fs)

1517 Binop op e1 e2 -> Binop op (f e1) (f e2)

1618 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) =

138138 c = (ctx' (RecordT fs rtype' :=: rtype))

139139 return (as, Set.insert c cs, t)

140140

141− Modify record label value ->

142− do (ras,rcs,rtype) <- gen record

143− (vas,vcs,vtype) <- gen value

141+ Remove e x ->

142+ do (as,cs,rtype) <- gen e

144143 t <- beta

145144 rtype' <- beta

146− let c = rtype :=: RecordT (Map.singleton label [t]) rtype'

147− return ( unionA ras vas

148− , Set.unions [Set.singleton (ctx' c), rcs, vcs]

149− , RecordT (Map.singleton label [vtype]) 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

151+ return ( unionA eas vas

152+ , Set.union ecs vcs

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 )

150163

151164 Record fields ->

152165 let insert label tipe = Map.insertWith (++) label [tipe]

@@ -281,3 +294,6 @@ getDatatypeInfo (Datatype name args tcs) =

281294 Just (name, args, tcs)

282295getDatatypeInfo _ = Nothing

283296

297+recordT :: [(String,Type)] -> Map.Map String [Type]

298+recordT fields =

299+ foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields