git.iko.soy/elk
on 0cd2af2 help sign in
elk/compiler/Build/File.hs
156 lines 5.6 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Build.File (build) where
4import Control.Applicative ((<$>))
5import Control.Monad.Error (runErrorT)
6import Control.Monad.RWS.Strict
7import System.Directory
8import System.Exit
9import System.FilePath
10import System.IO
12import qualified Data.Binary as Binary
13import qualified Data.Maybe as Maybe
14import qualified Data.Map as Map
15import qualified Data.ByteString.Lazy as L
17import qualified Build.Dependencies as Deps
18import qualified Build.Flags as Flag
19import qualified Build.Interface as Interface
20import qualified Build.Print as Print
21import qualified Build.Source as Source
22import qualified Build.Utils as Utils
23import qualified Generate.JavaScript as JS
24import qualified Parse.Module as Parser
25import qualified SourceSyntax.Module as M
26import qualified Transform.Canonicalize as Canonical
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) BInterfaces m a
32type Build a = BuildT IO a
34-- Interfaces, remembering if something was recompiled
35type BInterfaces = Map.Map String (Bool, M.ModuleInterface)
37evalBuild :: Flag.Flags -> M.Interfaces -> Build () -> IO (Maybe String)
38evalBuild flags interfaces b = do
39 (_, s) <- evalRWST b flags (fmap notUpdated interfaces)
40 return . getLast $ s
41 where
42 notUpdated i = (False, i)
44-- | Builds a list of files, returning the moduleName of the last one.
45-- Returns \"\" if the list is empty
46build :: Flag.Flags -> M.Interfaces -> [FilePath] -> IO String
47build flags is = fmap (Maybe.fromMaybe "") . evalBuild flags is . buildAll
49buildAll :: [FilePath] -> Build ()
50buildAll fs = mapM_ (uncurry build1) (zip [1..] fs)
51 where build1 :: Integer -> FilePath -> Build ()
52 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 iface <- liftIO $ Interface.load (Utils.elmi flags filePath)
103 case Interface.isValid filePath iface of
104 Right (name, interface) ->
105 do binterfaces <- get
106 let interfaces = snd <$> binterfaces
107 liftIO $ when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
108 update name interface False
110 Left err -> liftIO $ Print.failure err
112compile :: String -> FilePath -> Build ()
113compile number filePath =
114 do flags <- ask
115 binterfaces <- get
116 source <- liftIO $ readFile filePath
117 let interfaces = snd <$> binterfaces
118 name = getName source
119 liftIO $ do
120 printStatus name
121 createDirectoryIfMissing True (Flag.cache_dir flags)
122 createDirectoryIfMissing True (Flag.build_dir flags)
124 metaModule <-
125 liftIO $ case Source.build (Flag.no_prelude flags) interfaces source of
126 Right modul -> return modul
127 Left errors -> do Print.errors errors
128 exitFailure
130 liftIO $ when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule
132 let newInters = Canonical.interface name $ M.metaToInterface metaModule
133 generateCache name newInters metaModule
134 update name newInters True
136 where
137 getName source = case Parser.getModuleName source of
138 Just n -> n
139 Nothing -> "Main"
141 printStatus name =
142 hPutStrLn stdout $ concat [ number, " Compiling ", name
143 , replicate (max 1 (20 - length name)) ' '
144 , "( " ++ filePath ++ " )" ]
146 generateCache name interfs metaModule = do
147 flags <- ask
148 liftIO $ do
149 createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
150 writeFile (Utils.elmo flags filePath) (JS.generate metaModule)
151 withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->
152 L.hPut handle (Binary.encode (name, interfs))
154update :: String -> M.ModuleInterface -> Bool -> Build ()
155update name inter wasUpdated = modify (Map.insert name (wasUpdated, inter))
156 >> tell (Last . Just $ name)