{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Stack.Ghci.Script
( GhciScript
, ModuleName
, cmdAdd
, cmdCdGhc
, cmdModule
, scriptToLazyByteString
, scriptToBuilder
, scriptToFile
) where
import Data.ByteString.Builder ( toLazyByteString )
import qualified Data.List as L
import qualified Data.Set as S
import Distribution.ModuleName ( ModuleName, components )
import Stack.Prelude
import System.IO ( hSetBinaryMode )
newtype GhciScript = GhciScript { GhciScript -> [GhciCommand]
unGhciScript :: [GhciCommand] }
instance Semigroup GhciScript where
GhciScript [GhciCommand]
xs <> :: GhciScript -> GhciScript -> GhciScript
<> GhciScript [GhciCommand]
ys = [GhciCommand] -> GhciScript
GhciScript ([GhciCommand]
ys forall a. Semigroup a => a -> a -> a
<> [GhciCommand]
xs)
instance Monoid GhciScript where
mempty :: GhciScript
mempty = [GhciCommand] -> GhciScript
GhciScript []
mappend :: GhciScript -> GhciScript -> GhciScript
mappend = forall a. Semigroup a => a -> a -> a
(<>)
data GhciCommand
= AddCmd (Set (Either ModuleName (Path Abs File)))
| CdGhcCmd (Path Abs Dir)
| ModuleCmd (Set ModuleName)
deriving Int -> GhciCommand -> ShowS
[GhciCommand] -> ShowS
GhciCommand -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GhciCommand] -> ShowS
$cshowList :: [GhciCommand] -> ShowS
show :: GhciCommand -> String
$cshow :: GhciCommand -> String
showsPrec :: Int -> GhciCommand -> ShowS
$cshowsPrec :: Int -> GhciCommand -> ShowS
Show
cmdAdd :: Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd :: Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd = [GhciCommand] -> GhciScript
GhciScript forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Either ModuleName (Path Abs File)) -> GhciCommand
AddCmd
cmdCdGhc :: Path Abs Dir -> GhciScript
cmdCdGhc :: Path Abs Dir -> GhciScript
cmdCdGhc = [GhciCommand] -> GhciScript
GhciScript forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> GhciCommand
CdGhcCmd
cmdModule :: Set ModuleName -> GhciScript
cmdModule :: Set ModuleName -> GhciScript
cmdModule = [GhciCommand] -> GhciScript
GhciScript forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ModuleName -> GhciCommand
ModuleCmd
scriptToLazyByteString :: GhciScript -> LByteString
scriptToLazyByteString :: GhciScript -> LByteString
scriptToLazyByteString = Builder -> LByteString
toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciScript -> Builder
scriptToBuilder
scriptToBuilder :: GhciScript -> Builder
scriptToBuilder :: GhciScript -> Builder
scriptToBuilder GhciScript
backwardScript = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GhciCommand -> Builder
commandToBuilder [GhciCommand]
script
where
script :: [GhciCommand]
script = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ GhciScript -> [GhciCommand]
unGhciScript GhciScript
backwardScript
scriptToFile :: Path Abs File -> GhciScript -> IO ()
scriptToFile :: Path Abs File -> GhciScript -> IO ()
scriptToFile Path Abs File
path GhciScript
script =
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> IOMode -> (Handle -> m a) -> m a
withFile String
filepath IOMode
WriteMode
forall a b. (a -> b) -> a -> b
$ \Handle
hdl -> do forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
hdl (Maybe Int -> BufferMode
BlockBuffering forall a. Maybe a
Nothing)
Handle -> Bool -> IO ()
hSetBinaryMode Handle
hdl Bool
True
forall (m :: * -> *). MonadIO m => Handle -> Builder -> m ()
hPutBuilder Handle
hdl (GhciScript -> Builder
scriptToBuilder GhciScript
script)
where
filepath :: String
filepath = forall b t. Path b t -> String
toFilePath Path Abs File
path
commandToBuilder :: GhciCommand -> Builder
commandToBuilder :: GhciCommand -> Builder
commandToBuilder (AddCmd Set (Either ModuleName (Path Abs File))
modules)
| forall a. Set a -> Bool
S.null Set (Either ModuleName (Path Abs File))
modules = forall a. Monoid a => a
mempty
| Bool
otherwise =
Builder
":add "
forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat
( forall a. a -> [a] -> [a]
L.intersperse Builder
" "
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
( forall a. IsString a => String -> a
fromString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
quoteFileName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
L.intersperse String
"." forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [String]
components) forall b t. Path b t -> String
toFilePath
)
(forall a. Set a -> [a]
S.toAscList Set (Either ModuleName (Path Abs File))
modules)
)
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"
commandToBuilder (CdGhcCmd Path Abs Dir
path) =
Builder
":cd-ghc " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (ShowS
quoteFileName (forall b t. Path b t -> String
toFilePath Path Abs Dir
path)) forall a. Semigroup a => a -> a -> a
<> Builder
"\n"
commandToBuilder (ModuleCmd Set ModuleName
modules)
| forall a. Set a -> Bool
S.null Set ModuleName
modules = Builder
":module +\n"
| Bool
otherwise =
Builder
":module + "
forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat
( forall a. a -> [a] -> [a]
L.intersperse Builder
" "
forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
quoteFileName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
L.intersperse String
"."
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [String]
components forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
S.toAscList Set ModuleName
modules
)
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"
quoteFileName :: String -> String
quoteFileName :: ShowS
quoteFileName String
x = if Char
' ' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
x then forall a. Show a => a -> String
show String
x else String
x