5c68f6b · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Convert more files to the new Expression format that relies more on

5c68f6bEvan Czaplicki13 years ago

compiler/Generate/JavaScript.hs+48−19

compare with master

unifiedsplit

@@ -5,13 +5,15 @@ import Control.Monad (liftM,(<=<),join,ap)

5import Data.Char (isAlpha,isDigit)

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

7import qualified Data.Map as Map

8+import qualified Data.Set as Set

8import Data.Either (partitionEithers)

9import Data.Either (partitionEithers)

9import qualified Text.Pandoc as Pan

10import qualified Text.Pandoc as Pan

10−import Data.Maybe (maybeToList)

12import Unique

13import Generate.Cases

14import SourceSyntax.Everything hiding (parens)

15+import SourceSyntax.Location as Loc

16+import Transform.SortDefinitions

15import Types.Types ( Type(RecordT) )

17import Types.Types ( Type(RecordT) )

17showErr :: String -> String

19showErr :: String -> String

@@ -80,10 +82,15 @@ getExports names stmts = "\n"++ intercalate ";\n" (op : map fnPair fns)

81 op = ("_.$op = "++) . jsObj $ map opPair ops

83 op = ("_.$op = "++) . jsObj $ map opPair ops

83− get' (FnDef x _ _) = Just (Left x)

85+ get' def =

84− get' (OpDef op _ _ _) = Just (Right op)

86+ case def of

85− get' (TypeAnnotation _ _) = Nothing

87+ TypeAnnotation _ _ -> []

88+ Def pattern _ ->

89+ case Set.toList (boundVars pattern) of

90+ [var@(c:_)] -> [if isOp c then Right var else Left var]

91+ vars -> map Left vars

92+

86− get s = case s of Definition d -> maybeToList (get' d)

93+ get s = case s of Definition def -> get' def

87 Datatype _ _ tcs -> map (Left . fst) tcs

94 Datatype _ _ tcs -> map (Left . fst) tcs

88 ImportEvent _ _ x _ -> [ Left x ]

95 ImportEvent _ _ x _ -> [ Left x ]

89 ExportEvent _ _ _ -> []

96 ExportEvent _ _ _ -> []

@@ -125,10 +132,11 @@ stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)

125 valueOf s = case s of

132 valueOf s = case s of

126 Datatype _ _ _ -> 1

133 Datatype _ _ _ -> 1

127 ImportEvent _ _ _ _ -> 2

134 ImportEvent _ _ _ _ -> 2

128− Definition (FnDef f [] _) ->

135+ Definition (Def f (L _ _ (Lambda _ _))) -> 3

136+ Definition (Def (PVar name) _) ->

129− if derename f == "main" then 5 else 4

137+ if derename name == "main" then 5 else 4

138+ Definition (Def _ _) -> 4

130 Definition (TypeAnnotation _ _) -> 0

139 Definition (TypeAnnotation _ _) -> 0

131− Definition _ -> 3

132 ExportEvent _ _ _ -> 6

140 ExportEvent _ _ _ -> 6

133 TypeAlias _ _ _ -> 0

141 TypeAlias _ _ _ -> 0

134

142

@@ -136,8 +144,12 @@ class ToJS a where

136 toJS :: a -> Unique String

144 toJS :: a -> Unique String

137

145

138instance ToJS (Def t v) where

146instance ToJS (Def t v) where

147+

148+ -- TODO: Make this handle patterns besides plain variables

149+

139− toJS (FnDef x [] e) = assign x `liftM` toJS' e

150+ toJS (Def (PVar x) e) = assign x `liftM` toJS' e

151+{--

140− toJS (FnDef f as e) = (assign f . wrapper . func) `liftM` toJS' e

152+ toJS (Def f e) = (assign f . wrapper . func) `liftM` toJS' e

141 where

153 where

142 func body = jsFunc (intercalate ", " as) (ret body)

154 func body = jsFunc (intercalate ", " as) (ret body)

143 wrapper e | length as == 1 = e

155 wrapper e | length as == 1 = e

@@ -146,6 +158,7 @@ instance ToJS (Def t v) where

146 do body <- toJS' e

158 do body <- toJS' e

147 let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))

159 let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))

148 return (globalAssign ("$op['" ++ op ++ "']") func)

160 return (globalAssign ("$op['" ++ op ++ "']") func)

161+--}

149 toJS (TypeAnnotation _ _) = return ""

162 toJS (TypeAnnotation _ _) = return ""

150

163

151

164

@@ -155,9 +168,11 @@ instance ToJS (Declaration t v) where

155 Definition d -> toJS d

168 Definition d -> toJS d

156 Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs

169 Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs

