git.iko.soy/elk
on master help sign in
Update more modules to use the MetadataModule data structure
82983a6Evan Czaplicki
compiler/Compiler.hs+4−11
compare with master
unifiedsplit
@@ -98,12 +98,11 @@ buildFile flags moduleNum numModules filePath =
98 compile = do
98 compile = do
99 putStrLn (number ++ " Compiling " ++ name)
99 putStrLn (number ++ " Compiling " ++ name)
100 source <- readFile filePath
100 source <- readFile filePath
101− (interface,obj) <-
101+ obj <-
102− if takeExtension filePath == ".js" then return ("",source) else
102+ if takeExtension filePath == ".js" then return source else
103 case buildFromSource (no_prelude flags) source of
103 case buildFromSource (no_prelude flags) source of
104− Left err -> putStrLn err >> exitFailure
104+ Left err -> print err >> exitFailure
105− Right modul -> do exs <- exportInfo (modul :: Module () String)
106− return (exs, jsModule modul)
105+ Right modul -> return . jsModule $ (modul :: MetadataModule () ())
107 createDirectoryIfMissing True (output_directory flags)
106 createDirectoryIfMissing True (output_directory flags)
108 writeFile (elmo flags filePath) obj
107 writeFile (elmo flags filePath) obj
109 return obj
108 return obj
@@ -151,9 +150,3 @@ buildFiles flags numModules interfaces (filePath:rest) = do
151 let moduleName = intercalate "." (splitDirectories (dropExtensions filePath))
150 let moduleName = intercalate "." (splitDirectories (dropExtensions filePath))
152 interfaces' = Map.insert moduleName interface interfaces
151 interfaces' = Map.insert moduleName interface interfaces
153 buildFiles flags numModules interfaces' rest
152 buildFiles flags numModules interfaces' rest
154−
155−
156−exportInfo :: Module t v -> IO String
157−exportInfo (Module names exs ims stmts) =
158− do print exs
159− return (show exs)
compiler/Generate/JavaScript.hs+63−106
@@ -3,7 +3,7 @@ module Generate.JavaScript (showErr, jsModule) where
3import Control.Arrow (first,second)
3import Control.Arrow (first,second)
4import Control.Monad (liftM,(<=<),join,ap)
4import Control.Monad (liftM,(<=<),join,ap)
5import Data.Char (isAlpha,isDigit)
5import Data.Char (isAlpha,isDigit)
6−import Data.List (intercalate,sortBy,inits,foldl')
6+import Data.List (intercalate,inits,foldl')
7import qualified Data.Map as Map
7import qualified Data.Map as Map
8import qualified Data.Set as Set
8import qualified Data.Set as Set
9import Data.Either (partitionEithers)
9import Data.Either (partitionEithers)
@@ -13,7 +13,7 @@ import Unique
13import Generate.Cases
13import Generate.Cases
14import SourceSyntax.Everything hiding (parens)
14import SourceSyntax.Everything hiding (parens)
15import SourceSyntax.Location as Loc
15import SourceSyntax.Location as Loc
16−import Transform.SortDefinitions
16+import qualified Transform.SortDefinitions as SD
17
17
18showErr :: String -> String
18showErr :: String -> String
19showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)
19showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)
@@ -52,49 +52,50 @@ quoted s = "'" ++ concatMap f s ++ "'"
52globalAssign n e = "\n" ++ assign' n e ++ ";"
52globalAssign n e = "\n" ++ assign' n e ++ ";"
53assign' n e = n ++ " = " ++ e
53assign' n e = n ++ " = " ++ e
54
54
55−jsModule (Module names exports imports stmts) =
55+jsModule :: MetadataModule t v -> String
56+jsModule modul =
57+ run $ do
58+ body <- toJS (defs modul)
59+ foreignImport <- mapM importEvent (foreignImports modul)
60+ return $ concat [ setup ("Elm": names modul)
56− setup ("Elm":modNames) ++ globalAssign ("Elm." ++ modName) (jsFunc "elm" program)
61+ , globalAssign ("Elm." ++ modName)
62+ (jsFunc "elm" $ program body foreignImport) ]
57 where
63 where
58− modNames = if null names then ["Main"] else names
59− modName = intercalate "." modNames
64+ modName = intercalate "." (names modul)
60− includes = concatMap jsImport imports
65+ program body foreignImport =
61− body = stmtsToJS stmts
62− defs = assign "$op" "{}"
63− program = "\nvar " ++ usefulFuncs ++ ";" ++ defs ++ includes ++ body ++
66+ concat [ "\nvar " ++ usefulFuncs ++ ";"
67+ , assign "_op" "{}"
68+ , concatMap jsImport (imports modul)
69+ , concat foreignImport
70+ , concatMap exportEvent $ foreignExports modul
71+ , body
64− setup ("elm":"Native":modNames) ++
72+ , setup ("elm" : "Native" : names modul)
65− assign "_" ("elm.Native." ++ modName ++ "||{}") ++
73+ , assign "_" ("elm.Native." ++ modName ++ "||{}")
66− getExports exports stmts ++ setup ("elm":modNames) ++
74+ , concatMap jsExport (exports modul)
75+ , setup ("elm" : names modul)
67− ret (assign' ("elm." ++ modName) "_") ++ "\n"
76+ , ret (assign' ("elm." ++ modName) "_")
77+ ]
68− setup modNames = concatMap (\n -> globalAssign n $ n ++ "||{}") .
78+ setup names = concatMap (\n -> globalAssign n $ n ++ "||{}") .
69− map (intercalate ".") . drop 2 . inits $ init modNames
79+ map (intercalate ".") . drop 2 . inits $ init names
70 usefulFuncs = intercalate ", " (map (uncurry assign') internalImports)
80 usefulFuncs = intercalate ", " (map (uncurry assign') internalImports)
71
81
72−getExports names stmts = "\n"++ intercalate ";\n" (op : map fnPair fns)
82+ jsExport x =
73− where exNames n = either derename id n `elem` names
83+ if isOp x then "\n_._op['" ++ x ++ "'] = _op['" ++ x ++ "'];"
74− exports | null names = concatMap get stmts
84+ else "\n_." ++ derename x ++ " = " ++ x ++ ";"
75− | otherwise = filter exNames (concatMap get stmts)
85+
76−
86+ importEvent (js,base,elm,_) =
77− (fns,ops) = partitionEithers exports
87+ do v <- toJS' base
78−
88+ return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
79− opPair op = "'" ++ op ++ "' : $op['" ++ op ++ "']"
89+ , "\ndocument.addEventListener('", js
80− fnPair fn = let fn' = derename fn in "_." ++ fn' ++ " = " ++ fn
90+ , "_' + elm.id, function(e) { elm.notify(", elm
81−
91+ , ".id, e.value); });" ]
82− op = ("_.$op = "++) . jsObj $ map opPair ops
83−
84− get' def =
85− case def of
86− TypeAnnotation _ _ -> []
87− Def pattern _ ->
88− case Set.toList (boundVars pattern) of
89− [var@(c:_)] -> [if isOp c then Right var else Left var]
90− vars -> map Left vars
91−
92− get s = case s of Definition def -> get' def
93− Datatype _ _ tcs -> map (Left . fst) tcs
94− ImportEvent _ _ x _ -> [ Left x ]
95− ExportEvent _ _ _ -> []
96− TypeAlias _ _ _ -> []
97
92
93+ exportEvent (js,elm,_) =
94+ concat [ "\nlift(function(v) { "
95+ , "var e = document.createEvent('Event');"
96+ , "e.initEvent('", js, "_' + elm.id, true, true);"
97+ , "e.value = v;"
98+ , "document.dispatchEvent(e); return v; })(", elm, ");" ]
98
99
99jsImport (modul, how) =
100jsImport (modul, how) =
100 case how of
101 case how of
@@ -105,7 +106,7 @@ jsImport (modul, how) =
105 Importing vs -> include ++ named
106 Importing vs -> include ++ named
106 where
107 where
107 imprt v = assign' v ("_." ++ v)
108 imprt v = assign' v ("_." ++ v)
108− def (o:p) = imprt (if isOp o then "$op['" ++ o:p ++ "']" else deprime (o:p))
109+ def x = imprt $ if isOp x then "_op['" ++ x ++ "']" else deprime x
109 named = if null vs then "" else "\nvar " ++ intercalate ", " (map def vs) ++ ";"
110 named = if null vs then "" else "\nvar " ++ intercalate ", " (map def vs) ++ ";"
110 where
111 where
111 include = "\nvar _ = Elm." ++ modul ++ parens "elm" ++ ";" ++ setup modul
112 include = "\nvar _ = Elm." ++ modul ++ parens "elm" ++ ";" ++ setup modul
@@ -122,69 +123,31 @@ jsImport (modul, how) =
122 [] -> (reverse name, [])
123 [] -> (reverse name, [])
123
124
124
125
125−
126−stmtsToJS :: [Declaration t v] -> String
127−stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
128− return (concat program)
129− where
130− cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
131− valueOf s = case s of
132− Datatype _ _ _ -> 1
133− ImportEvent _ _ _ _ -> 2
134− Definition (Def f (L _ _ (Lambda _ _))) -> 3
135− Definition (Def (PVar name) _) ->
136− if derename name == "main" then 5 else 4
137− Definition (Def _ _) -> 4
138− Definition (TypeAnnotation _ _) -> 0
139− ExportEvent _ _ _ -> 6
140− TypeAlias _ _ _ -> 0
141−
142class ToJS a where
126class ToJS a where
143 toJS :: a -> Unique String
127 toJS :: a -> Unique String
144
128
129+
145instance ToJS (Def t v) where
130instance ToJS (Def t v) where
146
131
147 -- TODO: Make this handle patterns besides plain variables
132 -- TODO: Make this handle patterns besides plain variables
133+ toJS (Def (PVar x) e)
134+ | isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e
135+ | otherwise = assign x `liftM` toJS' e
136+
137+ toJS (Def pattern e) =
138+ do n <- guid
139+ let x = "_" ++ show n
140+ var = Loc.none . Var
141+ toDef y = Def (PVar y) (Loc.none $ Case (var x) [(pattern, var y)])
142+ stmt <- assign x `liftM` toJS' e
143+ vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern
144+ return (stmt ++ vars)
148
145
149− toJS (Def (PVar x) e) = assign x `liftM` toJS' e
150−{--
151− toJS (Def f e) = (assign f . wrapper . func) `liftM` toJS' e
152− where
153− func body = jsFunc (intercalate ", " as) (ret body)
154− wrapper e | length as == 1 = e
155− | otherwise = 'F' : show (length as) ++ parens e
156− toJS (OpDef op a1 a2 e) =
157− do body <- toJS' e
158− let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))
159− return (globalAssign ("$op['" ++ op ++ "']") func)
160−--}
161 toJS (TypeAnnotation _ _) = return ""
146 toJS (TypeAnnotation _ _) = return ""
162
147
163
148
164−instance ToJS (Declaration t v) where
149+instance ToJS a => ToJS [a] where
165− toJS stmt =
166− case stmt of
167− Definition d -> toJS d
168− Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
150+ toJS xs = concat `liftM` mapM toJS xs
169− where toDef (name,args) =
170− let vars = map (('a':) . show) [1..length args]
171− body = Loc.none (Data (derename name) (map (Loc.none . Var) vars))
172− func = foldr (\x e -> Loc.none (Lambda (PVar x) e)) body vars
173− in Definition $ Def (PVar name) func
174−
175− ImportEvent js base elm _ ->
176− do v <- toJS' base
177− return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
178− , "\ndocument.addEventListener('", js
179− , "_' + elm.id, function(e) { elm.notify(", elm
180− , ".id, e.value); });" ]
181− ExportEvent js elm _ ->
182− return $ concat [ "\nlift(function(v) { "
183− , "var e = document.createEvent('Event');"
184− , "e.initEvent('", js, "_' + elm.id, true, true);"
185− , "e.value = v;"
186− , "document.dispatchEvent(e); return v; })(", elm, ");" ]
187− TypeAlias n _ t -> return ""
188
151
189toJS' :: LExpr t v -> Unique String
152toJS' :: LExpr t v -> Unique String
190toJS' (L txt span expr) =
153toJS' (L txt span expr) =
@@ -254,7 +217,7 @@ instance ToJS (Expr t v) where
254 _ -> (patterns, lexpr)
217 _ -> (patterns, lexpr)
255
218
256 App e1 e2 -> jsApp e1 e2
219 App e1 e2 -> jsApp e1 e2
257− Let defs e -> jsLet defs e
220+ Let defs e -> jsLet $ SD.flattenLets defs e
258
221
259 ExplicitList es ->
222 ExplicitList es ->
260 do es' <- mapM toJS' es
223 do es' <- mapM toJS' es
@@ -302,15 +265,9 @@ multiIfToJS span ps =
302 e' <- toJS' e
265 e' <- toJS' e
303 return (b' ++ " ? " ++ e')
266 return (b' ++ " ? " ++ e')
304
267
305−jsLet defs e' = do ds <- jsDefs defs
268+jsLet (defs,e') = do ds <- mapM toJS defs
306− e <- toJS' e'
269+ e <- toJS' e'
307− return $ jsFunc "" (concat ds ++ ret e) ++ "()"
270+ return $ jsFunc "" (concat ds ++ ret e) ++ "()"
308− where
309− jsDefs defs = mapM toJS (sortBy f defs)
310− f a b = compare (valueOf a) (valueOf b)
311− valueOf (Def _ (L _ _ (Lambda _ _))) = 1
312− valueOf (Def _ _) = 2
313− valueOf (TypeAnnotation _ _) = 0
314
271
315caseToJS span e ps = do
272caseToJS span e ps = do
316 match <- caseToMatch ps
273 match <- caseToMatch ps
@@ -379,5 +336,5 @@ binop (o:p) e1 e2
379 "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
336 "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
380 "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
337 "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
381 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
338 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
382− | otherwise -> concat [ "$op['", o:p, "']"
339+ | otherwise -> concat [ "_op['", o:p, "']"
383 , parens e1, parens e2 ]
340 , parens e1, parens e2 ]
compiler/Initialize.hs+35−20
@@ -7,37 +7,52 @@ import qualified Data.Map as Map
7import Data.Data
7import Data.Data
8import Data.List (intercalate,partition)
8import Data.List (intercalate,partition)
9import System.Exit
9import System.Exit
10−import System.FilePath
10+import System.FilePath as FP
11import Text.PrettyPrint (Doc)
11import Text.PrettyPrint (Doc)
12
12
13−import Parse.Parser (parseProgram, parseDependencies)
14import SourceSyntax.Everything
13import SourceSyntax.Everything
14+import SourceSyntax.Declaration (Assoc)
15+import qualified SourceSyntax.Location as Loc
16+import qualified Parse.Parse as Parse
15import qualified Metadata.Libraries as Libs
17import qualified Metadata.Libraries as Libs
16import qualified Transform.Optimize as Optimize
18import qualified Transform.Optimize as Optimize
17import qualified Transform.Check as Check
19import qualified Transform.Check as Check
20+import qualified Transform.SortDefinitions as SD
18import qualified Type.Inference as TI
21import qualified Type.Inference as TI
22+import qualified Type.Constrain.Declaration as TcDecl
19import qualified Type.Type as T
23import qualified Type.Type as T
20
24
21
25
26+buildFromSource :: (Data t, Data v) => Bool -> String -> Either [Doc] (MetadataModule t v)
27+buildFromSource noPrelude src =
28+ do modul <- Parse.program src
22
29
23−checkMistakes :: (Data t, Data v) => Module t v -> Either [Doc] (Module t v)
30+ -- check for structural errors
24−checkMistakes modul@(Module name ex im decls) =
31+ Module names exs ims decls <- checkMistakes modul
25− case Check.mistakes decls of
26− [] -> return modul
27− ms -> Left ms
28
32
29−-- subs `seq` return (Optimize.optimize (renameModule modul))
33+ -- reorder AST into strongly connected components
34+ let metaModule = MetadataModule {
35+ names = names,
36+ path = FP.joinPath names,
37+ exports = exs,
38+ imports = ims,
39+ defs = fst . SD.flattenLets [] . SD.sortDefs . dummyLet $ TcDecl.toExpr decls,
40+ types = Map.empty,
41+ fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ],
42+ aliases = [ (name,tvs,tipe) | TypeAlias name tvs tipe <- decls ],
43+ foreignImports = [ (evt,v,name,typ) | ImportEvent evt v name typ <- decls ],
44+ foreignExports = [ (evt,name,typ) | ExportEvent evt name typ <- decls ]
45+ }
30
46
31−buildFromSource :: (Data t, Data v) => Bool -> String -> Either [Doc] (Module t v, Map.Map String T.Variable)
47+ types <- TI.infer metaModule
32−buildFromSource noPrelude src = do
48+ return $ metaModule { types = types }
33− modul <- parseProgram src
34
49
35− -- check for structural errors and give all variables unique names
50+ where
36− modul' <- renameModule <$> checkMistakes modul
51+ checkMistakes modul@(Module _ _ _ decls) =
37− -- reorder AST into strongly connected components
52+ case Check.mistakes decls of
53+ [] -> return modul
54+ ms -> Left ms
38
55
39− types <- TI.infer modul'
40− return (modul', types)
41
56
42getSortedModuleNames :: FilePath -> IO [String]
57getSortedModuleNames :: FilePath -> IO [String]
43getSortedModuleNames root =
58getSortedModuleNames root =
@@ -61,10 +76,10 @@ sortDeps deps = go [] (nub deps)
61readDeps :: [FilePath] -> FilePath -> IO [Deps]
76readDeps :: [FilePath] -> FilePath -> IO [Deps]
62readDeps seen root = do
77readDeps seen root = do
63 txt <- readFile root
78 txt <- readFile root
64− case parseDependencies txt of
79+ case Parse.dependencies txt of
65− Left err ->
80+ Left err -> putStrLn msg >> print err >> exitFailure
66− let msg = "Error resolving dependencies in " ++ root ++ ":\n" in
81+ where msg = "Error resolving dependencies in " ++ root ++ ":"
67− putStrLn (msg ++ err) >> exitFailure
82+
68 Right (name,deps) ->
83 Right (name,deps) ->
69 do rest <- mapM (readDeps seen' . toFilePath) newDeps
84 do rest <- mapM (readDeps seen' . toFilePath) newDeps
70 return ((name, realDeps) : concat rest)
85 return ((name, realDeps) : concat rest)