Commands.hs

-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}

module GHCMod.Options.Commands where

import Options.Applicative
import Options.Applicative.Types
import Options.Applicative.Builder.Internal
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Read
import Language.Haskell.GhcMod.Options.DocUtils
import Language.Haskell.GhcMod.Options.Help

type Symbol = String
type Expr = String
type Module = String
type Line = Int
type Col = Int
type Point = (Line, Col)

data GhcModCommands =
    CmdLang
  | CmdFlag
  | CmdDebug
  | CmdBoot
  | CmdNukeCaches
  | CmdRoot
  | CmdLegacyInteractive
  | CmdModules Bool
  | CmdDumpSym
  | CmdFind Symbol
  | CmdDoc Module
  | CmdLint LintOpts FilePath
  | CmdBrowse BrowseOpts [Module]
  | CmdDebugComponent [String]
  | CmdCheck [FilePath]
  | CmdExpand [FilePath]
  | CmdInfo FilePath Symbol
  | CmdType Bool FilePath Point
  | CmdSplit FilePath Point
  | CmdSig FilePath Point
  | CmdAuto FilePath Point
  | CmdRefine FilePath Point Expr
  | CmdTest FilePath
  -- interactive-only commands
  | CmdMapFile FilePath
  | CmdUnmapFile FilePath
  | CmdQuit
  deriving (Show)

commandsSpec :: Parser GhcModCommands
commandsSpec =
  hsubparser commands

commands :: Mod CommandFields GhcModCommands
commands =
       command "lang"
          $$  info (pure CmdLang)
          $$  progDesc "List all known GHC language extensions"
    <> command "flag"
          $$  info (pure CmdFlag)
          $$  progDesc "List GHC -f<foo> flags"
    <> command "debug"
          $$  info (pure CmdDebug)
          $$  progDesc' $$$ do
              "Print debugging information. Please include"
                \\ "the output in any bug reports you submit"
    <> command "debug-component"
          $$  info debugComponentArgSpec
          $$  progDesc' $$$ do
              "Debugging information related to cabal component"
                \\ "resolution"
    <> command "boot"
          $$  info (pure CmdBoot)
          $$  progDesc "Internal command used by the emacs frontend"
    -- <> command "nuke-caches"
    --       $$  info (pure CmdNukeCaches) idm
    <> command "root"
          $$  info (pure CmdRoot)
          $$  progDesc'
              "Try to find the project directory."
          <=> desc $$$ do
              "For Cabal projects this is the"
                \\ "directory containing the cabal file, for projects"
                \\ "that use a cabal sandbox but have no cabal file"
                \\ "this is the directory containing the cabal.sandbox.config"
                \\ "file and otherwise this is the current directory"
    <> command "legacy-interactive"
          $$  info legacyInteractiveArgSpec
          $$  progDesc "ghc-modi compatibility mode"
    <> command "list"
          $$  info modulesArgSpec
          $$  progDesc "List all visible modules"
    <> command "modules"
          $$  info modulesArgSpec
          $$  progDesc "List all visible modules"
    <> command "dumpsym"
          $$  info (pure CmdDumpSym) idm
    <> command "find"
          $$  info findArgSpec
          $$  progDesc "List all modules that define SYMBOL"
    <> command "doc"
          $$  info docArgSpec
          $$  progDesc' $$$ do
              "Try finding the html documentation directory"
                \\ "for the given MODULE"
    <> command "lint"
          $$  info lintArgSpec
          $$  progDesc "Check files using `hlint'"
    <> command "browse"
          $$  info browseArgSpec
          $$  progDesc "List symbols in a module"
    <> command "check"
          $$  info checkArgSpec
          $$  progDesc' $$$ do
              "Load the given files using GHC and report errors/warnings,"
                \\ "but don't produce output files"
    <> command "expand"
          $$  info expandArgSpec
          $$  progDesc "Like `check' but also pass `-ddump-splices' to GHC"
    <> command "info"
          $$  info infoArgSpec
          $$  progDesc' $$$ do
              "Look up an identifier in the context"
                \\ "of FILE (like ghci's `:info')"
    <> command "type"
          $$  info typeArgSpec
          $$  progDesc "Get the type of the expression under (LINE,COL)"
    <> command "split"
          $$  info splitArgSpec
          $$  progDesc
                  "Split a function case by examining a type's constructors"
          <=> desc $$$ do
                "For example given the following code snippet:"
                code $ do
                  "f :: [a] -> a"
                  "f x = _body"
                "would be replaced by:"
                code $ do
                  "f :: [a] -> a"
                  "f [] = _body"
                  "f (x:xs) = _body"
                "(See https://github.com/kazu-yamamoto/ghc-mod/pull/274)"
    <> command "sig"
          $$  info sigArgSpec
          $$  progDesc "Generate initial code given a signature"
          <=> desc $$$ do
              "For example when (LINE,COL) is on the"
                \\ "signature in the following code snippet:"
              code "func :: [a] -> Maybe b -> (a -> b) -> (a,b)"
              "ghc-mod would add the following on the next line:"
              code "func x y z f = _func_body"
              "(See: https://github.com/kazu-yamamoto/ghc-mod/pull/274)"
    <> command "auto"
          $$  info autoArgSpec
          $$  progDesc "Try to automatically fill the contents of a hole"
    <> command "refine"
          $$  info refineArgSpec
          $$  progDesc "Refine the typed hole at (LINE,COL) given EXPR"
          <=> desc $$$ do
              "For example if EXPR is `filter', which has type"
                \\ "`(a -> Bool) -> [a] -> [a]' and (LINE,COL) is on"
                \\ " the hole `_body' in the following code snippet:"
              code $ do
                "filterNothing :: [Maybe a] -> [a]"
                "filterNothing xs = _body"
              "ghc-mod changes the code to get a value of type"
                \\ " `[a]', which results in:"
              code "filterNothing xs = filter _body_1 _body_2"
              "(See also: https://github.com/kazu-yamamoto/ghc-mod/issues/311)"
    <> command "test"
          $$  info (CmdTest <$> strArg "FILE")
          $$  progDesc ""


