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