git.iko.soy/obelisk
on 6ab28f7 help sign in
obelisk/lib/command/src/Obelisk/Command/Run.hs
251 lines 10 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE TemplateHaskell #-}
7module Obelisk.Command.Run where
9import Control.Exception (bracket)
10import Control.Monad
11import Control.Monad.IO.Class (liftIO)
12import Control.Monad.Reader (MonadIO)
13import Data.ByteString (ByteString)
14import qualified Data.ByteString.UTF8 as BSU
15import Data.Either
16import qualified Data.List as L
17import qualified Data.List.NonEmpty as NE
18import Data.Maybe
19import qualified Data.Text as T
20import Distribution.Compiler (CompilerFlavor(..))
21import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
22import Distribution.Parsec.ParseResult (runParseResult)
23import Distribution.Pretty
24import Distribution.Types.BuildInfo
25import Distribution.Types.CondTree
26import Distribution.Types.GenericPackageDescription
27import Distribution.Types.Library
28import Distribution.Utils.Generic
29import Hpack.Config
30import Hpack.Render
31import Hpack.Yaml
32import Language.Haskell.Extension
33import Network.Socket hiding (Debug)
34import System.Directory
35import System.FilePath
36import System.Process (proc)
37import System.IO.Temp (withSystemTempDirectory)
38import System.Which (staticWhich)
39import Text.ShellEscape (bash)
41import Obelisk.App (MonadObelisk, ObeliskT)
42import Obelisk.CliApp
43 ( CliT (..), HasCliConfig, Severity (..)
44 , callCommand, failWith, getCliConfig, putLog
45 , readProcessAndLogStderr, runCli)
46import Obelisk.Command.Project (inProjectProc, withProjectRoot)
48data CabalPackageInfo = CabalPackageInfo
49 { _cabalPackageInfo_packageRoot :: FilePath
50 , _cabalPackageInfo_sourceDirs :: NE.NonEmpty FilePath
51 -- ^ List of hs src dirs of the library component
52 , _cabalPackageInfo_defaultExtensions :: [Extension]
53 -- ^ List of globally enable extensions of the library component
54 , _cabalPackageInfo_defaultLanguage :: Maybe Language
55 -- ^ List of globally set languages of the library component
56 , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
57 -- ^ List of compiler-specific options (e.g., the "ghc-options" field of the cabal file)
58 }
60-- NOTE: `run` is not polymorphic like the rest because we use StaticPtr to invoke it.
61run :: ObeliskT IO ()
62run = do
63 let nixPath = $(staticWhich "nix")
64 nixBuildPath = $(staticWhich "nix-build")
65 pkgs <- getLocalPkgs
66 withGhciScript pkgs $ \dotGhciPath -> do
67 freePort <- getFreePort
68 assets <- withProjectRoot "." $ \root -> do
69 let importableRoot = if "/" `isInfixOf` root
70 then root
71 else "./" <> root
72 isDerivation <- readProcessAndLogStderr Debug $
73 proc nixPath
74 [ "eval"
75 , "-f"
76 , root
77 , "(let a = import " <> importableRoot <> " {}; in toString (a.reflex.nixpkgs.lib.isDerivation a.passthru.staticFilesImpure))"
78 , "--raw"
79 -- `--raw` is not available with old nix-instantiate. It drops quotation
80 -- marks and trailing newline, so is very convenient for shelling out.
81 ]
82 -- Check whether the impure static files are a derivation (and so must be built)
83 if isDerivation == "1"
84 then fmap T.strip $ readProcessAndLogStderr Debug $ -- Strip whitespace here because nix-build has no --raw option
85 proc nixBuildPath
86 [ "--no-out-link"
87 , "-E", "(import " <> importableRoot <> "{}).passthru.staticFilesImpure"
88 ]
89 else readProcessAndLogStderr Debug $
90 proc nixPath ["eval", "-f", root, "passthru.staticFilesImpure", "--raw"]
91 putLog Debug $ "Assets impurely loaded from: " <> assets
92 runGhcid dotGhciPath $ Just $ unwords
93 [ "Obelisk.Run.run"
94 , show freePort
95 , "(runServeAsset " ++ show assets ++ ")"
96 , "Backend.backend"
97 , "Frontend.frontend"
98 ]
100runRepl :: MonadObelisk m => m ()
101runRepl = do
102 pkgs <- getLocalPkgs
103 withGhciScript pkgs $ \dotGhciPath -> do
104 runGhciRepl dotGhciPath
106runWatch :: MonadObelisk m => m ()
107runWatch = do
108 pkgs <- getLocalPkgs
109 withGhciScript pkgs $ \dotGhciPath -> runGhcid dotGhciPath Nothing
111-- | Relative paths to local packages of an obelisk project
112-- TODO a way to query this
113getLocalPkgs :: Applicative f => f [FilePath]
114getLocalPkgs = pure ["backend", "common", "frontend"]
116parseCabalPackage
117 :: (MonadObelisk m)
118 => FilePath -- ^ package directory
119 -> m (Maybe CabalPackageInfo)
120parseCabalPackage dir = do
121 let cabalFp = dir </> (takeBaseName dir <> ".cabal")
122 hpackFp = dir </> "package.yaml"
123 hasCabal <- liftIO $ doesFileExist cabalFp
124 hasHpack <- liftIO $ doesFileExist hpackFp
126 mCabalContents <- if hasCabal
127 then Just <$> liftIO (readUTF8File cabalFp)
128 else if hasHpack
129 then do
130 let decodeOptions = DecodeOptions (ProgramName "ob") hpackFp Nothing decodeYaml
131 liftIO (readPackageConfig decodeOptions) >>= \case
132 Left err -> do
133 putLog Error $ T.pack $ "Failed to parse " <> hpackFp <> ": " <> err
134 return Nothing
135 Right (DecodeResult hpackPackage _ _ _) -> do
136 return $ Just $ renderPackage [] hpackPackage
137 else return Nothing
139 fmap join $ forM mCabalContents $ \cabalContents -> do
140 let (warnings, result) = runParseResult $ parseGenericPackageDescription $
141 toUTF8BS $ cabalContents
142 mapM_ (putLog Warning) $ fmap (T.pack . show) warnings
143 case result of
144 Right gpkg -> do
145 return $ do
146 (_, lib) <- simplifyCondTree (const $ pure True) <$> condLibrary gpkg
147 pure $ CabalPackageInfo
148 { _cabalPackageInfo_packageRoot = takeDirectory cabalFp
149 , _cabalPackageInfo_sourceDirs =
150 fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
151 , _cabalPackageInfo_defaultExtensions =
152 defaultExtensions $ libBuildInfo lib
153 , _cabalPackageInfo_defaultLanguage =
154 defaultLanguage $ libBuildInfo lib
155 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
156 }
157 Left (_, errors) -> do
158 putLog Error $ T.pack $ "Failed to parse " <> cabalFp <> ":"
159 mapM_ (putLog Error) $ fmap (T.pack . show) errors
160 return Nothing
162withUTF8FileContentsM :: (MonadIO m, HasCliConfig e m) => FilePath -> (ByteString -> CliT e IO a) -> m a
163withUTF8FileContentsM fp f = do
164 c <- getCliConfig
165 liftIO $ withUTF8FileContents fp $ runCli c . f . toUTF8BS
167-- | Create ghci configuration to load the given packages
168withGhciScript
169 :: MonadObelisk m
170 => [FilePath] -- ^ List of packages to load into ghci
171 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporory .ghci
172 -> m ()
173withGhciScript pkgs f = do
174 (pkgDirErrs, packageInfos) <- fmap partitionEithers $ forM pkgs $ \pkg -> do
175 flip fmap (parseCabalPackage pkg) $ \case
176 Nothing -> Left pkg
177 Just packageInfo -> Right packageInfo
179 when (null packageInfos) $
180 failWith $ T.pack $ "No valid pkgs found in " <> intercalate ", " pkgs
181 unless (null pkgDirErrs) $
182 putLog Warning $ T.pack $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs
184 let extensions = packageInfos >>= _cabalPackageInfo_defaultExtensions
185 languageFromPkgs = L.nub $ mapMaybe _cabalPackageInfo_defaultLanguage packageInfos
186 -- NOTE when no default-language is present cabal sets Haskell98
187 language = NE.toList $ fromMaybe (Haskell98 NE.:| []) $ NE.nonEmpty languageFromPkgs
188 extensionsLine = if extensions == mempty
189 then ""
190 else ":set " <> intercalate " " ((("-X" <>) . prettyShow) <$> extensions)
191 ghcOptions = concat $ mapMaybe (\case (GHC, xs) -> Just xs; _ -> Nothing) $
192 packageInfos >>= _cabalPackageInfo_compilerOptions
193 dotGhci = unlines $
194 [ ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)
195 , case ghcOptions of
196 [] -> ""
197 xs -> ":set " <> intercalate " " xs
198 , extensionsLine
199 , ":set " <> intercalate " " (("-X" <>) . prettyShow <$> language)
200 , ":load Backend Frontend"
201 , "import Obelisk.Run"
202 , "import qualified Frontend"
203 , "import qualified Backend"
204 ]
205 warnDifferentLanguages language
206 withSystemTempDirectory "ob-ghci" $ \fp -> do
207 let dotGhciPath = fp </> ".ghci"
208 liftIO $ writeFile dotGhciPath dotGhci
209 f dotGhciPath
211 where
212 rootedSourceDirs pkg = NE.toList $
213 (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
215warnDifferentLanguages :: MonadObelisk m => [Language] -> m ()
216warnDifferentLanguages (_:_:_) = putLog Warning "Different languages detected across packages which may result in errors when loading the repl"
217warnDifferentLanguages _ = return ()
219-- | Run ghci repl
220runGhciRepl
221 :: MonadObelisk m
222 => FilePath -- ^ Path to .ghci
223 -> m ()
224runGhciRepl dotGhci = inProjectProc "ghc" $ fmap (bash . BSU.fromString) $ "ghci" : ["-no-user-package-db", "-ghci-script", dotGhci]
226-- | Run ghcid
227runGhcid
228 :: MonadObelisk m
229 => FilePath -- ^ Path to .ghci
230 -> Maybe String -- ^ Optional command to run at every reload
231 -> m ()
232runGhcid dotGhci mcmd = callCommand $ unwords $ $(staticWhich "ghcid") : opts
233 where
234 opts =
235 [ "-W"
236 --TODO: The decision of whether to use -fwarn-redundant-constraints should probably be made by the user
237 , "--command='ghci -Wall -ignore-dot-ghci -fwarn-redundant-constraints -no-user-package-db -ghci-script " <> dotGhci <> "' "
238 , "--reload=config"
239 , "--outputfile=ghcid-output.txt"
240 ] <> testCmd
241 testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'")
243getFreePort :: MonadIO m => m PortNumber
244getFreePort = liftIO $ withSocketsDo $ do
245 addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
246 bracket (open addr) close socketPort
247 where
248 open addr = do
249 sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
250 bind sock (addrAddress addr)
251 return sock