git.iko.soy/elk
on master help sign in
Get prelude added in all cases.
commit5d536d129a9bfd9bcbe4244b9de82d78e2644222 authorevancz <info@elm-lang.org> dateMon 8 Apr 2013, 01:48 (14 years ago) parent9c22031
7 files changed+52−39
compare with master
unifiedsplit
compiler/Compiler.hs+3−2 compiler/Gen/GenerateHtml.hs+6−4 compiler/Initialize.hs+11−10 compiler/Language/Elm.hs+3−7 compiler/Model/Libraries.hs+20−10 compiler/Types/Hints.hs+4−1 compiler/Types/Substitutions.hs+5−5
compiler/Compiler.hs+3−2
@@ -68,9 +68,10 @@ data What = JS | HTML | Split
6868fileTo flags what rtLoc file = do
6969 let jsStyle = if minify flags then Minified else Readable
7070 formatJS = if minify flags then BS.unpack . JS.minify . BS.pack else id
71− ems <- if make flags then build file
71+ prelude = not (no_prelude flags)
72+ ems <- if make flags then build prelude file
7273 else do src <- readFile file
73− return (fmap (:[]) (buildFromSource src))
74+ return (fmap (:[]) (buildFromSource prelude src))
7475 jss <- concat `fmap` mapM readFile (import_js flags)
7576 case ems of
7677 Left err -> do putStrLn $ "Error while compiling " ++ file ++ ":\n" ++ err
compiler/Gen/GenerateHtml.hs+6−4
@@ -15,9 +15,10 @@ import Text.Jasmine (minify)
1515import qualified Data.ByteString.Lazy.Char8 as BS
1616
1717import Ast
18−import Initialize
18+import Initialize (buildFromSource)
1919import CompileToJS
2020import ExtractNoscript
21+import Libraries as Libraries
2122
2223data JSStyle = Minified | Readable
2324
@@ -40,9 +41,10 @@ generateHtml :: String -- ^ Location of elm-runtime.js as expected by the browse
4041 -> String -- ^ The elm source code.
4142 -> Html
4243generateHtml libLoc title source =
43− case buildFromSource source of
44− Left err -> createHtml Readable libLoc title (Right $ showErr err) (H.noscript "") "Elm.Main"
45− Right modul -> modulesToHtml Readable title libLoc [] True [modul]
44+ case buildFromSource True source of
45+ Right modul -> modulesToHtml Readable title libLoc [] True [modul]
46+ Left err -> createHtml Readable libLoc title (Right $ showErr err)
47+ (H.noscript "") "Elm.Main"
4648
4749
4850modulesToHtml jsStyle title libLoc jss nscrpt modules =
compiler/Initialize.hs+11−10
@@ -10,7 +10,7 @@ import Data.Either (lefts,rights)
1010import Data.List (intercalate,partition)
1111import Parse.Parser (parseProgram, preParse)
1212import Rename
13−import Libraries (libraries)
13+import qualified Libraries as Libs
1414import Types.Types ((-:))
1515import Types.Hints (hints)
1616import Types.Unify
@@ -32,29 +32,30 @@ checkTypes modul =
3232check :: Module -> Either String Module
3333check = checkMistakes >=> checkTypes
3434
35−buildFromSource :: String -> Either String Module
36−buildFromSource src = check =<< parseProgram src
35+buildFromSource :: Bool -> String -> Either String Module
36+buildFromSource withPrelude src = (check . add) =<< (parseProgram src)
37+ where add = if withPrelude then Libs.addPrelude else id
3738
38−build :: FilePath -> IO (Either String [Module])
39−build root = do
39+build :: Bool -> FilePath -> IO (Either String [Module])
40+build withPrelude root = do
4041 names <- getSortedModuleNames root
4142 case names of
4243 Left err -> return (Left err)
4344 Right ns -> do srcs <- zipWithM buildFile' [1..] ns
4445 return (sequence srcs)
4546 where
46− buildFile' n name = putStrLn (msg n name) >> buildFile name
47+ buildFile' n name = putStrLn (msg n name) >> buildFile withPrelude name
4748 msg n name = "["++show n++" of "++show (length ns)++"] Compiling "++name
4849
49−buildFile :: String -> IO (Either String Module)
50−buildFile moduleName =
50+buildFile :: Bool -> String -> IO (Either String Module)
51+buildFile withPrelude moduleName =
5152 let filePath = toFilePath moduleName in
5253 case isNative moduleName of
5354 True -> return (Right $ Module [moduleName] [] [] [])
5455 --return (Left "Can't do that yet")
5556 --Right `liftM` readFile filePath
5657 False -> do txt <- readFile filePath
57− return $ buildFromSource txt
58+ return $ buildFromSource withPrelude txt
5859
5960
6061getSortedModuleNames :: FilePath -> IO (Either String [String])
@@ -87,7 +88,7 @@ readDeps seen root = do
8788 where realDeps = filter (`notElem` builtIns) deps
8889 newDeps = filter (`notElem` seen) realDeps
8990 seen' = root : seen ++ newDeps
90− builtIns = Map.keys libraries
91+ builtIns = Map.keys Libs.libraries
9192
9293isNative name = takeWhile (/='.') name == "Native"
9394toFilePath name = map swapDots name ++ ext
compiler/Language/Elm.hs+3−7
@@ -28,21 +28,17 @@ import ExtractNoscript
2828import GenerateHtml
2929import Initialize
3030import Text.Blaze.Html (Html)
31−import Language.Elm.Quasi
3231import Paths_Elm
3332
34−import qualified Data.Text as TS
35−import qualified Data.Text.Lazy as TL
36−
3733-- |This function compiles Elm code to JavaScript.
3834compile :: String -> String
39−compile source = either showErr (jsModule . Libraries.addPrelude) modul
40− where modul = buildFromSource source
35+compile source = either showErr jsModule modul
36+ where modul = buildFromSource True source
4137
4238-- |This function extracts the module name of a given source program.
4339moduleName :: String -> String
4440moduleName source = either (const "Main") getName modul
45− where modul = buildFromSource source
41+ where modul = buildFromSource False source
4642 getName (Ast.Module names _ _ _) = intercalate "." names
4743
4844-- |This function compiles Elm code into a full HTML page.
compiler/Model/Libraries.hs+20−10
@@ -6,8 +6,13 @@ import Data.List (inits)
66import Text.JSON
77import LoadLibraries (docs)
88
9+import System.IO.Unsafe
910
10−addPrelude (Module name exs ims stmts) = Module name exs (customIms ++ ims) stmts
11+addPrelude :: Module -> Module
12+addPrelude (Module name exs ims stmts) =
13+ unsafePerformIO $ do
14+ mapM print $ customIms ++ ims
15+ return $ Module name exs (customIms ++ ims) stmts
1116 where customIms = concatMap addModule prelude
1217
1318 addModule (n, method) = case lookup n ims of
@@ -23,15 +28,20 @@ prelude = text : map (\n -> (n, Hiding [])) modules
2328 , "Graphics.Collage", "Graphics.Geometry" ]
2429
2530libraries :: Map.Map String (Map.Map String String)
26−libraries = case getLibs of
27− Error err -> error err
28− Ok libs -> Map.unionWith Map.union libs nilAndTuples
29− where nilAndTuples = Map.singleton "Prelude" (Map.fromList pairs)
30− pairs = ("Nil", "List a") : map makeTuple (inits ['a'..'i'])
31− makeTuple cs =
32− let name = "Tuple" ++ show (length cs)
33− in (name, concatMap (\c -> c : " -> ") cs ++
34− name ++ concatMap (\c -> [' ',c]) cs)
31+libraries =
32+ case getLibs of
33+ Error err -> error err
34+ Ok libs -> Map.unionWith Map.union libs nilAndTuples
35+ where nilAndTuples = Map.singleton "Prelude" (Map.fromList pairs)
36+ pairs =
37+ [ ("Cons", "a -> [a] -> [a]")
38+ , ("Nil", "[a]")
39+ ] ++ map makeTuple (inits ['a'..'i'])
40+
41+ makeTuple cs =
42+ let name = "Tuple" ++ show (length cs)
43+ in (name, concatMap (\c -> c : " -> ") cs ++
44+ name ++ concatMap (\c -> [' ',c]) cs)
3545
3646getLibs :: Result (Map.Map String (Map.Map String String))
3747getLibs = do
compiler/Types/Hints.hs+4−1
@@ -12,8 +12,11 @@ import Types.Types
1212hints :: GuidCounter [(String, Scheme)]
1313hints = mapM toScheme values
1414 where
15− addPrefixes = concatMap (\(m,vs) -> map (first (\n -> m ++ "." ++ n)) vs)
15+
1616 values = addPrefixes (Map.toList (Map.map Map.toList libraries))
17+
18+ addPrefixes = concatMap (\(m,vs) -> map (first (\n -> m ++ "." ++ n)) vs)
19+
1720 toScheme (name, tipeString) =
1821 case iParse (fmap toType typeExpr) "parsing types in docs.json" tipeString of
1922 Left err -> error (show err)
compiler/Types/Substitutions.hs+5−5
@@ -113,11 +113,11 @@ superize name tipe =
113113 EmptyRecord -> return t
114114 Super _ -> return t
115115 VarT _ -> return t
116− LambdaT t1 t2 -> liftM2 LambdaT (go t1) (go t2)
117− ADT "Number" [] -> liftM VarT number
118− ADT "Appendable" [] -> liftM VarT append
119− ADT name ts -> liftM (ADT name) (mapM go ts)
120− RecordT fs t -> liftM2 RecordT fs' (go t)
116+ LambdaT t1 t2 -> liftM2 LambdaT (go t1) (go t2)
117+ ADT "Number" [] -> liftM VarT number
118+ ADT "Appendable" [t] -> liftM VarT append
119+ ADT name ts -> liftM (ADT name) (mapM go ts)
120+ RecordT fs t -> liftM2 RecordT fs' (go t)
121121 where pairs = Map.toList fs
122122 fs' = do ps <- mapM (\(f,t) -> liftM ((,) f) (mapM go t)) pairs
123123 return (Map.fromList ps)