-- | @futhark fmt@
module Futhark.CLI.Fmt (main) where

import Control.Monad (forM_, unless)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Futhark.Fmt.Printer
import Futhark.Util.Options
import Futhark.Util.Pretty (docText, hPutDoc, putDoc)
import Language.Futhark
import Language.Futhark.Parser (SyntaxError (..))
import System.Exit
import System.IO

newtype FmtCfg = FmtCfg
  { FmtCfg -> Bool
cfgCheck :: Bool
  }

initialFmtCfg :: FmtCfg
initialFmtCfg :: FmtCfg
initialFmtCfg = FmtCfg {cfgCheck :: Bool
cfgCheck = Bool
False}

fmtOptions :: [FunOptDescr FmtCfg]
fmtOptions :: [FunOptDescr FmtCfg]
fmtOptions =
  [ [Char]
-> [[Char]]
-> ArgDescr (Either (IO ()) (FmtCfg -> FmtCfg))
-> [Char]
-> FunOptDescr FmtCfg
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option
      [Char]
""
      [[Char]
"check"]
      (Either (IO ()) (FmtCfg -> FmtCfg)
-> ArgDescr (Either (IO ()) (FmtCfg -> FmtCfg))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (FmtCfg -> FmtCfg)
 -> ArgDescr (Either (IO ()) (FmtCfg -> FmtCfg)))
-> Either (IO ()) (FmtCfg -> FmtCfg)
-> ArgDescr (Either (IO ()) (FmtCfg -> FmtCfg))
forall a b. (a -> b) -> a -> b
$ (FmtCfg -> FmtCfg) -> Either (IO ()) (FmtCfg -> FmtCfg)
forall a b. b -> Either a b
Right ((FmtCfg -> FmtCfg) -> Either (IO ()) (FmtCfg -> FmtCfg))
-> (FmtCfg -> FmtCfg) -> Either (IO ()) (FmtCfg -> FmtCfg)
forall a b. (a -> b) -> a -> b
$ \FmtCfg
cfg -> FmtCfg
cfg {cfgCheck = True})
      [Char]
"Check whether file is correctly formatted."
  ]

-- | Run @futhark fmt@.
main :: String -> [String] -> IO ()
main :: [Char] -> [[Char]] -> IO ()
main = FmtCfg
-> [FunOptDescr FmtCfg]
-> [Char]
-> ([[Char]] -> FmtCfg -> Maybe (IO ()))
-> [Char]
-> [[Char]]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> [Char]
-> ([[Char]] -> cfg -> Maybe (IO ()))
-> [Char]
-> [[Char]]
-> IO ()
mainWithOptions FmtCfg
initialFmtCfg [FunOptDescr FmtCfg]
fmtOptions [Char]
"[FILES]" (([[Char]] -> FmtCfg -> Maybe (IO ()))
 -> [Char] -> [[Char]] -> IO ())
-> ([[Char]] -> FmtCfg -> Maybe (IO ()))
-> [Char]
-> [[Char]]
-> IO ()
forall a b. (a -> b) -> a -> b
$ \[[Char]]
args FmtCfg
cfg ->
  case [[Char]]
args of
    [] -> IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc (Doc AnsiStyle -> IO ()) -> IO (Doc AnsiStyle) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> Text -> IO (Doc AnsiStyle)
onInput [Char]
"<stdin>" (Text -> IO (Doc AnsiStyle)) -> IO Text -> IO (Doc AnsiStyle)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Text
T.getContents
    [[Char]]
files ->
      IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ [[Char]] -> ([Char] -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
files (([Char] -> IO ()) -> IO ()) -> ([Char] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Char]
file -> do
        Text
file_s <- [Char] -> IO Text
T.readFile [Char]
file
        Doc AnsiStyle
doc <- [Char] -> Text -> IO (Doc AnsiStyle)
onInput [Char]
file Text
file_s
        if FmtCfg -> Bool
cfgCheck FmtCfg
cfg
          then Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Doc AnsiStyle -> Text
forall a. Doc a -> Text
docText Doc AnsiStyle
doc Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
file_s) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
file Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": not formatted correctly."
            Handle -> Text -> IO ()
T.hPutStr Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> Text
forall a. Doc a -> Text
docText Doc AnsiStyle
doc
            IO ()
forall a. IO a
exitFailure
          else [Char] -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile [Char]
file IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> Doc AnsiStyle -> IO ()
hPutDoc Handle
h Doc AnsiStyle
doc
  where
    onInput :: [Char] -> Text -> IO (Doc AnsiStyle)
onInput [Char]
fname Text
s = do
      case [Char] -> Text -> Either SyntaxError (Doc AnsiStyle)
fmtToDoc [Char]
fname Text
s of
        Left (SyntaxError Loc
loc Text
err) -> do
          Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Loc -> Text
forall a. Located a => a -> Text
locText Loc
loc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Pretty a => a -> Text
prettyText Text
err
          IO (Doc AnsiStyle)
forall a. IO a
exitFailure
        Right Doc AnsiStyle
fmt -> Doc AnsiStyle -> IO (Doc AnsiStyle)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc AnsiStyle
fmt