5b263aa · elk · git.iko.soy

5import qualified Data.List as List

6import qualified Data.Map as Map

7import qualified Data.Set as Set

8−import Data.Either (partitionEithers)

8+import qualified Text.Pandoc as Pan

9

10import Generate.Cases

11import SourceSyntax.Everything

21 Right e -> prettyPrint (expression (e :: LExpr () ()))

22 Left err -> error (show err)

23

24+split = go []

25+ where

26+ go vars str =

27+ case break (=='.') str of

28+ (x,'.':rest) -> go (vars ++ [x]) rest

29+ (x,[]) -> vars ++ [x]

30+

24var name = Id () (makeSafe name)

31var name = Id () (makeSafe name)

25ref name = VarRef () (var name)

32ref name = VarRef () (var name)

26prop name = PropId () (var name)

33prop name = PropId () (var name)

30string = StringLit ()

37string = StringLit ()

31

38

32dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)

39dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)

40+get = dotSep . split

33

41

34varDecl x expr =

42varDecl x expr =

35 VarDecl () (var x) (Just expr)

43 VarDecl () (var x) (Just expr)

36

44

37include alias moduleName =

45include alias moduleName =

38− varDecl alias (dotSep moduleName <| ref "elm")

46+ varDecl alias (get moduleName <| ref "elm")

39

47

40internalImports name =

48internalImports name =

41 VarDeclStmt ()

49 VarDeclStmt ()

42− [ varDecl "N" (dotSep ["Elm","Native"])

50+ [ varDecl "N" (get "Elm.Native")

43− , include "_N" ["N","Utils"]

51+ , include "_N" "N.Utils"

44− , include "_L" ["N","List"]

52+ , include "_L" "N.List"

45− , include "_E" ["N","Error"]

53+ , include "_E" "N.Error"

46− , include "_J" ["N","JavaScript"]

54+ , include "_J" "N.JavaScript"

47− , varDecl "_str" (dotSep ["_J","toString"])

55+ , varDecl "_str" (get "_J.toString")

48 , varDecl "$moduleName" (string name)

56 , varDecl "$moduleName" (string name)

49 ]

57 ]

50

58

61 case expr of

69 case expr of

62 Var x -> ref x

70 Var x -> ref x

63 Literal lit -> literal lit

71 Literal lit -> literal lit

64− Range lo hi -> dotSep ["_L","range"] `call` [expression lo, expression hi]

72+ Range lo hi -> get "_L.range" `call` [expression lo, expression hi]

65

73

66 Access e x -> DotRef () (expression e) (var x)

74 Access e x -> DotRef () (expression e) (var x)

67− Remove e x -> dotSep ["_N","remove"] `call` [ref x, expression e]

75+ Remove e x -> get "_N.remove" `call` [ref x, expression e]

68− Insert e x v -> dotSep ["_N","insert"] `call` [ref x, expression v, expression e]

76+ Insert e x v -> get "_N.insert" `call` [ref x, expression v, expression e]

69 Modify e fs ->

77 Modify e fs ->

70 let modify (f,v) = ArrayLit () [ref f, expression e]

78 let modify (f,v) = ArrayLit () [ref f, expression e]

71− in dotSep ["_N","replace"] `call` [ArrayLit () (map modify fs), expression e]

79+ in get "_N.replace" `call` [ArrayLit () (map modify fs), expression e]

72

80

73 Record fields -> ObjectLit () $ (PropId () (var "_"), hidden) : visible

81 Record fields -> ObjectLit () $ (PropId () (var "_"), hidden) : visible

74 where

82 where

123 MultiIf branches ->

131 MultiIf branches ->

124 case last branches of

132 case last branches of

125 (L _ (Var "otherwise"), e) -> ifs (init branches) (expression e)

133 (L _ (Var "otherwise"), e) -> ifs (init branches) (expression e)

126− _ -> ifs branches (dotSep ["_E","If"] `call` [ ref "$moduleName", string (show span) ])

134+ _ -> ifs branches (get "_E.If" `call` [ ref "$moduleName", string (show span) ])

127 where

135 where

128 ifs branches finally = foldr iff finally branches

136 ifs branches finally = foldr iff finally branches

