1613118 · obelisk · git.iko.soy

git.iko.soy/obelisk

Allow run and run-static-io to run in ObeliskT

This gives us logging, spinners, etc. for `ob run`.

commit1613118de378267fd461ba5453194f166510f06e authorSridhar Ratnakumar <srid@srid.ca> dateTue 15 May 2018, 12:17 (8 years ago) parent14a9380

3 files changed+22−12

compare with master

unifiedsplit

lib/command/src/Obelisk/App.hs+1−1 lib/command/src/Obelisk/Command.hs+5−3 lib/command/src/Obelisk/Command/Run.hs+16−8

lib/command/src/Obelisk/App.hs+1−1

@@ -18,7 +18,7 @@ data Obelisk = Obelisk

1818newtype ObeliskT m a = ObeliskT

1919 { unObeliskT :: ReaderT Obelisk (LoggingT Output m) a

2020 }

21− deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask)

21+ deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadLog Output)

2222

2323runObelisk :: MonadIO m => Obelisk -> ObeliskT m a -> m a

2424runObelisk c =

lib/command/src/Obelisk/Command.hs+5−3

@@ -91,7 +91,7 @@ data ObInternal

9191 | ObInternal_CLIDemo

9292 deriving Show

9393

94−inNixShell' :: MonadObelisk m => StaticPtr (IO ()) -> m ()

94+inNixShell' :: MonadObelisk m => StaticPtr (ObeliskT IO ()) -> m ()

9595inNixShell' p = withProjectRoot "." $ \root -> do

9696 cmd <- liftIO $ unwords <$> mkCmd -- TODO: shell escape instead of unwords

9797 projectShell root False "ghc" cmd

@@ -284,9 +284,11 @@ ob = \case

284284 ObCommand_Repl component -> runRepl component

285285 ObCommand_Watch component -> watch component

286286 ObCommand_Internal icmd -> case icmd of

287− ObInternal_RunStaticIO k -> liftIO (unsafeLookupStaticPtr @(IO ()) k) >>= \case

287+ ObInternal_RunStaticIO k -> liftIO (unsafeLookupStaticPtr @(ObeliskT IO ()) k) >>= \case

288288 Nothing -> failWith $ "ObInternal_RunStaticIO: no such StaticKey: " <> T.pack (show k)

289− Just p -> liftIO $ deRefStaticPtr p

289+ Just p -> do

290+ c <- ask

291+ liftIO $ runObelisk c $ deRefStaticPtr p

290292 ObInternal_CLIDemo -> cliDemo

291293

292294--TODO: Clean up all the magic strings throughout this codebase

lib/command/src/Obelisk/Command/Run.hs+16−8

@@ -1,4 +1,5 @@

11{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE FlexibleContexts #-}

23module Obelisk.Command.Run where

45import qualified Control.Exception as E

@@ -6,7 +7,9 @@ import Control.Monad

67import Data.Either

78import Data.List

89import Data.Maybe

10+import Control.Monad.IO.Class (liftIO)

911import Data.Monoid

12+import qualified Data.Text as T

1013import Data.List.NonEmpty as NE

1114import Distribution.Utils.Generic (withUTF8FileContents)

1215import Distribution.PackageDescription.Parse (parseGenericPackageDescription, ParseResult(..))

@@ -20,20 +23,24 @@ import System.FilePath

2023import System.IO.Temp (withSystemTempDirectory)

2124import System.Process (callCommand)

2225

23−run :: IO ()

26+import Obelisk.App (ObeliskT)

27+import Obelisk.CLI (putLog, failWith, Severity(..))

28+

29+-- NOTE: `run` is not polymorphic like the rest because we use StaticPtr to invoke it.

30+run :: ObeliskT IO ()

2431run = do

25− freePort <- getFreePort

26− pkgs <- getLocalPkgs

27− (pkgDirErrs, hsSrcDirs) <- fmap partitionEithers $ forM pkgs $ \pkg -> do

32+ freePort <- liftIO getFreePort

33+ pkgs <- liftIO getLocalPkgs

34+ (pkgDirErrs, hsSrcDirs) <- liftIO $ fmap partitionEithers $ forM pkgs $ \pkg -> do

2835 let cabalFp = pkg </> pkg <.> "cabal"

2936 xs <- parseHsSrcDir cabalFp

3037 return $ case xs of

3138 Nothing -> Left pkg

3239 Just hsSrcDirs -> Right $ toList $ fmap (pkg </>) hsSrcDirs

3340 when (null hsSrcDirs) $

34− fail $ "No valid pkgs found in " <> intercalate ", " pkgs

41+ failWith $ T.pack $ "No valid pkgs found in " <> intercalate ", " pkgs

3542 when (not (null pkgDirErrs)) $

36− putStrLn $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs

43+ putLog Warning $ T.pack $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs

3744 let dotGhci = unlines

3845 [ ":set args --quiet --port " <> show freePort

3946 , ":set -i" <> intercalate ":" (mconcat hsSrcDirs)

@@ -50,8 +57,9 @@ run = do

5057 ]

5158 withSystemTempDirectory "ob-ghci" $ \fp -> do

5259 let dotGhciPath = fp </> ".ghci"

53− writeFile dotGhciPath dotGhci

54− runDev dotGhciPath $ Just testCmd

60+ liftIO $ do

61+ writeFile dotGhciPath dotGhci

62+ runDev dotGhciPath $ Just testCmd

5563

5664-- | Relative paths to local packages of an obelisk project

5765-- TODO a way to query this