git.iko.soy/elk
on 6511fc0 help sign in
elk/compiler/Build/File.hs
125 lines 4.5 kB history raw
1module Build.File (build) where
3import Control.Applicative ((<$>))
4import Control.Monad (when)
5import Control.Monad.RWS.Strict
6import qualified Data.Binary as Binary
7import qualified Data.List as List
8import qualified Data.Maybe as Maybe
9import Data.Monoid (Last(..))
10import qualified Data.Map as Map
11import System.Directory
12import System.Exit
13import System.FilePath
14import System.IO
16import qualified Transform.Canonicalize as Canonical
17import qualified Data.ByteString.Lazy as L
19import qualified Build.Utils as Utils
20import qualified Build.Flags as Flag
21import qualified Build.Source as Source
22import qualified Build.Print as Print
23import qualified Generate.JavaScript as JS
24import qualified InterfaceSerialization as IS
25import qualified Parse.Module as Parser
26import qualified SourceSyntax.Module as M
28-- Reader: Runtime flags, always accessible
29-- Writer: Remember the last module to be accessed
30-- State: Build up a map of the module interfaces
31type BuildT m a = RWST Flag.Flags (Last String) M.Interfaces m a
32type Build a = BuildT IO a
34evalBuild :: Flag.Flags -> M.Interfaces -> Build () -> IO (Maybe String)
35evalBuild fs is b = do
36 (_, s) <- evalRWST b fs is
37 return . getLast $ s
39-- Builds a list of files, returning the moduleName of the last one.
40-- Returns "" if the list is empty
41build :: Flag.Flags -> M.Interfaces -> [FilePath] -> IO String
42build flags is = fmap (Maybe.fromMaybe "") . evalBuild flags is . buildAll
44buildAll :: [FilePath] -> Build ()
45buildAll fs = mapM_ build1 (zip [1..] fs)
46 where build1 (num, fname) = do
47 compiled <- alreadyCompiled filePath
48 case compiled of
49 False ->
50 let number = join ["[", show num, " of ", show total, "]"]
51 compile number filePath
52 True -> retrieve filePath
53 total = length fs
55alreadyCompiled :: FilePath -> Build Bool
56alreadyCompiled filePath = do
57 flags <- ask
58 liftIO $ do
59 existsi <- doesFileExist (Utils.elmi flags filePath)
60 existso <- doesFileExist (Utils.elmo flags filePath)
61 if not existsi || not existso
62 then return False
63 else do tsrc <- getModificationTime filePath
64 tint <- getModificationTime (Utils.elmo flags filePath)
65 return (tsrc <= tint)
67retrieve :: FilePath -> Build ()
68retrieve filePath = do
69 flags <- ask
70 let elmi = Utils.elmi flags filePath
71 bytes <- liftIO $ IS.loadInterface elmi
72 let binary = IS.interfaceDecode elmi =<< bytes
73 case IS.validVersion filePath =<< binary of
74 Right (name, interface) ->
75 do interfaces <- get
76 liftIO $ when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
77 update name interface
79 Left err ->
80 liftIO $ hPutStrLn stderr err >> exitFailure
82compile :: String -> FilePath -> Build ()
83compile number filePath =
84 do flags <- ask
85 interfaces <- get
86 source <- liftIO $ readFile filePath
87 let name = getName source
88 liftIO $ do
89 printStatus name
90 createDirectoryIfMissing True (Flag.cache_dir flags)
91 createDirectoryIfMissing True (Flag.build_dir flags)
93 metaModule <-
94 liftIO $ case Source.build (Flag.no_prelude flags) interfaces source of
95 Right modul -> return modul
96 Left errors -> do Print.errors errors
97 exitFailure
99 liftIO $ when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule
101 let intermediate = (name, Canonical.interface name $ M.metaToInterface metaModule)
102 generateCache intermediate metaModule
103 uncurry update intermediate
105 where
106 getName source = case Parser.getModuleName source of
107 Just n -> n
108 Nothing -> "Main"
110 printStatus name =
111 hPutStrLn stdout $ concat [ number, " Compiling ", name
112 , replicate (max 1 (20 - length name)) ' '
113 , "( " ++ filePath ++ " )" ]
115 generateCache intermediate metaModule = do
116 flags <- ask
117 liftIO $ do
118 createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
119 writeFile (Utils.elmo flags filePath) (JS.generate metaModule)
120 withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->
121 L.hPut handle (Binary.encode intermediate)
123update :: String -> M.ModuleInterface -> Build ()
124update name inter = modify (Map.insert name inter)
125 >> tell (Last . Just $ name)