Newer
Older
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
import Colog
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Data.Foldable
import Data.Functor
import Data.Map.Strict qualified as Map
import Data.Text qualified as Text
import GHC.Stack
import Options.Applicative
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import System.Process.Typed
import Text.Pretty.Simple
import Text.PrettyPrint qualified as P
import Prelude hiding (log)
. fold
$ []
process :: (WithLog env (Msg sev) m, MonadIO m) => sev -> Text.Text -> m a -> m a
process sev p ma = do
msg "Started "
a <- ma
msg "Done "
pure a
s = withFrozenCallStack callStack
msg t = Colog.logMsg (Msg sev s (t <> p))
run :: (HasCallStack) => Parser (IO ())
run = do
file <- strArgument $ fold [metavar "FILE"]
validity <-
flag False True
$ fold
[ long "validity"
, help "check for validity, throw error if command fails"
]
expmode <-
flag False True
$ fold
[ long "exp"
, help "run in exponential mode"
]
pure
$ usingLoggerT (cmap fmtMessage logTextStdout)
$ do
let
test f = process D ("test " <> Text.pack f) do
log D (Text.pack $ show err)
pure (err == ExitSuccess)
output f c = process D ("writing " <> Text.pack f) do
let x = P.render (C.pretty (c $> C.undefNode))
liftIO $ writeFile f x
when validity do
liftIO $ copyFile file (file <.> "last")
output f c
t <- test f
if t
else do
liftIO $ when validity do
copyFile file (file <.> "fail")
copyFile (file <.> "last") file
exitFailure
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
let bak = file <.> "bak"
process D "backing up file" do
liftIO $ copyFile file bak
process I "check predicate" do
t <- test file
unless t do
liftIO exitFailure
c <- process D "parsing file" do
parseCFile file
output file c
process I "sanity checks" do
c' <- parseCFile file
unless (void c' == void c) do
liftIO do
withFile "error.1.hs" WriteMode (`pHPrint` void c)
withFile "error.2.hs" WriteMode (`pHPrint` void c')
logError "Outputted a different file than i read... Please report original file and error.{1,2}.hs"
liftIO exitFailure
t <- test file
unless t do
liftIO exitFailure
(check' file)
(Map.singleton (C.internalIdent "main") True)