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