@@ -1,12 +1,16 @@
11{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE FlexibleContexts #-}
23module Obelisk.Command.Run where
34
45import qualified Control.Exception as E
56import Control.Monad
67import Data.Either
78import Data.List
9+import Control.Monad.Reader (ask)
810import Data.Maybe
11+import Control.Monad.IO.Class (liftIO)
912import Data.Monoid
13+import qualified Data.Text as T
1014import Data.List.NonEmpty as NE
1115import Distribution.Utils.Generic (withUTF8FileContents)
1216import Distribution.PackageDescription.Parse (parseGenericPackageDescription, ParseResult(..))
@@ -20,10 +24,14 @@ import System.FilePath
2024import System.IO.Temp (withSystemTempDirectory)
2125import System.Process (callCommand)
2226
23−run :: IO ()
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.
31+run :: ObeliskT IO ()
2432run = do
25− freePort <- getFreePort
26− pkgs <- getLocalPkgs
33+ freePort <- liftIO getFreePort
34+ pkgs <- liftIO getLocalPkgs
2735 (pkgDirErrs, hsSrcDirs) <- fmap partitionEithers $ forM pkgs $ \pkg -> do
2836 let cabalFp = pkg </> pkg <.> "cabal"
2937 xs <- parseHsSrcDir cabalFp
@@ -31,9 +39,9 @@ run = do
3139 Nothing -> Left pkg
3240 Just hsSrcDirs -> Right $ toList $ fmap (pkg </>) hsSrcDirs
3341 when (null hsSrcDirs) $
34− fail $ "No valid pkgs found in " <> intercalate ", " pkgs
42+ failWith $ T.pack $ "No valid pkgs found in " <> intercalate ", " pkgs
3543 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
3745 let dotGhci = unlines
3846 [ ":set args --quiet --port " <> show freePort
3947 , ":set -i" <> intercalate ":" (mconcat hsSrcDirs)
@@ -50,28 +58,34 @@ run = do
5058 ]
5159 withSystemTempDirectory "ob-ghci" $ \fp -> do
5260 let dotGhciPath = fp </> ".ghci"
53− writeFile dotGhciPath dotGhci
54− runDev dotGhciPath $ Just testCmd
61+ liftIO $ do
62+ writeFile dotGhciPath dotGhci
63+ runDev dotGhciPath $ Just testCmd
5564
5665-- | Relative paths to local packages of an obelisk project
5766-- TODO a way to query this
5867getLocalPkgs :: IO [FilePath]
5968getLocalPkgs = return ["backend", "common", "frontend"]
6069
61−parseHsSrcDir :: FilePath -- ^ package cabal file path
62− -> IO (Maybe (NE.NonEmpty FilePath)) -- ^ List of hs src dirs of the library component
70+parseHsSrcDir
71+ :: MonadObelisk m
72+ => FilePath -- ^ package cabal file path
73+ -> m (Maybe (NE.NonEmpty FilePath)) -- ^ List of hs src dirs of the library component
6374parseHsSrcDir cabalFp = do
64− exists <- doesFileExist cabalFp
75+ exists <- liftIO $ doesFileExist cabalFp
6576 if exists
6677 then do
67− withUTF8FileContents cabalFp $ \cabal -> do
78+ c <- ask
79+ liftIO $ withUTF8FileContents cabalFp $ \cabal -> runObelisk c $ do
6880 case parseGenericPackageDescription cabal of
6981 ParseOk warnings gpkg -> do
70− mapM_ print warnings
82+ mapM_ (putLog Warning) $ fmap (T.pack . show) warnings
7183 return $ do
7284 (_, lib) <- simplifyCondTree (const $ pure True) <$> condLibrary gpkg
7385 pure $ fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
74− ParseFailed _ -> return Nothing
86+ ParseFailed e -> do
87+ putLog Error $ T.pack $ "Failed to parse cabal file: " <> show e
88+ return Nothing
7589 else return Nothing
7690
7791-- | Dev