{-# LANGUAGE OverloadedStrings, CPP, TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, FlexibleContexts, UndecidableInstances, MultiParamTypeClasses, TypeFamilies, ConstraintKinds #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module HsDev.Server.Types (
	ServerMonadBase,
	SessionLog(..), Session(..), SessionMonad(..), askSession, ServerM(..),
	CommandOptions(..), CommandMonad(..), askOptions, ClientM(..),
	withSession, serverListen, serverSetLogLevel, serverWait, serverWaitClients,
	serverSqlDatabase, openSqlConnection, closeSqlConnection, withSqlConnection, withSqlTransaction, serverSetFileContents,
	inSessionGhc, inSessionUpdater, postSessionUpdater, serverExit, commandRoot, commandNotify, commandLink, commandHold,
	ServerCommand(..), ConnectionPort(..), ServerOpts(..), silentOpts, ClientOpts(..), serverOptsArgs, Request(..),

	Command(..),
	FileSource(..), TargetFilter(..), SearchQuery(..), SearchType(..),
	FromCmd(..),
	) where

import Control.Applicative
import Control.Concurrent.Async (Async)
import qualified Control.Concurrent.FiniteChan as F
import Control.Lens (view, set)
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.Except
import Control.Monad.Morph
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.Trans.Control
import Data.Aeson hiding (Result(..), Error)
import qualified Data.Aeson.Types as A
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Default
import Data.Maybe (fromMaybe)
import Data.Foldable (asum)
import Data.Text (Text)
import Data.String (fromString)
import qualified Database.SQLite.Simple as SQL
import Options.Applicative
import System.Log.Simple as Log

import Control.Concurrent.Worker
import Data.LookupTable
import System.Directory.Paths
import Text.Format (Formattable(..))

import HsDev.Error (hsdevError)
import HsDev.Inspect.Types
import HsDev.Server.Message
import HsDev.Watcher.Types (Watcher)
import HsDev.Tools.Ghc.Worker (GhcWorker, GhcM)
import HsDev.Tools.Types (Note, OutputMessage)
import HsDev.Tools.AutoFix (Refact)
import HsDev.Types (HsDevError(..))
import HsDev.Util

#if mingw32_HOST_OS
import System.Win32.FileMapping.NamePool (Pool)
#endif

type ServerMonadBase m = (MonadIO m, MonadMask m, MonadBaseControl IO m, Alternative m, MonadPlus m)

data SessionLog = SessionLog {
	sessionLogger :: Log,
	sessionListenLog :: IO [Log.Message],
	sessionLogWait :: IO () }

data Session = Session {
	sessionSqlDatabase :: SQL.Connection,
	sessionSqlPath :: String,
	sessionLog :: SessionLog,
	sessionWatcher :: Watcher,
	sessionFileContents :: Path -> Maybe Text -> IO (),
#if mingw32_HOST_OS
	sessionMmapPool :: Maybe Pool,
#endif
	sessionGhc :: GhcWorker,
	sessionUpdater :: Worker (ServerM IO),
	sessionResolveEnvironment :: LookupTable (Maybe Path) (Environment, FixitiesTable),
	sessionExit :: IO (),
	sessionWait :: IO (),
	sessionClients :: F.Chan (IO ()),
	sessionDefines :: [(String, String)] }

class (ServerMonadBase m, MonadLog m) => SessionMonad m where
	getSession :: m Session
	localSession :: (Session -> Session) -> m a -> m a

askSession :: SessionMonad m => (Session -> a) -> m a
askSession f = liftM f getSession

newtype ServerM m a = ServerM { runServerM :: ReaderT Session m a }
	deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadReader Session, MonadTrans, MonadThrow, MonadCatch, MonadMask)

instance (MonadIO m, MonadMask m) => MonadLog (ServerM m) where
	askLog = ServerM $ asks (sessionLogger . sessionLog)
	localLog fn = ServerM . local setLog' . runServerM where
		setLog' sess = sess { sessionLog = (sessionLog sess) { sessionLogger = fn (sessionLogger (sessionLog sess)) } }

instance ServerMonadBase m => SessionMonad (ServerM m) where
	getSession = ask
	localSession = local

instance MonadBase b m => MonadBase b (ServerM m) where
	liftBase = ServerM . liftBase

instance MonadBaseControl b m => MonadBaseControl b (ServerM m) where
	type StM (ServerM m) a = StM (ReaderT Session m) a
	liftBaseWith f = ServerM $ liftBaseWith (\f' -> f (f' . runServerM))
	restoreM = ServerM . restoreM

instance MFunctor ServerM where
	hoist fn = ServerM . hoist fn . runServerM

instance SessionMonad m => SessionMonad (ReaderT r m) where
	getSession = lift getSession
	localSession = mapReaderT . localSession

instance (SessionMonad m, Monoid w) => SessionMonad (WriterT w m) where
	getSession = lift getSession
	localSession = mapWriterT . localSession

instance SessionMonad m => SessionMonad (StateT s m) where
	getSession = lift getSession
	localSession = mapStateT . localSession

data CommandOptions = CommandOptions {
	commandOptionsRoot :: FilePath,
	commandOptionsNotify :: Notification -> IO (),
	commandOptionsLink :: IO (),
	commandOptionsHold :: IO () }

instance Default CommandOptions where
	def = CommandOptions "." (const $ return ()) (return ()) (return ())

