git.iko.soy/elk
on 89bbbb9 help sign in
elk/compiler/Build/File.hs
176 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 liftIO $ when (Flag.print_types flags) (Print.types (Module.iTypes interface))
126 update name interface False
128 Left err -> liftIO $ Print.failure err
130compile :: String -> FilePath -> Build ()
131compile number filePath =
132 do flags <- ask
133 binterfaces <- get
134 source <- liftIO $ readFile filePath
135 let interfaces = snd <$> binterfaces
136 name = getName source
137 liftIO $ do
138 printStatus name
139 createDirectoryIfMissing True (Flag.cache_dir flags)
140 createDirectoryIfMissing True (Flag.build_dir flags)
142 canonicalModule <-
143 liftIO $ case Source.build (Flag.no_prelude flags) interfaces source of
144 Right modul -> return modul
145 Left errors -> do Print.errors errors
146 exitFailure
148 liftIO $ when (Flag.print_types flags) $ do
149 Print.types (Module.types (Module.body canonicalModule))
151 let newInters = Module.toInterface canonicalModule
152 generateCache name newInters canonicalModule
153 update name newInters True
155 where
156 getName source = case Parser.getModuleName source of
157 Just n -> n
158 Nothing -> "Main"
160 printStatus name =
161 hPutStrLn stdout $ concat [ number, " Compiling ", name
162 , replicate (max 1 (20 - length name)) ' '
163 , "( " ++ filePath ++ " )" ]
165 generateCache name interfs canonicalModule = do
166 flags <- ask
167 liftIO $ do
168 createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
169 writeFile (Utils.elmo flags filePath) (JS.generate canonicalModule)
170 withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->
171 L.hPut handle (Binary.encode (name, interfs))
173update :: String -> Module.Interface -> Bool -> Build ()
174update name inter wasUpdated =
175 do modify (Map.insert name (wasUpdated, inter))
176 tell (Last . Just $ name)