diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,7 @@ +# Changelog for tinytools-vty + +## [Unreleased] + +## [0.0.1] - alpha +### Added +- tinytools-vty just a test release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,19 @@ +# tinytools-vty + +`tinytools-vty` is a mono-space unicode diagram editor written in Haskell. It is currently a WIP and expect to have an beta release SOON. + +This repository contains the vty based view/controller implementation built on top of the [tinytools](https://github.com/pdlla/tinytools) model. + + +# running + +`cabal run tinytools-vty-exe` + +you may need to install ICU depuendencies to get things to compile + +# enabling unicode widechar support + +## NOT WORKING, WILL CRASH RANDOMLY IF YOU USE UNICODE WIDE CHARS 😨 (this is due to bugs in TextZipper module that I still need to fix) + +Unicode character display width seems to vary by terminal so you will need to generate a unicode width table file in order to enable support for unicode wide characters. +You can run `tinytools-vty` with the `--widthtable` arg to generate the table to your local config directory for the current terminal. Generating the table samples each unicode character inside the terminal and takes a few seconds to run. Please see the `Graphics.Vty.UnicodeWidthTable` module of the [vty](https://hackage.haskell.org/package/vty) for more info. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,145 @@ +{-# OPTIONS_GHC -threaded #-} + +module Main ( + main +) where + +import Relude + +import Potato.Flow +import Potato.Flow.TestStates +import Potato.Flow.TutorialState +import Potato.Flow.Vty.Main + + +import Control.Exception (try) +import GHC.IO.Handle +import Options.Applicative +import System.Directory +import System.FilePath +import System.IO hiding (putStrLn) + +import qualified Graphics.Vty as V +import qualified Graphics.Vty.UnicodeWidthTable.IO as V +import qualified Graphics.Vty.UnicodeWidthTable.Query as V + + + + +data PotatoCLIOptions = PotatoCLIOptions { + _potatoCLIOptions_args :: [String] + , _potatoCLIOptions_empty :: Bool + , _potatoCLIOptions_generateUnicodeWidthTable :: Bool +} + + +sample :: Parser PotatoCLIOptions +sample = PotatoCLIOptions + <$> many (argument str (metavar "FILE")) + <*> switch + ( long "empty" + <> short 'e' + <> help "open an empty document" ) + <*> switch + ( long "widthtable" + <> help "generate unicode width table for your terminal using vty" ) + + + +main :: IO () +main = mainWithDebug +--main = potatoMain +--main = layoutTestMain +--main = easyExample + +-- TODO add to https://hackage.haskell.org/package/ansi-terminal-0.11 +-- this won't work on Mac for whatever reason :( +pushTitleStack :: String +pushTitleStack = "\ESC[22;0t" +popTitleStack :: String +popTitleStack = "\ESC[23;0t" + + + + +mainWithDebug :: IO () +mainWithDebug = do + let + optsparser = info (sample <**> helper) + ( fullDesc + <> progDesc "optionally enter the filename you'd like to open" + <> header "tinytools-vty: an ASCII diagram editor" ) + + + opts <- execParser optsparser + + -- vty takes over stdout so this only will work with stderr + fd <- openFile "stderr.txt" WriteMode + hDuplicateTo fd stderr -- redirect stdout to file + hPutStrLn stderr "STDERR" -- will print to stderr + + -- pull/create config files + -- TODO finish config file stuff + --configPath <- getXdgDirectory XdgConfig "potato" + --createDirectoryIfMissing True configPath + --doesConfigExist <- doesFileExist (configPath "potato.config") + + + -- see if the argument file we passed in exists or not + minitfile <- if _potatoCLIOptions_empty opts + then + return Nothing + else case nonEmpty (_potatoCLIOptions_args opts) of + Nothing -> return Nothing + Just (x:|_) -> do + exists <- doesFileExist x + return $ if exists then Just x else Nothing + + if _potatoCLIOptions_generateUnicodeWidthTable opts + then do + mTermName <- V.currentTerminalName + case mTermName of + Just termName -> do + configdir <- tinytoolsConfigDir + let + fn = configdir (termName <> "_termwidthfile") + rslt <- try $ do + wt <- V.buildUnicodeWidthTable V.defaultUnicodeTableUpperBound + createDirectoryIfMissing False configdir + V.writeUnicodeWidthTable fn wt + case rslt of + Right _ -> do + putStrLn "\n" + putStrLn $ "successfully wrote " <> fn + exitSuccess + Left (SomeException e) -> do + putStrLn "\n" + die $ "failed to generate or write unicode width table " <> fn <> " with exception " <> show e + Nothing -> do + die "failed to generate unicode width table because could not obtain terminal name" + + else return () + + homeDir <- getHomeDirectory + let + config = MainPFWidgetConfig { + _mainPFWidgetConfig_initialFile = minitfile + , _mainPFWidgetConfig_homeDirectory = homeDir + , _mainPFWidgetConfig_initialState = if _potatoCLIOptions_empty opts + then (owlpfstate_newProject, emptyControllerMeta) + -- TODO load tutorial here owlpfstate_tutorial + --else owlpfstate_attachments1 + else tutorialState + } + + -- set the title + hPutStr stdout pushTitleStack + + potatoMainWidget $ mainPFWidget config + + -- unset the title + hPutStr stdout popTitleStack + -- TODO do this for mac + --hSetTitle stdout "" + + hClose fd diff --git a/app/termwidth.hs b/app/termwidth.hs new file mode 100644 --- /dev/null +++ b/app/termwidth.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -threaded #-} + +import Relude + +import Data.Maybe + +import qualified Graphics.Vty as V +import qualified Graphics.Vty.UnicodeWidthTable.IO as V +import qualified Graphics.Vty.UnicodeWidthTable.Query as V + + + +main :: IO () +main = do + mTermName <- V.currentTerminalName + let + widthMapFile = fromJust mTermName <> "_termwidthfile" + putStrLn $ "writing width for term: " <> show mTermName + table <- V.buildUnicodeWidthTable 'πŸ₯±' + V.writeUnicodeWidthTable widthMapFile table diff --git a/src/Data/String/Unicode/Lookup.hs b/src/Data/String/Unicode/Lookup.hs new file mode 100644 --- /dev/null +++ b/src/Data/String/Unicode/Lookup.hs @@ -0,0 +1,12 @@ +-- https://unicode.org/Public/UNIDATA/UnicodeData.txt + +module Data.String.Unicode.Lookup ( + +) where + + + + + +--unicodeData :: Text +--unicodeData = "" diff --git a/src/Potato/Flow/TutorialState.hs b/src/Potato/Flow/TutorialState.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Flow/TutorialState.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Potato.Flow.TutorialState (tutorialState) where + +import Relude + +import Potato.Flow + +import Data.ByteString +import qualified Data.ByteString.Lazy as LBS +import Data.FileEmbed (embedFile) + +import qualified Data.Text as T +import qualified Data.Aeson as Aeson +import Potato.Flow.TestStates + +tutorialState :: (OwlPFState, ControllerMeta) +tutorialState = fromMaybe (owlpfstate_newProject, emptyControllerMeta) . fmap (\(x, cm) -> (sPotatoFlow_to_owlPFState x, cm)) $ case Aeson.eitherDecode (LBS.fromStrict tutorialjson) of + --Left e -> error (T.pack e) -- Nothing + Left e -> Nothing + Right j -> Just j + +tutorialjson :: ByteString +tutorialjson = $(embedFile "tutorial.potato") + + + + diff --git a/src/Potato/Flow/Vty/Alert.hs b/src/Potato/Flow/Vty/Alert.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Flow/Vty/Alert.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +module Potato.Flow.Vty.Alert where + +import Relude + +import Potato.Flow +import Potato.Flow.Vty.Common +import Potato.Reflex.Vty.Helpers +import Potato.Flow.Vty.PotatoReader +import Potato.Flow.Vty.Attrs +import Potato.Reflex.Vty.Widget.FileExplorer +import Potato.Reflex.Vty.Widget.Popup + + +import Control.Monad.Fix +import qualified Data.Text as T + +import qualified Graphics.Vty as V +import Reflex +import Reflex.Potato.Helpers +import Reflex.Vty + +-- UNTESTED +popupAlert :: forall t m. (MonadWidget t m, HasPotato t m) + => Event t Text + -> m (Dynamic t Bool) -- ^ (popup state) +popupAlert alertEv = do + -- TODO style + let + fmapfn alert = \escEv clickOutsideEv -> do + okEv <- boxTitle (constant def) "😱ALERT😱" $ do + initLayout $ col $ do + (grout . stretch) 1 $ text (constant alert) + (grout . fixed) 3 $ textButton def (constant "OK") + return (leftmost [escEv, okEv], never) + fmap snd $ popupPane def $ (fmap fmapfn alertEv) diff --git a/src/Potato/Flow/Vty/AppKbCmd.hs b/src/Potato/Flow/Vty/AppKbCmd.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Flow/Vty/AppKbCmd.hs @@ -0,0 +1,51 @@ +module Potato.Flow.Vty.AppKbCmd where + +import Relude + +import Potato.Reflex.Vty.Helpers + +import Reflex +import Reflex.Vty +import qualified Graphics.Vty.Input.Events as V + +data AppKbCmd t = AppKbCmd { + _appKbCmd_save :: Event t () + , _appKbCmd_open :: Event t () + , _appKbCmd_print :: Event t () + , _appKbCmd_quit :: Event t () + , _appKbCmd_forceQuit :: Event t () + , _appKbCmd_new :: Event t () + , _appKbCmd_capturedInput :: Event t () +} + +holdAppKbCmd :: (MonadWidget t m) => m (AppKbCmd t) +holdAppKbCmd = do + inp <- input + + let + captureKeyWithCtrl c = fforMaybe inp $ \i -> case i of + V.EvKey (V.KChar c') [V.MCtrl] | c' == c -> Just () + _ -> Nothing + saveEv = captureKeyWithCtrl 's' + openEv = captureKeyWithCtrl 'o' + printEv = captureKeyWithCtrl 'p' + quitEv = captureKeyWithCtrl 'q' + newEv = captureKeyWithCtrl 'n' + + -- TODO this doesn't seem to work, prob cuz vty isn't handling shift correctly on mac + forceQuitEv = fforMaybe inp $ \i -> case i of + V.EvKey (V.KChar 'q') [V.MCtrl, V.MShift] -> Just () + V.EvKey (V.KChar 'q') [V.MShift, V.MCtrl] -> Just () + _ -> Nothing + + captureEv = leftmost [saveEv, openEv, quitEv, newEv, forceQuitEv] + + return $ AppKbCmd { + _appKbCmd_save = saveEv + , _appKbCmd_open = openEv + , _appKbCmd_print = printEv + , _appKbCmd_quit = quitEv + , _appKbCmd_forceQuit = forceQuitEv + , _appKbCmd_new = newEv + , _appKbCmd_capturedInput = captureEv + } diff --git a/src/Potato/Flow/Vty/Attrs.hs b/src/Potato/Flow/Vty/Attrs.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Flow/Vty/Attrs.hs @@ -0,0 +1,57 @@ + + +module Potato.Flow.Vty.Attrs where + + +import Relude + +import Potato.Flow.Controller.Handler + +import Graphics.Vty + + +lg_default :: Attr +lg_default = Attr { + attrStyle = SetTo defaultStyleMask + , attrForeColor = SetTo black + , attrBackColor = SetTo brightWhite + , attrURL = Default +} + +lg_textfield_normal :: Attr +lg_textfield_normal = lg_default `withBackColor` white + +lg_textfield_modifying :: Attr +lg_textfield_modifying = lg_textfield_normal + +lg_textfield_cursor :: Attr +lg_textfield_cursor = lg_default `withBackColor` black `withForeColor` white + + +lg_layer_inheritselect :: Attr +lg_layer_inheritselect = lg_default `withBackColor` white + +lg_layer_selected :: Attr +lg_layer_selected = lg_default `withStyle` standout + + +lg_manip :: Attr +lg_manip = lg_default `withStyle` blink `withBackColor` brightMagenta + +lg_canvas_cursor :: Attr +lg_canvas_cursor = lg_default `withStyle` blink `withBackColor` brightMagenta + +lg_canvas_default :: Attr +lg_canvas_default = lg_default + +lg_canvas_oob :: Attr +lg_canvas_oob = lg_default `withBackColor` white + +renderHandlerColorToVtyColor :: RenderHandleColor -> Color +renderHandlerColorToVtyColor = \case + RHC_Default -> brightMagenta + RHC_Attachment -> brightBlue + RHC_AttachmentHighlight -> brightCyan + +lg_make_canvas_cursor :: RenderHandleColor -> Attr +lg_make_canvas_cursor rhc = lg_default `withStyle` blink `withBackColor` (renderHandlerColorToVtyColor rhc) diff --git a/src/Potato/Flow/Vty/Canvas.hs b/src/Potato/Flow/Vty/Canvas.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Flow/Vty/Canvas.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +module Potato.Flow.Vty.Canvas ( + CanvasWidgetConfig(..) + , CanvasWidget(..) + , holdCanvasWidget +) where + + +import Relude + +import Potato.Flow +import Potato.Flow.Vty.Input +import Potato.Reflex.Vty.Helpers +import Potato.Flow.Vty.PotatoReader + +import qualified Data.Text as T +import qualified Data.List.Index as L +import Data.Tuple.Extra (thd3) + +import qualified Graphics.Vty as V +import Reflex +import Reflex.Vty + + +-- TODO why does this not handle wide chars correctly? +-- alternative text rendering methods that don't show spaces +textNoRenderSpaces + :: (HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) + => Behavior t Text + -> m () +textNoRenderSpaces t = do + bt <- theme + let img = (\a s -> [makeimages a s]) + <$> bt + <*> t + tellImages (fmap join img) + where + -- revout is of type [(Text, Int)] where the int is offset from BoL + foldlinefn (offset, spaces, revout) c = (offset+ (fromIntegral (getPCharWidth c)), newspaces, newrevout) where + (newspaces, newrevout) = if c == ' ' + then (spaces+1, revout) + else if spaces /= 0 + then (0, ([c], offset):revout) + else case revout of + (x,n):xs -> (0, (c:x,n):xs) + -- first character case + [] -> (0, [([c], 0)]) + makeimages th = + join + . L.imap (\i -> fmap (V.translateY i)) -- for each line, offset the image vertically + . fmap (fmap (\(txt,offset) -> V.translateX offset $ V.string th (reverse txt))) -- for each chunk and offset, convert to image + . fmap (thd3 . foldl' foldlinefn (0,0,[]) . T.unpack) -- for each line, split into chunks with offset + . T.split (=='\n') -- split into lines + +lBox_to_region :: LBox -> Region +lBox_to_region (LBox (V2 x y) (V2 w h)) = Region x y w h + +region_to_lBox :: Region -> LBox +region_to_lBox (Region x y w h) = (LBox (V2 x y) (V2 w h)) + +dynLBox_to_dynRegion :: (Reflex t) => Dynamic t LBox -> Dynamic t Region +dynLBox_to_dynRegion dlb = ffor dlb $ lBox_to_region + +{- DELETE ME +translate_dynRegion :: (Reflex t) => Dynamic t XY -> Dynamic t Region -> Dynamic t Region +translate_dynRegion dpos dr = ffor2 dpos dr $ \(V2 x y) region -> region { + _region_left = _region_left region + x + , _region_top = _region_top region + y + } +-} + +data CanvasWidgetConfig t = CanvasWidgetConfig { + _canvasWidgetConfig_pan :: Dynamic t XY + -- TODO DELETE + , _canvasWidgetConfig_broadPhase :: Dynamic t BroadPhaseState + , _canvasWidgetConfig_renderedCanvas :: Dynamic t RenderedCanvasRegion + , _canvasWidgetConfig_renderedSelection :: Dynamic t RenderedCanvasRegion + , _canvasWidgetConfig_canvas :: Dynamic t SCanvas + , _canvasWidgetConfig_handles :: Dynamic t HandlerRenderOutput +} + + +data CanvasWidget t = CanvasWidget { + _canvasWidget_mouse :: Event t LMouseData + , _canvasWidget_regionDim :: Event t XY +} + +holdCanvasWidget :: forall t m. (MonadWidget t m, HasPotato t m) + => CanvasWidgetConfig t + -> m (CanvasWidget t) +holdCanvasWidget CanvasWidgetConfig {..} = mdo + + potatostylebeh <- fmap _potatoConfig_style askPotato + + dh <- displayHeight + dw <- displayWidth + + -- ::draw the canvas:: + let + -- the screen region + screenRegion' = ffor2 dw dh (\w h -> LBox 0 (V2 w h)) + screenRegion = dynLBox_to_dynRegion screenRegion' + -- the screen region in canvas space + canvasScreenRegion' = fmap _renderedCanvasRegion_box _canvasWidgetConfig_renderedCanvas + + -- true region is the canvas region cropped to the panned screen (i.e. the intersection of screen and canvas in canvas space) + maybeCropAndPan pan scanvas screen = maybe (LBox 0 0) (translate_lBox pan) $ intersect_lBox screen (_sCanvas_box scanvas) + trueRegion' = ffor3 _canvasWidgetConfig_pan _canvasWidgetConfig_canvas canvasScreenRegion' maybeCropAndPan + trueRegion = dynLBox_to_dynRegion trueRegion' + oobRegions' = ffor2 screenRegion' trueRegion' $ \sc tr -> substract_lBox sc tr + oobRegions = fmap (fmap lBox_to_region) oobRegions' + + -- reg is in screen space so we need to translate back to canvas space by undoing the pan + renderRegionFn pan reg rc = renderedCanvasRegionToText (translate_lBox (-pan) (region_to_lBox reg)) rc + + -- same as renderRegionFn + debugRenderRegionFn pan reg rc = r where + txt = renderedCanvasRegionToText (translate_lBox (-pan) (region_to_lBox reg)) rc + --r = trace (T.unpack txt) txt + r = txt + + renderRegion dreg = pane dreg (constDyn False) $ do + text . current . ffor3 _canvasWidgetConfig_pan dreg _canvasWidgetConfig_renderedCanvas $ renderRegionFn + + + -- 1. render out of bounds region + localTheme (const (fmap _potatoStyle_canvas_oob potatostylebeh)) $ do + fill (constant ' ') + simpleList oobRegions renderRegion + return () + + -- 2. render the canvas region + renderRegion trueRegion + + -- 3. render the selection + localTheme (const (fmap _potatoStyle_selected potatostylebeh)) $ do + -- this version does not handle wide chars correctly + textNoRenderSpaces . current . ffor3 _canvasWidgetConfig_pan screenRegion _canvasWidgetConfig_renderedSelection $ debugRenderRegionFn + return () + + -- 4. render the handlers + let + makerhimage attr' (V2 px py) rh = r where + LBox (V2 x y) (V2 w h) = _renderHandle_box rh + rc = fromMaybe ' ' $ _renderHandle_char rh + attr = attr' -- TODO eventually RenderHandle may be styled somehow + r = V.translate (x+px) (y+py) $ V.charFill attr rc w h + tellImages $ ffor3 (current _canvasWidgetConfig_handles) (fmap _potatoStyle_makeCanvasManipulator potatostylebeh) (current _canvasWidgetConfig_pan) + $ \(HandlerRenderOutput hs) attrfn reg -> fmap (\rh -> makerhimage (attrfn (_renderHandle_color rh)) reg rh) hs + + inp <- makeLMouseDataInputEv (constDyn (0,0)) False + postBuildEv <- getPostBuild + + let + regionDimDyn = ffor2 dw dh V2 + regionDimEv = updated regionDimDyn + forceDimEv = pushAlways (\_ -> sample . current $ regionDimDyn) postBuildEv + + + return $ CanvasWidget inp (leftmost [regionDimEv, forceDimEv]) diff --git a/src/Potato/Flow/Vty/Common.hs b/src/Potato/Flow/Vty/Common.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Flow/Vty/Common.hs @@ -0,0 +1,186 @@ +-- TODO move to widget folder +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +module Potato.Flow.Vty.Common ( + ffilterButtonIndex + , oneLineButton + , buttonList + , radioList + , radioListSimple + , checkBox +) where + +import Relude +import qualified Relude.Unsafe as Unsafe + +import Potato.Flow.Vty.Attrs +import Potato.Reflex.Vty.Widget + +import Control.Monad.Fix +import Control.Monad.NodeId +import qualified Data.List.Index as L +import qualified Data.Text as T +import Data.Tuple.Extra + +import qualified Graphics.Vty as V +import Reflex +import Reflex.Vty + + + + +ffilterButtonIndex :: (Reflex t) => Int -> Event t Int -> Event t () +ffilterButtonIndex i = fmapMaybe (\i' -> if i == i' then Just () else Nothing) + + +maximumlist :: [Int] -> Int +maximumlist = foldr (\x y ->if x >= y then x else y) (-1) + +simpleDrag :: (Reflex t, MonadHold t m, MonadFix m, HasInput t m) => V.Button -> m (Event t ((Int, Int), (Int, Int))) +simpleDrag btn = do + dragEv <- drag2 btn + return $ flip push dragEv $ \(Drag2 (fromX, fromY) (toX, toY) _ _ ds) -> do + return $ if ds == DragEnd + then Just $ ((fromX, fromY), (toX, toY)) + else Nothing + +makeOneLineButtonImage :: V.Attr -> V.Attr -> ((Int,Int,Int), Text, Bool) -> V.Image +makeOneLineButtonImage defAttr downAttr ((x,y,_), t, downclickTODO) = V.translate x y $ V.text' attr ("["<>t<>"]") where + attr = if downclickTODO then downAttr else defAttr + + +oneLineButton :: forall t m. (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m) + => Behavior t (V.Attr, V.Attr) + -> Dynamic t Text -- ^ button content + -> m (Event t ()) -- ^ event when button is clicked +oneLineButton attrBeh buttonDyn = do + dw <- displayWidth + clickEv <- simpleDrag V.BLeft + let + selectEv = flip push clickEv $ \((px,py),(ex,ey)) -> do + t <- sample . current $ buttonDyn + let l = T.length t + 2 + return $ if py == 0 && ey == 0 && px >= 0 && ex >= 0 && px < l && ex < l + then Just () + else Nothing + + (defAttr, downAttr) <- sample attrBeh + + let + -- ((x,y,length), contents, downClickTODO) + buttonDyn' :: Dynamic t ((Int,Int,Int), Text, Bool) + buttonDyn' = ffor2 dw buttonDyn $ \w t -> ((0,0, T.length t + 2), t, False) + + -- TODO pass correct theme based on style + tellImages $ fmap (\b -> [makeOneLineButtonImage defAttr downAttr b]) $ current buttonDyn' + return $ selectEv + +-- TODO pass in sel and default attrs +-- | option to pass in height is a hack to work around circular dependency issues as when using Layout, displayWidth may be dependent on returned dynamic height +buttonList :: forall t m. (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasTheme t m) + => Dynamic t [Text] -- ^ list of button contents + -> Maybe (Dynamic t Int) -- ^ optional width (displayWidth is used if Nothing) + -> m (Event t Int, Dynamic t Int) -- ^ (event when button is clicked, height) +buttonList buttonsDyn mWidthDyn = do + dw <- case mWidthDyn of + Nothing -> displayWidth + Just widthDyn -> return widthDyn + clickEv <- simpleDrag V.BLeft + + -- TODO the better version of this highlights button on mouse down and "clicks" so long as you don't drag off the button + --dragPosDyn + --isDraggingDyn + + let + -- ((x,y,length), contents, downclickTODO) + buttons :: Dynamic t [((Int,Int,Int), Text, Bool)] + buttons = ffor2 dw buttonsDyn $ fn where + fn w bs = r where + mapaccumfn (x,y) t = ((nextx, ny), ((nx,ny,buttonl),t, False)) where + buttonl = T.length t + 2 + nextx' = x + buttonl + (nx,ny,nextx) = if nextx' > w then (0,y+1, buttonl) else (x,y, nextx') + (_,r) = mapAccumL mapaccumfn (0, 0) bs + + -- TODO replace with makeOneLineButtonImage + makeImage :: ((Int,Int,Int), Text, Bool) -> V.Image + makeImage ((x,y,_), t, downclickTODO) = V.translate x y $ V.text' attr ("["<>t<>"]") where + attr = if downclickTODO then lg_layer_selected else lg_default + heightDyn = fmap ((+1) . maximumlist . fmap (snd3 . fst3)) buttons + selectEv = flip push clickEv $ \((px,py),(ex,ey)) -> do + bs <- sample . current $ buttons + return $ L.ifindIndex (\_ ((x,y,l),_,_) -> py == y && ey == y && px >= x && ex >= x && px < x+l && ex < x+l) bs + tellImages $ fmap (fmap makeImage) $ current buttons + return $ (selectEv, heightDyn) + +-- TODO pass in sel and default attrs + +-- | option to pass in height is a hack to work around circular dependency issues as when using Layout, displayWidth may be dependent on returned dynamic height +-- override style: does not modify state internally, instead state must be passed back in +radioList :: forall t m. (Reflex t, MonadNodeId m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasTheme t m) + => Dynamic t [Text] -- ^ list of button contents + -> Dynamic t [Int] -- ^ which buttons are "active" + -> Maybe (Dynamic t Int) -- ^ optional width (displayWidth is used if Nothing) + -> m (Event t Int, Dynamic t Int) -- ^ (event when button is clicked, height) +radioList buttonsDyn activeDyn mWidthDyn = do + dw <- case mWidthDyn of + Nothing -> displayWidth + Just widthDyn -> return widthDyn + mouseDownEv <- mouseDown V.BLeft + let + -- ((x,y,length), contents) + buttons' :: Dynamic t [((Int,Int,Int), Text)] + buttons' = ffor2 dw buttonsDyn $ fn where + fn w bs = r where + mapaccumfn (x,y) t = ((nextx, ny), ((nx,ny,buttonl),t)) where + buttonl = T.length t + 2 + nextx' = x + buttonl + (nx,ny,nextx) = if nextx' > w then (0,y+1, buttonl) else (x,y, nextx') + (_,r) = mapAccumL mapaccumfn (0, 0) bs + buttons :: Dynamic t [((Int,Int,Int), Text, Bool)] + buttons = ffor2 buttons' activeDyn $ fn where + fn bs actives' = r where + actives = reverse $ sort actives' + ifoldrfn _ (l,t) (output, []) = ((l,t,False):output, []) + ifoldrfn i (l,t) (output, a:as) = if i == a + then ((l,t,True):output, as) + else ((l,t,False):output, a:as) + (r,_) = L.ifoldr ifoldrfn ([],actives) bs + makeImage :: ((Int,Int,Int), Text, Bool) -> V.Image + makeImage ((x,y,_), t, selected) = V.translate x y $ V.text' attr c where + attr = if selected then lg_layer_selected else lg_default + --c = if selected then "[" <> t <> "]" else " " <> t <> " " + c = "["<>t<>"]" + heightDyn = fmap ((+1) . maximumlist . fmap (snd3 . fst3)) buttons + selectEv = flip push mouseDownEv $ \(MouseDown _ (px,py) _) -> do + bs <- sample . current $ buttons + return $ L.ifindIndex (\_ ((x,y,l),_,_) -> py == y && px >= x && px < x+l) bs + tellImages $ fmap (fmap makeImage) $ current buttons + return $ (selectEv, heightDyn) + +-- TODO pass in sel and default attrs + +radioListSimple :: forall t m. (Reflex t, MonadFix m, MonadHold t m, MonadNodeId m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasTheme t m) + => Int -- ^ initial choice + -> [Text] -- ^ list of button contents (must be at least one) + -> m (Dynamic t Int) -- ^ which radio is selected +radioListSimple initial buttons = mdo + (radioEvs,_) <- radioList (constDyn buttons) radioDyn Nothing + radioDyn <- holdDyn [initial] $ fmap (\x->[x]) radioEvs + return $ fmap (Unsafe.head) radioDyn + + + +-- TODO focus + enter to select via keyboard +-- | creates a check box "[x]" in upper left corner of region +-- override style: does not modify state internally, instead state must be passed back in +checkBox + :: forall t m. (Reflex t, MonadFix m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasTheme t m) + => Dynamic t Bool + -> m (Event t Bool) +checkBox stateDyn = do + text (ffor (current stateDyn) (\s -> if s then "[x]" else "[ ]")) + mouseDownEv <- mouseDown V.BLeft + let toggleEv = fforMaybe mouseDownEv $ \(MouseDown _ (px,py) _) -> if px >= 0 && px < 3 && py == 0 then Just () else Nothing + return $ tag (current (fmap not stateDyn)) toggleEv diff --git a/src/Potato/Flow/Vty/Info.hs b/src/Potato/Flow/Vty/Info.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Flow/Vty/Info.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +module Potato.Flow.Vty.Info ( + InfoWidgetConfig(..) + , InfoWidget(..) + , holdInfoWidget +) where + +import Relude + +import Potato.Flow +import Potato.Reflex.Vty.Helpers + +import Reflex +import Reflex.Network +import Reflex.Vty + + + +data InfoWidgetConfig t = InfoWidgetConfig { + _infoWidgetConfig_selection :: Dynamic t Selection +} + +data InfoWidget t = InfoWidget { +} + +holdInfoWidget :: forall t m. (MonadWidget t m) + => InfoWidgetConfig t + -> m (InfoWidget t) +holdInfoWidget InfoWidgetConfig {..} = do + let + -- TODO read canvasSelection and figure out what the preset is + infoDyn = ffor _infoWidgetConfig_selection $ \selection@(SuperOwlParliament sowls) -> case () of + _ | isParliament_length selection == 0 -> return () + _ | isParliament_length selection > 1 -> text "many" + _ -> do + let + sowl = selectionToSuperOwl (CanvasSelection sowls) + rid = _superOwl_id sowl + label = hasOwlItem_name sowl + selt = superOwl_toSElt_hack sowl + initLayout $ col $ do + (grout . fixed) 1 $ text (constant ("rid: " <> show rid <> " name: " <> label)) + case selt of + SEltBox SBox {..} -> (grout . fixed) 1 $ text (constant (_sBoxText_text _sBox_text)) + _ -> (grout . fixed) 1 $ text (constant "something else") + + networkView infoDyn + + return InfoWidget {} diff --git a/src/Potato/Flow/Vty/Input.hs b/src/Potato/Flow/Vty/Input.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Flow/Vty/Input.hs @@ -0,0 +1,117 @@ + +module Potato.Flow.Vty.Input ( + convertModifiers + , convertKey + , convertButton + , makeLMouseDataInputEv +) where +import Relude + +import Potato.Flow +import Potato.Flow.Controller + +import qualified Graphics.Vty as V +import qualified Graphics.Vty.Input.Events as V +import Reflex +import Reflex.Vty + +import Control.Monad.Fix +import qualified Data.Text.Encoding as T + +convertModifiers :: [V.Modifier] -> [KeyModifier] +convertModifiers = fmap $ \case + V.MShift -> KeyModifier_Shift + V.MCtrl -> KeyModifier_Ctrl + V.MMeta -> KeyModifier_Ctrl + V.MAlt -> KeyModifier_Alt + +convertKey :: V.Key -> Maybe KeyboardKey +convertKey = \case + V.KEsc -> Just KeyboardKey_Esc + V.KChar c -> Just $ KeyboardKey_Char c + V.KBS -> Just KeyboardKey_Backspace + V.KEnter -> Just KeyboardKey_Return + V.KLeft -> Just KeyboardKey_Left + V.KRight -> Just KeyboardKey_Right + V.KUp -> Just KeyboardKey_Up + V.KDown -> Just KeyboardKey_Down + V.KUpLeft -> Nothing + V.KUpRight -> Nothing + V.KDownLeft -> Nothing + V.KDownRight -> Nothing + V.KCenter -> Nothing + V.KFun _ -> Nothing + V.KBackTab -> Nothing + V.KPrtScr -> Nothing + V.KPause -> Nothing + V.KIns -> Nothing + V.KHome -> Just KeyboardKey_Home + V.KDel -> Just KeyboardKey_Delete + V.KEnd -> Just KeyboardKey_End + V.KBegin -> Nothing + V.KMenu -> Nothing + -- disabled for now cuz I use for debugging + -- TODO enable + --V.KPageUp -> Just KeyboardKey_PageUp + --V.KPageDown -> Just KeyboardKey_PageDown + _ -> Nothing + + +convertButton :: V.Button -> Maybe MouseButton +convertButton = \case + V.BLeft -> Just MouseButton_Left + V.BMiddle -> Just MouseButton_Middle + V.BRight -> Just MouseButton_Right + V.BScrollUp -> Nothing + V.BScrollDown -> Nothing + +tupleToXY :: (Int, Int) -> XY +tupleToXY (x,y) = V2 x y + + +makeLMouseDataInputEv + :: (Reflex t, MonadFix m, MonadHold t m, HasInput t m) + => Dynamic t (Int, Int) + -> Bool + -> m (Event t LMouseData) +makeLMouseDataInputEv offsetDyn isLayerMouse = do + -- NOTE, must report both mouse down and up for any given drag or things will break + -- button/mods is always the same button as mouse down, even if it changes during a drag + inp <- input + + let + mouseDownEv = fforMaybe inp $ \case + V.EvMouseDown _ _ b mods -> Just (b, mods) + _ -> Nothing + -- tracks if last event was a mouse up + mouseUpEv = fforMaybe inp $ \case + V.EvMouseUp _ _ _ -> Just True + V.EvMouseDown _ _ _ _ -> Just False + _ -> Nothing + mouseDownFoldFn (True, x) _ = x -- only updated button/mods just after a mouse up + mouseDownFoldFn (False, _) x = x + mouseUpDyn <- holdDyn True mouseUpEv + mouseDownDyn <- foldDyn mouseDownFoldFn (V.BLeft,[]) (attach (current mouseUpDyn) mouseDownEv) + + return $ fforMaybe (attach (current ((,) <$> mouseDownDyn <*> offsetDyn)) inp) $ \case + (_, V.EvMouseDown _ _ V.BScrollUp _) -> Nothing + (_, V.EvMouseDown _ _ V.BScrollDown _) -> Nothing + ((_,offset), V.EvMouseDown x y b mods) -> case convertButton b of + Nothing -> Nothing + Just b' -> Just $ LMouseData { + _lMouseData_position = (V2 x y) + tupleToXY offset + , _lMouseData_isRelease = False + , _lMouseData_button = b' + , _lMouseData_modifiers = convertModifiers mods + , _lMouseData_isLayerMouse = isLayerMouse + } + (((b,mods),offset), V.EvMouseUp x y _) -> case convertButton b of + Nothing -> Nothing + Just b' -> Just $ LMouseData { + _lMouseData_position = (V2 x y) + tupleToXY offset + , _lMouseData_isRelease = True + , _lMouseData_button = b' + , _lMouseData_modifiers = convertModifiers mods + , _lMouseData_isLayerMouse = isLayerMouse + } + _ -> Nothing diff --git a/src/Potato/Flow/Vty/Layer.hs b/src/Potato/Flow/Vty/Layer.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Flow/Vty/Layer.hs @@ -0,0 +1,212 @@ + +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +module Potato.Flow.Vty.Layer ( + LayerWidgetConfig(..) + , LayerWidget(..) + , holdLayerWidget +) where + +import Relude + +import Potato.Flow +import Potato.Flow.Controller +import Potato.Flow.Vty.Attrs +import Potato.Flow.Vty.Input +import Potato.Reflex.Vty.Helpers +import Potato.Reflex.Vty.Widget +import Potato.Flow.Vty.PotatoReader +import Potato.Flow.Vty.Common +import Potato.Reflex.Vty.Widget.ScrollBar + + +import qualified Potato.Data.Text.Zipper +import Control.Monad.Fix +import Data.Align +import Data.Dependent.Sum (DSum ((:=>))) +import qualified Data.IntMap.Strict as IM +import qualified Data.List as L +import qualified Data.Sequence as Seq +import qualified Data.Text as T +import Data.Text.Zipper +import qualified Data.Text.Zipper as TZ +import Data.These + +import qualified Graphics.Vty as V +import Reflex +import Reflex.Network +import Reflex.Potato.Helpers +import Reflex.Vty + + + +-- | simple conversion function +-- potato-flow does not want to depend on reflex an has a coppy of TextZipper library but they are pretty much the same +coerceZipper :: Potato.Data.Text.Zipper.TextZipper -> TZ.TextZipper +coerceZipper (Potato.Data.Text.Zipper.TextZipper a b c d) = TZ.TextZipper a b c d + +--moveChar :: Char +--moveChar = '≑' +hiddenChar :: Char +hiddenChar = '-' +visibleChar :: Char +visibleChar = 'e' +lockedChar :: Char +lockedChar = '@' +unlockedChar :: Char +unlockedChar = 'a' +expandChar :: Char +expandChar = 'Β»' +closeChar :: Char +closeChar = 'β‡Š' + +{-# INLINE if' #-} +if' :: Bool -> a -> a -> a +if' True x _ = x +if' False _ y = y + + +data LayerWidgetConfig t = LayerWidgetConfig { + _layerWidgetConfig_layers :: Dynamic t LayersState + , _layerWidgetConfig_layersView :: Dynamic t LayersViewHandlerRenderOutput + , _layerWidgetConfig_selection :: Dynamic t Selection +} + +data LayerWidget t = LayerWidget { + _layerWidget_mouse :: Event t LMouseData + , _layerWidget_newFolderEv :: Event t () +} + +layerContents :: forall t m. (MonadWidget t m, HasPotato t m) + => LayerWidgetConfig t + -> Dynamic t (Int, Int) + -> m (Event t LMouseData) +layerContents LayerWidgetConfig {..} scrollDyn = do + + + potatostylebeh <- fmap _potatoConfig_style askPotato + PotatoStyle {..} <- sample potatostylebeh + + regionWidthDyn <- displayWidth + regionHeightDyn <- displayHeight + + + let + padBottom = 0 + listRegionDyn = ffor2 regionWidthDyn regionHeightDyn (,) + + + makeLayerImage :: Int -> LayersHandlerRenderEntry -> V.Image + makeLayerImage width lhrentry = case lhrentry of + LayersHandlerRenderEntryDummy ident -> r where + r = V.text' lg_layer_selected . T.pack . L.take width + $ replicate ident ' ' + <> replicate 10 '*' + LayersHandlerRenderEntryNormal selected mdots mrenaming lentry@LayerEntry{..} -> r where + ident = layerEntry_depth lentry + sowl = _layerEntry_superOwl + rid = _superOwl_id sowl + label = hasOwlItem_name sowl + + attr = case selected of + LHRESS_Selected -> _potatoStyle_selected + LHRESS_InheritSelected -> _potatoStyle_selected + LHRESS_ChildSelected -> _potatoStyle_layers_softSelected + _ -> _potatoStyle_normal + + -- TODO correct styles so they aren't confused with selected styles (you should add colors) + attrrenamingbg = _potatoStyle_layers_softSelected + attrrenamingcur = _potatoStyle_selected + + identn = case mdots of + Nothing -> ident + Just x -> x - 1 + + icon = case _owlItem_subItem (_superOwl_elt sowl) of + OwlSubItemFolder _ -> "𐃛" + OwlSubItemBox _ -> "⧈" + OwlSubItemLine _ -> "‑" + OwlSubItemTextArea _ -> "𐂂" + + t1 = V.text' attr . T.pack $ + + -- render identation and possible drop depth + replicate identn ' ' + <> replicate (min 1 (ident - identn)) '|' + <> replicate (max 0 (ident - identn - 1)) ' ' + + -- render folder hide lock icons + -- <> [moveChar] + <> if' (layerEntry_isFolder lentry) (if' _layerEntry_isCollapsed [expandChar] [closeChar]) [' '] + <> if' (lockHiddenStateToBool _layerEntry_hideState) [hiddenChar] [visibleChar] + <> if' (lockHiddenStateToBool _layerEntry_lockState) [lockedChar] [unlockedChar] + <> " " + <> icon + <> " " + + t2 = case mrenaming of + Nothing -> V.text' attr label + Just renaming -> img where + dls = TZ.displayLines 999999 attrrenamingbg attrrenamingcur (coerceZipper renaming) + img = V.vertCat . images $ TZ._displayLines_spans dls + + r = t1 V.<|> t2 + + layerImages :: Behavior t [V.Image] + layerImages = current $ fmap ((:[]) . V.vertCat) + $ ffor3 listRegionDyn (fmap _layersViewHandlerRenderOutput_entries _layerWidgetConfig_layersView) scrollDyn $ \(w,h) lhrentries scroll -> + map (makeLayerImage w) . L.take (max 0 (h - padBottom)) . L.drop (snd scroll) $ toList lhrentries + tellImages layerImages + + layerInpEv_d3 <- makeLMouseDataInputEv scrollDyn True + return layerInpEv_d3 + +holdLayerWidget :: forall t m. (MonadWidget t m, HasPotato t m) + => LayerWidgetConfig t + -> m (LayerWidget t) +holdLayerWidget lwc@LayerWidgetConfig {..} = do + + + + + potatostylebeh <- fmap _potatoConfig_style askPotato + PotatoStyle {..} <- sample potatostylebeh + + regionWidthDyn <- displayWidth + --regionHeightDyn <- displayHeight + + (layerInpEv, newFolderEv) <- initLayout $ col $ mdo + -- layer contents and scroll bar + layerInpEv_d1 <- (grout . stretch) 1 $ row $ mdo + + -- the layer list itself + (layerInpEv_d2, listRegionHeightDyn) <- (grout . stretch) 0 $ col $ do + listRegionHeightDyn_d1 <- displayHeight + layerInpEv_d3 <- layerContents lwc (fmap (\y -> (0,y)) vScrollDyn) + return (layerInpEv_d3, listRegionHeightDyn_d1) + + -- the vertical scroll bar + vScrollDyn <- (grout . fixed) 1 $ col $ do + let + contentSizeDyn = fmap ((+1) . Seq.length . _layersViewHandlerRenderOutput_entries) _layerWidgetConfig_layersView + vScrollBar contentSizeDyn + + return layerInpEv_d2 + + -- TODO horizontal scroll bar somedays + + -- buttons at the bottom + (newFolderEv_d1, heightDyn) <- (grout . fixed) heightDyn $ row $ do + (buttonsEv, heightDyn_d1) <- buttonList (constDyn ["new folder"]) (Just regionWidthDyn) + -- TODO new layer/delete buttons how here + -- TODO other folder options too maybe? + return (ffilterButtonIndex 0 buttonsEv, heightDyn_d1) + + return (layerInpEv_d1, newFolderEv_d1) + + + return $ LayerWidget { + _layerWidget_mouse = layerInpEv + , _layerWidget_newFolderEv = newFolderEv + } diff --git a/src/Potato/Flow/Vty/Left.hs b/src/Potato/Flow/Vty/Left.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Flow/Vty/Left.hs @@ -0,0 +1,202 @@ +-- TODO someday we will do dockable widget manager, but this is what yo uget for now + +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +module Potato.Flow.Vty.Left ( + LeftWidgetConfig(..) + , holdLeftWidget + , LeftWidget(..) + , MenuButtonsWidget(..) +) where +import Relude + + +import Potato.Flow +import Potato.Flow.Vty.Info +import Potato.Flow.Vty.Layer +import Potato.Flow.Vty.Params +import Potato.Flow.Vty.PotatoReader +import Potato.Flow.Vty.Tools +import Potato.Flow.Vty.ToolOptions +import Potato.Flow.Vty.Common +import Potato.Reflex.Vty.Helpers +import qualified Data.Text.IO as T + +import Reflex +import Reflex.Vty +import qualified Graphics.Vty as V + + +-- could put into a different file but whatever +data MenuButtonsWidget t = MenuButtonsWidget { + _menuButtonsWidget_newEv :: Event t () + , _menuButtonsWidget_openEv :: Event t () + , _menuButtonsWidget_saveEv :: Event t () + , _menuButtonsWidget_saveAsEv :: Event t () + , _menuButtonsWidget_exportEv :: Event t () + , _menuButtonsWidget_quitEv :: Event t () +} + +data LeftWidgetConfig t = LeftWidgetConfig { + -- TODO rename to _leftWidgetConfig_goatW + _layersWidgetConfig_goatW :: GoatWidget t + -- TODO other stuff +} + +data LeftWidget t = LeftWidget { + _leftWidget_layersW :: LayerWidget t + , _leftWidget_toolsW :: ToolWidget t + , _leftWidget_paramsW :: ParamsWidget t + , _leftWidget_menuButtonsW :: MenuButtonsWidget t + , _leftWidget_setFocusEvent :: Event t GoatFocusedArea + -- TODO other stuff +} + + +hdivider :: forall t m. (MonadWidget t m, HasLayout t m) => m () +hdivider = (grout. fixed) 1 $ fill (constant '-') + +-- | Mouse down events for a particular mouse button +mouseFocus + :: (Reflex t, Monad m, HasInput t m) + => m (Event t Bool) +mouseFocus = do + i <- input + return $ fforMaybe i $ \case + V.EvMouseDown _ _ _ _ -> Just True + _ -> Nothing + + +holdLeftWidget :: forall t m. (MonadWidget t m, HasPotato t m) + => LeftWidgetConfig t + -> m (LeftWidget t) +holdLeftWidget LeftWidgetConfig {..} = do + + widthDyn <- displayWidth + -- this will toggle true/fales as you click between left/canvas panels + -- this only works because you use splitHDrag to split the Left/Canvas panels (it toggles the focus) + focusDyn <- focus + let + + loseFocusEv = void $ ffilter (not . id) $ updated focusDyn + + initLayout $ col $ mdo + + + -- Menu + -- TODO height should be dynamic but not sure if there's away to do this dynamically because width (from which buttonsHeightDyn) is derived depends on `grout . fixed`. You need to pull width from outside of the `grout . fixed` call to make this work right... + (menuButtons, menuFocusEv, buttonsHeightDyn) <- (grout . fixed) buttonsHeightDyn $ row $ do + + (buttonsEv, heightDyn) <- buttonList (constDyn ["new", "open", "save", "save as", "export to \"potato.txt\"", "quit"]) (Just widthDyn) + let + exportEv = ffilterButtonIndex 4 buttonsEv + menuButtons' = MenuButtonsWidget { + _menuButtonsWidget_newEv = ffilterButtonIndex 0 buttonsEv + , _menuButtonsWidget_openEv = ffilterButtonIndex 1 buttonsEv + , _menuButtonsWidget_saveEv = ffilterButtonIndex 2 buttonsEv + , _menuButtonsWidget_saveAsEv = ffilterButtonIndex 3 buttonsEv + , _menuButtonsWidget_exportEv = exportEv + , _menuButtonsWidget_quitEv = ffilterButtonIndex 5 buttonsEv + } + clickPrintEv = tag (current $ _goatWidget_renderedCanvas _layersWidgetConfig_goatW) (void exportEv) + -- TODO don't do this here cmon... + performEvent_ $ ffor clickPrintEv $ \rc -> do + let t = renderedCanvasToText rc + -- TODO at least use filename... + liftIO $ T.writeFile "potato.txt" t + menuFocusEv' <- mouseFocus + return (menuButtons', menuFocusEv', heightDyn) + + + + hdivider + + -- Tools + (tools, toolsFocusEv) <- (grout . fixed) (_toolWidget_heightDyn tools) $ do + tools' <- holdToolsWidget $ ToolWidgetConfig { + _toolWidgetConfig_tool = _goatWidget_tool _layersWidgetConfig_goatW + , _toolWidgetConfig_widthDyn = widthDyn + } + toolsFocusEv' <- mouseFocus + return (tools', toolsFocusEv') + + -- ToolsOptions + -- doesn't do anything right now, just a stub + (toolOptions, toolsOptionsFocusEv) <- (grout . fixed) (_toolOptionsWidget_heightDyn toolOptions) $ do + toolsOptions' <- holdToolOptionsWidget $ ToolOptionsWidgetConfig { + _toolOptionsWidgetConfig_tool = _goatWidget_tool _layersWidgetConfig_goatW + , _toolOptionsWidgetConfig_widthDyn = widthDyn + } + toolsOptionsFocusEv' <- mouseFocus + return (toolsOptions', toolsOptionsFocusEv') + + hdivider + + -- Layers + (layers, layersFocusEv) <- (grout . stretch) 1 $ do + layers' <- holdLayerWidget $ LayerWidgetConfig { + _layerWidgetConfig_layers = _goatWidget_layers _layersWidgetConfig_goatW + , _layerWidgetConfig_layersView = _goatWidget_layersHandlerRenderOutput _layersWidgetConfig_goatW + , _layerWidgetConfig_selection = _goatWidget_selection _layersWidgetConfig_goatW + } + layersFocusEv' <- mouseFocus + return (layers', layersFocusEv') + + hdivider + + +{- + -- Info + infoFocusEv <- (grout . fixed) 5 $ do + holdInfoWidget $ InfoWidgetConfig { + _infoWidgetConfig_selection = _goatWidget_selection _layersWidgetConfig_goatW + } + mouseFocus + + hdivider +-} + let infoFocusEv = never + + -- Params + (params, paramsFocusEv) <- (grout . fixed) (_paramsWidget_widgetHeight params) $ do + params' <- holdParamsWidget $ ParamsWidgetConfig { + _paramsWidgetConfig_selectionDyn = _goatWidget_selection _layersWidgetConfig_goatW + , _paramsWidgetConfig_canvasDyn = _goatWidget_canvas _layersWidgetConfig_goatW + , _paramsWidgetConfig_defaultParamsDyn = _goatWidget_potatoDefaultParameters _layersWidgetConfig_goatW + , _paramsWidgetConfig_toolDyn = _goatWidget_tool _layersWidgetConfig_goatW + , _paramsWidgetConfig_loseFocusEv = loseFocusEv + } + paramsFocusEv' <- mouseFocus + return (params', paramsFocusEv') + + let + refinedFocusEv = leftmost + [ fmap (const "menu") menuFocusEv + , fmap (const "tools") toolsFocusEv + , fmap (const "toolsOptions") toolsOptionsFocusEv + , fmap (const "layers") layersFocusEv + , fmap (const "info") infoFocusEv + , fmap (const "params") paramsFocusEv + ] + + refinedFocusDyn <- holdDyn "none" refinedFocusEv + + let + setFocusDyn' = ffor2 focusDyn refinedFocusDyn $ \f1 f2 -> case (f1, f2) of + (True, "layers") -> Just GoatFocusedArea_Layers + (True, _) -> Just GoatFocusedArea_Other + -- right now, canvas is the only other choice, eventually there migh be more, in which case change this to Nothing + -- NOTE changing this to Nothing will break the rename via layers -> click on canvas case as currently Goat does not know how to resolve the layer rename handler without an explicit focus change + (False, _) -> Just GoatFocusedArea_Canvas + + setFocusDyn <- holdUniqDyn setFocusDyn' + + + return LeftWidget { + _leftWidget_layersW = layers + , _leftWidget_toolsW = tools + , _leftWidget_paramsW = params + , _leftWidget_menuButtonsW = menuButtons + , _leftWidget_setFocusEvent = fmapMaybe id (updated setFocusDyn) + } diff --git a/src/Potato/Flow/Vty/Main.hs b/src/Potato/Flow/Vty/Main.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Flow/Vty/Main.hs @@ -0,0 +1,445 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +module Potato.Flow.Vty.Main ( + potatoMainWidget + , mainPFWidget + , mainPFWidgetWithBypass + , MainPFWidgetConfig(..) + , somedefaultpfcfg + , tinytoolsConfigDir +) where +import Relude + + +import Potato.Flow +import Potato.Flow.TestStates +import Potato.Flow.Vty.Canvas +import Potato.Flow.Vty.Input +import Potato.Flow.Vty.Layer +import Potato.Flow.Vty.Params +import Potato.Flow.Vty.PotatoReader +import Potato.Flow.Vty.Tools +import Potato.Flow.Vty.Left +import Potato.Reflex.Vty.Helpers +import Potato.Reflex.Vty.Widget.Popup +import Potato.Reflex.Vty.Widget +import qualified Potato.Reflex.Vty.Host +import Potato.Flow.Vty.SaveAsWindow +import Potato.Flow.Vty.OpenWindow +import Potato.Flow.Vty.Alert +import Potato.Flow.Vty.AppKbCmd +import Potato.Flow.Vty.Attrs + +import System.Console.ANSI (hSetTitle) +import qualified System.FilePath as FP +import qualified System.Directory as FP + +import Control.Concurrent +import Control.Monad.NodeId +import Control.Exception (handle) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Encode.Pretty as PrettyAeson +import Data.Maybe +import Data.Default +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT +import qualified Data.Text.IO as T +import Data.Time.Clock +import qualified Data.ByteString.Lazy as LBS +import Data.These + + +import Network.HTTP.Simple + +import qualified Graphics.Vty as V +--import qualified Graphics.Vty.UnicodeWidthTable.IO as V +import Reflex +import Reflex.Potato.Helpers +import Reflex.Vty + + + +-- TODO move all this into Potato.Reflex.Vty.Host or something whatever +-- | Sets up the top-level context for a 'VtyWidget' and runs it with that context +potatoMainWidgetWithHandle + :: V.Vty + -> (forall t m. (Potato.Reflex.Vty.Host.MonadVtyApp t m + , HasImageWriter t m + , MonadNodeId m + , HasDisplayRegion t m + , HasFocusReader t m + , HasInput t m + , HasTheme t m) => m (Event t ())) + -> IO () +potatoMainWidgetWithHandle vty child = + Potato.Reflex.Vty.Host.runVtyAppWithHandle vty $ \dr0 inp -> do + size <- holdDyn dr0 $ fforMaybe inp $ \case + V.EvResize w h -> Just (w, h) + _ -> Nothing + let inp' = fforMaybe inp $ \case + V.EvResize {} -> Nothing + x -> Just x + (shutdown, imgs) <- runThemeReader (constant lg_default) $ + runFocusReader (pure True) $ + runDisplayRegion (fmap (\(w, h) -> Region 0 0 w h) size) $ + runImageWriter $ + runNodeIdT $ + runInput inp' $ do + tellImages . ffor (current size) $ \(w, h) -> [V.charFill lg_default ' ' w h] + child + return $ Potato.Reflex.Vty.Host.VtyResult + { _vtyResult_picture = fmap (V.picForLayers . reverse) imgs + , _vtyResult_shutdown = shutdown + } + + +tinytoolsConfigDir :: IO FP.FilePath +tinytoolsConfigDir = do + homedir <- FP.getHomeDirectory + return $ (homedir FP. ".tinytools/") + + +-- | run a VtyWidget using term width map written to disk with write-term-width for the current terminal +-- uses default if the file does not exist +potatoMainWidget + :: (forall t m. (Potato.Reflex.Vty.Host.MonadVtyApp t m + , HasImageWriter t m + , MonadNodeId m + , HasDisplayRegion t m + , HasFocusReader t m + , HasInput t m + , HasTheme t m) => m (Event t ())) + -> IO () +potatoMainWidget child = do + cfg'' <- V.standardIOConfig + configDir <- tinytoolsConfigDir + let + mTermName = V.termName cfg'' + widthMapFile = case mTermName of + Nothing -> "" + Just termName -> configDir FP. (termName <> "_termwidthfile") + doesWidthMapFileExist <- FP.doesFileExist widthMapFile + if doesWidthMapFileExist + then putStrLn $ "attempting to load unicode width table file " <> widthMapFile + else putStrLn $ "could not find unicode width table file " <> widthMapFile <> " please run --widthtable to generate unicode width table file" + let + cfg' = cfg'' { V.mouseMode = Just True } + cfg = if doesWidthMapFileExist + then cfg' { + V.allowCustomUnicodeWidthTables = Just True + , V.termWidthMaps = [(fromJust mTermName, widthMapFile)] + } + else cfg' + vty <- V.mkVty cfg + potatoMainWidgetWithHandle vty child + + +-- | tick once (redraw widgets) upon event firing +tickOnEvent :: (Adjustable t m) => Event t a -> m () +tickOnEvent ev = void $ runWithReplace (return ()) (ev $> return ()) + +-- | TODO move to ReflexHelpers +fanMaybe :: (Reflex t) => Event t (Maybe a) -> (Event t a, Event t ()) +fanMaybe ev = (fmapMaybe id ev, fmapMaybe fmapfn ev) where + fmapfn ma = case ma of + Nothing -> Just () + _ -> Nothing + +-- TODO move to Data.Either.Extra +maybeLeft :: Either a b -> Maybe a +maybeLeft (Left a) = Just a +maybeLeft _ = Nothing + +somedefaultpfcfg :: MainPFWidgetConfig +somedefaultpfcfg = def { + --_mainPFWidgetConfig_initialFile = Just "potato.flow" + _mainPFWidgetConfig_initialState = (owlpfstate_newProject, emptyControllerMeta) + } + +{- +verifyInput :: (Reflex t, MonadHold t m) => Event t VtyEvent -> m (Event t VtyEvent) +verifyInput ev = do + let + foldDynMaybeFn = \case + EvMouseDown _ _ _ _ -> Just True + EvMouseUp _ _ _ -> Just False + _ -> Nothing + isMouseDownDyn <- foldDynMaybe foldDynMaybeFn False ev + -- TODO check for invalid key presses based on mouse state +-} + +fetchMOTD :: IO Text +fetchMOTD = do + resp <- httpLBS "https://raw.githubusercontent.com/pdlla/tinytools-vty/potato/MOTD.txt" + return $ LT.toStrict $ LT.decodeUtf8 (getResponseBody resp) + +fetchMOTDAsync :: forall t m. (MonadWidget t m) => Event t () -> m (Event t Text) +fetchMOTDAsync ev = performEventAsync $ ffor ev $ const $ \f -> liftIO $ do + forkIO $ do + motd <- fetchMOTD + f motd + return () + +-- NOTE, this will query welcome message each time you recreate this +welcomeWidget :: forall t m. (MonadWidget t m) + => m (Event t ()) +welcomeWidget = do + postBuildEv <- getPostBuild + welcomeMessageEv <- fetchMOTDAsync postBuildEv + welcomeMessageDyn <- holdDyn "loading..." welcomeMessageEv + boxTitle (constant def) "😱😱😱" $ do + initLayout $ col $ do + (grout . stretch) 1 $ text (current welcomeMessageDyn) + (grout . fixed) 3 $ textButton def (constant "bye") + + + + +-- TODO DELETE OR MOVE UNUSED +-- | toggle the focus of a widget +-- also forces unfocused widget to ignore mouse inputs +focusWidgetNoMouse :: forall t m a. (MonadWidget t m) + => Dynamic t Bool -- ^ whether widget should be focused or not, note events that change focus are not captured! + -> m a + -> m a +focusWidgetNoMouse f child = do + localFocus (liftA2 (&&) f) $ + localInput (gate (current f)) $ + child + +-- TODO DELETE OR MOVE UNUSED +-- | ignores mouse input unless widget is focused +ignoreMouseUnlessFocused :: forall t m a. (MonadWidget t m) + => m a + -> m a +ignoreMouseUnlessFocused child = do + f <- focus + focusWidgetNoMouse f child + + + +-- | block all or some input events, always focused if parent is focused +captureInputEvents :: forall t m a. (MonadWidget t m) + => These (Event t ()) (Behavior t Bool) -- ^ This ev is event indicating input should be capture. That beh is behavior gating input (true means captured) + -> m a + -> m a +captureInputEvents capture child = do + let + (ev, beh) = fromThese never (constant False) capture + localInput (\inp -> difference (gate (fmap not beh) inp) ev) $ + child + +data MainPFWidgetConfig = MainPFWidgetConfig { + _mainPFWidgetConfig_initialFile :: Maybe FP.FilePath + , _mainPFWidgetConfig_homeDirectory :: FP.FilePath + -- should this include controller meta too? + , _mainPFWidgetConfig_initialState :: (OwlPFState, ControllerMeta) -- ^ will be overriden by initialFile if set +} + +instance Default MainPFWidgetConfig where + def = MainPFWidgetConfig { + _mainPFWidgetConfig_initialFile = Nothing + --, _mainPFWidgetConfig_homeDirectory = "/" + , _mainPFWidgetConfig_homeDirectory = "/home/minimaple/kitchen/faucet/potato-flow-vty" + , _mainPFWidgetConfig_initialState = (emptyOwlPFState, emptyControllerMeta) + } + +mainPFWidget :: forall t m. (MonadWidget t m) + => MainPFWidgetConfig + -> m (Event t ()) +mainPFWidget cfg = mainPFWidgetWithBypass cfg never + +mainPFWidgetWithBypass :: forall t m. (MonadWidget t m) + => MainPFWidgetConfig + -> Event t WSEvent + -> m (Event t ()) +mainPFWidgetWithBypass MainPFWidgetConfig {..} bypassEvent = mdo + -- external inputs + --currentTime <- liftIO $ getCurrentTime + + -- note tickEv triggers 2 ticks + --tickEv <- tickLossy 1 currentTime + --ticks <- foldDyn (+) (0 :: Int) (fmap (const 1) tickEv) + + --flowInput <- input >>= return . traceEvent "input: " + flowInput <- input + postBuildEv <- getPostBuild + + -- need this to force redraw of handles in some cases + tickOnEvent (updated . _goatWidget_selection $ everythingW) + + let + -- load file on start + -- TODO load file from open file dialog + tryOpenFileEv = leftmost [fforMaybe postBuildEv (const _mainPFWidgetConfig_initialFile), openFileEv] + + -- load file on start + mLoadFileEv <- performEvent $ ffor tryOpenFileEv + $ \fp -> do + absfp <- liftIO $ FP.makeAbsolute fp + mspf :: Maybe (SPotatoFlow, ControllerMeta) <- liftIO $ Aeson.decodeFileStrict absfp + return (mspf, absfp) + + -- empty project event + let + -- a little silly to route a new empty project through the load file event but it's easy whatever + newEmptyFileEv = fmap (const (owlPFState_to_sPotatoFlow owlpfstate_newProject, emptyControllerMeta)) _saveBeforeActionOutput_new + + + -- set the title + let + setOpenFileStateEv = updated $ ffor2 currentOpenFileDyn (_goatWidget_unsavedChanges everythingW) (,) + performEvent_ $ ffor setOpenFileStateEv $ \(mfn, dirty) -> do + -- this only seems to sometimes work πŸ€·πŸΌβ€β™€οΈ + liftIO $ hSetTitle stdout $ fromMaybe "<>" mfn <> (if dirty then "*" else "") + + + let + performSaveEv = attach (current $ _goatWidget_DEBUG_goatState everythingW) $ leftmost [saveAsEv, clickSaveEv] + saveSuccessEv = snd (fanEither finishSaveEv) + finishSaveEv <- performEvent $ ffor performSaveEv $ \(gs,fn) -> liftIO $ do + let + spf = owlPFState_to_sPotatoFlow . _owlPFWorkspace_owlPFState . _goatState_workspace $ gs + cm = ControllerMeta { + _controllerMeta_pan = _goatState_pan gs + , _controllerMeta_layers = _layersState_meta . _goatState_layersState $ gs + } + handle (\(SomeException e) -> return . Left $ "ERROR, Could not save to file " <> show fn <> " got exception \"" <> show e <> "\"") $ do + --liftIO $ Aeson.encodeFile "potato.flow" spf + --print $ "wrote to file: " <> fn + LBS.writeFile fn $ PrettyAeson.encodePretty (spf, cm) + --LBS.writeFile fn $ Aeson.encode (spf, cm) + return $ Right fn + + -- debug stuff (temp) + let + debugKeyEv' = fforMaybe flowInput $ \case + V.EvKey (V.KPageDown) [] -> Just () + _ -> Nothing + debugKeyEv = attach (current . fmap _goatState_handler . _goatWidget_DEBUG_goatState $ everythingW) debugKeyEv' + performEvent_ $ ffor debugKeyEv $ \(handler, _) -> do + liftIO $ do + T.hPutStr stderr $ pHandlerDebugShow handler + hFlush stderr + + -- application level hotkeys + AppKbCmd {..} <- captureInputEvents (That inputCapturedByPopupBeh) holdAppKbCmd + + -- setup PotatoConfig + currentOpenFileDyn <- holdDyn Nothing $ fmap Just $ leftmost [saveSuccessEv, fmap snd mLoadFileEv] + let + potatoConfig = PotatoConfig { + _potatoConfig_style = constant def + , _potatoConfig_appCurrentOpenFile = current currentOpenFileDyn + , _potatoConfig_appCurrentDirectory = fmap (maybe _mainPFWidgetConfig_homeDirectory FP.takeDirectory) $ current currentOpenFileDyn + -- TODO + , _potatoConfig_appPrintFile = constant Nothing + } + + goatWidgetConfig = GoatWidgetConfig { + _goatWidgetConfig_initialState = _mainPFWidgetConfig_initialState + , _goatWidgetConfig_load = leftmost [fmapMaybe fst mLoadFileEv, newEmptyFileEv] + + -- canvas direct input + , _goatWidgetConfig_mouse = leftmostWarn "mouse" [(_layerWidget_mouse (_leftWidget_layersW leftW)), (_canvasWidget_mouse canvasW)] + , _goatWidgetConfig_keyboard = keyboardEv + + , _goatWidgetConfig_canvasRegionDim = _canvasWidget_regionDim canvasW + + , _goatWidgetConfig_selectTool = _toolWidget_setTool (_leftWidget_toolsW leftW) + , _goatWidgetConfig_paramsEvent = _paramsWidget_paramsEvent (_leftWidget_paramsW leftW) + , _goatWidgetConfig_canvasSize = _paramsWidget_canvasSizeEvent (_leftWidget_paramsW leftW) + , _goatWidgetConfig_newFolder = _layerWidget_newFolderEv (_leftWidget_layersW leftW) + , _goatWidgetConfig_setPotatoDefaultParameters = _paramsWidget_setDefaultParamsEvent (_leftWidget_paramsW leftW) + , _goatWidgetConfig_markSaved = void saveSuccessEv + + , _goatWidgetConfig_setFocusedArea = _leftWidget_setFocusEvent leftW + + -- TODO + --, _goatWidgetConfig_unicodeWidthFn = + + -- debugging stuff + , _goatWidgetConfig_setDebugLabel = never + , _goatWidgetConfig_bypassEvent = bypassEvent + } + + everythingW <- holdGoatWidget goatWidgetConfig + + + + -- define main panels + let + leftPanel = holdLeftWidget LeftWidgetConfig { + _layersWidgetConfig_goatW = everythingW + } + + rightPanel = do + dreg' <- askRegion + let dreg = fmap (\region -> region { _region_left = 0, _region_top = 0}) dreg' + f <- focus + pane dreg f $ holdCanvasWidget $ CanvasWidgetConfig { + _canvasWidgetConfig_pan = _goatWidget_pan everythingW + , _canvasWidgetConfig_broadPhase = _goatWidget_broadPhase everythingW + , _canvasWidgetConfig_renderedCanvas = _goatWidget_renderedCanvas everythingW + , _canvasWidgetConfig_renderedSelection = _goatWidget_renderedSelection everythingW + , _canvasWidgetConfig_canvas = _goatWidget_canvas everythingW + , _canvasWidgetConfig_handles = _goatWidget_handlerRenderOutput everythingW + } + + -- render main panels + (keyboardEv, (leftW, canvasW)) <- flip runPotatoReader potatoConfig $ + captureInputEvents (These _appKbCmd_capturedInput inputCapturedByPopupBeh) $ do + stuff <- splitHDrag 35 (fill (constant '*')) leftPanel rightPanel + -- left panel may capture inputs, rigth panel never captures inputs + kb <- captureInputEvents (This (_paramsWidget_captureInputEv (_leftWidget_paramsW leftW))) $ do + inp <- input + return $ fforMaybe inp $ \case + V.EvKey k mods -> convertKey k >>= (\kbd -> return $ KeyboardData kbd (convertModifiers mods)) + V.EvPaste bs -> Just $ KeyboardData (KeyboardKey_Paste (T.decodeUtf8 bs)) [] + _ -> Nothing + + return (kb, stuff) + + let + (clickSaveEv, nothingClickSaveEv) = fanMaybe $ tag (_potatoConfig_appCurrentOpenFile potatoConfig) $ leftmost [_menuButtonsWidget_saveEv . _leftWidget_menuButtonsW $ leftW, _appKbCmd_save, _saveBeforeActionOutput_save] + clickSaveAsEv = leftmost $ [_menuButtonsWidget_saveAsEv . _leftWidget_menuButtonsW $ leftW, nothingClickSaveEv, _saveBeforeActionOutput_saveAs] + + -- TODO probably have some sort of PopupManager -__- + -- 1 welcome popup + --(_, popupStateDyn1) <- popupPaneSimple def (postBuildEv $> welcomeWidget) + (_, popupStateDyn1) <- popupPaneSimple def (never $> welcomeWidget) + + -- 2 save as popup + (saveAsEv, popupStateDyn2) <- flip runPotatoReader potatoConfig $ popupSaveAsWindow $ SaveAsWindowConfig (tag (_potatoConfig_appCurrentDirectory potatoConfig) clickSaveAsEv) + + -- TODO alert if mLoadFileEv fails (Nothing) + -- 3 alert popup + let + saveFailAlertEv = fmapMaybe maybeLeft finishSaveEv + popupStateDyn3 <- flip runPotatoReader potatoConfig $ popupAlert saveFailAlertEv + + -- 4 unsaved changes on action popup + (SaveBeforeActionOutput {..}, popupStateDyn4) <- flip runPotatoReader potatoConfig $ popupSaveBeforeExit $ + SaveBeforeActionConfig { + _saveBeforeActionConfig_unsavedChangesBeh = current $ _goatWidget_unsavedChanges everythingW + , _saveBeforeActionConfig_open = leftmost [_appKbCmd_open, _menuButtonsWidget_openEv . _leftWidget_menuButtonsW $ leftW] + , _saveBeforeActionConfig_new = leftmost [_appKbCmd_new, _menuButtonsWidget_newEv . _leftWidget_menuButtonsW $ leftW] + , _saveBeforeActionConfig_exit = leftmost [_appKbCmd_quit, _menuButtonsWidget_quitEv . _leftWidget_menuButtonsW $ leftW] + , _saveBeforeActionConfig_saveOutcomeEv = finishSaveEv + } + + -- 5 open popup + (openFileEv, popupStateDyn5) <- flip runPotatoReader potatoConfig $ popupOpenWindow $ OpenWindowConfig (tag (_potatoConfig_appCurrentDirectory potatoConfig) _saveBeforeActionOutput_open) + + + + let + -- TODO assert that we never have more than 1 popup open at once + -- block input if any popup is currently open + inputCapturedByPopupBeh = current . fmap getAny . mconcat . fmap (fmap Any) $ [popupStateDyn1, popupStateDyn2, popupStateDyn3, popupStateDyn4, popupStateDyn5] + + + -- handle escape event + return $ leftmost [_appKbCmd_forceQuit, _saveBeforeActionOutput_exit] diff --git a/src/Potato/Flow/Vty/OpenWindow.hs b/src/Potato/Flow/Vty/OpenWindow.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Flow/Vty/OpenWindow.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +module Potato.Flow.Vty.OpenWindow where + +import Relude + +import Potato.Flow +import Potato.Flow.Vty.Attrs +import Potato.Flow.Vty.Common +import Potato.Flow.Vty.PotatoReader +import Potato.Reflex.Vty.Helpers +import Potato.Reflex.Vty.Widget.FileExplorer +import Potato.Reflex.Vty.Widget.Popup + + +import Control.Monad.Fix +import Control.Monad.NodeId +import Data.Align +import Data.Char (isNumber) +import Data.Dependent.Sum (DSum ((:=>))) +import qualified Data.IntMap as IM +import qualified Data.List.Extra as L +import qualified Data.Maybe +import qualified Data.Sequence as Seq +import qualified Data.Text as T +import qualified Data.Text.Zipper as TZ +import Data.These +import Data.Tuple.Extra + +import qualified Graphics.Vty as V +import Reflex +import Reflex.Network +import Reflex.Potato.Helpers +import Reflex.Vty + +import qualified System.Directory as FP +import qualified System.FilePath as FP + +data OpenWindowConfig t = OpenWindowConfig { + _openWindowConfig_open :: Event t FP.FilePath -- ^ Event to launch the popup window to open file starting in the given directory +} + +popupOpenWindow :: forall t m. (MonadWidget t m, HasPotato t m) + => OpenWindowConfig t + -> m (Event t FP.FilePath, Dynamic t Bool) -- ^ (file to open, popup state) +popupOpenWindow OpenWindowConfig {..} = do + + potatostylebeh <- fmap _potatoConfig_style askPotato + + let + + popupOpenEv = ffor _openWindowConfig_open $ \d0 -> mdo + boxTitle (constant def) "Open" $ do + initManager_ $ col $ mdo + fewidget <- (tile . stretch) 3 $ holdFileExplorerWidget $ FileExplorerWidgetConfig { + _fileExplorerWidgetConfig_fileFilter = \fp -> FP.takeExtension fp == kTinyToolsFileExtension + , _fileExplorerWidgetConfig_initialFile = d0 + , _fileExplorerWidgetConfig_clickDownStyle = fmap _potatoStyle_layers_softSelected potatostylebeh + } + (cancelEv, openButtonEv) <- (tile . fixed) 3 $ row $ do + cancelEv' <- (tile . stretch) 10 $ textButton def "cancel" + + -- TODO grey out if filename is empty + openEv' <- (tile . stretch) 10 $ textButton def "open" + + return (cancelEv', openEv') + + let + -- do we really want to allow open on pressing enter? + openEv'' = leftmost [_fileExplorerWidget_returnOnfilename fewidget, _fileExplorerWidget_doubleClick fewidget, openButtonEv] + openEv' = tag (_fileExplorerWidget_fullfilename fewidget) openEv'' + openEv = fmap addTinyToolsFileExtensionIfNecessary openEv' + + return (cancelEv, openEv) + fmapfn w = \escEv clickOutsideEv -> fmap (\(cancelEv, outputEv) -> (leftmost [escEv, cancelEv, void outputEv], outputEv)) w + + localTheme (const $ fmap _potatoStyle_normal potatostylebeh) $ do + popupPane def $ (fmap fmapfn popupOpenEv) + diff --git a/src/Potato/Flow/Vty/Params.hs b/src/Potato/Flow/Vty/Params.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Flow/Vty/Params.hs @@ -0,0 +1,745 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +module Potato.Flow.Vty.Params ( + ParamsWidgetConfig(..) + , ParamsWidget(..) + , holdParamsWidget + + -- exposed for testing + , selectParamsFromSelection + , networkParamsWidgetOutputDynForTesting + , holdSuperStyleWidget +) where + +import Relude + +import Potato.Flow +import Potato.Flow.OwlHelpers +import Potato.Flow.Vty.Common +import Potato.Reflex.Vty.Helpers +import Potato.Flow.Vty.PotatoReader +import Potato.Flow.Vty.Attrs +import Potato.Reflex.Vty.Widget.TextInputHelpers + +import Control.Monad.Fix +import Control.Monad.NodeId +import Data.Align +import Data.Char (isNumber) +import Data.Dependent.Sum (DSum ((:=>))) +import qualified Data.IntMap as IM +import qualified Data.List.Extra as L +import qualified Data.Maybe +import qualified Data.Sequence as Seq +import qualified Data.Text as T +import qualified Data.Text.Zipper as TZ +import Data.These +import Data.Tuple.Extra +import qualified Data.List as List + +import qualified Graphics.Vty as V +import Reflex +import Reflex.Network +import Reflex.Potato.Helpers +import Reflex.Vty + +deriving instance Show FocusId + + +listForMi :: (Monad m) => [a] -> ((a, Int) -> m b) -> m [b] +listForMi x f = forM (zip x [0..]) f + +controllersWithId_to_llama :: ControllersWithId -> Llama +controllersWithId_to_llama = makePFCLlama . OwlPFCManipulate + + +paramsNavigation :: (MonadWidget t m) => m (Event t Int) +paramsNavigation = do + tabEv <- key (V.KChar '\t') + returnEv <- key V.KEnter + let fwd = fmap (const 1) $ leftmost [tabEv, returnEv] + back <- fmap (const (-1)) <$> key V.KBackTab + return $ leftmost [fwd, back] + +repeatNavigation :: (MonadWidget t m, HasFocus t m) => m () +repeatNavigation = do + navEv <- paramsNavigation + requestFocus $ Refocus_Shift <$> navEv + + +-- Maybe Params stuff + +-- | method type for picking out params from SuperSEltLabel +type ParamsSelector a = (Eq a) => SuperOwl -> Maybe a +-- | method type for picking out params when there is no selection +type DefaultParamsSelector a = PotatoDefaultParameters -> a +type ToolOverrideSelector = Tool -> Bool + + +toolOverrideTextAlign :: ToolOverrideSelector +toolOverrideTextAlign = (== Tool_Text) + +toolOverrideSuperStyle :: ToolOverrideSelector +toolOverrideSuperStyle = (\t -> t == Tool_Box || t == Tool_Text || t == Tool_Line || t == Tool_CartLine) + +toolOverrideLineStyle :: ToolOverrideSelector +toolOverrideLineStyle = (\t -> t == Tool_Line || t == Tool_CartLine) + +toolOverrideSBoxType :: ToolOverrideSelector +toolOverrideSBoxType = (const False) -- NOTE default variant here does nothing as this is always overriden based on tool + + +-- | method to extract common parameters from a selection +-- returns Nothing if nothing in the selection has the selected param +-- returns Just (selection, Nothing) if selection that has the selected param do not share the same value +selectParamsFromSelection :: (Eq a) => ParamsSelector a -> Selection -> Maybe (Selection, Maybe a) +selectParamsFromSelection ps (SuperOwlParliament selection) = r where + -- TODO don't do list conversion in between whataver ugh + params = catMaybes . toList . fmap (\sowl -> ps sowl >>= \a -> Just (sowl, a)) $ selection + values = fmap snd params + subSelection = SuperOwlParliament $ Seq.fromList $ fmap fst params + r = case values of + [] -> Nothing + x:xs -> if L.allSame values + then Just (subSelection, Just x) + else Just (subSelection, Nothing) + +makeParamsInputDyn :: (Eq a) => ToolOverrideSelector -> ParamsSelector a -> DefaultParamsSelector a -> Tool -> Selection -> PotatoDefaultParameters -> Maybe (Selection, Maybe a, Tool) +makeParamsInputDyn tooloverridef psf dpsf tool selection pdp = r where + r = if tooloverridef tool + then Just (selection, Just (dpsf pdp), tool) + else fmap (\(a,b) -> (a,b,tool)) $ selectParamsFromSelection psf selection + +-- similar to makeParamsInputDyn except specialized for LineStyle +-- LineStyle is special because it is split between start/end and we L.allSame on each end individually +makeLineStyleInputDyn :: Tool -> Selection -> PotatoDefaultParameters -> Maybe (Selection, Maybe (Maybe LineStyle, Maybe LineStyle), Tool) +makeLineStyleInputDyn tool selection pdp = r where + + selectLineStyleFromSelection :: Selection -> Maybe (Selection, Maybe (Maybe LineStyle, Maybe LineStyle)) + selectLineStyleFromSelection (SuperOwlParliament selection) = r_d1 where + ps = (\x -> (getSEltLineStyle x, getSEltLineStyleEnd x)) . superOwl_toSElt_hack + rawparams = ffilter (\(_,(x,y)) -> isJust x || isJust y) . fmap (\sowl -> (sowl, ps sowl)) $ selection + startvalues = catMaybes . toList . fmap fst . fmap snd $ rawparams + endvalues = catMaybes . toList . fmap snd . fmap snd $ rawparams + subSelection = SuperOwlParliament $ fmap fst rawparams + r_d1 = case (startvalues, endvalues) of + ([],[]) -> Nothing + (x:_, y:_) -> Just (subSelection, Just + (if L.allSame startvalues then Just x else Nothing, + if L.allSame endvalues then Just y else Nothing)) + + -- NOTE the outer maybe in `Maybe (Maybe LineStyle, Maybe LineStyle)` is redundant + -- should be joined into the inner `Maybe`s when used + r = if toolOverrideLineStyle tool + then Just (selection, Just (Just $ _potatoDefaultParameters_lineStyle pdp, Just $ _potatoDefaultParameters_lineStyleEnd pdp), tool) + else fmap (\(a,b) -> (a,b,tool)) $ selectLineStyleFromSelection selection + +type MaybeParamsWidgetOutputDyn t m b = Dynamic t (Maybe (m (Dynamic t Int, Event t (), Event t b))) +type ParamsWidgetOutputDyn t m b = Dynamic t (m (Dynamic t Int, Event t (), Event t b)) +-- if the `Maybe a` part is `Nothing` then the selection has different such properties +type ParamsWidgetFn t m a b = Dynamic t PotatoDefaultParameters -> Dynamic t (Selection, Maybe a, Tool) -> ParamsWidgetOutputDyn t m b + +networkParamsWidgetOutputDynForTesting :: (MonadWidget t m, HasPotato t m) => ParamsWidgetOutputDyn t m b -> m (Dynamic t Int, Event t (), Event t b) +networkParamsWidgetOutputDynForTesting p = do + out' <- networkView p + outHeightDyn <- holdDyn (constDyn 0) $ fmap fst3 out' + outCaptureEv <- switchHold never $ fmap snd3 out' + outEv <- switchHold never $ fmap thd3 out' + return (join outHeightDyn, outCaptureEv, outEv) + + +-- | +-- returned Dynamic contains Nothing if selection was Nothing, otherwise contains Just the widget to modify parameters +-- remember that input dynamic must not be disconnected from output event or there will be an infinite loop! +-- maybe use delayEvent :: forall t m a. (Adjustable t m) => Event t a -> m) (Event t a) 😱 +holdMaybeParamsWidget :: forall t m a b. (MonadWidget t m) + => Dynamic t PotatoDefaultParameters + -> Dynamic t (Maybe (Selection, Maybe a, Tool)) -- ^ selection/params input + -> ParamsWidgetFn t m a b -- ^ function creating widget, note that it should always return non-nothing but using Maybe type makes life easier + -> m (MaybeParamsWidgetOutputDyn t m b) +holdMaybeParamsWidget pdpDyn mInputDyn widgetFn = do + -- only remake the widget if it goes from Just to Nothing + uniqDyn <- holdUniqDynBy (\a b -> isJust a == isJust b) mInputDyn + return . join . ffor uniqDyn $ \case + Nothing -> constDyn Nothing + -- eh this is weird, fromMaybe should always succeed, maybe using fromJust is ok due to laziness but I don't care to find out + Just _ -> Just <$> widgetFn pdpDyn (fmap (fromMaybe (isParliament_empty, Nothing, Tool_Select)) mInputDyn) + +emptyWidget :: (Monad m) => m () +emptyWidget = return () + + + +-- SuperStyle stuff +data SuperStyleCell = SSC_TL | SSC_TR | SSC_BL | SSC_BR | SSC_V | SSC_H | SSC_Fill deriving (Show) + +updateFromSuperStyle :: SuperStyleCell -> (SuperStyle -> TZ.TextZipper) +updateFromSuperStyle ssc = TZ.top . TZ.fromText . T.singleton . gettfn ssc where + gettfn ssc' = fromMaybe ' ' . gettfn' ssc' + gettfn' = \case + SSC_TL -> _superStyle_tl + SSC_TR -> _superStyle_tr + SSC_BL -> _superStyle_bl + SSC_BR -> _superStyle_br + SSC_V -> _superStyle_vertical + SSC_H -> _superStyle_horizontal + SSC_Fill -> (\case + FillStyle_Simple c -> Just c + _ -> Nothing) . _superStyle_fill + + +makeSuperStyleTextEntry :: (MonadWidget t m, HasPotato t m) => SuperStyleCell -> Dynamic t (Maybe SuperStyle) -> m (Behavior t PChar) +makeSuperStyleTextEntry ssc mssDyn = do + mss0 <- sample . current $ mssDyn + let modifyEv = (fmap (maybe id (\ss -> const (updateFromSuperStyle ssc ss))) (updated mssDyn)) + ti <- singleCellTextInput modifyEv $ case mss0 of + Nothing -> "" + Just ss0 -> updateFromSuperStyle ssc ss0 + return . current . fmap (\t -> maybe ' ' (\(c,_) -> c) (T.uncons t)) $ ti + +makeSuperStyleEvent :: (Reflex t) + => Behavior t PChar + -> Behavior t PChar + -> Behavior t PChar + -> Behavior t PChar + -> Behavior t PChar + -> Behavior t PChar + -> Behavior t PChar + -> Event t () + -> Event t SuperStyle +makeSuperStyleEvent tl v bl h f tr br trig = pushAlways pushfn trig where + pushfn _ = do + tl' <- sample tl + v' <- sample v + bl' <- sample bl + h' <- sample h + f' <- sample f + tr' <- sample tr + br' <- sample br + return $ def { + -- TODO Nothing is text cell was blank... + _superStyle_tl = Just tl' + , _superStyle_tr = Just tr' + , _superStyle_bl = Just bl' + , _superStyle_br = Just br' + , _superStyle_vertical = Just v' + , _superStyle_horizontal = Just h' + --, _superStyle_point :: PChar + , _superStyle_fill = FillStyle_Simple f' + } + +-- TODO move to SELts.hs +presetSuperStyles :: [[Char]] +presetSuperStyles = ["β•”β•—β•šβ•β•‘β• ","****|- ", "β–ˆβ–ˆβ–ˆβ–ˆβ–ˆβ–ˆ ", "β”Œβ”β””β”˜β”‚β”€ "] + +holdSuperStyleWidget :: forall t m. (MonadLayoutWidget t m, HasPotato t m) => ParamsWidgetFn t m SuperStyle (Either Llama SetPotatoDefaultParameters) +holdSuperStyleWidget pdpDyn inputDyn = constDyn $ mdo + + do + (grout . fixed) 1 $ text "style:" + typeChoiceDyn <- (grout . stretch) 1 $ radioListSimple 0 ["custom", "presets"] + + setStyleEvEv <- networkView $ ffor typeChoiceDyn $ \case + 1 -> do + setStyleEv' <- do + presetClicks <- listForMi presetSuperStyles $ \(s,i) -> (grout . fixed) 1 $ row $ (grout . stretch) 1 $ do + -- TODO highlight if style matches selection + text (show i <> ". " <> constant (T.pack s)) + fmap (fmap (\_ -> s)) (mouseDown V.BLeft) + return $ fmap superStyle_fromListFormat (leftmost presetClicks) + return (5, never, setStyleEv') + 0 -> do + -- TODO the awesome version of this has a toggle box so that you can choose to do horiz/vertical together (once you support separate horiz/vert left/right/top/down styles) + -- TODO also a toggle for setting corners to common sets + let + mssDyn = fmap snd3 inputDyn + + (focusDyn,tl,v,bl,h,f,tr,br) <- do + --(tile . fixed) 1 $ text (fmap (T.pack . superStyle_toListFormat . Data.Maybe.fromJust) $ current mssDyn) + (tl'',h'',tr'') <- (grout . fixed) 1 $ row $ do + tl' <- (tile . fixed) 1 $ makeSuperStyleTextEntry SSC_TL mssDyn + h' <- (tile . fixed) 1 $ makeSuperStyleTextEntry SSC_H mssDyn + tr' <- (tile . fixed) 1 $ makeSuperStyleTextEntry SSC_TR mssDyn + return (tl',h',tr') + (v'',f'') <- (grout . fixed) 1 $ row $ do + v' <- (tile . fixed) 1 $ makeSuperStyleTextEntry SSC_V mssDyn + f' <- (tile . fixed) 1 $ makeSuperStyleTextEntry SSC_Fill mssDyn + _ <- (grout . fixed) 1 $ emptyWidget -- TODO you can modify this too, why not, 2 boxes for the same thing + return (v',f') + (bl'',br'') <- (grout . fixed) 1 $ row $ do + bl' <- (tile . fixed) 1 $ makeSuperStyleTextEntry SSC_BL mssDyn + _ <- (grout . fixed) 1 $ emptyWidget -- TODO you can modify this too, why not, 2 boxes for the same thing + br' <- (tile . fixed) 1 $ makeSuperStyleTextEntry SSC_BR mssDyn + return (bl',br') + focusDyn' <- focusedId + return (focusDyn',tl'',v'',bl'',h'',f'',tr'',br'') + captureEv1 <- makeCaptureFromUpdateTextZipperMethod updateTextZipperForSingleCharacter + + focusDynUnique <- holdUniqDyn focusDyn + + let + -- TODO maybe just do it when any of the cell dynamics are updated rather than when focus changes... + -- TODO if we do it on focus change, you don't want to set when escape is pressed... so maybe it's better just to do πŸ–• + setStyleEv' = makeSuperStyleEvent tl v bl h f tr br (void $ updated focusDynUnique) + captureEv' = leftmost [void setStyleEv', captureEv1] + return (5, captureEv', setStyleEv') + + setStyleEv <- switchHold never (fmap thd3 setStyleEvEv) + captureEv <- switchHold never (fmap snd3 setStyleEvEv) + heightDyn <- holdDyn 0 (fmap fst3 setStyleEvEv) + + let + selectionDyn = fmap fst3 inputDyn + pushSuperStyleFn :: SuperStyle -> PushM t (Maybe (Either Llama SetPotatoDefaultParameters)) + pushSuperStyleFn ss = do + (SuperOwlParliament selection, _, tool) <- sample . current $ inputDyn + pdp <- sample . current $ pdpDyn + let + fmapfn sowl = case getSEltLabelSuperStyle (superOwl_toSEltLabel_hack sowl) of + Nothing -> Nothing + Just oldss -> if oldss == ss + then Nothing + else Just (_superOwl_id sowl, CTagSuperStyle :=> Identity (CSuperStyle (DeltaSuperStyle (oldss, ss)))) + return $ if toolOverrideSuperStyle tool + then if _potatoDefaultParameters_superStyle pdp == ss + then Nothing + else Just . Right $ def { _setPotatoDefaultParameters_superStyle = Just ss } + else case Data.Maybe.mapMaybe fmapfn . toList $ selection of + [] -> Nothing + x -> Just . Left . controllersWithId_to_llama $ IM.fromList x + ssparamsEv = push pushSuperStyleFn setStyleEv + return (heightDyn, captureEv, ssparamsEv) + +data LineStyleCell = LSC_L | LSC_R | LSC_U | LSC_D + +updateFromLineStyle :: LineStyleCell -> (LineStyle -> TZ.TextZipper) +updateFromLineStyle lsc = TZ.top . TZ.fromText . gettfn lsc where + gettfn = \case + LSC_L -> _lineStyle_leftArrows + LSC_R -> _lineStyle_rightArrows + LSC_U -> _lineStyle_upArrows + LSC_D -> _lineStyle_downArrows + +makeLineStyleEvent :: (Reflex t) + => Behavior t Text + -> Behavior t Text + -> Behavior t Text + -> Behavior t Text + -> Event t () + -> Event t LineStyle +makeLineStyleEvent l r u d trig = pushAlways pushfn trig where + pushfn _ = do + l' <- sample l + r' <- sample r + u' <- sample u + d' <- sample d + return $ def { + _lineStyle_leftArrows = l' + , _lineStyle_rightArrows = r' + , _lineStyle_upArrows = u' + , _lineStyle_downArrows = d' + } + +-- TODO someday do backwards expanding text entry boxes for LSC_R and LSC_D +makeLineStyleTextEntry :: (MonadWidget t m, HasPotato t m) => LineStyleCell -> Dynamic t (Maybe LineStyle) -> m (Dynamic t Text) +makeLineStyleTextEntry lsc mlsDyn = do + mls0 <- sample . current $ mlsDyn + let modifyEv = (fmap (maybe id (\ss -> const (updateFromLineStyle lsc ss))) (updated mlsDyn)) + -- TODO need to use different text input type + ti <- singleCellTextInput modifyEv $ case mls0 of + Nothing -> "" + Just ls0 -> updateFromLineStyle lsc ls0 + return ti + + +-- TODO move to SELts.hs +presetLineStyles :: [([Char], [Char], [Char], [Char])] +presetLineStyles = [("","","",""), ("<",">","^","v"), ("⇦","⇨","⇧","⇩")] + +presetLineStyle_toText :: ([Char], [Char], [Char], [Char]) -> Text +presetLineStyle_toText (l,r,u,d) = T.pack $ l <> " " <> r <> " " <> u <> " " <> d + + +leftmostEither :: (Reflex t) => Event t a -> Event t b -> Event t (Either a b) +leftmostEither eva evb = leftmost [(fmap Left eva), (fmap Right evb)] + +-- TODO lineystel widget should be like this +-- [x] start | [x] end (the one being modified is highlighted) +-- custom | preset +-- .... +holdLineStyleWidgetNew :: forall t m. (MonadLayoutWidget t m, HasPotato t m) => ParamsWidgetFn t m (Maybe LineStyle, Maybe LineStyle) (Either Llama SetPotatoDefaultParameters) +holdLineStyleWidgetNew pdpDyn inputDyn = constDyn $ do + + potatostylebeh <- fmap _potatoConfig_style askPotato + + let buttonAttrBeh = ffor potatostylebeh (\ps -> (_potatoStyle_normal ps, _potatoStyle_selected ps)) + + (grout . fixed) 1 $ text "line end style:" + -- TODO in the future, we'd like to be able to disable line ends more easily (without going into presets) + -- i.e. [x] start | [x] end + -- alternatively, consider combining with super sytyle + (endChoiceDyn, flipButtonEv) <- (grout . fixed) 1 $ row $ do + endChoiceDyn' <- col $ (grout . fixed) 17 $ radioListSimple 0 ["both", "start", "end"] + flipButtonEv' <- col $ (grout . stretch) 1 $ oneLineButton buttonAttrBeh "flip" + return (endChoiceDyn', flipButtonEv') + typeChoiceDyn <- (grout . stretch) 1 $ radioListSimple 0 ["custom", "presets"] + + setStyleEvEv <- do + networkView $ ffor2 typeChoiceDyn endChoiceDyn $ \tc' ec' -> case (tc', ec') of + (1, _) -> do + setStyleEv' <- do + presetClicks <- listForMi presetLineStyles $ \(s, i) -> (grout . fixed) 1 $ row $ (grout . stretch) 1 $ do + -- TODO highlight if style matches selection + text (constant (show i <> ". " <> presetLineStyle_toText s)) + fmap (fmap (\_ -> s)) (mouseDown V.BLeft) + return $ fmap lineStyle_fromListFormat (leftmost presetClicks) + return (5, never, setStyleEv') + (0, ec) -> do + + let + joinmaybetuple mx = case mx of + Nothing -> (Nothing, Nothing) + Just x -> x + lssDyn = ffor(fmap joinmaybetuple $ fmap snd3 inputDyn) $ \(start, end) -> case ec of + 0 -> if start == end then start else Nothing + 1 -> start + 2 -> end + + (focusDyn,wasChangeDyn,l,r,u,d) <- do + --(tile . fixed) 1 $ text (fmap (T.pack . superStyle_toListFormat . Data.Maybe.fromJust) $ current mssDyn) + l_d1 <- (grout . fixed) 1 $ row $ do + (grout . fixed) 8 $ text " left:" + (tile . stretch) 1 $ makeLineStyleTextEntry LSC_L lssDyn + r_d1 <- (grout . fixed) 1 $ row $ do + (grout . fixed) 8 $ text "right:" + (tile . stretch) 1 $ makeLineStyleTextEntry LSC_R lssDyn + u_d1 <- (grout . fixed) 1 $ row $ do + (grout . fixed) 8 $ text "up:" + (tile . stretch) 1 $ makeLineStyleTextEntry LSC_U lssDyn + d_d1 <- (grout . fixed) 1 $ row $ do + (grout . fixed) 8 $ text "down:" + (tile . stretch) 1 $ makeLineStyleTextEntry LSC_D lssDyn + focusDyn' <- focusedId + -- track if there were changes made in the cell and reset each time we change cells + let trueInputChangeEv = difference (leftmost [updated l_d1 $> True, updated r_d1 $> True, updated u_d1 $> True, updated d_d1 $> True]) (updated lssDyn) + wasChangeDyn' <- holdDyn False $ leftmost [updated focusDyn' $> False, trueInputChangeEv] + return (focusDyn',wasChangeDyn',l_d1,r_d1,u_d1,d_d1) + + captureEv'' <- makeCaptureFromUpdateTextZipperMethod updateTextZipperForSingleCharacter + focusDynUnique <- holdUniqDyn focusDyn + + let + setStyleEv' = makeLineStyleEvent (current l) (current r) (current u) (current d) (void $ gate (current wasChangeDyn) (updated focusDynUnique)) + captureEv' = leftmost [void setStyleEv', captureEv''] + return (7, captureEv', setStyleEv') + + setStyleEv <- switchHold never (fmap thd3 setStyleEvEv) + captureEv <- switchHold never (fmap snd3 setStyleEvEv) + heightDyn <- holdDyn 0 (fmap fst3 setStyleEvEv) + + let + selectionDyn = fmap fst3 inputDyn + pushLineStyleFn :: Either () LineStyle -> PushM t (Maybe (Either Llama SetPotatoDefaultParameters)) + pushLineStyleFn eflipss = do + pdp <- sample . current $ pdpDyn + whichEnd' <- sample . current $ endChoiceDyn + (SuperOwlParliament selection, _, tool) <- sample . current $ inputDyn + let + whichEnd = case whichEnd' of + 0 -> SetLineStyleEnd_Both + 1 -> SetLineStyleEnd_Start + 2 -> SetLineStyleEnd_End + (setstart, setend) = case whichEnd of + SetLineStyleEnd_Start -> (True, False) + SetLineStyleEnd_End -> (False, True) + SetLineStyleEnd_Both -> (True, True) + whichEndFn sowl = case whichEnd of + SetLineStyleEnd_Start -> startStyle + SetLineStyleEnd_End -> endStyle + SetLineStyleEnd_Both -> if startStyle == endStyle then startStyle else Nothing + where + seltl = superOwl_toSEltLabel_hack sowl + startStyle = getSEltLabelLineStyle seltl + endStyle = getSEltLabelLineStyleEnd seltl + return $ case eflipss of + Left () -> case Data.Maybe.mapMaybe fmapleftfn . toList $ selection of + [] -> Nothing + x -> Just . Left . makeCompositionLlama $ x + where + fmapleftfn sowl = makeLlamaForFlipLineStyle sowl + Right ss -> if toolOverrideLineStyle tool + then if _potatoDefaultParameters_lineStyle pdp == ss + then Nothing + else Just . Right $ + -- is there a better syntax to do this LOL? + def { + _setPotatoDefaultParameters_lineStyle = if setstart then Just ss else _setPotatoDefaultParameters_lineStyle def + , _setPotatoDefaultParameters_lineStyleEnd = if setend then Just ss else _setPotatoDefaultParameters_lineStyleEnd def + } + else case Data.Maybe.mapMaybe fmaprightfn . toList $ selection of + [] -> Nothing + x -> Just . Left . makeCompositionLlama $ x + where + fmaprightfn sowl = case whichEndFn sowl of + Nothing -> llama + Just oldss -> if oldss == ss then Nothing else llama + where llama = Just $ makeLlamaForLineStyle sowl whichEnd ss + ssparamsEv = push pushLineStyleFn (leftmostEither flipButtonEv setStyleEv) + + return (heightDyn, captureEv, ssparamsEv) + + +-- Text Alignment stuff +holdTextAlignmentWidget :: forall t m. (MonadLayoutWidget t m, HasPotato t m) => ParamsWidgetFn t m TextAlign (Either Llama SetPotatoDefaultParameters) +holdTextAlignmentWidget _ inputDyn = constDyn $ do + let + mtaDyn = fmap snd3 inputDyn + selectionDyn = fmap fst3 inputDyn + + let + + alignDyn = ffor mtaDyn $ \case + Nothing -> [] + Just TextAlign_Left -> [0] + Just TextAlign_Center -> [1] + Just TextAlign_Right -> [2] + + (grout . fixed) 1 $ text "text align:" + -- I'm actually not sure why using alignDyn here isn't causing an infinite loop + -- I guess the whole widget is getting recreated when alignment changes... but when I sampled alignDyn instead, it didn't update correctly πŸ€·πŸΌβ€β™€οΈ + (setAlignmentEv', _) <- (grout . stretch) 1 $ radioList (constDyn ["left","center","right"]) alignDyn Nothing + + let + setAlignmentEv = fmap (\case + 0 -> TextAlign_Left + 1 -> TextAlign_Center + 2 -> TextAlign_Right + ) $ setAlignmentEv' + pushAlignmentFn :: TextAlign -> PushM t (Maybe (Either Llama SetPotatoDefaultParameters)) + pushAlignmentFn ta = do + (SuperOwlParliament selection, _, tool) <- sample . current $ inputDyn + let + fmapfn sowl = case getSEltLabelBoxTextStyle (superOwl_toSEltLabel_hack sowl) of + Nothing -> Nothing + Just oldts -> if oldts == TextStyle ta + then Nothing + else Just (_superOwl_id sowl, CTagBoxTextStyle :=> Identity (CTextStyle (DeltaTextStyle (oldts, TextStyle ta)))) + return $ if toolOverrideTextAlign tool + then Just . Right $ def { _setPotatoDefaultParameters_box_text_textAlign = Just ta } + else case Data.Maybe.mapMaybe fmapfn . toList $ selection of + [] -> Nothing + x -> Just . Left . controllersWithId_to_llama $ IM.fromList x + alignmentParamsEv = push pushAlignmentFn setAlignmentEv + + return (2, never, alignmentParamsEv) + +holdSBoxTypeWidget :: forall t m. (MonadLayoutWidget t m) => ParamsWidgetFn t m SBoxType (Either Llama SetPotatoDefaultParameters) +holdSBoxTypeWidget _ inputDyn = constDyn $ do + let + mBoxType = fmap snd3 inputDyn + selectionDyn = fmap fst3 inputDyn + mbt0 <- sample . current $ mBoxType + + let + stateDyn = ffor mBoxType $ \case + -- Not great, this will override everything in selection without having a "grayed out state" and do the override in a not so great way, but whatever + Nothing -> (False,False) + Just SBoxType_Box -> (True,False) + Just SBoxType_BoxText -> (True,True) + Just SBoxType_NoBox -> (False,False) + Just SBoxType_NoBoxText -> (False,True) + + borderDyn = fmap fst stateDyn + textDyn = fmap snd stateDyn + + (b,t) <- do + b_d1 <- (grout . fixed) 1 $ row $ do + (grout . fixed) 8 $ text "border:" + (grout . stretch) 1 $ checkBox borderDyn + t_d1 <- (grout . fixed) 1 $ row $ do + (grout . fixed) 8 $ text " text:" + (grout . stretch) 1 $ checkBox textDyn + return (b_d1,t_d1) + + let + captureEv = void $ leftmost [b,t] + + pushSBoxTypeFn :: These Bool Bool -> PushM t (Maybe (Either Llama SetPotatoDefaultParameters)) + pushSBoxTypeFn bt = do + (SuperOwlParliament selection, _, tool) <- sample . current $ inputDyn + curState <- sample . current $ stateDyn + let + fmapfn sowl = case getSEltLabelBoxType (superOwl_toSEltLabel_hack sowl) of + Nothing -> Nothing + Just oldbt -> if oldbt == newbt + then Nothing + else Just (_superOwl_id sowl, CTagBoxType :=> Identity (CBoxType (oldbt, newbt))) + where + newbt = case bt of + This border -> make_sBoxType border (sBoxType_isText oldbt) + That text -> make_sBoxType (sBoxType_hasBorder oldbt) text + These border text -> make_sBoxType border text + return $ if toolOverrideSBoxType tool + -- UNTESTED, it's probably currect but the tool overrides this default so I never actually tested it + then Just . Right $ def { _setPotatoDefaultParameters_sBoxType = Just $ case bt of + This border -> make_sBoxType border (snd curState) + That text -> make_sBoxType (fst curState) text + These border text -> make_sBoxType border text + } + else case Data.Maybe.mapMaybe fmapfn . toList $ selection of + [] -> Nothing + x -> Just . Left . controllersWithId_to_llama $ IM.fromList x + sBoxTypeParamsEv = push pushSBoxTypeFn (align b t) + + -- TODO + return (2, captureEv, sBoxTypeParamsEv) + +-- manually pass in 'Dynamic t SCanvas' because it's not a property of th selection +holdCanvasSizeWidget :: forall t m. (MonadLayoutWidget t m, HasPotato t m) => Dynamic t SCanvas -> ParamsWidgetFn t m () XY +holdCanvasSizeWidget canvasDyn _ _ = constDyn $ do + let + cSizeDyn = fmap (_lBox_size . _sCanvas_box) canvasDyn + cWidthDyn = fmap (\(V2 x _) -> x) cSizeDyn + cHeightDyn = fmap (\(V2 _ y) -> y) cSizeDyn + + (focusDyn,wDyn,hDyn) <- do + (grout . fixed) 1 $ text "canvas:" + wDyn' <- (grout . fixed) 1 $ row $ do + (grout . fixed) 8 $ text " width:" + (tile . stretch) 1 $ dimensionInput cWidthDyn + hDyn' <- (grout . fixed) 1 $ row $ do + (grout . fixed) 8 $ text "height:" + (tile . stretch) 1 $ dimensionInput cHeightDyn + focusDyn' <- focusedId + return (focusDyn',wDyn',hDyn') + focusDynUnique <- holdUniqDyn focusDyn + let + outputEv = flip push (void $ updated focusDynUnique) $ \_ -> do + cw <- sample . current $ cWidthDyn + ch <- sample . current $ cHeightDyn + w <- sample . current $ wDyn + h <- sample . current $ hDyn + return $ if cw /= w || ch /= h + then Just $ V2 (w-cw) (h-ch) -- it's a delta D: + else Nothing + captureEv1 <- makeCaptureFromUpdateTextZipperMethod updateTextZipperForNumberInput + let + -- causes causality loop idk why :( + --captureEv = leftmost [void outputEv, void (updated wDyn), void (updated hDyn)] + captureEv = leftmost [void outputEv, captureEv1] + return (3, captureEv, outputEv) + +data SEltParams = SEltParams { + --_sEltParams_sBox = + } + +data ParamsWidgetConfig t = ParamsWidgetConfig { + _paramsWidgetConfig_selectionDyn :: Dynamic t Selection + , _paramsWidgetConfig_canvasDyn :: Dynamic t SCanvas + , _paramsWidgetConfig_defaultParamsDyn :: Dynamic t PotatoDefaultParameters + , _paramsWidgetConfig_toolDyn :: Dynamic t Tool + -- many params don't set anything until they lose focus. However if we lose focus because we clicked onto another pane, that focus event doesn't propogate down far enough so we have to pass it down manually + , _paramsWidgetConfig_loseFocusEv :: Event t () +} + +data ParamsWidget t = ParamsWidget { + _paramsWidget_paramsEvent :: Event t Llama + , _paramsWidget_canvasSizeEvent :: Event t XY + , _paramsWidget_setDefaultParamsEvent :: Event t SetPotatoDefaultParameters + , _paramsWidget_captureInputEv :: Event t () + + , _paramsWidget_widgetHeight :: Dynamic t Int + +} + +joinHold :: (Reflex t, MonadHold t m) => Event t (Dynamic t a) -> Dynamic t a -> m (Dynamic t a) +joinHold ev d0 = do + dyndyn <- holdDyn d0 ev + return $ join dyndyn + +fth4 :: (a,b,c,d) -> d +fth4 (_,_,_,d) = d + +fstsndthd4 :: (a,b,c,d) -> (a,b,c) +fstsndthd4 (a,b,c,_) = (a,b,c) + +holdParamsWidget :: forall t m. (MonadWidget t m, HasPotato t m) + => ParamsWidgetConfig t + -> m (ParamsWidget t) +holdParamsWidget ParamsWidgetConfig {..} = mdo + let + selectionDyn = _paramsWidgetConfig_selectionDyn + canvasDyn = ffor2 _paramsWidgetConfig_canvasDyn canvasSizeChangeEventDummyDyn const + defaultParamsDyn = _paramsWidgetConfig_defaultParamsDyn + toolDyn = _paramsWidgetConfig_toolDyn + + mTextAlignInputDyn = ffor3 toolDyn selectionDyn defaultParamsDyn $ makeParamsInputDyn + toolOverrideTextAlign + ((fmap (\(TextStyle ta) -> ta)) . getSEltLabelBoxTextStyle . superOwl_toSEltLabel_hack) + _potatoDefaultParameters_box_text_textAlign + + mSuperStyleInputDyn = ffor3 toolDyn selectionDyn defaultParamsDyn $ makeParamsInputDyn + toolOverrideSuperStyle + (getSEltLabelSuperStyle . superOwl_toSEltLabel_hack) + _potatoDefaultParameters_superStyle + + mLineStyleInputDyn = ffor3 toolDyn selectionDyn defaultParamsDyn $ makeLineStyleInputDyn + + mSBoxTypeInputDyn = ffor3 toolDyn selectionDyn defaultParamsDyn $ makeParamsInputDyn + toolOverrideSBoxType + (getSEltLabelBoxType . superOwl_toSEltLabel_hack) + _potatoDefaultParameters_sBoxType + + -- show canvas params when nothing is selected + mCanvasSizeInputDyn = ffor2 toolDyn selectionDyn (\t s -> if isParliament_null s then Just (isParliament_empty, Nothing, t) else Nothing) + + -- TODO consider doing initManager_ within the widgets if you don't want to tab from one widget to the next + (paramsOutputEv, captureEv, canvasSizeOutputEv, heightDyn) <- initManager_ $ col $ do + repeatNavigation + requestFocus $ (Refocus_Clear <$ _paramsWidgetConfig_loseFocusEv) + textAlignmentWidget <- holdMaybeParamsWidget defaultParamsDyn mTextAlignInputDyn holdTextAlignmentWidget + superStyleWidget2 <- holdMaybeParamsWidget defaultParamsDyn mSuperStyleInputDyn holdSuperStyleWidget + lineStyleWidget <- holdMaybeParamsWidget defaultParamsDyn mLineStyleInputDyn holdLineStyleWidgetNew + sBoxTypeWidget <- holdMaybeParamsWidget defaultParamsDyn mSBoxTypeInputDyn holdSBoxTypeWidget + canvasSizeWidget <- holdMaybeParamsWidget defaultParamsDyn mCanvasSizeInputDyn (holdCanvasSizeWidget canvasDyn) + + -- apparently textAlignmentWidget gets updated after any change which causes the whole network to rerender and we lose our focus state... + let + controllersWithIdParamsWidgets = fmap catMaybes . mconcat . (fmap (fmap (:[]))) $ [textAlignmentWidget, superStyleWidget2, lineStyleWidget, sBoxTypeWidget] + + paramsNetwork <- networkView . ffor2 controllersWithIdParamsWidgets canvasSizeWidget $ \widgets mcsw -> col $ do + outputs <- forM widgets $ \w -> mdo + (sz, captureEv', ev) <- (tile . fixed) sz w + return (sz, ev, captureEv') + -- canvas size widget is special becaues it's output type is different + (cssz, cssev, captureEv2) <- case mcsw of + Nothing -> return (0, never, never) + Just csw -> mdo + (cssz', csCaptureEv', cssev') <- (tile . fixed) cssz' csw + return (cssz', cssev', csCaptureEv') + let + heightDyn'' = liftA2 (+) cssz $ foldr (liftA2 (+)) 0 $ fmap fst3 outputs + -- NOTE multiple capture events will fire at once due to the way makeCaptureFromUpdateTextZipperMethod is scoped + return $ (leftmostWarn "paramsLayout" (fmap snd3 outputs), leftmost (captureEv2 : fmap thd3 outputs), cssev, heightDyn'') + + heightDyn' <- joinHold (fmap fth4 paramsNetwork) 0 + (paramsOutputEv', captureEv', canvasSizeOutputEv') <- switchHoldTriple never never never $ fmap fstsndthd4 paramsNetwork + + return (paramsOutputEv', captureEv', canvasSizeOutputEv', heightDyn') + + let + -- TODO move to Data.Either.Extra + maybeLeft (Left a) = Just a + maybeLeft _ = Nothing + maybeRight (Right a) = Just a + maybeRight _ = Nothing + + canvasSizeChangeEventDummyDyn <- holdDyn () (void canvasSizeOutputEv) + + return ParamsWidget { + _paramsWidget_paramsEvent = (fmapMaybe maybeLeft paramsOutputEv) + , _paramsWidget_canvasSizeEvent = canvasSizeOutputEv + , _paramsWidget_setDefaultParamsEvent = fmapMaybe maybeRight paramsOutputEv + , _paramsWidget_captureInputEv = captureEv + , _paramsWidget_widgetHeight = heightDyn + } diff --git a/src/Potato/Flow/Vty/PotatoReader.hs b/src/Potato/Flow/Vty/PotatoReader.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Flow/Vty/PotatoReader.hs @@ -0,0 +1,193 @@ +{-# Language UndecidableInstances #-} + +module Potato.Flow.Vty.PotatoReader where + +import Relude + +import Potato.Flow + +import Data.Default +import Control.Monad.Fix (MonadFix) +import Control.Monad.IO.Class (MonadIO) +--import Control.Monad.Morph +import Control.Monad.NodeId +import Control.Monad.Reader (ReaderT, ask, local, runReaderT) +import Control.Monad.Ref +import Control.Monad.Trans (MonadTrans, lift) + +import qualified System.FilePath as FP + +import qualified Graphics.Vty as V +import Reflex.Host.Class (MonadReflexCreateTrigger) +import Reflex +import Reflex.Vty + +import Potato.Flow.Vty.Attrs + + +-- TODO move elsewhere +kTinyToolsFileExtension :: (IsString a) => a +kTinyToolsFileExtension = ".potato" + +-- TODO move elsewhere +addTinyToolsFileExtensionIfNecessary :: FP.FilePath -> FP.FilePath +addTinyToolsFileExtensionIfNecessary fp = if FP.takeExtension fp == "" + then fp <> kTinyToolsFileExtension + else fp + + + +data PotatoStyle = PotatoStyle { + + -- TODO you can DELETE this now prob + _potatoStyle_canvasCursor :: V.Attr + + , _potatoStyle_makeCanvasManipulator :: RenderHandleColor -> V.Attr + , _potatoStyle_normal :: V.Attr + + , _potatoStyle_selected :: V.Attr + , _potatoStyle_layers_softSelected :: V.Attr -- color of parent(s) when child is selected + , _potatoStyle_canvas_oob :: V.Attr + + , _potatoStyle_textfield_normal :: V.Attr + , _potatoStyle_textfield_modifying :: V.Attr + , _potatoStyle_textfield_cursor :: V.Attr +} + + +instance Default PotatoStyle where + def = PotatoStyle { + _potatoStyle_normal = lg_default + + ,_potatoStyle_canvasCursor = lg_canvas_cursor + , _potatoStyle_makeCanvasManipulator = lg_make_canvas_cursor + , _potatoStyle_canvas_oob = lg_canvas_oob + + , _potatoStyle_selected = lg_layer_selected + , _potatoStyle_layers_softSelected = lg_layer_inheritselect + + , _potatoStyle_textfield_normal = lg_textfield_normal + , _potatoStyle_textfield_modifying = lg_textfield_modifying + , _potatoStyle_textfield_cursor = lg_textfield_cursor + } + +data PotatoConfig t = PotatoConfig { + _potatoConfig_style :: Behavior t PotatoStyle + + -- TODO these need to be per document if you ever want MDI + , _potatoConfig_appCurrentOpenFile :: Behavior t (Maybe FP.FilePath) + , _potatoConfig_appCurrentDirectory :: Behavior t FP.FilePath + , _potatoConfig_appPrintFile :: Behavior t (Maybe FP.FilePath) + -- TODO + --, _potatoConfig_unsavedChanges :: Behavior t Bool +} + +instance (Reflex t) => Default (PotatoConfig t) where + def = PotatoConfig { + _potatoConfig_style = constant def + , _potatoConfig_appCurrentOpenFile = constant Nothing + , _potatoConfig_appPrintFile = constant Nothing + } + +-- | A class for things that can dynamically gain and lose focus +class (Reflex t, Monad m) => HasPotato t m | m -> t where + askPotato :: m (PotatoConfig t) + +instance (HasInput t m, Monad m) => HasInput t (ReaderT r m) + + +-- TODO it's better to do this using +-- default input :: (f m' ~ m, Monad m', MonadTrans f, HasInput t m') => ... +-- inside of HasFocus class +instance (Reflex t, HasFocus t m, Monad m) => HasFocus t (ReaderT r m) where + makeFocus = lift makeFocus + requestFocus = lift . requestFocus + isFocused = lift . isFocused + --subFoci :: m a -> m (a, Dynamic t FocusSet) + subFoci x = ReaderT $ \r -> subFoci (runReaderT x r) + focusedId = lift focusedId + + +instance HasPotato t m => HasPotato t (ReaderT x m) +instance HasPotato t m => HasPotato t (BehaviorWriterT t x m) +instance HasPotato t m => HasPotato t (DynamicWriterT t x m) +instance HasPotato t m => HasPotato t (EventWriterT t x m) +instance HasPotato t m => HasPotato t (NodeIdT m) +instance HasPotato t m => HasPotato t (Input t m) +instance HasPotato t m => HasPotato t (ImageWriter t m) +instance HasPotato t m => HasPotato t (DisplayRegion t m) +instance HasPotato t m => HasPotato t (FocusReader t m) +instance HasPotato t m => HasPotato t (Focus t m) where + askPotato = lift askPotato +instance HasPotato t m => HasPotato t (Layout t m) where + askPotato = lift askPotato + + +-- | A widget that has access to information about whether it is focused +newtype PotatoReader t m a = PotatoReader + { unPotatoReader :: ReaderT (PotatoConfig t) m a } + deriving + ( Functor + , Applicative + , Monad + , MonadFix + , MonadHold t + , MonadIO + , MonadRef + , MonadSample t + ) + +instance (Monad m, Reflex t) => HasPotato t (PotatoReader t m) where + askPotato = PotatoReader ask + +deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (PotatoReader t m) +deriving instance NotReady t m => NotReady t (PotatoReader t m) +deriving instance PerformEvent t m => PerformEvent t (PotatoReader t m) +deriving instance PostBuild t m => PostBuild t (PotatoReader t m) +deriving instance TriggerEvent t m => TriggerEvent t (PotatoReader t m) +deriving instance (HasInput t m, Monad m) => HasInput t (PotatoReader t m) +deriving instance HasFocus t m => HasFocus t (PotatoReader t m) +deriving instance HasFocusReader t m => HasFocusReader t (PotatoReader t m) +deriving instance HasTheme t m => HasTheme t (PotatoReader t m) +deriving instance HasDisplayRegion t m => HasDisplayRegion t (PotatoReader t m) + +-- can't seem to include Control.Monad.Morph :( +--instance HasImageWriter t m => HasImageWriter t (PotatoReader t m) +--instance MFunctor (PotatoReader t) where +-- hoist f = PotatoReader . hoist f . unPotatoReader + +instance HasImageWriter t m => HasImageWriter t (PotatoReader t m) where + tellImages = lift . tellImages + mapImages f = hoistpotato (mapImages f) where + hoistpotato g = PotatoReader . (hoist g) . unPotatoReader + hoist nat m = ReaderT (\i -> nat (runReaderT m i)) + +-- TODO it's better to do this using +-- default input :: (f m' ~ m, Monad m', MonadTrans f, HasInput t m') => ... +-- inside of HasLayout class +instance (Reflex t, HasLayout t m) => HasLayout t (PotatoReader t m) where + axis a b c = PotatoReader . ReaderT $ \pcfg -> axis a b (runPotatoReader c pcfg) + region = lift . region + askOrientation = lift askOrientation + +instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (PotatoReader t m) where + runWithReplace (PotatoReader a) e = PotatoReader $ runWithReplace a $ fmap unPotatoReader e + traverseIntMapWithKeyWithAdjust f m e = PotatoReader $ traverseIntMapWithKeyWithAdjust (\k v -> unPotatoReader $ f k v) m e + traverseDMapWithKeyWithAdjust f m e = PotatoReader $ traverseDMapWithKeyWithAdjust (\k v -> unPotatoReader $ f k v) m e + traverseDMapWithKeyWithAdjustWithMove f m e = PotatoReader $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unPotatoReader $ f k v) m e + +instance MonadTrans (PotatoReader t) where + lift = PotatoReader . lift + + +instance MonadNodeId m => MonadNodeId (PotatoReader t m) + + +-- | Run a 'FocusReader' action with the given focus value +-- TODO flip arg order to match ReaderT oops... +runPotatoReader + :: (Reflex t, Monad m) + => PotatoReader t m a + -> PotatoConfig t + -> m a +runPotatoReader a b = flip runReaderT b $ unPotatoReader a diff --git a/src/Potato/Flow/Vty/SaveAsWindow.hs b/src/Potato/Flow/Vty/SaveAsWindow.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Flow/Vty/SaveAsWindow.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +module Potato.Flow.Vty.SaveAsWindow where + +import Relude + +import Potato.Flow +import Potato.Flow.Vty.Common +import Potato.Reflex.Vty.Helpers +import Potato.Flow.Vty.PotatoReader +import Potato.Flow.Vty.Attrs +import Potato.Reflex.Vty.Widget.FileExplorer +import Potato.Reflex.Vty.Widget.Popup + + +import Control.Monad.Fix +import Control.Monad.NodeId +import Data.Align +import Data.Char (isNumber) +import Data.Dependent.Sum (DSum ((:=>))) +import qualified Data.IntMap as IM +import qualified Data.List.Extra as L +import qualified Data.Maybe +import qualified Data.Sequence as Seq +import qualified Data.Text as T +import qualified Data.Text.Zipper as TZ +import Data.These +import Data.Tuple.Extra + +import qualified Graphics.Vty as V +import Reflex +import Reflex.Network +import Reflex.Potato.Helpers +import Reflex.Vty + +import qualified System.FilePath as FP +import qualified System.Directory as FP + +data SaveAsWindowConfig t = SaveAsWindowConfig { + _saveAsWindowConfig_saveAs :: Event t FP.FilePath -- ^ Event to launch the popup window to save file as Text is previous file name or empty string +} + +popupSaveAsWindow :: forall t m. (MonadWidget t m, HasPotato t m) + => SaveAsWindowConfig t + -> m (Event t FP.FilePath, Dynamic t Bool) -- ^ (file to save to, popup state) +popupSaveAsWindow SaveAsWindowConfig {..} = do + + potatostylebeh <- fmap _potatoConfig_style askPotato + + let + popupSaveAsEv = ffor _saveAsWindowConfig_saveAs $ \f0 -> mdo + boxTitle (constant def) "Save As" $ do + initManager_ $ col $ mdo + fewidget <- (tile . stretch) 3 $ holdFileExplorerWidget $ FileExplorerWidgetConfig { + _fileExplorerWidgetConfig_fileFilter = \fp -> FP.takeExtension fp == kTinyToolsFileExtension + , _fileExplorerWidgetConfig_initialFile = f0 + , _fileExplorerWidgetConfig_clickDownStyle = fmap _potatoStyle_layers_softSelected potatostylebeh + } + (cancelEv, saveButtonEv) <- (tile . fixed) 3 $ row $ do + cancelEv' <- (tile . stretch) 10 $ textButton def "cancel" + + -- TODO grey out if filename is empty + saveEv' <- (tile . stretch) 10 $ textButton def "save" + + return (cancelEv', saveEv') + + -- DELETE + -- IO file validity checkin + {-mSaveAsFileEv <- performEvent $ ffor (tag (_fileExplorerWidget_fullfilename fewidget) saveEv) $ \ffn -> liftIO $ do + exists <- FP.doesFileExist ffn + return $ if exists + then Just ffn else Nothing + let saveAsFileEv = fmapMaybe id mSaveAsFileEv-} + + + let + -- do we really want to allow save on pressing enter? + saveEv' = leftmost [_fileExplorerWidget_returnOnfilename fewidget, _fileExplorerWidget_doubleClick fewidget, saveButtonEv] + + -- only save if filename is non-empty + saveEv = gate (fmap (not . T.null) (_fileExplorerWidget_filename fewidget)) saveEv' + + saveAsFileEv' = tag (_fileExplorerWidget_fullfilename fewidget) saveEv + saveAsFileEv = fmap addTinyToolsFileExtensionIfNecessary saveAsFileEv' + return (cancelEv, saveAsFileEv) + fmapfn w = \escEv clickOutsideEv -> fmap (\(cancelEv, outputEv) -> (leftmost [escEv, cancelEv, void outputEv], outputEv)) w + + localTheme (const $ fmap _potatoStyle_normal potatostylebeh) $ do + popupPane def $ (fmap fmapfn popupSaveAsEv) + + +-- TODO rename to MaybeSaveBeforeAction... +data SaveBeforeActionConfig t = SaveBeforeActionConfig { + _saveBeforeActionConfig_unsavedChangesBeh :: Behavior t Bool + , _saveBeforeActionConfig_open :: Event t () + , _saveBeforeActionConfig_new :: Event t () + , _saveBeforeActionConfig_exit :: Event t () + , _saveBeforeActionConfig_saveOutcomeEv :: Event t (Either Text FilePath) -- Left is error Right is success, open/new/exit events only fire if it was a success +} + +data SaveBeforeActionType = SaveBeforeActionType_Open | SaveBeforeActionType_New | SaveBeforeActionType_Exit | SaveBeforeActionType_None deriving (Show, Eq) + +-- TODO make this generic, via some PopupManager thingy or what not +-- you want to use the same NeedSave for close and open when there are unsaved changes +-- and after the save action, you want to redirect back to the open or quit operation +data SaveBeforeActionOutput t = SaveBeforeActionOutput { + + -- TODO you should be able to get this to work... + --_saveBeforeActionOutput_save :: Event t FP.FilePath + _saveBeforeActionOutput_save :: Event t () + + , _saveBeforeActionOutput_saveAs :: Event t () + + , _saveBeforeActionOutput_new :: Event t () + , _saveBeforeActionOutput_open :: Event t () + , _saveBeforeActionOutput_exit :: Event t () +} + +hackAlign3 :: (Reflex t) => Event t a -> Event t b -> Event t c -> Event t (These a (These b c)) +hackAlign3 a b c = align a (align b c) + +hackFanThese3 :: (Reflex t) => Event t (These a (These b c)) -> (Event t a, Event t b, Event t c) +hackFanThese3 ev = r where + (a, bc) = fanThese ev + (b, c) = fanThese bc + r = (a,b,c) + +-- TODO somehow allow auto save on exit +popupSaveBeforeExit :: forall t m. (MonadWidget t m, HasPotato t m) + => SaveBeforeActionConfig t + -> m (SaveBeforeActionOutput t, Dynamic t Bool) +popupSaveBeforeExit SaveBeforeActionConfig {..} = do + mopenfilebeh <- fmap _potatoConfig_appCurrentOpenFile askPotato + -- TODO unsure why this doesn't get resampled each time popup is created :( + --mopenfile <- sample mopenfilebeh + + potatostylebeh <- fmap _potatoConfig_style askPotato + + let + + combinedEv = leftmost [SaveBeforeActionType_Open <$_saveBeforeActionConfig_open, SaveBeforeActionType_New <$_saveBeforeActionConfig_new, SaveBeforeActionType_Exit <$_saveBeforeActionConfig_exit] + filteredEv = gate _saveBeforeActionConfig_unsavedChangesBeh combinedEv + skipNoUnsavedChangesEv = gate (fmap not _saveBeforeActionConfig_unsavedChangesBeh) combinedEv + + + + combinedDyn <- holdDyn SaveBeforeActionType_None combinedEv + + let + popupSaveBeforeExitEv = ffor filteredEv $ \iev -> mdo + boxTitle (constant def) "😱😱 You have unsaved changes. Would you like to save? 😱😱" $ do + initManager_ $ col $ mdo + (ignoreEv, cancelEv, saveButtonEv, saveAsButtonEv) <- do + (tile . stretch) 0 $ col $ return () + (tile . fixed) 3 $ row $ do + cancelEv' <- (tile . stretch) 9 $ textButton def "cancel" + + -- TODO you should be able to get this to work... + --saveEv' <- case mopenfile of + -- Nothing -> return never + -- Just x -> (tile . stretch) 9 $ (const x <<$>> textButton def "save") + saveEv' <- (tile . stretch) 9 $ textButton def "save" + + saveAsEv' <- (tile . stretch) 9 $ textButton def "save as" + ignoreEv' <- (tile . stretch) 9 $ textButton def "ignore" + return (ignoreEv' $> iev, cancelEv', saveEv', saveAsEv') + return (cancelEv, hackAlign3 saveButtonEv saveAsButtonEv ignoreEv) + fmapfn w = \escEv clickOutsideEv -> fmap (\(cancelEv, outputEv) -> (leftmost [escEv, cancelEv, void outputEv], outputEv)) w + (outputEv, stateDyn) <- localTheme (const $ fmap _potatoStyle_normal potatostylebeh) $ do + popupPane def $ (fmap fmapfn popupSaveBeforeExitEv) + + let + (saveEv, saveAsEv, ignoreEv) = hackFanThese3 outputEv + saveFinalized <- waitForSecondAfterFirst (tag (current combinedDyn) $ align saveEv saveAsEv) _saveBeforeActionConfig_saveOutcomeEv + let + saveFinalizedSuccess = fmap fst . ffilter (isRight . snd) $ saveFinalized + + + -- only do the action if + -- there were no unsaved changes + -- the user hit the "ignore" button + -- the user successfuly saved after save/saveas operation + doActionEv = leftmost [skipNoUnsavedChangesEv, ignoreEv, saveFinalizedSuccess] + + sbao = SaveBeforeActionOutput { + _saveBeforeActionOutput_save = saveEv + , _saveBeforeActionOutput_saveAs = saveAsEv + , _saveBeforeActionOutput_new = void $ ffilter (== SaveBeforeActionType_New) doActionEv + , _saveBeforeActionOutput_open = void $ ffilter (== SaveBeforeActionType_Open) doActionEv + , _saveBeforeActionOutput_exit = void $ ffilter (== SaveBeforeActionType_Exit) doActionEv + } + + + return (sbao, stateDyn) diff --git a/src/Potato/Flow/Vty/ToolOptions.hs b/src/Potato/Flow/Vty/ToolOptions.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Flow/Vty/ToolOptions.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +module Potato.Flow.Vty.ToolOptions ( + ToolOptionsWidgetConfig(..) + , ToolOptionsWidget(..) + , holdToolOptionsWidget +) where + +import Relude + +import Potato.Flow.Controller +import Potato.Flow.Vty.Common +import Potato.Reflex.Vty.Helpers + +import Control.Monad.Fix +import Control.Monad.NodeId + +import Reflex + + +data ToolOptionsWidgetConfig t = ToolOptionsWidgetConfig { + _toolOptionsWidgetConfig_tool :: Dynamic t Tool + , _toolOptionsWidgetConfig_widthDyn :: Dynamic t Int +} + +data ToolOptionsWidget t = ToolOptionsWidget { + _toolOptionsWidget_setOption :: Event t () + , _toolOptionsWidget_heightDyn :: Dynamic t Int +} + + +holdToolOptionsWidget :: forall t m. (PostBuild t m, MonadWidget t m) + => ToolOptionsWidgetConfig t + -> m (ToolOptionsWidget t) +holdToolOptionsWidget ToolOptionsWidgetConfig {..} = mdo + + + return ToolOptionsWidget { + _toolOptionsWidget_setOption = never + , _toolOptionsWidget_heightDyn = constDyn 0 + } diff --git a/src/Potato/Flow/Vty/Tools.hs b/src/Potato/Flow/Vty/Tools.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Flow/Vty/Tools.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +module Potato.Flow.Vty.Tools ( + Tool(..) + , ToolWidgetConfig(..) + , ToolWidget(..) + , holdToolsWidget +) where + +import Relude + +import Potato.Flow.Controller +import Potato.Flow.Vty.Common +import Potato.Reflex.Vty.Helpers + +import Control.Monad.Fix +import Control.Monad.NodeId + +import Reflex + + +data ToolWidgetConfig t = ToolWidgetConfig { + _toolWidgetConfig_tool :: Dynamic t Tool + , _toolWidgetConfig_widthDyn :: Dynamic t Int +} + +data ToolWidget t = ToolWidget { + _toolWidget_setTool :: Event t Tool + , _toolWidget_heightDyn :: Dynamic t Int +} + + +--onlyIfBeh :: (Reflex t) => Event t a -> Behavior t Bool -> Event t a +--onlyIfBeh ev beh = fmapMaybe (\(b,e) -> if b then Just e else Nothing) $ attach beh ev + + +holdToolsWidget :: forall t m. (PostBuild t m, MonadWidget t m) + => ToolWidgetConfig t + -> m (ToolWidget t) +holdToolsWidget ToolWidgetConfig {..} = mdo + + (radioEvs, heightDyn) <- radioList (constDyn ["(v)select","(p)an","(b)ox","(l)ine","(t)extbox","pai(n)t"]) (fmap ((:[]) . fromEnum) _toolWidgetConfig_tool) (Just _toolWidgetConfig_widthDyn) + let + selectB = void $ ffilter (==0) radioEvs + panB = void $ ffilter (==1) radioEvs + boxB = void $ ffilter (==2) radioEvs + lineB = void $ ffilter (==3) radioEvs + textB = void $ ffilter (==4) radioEvs + textareaB = void $ ffilter (==5) radioEvs + + let + setTool = leftmost + [Tool_Select <$ leftmost [selectB] + , Tool_Pan <$ leftmost [panB] + , Tool_Box <$ leftmost [boxB] + , Tool_Line <$ leftmost [lineB] + , Tool_Text <$ leftmost [textB] + , Tool_TextArea <$ leftmost [textareaB]] +{- + vLayoutPad 4 $ debugStream [ + never + , fmapLabelShow "radio" $ radioEvs + , fmapLabelShow "selected" $ fmap ((:[]) . fromEnum) (updated _toolWidgetConfig_tool) + ] +-} + + + return ToolWidget { + _toolWidget_setTool = setTool + , _toolWidget_heightDyn = heightDyn + } + + {- + keyPressEv k = flip push (_pFWidgetCtx_ev_input _toolWidgetConfig_pfctx) $ \vtyev -> do + consuming <- sample _toolWidgetConfig_consumingKeyboard + return $ if not consuming + then case vtyev of + V.EvKey (V.KChar k') [] | k' == k -> Just () + _ -> Nothing + else Nothing + -} diff --git a/src/Potato/Reflex/Vty/Helpers.hs b/src/Potato/Reflex/Vty/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Reflex/Vty/Helpers.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +{-# OPTIONS_GHC -threaded #-} + +module Potato.Reflex.Vty.Helpers ( + MonadWidget + , MonadLayoutWidget + , debugFocus + , debugInput + , debugSize + , dragTest + , richTextConfig_simpleForeColorAttr + , debugStreamBeh + , debugStream + , fmapLabelShow + , countEv + , vLayoutPad + , drag2AttachOnStart +) where + + +import Relude + +import Potato.Reflex.Vty.Widget +import Reflex.Potato.Helpers (simultaneous) + +import Control.Monad.Fix +import Control.Monad.NodeId +import qualified Data.Text as T +import qualified Graphics.Vty as V +import Reflex +import Reflex.Vty + +type MonadWidget t m = (Reflex t, MonadHold t m, MonadFix m, NotReady t m, Adjustable t m, PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadNodeId m, MonadIO (Performable m), MonadSample t m, MonadIO m + , HasImageWriter t m + , MonadNodeId m + , HasDisplayRegion t m + , HasFocusReader t m + , HasInput t m + , HasTheme t m) + +type MonadLayoutWidget t m = (MonadWidget t m, HasFocus t m, HasLayout t m) + +debugFocus :: (HasFocusReader t m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => m () +debugFocus = do + f <- focus + text $ T.pack . show <$> current f + +debugInput :: (MonadHold t m, HasInput t m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => m () +debugInput = do + lastEvent <- hold "No event yet" . fmap show =<< input + text $ T.pack <$> lastEvent + +debugSize :: (MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => m () +debugSize = do + ldw <- displayWidth + ldh <- displayHeight + let combine w h = "w: " <> show w <> " h: " <> show h + text $ liftA2 combine (current ldw) (current ldh) + +dragTest :: (MonadHold t m, MonadFix m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasTheme t m) => m () +dragTest = do + lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft + text $ T.pack <$> lastEvent + +richTextConfig_simpleForeColorAttr :: (Reflex t) => RichTextConfig t +richTextConfig_simpleForeColorAttr = RichTextConfig $ constant (V.defAttr { V.attrForeColor = V.SetTo V.yellow}) + +fmapLabelShow :: (Functor f, Show a) => Text -> f a -> f Text +fmapLabelShow t = fmap (\x -> t <> ": " <> show x) + +-- TODO rename to debugStreamEv +debugStream :: (MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => [Event t Text] -> m () +debugStream evs = do + t <- holdDyn "" $ mergeWith (\a b -> a <> "\n" <> b) evs + richText richTextConfig_simpleForeColorAttr (current t) + +debugStreamBeh :: (MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => [Behavior t Text] -> m () +debugStreamBeh behs = text $ foldr (liftA2 (\t1 t2 -> t1 <> " " <> t2)) "" behs + +countEv :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Dynamic t Int) +countEv ev = foldDyn (\_ b -> b+1) 0 ev + +vLayoutPad :: (PostBuild t m, MonadHold t m, MonadFix m, MonadNodeId m, HasFocusReader t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m) => Int -> m a -> m a +vLayoutPad n w = initLayout $ col $ do + (grout . fixed) (constDyn n) $ return () + (grout . stretch) 0 (lift w) + +{- +dragAttachOnStart + :: forall t m a. (Reflex t, MonadFix m, MonadHold t m) + => V.Button + -> Behavior t a + -> m (Event t (a, Drag)) +dragAttachOnStart btn beh = mdo + inp <- input + let + f :: (Maybe (a, Drag), V.Event) -> PushM t (Maybe (a, Drag)) + f (Nothing, inp) = case inp of + V.EvMouseDown x y btn' mods + | btn == btn' -> do + a <- sample beh + return . Just $ (a, Drag (x,y) (x,y) btn' mods False) + | otherwise -> return Nothing + _ -> return Nothing + f (Just (a, Drag from _ _ mods end), inp) = case inp of + V.EvMouseDown x y btn' mods' + | end && btn == btn' -> do + newa <- sample beh + return . Just $ (newa, Drag (x,y) (x,y) btn' mods' False) + | btn == btn' -> return . Just $ (a, Drag from (x,y) btn mods' False) + | otherwise -> return Nothing -- Ignore other buttons. + V.EvMouseUp x y (Just btn') + | end -> return Nothing + | btn == btn' -> return . Just $ (a, Drag from (x,y) btn mods True) + | otherwise -> return Nothing + V.EvMouseUp x y Nothing -- Terminal doesn't specify mouse up button, + -- assume it's the right one. + | end -> return Nothing + | otherwise -> return . Just $ (a, Drag from (x,y) btn mods True) + _ -> return Nothing + newDrag :: Event t (a, Drag) + newDrag = push f (attach (current dragD) inp) + dragD <- holdDyn Nothing $ Just <$> newDrag + return (fmapMaybe id $ updated dragD) +-} + + +drag2AttachOnStart + :: forall t m a. (Reflex t, MonadFix m, MonadHold t m, HasInput t m) + => V.Button + -> Behavior t a + -> m (Event t (a, Drag2)) +drag2AttachOnStart btn beh = do + dragEv <- drag2 V.BLeft + let + foldfn d ma = do + anew <- case ma of + Nothing -> sample beh + Just (a, _) | _drag2_state d == DragStart -> sample beh + Just (a, _) -> return a + return $ Just (anew, d) + dragBeh <- foldDynM foldfn Nothing dragEv + return $ fmapMaybe id $ updated dragBeh diff --git a/src/Potato/Reflex/Vty/Host.hs b/src/Potato/Reflex/Vty/Host.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Reflex/Vty/Host.hs @@ -0,0 +1,272 @@ +{-| +Module: Potato.Reflex.Vty.Host +Description: Potato version of Reflex.Vty.Host where render events are skipped to improve speed + +-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} + +module Potato.Reflex.Vty.Host + ( VtyApp + , VtyResult(..) + , getDefaultVty + , runVtyApp + , runVtyAppWithHandle + , MonadVtyApp + , VtyEvent + ) where + +import Prelude + +import System.IO +import Control.Concurrent (forkIO, killThread, MVar, newMVar, putMVar, readMVar, modifyMVar_) +import Control.Concurrent.Chan (newChan, readChan, writeChan) +import Control.Exception (onException) +import Control.Monad (forM, forM_, forever) +import Control.Monad.Fix (MonadFix, fix) +import Control.Monad.IO.Class (liftIO, MonadIO) +import Control.Monad.Identity (Identity(..)) +import Control.Monad.Primitive (PrimMonad) +import Control.Monad.Ref (MonadRef, Ref, readRef) +import Data.Dependent.Sum (DSum ((:=>))) +import Data.IORef (IORef, readIORef) +import Data.Maybe (catMaybes) + +import Reflex +import Reflex.Host.Class +import Reflex.Spider.Orphans () +import Graphics.Vty (DisplayRegion) +import qualified Graphics.Vty as V + + + + + +-- | A synonym for the underlying vty event type from 'Graphics.Vty'. This should +-- probably ultimately be replaced by something defined in this library. +type VtyEvent = V.Event + +-- | The output of a 'VtyApp'. +data VtyResult t = VtyResult + { _vtyResult_picture :: Behavior t V.Picture + -- ^ The current vty output. 'runVtyAppWithHandle' samples this value every time an + -- event fires and updates the display. + , _vtyResult_shutdown :: Event t () + -- ^ An event that requests application termination. + } + +-- | The constraints necessary to run a 'VtyApp'. See 'runVtyAppWithHandle' for more +-- on why each of these are necessary and how they can be fulfilled. +type MonadVtyApp t m = + ( Reflex t + , MonadHold t m + , MonadFix m + , PrimMonad (HostFrame t) + , ReflexHost t + , MonadIO (HostFrame t) + , Ref m ~ IORef + , Ref (HostFrame t) ~ IORef + , MonadRef (HostFrame t) + , NotReady t m + , TriggerEvent t m + , PostBuild t m + , PerformEvent t m + , MonadIO m + , MonadIO (Performable m) + , MonadSample t (Performable m) + , Adjustable t m + ) + +-- | A functional reactive vty application. +type VtyApp t m = MonadVtyApp t m + => DisplayRegion + -- ^ The initial display size (updates to this come as events) + -> Event t V.Event + -- ^ Vty input events. + -> m (VtyResult t) + -- ^ The output of the 'VtyApp'. The application runs in a context that, + -- among other things, allows new events to be created and triggered + -- ('TriggerEvent'), provides access to an event that fires immediately upon + -- app instantiation ('PostBuild'), and allows actions to be run upon + -- occurrences of events ('PerformEvent'). + +-- | Runs a 'VtyApp' in a given 'Graphics.Vty.Vty'. +-- Same as Reflex.Vty.runVtyAppWithHandle except does some bonus potato stuff +runVtyAppWithHandle + :: V.Vty + -- ^ A 'Graphics.Vty.Vty' handle. + -> (forall t m. VtyApp t m) + -- ^ A functional reactive vty application. + -> IO () +runVtyAppWithHandle vty vtyGuest = flip onException (V.shutdown vty) $ + + -- We are using the 'Spider' implementation of reflex. Running the host + -- allows us to take actions on the FRP timeline. The scoped type signature + -- specifies that our host runs on the Global timeline. + -- For more information, see 'Reflex.Spider.Internal.runSpiderHost'. + (runSpiderHost :: SpiderHost Global a -> IO a) $ do + + -- Create an 'Event' and a "trigger" reference for that event. The trigger + -- reference can be used to determine whether anyone is "subscribed" to + -- that 'Event' and, therefore, whether we need to bother performing any + -- updates when the 'Event' fires. + -- The 'Event' below will be used to convey vty input events. + (vtyEvent, vtyEventTriggerRef) <- newEventWithTriggerRef + + -- Create the "post-build" event and associated trigger. This event fires + -- once, when the application starts. + (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef + + -- Create a queue to which we will write 'Event's that need to be + -- processed. + events <- liftIO newChan + triggerEvents <- liftIO newChan + chanSizeVar :: MVar Int <- liftIO $ newMVar 0 + + displayRegion0 <- liftIO $ V.displayBounds $ V.outputIface vty + + -- Run the vty "guest" application, providing the appropriate context. The + -- result is a 'VtyResult', and a 'FireCommand' that will be used to + -- trigger events. + (vtyResult, fc@(FireCommand fire)) <- do + hostPerformEventT $ -- Allows the guest app to run + -- 'performEvent', so that actions + -- (e.g., IO actions) can be run when + -- 'Event's fire. + + flip runPostBuildT postBuild $ -- Allows the guest app to access to + -- a "post-build" 'Event' + + flip runTriggerEventT triggerEvents $ -- Allows the guest app to create new + -- events and triggers and writes + -- those triggers to a channel from + -- which they will be read and + -- processed. + + vtyGuest displayRegion0 vtyEvent + -- The guest app is provided the + -- initial display region and an + -- 'Event' of vty inputs. + + -- Reads the current value of the 'Picture' behavior and updates the + -- display with it. This will be called whenever we determine that a + -- display update is necessary. In this implementation that is when various + -- events occur. + let updateVty = + sample (_vtyResult_picture vtyResult) >>= \x -> do + n <- liftIO . readMVar $ chanSizeVar + if n < 5 + then liftIO . V.update vty $ x + else return () + + -- Read the trigger reference for the post-build event. This will be + -- 'Nothing' if the guest application hasn't subscribed to this event. + mPostBuildTrigger <- readRef postBuildTriggerRef + + -- When there is a subscriber to the post-build event, fire the event. + forM_ mPostBuildTrigger $ \postBuildTrigger -> + fire [postBuildTrigger :=> Identity ()] $ return () + + -- After firing the post-build event, sample the vty result and update + -- the display. + updateVty + + -- Subscribe to an 'Event' of that the guest application can use to + -- request application shutdown. We'll check whether this 'Event' is firing + -- to determine whether to terminate. + shutdown <- subscribeEvent $ _vtyResult_shutdown vtyResult + + -- Fork a thread and continuously get the next vty input event, and then + -- write the input event to our channel of FRP 'Event' triggers. + -- The thread is forked here because 'nextEvent' blocks. + nextEventThread <- liftIO $ forkIO $ forever $ do + -- Retrieve the next input event. + ne <- V.nextEvent vty + let -- The reference to the vty input 'EventTrigger'. This is the trigger + -- we'd like to associate the input event value with. + triggerRef = EventTriggerRef vtyEventTriggerRef + -- Create an event 'TriggerInvocation' with the value that we'd like + -- the event to have if it is fired. It may not fire with this value + -- if nobody is subscribed to the 'Event'. + triggerInvocation = TriggerInvocation ne $ return () + -- Write our input event's 'EventTrigger' with the newly created + -- 'TriggerInvocation' value to the queue of events. + writeChan events [triggerRef :=> triggerInvocation] + modifyMVar_ chanSizeVar (return . (+1)) + + triggerEventThread <- liftIO $ forkIO $ forever $ do + ev <- readChan triggerEvents + writeChan events ev + modifyMVar_ chanSizeVar (return . (+1)) + + + numFramesVar :: MVar Int <- liftIO $ newMVar 0 + + -- The main application loop. We wait for new events, fire those that + -- have subscribers, and update the display. If we detect a shutdown + -- request, the application terminates. + fix $ \loop -> do + -- Read the next event (blocking). + ers <- liftIO $ readChan events + liftIO $ modifyMVar_ chanSizeVar (return . (+ (-1))) + stop <- do + -- Fire events that have subscribers. + fireEventTriggerRefs fc ers $ + -- Check if the shutdown 'Event' is firing. + readEvent shutdown >>= \case + Nothing -> return False + Just _ -> return True + + -- potato debug logging + {- + liftIO $ do + nFrames <- readMVar numFramesVar + hPutStrLn stderr $ "frame: " <> show nFrames <> " ticks: " <> show (length stop) + hFlush stderr + modifyMVar_ numFramesVar (return . (+1)) + -} + + if or stop + then liftIO $ do -- If we received a shutdown 'Event' + killThread nextEventThread -- then stop reading input events and + killThread triggerEventThread + V.shutdown vty -- call the 'Graphics.Vty.Vty's shutdown command. + + else do -- Otherwise, update the display and loop. + updateVty + loop + where + -- TODO Some part of this is probably general enough to belong in reflex + -- | Use the given 'FireCommand' to fire events that have subscribers + -- and call the callback for the 'TriggerInvocation' of each. + fireEventTriggerRefs + :: (Monad (ReadPhase m), MonadIO m) + => FireCommand t m + -> [DSum (EventTriggerRef t) TriggerInvocation] + -> ReadPhase m a + -> m [a] + fireEventTriggerRefs (FireCommand fire) ers rcb = do + mes <- liftIO $ + forM ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do + me <- readIORef er + return $ fmap (\e -> e :=> Identity a) me + a <- fire (catMaybes mes) rcb + liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb + return a + +-- | Run a 'VtyApp' with a 'Graphics.Vty.Vty' handle with a standard configuration. +runVtyApp + :: (forall t m. VtyApp t m) + -> IO () +runVtyApp app = do + vty <- getDefaultVty + runVtyAppWithHandle vty app + +-- | Returns the standard vty configuration with mouse mode enabled. +getDefaultVty :: IO V.Vty +getDefaultVty = do + cfg <- V.standardIOConfig + V.mkVty $ cfg { V.mouseMode = Just True } diff --git a/src/Potato/Reflex/Vty/Widget.hs b/src/Potato/Reflex/Vty/Widget.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Reflex/Vty/Widget.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + + +module Potato.Reflex.Vty.Widget + ( + SingleClick(..) + , singleClick + , singleClickNoDragOffSimple + , singleClickWithDownState + , DoubleClickConfig(..) + , doubleClick + , doubleClickSimple + + , splitHDrag + , DragState(..) + , Drag2(..) + , drag2 + ) where + +import Prelude + +import qualified Graphics.Vty as V + +import Reflex +import Reflex.Class () +import Reflex.Vty.Widget +import Reflex.Vty.Widget.Input.Mouse + + + +import Control.Monad.NodeId +import Control.Monad.Reader +import System.Clock + + +-- currently only works for a SINGLE POINT +-- TODO integrate with pane2 so it reports clicks that happen on pane. +data SingleClick = SingleClick + { _singleClick_button :: V.Button + , _singleClick_coordinates :: (Int, Int) -- ^ coordinates of down click + , _singleClick_modifiers :: [V.Modifier] + , _singleClick_didDragOff :: Bool + } + deriving (Eq, Ord, Show) + + +singleClick :: (Reflex t, MonadHold t m, MonadFix m, HasInput t m) => V.Button -> m (Event t SingleClick) +singleClick btn = do + let + -- TODO implement for pane2 instead + withinBounds (Drag2 (fromX, fromY) (toX, toY) _ _ _) = fromX == toX && fromY == toY + dragEv <- drag2 btn + didStayOnDyn <- foldDyn (const . withinBounds) False dragEv + return $ flip push dragEv $ \d@(Drag2 (fromX, fromY) _ _ mods ds) -> do + didStayOn <- sample . current $ didStayOnDyn + return $ if ds == DragEnd && withinBounds d + then Just $ SingleClick btn (fromX, fromY) mods (not didStayOn) + else Nothing + +singleClickNoDragOffSimple :: (Reflex t, MonadHold t m, MonadFix m, HasInput t m) => V.Button -> m (Event t ()) +singleClickNoDragOffSimple btn = do + ev <- singleClick btn + return $ fmapMaybe (\sc -> if _singleClick_didDragOff sc then Nothing else Just ()) ev + + +singleClickWithDownState :: (Reflex t, MonadHold t m, MonadFix m, HasInput t m) => V.Button -> m (Event t SingleClick, Dynamic t Bool) +singleClickWithDownState btn = do + let + -- TODO implement for pane2 instead + withinBounds (Drag2 (fromX, fromY) (toX, toY) _ _ _) = fromX == toX && fromY == toY + dragEv <- drag2 btn + downDyn <- foldDyn (\(Drag2 _ _ _ _ ds) _ -> ds /= DragEnd) False dragEv + didStayOnDyn <- foldDyn (const . withinBounds) False dragEv + let + scEv = flip push dragEv $ \d@(Drag2 (fromX, fromY) _ _ mods ds) -> do + didStayOn <- sample . current $ didStayOnDyn + return $ if ds == DragEnd && withinBounds d + then Just $ SingleClick btn (fromX, fromY) mods (not didStayOn) + else Nothing + return (scEv, downDyn) + +data DoubleClickConfig = DoubleClickConfig { + -- TODO lol... + --_doubleClickConfig_spaceTolerance :: (Int, Int) -- the (x,y) mouse travel tolerance + _doubleClickConfig_timeTolerance :: Integer -- the time (ms) between click tolerance + , _dobuleClickConfig_button :: V.Button + } + +doubleClick :: (Reflex t, MonadHold t m, MonadFix m, PerformEvent t m, MonadIO (Performable m), HasInput t m) => DoubleClickConfig -> m (Event t ()) +doubleClick DoubleClickConfig {..} = do + singleClickEv <- singleClickNoDragOffSimple _dobuleClickConfig_button + singleClickTimeEv <- performEvent $ ffor singleClickEv $ \_ -> do + liftIO $ getTime Monotonic + lastClickTimeDyn <- holdDyn (-1) $ singleClickTimeEv + (fmap (fmapMaybe id)) $ performEvent $ ffor (tag (current lastClickTimeDyn) singleClickEv) $ \ns -> do + time <- liftIO $ getTime Monotonic + return $ if (toNanoSecs $ time - ns) `div` 1000000 < _doubleClickConfig_timeTolerance + then Just () + else Nothing + +doubleClickSimple :: (Reflex t, MonadHold t m, MonadFix m, PerformEvent t m, MonadIO (Performable m), HasInput t m) => m (Event t ()) +doubleClickSimple = doubleClick DoubleClickConfig { + --_doubleClickConfig_spaceTolerance = (0,0) + _doubleClickConfig_timeTolerance = 300 + , _dobuleClickConfig_button = V.BLeft + } + + +integralFractionalDivide :: (Integral a, Fractional b) => a -> a -> b +integralFractionalDivide n d = fromIntegral n / fromIntegral d + +-- | A split of the available space into two parts with a draggable separator. +-- Starts with half the space allocated to each, and the first pane has focus. +-- Clicking in a pane switches focus. +splitHDrag :: (Reflex t, MonadFix m, MonadHold t m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m) + => Int -- ^ initial width of left panel + -> m () + -> m a + -> m b + -> m (a,b) +splitHDrag splitter0 wS wA wB = mdo + dh <- displayHeight + dw <- displayWidth + w0 <- sample . current $ dw + dragE <- drag V.BLeft + splitterCheckpoint <- holdDyn splitter0 $ leftmost [fst <$> ffilter snd dragSplitter, resizeSplitter] + splitterPos <- holdDyn splitter0 $ leftmost [fst <$> dragSplitter, resizeSplitter] + splitterFrac <- holdDyn (integralFractionalDivide splitter0 w0) $ ffor (attach (current dw) (fst <$> dragSplitter)) $ \(w, x) -> + fromIntegral x / (max 1 (fromIntegral w)) + let dragSplitter = fforMaybe (attach (current splitterCheckpoint) dragE) $ + \(splitterX, Drag (fromX, _) (toX, _) _ _ end) -> + if splitterX == fromX then Just (toX, end) else Nothing + regA = Region 0 0 <$> splitterPos <*> dh + regS = Region <$> splitterPos <*> 0 <*> 1 <*> dh + regB = Region <$> (splitterPos + 1) <*> 0 <*> (dw - splitterPos - 1) <*> dh + resizeSplitter = ffor (attach (current splitterFrac) (updated dw)) $ + \(frac, w) -> round (frac * fromIntegral w) + focA <- holdDyn True $ leftmost + [ True <$ mA + , False <$ mB + ] + + (mA, rA) <- pane regA focA $ withMouseDown wA + pane regS (pure False) wS + (mB, rB) <- pane regB (not <$> focA) $ withMouseDown wB + + return (rA, rB) + where + withMouseDown x = do + m <- mouseDown V.BLeft + x' <- x + return (m, x') + + + +data DragState = DragStart | Dragging | DragEnd deriving (Eq, Ord, Show) + +-- | Same as 'Drag' but able to track drag start case +data Drag2 = Drag2 + { _drag2_from :: (Int, Int) -- ^ Where the drag began + , _drag2_to :: (Int, Int) -- ^ Where the mouse currently is + , _drag2_button :: V.Button -- ^ Which mouse button is dragging + , _drag2_modifiers :: [V.Modifier] -- ^ What modifiers are held + , _drag2_state :: DragState -- ^ Whether the drag ended (the mouse button was released) + } + deriving (Eq, Ord, Show) + +-- | Same as 'drag' but returns 'Drag2' which tracks drag start events +drag2 + :: (Reflex t, MonadFix m, MonadHold t m, HasInput t m) + => V.Button + -> m (Event t Drag2) +drag2 btn = mdo + inp <- input + let f :: Maybe Drag2 -> V.Event -> Maybe Drag2 + f Nothing = \case + V.EvMouseDown x y btn' mods + | btn == btn' -> Just $ Drag2 (x,y) (x,y) btn' mods DragStart + | otherwise -> Nothing + _ -> Nothing + f (Just (Drag2 from _ _ mods st)) = \case + V.EvMouseDown x y btn' mods' + | st == DragEnd && btn == btn' -> Just $ Drag2 (x,y) (x,y) btn' mods' DragStart + | btn == btn' -> Just $ Drag2 from (x,y) btn mods' Dragging + | otherwise -> Nothing -- Ignore other buttons. + V.EvMouseUp x y (Just btn') + | st == DragEnd -> Nothing + | btn == btn' -> Just $ Drag2 from (x,y) btn mods DragEnd + | otherwise -> Nothing + V.EvMouseUp x y Nothing -- Terminal doesn't specify mouse up button, + -- assume it's the right one. + | st == DragEnd -> Nothing + | otherwise -> Just $ Drag2 from (x,y) btn mods DragEnd + _ -> Nothing + let + newDrag = attachWithMaybe f (current dragD) inp + dragD <- holdDyn Nothing $ Just <$> newDrag + return (fmapMaybe id $ updated dragD) diff --git a/src/Potato/Reflex/Vty/Widget/FileExplorer.hs b/src/Potato/Reflex/Vty/Widget/FileExplorer.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Reflex/Vty/Widget/FileExplorer.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +module Potato.Reflex.Vty.Widget.FileExplorer ( + FileExplorerWidgetConfig(..) + , FileExplorerWidget(..) + , holdFileExplorerWidget +) where + +import Relude + +import Potato.Flow +import Potato.Flow.Controller +import Potato.Flow.Vty.Attrs +import Potato.Flow.Vty.Input +import Potato.Reflex.Vty.Helpers +import Potato.Reflex.Vty.Widget +import Potato.Flow.Vty.PotatoReader +import Potato.Reflex.Vty.Widget.TextInputHelpers +import Potato.Reflex.Vty.Widget.ScrollBar + + + +import Control.Exception (catch) +import Control.Monad.Fix +import Data.Align +import Data.Dependent.Sum (DSum ((:=>))) +import qualified Data.IntMap.Strict as IM +import qualified Data.List as L +import qualified Data.Sequence as Seq +import qualified Data.Text as T +import Data.Text.Zipper +import qualified Data.Text.Zipper as TZ +import Data.These +import qualified System.Directory as FP +import qualified System.FilePath as FP + +import qualified Graphics.Vty as V +import Reflex +import Reflex.Network +import Reflex.Potato.Helpers +import Reflex.Vty + + +fetchDirectory :: forall t m. (MonadWidget t m) => Event t FP.FilePath -> m (Event t [(Bool, FP.FilePath)]) +fetchDirectory ev = let + catchfn :: SomeException -> IO [(Bool, FP.FilePath)] + catchfn = const (return []) + in performEvent $ ffor ev $ \dir -> liftIO $ (flip catch catchfn) $ do + --workingDir <- FP.getCurrentDirectory + contents <- FP.getDirectoryContents dir + contentsWithFolder <- forM contents $ \d -> FP.doesDirectoryExist (FP.combine dir d) >>= return . (,FP.combine dir d) + let + sortfn (d1,_) (d2,_) = case (d1,d2) of + (True, False) -> LT + (False, True) -> GT + _ -> EQ + return $ (L.sortBy sortfn) contentsWithFolder + +data FileExplorerWidgetConfig t = FileExplorerWidgetConfig { + _fileExplorerWidgetConfig_clickDownStyle :: Behavior t V.Attr + + -- TODO we don't need full filepath + , _fileExplorerWidgetConfig_fileFilter :: FP.FilePath -> Bool + , _fileExplorerWidgetConfig_initialFile :: FP.FilePath +} + +data FileExplorerWidget t = FileExplorerWidget { + -- the filename in the entry area + _fileExplorerWidget_filename :: Behavior t Text + -- the directory <> filename in the entry area + , _fileExplorerWidget_fullfilename :: Behavior t FP.FilePath + , _fileExplorerWidget_doubleClickFile :: Event t FP.FilePath -- pretty sure this is just single click for now -__- + , _fileExplorerWidget_directory :: Dynamic t FP.FilePath + , _fileExplorerWidget_returnOnfilename :: Event t () -- fires when you hit the "return" key in file name input area + , _fileExplorerWidget_doubleClick :: Event t () -- fires when you double click on an existing valid file +} + +data FileClick = FileClick { + _fileClick_isDouble :: Bool + , _fileClick_isFolder :: Bool + , _fileClick_file :: FP.FilePath + } +-- TODO reduce constraints, don't use HasPotato +holdFileExplorerWidget :: forall t m. (MonadLayoutWidget t m, HasPotato t m) + => FileExplorerWidgetConfig t + -> m (FileExplorerWidget t) +holdFileExplorerWidget FileExplorerWidgetConfig {..} = mdo + + baseStyle <- theme + isInitialFileDir <- liftIO (FP.doesDirectoryExist _fileExplorerWidgetConfig_initialFile) + + -- select + click is one way to do choose file to save to but double click is prob better... + --selectedDyn :: Dynamic t (Maybe Int) + --selectedDyn <- holdDyn Nothing $ leftmost [selectEv, ] + + -- set up directory/filename text field stuff + pb <- getPostBuild + let + initialDirFileEv :: Event t (FilePath, FilePath) = flip pushAlways pb $ \_ -> do + let + dir = FP.takeDirectory _fileExplorerWidgetConfig_initialFile + file = FP.takeFileName _fileExplorerWidgetConfig_initialFile + return $ if isInitialFileDir then (_fileExplorerWidgetConfig_initialFile, "") else (dir, file) + foldDirDynFn new old = case FP.takeFileName new of + "." -> old + ".." -> FP.takeDirectory old + _ -> new + dirDyn <- foldDyn foldDirDynFn "" (leftmost [fmap fst initialDirFileEv, clickFolderEvent, setFolderEvent]) + fetchDirComplete <- fetchDirectory (updated dirDyn) + dirContentsDyn <- holdDyn [] fetchDirComplete + + let + -- set up directory list widget + dirWidget filenameinentryfielddyn xs = (grout . stretch) 1 $ row $ mdo + r <- (grout . stretch) 1 $ col $ do + let + scrolledContents = ffor vScrollDyn $ \vscroll -> fmap leftmost $ forM (drop vscroll xs) $ \(isFolder, path) -> do + (grout . fixed) 1 $ row $ do + let + clickable = _fileExplorerWidgetConfig_fileFilter path + + -- TODO design proper styling... (maybe prefix folders with > instead of style differently?) + + -- TODO make it so you need to click on the name??? + (singleClick', downDyn) <- singleClickWithDownState V.BLeft + doubleClick <- doubleClickSimple + + -- TODO highlight if matches the file entry box + let + styleBeh = join $ ffor2 (current filenameinentryfielddyn) (current downDyn) $ \fn d -> if d || T.unpack fn == filename then _fileExplorerWidgetConfig_clickDownStyle else baseStyle + filename = FP.takeFileName path + pathtext' = T.pack filename + pathtext = if isFolder + then "> " <> pathtext' + else if clickable + then " *" <> pathtext' + else " " <> pathtext' + + localTheme (const styleBeh) $ do + text (constant pathtext) + + let + singleClick = ffilter (not . _singleClick_didDragOff) singleClick' + makefileclick isdouble = FileClick { + _fileClick_isDouble = isdouble + , _fileClick_isFolder = isFolder + , _fileClick_file = path + } + alignWithFn th = case th of + This _ -> makefileclick False + That _ -> makefileclick True + These _ _ -> makefileclick True + fileclickev = alignWith alignWithFn singleClick (traceEvent "double" doubleClick) + + if isFolder || clickable + then return fileclickev + else return never + join . fmap (switchHold never) . networkView $ scrolledContents + vScrollDyn <- (grout . fixed) 1 $ col $ do + vScrollBar (constDyn (length xs)) + return r + + -- put it all together + (clickEvent, setFolderRawEvent, filenameDyn, enterEv) <- col $ do + -- TODO consider combining filename and directory into one... + let + setFileEv = fmap T.pack $ leftmost [fmap snd initialDirFileEv, fmap FP.takeFileName clickFileEvent] + + + -- input for filename + (fninputfid, (filenameDyn', enterEv')) <- (tile . fixed) 1 $ row $ do + (grout . fixed) 10 $ text "filename" + (tile' . stretch) 1 $ (,) <$> filenameInput "" setFileEv <*> key V.KEnter + + -- focus the filename input + requestFocus (pb $> Refocus_Id fninputfid) + + -- input for directory + setFolderRawEvent' <- (tile . fixed) 1 $ row $ do + (grout . fixed) 10 $ text "directory" + (tile . stretch) 1 $ do + let indirev = (updated (fmap T.pack dirDyn)) + dirdyn <- filenameInput "" indirev + return $ difference (updated $ fmap T.unpack dirdyn) indirev + + -- click in dir list event + (clickEvent') <- (grout . stretch) 5 $ box (constant singleBoxStyle) $ do + join . fmap (switchHold never) $ networkView (ffor dirContentsDyn (dirWidget filenameDyn')) + + return (clickEvent', setFolderRawEvent', filenameDyn', enterEv') + + -- perform the IO query to get the folder contents + mSetFolderEvent <- performEvent $ ffor setFolderRawEvent $ \dir -> liftIO $ do + exists <- FP.doesDirectoryExist dir + if exists then return $ Just dir else return Nothing + let + setFolderEvent = fmapMaybe id mSetFolderEvent + + let + -- TODO consider using doubleClickEvent (you might want to implement highlight selection in this case) + maybeClickFolder fc = if _fileClick_isFolder fc && not (_fileClick_isDouble fc) then Just (_fileClick_file fc) else Nothing + maybeClickFile fc = if not (_fileClick_isFolder fc) && not (_fileClick_isDouble fc) then Just (_fileClick_file fc) else Nothing + maybeDoubleClickFile fc = if not (_fileClick_isFolder fc) && _fileClick_isDouble fc then Just (_fileClick_file fc) else Nothing + + clickFolderEvent = fmapMaybe maybeClickFolder clickEvent + clickFileEvent = fmapMaybe maybeClickFile clickEvent + doubleClickFileEvent = fmapMaybe maybeDoubleClickFile clickEvent + + fullfilenameDyn = ffor2 dirDyn filenameDyn $ \dir fn -> FP.combine dir (T.unpack fn) + + return $ FileExplorerWidget { + _fileExplorerWidget_filename = current filenameDyn + , _fileExplorerWidget_fullfilename = current fullfilenameDyn + , _fileExplorerWidget_doubleClickFile = clickFileEvent + , _fileExplorerWidget_directory = dirDyn + , _fileExplorerWidget_returnOnfilename = void enterEv + , _fileExplorerWidget_doubleClick = void doubleClickFileEvent + } diff --git a/src/Potato/Reflex/Vty/Widget/Menu.hs b/src/Potato/Reflex/Vty/Widget/Menu.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Reflex/Vty/Widget/Menu.hs @@ -0,0 +1,108 @@ +-- TODO FINISH INCOMPLETE +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +module Potato.Reflex.Vty.Widget.Menu ( + holdMenuWidget +) where + +import Relude + +import Potato.Reflex.Vty.Helpers +import Potato.Reflex.Vty.Widget + +import qualified Graphics.Vty.Input.Events as V +import Reflex +import Reflex.Network +import Reflex.Potato.Helpers +import Reflex.Vty + + +import Data.Default +import qualified Data.Map as Map +import qualified Data.Text as T +import Data.Tree + +type Shortcut = () + +data MenuTreeNode k = MenuTreeNode { + _menuTreeNode_key :: k -- MUST BE UNIQUE + , _menuTreeNode_label :: Text + , _menuTreeNode_shortcut :: Maybe Shortcut +} deriving (Eq, Show) + +data MenuWidgetConfig t k = MenuWidgetConfig { + _menuWidgetConfig_menus :: Dynamic t ([Tree (MenuTreeNode k)]) +} + +data MenuWidget t k = MenuWidget { + _menuWidget_activated :: Event t k + , _menuWidget_capturedInput :: Event t () +} + +indexedMerge :: (Reflex t) => [Event t a] -> Event t (Int,a) +indexedMerge evs = leftmost . fmap (\(i,ev)-> fmap (i,) ev) . zip [0..] $ evs + +type Pos = (Int,Int) + +type MenuFocus k = [(k, Int, Pos)] + +holdMenuWidget = undefined + +{- +holdMenuWidget :: + forall t m k. (MonadWidget t m) + => MenuWidgetConfig t k + -> m (MenuWidget t k) +holdMenuWidget MenuWidgetConfig {..} = mdo + let + makeMenuWidget :: [Tree (MenuTreeNode k)] -> m () + makeMenuWidget roots = do + -- TODO + -- if line down to currently opened menu still exists, keep focus (I guess to do this really right, you should track index as well so there's no menu jump glitcehs) + + -- setup shortcut map + let + shortcutfmapfn MenuTreeNode {..} = case _menuTreeNode_shortcut of + Nothing -> Nothing + Just x -> Just (x, _menuTreeNode_key) + rootMaybeShortcuts = fmap (fmap shortcutfmapfn) roots + shortcuts = catMaybes . join . fmap flatten $ rootMaybeShortcuts + shortcutMap :: Behavior t (Map.Map Shortcut k) = constant $ Map.fromList $ shortcuts + + -- render the first layer at top row + topLayerOut <- beginLayout $ row $ + forM roots $ \(Node MenuTreeNode {..} _) -> do + let l = T.length _menuTreeNode_label + (tile . fixed) (constDyn $ l + 1) $ do + -- TODO highlight if selected in focusDyn + text (constant _menuTreeNode_label) + click <- mouseDown V.BLeft + return (l+1, click $> _menuTreeNode_key) + let + topOffsets = scanl (+) 0 $ fmap fst topLayerOut + -- (index, xoffset) + topEv :: Event t (Int, Int) = indexedMerge $ zipWith (\offx ev -> fmap (,offx) ev) topOffsets $ fmap snd topLayerOut + + rootSetFocusEv = ffor topEv $ \(idx,(k,xoff)) -> [(k,idx,(xoff,1))] + + childWidgetFn [] = return never + childWidgetFn ((k,idx,(xoff,yoff)):xs) = do + forM + selfClickEv + childClickEv <- childWidgetFn xs + return $ leftmost [selfClickEv, childClickEv] + + -- TODO list to changes in focus Dyn and render each following layer + childMenusDyn = ffor (fmap tail focusDyn) $ childWidgetFn + + + focusDyn :: Dynamic t (MenuFocus k) <- undefined + return () + + + return MenuWidget { + _menuWidget_activated = never + , _menuWidget_capturedInput = never + } +-} diff --git a/src/Potato/Reflex/Vty/Widget/Popup.hs b/src/Potato/Reflex/Vty/Widget/Popup.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Reflex/Vty/Widget/Popup.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +module Potato.Reflex.Vty.Widget.Popup ( + popupPane + , popupPaneSimple +) where + +import Relude + +import Potato.Reflex.Vty.Helpers +import Potato.Reflex.Vty.Widget + +import qualified Graphics.Vty.Input.Events as V +import Reflex +import Reflex.Network +import Reflex.Potato.Helpers +import Reflex.Vty + +import Data.Default + +data PopupPaneSize = PopupPaneSize { + _popupPaneSize_minWidth :: Int + ,_popupPaneSize_minHeight :: Int + , _popupPaneSize_widthRatio :: Float + , _popupPaneSize_heightRatio :: Float + } + +instance Default PopupPaneSize where + def = PopupPaneSize 0 0 0.5 0.5 + +mulRatio :: Int -> Float -> Int +mulRatio i r = ceiling . (*r) . fromIntegral $ i + +type PopupInputWidget t m a = + Event t () -- ^ escape button pressed + -> Event t () -- ^ click outside box + -> m (Event t (), Event t a) -- ^ (close event, output event) + +-- TODO reduce constraints +popupPaneInternal :: forall t m a. (MonadWidget t m) + => PopupPaneSize + -> PopupInputWidget t m a -- ^ widget to be displayed in the popup + -> m (Event t a, Event t ()) -- ^ (inner widget event, closed event) +popupPaneInternal PopupPaneSize {..} widgetFnEv = do + screenWidthDyn <- displayWidth + screenHeightDyn <- displayHeight + let + widthDyn = ffor screenWidthDyn (\sw -> max (mulRatio sw _popupPaneSize_widthRatio) _popupPaneSize_minWidth) + heightDyn = ffor screenHeightDyn (\sh -> max (mulRatio sh _popupPaneSize_heightRatio) _popupPaneSize_minHeight) + regionDyn = ffor2 ((,) <$> screenWidthDyn <*> screenHeightDyn) ((,) <$> widthDyn <*> heightDyn) $ \(sw,sh) (w,h) -> Region { + _region_left = (sw - w) `div` 2 + , _region_top = (sh - h) `div` 2 + , _region_width = w + , _region_height = h + } + escapeEv <- key V.KEsc + outsideMouseEv <- mouseDown V.BLeft + (outputEv, closeEv) <- pane regionDyn (constDyn True) $ do + insideMouseEv <- mouseDown V.BLeft + (closeEv', outputEv') <- widgetFnEv (void escapeEv) (void $ difference outsideMouseEv insideMouseEv) + return (outputEv', closeEv') + return (outputEv, closeEv) + +-- TODO reduce constraints +-- | popupPane can only emit a single event before closing itself +-- clicking outside the popup closes the popup and emits no events (conisder disabling this as default behavior?) +popupPane :: forall t m a. (MonadWidget t m) + => PopupPaneSize + -> Event t (PopupInputWidget t m a) + -> m (Event t a, Dynamic t Bool) -- ^ (inner widget event, popup state) +popupPane size widgetEv = mdo + let + emptyPopupWidget _ _ = return (never, never) + inputEv = leftmost [widgetEv, canceledEv $> emptyPopupWidget] + innerDynEv :: Dynamic t (Event t a, Event t ()) + <- networkHold (return (never, never)) (fmap (popupPaneInternal size) inputEv) + let + innerWidgetEv = switchDyn (fmap fst innerDynEv) + canceledEv = switchDyn (fmap snd innerDynEv) + outputStateDyn <- holdDyn False $ leftmostWarn "popupOverride" [widgetEv $> True, canceledEv $> False] + return (innerWidgetEv, outputStateDyn) + + +-- | a simple popup pane +-- the inner popup pane event closes the popup pane (e.g. notification dialog box with "ok" button) +-- clicking outside or pressing escape closes the popup and emits no events +popupPaneSimple :: forall t m a. (MonadWidget t m) + => PopupPaneSize + -> Event t (m (Event t a)) -- ^ when inner event fires, popup is disabled + -> m (Event t a, Dynamic t Bool) -- ^ (inner widget event, popup state) +popupPaneSimple size widgetEv = popupPane size fancyWidgetEv where + fmapfn w = \escEv clickOutsideEv -> fmap (\outputEv -> (leftmost [escEv, clickOutsideEv, void outputEv], outputEv)) w + fancyWidgetEv = fmap fmapfn widgetEv diff --git a/src/Potato/Reflex/Vty/Widget/ScrollBar.hs b/src/Potato/Reflex/Vty/Widget/ScrollBar.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Reflex/Vty/Widget/ScrollBar.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +module Potato.Reflex.Vty.Widget.ScrollBar ( + vScrollBar +) where + +import Relude + +import Potato.Reflex.Vty.Helpers +import Potato.Reflex.Vty.Widget + + +import qualified Graphics.Vty as V +import Reflex +import Reflex.Network +import Reflex.Potato.Helpers +import Reflex.Vty + + +import Data.Default +import qualified Data.Sequence as Seq +import Data.Fixed (div') +import Data.These +import Data.Align (align) + + + +emptyDrag2 :: Drag2 +emptyDrag2 = Drag2 { + _drag2_from = (0,0) + , _drag2_to = (0,0) + , _drag2_button = V.BLeft + , _drag2_modifiers = [] + , _drag2_state = DragStart + } + +componentSub :: (Num a) => (a,a) -> (a,a) -> (a,a) +componentSub (a,b) (c,d) = (a-c,b-d) + +onlyIfSimultaneous :: (Reflex t) => Event t a -> Event t b -> Event t a +onlyIfSimultaneous eva evb = fforMaybe (align eva evb) $ \case + These a _ -> Just a + _ -> Nothing + +-- TODO write UTs +-- TODO reduce constraints +vScrollBar :: forall t m a. (MonadWidget t m) + => Dynamic t Int -- ^ content height + -> m (Dynamic t Int) -- ^ offset +vScrollBar contentSizeDyn = mdo + maxSizeDyn <- displayHeight + let + screen_over_content_dyn :: Dynamic t Float = liftA2 (\a b -> fromIntegral a / fromIntegral b ) maxSizeDyn contentSizeDyn + maxSizeDiffDyn = liftA2 (-) maxSizeDyn boxHeightDyn + + maxContentSizeDiffDyn = fromIntegral . max 0 <$> liftA2 (-) contentSizeDyn maxSizeDyn + + boxHeightDyn = fmap ceiling $ liftA2 (*) screen_over_content_dyn (fromIntegral <$> maxSizeDyn) + boxRegionDyn = Region <$> 0 <*> offsetScreenUnitDyn <*> 1 <*> boxHeightDyn + + --innerDragEv will only fire on drag events that started on the scroll bar handle portion + innerDragEv <- pane boxRegionDyn (constDyn True) $ do + -- render the scroll bar handle + fill (constant '#') + drag2 V.BLeft + + d2ev <- drag2 V.BLeft + let + moveDragEv = fmapMaybe (\d2 -> if _drag2_state d2 == Dragging then Just d2 else Nothing) d2ev + lastDrag <- holdDyn emptyDrag2 d2ev + let + deltaDragEv_d1' = attach (current lastDrag) moveDragEv + deltaDragEv_d1 = fmap (\(pd,d) -> _drag2_to d `componentSub` _drag2_to pd) deltaDragEv_d1' + -- only process the event if they are simultaneous with innerDragEv (thus meaning they started on the scroll bar handle) + -- the reason we need to do it this way is because `pane` messes with the mouse coords so we need to get the mouse coords from outside + deltaDragEv = onlyIfSimultaneous (fmap snd deltaDragEv_d1) innerDragEv + + let + content_over_screen_dyn = fmap (\x -> 1 / x) screen_over_content_dyn + dragDeltaAdjustedEv = fmap (\(x,y) -> x * fromIntegral y) (attach (current content_over_screen_dyn) deltaDragEv) + + -- TODO movement when you click on areas off the bar + -- TODO maybe do ^ v arrows at top and bottom to click scroll through 1 at a time + + -- TODO ugg you probably need an inputCaptured event here :\ (or you could just get rid of keyboard movement...) + -- keyboard/scroll movement + kup <- key V.KUp + kdown <- key V.KDown + kpgup <- key V.KPageUp + kpgdown <- key V.KPageDown + mscroll <- mouseScroll + let + requestedScroll :: Event t Float + requestedScroll = leftmost + [ 1 <$ kdown + , (-1) <$ kup + + -- maybe scale to height of scroll bar? + , 8 <$ kpgdown + , (-8) <$ kpgup + + , ffor mscroll $ \case + ScrollDirection_Up -> (-1) + ScrollDirection_Down -> 1 + ] + + -- then put it all together + let + foldOffsetFn (maxdiff, delta) c = max 0 (min maxdiff (c+delta)) + offsetFloatDyn <- foldDyn foldOffsetFn 0 (attach (current maxContentSizeDiffDyn) (leftmost [dragDeltaAdjustedEv, requestedScroll])) + + let + offsetScreenUnitDyn = fmap round . liftA2 (*) screen_over_content_dyn $ offsetFloatDyn + + return $ fmap floor offsetFloatDyn + + +{- + + data DragState = DragStart | Dragging | DragEnd deriving (Eq, Ord, Show) + + -- | Same as 'Drag' but able to track drag start case + data Drag2 = Drag2 + { _drag2_from :: (Int, Int) -- ^ Where the drag began + , _drag2_to :: (Int, Int) -- ^ Where the mouse currently is + , _drag2_button :: V.Button -- ^ Which mouse button is dragging + , _drag2_modifiers :: [V.Modifier] -- ^ What modifiers are held + , _drag2_state :: DragState -- ^ Whether the drag ended (the mouse button was released) + } + deriving (Eq, Ord, Show) + + -- | Same as 'drag' but returns 'Drag2' which tracks drag start events + drag2 + :: (Reflex t, MonadFix m, MonadHold t m, HasInput t m) + => V.Button + -> m (Event t Drag2) + drag2 btn = mdo-} diff --git a/src/Potato/Reflex/Vty/Widget/TextInputHelpers.hs b/src/Potato/Reflex/Vty/Widget/TextInputHelpers.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Reflex/Vty/Widget/TextInputHelpers.hs @@ -0,0 +1,221 @@ +-- extends methods Text.Input +-- TODO belongs in Potato because depends on HasPotato +-- alternatively, drop the HasPotato requirement by passing in Behavior t V.Attr into these methods + +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +module Potato.Reflex.Vty.Widget.TextInputHelpers where + +import Relude + +import Potato.Flow +import Potato.Flow.Vty.Attrs +import Potato.Reflex.Vty.Helpers +import Potato.Reflex.Vty.Widget +import Potato.Flow.Vty.PotatoReader + +import Control.Monad.Fix +import Control.Monad.NodeId +import Data.Align +import Data.Char (isNumber) +import Data.Dependent.Sum (DSum ((:=>))) +import qualified Data.IntMap as IM +import qualified Data.List.Extra as L +import qualified Data.Maybe +import qualified Data.Sequence as Seq +import qualified Data.Text as T +import qualified Data.Text.Zipper as TZ +import Data.These +import Data.Tuple.Extra + +import qualified Graphics.Vty as V +import Reflex +import Reflex.Network +import Reflex.Potato.Helpers +import Reflex.Vty + + +infiniteWidthDyn :: (Reflex t) => Dynamic t Int +infiniteWidthDyn = constDyn 99999 + + +type UpdateTextZipperMethod = V.Event -> Maybe (TZ.TextZipper -> TZ.TextZipper) + +makeCaptureFromUpdateTextZipperMethod :: (Reflex t, MonadFix m, MonadNodeId m, HasInput t m) => UpdateTextZipperMethod -> m (Event t()) +makeCaptureFromUpdateTextZipperMethod f = do + inp <- input + return $ void $ fforMaybe inp f + +makeModifyEventFromUpdateTextZipperMethod :: + UpdateTextZipperMethod + -> V.Event -- ^ The vty event to handle + -> TZ.TextZipper -- ^ The zipper to modify + -> TZ.TextZipper +makeModifyEventFromUpdateTextZipperMethod f = \ev -> fromMaybe id (f ev) + + +updateTextZipperForSingleCharacter :: UpdateTextZipperMethod +updateTextZipperForSingleCharacter ev = case ev of + V.EvKey (V.KChar '\t') [] -> Just $ id + V.EvKey (V.KChar k) [] -> Just $ const $ TZ.top $ TZ.insertChar k TZ.empty + V.EvKey V.KBS [] -> Just $ const TZ.empty + V.EvKey V.KDel [] -> Just $ const TZ.empty + V.EvKey (V.KChar 'u') [V.MCtrl] -> Just $ const TZ.empty + _ -> Nothing + +updateTextZipperForNumberInput + :: UpdateTextZipperMethod +updateTextZipperForNumberInput ev = case ev of + V.EvKey (V.KChar k) [] | isNumber k -> Just $ TZ.insertChar k + V.EvKey V.KBS [] -> Just $ TZ.deleteLeft + V.EvKey V.KDel [] -> Just $ TZ.deleteRight + V.EvKey V.KLeft [] -> Just $ TZ.left + V.EvKey V.KRight [] -> Just $ TZ.right + V.EvKey V.KHome [] -> Just $ TZ.home + V.EvKey V.KEnd [] -> Just $ TZ.end + V.EvKey (V.KChar 'u') [V.MCtrl] -> Just $ const TZ.empty + _ -> Nothing + + +singleCellTextInput + :: (MonadWidget t m, HasPotato t m) + => Event t (TZ.TextZipper -> TZ.TextZipper) + -> TZ.TextZipper + -> m (Dynamic t Text) +singleCellTextInput modifyEv c0 = do + i <- input + textInputCustom (mergeWith (.) [fmap (makeModifyEventFromUpdateTextZipperMethod updateTextZipperForSingleCharacter) i, modifyEv]) c0 + + +-- remember that input dyn can't update the same time the output updates or you will have infinite loop +dimensionInput + :: (MonadWidget t m, HasPotato t m) + => Dynamic t Int + -> m (Dynamic t Int) +dimensionInput valueDyn = do + let + toText = TZ.fromText . show + modifyEv = fmap (\v -> const (toText v)) (updated valueDyn) + v0 <- sample . current $ valueDyn + i <- input + tDyn <- textInputCustom (mergeWith (.) [fmap (makeModifyEventFromUpdateTextZipperMethod updateTextZipperForNumberInput) i, modifyEv]) (toText v0) + --tDyn <- fmap _textInput_value $ textInput (def { _textInputConfig_initialValue = (toText v0)}) + return $ ffor2 valueDyn tDyn $ \v t -> fromMaybe v (readMaybe (T.unpack t)) + + + +updateTextZipperForFilenameCharacters :: UpdateTextZipperMethod +updateTextZipperForFilenameCharacters ev = case ev of + -- TODO you need to do more filtering here + V.EvKey (V.KChar k) [] -> Just $ TZ.insertChar k + V.EvKey V.KBS [] -> Just $ TZ.deleteLeft + V.EvKey V.KDel [] -> Just $ TZ.deleteRight + V.EvKey V.KLeft [] -> Just $ TZ.left + V.EvKey V.KRight [] -> Just $ TZ.right + V.EvKey V.KHome [] -> Just $ TZ.home + V.EvKey V.KEnd [] -> Just $ TZ.end + V.EvKey (V.KChar 'u') [V.MCtrl] -> Just $ const TZ.empty + _ -> Nothing + + +-- UNTESTED +-- prob don't need this version +filenameInputFireEventOnLoseFocus + :: (MonadWidget t m, HasPotato t m, HasFocus t m) + => Text -- ^ initial + -> Event t Text -- ^ override input event + -> m (Event t Text) -- ^ event that fires when text input loses focus +filenameInputFireEventOnLoseFocus t0 overrideEv' = mdo + dw <- displayWidth + i <- input + let + overrideEv = ffor overrideEv' $ \t -> const (TZ.fromText t) + offsetx = ffor2 dw dt $ \w fn -> max 0 (T.length fn - w + 4) + dt <- textInputCustom' infiniteWidthDyn offsetx (mergeWith (.) [fmap (makeModifyEventFromUpdateTextZipperMethod updateTextZipperForFilenameCharacters) i, overrideEv]) (TZ.fromText t0) + focusDyn <- focusedId + lastTextDyn <- holdDyn t0 updatedtextev + let + updatedtextev = flip push (void $ updated focusDyn) $ \_ -> do + t <- sample . current $ dt + told <- sample . current $ lastTextDyn + if t == told + then return Nothing + else return $ Just t + return updatedtextev + +-- UNTESTED +filenameInput + :: (MonadWidget t m, HasPotato t m) + => Text -- ^ initial + -> Event t Text -- ^ override input event + -> m (Dynamic t Text) +filenameInput t0 overrideEv' = mdo + dw <- displayWidth + i <- input + let + overrideEv = ffor overrideEv' $ \t -> const (TZ.fromText t) + offsetx = ffor2 dw dt $ \w fn -> max 0 (T.length fn - w + 4) + dt <- textInputCustom' infiniteWidthDyn offsetx (mergeWith (.) [fmap (makeModifyEventFromUpdateTextZipperMethod updateTextZipperForFilenameCharacters) i, overrideEv]) (TZ.fromText t0) + return dt + +-- | Turn a 'Span' into an 'Graphics.Vty.Image' +{- +spanToImage :: Span V.Attr -> V.Image +spanToImage (Span attrs t) = V.text' attrs t + +images :: [[Span V.Attr]] -> [V.Image] +images = map (V.horizCat . map spanToImage) +-} + +dropSpan :: Int -> [TZ.Span V.Attr] -> [TZ.Span V.Attr] +dropSpan _ [] = [] +dropSpan n ((TZ.Span tag text):xs) = TZ.Span tag (T.drop n text) : dropSpan (max 0 (n - T.length text)) xs + +renderTextZipper :: (MonadWidget t m, HasPotato t m) => Dynamic t Int -> Dynamic t Int -> Dynamic t TZ.TextZipper -> m (Dynamic t (TZ.DisplayLines V.Attr)) +renderTextZipper offsetDyn dw tz = do + f <- focus + + -- TODO do this without sampling (I think this will not update if you change style without recreating these widgets) + -- (you could do this easily by using localTheme) + potatostyle <- askPotato >>= sample . _potatoConfig_style + let + cursorAttributes = _potatoStyle_textfield_cursor potatostyle + normalAttributes = _potatoStyle_textfield_modifying potatostyle + nofocusAttributes = _potatoStyle_textfield_normal potatostyle + attrsDyn = ffor f $ \x -> if x then (normalAttributes, cursorAttributes) else (nofocusAttributes, nofocusAttributes) + + -- TODO this will still render trailing cursor when we aren't focused... please fix + let rows = (\w s (nattr, cattr) -> TZ.displayLines w nattr cattr s) + <$> dw + <*> tz + <*> attrsDyn + img = ffor2 rows offsetDyn $ \rows' ox -> images . fmap (dropSpan ox) . TZ._displayLines_spans $ rows' + tellImages $ (\imgs -> (:[]) . V.vertCat $ imgs) <$> current img + return rows + +-- TODO rename to singelLineTextInputCustom or something +textInputCustom' + :: (MonadWidget t m, HasPotato t m) + => Dynamic t Int + -> Dynamic t Int + -> Event t (TZ.TextZipper -> TZ.TextZipper) + -> TZ.TextZipper + -> m (Dynamic t Text) +textInputCustom' widthDyn offsetDyn modifyEv c0 = mdo + rec v <- foldDyn ($) c0 $ mergeWith (.) + [ modifyEv + , let displayInfo = current ((,) <$> dls <*> offsetDyn) + in ffor (attach displayInfo click) $ \((dl,ox), MouseDown _ (mx, my) _) -> + TZ.goToDisplayLinePosition (ox+mx) my dl + ] + click <- mouseDown V.BLeft + dls <- renderTextZipper offsetDyn widthDyn v + return $ TZ.value <$> v + +textInputCustom + :: (MonadWidget t m, HasPotato t m) + => Event t (TZ.TextZipper -> TZ.TextZipper) + -> TZ.TextZipper + -> m (Dynamic t Text) +textInputCustom = textInputCustom' infiniteWidthDyn (constDyn 0) diff --git a/src/Potato/Reflex/Vty/Widget/Windows.hs b/src/Potato/Reflex/Vty/Widget/Windows.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Reflex/Vty/Widget/Windows.hs @@ -0,0 +1,202 @@ +-- TODO FINISH INCOMPLETE +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +module Potato.Reflex.Vty.Widget.Windows ( + +) where + +import Relude + +import Potato.Reflex.Vty.Helpers +import Potato.Reflex.Vty.Widget + +import qualified Graphics.Vty.Input.Events as V +import Reflex +import Reflex.Network +import Reflex.Potato.Helpers +import Reflex.Vty + +import qualified Data.Map as Map +import Data.Default +import Control.Monad.Fix + +type WidgetId = Int + +data WindowsAttrs t = WindowsAttrs { + +} + +data Window = Window { + _window_name :: Text + , _window_widgetId :: WidgetId + , _window_allowClose :: Bool + , _window_allowMove :: Bool + , _window_allowResize :: Bool +} + +-- note, OneWindow can not have tabs added to it +data Tab = OneWindow Window | Tab [Window] + +data DockDirection = + DockDirection_Left + | DockDirection_Right + | DockDirection_Top + | DockDirection_Bottom + deriving (Show) + +data DockedTab = DockedTab { + _dockedTab_tabs :: [(Int, Tab)] -- left to right, or top to bottom + , _dockedTab_size :: Int + , _dockedTab_dir :: DockDirection +} + +data FreeWindow = FreeWindow { + _freeWindow_window :: Window + , _freeWindow_position :: (Int, Int) + , _freeWindow_size :: (Int, Int) +} + +type WindowWidgetMap t m a = Map WidgetId (m a) +data WindowManagerState t m a = WindowManagerState { + _windowManagerState_docked :: [DockedTab] + , _windowManagerState_free :: [FreeWindow] + , _windowManagerState_size :: Dimension + , _windowManagerState_widgetMap :: WindowWidgetMap t m a +} + +emptyWindowManagerState :: WindowManagerState t m a +emptyWindowManagerState = WindowManagerState { + _windowManagerState_docked = [] + , _windowManagerState_free = [] + , _windowManagerState_size = (0,0) + , _windowManagerState_widgetMap = Map.empty + } + +-- temp math stuff +type Position = (Int, Int) +type Dimension = (Int, Int) +type PosDim = (Position, Dimension) + +makeDynRegion :: (Reflex t) => Dynamic t Position -> Dynamic t Dimension -> Dynamic t Region +makeDynRegion dp dd = ffor2 dp dd $ \(x,y) (w,h) -> Region x y w h + +--(:+) :: (Int, Int) -> (Int, Int) -> (Int, Int) +--(a,b) :+ (x,y) = (a+x, b+y) +--infixl 6 :+ +--(-+) :: (Int, Int) -> (Int, Int) -> (Int, Int) +--(a,b) :+ (x,y) = (a-x, b-y) +--infixl 6 -+ + +computeDockDimensions :: PosDim -> [DockedTab] -> [PosDim] +computeDockDimensions dim = snd . mapAccumL mapAccumFn dim where + mapAccumFn ((accx, accy), (accw, acch)) dt = (newAccDim, dtpd) where + (dtpd, newAccDim) = case _dockedTab_dir dt of + DockDirection_Left -> ( + ((accx, accy), (dw, acch)) + , ((accx+dw, accy), (accw-dw, acch)) + ) + DockDirection_Right -> ( + ((accx + accw - dw, accy), (dw, acch)) + , ((accx, accy), (accw-dw, acch)) + ) + DockDirection_Top -> ( + ((accx, accy), (accw, dh)) + , ((accx, accy+dh), (accw, acch-dh)) + ) + DockDirection_Bottom -> ( + ((accx, accy + acch - dh), (accw, dh)) + , ((accx, accy), (accw, acch-dh)) + ) + where + dw = min accw (_dockedTab_size dt) + dh = min acch (_dockedTab_size dt) + + + +data WindowManagerConfig t m a = WindowManagerConfig { + _windowManagerConfig_initialWidgets :: Map WidgetId (m a) + + -- TODO initial widget configuration + + , _windowManagerConfig_style :: WindowsAttrs t + + -- eventually + --, _windowManagerConfig_addWidget :: Event t +} + +data WMCmd = WMCmd_None + +{- TODO fix for new layout stuff +windowManager :: + forall t m a. (Reflex t, Adjustable t m, NotReady t m, PostBuild t m, MonadFix m, MonadHold t m, MonadNodeId m, Monad m) + => WindowManagerConfig t m a + -> m (Event t (NonEmpty a)) +windowManager WindowManagerConfig {..} = mdo + + inpEv <- input + widthDyn <- displayWidth + heightDyn <- displayHeight + initialWidth <- sample . current $ widthDyn + initialHeight <- sample . current $ heightDyn + + let + cmdev = never + foldfn :: WMCmd -> WindowManagerState t m a -> WindowManagerState t m a + foldfn cmd wms@WindowManagerState {..} = r where + r = wms + + initialState = emptyWindowManagerState { + _windowManagerState_size = (initialWidth, initialHeight) + } + + wmsDyn <- foldDyn foldfn initialState cmdev + + -- TODO wrap everything in a VtyWidget so you can capture mouse input for dock manipulation + + -- TODO first render docked widgets + + -- next render floating widgets + let + freeWindowFn :: WindowWidgetMap t m a -> Dynamic t Bool -> Dynamic t FreeWindow -> m a + freeWindowFn wwm focussedDyn freeWindowDyn = do + -- TODO change return type to Dynamic t (m a) so that these params can change too + Window {..} <- sample . current $ fmap _freeWindow_window freeWindowDyn + let + child = case Map.lookup _window_widgetId wwm of + -- TODO pretty sure you should just change to m () + Nothing -> return undefined + Just w -> w + dynRegion = makeDynRegion (_freeWindow_position <$> freeWindowDyn) (_freeWindow_size <$> freeWindowDyn) + pane dynRegion focussedDyn $ do + -- TODO add close button + -- TODO proper window widget, this is just temp render for testing + boxTitle (constant roundedBoxStyle) (constant _window_name) child + + let + freeWindowsDyn = fmap _windowManagerState_free wmsDyn + -- TODO figure out how to pass in focussedDyn + fmapFnFreeWindow wms = simpleList freeWindowsDyn (freeWindowFn (_windowManagerState_widgetMap wms) (constDyn False)) + outputEvs <- networkView $ fmap fmapFnFreeWindow wmsDyn + + + -- TODO fmap through wmsDyn window stack and render them + -- TODO fanMap out window events (close/moved) + return never +-} +-- TODO monad for making initial configuration +{- +dock = do + free $ widget1 + free $ widget2 + free $ widget3 + dock DockDirection_Left $ do + addTab $ do + tab $ widget4 + tab $ widget5 + addTab $ do + tab $ widget6 + tab $ widget7 + dock DockDirection_Bottom $ do + addWindow $ widget8 +-} diff --git a/src/Reflex/Vty/Test/Monad/Host.hs b/src/Reflex/Vty/Test/Monad/Host.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Vty/Test/Monad/Host.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE UndecidableInstances #-} + +module Reflex.Vty.Test.Monad.Host ( + module Reflex.Test.Monad.Host + , ReflexVtyTestT + , queueVtyEvent + , vtyInputTriggerRefs + , userInputTriggerRefs + , userOutputs + , vtyOutputs + , queueMouseEvent + , queueMouseEventInRegion + , queueMouseEventInRegionGated + , queueMouseDrag + , queueMouseDragInRegion + , runReflexVtyTestT + , ReflexVtyTestApp(..) + , runReflexVtyTestApp + -- Reflex.Vty.Widget.Test +) where + +import Relude hiding (getFirst) + +import Control.Monad.Ref +import qualified Data.Map as Map + +import qualified Graphics.Vty as V +import Potato.Reflex.Vty.Widget +import Reflex +import Reflex.Host.Class +import Reflex.Test.Monad.Host (MonadReflexTest (..), ReflexTestT, + ReflexTriggerRef, + TestGuestConstraints, TestGuestT, + runReflexTestT) +import Reflex.Vty + + +-- for debug layout/widget stuff +import Control.Monad.Fix +import Data.Bimap (Bimap) +import qualified Data.Bimap as Bimap +import Data.Semigroup + + + +-- | reflex-vty variant of 'ReflexTestT' which packages an 'VtyEvent' into the input and 'Behavior t [V.Image]' into the output +-- 'uintref' and 'uout' allow user to add their own inputs and outputs +-- 'uintref' will often just be some singleton type (e.g. '()') as the app being tested still has access to the input 'Event t VtyEvent' through the 'VtyWidget' monad +type ReflexVtyTestT t uintref uout m = ReflexTestT t (uintref, ReflexTriggerRef t m VtyEvent) (uout, Behavior t [V.Image]) m + +-- | queue a 'VtyEvent' +queueVtyEvent :: (MonadRef m) => VtyEvent -> ReflexVtyTestT t uintref uout m () +queueVtyEvent vtyev = do + (_, vtytref) <- inputTriggerRefs + queueEventTriggerRef vtytref vtyev + +-- | obtain vty inputs +vtyInputTriggerRefs :: (MonadRef m) => ReflexVtyTestT t uintref uout m (ReflexTriggerRef t m VtyEvent) +vtyInputTriggerRefs = do + (_, vtytrefs) <- inputTriggerRefs + return vtytrefs + +-- | obtain user defined inputs +userInputTriggerRefs :: (MonadRef m) => ReflexVtyTestT t uintref uout m uintref +userInputTriggerRefs = do + (usertrefs, _) <- inputTriggerRefs + return usertrefs + +-- | obtain user defined outputs +userOutputs :: (MonadRef m) => ReflexVtyTestT t uintref uout m uout +userOutputs = do + (useroutputs, _) <- outputs + return useroutputs + +-- | obtain vty outputs +vtyOutputs :: (MonadRef m) => ReflexVtyTestT t uintref uout m (Behavior t [V.Image]) +vtyOutputs = do + (_, vtyoutputs) <- outputs + return vtyoutputs + +-- | queue mouse event +queueMouseEvent :: (MonadRef m) + => Either MouseDown MouseUp -- ^ mouse coordinates are LOCAL to the input region + -> ReflexVtyTestT t uintref uout m () +queueMouseEvent mouse = case mouse of + Left (MouseDown b c mods) -> queueVtyEvent $ uncurry V.EvMouseDown c b mods + Right (MouseUp b c) -> queueVtyEvent $ uncurry V.EvMouseUp c b + + +-- | queue mouse event in a 'DynRegion' +queueMouseEventInRegion :: (Reflex t, MonadSample t m, MonadRef m) + => Dynamic t Region + -> Either MouseDown MouseUp -- ^ mouse coordinates are LOCAL to the input region + -> ReflexVtyTestT t uintref uout m () +queueMouseEventInRegion dr mouse = do + let + absCoords (Region l t _ _) (x,y) = (x+l, y+t) + region <- sample . current $ dr + case mouse of + Left (MouseDown b c mods) -> queueVtyEvent $ uncurry V.EvMouseDown (absCoords region c) b mods + Right (MouseUp b c) -> queueVtyEvent $ uncurry V.EvMouseUp (absCoords region c) b + +-- | queue mouse event in a 'DynRegion' +-- if (local) mouse coordinates are outside of the (absolute) region, returns False and does not queue any event +queueMouseEventInRegionGated :: (Reflex t, MonadSample t m, MonadRef m) + => Dynamic t Region + -> Either MouseDown MouseUp -- ^ mouse coordinates are LOCAL to the input region + -> ReflexVtyTestT t uintref uout m Bool +queueMouseEventInRegionGated dr mouse = do + region <- sample . current $ dr + let + absCoords (Region l t _ _) (x,y) = (x+l, y+t) + coordinates = case mouse of + Left (MouseDown _ c _) -> c + Right (MouseUp _ c) -> c + withinRegion (Region _ _ w h) (x,y) = not $ or [ x < 0, y < 0, x >= w, y >= h ] + if withinRegion region coordinates + then do + case mouse of + Left (MouseDown b c mods) -> queueVtyEvent $ uncurry V.EvMouseDown (absCoords region c) b mods + Right (MouseUp b c) -> queueVtyEvent $ uncurry V.EvMouseUp (absCoords region c) b + return True + else return False + +-- | queue and fire a series of mouse events representing a mouse drag +-- returns collected outputs +queueMouseDrag :: (Reflex t, MonadSample t m, MonadRef m) + => V.Button -- ^ button to press + -> [V.Modifier] -- ^ modifier held during drag + -> NonEmpty (Int,Int) -- ^ list of drag positions + -- TODO add something like DragState to this + -> ((Int,Int) -> ReadPhase m a) -- ^ ReadPhase to run after each normal drag + -> ReflexVtyTestT t uintref uout m (NonEmpty [a]) -- ^ collected outputs +queueMouseDrag = queueMouseDragInRegion (constDyn $ Region 0 0 0 0) +{-queueMouseDrag b mods ps rps = do + let + dragPs' = init ps + -- if there is only 1 elt in ps, then simulate a single click + dragPs = fromMaybe (pure (head ps)) $ viaNonEmpty id dragPs' + endP = last ps + initas <- forM dragPs $ \p -> do + queueVtyEvent (uncurry V.EvMouseDown p b mods) + fireQueuedEventsAndRead (rps p) + queueVtyEvent (uncurry V.EvMouseUp endP (Just b)) + lastas <- fireQueuedEventsAndRead (rps endP) + return $ initas <> (lastas :| []) +-} + +-- | same as queueMouseDrag but coordinates are translated to a region +queueMouseDragInRegion :: (Reflex t, MonadSample t m, MonadRef m) + => Dynamic t Region + + -> V.Button -- ^ button to press + -> [V.Modifier] -- ^ modifier held during drag + -> NonEmpty (Int,Int) -- ^ list of drag positions + -- TODO add something like DragState to this + -> ((Int,Int) -> ReadPhase m a) -- ^ ReadPhase to run after each normal drag + -> ReflexVtyTestT t uintref uout m (NonEmpty [a]) -- ^ collected outputs +queueMouseDragInRegion region b mods ps rps = do + let + dragPs' = init ps + -- if there is only 1 elt in ps, then simulate a single click + dragPs = fromMaybe (pure (head ps)) $ viaNonEmpty id dragPs' + endP = last ps + initas <- forM dragPs $ \p -> do + queueMouseEventInRegion region $ Left (MouseDown b p mods) + fireQueuedEventsAndRead (rps p) + queueMouseEventInRegion region $ Right (MouseUp (Just b) endP) + lastas <- fireQueuedEventsAndRead (rps endP) + return $ initas <> (lastas :| []) + + + +{- +deriving instance (MonadSubscribeEvent t m) => MonadSubscribeEvent t (Input t m) +deriving instance (MonadReflexHost t m) => MonadReflexHost t (Input t m) +deriving instance (MonadSubscribeEvent t m) => MonadSubscribeEvent t (ThemeReader t m) +deriving instance (MonadReflexHost t m) => MonadReflexHost t (ThemeReader t m) +deriving instance (MonadSubscribeEvent t m) => MonadSubscribeEvent t (FocusReader t m) +deriving instance (MonadReflexHost t m) => MonadReflexHost t (FocusReader t m) +deriving instance (MonadSubscribeEvent t m) => MonadSubscribeEvent t (DisplayRegion t m) +deriving instance (MonadReflexHost t m) => MonadReflexHost t (DisplayRegion t m) + + +instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ImageWriter t m) where + subscribeEvent = lift . subscribeEvent +instance MonadReflexHost t m => MonadReflexHost t (ImageWriter t m) where + type ReadPhase (ImageWriter t m) = ReadPhase m + fireEventsAndRead dm a = lift $ fireEventsAndRead dm a + runHostFrame = lift . runHostFrame + +instance MonadSubscribeEvent t m => MonadSubscribeEvent t (NodeIdT m) where + subscribeEvent = lift . subscribeEvent +instance MonadReflexHost t m => MonadReflexHost t (NodeIdT m) where + type ReadPhase (NodeIdT m) = ReadPhase m + fireEventsAndRead dm a = lift $ fireEventsAndRead dm a + runHostFrame = lift . runHostFrame +-} + +type InnerWidgetConstraints t widget = ( + MonadVtyApp t widget + , HasImageWriter t widget + , MonadNodeId widget + , HasDisplayRegion t widget + , HasFocusReader t widget + , HasInput t widget + , HasTheme t widget + ) + +-- | run a 'ReflexVtyTestT' +-- analogous to runReflexTestT +runReflexVtyTestT :: forall uintref uinev uout t m a. (MonadVtyApp t (TestGuestT t m), TestGuestConstraints t m) + -- ^ the reason for this constraint is that we need explicit access to both inner (m) and outer (TestGuestT m) monads + => (Int, Int) -- ^ initial screen size + -> (uinev, uintref) -- ^ make sure uintref match uinev, i.e. return values of newEventWithTriggerRef + + -- TODO extract widget constraints + -> (forall widget. (InnerWidgetConstraints t widget) => uinev -> widget uout) -- ^ VtyWidget to test + -> ReflexVtyTestT t uintref uout m a -- ^ test monad to run + -> m () +runReflexVtyTestT r0 (uinput, uinputtrefs) app rtm = do + + -- generate vty events trigger + (vinev, vintref) <- newEventWithTriggerRef + + size <- holdDyn r0 $ fforMaybe vinev $ \case + V.EvResize w h -> Just (w, h) + _ -> Nothing + + -- unwrap VtyWidget and pass to runReflexTestT + runReflexTestT + ((uinput, vinev), (uinputtrefs, vintref)) + -- TODO need ta add runVtyApp in here + (\(uinput',_) -> runThemeReader (constant V.defAttr) $ + runFocusReader (pure True) $ + runDisplayRegion (fmap (\(w, h) -> Region 0 0 w h) size) $ + runImageWriter $ + runNodeIdT $ + runInput vinev $ do + tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h] + (app uinput')) + rtm + + +-- | class to help bind network and types to a 'ReflexVtyTestT' +-- analogous to ReflexTestApp +class ReflexVtyTestApp app t m | app -> t m where + + data VtyAppInputTriggerRefs app :: Type + data VtyAppInputEvents app :: Type + + data VtyAppOutput app :: Type + getApp :: (InnerWidgetConstraints t widget) + => VtyAppInputEvents app -> widget (VtyAppOutput app) + makeInputs :: m (VtyAppInputEvents app, VtyAppInputTriggerRefs app) + +runReflexVtyTestApp :: (ReflexVtyTestApp app t m, MonadVtyApp t (TestGuestT t m), TestGuestConstraints t m) + => (Int, Int) -- ^ initial screen size + -> ReflexVtyTestT t (VtyAppInputTriggerRefs app) (VtyAppOutput app) m () + -> m () +runReflexVtyTestApp r0 rtm = do + inp <- makeInputs + runReflexVtyTestT r0 inp getApp rtm + +-- Reflex.Vty.Widget.Test +integralFractionalDivide :: (Integral a, Fractional b) => a -> a -> b +integralFractionalDivide n d = fromIntegral n / fromIntegral d + + + + +-- TODO DELETE I don't really remember what I did here and testing Layout seems to be more a less a mistake +-- Reflex.Vty.Widget.Layout.Test +-- | same as 'RunLayout' except returns DynRegions for each of the queries in the layout +-- NOTE this method recreates the 'DynRegion's inside each 'Tile' of the layout so is not very performant +-- a better implementation is to have Layout hold its own 'DynRegion' but I'm avoid invasive changes for now. +{- +runLayout_debug + :: (MonadFix m, MonadHold t m, PostBuild t m, Monad m, MonadNodeId m) + => Dynamic t Orientation -- ^ The main-axis 'Orientation' of this 'Layout' + -> Int -- ^ The positional index of the initially focused tile + -> Event t Int -- ^ An event that shifts focus by a given number of tiles + -> Layout t m a -- ^ The 'Layout' widget + -> m (a, Dynamic t (Map NodeId (DynRegion t))) +runLayout_debug ddir focus0 focusShift (Layout child) = mdo + dw <- displayWidth + dh <- displayHeight + let main = ffor3 ddir dw dh $ \d w h -> case d of + Orientation_Column -> h + Orientation_Row -> w + pb <- getPostBuild + ((a, focusReq), queriesEndo) <- runReaderT (runDynamicWriterT $ runEventWriterT child) $ LayoutCtx solutionMap focusDemux ddir + let + queries = flip appEndo [] <$> queriesEndo + solution = ffor2 main queries $ \sz qs -> Map.fromList + . Map.elems + . computeEdges + . computeSizes sz + . fmap (fmap snd) + . Map.fromList + . zip [0::Integer ..] + $ qs + solutionMap = ffor solution $ \ss -> ffor ss $ \(offset, sz) -> LayoutSegment + { _layoutSegment_offset = offset + , _layoutSegment_size = sz + } + solutionReg = ffor2 solution ddir $ \ss dir -> ffor ss $ \(offset, sz) -> DynRegion + { _dynRegion_top = case dir of + Orientation_Column -> constDyn offset + Orientation_Row -> 0 + , _dynRegion_left = case dir of + Orientation_Column -> 0 + Orientation_Row -> constDyn offset + , _dynRegion_width = case dir of + Orientation_Column -> dw + Orientation_Row -> constDyn sz + , _dynRegion_height = case dir of + Orientation_Column -> constDyn sz + Orientation_Row -> dh + } + focusable = fmap (Bimap.fromList . zip [0..]) $ + ffor queries $ \qs -> fforMaybe qs $ \(nodeId, (f, _)) -> + if f then Just nodeId else Nothing + adjustFocus + :: (Bimap Int NodeId, (Int, Maybe NodeId)) + -> Either Int NodeId + -> (Int, Maybe NodeId) + adjustFocus (fm, (cur, _)) (Left shift) = + let ix = (cur + shift) `mod` (max 1 $ Bimap.size fm) + in (ix, Bimap.lookup ix fm) + adjustFocus (fm, (cur, _)) (Right goto) = + let ix = fromMaybe cur $ Bimap.lookupR goto fm + in (ix, Just goto) + focusChange = attachWith + adjustFocus + (current $ (,) <$> focusable <*> focussed) + $ leftmost [Left <$> focusShift, Left 0 <$ pb, Right . getFirst <$> focusReq] + -- A pair (Int, Maybe NodeId) which represents the index + -- that we're trying to focus, and the node that actually gets + -- focused (at that index) if it exists + focussed <- holdDyn (focus0, Nothing) focusChange + let + focusDemux = demux $ snd <$> focussed + return (a, solutionReg) +-} + + + + + + + + + + + + + +{- +-- class variant which I couldn't figure out how to get working... + +class MonadReflexVtyTest t m | m -> t where + type UserInputTriggerRefs m :: Type + type UserOutputEvents m :: Type + queueVtyEvent :: VtyEvent -> m () + +newtype ReflexVtyTestT t uintref uout m a = ReflexVtyTestT { unReflexVtyTestT :: ReflexTestT t (uintref, ReflexTriggerRef t m VtyEvent) uout m a } + deriving (Functor, Applicative, Monad, MonadIO, MonadState (AppState t m)) + +instance MonadTrans (ReflexVtyTestT t uintref uout) where + lift = ReflexVtyTestT . lift + +instance (r ~ ReflexTriggerRef t m VtyEvent, Monad m) => MonadReader ((uintref, r), uout) (ReflexVtyTestT t uintref uout m) where + ask :: ReflexVtyTestT t uintref uout m ((uintref, r), uout) + ask = ReflexVtyTestT ask --(ask :: ReflexTestT t (uintref,r) uout m (uintref,r)) +--deriving instance (r ~ ReflexTriggerRef t m VtyEvent) => MonadReader (uintref,r) (ReflexVtyTestT t uintref uout m) --via ReflexTestT t (uintref,r) uout m + +instance MonadReflexVtyTest t (ReflexVtyTestT t uintref uout m) where + type UserInputTriggerRefs (ReflexVtyTestT t uintref uout m) = uintref + type UserOutputEvents (ReflexVtyTestT t uintref uout m) = uout + queueVtyEvent vtyev = do + ((_, vtytref),_) :: ((uintref, ReflexTriggerRef t m VtyEvent), uout) <- ask + queueEventTriggerRef vtytref vtyev +-} diff --git a/src/Reflex/Vty/Test/Monad/Host/TH.hs b/src/Reflex/Vty/Test/Monad/Host/TH.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Vty/Test/Monad/Host/TH.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE TemplateHaskell #-} + + +module Reflex.Vty.Test.Monad.Host.TH where + +import Prelude (foldl) +import Relude hiding (getFirst, Type) + +import Data.Char (toLower) +import Language.Haskell.TH + +import Reflex +import Reflex.Vty.Test.Monad.Host +import Reflex.Host.Class (EventTrigger, newEventWithTriggerRef) +import Control.Monad.Ref + +-- | reference the 't' variable your quasi-quotes. e.g. 'Event $(tv) ()' +tv :: Q Type +tv = varT $ mkName "t" +-- does this capture types in generated scope? Probably not??? +--tv = do +-- Just r <- lookupTypeName "t" +-- varT r + +-- | reference a specific input event +tinput :: String -> String -> Q Exp +tinput name suffix = return $ AppE (VarE $ convertNameToPrefixedNameField (mkName name) ("InputEvents_"<>suffix)) (VarE $ getAppInputEventsArgName) + +-- | reference the output constructor +toutputcon :: String -> Q Exp +toutputcon name = conE $ mkName (name <> "_Output") + +-- | call me to generate code +declareStuff :: String -> [(String, Q Type)] -> [(String, Q Type)] -> Q Exp -> Q [Dec] +declareStuff name' inputEventTypes outputTypes body = do + let + name = mkName name' + nd <- declareNetworkData name + ni <- declareNetworkInstance name inputEventTypes outputTypes body + return (nd<>ni) + + + + +getAppInputEventsArgName :: Name +getAppInputEventsArgName = mkName "inputEvs_____donotusethisvariablenameforanythingelse" + +declareNetworkData :: Name -> Q [Dec] +declareNetworkData name = do + let + k_m = InfixT StarT ''(->) StarT + tv_t <- newName "t" + tv_m <- newName "m" + -- not sure if KindedTV is necessary + return $ [DataD [] name [PlainTV tv_t (), KindedTV tv_m () k_m] Nothing [] []] + +declareNetworkInstance :: Name -> [(String, Q Type)] -> [(String, Q Type)] -> Q Exp -> Q [Dec] +declareNetworkInstance name inputEventTypes outputTypes body = do + let + v_t = VarT $ mkName "t" + v_m = VarT $ mkName "m" + cxt1 = AppT (AppT (ConT $ mkName "MonadVtyApp") v_t) $ AppT (AppT (ConT $ mkName "TestGuestT") v_t) v_m + cxt2 = AppT (AppT (ConT $ mkName "TestGuestConstraints") v_t) $ v_m + v_potatoNetwork = AppT (AppT (ConT $ name) v_t) v_m + --instance (MonadVtyApp t (TestGuestT t m), TestGuestConstraints t m) => ReflexVtyTestApp ([|$(VarT name)|] t m) t m where + classinstance = AppT (AppT (AppT (ConT $ mkName "ReflexVtyTestApp") v_potatoNetwork) v_t) v_m + -- same but using quasiquoters + --cxt1 <- [t| $(conT $ mkName "MonadVtyApp") $(varT $ mkName "t") ($(conT $ mkName "TestGuestT") $(varT $ mkName "t") $(varT $ mkName "m")) |] + + outputs <- declareOutputs name outputTypes + inputs <- declareInputs name inputEventTypes + makeInputsFn <- declareMakeInputs name inputEventTypes + bodyFn <- declareGetApp name body + + return $ [InstanceD Nothing [cxt1,cxt2] classinstance ((outputs:inputs) <> [makeInputsFn, bodyFn])] + +normalBang :: Bang +normalBang = Bang NoSourceUnpackedness NoSourceStrictness + + +convertNameToPrefixedNameField :: Name -> String -> Name +convertNameToPrefixedNameField name suffix = r where + prefix = case nameBase name of + [] -> "" + x:xs -> (toLower x):xs + r = mkName $ "_" <> prefix <> "_" <> suffix + +convertNameToPrefixedNameType :: Name -> String -> Name +convertNameToPrefixedNameType name suffix = r where + r = mkName $ nameBase name <> "_" <> suffix + +varNetwork :: Name -> Type +varNetwork name = r where + v_t = VarT $ mkName "t" + v_m = VarT $ mkName "m" + r = AppT (AppT (ConT $ name) v_t) v_m + +declareOutputs :: Name -> [(String, Q Type)] -> Q Dec +declareOutputs name outputTypes = do + recs <- forM (fmap (\(x,q) -> fmap (x,) q) outputTypes) $ \nt -> do + (n,t) <- nt + let + fname = convertNameToPrefixedNameField name ("Output_" <> n) + return (fname, normalBang, t) + let + recname = convertNameToPrefixedNameType name "Output" + cs = [RecC recname recs] + return $ DataInstD [] Nothing (AppT (ConT $ mkName "VtyAppOutput") (varNetwork name)) Nothing cs [] + +mkvar :: String -> Q Type +mkvar = varT . mkName + +declareInputs :: Name -> [(String, Q Type)] -> Q [Dec] +declareInputs name inputEventTypes = do + recs <- forM (fmap (\(x,q) -> fmap (x,) q) inputEventTypes) $ \nt -> do + (n, t) <- nt + let + infname = convertNameToPrefixedNameField name ("InputEvents_" <> n) + trigfname = convertNameToPrefixedNameField name ("InputTriggerRefs_" <> n) + int <- [t|Event $(tv) $(return t)|] + trigt <- [t| Ref $(mkvar "m") (Maybe (EventTrigger $(tv) $(return t))) |] + return ((infname, normalBang, int), (trigfname, normalBang, trigt)) + + let + (inrecs, trigrecs) = unzip recs + incs = [RecC (convertNameToPrefixedNameType name "InputEvents") inrecs] + trigcs = [RecC (convertNameToPrefixedNameType name "InputTriggerRefs") trigrecs] + indi = DataInstD [] Nothing (AppT (ConT $ mkName "VtyAppInputEvents") (varNetwork name)) Nothing incs [] + trigdi = DataInstD [] Nothing (AppT (ConT $ mkName "VtyAppInputTriggerRefs") (varNetwork name)) Nothing trigcs [] + return [indi, trigdi] + +declareMakeInputs :: Name -> [(String, Q Type)] -> Q Dec +declareMakeInputs name inputEventTypes = do + varnames <- forM (fmap (\(x,q) -> fmap (x,) q) inputEventTypes) $ \nt -> do + (n, t) <- nt + evname <- newName "ev" + trefname <- newName "ref" + return (evname, trefname) + refstmts <- forM varnames $ \(evname,trefname) -> do + return $ BindS (TupP [VarP evname, VarP trefname]) $ VarE (mkName "newEventWithTriggerRef") + let + returnstmtsfst = foldl AppE (ConE $ convertNameToPrefixedNameType name "InputEvents") (fmap (VarE . fst) varnames) + returnstmtssnd = foldl AppE (ConE $ convertNameToPrefixedNameType name "InputTriggerRefs") (fmap (VarE . snd) varnames) + returnstmts <- [|return ($(return returnstmtsfst),$(return returnstmtssnd))|] + let + b = NormalB $ DoE Nothing (refstmts <> [NoBindS returnstmts]) + c = Clause [] b [] + return $ FunD (mkName "makeInputs") [c] + + +declareGetApp :: Name -> Q Exp -> Q Dec +declareGetApp name body' = do + body <- body' + let + b = NormalB $ body + c = Clause [VarP $ getAppInputEventsArgName] b [] + return $ FunD (mkName "getApp") [c] diff --git a/test/Potato/Flow/ParamsSpec.hs b/test/Potato/Flow/ParamsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Potato/Flow/ParamsSpec.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} + +module Potato.Flow.ParamsSpec + ( spec + ) +where + +import Relude hiding (Type) + +import Test.Hspec +import Test.Hspec.Contrib.HUnit (fromHUnitTest) +import Test.HUnit + +import Potato.Flow.Vty.Params +import Potato.Flow +import Potato.Flow.Vty.PotatoReader + +import Data.Default + +import qualified Graphics.Vty as V +import Reflex +import Reflex.Host.Class +import Reflex.Vty +import Reflex.Vty.Test.Monad.Host +import Reflex.Vty.Test.Monad.Host.TH +import Reflex.Vty.Test.Common + + +$(declareStuff "ParamsNetwork" + [("setSelection", [t|Selection|]) + , ("setCanvas", [t|SCanvas|])] + [("paramsWidget", [t|ParamsWidget $(tv)|])] + [| + do + setSelectionDyn <- holdDyn isParliament_empty $(tinput "ParamsNetwork" "setSelection") + setCanvasDyn <- holdDyn (SCanvas (LBox (V2 0 0) (V2 100 100))) $(tinput "ParamsNetwork" "setCanvas") + paramsWidget <- flip runPotatoReader def $ holdParamsWidget $ ParamsWidgetConfig { + _paramsWidgetConfig_selectionDyn = setSelectionDyn + , _paramsWidgetConfig_canvasDyn = setCanvasDyn + , _paramsWidgetConfig_defaultParamsDyn = constDyn def + , _paramsWidgetConfig_toolDyn = constDyn Tool_Select + , _paramsWidgetConfig_loseFocusEv = never + } + return $ $(toutputcon "ParamsNetwork") paramsWidget + |] + ) + + +test_params_set_canvas_size :: Test +test_params_set_canvas_size = TestLabel "set canvas size" $ TestCase $ runSpiderHost $ + runReflexVtyTestApp @(ParamsNetwork (SpiderTimeline Global) (SpiderHost Global)) (100,100) $ do + + -- get our app's input triggers + ParamsNetwork_InputTriggerRefs {..} <- userInputTriggerRefs + + -- get our app's output events and subscribe to them + ParamsNetwork_Output (ParamsWidget {..}) <- userOutputs + canvasSizeH <- subscribeEvent _paramsWidget_canvasSizeEvent + + let + readCanvasSize = sequence =<< readEvent canvasSizeH + + -- fire an empty event and ensure there is no canvas change event + fireQueuedEventsAndRead readCanvasSize >>= \a -> liftIO (checkNothing a) + + -- set the canvas size and ensure there is no canvas change event + queueEventTriggerRef _paramsNetwork_InputTriggerRefs_setCanvas (SCanvas (LBox (V2 0 0) (V2 50 50))) + fireQueuedEventsAndRead readCanvasSize >>= \a -> liftIO (checkNothing a) + + -- we have nothing selected so canvas size should be first thing in ParamsWidget + queueVtyEvent (V.EvMouseDown 10 1 V.BLeft []) >> fireQueuedEvents + queueVtyEvent (V.EvMouseUp 10 1 Nothing) >> fireQueuedEvents + queueVtyEvent (V.EvKey V.KBS []) >> fireQueuedEvents + queueVtyEvent (V.EvKey V.KBS []) >> fireQueuedEvents + queueVtyEvent (V.EvKey (V.KChar '2') []) >> fireQueuedEvents + queueVtyEvent (V.EvKey (V.KChar '0') []) >> fireQueuedEvents + queueVtyEvent (V.EvKey V.KEnter []) + fireQueuedEventsAndRead readCanvasSize >>= \a -> liftIO (checkSingleMaybe a (V2 (-30) 0)) + queueVtyEvent (V.EvKey V.KBS []) >> fireQueuedEvents + queueVtyEvent (V.EvKey V.KBS []) >> fireQueuedEvents + queueVtyEvent (V.EvKey (V.KChar '3') []) >> fireQueuedEvents + queueVtyEvent (V.EvKey (V.KChar '0') []) >> fireQueuedEvents + queueVtyEvent (V.EvKey V.KEnter []) + fireQueuedEventsAndRead readCanvasSize >>= \a -> liftIO (checkSingleMaybe a (V2 0 (-20))) + + -- TODO test other stuff πŸ˜₯ + + + + + +$(declareStuff "SuperStyleWidgetNetwork" + [("setSelection", [t|Selection|])] + [("height", [t|Dynamic $(tv) Int|]) + , ("capture", [t|Event $(tv) ()|]) + , ("output", [t|Event $(tv) (Either Llama SetPotatoDefaultParameters)|])] + [| + initManager_ $ col $ do + selectionDyn <- holdDyn isParliament_empty $(tinput "SuperStyleWidgetNetwork" "setSelection") + + let + selectFn s = case selectParamsFromSelection (getSEltLabelSuperStyle . superOwl_toSEltLabel_hack) s of + Nothing -> (isParliament_empty, Nothing, Tool_Select) + Just (a,b) -> (a,b,Tool_Select) + mSuperStyleInputDyn = fmap selectFn selectionDyn + (heightDyn, captureEv, outputEv) <- flip runPotatoReader def $ networkParamsWidgetOutputDynForTesting (holdSuperStyleWidget (constDyn def) mSuperStyleInputDyn) + -- TODO consider convert outputEv back to Event t SuperStyle... + return $ $(toutputcon "SuperStyleWidgetNetwork") heightDyn captureEv outputEv + |] + ) + +test_superStyleWidget_basic :: Test +test_superStyleWidget_basic = TestLabel "set canvas size" $ TestCase $ runSpiderHost $ + runReflexVtyTestApp @(SuperStyleWidgetNetwork (SpiderTimeline Global) (SpiderHost Global)) (100,100) $ do + + --let queueVtyEventAndFire x = queueVtyEvent x >> fireQueuedEvents + + -- get our app's input triggers + SuperStyleWidgetNetwork_InputTriggerRefs {..} <- userInputTriggerRefs + + -- get our app's output events and subscribe to them + SuperStyleWidgetNetwork_Output heightDyn captureEv outputEv <- userOutputs + heightDynH <- subscribeDynamic heightDyn + captureEvH <- subscribeEvent captureEv + outputEvH <- subscribeEvent outputEv + + let + --readHeightDyn = readDynamic heightDynH + readCaptureEv = sequence =<< readEvent captureEvH + readOutputEv = sequence =<< readEvent outputEvH + + -- fire an empty event and ensure there is no output or capture ev + fireQueuedEventsAndRead readCaptureEv >>= \a -> liftIO (checkNothing a) + fireQueuedEventsAndRead readOutputEv >>= \a -> liftIO (checkNothing a) + + -- set the canvas size and ensure there is no canvas change event + --queueEventTriggerRef _paramsNetwork_InputTriggerRefs_setCanvas (SCanvas (LBox (V2 0 0) (V2 50 50))) + --fireQueuedEventsAndRead readCanvasSize >>= \a -> liftIO (checkNothing a) + + + -- TODO test other stuff πŸ˜₯ + + +spec :: Spec +spec = do + fromHUnitTest test_params_set_canvas_size + fromHUnitTest test_superStyleWidget_basic diff --git a/test/Potato/FlowSpecTH.hs b/test/Potato/FlowSpecTH.hs new file mode 100644 --- /dev/null +++ b/test/Potato/FlowSpecTH.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} + +module Potato.FlowSpecTH + ( spec + ) +where + +import Relude hiding (Type) + +import Test.Hspec +import Test.Hspec.Contrib.HUnit (fromHUnitTest) +import Test.HUnit + +import Potato.Flow.Vty.Main +import Potato.Flow + +import qualified Graphics.Vty as V +import Reflex +import Reflex.Host.Class +import Reflex.Vty +import Reflex.Vty.Test.Monad.Host +import Reflex.Vty.Test.Monad.Host.TH +import Reflex.Vty.Test.Common + +-- for reference, non-TH equivalent network +{- +data PotatoNetwork t (m :: Type -> Type) + +instance (MonadVtyApp t (TestGuestT t m), TestGuestConstraints t m) => ReflexVtyTestApp (PotatoNetwork t m) t m where + data instance VtyAppInputTriggerRefs (PotatoNetwork t m) = PotatoNetwork_InputTriggerRefs { + -- force an event bypassing the normal interface + _potatoNetwork_InputTriggerRefs_bypassEvent :: Ref m (Maybe (EventTrigger t WSEvent)) + } + data instance VtyAppInputEvents (PotatoNetwork t m) = PotatoNetwork_InputEvents { + _potatoNetwork_InputEvents_InputEvents_bypassEvent :: Event t WSEvent + } + + data instance VtyAppOutput (PotatoNetwork t m) = + PotatoNetwork_Output { + _potatoNetwork_Output_exitEv :: Event t () + } + getApp PotatoNetwork_InputEvents {..} = do + exitEv <- mainPFWidget $ MainPFWidgetConfig { + _mainPFWidgetConfig_initialFile = Nothing + , _mainPFWidgetConfig_initialState = emptyOwlPFState + , _mainPFWidgetConfig_bypassEvent = _potatoNetwork_InputEvents_InputEvents_bypassEvent + } + return PotatoNetwork_Output { + _potatoNetwork_Output_exitEv = exitEv + } + + makeInputs = do + (ev, ref) <- newEventWithTriggerRef + return (PotatoNetwork_InputEvents ev, PotatoNetwork_InputTriggerRefs ref) +-} + +$(declareStuff "PotatoNetwork" + [("bypassEvent", [t|WSEvent|]) + , ("moop", [t|Int|])] + [("exitEv", [t|Event $(tv) ()|])] + [| + do + exitEv <- mainPFWidgetWithBypass + (MainPFWidgetConfig { + _mainPFWidgetConfig_initialFile = Nothing + , _mainPFWidgetConfig_initialState = (emptyOwlPFState, emptyControllerMeta) + , _mainPFWidgetConfig_homeDirectory = "" + }) + $(tinput "PotatoNetwork" "bypassEvent") + + return $ $(toutputcon "PotatoNetwork") exitEv + + -- you can also do it yourself + --return ($(conE $ mkName "PotatoNetwork_Output") exitEv) + + -- splicing within record initializer does not seem to work :( + --return $(ConT $ mkName "PotatoNetwork_Output") { $(VarE $ mkName "_potatoNetwork_Output_exitEv") = exitEv }) + |] + ) + +-- DELETE +--data SomeData = SomeData { someField :: () } +-- $([d| y = SomeData { someField = () } |]) +-- splicing inside quasi-quoted record initialization (i.e. RecordType { ... }) does not work +-- $([d| x = SomeData { $(VarE $ mkName "someField") = () } |]) + +test_basic :: Test +test_basic = TestLabel "open and quit" $ TestCase $ runSpiderHost $ + runReflexVtyTestApp @(PotatoNetwork (SpiderTimeline Global) (SpiderHost Global)) (100,100) $ do + + -- get our app's input triggers + PotatoNetwork_InputTriggerRefs {..} <- userInputTriggerRefs + + -- get our app's output events and subscribe to them + PotatoNetwork_Output {..} <- userOutputs + exitH <- subscribeEvent _potatoNetwork_Output_exitEv + + let + readExitEv = sequence =<< readEvent exitH + + -- fire an empty event and ensure there is no quit event + fireQueuedEventsAndRead readExitEv >>= \a -> liftIO (checkNothing a) + + -- close the annoying welcome popup + queueVtyEvent (V.EvKey V.KEnter []) >> fireQueuedEvents + + -- drag mouse between layer and canvas panes to ensure GoatWidget mouse assumptions hold (otherwise it would crash) + queueVtyEvent (V.EvMouseDown 0 10 V.BLeft []) >> fireQueuedEvents + queueVtyEvent (V.EvMouseDown 1000 10 V.BLeft []) >> fireQueuedEvents + queueVtyEvent (V.EvMouseUp 1000 10 (Just V.BLeft)) >> fireQueuedEvents + queueVtyEvent (V.EvMouseDown 1000 10 V.BLeft []) >> fireQueuedEvents + queueVtyEvent (V.EvMouseDown 0 10 V.BLeft []) >> fireQueuedEvents + queueVtyEvent (V.EvMouseUp 0 10 (Just V.BLeft)) >> fireQueuedEvents + + -- enter quit sequence and ensure there is a quit event + queueVtyEvent $ V.EvKey (V.KChar 'q') [V.MCtrl] + fireQueuedEventsAndRead readExitEv >>= \a -> liftIO (checkSingleMaybe a ()) + +spec :: Spec +spec = do + --fromHUnitTest $ TestLabel "Reifying..." $ TestCase $ liftIO $ putStrLn $(stringE . show =<< reifyInstances ''ReflexVtyTestApp [VarT $ mkName "a"]) + fromHUnitTest test_basic diff --git a/test/Potato/Reflex/Vty/Widget/PopupSpec.hs b/test/Potato/Reflex/Vty/Widget/PopupSpec.hs new file mode 100644 --- /dev/null +++ b/test/Potato/Reflex/Vty/Widget/PopupSpec.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} + +module Potato.Reflex.Vty.Widget.PopupSpec + ( spec + ) +where + +import Relude + +import Test.Hspec +import Test.Hspec.Contrib.HUnit (fromHUnitTest) +import Test.HUnit + +import Potato.Reflex.Vty.Widget.Popup + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Ref +import Data.Default +import Data.Kind +import qualified Data.List as L + +import qualified Graphics.Vty as V +import Reflex +import Reflex.Host.Class +import Reflex.Vty +import Reflex.Vty.Test.Monad.Host +import Reflex.Vty.Test.Common + +data BasicNetworkTest1 t (m :: Type -> Type) + +instance (MonadVtyApp t (TestGuestT t m), TestGuestConstraints t m) => ReflexVtyTestApp (BasicNetworkTest1 t m) t m where + + -- I just wanted to try using VtyAppInputEvents/VtyAppInputTriggerRefs + -- it would have been a lot easier to use a vty event to trigger the popup + data VtyAppInputTriggerRefs (BasicNetworkTest1 t m) = BasicNetworkTest1_InputTriggerRefs { + _basicNetworkTest1_InputTriggerRefs_makePopup :: Ref m (Maybe (EventTrigger t ())) + } + data VtyAppInputEvents (BasicNetworkTest1 t m) = BasicNetworkTest1_InputEvents { + _basicNetworkTest1_InputEvents_makePopup :: Event t () + } + data VtyAppOutput (BasicNetworkTest1 t m) = + BasicNetworkTest1_Output { + _basicNetworkTest1_Output_cancelEv :: Event t () + , _basicNetworkTest1_Output_popupOutEv :: Event t Int + , _basicNetworkTest1_Output_popupStateDyn :: Dynamic t Bool + } + getApp BasicNetworkTest1_InputEvents {..} = do + let + someWidget = fmap (const 123) <$> key V.KEnter + someWidgetEv = fmap (const someWidget) _basicNetworkTest1_InputEvents_makePopup + -- popup that closes when you press enter + (popupEv, popupStateDyn) <- popupPaneSimple def someWidgetEv + -- gotta make the popup look pretty :D + fill $ constant '#' + return $ BasicNetworkTest1_Output never popupEv popupStateDyn + makeInputs = do + (ev, ref) <- newEventWithTriggerRef + return (BasicNetworkTest1_InputEvents ev, BasicNetworkTest1_InputTriggerRefs ref) + +test_basic :: Test +test_basic = TestLabel "basic" $ TestCase $ runSpiderHost $ + runReflexVtyTestApp @(BasicNetworkTest1 (SpiderTimeline Global) (SpiderHost Global)) (100,100) $ do + + -- get our app's input triggers + BasicNetworkTest1_InputTriggerRefs {..} <- userInputTriggerRefs + + -- get our app's output events and subscribe to them + BasicNetworkTest1_Output {..} <- userOutputs + popupOutH <- subscribeEvent _basicNetworkTest1_Output_popupOutEv + popupStateH <- subscribeEvent $ updated _basicNetworkTest1_Output_popupStateDyn + + let + readPopupState = sample . current $ _basicNetworkTest1_Output_popupStateDyn + readPopupStateEv = sequence =<< readEvent popupStateH + + -- fire an empty event and ensure there is no popup + fireQueuedEventsAndRead readPopupState >>= \a -> liftIO (checkSingle a False) + + -- enable the popup + queueEventTriggerRef _basicNetworkTest1_InputTriggerRefs_makePopup () + fireQueuedEventsAndRead readPopupStateEv >>= \a -> liftIO (checkSingleMaybe a True) + + -- fire an empty event and ensure popup is still there + fireQueuedEventsAndRead readPopupState >>= \a -> liftIO (checkSingle a True) + + -- close the popup + queueVtyEvent $ V.EvKey V.KEnter [] + fireQueuedEventsAndRead readPopupStateEv >>= \a -> liftIO (checkSingleMaybe a False) + + -- enable the popup + queueEventTriggerRef _basicNetworkTest1_InputTriggerRefs_makePopup () + fireQueuedEventsAndRead readPopupStateEv >>= \a -> liftIO (checkSingleMaybe a True) + +{- this is broken now, I don't know why, doesn't matter I must have changed the behavior at some point, can't be bothered to figure it out + -- click within the popup and ensure it's still there + queueVtyEvent $ V.EvMouseDown 50 50 V.BLeft [] + fireQueuedEventsAndRead readPopupState >>= \a -> liftIO (checkSingle a True) + + -- drag off and ensure popup is still there + queueVtyEvent $ V.EvMouseDown 100 100 V.BLeft [] + fireQueuedEventsAndRead readPopupState >>= \a -> liftIO (checkSingle a True) + + -- FAILING HERE WHY + -- release the mouse + queueVtyEvent $ V.EvMouseUp 100 100 Nothing + fireQueuedEventsAndRead readPopupState >>= \a -> liftIO (checkSingle a True) + +-} + + -- click off the popup and check that it got cancelled + queueVtyEvent $ V.EvMouseDown 100 100 V.BLeft [] + fireQueuedEventsAndRead readPopupStateEv >>= \a -> liftIO (checkSingleMaybe a False) + + -- enable the popup + queueEventTriggerRef _basicNetworkTest1_InputTriggerRefs_makePopup () + fireQueuedEventsAndRead readPopupStateEv >>= \a -> liftIO (checkSingleMaybe a True) + + -- re-enable the popup + queueEventTriggerRef _basicNetworkTest1_InputTriggerRefs_makePopup () + fireQueuedEventsAndRead readPopupStateEv >>= \a -> liftIO (checkSingleMaybe a True) + + -- escape cancel the popup + queueVtyEvent $ V.EvKey V.KEsc [] + fireQueuedEventsAndRead readPopupStateEv >>= \a -> liftIO (checkSingleMaybe a False) + + +spec :: Spec +spec = do + fromHUnitTest test_basic diff --git a/test/PotatoSpec.hs b/test/PotatoSpec.hs new file mode 100644 --- /dev/null +++ b/test/PotatoSpec.hs @@ -0,0 +1,74 @@ +--TODO DELETE THIS + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} + +module PotatoSpec + ( spec + ) +where + +import Prelude + +import Test.Hspec +import Test.Hspec.Contrib.HUnit (fromHUnitTest) +import Test.HUnit + +import Control.Monad.IO.Class (liftIO) +import Data.Kind +import qualified Data.List as L + +import qualified Graphics.Vty as V +import Reflex +import Reflex.Host.Class +import Reflex.Vty +import Reflex.Vty.Test.Monad.Host + +data BasicPotatoTest1 t (m :: Type -> Type) + +instance (MonadVtyApp t (TestGuestT t m), TestGuestConstraints t m) => ReflexVtyTestApp (BasicPotatoTest1 t m) t m where + data VtyAppInputTriggerRefs (BasicPotatoTest1 t m) = BasicPotatoTest1_InputTriggerRefs + data VtyAppInputEvents (BasicPotatoTest1 t m) = BasicPotatoTest1_InputEvents + data VtyAppOutput (BasicPotatoTest1 t m) = BasicPotatoTest1_Output + getApp _ = do + return $ BasicPotatoTest1_Output + makeInputs = do + -- return dummy inputs since they are both empty + return (BasicPotatoTest1_InputEvents, BasicPotatoTest1_InputTriggerRefs) + +test_basic :: Test +test_basic = TestLabel "basic" $ TestCase $ runSpiderHost $ + runReflexVtyTestApp @(BasicPotatoTest1 (SpiderTimeline Global) (SpiderHost Global)) (500,500) $ do + -- get our app's output events and subscribe to them + BasicPotatoTest1_Output <- userOutputs + vtyImages <- vtyOutputs + --vtyH <- subscribeEvent _basicNetworkTest1_Output_vtyEv + --dwH <- subscribeEvent $ updated _basicNetworkTest1_Output_displayWidth + + + -- fire an empty event and ensure there is no output + -- also check that an image was rendered + a1 :: [((), [V.Image])] <- fireQueuedEventsAndRead $ do + --a <- sequence =<< readEvent vtyH + b <- sample vtyImages + return ((),b) + --liftIO $ (fst . L.last $ a1) @?= Nothing + --liftIO $ (length . snd . L.last $ a1) @?= 1 + + -- fire escape event and ensure we can + --let someEvent = V.EvKey V.KEsc [] + --queueVtyEvent someEvent + --a2 :: [Maybe VtyEvent] <- fireQueuedEventsAndRead $ sequence =<< readEvent vtyH + --liftIO $ a2 @?= [Just someEvent] + + -- resize the screen and check that the changes are reflected + --queueVtyEvent $ V.EvResize 10 10 + --a3 :: [Maybe Int] <- fireQueuedEventsAndRead $ sequence =<< readEvent dwH + --liftIO $ a3 @?= [Just 10] + + return () + +spec :: Spec +spec = do + fromHUnitTest test_basic diff --git a/test/Reflex/Vty/Test/Common.hs b/test/Reflex/Vty/Test/Common.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Vty/Test/Common.hs @@ -0,0 +1,55 @@ +module Reflex.Vty.Test.Common + ( subscribeDynamic + , readDynamic + , checkSingle + , checkSingleMaybe + , checkNothing + ) +where + +import Relude + +import Test.Hspec +import Test.Hspec.Contrib.HUnit (fromHUnitTest) +import Test.HUnit + +import Control.Monad.IO.Class (liftIO) +import Data.Kind +import qualified Data.List as L + +import qualified Graphics.Vty as V +import Reflex +import Reflex.Host.Class +import Reflex.Vty +import Reflex.Vty.Test.Monad.Host + + +subscribeDynamic :: (MonadSubscribeEvent t m) => Dynamic t a -> m (EventHandle t a, Behavior t a) +subscribeDynamic d = do + eh <- subscribeEvent $ updated d + return (eh, current d) + +readDynamic :: forall t m a. (MonadReadEvent t m, MonadSample t m) => (EventHandle t a, Behavior t a) -> m a +readDynamic (evh, b) = do + v <- readEvent evh + case v of + Nothing -> sample b + Just x -> x + + + +checkSingle :: (Eq a, Show a) => [a] -> a -> Assertion +checkSingle values a = case nonEmpty values of + Nothing -> assertFailure "empty list" + Just x -> a @=? head x + +checkSingleMaybe :: (Eq a, Show a) => [Maybe a] -> a -> Assertion +checkSingleMaybe values a = case nonEmpty values of + Nothing -> assertFailure "empty list" + Just x -> Just a @=? head x + +checkNothing :: (Show a) => [Maybe a] -> Assertion +checkNothing values = case nonEmpty values of + Nothing -> assertFailure "empty list" + -- TODO prob check that all elts in list are Nothing + Just x -> True @=? isNothing (head x) diff --git a/test/Reflex/Vty/Test/Monad/HostSpec.hs b/test/Reflex/Vty/Test/Monad/HostSpec.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Vty/Test/Monad/HostSpec.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} + +module Reflex.Vty.Test.Monad.HostSpec + ( spec + ) +where + +import Prelude + +import Test.Hspec +import Test.Hspec.Contrib.HUnit (fromHUnitTest) +import Test.HUnit + +import Control.Monad.IO.Class (liftIO) +import Data.Kind +import qualified Data.List as L + +import qualified Graphics.Vty as V +import Reflex +import Reflex.Host.Class +import Reflex.Vty +import Reflex.Vty.Test.Monad.Host + +data BasicNetworkTest1 t (m :: Type -> Type) + +instance (MonadVtyApp t (TestGuestT t m), TestGuestConstraints t m) => ReflexVtyTestApp (BasicNetworkTest1 t m) t m where + data VtyAppInputTriggerRefs (BasicNetworkTest1 t m) = BasicNetworkTest1_InputTriggerRefs + data VtyAppInputEvents (BasicNetworkTest1 t m) = BasicNetworkTest1_InputEvents + data VtyAppOutput (BasicNetworkTest1 t m) = + BasicNetworkTest1_Output { + _basicNetworkTest1_Output_vtyEv :: Event t VtyEvent + , _basicNetworkTest1_Output_displayWidth :: Dynamic t Int + , _basicNetworkTest1_Output_displayHeight :: Dynamic t Int + } + getApp _ = do + inp <- input + dw <- displayWidth + dh <- displayHeight + fill $ constant '#' + return $ BasicNetworkTest1_Output inp dw dh + makeInputs = do + -- return dummy inputs since they are both empty + return (BasicNetworkTest1_InputEvents, BasicNetworkTest1_InputTriggerRefs) + +test_basic :: Test +test_basic = TestLabel "basic" $ TestCase $ runSpiderHost $ + runReflexVtyTestApp @(BasicNetworkTest1 (SpiderTimeline Global) (SpiderHost Global)) (5,5) $ do + -- get our app's output events and subscribe to them + BasicNetworkTest1_Output {..} <- userOutputs + vtyImages <- vtyOutputs + vtyH <- subscribeEvent _basicNetworkTest1_Output_vtyEv + dwH <- subscribeEvent $ updated _basicNetworkTest1_Output_displayWidth + + + -- fire an empty event and ensure there is no output + -- also check that an image was rendered + a1 :: [(Maybe VtyEvent, [V.Image])] <- fireQueuedEventsAndRead $ do + a <- sequence =<< readEvent vtyH + b <- sample vtyImages + return (a,b) + liftIO $ (fst . L.last $ a1) @?= Nothing + -- not sure why this produces two images now, whatever, + --liftIO $ (length . snd . L.last $ a1) @?= 1 + + + -- fire a vty event and ensure the output is the same as the input + let someEvent = V.EvKey V.KEsc [] + queueVtyEvent someEvent + a2 :: [Maybe VtyEvent] <- fireQueuedEventsAndRead $ sequence =<< readEvent vtyH + liftIO $ a2 @?= [Just someEvent] + + -- resize the screen and check that the changes are reflected + queueVtyEvent $ V.EvResize 10 10 + a3 :: [Maybe Int] <- fireQueuedEventsAndRead $ sequence =<< readEvent dwH + liftIO $ a3 @?= [Just 10] + + + +spec :: Spec +spec = do + fromHUnitTest test_basic diff --git a/test/Reflex/Vty/Test/Monad/THSpec.hs b/test/Reflex/Vty/Test/Monad/THSpec.hs new file mode 100644 --- /dev/null +++ b/test/Reflex/Vty/Test/Monad/THSpec.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} + +module Reflex.Vty.Test.Monad.THSpec + ( spec + ) +where + +import Relude + +import Test.Hspec +import Test.Hspec.Contrib.HUnit (fromHUnitTest) +import Test.HUnit + +import qualified Data.List as L + +import qualified Graphics.Vty as V +import Reflex +import Reflex.Host.Class +import Reflex.Vty +import Reflex.Vty.Test.Monad.Host +import Reflex.Vty.Test.Monad.Host.TH + + +$(declareStuff "BasicNetworkTest1" + [("dummy", [t|Char|])] + [("vtyEv", [t|Event $(tv) V.Event|]) + , ("displayWidth", [t|Dynamic $(tv) Int|]) + , ("displayHeight", [t|Dynamic $(tv) Int|])] + [| + do + inp <- input + dw <- displayWidth + dh <- displayHeight + fill $ constant '#' + let + dummyInput = fmap (\c -> V.EvKey (V.KChar c) []) $(tinput "BasicNetworkTest1" "dummy") + inpOut = leftmost [inp, dummyInput] + return $ $(toutputcon "BasicNetworkTest1") inpOut dw dh + |]) + +-- | TODO add splicing to get network input/output var names +test_basic :: Test +test_basic = TestLabel "basic" $ TestCase $ runSpiderHost $ + runReflexVtyTestApp @(BasicNetworkTest1 (SpiderTimeline Global) (SpiderHost Global)) (100,100) $ do + + -- get our app's input triggers + BasicNetworkTest1_InputTriggerRefs {..} <- userInputTriggerRefs + + -- get our app's output events and subscribe to them + BasicNetworkTest1_Output {..} <- userOutputs + vtyImages <- vtyOutputs + vtyH <- subscribeEvent _basicNetworkTest1_Output_vtyEv + dwH <- subscribeEvent $ updated _basicNetworkTest1_Output_displayWidth + + -- fire an empty event and ensure there is no output + -- also check that an image was rendered + a1 :: [(Maybe VtyEvent, [V.Image])] <- fireQueuedEventsAndRead $ do + a <- sequence =<< readEvent vtyH + b <- sample vtyImages + return (a,b) + liftIO $ (fst . L.last $ a1) @?= Nothing + -- not sure why this produces two images now, whatever, + --liftIO $ (length . snd . L.last $ a1) @?= 1 + + -- fire a vty event and ensure the output is the same as the input + let someEvent = V.EvKey V.KEsc [] + queueVtyEvent someEvent + a2 :: [Maybe VtyEvent] <- fireQueuedEventsAndRead $ sequence =<< readEvent vtyH + liftIO $ a2 @?= [Just someEvent] + + -- fire a dummy input event and enusre the output is as expected + queueEventTriggerRef _basicNetworkTest1_InputTriggerRefs_dummy 'p' + a3 :: [Maybe VtyEvent] <- fireQueuedEventsAndRead $ sequence =<< readEvent vtyH + liftIO $ a3 @?= [Just $ V.EvKey (V.KChar 'p') []] + + -- resize the screen and check that the changes are reflected + queueVtyEvent $ V.EvResize 10 10 + a4 :: [Maybe Int] <- fireQueuedEventsAndRead $ sequence =<< readEvent dwH + liftIO $ a4 @?= [Just 10] + + + +spec :: Spec +spec = do + fromHUnitTest test_basic diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +-- hspec auto-discovery stuff +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tinytools-vty.cabal b/tinytools-vty.cabal new file mode 100644 --- /dev/null +++ b/tinytools-vty.cabal @@ -0,0 +1,385 @@ +cabal-version: 1.12 + +name: tinytools-vty +version: 0.1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/pdlla/tinytools-vty#readme +bug-reports: https://github.com/pdlla/tinytools-vty/issues +author: pdlla +maintainer: chippermonky@gmail.com +copyright: 2020 Peter Lu +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + + +source-repository head + type: git + location: https://github.com/pdlla/tinytools-vty + + +library + exposed-modules: + Data.String.Unicode.Lookup + Potato.Flow.TutorialState + Potato.Flow.Vty.Alert + Potato.Flow.Vty.AppKbCmd + Potato.Flow.Vty.Attrs + Potato.Flow.Vty.Canvas + Potato.Flow.Vty.Common + Potato.Flow.Vty.Info + Potato.Flow.Vty.Input + Potato.Flow.Vty.Layer + Potato.Flow.Vty.Left + Potato.Flow.Vty.Main + Potato.Flow.Vty.OpenWindow + Potato.Flow.Vty.Params + Potato.Flow.Vty.PotatoReader + Potato.Flow.Vty.SaveAsWindow + Potato.Flow.Vty.ToolOptions + Potato.Flow.Vty.Tools + Potato.Reflex.Vty.Helpers + Potato.Reflex.Vty.Host + Potato.Reflex.Vty.Widget + Potato.Reflex.Vty.Widget.FileExplorer + Potato.Reflex.Vty.Widget.Menu + Potato.Reflex.Vty.Widget.Popup + Potato.Reflex.Vty.Widget.ScrollBar + Potato.Reflex.Vty.Widget.TextInputHelpers + Potato.Reflex.Vty.Widget.Windows + Reflex.Vty.Test.Monad.Host + Reflex.Vty.Test.Monad.Host.TH + hs-source-dirs: + src + default-extensions: + ApplicativeDo + BangPatterns + DataKinds + ConstraintKinds + DeriveFoldable + DeriveFunctor + DeriveTraversable + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + EmptyCase + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeFamilyDependencies + TypeOperators + NoImplicitPrelude + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + build-depends: + aeson + , aeson-pretty + , ansi-terminal + , base >=4.7 && <5 + , bimap + , bytestring + , clock + , constraints-extras + , containers + , data-default + , dependent-map + , dependent-sum + , directory + , extra + , file-embed + , filepath + , http-conduit + , ilist + , lens + , mtl + , optparse-applicative + , primitive + , ref-tf + , reflex + , reflex-potatoes + , reflex-test-host >=0.1.2.2 + , reflex-vty + , relude + , semialign + -- TODO set latest version + , template-haskell >=2.18 + , text + , these + , time + , tinytools + , vty + default-language: Haskell2010 + +executable tinytools-vty-exe + main-is: Main.hs + hs-source-dirs: + app + default-extensions: + ApplicativeDo + BangPatterns + DataKinds + ConstraintKinds + DeriveFoldable + DeriveFunctor + DeriveTraversable + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + EmptyCase + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeFamilyDependencies + TypeOperators + NoImplicitPrelude + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N +RTS -A128m -n2m -s -RTS -O0 + build-depends: + aeson + , aeson-pretty + , ansi-terminal + , base >=4.7 && <5 + , bimap + , bytestring + , clock + , constraints-extras + , containers + , data-default + , dependent-map + , dependent-sum + , directory + , extra + , file-embed + , filepath + , http-conduit + , ilist + , lens + , mtl + , optparse-applicative + , tinytools-vty + , primitive + , ref-tf + , reflex-vty + , reflex >= 0.8 && <1 + , reflex-potatoes >=0.1 + , reflex-test-host >=0.1.2.2 + , tinytools >= 0.1 + , relude + , semialign + , template-haskell + , text + , these + , time + , vty + default-language: Haskell2010 + +executable write-term-width + main-is: termwidth.hs + other-modules: + Main + hs-source-dirs: + app + default-extensions: + ApplicativeDo + BangPatterns + DataKinds + ConstraintKinds + DeriveFoldable + DeriveFunctor + DeriveTraversable + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + EmptyCase + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeFamilyDependencies + TypeOperators + NoImplicitPrelude + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , aeson-pretty + , ansi-terminal + , base >=4.7 && <5 + , bimap + , bytestring + , clock + , constraints-extras + , containers + , data-default + , dependent-map + , dependent-sum + , directory + , extra + , file-embed + , filepath + , http-conduit + , ilist + , lens + , mtl + , optparse-applicative + , tinytools-vty + , primitive + , ref-tf + , reflex >= 0.8 && <1 + , reflex-potatoes >=0.1 + , reflex-test-host >=0.1.2.2 + , tinytools >= 0.1 + , relude + , semialign + , template-haskell + , text + , these + , time + , tinytools + , vty + default-language: Haskell2010 + +test-suite tinytools-vty-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Potato.Flow.ParamsSpec + Potato.FlowSpecTH + Potato.Reflex.Vty.Widget.PopupSpec + PotatoSpec + Reflex.Vty.Test.Common + Reflex.Vty.Test.Monad.HostSpec + Reflex.Vty.Test.Monad.THSpec + hs-source-dirs: + test + default-extensions: + ApplicativeDo + BangPatterns + DataKinds + ConstraintKinds + DeriveFoldable + DeriveFunctor + DeriveTraversable + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + EmptyCase + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeFamilyDependencies + TypeOperators + NoImplicitPrelude + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + HUnit + , aeson + , aeson-pretty + , ansi-terminal + , base >=4.7 && <5 + , bimap + , bytestring + , clock + , constraints-extras + , containers + , data-default + , dependent-map + , dependent-sum + , directory + , extra + , file-embed + , filepath + , hspec + , hspec-contrib + , http-conduit + , ilist + , lens + , mtl + , optparse-applicative + , tinytools-vty + , primitive + , ref-tf + , reflex + , reflex-potatoes + , reflex-test-host >=0.1.2.2 + , reflex-vty + , relude + , semialign + , template-haskell + , text + , these + , time + , tinytools + , vty + default-language: Haskell2010