class (SessionMonad m, MonadPlus m) => CommandMonad m where
	getOptions :: m CommandOptions

askOptions :: CommandMonad m => (CommandOptions -> a) -> m a
askOptions f = liftM f getOptions

newtype ClientM m a = ClientM { runClientM :: ServerM (ReaderT CommandOptions m) a }
	deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadThrow, MonadCatch, MonadMask)

instance MonadTrans ClientM where
	lift = ClientM . lift . lift

instance (MonadIO m, MonadMask m) => MonadLog (ClientM m) where
	askLog = ClientM askLog
	localLog fn = ClientM . localLog fn . runClientM

instance ServerMonadBase m => SessionMonad (ClientM m) where
	getSession = ClientM getSession
	localSession fn = ClientM . localSession fn . runClientM

instance ServerMonadBase m => CommandMonad (ClientM m) where
	getOptions = ClientM $ lift ask

instance MonadBase b m => MonadBase b (ClientM m) where
	liftBase = ClientM . liftBase

instance MonadBaseControl b m => MonadBaseControl b (ClientM m) where
	type StM (ClientM m) a = StM (ServerM (ReaderT CommandOptions m)) a
	liftBaseWith f = ClientM $ liftBaseWith (\f' -> f (f' . runClientM))
	restoreM = ClientM . restoreM

instance MFunctor ClientM where
	hoist fn = ClientM . hoist (hoist fn) . runClientM

instance CommandMonad m => CommandMonad (ReaderT r m) where
	getOptions = lift getOptions

instance (CommandMonad m, Monoid w) => CommandMonad (WriterT w m) where
	getOptions = lift getOptions

instance CommandMonad m => CommandMonad (StateT s m) where
	getOptions = lift getOptions

-- | Run action on session
withSession :: Session -> ServerM m a -> m a
withSession s act = runReaderT (runServerM act) s

-- | Listen server's log
serverListen :: SessionMonad m => m [Log.Message]
serverListen = join . liftM liftIO $ askSession (sessionListenLog . sessionLog)

-- | Set server's log config
serverSetLogLevel :: SessionMonad m => Level -> m Level
serverSetLogLevel lev = do
	l <- askSession (sessionLogger . sessionLog)
	cfg <- updateLogConfig l (set (componentCfg "") (Just lev))
	return $ fromMaybe def $ view (componentCfg "") cfg

-- | Wait for server
serverWait :: SessionMonad m => m ()
serverWait = join . liftM liftIO $ askSession sessionWait

-- | Wait while clients disconnects
serverWaitClients :: SessionMonad m => m ()
serverWaitClients = do
	clientChan <- askSession sessionClients
	liftIO (F.stopChan clientChan) >>= sequence_ . map liftIO

-- | Get sql connection
serverSqlDatabase :: SessionMonad m => m SQL.Connection
serverSqlDatabase = askSession sessionSqlDatabase

-- | Open new sql connection
openSqlConnection :: SessionMonad m => m SQL.Connection
openSqlConnection = do
	p <- askSession sessionSqlPath
	-- FIXME: There's `new` function in HsDev's SQLite module
	liftIO $ do
		conn <- SQL.open p
		SQL.execute_ conn "pragma case_sensitive_like = true;"
		SQL.execute_ conn "pragma synchronous = off;"
		SQL.execute_ conn "pragma journal_mode = memory;"
		return conn

-- | Close sql connection
closeSqlConnection :: SessionMonad m => SQL.Connection -> m ()
closeSqlConnection = liftIO . SQL.close

-- | Locally opens new connection, updating @Session@
withSqlConnection :: SessionMonad m => m a -> m a
withSqlConnection act = bracket openSqlConnection closeSqlConnection $ \conn ->
	localSession (\sess -> sess { sessionSqlDatabase = conn }) act

-- | With sql transaction
withSqlTransaction :: SessionMonad m => ServerM IO a -> m a
withSqlTransaction fn = do
	conn <- serverSqlDatabase
	sess <- getSession
	liftIO $ SQL.withTransaction conn $ withSession sess fn

-- | Set custom file contents
serverSetFileContents :: SessionMonad m => Path -> Maybe Text -> m ()
serverSetFileContents fpath mcts = do
	setCts <- askSession sessionFileContents
	liftIO $ setCts fpath mcts

-- | In ghc session
inSessionGhc :: SessionMonad m => GhcM a -> m a
inSessionGhc act = do
	ghcw <- askSession sessionGhc
	inWorkerWith (hsdevError . GhcError . displayException) ghcw act

-- | In updater
inSessionUpdater :: SessionMonad m => ServerM IO a -> m a
inSessionUpdater act = do
	uw <- askSession sessionUpdater
	inWorkerWith (hsdevError . OtherError . displayException) uw act

-- | Post to updater and return
postSessionUpdater :: SessionMonad m => ServerM IO a -> m (Async a)
postSessionUpdater act = do
	uw <- askSession sessionUpdater
	liftIO $ sendTask uw act

-- | Exit session
serverExit :: SessionMonad m => m ()
serverExit = join . liftM liftIO $ askSession sessionExit

commandRoot :: CommandMonad m => m FilePath
commandRoot = askOptions commandOptionsRoot

commandNotify :: CommandMonad m => Notification -> m ()
commandNotify n = join . liftM liftIO $ askOptions commandOptionsNotify <*> pure n

