{-# 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 [GhciCommand] -> [GhciCommand] -> [GhciCommand]
forall a. Semigroup a => a -> a -> a
<> [GhciCommand]
xs)

instance Monoid GhciScript where
  mempty :: GhciScript
mempty = [GhciCommand] -> GhciScript
GhciScript []
  mappend :: GhciScript -> GhciScript -> GhciScript
mappend = GhciScript -> GhciScript -> GhciScript
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
(Int -> GhciCommand -> ShowS)
-> (GhciCommand -> String)
-> ([GhciCommand] -> ShowS)
-> Show GhciCommand
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GhciCommand -> ShowS
showsPrec :: Int -> GhciCommand -> ShowS
$cshow :: GhciCommand -> String
show :: GhciCommand -> String
$cshowList :: [GhciCommand] -> ShowS
showList :: [GhciCommand] -> ShowS
Show

cmdAdd :: Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd :: Set (Either ModuleName (Path Abs File)) -> GhciScript
cmdAdd = [GhciCommand] -> GhciScript
GhciScript ([GhciCommand] -> GhciScript)
-> (Set (Either ModuleName (Path Abs File)) -> [GhciCommand])
-> Set (Either ModuleName (Path Abs File))
-> GhciScript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GhciCommand -> [GhciCommand] -> [GhciCommand]
forall a. a -> [a] -> [a]
:[]) (GhciCommand -> [GhciCommand])
-> (Set (Either ModuleName (Path Abs File)) -> GhciCommand)
-> Set (Either ModuleName (Path Abs File))
-> [GhciCommand]
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 ([GhciCommand] -> GhciScript)
-> (Path Abs Dir -> [GhciCommand]) -> Path Abs Dir -> GhciScript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GhciCommand -> [GhciCommand] -> [GhciCommand]
forall a. a -> [a] -> [a]
:[]) (GhciCommand -> [GhciCommand])
-> (Path Abs Dir -> GhciCommand) -> Path Abs Dir -> [GhciCommand]
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 ([GhciCommand] -> GhciScript)
-> (Set ModuleName -> [GhciCommand])
-> Set ModuleName
-> GhciScript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GhciCommand -> [GhciCommand] -> [GhciCommand]
forall a. a -> [a] -> [a]
:[]) (GhciCommand -> [GhciCommand])
-> (Set ModuleName -> GhciCommand)
-> Set ModuleName
-> [GhciCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ModuleName -> GhciCommand
ModuleCmd

scriptToLazyByteString :: GhciScript -> LByteString
scriptToLazyByteString :: GhciScript -> LByteString
scriptToLazyByteString = Builder -> LByteString
toLazyByteString (Builder -> LByteString)
-> (GhciScript -> Builder) -> GhciScript -> LByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciScript -> Builder
scriptToBuilder

scriptToBuilder :: GhciScript -> Builder
scriptToBuilder :: GhciScript -> Builder
scriptToBuilder GhciScript
backwardScript = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ (GhciCommand -> Builder) -> [GhciCommand] -> [Builder]
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 = [GhciCommand] -> [GhciCommand]
forall a. [a] -> [a]
reverse ([GhciCommand] -> [GhciCommand]) -> [GhciCommand] -> [GhciCommand]
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 =
  String -> IOMode -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> IOMode -> (Handle -> m a) -> m a
withFile String
filepath IOMode
WriteMode
    ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
hdl -> do Handle -> BufferMode -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
hdl (Maybe Int -> BufferMode
BlockBuffering Maybe Int
forall a. Maybe a
Nothing)
                 Handle -> Bool -> IO ()
hSetBinaryMode Handle
hdl Bool
True
                 Handle -> Builder -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> Builder -> m ()
hPutBuilder Handle
hdl (GhciScript -> Builder
scriptToBuilder GhciScript
script)
 where
  filepath :: String
filepath = Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
path

-- Command conversion


commandToBuilder :: GhciCommand -> Builder

commandToBuilder :: GhciCommand -> Builder
commandToBuilder (AddCmd Set (Either ModuleName (Path Abs File))
modules)
  | Set (Either ModuleName (Path Abs File)) -> Bool
forall a. Set a -> Bool
S.null Set (Either ModuleName (Path Abs File))
modules = Builder
forall a. Monoid a => a
mempty
  | Bool
otherwise      =
       Builder
":add "
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
         ( Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
L.intersperse Builder
" "
             ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$ (Either ModuleName (Path Abs File) -> Builder)
-> [Either ModuleName (Path Abs File)] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                 ( String -> Builder
forall a. IsString a => String -> a
fromString
                 (String -> Builder)
-> (Either ModuleName (Path Abs File) -> String)
-> Either ModuleName (Path Abs File)
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
quoteFileName
                 ShowS
-> (Either ModuleName (Path Abs File) -> String)
-> Either ModuleName (Path Abs File)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName -> String)
-> (Path Abs File -> String)
-> Either ModuleName (Path Abs File)
-> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([String] -> String
forall a. Monoid a => [a] -> a
mconcat ([String] -> String)
-> (ModuleName -> [String]) -> ModuleName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [String]
forall a. a -> [a] -> [a]
L.intersperse String
"." ([String] -> [String])
-> (ModuleName -> [String]) -> ModuleName -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [String]
components) Path Abs File -> String
forall b t. Path b t -> String
toFilePath
                 )
                 (Set (Either ModuleName (Path Abs File))
-> [Either ModuleName (Path Abs File)]
forall a. Set a -> [a]
S.toAscList Set (Either ModuleName (Path Abs File))
modules)
         )
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"

commandToBuilder (CdGhcCmd Path Abs Dir
path) =
  Builder
":cd-ghc " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
forall a. IsString a => String -> a
fromString (ShowS
quoteFileName (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
path)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"

commandToBuilder (ModuleCmd Set ModuleName
modules)
  | Set ModuleName -> Bool
forall a. Set a -> Bool
S.null Set ModuleName
modules = Builder
":module +\n"
  | Bool
otherwise      =
       Builder
":module + "
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
         ( Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
L.intersperse Builder
" "
             ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$ String -> Builder
forall a. IsString a => String -> a
fromString
             (String -> Builder)
-> (ModuleName -> String) -> ModuleName -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
quoteFileName
             ShowS -> (ModuleName -> String) -> ModuleName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall a. Monoid a => [a] -> a
mconcat
             ([String] -> String)
-> (ModuleName -> [String]) -> ModuleName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [String]
forall a. a -> [a] -> [a]
L.intersperse String
"."
             ([String] -> [String])
-> (ModuleName -> [String]) -> ModuleName -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [String]
components (ModuleName -> Builder) -> [ModuleName] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set ModuleName -> [ModuleName]
forall a. Set a -> [a]
S.toAscList Set ModuleName
modules
         )
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n"

-- | Make sure that a filename with spaces in it gets the proper quotes.

quoteFileName :: String -> String
quoteFileName :: ShowS
quoteFileName String
x = if Char
' ' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
x then ShowS
forall a. Show a => a -> String
show String
x else String
x