89669c7 · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

Merge pull request #79 from obsidiansystems/ss-run-static-io-logging

89669c7Luigy Leon8 years ago

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

compare with master

unifiedsplit

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

18newtype ObeliskT m a = ObeliskT

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

20 }

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

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

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

24runObelisk c =

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

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

91 | ObInternal_CLIDemo

92 deriving Show

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

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

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

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

97 projectShell root False "ghc" cmd

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

284 ObCommand_Repl component -> runRepl component

285 ObCommand_Watch component -> watch component

286 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

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

289+ Just p -> do

290+ c <- ask

289− Just p -> liftIO $ deRefStaticPtr p

291+ liftIO $ runObelisk c $ deRefStaticPtr p

290 ObInternal_CLIDemo -> cliDemo

292 ObInternal_CLIDemo -> cliDemo

291

293

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

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

lib/command/src/Obelisk/Command/Run.hs+27−13

@@ -1,12 +1,16 @@

1{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE FlexibleContexts #-}

2module Obelisk.Command.Run where

3module Obelisk.Command.Run where

4import qualified Control.Exception as E

5import qualified Control.Exception as E

5import Control.Monad

6import Control.Monad

6import Data.Either

7import Data.Either

7import Data.List

8import Data.List

9+import Control.Monad.Reader (ask)

8import Data.Maybe

10import Data.Maybe

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

9import Data.Monoid

12import Data.Monoid

13+import qualified Data.Text as T

10import Data.List.NonEmpty as NE

14import Data.List.NonEmpty as NE

11import Distribution.Utils.Generic (withUTF8FileContents)

15import Distribution.Utils.Generic (withUTF8FileContents)

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

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

@@ -20,10 +24,14 @@ import System.FilePath

20import System.IO.Temp (withSystemTempDirectory)

24import System.IO.Temp (withSystemTempDirectory)

21import System.Process (callCommand)

25import System.Process (callCommand)

27+import Obelisk.App (MonadObelisk, ObeliskT, runObelisk)

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

29+

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

23−run :: IO ()

31+run :: ObeliskT IO ()

24run = do

32run = do

25− freePort <- getFreePort

33+ freePort <- liftIO getFreePort

26− pkgs <- getLocalPkgs

34+ pkgs <- liftIO getLocalPkgs

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

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

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

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

29 xs <- parseHsSrcDir cabalFp

37 xs <- parseHsSrcDir cabalFp

@@ -31,9 +39,9 @@ run = do

31 Nothing -> Left pkg

39 Nothing -> Left pkg

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

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

33 when (null hsSrcDirs) $

41 when (null hsSrcDirs) $

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

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

35 when (not (null pkgDirErrs)) $

43 when (not (null pkgDirErrs)) $

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

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

37 let dotGhci = unlines

45 let dotGhci = unlines

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

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

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

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

@@ -50,28 +58,34 @@ run = do

50 ]

58 ]

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

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

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

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

61+ liftIO $ do

53− writeFile dotGhciPath dotGhci

62+ writeFile dotGhciPath dotGhci

54− runDev dotGhciPath $ Just testCmd

63+ runDev dotGhciPath $ Just testCmd

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

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

57-- TODO a way to query this

66-- TODO a way to query this

58getLocalPkgs :: IO [FilePath]

67getLocalPkgs :: IO [FilePath]

59getLocalPkgs = return ["backend", "common", "frontend"]

68getLocalPkgs = return ["backend", "common", "frontend"]

70+parseHsSrcDir

71+ :: MonadObelisk m

61−parseHsSrcDir :: FilePath -- ^ package cabal file path

72+ => FilePath -- ^ package cabal file path

62− -> IO (Maybe (NE.NonEmpty FilePath)) -- ^ List of hs src dirs of the library component

73+ -> m (Maybe (NE.NonEmpty FilePath)) -- ^ List of hs src dirs of the library component

63parseHsSrcDir cabalFp = do

74parseHsSrcDir cabalFp = do

64− exists <- doesFileExist cabalFp

75+ exists <- liftIO $ doesFileExist cabalFp

65 if exists

76 if exists

66 then do

77 then do

78+ c <- ask

67− withUTF8FileContents cabalFp $ \cabal -> do

79+ liftIO $ withUTF8FileContents cabalFp $ \cabal -> runObelisk c $ do

68 case parseGenericPackageDescription cabal of

80 case parseGenericPackageDescription cabal of

69 ParseOk warnings gpkg -> do

81 ParseOk warnings gpkg -> do

70− mapM_ print warnings

82+ mapM_ (putLog Warning) $ fmap (T.pack . show) warnings

71 return $ do

83 return $ do

72 (_, lib) <- simplifyCondTree (const $ pure True) <$> condLibrary gpkg

84 (_, lib) <- simplifyCondTree (const $ pure True) <$> condLibrary gpkg

73 pure $ fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib

85 pure $ fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib

86+ ParseFailed e -> do

87+ putLog Error $ T.pack $ "Failed to parse cabal file: " <> show e

74− ParseFailed _ -> return Nothing

88+ return Nothing

75 else return Nothing

89 else return Nothing

77-- | Dev

91-- | Dev