commandLink :: CommandMonad m => m ()
commandLink = join . liftM liftIO $ askOptions commandOptionsLink

commandHold :: CommandMonad m => m ()
commandHold = join . liftM liftIO $ askOptions commandOptionsHold

-- | Server control command
data ServerCommand =
	Version |
	Start ServerOpts |
	Run ServerOpts |
	Stop ClientOpts |
	Connect ClientOpts |
	Remote ClientOpts Bool Command
		deriving (Show)

data ConnectionPort = NetworkPort Int | UnixPort String deriving (Eq, Read)

instance Default ConnectionPort where
	def = NetworkPort 4567

instance Show ConnectionPort where
	show (NetworkPort p) = show p
	show (UnixPort s) = "unix " ++ s

instance Formattable ConnectionPort

-- | Server options
data ServerOpts = ServerOpts {
	serverPort :: ConnectionPort,
	serverTimeout :: Int,
	serverLog :: Maybe FilePath,
	serverLogLevel :: String,
	serverLogNoColor :: Bool,
	serverDbFile :: Maybe FilePath,
	serverSilent :: Bool }
		deriving (Show)

instance Default ServerOpts where
	def = ServerOpts def 0 Nothing "info" False Nothing False

-- | Silent server with no connection, useful for ghci
silentOpts :: ServerOpts
silentOpts = def { serverSilent = True }

-- | Client options
data ClientOpts = ClientOpts {
	clientPort :: ConnectionPort,
	clientPretty :: Bool,
	clientStdin :: Bool,
	clientTimeout :: Int,
	clientSilent :: Bool }
		deriving (Show)

instance Default ClientOpts where
	def = ClientOpts def False False 0 False

instance FromCmd ServerCommand where
	cmdP = serv <|> remote where
		serv = subparser $ mconcat [
			cmd "version" "hsdev version" (pure Version),
			cmd "start" "start remote server" (Start <$> cmdP),
			cmd "run" "run server" (Run <$> cmdP),
			cmd "stop" "stop remote server" (Stop <$> cmdP),
			cmd "connect" "connect to send commands directly" (Connect <$> cmdP)]
		remote = Remote <$> cmdP <*> noFileFlag <*> cmdP

instance FromCmd ServerOpts where
	cmdP = ServerOpts <$>
		(connectionArg <|> pure (serverPort def)) <*>
		(timeoutArg <|> pure (serverTimeout def)) <*>
		optional logArg <*>
		(logLevelArg <|> pure (serverLogLevel def)) <*>
		noColorFlag <*>
		optional dbFileArg <*>
		serverSilentFlag

instance FromCmd ClientOpts where
	cmdP = ClientOpts <$>
		(connectionArg <|> pure (clientPort def)) <*>
		prettyFlag <*>
		stdinFlag <*>
		(timeoutArg <|> pure (clientTimeout def)) <*>
		silentFlag

portArg :: Parser ConnectionPort
connectionArg :: Parser ConnectionPort
timeoutArg :: Parser Int
logArg :: Parser FilePath
logLevelArg :: Parser String
noColorFlag :: Parser Bool
noFileFlag :: Parser Bool
prettyFlag :: Parser Bool
serverSilentFlag :: Parser Bool
stdinFlag :: Parser Bool
silentFlag :: Parser Bool
dbFileArg :: Parser FilePath

portArg = NetworkPort <$> option auto (long "port" <> metavar "number" <> help "connection port")
#if mingw32_HOST_OS
connectionArg = portArg
#else
unixArg :: Parser ConnectionPort
unixArg = UnixPort <$> strOption (long "unix" <> metavar "name" <> help "unix connection port")
connectionArg = portArg <|> unixArg
#endif
timeoutArg = option auto (long "timeout" <> metavar "msec" <> help "query timeout")
logArg = strOption (long "log" <> short 'l' <> metavar "file" <> help "log file")
logLevelArg = strOption (long "log-level" <> metavar "level" <> help "log level: trace/debug/info/warning/error/fatal")
noColorFlag = switch (long "no-color" <> help "don't use colorized log output")
noFileFlag = switch (long "no-file" <> help "don't use mmap files")
prettyFlag = switch (long "pretty" <> help "pretty json output")
serverSilentFlag = switch (long "silent" <> help "no stdout/stderr")
stdinFlag = switch (long "stdin" <> help "pass data to stdin")
silentFlag = switch (long "silent" <> help "supress notifications")
dbFileArg = strOption (long "db" <> metavar "path" <> help "path to sql database")

serverOptsArgs :: ServerOpts -> [String]
serverOptsArgs sopts = concat [
	portArgs (serverPort sopts),
	["--timeout", show $ serverTimeout sopts],
	marg "--log" (serverLog sopts),
	["--log-level", serverLogLevel sopts],
	marg "--db" (serverDbFile sopts),
	["--silent" | serverSilent sopts]]
	where
		marg :: String -> Maybe String -> [String]
		marg n (Just v) = [n, v]
		marg _ _ = []
		portArgs :: ConnectionPort -> [String]
		portArgs (NetworkPort n) = ["--port", show n]
		portArgs (UnixPort s) = ["--unix", s]

data Request = Request {
	requestCommand :: Command,
	requestDirectory :: FilePath,
	requestNoFile :: Bool,
	requestTimeout :: Int,
	requestSilent :: Bool }
		deriving (Show)

