git.iko.soy/elk
on 021af44 help sign in
elk/compiler/Build/File.hs
178 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 SourceSyntax.Module as M
27import qualified Transform.Canonicalize as Canonical
29-- Reader: Runtime flags, always accessible
30-- Writer: Remember the last module to be accessed
31-- State: Build up a map of the module interfaces
32type BuildT m a = RWST Flag.Flags (Last String) BInterfaces m a
33type Build a = BuildT IO a
35-- Interfaces, remembering if something was recompiled
36type BInterfaces = Map.Map String (Bool, M.ModuleInterface)
38evalBuild :: Flag.Flags -> M.Interfaces -> Build ()
39 -> IO (Map.Map String M.ModuleInterface, Maybe String)
40evalBuild flags interfaces build =
41 do (ifaces, moduleNames) <- execRWST build flags (fmap notUpdated interfaces)
42 return (fmap snd ifaces, getLast moduleNames)
43 where
44 notUpdated iface = (False, iface)
46-- | Builds a list of files, returning the moduleName of the last one.
47-- Returns \"\" if the list is empty
48build :: Flag.Flags -> M.Interfaces -> [FilePath] -> IO String
49build flags interfaces files =
50 do (ifaces, topName) <- evalBuild flags interfaces (buildAll files)
51 let removeTopName = Maybe.maybe id Map.delete topName
52 mapM_ (checkPorts topName) (Map.toList $ removeTopName ifaces)
53 return $ Maybe.fromMaybe "" topName
54 where
55 checkPorts topName (name,iface)
56 | null ports = return ()
57 | otherwise = Print.failure msg
58 where
59 ports = M.iPorts iface
60 msg = concat
61 [ "Port Error: ports may only appear in the main module, but\n"
62 , " sub-module ", name, " declares the following port"
63 , if length ports == 1 then "" else "s", ": "
64 , List.intercalate ", " ports
65 , case topName of
66 Nothing -> ""
67 Just tname -> "\n All ports must appear in module " ++ tname
68 ]
70buildAll :: [FilePath] -> Build ()
71buildAll fs = mapM_ (uncurry build1) (zip [1..] fs)
72 where build1 :: Integer -> FilePath -> Build ()
73 build1 num fname = do
74 shouldCompile <- shouldBeCompiled fname
75 if shouldCompile
76 then compile number fname
77 else retrieve fname
79 where number = join ["[", show num, " of ", show total, "]"]
81 total = length fs
83shouldBeCompiled :: FilePath -> Build Bool
84shouldBeCompiled filePath = do
85 flags <- ask
86 let alreadyCompiled = liftIO $ do
87 existsi <- doesFileExist (Utils.elmi flags filePath)
88 existso <- doesFileExist (Utils.elmo flags filePath)
89 return $ existsi && existso
91 outDated = liftIO $ do
92 tsrc <- getModificationTime filePath
93 tint <- getModificationTime (Utils.elmo flags filePath)
94 return (tsrc > tint)
96 dependenciesUpdated = do
97 eDeps <- liftIO . runErrorT $ Deps.readDeps filePath
98 case eDeps of
99 -- Should never actually reach here
100 Left err -> liftIO $ Print.failure err
101 Right (_, deps) -> anyM wasCompiled deps
104 in (not <$> alreadyCompiled) `orM` outDated `orM` dependenciesUpdated
106wasCompiled :: String -> Build Bool
107wasCompiled modul = maybe False fst . Map.lookup modul <$> get
109-- Short-circuiting monadic (||)
110infixr 2 `orM`
111orM :: (Monad m) => m Bool -> m Bool -> m Bool
112orM m1 m2 = do b1 <- m1
113 if b1
114 then return b1
115 else m2
117anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
118anyM f = foldr (orM . f) (return False)
120retrieve :: FilePath -> Build ()
121retrieve filePath = do
122 flags <- ask
123 iface <- liftIO $ Interface.load (Utils.elmi flags filePath)
124 case Interface.isValid filePath iface of
125 Right (name, interface) ->
126 do binterfaces <- get
127 let interfaces = snd <$> binterfaces
128 liftIO $ when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
129 update name interface False
131 Left err -> liftIO $ Print.failure err
133compile :: String -> FilePath -> Build ()
134compile number filePath =
135 do flags <- ask
136 binterfaces <- get
137 source <- liftIO $ readFile filePath
138 let interfaces = snd <$> binterfaces
139 name = getName source
140 liftIO $ do
141 printStatus name
142 createDirectoryIfMissing True (Flag.cache_dir flags)
143 createDirectoryIfMissing True (Flag.build_dir flags)
145 metaModule <-
146 liftIO $ case Source.build (Flag.no_prelude flags) interfaces source of
147 Right modul -> return modul
148 Left errors -> do Print.errors errors
149 exitFailure
151 liftIO $ when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule
153 let newInters = Canonical.interface name $ M.metaToInterface metaModule
154 generateCache name newInters metaModule
155 update name newInters True
157 where
158 getName source = case Parser.getModuleName source of
159 Just n -> n
160 Nothing -> "Main"
162 printStatus name =
163 hPutStrLn stdout $ concat [ number, " Compiling ", name
164 , replicate (max 1 (20 - length name)) ' '
165 , "( " ++ filePath ++ " )" ]
167 generateCache name interfs metaModule = do
168 flags <- ask
169 liftIO $ do
170 createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
171 writeFile (Utils.elmo flags filePath) (JS.generate metaModule)
172 withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->
173 L.hPut handle (Binary.encode (name, interfs))
175update :: String -> M.ModuleInterface -> Bool -> Build ()
176update name inter wasUpdated =
177 do modify (Map.insert name (wasUpdated, inter))
178 tell (Last . Just $ name)