A-gent-0.11.0.20: src/Internal/LLM.hs
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DuplicateRecordFields #-}
--------------------------------------------------------------------------------
-- |
-- Copyright : (c) 2026 SPISE MISU ApS
-- License : SSPL-1.0 OR AGPL-3.0-only
-- Maintainer : SPISE MISU <mail+hackage@spisemisu.com>
-- Stability : experimental
--------------------------------------------------------------------------------
module Internal.LLM
( UUID (..)
, Root (..)
, Filter (..)
, Quit (..)
, Mode (..)
, Chit (..)
, Chat
, History (..)
, Load
, Flow (..)
, Wrap (..)
, Context(..)
, Mask (..)
, File (..)
, Files (..)
, FileLine
, FilePaths (..)
--
, Failure, ModeOrFailure, Description
, Label (..)
, Branch (..)
, Branches (..)
, Index (..)
--
, Jobs (..)
, JobStatus (..)
--
, Pattern (..)
--
, AbsoluteFilePath (..)
, AbsoluteFilePaths (..)
--
, Template (..)
, GhcError (..)
, Location (..)
-- , Content (..)
, Hole (..)
, Signature (..)
--
, TestCase (..)
, TestCases (..)
, TestResult (..)
, TestStatus (..)
--
, modes
--
, ghcErrorHole
, getGhcErrorLocation
, setGhcErrorLocation
--
, tpl2xmls
--
, decodeJsonArray
--
, txt2b
, txt2ghces
, ghces2ths
--
, th2xml
, ths2xml
--
, gd2fps
--
, isSuccess
, isMeldable
, jsonl2tcs
)
where
--------------------------------------------------------------------------------
import Prelude hiding ( span )
import Control.Arrow ( first )
import Control.Monad ( void )
import Data.Char ( toLower, toUpper )
import Data.Data ( Data )
import Data.Either ( partitionEithers )
import Data.List ( isPrefixOf, partition )
import Data.Maybe ( fromMaybe, listToMaybe )
import Numeric ( showFFloat )
import Text.Read ( readMaybe )
import Text.ParserCombinators.ReadP
import Internal.GaloisInc.Text.JSON.Generic
( Result (Error, Ok)
, fromJSON
)
import Internal.GaloisInc.Text.JSON.String
( readJSValue
, runGetJSON
)
import Agent.Control.Concurrent ( Task )
import qualified Internal.Utils as UTL
--------------------------------------------------------------------------------
newtype UUID = UUID String
newtype Root = Root FilePath deriving Eq
newtype Filter = Filter String
newtype Quit = Quit Bool
data Mode
= Auto
| Chat
| Code
| Docs
| Echo
| Hone
| Plan
| Spec
deriving (Bounded, Enum, Eq, Read, Show)
data Chit =
Chit
{ prev :: ![String]
, next :: ![String]
}
type Chat = [String]
data History =
History
{ chit :: !Chit
, chat :: !Chat
}
type Load a =
( Data a
, Show a
)
=> Maybe a
newtype Flow = Flow Bool
newtype Wrap = Wrap Bool
data Context a =
Context
{ quit :: !Quit
, mode :: !Mode
, load :: !(Load a)
, hist :: !History
, list :: !(Maybe Filter)
, pile :: !(Maybe FilePaths)
, ruck :: !(Maybe Files)
, jobs :: !(Maybe (Jobs (Context a)))
, flow :: !Flow
, wrap :: !Wrap
}
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
newtype Mask = Mask [String]
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
type Markdown = String
type FileLine = String
newtype File = File (FilePath, [FileLine])
--------------------------------------------------------------------------------
newtype Files = Files [File]
instance Semigroup Files where
Files xs <> Files ys =
Files (xs ++ ys)
instance Monoid Files where
mempty = Files []
--------------------------------------------------------------------------------
newtype AbsoluteFilePath = AbsoluteFilePath FilePath
newtype AbsoluteFilePaths = AbsoluteFilePaths [FilePath]
--------------------------------------------------------------------------------
-- NOTE: Then use `mconcat` to combine
newtype FilePaths = FilePaths { filePaths :: [FilePath] }
instance Semigroup FilePaths where
FilePaths xs <> FilePaths ys =
FilePaths (xs ++ ys)
instance Monoid FilePaths where
mempty = FilePaths []
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
type Description = String
newtype Label = Label Description
type Failure = ()
type ModeOrFailure = Either Failure Mode
data Branch = Branch !UUID !ModeOrFailure !Description
newtype Branches = Branches [Branch]
newtype Index = Index Int
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
newtype Jobs a = Jobs [(UUID, Task a)]
--------------------------------------------------------------------------------
data JobStatus
= Blended
| Failure_
| Running
| Skipped
| Stopped
| Waiting
instance Show JobStatus where
show status_ =
case status_ of
Blended -> "BLENDED"
Failure_ -> "FAILURE"
Running -> "RUNNING"
Skipped -> "SKIPPED"
Stopped -> "STOPPED"
Waiting -> "WAITING"
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
data Template =
Template
{ purpose :: !String
, instructions :: ![String]
, examples :: ![Markdown]
, files :: ![File]
}
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
newtype Pattern = Pattern String
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
data DecodeError
= InvalidJSON !String
| DiffSchema !String
deriving Show
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
data ParseError
= Remaining !String
| Unparsed ![String]
| Unexpected ![String]
deriving Show
--------------------------------------------------------------------------------
data GhcError =
GhcError
{ location :: !(String,Int,Int)
, number :: !(Maybe Int)
, content :: ![String]
} deriving Show
--------------------------------------------------------------------------------
data Location =
Location !String !Int !Int
deriving Show
data Signature =
Signature !String !String
deriving Show
data Hole =
Hole
{ location :: !Location
, signature :: !Signature
, description :: ![String]
, bindings :: ![(String, String)]
, constraints :: ![(String, String)]
, fits :: ![(String, String, Double)]
, refinements :: ![(String, String, String)]
} deriving Show
--------------------------------------------------------------------------------
data TestStatus
= Success
| Failure
| Desisted
| NoFailure
deriving (Eq, Data, Show)
data TestResult =
TestResult
{ status :: !TestStatus
, numTests :: !Int
, usedSize :: !Int
, output :: !String
, reason :: !String
, theException :: !String
} deriving (Data, Show)
data TestCase =
TestCase
{ label :: !String
, result :: !TestResult
} deriving (Data, Show)
newtype TestCases = TestCases [TestCase]
instance Semigroup TestCases where
TestCases xs <> TestCases ys =
TestCases (xs ++ ys)
instance Monoid TestCases where
mempty = TestCases []
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
modes :: [Mode]
modes =
[ minBound .. maxBound ]
--------------------------------------------------------------------------------
tpl2xmls
:: Template
-> (String, [Hole])
-> [String]
tpl2xmls tpl (cwd, ths) =
[ ( if eis && ees && efs then
pur
else
"<purpose>" ++ pur ++ "</purpose>"
) ++
( if eis then
[]
else
"<instructions>" ++
tis ++
"</instructions>"
) ++
( if ees then
[]
else
"<examples>" ++
tes ++
"</examples>"
) ++
( if efs then
[]
else
"<files>" ++
concatMap aux tfs ++
"</files>"
) ++
ths2xml cwd ths
]
where
pur =
purpose tpl ++
( if eis then
[]
else
". Follow the specified `instructions`"
) ++
( if ees then
[]
else
". Output MUST match scaffolding from provided `examples`"
) ++
( if efs then
[]
else
". Apply to each of the `files`"
)
eis = null tis
ees = null tes
efs = null tfs
tis =
concatMap (\ x -> "<instruction><![CDATA[" ++ x ++ "]]></instruction>")
$ instructions tpl
tes =
concatMap (\ x -> "<example><![CDATA[" ++ x ++ "]]></example>")
$ examples tpl
tfs = zip [0 :: Int ..] $ files tpl
aux (i, File (src, ls)) =
"<file index='" ++ show i ++ "'>" ++
"<source>" ++ src ++ "</source>" ++
"<content><![CDATA[" ++ unlines ls ++ "]]></content>" ++
"</file>"
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
ghcErrorHole
:: GhcError
-> Bool
ghcErrorHole (GhcError { number = Just 88464, content = ms }) =
-- NOTE: If it's 'var not in scope', just skip
case isPrefixOf "Variable not in scope:" <$> listToMaybe ms of
Just True -> False
_________ -> True
ghcErrorHole ________________________________________________ = False
getGhcErrorLocation
:: GhcError
-> (String,Int,Int)
getGhcErrorLocation (GhcError l _ _) =
l
setGhcErrorLocation
:: (String,Int,Int)
-> GhcError
-> GhcError
setGhcErrorLocation loc (GhcError _ mec con) =
GhcError loc mec con
--------------------------------------------------------------------------------
decodeJsonArray
:: String
-> Either DecodeError [FileLine]
decodeJsonArray json =
case runGetJSON readJSValue json of
Left e -> Left $ InvalidJSON e
Right v ->
case fromJSON v of
Error err -> Left $ DiffSchema err
Ok fls -> Right fls
--------------------------------------------------------------------------------
txt2ghcesInitHlp
:: String
-> Either ParseError GhcError
txt2ghcesInitHlp txt =
case readP_to_S (errP <* eof) txt of
[(a, [])] -> Right a
[(_, cs)] -> (Left . Remaining) cs
_________ -> (Left . Unparsed) [txt]
where
errP =
( \ _ fp l c _ _ oe ->
GhcError
{ location = (fp, read l :: Int, read c :: Int)
, number = oe
, content = []
}
)
<$> skipSpaces
<*> manyTill anyChar (char ':')
<*> manyTill anyChar (char ':')
<*> manyTill anyChar (char ':')
<*> skipSpaces
-- NOTE: As we need to validate typed-hole filling from the LLM against
-- the specification, in order to be able to `-fdefer-typed-holes`, we
-- need to support warnings as well as errors.
<*> choice [ string "error:", string "warning:" ]
<*> choice
[ -- NOTE: "error:"
( \ _ _ n _ -> Just (read n :: Int)
)
<$> skipSpaces
<*> string "[GHC-"
<*> manyTill anyChar (char ']')
<*> endOfLine
, -- NOTE: "warning:"
( \ _ _ n _ _ _ _ -> Just (read n :: Int)
)
<$> skipSpaces
<*> string "[GHC-"
<*> manyTill anyChar (char ']')
-- NOTE: Added when refactored from "error:" to "warning:"
<*> skipSpaces
<*> char '['
<*> manyTill anyChar (char ']')
<*> endOfLine
, -- NOTE: No extra info
Nothing <$ endOfLine
]
txt2ghcesLastHlp
:: GhcError
-> Either ParseError GhcError
txt2ghcesLastHlp (GhcError gel gemn gels) =
case readP_to_S (errP <* eof) txt of
[(a, [])] -> Right a
[(_, cs)] -> (Left . Remaining) cs
_________ -> (Left . Unparsed) [txt]
where
txt = unlines gels
errP =
( \ b _ _ _ _ _ _ ->
let
ls =
filter (not . null)
$ map (drop 4)
$ lines b
in
GhcError gel gemn ls
)
<$> manyTill anyChar (char '|')
<*> manyTill anyChar endOfLine
<*> manyTill anyChar (char '|')
<*> manyTill anyChar endOfLine
<*> manyTill anyChar (char '|')
<*> manyTill anyChar
( choice
[ void endOfLine
, eof
]
)
<*> skipSpaces
txt2ghces
:: [String]
-> Either [ParseError] [GhcError]
txt2ghces =
( \ case
([], rs) -> Right rs
(es, __) -> Left es
)
<$> partitionEithers . aux nil
where
nil = Nothing
--
aux Nothing [ ] = [ ]
aux (Just acc) [ ] =
[ case acc of
Right a -> txt2ghcesLastHlp a
Left e -> Left e
]
--
aux Nothing ([ ] : ls) = aux nil ls
aux (Just acc) ([ ] : ls) =
( case acc of
Right a -> txt2ghcesLastHlp a
Left e -> Left e
) : aux nil ls
--
aux Nothing ( l : ls) =
aux (Just mghce) ls
where
mghce = txt2ghcesInitHlp (l ++ "\n")
aux (Just acc) ( l : ls) =
aux (Just mghce) ls
where
mghce =
case acc of
Right a ->
Right
( a
{ content = content a ++ [l]
}
)
Left e ->
Left e
ghces2ths
:: FilePath
-> Maybe Int
-> [GhcError]
-> Either [ParseError] [Hole]
ghces2ths cwd upper ghces =
if null ls then
Right rs
else
(Left . concat) ls
where
sub = substitute cwd []
ehs =
( map
( \ (GhcError (lfp, ll, lc) _ ms) ->
-- NOTE: Scripts MUST be excuted with UTF-8 support:
--
-- LLM_PATH_CWD= … LC_ALL=en_US.UTF-8 ./hone.lhs
--
-- Otherwise they fallback to '*' instead of '•'.
case combine "•" ms of
[m1, m2, m3] ->
case msg1P $ unwords $ msgFix (-1) $ indentations m1 of
Right (hn, sig) ->
case msg3P m3bs m3cs m3fs m3rs of
Right (bs, cs, fs_, rs_) ->
Right $
Hole
{ location = Location lfp ll lc
, signature = Signature hn (sub sig)
, description = map sub $ msgFix 0 $ indentations m2
, bindings = bs
, constraints = cs
, fits =
take mf
$ zipWith
( \(n,s) d ->
let
-- NOTE: If name is in bindings,
-- there is a high probability
-- that it will fit the
-- hole. Otherwise, it might be
-- low and hereby look in
-- refinements, with the provided
-- order.
p =
if
n `elem` lh ||
n `elem` ns ||
is
then
1.0 - 1.0 / 11.0 ** (10.0 - d)
else
1.0 / 10.0 ** ( 1.0 + d)
in
( n, s
, p
)
)
(hf ++ bf ++ ff) [0..]
, refinements = hr ++ rf
}
where
-- NOTE: If the typed-hole name, less the
-- underscore, matches, then we put it
-- in-front of the list. Otherwise, we order
-- accordingly to the bindings (local and
-- closest first).
!hf = filter ( \ (n,_) -> n `elem` lh) fs_
!lf = map fst fs_
-- NOTE: If only one fit (singleton), then
-- it's very likely to be the one
!is =
case lf of
[_] -> True
___ -> False
!bf =
( filter ( \ (n,_) -> n `elem` lf)
. filter ( \ (n,_) -> n `notElem` lh)
) bs
!lb = map fst bf
!ff =
( filter ( \ (n,_) -> n `notElem` lh)
. filter ( \ (n,_) -> n `notElem` lb)
) fs_
--
!ns = map fst bs
--
!rr = take mr rs_
(!hr,!rf) =
partition ( \ (n,_,_) -> n `elem` lh) rr
--
mr = fromMaybe 10 upper
mf = mr `div` 2
Left errs ->
Left errs
where
m3is = indentations m3
m3bs =
includes bsInclude
$ msgFix 2 $ relOrValidInclude bsInclude m3is
m3cs =
includes csInclude
$ msgFix 2 $ relOrValidInclude csInclude m3is
m3fs =
includes fsInclude
$ msgFix 2 $ relOrValidInclude fsInclude m3is
m3rs =
includes rsInclude
$ msgFix 2 $ relOrValidInclude rsInclude m3is
--
lh =
-- NOTE: Drop the prefixing underscore
case hn of
[ ] -> [ ]
_:cs -> [cs]
Left err ->
Left [ err ]
__________ ->
Left
[ Unexpected [ "Three expected messages aren't present: " ] ]
)
. filter ghcErrorHole
) ghces
(ls, rs) = partitionEithers ehs
--------------------------------------------------------------------------------
msg1P :: String -> Either ParseError (String, String)
msg1P l1 =
case readP_to_S (auxP <* eof) l1 of
[(a, [])] -> Right a
[(_, cs)] -> Left $ Remaining cs
[ ] -> Left $ Unparsed [ l1 ]
_________ -> Left $ Unexpected [ l1 ]
where
auxP =
( \ _ _ n h -> (n, h)
)
<$> string "Found hole:"
<*> skipSpaces
<*> manyTill anyChar (string " :: ")
<*> many anyChar
msg3P
:: [String]
-> [String]
-> [String]
-> [String]
-> Either [ParseError]
( [(String, String)]
, [(String, String)]
, [(String, String)]
, [(String, String, String)]
)
msg3P bs cs fs rs =
let
(lbs, rbs) =
partitionEithers
$ map
( \ b ->
case readP_to_S bP b of
[(a, [ ])] -> Right a
[(_, cs_)] -> Left $ Remaining cs_
[ ] -> Left $ Unparsed bs
__________ -> Left $ Unexpected bs
) bs
(lcs, rcs) =
partitionEithers
$ map
( \ b ->
case readP_to_S cP b of
[(a, [ ])] -> Right a
[(_, cs_)] -> Left $ Remaining cs_
[ ] -> Left $ Unparsed cs
__________ -> Left $ Unexpected cs
) cs
(lfs, rfs) =
partitionEithers
$ map
( \ f ->
case readP_to_S fP f of
[(a, [ ])] -> Right a
[(_, cs_)] -> Left $ Remaining cs_
[ ] -> Left $ Unparsed fs
__________ -> Left $ Unexpected fs
) fs
(lrs, rrs) =
partitionEithers
$ map
( \ r ->
case readP_to_S rP r of
[(a, [ ])] -> Right a
[(_, cs_)] -> Left $ Remaining cs_
[ ] -> Left $ Unparsed rs
__________ -> Left $ Unexpected rs
) rs
in
case (lbs, lcs, lfs, lrs) of
([], [], [], []) ->
Right
( rbs
, rcs
, rfs
, rrs
)
____________ ->
Left $ lbs ++ lcs ++ lfs ++ lrs
where
bP =
( \ n s _ _ ->
( n
, s
)
)
<$> manyTill anyChar (string " :: ")
<*> manyTill anyChar (string " (bound at ")
<*> manyTill anyChar (char ')')
<*> eof
cP =
( \ n p _ ->
( n
, p
)
)
<$> manyTill anyChar (char ' ')
<*> manyTill anyChar (char ' ')
<*> manyTill anyChar eof
fP =
(,)
<$> manyTill anyChar (string " :: ")
<*> manyTill anyChar eof
rP =
( \ n h s ->
( n
, " (_ :: " ++ h
, s
)
)
<$> manyTill anyChar (string " (_ :: ")
<*> manyTill anyChar (string " where ")
<*> manyTill anyChar eof
anyChar :: ReadP Char
anyChar =
satisfy (const True)
newline :: ReadP Char
newline =
char '\n'
crlf :: ReadP Char
crlf =
char '\r' *> char '\n'
endOfLine :: ReadP Char
endOfLine =
choice [ newline, crlf ]
bsInclude :: String
bsInclude = "Relevant bindings include"
csInclude :: String
csInclude = "Constraints include"
fsInclude :: String
fsInclude = "Valid hole fits include"
rsInclude :: String
rsInclude = "Valid refinement hole fits include"
combine
:: String
-> [String]
-> [[String]]
combine pat =
map (map (drop 2)) . filter (not . null) . aux []
where
aux acc ls =
case ls of
[ ] -> [acc]
(x:xs) ->
if pat `isPrefixOf` x then
acc : aux [x] xs
else
aux (acc ++ [x]) xs
indentations :: [String] -> [(Int, String)]
indentations =
map (first length . break (/= ' '))
msgFix :: Int -> [(Int, String)] -> [String]
msgFix ident ls =
case ls of
[ ] -> [ ]
[(_,x) ] -> [x]
((_,x):(i,y):rs) ->
if ident < i then
msgFix ident ((i, UTL.trim x ++ " " ++ UTL.trim y) : rs)
else
x : msgFix ident ((i, y) : rs)
relOrValidInclude
:: String
-> [(Int, String)]
-> [(Int, String)]
relOrValidInclude pat xs =
case ys of
[ ] -> [ ]
[y ] -> [y]
(y:rs) -> y : takeWhile (\(i, _) -> 0 < i) rs
where
ys =
dropWhile
( \(_,l) -> not (pat `isPrefixOf` l)
) xs
includes
:: String
-> [String]
-> [String]
includes pat xs =
case xs of
[ ] -> []
[x ] -> [UTL.trim $ drop (length pat) x]
(_:rs) -> rs
--------------------------------------------------------------------------------
substitute
:: String
-> String
-> String
-> String
substitute pat sub txt =
aux 0 ids txt
where
len = length pat
ids = findIndices pat txt
aux _ ______ [] = []
aux _ [ ] cs = cs
aux o (i:is) cs =
take j cs ++ sub ++ aux n is r
where
j = i - o
k = j + len
n = k + o
r = drop k cs
findIndices
:: Eq a
=> [a]
-> [a]
-> [Int]
findIndices [ ] = const []
findIndices pat =
aux 0 0 pat
where
aux o i [] xs = i : aux o o pat xs
aux _ _ __ [] = [ ]
aux o i (p:ps) (x:xs) =
if p == x then
aux (o+1) i ps xs
else
aux (o+1) (o+1) pat xs
--------------------------------------------------------------------------------
txt2b
:: String
-> Either ParseError Branch
txt2b txt =
case readP_to_S (auxP <* eof) txt of
[(a, [])] -> Right a
[(_, cs)] -> Left $ Remaining cs
[ ] -> Left $ Unparsed [ txt ]
_________ -> Left $ Unexpected [ txt ]
where
-- NOTE: Sample
-- branch.20260811-075012-747631762.description [HONE] text_goes_here
auxP =
( \ _ _ uid _ _ _ mof _ des ->
let
emof =
case mof of
[ ] -> Left ( )
(c:cs) ->
case readMaybe (toUpper c : map toLower cs) :: Maybe Mode of
Nothing -> Left ( )
Just m -> Right m
in
Branch (UUID uid) emof des
)
<$> string "branch"
<*> char '.'
<*> manyTill anyChar (char '.')
<*> string "description"
<*> skipSpaces
<*> char '['
<*> manyTill anyChar (char ']')
<*> skipSpaces
<*> manyTill anyChar eof
--------------------------------------------------------------------------------
th2xml
:: String
-> Hole
-> String
th2xml cwd
( Hole (Location p l o) (Signature hn s) d bs cs fs rs ) =
"<typedhole>" ++
"<source>" ++
(frp ++ ":" ++ show l ++ ":" ++ show o) ++
"</source>" ++
"<hole><![CDATA[" ++
hn ++ " :: " ++ s ++
"]]></hole>" ++
"<description><![CDATA[" ++
(init . unlines) d ++
"]]></description>" ++
"<bindings>" ++
(concatMap b . zip [0 :: Int ..]) bs ++
"</bindings>" ++
"<constraints>" ++
(concatMap c . zip [0 :: Int ..]) cs ++
"</constraints>" ++
"<fits>" ++
(concatMap f . zip [0 :: Int ..]) fs ++
"</fits>" ++
"<refinements>" ++
(concatMap r . zip [0 :: Int ..]) rs ++
"</refinements>" ++
"</typedhole>"
where
dec n = showFFloat (Just 10) n ""
frp = drop (length cwd) p
b (i, (n, s_)) =
"<binding index='" ++ show i ++ "'><![CDATA[" ++
n ++ " :: " ++ s_ ++
"]]></binding>"
c (i, (n, p_)) =
"<constraint index='" ++ show i ++ "'><![CDATA[" ++
n ++ " " ++ p_ ++
"]]></constraint>"
f (i, (c_, s_, l_)) =
"<fit index='" ++ show i ++ "' likelihood='" ++ dec l_ ++ "'>" ++
"<code><![CDATA[" ++
c_ ++
"]]></code>" ++
"<where><![CDATA[" ++
c_ ++ " :: " ++ s_ ++
"]]></where>" ++
"</fit>"
where
-- lc = map toLower $ show l_
_ = dec l_
r (i, (n, c_, s_)) =
"<refinement index='" ++ show i ++ "'>" ++
"<code><![CDATA[" ++
n ++ c_ ++
"]]></code>" ++
"<where><![CDATA[" ++
s_ ++
"]]></where>" ++
"</refinement>"
ths2xml
:: String
-> [Hole]
-> String
ths2xml cwd ths =
if null ths then
[]
else
"<typedholes>" ++
concatMap (th2xml cwd) ths ++
"</typedholes>"
--------------------------------------------------------------------------------
gd2fps :: String -> Either ParseError [FilePath]
gd2fps txt =
case readP_to_S (many auxP <* eof) txt of
[(a, [])] -> Right a
[(_, cs)] -> Left $ Remaining cs
[ ] -> Left $ Unparsed [ txt ]
_________ -> Left $ Unexpected [ txt ]
where
auxP =
( \ _ _ fp -> fp
)
<$> choice
[ char 'A'
, char 'M'
]
<*> skipSpaces
<*> manyTill anyChar endOfLine
--------------------------------------------------------------------------------
isSuccess
:: TestCase
-> Bool
isSuccess TestCase { result = TestResult { status = Success } } = True
isSuccess _____________________________________________________ = False
isMeldable
:: TestCase
-> Bool
isMeldable
TestCase { result = TestResult { status = Success } } =
True
isMeldable
TestCase { result = TestResult { status = Failure, theException = e } } =
-- NOTE: Now, this SHOULD go really fast as we JUST need to check if ALL
-- errors are typed-holes: Just 88464 (no parsing what-so-ever) and ensure
-- first line in description shows is not a 'var not in scope'
case txt2ghces els of
Right es -> all ghcErrorHole es
Left __ -> False
where
suf = "|\n|\n|\n"
els = lines (e ++ suf)
isMeldable
_______________________________________________________________________ =
False
--------------------------------------------------------------------------------
decodeJsonlTestCases
:: [String]
-> Either [DecodeError] [TestCase]
decodeJsonlTestCases jsonl =
case partitionEithers aux of
([], rs) -> Right rs
(ls, __) -> Left ls
where
aux =
map
( \ json ->
case runGetJSON readJSValue json of
Left e -> Left $ InvalidJSON e
Right v ->
case fromJSON v of
Error err -> Left $ DiffSchema err
Ok fls -> Right fls
)
jsonl
jsonl2tcs
:: FilePath
-> [String]
-> Either [DecodeError] TestCases
jsonl2tcs cwd js =
case decodeJsonlTestCases js of
Right tcs -> (Right . TestCases) tcf
where
-- NOTE: Remove reason from output
tcf =
map
( \ tc@(TestCase _ res) ->
let
o = output res
r = reason res
e = theException res
in
tc
{ result =
res
{ output = UTL.trim (substitute r [] o)
, theException = UTL.trim (substitute cwd [] e)
}
}
)
tcs
Left des -> Left des