A-gent-0.11.0.20: src/Agent/LLM.hs
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE LambdaCase #-}
--------------------------------------------------------------------------------
-- |
-- Copyright : (c) 2026 SPISE MISU ApS
-- License : SSPL-1.0 OR AGPL-3.0-only
-- Maintainer : SPISE MISU <mail+hackage@spisemisu.com>
-- Stability : experimental
--
-- Polite and well educated LLM agent with excellent manners that always behaves
-- well.
--------------------------------------------------------------------------------
module Agent.LLM
( -- * Modes
Mode(..)
-- * Context
, Context(..)
, AbsoluteFilePath
, Chat
, Chit
, File
, FileLine
, FilePaths
, Files
, Filter
, History
, Load
, Mask
, Root
, Template
, UUID
-- * Paramenters
, Eval
-- * Methods
, repl
, replWithMode
)
where
--------------------------------------------------------------------------------
import Prelude hiding ( head, mod, print, read )
import qualified Prelude as PRE
import Control.Monad ( void )
import Data.Char ( toLower, toUpper )
import Data.Foldable ( foldlM )
import Data.List ( isPrefixOf, nub, sort )
import Data.Maybe ( fromMaybe )
import GHC.IO.Encoding ( setLocaleEncoding )
import Numeric ( showFFloat )
import System.Environment ( getProgName )
import qualified System.Environment.Blank as ENV
import System.Exit
( ExitCode (ExitFailure, ExitSuccess)
)
import System.IO
( BufferMode (LineBuffering, NoBuffering)
, hFlush
, hSetBuffering
, hSetEcho
, stderr
, stdin
, stdout
, utf8
)
import System.Process ( readProcessWithExitCode )
import Text.Read ( readMaybe )
import Internal.LLM
( AbsoluteFilePath
, Chat
, Chit (..)
, Context (..)
, File
, FileLine
, FilePaths
, Files
, Filter
, History (..)
, Load
, Mask
, Mode (..)
, Root
, Template
, UUID
, modes
)
import qualified Internal.LLM as INT
import Internal.LLM.Action ( Action (..) )
import qualified Internal.LLM.SystemOne as SOM
import Internal.RIO
( RIO (..)
, fork
, input
, output
, terr
, timeout
, timestampUTC
, tkil
, tnum
, tval
, tvar
, typedHolesDev
, wait
)
import qualified Internal.Utils as UTL
import qualified Agent.Data.ANSI.EscapeCode as AEC
import qualified Agent.LLM.Message as MSG
import Agent.LLM.Message ( Message )
--------------------------------------------------------------------------------
type Eval a =
Context a
-> Message
-> RIO (Context a, Action)
--------------------------------------------------------------------------------
repl
:: Eval a
-> IO ()
repl =
replWithMode INT.Chat
replWithMode
:: INT.Mode
-> Eval a
-> IO ()
replWithMode mode_ proc =
do
constraint <- integrity
case constraint of
Right __ ->
do
setLocaleEncoding utf8
hSetBuffering stderr NoBuffering
hSetBuffering stdin NoBuffering
-- NOTE: logic based on `hFlush stdout`
hSetBuffering stdout LineBuffering
-- NOTE: No default output when typing
hSetEcho stdin False
putStrLn cls >> hFlush stdout
putStrLn head >> hFlush stdout
void $ run $ loop ctx proc
Left err ->
putStrLn err >> hFlush stdout
where
-- NOTE: `cls` and `clear` SHOULD be only defined once !!!
cls = "\^[[H\^[[2J" -- NOTE: See `infocmp -x`
ctx =
Context
{ quit = INT.Quit False
, mode = mode_
, load = Nothing
, hist =
History
{ chit =
Chit
{ prev = []
, next = []
}
, chat = []
}
, list = Nothing
, pile = Just $ INT.FilePaths []
, ruck = Just $ INT.Files []
, jobs = Just $ INT.Jobs []
, flow = INT.Flow False
, wrap = INT.Wrap False
}
--------------------------------------------------------------------------------
-- HELPERS (private)
{- NOTE: Doesn't seem to work
-- ctrlC :: IO () -> IO ()
ctrlC task =
-- NOTE: Catch CTRL+C
-- https://neilmitchell.blogspot.com/2015/05/handling-control-c-in-haskell.html
join . (:[]) <$> fork task
-}
head :: String
head =
"# Exit Λ-gent with /e or /exit. For more commands, type /? or /help."
help :: String
help =
unlines
[ "# Supported commands:"
, ds
, "/? or /help | This message"
, "/e or /exit | Exit Λ-gent"
, "/w or /wipe | Wipe screen (CTRL + L)"
, ds
, "/m m or /mode m | Change {" ++ ms ++ "}. Ex: /m plan"
, ds
, "/h or /hist | View history (input and output)"
, " /chit | View history (only input) "
, " /chat | View history (only output)"
, ds
, "/d or /drop | Drop end-user data load"
, ds
, "/l f or /list f | List of files, limited by mode, file masks and filter"
, "/p or /pile | Show stored list of files in pile. See /list above"
, "/f i or /file i | Show file with the provided index. See /pile above"
, "/n i or /nums i | Show file (idx) with line numbers. See /file above"
, ds
, "/s m or /send m | Sending /pile to LLM as context to the message"
, ds
, "/r or /ruck o | View files (opt index) from LLM responses. See /send or /fill"
, ds
, "/a d or /atom d | Atomically save /ruck files to a GIT branch (+ description)"
, ds
, " /repo | List /atom created GIT branches, including description"
, " /tail | Show (opt create) TAIL, based on origin/HEAD, as local storage"
, " /diff u | Show GIT branch (uid) differences with TAIL or origin/HEAD"
, " /disp | Dispose /atom failed branches or are behind/older than TAIL"
, " /meld | Auto-merge branches with TAIL, if possible. See /disp above"
, " /push | Create a remote branch, on origin, for TAIL"
, " /pull | Retrieve latest snapshot of origin/HEAD. See /push above"
, " /shed | Remove TAIL, if merged with origin/HEAD. See /pull above"
, ds
, "/t m or /task m | Fork /send m jobs for files. See /pile above"
, "/j or /jobs | Show info for executed jobs. See /task above"
, " /sync | Join contexts, if no errors. See /jobs above"
, " /stop | Kill or abort, current jobs. See /jobs above"
, ds
, " /disc | Discover files with typed-holes and store them in /pile"
, " /hole i | Show file (idx) typed-holes, if any. See /pile above"
, " /fill | Send /pile to LLM, to fill typed-holes with best suggestions"
, ds
, " /test u | Test TAIL or /atom GIT branches (uid) against specification"
, ds
, " /exec | Execute the automated mode. Limited by /mode auto"
, " /halt | Bring automation to a halt. Limited by /mode auto"
, ds
]
where
ds = replicate 80 '-'
ms =
foldl1 (\ x y -> x ++ "|" ++ y) $ map (map toLower . show) modes
--------------------------------------------------------------------------------
timeoutSecs :: Int
timeoutSecs = 3
loop
:: Context a
-> Eval a
-> RIO (Context a)
loop ctx eval =
print prompt >>
( if Auto == mod && flw then
( \case
Just "/halt" -> "/halt"
____________ -> "/exec"
)
<$> timeout timeoutSecs (read hps hns)
else
read hps hns
) >>= \ txt ->
printLn mtd [ ] >>
timestampUTC >>= \ outs ->
loopHelper mtd (action ctx txt) outs eval (prv txt ctx) >>= \ ctx_ ->
case ctx_ of
Context { quit = INT.Quit True } -> pure ctx_
________________________________ -> loop ctx_ eval
where
mtd = False
(INT.Flow flw) = flow ctx
mod = mode ctx
-- TODO: Refactoring needed
his = hist ctx
chi = chit his
hps = prev chi
hns = next chi
-- TODO: Refactoring needed
prv p c =
c
{ hist =
h
{ chit =
(chit $ hist c)
{ prev = p : hps
}
}
}
where
h = hist c
-- TODO: Refactoring needed
prompt =
(show . AEC.bold . AEC.sgr)
("Λ-" ++ (map toLower . show . mode) ctx ++ "> ")
read = input
loopHelper
:: Bool
-> Action
-> Maybe String
-> Eval a
-> Context a
-> RIO (Context a)
loopHelper mtd act_ outs eval ctx =
case act_ of
-- TODO: Refactoring needed
-- Nested -- Start
None ->
pure ctx
File _ ->
pure ctx
Files _ ->
pure ctx
Template {} ->
pure ctx
-- Nested -- Stop
Exit -> caseExit
Help -> caseHelp
Drop -> caseDrop
Hist (chits, chats) -> caseHist chits chats
Mode c cs -> caseMode c cs
Paths (INT.FilePaths fps) -> casePaths fps
Branches (INT.Branches bs) -> caseBranches bs
Pile -> casePile
Ruck midx -> caseRuck midx
Wipe -> caseWipe
UnknownCmd cmd -> caseUnknownCmd cmd
Discover -> caseDisc
Hole mfp -> caseHole mfp
Refine ->
-- TODO: Refeactor cos it works, but it's horrible !!!
case oafps of
Nothing ->
printLn mtd "No files in pile" >>
pure ctx
Just [ ] ->
printLn mtd "No files in pile" >>
pure ctx
Just afps ->
eval ctx MSG.Root >>= \ (upd0, act0) ->
case act0 of
Paths (INT.FilePaths rfps) ->
( case rfps of
[cwd] ->
eval upd0 MSG.Tail >>= \ (upd1, act1) ->
case act1 of
Branches (INT.Branches [INT.Branch uuid@(INT.UUID tid) _ _]) ->
typedHolesDev (Just uuid) cwd >>= \ case
Right ths_ ->
-- case INT.ghces2ths cwd Nothing ths_ of
case INT.ghces2ths tap Nothing ths_ of
Right ths ->
--
let
ds =
( nub . sort )
$ map
( \ (INT.Hole (INT.Location p _ _) _ _ _ _ _ _) ->
p
)
ths
ij =
filter
( \ (INT.AbsoluteFilePath afp) -> afp `elem` ds
)
afps
ps =
map
( \ (INT.AbsoluteFilePath afp) -> afp
)
afps
-- NOTE: We need to filer files that doesn't
-- have any TH. Once we have done that, we
-- need to filter away all the TH that aren't
-- in /pile files
kl =
filter
( \ (INT.Hole (INT.Location p _ _) _ _ _ _ _ _) ->
p `elem` ps
)
ths
in
if null ij then
printLn mtd nmsg >>
pure (nxt upd0 Nothing)
else
eval ctx ((MSG.Fill . Just) ij) >>= \ (upd2, act2) ->
case act2 of
Files (INT.Files fs) ->
acc >>= \ acc_ ->
pure (nxt acc_ Nothing)
where
len = length cwd
lhs =
map
( \ (INT.Hole (INT.Location lp ll lc) hs hd hbs hcs hfs hrs) ->
let
np = drop len lp
in
INT.Hole (INT.Location np ll lc) hs hd hbs hcs hfs hrs
)
kl
acc =
-- NOTE: We need to have the files
-- from TAIL branch
foldlM
( \ u req ->
eval u (MSG.Send [SOM.encode req]) >>= \ (u_, a_) ->
case a_ of
Message (MSG.Text cs) ->
case edec of
Right res ->
printLn mtd "# Fil/refine typed-holes" >>
( mapM_
( \ (q,a) ->
let
ai = PRE.read (SOM.choice a) :: Int
qc = SOM.criteria q !! ai
in
print "* " >>
( printLn mtd
. SOM.instructions
) q >>
print " - choice: " >>
( printLn mtd . SOM.val
) (snd qc) >>
print " - confidence: " >>
( printLn mtd
. show . SOM.confidence
) a
)
$ zip (map snd qs) (map snd as)
) >>
print "> Used tokens: " >>
print (show ut) >>
print " and elapsed time (ms): " >>
printLn mtd (show ul) >>
pure
( nxt
( u_ { ruck = Just rs }
)
( Just cs
)
)
where
rs =
case ruck u_ of
Nothing ->
INT.Files
[ SOM.replaceHoles req res
]
Just (INT.Files fs_) ->
INT.Files
( fs_ ++
[ SOM.replaceHoles req res
]
)
qs = SOM.questions req
as = SOM.answers res
ut = (SOM.input_tokens . SOM.usage) res
ul = (SOM.latency_ms . SOM.usage) res
Left err ->
printLn mtd err >>
pure (nxt u_ Nothing)
where
edec = SOM.decode cs
None ->
pure (nxt u_ Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt u_ (Just []))
) (upd2 { ruck = Nothing } )
$ map
( \ f@(INT.File (fp, _)) ->
let
hs =
filter
( \ (INT.Hole (INT.Location p _ _) _ _ _ _ _ _) ->
fp `isPrefixOf` p
)
lhs
in
SOM.request f hs
)
fs
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd2 (Just cs))
None ->
pure (nxt upd2 Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd2 (Just []))
where
nmsg =
"No files in pile with typed-holes"
Left es ->
mapM_ (printLn mtd . show) es >>
pure (nxt upd0 Nothing)
where
tmp = cwd ++ "tmp"
lid = (++ "_") $ map toLower tid
tap = tmp ++ "/" ++ lid ++ "/"
Left es ->
mapM_ (printLn mtd) es >>
pure (nxt upd0 Nothing)
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd1 (Just cs))
None ->
pure (nxt upd1 Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd1 (Just []))
_____ ->
printLn mtd "Missing root path" >>
pure (nxt upd0 Nothing)
)
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd0 (Just cs))
None ->
pure (nxt upd0 Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd0 (Just []))
where
oafps =
( \ (INT.FilePaths fps) -> map INT.AbsoluteFilePath fps
)
<$> pile ctx
Branch msg fs ->
eval ctx (MSG.Atom msg fs) >>= \ (upd, act) ->
case act of
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd (Just cs))
None ->
pure (nxt upd Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd (Just []))
Prompt msg ->
case oafps of
Nothing ->
printLn mtd "No files in pile" >>
pure ctx
Just [ ] ->
printLn mtd "No files in pile" >>
pure ctx
Just aps ->
-- TODO: Refactor
eval ctx (MSG.Tmpl $ Just aps) >>= \ (upd0, act0) ->
case act0 of
Template p is es fs ->
eval upd0 (MSG.Send xml) >>= \ (upd1, act1) ->
case act1 of
Message (MSG.Text cs) ->
case epfs of
Right pfs ->
printLn mtd cs >>
pure
( nxt
( upd1 { ruck = Just pfs }
)
( Just cs
)
)
Left es_ ->
( mapM_ ( \(i, x) -> printLn mtd $ i ++ ": " ++ x)
$ UTL.linesOptNums [] [] True 0 es_
) >>
pure (nxt upd1 (Just cs))
where
epfs =
case p cs of
Right fs_ ->
Right
$ INT.Files
$ map
( \ (fp, ls) ->
INT.File (fp, trimLines ls)
)
fs_
Left es_ ->
Left es_
None ->
pure (nxt upd1 Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd1 (Just []))
where
ils = concatMap ( \ (INT.File (_, ls)) -> ls) is
els = map ( \ (INT.File (_, ls)) -> unlines ls) es
tpl = INT.Template msg ils els fs
xml = INT.tpl2xmls tpl ([], [])
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd0 (Just cs))
None ->
pure (nxt upd0 Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd0 (Just []))
where
oafps =
( \ (INT.FilePaths fps) -> map INT.AbsoluteFilePath fps
)
<$> pile ctx
Batch msg ->
-- TODO: Refactor
case (null eps, null ejs, outs) of
( False, True, Just uts) ->
( eval ctx (MSG.Tmpl aps) >>= \ (upd0, act0) ->
case act0 of
Template p is es fs ->
let
ils = concatMap ( \ (INT.File (_, ls)) -> ls) is
els = map ( \ (INT.File (_, ls)) -> unlines ls) es
in
mapM
( \ f ->
let
tpl = INT.Template msg ils els [f]
xml = INT.tpl2xmls tpl ([], [])
in
fork
-- NOTE: Chats MUST be empty for each job as otherwise
-- we end up adding the previous history n times
( eval
( ( upd0
{ hist =
(hist upd0) { chat = [] }
}
)
) ( MSG.Send xml ) >>= \ (upd1, act1) ->
case act1 of
Message (MSG.Text cs) ->
case epfs of
Right pfs ->
pure
( nxt
( upd1
{ ruck = Just pfs
}
)
( Just cs
)
)
Left ___ ->
pure
( nxt upd1 (Just cs)
)
where
epfs =
case p cs of
Right fs_ ->
Right
$ INT.Files
$ map
( \ (fp, ls) ->
INT.File (fp, trimLines ls)
)
fs_
Left es_ ->
Left es_
_____________________ ->
pure upd1
)
)
fs
Message (MSG.Text cs) ->
sequence
[ fork
( pure
( upd0
{ hist =
(hist upd0) { chat = [ cs ] }
}
)
)
]
None ->
sequence
[ fork
( pure
( upd0
{ hist =
(hist upd0) { chat = [] }
}
)
)
]
_____________________ ->
-- NOTE: Unexpected error
sequence
[ fork
( pure
( upd0
{ hist =
(hist upd0) { chat = [ "Unexpected error" ] }
}
)
)
]
) >>= \ js ->
printLn mtd ("Batched tasks unique identifier: " ++ uts) >>
pure ctx { jobs = Just (njs (INT.UUID uts) js) }
( True, _, _) ->
printLn mtd "There are no files in the pile. See /help for info" >>
pure ctx
( _, False, _) ->
printLn mtd "Current batch is unsynchronized. See /help for info" >>
pure ctx
( _, _, Nothing) ->
printLn mtd "Missing unique identifier UTC-timestamp." >>
pure ctx
where
aps =
( \ (INT.FilePaths fps) -> map INT.AbsoluteFilePath fps
)
<$> pile ctx
eps = fromMaybe [] aps
ojs = jobs ctx
ejs =
case ojs of
Nothing -> []
Just (INT.Jobs js) -> js
njs uuid js =
INT.Jobs $ zip (repeat uuid) js
Status ->
mapM
( \ (INT.UUID uid, j) ->
tnum j >>= \ num ->
tvar j >>= \ var ->
if not var then
pure (uid, num, show INT.Running)
else
tval j >>= \ val ->
case val of
Nothing ->
terr j >>= \ err ->
pure (uid, num, show INT.Failure_ ++ " | " ++ fromMaybe [] err)
Just __ ->
pure (uid, num, show INT.Stopped)
) njs >>= \ logs ->
mapM_
( \ (uid, tid, status) ->
printLn mtd $ uid ++ " | " ++ tid ++ " | " ++ status
) logs >>
pure ctx
where
njs =
case jobs ctx of
Nothing -> []
Just (INT.Jobs js) -> js
Sync ->
mapM
( \ (_, j) ->
tvar j >>= \ var ->
if not var then
pure var
else
tval j >>= \ case
Nothing -> pure $ var && False
Just __ -> pure $ var && True
) njs >>= \ succeeded ->
if and succeeded then
mapM (wait . snd) njs >>= \ ctxs ->
let
(skipped, merged) =
foldl
( \ (bs, a) x ->
let
ars =
case ruck a of
Just (INT.Files rs) -> rs
Nothing -> []
xrs =
case ruck x of
Just (INT.Files rs) -> rs
Nothing -> []
ah = hist a
acs = chat ah
xcs = chat $ hist x
in
( bs ++ [null xrs]
, a
{ ruck = Just $ INT.Files $ ars ++ xrs
, hist = ah { chat = acs ++ xcs }
}
)
)
( []
, ctx { jobs = Just $ INT.Jobs [] }
)
ctxs
in
mapM
( \ ((INT.UUID uid, j), skip) ->
tnum j >>= \ num ->
if skip then
pure (uid, num, show INT.Skipped)
else
pure (uid, num, show INT.Blended)
) (zip njs skipped) >>= \ logs ->
mapM_
( \ (uid, tid, status) ->
printLn mtd $ uid ++ " | " ++ tid ++ " | " ++ status
) logs >>
pure merged
else
loopHelper mtd Status outs eval ctx
where
njs =
case jobs ctx of
Nothing -> []
Just (INT.Jobs js) -> js
Stop ->
mapM
( \ (INT.UUID uid, j) ->
tvar j >>= \ var ->
if not var then
tkil j >>= \ num ->
pure (uid, num, show INT.Stopped)
else
tnum j >>= \ num ->
pure (uid, num, show INT.Skipped)
) njs >>= \ logs ->
mapM_
( \ (uid, tid, status) ->
printLn mtd $ uid ++ " | " ++ tid ++ " | " ++ status
) logs >>
pure ctx { jobs = Just $ INT.Jobs [] }
where
njs =
case jobs ctx of
Nothing -> []
Just (INT.Jobs js) -> js
Tests _ ->
-- HERE: How do we use this???
printLn mtd "DEBUG:" >>
pure ctx
Exec ->
if Auto == mod then
if w then
printLn mtd "Automation has successfully halted" >>
pure (ctx { flow = INT.Flow False, wrap = INT.Wrap False })
else
let
flw = ctx { flow = INT.Flow True }
in
printLn mtd "> Discover and fill/refine Typed-Holes" >>
loopHelper mtd (Message MSG.Tail) outs eval flw >>=
loopHelper mtd Discover outs eval >>= \ dis ->
loopHelper mtd Refine outs eval dis >>= \ ref ->
let
(INT.FilePaths fps) = fromMaybe (INT.FilePaths []) (pile dis)
rfs = fromMaybe (INT.Files []) (ruck ref)
msg = "Automated atomic branch creation"
in
if null fps then
-- NOTE: If no files with TH, we stop automation
loopHelper mtd Halt outs eval ref
else
printLn mtd "> Create atomic branches, test, meld and clean-up" >>
loopHelper mtd (Branch msg rfs) outs eval ref >>= \ bch ->
eval bch MSG.Repo >>= \ (rep, act) ->
let
us =
case act of
Branches (INT.Branches bs) ->
map
( \ (INT.Branch uuid _ _) -> uuid
)
bs
__________________________ -> []
in
printLn mtd "> Differences with TAIL" >>
foldlM
( \ acc uuid ->
loopHelper mtd (Message (MSG.Diff uuid)) outs eval acc
) rep
us
>>= \ dif ->
printLn mtd "> Evaluating against the specification " >>
foldlM
( \ acc uuid ->
loopHelper mtd (Message (MSG.Test uuid)) outs eval acc
) dif
us
>>= \ tst ->
printLn mtd "> Melding with TAIL" >>
loopHelper mtd (Message MSG.Meld) outs eval tst >>=
loopHelper mtd (Message MSG.Disp) outs eval >>= \ lst ->
printLn mtd tom >>
pure lst
else
printLn mtd "/exec is only available in Auto-mode" >>
pure ctx
where
(INT.Wrap w) = wrap ctx
mod = mode ctx
tom =
"> NOTE: Type /halt to stop automated execution (timeout is: " ++
show timeoutSecs ++
" seconds)"
Halt ->
if Auto == mod then
( case (f, w) of
(False, ____) -> printLn mtd "No automation is running"
(True, True) -> printLn mtd "Wrap it up has already been requested"
_____________ -> printLn mtd "Request to wrap it up"
) >>
pure (ctx { wrap = INT.Wrap True })
else
printLn mtd "/halt is only available in Auto-mode" >>
pure ctx
where
(INT.Flow f) = flow ctx
(INT.Wrap w) = wrap ctx
mod = mode ctx
Message (MSG.Path ns afp) ->
eval ctx (MSG.Path ns afp) >>= \ (upd, act) ->
case act of
File (INT.File (_,ls)) ->
caseFile ns ls
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd (Just cs))
None ->
pure (nxt upd Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd (Just []))
Message (MSG.List fil) ->
eval ctx (MSG.List fil) >>= \ (upd, act) ->
case act of
Paths (INT.FilePaths fps) ->
casePaths fps
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd (Just cs))
None ->
pure (nxt upd Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd (Just []))
Message MSG.Repo ->
eval ctx MSG.Repo >>= \ (upd, act) ->
case act of
Branches (INT.Branches bs) ->
caseBranches bs
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd (Just cs))
None ->
pure (nxt upd Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd (Just []))
Message MSG.Tail ->
eval ctx MSG.Tail >>= \ (upd, act) ->
case act of
Branches (INT.Branches bs) ->
caseBranches bs
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd (Just cs))
None ->
pure (nxt upd Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd (Just []))
Message MSG.Disp ->
eval ctx MSG.Disp >>= \ (upd, act) ->
case act of
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd (Just cs))
None ->
pure (nxt upd Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd (Just []))
Message MSG.Meld ->
eval ctx MSG.Meld >>= \ (upd, act) ->
case act of
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd (Just cs))
None ->
pure (nxt upd Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd (Just []))
Message MSG.Push ->
eval ctx MSG.Push >>= \ (upd, act) ->
case act of
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd (Just cs))
None ->
pure (nxt upd Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd (Just []))
Message MSG.Pull ->
eval ctx MSG.Pull >>= \ (upd, act) ->
case act of
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd (Just cs))
None ->
pure (nxt upd Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd (Just []))
Message MSG.Shed ->
eval ctx MSG.Shed >>= \ (upd, act) ->
case act of
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd (Just cs))
None ->
pure (nxt upd Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd (Just []))
Message (MSG.Test uuid) ->
eval ctx (MSG.Test uuid) >>= \ (upd0, act0) ->
case act0 of
Tests (INT.TestCases tcs) ->
( if null tcs then
let
msg = "[FAIL] There are no test cases"
lab = INT.Label msg
in
eval ctx (MSG.Desc uuid lab) >>= \ (upd1, act1) ->
case act1 of
Message (MSG.Text cs) ->
printLn mtd ("# " ++ msg) >>
pure (nxt upd1 (Just cs))
None ->
pure (nxt upd1 Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error DEBUG:" >>
pure (nxt upd1 (Just []))
else
let
msg = "[FAIL] Not all test cases are meldable"
lab = INT.Label msg
in
( if eam then
printLn mtd "# Test cases"
else
printLn mtd ("# " ++ msg)
) >>
printLn mtd ("* All succeeded .....: " ++ show eas) >>
printLn mtd ("* All meldable ......: " ++ show eam) >>
mapM_
( \ ( INT.TestCase l
( INT.TestResult
{ INT.status = s
, INT.output = o
--
, INT.numTests = m
, INT.usedSize = n
, INT.reason = r
, INT.theException = e
}
)
) ->
printLn mtd ("## " ++ l) >>
printLn mtd ("* Status ............: " ++ show s) >>
if INT.Failure == s then
let
m_ = if null e then r else e
in
printLn mtd ("* Tests size ........: " ++ show m) >>
printLn mtd ("* Tests performed ...: " ++ show n) >>
printLn mtd ("* Result ............:\n" ++ o) >>
printLn mtd ("* Reason ............:\n" ++ m_)
else
printLn mtd ("* Result ............:\n" ++ o)
)
tcs
>>
( if not eam then
eval ctx (MSG.Desc uuid lab) >>= \ (upd1, act1) ->
case act1 of
Message (MSG.Text cs) ->
pure (nxt upd1 (Just cs))
None ->
pure (nxt upd1 Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error DEBUG:" >>
pure (nxt upd1 (Just []))
else
pure (nxt upd0 Nothing)
)
)
where
eas = not (null tcs) && all INT.isSuccess tcs
eam = not (null tcs) && all INT.isMeldable tcs
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd0 (Just cs))
None ->
pure (nxt upd0 Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error DEBUG:" >>
pure (nxt upd0 (Just []))
Message msg ->
eval ctx msg >>= \ (upd, act) ->
case act of
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd (Just cs))
None ->
pure (nxt upd Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd (Just []))
where
-- TODO: Refactoring needed
nxt c o =
c
{ hist =
h
{ chat =
case o of
Nothing -> chat h
Just r -> (r:) $ chat h
}
}
where
h = hist c
caseExit =
printLn mtd "Λ-gent will shutdown" >>
pure ctx_
where
ctx_ = ctx { quit = INT.Quit True }
caseDrop =
printLn mtd "Dropping end-user data load" >>
pure
( ctx
{ load = Nothing
}
)
-- TODO: Refactoring needed
caseMode c cs =
case mmod of
Just mode_ ->
printLn mtd ("Changed to " ++ low ++ "-mode") >>
pure
( ctx
{ mode = mode_
, pile = Just $ INT.FilePaths []
, ruck = Just $ INT.Files []
}
)
where
low = map toLower $ show mode_
Nothing ->
printLn mtd ("Invalid mode: " ++ c:cs) >>
pure ctx
where
mmod = readMaybe (toUpper c : map toLower cs) :: Maybe INT.Mode
caseHist chits chats =
( if chits then
printLn mtd "* Chits:" >>
( mapM_ (printLn mtd) . UTL.combine False . UTL.chits True . prev . chit . hist
) ctx
else
pure ()
) >>
( if chats then
printLn mtd "* Chats:" >>
( mapM_ (printLn mtd) . UTL.combine False . UTL.chats True . chat . hist
) ctx
else
pure ()
) >>
pure ctx
caseFile ns ls =
( mapM_ (printLn mtd) .
UTL.combine False .
UTL.file ns
) (unlines ls) >>
pure ctx
caseHelp =
printLn mtd help >>
pure ctx
casePaths fps =
eval ctx MSG.Root >>= \ (upd, act) ->
case act of
Paths (INT.FilePaths rfps) ->
( case rfps of
[cwd] ->
mapM_ (printLn mtd) .
UTL.combine False .
UTL.files [] True .
-- NOTE: Show relative paths
map (drop (length cwd)) $
fps
_____ ->
printLn mtd "Missing root path"
) >>
pure
( (nxt upd Nothing)
{ pile = Just $ INT.FilePaths fps
}
)
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd (Just cs))
None ->
pure (nxt upd Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd (Just []))
caseBranches bs =
if null bs then
printLn mtd "There are no local branches" >>
pure (nxt ctx Nothing)
else
mapM_ (printLn mtd) ls >>
pure (nxt ctx Nothing)
where
ls =
UTL.combine False .
UTL.files [] False .
map
( \ (INT.Branch (INT.UUID uid) emof des) ->
let
mod =
case emof of
Left _ -> "[FAIL]"
Right m -> "[" ++ map toUpper (show m) ++ "]"
in
uid ++ ": " ++ mod ++ " " ++ des
) $
bs
casePile =
eval ctx MSG.Root >>= \ (upd, act) ->
case act of
Paths (INT.FilePaths fps) ->
( case fps of
[cwd] ->
mapM_ (printLn mtd) .
UTL.combine False .
UTL.files [] True .
-- NOTE: Show relative paths
map (drop (length cwd)) .
concatMap INT.filePaths .
pile $
upd
_____ ->
printLn mtd "Missing root path"
) >>
pure (nxt upd Nothing)
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd (Just cs))
None ->
pure (nxt upd Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd (Just []))
caseRuck midx =
( case idx of
Right i ->
if 0 <= i && i < len then
( mapM_ (printLn mtd) .
UTL.combine False .
UTL.file True .
concatMap f .
ruck
) ctx
else
let
m = "Index (" ++ show i ++ ") is out of bounds."
in
printLn mtd m
where
f (INT.Files fs) =
case fs !! i of
INT.File (_,ls) -> unlines ls
Left [] ->
-- NOTE: If no optional index provided, show only paths
( mapM_ (printLn mtd) .
UTL.combine False .
UTL.files [] True .
concatMap fps .
ruck
) ctx
Left es ->
(printLn mtd . unlines) es
) >>
pure ctx
where
idx =
case midx of
[ ] ->
Left []
' ':cs ->
maybe
( Left
[ "Invalid index. Type /help for more info"
]
)
Right
( readMaybe cs :: Maybe Int
)
______ ->
Left
[ "Invalid use of /r or /ruck. Use space between cmd and index"
]
len =
case ruck ctx of
Just (INT.Files fs) -> length fs
Nothing -> 0
fps (INT.Files fs) =
map ( \ (INT.File (p,_)) -> p) fs
caseDisc =
-- TODO: Refactor
eval ctx MSG.Root >>= \ (upd0, act0) ->
case act0 of
Paths (INT.FilePaths rfps) ->
( case rfps of
[cwd] ->
eval upd0 MSG.Tail >>= \ (upd1, act1) ->
case act1 of
Branches (INT.Branches [INT.Branch uuid@(INT.UUID tid) _ _]) ->
typedHolesDev (Just uuid) cwd >>= \ eths ->
case eths of
Right ths_ ->
-- case INT.ghces2ths cwd Nothing ths_ of
case INT.ghces2ths tap Nothing ths_ of
Right ths ->
( mapM_
( \ ( i
, INT.Hole (INT.Location p l c) (INT.Signature hn s) d _ _ _ _
) ->
let
rp = drop (length cwd) p
in
( printLn mtd
$ show i ++ ": " ++
rp ++ ":" ++
show l ++ ":" ++
show c
) >>
(printLn mtd " # Hole") >>
(printLn mtd $ " (" ++ hn ++ " :: " ++ s ++ ")") >>
(printLn mtd " # Description") >>
(mapM_ (printLn mtd . (" - " ++)) d)
)
$ zip [0 :: Int ..] ths
) >>
pure
( (nxt upd0 Nothing)
{ pile =
Just
$ INT.FilePaths
$ ( nub . sort )
$ map
( \ (INT.Hole (INT.Location p _ _) _ _ _ _ _ _) ->
p
)
ths
}
)
Left es ->
mapM_ (printLn mtd . show) es >>
pure (nxt upd1 Nothing)
where
tmp = cwd ++ "tmp"
lid = (++ "_") $ map toLower tid
tap = tmp ++ "/" ++ lid ++ "/"
Left es ->
mapM_ (printLn mtd) es >>
pure (nxt upd1 Nothing)
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd1 (Just cs))
None ->
pure (nxt upd1 Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd1 (Just []))
_____ ->
printLn mtd "Missing root path" >>
pure (nxt upd0 Nothing)
)
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd0 (Just cs))
None ->
pure (nxt upd0 Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd0 (Just []))
caseHole mfp =
-- TODO: Refact0or
case mfp of
Just (INT.AbsoluteFilePath afp) ->
eval ctx MSG.Root >>= \ (upd0, act0) ->
case act0 of
Paths (INT.FilePaths rfps) ->
( case rfps of
[cwd] ->
eval upd0 MSG.Tail >>= \ (upd1, act1) ->
case act1 of
Branches (INT.Branches [INT.Branch uuid@(INT.UUID tid) _ _]) ->
typedHolesDev (Just uuid) cwd >>= \ case
Right ths_ ->
-- case INT.ghces2ths cwd Nothing ths_ of
case INT.ghces2ths tap Nothing ths_ of
Right ths ->
( mapM_
( \ ( i
, INT.Hole (INT.Location p l c) (INT.Signature hn s) d bs cs fs rs_
) ->
let
rp = drop (length cwd) p
dc n = showFFloat (Just 10) n ""
in
( printLn mtd
$ show i ++ ": " ++
rp ++ ":" ++
show l ++ ":" ++ show c
) >>
(printLn mtd " # Hole") >>
( printLn mtd
$ " (" ++ hn ++ " :: " ++ s ++ ")"
) >>
(printLn mtd " # Description") >>
( mapM_ (printLn mtd . (" - " ++)) d
) >>
(printLn mtd " # Bindings") >>
( mapM_
( \(n,s_) ->
printLn mtd
$ " - " ++ n ++ " :: " ++ s_
)
bs
) >>
(printLn mtd " # Constraints") >>
( mapM_
( \(n,p_) ->
printLn mtd
$ " - " ++ n ++ " " ++ p_
)
cs
) >>
(printLn mtd " # Fits") >>
(mapM_
( \(n,s_,l_) ->
printLn mtd
$ " - " ++ n ++
" :: " ++ s_ ++
" (likelihood: " ++ dc l_ ++ ")"
) fs
) >>
(printLn mtd " # Refinements") >>
( mapM_
( \(n,c_,s_) ->
printLn mtd
$ " - " ++ n ++ c_ ++ " where " ++ s_
)
rs_
)
)
$ zip [0 :: Int ..]
$ filter
( \ (INT.Hole (INT.Location p _ _) _ _ _ _ _ _) ->
p == afp
)
ths
) >>
pure (nxt upd1 Nothing)
Left es ->
mapM_ (printLn mtd . show) es >>
pure (nxt upd1 Nothing)
where
tmp = cwd ++ "tmp"
lid = (++ "_") $ map toLower tid
tap = tmp ++ "/" ++ lid ++ "/"
Left es ->
mapM_ (printLn mtd) es >>
pure (nxt upd1 Nothing)
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd1 (Just cs))
None ->
pure (nxt upd1 Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd1 (Just []))
_____ ->
printLn mtd "Missing root path" >>
pure (nxt upd0 Nothing)
)
Message (MSG.Text cs) ->
printLn mtd cs >>
pure (nxt upd0 (Just cs))
None ->
pure (nxt upd0 Nothing)
_________________________ ->
-- NOTE: Unexpected error
printLn mtd "Unexpected error" >>
pure (nxt upd0 (Just []))
Nothing ->
printLn mtd "Invalid index, see /pile. Type /help for more info" >>
pure (nxt ctx Nothing)
caseWipe =
printLn mtd clear >>
pure ctx
caseUnknownCmd cmd =
printLn mtd msg >>
pure ctx
where
msg = "Command not recognized: " ++ show ("/" ++ cmd)
-- NOTE: Clear screen & Move top-left
clear = "\^[[H\^[[2J" -- NOTE: See `infocmp -x`
print
:: String
-> RIO ()
print =
output . show . AEC.faint . AEC.sgr
printLn
:: Bool
-> String
-> RIO ()
printLn mtd x =
if mtd then
pure ()
else
print $ x ++ "\n"
action
:: Context a
-> String
-> Action
action ctx txt =
-- TODO: Refactoring needed
case txt of
'/':'m':'o':'d':'e':' ':c:cs -> Mode c cs
'/':'m' :' ':c:cs -> Mode c cs
'/':'l':'i':'s':'t' :mfil ->
-- TODO: DRY
Message (MSG.List fil)
where
fil =
case mfil of
[ ] -> Just $ INT.Filter mfil
' ':cs -> Just $ INT.Filter cs
______ -> Nothing
'/':'l' :mfil ->
-- TODO: DRY
Message (MSG.List fil)
where
fil =
case mfil of
[ ] -> Just $ INT.Filter mfil
' ':cs -> Just $ INT.Filter cs
______ -> Nothing
'/':'f':'i':'l':'e':' ':midx ->
-- TODO: DRY
case oidx of
Nothing ->
Message (MSG.Path False Nothing)
Just idx ->
if 0 <= idx && idx < length pfs then
Message (MSG.Path False (Just $ INT.AbsoluteFilePath $ pfs !! idx))
else
Message (MSG.Path False Nothing)
where
pfs = concatMap INT.filePaths $ pile ctx
where
oidx =
case midx of
[] -> Nothing
cs -> readMaybe cs :: Maybe Int
'/':'f' :' ':midx ->
-- TODO: DRY
case oidx of
Nothing ->
Message (MSG.Path False Nothing)
Just idx ->
if 0 <= idx && idx < length pfs then
Message (MSG.Path False (Just $ INT.AbsoluteFilePath $ pfs !! idx))
else
Message (MSG.Path False Nothing)
where
pfs = concatMap INT.filePaths $ pile ctx
where
oidx =
case midx of
[] -> Nothing
cs -> readMaybe cs :: Maybe Int
'/':'n':'u':'m':'s':' ':midx ->
-- TODO: DRY
case oidx of
Nothing ->
Message (MSG.Path True Nothing)
Just idx ->
if 0 <= idx && idx < length pfs then
Message (MSG.Path True (Just $ INT.AbsoluteFilePath $ pfs !! idx))
else
Message (MSG.Path True Nothing)
where
pfs = concatMap INT.filePaths $ pile ctx
where
oidx =
case midx of
[] -> Nothing
cs -> readMaybe cs :: Maybe Int
'/':'n' :' ':midx ->
-- TODO: DRY
case oidx of
Nothing ->
Message (MSG.Path True Nothing)
Just idx ->
if 0 <= idx && idx < length pfs then
Message (MSG.Path True (Just $ INT.AbsoluteFilePath $ pfs !! idx))
else
Message (MSG.Path True Nothing)
where
pfs = concatMap INT.filePaths $ pile ctx
where
oidx =
case midx of
[] -> Nothing
cs -> readMaybe cs :: Maybe Int
'/':'s':'e':'n':'d':' ':mesg -> Prompt mesg
'/':'s' :' ':mesg -> Prompt mesg
'/':'t':'a':'s':'k':' ':mesg -> Batch mesg
'/':'t' :' ':mesg -> Batch mesg
['/','j','o','b','s'] -> Status
['/','j' ] -> Status
['/','s','y','n','c'] -> Sync
['/','s','t','o','p'] -> Stop
['/','d','i','s','c'] -> Discover
'/':'h':'o':'l':'e' :midx ->
-- TODO: DRY
case oidx of
Nothing ->
Hole Nothing
Just idx ->
if 0 <= idx && idx < length pfs then
Hole $ Just $ INT.AbsoluteFilePath $ pfs !! idx
else
Hole Nothing
where
pfs = concatMap INT.filePaths $ pile ctx
where
oidx =
case midx of
[] -> Nothing
cs -> readMaybe cs :: Maybe Int
['/','f','i','l','l'] -> Refine
'/':'a':'t':'o':'m':' ':mesg ->
-- TODO: DRY
Branch mesg fs
where
fs = fromMaybe (INT.Files []) (ruck ctx)
'/':'a' :' ':mesg ->
-- TODO: DRY
Branch mesg fs
where
fs = fromMaybe (INT.Files []) (ruck ctx)
['/','r','e','p','o'] -> Message MSG.Repo
['/','t','a','i','l'] -> Message MSG.Tail
'/':'d':'i':'f':'f' :muid ->
-- TODO: Fix, doesn't seem to work
case ouid of
Nothing ->
Message (MSG.Text "No valid uniqued identifier was provided")
Just u ->
Message (MSG.Diff (INT.UUID u))
where
ouid =
case muid of
[ ] -> Nothing
' ':cs -> Just cs
______ -> Nothing
['/','d','i','s','p'] -> Message MSG.Disp
['/','m','e','l','d'] -> Message MSG.Meld
['/','p','u','s','h'] -> Message MSG.Push
['/','p','u','l','l'] -> Message MSG.Pull
['/','s','h','e','d'] -> Message MSG.Shed
'/':'t':'e':'s':'t' :muid ->
case ouid of
Nothing ->
Message (MSG.Text "No valid uniqued identifier was provided")
Just u ->
Message (MSG.Test (INT.UUID u))
where
ouid =
case muid of
[ ] -> Nothing
' ':cs -> Just cs
______ -> Nothing
['/','e','x','e','c'] -> Exec
['/','h','a','l','t'] -> Halt
'/':'r':'u':'c':'k' :midx -> Ruck midx
['/','r'] -> Ruck [ ]
"/exit" -> Exit
"/e" -> Exit
"/help" -> Help
"/?" -> Help
"/drop" -> Drop
"/d" -> Drop
"/hist" -> Hist ( True, True )
"/h" -> Hist ( True, True )
"/chit" -> Hist ( True, False )
"/chat" -> Hist ( False, True )
"/pile" -> Pile
"/p" -> Pile
"/wipe" -> Wipe
"/w" -> Wipe
'/':cmd -> UnknownCmd cmd
____________________________ -> Message (MSG.Text txt)
--------------------------------------------------------------------------------
integrity :: IO (Either String ())
integrity =
do
ohi <- ENV.getEnv "LLM_SIGN_SHA"
case ohi of
Nothing -> pure $ Right ()
Just hi ->
do
op <- cwd
pn <- getProgName
case op of
Left e -> pure $ Left e
Right p ->
do
ehf <- sha ap
case ehf of
Left ef -> pure $ Left ef
Right hf ->
if hi == h64 then
pure $ Right ()
else
pure $
Left $
"# Λ-gent integrity failed:\n" ++
"> " ++ hi ++ " (expected)\n" ++
"> " ++ h64 ++ " (observed)"
where
h64 = take 64 hf
where
ap = concat $ lines p ++ [ "/" ] ++ lines pn
where
-- TODO: Move "HELPERS (private)" private out from Internal/RIO.hs to
-- Internal/IO.hs and then just wrap them with `RestrictedIO`. This will
-- allow for logic like this to be simplified
cwd =
do
-- NOTE: inconsistency between `linux` and `macOS`:
--
-- - If no option is specified, -P is assumed (linux)
--
-- - If no options are specified, the -L option is assumed (macOS)
--
-- -L, --logical use PWD from environment, even if it contains symlinks
--
-- -P, --physical resolve all symlinks
(exitcode, out, err) <- readProcessWithExitCode "pwd" [ "-P" ] []
case exitcode of
ExitSuccess ->
pure $ Right out
ExitFailure _ ->
pure $ Left err
sha p =
do
(exitcode, out, err) <- readProcessWithExitCode "sha256sum" [ p ] []
case exitcode of
ExitSuccess ->
pure $ Right out
ExitFailure _ ->
pure $ Left err
--------------------------------------------------------------------------------
trimLines
:: [String]
-> [String]
trimLines [ ] = [ ]
trimLines ls@(x:xs) = if null x then trimLines xs else aux (reverse ls)
where
aux [ ] = [ ]
aux rls@(y:ys) = if null y then aux ys else reverse rls