module Control.Biegunka.Biegunka
(
biegunka, Interpreter, interpret, interpretOptimistically
, pause, confirm
, expandHome
) where
import Control.Exception (bracket)
import Control.Lens
import Control.Monad.Free (Free)
import Data.Char (toLower)
import Data.Default.Class (Default(..))
import Data.Function (fix)
import Data.Semigroup (Semigroup(..), Monoid(..))
import qualified System.Directory as D
import System.Exit (ExitCode(..))
import System.FilePath ((</>))
import Control.Biegunka.Language
import qualified Control.Biegunka.Log as Log
import Control.Biegunka.Script
(HasRoot(root), Script, Annotate, app, profiles, runScript)
import Control.Biegunka.Script.Token (tokens)
import Control.Biegunka.Settings
import System.IO
import Text.PrettyPrint.ANSI.Leijen ((<//>), text, line)
newtype Interpreter = I
(Settings () -> Free (Term Annotate Sources) () -> IO ExitCode -> IO ExitCode)
instance Default Interpreter where
def = I $ \_ _ k -> k
instance Semigroup Interpreter where
I f <> I g = I $ \c s k -> f c s (g c s k)
instance Monoid Interpreter where
mempty = def
mappend = (<>)
interpret
:: (Settings () -> Free (Term Annotate Sources) () -> IO ExitCode -> IO ExitCode)
-> Interpreter
interpret = I
interpretOptimistically
:: (Settings () -> Free (Term Annotate Sources) () -> IO ())
-> Interpreter
interpretOptimistically f =
interpret $ \c s k -> f c s >> k
runInterpreter :: Interpreter -> Settings () -> Free (Term Annotate 'Sources) () -> IO ExitCode
runInterpreter (I f) c s = f c s (return ExitSuccess)
biegunka :: (Settings () -> Settings ())
-> Interpreter
-> Script Sources ()
-> IO ExitCode
biegunka (($ def) -> c) interpreter script = do
appRoot <- c^.root.to expandHome
dataDir <- c^.appData.to expandHome
bracket Log.start Log.stop $ \queue -> do
Log.write queue $
Log.plain (text (info appRoot dataDir c))
let (annotatedScript, annotations) = runScript def (def & app .~ appRoot) tokens script
settings = c
& root .~ appRoot
& appData .~ dataDir
& logger .~ queue
& targets .~ annotations^.profiles.to Subset
runInterpreter interpreter settings annotatedScript
where
info appRoot dataDir settings = unlines $
[ "* Relative filepaths are deemed relative to " ++ appRoot
, "* Data will be saved in " ++ dataDir
] ++
maybe [] (\_ -> return "* Offline mode") (settings ^? mode._Offline)
expandHome :: String -> IO String
expandHome pat =
case pat of
"~" -> D.getHomeDirectory
'~':'/':xs -> do
home <- D.getHomeDirectory
return (home </> xs)
_ -> return pat
pause :: Interpreter
pause = interpretOptimistically $ \settings _ -> do
Log.write (settings^.logger) $
Log.plain (text "Press any key to continue" <//> line)
hSetBuffering stdin NoBuffering
getChar
hSetBuffering stdin LineBuffering
confirm :: Interpreter
confirm = interpret go
where
go settings _ ks = do
k <- prompt (text "Proceed? [Y/n] ")
k
where
prompt message = fix $ \loop -> do
Log.write (settings^.logger) $
Log.plain message
res <- getLine
case map toLower res of
"y" -> return ks
"" -> return ks
"n" -> return (return (ExitFailure 1))
_ -> loop