129 iff (if', then') else' = CondExpr () (expression if') (expression then') else'

137 iff (if', then') else' = CondExpr () (expression if') (expression then') else'

138 in (initialMatch, [VarDeclStmt () [decl]])

146 in (initialMatch, [VarDeclStmt () [decl]])

139

147

140 ExplicitList es ->

148 ExplicitList es ->

141− dotSep ["_J","toList"] <| ArrayLit () (map expression es)

149+ get "_J.toList" <| ArrayLit () (map expression es)

142

150

143 Data name es ->

151 Data name es ->

144 ObjectLit () (ctor : fields)

152 ObjectLit () (ctor : fields)

145 where

153 where

146 ctor = (prop "ctor", string (makeSafe name))

154 ctor = (prop "ctor", string (makeSafe name))

147 fields = zipWith (\n e -> (prop ("_" ++ show n), expression e)) [0..] es

155 fields = zipWith (\n e -> (prop ("_" ++ show n), expression e)) [0..] es

148−{--

156+

149− Markdown doc -> return $ "Text.text('" ++ pad ++ md ++ pad ++ "')"

157+ Markdown doc -> get "Text.text" <| string (pad ++ md ++ pad)

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

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

151− md = formatMarkdown $ Pan.writeHtmlString Pan.def doc

159+ md = Pan.writeHtmlString Pan.def doc

152−--}

160+

153

161

154definition def =

162definition def =

155 case def of

163 case def of

166

174

167 PRecord fields -> VarDeclStmt () (assign "$" : map setField fields)

175 PRecord fields -> VarDeclStmt () (assign "$" : map setField fields)

168 where

176 where

169− setField f = VarDecl () (var f) (Just (dotSep ["$",f]))

177+ setField f = VarDecl () (var f) (Just $ dotSep ["$",f])

170

178

171 PData name patterns | vars /= Nothing ->

179 PData name patterns | vars /= Nothing ->

172 case vars of

180 case vars of

185 | otherwise = safeAssign : vars

193 | otherwise = safeAssign : vars

186

194

187 safeAssign = VarDecl () (var "$") (Just $ CondExpr () if' (expression expr) exception)

195 safeAssign = VarDecl () (var "$") (Just $ CondExpr () if' (expression expr) exception)

188− if' = InfixExpr () OpStrictEq (dotSep ["$","ctor"]) (string name)

196+ if' = InfixExpr () OpStrictEq (get "$.ctor") (string name)

189− exception = dotSep ["_E","Case"] `call` [ref "$moduleName", string (show span)]

197+ exception = get "_E.Case" `call` [ref "$moduleName", string (show span)]

190

198

191 _ -> BlockStmt () ( VarDeclStmt () [assign "$"] : map toDef vars )

199 _ -> BlockStmt () ( VarDeclStmt () [assign "$"] : map toDef vars )

192 where

200 where

194 mkVar = L span . Var

202 mkVar = L span . Var

195 toDef y = definition $

203 toDef y = definition $

196 Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])

204 Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])

197−--}

198

205

199match span mtch =

206match span mtch =

200 case mtch of

207 case mtch of

206 _ -> False

213 _ -> False

207 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]

214 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]

208

215

209− Fail -> [ ExprStmt () (dotSep ["_E","Case"] `call` [ref "$moduleName", string (show span)]) ]

216+ Fail -> [ ExprStmt () (get "_E.Case" `call` [ref "$moduleName", string (show span)]) ]

210 Break -> []

217 Break -> []

211 Other e -> [ ReturnStmt () (Just $ expression e) ]

218 Other e -> [ ReturnStmt () (Just $ expression e) ]

212 Seq ms -> concatMap (match span) (dropEnd [] ms)

219 Seq ms -> concatMap (match span) (dropEnd [] ms)

292 '.':rest -> (reverse name, rest)

299 '.':rest -> (reverse name, rest)

293 c:rest -> go (c:name) rest

300 c:rest -> go (c:name) rest

294 [] -> (reverse name, [])

301 [] -> (reverse name, [])

295−

296−

297−formatMarkdown = concatMap f

298− where f '\'' = "\\'"

299− f '\n' = "\\n"

300− f '"' = "\""

301− f c = [c]

302--}

303binop span op e1 e2 =

304 case op of

305 "Basics.." -> ["$"] ==> foldr (<|) (ref "$") (map expression (e1 : collect [] e2))

306 "Basics.<|" -> foldr (<|) (expression e2) (map expression (collect [] e1))

307 "::" -> expression (L span (Data "::" [e1,e2]))

308− "List.++" -> dotSep ["_L","append"] `call` [js1, js2]

308+ "List.++" -> get "_L.append" `call` [js1, js2]

309 _ -> case Map.lookup op opDict of

310 Just f -> f js1 js2

311− Nothing -> ref "A2" `call` [ func [] op, js1, js2 ]

311+ Nothing -> ref "A2" `call` [ func, js1, js2 ]

312 where

313 collect es e =

314 case e of

318 js1 = expression e1

319 js2 = expression e2

320

321− func vs str =

322− case break (=='.') str of

323− (x,'.':rest) -> func (vs ++ [x]) rest

324− (op,[])

325− | isOp op -> BracketRef () (dotSep (vs ++ ["_op"])) (string op)

321+ func | isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string op)

326− | otherwise -> dotSep (vs ++ [op])

322+ | otherwise = dotSep parts

323+ where

324+ parts = split op

325+ operator = last parts

327

326

328 opDict = Map.fromList (infixOps ++ specialOps)

327 opDict = Map.fromList (infixOps ++ specialOps)

329

328

340 ]

339 ]

341

340

342 specialOps =

341 specialOps =

343− [ specialOp "^" $ \a b -> dotSep ["Math","pow"] `call` [a,b]

342+ [ specialOp "^" $ \a b -> get "Math.pow" `call` [a,b]

344 , specialOp "|>" $ flip (<|)

343 , specialOp "|>" $ flip (<|)

345− , specialOp "==" $ \a b -> dotSep ["_N","eq"] `call` [a,b]

344+ , specialOp "==" $ \a b -> get "_N.eq" `call` [a,b]

346− , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (dotSep ["_N","eq"] `call` [a,b])

345+ , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (get "_N.eq" `call` [a,b])

347 , specialOp "<" $ cmp OpLT 0

346 , specialOp "<" $ cmp OpLT 0

348 , specialOp ">" $ cmp OpGT 0

347 , specialOp ">" $ cmp OpGT 0

349 , specialOp "<=" $ cmp OpLT 1

348 , specialOp "<=" $ cmp OpLT 1

351 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

350 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

352 ]

351 ]

353

352

354− cmp op n a b = InfixExpr () op (dotSep ["_N","cmp"] `call` [a,b]) (IntLit () n)

353+ cmp op n a b = InfixExpr () op (get "_N.cmp" `call` [a,b]) (IntLit () n)