git.iko.soy/obelisk
on ee81335 help sign in
obelisk/lib/command/src/Obelisk/Command/Run.hs
190 lines 7.1 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 Data.List
14import 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
30import System.Directory
31import System.FilePath
32import System.IO.Temp (withSystemTempDirectory)
33import Data.ByteString (ByteString)
35import Obelisk.App (MonadObelisk, ObeliskT)
36import Obelisk.CliApp (CliT (..), HasCliConfig, Severity (..), callCommand, failWith, getCliConfig, putLog,
37 runCli)
38import Obelisk.Command.Project (inProjectShell)
40data CabalPackageInfo = CabalPackageInfo
41 { _cabalPackageInfo_packageRoot :: FilePath
42 , _cabalPackageInfo_sourceDirs :: NE.NonEmpty FilePath
43 -- ^ List of hs src dirs of the library component
44 , _cabalPackageInfo_defaultExtensions :: [Extension]
45 -- ^ List of globally enable extensions of the library component
46 }
48-- NOTE: `run` is not polymorphic like the rest because we use StaticPtr to invoke it.
49run :: ObeliskT IO ()
50run = do
51 pkgs <- getLocalPkgs
52 withGhciScript pkgs $ \dotGhciPath -> do
53 freePort <- getFreePort
54 runGhcid dotGhciPath $ Just $ unwords ["run", show freePort, "(runServeAsset Obelisk.Generated.Static.staticRootPath)", "Backend.backend", "Frontend.frontend"]
56runRepl :: MonadObelisk m => m ()
57runRepl = do
58 pkgs <- getLocalPkgs
59 withGhciScript pkgs $ \dotGhciPath -> do
60 runGhciRepl dotGhciPath
62runWatch :: MonadObelisk m => m ()
63runWatch = do
64 pkgs <- getLocalPkgs
65 withGhciScript pkgs $ \dotGhciPath -> runGhcid dotGhciPath Nothing
67-- | Relative paths to local packages of an obelisk project
68-- TODO a way to query this
69getLocalPkgs :: Applicative f => f [FilePath]
70getLocalPkgs = pure ["backend", "common", "frontend"]
72parseCabalPackage
73 :: (MonadObelisk m)
74 => FilePath -- ^ package directory
75 -> m (Maybe CabalPackageInfo)
76parseCabalPackage dir = do
77 let cabalFp = dir </> (takeBaseName dir <> ".cabal")
78 hpackFp = dir </> "package.yaml"
79 hasCabal <- liftIO $ doesFileExist cabalFp
80 hasHpack <- liftIO $ doesFileExist hpackFp
82 mCabalContents <- if hasCabal
83 then Just <$> liftIO (readUTF8File cabalFp)
84 else if hasHpack
85 then do
86 let decodeOptions = DecodeOptions hpackFp Nothing decodeYaml
87 liftIO (readPackageConfig decodeOptions) >>= \case
88 Left err -> do
89 putLog Error $ T.pack $ "Failed to parse " <> hpackFp <> ": " <> err
90 return Nothing
91 Right (DecodeResult hpackPackage _ _) -> do
92 return $ Just $ renderPackage [] hpackPackage
93 else return Nothing
95 fmap join $ forM mCabalContents $ \cabalContents -> do
96 let (warnings, result) = runParseResult $ parseGenericPackageDescription $
97 toUTF8BS $ cabalContents
98 mapM_ (putLog Warning) $ fmap (T.pack . show) warnings
99 case result of
100 Right gpkg -> do
101 return $ do
102 (_, lib) <- simplifyCondTree (const $ pure True) <$> condLibrary gpkg
103 pure $ CabalPackageInfo
104 { _cabalPackageInfo_packageRoot = takeDirectory cabalFp
105 , _cabalPackageInfo_sourceDirs =
106 fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
107 , _cabalPackageInfo_defaultExtensions =
108 defaultExtensions $ libBuildInfo lib
109 }
110 Left (_, errors) -> do
111 putLog Error $ T.pack $ "Failed to parse " <> cabalFp <> ":"
112 mapM_ (putLog Error) $ fmap (T.pack . show) errors
113 return Nothing
115withUTF8FileContentsM :: (MonadIO m, HasCliConfig e m) => FilePath -> (ByteString -> CliT e IO a) -> m a
116withUTF8FileContentsM fp f = do
117 c <- getCliConfig
118 liftIO $ withUTF8FileContents fp $ runCli c . f . toUTF8BS
120-- | Create ghci configuration to load the given packages
121withGhciScript
122 :: MonadObelisk m
123 => [FilePath] -- ^ List of packages to load into ghci
124 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporory .ghci
125 -> m ()
126withGhciScript pkgs f = do
127 (pkgDirErrs, packageInfos) <- fmap partitionEithers $ forM pkgs $ \pkg -> do
128 flip fmap (parseCabalPackage pkg) $ \case
129 Nothing -> Left pkg
130 Just packageInfo -> Right packageInfo
132 when (null packageInfos) $
133 failWith $ T.pack $ "No valid pkgs found in " <> intercalate ", " pkgs
134 unless (null pkgDirErrs) $
135 putLog Warning $ T.pack $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs
137 let extensions = packageInfos >>= _cabalPackageInfo_defaultExtensions
138 extensionsLine = if extensions == mempty
139 then ""
140 else ":set " <> intercalate " " ((("-X" <>) . prettyShow) <$> extensions)
141 dotGhci = unlines $
142 [ ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)
143 , extensionsLine
144 , ":load Backend Frontend"
145 , "import Obelisk.Run"
146 , "import qualified Frontend"
147 , "import qualified Backend"
148 ]
149 withSystemTempDirectory "ob-ghci" $ \fp -> do
150 let dotGhciPath = fp </> ".ghci"
151 liftIO $ writeFile dotGhciPath dotGhci
152 f dotGhciPath
154 where
155 rootedSourceDirs pkg = NE.toList $
156 (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
158-- | Run ghci repl
159runGhciRepl
160 :: MonadObelisk m
161 => FilePath -- ^ Path to .ghci
162 -> m ()
163runGhciRepl dotGhci = inProjectShell "ghc" $ unwords $ "ghci" : ["-ghci-script", dotGhci]
165-- | Run ghcid
166runGhcid
167 :: MonadObelisk m
168 => FilePath -- ^ Path to .ghci
169 -> Maybe String -- ^ Optional command to run at every reload
170 -> m ()
171runGhcid dotGhci mcmd = callCommand $ unwords $ "ghcid" : opts
172 where
173 opts =
174 [ "-W"
175 --TODO: The decision of whether to use -fwarn-redundant-constraints should probably be made by the user
176 , "--command='ghci -Wall -ignore-dot-ghci -fwarn-redundant-constraints -ghci-script " <> dotGhci <> "' "
177 , "--reload=config"
178 , "--outputfile=ghcid-output.txt"
179 ] <> testCmd
180 testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'")
182getFreePort :: MonadIO m => m PortNumber
183getFreePort = liftIO $ withSocketsDo $ do
184 addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
185 bracket (open addr) close socketPort
186 where
187 open addr = do
188 sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
189 bind sock (addrAddress addr)
190 return sock