instance ToJSON Request where
	toJSON (Request c dir f tm s) = object ["current-directory" .= dir, "no-file" .= f, "timeout" .= tm, "silent" .= s] `objectUnion` toJSON c

instance FromJSON Request where
	parseJSON = withObject "request" $ \v -> Request <$>
		parseJSON (Object v) <*>
		((v .:: "current-directory") <|> pure ".") <*>
		((v .:: "no-file") <|> pure False) <*>
		((v .:: "timeout") <|> pure 0) <*>
		((v .:: "silent") <|> pure False)

-- | Command from client
data Command =
	Ping |
	Listen (Maybe String) |
	SetLogLevel String |
	Scan {
		scanProjects :: [Path],
		scanCabal :: Bool,
		scanSandboxes :: [Path],
		scanFiles :: [FileSource],
		scanPaths :: [Path],
		scanGhcOpts :: [String],
		scanDocs :: Bool,
		scanInferTypes :: Bool } |
	SetFileContents Path (Maybe Text) |
	RefineDocs {
		docsProjects :: [Path],
		docsFiles :: [Path] } |
	InferTypes {
		inferProjects :: [Path],
		inferFiles :: [Path] } |
	Remove {
		removeProjects :: [Path],
		removeCabal :: Bool,
		removeSandboxes :: [Path],
		removeFiles :: [Path] } |
	RemoveAll |
	InfoPackages |
	InfoProjects |
	InfoSandboxes |
	InfoSymbol SearchQuery [TargetFilter] Bool Bool |
	InfoModule SearchQuery [TargetFilter] Bool Bool |
	InfoProject (Either Text Path) |
	InfoSandbox Path |
	Lookup Text Path |
	Whois Text Path |
	Whoat Int Int Path |
	ResolveScopeModules SearchQuery Path |
	ResolveScope SearchQuery Path |
	FindUsages Int Int Path |
	Complete Text Bool Path |
	Hayoo {
		hayooQuery :: String,
		hayooPage :: Int,
		hayooPages :: Int } |
	CabalList { cabalListPackages :: [Text] } |
	UnresolvedSymbols {
		unresolvedFiles :: [Path] } |
	Lint {
		lintFiles :: [FileSource],
		lintHlintOpts :: [String]
	} |
	Check {
		checkFiles :: [FileSource],
		checkGhcOpts :: [String],
		checkClear :: Bool } |
	CheckLint {
		checkLintFiles :: [FileSource],
		checkLintGhcOpts :: [String],
		checkLintOpts :: [String],
		checkLinkClear :: Bool } |
	Types {
		typesFiles :: [FileSource],
		typesGhcOpts :: [String],
		typesClear :: Bool } |
	AutoFix [Note OutputMessage] |
	Refactor [Note Refact] [Note Refact] Bool |
	Rename Text Text Path |
	GhcEval { ghcEvalExpressions :: [String], ghcEvalSource :: Maybe FileSource } |
	GhcType { ghcTypeExpressions :: [String], ghcTypeSource :: Maybe FileSource } |
	Langs |
	Flags |
	Link { linkHold :: Bool } |
	StopGhc |
	Exit
		deriving (Show)

data FileSource = FileSource { fileSource :: Path, fileContents :: Maybe Text } deriving (Show)
data TargetFilter =
	TargetProject Text |
	TargetFile Path |
	TargetModule Text |
	TargetPackage Text |
	TargetInstalled |
	TargetSourced |
	TargetStandalone
		deriving (Eq, Show)
data SearchQuery = SearchQuery Text SearchType deriving (Show)
data SearchType = SearchExact | SearchPrefix | SearchInfix | SearchSuffix deriving (Show)

instance Paths Command where
	paths f (Scan projs c cs fs ps ghcs docs infer) = Scan <$>
		traverse (paths f) projs <*>
		pure c <*>
		traverse (paths f) cs <*>
		traverse (paths f) fs <*>
		traverse (paths f) ps <*>
		pure ghcs <*>
		pure docs <*>
		pure infer
	paths f (SetFileContents p cts) = SetFileContents <$> paths f p <*> pure cts
	paths f (RefineDocs projs fs) = RefineDocs <$> traverse (paths f) projs <*> traverse (paths f) fs
	paths f (InferTypes projs fs) = InferTypes <$> traverse (paths f) projs <*> traverse (paths f) fs
	paths f (Remove projs c cs fs) = Remove <$> traverse (paths f) projs <*> pure c <*> traverse (paths f) cs <*> traverse (paths f) fs
	paths _ RemoveAll = pure RemoveAll
	paths f (InfoSymbol q t h l) = InfoSymbol <$> pure q <*> traverse (paths f) t <*> pure h <*> pure l
	paths f (InfoModule q t h i) = InfoModule <$> pure q <*> traverse (paths f) t <*> pure h <*> pure i
	paths f (InfoProject (Right proj)) = InfoProject <$> (Right <$> paths f proj)
	paths f (InfoSandbox fpath) = InfoSandbox <$> paths f fpath
	paths f (Lookup n fpath) = Lookup <$> pure n <*> paths f fpath
	paths f (Whois n fpath) = Whois <$> pure n <*> paths f fpath
	paths f (Whoat l c fpath) = Whoat <$> pure l <*> pure c <*> paths f fpath
	paths f (ResolveScopeModules q fpath) = ResolveScopeModules q <$> paths f fpath
	paths f (ResolveScope q fpath) = ResolveScope q <$> paths f fpath
	paths f (FindUsages l c fpath) = FindUsages <$> pure l <*> pure c <*> paths f fpath
	paths f (Complete n g fpath) = Complete n g <$> paths f fpath
	paths f (UnresolvedSymbols fs) = UnresolvedSymbols <$> traverse (paths f) fs
	paths f (Lint fs lints) = Lint <$> traverse (paths f) fs <*> pure lints
	paths f (Check fs ghcs c) = Check <$> traverse (paths f) fs <*> pure ghcs <*> pure c
	paths f (CheckLint fs ghcs lints c) = CheckLint <$> traverse (paths f) fs <*> pure ghcs <*> pure lints <*> pure c
	paths f (Types fs ghcs c) = Types <$> traverse (paths f) fs <*> pure ghcs <*> pure c
	paths f (GhcEval e mf) = GhcEval e <$> traverse (paths f) mf
	paths f (GhcType e mf) = GhcType e <$> traverse (paths f) mf
	paths _ c = pure c

