git.iko.soy/elk
on cf9d21b help sign in
elk/compiler/Build/File.hs
158 lines 5.7 kB history raw
1module Build.File (build) where
3import Control.Applicative ((<$>), (<*>), pure)
4import Control.Monad (when)
5import Control.Monad.Error (runErrorT)
6import Control.Monad.RWS.Strict
7import Data.Monoid (Last(..))
8import System.Directory
9import System.Exit
10import System.FilePath
11import System.IO
13import qualified Data.Binary as Binary
14import qualified Data.List as List
15import qualified Data.Maybe as Maybe
16import qualified Data.Map as Map
17import qualified Data.ByteString.Lazy as L
19import qualified Build.Dependencies as Deps
20import qualified Build.Flags as Flag
21import qualified Build.Print as Print
22import qualified Build.Source as Source
23import qualified Build.Utils as Utils
24import qualified Generate.JavaScript as JS
25import qualified InterfaceSerialization as IS
26import qualified Parse.Module as Parser
27import qualified SourceSyntax.Module as M
28import qualified Transform.Canonicalize as Canonical
30-- Reader: Runtime flags, always accessible
31-- Writer: Remember the last module to be accessed
32-- State: Build up a map of the module interfaces
33type BuildT m a = RWST Flag.Flags (Last String) BInterfaces m a
34type Build a = BuildT IO a
36-- Interfaces, remembering if something was recompiled
37type BInterfaces = Map.Map String (Bool, M.ModuleInterface)
39evalBuild :: Flag.Flags -> M.Interfaces -> Build () -> IO (Maybe String)
40evalBuild fs is b = do
41 (_, s) <- evalRWST b fs (fmap notUpdated is)
42 return . getLast $ s
43 where notUpdated i = (False, i)
45-- | Builds a list of files, returning the moduleName of the last one.
46-- Returns \"\" if the list is empty
47build :: Flag.Flags -> M.Interfaces -> [FilePath] -> IO String
48build flags is = fmap (Maybe.fromMaybe "") . evalBuild flags is . buildAll
50buildAll :: [FilePath] -> Build ()
51buildAll fs = mapM_ (uncurry build1) (zip [1..] fs)
52 where build1 num fname = do
53 shouldCompile <- shouldBeCompiled fname
54 if shouldCompile
55 then compile number fname
56 else retrieve fname
58 where number = join ["[", show num, " of ", show total, "]"]
60 total = length fs
62shouldBeCompiled :: FilePath -> Build Bool
63shouldBeCompiled filePath = do
64 flags <- ask
65 let alreadyCompiled = liftIO $ do
66 existsi <- doesFileExist (Utils.elmi flags filePath)
67 existso <- doesFileExist (Utils.elmo flags filePath)
68 return $ existsi && existso
70 outDated = liftIO $ do
71 tsrc <- getModificationTime filePath
72 tint <- getModificationTime (Utils.elmo flags filePath)
73 return (tsrc > tint)
75 dependenciesUpdated = do
76 eDeps <- liftIO . runErrorT $ Deps.readDeps filePath
77 case eDeps of
78 -- Should never actually reach here
79 Left err -> liftIO $ Print.failure err
80 Right (_, deps) -> anyM wasCompiled deps
83 in (not <$> alreadyCompiled) `orM` outDated `orM` dependenciesUpdated
85wasCompiled :: String -> Build Bool
86wasCompiled modul = maybe False fst . Map.lookup modul <$> get
88-- Short-circuiting monadic (||)
89infixr 2 `orM`
90orM :: (Monad m) => m Bool -> m Bool -> m Bool
91orM m1 m2 = do b1 <- m1
92 if b1
93 then return b1
94 else m2
96anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
97anyM f = foldr (orM . f) (return False)
99retrieve :: FilePath -> Build ()
100retrieve filePath = do
101 flags <- ask
102 let elmi = Utils.elmi flags filePath
103 bytes <- liftIO $ IS.loadInterface elmi
104 let binary = IS.interfaceDecode elmi =<< bytes
105 case IS.validVersion filePath =<< binary of
106 Right (name, interface) ->
107 do binterfaces <- get
108 let interfaces = snd <$> binterfaces
109 liftIO $ when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
110 update name interface False
112 Left err -> liftIO $ Print.failure err
114compile :: String -> FilePath -> Build ()
115compile number filePath =
116 do flags <- ask
117 binterfaces <- get
118 source <- liftIO $ readFile filePath
119 let interfaces = snd <$> binterfaces
120 name = getName source
121 liftIO $ do
122 printStatus name
123 createDirectoryIfMissing True (Flag.cache_dir flags)
124 createDirectoryIfMissing True (Flag.build_dir flags)
126 metaModule <-
127 liftIO $ case Source.build (Flag.no_prelude flags) interfaces source of
128 Right modul -> return modul
129 Left errors -> do Print.errors errors
130 exitFailure
132 liftIO $ when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule
134 let newInters = Canonical.interface name $ M.metaToInterface metaModule
135 generateCache name newInters metaModule
136 update name newInters True
138 where
139 getName source = case Parser.getModuleName source of
140 Just n -> n
141 Nothing -> "Main"
143 printStatus name =
144 hPutStrLn stdout $ concat [ number, " Compiling ", name
145 , replicate (max 1 (20 - length name)) ' '
146 , "( " ++ filePath ++ " )" ]
148 generateCache name interfs metaModule = do
149 flags <- ask
150 liftIO $ do
151 createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
152 writeFile (Utils.elmo flags filePath) (JS.generate metaModule)
153 withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->
154 L.hPut handle (Binary.encode (name, interfs))
156update :: String -> M.ModuleInterface -> Bool -> Build ()
157update name inter wasUpdated = modify (Map.insert name (wasUpdated, inter))
158 >> tell (Last . Just $ name)