{-# LANGUAGE TupleSections #-}
module Seminal (
runSeminal,
Status(..),
) where
import Seminal.Compiler.API
import Seminal.Options (Options(Options), SearchMethod(Lazy))
import Seminal.Change (Change (..), ChangeType(..), getNode, show)
import qualified Seminal.Compiler.TypeChecker as TypeChecker(typecheckModule, TypeCheckStatus(..))
import Seminal.Compiler.Runner (runCompiler)
import Seminal.Enumerator.Modules (enumerateChangesInModule)
import Seminal.Compiler.TypeChecker (ErrorType(..), isScopeError, getTypeCheckError)
import Data.Maybe (mapMaybe)
import Prelude hiding (mod)
import Data.Tuple.HT (thd3)
import Seminal.Ranker (sortChanges)
import Data.Bifunctor (second)
import Control.Monad (when)
type ErrorMessage = String
data Status =
Success |
Error ErrorMessage |
Result (
Int,
[(FilePath, ErrorMessage, [Change HsModule])]
)
runSeminal :: Options -> [FilePath] -> IO Status
runSeminal :: Options -> [FilePath] -> IO Status
runSeminal (Options SearchMethod
searchMethod Bool
traceCalls) [FilePath]
filePaths = (FilePath -> Status)
-> (Status -> Status) -> Either FilePath Status -> Status
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> Status
Error Status -> Status
forall a. a -> a
id (Either FilePath Status -> Status)
-> IO (Either FilePath Status) -> IO Status
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Either FilePath Status)
ghcAction
where
ghcAction :: IO (Either FilePath Status)
ghcAction = [FilePath]
-> ([(FilePath, ParsedModule)] -> Ghc Status)
-> IO (Either FilePath Status)
forall a.
[FilePath]
-> ([(FilePath, ParsedModule)] -> Ghc a) -> IO (Either FilePath a)
runCompiler [FilePath]
filePaths (([(FilePath, ParsedModule)] -> Ghc Status)
-> IO (Either FilePath Status))
-> ([(FilePath, ParsedModule)] -> Ghc Status)
-> IO (Either FilePath Status)
forall a b. (a -> b) -> a -> b
$ \[(FilePath, ParsedModule)]
filesAndModules -> do
[(FilePath, ParsedModule, TypeCheckStatus)]
res <- ((FilePath, ParsedModule)
-> Ghc (FilePath, ParsedModule, TypeCheckStatus))
-> [(FilePath, ParsedModule)]
-> Ghc [(FilePath, ParsedModule, TypeCheckStatus)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(FilePath
f, ParsedModule
m) -> (FilePath
f,ParsedModule
m,) (TypeCheckStatus -> (FilePath, ParsedModule, TypeCheckStatus))
-> Ghc TypeCheckStatus
-> Ghc (FilePath, ParsedModule, TypeCheckStatus)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsedModule -> Ghc TypeCheckStatus
typecheckPm ParsedModule
m) [(FilePath, ParsedModule)]
filesAndModules
case ((FilePath, ParsedModule, TypeCheckStatus)
-> Maybe (FilePath, ParsedModule, ErrorType))
-> [(FilePath, ParsedModule, TypeCheckStatus)]
-> [(FilePath, ParsedModule, ErrorType)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(FilePath
f, ParsedModule
mod, TypeCheckStatus
status) -> (FilePath
f,ParsedModule
mod,) (ErrorType -> (FilePath, ParsedModule, ErrorType))
-> Maybe ErrorType -> Maybe (FilePath, ParsedModule, ErrorType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeCheckStatus -> Maybe ErrorType
getTypeCheckError TypeCheckStatus
status) [(FilePath, ParsedModule, TypeCheckStatus)]
res of
[] -> Status -> Ghc Status
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Success
[(FilePath, ParsedModule, ErrorType)]
errs -> case ((FilePath, ParsedModule, ErrorType) -> Bool)
-> [(FilePath, ParsedModule, ErrorType)]
-> [(FilePath, ParsedModule, ErrorType)]
forall a. (a -> Bool) -> [a] -> [a]
filter (ErrorType -> Bool
isScopeError (ErrorType -> Bool)
-> ((FilePath, ParsedModule, ErrorType) -> ErrorType)
-> (FilePath, ParsedModule, ErrorType)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, ParsedModule, ErrorType) -> ErrorType
forall a b c. (a, b, c) -> c
thd3) [(FilePath, ParsedModule, ErrorType)]
errs of
[] -> do
[(Int, (FilePath, [Change HsModule], ErrorType))]
foundChanges <- ((FilePath, ParsedModule, ErrorType)
-> Ghc (Int, (FilePath, [Change HsModule], ErrorType)))
-> [(FilePath, ParsedModule, ErrorType)]
-> Ghc [(Int, (FilePath, [Change HsModule], ErrorType))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(FilePath
f, ParsedModule
m, ErrorType
err) -> (\(Int
n, [Change HsModule]
c) -> (Int
n, (FilePath
f, [Change HsModule] -> [Change HsModule]
forall a. [Change a] -> [Change a]
sortChanges [Change HsModule]
c, ErrorType
err))) ((Int, [Change HsModule])
-> (Int, (FilePath, [Change HsModule], ErrorType)))
-> Ghc (Int, [Change HsModule])
-> Ghc (Int, (FilePath, [Change HsModule], ErrorType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsedModule -> Ghc (Int, [Change HsModule])
changes ParsedModule
m) [(FilePath, ParsedModule, ErrorType)]
errs
let totalCall :: Int
totalCall = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Int, (FilePath, [Change HsModule], ErrorType)) -> Int
forall a b. (a, b) -> a
fst ((Int, (FilePath, [Change HsModule], ErrorType)) -> Int)
-> [(Int, (FilePath, [Change HsModule], ErrorType))] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, (FilePath, [Change HsModule], ErrorType))]
foundChanges
formattedChanges :: [(FilePath, FilePath, [Change HsModule])]
formattedChanges = (\(FilePath
f, [Change HsModule]
m, ErrorType
err) -> (FilePath
f, ErrorType -> FilePath
forall a. Show a => a -> FilePath
Prelude.show ErrorType
err, [Change HsModule]
m)) ((FilePath, [Change HsModule], ErrorType)
-> (FilePath, FilePath, [Change HsModule]))
-> ((Int, (FilePath, [Change HsModule], ErrorType))
-> (FilePath, [Change HsModule], ErrorType))
-> (Int, (FilePath, [Change HsModule], ErrorType))
-> (FilePath, FilePath, [Change HsModule])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, (FilePath, [Change HsModule], ErrorType))
-> (FilePath, [Change HsModule], ErrorType)
forall a b. (a, b) -> b
snd ((Int, (FilePath, [Change HsModule], ErrorType))
-> (FilePath, FilePath, [Change HsModule]))
-> [(Int, (FilePath, [Change HsModule], ErrorType))]
-> [(FilePath, FilePath, [Change HsModule])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, (FilePath, [Change HsModule], ErrorType))]
foundChanges
Status -> Ghc Status
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Status -> Ghc Status) -> Status -> Ghc Status
forall a b. (a -> b) -> a -> b
$ (Int, [(FilePath, FilePath, [Change HsModule])]) -> Status
Result (Int
totalCall, [(FilePath, FilePath, [Change HsModule])]
formattedChanges)
[(FilePath, ParsedModule, ErrorType)]
scopeErrors -> Status -> Ghc Status
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Status -> Ghc Status) -> Status -> Ghc Status
forall a b. (a -> b) -> a -> b
$ FilePath -> Status
Error (FilePath -> Status) -> FilePath -> Status
forall a b. (a -> b) -> a -> b
$ ((FilePath, ParsedModule, ErrorType) -> FilePath)
-> [(FilePath, ParsedModule, ErrorType)] -> FilePath
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(FilePath
f, ParsedModule
_, ErrorType
err) -> FilePath
f FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" - " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ErrorType -> FilePath
forall a. Show a => a -> FilePath
Prelude.show ErrorType
err) [(FilePath, ParsedModule, ErrorType)]
scopeErrors
changes :: ParsedModule -> Ghc (Int, [Change HsModule])
changes ParsedModule
pm = SearchMethod
-> (Change HsModule -> Ghc (Change HsModule, Int, TypeCheckStatus))
-> HsModule
-> Ghc (Int, [Change HsModule])
findChanges SearchMethod
searchMethod (ParsedModule
-> Bool
-> Change HsModule
-> Ghc (Change HsModule, Int, TypeCheckStatus)
evaluateChange ParsedModule
pm Bool
traceCalls) (ParsedModule -> HsModule
hsModule ParsedModule
pm)
hsModule :: ParsedModule -> HsModule
hsModule = GenLocated SrcSpan HsModule -> HsModule
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan HsModule -> HsModule)
-> (ParsedModule -> GenLocated SrcSpan HsModule)
-> ParsedModule
-> HsModule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> GenLocated SrcSpan HsModule
pm_parsed_source
typecheckPm :: ParsedModule -> Ghc TypeCheckStatus
typecheckPm = ParsedModule -> Ghc TypeCheckStatus
TypeChecker.typecheckModule
findChanges :: SearchMethod -> (Change HsModule -> Ghc (Change HsModule, Int, TypeChecker.TypeCheckStatus)) -> HsModule -> Ghc (Int, [Change HsModule])
findChanges :: SearchMethod
-> (Change HsModule -> Ghc (Change HsModule, Int, TypeCheckStatus))
-> HsModule
-> Ghc (Int, [Change HsModule])
findChanges SearchMethod
method Change HsModule -> Ghc (Change HsModule, Int, TypeCheckStatus)
test HsModule
m = Int -> [Change HsModule] -> Ghc (Int, [Change HsModule])
findValidChanges Int
0 (HsModule -> [Change HsModule]
enumerateChangesInModule HsModule
m)
where
evaluateAll :: [Change HsModule] -> Ghc [(Change HsModule, Int, TypeCheckStatus)]
evaluateAll = (Change HsModule -> Ghc (Change HsModule, Int, TypeCheckStatus))
-> [Change HsModule]
-> Ghc [(Change HsModule, Int, TypeCheckStatus)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Change HsModule -> Ghc (Change HsModule, Int, TypeCheckStatus)
test
findValidChanges :: Int -> [Change HsModule] -> Ghc (Int, [Change HsModule])
findValidChanges Int
n [] = (Int, [Change HsModule]) -> Ghc (Int, [Change HsModule])
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
n, [])
findValidChanges Int
n [Change HsModule]
clist = do
[(Change HsModule, Int, TypeCheckStatus)]
changesWithTcCalls <- [Change HsModule] -> Ghc [(Change HsModule, Int, TypeCheckStatus)]
evaluateAll [Change HsModule]
clist
let execsCounts :: Int
execsCounts = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((\(Change HsModule
_, Int
c, TypeCheckStatus
_) -> Int
c) ((Change HsModule, Int, TypeCheckStatus) -> Int)
-> [(Change HsModule, Int, TypeCheckStatus)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Change HsModule, Int, TypeCheckStatus)]
changesWithTcCalls)
tcCalls :: Int
tcCalls = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
execsCounts
changes :: [(Change HsModule, TypeCheckStatus)]
changes = (\(Change HsModule
a, Int
_ , TypeCheckStatus
b) -> (Change HsModule
a, TypeCheckStatus
b)) ((Change HsModule, Int, TypeCheckStatus)
-> (Change HsModule, TypeCheckStatus))
-> [(Change HsModule, Int, TypeCheckStatus)]
-> [(Change HsModule, TypeCheckStatus)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Change HsModule, Int, TypeCheckStatus)]
changesWithTcCalls
successfulchanges :: [Change HsModule]
successfulchanges = (Change HsModule, TypeCheckStatus) -> Change HsModule
forall a b. (a, b) -> a
fst ((Change HsModule, TypeCheckStatus) -> Change HsModule)
-> [(Change HsModule, TypeCheckStatus)] -> [Change HsModule]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Change HsModule, TypeCheckStatus) -> Bool)
-> [(Change HsModule, TypeCheckStatus)]
-> [(Change HsModule, TypeCheckStatus)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((TypeCheckStatus
TypeChecker.Success TypeCheckStatus -> TypeCheckStatus -> Bool
forall a. Eq a => a -> a -> Bool
==) (TypeCheckStatus -> Bool)
-> ((Change HsModule, TypeCheckStatus) -> TypeCheckStatus)
-> (Change HsModule, TypeCheckStatus)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Change HsModule, TypeCheckStatus) -> TypeCheckStatus
forall a b. (a, b) -> b
snd) [(Change HsModule, TypeCheckStatus)]
changes
if (SearchMethod
method SearchMethod -> SearchMethod -> Bool
forall a. Eq a => a -> a -> Bool
== SearchMethod
Lazy) Bool -> Bool -> Bool
&& (Change HsModule -> Bool) -> [Change HsModule] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((ChangeType
Terminal ChangeType -> ChangeType -> Bool
forall a. Eq a => a -> a -> Bool
==) (ChangeType -> Bool)
-> (Change HsModule -> ChangeType) -> Change HsModule -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Change HsModule -> ChangeType
forall node. Change node -> ChangeType
category) [Change HsModule]
successfulchanges
then (Int, [Change HsModule]) -> Ghc (Int, [Change HsModule])
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
tcCalls, [Change HsModule]
successfulchanges)
else ([Change HsModule] -> [Change HsModule])
-> (Int, [Change HsModule]) -> (Int, [Change HsModule])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ([Change HsModule]
successfulchanges [Change HsModule] -> [Change HsModule] -> [Change HsModule]
forall a. [a] -> [a] -> [a]
++) ((Int, [Change HsModule]) -> (Int, [Change HsModule]))
-> Ghc (Int, [Change HsModule]) -> Ghc (Int, [Change HsModule])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [Change HsModule] -> Ghc (Int, [Change HsModule])
findValidChanges Int
tcCalls ((Change HsModule -> [Change HsModule])
-> [Change HsModule] -> [Change HsModule]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Change HsModule -> [Change HsModule]
forall node. Change node -> [Change node]
followups [Change HsModule]
successfulchanges)
evaluateChange :: ParsedModule -> Bool -> Change HsModule -> Ghc (Change HsModule, Int, TypeChecker.TypeCheckStatus)
evaluateChange :: ParsedModule
-> Bool
-> Change HsModule
-> Ghc (Change HsModule, Int, TypeCheckStatus)
evaluateChange ParsedModule
pm Bool
traceCall Change HsModule
change = case Change HsModule -> [ChangeNode HsModule]
forall node. Change node -> [ChangeNode node]
exec Change HsModule
change of
[] -> (Change HsModule, Int, TypeCheckStatus)
-> Ghc (Change HsModule, Int, TypeCheckStatus)
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Change HsModule
change, Int
0, ErrorType -> TypeCheckStatus
TypeChecker.Error (ErrorType -> TypeCheckStatus) -> ErrorType -> TypeCheckStatus
forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorType
TypeCheckError FilePath
"{From Change Group}" )
(ChangeNode HsModule
a:[ChangeNode HsModule]
b) -> do
TypeCheckStatus
statusA <- if Bool
traceCall then ChangeNode HsModule -> Ghc TypeCheckStatus
traceTcCall ChangeNode HsModule
a else ChangeNode HsModule -> Ghc TypeCheckStatus
callTypecheckerOnExec ChangeNode HsModule
a
case TypeCheckStatus
statusA of
TypeCheckStatus
TypeChecker.Success -> (Change HsModule, Int, TypeCheckStatus)
-> Ghc (Change HsModule, Int, TypeCheckStatus)
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Change HsModule
change { exec :: [ChangeNode HsModule]
exec = [ChangeNode HsModule
a] }, Int
1, TypeCheckStatus
statusA)
TypeCheckStatus
_ -> (\(Change HsModule
m, Int
count, TypeCheckStatus
s) -> (Change HsModule
m, Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, TypeCheckStatus
s)) ((Change HsModule, Int, TypeCheckStatus)
-> (Change HsModule, Int, TypeCheckStatus))
-> Ghc (Change HsModule, Int, TypeCheckStatus)
-> Ghc (Change HsModule, Int, TypeCheckStatus)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsedModule
-> Bool
-> Change HsModule
-> Ghc (Change HsModule, Int, TypeCheckStatus)
evaluateChange ParsedModule
pm Bool
traceCall (Change HsModule
change { exec :: [ChangeNode HsModule]
exec = [ChangeNode HsModule]
b })
where
traceTcCall :: ChangeNode HsModule -> Ghc TypeCheckStatus
traceTcCall ChangeNode HsModule
e = do
()
_ <- IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
traceCall (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
FilePath -> IO ()
putStrLn (ChangeNode HsModule -> ChangeNode HsModule -> SrcSpan -> FilePath
forall node.
ChangeNode node -> ChangeNode node -> SrcSpan -> FilePath
Seminal.Change.show (Change HsModule -> ChangeNode HsModule
forall node. Change node -> ChangeNode node
src Change HsModule
change) ChangeNode HsModule
e (Change HsModule -> SrcSpan
forall node. Change node -> SrcSpan
location Change HsModule
change))
FilePath -> IO ()
putStr FilePath
"Status: "
TypeCheckStatus
status <- ChangeNode HsModule -> Ghc TypeCheckStatus
callTypecheckerOnExec ChangeNode HsModule
e
()
_ <- IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ case TypeCheckStatus
status of
TypeCheckStatus
TypeChecker.Success -> FilePath
"Success\n"
TypeCheckStatus
_ -> FilePath
"Fail\n"
TypeCheckStatus -> Ghc TypeCheckStatus
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return TypeCheckStatus
status
callTypecheckerOnExec :: ChangeNode HsModule -> Ghc TypeCheckStatus
callTypecheckerOnExec ChangeNode HsModule
s = ParsedModule -> Ghc TypeCheckStatus
TypeChecker.typecheckModule (ParsedModule -> HsModule -> ParsedModule
wrapHsModule ParsedModule
pm (ChangeNode HsModule -> HsModule
forall n. ChangeNode n -> n
getNode ChangeNode HsModule
s))
wrapHsModule :: ParsedModule -> HsModule -> ParsedModule
wrapHsModule :: ParsedModule -> HsModule -> ParsedModule
wrapHsModule ParsedModule
pm HsModule
m = let
(ParsedModule ModSummary
_ GenLocated SrcSpan HsModule
modsrc [FilePath]
_) = ParsedModule
pm
srcLoc :: SrcSpan
srcLoc = GenLocated SrcSpan HsModule -> SrcSpan
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpan HsModule
modsrc
in ParsedModule
pm { pm_parsed_source :: GenLocated SrcSpan HsModule
pm_parsed_source = SrcSpan -> HsModule -> GenLocated SrcSpan HsModule
forall l e. l -> e -> GenLocated l e
L SrcSpan
srcLoc HsModule
m }