juvix/app/CommonOptions.hs

-- | Contains common options reused in several commands.
module CommonOptions
  ( module CommonOptions,
    module Juvix.Prelude,
    module Options.Applicative,
  )
where

import Control.Exception qualified as GHC
import Data.List.NonEmpty qualified as NonEmpty
import Juvix.Compiler.Core.Data.TransformationId.Parser qualified as Core
import Juvix.Compiler.Pipeline.EntryPoint
import Juvix.Compiler.Reg.Data.TransformationId.Parser qualified as Reg
import Juvix.Compiler.Tree.Data.TransformationId.Parser qualified as Tree
import Juvix.Data.Field
import Juvix.Prelude
import Juvix.Prelude as Juvix
import Options.Applicative
import System.Process
import Text.Read (readMaybe)
import Prelude (show)

-- | Paths that are input are used to detect the root of the project.
data AppPath f = AppPath
  { _pathPath :: Prepath f,
    _pathIsInput :: Bool
  }
  deriving stock (Data, Eq)

makeLenses ''AppPath

instance Show (AppPath f) where
  show = Prelude.show . (^. pathPath)

parseInputFiles :: NonEmpty FileExt -> Parser (AppPath File)
parseInputFiles exts' = do
  let exts = NonEmpty.toList exts'
      mvars = intercalate "|" (map toMetavar exts)
      dotExts = intercalate ", " (map Prelude.show exts)
      helpMsg = "Path to a " <> dotExts <> " file"
      completers = foldMap (completer . extCompleter) exts
  _pathPath <-
    argument
      somePreFileOpt
      ( metavar mvars
          <> help helpMsg
          <> completers
          <> action "file"
      )
  pure AppPath {_pathIsInput = True, ..}

parseInputFile :: FileExt -> Parser (AppPath File)
parseInputFile = parseInputFiles . NonEmpty.singleton

parseProgramInputFile :: Parser (AppPath File)
parseProgramInputFile = do
  _pathPath <-
    option
      somePreFileOpt
      ( long "program_input"
          <> metavar "JSON_FILE"
          <> help "Path to program input json file"
          <> completer (extCompleter FileExtJson)
          <> action "file"
      )
  pure AppPath {_pathIsInput = True, ..}

parseGenericInputFile :: Parser (AppPath File)
parseGenericInputFile = do
  _pathPath <-
    argument
      somePreFileOpt
      ( metavar "INPUT_FILE"
          <> help "Path to input file"
          <> action "file"
      )
  pure AppPath {_pathIsInput = True, ..}

parseGenericOutputFile :: Parser (AppPath File)
parseGenericOutputFile = do
  _pathPath <-
    option
      somePreFileOpt
      ( long "output"
          <> short 'o'
          <> metavar "OUTPUT_FILE"
          <> help "Path to output file"
          <> action "file"
      )
  pure AppPath {_pathIsInput = False, ..}

parseGenericOutputDir :: Mod OptionFields (Prepath Dir) -> Parser (AppPath Dir)
parseGenericOutputDir m = do
  _pathPath <-
    option
      somePreDirOpt
      ( long "output-dir"
          <> metavar "OUTPUT_DIR"
          <> help "Path to output directory"
          <> action "directory"
          <> m
      )
  pure AppPath {_pathIsInput = False, ..}

somePreDirOpt :: ReadM (Prepath Dir)
somePreDirOpt = mkPrepath <$> str

somePreFileOpt :: ReadM (Prepath File)
somePreFileOpt = mkPrepath <$> str

someFileOpt :: ReadM (SomeBase File)
someFileOpt = eitherReader aux
  where
    aux :: String -> Either String (SomeBase File)
    aux s = maybe (Left $ s <> " is not a file path") Right (parseSomeFile s)

someDirOpt :: ReadM (SomeBase Dir)
someDirOpt = eitherReader aux
  where
    aux :: String -> Either String (SomeBase Dir)
    aux s = maybe (Left $ s <> " is not a directory path") Right (parseSomeDir s)

naturalNumberOpt :: ReadM Word
naturalNumberOpt = eitherReader aux
  where
    aux :: String -> Either String Word
    aux s = maybe (Left $ s <> " is not a nonnegative number") Right (readMaybe s :: Maybe Word)

fieldSizeOpt :: ReadM (Maybe Natural)
fieldSizeOpt = eitherReader aux
  where
    aux :: String -> Either String (Maybe Natural)
    aux s = case s of
      "cairo" -> Right $ Just cairoFieldSize
      "small" -> Right $ Just smallFieldSize
      _ ->
        mapRight Just
          . either Left checkAllowed
          $ maybe (Left $ s <> " is not a valid field size") Right (readMaybe s :: Maybe Natural)

    checkAllowed :: Natural -> Either String Natural
    checkAllowed n
      | n `elem` allowedFieldSizes = Right n
      | otherwise = Left $ Prelude.show n <> " is not a recognized field size"