instance Paths FileSource where
	paths f (FileSource fpath mcts) = FileSource <$> paths f fpath <*> pure mcts

instance Paths TargetFilter where
	paths f (TargetFile fpath) = TargetFile <$> paths f fpath
	paths _ t = pure t

instance FromCmd Command where
	cmdP = subparser $ mconcat [
		cmd "ping" "ping server" (pure Ping),
		cmd "listen" "listen server log" (Listen <$> optional logLevelArg),
		cmd "set-log" "set log level" (SetLogLevel <$> strArgument idm),
		cmd "scan" "scan sources" $ Scan <$>
			many projectArg <*>
			cabalFlag <*>
			many sandboxArg <*>
			many cmdP <*>
			many (pathArg $ help "path") <*>
			ghcOpts <*>
			docsFlag <*>
			inferFlag,
		cmd "set-file-contents" "set edited file contents, which will be used instead of contents in file until it updated" $
			SetFileContents <$> fileArg <*> optional contentsArg,
		cmd "docs" "scan docs" $ RefineDocs <$> many projectArg <*> many fileArg,
		cmd "infer" "infer types" $ InferTypes <$> many projectArg <*> many fileArg,
		cmd "remove" "remove modules info" $ Remove <$>
			many projectArg <*>
			cabalFlag <*>
			many sandboxArg <*>
			many fileArg,
		cmd "remove-all" "remove all data" (pure RemoveAll),
		cmd "packages" "list packages" (pure InfoPackages),
		cmd "projects" "list projects" (pure InfoProjects),
		cmd "sandboxes" "list sandboxes" (pure InfoSandboxes),
		cmd "symbol" "get symbol info" (InfoSymbol <$> cmdP <*> many cmdP <*> headerFlag <*> localsFlag),
		cmd "module" "get module info" (InfoModule <$> cmdP <*> many cmdP <*> headerFlag <*> inspectionFlag),
		cmd "project" "get project info" (InfoProject <$> ((Left <$> projectArg) <|> (Right <$> pathArg idm))),
		cmd "sandbox" "get sandbox info" (InfoSandbox <$> pathArg (help "locate sandbox in parent of this path")),
		cmd "lookup" "lookup for symbol" (Lookup <$> textArgument idm <*> ctx),
		cmd "whois" "get info for symbol" (Whois <$> textArgument idm <*> ctx),
		cmd "whoat" "get info for symbol under cursor" (Whoat <$> argument auto (metavar "line") <*> argument auto (metavar "column") <*> ctx),
		cmd "scope" "get declarations accessible from module or within a project" (
			subparser (cmd "modules" "get modules accessible from module or within a project" (ResolveScopeModules <$> cmdP <*> ctx)) <|>
			ResolveScope <$> cmdP <*> ctx),
		cmd "usages" "find usages of symbol within project/module" (FindUsages <$> argument auto (metavar "line") <*> argument auto (metavar "column") <*> ctx),
		cmd "complete" "show completions for input" (Complete <$> textArgument idm <*> wideFlag <*> ctx),
		cmd "hayoo" "find declarations online via Hayoo" (Hayoo <$> strArgument idm <*> hayooPageArg <*> hayooPagesArg),
		cmd "cabal" "cabal commands" (subparser $ cmd "list" "list cabal packages" (CabalList <$> many (textArgument idm))),
		cmd "unresolveds" "list unresolved symbols in source file" (UnresolvedSymbols <$> many fileArg),
		cmd "lint" "lint source files or file contents" (Lint <$> many cmdP <*> lintOpts),
		cmd "check" "check source files or file contents" (Check <$> many cmdP <*> ghcOpts <*> clearFlag),
		cmd "check-lint" "check and lint source files or file contents" (CheckLint <$> many cmdP <*> ghcOpts <*> lintOpts <*> clearFlag),
		cmd "types" "get types for file expressions" (Types <$> many cmdP <*> ghcOpts <*> clearFlag),
		cmd "autofixes" "get autofixes by output messages" (AutoFix <$> option readJSON (long "data" <> metavar "message" <> help "messages to make fixes for")),
		cmd "refactor" "apply some refactors and get rest updated" (Refactor <$>
			option readJSON (long "data" <> metavar "message" <> help "messages to fix") <*>
			option readJSON (long "rest" <> metavar "correction" <> short 'r' <> help "update corrections") <*>
			pureFlag),
		cmd "rename" "get rename refactors" (Rename <$> textArgument idm <*> textArgument idm <*> ctx),
		cmd "ghc" "ghc commands" (
				subparser (cmd "eval" "evaluate expression" (GhcEval <$> many (strArgument idm) <*> optional cmdP)) <|>
				subparser (cmd "type" "expression type" (GhcType <$> many (strArgument idm) <*> optional cmdP))),
		cmd "langs" "ghc language options" (pure Langs),
		cmd "flags" "ghc flags" (pure Flags),
		cmd "link" "link to server" (Link <$> holdFlag),
		cmd "stop-ghc" "stop ghc sessions" (pure StopGhc),
		cmd "exit" "exit" (pure Exit)]

