git.iko.soy/rowtype-yoga/purescript-native
on ebbc4e4 help sign in
rowtype-yoga/purescript-native/pcc/Make.hs
175 lines 6.7 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : Make
4-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5-- License : MIT
6--
7-- Maintainer : Andy Arvanitis
8-- Stability : experimental
9-- Portability :
10--
11-- |
12--
13-----------------------------------------------------------------------------
15{-# LANGUAGE DataKinds #-}
16{-# LANGUAGE FlexibleContexts #-}
17{-# LANGUAGE GeneralizedNewtypeDeriving #-}
18{-# LANGUAGE TupleSections #-}
19{-# LANGUAGE TemplateHaskell #-}
21module Make
22 ( Make(..)
23 , runMake
24 , buildMakeActions
25 ) where
27import Control.Monad
28import Control.Monad.Error.Class (MonadError(..))
29import Control.Monad.Reader
31import Data.FileEmbed (embedFile)
32import Data.List (intercalate)
33import Data.Maybe (fromMaybe)
34import Data.String (fromString)
35import Data.Time.Clock
36import Data.Version (showVersion)
37import qualified Data.Map as M
38import qualified Data.ByteString.Char8 as B
40import System.Directory (doesDirectoryExist, doesFileExist, getModificationTime, createDirectoryIfMissing)
41import System.FilePath ((</>), takeDirectory, addExtension, dropExtension)
42import System.IO.Error (tryIOError)
43import System.IO.UTF8
45import Language.PureScript.Errors
46import Language.PureScript (Make, runMake)
48import qualified Language.PureScript as P
49import qualified Language.PureScript.CodeGen.Cpp as CPP
50import qualified Language.PureScript.CoreFn as CF
51import qualified Paths_purescript as Paths
53makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
54makeIO f io = do
55 e <- liftIO $ tryIOError io
56 either (throwError . P.singleError . f) return e
58-- Traverse (Either e) instance (base 4.7)
59traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
60traverseEither _ (Left x) = pure (Left x)
61traverseEither f (Right y) = Right <$> f y
63buildMakeActions :: FilePath
64 -> M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
65 -> Bool
66 -> P.MakeActions Make
67buildMakeActions outputDir filePathMap usePrefix =
68 P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
69 where
71 getInputFile :: P.ModuleName -> FilePath
72 getInputFile mn =
73 let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap in
74 case path of
75 Right path' -> path'
76 Left _ -> error "Module has no filename in 'make'"
78 getInputTimestamp :: P.ModuleName -> Make (Either P.RebuildPolicy (Maybe UTCTime))
79 getInputTimestamp mn = do
80 let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
81 traverseEither getTimestamp path
83 getOutputTimestamp :: P.ModuleName -> Make (Maybe UTCTime)
84 getOutputTimestamp mn = do
86 let filePath = dotsTo '/' $ P.runModuleName mn
87 fileBase = outputDir </> filePath </> (last . words . dotsTo ' ' $ P.runModuleName mn)
88 srcFile = addExtension fileBase "cc"
89-- headerFile = addExtension fileBase "hh"
90 externsFile = outputDir </> filePath </> "externs.purs"
91 min <$> getTimestamp srcFile <*> getTimestamp externsFile
93 readExterns :: P.ModuleName -> Make (FilePath, P.Externs)
94 readExterns mn = do
95 let path = outputDir </> (dotsTo '/' $ P.runModuleName mn) </> "externs.purs"
96 (path, ) <$> readTextFile path
98 codegen :: CF.Module CF.Ann -> P.Environment -> P.Externs -> P.SupplyT Make ()
99 codegen m env exts = do
100 let mn = CF.moduleName m
101 let filePath = dotsTo '/' $ P.runModuleName mn
102 fileBase = outputDir </> filePath </> (last . words . dotsTo ' ' $ P.runModuleName mn)
103 srcFile = addExtension fileBase "cc"
104 headerFile = addExtension fileBase "hh"
105 externsFile = outputDir </> filePath </> "externs.purs"
106 prefix = ["Generated by pcc version " ++ showVersion Paths.version | usePrefix]
107 cpps <- CPP.moduleToCpp env m
108 let (hdrs,srcs) = span (/= CPP.CppEndOfHeader) cpps
109 psrcs <- CPP.prettyPrintCpp <$> pure srcs
110 phdrs <- CPP.prettyPrintCpp <$> pure hdrs
111 let src = unlines $ map ("// " ++) prefix ++ [psrcs]
112 hdr = unlines $ map ("// " ++) prefix ++ [phdrs]
114 lift $ do
115 writeTextFile srcFile src
116 writeTextFile headerFile hdr
117 writeTextFile externsFile exts
119 let supportDir = outputDir </> "PureScript"
120 supportFilesExist <- dirExists supportDir
121 when (not supportFilesExist) $ do
122 writeTextFile (supportDir </> "PureScript.hh") $ B.unpack $(embedFile "pcc/include/purescript.hh")
123 writeTextFile (supportDir </> "PureScript.cc") $ B.unpack $(embedFile "pcc/include/purescript.cc")
124 writeTextFile (supportDir </> "PureScript_GC.hh") $ B.unpack $(embedFile "pcc/include/purescript_gc.hh")
126 let inputPath = dropExtension $ getInputFile mn
127 hfile = addExtension inputPath "hh"
128 sfile = addExtension inputPath "cc"
129 hfileExists <- textFileExists hfile
130 when (hfileExists || requiresForeign m) $ do
131 text <- if hfileExists
132 then readTextFile hfile
133 else pure []
134 writeTextFile (addExtension (fileBase ++ "_ffi") "hh") text
135 sfileExists <- textFileExists sfile
136 when (sfileExists) $ do
137 text' <- readTextFile sfile
138 writeTextFile (addExtension (fileBase ++ "_ffi") "cc") text'
140 requiresForeign :: CF.Module a -> Bool
141 requiresForeign = not . null . CF.moduleForeign
143 dirExists :: FilePath -> Make Bool
144 dirExists path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ do
145 doesDirectoryExist path
147 textFileExists :: FilePath -> Make Bool
148 textFileExists path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ do
149 doesFileExist path
151 getTimestamp :: FilePath -> Make (Maybe UTCTime)
152 getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do
153 exists <- doesFileExist path
154 traverse (const $ getModificationTime path) $ guard exists
156 readTextFile :: FilePath -> Make String
157 readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path
159 writeTextFile :: FilePath -> String -> Make ()
160 writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
161 mkdirp path
162 writeFile path text
163 where
164 mkdirp :: FilePath -> IO ()
165 mkdirp = createDirectoryIfMissing True . takeDirectory
167 -- | Render a progress message
168 renderProgressMessage :: P.ProgressMessage -> String
169 renderProgressMessage (P.CompilingModule mn) = "Compiling " ++ P.runModuleName mn
171 progress :: P.ProgressMessage -> Make ()
172 progress = liftIO . putStrLn . renderProgressMessage
174dotsTo :: Char -> String -> String
175dotsTo chr = map (\c -> if c == '.' then chr else c)