{-# LANGUAGE RecordWildCards, ScopedTypeVariables, MultiParamTypeClasses, DeriveDataTypeable, StandaloneDeriving, GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- -- -- Module : Yi.UI.Pango.Control -- Copyright : 2007-2009 Jean-Philippe Bernardy, Hamish Mackenzie -- License : GPL -- -- | -- ----------------------------------------------------------------------------- module Yi.UI.Pango.Control ( Control(..) , ControlM(..) , Buffer(..) , View(..) , Iter(..) , newControl , runControl , newBuffer , newView , getBuffer , setBufferMode , withBuffer , setText , getText ) where import Prelude (map) import Data.List (drop, zip, take) import qualified Data.Rope as Rope import Yi hiding(withBuffer) import Yi.Window import Yi.Editor import Yi.Monad import Yi.Style import Yi.UI.Utils import Graphics.UI.Gtk as Gtk hiding(Point, Region) import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer (MonadIO(..)) import Control.Concurrent (newMVar, modifyMVar, MVar(..)) import Data.Typeable import qualified Data.List.PointedList as PL (insertRight) import Yi.Regex import System.FilePath data Control = Control { config :: Config , editor :: MVar Editor } newtype ControlM a = ControlM { runControl' :: ReaderT Control IO a } deriving (Monad, MonadReader Control, MonadIO, Typeable, Functor) instance MonadState Editor ControlM where get = readRef =<< editor <$> ask put v = flip modifyRef (const v) =<< editor <$> ask instance MonadEditor ControlM where askCfg = config <$> ask withEditor f = do r <- asks editor cfg <- asks config liftIO $ controlUnsafeWithEditor cfg r f controlUnsafeWithEditor :: Config -> MVar Editor -> EditorM a -> IO a controlUnsafeWithEditor cfg r f = modifyMVar r $ \e -> do let (e',a) = runEditor cfg f e -- Make sure that the result of runEditor is evaluated before -- replacing the editor state. Otherwise, we might replace e -- with an exception-producing thunk, which makes it impossible -- to look at or update the editor state. -- Maybe this could also be fixed by -fno-state-hack flag? -- TODO: can we simplify this? e' `seq` a `seq` return (e', a) data Buffer = Buffer { fBufRef :: BufferRef } data View = View { viewFBufRef :: BufferRef , windowRef :: WindowRef , drawArea :: DrawingArea , layout :: PangoLayout , scrollWin :: ScrolledWindow } data Iter = Iter { iterFBufRef :: BufferRef , point :: Point } newControl :: Config -> IO Control newControl config = do editor <- newMVar emptyEditor return Control {..} runControl :: ControlM a -> Control -> IO a runControl f s = runReaderT (runControl' f) s newBuffer :: BufferId -> String -> ControlM Buffer newBuffer id text = do fBufRef <- liftEditor $ stringToNewBuffer id $ Rope.fromString text return Buffer{..} newView :: Buffer -> ControlM View newView buffer = do control <- ask config <- askCfg let viewFBufRef = fBufRef buffer window <- fmap (\w -> w{height=50, winRegion = mkRegion (Point 0) (Point 2000)}) $ liftEditor $ newWindowE False viewFBufRef let windowRef = wkey window liftEditor $ modA windowsA (PL.insertRight window) drawArea <- liftIO $ drawingAreaNew context <- liftIO $ widgetCreatePangoContext drawArea layout <- liftIO $ layoutEmpty context liftIO $ layoutSetText layout "Test" liftIO $ drawArea `Gtk.onExpose` \event -> do (text, allAttrs, debug) <- runControl (liftEditor $ do modA buffersA (fmap (clearSyntax . clearHighlight)) let winh = height window let tos = max 0 (regionStart (winRegion window)) let bos = regionEnd (winRegion window) withGivenBufferAndWindow0 window viewFBufRef $ do -- tos <- getMarkPointB =<< fromMark <$> askMarks rope <- streamB Forward tos point <- pointB -- let (tos, point, text, picture) = do runBu -- from <- getMarkPointB =<< fromMark <$> askMarks -- rope <- streamB Forward from -- p <- pointB let content = fst $ Rope.splitAtLine winh rope -- allow BOS offset to be just after the last line let addNL = if Rope.countNewLines content == winh then id else (++"\n") sty = extractValue $ configTheme (configUI config) -- attributesPictureAndSelB sty (currentRegex e) (mkRegion tos bos) -- return (from, p, addNL $ Rope.toString content, picture) let text = addNL $ Rope.toString content picture <- attributesPictureAndSelB sty Nothing (mkRegion tos bos) -- add color attributes. let strokes = [(start',s,end') | ((start', s), end') <- zip picture (drop 1 (map fst picture) ++ [bos]), s /= emptyAttributes] rel p = fromIntegral (p - tos) allAttrs = concat $ do (p1, Attributes fg bg _rv bd itlc udrl, p2) <- strokes return $ [ AttrForeground (rel p1) (rel p2) (mkCol True fg) , AttrBackground (rel p1) (rel p2) (mkCol False bg) , AttrStyle (rel p1) (rel p2) (if itlc then StyleItalic else StyleNormal) , AttrUnderline (rel p1) (rel p2) (if udrl then UnderlineSingle else UnderlineNone) , AttrWeight (rel p1) (rel p2) (if bd then WeightBold else WeightNormal) ] return (text, allAttrs, (picture, strokes))) control putStrLn $ "Setting Layout Attributes " ++ show debug layoutSetAttributes layout allAttrs putStrLn "Done Stting Layout Attributes" dw <- widgetGetDrawWindow drawArea gc <- gcNew dw oldText <- layoutGetText layout when (text /= oldText) $ layoutSetText layout text drawLayout dw gc 0 0 layout return True scrollWin <- liftIO $ scrolledWindowNew Nothing Nothing liftIO $ scrolledWindowAddWithViewport scrollWin drawArea return View {..} where clearHighlight fb = -- if there were updates, then hide the selection. let h = getVal highlightSelectionA fb us = getVal pendingUpdatesA fb in highlightSelectionA ^= (h && null us) $ fb setBufferMode :: FilePath -> Buffer -> ControlM () setBufferMode f buffer = do let bufRef = fBufRef buffer -- adjust the mode tbl <- asks (modeTable . config) contents <- liftEditor $ withGivenBuffer0 bufRef $ elemsB let header = take 1024 contents hmode = case header =~ "\\-\\*\\- *([^ ]*) *\\-\\*\\-" of AllTextSubmatches [_,m] -> m _ -> "" Just mode = (find (\(AnyMode m)-> modeName m == hmode) tbl) <|> (find (\(AnyMode m)-> modeApplies m f contents) tbl) <|> Just (AnyMode emptyMode) case mode of AnyMode newMode -> do liftIO $ putStrLn $ show (f, header, modeName newMode) liftEditor $ withGivenBuffer0 bufRef $ setMode newMode withBuffer :: Buffer -> BufferM a -> ControlM a withBuffer Buffer{fBufRef = b} f = liftEditor $ withGivenBuffer0 b f getBuffer :: View -> Buffer getBuffer view = Buffer {fBufRef = viewFBufRef view} setText :: Buffer -> String -> ControlM () setText b text = withBuffer b $ do r <- regionOfB Document replaceRegionClever r text getText :: Buffer -> Iter -> Iter -> ControlM String getText b Iter{point = p1} Iter{point = p2} = withBuffer b $ readRegionB $ mkRegion p1 p2 mkCol :: Bool -- ^ is foreground? -> Yi.Style.Color -> Gtk.Color mkCol True Default = Color 0 0 0 mkCol False Default = Color maxBound maxBound maxBound mkCol _ (RGB x y z) = Color (fromIntegral x * 256) (fromIntegral y * 256) (fromIntegral z * 256)