{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Formatting Swarm language code.
module Swarm.Language.Format where

import Control.Applicative ((<|>))
import Control.Lens ((&), (.~))
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Prettyprinter
import Prettyprinter.Render.Text qualified as RT
import Swarm.Language.Parser (readTerm')
import Swarm.Language.Parser.Core (LanguageVersion, defaultParserConfig, languageVersion)
import Swarm.Language.Pretty
import Swarm.Util ((?))
import System.Console.Terminal.Size qualified as Term
import System.Exit (exitFailure)
import System.IO (stderr)
import Text.Megaparsec.Error (errorBundlePretty)
import Witch (into)

-- | From where should the input be taken?
data FormatInput = Stdin | InputFile FilePath

getInput :: FormatInput -> IO Text
getInput :: FormatInput -> IO Text
getInput FormatInput
Stdin = IO Text
T.getContents
getInput (InputFile String
fp) = String -> IO Text
T.readFile String
fp

showInput :: FormatInput -> Text
showInput :: FormatInput -> Text
showInput FormatInput
Stdin = Text
"(input)"
showInput (InputFile String
fp) = String -> Text
T.pack String
fp

-- | Where should the formatted code be output?
data FormatOutput = Stdout | OutputFile FilePath | Inplace

type FormatWidth = Int

data FormatConfig = FormatConfig
  { FormatConfig -> FormatInput
formatInput :: FormatInput
  , FormatConfig -> FormatOutput
formatOutput :: FormatOutput
  , FormatConfig -> Maybe FormatWidth
formatWidth :: Maybe FormatWidth
  , FormatConfig -> LanguageVersion
formatLanguageVersion :: LanguageVersion
  }

-- | Validate and format swarm-lang code.
formatSwarmIO :: FormatConfig -> IO ()
formatSwarmIO :: FormatConfig -> IO ()
formatSwarmIO cfg :: FormatConfig
cfg@(FormatConfig FormatInput
input FormatOutput
output Maybe FormatWidth
mWidth LanguageVersion
_) = do
  Text
content <- FormatInput -> IO Text
getInput FormatInput
input
  Maybe FormatWidth
mWindowWidth <- ((Maybe (Window FormatWidth) -> Maybe FormatWidth)
-> IO (Maybe (Window FormatWidth)) -> IO (Maybe FormatWidth)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe (Window FormatWidth) -> Maybe FormatWidth)
 -> IO (Maybe (Window FormatWidth)) -> IO (Maybe FormatWidth))
-> ((Window FormatWidth -> FormatWidth)
    -> Maybe (Window FormatWidth) -> Maybe FormatWidth)
-> (Window FormatWidth -> FormatWidth)
-> IO (Maybe (Window FormatWidth))
-> IO (Maybe FormatWidth)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Window FormatWidth -> FormatWidth)
-> Maybe (Window FormatWidth) -> Maybe FormatWidth
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Window FormatWidth -> FormatWidth
forall a. Window a -> a
Term.width IO (Maybe (Window FormatWidth))
forall n. Integral n => IO (Maybe (Window n))
Term.size
  let w :: Maybe FormatWidth
w = Maybe FormatWidth
mWidth Maybe FormatWidth -> Maybe FormatWidth -> Maybe FormatWidth
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> case FormatOutput
output of FormatOutput
Stdout -> Maybe FormatWidth
mWindowWidth; FormatOutput
_ -> Maybe FormatWidth
forall a. Maybe a
Nothing
  case FormatConfig -> Text -> Either Text Text
formatSwarm FormatConfig
cfg {formatWidth = w} Text
content of
    Right Text
fmt -> case FormatOutput
output of
      FormatOutput
Stdout -> Text -> IO ()
T.putStrLn Text
fmt
      OutputFile String
outFile -> String -> Text -> IO ()
T.writeFile String
outFile Text
fmt
      FormatOutput
Inplace -> case FormatInput
input of
        FormatInput
Stdin -> Text -> IO ()
T.putStrLn Text
fmt
        InputFile String
inFile -> String -> Text -> IO ()
T.writeFile String
inFile Text
fmt
    Left Text
e -> do
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ FormatInput -> Text
showInput FormatInput
input Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e
      IO ()
forall a. IO a
exitFailure

formatSwarm :: FormatConfig -> Text -> Either Text Text
formatSwarm :: FormatConfig -> Text -> Either Text Text
formatSwarm (FormatConfig FormatInput
_ FormatOutput
_ Maybe FormatWidth
mWidth LanguageVersion
ver) Text
content = case ParserConfig -> Text -> Either ParserError (Maybe Syntax)
readTerm' ParserConfig
cfg Text
content of
  Right Maybe Syntax
Nothing -> Text -> Either Text Text
forall a b. b -> Either a b
Right Text
""
  Right (Just Syntax
ast) ->
    let mkOpt :: FormatWidth -> LayoutOptions
mkOpt FormatWidth
w = PageWidth -> LayoutOptions
LayoutOptions (FormatWidth -> Double -> PageWidth
AvailablePerLine FormatWidth
w Double
1.0)
        opt :: LayoutOptions
opt = (FormatWidth -> LayoutOptions
mkOpt (FormatWidth -> LayoutOptions)
-> Maybe FormatWidth -> Maybe LayoutOptions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FormatWidth
mWidth) Maybe LayoutOptions -> LayoutOptions -> LayoutOptions
forall a. Maybe a -> a -> a
? LayoutOptions
defaultLayoutOptions
     in Text -> Either Text Text
forall a b. b -> Either a b
Right (Text -> Either Text Text)
-> (Doc Any -> Text) -> Doc Any -> Either Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
RT.renderStrict (SimpleDocStream Any -> Text)
-> (Doc Any -> SimpleDocStream Any) -> Doc Any -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
opt (Doc Any -> Either Text Text) -> Doc Any -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Syntax -> Doc Any
forall a ann. PrettyPrec a => a -> Doc ann
ppr Syntax
ast
  Left ParserError
e -> Text -> Either Text Text
forall a b. a -> Either a b
Left (forall target source. From source target => source -> target
into @Text (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ParserError -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParserError
e)
 where
  cfg :: ParserConfig
cfg = ParserConfig
defaultParserConfig ParserConfig -> (ParserConfig -> ParserConfig) -> ParserConfig
forall a b. a -> (a -> b) -> b
& (LanguageVersion -> Identity LanguageVersion)
-> ParserConfig -> Identity ParserConfig
Lens' ParserConfig LanguageVersion
languageVersion ((LanguageVersion -> Identity LanguageVersion)
 -> ParserConfig -> Identity ParserConfig)
-> LanguageVersion -> ParserConfig -> ParserConfig
forall s t a b. ASetter s t a b -> b -> s -> t
.~ LanguageVersion
ver