@@ -1,176 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Build.File (build) where
3−
4−import Control.Applicative ((<$>))
5−import Control.Monad.Error (runErrorT)
6−import Control.Monad.RWS.Strict
7−import System.Directory
8−import System.Exit
9−import System.FilePath
10−import System.IO
11−
12−import qualified Data.Binary as Binary
13−import qualified Data.List as List
14−import qualified Data.Maybe as Maybe
15−import qualified Data.Map as Map
16−import qualified Data.ByteString.Lazy as L
17−
18−import qualified Build.Dependencies as Deps
19−import qualified Build.Flags as Flag
20−import qualified Build.Interface as Interface
21−import qualified Build.Print as Print
22−import qualified Build.Source as Source
23−import qualified Build.Utils as Utils
24−import qualified Generate.JavaScript as JS
25−import qualified Parse.Module as Parser
26−import qualified AST.Module as Module
27−
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
31−type BuildT m a = RWST Flag.Flags (Last String) BInterfaces m a
32−type Build a = BuildT IO a
33−
34−-- Interfaces, remembering if something was recompiled
35−type BInterfaces = Map.Map String (Bool, Module.Interface)
36−
37−evalBuild :: Flag.Flags -> Module.Interfaces -> Build ()
38− -> IO (Map.Map String Module.Interface, Maybe String)
39−evalBuild 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)
44−
45−-- | Builds a list of files, returning the moduleName of the last one.
46−-- Returns \"\" if the list is empty
47−build :: Flag.Flags -> Module.Interfaces -> [FilePath] -> IO String
48−build 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− ]
68−
69−buildAll :: [FilePath] -> Build ()
70−buildAll 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
77−
78− where number = join ["[", show num, " of ", show total, "]"]
79−
80− total = length fs
81−
82−shouldBeCompiled :: FilePath -> Build Bool
83−shouldBeCompiled 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
89−
90− outDated = liftIO $ do
91− tsrc <- getModificationTime filePath
92− tint <- getModificationTime (Utils.elmo flags filePath)
93− return (tsrc > tint)
94−
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
101−
102−
103− in (not <$> alreadyCompiled) `orM` outDated `orM` dependenciesUpdated
104−
105−wasCompiled :: String -> Build Bool
106−wasCompiled modul = maybe False fst . Map.lookup modul <$> get
107−
108−-- Short-circuiting monadic (||)
109−infixr 2 `orM`
110−orM :: (Monad m) => m Bool -> m Bool -> m Bool
111−orM m1 m2 = do b1 <- m1
112− if b1
113− then return b1
114− else m2
115−
116−anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
117−anyM f = foldr (orM . f) (return False)
118−
119−retrieve :: FilePath -> Build ()
120−retrieve 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
127−
128− Left err -> liftIO $ Print.failure err
129−
130−compile :: String -> FilePath -> Build ()
131−compile 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)
141−
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
147−
148− liftIO $ when (Flag.print_types flags) $ do
149− Print.types (Module.types (Module.body canonicalModule))
150−
151− let newInters = Module.toInterface canonicalModule
152− generateCache name newInters canonicalModule
153− update name newInters True
154−
155− where
156− getName source = case Parser.getModuleName source of
157− Just n -> n
158− Nothing -> "Main"
159−
160− printStatus name =
161− hPutStrLn stdout $ concat [ number, " Compiling ", name
162− , replicate (max 1 (20 - length name)) ' '
163− , "( " ++ filePath ++ " )" ]
164−
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))
172−
173−update :: String -> Module.Interface -> Bool -> Build ()
174−update name inter wasUpdated =
175− do modify (Map.insert name (wasUpdated, inter))
176− tell (Last . Just $ name)