@@ -2,7 +2,7 @@ module CompileToJS (showErr, jsModule) where
22
33import Ast
44import Context
5−import Control.Arrow (first)
5+import Control.Arrow (first,second)
66import Control.Monad (liftM,(<=<),join,ap)
77import Data.Char (isAlpha,isDigit)
88import Data.List (intercalate,sortBy,inits,foldl')
@@ -181,31 +181,23 @@ toJS' (C txt span expr) =
181181 Case e cases -> caseToJS span e cases
182182 _ -> toJS expr
183183
184−recordToJS e loop cmds =
185− do e' <- toJS' e
186− return $ jsFunc "" (concat [ assign "r" "{}"
187− , assign "e" e'
188− , "\nfor(var i in e){", loop, "}"
189− , cmds
190− , ret "r" ]) ++ "()"
191−
192−remove x = concat [ "\n if (i!='", x, "') { r[i]=e[i]; }"
193− , "\n else if (e[i].length>1) { r[i]=e[i].slice(1); }" ]
194−addField (x,e) = ((++add) . assign "v") `liftM` toJS' e
195− where add = concat [ "\n r.", x, " = '", x, "' in r ? [v].concat(r.", x, ") : [v];" ]
196−setField (x,e) = let rx = "r." ++ x in
197− do set <- globalAssign (rx ++ "[0]") `liftM` toJS' e
198− return (globalAssign rx (rx ++ ".slice(0)") ++ set)
199−access x e = jsFunc "r" (ret body) ++ parens e
200− where body = "'_' in r ? r." ++ x ++ "[0] : r." ++ x
201−makeRecord kvs = do
202− kvs' <- (Map.toList . foldl' combine Map.empty) `liftM` mapM prep kvs
203− let fs = map (\(k,vs) -> k ++ " : " ++ jsList vs) kvs' ++ ["_ : true"]
204− return $ braces ("\n " ++ intercalate ",\n " fs)
205− where combine r (k,v) = Map.insertWith (++) k v r
206− prep (k, as, e@(C t s _)) =
207− do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) e as)
208− return (k,[v])
184+remove x e = "elmRecordRemove('" ++ x ++ "', " ++ e ++ ")"
185+addField x v e = "elmRecordInsert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
186+setField fs e = "elmRecordReplace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
187+ where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
188+access x e = parens e ++ "." ++ x
189+makeRecord kvs = record `liftM` collect kvs
190+ where
191+ combine r (k,v) = Map.insertWith (++) k v r
192+ collect = liftM (foldl' combine Map.empty) . mapM prep
193+ prep (k, as, e@(C t s _)) =
194+ do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) e as)
195+ return (k,[v])
196+ fields fs =
197+ braces ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
198+ hidden = fields . map (second jsList) .
199+ filter (not . null . snd) . Map.toList . Map.map tail
200+ record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
209201
210202
211203instance ToJS Expr where
@@ -219,9 +211,10 @@ instance ToJS Expr where
219211 Boolean b -> return $ if b then "true" else "false"
220212 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
221213 Access e x -> access x `liftM` toJS' e
222− Remove e x -> recordToJS e (remove x) ""
223− Insert e x v -> recordToJS e "r[i]=e[i];" =<< addField (x,v)
224− Modify e fs -> recordToJS e "r[i]=e[i];" . concat =<< mapM setField fs
214+ Remove e x -> remove x `liftM` toJS' e
215+ Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
216+ Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
217+ setField fs' `liftM` toJS' e
225218 Record fs -> makeRecord fs
226219 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
227220