git.iko.soy/elk
on defb47d help sign in
elk/compiler/Build/File.hs
106 lines 4.0 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Build.File (build) where
4import Control.Monad (when)
5import qualified Data.Binary as Binary
6import qualified Data.Map as Map
7import System.Directory
8import System.Exit
9import System.FilePath
10import System.IO
12import qualified Transform.Canonicalize as Canonical
14import qualified Data.ByteString.Lazy as L
16import qualified Build.Utils as Utils
17import qualified Build.Flags as Flag
18import qualified Build.Source as Source
19import qualified Build.Print as Print
20import qualified Generate.JavaScript as JS
21import qualified InterfaceSerialization as IS
22import qualified Parse.Module as Parser
23import qualified SourceSyntax.Module as M
25build :: Flag.Flags -> Int -> M.Interfaces -> String -> [FilePath]
26 -> IO (String, M.Interfaces)
27build _ _ interfaces moduleName [] =
28 return (moduleName, interfaces)
29build flags numModules interfaces _ (filePath:rest) =
30 do (name,interface) <-
31 build1 flags (numModules - length rest) numModules interfaces filePath
32 let interfaces' = Map.insert name interface interfaces
33 build flags numModules interfaces' name rest
36build1 :: Flag.Flags -> Int -> Int -> M.Interfaces -> FilePath
37 -> IO (String, M.ModuleInterface)
38build1 flags moduleNum numModules interfaces filePath =
39 do compiled <- alreadyCompiled flags filePath
40 case compiled of
41 False -> compile flags number interfaces filePath
42 True -> retrieve flags interfaces filePath
43 where
44 number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"
47alreadyCompiled :: Flag.Flags -> FilePath -> IO Bool
48alreadyCompiled flags filePath = do
49 existsi <- doesFileExist (Utils.elmi flags filePath)
50 existso <- doesFileExist (Utils.elmo flags filePath)
51 if not existsi || not existso
52 then return False
53 else do tsrc <- getModificationTime filePath
54 tint <- getModificationTime (Utils.elmo flags filePath)
55 return (tsrc <= tint)
57retrieve :: Flag.Flags -> Map.Map String M.ModuleInterface -> FilePath
58 -> IO (String, M.ModuleInterface)
59retrieve flags interfaces filePath = do
60 bytes <- IS.loadInterface (Utils.elmi flags filePath)
61 let binary = IS.interfaceDecode (Utils.elmi flags filePath) =<< bytes
62 case IS.validVersion filePath =<< binary of
63 Right (name, interface) ->
64 do when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
65 return (name, interface)
66 Left err ->
67 do hPutStrLn stderr err
68 exitFailure
70compile :: Flag.Flags -> String -> M.Interfaces -> FilePath
71 -> IO (String, M.ModuleInterface)
72compile flags number interfaces filePath =
73 do source <- readFile filePath
74 let name = getName source
75 printStatus name
77 createDirectoryIfMissing True (Flag.cache_dir flags)
78 createDirectoryIfMissing True (Flag.build_dir flags)
80 metaModule <-
81 case Source.build (Flag.no_prelude flags) interfaces source of
82 Right modul -> return modul
83 Left errors -> do Print.errors errors
84 exitFailure
86 when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule
88 let intermediate = (name, Canonical.interface name $ M.metaToInterface metaModule)
89 generateCache intermediate metaModule
90 return intermediate
92 where
93 getName source = case Parser.getModuleName source of
94 Just n -> n
95 Nothing -> "Main"
97 printStatus name =
98 hPutStrLn stdout $ concat [ number, " Compiling ", name
99 , replicate (max 1 (20 - length name)) ' '
100 , "( " ++ filePath ++ " )" ]
102 generateCache intermediate metaModule = do
103 createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
104 writeFile (Utils.elmo flags filePath) (JS.generate metaModule)
105 withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->
106 L.hPut handle (Binary.encode intermediate)