interactiveCommandsSpec :: Parser GhcModCommands
interactiveCommandsSpec =
    hsubparser'
        $  commands
        <> command "map-file"
              $$  info mapArgSpec
              $$  progDesc "tells ghc-modi to read `file.hs` source from stdin"
              <=> desc $$$ do
                "Works the same as second form of"
                  \\ "`--map-file` CLI option."
        <> command "unmap-file"
              $$  info unmapArgSpec
              $$  progDesc' $$$ do
                    "unloads previously mapped file,"
                      \\ "so that it's no longer mapped."
              <=> desc $$$ do
                    "`file.hs` can be full path or relative"
                      \\ "to project root, either will work."
        <> command "quit"
              $$ info (pure CmdQuit)
              $$ progDesc "Exit interactive mode"
        <> command ""
              $$ info (pure CmdQuit) idm

strArg :: String -> Parser String
strArg = argument str . metavar

filesArgsSpec :: Parser ([String] -> b) -> Parser b
filesArgsSpec x = x <*> some (strArg "FILES..")

locArgSpec :: Parser (String -> (Int, Int) -> b) -> Parser b
locArgSpec x = x
  <*> strArg "FILE"
  <*> ( (,)
        <$> argument int (metavar "LINE")
        <*> argument int (metavar "COL")
      )

modulesArgSpec, docArgSpec, findArgSpec,
  lintArgSpec, browseArgSpec, checkArgSpec, expandArgSpec,
  infoArgSpec, typeArgSpec, autoArgSpec, splitArgSpec,
  sigArgSpec, refineArgSpec, debugComponentArgSpec,
  mapArgSpec, unmapArgSpec, legacyInteractiveArgSpec :: Parser GhcModCommands

modulesArgSpec = CmdModules
  <$> switch
        $$  long "detailed"
        <=> short 'd'
        <=> help "Print package modules belong to"
findArgSpec = CmdFind <$> strArg "SYMBOL"
docArgSpec = CmdDoc <$> strArg "MODULE"
lintArgSpec = CmdLint
  <$> LintOpts <$$> many $$ strOption
      $$  long "hlintOpt"
      <=> short 'h'
      <=> help "Option to be passed to hlint"
  <*> strArg "FILE"
browseArgSpec = CmdBrowse
  <$> (BrowseOpts
        <$> switch
            $$  long "operators"
            <=> short 'o'
            <=> help "Also print operators"
        <*> switch
            $$  long "detailed"
            <=> short 'd'
            <=> help "Print symbols with accompanying signature"
        <*> switch
            $$  long "parents"
            <=> short 'p'
            <=> help "Print symbols parents"
        <*> switch
            $$  long "qualified"
            <=> short 'q'
            <=> help "Qualify symbols"
      )
  <*> some (strArg "MODULE")
debugComponentArgSpec = filesArgsSpec (pure CmdDebugComponent)
checkArgSpec = filesArgsSpec (pure CmdCheck)
expandArgSpec = filesArgsSpec (pure CmdExpand)
infoArgSpec = CmdInfo
    <$> strArg "FILE"
    <*> strArg "SYMBOL"
typeArgSpec = locArgSpec $ CmdType <$>
        switch
          $$  long "constraints"
          <=> short 'c'
          <=> help "Include constraints into type signature"
autoArgSpec = locArgSpec (pure CmdAuto)
splitArgSpec = locArgSpec (pure CmdSplit)
sigArgSpec = locArgSpec (pure CmdSig)
refineArgSpec = locArgSpec (pure CmdRefine) <*> strArg "SYMBOL"
mapArgSpec = CmdMapFile <$> strArg "FILE"
unmapArgSpec = CmdUnmapFile <$> strArg "FILE"
legacyInteractiveArgSpec = const CmdLegacyInteractive <$>
  optional interactiveCommandsSpec

hsubparser' :: Mod CommandFields a -> Parser a
hsubparser' m = mkParser d g rdr
  where
    Mod _ d g = m `mappend` metavar ""
    (cmds, subs) = mkCommand m
    rdr = CmdReader cmds (fmap add_helper . subs)
    add_helper pinfo = pinfo
      { infoParser = infoParser pinfo <**> helper }

int :: ReadM Int
int = do
  v <- readerAsk
  maybe (readerError $ "Not a number \"" ++ v ++ "\"") return $ readMaybe v