157 where toDef (name,args) =

170 where toDef (name,args) =

158− let vars = map (('a':) . show) [1..length args] in

171+ let vars = map (('a':) . show) [1..length args]

159− Definition . FnDef name vars . none $

172+ body = Loc.none (Data (derename name) (map (Loc.none . Var) vars))

160− Data (derename name) (map (none . Var) vars)

173+ func = foldr (\x e -> Loc.none (Lambda (PVar x) e)) body vars

174+ in Definition $ Def (PVar name) func

175+

161 ImportEvent js base elm _ ->

176 ImportEvent js base elm _ ->

162 do v <- toJS' base

177 do v <- toJS' base

163 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"

178 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"

@@ -188,8 +203,8 @@ makeRecord kvs = record `liftM` collect kvs

188 where

203 where

189 combine r (k,v) = Map.insertWith (++) k v r

204 combine r (k,v) = Map.insertWith (++) k v r

190 collect = liftM (foldl' combine Map.empty) . mapM prep

205 collect = liftM (foldl' combine Map.empty) . mapM prep

191− prep (k, as, e@(L t s _)) =

206+ prep (k, e) =

192− do v <- toJS' (foldr (\x e -> L t s $ Lambda x e) e as)

207+ do v <- toJS' e

193 return (k,[v])

208 return (k,[v])

194 fields fs =

209 fields fs =

195 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))

210 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))

@@ -222,7 +237,22 @@ instance ToJS (Expr t v) where

222 Record fs -> makeRecord fs

237 Record fs -> makeRecord fs

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

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

224

239

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

240+ Lambda p e -> liftM (jsFunc (intercalate ", " args) . ret) (toJS' body)

241+ where

242+ (args, body) = foldr depattern ([], innerBody) (zip patterns [1..])

243+

244+ depattern (pattern,n) (args, body) =

245+ case pattern of

246+ PVar x -> (x:args, body)

247+ _ -> let arg = "arg" ++ show n

248+ in (arg:args, Loc.none (Case (Loc.none (Var arg)) [(pattern, body)]))

249+

250+ (patterns, innerBody) = collect [p] e

251+

252+ collect patterns lexpr@(L a b expr) =

253+ case expr of

254+ Lambda p e -> collect (p:patterns) e

255+ _ -> (patterns, lexpr)

226

256

227 App e1 e2 -> jsApp e1 e2

257 App e1 e2 -> jsApp e1 e2

228 Let defs e -> jsLet defs e

258 Let defs e -> jsLet defs e

@@ -279,9 +309,8 @@ jsLet defs e' = do ds <- jsDefs defs

279 where

309 where

280 jsDefs defs = mapM toJS (sortBy f defs)

310 jsDefs defs = mapM toJS (sortBy f defs)

281 f a b = compare (valueOf a) (valueOf b)

311 f a b = compare (valueOf a) (valueOf b)

282− valueOf (FnDef _ [] _) = 2

312+ valueOf (Def _ (L _ _ (Lambda _ _))) = 1

283− valueOf (FnDef _ _ _) = 1

313+ valueOf (Def _ _) = 2

284− valueOf (OpDef _ _ _ _) = 1

285 valueOf (TypeAnnotation _ _) = 0

314 valueOf (TypeAnnotation _ _) = 0

286

315

287caseToJS span e ps = do

316caseToJS span e ps = do

compiler/SourceSyntax/Location.hs+2−1

@@ -10,7 +10,8 @@ data SrcPos = Pos Int Int

10data SrcSpan = Span SrcPos SrcPos | NoSpan

11 deriving (Eq, Ord, Data, Typeable)

13−data Located e = L (Maybe String) SrcSpan e deriving (Eq,Ord, Data, Typeable)

13+data Located e = L (Maybe String) SrcSpan e

14+ deriving (Eq, Ord, Data, Typeable)

16instance Show SrcPos where

17instance Show SrcPos where

compiler/Transform/SortDefinitions.hsnew file+112

@@ -0,0 +1,112 @@

2+module Transform.SortDefinitions (boundVars) where

4+import Control.Monad.State

5+import qualified Data.Set as Set

6+import qualified Data.Map as Map

7+import SourceSyntax.Everything

10+boundVars :: Pattern -> Set.Set String

11+boundVars pattern =

12+ case pattern of

13+ PVar x -> Set.singleton x

14+ PAlias x p -> Set.insert x (boundVars p)

15+ PData _ ps -> Set.unions (map boundVars ps)

16+ PRecord fields -> Set.fromList fields

17+ PAnything -> Set.empty

18+ PLiteral _ -> Set.empty

19+

20+free x = modify (Set.insert x)

21+bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)

22+

