module Yi.Types where
import Control.Applicative
import Control.Concurrent
import Control.Monad.Base
import Control.Monad.RWS.Strict (RWS, MonadWriter)
import Control.Monad.Reader
import Control.Monad.State
import qualified Data.DynamicState as ConfigState
import qualified Data.DynamicState.Serializable as DynamicState
import Data.Binary (Binary)
import qualified Data.Binary as B
import Data.Default
import qualified Data.DelayList as DelayList
import Data.Foldable
import Data.Function (on)
import Data.List.NonEmpty
import Data.List.PointedList
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Time
import Data.Traversable
import Data.Typeable
import Data.Word
#ifdef FRONTEND_VTY
import qualified Graphics.Vty as Vty
#endif
import Yi.Buffer.Basic (BufferRef, WindowRef)
import Yi.Buffer.Implementation
import Yi.Buffer.Undo
import Yi.Config.Misc
import Yi.Event
import qualified Yi.Interact as I
import Yi.KillRing
import Yi.Layout
import Yi.Monad
import Yi.Process (SubprocessInfo, SubprocessId)
import qualified Yi.Rope as R
import Yi.Style
import Yi.Style.Library
import Yi.Syntax
import Yi.Tab
import Yi.UI.Common
import Yi.Window
data Action = forall a. Show a => YiA (YiM a)
| forall a. Show a => EditorA (EditorM a)
| forall a. Show a => BufferA (BufferM a)
deriving Typeable
emptyAction :: Action
emptyAction = BufferA (return ())
class (Default a, Binary a, Typeable a) => YiVariable a
class (Default a, Typeable a) => YiConfigVariable a
instance Eq Action where
_ == _ = False
instance Show Action where
show (YiA _) = "@Y"
show (EditorA _) = "@E"
show (BufferA _) = "@B"
type Interact ev a = I.I ev Action a
type KeymapM a = Interact Event a
type Keymap = KeymapM ()
type KeymapEndo = Keymap -> Keymap
type KeymapProcess = I.P Event Action
data IsRefreshNeeded = MustRefresh | NoNeedToRefresh
deriving (Show, Eq)
data Yi = Yi { yiUi :: UI Editor
, yiInput :: [Event] -> IO ()
, yiOutput :: IsRefreshNeeded -> [Action] -> IO ()
, yiConfig :: Config
, yiVar :: MVar YiVar
}
deriving Typeable
data YiVar = YiVar { yiEditor :: !Editor
, yiSubprocessIdSupply :: !SubprocessId
, yiSubprocesses :: !(M.Map SubprocessId SubprocessInfo)
}
newtype YiM a = YiM {runYiM :: ReaderT Yi IO a}
deriving (Monad, Applicative, MonadReader Yi, MonadBase IO, Typeable, Functor)
instance MonadState Editor YiM where
get = yiEditor <$> (liftBase . readMVar =<< yiVar <$> ask)
put v = liftBase . flip modifyMVar_ (\x -> return $ x {yiEditor = v}) =<< yiVar <$> ask
instance MonadEditor YiM where
askCfg = yiConfig <$> ask
withEditor f = do
r <- asks yiVar
cfg <- asks yiConfig
liftBase $ unsafeWithEditor cfg r f
unsafeWithEditor :: Config -> MVar YiVar -> EditorM a -> IO a
unsafeWithEditor cfg r f = modifyMVar r $ \var -> do
let e = yiEditor var
let (e',a) = runEditor cfg f e
e' `seq` a `seq` return (var {yiEditor = e'}, a)
data KeymapSet = KeymapSet
{ topKeymap :: Keymap
, insertKeymap :: Keymap
}
extractTopKeymap :: KeymapSet -> Keymap
extractTopKeymap kms = forever (topKeymap kms)
newtype BufferM a = BufferM { fromBufferM :: RWS Window [Update] FBuffer a }
deriving (Monad, Functor, MonadWriter [Update], MonadState FBuffer, MonadReader Window, Typeable)
data IndentSettings = IndentSettings
{ expandTabs :: Bool
, tabSize :: Int
, shiftWidth :: Int
} deriving (Eq, Show, Typeable)
instance Applicative BufferM where
pure = return
(<*>) = ap
data FBuffer = forall syntax.
FBuffer { bmode :: !(Mode syntax)
, rawbuf :: !(BufferImpl syntax)
, attributes :: !Yi.Types.Attributes
}
deriving Typeable
instance Eq FBuffer where
(==) = (==) `on` bkey__ . attributes
type WinMarks = MarkSet Mark
data MarkSet a = MarkSet { fromMark, insMark, selMark :: !a }
deriving (Traversable, Foldable, Functor)
instance Binary a => Binary (MarkSet a) where
put (MarkSet f i s) = B.put f >> B.put i >> B.put s
get = liftM3 MarkSet B.get B.get B.get
data Attributes
= Attributes
{ ident :: !BufferId
, bkey__ :: !BufferRef
, undos :: !URList
, bufferDynamic :: !DynamicState.DynamicState
, preferCol :: !(Maybe Int)
, preferVisCol :: !(Maybe Int)
, pendingUpdates :: ![UIUpdate]
, selectionStyle :: !SelectionStyle
, keymapProcess :: !KeymapProcess
, winMarks :: !(M.Map WindowRef WinMarks)
, lastActiveWindow :: !Window
, lastSyncTime :: !UTCTime
, readOnly :: !Bool
, inserting :: !Bool
, directoryContent :: !Bool
, pointFollowsWindow :: !(WindowRef -> Bool)
, updateTransactionInFlight :: !Bool
, updateTransactionAccum :: ![Update]
, fontsizeVariation :: !Int
, encodingConverterName :: Maybe R.ConverterName
} deriving Typeable
instance Binary Yi.Types.Attributes where
put (Yi.Types.Attributes n b u bd pc pv pu selectionStyle_
_proc wm law lst ro ins _dc _pfw isTransacPresent transacAccum fv cn) = do
let putTime (UTCTime x y) = B.put (fromEnum x) >> B.put (fromEnum y)
B.put n >> B.put b >> B.put u >> B.put bd
B.put pc >> B.put pv >> B.put pu >> B.put selectionStyle_ >> B.put wm
B.put law >> putTime lst >> B.put ro >> B.put ins >> B.put _dc
B.put isTransacPresent >> B.put transacAccum >> B.put fv >> B.put cn
get = Yi.Types.Attributes <$> B.get <*> B.get <*> B.get <*>
B.get <*> B.get <*> B.get <*> B.get <*> B.get <*> pure I.End <*> B.get <*> B.get
<*> getTime <*> B.get <*> B.get <*> B.get
<*> pure (const False) <*> B.get <*> B.get <*> B.get <*> B.get
where
getTime = UTCTime <$> (toEnum <$> B.get) <*> (toEnum <$> B.get)
data BufferId = MemBuffer T.Text
| FileBuffer FilePath
deriving (Show, Eq, Ord)
instance Binary BufferId where
get = B.get >>= \case
(0 :: Word8) -> MemBuffer . E.decodeUtf8 <$> B.get
1 -> FileBuffer <$> B.get
x -> fail $ "Binary failed on BufferId, tag: " ++ show x
put (MemBuffer t) = B.put (0 :: Word8) >> B.put (E.encodeUtf8 t)
put (FileBuffer t) = B.put (1 :: Word8) >> B.put t
data SelectionStyle = SelectionStyle
{ highlightSelection :: !Bool
, rectangleSelection :: !Bool
} deriving Typeable
instance Binary SelectionStyle where
put (SelectionStyle h r) = B.put h >> B.put r
get = SelectionStyle <$> B.get <*> B.get
data AnyMode = forall syntax. AnyMode (Mode syntax)
deriving Typeable
data Mode syntax = Mode
{ modeName :: T.Text
, modeApplies :: FilePath -> R.YiString -> Bool
, modeHL :: ExtHL syntax
, modePrettify :: syntax -> BufferM ()
, modeKeymap :: KeymapSet -> KeymapSet
, modeIndent :: syntax -> IndentBehaviour -> BufferM ()
, modeAdjustBlock :: syntax -> Int -> BufferM ()
, modeFollow :: syntax -> Action
, modeIndentSettings :: IndentSettings
, modeToggleCommentSelection :: Maybe (BufferM ())
, modeGetStrokes :: syntax -> Point -> Point -> Point -> [Stroke]
, modeOnLoad :: BufferM ()
, modeModeLine :: [T.Text] -> BufferM T.Text
, modeGotoDeclaration :: BufferM ()
}
data IndentBehaviour =
IncreaseCycle
| DecreaseCycle
| IncreaseOnly
| DecreaseOnly
deriving (Eq, Show)
type Status = ([T.Text], StyleName)
type Statuses = DelayList.DelayList Status
data Editor = Editor
{ bufferStack :: !(NonEmpty BufferRef)
, buffers :: !(M.Map BufferRef FBuffer)
, refSupply :: !Int
, tabs_ :: !(PointedList Tab)
, dynamic :: !DynamicState.DynamicState
, statusLines :: !Statuses
, maxStatusHeight :: !Int
, killring :: !Killring
, currentRegex :: !(Maybe SearchExp)
, searchDirection :: !Direction
, pendingEvents :: ![Event]
, onCloseActions :: !(M.Map BufferRef (EditorM ()))
} deriving Typeable
newtype EditorM a = EditorM {fromEditorM :: ReaderT Config (State Editor) a}
deriving (Monad, Applicative, MonadState Editor,
MonadReader Config, Functor)
instance MonadEditor EditorM where
askCfg = ask
withEditor = id
#if __GLASGOW_HASKELL__ < 708
deriving instance Typeable1 EditorM
#else
deriving instance Typeable EditorM
#endif
class (Monad m, MonadState Editor m) => MonadEditor m where
askCfg :: m Config
withEditor :: EditorM a -> m a
withEditor f = do
cfg <- askCfg
getsAndModify (runEditor cfg f)
withEditor_ :: EditorM a -> m ()
withEditor_ = withEditor . void
runEditor :: Config -> EditorM a -> Editor -> (Editor, a)
runEditor cfg f e = let (a, e') = runState (runReaderT (fromEditorM f) cfg) e
in (e',a)
data UIConfig = UIConfig {
#ifdef FRONTEND_VTY
configVty :: Vty.Config,
#endif
configFontName :: Maybe String,
configFontSize :: Maybe Int,
configScrollStyle :: Maybe ScrollStyle,
configScrollWheelAmount :: Int,
configLeftSideScrollBar :: Bool,
configAutoHideScrollBar :: Bool,
configAutoHideTabBar :: Bool,
configLineWrap :: Bool,
configCursorStyle :: CursorStyle,
configWindowFill :: Char,
configTheme :: Theme
}
type UIBoot = Config -> ([Event] -> IO ())
-> ([Action] -> IO ()) -> Editor -> IO (UI Editor)
data CursorStyle = AlwaysFat
| NeverFat
| FatWhenFocused
| FatWhenFocusedAndInserting
data Config = Config {startFrontEnd :: UIBoot,
configUI :: UIConfig,
startActions :: [Action],
initialActions :: [Action],
defaultKm :: KeymapSet,
configInputPreprocess :: I.P Event Event,
modeTable :: [AnyMode],
debugMode :: Bool,
configRegionStyle :: RegionStyle,
configKillringAccumulate :: Bool,
configCheckExternalChangesObsessively :: Bool,
bufferUpdateHandler :: [[Update] -> BufferM ()],
layoutManagers :: [AnyLayoutManager],
configVars :: ConfigState.DynamicState
}
data RegionStyle = LineWise
| Inclusive
| Exclusive
| Block
deriving (Eq, Typeable, Show)
instance Binary RegionStyle where
put LineWise = B.put (0 :: Word8)
put Inclusive = B.put (1 :: Word8)
put Exclusive = B.put (2 :: Word8)
put Block = B.put (3 :: Word8)
get = B.get >>= \case
(0 :: Word8) -> return LineWise
1 -> return Inclusive
2 -> return Exclusive
3 -> return Block
n -> fail $ "Binary RegionStyle fail with " ++ show n
instance Default RegionStyle where
def = Inclusive
instance YiVariable RegionStyle