enumReader :: forall a. (Bounded a, Enum a, Show a) => Proxy a -> ReadM a
enumReader _ = eitherReader $ \val ->
  case lookup val assocs of
    Just x -> return x
    Nothing -> Left ("Invalid value " <> val <> ". Valid values are: " <> (Juvix.show (allElements @a)))
  where
    assocs :: [(String, a)]
    assocs = [(Prelude.show x, x) | x <- allElements @a]

enumCompleter :: forall a. (Bounded a, Enum a, Show a) => Proxy a -> Completer
enumCompleter _ = listCompleter [Juvix.show e | e <- allElements @a]

extCompleter :: FileExt -> Completer
extCompleter ext = mkCompleter $ \word -> do
  let cmd = unwords ["compgen", "-o", "plusdirs", "-f", "-X", "!*" <> Prelude.show ext, "--", requote word]
  result <- GHC.try @GHC.SomeException $ readProcess "bash" ["-c", cmd] ""
  return . lines . fromRight [] $ result

requote :: String -> String
requote s =
  let -- Bash doesn't appear to allow "mixed" escaping
      -- in bash completions. So we don't have to really
      -- worry about people swapping between strong and
      -- weak quotes.
      unescaped =
        case s of
          -- It's already strongly quoted, so we
          -- can use it mostly as is, but we must
          -- ensure it's closed off at the end and
          -- there's no single quotes in the
          -- middle which might confuse bash.
          ('\'' : rs) -> unescapeN rs
          -- We're weakly quoted.
          ('"' : rs) -> unescapeD rs
          -- We're not quoted at all.
          -- We need to unescape some characters like
          -- spaces and quotation marks.
          elsewise -> unescapeU elsewise
   in strong unescaped
  where
    strong :: String -> String
    strong ss = '\'' : foldr go "'" ss
      where
        -- If there's a single quote inside the
        -- command: exit from the strong quote and
        -- emit it the quote escaped, then resume.
        go '\'' t = "'\\''" ++ t
        go h t = h : t

    -- Unescape a strongly quoted string
    -- We have two recursive functions, as we
    -- can enter and exit the strong escaping.
    unescapeN = goX
      where
        goX ('\'' : xs) = goN xs
        goX (x : xs) = x : goX xs
        goX [] = []

        goN ('\\' : '\'' : xs) = '\'' : goN xs
        goN ('\'' : xs) = goX xs
        goN (x : xs) = x : goN xs
        goN [] = []

    -- Unescape an unquoted string
    unescapeU = goX
      where
        goX [] = []
        goX ('\\' : x : xs) = x : goX xs
        goX (x : xs) = x : goX xs

    -- Unescape a weakly quoted string
    unescapeD = goX
      where
        -- Reached an escape character
        goX ('\\' : x : xs)
          -- If it's true escapable, strip the
          -- slashes, as we're going to strong
          -- escape instead.
          | x `elem` ("$`\"\\\n" :: String) = x : goX xs
          | otherwise = '\\' : x : goX xs
        -- We've ended quoted section, so we
        -- don't recurse on goX, it's done.
        goX ('"' : xs) =
          xs
        -- Not done, but not a special character
        -- just continue the fold.
        goX (x : xs) =
          x : goX xs
        goX [] =
          []

optDeBruijn :: Parser Bool
optDeBruijn =
  switch
    ( long "show-de-bruijn"
        <> help "Show variable de Bruijn indices"
    )

optIdentIds :: Parser Bool
optIdentIds =
  switch
    ( long "show-ident-ids"
        <> help "Show identifier IDs"
    )

optArgsNum :: Parser Bool
optArgsNum =
  switch
    ( long "show-args-num"
        <> help "Show identifier arguments number"
    )

optNoDisambiguate :: Parser Bool
optNoDisambiguate =
  switch
    ( long "no-disambiguate"
        <> help "Don't disambiguate the names of bound variables"
    )

optTransformationIds :: forall a. (Text -> Either Text [a]) -> (String -> [String]) -> Parser [a]
optTransformationIds parseIds completions =
  option
    (eitherReader parseTransf)
    ( long "transforms"
        <> short 't'
        <> value []
        <> metavar "[Transform]"
        <> completer (mkCompleter (return . completions))
        <> help "hint: use autocomplete"
    )
  where
    parseTransf :: String -> Either String [a]
    parseTransf = mapLeft unpack . parseIds . pack

optCoreTransformationIds :: Parser [Core.TransformationId]
optCoreTransformationIds = optTransformationIds Core.parseTransformations Core.completionsString

optTreeTransformationIds :: Parser [Tree.TransformationId]
optTreeTransformationIds = optTransformationIds Tree.parseTransformations Tree.completionsString

optRegTransformationIds :: Parser [Reg.TransformationId]
optRegTransformationIds = optTransformationIds Reg.parseTransformations Reg.completionsString

class EntryPointOptions a where
  applyOptions :: a -> EntryPoint -> EntryPoint

instance EntryPointOptions () where
  applyOptions () = id