23+reorderAndGetDependencies pattern expr =

24+ do globalFrees <- get

25+ expr' <- reorder expr

26+ localFrees <- get

27+ modify (Set.union globalFrees)

28+ let addDep var deps = Map.insert var localFrees deps

29+ dependencies = Set.foldr addDep Map.empty (boundVars pattern)

30+ return (expr', dependencies)

31+

32+reorder :: LExpr t v -> State (Set.Set String) (LExpr t v)

33+reorder lexpr@(L a b expr) =

34+ L a b `liftM`

35+ case expr of

36+{--

37+ -- Actually do some reordering

38+ Let defs body ->

39+ do -- swap in a fresh environment

40+

41+ -- swap in the old environment

42+ body' <- reorder body

43+ bound (boundVars (patterns defs))

44+ Let `liftM` defs' `ap` body'

45+

46+ where

47+ patterns = flip concatMap defs $

48+ case def of

49+ Def pattern _ -> [pattern]

50+ TypeAnnotation _ _ -> []

51+--}

52+ -- Be careful adding and restricting freeVars

53+ Var x -> free x >> return expr

54+

55+ Lambda p e ->

56+ uncurry Lambda `liftM` bindingReorder (p,e)

57+

58+ Binop op e1 e2 ->

59+ do free op

60+ Binop op `liftM` reorder e1 `ap` reorder e2

61+

62+ Case e cases ->

63+ Case `liftM` reorder e `ap` mapM bindingReorder cases

64+

65+ Data name es ->

66+ do free name

67+ Data name `liftM` mapM reorder es

68+

69+ -- Just pipe the reorder though

70+ Literal _ -> return expr

71+

72+ Range e1 e2 ->

73+ Range `liftM` reorder e1 `ap` reorder e2

74+

75+ ExplicitList es ->

76+ ExplicitList `liftM` mapM reorder es

77+

78+ App e1 e2 ->

79+ App `liftM` reorder e1 `ap` reorder e2

80+

81+ MultiIf branches ->

82+ MultiIf `liftM` mapM reorderPair branches

83+

84+ Access e lbl ->

85+ Access `liftM` reorder e `ap` return lbl

86+

87+ Remove e lbl ->

88+ Remove `liftM` reorder e `ap` return lbl

89+

90+ Insert e lbl v ->

91+ Insert `liftM` reorder e `ap` return lbl `ap` reorder v

92+

93+ Modify e fields ->

94+ Modify `liftM` reorder e `ap` mapM reorderField fields

95+

96+ Record fields ->

97+ Record `liftM` mapM reorderField fields

98+

99+ Markdown _ -> return expr

100+

101+reorderField (label, expr) =

102+ (,) label `liftM` reorder expr

103+

104+reorderPair (e1,e2) =

105+ (,) `liftM` reorder e1 `ap` reorder e2

106+

107+bindingReorder :: (Pattern, LExpr t v) -> State (Set.Set String) (Pattern, LExpr t v)

108+bindingReorder (pattern,expr) =

109+ do expr' <- reorder expr

110+ bound (boundVars pattern)

111+ return (pattern, expr')

112+

compiler/Transform/Substitute.hs+4−5

@@ -12,13 +12,12 @@ subst old new expr =

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

13 ExplicitList es -> ExplicitList (map f es)

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

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

15+ Lambda p e -> Lambda p (f e)

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

17 MultiIf ps -> MultiIf (map (f *** f) ps)

18 Let defs body -> Let (map substDef defs) (f body)

19− where substDef (FnDef name vs e) = FnDef name vs (f e)

19+ where substDef (Def name e) = Def name (f e)

20− substDef (OpDef op a1 a2 e) = OpDef op a1 a2 (f e)

20+ substDef anno@(TypeAnnotation _ _) = anno

21− substDef x = x

22 Var x -> if x == old then new else expr

21 Var x -> if x == old then new else expr

23 Case e cases -> Case (f e) $ map (second f) cases

22 Case e cases -> Case (f e) $ map (second f) cases

24 Data name es -> Data name (map f es)

23 Data name es -> Data name (map f es)

@@ -26,6 +25,6 @@ subst old new expr =

26 Remove e x -> Remove (f e) x

25 Remove e x -> Remove (f e) x

27 Insert e x v -> Insert (f e) x (f v)

26 Insert e x v -> Insert (f e) x (f v)

28 Modify r fs -> Modify (f r) (map (second f) fs)

27 Modify r fs -> Modify (f r) (map (second f) fs)

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

28+ Record fs -> Record (map (second f) fs)

30 Literal _ -> expr

29 Literal _ -> expr

31 Markdown _ -> expr

30 Markdown _ -> expr