git.iko.soy/elk
on d41a656 help sign in
elk/compiler/Build/File.hs
177 lines 6.5 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.List as List
14import qualified Data.Maybe as Maybe
15import qualified Data.Map as Map
16import qualified Data.ByteString.Lazy as L
18import qualified Build.Dependencies as Deps
19import qualified Build.Flags as Flag
20import qualified Build.Interface as Interface
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 Parse.Module as Parser
26import qualified AST.Module as Module
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, Module.Interface)
37evalBuild :: Flag.Flags -> Module.Interfaces -> Build ()
38 -> IO (Map.Map String Module.Interface, Maybe String)
39evalBuild flags interfaces build =
40 do (ifaces, moduleNames) <- execRWST build flags (fmap notUpdated interfaces)
41 return (fmap snd ifaces, getLast moduleNames)
42 where
43 notUpdated iface = (False, iface)
45-- | Builds a list of files, returning the moduleName of the last one.
46-- Returns \"\" if the list is empty
47build :: Flag.Flags -> Module.Interfaces -> [FilePath] -> IO String
48build flags interfaces files =
49 do (ifaces, topName) <- evalBuild flags interfaces (buildAll files)
50 let removeTopName = Maybe.maybe id Map.delete topName
51 mapM_ (checkPorts topName) (Map.toList $ removeTopName ifaces)
52 return $ Maybe.fromMaybe "" topName
53 where
54 checkPorts topName (name,iface)
55 | null ports = return ()
56 | otherwise = Print.failure msg
57 where
58 ports = Module.iPorts iface
59 msg = concat
60 [ "Port Error: ports may only appear in the main module, but\n"
61 , " sub-module ", name, " declares the following port"
62 , if length ports == 1 then "" else "s", ": "
63 , List.intercalate ", " ports
64 , case topName of
65 Nothing -> ""
66 Just tname -> "\n All ports must appear in module " ++ tname
67 ]
69buildAll :: [FilePath] -> Build ()
70buildAll fs = mapM_ (uncurry build1) (zip [1..] fs)
71 where build1 :: Integer -> FilePath -> Build ()
72 build1 num fname = do
73 shouldCompile <- shouldBeCompiled fname
74 if shouldCompile
75 then compile number fname
76 else retrieve fname
78 where number = join ["[", show num, " of ", show total, "]"]
80 total = length fs
82shouldBeCompiled :: FilePath -> Build Bool
83shouldBeCompiled filePath = do
84 flags <- ask
85 let alreadyCompiled = liftIO $ do
86 existsi <- doesFileExist (Utils.elmi flags filePath)
87 existso <- doesFileExist (Utils.elmo flags filePath)
88 return $ existsi && existso
90 outDated = liftIO $ do
91 tsrc <- getModificationTime filePath
92 tint <- getModificationTime (Utils.elmo flags filePath)
93 return (tsrc > tint)
95 dependenciesUpdated = do
96 eDeps <- liftIO . runErrorT $ Deps.readDeps filePath
97 case eDeps of
98 -- Should never actually reach here
99 Left err -> liftIO $ Print.failure err
100 Right (_, deps) -> anyM wasCompiled deps
103 in (not <$> alreadyCompiled) `orM` outDated `orM` dependenciesUpdated
105wasCompiled :: String -> Build Bool
106wasCompiled modul = maybe False fst . Map.lookup modul <$> get
108-- Short-circuiting monadic (||)
109infixr 2 `orM`
110orM :: (Monad m) => m Bool -> m Bool -> m Bool
111orM m1 m2 = do b1 <- m1
112 if b1
113 then return b1
114 else m2
116anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
117anyM f = foldr (orM . f) (return False)
119retrieve :: FilePath -> Build ()
120retrieve filePath = do
121 flags <- ask
122 iface <- liftIO $ Interface.load (Utils.elmi flags filePath)
123 case Interface.isValid filePath iface of
124 Right (name, interface) ->
125 do binterfaces <- get
126 let interfaces = snd <$> binterfaces
127 liftIO $ when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
128 update name interface False
130 Left err -> liftIO $ Print.failure err
132compile :: String -> FilePath -> Build ()
133compile number filePath =
134 do flags <- ask
135 binterfaces <- get
136 source <- liftIO $ readFile filePath
137 let interfaces = snd <$> binterfaces
138 name = getName source
139 liftIO $ do
140 printStatus name
141 createDirectoryIfMissing True (Flag.cache_dir flags)
142 createDirectoryIfMissing True (Flag.build_dir flags)
144 canonicalModule <-
145 liftIO $ case Source.build (Flag.no_prelude flags) interfaces source of
146 Right modul -> return modul
147 Left errors -> do Print.errors errors
148 exitFailure
150 liftIO $ when (Flag.print_types flags) $ Print.moduleTypes interfaces canonicalModule
152 let newInters = Module.toInterface canonicalModule
153 generateCache name newInters canonicalModule
154 update name newInters True
156 where
157 getName source = case Parser.getModuleName source of
158 Just n -> n
159 Nothing -> "Main"
161 printStatus name =
162 hPutStrLn stdout $ concat [ number, " Compiling ", name
163 , replicate (max 1 (20 - length name)) ' '
164 , "( " ++ filePath ++ " )" ]
166 generateCache name interfs canonicalModule = do
167 flags <- ask
168 liftIO $ do
169 createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
170 writeFile (Utils.elmo flags filePath) (JS.generate canonicalModule)
171 withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->
172 L.hPut handle (Binary.encode (name, interfs))
174update :: String -> Module.Interface -> Bool -> Build ()
175update name inter wasUpdated =
176 do modify (Map.insert name (wasUpdated, inter))
177 tell (Last . Just $ name)