{-# LANGUAGE OverloadedLabels  #-}
{-# LANGUAGE OverloadedLists   #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}

module Model
  ( module Model
  , module Namespace
  , module Common
  ) where

import Data.Maybe (fromMaybe)
import Data.Sequence as Seq
import Lens.Micro.Platform
import Data.Time
import System.Directory
import System.FilePath
import Data.Text(Text, pack)
import qualified Data.Text as T
import Text.Read

import Brick.Forms
import Brick.BChan
import Brick (EventM, Widget)
import Brick.Widgets.List

import Namespace
import Common
import Lib
import IOTree
import Control.Concurrent
import qualified Graphics.Vty as Vty
import Data.Int
import GHC.Debug.Client (ccID)
import GHC.Debug.Client.Monad (DebugM)
import GHC.Debug.CostCentres (findAllChildrenOfCC)
import qualified GHC.Debug.Types as GD
import qualified GHC.Debug.Types.Version as GD


data Event
  = PollTick  -- Used to perform arbitrary polling based tasks e.g. looking for new debuggees
  | ProgressMessage Text
  | ProgressFinished Text NominalDiffTime
  | AsyncFinished (EventM Name OperationalState ())


initialAppState :: BChan Event -> AppState
initialAppState event = AppState
  { _majorState = Setup
      { _setupKind = Socket
      , _knownDebuggees = list Setup_KnownDebuggeesList [] 1
      , _knownSnapshots = list Setup_KnownSnapshotsList [] 1
      },
    _appChan = event
  }

data AppState = AppState
  { _majorState :: MajorState
  , _appChan    :: BChan Event
  }

mkSocketInfo :: FilePath -> IO SocketInfo
mkSocketInfo fp = SocketInfo fp <$> getModificationTime fp

socketName :: SocketInfo -> Text
socketName = pack . takeFileName . _socketLocation

renderSocketTime :: SocketInfo -> Text
renderSocketTime = pack . formatTime defaultTimeLocale "%c" . _socketCreated

data SocketInfo = SocketInfo
                    { _socketLocation :: FilePath -- ^ FilePath to socket, absolute path
                    , _socketCreated :: UTCTime  -- ^ Time of socket creation
                    } deriving Eq

instance Ord SocketInfo where
  compare (SocketInfo s1 t1) (SocketInfo s2 t2) =
    -- Compare time first
    compare t1 t2 <> compare s1 s2

type SnapshotInfo = SocketInfo

data SetupKind = Socket | Snapshot

toggleSetup :: SetupKind -> SetupKind
toggleSetup Socket = Snapshot
toggleSetup Snapshot = Socket

data MajorState
  -- | We have not yet connected to a debuggee.
  = Setup
    { _setupKind :: SetupKind
    , _knownDebuggees :: GenericList Name Seq SocketInfo
    , _knownSnapshots :: GenericList Name Seq SnapshotInfo
    }

  -- | Connected to a debuggee
  | Connected
    { _debuggeeSocket :: SocketInfo
    , _debuggee :: Debuggee
    , _mode     :: ConnectedMode
    }

data InfoInfo = InfoInfo
  {
    _labelInParent :: Text -- ^ A label describing the relationship to the parent
  -- Stuff  that requires IO to calculate
  , _pretty :: Text
  , _sourceLocation :: Maybe SourceInformation
  , _closureType :: Maybe Text
  , _constructor :: Maybe Text
  , _profHeaderInfo :: !(Maybe ProfHeaderWord)
  } deriving Show

data ClosureDetails = ClosureDetails
  { _closure :: DebugClosure CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
  , _excSize :: Size
  , _info :: InfoInfo
  }
  | InfoDetails { _info :: InfoInfo }
  | CCSDetails Text CCSPtr (GenCCSPayload CCSPtr CCPayload)
  | CCDetails Text CCPayload
  | LabelNode { _label :: Text } deriving Show

data TreeMode = SavedAndGCRoots (ClosureDetails -> Widget Name)
              | Retainer (ClosureDetails -> Widget Name) (IOTree (ClosureDetails) Name)
              | forall a . Searched (a -> Widget Name) (IOTree a Name)

treeLength :: TreeMode -> Maybe Int
treeLength (SavedAndGCRoots {}) = Nothing
treeLength (Retainer _ tree) = Just $ Prelude.length $ getIOTreeRoots tree
treeLength (Searched _ tree) = Just $ Prelude.length $ getIOTreeRoots tree

data FooterMode = FooterInfo
                | FooterMessage Text
                | FooterInput FooterInputMode (Form Text () Name)

isFocusedFooter :: FooterMode -> Bool
isFocusedFooter (FooterInput {}) = True
isFocusedFooter _ = False

data FooterInputMode = FClosureAddress {runNow :: Bool, invert :: Bool}
                     | FInfoTableAddress {runNow :: Bool, invert :: Bool}
                     | FConstructorName {runNow :: Bool, invert :: Bool}
                     | FClosureName {runNow :: Bool, invert :: Bool}
                     | FArrWordsSize
                     | FFilterEras {runNow :: Bool, invert :: Bool}
                     | FFilterClosureType {invert :: Bool}
                     | FFilterClosureSize {invert :: Bool}
                     | FFilterCcId {runNow :: Bool, invert :: Bool}
                     | FProfile ProfileLevel
                     | FSnapshot
                     | FDumpArrWords
                     | FSetResultSize
                     deriving Show

-- | Profiling requirement for a command
data ProfilingReq
  = ReqSomeProfiling
  | ReqErasProfiling
  | NoReq

data Command = Command { commandDescription :: Text
                       , commandKey :: Maybe Vty.Event
                       , dispatchCommand :: Debuggee -> EventM Name OperationalState ()
                       , commandRequiresProfMode :: ProfilingReq
                       -- ^ The command requires that the debuggee is in a specific
                       -- profiling mode.
                       -- For example, we can only filter by eras if the program
                       -- has era profiling enabled.
                       }

mkCommand :: Text -> Vty.Event -> EventM Name OperationalState () -> Command
mkCommand desc ev dispatch = Command desc (Just ev) (\_ -> dispatch) NoReq

mkCommand' :: Text -> EventM Name OperationalState () -> Command
mkCommand' desc dispatch = Command desc Nothing (\_ -> dispatch) NoReq

mkFilterCmd :: Text -> Vty.Event -> EventM Name OperationalState () -> ProfilingReq -> Command
mkFilterCmd desc ev dispatch profMode = Command desc (Just ev) (\_ -> dispatch) profMode

mkFilterCmd' :: Text -> EventM Name OperationalState () -> ProfilingReq -> Command
mkFilterCmd' desc dispatch profMode = Command desc Nothing (\_ -> dispatch) profMode

isCmdEnabled :: GD.Version -> Command -> Bool
isCmdEnabled debuggeeVersion cmd = case commandRequiresProfMode cmd of
  NoReq -> True
  ReqErasProfiling ->
    Just GD.EraProfiling == GD.v_profiling debuggeeVersion
  ReqSomeProfiling ->
    GD.isProfiledRTS debuggeeVersion

isCmdDisabled :: GD.Version -> Command -> Bool
isCmdDisabled v cmd = not $ isCmdEnabled v cmd

data OverlayMode = KeybindingsShown
                 -- TODO: Abstract the "CommandPicker" into it's own module
                 | CommandPicker (Form Text () Name) (GenericList Name Seq Command) (Seq Command)
                 | NoOverlay


invertInput :: FooterInputMode -> FooterInputMode
invertInput x@FClosureAddress{invert} = x{invert = not invert}
invertInput x@FInfoTableAddress{invert} = x{invert = not invert}
invertInput x@FConstructorName{invert} = x{invert = not invert}
invertInput x@FClosureName{invert} = x{invert = not invert}
invertInput x@FFilterEras{invert} = x{invert = not invert}
invertInput x@FFilterClosureSize{invert} = x{invert = not invert}
invertInput x@FFilterClosureType{invert} = x{invert = not invert}
invertInput x@FFilterCcId{invert} = x{invert = not invert}
invertInput x = x

formatFooterMode :: FooterInputMode -> Text
formatFooterMode FClosureAddress{invert} = (if invert then "!" else "") <> "address (0x..): "
formatFooterMode FInfoTableAddress{invert} = (if invert then "!" else "") <> "info table pointer (0x..): "
formatFooterMode FConstructorName{invert} = (if invert then "!" else "") <> "constructor name: "
formatFooterMode FClosureName{invert} = (if invert then "!" else "") <> "closure name: "
formatFooterMode FFilterEras{invert} = (if invert then "!" else "") <> "era range (<era>/<start-era>-<end-era>): "
formatFooterMode FFilterClosureSize{invert} = (if invert then "!" else "") <> "closure size (bytes): "
formatFooterMode FFilterClosureType{invert} = (if invert then "!" else "") <> "closure type: "
formatFooterMode FFilterCcId{invert} = (if invert then "!" else "") <> "CC Id: "
formatFooterMode FArrWordsSize = "size (bytes)>= "
formatFooterMode FDumpArrWords = "dump payload to file: "
formatFooterMode FSetResultSize = "search result limit (0 for infinity): "
formatFooterMode FSnapshot = "snapshot name: "
formatFooterMode (FProfile {}) = "filename: "

data ConnectedMode
  -- | Debuggee is running
  = RunningMode
  -- | Debuggee is paused and we're exploring the heap
  | PausedMode { _pausedMode :: OperationalState }

data RootsOrigin = DefaultRoots [(Text, Ptr)]
                 | SearchedRoots [(Text, Ptr)]


currentRoots :: RootsOrigin -> [(Text, Ptr)]
currentRoots (DefaultRoots cp) = cp
currentRoots (SearchedRoots cp) = cp

data OperationalState = OperationalState
    { _running_task :: Maybe ThreadId
    , _last_run_time :: Maybe (Text, NominalDiffTime)
    , _treeMode :: TreeMode
    , _keybindingsMode :: OverlayMode
    , _footerMode :: FooterMode
    , _rootsFrom  :: RootsOrigin
    , _treeSavedAndGCRoots :: IOTree (ClosureDetails) Name
    -- ^ Tree corresponding to SavedAndGCRoots mode
    , _event_chan :: BChan Event
    , _resultSize :: Maybe Int
    , _filters :: [UIFilter]
    , _version :: GD.Version
    }

clearFilters :: OperationalState -> OperationalState
clearFilters os = os { _filters = [] }

setFilters :: [UIFilter] -> OperationalState -> OperationalState
setFilters fs os = os {_filters = fs}

addFilters :: [UIFilter] -> OperationalState -> OperationalState
addFilters fs os = os {_filters = fs ++ _filters os}

data UIFilter =
    UIAddressFilter Bool ClosurePtr
  | UIInfoAddressFilter Bool InfoTablePtr
  | UIConstructorFilter Bool String
  | UIInfoNameFilter Bool String
  | UIEraFilter Bool EraRange
  | UISizeFilter Bool Size
  | UIClosureTypeFilter Bool ClosureType
  | UICcId Bool Int64

uiFiltersToFilter :: [UIFilter] -> DebugM ClosureFilter
uiFiltersToFilter uifilters = do
  closFilters <- mapM uiFilterToFilter uifilters
  pure $ foldr AndFilter (PureFilter True) closFilters

uiFilterToFilter :: UIFilter -> DebugM ClosureFilter
uiFilterToFilter (UIAddressFilter invert x)     = pure $ AddressFilter (xor invert . (== x))
uiFilterToFilter (UIInfoAddressFilter invert x) = pure $ InfoPtrFilter (xor invert . (== x))
uiFilterToFilter (UIConstructorFilter invert x) = pure $ ConstructorDescFilter (xor invert . (== x) . name)
uiFilterToFilter (UIInfoNameFilter invert x)    = pure $ InfoSourceFilter (xor invert . (== x) . infoName)
uiFilterToFilter (UIEraFilter  invert x)        = pure $ ProfHeaderFilter (xor invert . (`profHeaderInEraRange` (Just x)))
uiFilterToFilter (UISizeFilter invert x)        = pure $ SizeFilter (xor invert . (>= x))
uiFilterToFilter (UIClosureTypeFilter invert x) = pure $ InfoFilter (xor invert . (== x) . tipe)
uiFilterToFilter (UICcId invert x)      = do
  ccsPtrs <- findAllChildrenOfCC ((x ==) . ccID)
  pure $ ProfHeaderFilter (xor invert . (`profHeaderReferencesCCS` ccsPtrs))

xor :: Bool -> Bool -> Bool
xor False False = False
xor True True = False
xor _ _ = True

parseEraRange :: Text -> Maybe EraRange
parseEraRange range = case T.splitOn "-" range of
  [nstr] -> case readMaybe (T.unpack nstr) of
    Just n -> Just $ EraRange n n
    Nothing -> Nothing
  [start,end] -> case (T.unpack start, T.unpack end) of
    ("", "") -> Just $ EraRange 0 maxBound
    ("", readMaybe -> Just e) -> Just $ EraRange 0 e
    (readMaybe -> Just s, "") -> Just $ EraRange s maxBound
    (readMaybe -> Just s, readMaybe -> Just e) -> Just $ EraRange s e
    _ -> Nothing
  _ -> Nothing

showEraRange :: EraRange -> String
showEraRange (EraRange s e)
  | s == e = show s
  | otherwise = "[" ++ show s ++ "," ++ go e
  where
    go n
      | n == maxBound = "∞)"
      | otherwise = show n ++ "]"

osSize :: OperationalState -> Int
osSize os = fromMaybe (Prelude.length (getIOTreeRoots $ _treeSavedAndGCRoots os)) $ treeLength (_treeMode os)

pauseModeTree :: (forall a . (a -> Widget Name) -> IOTree a Name -> r) -> OperationalState -> r
pauseModeTree k (OperationalState _ _ mode _kb _footer _from roots _ _ _ _) = case mode of
  SavedAndGCRoots render -> k render roots
  Retainer render r -> k render r
  Searched render r -> k render r

makeLenses ''AppState
makeLenses ''MajorState
makeLenses ''ClosureDetails
makeLenses ''ConnectedMode
makeLenses ''OperationalState
makeLenses ''SocketInfo
makeLenses ''OverlayMode