@@ -10,7 +10,7 @@ import Data.Aeson
1010import Data.Aeson.Types
1111import Data.Char
1212import Data.FileEmbed (embedFile)
13−import Data.List (delete, isPrefixOf, partition)
13+import Data.List (delete, intercalate, isPrefixOf, nub, partition, (\\))
1414import Data.Maybe
1515import Data.Monoid ((<>))
1616import Data.Version
@@ -19,8 +19,10 @@ import Control.Monad.Supply.Class
1919import Text.Printf
2020
2121import System.Environment
22−import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getModificationTime)
22+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getCurrentDirectory, getModificationTime)
2323import System.FilePath ((</>), joinPath, splitDirectories, takeDirectory)
24+import System.FilePath.Find
25+import System.Process
2426
2527import Data.Text (Text)
2628import qualified Data.Text as T
@@ -29,6 +31,8 @@ import qualified Data.Text.Lazy as L
2931import qualified Data.Text.Lazy.Encoding as L
3032import qualified Data.ByteString as B
3133
34+import Development.GitRev
35+
3236import Language.PureScript.AST.Literals
3337import Language.PureScript.CoreFn
3438import Language.PureScript.CoreFn.FromJSON
@@ -39,6 +43,8 @@ import CodeGen.IL.Printer
3943
4044import Tests
4145
46+data Command = Build | Run (Maybe String)
47+
4248parseJson :: Text -> Value
4349parseJson text
4450 | Just fileJson <- decode . L.encodeUtf8 $ L.fromStrict text = fileJson
@@ -48,40 +54,98 @@ jsonToModule :: Value -> Module Ann
4854jsonToModule value =
4955 case parse moduleFromJSON value of
5056 Success (_, r) -> r
51− _ -> error "failed"
57+ _ -> error "Failed parsing corefn. Psgo currently supports purescript <= 0.13.8"
58+
59+splitArgs :: [String] -> ([String], Maybe String, [String])
60+splitArgs args =
61+ let (opts, files) = partition (isPrefixOf "--") args
62+ opts' = (map . map) toLower opts
63+ (moduleName, files') =
64+ if null files
65+ then (Nothing, files)
66+ else
67+ if "--run" `elem` opts' && length (files) >= 1
68+ then do
69+ let file0 = head files
70+ files' = tail files
71+ case file0 of
72+ "Main.main" -> (Just "Main", files')
73+ "Test.Main.main" -> (Just "Test.Main", files')
74+ _ -> (Nothing, files)
75+ else (Nothing, files)
76+ in (opts, moduleName, files')
5277
5378main :: IO ()
5479main = do
5580 args <- getArgs
56− if null args
57− then return ()
81+ -- let (opts, files) = partition (isPrefixOf "--") args
82+ let (opts, moduleName, files) = splitArgs args
83+ opts' = (map . map) toLower opts
84+ if "--tests" `elem` opts'
85+ then runTests
5886 else do
59− let (opts, files) = partition (isPrefixOf "--") args
60− opts' = (map . map) toLower opts
61− if "--tests" `elem` opts'
62− then runTests
63− else do
64− when ("--makefile" `elem` opts') $
65− B.writeFile "Makefile" $(embedFile "support/Makefile")
66− when ("--help" `elem` opts') $
87+ if "--help" `elem` opts' || "--version" `elem` opts'
88+ then do
89+ when ("--help" `elem` opts') $ do
6790 putStrLn help
68− when (not $ null files) $ do
69− let filepath = takeDirectory (head files)
70− baseOutpath = joinPath $ (init $ splitDirectories filepath) ++ [outdir]
71− writeRuntimeFiles baseOutpath
72− Par.mapM (generateCode opts' baseOutpath) files
73− return ()
74− return ()
91+ when ("--version" `elem` opts') $ do
92+ let branch = $(gitBranch)
93+ details | branch == "golang" = "master, commit " ++ $(gitHash)
94+ | otherwise = branch
95+ putStrLn $ details ++ if $(gitDirty) then " (DIRTY)" else ""
96+ else do
97+ if null files
98+ then do
99+ currentDir <- getCurrentDirectory
100+ processFiles opts' [currentDir]
101+ else
102+ processFiles opts' files
103+ if "--run" `elem` opts
104+ then runBuildTool $ Run moduleName
105+ else when ("--no-build" `notElem` opts) $
106+ runBuildTool Build
107+ return ()
108+ where
109+ processFiles :: [String] -> [FilePath] -> IO ()
110+ processFiles opts [file] = do
111+ isDir <- doesDirectoryExist file
112+ if isDir then do
113+ files <- find always (fileName ==? corefn) file
114+ if null files
115+ then errorNoCorefnFiles
116+ else generateFiles opts files
117+ else generateFiles opts [file]
118+ processFiles opts files = do
119+ generateFiles opts files
120+ basePath :: [FilePath] -> FilePath
121+ basePath files =
122+ let filepath = takeDirectory (head files) in
123+ joinPath $ (init $ splitDirectories filepath)
124+ generateFiles :: [String] -> [FilePath] -> IO ()
125+ generateFiles opts files = do
126+ let baseOutpath = basePath files
127+ writeSupportFiles baseOutpath
128+ Par.mapM (generateCode opts baseOutpath) files
129+ return ()
130+ runBuildTool :: Command -> IO ()
131+ runBuildTool cmd = do
132+ project <- projectEnv
133+ case cmd of
134+ Build -> do
135+ callProcess "go" ["build", T.unpack project </> modPrefix' </> "Main"]
136+ Run moduleName -> do
137+ callProcess "go" ["run", T.unpack project </> modPrefix' </> fromMaybe "Main" moduleName]
138+ return ()
75139
76140generateCode :: [String] -> FilePath -> FilePath -> IO ()
77141generateCode opts baseOutpath jsonFile = do
78142 jsonModTime <- getModificationTime jsonFile
79143 let filepath = takeDirectory jsonFile
80144 dirparts = splitDirectories $ filepath
81− mname = (\c -> if c == '.' then '_' else c) <$> last dirparts
145+ mname = last dirparts
82146 basedir = joinPath $ init dirparts
83− mname' = moduleNameToIL' $ T.pack mname
84− possibleFileName = basedir </> outdir </> (T.unpack mname') </> implFileName mname'
147+ mname' = T.pack mname
148+ possibleFileName = basedir </> (T.unpack mname') </> implFileName mname'
85149 exists <- doesFileExist possibleFileName
86150 if exists
87151 then do
@@ -93,9 +157,10 @@ generateCode opts baseOutpath jsonFile = do
93157transpile :: [String] -> FilePath -> FilePath -> IO ()
94158transpile opts baseOutpath jsonFile = do
95159 jsonText <- T.decodeUtf8 <$> B.readFile jsonFile
160+ project <- projectEnv
96161 let module' = jsonToModule $ parseJson jsonText
97− ((_, foreigns, asts, implHeader, implFooter), _) <- runSupplyT 5 (moduleToIL module' Nothing)
98− let mn = moduleNameToIL $ moduleName module'
162+ ((_, foreigns, asts, implHeader, implFooter), _) <- runSupplyT 5 (moduleToIL module' project)
163+ let mn = moduleNameToIL' $ moduleName module'
99164 implementation = prettyPrintIL asts
100165 outpath = joinPath [baseOutpath, T.unpack mn]
101166 implPath = outpath </> implFileName mn
@@ -103,28 +168,83 @@ transpile opts baseOutpath jsonFile = do
103168 putStrLn implPath
104169 B.writeFile implPath $ T.encodeUtf8 (implHeader <> implementation <> implFooter)
105170
106−writeRuntimeFiles :: FilePath -> IO ()
107−writeRuntimeFiles baseOutpath = do
108− createDirectoryIfMissing True $ baseOutpath </> "purescript"
109− let runtimeSource = baseOutpath </> "purescript" </> "purescript.go"
110− runtimeExists <- doesFileExist runtimeSource
111− when (not runtimeExists) $ do
112− B.writeFile runtimeSource $(embedFile "runtime/purescript.go")
113−
114−outdir :: FilePath
115−outdir = "src"
171+writeSupportFiles :: FilePath -> IO ()
172+writeSupportFiles baseOutpath = do
173+ currentDir <- getCurrentDirectory
174+ let outputdir = T.pack $ baseOutpath \\ currentDir
175+ ffiOutpath = currentDir </> subdir
176+ createDirectoryIfMissing True baseOutpath
177+ createDirectoryIfMissing True ffiOutpath
178+ writeModuleFile outputdir currentDir $(embedFile "support/go.mod.working")
179+ writeModuleFile outputdir baseOutpath $(embedFile "support/go.mod.output")
180+ writeModuleFile outputdir ffiOutpath $(embedFile "support/go.mod.ffi-loader")
181+ writeLoaderFile ffiOutpath $(embedFile "support/ffi-loader.go")
182+ where
183+ writeModuleFile :: Text -> FilePath -> B.ByteString -> IO ()
184+ writeModuleFile outputdir path modText = do
185+ let goModSource = path </> "go.mod"
186+ goModSourceExists <- doesFileExist goModSource
187+ when (not goModSourceExists) $ do
188+ project <- projectEnv
189+ let project' = T.unpack project
190+ outputdir' = tail $ T.unpack outputdir
191+ modText' = T.replace "$PROJECT" project $ T.decodeUtf8 modText
192+ replaceLoader = project' </> ffiLoader' <> "=." </> subdir
193+ replaceOutput = project' </> modPrefix' <> "=." </> outputdir'
194+ B.writeFile goModSource $ T.encodeUtf8 modText'
195+ callProcess "go" ["mod", "edit", "-replace", replaceLoader]
196+ callProcess "go" ["mod", "edit", "-replace", replaceOutput]
197+ callProcess "go" ["clean", "-modcache"]
198+ writeLoaderFile :: FilePath -> B.ByteString -> IO ()
199+ writeLoaderFile ffiOutpath loaderText = do
200+ let loaderSource = ffiOutpath </> "ffi_loader.go"
201+ loaderSourceExists <- doesFileExist loaderSource
202+ when (not loaderSourceExists) $ do
203+ B.writeFile loaderSource loaderText
116204
117205implFileName :: Text -> FilePath
118−implFileName mn = T.unpack $ mn <> ".go"
206+implFileName mn = ((\c -> if c == '.' then '_' else c) <$> T.unpack mn) <> ".go"
207+
208+projectEnv :: IO Text
209+projectEnv = do
210+ T.pack . fromMaybe defaultProject <$> lookupEnv goproject
119211
120212help :: String
121213help = "Usage: psgo OPTIONS COREFN-FILES\n\
122− \ PureScript-to-go compiler\n\n\
214+ \ PureScript to native (via go) compiler\n\n\
123215 \Available options:\n\
124216 \ --help Show this help text\n\n\
125− \ --makefile Generate a GNU Makefile which can be used for compiling\n\
126− \ a PureScript program and libraries to a native binary via\n\
127− \ purs corefn output and C++\n\n\
217+ \ --version Show the version number\n\n\
218+ \ --run Run the generated go code directly, without building an\n\
219+ \ executable\n\
220+ \ --no-build Generate go source files, but do not build an executable\n\
128221 \ --tests Run test cases (under construction)\n\n\
129222 \See also:\n\
130223 \ purs compile --help\n"
224+
225+corefn :: String
226+corefn = "corefn.json"
227+
228+goSrc :: String
229+goSrc = ".go"
230+
231+goproject :: String
232+goproject = "GOPROJECT"
233+
234+defaultProject :: String
235+defaultProject = "project.localhost"
236+
237+modPrefix' :: String
238+modPrefix' = T.unpack modPrefix
239+
240+ffiLoader' :: String
241+ffiLoader' = T.unpack ffiLoader
242+
243+subdir :: String
244+subdir = T.unpack modLabel
245+
246+errorNoCorefnFiles :: IO ()
247+errorNoCorefnFiles = do
248+ ioError . userError $ "no compiled purescript '" <> corefn <> "' files found –\n" <>
249+ " make sure to use the '--codegen corefn' option with your purs\n" <>
250+ " project build tool"