de6cb46 · elk · git.iko.soy

elm/src/Ast.hs+3−1

compare with master

unifiedsplit

@@ -27,6 +27,7 @@ data Expr = IntNum Int

27 | Boolean Bool

28 | Range CExpr CExpr

29 | Access CExpr String

30+ | Modify CExpr String CExpr

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

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

31 | Binop String CExpr CExpr

32 | Binop String CExpr CExpr

32 | Lambda String CExpr

33 | Lambda String CExpr

@@ -88,7 +89,8 @@ instance Show Expr where

88 Boolean b -> show b

89 Boolean b -> show b

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

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

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

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

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

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

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

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

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

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

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

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

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

elm/src/Gen/CompileToJS.hs+7

@@ -186,6 +186,13 @@ instance ToJS Expr where

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 ++ "()"

189

196

190 Record fs -> (braces . intercalate ",\n") `liftM` mapM toField fs

197 Record fs -> (braces . intercalate ",\n") `liftM` mapM toField fs

191 where toField (f, as, ce@(C t s e)) =

198 where toField (f, as, ce@(C t s e)) =

elm/src/Parse/Expr.hs+13−18

@@ -93,27 +93,22 @@ parensTerm = parens $ choice

93 ]

94

95recordTerm :: IParser Expr

96−recordTerm = brackets $ do

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

97− Record <$> (mapM extract =<< commaSep field)

98 where field = do

97 where field = do

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

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

100− whitespace

99+ whitespace

101− e <- string "=" >> whitespace >> expr

100+ e <- string "=" >> whitespace >> expr

102− flattenPatterns fDefs e

101+ flattenPatterns fDefs e

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

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

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

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

105−{--

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

106− record <- expr

105+ modify = do

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

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

107+ whitespace >> string "|" >> whitespace

108+ return record

108− label <- lowVar

109+ label <- lowVar

109− whitespace

110+ whitespace >> string "<-" >> whitespace

110− op <- (string "<-" <|> string "=")

111+ Modify record label <$> expr

111− whitespace

112− e <- expr

113− case op of

114− "<-" ->

115− "=" ->

116−--}

117

112

118term :: IParser CExpr

113term :: IParser CExpr

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

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

elm/src/Rename.hs+8

@@ -63,6 +63,14 @@ instance Rename Expr where

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

64 `ap` return x

65

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

67+ `ap` rnm v

68+

69+ Record fs -> Record `liftM` mapM frnm fs

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

71+ e' <- rename env' e

72+ return (f, map env' as, e')

73+

66 Binop op@(h:_) e1 e2 ->

74 Binop op@(h:_) e1 e2 ->

67 let rop = if isLower h || '_' == h

75 let rop = if isLower h || '_' == h

68 then env op

76 then env op

elm/src/Substitute.hs+2

@@ -10,6 +10,8 @@ subst old new expr =

10 case expr of

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

12 Access e x -> Access (f e) x

13+ Modify r lbl v -> Modify (f r) lbl (f v)

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

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

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

14 Lambda x e -> if x == old then expr else Lambda x (f e)

16 Lambda x e -> if x == old then expr else Lambda x (f e)

15 App e1 e2 -> App (f e1) (f e2)

17 App e1 e2 -> App (f e1) (f e2)

elm/src/Types/Constrain.hs+10

@@ -138,6 +138,16 @@ gen (C _ span expr) =

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

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

140

141+ Modify record label value ->

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

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

144+ t <- beta

145+ 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' )

150+

141 Record fields ->

151 Record fields ->

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

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

143 getScheme (f,args,e) = do

153 getScheme (f,args,e) = do