instance FromCmd FileSource where
	cmdP = option readJSON (long "contents") <|> (FileSource <$> fileArg <*> pure Nothing)

instance FromCmd TargetFilter where
	cmdP = asum [
		TargetProject <$> projectArg,
		TargetFile <$> fileArg,
		TargetModule <$> moduleArg,
		TargetPackage <$> packageArg,
		flag' TargetInstalled (long "installed"),
		flag' TargetSourced (long "src"),
		flag' TargetStandalone (long "stand")]

instance FromCmd SearchQuery where
	cmdP = SearchQuery <$> (textArgument idm <|> pure "") <*> asum [
		flag' SearchExact (long "exact"),
		flag' SearchInfix (long "infix"),
		flag' SearchSuffix (long "suffix"),
		pure SearchPrefix <* switch (long "prefix")]

readJSON :: FromJSON a => ReadM a
readJSON = str >>= maybe (readerError "Can't parse JSON argument") return . decode . L.pack

textOption :: Mod OptionFields String -> Parser Text
textOption = fmap fromString . strOption

textArgument :: Mod ArgumentFields String -> Parser Text
textArgument = fmap fromString . strArgument

cabalFlag :: Parser Bool
clearFlag :: Parser Bool
contentsArg :: Parser Text
ctx :: Parser Path
docsFlag :: Parser Bool
fileArg :: Parser Path
ghcOpts :: Parser [String]
hayooPageArg :: Parser Int
hayooPagesArg :: Parser Int
headerFlag :: Parser Bool
holdFlag :: Parser Bool
inferFlag :: Parser Bool
inspectionFlag :: Parser Bool
lintOpts :: Parser [String]
localsFlag :: Parser Bool
moduleArg :: Parser Text
packageArg :: Parser Text
pathArg :: Mod OptionFields String -> Parser Path
projectArg :: Parser Path
pureFlag :: Parser Bool
sandboxArg :: Parser Path
wideFlag :: Parser Bool

cabalFlag = switch (long "cabal")
clearFlag = switch (long "clear" <> short 'c' <> help "clear run, drop previous state")
contentsArg = textOption (long "contents" <> help "text contents")
ctx = fileArg
docsFlag = switch (long "docs" <> help "scan source file docs")
fileArg = textOption (long "file" <> metavar "path" <> short 'f')
ghcOpts = many (strOption (long "ghc" <> metavar "option" <> short 'g' <> help "options to pass to GHC"))
hayooPageArg = option auto (long "page" <> metavar "n" <> short 'p' <> help "page number (0 by default)" <> value 0)
hayooPagesArg = option auto (long "pages" <> metavar "count" <> short 'n' <> help "pages count (1 by default)" <> value 1)
headerFlag = switch (long "header" <> short 'h' <> help "show only header of module")
holdFlag = switch (long "hold" <> short 'h' <> help "don't return any response")
inferFlag = switch (long "infer" <> help "infer types")
inspectionFlag = switch (long "inspection" <> short 'i' <> help "return inspection data")
lintOpts = many (strOption (long "lint" <> metavar "option" <> short 'l' <> help "options for hlint"))
localsFlag = switch (long "locals" <> short 'l' <> help "look in local declarations")
moduleArg = textOption (long "module" <> metavar "name" <> short 'm' <> help "module name")
packageArg = textOption (long "package" <> metavar "name" <> help "module package")
pathArg f = textOption (long "path" <> metavar "path" <> short 'p' <> f)
projectArg = textOption (long "project" <> long "proj" <> metavar "project")
pureFlag = switch (long "pure" <> help "don't modify actual file, just return result")
sandboxArg = textOption (long "sandbox" <> metavar "path" <> help "path to cabal sandbox")
wideFlag = switch (long "wide" <> short 'w' <> help "wide mode - complete as if there were no import lists")

instance ToJSON Command where
	toJSON Ping = cmdJson "ping" []
	toJSON (Listen lev) = cmdJson "listen" ["level" .= lev]
	toJSON (SetLogLevel lev) = cmdJson "set-log" ["level" .= lev]
	toJSON (Scan projs cabal sboxes fs ps ghcs docs' infer') = cmdJson "scan" [
		"projects" .= projs,
		"cabal" .= cabal,
		"sandboxes" .= sboxes,
		"files" .= fs,
		"paths" .= ps,
		"ghc-opts" .= ghcs,
		"docs" .= docs',
		"infer" .= infer']
	toJSON (SetFileContents f cts) = cmdJson "set-file-contents" ["file" .= f, "contents" .= cts]
	toJSON (RefineDocs projs fs) = cmdJson "docs" ["projects" .= projs, "files" .= fs]
	toJSON (InferTypes projs fs) = cmdJson "infer" ["projects" .= projs, "files" .= fs]
	toJSON (Remove projs cabal sboxes fs) = cmdJson "remove" ["projects" .= projs, "cabal" .= cabal, "sandboxes" .= sboxes, "files" .= fs]
	toJSON RemoveAll = cmdJson "remove-all" []
	toJSON InfoPackages = cmdJson "packages" []
	toJSON InfoProjects = cmdJson "projects" []
	toJSON InfoSandboxes = cmdJson "sandboxes" []
	toJSON (InfoSymbol q tf h l) = cmdJson "symbol" ["query" .= q, "filters" .= tf, "header" .= h, "locals" .= l]
	toJSON (InfoModule q tf h i) = cmdJson "module" ["query" .= q, "filters" .= tf, "header" .= h, "inspection" .= i]
	toJSON (InfoProject p) = cmdJson "project" $ either (\pname -> ["name" .= pname]) (\ppath -> ["path" .= ppath]) p
	toJSON (InfoSandbox p) = cmdJson "sandbox" ["path" .= p]
	toJSON (Lookup n f) = cmdJson "lookup" ["name" .= n, "file" .= f]
	toJSON (Whois n f) = cmdJson "whois" ["name" .= n, "file" .= f]
	toJSON (Whoat l c f) = cmdJson "whoat" ["line" .= l, "column" .= c, "file" .= f]
	toJSON (ResolveScopeModules q f) = cmdJson "scope modules" ["query" .= q, "file" .= f]
	toJSON (ResolveScope q f) = cmdJson "scope" ["query" .= q, "file" .= f]
	toJSON (FindUsages l c f) = cmdJson "usages" ["line" .= l, "column" .= c, "file" .= f]
	toJSON (Complete q w f) = cmdJson "complete" ["prefix" .= q, "wide" .= w, "file" .= f]
	toJSON (Hayoo q p ps) = cmdJson "hayoo" ["query" .= q, "page" .= p, "pages" .= ps]
	toJSON (CabalList ps) = cmdJson "cabal list" ["packages" .= ps]
	toJSON (UnresolvedSymbols fs) = cmdJson "unresolveds" ["files" .= fs]
	toJSON (Lint fs lints) = cmdJson "lint" ["files" .= fs, "lint-opts" .= lints]
	toJSON (Check fs ghcs c) = cmdJson "check" ["files" .= fs, "ghc-opts" .= ghcs, "clear" .= c]
	toJSON (CheckLint fs ghcs lints c) = cmdJson "check-lint" ["files" .= fs, "ghc-opts" .= ghcs, "lint-opts" .= lints, "clear" .= c]
	toJSON (Types fs ghcs c) = cmdJson "types" ["files" .= fs, "ghc-opts" .= ghcs, "clear" .= c]
	toJSON (AutoFix ns) = cmdJson "autofixes" ["messages" .= ns]
	toJSON (Refactor ns rests pure') = cmdJson "refactor" ["messages" .= ns, "rest" .= rests, "pure" .= pure']
	toJSON (Rename n n' f) = cmdJson "rename" ["name" .= n, "new-name" .= n', "file" .= f]
	toJSON (GhcEval exprs f) = cmdJson "ghc eval" ["exprs" .= exprs, "file" .= f]
	toJSON (GhcType exprs f) = cmdJson "ghc type" ["exprs" .= exprs, "file" .= f]
	toJSON Langs = cmdJson "langs" []
	toJSON Flags = cmdJson "flags" []
	toJSON (Link h) = cmdJson "link" ["hold" .= h]
	toJSON StopGhc = cmdJson "stop-ghc" []
	toJSON Exit = cmdJson "exit" []

instance FromJSON Command where
	parseJSON = withObject "command" $ \v -> asum [
		guardCmd "ping" v *> pure Ping,
		guardCmd "listen" v *> (Listen <$> v .::? "level"),
		guardCmd "set-log" v *> (SetLogLevel <$> v .:: "level"),
		guardCmd "scan" v *> (Scan <$>
			v .::?! "projects" <*>
			(v .:: "cabal" <|> pure False) <*>
			v .::?! "sandboxes" <*>
			v .::?! "files" <*>
			v .::?! "paths" <*>
			v .::?! "ghc-opts" <*>
			(v .:: "docs" <|> pure False) <*>
			(v .:: "infer" <|> pure False)),
		guardCmd "set-file-contents" v *> (SetFileContents <$> v .:: "file" <*> v .:: "contents"),
		guardCmd "docs" v *> (RefineDocs <$> v .::?! "projects" <*> v .::?! "files"),
		guardCmd "infer" v *> (InferTypes <$> v .::?! "projects" <*> v .::?! "files"),
		guardCmd "remove" v *> (Remove <$>
			v .::?! "projects" <*>
			(v .:: "cabal" <|> pure False) <*>
			v .::?! "sandboxes" <*>
			v .::?! "files"),
		guardCmd "remove-all" v *> pure RemoveAll,
		guardCmd "packages" v *> pure InfoPackages,
		guardCmd "projects" v *> pure InfoProjects,
		guardCmd "sandboxes" v *> pure InfoSandboxes,
		guardCmd "symbol" v *> (InfoSymbol <$> v .:: "query" <*> v .::?! "filters" <*> v .:: "header" <*> (v .:: "locals" <|> pure False)),
		guardCmd "module" v *> (InfoModule <$> v .:: "query" <*> v .::?! "filters" <*> v .:: "header" <*> v .:: "inspection"),
		guardCmd "project" v *> (InfoProject <$> asum [Left <$> v .:: "name", Right <$> v .:: "path"]),
		guardCmd "sandbox" v *> (InfoSandbox <$> v .:: "path"),
		guardCmd "lookup" v *> (Lookup <$> v .:: "name" <*> v .:: "file"),
		guardCmd "whois" v *> (Whois <$> v .:: "name" <*> v .:: "file"),
		guardCmd "whoat" v *> (Whoat <$> v .:: "line" <*> v .:: "column" <*> v .:: "file"),
		guardCmd "scope modules" v *> (ResolveScopeModules <$> v .:: "query" <*> v .:: "file"),
		guardCmd "scope" v *> (ResolveScope <$> v .:: "query" <*> v .:: "file"),
		guardCmd "usages" v *> (FindUsages <$> v .:: "line" <*> v .:: "column" <*> v .:: "file"),
		guardCmd "complete" v *> (Complete <$> v .:: "prefix" <*> (v .:: "wide" <|> pure False) <*> v .:: "file"),
		guardCmd "hayoo" v *> (Hayoo <$> v .:: "query" <*> (v .:: "page" <|> pure 0) <*> (v .:: "pages" <|> pure 1)),
		guardCmd "cabal list" v *> (CabalList <$> v .::?! "packages"),
		guardCmd "unresolveds" v *> (UnresolvedSymbols <$> v .::?! "files"),
		guardCmd "lint" v *> (Lint <$> v .::?! "files" <*> v .::?! "lint-opts"),
		guardCmd "check" v *> (Check <$> v .::?! "files" <*> v .::?! "ghc-opts" <*> (v .:: "clear" <|> pure False)),
		guardCmd "check-lint" v *> (CheckLint <$> v .::?! "files" <*> v .::?! "ghc-opts" <*> v .::?! "lint-opts" <*> (v .:: "clear" <|> pure False)),
		guardCmd "types" v *> (Types <$> v .::?! "files" <*> v .::?! "ghc-opts" <*> (v .:: "clear" <|> pure False)),
		guardCmd "autofixes" v *> (AutoFix <$> v .:: "messages"),
		guardCmd "refactor" v *> (Refactor <$> v .:: "messages" <*> v .::?! "rest" <*> (v .:: "pure" <|> pure True)),
		guardCmd "rename" v *> (Rename <$> v .:: "name" <*> v .:: "new-name" <*> v .:: "file"),
		guardCmd "ghc eval" v *> (GhcEval <$> v .::?! "exprs" <*> v .::? "file"),
		guardCmd "ghc type" v *> (GhcType <$> v .::?! "exprs" <*> v .::? "file"),
		guardCmd "langs" v *> pure Langs,
		guardCmd "flags" v *> pure Flags,
		guardCmd "link" v *> (Link <$> (v .:: "hold" <|> pure False)),
		guardCmd "stop-ghc" v *> pure StopGhc,
		guardCmd "exit" v *> pure Exit]

instance ToJSON FileSource where
	toJSON (FileSource fpath mcts) = object ["file" .= fpath, "contents" .= mcts]

instance FromJSON FileSource where
	parseJSON = withObject "file-contents" $ \v -> FileSource <$> v .:: "file" <*> v .::? "contents"

instance ToJSON TargetFilter where
	toJSON (TargetProject pname) = object ["project" .= pname]
	toJSON (TargetFile fpath) = object ["file" .= fpath]
	toJSON (TargetModule mname) = object ["module" .= mname]
	toJSON (TargetPackage pkg) = object ["package" .= pkg]
	toJSON TargetInstalled = toJSON ("installed" :: String)
	toJSON TargetSourced = toJSON ("sourced" :: String)
	toJSON TargetStandalone = toJSON ("standalone" :: String)

instance FromJSON TargetFilter where
	parseJSON j = obj j <|> str' where
		obj = withObject "target-filter" $ \v -> asum [
			TargetProject <$> v .:: "project",
			TargetFile <$> v .:: "file",
			TargetModule <$> v .:: "module",
			TargetPackage <$> v .:: "package"]
		str' = do
			s <- parseJSON j :: A.Parser String
			case s of
				"installed" -> return TargetInstalled
				"sourced" -> return TargetSourced
				"standalone" -> return TargetStandalone
				_ -> empty

instance ToJSON SearchQuery where
	toJSON (SearchQuery q st) = object ["input" .= q, "type" .= st]

instance FromJSON SearchQuery where
	parseJSON = withObject "search-query" $ \v -> SearchQuery <$> (v .:: "input" <|> pure "") <*> (v .:: "type" <|> pure SearchPrefix)

instance ToJSON SearchType where
	toJSON SearchExact = toJSON ("exact" :: String)
	toJSON SearchPrefix = toJSON ("prefix" :: String)
	toJSON SearchInfix = toJSON ("infix" :: String)
	toJSON SearchSuffix = toJSON ("suffix" :: String)

instance FromJSON SearchType where
	parseJSON v = do
		str' <- parseJSON v :: A.Parser String
		case str' of
			"exact" -> return SearchExact
			"prefix" -> return SearchPrefix
			"infix" -> return SearchInfix
			"suffix" -> return SearchInfix
			_ -> empty