git.iko.soy/elk
on master help sign in
Convert more files to the new Expression format that relies more on

patterns. Seems to clean things up so far. Also, begin adding a module that resorts definitions to make sure that each definition comes after the ones it depends on. This will also make it possible to disallow recursive values statically.

commit5c68f6bb7301182265b7d6f53ceaac51308d06ba authorEvan Czaplicki <evan@Evans-MacBook-Air.local> dateThu 4 Jul 2013, 17:24 (13 years ago) parent69ed763
4 files changed+166−25
compare with master
unifiedsplit
compiler/Generate/JavaScript.hs+48−19 compiler/SourceSyntax/Location.hs+2−1 compiler/Transform/SortDefinitions.hs+112 compiler/Transform/Substitute.hs+4−5
compiler/Generate/JavaScript.hs+48−19
@@ -5,13 +5,15 @@ import Control.Monad (liftM,(<=<),join,ap)
55import Data.Char (isAlpha,isDigit)
66import Data.List (intercalate,sortBy,inits,foldl')
77import qualified Data.Map as Map
8+import qualified Data.Set as Set
89import Data.Either (partitionEithers)
910import qualified Text.Pandoc as Pan
10−import Data.Maybe (maybeToList)
1111
1212import Unique
1313import Generate.Cases
1414import SourceSyntax.Everything hiding (parens)
15+import SourceSyntax.Location as Loc
16+import Transform.SortDefinitions
1517import Types.Types ( Type(RecordT) )
1618
1719showErr :: String -> String
@@ -80,10 +82,15 @@ getExports names stmts = "\n"++ intercalate ";\n" (op : map fnPair fns)
8082
8183 op = ("_.$op = "++) . jsObj $ map opPair ops
8284
83− get' (FnDef x _ _) = Just (Left x)
84− get' (OpDef op _ _ _) = Just (Right op)
85− get' (TypeAnnotation _ _) = Nothing
86− get s = case s of Definition d -> maybeToList (get' d)
85+ get' def =
86+ case def of
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+
93+ get s = case s of Definition def -> get' def
8794 Datatype _ _ tcs -> map (Left . fst) tcs
8895 ImportEvent _ _ x _ -> [ Left x ]
8996 ExportEvent _ _ _ -> []
@@ -125,10 +132,11 @@ stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
125132 valueOf s = case s of
126133 Datatype _ _ _ -> 1
127134 ImportEvent _ _ _ _ -> 2
128− Definition (FnDef f [] _) ->
129− if derename f == "main" then 5 else 4
135+ Definition (Def f (L _ _ (Lambda _ _))) -> 3
136+ Definition (Def (PVar name) _) ->
137+ if derename name == "main" then 5 else 4
138+ Definition (Def _ _) -> 4
130139 Definition (TypeAnnotation _ _) -> 0
131− Definition _ -> 3
132140 ExportEvent _ _ _ -> 6
133141 TypeAlias _ _ _ -> 0
134142
@@ -136,8 +144,12 @@ class ToJS a where
136144 toJS :: a -> Unique String
137145
138146instance ToJS (Def t v) where
139− toJS (FnDef x [] e) = assign x `liftM` toJS' e
140− toJS (FnDef f as e) = (assign f . wrapper . func) `liftM` toJS' e
147+
148+ -- TODO: Make this handle patterns besides plain variables
149+
150+ toJS (Def (PVar x) e) = assign x `liftM` toJS' e
151+{--
152+ toJS (Def f e) = (assign f . wrapper . func) `liftM` toJS' e
141153 where
142154 func body = jsFunc (intercalate ", " as) (ret body)
143155 wrapper e | length as == 1 = e
@@ -146,6 +158,7 @@ instance ToJS (Def t v) where
146158 do body <- toJS' e
147159 let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))
148160 return (globalAssign ("$op['" ++ op ++ "']") func)
161+--}
149162 toJS (TypeAnnotation _ _) = return ""
150163
151164
@@ -155,9 +168,11 @@ instance ToJS (Declaration t v) where
155168 Definition d -> toJS d
156169 Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
157170 where toDef (name,args) =
158− let vars = map (('a':) . show) [1..length args] in
159− Definition . FnDef name vars . none $
160− Data (derename name) (map (none . Var) vars)
171+ let vars = map (('a':) . show) [1..length args]
172+ body = Loc.none (Data (derename name) (map (Loc.none . Var) vars))
173+ func = foldr (\x e -> Loc.none (Lambda (PVar x) e)) body vars
174+ in Definition $ Def (PVar name) func
175+
161176 ImportEvent js base elm _ ->
162177 do v <- toJS' base
163178 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
@@ -188,8 +203,8 @@ makeRecord kvs = record `liftM` collect kvs
188203 where
189204 combine r (k,v) = Map.insertWith (++) k v r
190205 collect = liftM (foldl' combine Map.empty) . mapM prep
191− prep (k, as, e@(L t s _)) =
192− do v <- toJS' (foldr (\x e -> L t s $ Lambda x e) e as)
206+ prep (k, e) =
207+ do v <- toJS' e
193208 return (k,[v])
194209 fields fs =
195210 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
@@ -222,7 +237,22 @@ instance ToJS (Expr t v) where
222237 Record fs -> makeRecord fs
223238 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
224239
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)
226256
227257 App e1 e2 -> jsApp e1 e2
228258 Let defs e -> jsLet defs e
@@ -279,9 +309,8 @@ jsLet defs e' = do ds <- jsDefs defs
279309 where
280310 jsDefs defs = mapM toJS (sortBy f defs)
281311 f a b = compare (valueOf a) (valueOf b)
282− valueOf (FnDef _ [] _) = 2
283− valueOf (FnDef _ _ _) = 1
284− valueOf (OpDef _ _ _ _) = 1
312+ valueOf (Def _ (L _ _ (Lambda _ _))) = 1
313+ valueOf (Def _ _) = 2
285314 valueOf (TypeAnnotation _ _) = 0
286315
287316caseToJS span e ps = do
compiler/SourceSyntax/Location.hs+2−1
@@ -10,7 +10,8 @@ data SrcPos = Pos Int Int
1010data SrcSpan = Span SrcPos SrcPos | NoSpan
1111 deriving (Eq, Ord, Data, Typeable)
1212
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)
1415
1516
1617instance Show SrcPos where
compiler/Transform/SortDefinitions.hsnew file+112
@@ -0,0 +1,112 @@
1+
2+module Transform.SortDefinitions (boundVars) where
3+
4+import Control.Monad.State
5+import qualified Data.Set as Set
6+import qualified Data.Map as Map
7+import SourceSyntax.Everything
8+
9+
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 =
1212 Range e1 e2 -> Range (f e1) (f e2)
1313 ExplicitList es -> ExplicitList (map f es)
1414 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)
1616 App e1 e2 -> App (f e1) (f e2)
1717 MultiIf ps -> MultiIf (map (f *** f) ps)
1818 Let defs body -> Let (map substDef defs) (f body)
19− where substDef (FnDef name vs e) = FnDef name vs (f e)
20− substDef (OpDef op a1 a2 e) = OpDef op a1 a2 (f e)
21− substDef x = x
19+ where substDef (Def name e) = Def name (f e)
20+ substDef anno@(TypeAnnotation _ _) = anno
2221 Var x -> if x == old then new else expr
2322 Case e cases -> Case (f e) $ map (second f) cases
2423 Data name es -> Data name (map f es)
@@ -26,6 +25,6 @@ subst old new expr =
2625 Remove e x -> Remove (f e) x
2726 Insert e x v -> Insert (f e) x (f v)
2827 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)
3029 Literal _ -> expr
3130 Markdown _ -> expr