attic/hsedit
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

tab works now

Browse source
This commit is contained in:
Armin Friedl 2016-08-08 23:47:14 +02:00
parent f3f19592fc
commit 46d9c6e437
2 changed files with 30 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
hedit.cabal
View file

@ -66,7 +66,8 @@ executable hedit
microlens >=0.4 && <0.5, microlens-th >=0.4 && <0.5, microlens >=0.4 && <0.5, microlens-th >=0.4 && <0.5,
-- for Control.Monal.IO.Class -- for Control.Monal.IO.Class
transformers >=0.5 && <0.6, transformers >=0.5 && <0.6,
directory directory,
text-zipper
-- Directories containing source files. -- Directories containing source files.
hs-source-dirs: src, src/App hs-source-dirs: src, src/App

44
src/App/Gui.hs
View file

@ -20,6 +20,7 @@ import qualified Graphics.Vty as Vty
import Data.Text (pack, singleton, unpack) import Data.Text (pack, singleton, unpack)
import Data.Text.Markup (Markup, fromText, markupSet, toText, import Data.Text.Markup (Markup, fromText, markupSet, toText,
(@@)) (@@))
import qualified Data.Text.Zipper as TextZipper
---- Files ---- ---- Files ----
import System.Directory (doesFileExist) import System.Directory (doesFileExist)
@ -36,7 +37,7 @@ import Data.Maybe
import Data.Monoid (mempty, (<>)) import Data.Monoid (mempty, (<>))
import Data.String (fromString) import Data.String (fromString)
import Data.Tuple import Data.Tuple
import Lens.Micro ((^.)) import Lens.Micro ((%~), (&), (^.))
import Lens.Micro.TH (makeLenses) import Lens.Micro.TH (makeLenses)
@ -82,30 +83,29 @@ drawContent = markup . (createMarkup []) . unlines
-- add functions that return [(AttrName,Attr)] lists into foldl list -- add functions that return [(AttrName,Attr)] lists into foldl list
-- for additional attributes -- for additional attributes
getAttrMap :: AttrMap getAttrMap :: AttrMap
getAttrMap = foldl merge mainMap [Fontifier.fontMap] getAttrMap = foldl merge uiMap [Fontifier.fontMap]
where merge map list = applyAttrMappings list map -- just reverses arguments of apply where merge map list = applyAttrMappings list map -- just reverses arguments of apply
mainMap = attrMap Vty.defAttr [
(attrName "blackOnWhite", Vty.white `on` Vty.brightMagenta), uiMap :: AttrMap
(attrName "title", foldl Vty.withStyle (Vty.blue `on` Vty.brightYellow) uiMap = attrMap Vty.defAttr
[Vty.standout,Vty.bold, [ (attrName "blackOnWhite", Vty.white `on` Vty.brightMagenta)
Vty.blink]), , (attrName "title" , foldl Vty.withStyle (Vty.blue `on` Vty.brightYellow) [Vty.standout, Vty.bold])
(attrName "commands", Vty.white `on` Vty.magenta) , (attrName "commands" , Vty.white `on` Vty.magenta)
] ]
drawUI :: HeditState -> [Widget Names] drawUI :: HeditState -> [Widget Names]
drawUI st = stackTopDown [titleBar, title, titleBar, commands] ++ [editWidget] drawUI st = vBox [titleBar, title, titleBar, commands] : [editWidget]
-- the where is a bit ugly, for an intuitive understanding just don't look at it
where editWidget = padTop (Pad 5) $ EditWidget.renderEditor True (st^.hedit) where editWidget = padTop (Pad 5) $ EditWidget.renderEditor True (st^.hedit)
hBorder = BorderWidgets.hBorder hBorder = BorderWidgets.hBorder
commands = withAttr (attrName "commands") $ padLeft Max $ hBox [ str "^S" commands = withAttr (attrName "commands") $ padLeft Max $ hBox [ str "^S...Save"
, str "...Save"
, str " │ " , str " │ "
, str "^C/Esc" , str "^C/Esc...Quit "
, str "...Quit "
] ]
title = withAttr (attrName "title") $ CenterWidget.hCenter $ title = withAttr (attrName "title") $ CenterWidget.hCenter $ str "HEDIT - The Not So Fancy Editor"
str "HEDIT - The Not So Fancy Editor" titleBar = withAttr (attrName "title") $ CenterWidget.hCenter $ str " " -- creates an empty, colored bar
titleBar = withAttr (attrName "title") $ CenterWidget.hCenter $ str " " -- that spans the whole width
stackTopDown widgets = [vBox widgets] -- doesn't work with editor (at least i don't know how) -- 1 line high
appCursor :: HeditState -> [CursorLocation Names] -> Maybe (CursorLocation Names) appCursor :: HeditState -> [CursorLocation Names] -> Maybe (CursorLocation Names)
appCursor st c = Just (head c) appCursor st c = Just (head c)
@ -114,6 +114,7 @@ appEvent :: HeditState -> Vty.Event -> EventM Names (Next HeditState)
appEvent st ev appEvent st ev
| ev `elem` [esc, ctrl 'c'] = quit | ev `elem` [esc, ctrl 'c'] = quit
| ev == ctrl 's' = save >> BrickMain.continue st | ev == ctrl 's' = save >> BrickMain.continue st
| ev == tab = insertFourSpaces >>= BrickMain.continue
| otherwise = forwardToWidget >>= BrickMain.continue | otherwise = forwardToWidget >>= BrickMain.continue
-- forget about the where, you can safely assume that what the -- forget about the where, you can safely assume that what the
-- names suggest is what is done -- names suggest is what is done
@ -122,7 +123,16 @@ appEvent st ev
save = liftIO (writeFile (st^.file) (unlines $ EditWidget.getEditContents $ st^.hedit)) save = liftIO (writeFile (st^.file) (unlines $ EditWidget.getEditContents $ st^.hedit))
quit = halt st quit = halt st
forwardToWidget = handleEventLensed st hedit EditWidget.handleEditorEvent ev forwardToWidget = handleEventLensed st hedit EditWidget.handleEditorEvent ev
tab = Vty.EvKey (Vty.KChar '\t') []
insertFourSpaces = return $ insertString (replicate 4 ' ') st
-- just don't ask what this does --- inserts a string, returns the state. end of story.
insertString :: String -> HeditState -> HeditState
insertString string st = st & hedit %~ insertString' string -- uses some fancy lense magic
where insertString' [] e = e
insertString' (a:aa) e = insertString' aa $ insertChar
-- inserts char a returns resulting editor
where insertChar = EditWidget.applyEdit (TextZipper.insertChar a) e
drawHeditText :: [String] -> Widget n drawHeditText :: [String] -> Widget n
drawHeditText lines = makeWidget $ makeMarkup $ getFontification text drawHeditText lines = makeWidget $ makeMarkup $ getFontification text