tinytools 0.1.0.4 → 0.1.0.5
raw patch · 51 files changed
+1652/−1230 lines, 51 filesdep −template-haskelldep ~reflexdep ~reflex-test-host
Dependencies removed: template-haskell
Dependency ranges changed: reflex, reflex-test-host
Files
- ChangeLog.md +6/−1
- src/Potato/Data/Text/Zipper2.hs +1/−1
- src/Potato/Flow.hs +4/−4
- src/Potato/Flow/Attachments.hs +1/−1
- src/Potato/Flow/BroadPhase.hs +2/−2
- src/Potato/Flow/Controller/Goat.hs +37/−28
- src/Potato/Flow/Controller/Handler.hs +1/−3
- src/Potato/Flow/Controller/Manipulator/Box.hs +73/−15
- src/Potato/Flow/Controller/Manipulator/BoxText.hs +1/−1
- src/Potato/Flow/Controller/Manipulator/Common.hs +1/−1
- src/Potato/Flow/Controller/Manipulator/Layers.hs +1/−1
- src/Potato/Flow/Controller/Manipulator/Line.hs +11/−8
- src/Potato/Flow/Controller/Manipulator/Select.hs +1/−1
- src/Potato/Flow/Controller/Manipulator/TextArea.hs +1/−1
- src/Potato/Flow/Controller/Manipulator/TextInputState.hs +1/−1
- src/Potato/Flow/Controller/OwlLayers.hs +7/−3
- src/Potato/Flow/Controller/Types.hs +1/−1
- src/Potato/Flow/DebugHelpers.hs +2/−2
- src/Potato/Flow/Deprecated/State.hs +2/−2
- src/Potato/Flow/Llama.hs +1/−1
- src/Potato/Flow/Methods/LineDrawer.hs +6/−5
- src/Potato/Flow/Methods/LineTypes.hs +1/−1
- src/Potato/Flow/Methods/LlamaWorks.hs +1/−1
- src/Potato/Flow/Methods/SEltMethods.hs +384/−0
- src/Potato/Flow/Methods/TextCommon.hs +1/−1
- src/Potato/Flow/Methods/Types.hs +1/−1
- src/Potato/Flow/Owl.hs +61/−31
- src/Potato/Flow/OwlHelpers.hs +2/−2
- src/Potato/Flow/OwlItem.hs +1/−1
- src/Potato/Flow/OwlState.hs +15/−13
- src/Potato/Flow/OwlWorkspace.hs +2/−1
- src/Potato/Flow/Preview.hs +2/−0
- src/Potato/Flow/Reflex/GoatWidget.hs +7/−7
- src/Potato/Flow/Render.hs +2/−2
- src/Potato/Flow/RenderCache.hs +1/−1
- src/Potato/Flow/SEltMethods.hs +0/−384
- src/Potato/Flow/SElts.hs +0/−458
- src/Potato/Flow/Serialization/Snake.hs +5/−81
- src/Potato/Flow/Serialization/SnakeWrangler.hs +83/−0
- src/Potato/Flow/Serialization/Versions/V1/SElts.hs +460/−0
- src/Potato/Flow/Types.hs +1/−1
- test/Potato/Flow/AttachmentsSpec.hs +1/−1
- test/Potato/Flow/Controller/Manipulator/BoxSpec.hs +71/−1
- test/Potato/Flow/Controller/Manipulator/LayersSpec.hs +171/−9
- test/Potato/Flow/Controller/Manipulator/PanSpec.hs +58/−8
- test/Potato/Flow/Deprecated/Controller/Manipulator/BoxTextSpec.hs +3/−3
- test/Potato/Flow/GoatTester.hs +24/−2
- test/Potato/Flow/Methods/SEltMethodsSpec.hs +119/−0
- test/Potato/Flow/OwlSpec.hs +3/−3
- test/Potato/Flow/SEltMethodsSpec.hs +0/−119
- tinytools.cabal +11/−15
ChangeLog.md view
@@ -1,6 +1,11 @@ # Changelog -## [Unreleased]+## [unreleased]++## [0.1.0.5]+- various internal improvements to how previews are staged and committed+- fix crash issue with undoing drags that contained folders+- fix several other crashes ## [0.1.0.4] ### Changed
src/Potato/Data/Text/Zipper2.hs view
@@ -4,7 +4,7 @@ import Prelude import Control.Exception (assert)-import Control.Monad.State (evalState, forM, get, put)+import Control.Monad.State (evalState, get, put) import Data.Char (isSpace) import Data.Map (Map) import Data.Maybe (fromMaybe)
src/Potato/Flow.hs view
@@ -1,7 +1,7 @@ module Potato.Flow (- module Potato.Flow.SElts+ module Potato.Flow.Serialization.Snake , module Potato.Flow.Math- , module Potato.Flow.SEltMethods+ , module Potato.Flow.Methods.SEltMethods , module Potato.Flow.Types , module Potato.Flow.Methods.Types , module Potato.Flow.Render@@ -21,9 +21,9 @@ import Potato.Flow.Controller import Potato.Flow.Math import Potato.Flow.Render-import Potato.Flow.SEltMethods+import Potato.Flow.Methods.SEltMethods import Potato.Flow.Methods.Types-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import Potato.Flow.Types import Potato.Flow.OwlHelpers import Potato.Flow.OwlWorkspace
src/Potato/Flow/Attachments.hs view
@@ -18,7 +18,7 @@ import Potato.Flow.Math import Potato.Flow.OwlItem-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import Potato.Flow.Methods.LineTypes import Data.List (minimumBy)
src/Potato/Flow/BroadPhase.hs view
@@ -23,8 +23,8 @@ import Potato.Flow.Owl import Potato.Flow.OwlItem import Potato.Flow.OwlState-import Potato.Flow.SEltMethods-import Potato.Flow.SElts+import Potato.Flow.Methods.SEltMethods+import Potato.Flow.Serialization.Snake import Potato.Flow.Types import qualified Data.IntMap.Strict as IM
src/Potato/Flow/Controller/Goat.hs view
@@ -48,8 +48,8 @@ import Potato.Flow.OwlState import Potato.Flow.OwlWorkspace import Potato.Flow.Render-import Potato.Flow.SEltMethods-import Potato.Flow.SElts+import Potato.Flow.Methods.SEltMethods+import Potato.Flow.Serialization.Snake import Potato.Flow.Types import Potato.Flow.Preview import Potato.Flow.Methods.LlamaWorks@@ -282,9 +282,11 @@ gs_1 = gs { _goatState_screenRegion = x }- r = goat_setPan (_goatState_pan gs_1) gs_1+ r = goat_rerenderAfterMove gs_1+ + endoGoatCmdWSEvent :: WSEvent -> GoatState -> GoatState endoGoatCmdWSEvent wsev gs = goat_applyWSEvent WSEventType_Local_Refresh wsev gs @@ -303,23 +305,28 @@ -- NOTE _goatState_layersHandler gets set by goat_applyWSEvent during refresh } -endoGoatCmdSetFocusedArea :: GoatFocusedArea -> GoatState -> GoatState-endoGoatCmdSetFocusedArea gfa goatState = r where+goat_setFocusedArea :: GoatFocusedArea -> GoatState -> GoatState+goat_setFocusedArea gfa goatState = r where didchange = gfa /= _goatState_focusedArea goatState goatstatewithnewfocus = goatState { _goatState_focusedArea = gfa } noactionneeded = goatstatewithnewfocus potatoHandlerInput = potatoHandlerInputFromGoatState goatState r = if didchange && pHandlerName (_goatState_layersHandler goatState) == handlerName_layersRename+ -- special case to force confirmation on layersRename handler which is special because it does not generate a Preview then let goatState_afterAction = case pHandleKeyboard (_goatState_layersHandler goatState) potatoHandlerInput (KeyboardData KeyboardKey_Return []) of Nothing -> noactionneeded- Just pho -> goat_processLayersHandlerOutput pho goatstatewithnewfocus- in assert (_goatState_focusedArea goatState == GoatFocusedArea_Layers) $ goatState_afterAction + Just pho -> traceShow "press enter" $ goat_processLayersHandlerOutput pho goatstatewithnewfocus+ in assert (_goatState_focusedArea goatState == GoatFocusedArea_Layers) $ goatState_afterAction else noactionneeded +endoGoatCmdSetFocusedArea :: GoatFocusedArea -> GoatState -> GoatState+endoGoatCmdSetFocusedArea = goat_setFocusedArea++ endoGoatCmdMouse :: LMouseData -> GoatState -> GoatState-endoGoatCmdMouse mouseData goatState = trace ("endomouse: " <> show mouseData) $ r where+endoGoatCmdMouse mouseData goatState = r where sameSource = _mouseDrag_isLayerMouse (_goatState_mouseDrag goatState) == _lMouseData_isLayerMouse mouseData mouseSourceFailure = _mouseDrag_state (_goatState_mouseDrag goatState) /= MouseDragState_Up && not sameSource mouseDrag = case _mouseDrag_state (_goatState_mouseDrag goatState) of@@ -328,9 +335,9 @@ _ -> continueDrag mouseData (_goatState_mouseDrag goatState) canvasDrag = toRelMouseDrag last_pFState (_goatState_pan goatState) mouseDrag- goatState_withNewMouse = goatState {+ goatState_withFocusedArea = goat_setFocusedArea (if isLayerMouse then GoatFocusedArea_Layers else GoatFocusedArea_Canvas) goatState+ goatState_withNewMouse = goatState_withFocusedArea { _goatState_mouseDrag = mouseDrag- , _goatState_focusedArea = if isLayerMouse then GoatFocusedArea_Layers else GoatFocusedArea_Canvas } noChangeOutput = goatState_withNewMouse -- TODO maybe split this case out to endoGoatCmdLayerMouse@@ -539,25 +546,32 @@ , _renderContext_renderedCanvasRegion = _goatState_renderedCanvas goatState } -goat_setPan :: XY -> GoatState -> GoatState-goat_setPan (V2 dx dy) goatState = r where+goat_addPan :: XY -> GoatState -> GoatState+goat_addPan (V2 dx dy) goatState = r where -- set the pan -- render move -- render selection V2 cx0 cy0 = _goatState_pan goatState next_pan = V2 (cx0+dx) (cy0 + dy) + gs_1 = goatState {+ _goatState_pan = next_pan+ }+ + r = goat_rerenderAfterMove gs_1++goat_rerenderAfterMove :: GoatState -> GoatState+goat_rerenderAfterMove goatState = r where+ -- render move+ -- render selection rc = renderContextFromGoatState goatState- (rc_aftermove, _) = goat_renderCanvas_move rc next_pan (_goatState_screenRegion goatState)+ (rc_aftermove, _) = goat_renderCanvas_move rc (_goatState_pan goatState) (_goatState_screenRegion goatState) rc_afterselection = goat_renderCanvas_selection rc_aftermove (_goatState_selection goatState) r = goatState {- _goatState_pan = next_pan- , _goatState_renderedCanvas = _renderContext_renderedCanvasRegion rc_aftermove+ _goatState_renderedCanvas = _renderContext_renderedCanvasRegion rc_aftermove , _goatState_renderedSelection = _renderContext_renderedCanvasRegion rc_afterselection } -- computeCanvasSelection :: (HasCallStack) => GoatState -> CanvasSelection computeCanvasSelection goatState = r where pfs = goatState_pFState goatState@@ -633,11 +647,11 @@ goat_processHandlerOutput_noSetHandler :: PotatoHandlerOutput -> GoatState -> GoatState-goat_processHandlerOutput_noSetHandler pho goatState = trace ("goat_processHandlerOutput_noSetHandler HANDLER OUTPUT: " <> show pho <> " CURRENT HANDLER: " <> show (_goatState_handler goatState)) $ r where+goat_processHandlerOutput_noSetHandler pho goatState = r where r = case _potatoHandlerOutput_action pho of HOA_Select x y -> goat_setSelection x y goatState- HOA_Pan x -> goat_setPan x goatState+ HOA_Pan x -> goat_addPan x goatState HOA_Layers x y -> goat_setLayersStateWithChangesFromToggleHide x y goatState HOA_Preview p -> goat_applyWSEvent WSEventType_Local_NoRefresh (WSEApplyPreview dummyShepard dummyShift p) goatState HOA_Nothing -> goatState@@ -650,16 +664,11 @@ goat_processCanvasHandlerOutput pho goatState = r where canvasSelection = computeCanvasSelection goatState - wasNoAction = handlerOutputAction_isNothing $ _potatoHandlerOutput_action pho- -- TODO you can DELETE workspace stuff here once all handlers properly return commit actions when they are done- -- you need this right now otherwise, for example, drag creating a box via BoxHandler will not commit after mouseup as it returns (handler: Nothing, action: HOA_Nothing)- (next_handler, next_workspace) = case _potatoHandlerOutput_nextHandler pho of- -- if we replaced the handler and there was HOA_Nothing, commit its local preview if there was one- Nothing -> (makeHandlerFromSelection canvasSelection, if wasNoAction then maybeCommitLocalPreviewToLlamaStackAndClear $ _goatState_workspace goatState else _goatState_workspace goatState)- Just x -> (x, _goatState_workspace goatState)+ next_handler = case _potatoHandlerOutput_nextHandler pho of+ Nothing -> makeHandlerFromSelection canvasSelection+ Just x -> x goatState' = goatState { _goatState_handler = next_handler - , _goatState_workspace = next_workspace } r = goat_processHandlerOutput_noSetHandler pho $ goatState' @@ -761,7 +770,7 @@ -- NO that's not true because in those cases you can return an explicit commit action or you return HOA_Nothing which should also commit when the handler is replaced (next_handler, next_workspace) = if (not . handlerActiveState_isActive) (pIsHandlerActive (_goatState_handler goatState_afterSetLayersState)) && not (goatState_hasLocalPreview goatState_afterSetLayersState) -- if we replaced the handler, commit its local preview if there was one- then trace "COMMIT: " $ (makeHandlerFromSelection next_canvasSelection, maybeCommitLocalPreviewToLlamaStackAndClear $ _goatState_workspace goatState_afterSetLayersState)+ then (makeHandlerFromSelection next_canvasSelection, maybeCommitLocalPreviewToLlamaStackAndClear $ _goatState_workspace goatState_afterSetLayersState) else (_goatState_handler goatState_afterSetLayersState, _goatState_workspace goatState_afterSetLayersState) goatState_afterSetHandler = goatState_afterSetLayersState { _goatState_handler = next_handler
src/Potato/Flow/Controller/Handler.hs view
@@ -14,7 +14,7 @@ import Potato.Flow.Render import Potato.Flow.OwlState import Potato.Flow.OwlWorkspace-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import qualified Potato.Flow.Preview as Preview import qualified Potato.Data.Text.Zipper as TZ@@ -51,8 +51,6 @@ , _potatoHandlerOutput_action :: HandlerOutputAction } deriving (Show)-- instance Default PotatoHandlerOutput where def = PotatoHandlerOutput {
src/Potato/Flow/Controller/Manipulator/Box.hs view
@@ -7,14 +7,7 @@ {-# OPTIONS_GHC -fno-warn-unused-record-wildcards #-} -module Potato.Flow.Controller.Manipulator.Box (- BoxHandleType(..)- , BoxHandler(..)- , BoxCreationType(..)- , makeHandleBox- , makeDeltaBox- --, MouseManipulator(..)-) where+module Potato.Flow.Controller.Manipulator.Box where import Relude @@ -25,8 +18,8 @@ import Potato.Flow.Controller.Manipulator.Common import Potato.Flow.Controller.Types import Potato.Flow.Math-import Potato.Flow.SEltMethods-import Potato.Flow.SElts+import Potato.Flow.Methods.SEltMethods+import Potato.Flow.Serialization.Snake import Potato.Flow.Types import Potato.Flow.OwlItem import Potato.Flow.Owl@@ -156,6 +149,9 @@ data BoxHandler = BoxHandler { _boxHandler_handle :: BoxHandleType -- the current handle we are dragging++ -- TODO this is wrong as makeDragOperation does not always return a Llama+ -- rename this to mouseActive or something , _boxHandler_undoFirst :: Bool -- with this you can use same code for both create and manipulate (create the handler and immediately pass input to it)@@ -164,6 +160,9 @@ , _boxHandler_downOnLabel :: Bool ++ , _boxHandler_prevDeltaLBox :: Maybe DeltaLBox+ } deriving (Show) makeDragDeltaBox :: BoxHandleType -> RelMouseDrag -> DeltaLBox@@ -178,18 +177,68 @@ r = makeDeltaBox bht boxRestrictedDelta +-- reduces the DeltaLBox such that the LBox does not invert+-- assumes LBox is canonical and that LBox is not already smaller than the desired constrained size+constrainDeltaLBox :: Int -> DeltaLBox -> LBox -> DeltaLBox+constrainDeltaLBox minsize d1@(DeltaLBox (V2 dx dy) (V2 dw dh)) d2@((LBox (V2 x y) (V2 w h))) = r where+ optuple e = (e, -e)++ (ndx, ndw) = if dx /= 0 + then optuple (min (w-minsize) dx)+ else (dx, (max minsize (w+dw)) - w)+ + (ndy, ndh) = if dy /= 0+ then optuple (min (h-minsize) dy)+ else (dy, (max minsize (h+dh)) - h)++ istranslateonly = dw == 0 && dh == 0+ + r = if istranslateonly + then d1 + else DeltaLBox (V2 ndx ndy) (V2 ndw ndh)++-- OR you remove the delta portion that already modified the box in preview+makeDragOperationNew :: PotatoHandlerInput -> DeltaLBox -> Maybe Llama+makeDragOperationNew phi dbox = op where+ selection = transformableSelection phi+ selectionl = toList $ transformableSelection phi+ pfs = _potatoHandlerInput_pFState phi+ lboxes = fmap (\sowl -> _sEltDrawer_box (getDrawer . hasOwlItem_toOwlSubItem $ sowl) pfs) selectionl++ -- go through each element in selection and ensure that dbox does not invert that element+ -- DANGER you need to make sure you have sensible bounding box functions or you might put things in a non-resizeable state+ constraineddbox = foldl' (constrainDeltaLBox 1) dbox lboxes++ fmapfn sowl = makeSetLlama (rid, newselt) where+ rid = _superOwl_id sowl+ oldselt = superOwl_toSElt_hack sowl+ -- TODO don't use the CBoundingBox version of that funciton, it's deprecated, write a new one.+ newselt = modify_sElt_with_cBoundingBox True oldselt (CBoundingBox constraineddbox)++ op = if Seq.null selection+ then Nothing+ else Just $ makeCompositionLlama . toList $ (fmap fmapfn selectionl)++ makeDragOperation :: PotatoHandlerInput -> DeltaLBox -> Maybe Llama makeDragOperation phi dbox = op where selection = transformableSelection phi+ selectionl = toList $ transformableSelection phi+ pfs = _potatoHandlerInput_pFState phi+ lboxes = fmap (\sowl -> _sEltDrawer_box (getDrawer . hasOwlItem_toOwlSubItem $ sowl) pfs) selectionl + -- go through each element in selection and ensure that dbox does not invert that element+ -- DANGER you need to make sure you have sensible bounding box functions or you might put things in a non-resizeable state+ constraineddbox = foldl' (constrainDeltaLBox 0) dbox lboxes+ makeController _ = cmd where cmd = CTagBoundingBox :=> (Identity $ CBoundingBox {- _cBoundingBox_deltaBox = dbox+ _cBoundingBox_deltaBox = dbox -- constraineddbox }) op = if Seq.null selection then Nothing- else Just $ makePFCLlama . OwlPFCManipulate $ IM.fromList (fmap (\s -> (_superOwl_id s, makeController s)) (toList selection))+ else Just $ makePFCLlama . OwlPFCManipulate $ IM.fromList (fmap (\s -> (_superOwl_id s, makeController s)) selectionl) -- TODO split this handler in two handlers -- one for resizing selection (including boxes)@@ -201,6 +250,7 @@ , _boxHandler_creation = BoxCreationType_None , _boxHandler_active = False , _boxHandler_downOnLabel = False+ , _boxHandler_prevDeltaLBox = Nothing -- TODO whatever --, _boxHandler_wasDragged = False }@@ -223,6 +273,8 @@ then True else False +minusDeltaLBox :: DeltaLBox -> DeltaLBox -> DeltaLBox+minusDeltaLBox (DeltaLBox (V2 dx1 dy1) (V2 dw1 dh1)) (DeltaLBox (V2 dx2 dy2) (V2 dw2 dh2)) = DeltaLBox (V2 (dx1-dx2) (dy1-dy2)) (V2 (dw1-dw2) (dh1-dh2)) instance PotatoHandler BoxHandler where pHandlerName _ = handlerName_box@@ -295,16 +347,18 @@ BoxCreationType_TextArea -> "<textarea>" _ -> error "invalid BoxCreationType" + mdd = makeDragDeltaBox _boxHandler_handle rmd mop = case _boxHandler_creation of x | x == BoxCreationType_Box || x == BoxCreationType_Text -> Just $ makeAddEltLlama _potatoHandlerInput_pFState newEltPos (OwlItem (OwlInfo nameToAdd) (OwlSubItemBox boxToAdd)) BoxCreationType_TextArea -> Just $ makeAddEltLlama _potatoHandlerInput_pFState newEltPos (OwlItem (OwlInfo nameToAdd) (OwlSubItemTextArea textAreaToAdd))- _ -> makeDragOperation phi (makeDragDeltaBox _boxHandler_handle rmd)+ _ -> makeDragOperationNew phi (minusDeltaLBox mdd (fromMaybe (DeltaLBox 0 0) _boxHandler_prevDeltaLBox)) newbh = bh { _boxHandler_undoFirst = True -- if we drag, we are no longer in label case , _boxHandler_downOnLabel = False+ , _boxHandler_prevDeltaLBox = Just mdd } -- NOTE, that if we did create a new box, it wil get auto selected and a new BoxHandler will be created for it@@ -357,7 +411,11 @@ -- This clears the handler and causes selection to regenerate a new handler. -- Why do we do it this way instead of returning a handler? Not sure, doesn't matter.- else Just def+ else Just def {+ _potatoHandlerOutput_action = HOA_Preview Preview_MaybeCommit+ -- doesn't work, see comments where _boxHandler_undoFirst is defined+ --_potatoHandlerOutput_action = if _boxHandler_undoFirst then HOA_Preview Preview_Commit else HOA_Nothing+ } -- TODO if this was a text box creation case, consider entering text edit mode @@ -388,7 +446,7 @@ else case mmove of Nothing -> Nothing Just move -> Just r2 where- mop = makeDragOperation phi move+ mop = makeDragOperationNew phi move r2 = def { _potatoHandlerOutput_nextHandler = Just $ SomePotatoHandler bh , _potatoHandlerOutput_action = case mop of
src/Potato/Flow/Controller/Manipulator/BoxText.hs view
@@ -24,7 +24,7 @@ import Potato.Flow.Controller.Input import Potato.Flow.Controller.Manipulator.Common import Potato.Flow.Math-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import Potato.Flow.Types import Potato.Flow.Owl import Potato.Flow.OwlWorkspace
src/Potato/Flow/Controller/Manipulator/Common.hs view
@@ -16,7 +16,7 @@ import Potato.Flow.Controller.Types import Potato.Flow.Math-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import Potato.Flow.OwlItem import Potato.Flow.Owl import Potato.Flow.DebugHelpers
src/Potato/Flow/Controller/Manipulator/Layers.hs view
@@ -18,7 +18,7 @@ import Potato.Flow.OwlItem import Potato.Flow.OwlState import Potato.Flow.OwlWorkspace-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import Potato.Flow.Types import Potato.Flow.Preview
src/Potato/Flow/Controller/Manipulator/Line.hs view
@@ -24,7 +24,7 @@ import Potato.Flow.OwlItem import Potato.Flow.OwlState import Potato.Flow.OwlWorkspace-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import Potato.Flow.Methods.LlamaWorks import Potato.Flow.Preview @@ -182,7 +182,7 @@ -- | -- see indexing information in 'whichSubSegmentDidClick'-getAnchorPosition :: Bool -> OwlPFState -> SAutoLine -> Int -> XY+getAnchorPosition :: (HasCallStack) => Bool -> OwlPFState -> SAutoLine -> Int -> XY getAnchorPosition offsetAttach pfs sline@SAutoLine {..} anchorindex = r where mps = _sAutoLine_midpoints endindex = length mps + 1@@ -191,7 +191,7 @@ else if anchorindex == endindex then getEndpointPosition offsetAttach pfs sline False else if anchorindex > 0 && anchorindex < endindex- then case mps L.!! (anchorindex-1) of+ then case mps `debugBangBang` (anchorindex-1) of SAutoLineConstraintFixed xy -> xy else error $ "out of bounds anchor index " <> show anchorindex @@ -440,7 +440,9 @@ , _potatoHandlerOutput_action = HOA_Preview $ Preview (previewOperation_fromUndoFirst _autoLineEndPointHandler_undoFirst) op } -- no need to return AutoLineHandler, it will be recreated from selection by goat- MouseDragState_Up -> Just def+ MouseDragState_Up -> Just def {+ _potatoHandlerOutput_action = if _autoLineEndPointHandler_undoFirst then HOA_Preview Preview_Commit else HOA_Nothing+ } MouseDragState_Cancelled -> if _autoLineEndPointHandler_undoFirst then Just def { _potatoHandlerOutput_action = HOA_Preview Preview_Cancel } else Just def pHandleKeyboard _ PotatoHandlerInput {..} _ = Nothing@@ -591,7 +593,9 @@ , _potatoHandlerOutput_action = HOA_Preview $ Preview (previewOperation_fromUndoFirst _autoLineMidPointHandler_undoFirst) event } -- no need to return AutoLineHandler, it will be recreated from selection by goat- MouseDragState_Up -> Just def+ MouseDragState_Up -> Just def {+ _potatoHandlerOutput_action = if _autoLineMidPointHandler_undoFirst then HOA_Preview Preview_Commit else HOA_Nothing+ } MouseDragState_Cancelled -> if _autoLineMidPointHandler_undoFirst then Just def { _potatoHandlerOutput_action = HOA_Preview Preview_Cancel } else Just def pRenderHandler AutoLineMidPointHandler {..} phi@PotatoHandlerInput {..} = r where boxes = maybeRenderPoints (False, False) _autoLineMidPointHandler_offsetAttach _autoLineMidPointHandler_midPointIndex phi@@ -640,9 +644,6 @@ } MouseDragState_Up -> Just def {-- -- TODO Preview_Commit - -- go back to AutoLineLabelHandler on completion _potatoHandlerOutput_nextHandler = if not _autoLineLabelMoverHandler_undoFirst -- if _autoLineLabelMoverHandler_undoFirst is false, this means we didn't drag at all, in which case go to label edit handler@@ -650,6 +651,8 @@ makeAutoLineLabelHandler_from_labelIndex _autoLineLabelMoverHandler_labelIndex _autoLineLabelMoverHandler_prevHandler phi rmd -- TODO consider also going into edit handler after dragging an endpoint, but for now, just go back to the previous handler (which will be AutoLineHandler) else Just (_autoLineLabelMoverHandler_prevHandler)++ , _potatoHandlerOutput_action = if _autoLineLabelMoverHandler_undoFirst then HOA_Preview Preview_Commit else HOA_Nothing } MouseDragState_Cancelled -> Just def {
src/Potato/Flow/Controller/Manipulator/Select.hs view
@@ -21,7 +21,7 @@ import Potato.Flow.OwlItem import Potato.Flow.OwlState import Potato.Flow.RenderCache-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import Control.Exception (assert) import Data.Default
src/Potato/Flow/Controller/Manipulator/TextArea.hs view
@@ -17,7 +17,7 @@ import Potato.Flow.Math import Potato.Flow.Owl import Potato.Flow.OwlWorkspace-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import Potato.Flow.Types import Potato.Flow.Preview
src/Potato/Flow/Controller/Manipulator/TextInputState.hs view
@@ -5,7 +5,7 @@ import Relude import Potato.Flow.Math-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import Potato.Flow.Controller.Input import Potato.Flow.Controller.Handler
src/Potato/Flow/Controller/OwlLayers.hs view
@@ -9,7 +9,7 @@ import Potato.Flow.Controller.Types import Potato.Flow.Types-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import Potato.Flow.OwlItem import Potato.Flow.Owl import Potato.Flow.OwlState@@ -136,8 +136,12 @@ r = "LayersState: " <> show _layersState_meta <> "\nLayerEntries:\n"- <> showFoldable _layersState_entries+ <> layerEntriesToPrettyText _layersState_entries +--instance Show LayersState where+-- show ls = T.unpack (potatoShow ls)++ data LockHideCollapseOp = LHCO_ToggleLock | LHCO_ToggleHide | LHCO_ToggleCollapse deriving (Show) alterWithDefault :: (Eq a, Default a) => (a -> a) -> REltId -> REltIdMap a -> REltIdMap a@@ -199,7 +203,7 @@ le = Seq.index _layersState_entries lepos lerid = layerEntry_rEltId le ledepth = layerEntry_depth le- childFrom nextLayerEntry = layerEntry_depth nextLayerEntry /= ledepth+ childFrom nextLayerEntry = layerEntry_depth nextLayerEntry > ledepth -- visible children of le childles = Seq.takeWhileL childFrom . Seq.drop (lepos+1) $ _layersState_entries -- everything before le
src/Potato/Flow/Controller/Types.hs view
@@ -21,7 +21,7 @@ import Potato.Flow.Math import Potato.Flow.Owl-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import Potato.Flow.Types import Data.Aeson
src/Potato/Flow/DebugHelpers.hs view
@@ -25,8 +25,8 @@ then b else error $ "assert failed:\n" <> potatoShow a -traceWith :: (a -> String) -> a -> a-traceWith f x = trace (f x) x+traceIdWith :: (a -> String) -> a -> a+traceIdWith f x = trace (f x) x traceShowIdWithLabel :: (Show a) => String -> a -> a traceShowIdWithLabel label x = trace (label <> ": " <> show x) x
src/Potato/Flow/Deprecated/State.hs view
@@ -40,8 +40,8 @@ import Potato.Flow.Deprecated.Layers import Potato.Flow.Math-import Potato.Flow.SEltMethods-import Potato.Flow.SElts+import Potato.Flow.Methods.SEltMethods+import Potato.Flow.Serialization.Snake import Potato.Flow.Types import Control.Exception (assert)
src/Potato/Flow/Llama.hs view
@@ -10,7 +10,7 @@ import Potato.Flow.Owl import Potato.Flow.OwlItem import Potato.Flow.OwlState-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import Potato.Flow.Types
src/Potato/Flow/Methods/LineDrawer.hs view
@@ -38,7 +38,8 @@ import Potato.Flow.Methods.Types import Potato.Flow.Owl import Potato.Flow.OwlItem-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake+import Potato.Flow.DebugHelpers import qualified Data.List as L import qualified Data.List.Index as L@@ -691,13 +692,13 @@ -- the SAutoLineLabel does not have to be one of labels contained in the SAutoLine _sAutoLine_labels -- which is useful for positioning SAutoLineLabel before adding them to SAutoLine -- however the midpoint index in SAutoLineLabel is expected to map correctly to the SAutoLine-getSAutoLineLabelPosition :: (HasOwlTree a) => a -> SAutoLine -> SAutoLineLabel -> XY+getSAutoLineLabelPosition :: (HasCallStack, HasOwlTree a) => a -> SAutoLine -> SAutoLineLabel -> XY getSAutoLineLabelPosition ot sal sall = getSAutoLineLabelPositionFromLineAnchorsForRender lar sal sall where- lar = sAutoLine_to_lineAnchorsForRenderList ot sal L.!! (_sAutoLineLabel_index sall)+ lar = sAutoLine_to_lineAnchorsForRenderList ot sal `debugBangBang` (_sAutoLineLabel_index sall) -- get SAutoLineLabel positions in visual order (which may not be the same as logical order) -- return includes SAutoLineLabel and its original logical index for convenience-getSortedSAutoLineLabelPositions :: (HasOwlTree a) => a -> SAutoLine -> [(XY, Int, SAutoLineLabel)]+getSortedSAutoLineLabelPositions :: (HasCallStack, HasOwlTree a) => a -> SAutoLine -> [(XY, Int, SAutoLineLabel)] getSortedSAutoLineLabelPositions ot sal@SAutoLine {..} = r where sortfn (_,a) (_,b) = case compare (_sAutoLineLabel_index a) (_sAutoLineLabel_index b) of EQ -> case _sAutoLineLabel_position a of@@ -708,7 +709,7 @@ larlist = sAutoLine_to_lineAnchorsForRenderList ot sal - r = fmap (\(i, sall) -> (internal_getSAutoLineLabelPosition (larlist L.!! _sAutoLineLabel_index sall) sal sall, i, sall)) sortedlls+ r = fmap (\(i, sall) -> (internal_getSAutoLineLabelPosition (larlist `debugBangBang` _sAutoLineLabel_index sall) sal sall, i, sall)) sortedlls -- takes a list of line anchors as returned by sAutoLine_to_lineAnchorsForRenderList and a position
src/Potato/Flow/Methods/LineTypes.hs view
@@ -5,7 +5,7 @@ import Relude import Potato.Flow.Math-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import Linear.Vector ((^*)) import Linear.Matrix (M22, (!*))
src/Potato/Flow/Methods/LlamaWorks.hs view
@@ -14,7 +14,7 @@ import Potato.Flow.OwlWorkspace import Potato.Flow.OwlState import Potato.Flow.Llama-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import Potato.Flow.Types import Control.Exception (assert)
+ src/Potato/Flow/Methods/SEltMethods.hs view
@@ -0,0 +1,384 @@+{-# LANGUAGE RecordWildCards #-}++module Potato.Flow.Methods.SEltMethods where++import Relude++import Potato.Flow.Math+import Potato.Flow.Methods.LineDrawer+import Potato.Flow.Methods.TextCommon+import Potato.Flow.Methods.Types+import Potato.Flow.Owl+import Potato.Flow.RenderCache+import Potato.Flow.OwlItem+import Potato.Flow.Serialization.Snake+import Potato.Flow.Types++import Data.Dependent.Sum (DSum ((:=>)))+import qualified Data.Map as Map+import Data.Maybe (fromJust)+import qualified Data.Text as T+import qualified Potato.Data.Text.Zipper as TZ+import Control.Exception (assert)+++-- DisplayLines tag is Int, 0 for no cursor 1 for cursor+noTrailngCursorDisplayLines :: Int -> TextAlign -> T.Text -> TZ.DisplayLines Int+noTrailngCursorDisplayLines width alignment text = r where+ -- force TZ to top so that displayLinesWithAlignment doesn't create trailing space for cursor+ tz = TZ.top (TZ.fromText text)++ -- hack to get rid of trailing cursor if text is ""+ r = if T.null text+ then TZ.DisplayLines {+ _displayLines_spans = []+ , _displayLines_offsetMap = Map.empty+ , _displayLines_cursorPos = (0,0)+ }+ else TZ.displayLinesWithAlignment (convertTextAlignToTextZipperTextAlignment alignment) width 0 1 tz++makeDisplayLinesFromSBox :: SBox -> TZ.DisplayLines Int+makeDisplayLinesFromSBox sbox = r where+ alignment = _textStyle_alignment . _sBoxText_style . _sBox_text $ sbox+ text = _sBoxText_text . _sBox_text $ sbox+ LBox _ (V2 width' _) = _sBox_box sbox+ width = case _sBox_boxType sbox of+ SBoxType_BoxText -> max 0 (width'-2)+ SBoxType_NoBoxText -> width'+ _ -> error "wrong type"+ r = noTrailngCursorDisplayLines width alignment text++++-- TODO DELETE use doesOwlSubItemIntersectBox instead+doesSEltIntersectBox_DEPRECATED :: LBox -> SElt -> Bool+doesSEltIntersectBox_DEPRECATED lbox selt = case selt of+ SEltNone -> False+ SEltFolderStart -> False+ SEltFolderEnd -> False+ SEltBox x -> does_lBox_intersect_include_zero_area lbox (_sBox_box x)+ SEltTextArea x -> does_lBox_intersect_include_zero_area lbox (_sTextArea_box x)+ -- TODO this is wrong, do it correctly...+ -- we use does_lBox_intersect since it's impossible for a SAutoLine to have zero sized box+ SEltLine sline -> does_lBox_intersect lbox (fromJust $ getSEltBox_naive (SEltLine sline))++doesSEltIntersectPoint :: XY -> SElt -> Bool+doesSEltIntersectPoint pos selt = doesSEltIntersectBox_DEPRECATED (LBox pos (V2 1 1)) selt++getSEltSuperStyle :: SElt -> Maybe SuperStyle+getSEltSuperStyle selt = case selt of+ SEltBox SBox {..} -> Just _sBox_superStyle+ SEltLine SAutoLine {..} -> Just _sAutoLine_superStyle+ _ -> Nothing++getSEltLabelSuperStyle :: SEltLabel -> Maybe SuperStyle+getSEltLabelSuperStyle (SEltLabel _ x) = getSEltSuperStyle x++getSEltLineStyle :: SElt -> Maybe LineStyle+getSEltLineStyle selt = case selt of+ SEltLine SAutoLine {..} -> Just _sAutoLine_lineStyle+ _ -> Nothing++getSEltLineStyleEnd :: SElt -> Maybe LineStyle+getSEltLineStyleEnd selt = case selt of+ SEltLine SAutoLine {..} -> Just _sAutoLine_lineStyleEnd+ _ -> Nothing++getSEltLabelLineStyle :: SEltLabel -> Maybe LineStyle+getSEltLabelLineStyle (SEltLabel _ x) = getSEltLineStyle x++getSEltLabelLineStyleEnd :: SEltLabel -> Maybe LineStyle+getSEltLabelLineStyleEnd (SEltLabel _ x) = getSEltLineStyleEnd x+++getSEltBoxTextStyle :: SElt -> Maybe TextStyle+getSEltBoxTextStyle = \case+ SEltBox SBox {..} -> Just . _sBoxText_style $ _sBox_text+ _ -> Nothing++getSEltLabelBoxTextStyle :: SEltLabel -> Maybe TextStyle+getSEltLabelBoxTextStyle (SEltLabel _ x) = getSEltBoxTextStyle x++getSEltBoxType :: SElt -> Maybe SBoxType+getSEltBoxType = \case+ SEltBox SBox {..} -> Just _sBox_boxType+ _ -> Nothing++getSEltLabelBoxType :: SEltLabel -> Maybe SBoxType+getSEltLabelBoxType (SEltLabel _ x) = getSEltBoxType x++sBox_drawer :: SBox -> SEltDrawer+sBox_drawer sbox@SBox {..} = r where+ CanonicalLBox _ _ lbox@(LBox (V2 x y) (V2 w h)) = canonicalLBox_from_lBox _sBox_box++ titlewidth = max 0 (w-2)++ fillfn _ = case _superStyle_fill _sBox_superStyle of+ FillStyle_Simple c -> Just c+ FillStyle_Blank -> Nothing++ rfntext (V2 x' y') = case _sBox_boxType of+ SBoxType_Box -> Nothing+ SBoxType_NoBox -> Nothing+ _ -> outputChar where++ -- 😰😰😰 for now we just do the below for every cell+ dl = makeDisplayLinesFromSBox sbox++ offs = case _sBox_boxType of+ SBoxType_NoBoxText -> (0,0)+ _ -> (1,1)++ outputChar = displayLinesToChar (x, y) dl (x', y') offs++ -- TODO test+ rfnlabel (V2 x' y') = case _sBoxTitle_title _sBox_title of+ Nothing -> Nothing+ Just title -> outputChar where+ -- TODO we want to crop instead of wrap here+ -- however using infinite width trick will break AlignRight :(+ dl = noTrailngCursorDisplayLines titlewidth (_sBoxTitle_align _sBox_title) title+ -- note that y' will ultimately resolve to a yindex of 0 inside of displayLinesToChar+ outputChar = displayLinesToChar (x, y) dl (x', y') (1,0)++ rfnnoborder pt+ | not (does_lBox_contains_XY lbox pt) = Nothing+ | otherwise = case rfntext pt of+ -- 'Just Nothing' means don't use fill char (this happens when there are wide chars)+ Just mx -> mx+ Nothing -> fillfn pt++ rfnborder pt@(V2 x' y')+ | not (does_lBox_contains_XY lbox pt) = Nothing+ | w == 1 && h == 1 = _superStyle_point _sBox_superStyle+ | w == 1 = _superStyle_vertical _sBox_superStyle+ | h == 1 = _superStyle_horizontal _sBox_superStyle+ | x' == x && y' == y = _superStyle_tl _sBox_superStyle+ | x' == x && y' == y+h-1 = _superStyle_bl _sBox_superStyle+ | x' == x+w-1 && y' == y = _superStyle_tr _sBox_superStyle+ | x' == x+w-1 && y' == y+h-1 = _superStyle_br _sBox_superStyle+ | x' == x || x' == x+w-1 = _superStyle_vertical _sBox_superStyle+ -- label shows up at top horizontal portion+ | y' == y = case rfnlabel pt of+ Nothing -> _superStyle_horizontal _sBox_superStyle+ Just pchar -> pchar+ | y' == y+h-1 = _superStyle_horizontal _sBox_superStyle+ | otherwise = rfnnoborder pt++ r = SEltDrawer {+ _sEltDrawer_box = const lbox+ , _sEltDrawer_renderFn = \_ -> case _sBox_boxType of+ SBoxType_NoBoxText -> rfnnoborder+ SBoxType_NoBox -> rfnnoborder+ _ -> rfnborder+ + -- TODO + , _sEltDrawer_maxCharWidth = 1+ }++sTextArea_drawer :: STextArea -> SEltDrawer+sTextArea_drawer STextArea {..} = r where++ lbox@(LBox p _) = _sTextArea_box++ renderfn p' = outputChar where+ inbounds = does_lBox_contains_XY lbox p'+ outputChar = if inbounds+ then case Map.lookup (p' - p) _sTextArea_text of+ Nothing -> if _sTextArea_transparent+ then Nothing+ else Just ' '+ Just c -> Just c+ else Nothing++ r = SEltDrawer {+ _sEltDrawer_box = const lbox+ , _sEltDrawer_renderFn = \_ -> renderfn++ -- TODO+ , _sEltDrawer_maxCharWidth = 1+ }++-- NOTE that there is not a 1-1 mapping between `OwlSubItem` and `OwlItemCache` as the `OwlItemCache` is dependent on the OwlTree+-- this function assumes that you are requesting the drawer with the intent of passing in an OwlTree+-- TODO it would have been better for SEltDrawer to be created based on an OwlTree rather than return a function that takes an OwlTree+getDrawerWithCache :: OwlSubItem -> Maybe OwlItemCache -> SEltDrawer+getDrawerWithCache osubitem mcache = case osubitem of + OwlSubItemNone -> nilDrawer+ OwlSubItemFolder _ -> nilDrawer+ OwlSubItemBox sbox -> sBox_drawer sbox+ OwlSubItemLine sline -> case mcache of + Just (OwlItemCache_Line lars _) -> sSimpleLineNewRenderFn sline (Just lars)+ Nothing -> sSimpleLineNewRenderFn sline Nothing+ _ -> assert False (sSimpleLineNewRenderFn sline Nothing)+ OwlSubItemTextArea stextarea -> sTextArea_drawer stextarea++-- TODO pass in cache here+getDrawer :: OwlSubItem -> SEltDrawer+getDrawer = \case+ OwlSubItemNone -> nilDrawer+ OwlSubItemFolder _ -> nilDrawer+ OwlSubItemBox sbox -> sBox_drawer sbox+ OwlSubItemLine sline -> sSimpleLineNewRenderFn sline Nothing+ OwlSubItemTextArea stextarea -> sTextArea_drawer stextarea+ {-+ where+ potatoDrawer = SEltDrawer {+ _sEltDrawer_box = const $ fromJust (getSEltBox_naive selt)+ , _sEltDrawer_renderFn = makePotatoRenderer $ fromJust (getSEltBox_naive selt)+ }+ -}++getDrawerFromSEltForTest :: SElt -> SEltDrawer+getDrawerFromSEltForTest = getDrawer . sElt_to_owlSubItem++updateOwlSubItemCache :: (HasOwlTree a) => a -> OwlSubItem -> Maybe OwlItemCache+updateOwlSubItemCache ot x = r where+ r = case x of+ -- TODO use sAutoLine_to_lineAnchorsForRenderList here instead+ (OwlSubItemLine sline) -> cache where+ cache = Just $ OwlItemCache_Line (sSimpleLineNewRenderFnComputeCache ot sline) prerender+ seltdrawer = getDrawerWithCache x cache+ prerender = makePreRender ot seltdrawer + _ -> Just $ OwlItemCache_Generic prerender where+ seltdrawer = getDrawerWithCache x Nothing+ prerender = makePreRender ot seltdrawer +++-- TODO move modify methods to another file++modify_sAutoLineConstraint_with_cBoundingBox :: Bool -> SAutoLineConstraint -> CBoundingBox -> SAutoLineConstraint+modify_sAutoLineConstraint_with_cBoundingBox isDo constraint CBoundingBox {..} = case constraint of+ SAutoLineConstraintFixed xy -> SAutoLineConstraintFixed $ modifyDelta isDo xy (_deltaLBox_translate _cBoundingBox_deltaBox)++modify_sElt_with_cBoundingBox :: Bool -> SElt -> CBoundingBox -> SElt+modify_sElt_with_cBoundingBox isDo selt cbb@CBoundingBox {..} = case selt of+ SEltBox sbox -> SEltBox $ sbox {+ _sBox_box = modifyDelta isDo (_sBox_box sbox) _cBoundingBox_deltaBox+ }+ -- TODO handle resize parameter+ SEltLine sline@SAutoLine {..} -> SEltLine $ sline {+ _sAutoLine_start = modifyDelta isDo _sAutoLine_start+ (_deltaLBox_translate _cBoundingBox_deltaBox)+ , _sAutoLine_end = modifyDelta isDo _sAutoLine_end+ (_deltaLBox_translate _cBoundingBox_deltaBox)+ , _sAutoLine_midpoints = fmap (\slc -> modify_sAutoLineConstraint_with_cBoundingBox isDo slc cbb) _sAutoLine_midpoints+ }+ SEltTextArea stext -> SEltTextArea $ stext {+ _sTextArea_box = modifyDelta isDo (_sTextArea_box stext) _cBoundingBox_deltaBox+ }+ x -> x++modify_sElt_with_cSuperStyle :: Bool -> SElt -> CSuperStyle -> SElt+modify_sElt_with_cSuperStyle isDo selt (CSuperStyle style) = case selt of+ SEltBox sbox -> SEltBox $ sbox {+ _sBox_superStyle = modifyDelta isDo (_sBox_superStyle sbox) style+ }+ -- TODO handle resize parameter+ SEltLine sline -> SEltLine $ sline {+ _sAutoLine_superStyle = modifyDelta isDo (_sAutoLine_superStyle sline) style+ }+ _ -> error $ "Controller - SElt type mismatch: CTagSuperStyle - " <> show selt+ -- maybe we want silent failure case in the future, so you can easily restyle a big selection in bulk+ --x -> x++-- TODO DELETE use llama instead+modify_sElt_with_cLineStyle :: Bool -> SElt -> CLineStyle -> SElt+modify_sElt_with_cLineStyle isDo selt (CLineStyle style) = case selt of+ SEltLine sline -> SEltLine $ sline {+ _sAutoLine_lineStyle = modifyDelta isDo (_sAutoLine_lineStyle sline) style+ }+ _ -> error $ "Controller - SElt type mismatch: CTagLineStyle - " <> show selt+ -- maybe we want silent failure case in the future, so you can easily restyle a big selection in bulk+ --x -> x++modify_sElt_with_cTextStyle :: Bool -> SElt -> CTextStyle -> SElt+modify_sElt_with_cTextStyle isDo selt (CTextStyle style) = case selt of+ SEltBox sbox -> SEltBox $ sbox {+ _sBox_text = (_sBox_text sbox) {+ _sBoxText_style = modifyDelta isDo (_sBoxText_style . _sBox_text $ sbox) style+ }+ }+ _ -> error $ "Controller - SElt type mismatch: CTagBoxTextStyle - " <> show selt+ -- maybe we want silent failure case in the future, so you can easily restyle a big selection in bulk+ --x -> x++modify_sEltBox_label_with_cTextAlign :: Bool -> SElt -> CTextAlign -> SElt+modify_sEltBox_label_with_cTextAlign isDo selt (CTextAlign align) = case selt of+ SEltBox sbox -> SEltBox $ sbox {+ _sBox_title = sboxtitle {+ _sBoxTitle_align = modifyDelta isDo (_sBoxTitle_align sboxtitle) align+ }+ } where+ sboxtitle = _sBox_title sbox+ _ -> error $ "Controller - SElt type mismatch: CTagBoxLabelAlignment - " <> show selt+ -- maybe we want silent failure case in the future, so you can easily restyle a big selection in bulk+ --x -> x++modify_sEltBox_label_with_cMaybeText :: Bool -> SElt -> CMaybeText -> SElt+modify_sEltBox_label_with_cMaybeText isDo selt (CMaybeText text) = case selt of+ SEltBox sbox -> SEltBox $ sbox {+ _sBox_title = sboxtitle {+ _sBoxTitle_title = modifyDelta isDo (_sBoxTitle_title sboxtitle) text+ }+ } where+ sboxtitle = _sBox_title sbox+ _ -> error $ "Controller - SElt type mismatch: CTagBoxLabelAlignment - " <> show selt++modify_sEltTextArea_with_cTextArea :: Bool -> SElt -> CTextArea -> SElt+modify_sEltTextArea_with_cTextArea isDo selt (CTextArea dt) = case selt of+ SEltTextArea stextarea -> SEltTextArea $ stextarea {+ _sTextArea_text = modifyDelta isDo (_sTextArea_text stextarea) dt+ }+ _ -> error $ "Controller - SElt type mismatch: CTagTextArea - " <> show selt++modify_sEltTextArea_with_cTextAreaToggle :: Bool -> SElt -> CTextAreaToggle -> SElt+modify_sEltTextArea_with_cTextAreaToggle isDo selt (CTextAreaToggle toggle) = case selt of+ -- double toggle is idempotent but we disallow it for now+ SEltTextArea _ -> error $ "Controller - SElt type mismatch: CTagTextAreaToggle - " <> show selt+ x -> modifyDelta isDo x toggle+++modifyDelta :: (Delta x dx) => Bool -> x -> dx -> x+modifyDelta isDo x dx = if isDo+ then plusDelta x dx+ else minusDelta x dx++updateFnFromController :: Bool -> Controller -> (SEltLabel -> SEltLabel)+updateFnFromController isDo = \case+ (CTagRename :=> Identity d) -> \seltl -> modifyDelta isDo seltl d+ (CTagLine :=> Identity d) -> \(SEltLabel sname selt) -> case selt of+ SEltLine s -> SEltLabel sname (SEltLine $ modifyDelta isDo s d)+ _ -> error $ "Controller - SElt type mismatch: CTagLine - " <> show selt+ (CTagBoxText :=> Identity d) -> \(SEltLabel sname selt) -> case selt of+ SEltBox s -> SEltLabel sname (SEltBox $ modifyDelta isDo s d)+ _ -> error $ "Controller - SElt type mismatch: CTagBoxText - " <> show selt+ (CTagBoxType :=> Identity d) -> \(SEltLabel sname selt) -> case selt of+ SEltBox s -> SEltLabel sname (SEltBox $ modifyDelta isDo s d)+ _ -> error $ "Controller - SElt type mismatch: CTagBoxText - " <> show selt+ (CTagBoundingBox :=> Identity d) -> \(SEltLabel sname selt) ->+ SEltLabel sname (modify_sElt_with_cBoundingBox isDo selt d)+ (CTagSuperStyle :=> Identity d) -> \(SEltLabel sname selt) ->+ SEltLabel sname (modify_sElt_with_cSuperStyle isDo selt d)+ (CTagLineStyle :=> Identity d) -> \(SEltLabel sname selt) ->+ SEltLabel sname (modify_sElt_with_cLineStyle isDo selt d)+ (CTagBoxTextStyle :=> Identity d) -> \(SEltLabel sname selt) ->+ SEltLabel sname (modify_sElt_with_cTextStyle isDo selt d)++ (CTagBoxLabelAlignment :=> Identity d) -> \(SEltLabel sname selt) ->+ SEltLabel sname (modify_sEltBox_label_with_cTextAlign isDo selt d)+ (CTagBoxLabelText :=> Identity d) -> \(SEltLabel sname selt) ->+ SEltLabel sname (modify_sEltBox_label_with_cMaybeText isDo selt d)++ (CTagTextArea :=> Identity d) -> \(SEltLabel sname selt) ->+ SEltLabel sname (modify_sEltTextArea_with_cTextArea isDo selt d)+ (CTagTextAreaToggle :=> Identity d) -> \(SEltLabel sname selt) ->+ SEltLabel sname (modify_sEltTextArea_with_cTextAreaToggle isDo selt d)+++-- | helper method used in copy pasta+offsetSEltTree :: XY -> SEltTree -> SEltTree+offsetSEltTree offset stree = r where+ op = CBoundingBox (DeltaLBox offset 0)+ offsetfn (rid, seltl) = (rid, updateFnFromController True (CTagBoundingBox :=> Identity op) seltl)+ r = fmap offsetfn stree
src/Potato/Flow/Methods/TextCommon.hs view
@@ -6,7 +6,7 @@ import Relude -import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import qualified Data.Map as Map import qualified Data.Text as T
src/Potato/Flow/Methods/Types.hs view
@@ -11,7 +11,7 @@ import Potato.Flow.Math import Potato.Flow.Owl-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import qualified Data.Text as T
src/Potato/Flow/Owl.hs view
@@ -16,7 +16,7 @@ import qualified Data.IntSet as IS import qualified Data.Text as T import Potato.Flow.OwlItem-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import Potato.Flow.Types import Potato.Flow.DebugHelpers @@ -611,6 +611,7 @@ (rpass, rmsg) = (rpass1 && rpass2, rmsg2) r = Seq.foldlWithIndex foldfn (True, msg0) kiddos +-- oops, this should have been -1 but it's 0 so we start indexing stuff at 1 🤷🏼♀️ owlTree_maxId :: OwlTree -> REltId owlTree_maxId s = maybe 0 fst (IM.lookupMax (_owlTree_mapping s)) @@ -781,21 +782,25 @@ where r = owlParliament_toSuperOwlParliament od . OwlParliament $ _owlTree_topOwls -owlTree_removeREltId :: REltId -> OwlTree -> OwlTree-owlTree_removeREltId rid od = owlTree_removeSuperOwl (owlTree_mustFindSuperOwl od rid) od+owlTree_removeREltId :: Bool -> REltId -> OwlTree -> OwlTree+owlTree_removeREltId keepChildren rid od = owlTree_removeSuperOwl keepChildren (owlTree_mustFindSuperOwl od rid) od -owlTree_removeSuperOwl :: SuperOwl -> OwlTree -> OwlTree-owlTree_removeSuperOwl sowl OwlTree {..} = r+owlTree_removeSuperOwl :: Bool -> SuperOwl -> OwlTree -> OwlTree+owlTree_removeSuperOwl keepChildren sowl OwlTree {..} = r where -- remove the element itself newMapping'' = IM.delete (_superOwl_id sowl) _owlTree_mapping - -- remove all children recursively++ -- remove all children recursively if desired+ -- NOTE if keepChildren is true, this will put the OwlTree in an invalid state (presumably so that you can fix it later) removeEltWithoutAdjustMommyFn rid mapping = case IM.lookup rid mapping of Nothing -> error $ errorMsg_owlMapping_lookupFail mapping rid Just (_, OwlItem _ (OwlSubItemFolder kiddos)) -> foldr removeEltWithoutAdjustMommyFn (IM.delete rid mapping) kiddos Just _ -> IM.delete rid mapping- newMapping' = case _superOwl_elt sowl of+ newMapping' = if keepChildren+ then newMapping''+ else case _superOwl_elt sowl of OwlItem _ (OwlSubItemFolder kiddos) -> foldr removeEltWithoutAdjustMommyFn newMapping'' kiddos _ -> newMapping'' @@ -841,7 +846,7 @@ -- NOTE, that _owlItemMeta_position in sowls may be incorrect in the middle of this fold -- this forces us to do linear search in the owlTree_removeSuperOwl call rather than use sibling position as index into children D: -- TODO fix by always sort from right to left to avoid this- removedOd = foldl (\acc sowl -> owlTree_removeSuperOwl sowl acc) od sowls+ removedOd = foldl (\acc sowl -> owlTree_removeSuperOwl False sowl acc) od sowls -- WIP start -- ??? I can't remember what this is anymore, did I aready fix this or no? Pretty sure I can just delet all of this@@ -872,10 +877,12 @@ . filter ((== _owlSpot_parent) . _owlItemMeta_parent . _superOwl_meta) . toList $ sowls+ -- list of all siblings on the spot we are dragging to origSiblings = fromMaybe (error "expected siblings") $ if _owlSpot_parent == noOwl then mommyOwl_kiddos $ od else mommyOwl_kiddos $ owlTree_mustFindSuperOwl od _owlSpot_parent+ -- now we will walk from right to left picking out the first elt that is on or after the target spot we are dragging to (_owlSpot_leftSibling) and isn't in the removed list findPos :: REltId -- ^ original _owlSpot_leftSibling@@ -896,9 +903,11 @@ else if x == y then findPos targetrid xs ys past else findPos targetrid (x:xs) ys past+ newLeftSibling = case _owlSpot_leftSibling of Nothing -> Nothing Just target -> findPos target (reverse $ toList removed) (reverse $ toList origSiblings) False+ correctedSpot = spot { _owlSpot_leftSibling = newLeftSibling} selttree = superOwlParliament_toSEltTree od sop@@ -961,16 +970,28 @@ x -> x -- go from left to right such that parents/left siblings are added first- r = mapAccumL mapaccumlfn od0 $ toList $ fmap (\sowl -> (owlTree_owlItemMeta_toOwlSpot miniot (_superOwl_meta sowl), sowl)) (owliterateall miniot)+ (newot, addedSowls) = mapAccumL mapaccumlfn od0 $ toList $ fmap (\sowl -> (owlTree_owlItemMeta_toOwlSpot miniot (_superOwl_meta sowl), sowl)) (owliterateall miniot)+ r = (newot, addedSowls) --- parents NOT allowed :O-internal_owlTree_addOwlItem :: OwlSpot -> REltId -> OwlItem -> OwlTree -> (OwlTree, SuperOwl)-internal_owlTree_addOwlItem OwlSpot {..} rid oitem OwlTree {..} = assert nochildrenifaddingfolder r++internal_owlTree_recalculateChildrenDepths_recursive :: OwlTree -> REltId -> OwlTree+internal_owlTree_recalculateChildrenDepths_recursive ot rid = r_0 where+ sowl = owlTree_mustFindSuperOwl ot rid+ adjustdepthfn (oem, oitem) = (,oitem) $ oem { _owlItemMeta_depth = _owlItemMeta_depth (_superOwl_meta sowl) + 1 }+ r_0 = case _superOwl_elt sowl of+ OwlItem oinfo (OwlSubItemFolder kiddos) -> r_1 where+ -- update the depth of all its kiddos+ omwithadjusteddepth = foldr (\kid om -> IM.adjust adjustdepthfn kid om) (_owlTree_mapping ot) kiddos+ newot_0 = ot {_owlTree_mapping = omwithadjusteddepth}+ -- recurse+ r_1 = foldl (internal_owlTree_recalculateChildrenDepths_recursive) newot_0 kiddos+ x -> ot++-- parents allowed ONLY if all the children already exist in the tree (as orphans) or it will crash+-- returns the added element for convenience but NOT its children +internal_owlTree_addOwlItem :: (HasCallStack) => OwlSpot -> REltId -> OwlItem -> OwlTree -> (OwlTree, SuperOwl)+internal_owlTree_addOwlItem OwlSpot {..} rid oitem OwlTree {..} = r where- -- if we're adding a folder (in the normal case), ensure it has no children- nochildrenifaddingfolder = case oitem of- OwlItem _ (OwlSubItemFolder kiddos) -> Seq.null kiddos- _ -> True -- first add the OwlItem to the mapping meta =@@ -987,8 +1008,8 @@ newMapping' = IM.insertWithKey (\k _ ov -> error ("key " <> show k <> " already exists with value " <> show ov)) rid (meta, oitem) _owlTree_mapping - -- modify kiddos of the parent we are adding to- modifyKiddos kiddos = Seq.insertAt position rid kiddos+ -- update siblings in the parent we are adding to, leaving the tree in an invalid state (siblings have wrong position index in their OwlItemMeta)+ updateSiblings kiddos = Seq.insertAt position rid kiddos where position = case _owlSpot_leftSibling of Nothing -> 0@@ -996,32 +1017,42 @@ Nothing -> error $ "expected to find leftmost sibling " <> show leftsibrid <> " in " <> show kiddos Just x -> x + 1 adjustfn (oem, oitem') = case oitem' of- OwlItem oinfo (OwlSubItemFolder kiddos) -> (oem, OwlItem oinfo (OwlSubItemFolder (modifyKiddos kiddos)))+ OwlItem oinfo (OwlSubItemFolder kiddos) -> (oem, OwlItem oinfo (OwlSubItemFolder (updateSiblings kiddos))) _ -> error $ "expected OwlItemFolder" newMapping = case _owlSpot_parent of x | x == noOwl -> newMapping'- _ -> IM.adjust adjustfn _owlSpot_parent newMapping'+ _ -> assert (IM.member _owlSpot_parent newMapping') $ IM.adjust adjustfn _owlSpot_parent newMapping' -- or top owls if there is no parent newTopOwls = case _owlSpot_parent of- x | x == noOwl -> modifyKiddos _owlTree_topOwls+ x | x == noOwl -> updateSiblings _owlTree_topOwls _ -> _owlTree_topOwls - r' =+ tree_1 = OwlTree { _owlTree_mapping = newMapping, _owlTree_topOwls = newTopOwls } - newtree = internal_owlTree_reorgKiddos r' _owlSpot_parent+ -- correct the sibling indices+ tree_2 = internal_owlTree_reorgKiddos tree_1 _owlSpot_parent - newsowl = owlTree_mustFindSuperOwl newtree rid+ -- correct the children depths+ tree_3 = internal_owlTree_recalculateChildrenDepths_recursive tree_2 rid - r = (newtree, newsowl)+ newsowl = owlTree_mustFindSuperOwl tree_3 rid --- OwlItem must not be a parent-owlTree_addOwlItem :: OwlSpot -> REltId -> OwlItem -> OwlTree -> (OwlTree, SuperOwl)-owlTree_addOwlItem = internal_owlTree_addOwlItem+ r = (tree_3, newsowl) +-- NOTE parents are allowed here IF all the children already exist in the tree+-- returns the added element and all its children+owlTree_addOwlItem :: OwlSpot -> REltId -> OwlItem -> OwlTree -> (OwlTree, [SuperOwl])+owlTree_addOwlItem ospot rid oitem ot = r where+ (newot, addedSowls) = internal_owlTree_addOwlItem ospot rid oitem ot+ addedSowlsWithChildren = toList . owliterateat newot . _superOwl_id $ addedSowls+ r = (newot, addedSowlsWithChildren)++ + -- this method works for parents IF all children are included in the list and sorted from left to right owlTree_addOwlItemList :: [(REltId, OwlSpot, OwlItem)] -> OwlTree -> (OwlTree, [SuperOwl]) owlTree_addOwlItemList seltls od0 = r where@@ -1031,14 +1062,13 @@ mapaccumlfn od (rid,ospot,oitem) = internal_owlTree_addOwlItem ospot rid oitemmodded od where osubitemmodded = case _owlItem_subItem oitem of -- temp remove kiddos from parent as needed by internal_owlTree_addOwlItem+ -- the kiddos will be set correctly when the children get added further down the seltls list OwlSubItemFolder _ -> OwlSubItemFolder Seq.empty x -> x oitemmodded = OwlItem (_owlItem_info oitem) osubitemmodded -- go from left to right such that parents are added first- (newot, changes) = mapAccumL mapaccumlfn od0 seltls-- r = (newot, changes)+ r = mapAccumL mapaccumlfn od0 seltls -- TODO TEST
src/Potato/Flow/OwlHelpers.hs view
@@ -3,11 +3,11 @@ import Relude -import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import Potato.Flow.Owl import Potato.Flow.OwlItem import Potato.Flow.Llama-import Potato.Flow.SEltMethods+import Potato.Flow.Methods.SEltMethods superOwl_mustGetSLine :: SuperOwl -> SAutoLine superOwl_mustGetSLine sowl = case _owlItem_subItem$ _superOwl_elt sowl of
src/Potato/Flow/OwlItem.hs view
@@ -4,7 +4,7 @@ import Relude -import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import Potato.Flow.DebugHelpers data OwlInfo = OwlInfo {
src/Potato/Flow/OwlState.hs view
@@ -8,8 +8,8 @@ import Potato.Flow.Attachments import Potato.Flow.OwlItem import Potato.Flow.Math-import Potato.Flow.SElts-import Potato.Flow.SEltMethods+import Potato.Flow.Serialization.Snake+import Potato.Flow.Methods.SEltMethods import Potato.Flow.Types import Potato.Flow.DebugHelpers @@ -18,6 +18,7 @@ import Data.List.Ordered (isSortedBy) import Data.Maybe import qualified Data.Text as T+import qualified Data.Sequence as Seq @@ -114,10 +115,10 @@ owlPFState_to_SuperOwlParliament :: OwlPFState -> SuperOwlParliament owlPFState_to_SuperOwlParliament OwlPFState {..} = owlParliament_toSuperOwlParliament _owlPFState_owlTree $ OwlParliament $ _owlTree_topOwls _owlPFState_owlTree -do_newElts :: [(REltId, OwlSpot, OwlItem)] -> OwlPFState -> (OwlPFState, SuperOwlChanges)+do_newElts :: (HasCallStack) => [(REltId, OwlSpot, OwlItem)] -> OwlPFState -> (OwlPFState, SuperOwlChanges) do_newElts seltls pfs@OwlPFState {..} = r where - -- parents are allowed, but seltls must be sortefd from left -> right such that leftmost sibling/parent of OwlSpot exists (assuming elts are added to the tree from left to right)+ -- notably, passing in a list here rather than SuperOwlParialment allows us to add parents with children so long as everything is sorted from left to right (such that the parent/sibling exist when the child gets added) (newot, changes') = owlTree_addOwlItemList seltls _owlPFState_owlTree changes = IM.fromList $ fmap (\sowl -> (_superOwl_id sowl, Just sowl)) changes'@@ -125,7 +126,7 @@ undo_newElts :: [(REltId, OwlSpot, OwlItem)] -> OwlPFState -> (OwlPFState, SuperOwlChanges) undo_newElts seltls pfs@OwlPFState {..} = r where- foldfn (rid,_,_) od = owlTree_removeREltId rid od+ foldfn (rid,_,_) od = owlTree_removeREltId False rid od -- assumes seltls sorted from left to right so that no parent is deleted before its child newot = foldr foldfn _owlPFState_owlTree seltls changes = IM.fromList $ fmap (\(rid,_,_) -> (rid, Nothing)) seltls@@ -145,7 +146,7 @@ undo_newMiniOwlTree :: (MiniOwlTree, OwlSpot) -> OwlPFState -> (OwlPFState, SuperOwlChanges) undo_newMiniOwlTree (mot, _) pfs@OwlPFState {..} = r where- foldfn rid od = owlTree_removeREltId rid od+ foldfn rid od = owlTree_removeREltId False rid od newot = foldr foldfn _owlPFState_owlTree (_owlTree_topOwls mot) changes = IM.fromList $ fmap (\sowl -> (_superOwl_id sowl, Nothing)) $ toList $ owliterateall mot r = (pfs { _owlPFState_owlTree = newot}, changes)@@ -174,9 +175,10 @@ op = superOwlParliament_toOwlParliament sop (newot, changes') = owlTree_moveOwlParliament op os _owlPFState_owlTree changes = IM.fromList $ fmap (\sowl -> (_superOwl_id sowl, Just sowl)) changes'+ r = (pfs { _owlPFState_owlTree = newot}, changes) -undo_move :: (OwlSpot, SuperOwlParliament) -> OwlPFState -> (OwlPFState, SuperOwlChanges)+undo_move :: (HasCallStack) => (OwlSpot, SuperOwlParliament) -> OwlPFState -> (OwlPFState, SuperOwlChanges) undo_move (_, sop) pfs@OwlPFState {..} = assert isUndoFriendly r where -- NOTE that sop is likely invalid in pfs at this point@@ -184,17 +186,17 @@ -- make sure SuperOwlParliament is ordered in an undo-friendly way isUndoFriendly = isSuperOwlParliamentUndoFriendly sop - -- first remove all elements we moved- removefoldfn tree' so = owlTree_removeREltId (_superOwl_id so) tree'+ -- first remove all elements we moved, but keep their children putting the tree in an invalid state+ removefoldfn tree' so = owlTree_removeREltId True (_superOwl_id so) tree' removedTree = foldl' removefoldfn _owlPFState_owlTree (unSuperOwlParliament sop) - -- then add them back in in order+ -- then add them back in in order (any children are still in the tree with missing parent) addmapaccumlfn tree' so = owlTree_addOwlItem ospot (_superOwl_id so) (_superOwl_elt so) tree' where- -- NOTE that because we are ordered from left to right, _superOwl_meta so is valid in tree'+ -- NOTE that because we are ordered from left to right, `_superOwl_meta so` points to a vlaid spot in the tree' (parents comes before children) ospot = owlTree_owlItemMeta_toOwlSpot tree' $ _superOwl_meta so (addedTree, changes') = mapAccumL addmapaccumlfn removedTree (unSuperOwlParliament sop)-- changes = IM.fromList $ fmap (\sowl -> (_superOwl_id sowl, Just sowl)) (toList changes')+ changes = IM.fromList $ fmap (\sowl -> (_superOwl_id sowl, Just sowl)) (join . toList $ changes')+ r = (pfs { _owlPFState_owlTree = addedTree}, changes)
src/Potato/Flow/OwlWorkspace.hs view
@@ -22,7 +22,7 @@ import Potato.Flow.Owl import Potato.Flow.OwlItem import Potato.Flow.OwlState-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import Potato.Flow.Types import Potato.Flow.Preview @@ -278,6 +278,7 @@ Preview_Commit -> assert (owlPFWorkspace_hasLocalPreview ws) $ (ws_afterCommit, IM.empty)+ Preview_MaybeCommit -> (ws_afterCommit, IM.empty) Preview_Cancel -> case _owlPFWorkspace_localPreview ws of Nothing -> error "expected local preview" Just (_, _, undollama) -> clearLocalPreview $ doLlamaWorkspace' False undollama ws
src/Potato/Flow/Preview.hs view
@@ -41,6 +41,8 @@ Preview PreviewOperation Llama -- commit the last operation | Preview_Commit+ -- same as above but does not assert that there is a local preview+ | Preview_MaybeCommit -- cancel the preview | Preview_Cancel deriving (Show, Generic)
src/Potato/Flow/Reflex/GoatWidget.hs view
@@ -124,11 +124,8 @@ -- new Endo folding endoStyle = [ - -- these be run before _goatWidgetConfig_mouse because sometimes we want to set params/change focus and input a mouse at the same time (i.e. clicking away from params widget to canvas widget causing params to send an update)- fmap endoGoatCmdSetFocusedArea _goatWidgetConfig_setFocusedArea-- -- the order of the rest doesn't matter- , fmap endoGoatCmdSetDefaultParams _goatWidgetConfig_setPotatoDefaultParameters+ -- the order of these ones don't matter+ fmap endoGoatCmdSetDefaultParams _goatWidgetConfig_setPotatoDefaultParameters , fmap endoGoatCmdMarkSaved _goatWidgetConfig_markSaved , fmap endoGoatCmdSetTool _goatWidgetConfig_selectTool , fmap endoGoatCmdSetDebugLabel _goatWidgetConfig_setDebugLabel@@ -136,10 +133,13 @@ , fmap endoGoatCmdLoad _goatWidgetConfig_load , fmap (\_ -> endoGoatCmdNewFolder "folder") _goatWidgetConfig_newFolder , fmap endoGoatCmdWSEvent _goatWidgetConfig_bypassEvent- , fmap endoGoatCmdWSEvent $ ffor _goatWidgetConfig_paramsEvent $ \llama -> WSEApplyLlama (False, llama)- , fmap endoGoatCmdWSEvent $ ffor _goatWidgetConfig_canvasSize $ \xy -> WSEApplyLlama (False, makePFCLlama $ OwlPFCResizeCanvas (DeltaLBox 0 xy)) , fmap endoGoatCmdMouse _goatWidgetConfig_mouse , fmap endoGoatCmdKeyboard _goatWidgetConfig_keyboard++ -- these be run before _goatWidgetConfig_mouse because sometimes we want to set params/change focus and input a mouse at the same time (i.e. clicking away from params widget to canvas widget causing params to send an update)+ , fmap endoGoatCmdSetFocusedArea _goatWidgetConfig_setFocusedArea+ , fmap endoGoatCmdWSEvent $ ffor _goatWidgetConfig_paramsEvent $ \llama -> WSEApplyLlama (False, llama)+ , fmap endoGoatCmdWSEvent $ ffor _goatWidgetConfig_canvasSize $ \xy -> WSEApplyLlama (False, makePFCLlama $ OwlPFCResizeCanvas (DeltaLBox 0 xy)) ] -- DELETE
src/Potato/Flow/Render.hs view
@@ -34,9 +34,9 @@ import Potato.Flow.RenderCache import Potato.Flow.BroadPhase import Potato.Flow.Math-import Potato.Flow.SEltMethods+import Potato.Flow.Methods.SEltMethods import Potato.Flow.Methods.Types-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import Potato.Flow.Types import Potato.Flow.OwlState import Potato.Flow.OwlItem
src/Potato/Flow/RenderCache.hs view
@@ -6,7 +6,7 @@ import Potato.Flow.Math import Potato.Flow.Methods.Types-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import Potato.Flow.Types import Potato.Flow.Owl import Potato.Flow.Methods.LineTypes
− src/Potato/Flow/SEltMethods.hs
@@ -1,384 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--module Potato.Flow.SEltMethods where--import Relude--import Potato.Flow.Math-import Potato.Flow.Methods.LineDrawer-import Potato.Flow.Methods.TextCommon-import Potato.Flow.Methods.Types-import Potato.Flow.Owl-import Potato.Flow.RenderCache-import Potato.Flow.OwlItem-import Potato.Flow.SElts-import Potato.Flow.Types--import Data.Dependent.Sum (DSum ((:=>)))-import qualified Data.Map as Map-import Data.Maybe (fromJust)-import qualified Data.Text as T-import qualified Potato.Data.Text.Zipper as TZ-import Control.Exception (assert)----- DisplayLines tag is Int, 0 for no cursor 1 for cursor-noTrailngCursorDisplayLines :: Int -> TextAlign -> T.Text -> TZ.DisplayLines Int-noTrailngCursorDisplayLines width alignment text = r where- -- force TZ to top so that displayLinesWithAlignment doesn't create trailing space for cursor- tz = TZ.top (TZ.fromText text)-- -- hack to get rid of trailing cursor if text is ""- r = if T.null text- then TZ.DisplayLines {- _displayLines_spans = []- , _displayLines_offsetMap = Map.empty- , _displayLines_cursorPos = (0,0)- }- else TZ.displayLinesWithAlignment (convertTextAlignToTextZipperTextAlignment alignment) width 0 1 tz--makeDisplayLinesFromSBox :: SBox -> TZ.DisplayLines Int-makeDisplayLinesFromSBox sbox = r where- alignment = _textStyle_alignment . _sBoxText_style . _sBox_text $ sbox- text = _sBoxText_text . _sBox_text $ sbox- LBox _ (V2 width' _) = _sBox_box sbox- width = case _sBox_boxType sbox of- SBoxType_BoxText -> max 0 (width'-2)- SBoxType_NoBoxText -> width'- _ -> error "wrong type"- r = noTrailngCursorDisplayLines width alignment text------ TODO DELETE use doesOwlSubItemIntersectBox instead-doesSEltIntersectBox_DEPRECATED :: LBox -> SElt -> Bool-doesSEltIntersectBox_DEPRECATED lbox selt = case selt of- SEltNone -> False- SEltFolderStart -> False- SEltFolderEnd -> False- SEltBox x -> does_lBox_intersect_include_zero_area lbox (_sBox_box x)- SEltTextArea x -> does_lBox_intersect_include_zero_area lbox (_sTextArea_box x)- -- TODO this is wrong, do it correctly...- -- we use does_lBox_intersect since it's impossible for a SAutoLine to have zero sized box- SEltLine sline -> does_lBox_intersect lbox (fromJust $ getSEltBox_naive (SEltLine sline))--doesSEltIntersectPoint :: XY -> SElt -> Bool-doesSEltIntersectPoint pos selt = doesSEltIntersectBox_DEPRECATED (LBox pos (V2 1 1)) selt--getSEltSuperStyle :: SElt -> Maybe SuperStyle-getSEltSuperStyle selt = case selt of- SEltBox SBox {..} -> Just _sBox_superStyle- SEltLine SAutoLine {..} -> Just _sAutoLine_superStyle- _ -> Nothing--getSEltLabelSuperStyle :: SEltLabel -> Maybe SuperStyle-getSEltLabelSuperStyle (SEltLabel _ x) = getSEltSuperStyle x--getSEltLineStyle :: SElt -> Maybe LineStyle-getSEltLineStyle selt = case selt of- SEltLine SAutoLine {..} -> Just _sAutoLine_lineStyle- _ -> Nothing--getSEltLineStyleEnd :: SElt -> Maybe LineStyle-getSEltLineStyleEnd selt = case selt of- SEltLine SAutoLine {..} -> Just _sAutoLine_lineStyleEnd- _ -> Nothing--getSEltLabelLineStyle :: SEltLabel -> Maybe LineStyle-getSEltLabelLineStyle (SEltLabel _ x) = getSEltLineStyle x--getSEltLabelLineStyleEnd :: SEltLabel -> Maybe LineStyle-getSEltLabelLineStyleEnd (SEltLabel _ x) = getSEltLineStyleEnd x---getSEltBoxTextStyle :: SElt -> Maybe TextStyle-getSEltBoxTextStyle = \case- SEltBox SBox {..} -> Just . _sBoxText_style $ _sBox_text- _ -> Nothing--getSEltLabelBoxTextStyle :: SEltLabel -> Maybe TextStyle-getSEltLabelBoxTextStyle (SEltLabel _ x) = getSEltBoxTextStyle x--getSEltBoxType :: SElt -> Maybe SBoxType-getSEltBoxType = \case- SEltBox SBox {..} -> Just _sBox_boxType- _ -> Nothing--getSEltLabelBoxType :: SEltLabel -> Maybe SBoxType-getSEltLabelBoxType (SEltLabel _ x) = getSEltBoxType x--sBox_drawer :: SBox -> SEltDrawer-sBox_drawer sbox@SBox {..} = r where- CanonicalLBox _ _ lbox@(LBox (V2 x y) (V2 w h)) = canonicalLBox_from_lBox _sBox_box-- titlewidth = max 0 (w-2)-- fillfn _ = case _superStyle_fill _sBox_superStyle of- FillStyle_Simple c -> Just c- FillStyle_Blank -> Nothing-- rfntext (V2 x' y') = case _sBox_boxType of- SBoxType_Box -> Nothing- SBoxType_NoBox -> Nothing- _ -> outputChar where-- -- 😰😰😰 for now we just do the below for every cell- dl = makeDisplayLinesFromSBox sbox-- offs = case _sBox_boxType of- SBoxType_NoBoxText -> (0,0)- _ -> (1,1)-- outputChar = displayLinesToChar (x, y) dl (x', y') offs-- -- TODO test- rfnlabel (V2 x' y') = case _sBoxTitle_title _sBox_title of- Nothing -> Nothing- Just title -> outputChar where- -- TODO we want to crop instead of wrap here- -- however using infinite width trick will break AlignRight :(- dl = noTrailngCursorDisplayLines titlewidth (_sBoxTitle_align _sBox_title) title- -- note that y' will ultimately resolve to a yindex of 0 inside of displayLinesToChar- outputChar = displayLinesToChar (x, y) dl (x', y') (1,0)-- rfnnoborder pt- | not (does_lBox_contains_XY lbox pt) = Nothing- | otherwise = case rfntext pt of- -- 'Just Nothing' means don't use fill char (this happens when there are wide chars)- Just mx -> mx- Nothing -> fillfn pt-- rfnborder pt@(V2 x' y')- | not (does_lBox_contains_XY lbox pt) = Nothing- | w == 1 && h == 1 = _superStyle_point _sBox_superStyle- | w == 1 = _superStyle_vertical _sBox_superStyle- | h == 1 = _superStyle_horizontal _sBox_superStyle- | x' == x && y' == y = _superStyle_tl _sBox_superStyle- | x' == x && y' == y+h-1 = _superStyle_bl _sBox_superStyle- | x' == x+w-1 && y' == y = _superStyle_tr _sBox_superStyle- | x' == x+w-1 && y' == y+h-1 = _superStyle_br _sBox_superStyle- | x' == x || x' == x+w-1 = _superStyle_vertical _sBox_superStyle- -- label shows up at top horizontal portion- | y' == y = case rfnlabel pt of- Nothing -> _superStyle_horizontal _sBox_superStyle- Just pchar -> pchar- | y' == y+h-1 = _superStyle_horizontal _sBox_superStyle- | otherwise = rfnnoborder pt-- r = SEltDrawer {- _sEltDrawer_box = const lbox- , _sEltDrawer_renderFn = \_ -> case _sBox_boxType of- SBoxType_NoBoxText -> rfnnoborder- SBoxType_NoBox -> rfnnoborder- _ -> rfnborder- - -- TODO - , _sEltDrawer_maxCharWidth = 1- }--sTextArea_drawer :: STextArea -> SEltDrawer-sTextArea_drawer STextArea {..} = r where-- lbox@(LBox p _) = _sTextArea_box-- renderfn p' = outputChar where- inbounds = does_lBox_contains_XY lbox p'- outputChar = if inbounds- then case Map.lookup (p' - p) _sTextArea_text of- Nothing -> if _sTextArea_transparent- then Nothing- else Just ' '- Just c -> Just c- else Nothing-- r = SEltDrawer {- _sEltDrawer_box = const lbox- , _sEltDrawer_renderFn = \_ -> renderfn-- -- TODO- , _sEltDrawer_maxCharWidth = 1- }---- NOTE that there is not a 1-1 mapping between `OwlSubItem` and `OwlItemCache` as the `OwlItemCache` is dependent on the OwlTree--- this function assumes that you are requesting the drawer with the intent of passing in an OwlTree--- TODO it would have been better for SEltDrawer to be created based on an OwlTree rather than return a function that takes an OwlTree-getDrawerWithCache :: OwlSubItem -> Maybe OwlItemCache -> SEltDrawer-getDrawerWithCache osubitem mcache = case osubitem of - OwlSubItemNone -> nilDrawer- OwlSubItemFolder _ -> nilDrawer- OwlSubItemBox sbox -> sBox_drawer sbox- OwlSubItemLine sline -> case mcache of - Just (OwlItemCache_Line lars _) -> sSimpleLineNewRenderFn sline (Just lars)- Nothing -> sSimpleLineNewRenderFn sline Nothing- _ -> assert False (sSimpleLineNewRenderFn sline Nothing)- OwlSubItemTextArea stextarea -> sTextArea_drawer stextarea---- TODO pass in cache here-getDrawer :: OwlSubItem -> SEltDrawer-getDrawer = \case- OwlSubItemNone -> nilDrawer- OwlSubItemFolder _ -> nilDrawer- OwlSubItemBox sbox -> sBox_drawer sbox- OwlSubItemLine sline -> sSimpleLineNewRenderFn sline Nothing- OwlSubItemTextArea stextarea -> sTextArea_drawer stextarea- {-- where- potatoDrawer = SEltDrawer {- _sEltDrawer_box = const $ fromJust (getSEltBox_naive selt)- , _sEltDrawer_renderFn = makePotatoRenderer $ fromJust (getSEltBox_naive selt)- }- -}--getDrawerFromSEltForTest :: SElt -> SEltDrawer-getDrawerFromSEltForTest = getDrawer . sElt_to_owlSubItem--updateOwlSubItemCache :: (HasOwlTree a) => a -> OwlSubItem -> Maybe OwlItemCache-updateOwlSubItemCache ot x = r where- r = case x of- -- TODO use sAutoLine_to_lineAnchorsForRenderList here instead- (OwlSubItemLine sline) -> cache where- cache = Just $ OwlItemCache_Line (sSimpleLineNewRenderFnComputeCache ot sline) prerender- seltdrawer = getDrawerWithCache x cache- prerender = makePreRender ot seltdrawer - _ -> Just $ OwlItemCache_Generic prerender where- seltdrawer = getDrawerWithCache x Nothing- prerender = makePreRender ot seltdrawer ----- TODO move modify methods to another file--modify_sAutoLineConstraint_with_cBoundingBox :: Bool -> SAutoLineConstraint -> CBoundingBox -> SAutoLineConstraint-modify_sAutoLineConstraint_with_cBoundingBox isDo constraint CBoundingBox {..} = case constraint of- SAutoLineConstraintFixed xy -> SAutoLineConstraintFixed $ modifyDelta isDo xy (_deltaLBox_translate _cBoundingBox_deltaBox)--modify_sElt_with_cBoundingBox :: Bool -> SElt -> CBoundingBox -> SElt-modify_sElt_with_cBoundingBox isDo selt cbb@CBoundingBox {..} = case selt of- SEltBox sbox -> SEltBox $ sbox {- _sBox_box = modifyDelta isDo (_sBox_box sbox) _cBoundingBox_deltaBox- }- -- TODO handle resize parameter- SEltLine sline@SAutoLine {..} -> SEltLine $ sline {- _sAutoLine_start = modifyDelta isDo _sAutoLine_start- (_deltaLBox_translate _cBoundingBox_deltaBox)- , _sAutoLine_end = modifyDelta isDo _sAutoLine_end- (_deltaLBox_translate _cBoundingBox_deltaBox)- , _sAutoLine_midpoints = fmap (\slc -> modify_sAutoLineConstraint_with_cBoundingBox isDo slc cbb) _sAutoLine_midpoints- }- SEltTextArea stext -> SEltTextArea $ stext {- _sTextArea_box = modifyDelta isDo (_sTextArea_box stext) _cBoundingBox_deltaBox- }- x -> x--modify_sElt_with_cSuperStyle :: Bool -> SElt -> CSuperStyle -> SElt-modify_sElt_with_cSuperStyle isDo selt (CSuperStyle style) = case selt of- SEltBox sbox -> SEltBox $ sbox {- _sBox_superStyle = modifyDelta isDo (_sBox_superStyle sbox) style- }- -- TODO handle resize parameter- SEltLine sline -> SEltLine $ sline {- _sAutoLine_superStyle = modifyDelta isDo (_sAutoLine_superStyle sline) style- }- _ -> error $ "Controller - SElt type mismatch: CTagSuperStyle - " <> show selt- -- maybe we want silent failure case in the future, so you can easily restyle a big selection in bulk- --x -> x---- TODO DELETE use llama instead-modify_sElt_with_cLineStyle :: Bool -> SElt -> CLineStyle -> SElt-modify_sElt_with_cLineStyle isDo selt (CLineStyle style) = case selt of- SEltLine sline -> SEltLine $ sline {- _sAutoLine_lineStyle = modifyDelta isDo (_sAutoLine_lineStyle sline) style- }- _ -> error $ "Controller - SElt type mismatch: CTagLineStyle - " <> show selt- -- maybe we want silent failure case in the future, so you can easily restyle a big selection in bulk- --x -> x--modify_sElt_with_cTextStyle :: Bool -> SElt -> CTextStyle -> SElt-modify_sElt_with_cTextStyle isDo selt (CTextStyle style) = case selt of- SEltBox sbox -> SEltBox $ sbox {- _sBox_text = (_sBox_text sbox) {- _sBoxText_style = modifyDelta isDo (_sBoxText_style . _sBox_text $ sbox) style- }- }- _ -> error $ "Controller - SElt type mismatch: CTagBoxTextStyle - " <> show selt- -- maybe we want silent failure case in the future, so you can easily restyle a big selection in bulk- --x -> x--modify_sEltBox_label_with_cTextAlign :: Bool -> SElt -> CTextAlign -> SElt-modify_sEltBox_label_with_cTextAlign isDo selt (CTextAlign align) = case selt of- SEltBox sbox -> SEltBox $ sbox {- _sBox_title = sboxtitle {- _sBoxTitle_align = modifyDelta isDo (_sBoxTitle_align sboxtitle) align- }- } where- sboxtitle = _sBox_title sbox- _ -> error $ "Controller - SElt type mismatch: CTagBoxLabelAlignment - " <> show selt- -- maybe we want silent failure case in the future, so you can easily restyle a big selection in bulk- --x -> x--modify_sEltBox_label_with_cMaybeText :: Bool -> SElt -> CMaybeText -> SElt-modify_sEltBox_label_with_cMaybeText isDo selt (CMaybeText text) = case selt of- SEltBox sbox -> SEltBox $ sbox {- _sBox_title = sboxtitle {- _sBoxTitle_title = modifyDelta isDo (_sBoxTitle_title sboxtitle) text- }- } where- sboxtitle = _sBox_title sbox- _ -> error $ "Controller - SElt type mismatch: CTagBoxLabelAlignment - " <> show selt--modify_sEltTextArea_with_cTextArea :: Bool -> SElt -> CTextArea -> SElt-modify_sEltTextArea_with_cTextArea isDo selt (CTextArea dt) = case selt of- SEltTextArea stextarea -> SEltTextArea $ stextarea {- _sTextArea_text = modifyDelta isDo (_sTextArea_text stextarea) dt- }- _ -> error $ "Controller - SElt type mismatch: CTagTextArea - " <> show selt--modify_sEltTextArea_with_cTextAreaToggle :: Bool -> SElt -> CTextAreaToggle -> SElt-modify_sEltTextArea_with_cTextAreaToggle isDo selt (CTextAreaToggle toggle) = case selt of- -- double toggle is idempotent but we disallow it for now- SEltTextArea _ -> error $ "Controller - SElt type mismatch: CTagTextAreaToggle - " <> show selt- x -> modifyDelta isDo x toggle---modifyDelta :: (Delta x dx) => Bool -> x -> dx -> x-modifyDelta isDo x dx = if isDo- then plusDelta x dx- else minusDelta x dx--updateFnFromController :: Bool -> Controller -> (SEltLabel -> SEltLabel)-updateFnFromController isDo = \case- (CTagRename :=> Identity d) -> \seltl -> modifyDelta isDo seltl d- (CTagLine :=> Identity d) -> \(SEltLabel sname selt) -> case selt of- SEltLine s -> SEltLabel sname (SEltLine $ modifyDelta isDo s d)- _ -> error $ "Controller - SElt type mismatch: CTagLine - " <> show selt- (CTagBoxText :=> Identity d) -> \(SEltLabel sname selt) -> case selt of- SEltBox s -> SEltLabel sname (SEltBox $ modifyDelta isDo s d)- _ -> error $ "Controller - SElt type mismatch: CTagBoxText - " <> show selt- (CTagBoxType :=> Identity d) -> \(SEltLabel sname selt) -> case selt of- SEltBox s -> SEltLabel sname (SEltBox $ modifyDelta isDo s d)- _ -> error $ "Controller - SElt type mismatch: CTagBoxText - " <> show selt- (CTagBoundingBox :=> Identity d) -> \(SEltLabel sname selt) ->- SEltLabel sname (modify_sElt_with_cBoundingBox isDo selt d)- (CTagSuperStyle :=> Identity d) -> \(SEltLabel sname selt) ->- SEltLabel sname (modify_sElt_with_cSuperStyle isDo selt d)- (CTagLineStyle :=> Identity d) -> \(SEltLabel sname selt) ->- SEltLabel sname (modify_sElt_with_cLineStyle isDo selt d)- (CTagBoxTextStyle :=> Identity d) -> \(SEltLabel sname selt) ->- SEltLabel sname (modify_sElt_with_cTextStyle isDo selt d)-- (CTagBoxLabelAlignment :=> Identity d) -> \(SEltLabel sname selt) ->- SEltLabel sname (modify_sEltBox_label_with_cTextAlign isDo selt d)- (CTagBoxLabelText :=> Identity d) -> \(SEltLabel sname selt) ->- SEltLabel sname (modify_sEltBox_label_with_cMaybeText isDo selt d)-- (CTagTextArea :=> Identity d) -> \(SEltLabel sname selt) ->- SEltLabel sname (modify_sEltTextArea_with_cTextArea isDo selt d)- (CTagTextAreaToggle :=> Identity d) -> \(SEltLabel sname selt) ->- SEltLabel sname (modify_sEltTextArea_with_cTextAreaToggle isDo selt d)----- | helper method used in copy pasta-offsetSEltTree :: XY -> SEltTree -> SEltTree-offsetSEltTree offset stree = r where- op = CBoundingBox (DeltaLBox offset 0)- offsetfn (rid, seltl) = (rid, updateFnFromController True (CTagBoundingBox :=> Identity op) seltl)- r = fmap offsetfn stree
− src/Potato/Flow/SElts.hs
@@ -1,458 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--module Potato.Flow.SElts where--import Relude--import Potato.Flow.Math-import Potato.Data.Text.Unicode--import Control.Exception (assert)-import Data.Aeson-import Data.Binary-import Data.Default-import qualified Text.Show-import qualified Data.Text as T-import qualified Data.List as L-import qualified Data.Map as Map-import qualified Potato.Data.Text.Zipper as TZ-import Data.Ratio---type REltId = Int-type PChar = Char-type MPChar = Maybe PChar--getPCharWidth :: Char -> Int8-getPCharWidth = getCharWidth---data FillStyle = FillStyle_Blank | FillStyle_Simple PChar deriving (Eq, Generic, Show)--instance FromJSON FillStyle-instance ToJSON FillStyle-instance Binary FillStyle-instance NFData FillStyle--instance Default FillStyle where- def = FillStyle_Simple ' '---- TODO add line ends?--- TODO add line thickness?--- TODO add line fill?-data SuperStyle = SuperStyle {- _superStyle_tl :: MPChar- , _superStyle_tr :: MPChar- , _superStyle_bl :: MPChar- , _superStyle_br :: MPChar- , _superStyle_vertical :: MPChar- , _superStyle_horizontal :: MPChar- , _superStyle_point :: MPChar -- used for 1x1 boxes and 1x lines- , _superStyle_fill :: FillStyle-} deriving (Eq, Generic)--instance FromJSON SuperStyle-instance ToJSON SuperStyle-instance Binary SuperStyle-instance NFData SuperStyle--instance Default SuperStyle where- def = SuperStyle {- _superStyle_tl = Just '╔'- , _superStyle_tr = Just '╗'- , _superStyle_bl = Just '╚'- , _superStyle_br = Just '╝'- , _superStyle_vertical = Just '║'- , _superStyle_horizontal = Just '═'- , _superStyle_point = Just '█'- , _superStyle_fill = def- }--instance Show SuperStyle where- show = superStyle_toListFormat--superStyle_fromListFormat :: [PChar] -> SuperStyle-superStyle_fromListFormat chars = assert (l == 7 || l == 8) $ r where- l = length chars- r = SuperStyle {- _superStyle_tl = Just $ chars L.!! 0- , _superStyle_tr = Just $ chars L.!! 1- , _superStyle_bl = Just $ chars L.!! 2- , _superStyle_br = Just $ chars L.!! 3- , _superStyle_vertical = Just $ chars L.!! 4- , _superStyle_horizontal = Just $ chars L.!! 5- , _superStyle_point = Just $ chars L.!! 6- , _superStyle_fill = if l == 7 then FillStyle_Blank else FillStyle_Simple (chars L.!! 7)- }---- superStyle_fromListFormat "╔╗╚╝║═█" `shouldBe` def--- empty styles are converted to space character-superStyle_toListFormat :: SuperStyle -> [PChar]-superStyle_toListFormat SuperStyle {..} = r where- mfill = case _superStyle_fill of- FillStyle_Blank -> []- FillStyle_Simple c -> [c]- r = [- fromMaybe ' ' _superStyle_tl- ,fromMaybe ' ' _superStyle_tr- ,fromMaybe ' ' _superStyle_bl- ,fromMaybe ' ' _superStyle_br- ,fromMaybe ' ' _superStyle_vertical- ,fromMaybe ' ' _superStyle_horizontal- ,fromMaybe ' ' _superStyle_point- ] <> mfill---- |-data TextAlign = TextAlign_Left | TextAlign_Right | TextAlign_Center deriving (Eq, Generic, Show)--instance FromJSON TextAlign-instance ToJSON TextAlign-instance Binary TextAlign-instance NFData TextAlign--instance Default TextAlign where- def = TextAlign_Left--convertTextAlignToTextZipperTextAlignment :: TextAlign -> TZ.TextAlignment-convertTextAlignToTextZipperTextAlignment = \case- TextAlign_Left -> TZ.TextAlignment_Left- TextAlign_Right -> TZ.TextAlignment_Right- TextAlign_Center -> TZ.TextAlignment_Center---- |-data TextStyle = TextStyle {- -- margins- _textStyle_alignment :: TextAlign-} deriving (Eq, Generic)--instance FromJSON TextStyle-instance ToJSON TextStyle-instance Binary TextStyle-instance NFData TextStyle--instance Default TextStyle where- def = TextStyle { _textStyle_alignment = def }--instance Show TextStyle where- show TextStyle {..} = show _textStyle_alignment----- TODO you need support for AL_Any and maybe AL_Center--- TODO lowercase plz-data AttachmentLocation = AL_Top | AL_Bot | AL_Left | AL_Right | AL_Any deriving (Eq, Generic, Show)--instance FromJSON AttachmentLocation-instance ToJSON AttachmentLocation-instance Binary AttachmentLocation-instance NFData AttachmentLocation--type AttachmentOffsetRatio = Ratio Int--data Attachment = Attachment {- _attachment_target :: REltId- , _attachment_location :: AttachmentLocation- -- you can prob just delete these, don't think we need them.- -- 1 is right/down most, 0 is left/top most, `1 % 2` is the middle- , _attachment_offset_rel :: AttachmentOffsetRatio-} deriving (Eq, Generic, Show)--instance FromJSON Attachment-instance ToJSON Attachment-instance Binary Attachment-instance NFData Attachment---attachment_offset_rel_default :: Ratio Int-attachment_offset_rel_default = 1 % 2--attachment_create_default :: REltId -> AttachmentLocation -> Attachment-attachment_create_default rid al = Attachment {- _attachment_target = rid- , _attachment_location = al- , _attachment_offset_rel = attachment_offset_rel_default- }---- |-data SBoxTitle = SBoxTitle {- _sBoxTitle_title :: Maybe Text- , _sBoxTitle_align :: TextAlign-} deriving (Eq, Generic)--instance FromJSON SBoxTitle-instance ToJSON SBoxTitle-instance Binary SBoxTitle-instance NFData SBoxTitle--instance Default SBoxTitle where- def = SBoxTitle {- _sBoxTitle_title = Nothing- , _sBoxTitle_align = def- }--instance Show SBoxTitle where- show SBoxTitle {..} = "SBoxTitle: " <> show _sBoxTitle_align <> " " <> show _sBoxTitle_title---- |-data SBoxText = SBoxText {- _sBoxText_text :: Text- , _sBoxText_style :: TextStyle-} deriving (Eq, Generic)--instance FromJSON SBoxText-instance ToJSON SBoxText-instance Binary SBoxText-instance NFData SBoxText--instance Default SBoxText where- def = SBoxText {- _sBoxText_text = ""- , _sBoxText_style = def- }--instance Show SBoxText where- show SBoxText {..} = "SBoxText: " <> T.unpack _sBoxText_text <> " " <> show _sBoxText_style---data SBoxType = SBoxType_Box | SBoxType_NoBox | SBoxType_BoxText | SBoxType_NoBoxText deriving (Eq, Generic, Show)--instance FromJSON SBoxType-instance ToJSON SBoxType-instance Binary SBoxType-instance NFData SBoxType--instance Default SBoxType where- def = SBoxType_Box--sBoxType_isText :: SBoxType -> Bool-sBoxType_isText sbt = sbt == SBoxType_BoxText || sbt == SBoxType_NoBoxText--sBoxType_hasBorder :: SBoxType -> Bool-sBoxType_hasBorder sbt = sbt == SBoxType_Box || sbt == SBoxType_BoxText--make_sBoxType :: Bool -> Bool -> SBoxType-make_sBoxType border text = if border- then if text- then SBoxType_BoxText- else SBoxType_Box- else if text- then SBoxType_NoBoxText- else SBoxType_NoBox---- |-data SBox = SBox {- _sBox_box :: LBox- , _sBox_superStyle :: SuperStyle- , _sBox_title :: SBoxTitle- , _sBox_text :: SBoxText- , _sBox_boxType :: SBoxType-} deriving (Eq, Generic)--instance FromJSON SBox-instance ToJSON SBox-instance Binary SBox-instance NFData SBox--instance Default SBox where- def = SBox {- _sBox_box = LBox 0 0- , _sBox_superStyle = def- , _sBox_title = def- , _sBox_text = def- , _sBox_boxType = SBoxType_Box- }--instance Show SBox where- show SBox {..} = "SBox: " <> show _sBox_box <> " " <> show _sBox_title <> " " <> show _sBox_text <> " " <> show _sBox_boxType <> " " <> show _sBox_superStyle--sBox_hasLabel :: SBox -> Bool-sBox_hasLabel sbox = sBoxType_hasBorder (_sBox_boxType sbox) && (isJust . _sBoxTitle_title ._sBox_title $ sbox)---- TODO DELETE no longer used with SAutoLine-data LineAutoStyle =- LineAutoStyle_Auto- | LineAutoStyle_AutoStraight- | LineAutoStyle_StraightAlwaysHorizontal- | LineAutoStyle_StraightAlwaysVertical- deriving (Eq, Generic, Show)--instance FromJSON LineAutoStyle-instance ToJSON LineAutoStyle-instance Binary LineAutoStyle-instance NFData LineAutoStyle--instance Default LineAutoStyle where- def = LineAutoStyle_AutoStraight---data LineStyle = LineStyle {- _lineStyle_leftArrows :: Text- , _lineStyle_rightArrows :: Text- , _lineStyle_upArrows :: Text- , _lineStyle_downArrows :: Text-} deriving (Eq, Generic)--instance FromJSON LineStyle-instance ToJSON LineStyle-instance Binary LineStyle-instance NFData LineStyle--instance Default LineStyle where- def = LineStyle {- _lineStyle_leftArrows = "<"- , _lineStyle_rightArrows = ">"- , _lineStyle_upArrows = "^"- , _lineStyle_downArrows = "v"- }--lineStyle_fromListFormat :: ([PChar], [PChar], [PChar], [PChar]) -> LineStyle-lineStyle_fromListFormat (l,r,u,d) = LineStyle {- _lineStyle_leftArrows = T.pack l- , _lineStyle_rightArrows = T.pack r- , _lineStyle_upArrows = T.pack u- , _lineStyle_downArrows = T.pack d- }--lineStyle_toListFormat :: LineStyle -> ([PChar], [PChar], [PChar], [PChar])-lineStyle_toListFormat LineStyle {..} = (T.unpack _lineStyle_leftArrows, T.unpack _lineStyle_rightArrows, T.unpack _lineStyle_upArrows, T.unpack _lineStyle_downArrows)---instance Show LineStyle where- show ls = r where- (a, b, c, d) = lineStyle_toListFormat ls- r = "LineStyle: " <> a <> " " <> b <> " " <> c <> " " <> d---- someday we might have more than one constraint...-data SAutoLineConstraint = SAutoLineConstraintFixed XY deriving (Eq, Generic, Show)--instance FromJSON SAutoLineConstraint-instance ToJSON SAutoLineConstraint-instance Binary SAutoLineConstraint-instance NFData SAutoLineConstraint---- TODO provide absolute and relative positioning args-data SAutoLineLabelPosition =- SAutoLineLabelPositionRelative Float -- 0 is at "left" anchor point and 1 is at "right" anchor point- deriving (Eq, Generic, Show)--instance FromJSON SAutoLineLabelPosition-instance ToJSON SAutoLineLabelPosition-instance Binary SAutoLineLabelPosition-instance NFData SAutoLineLabelPosition--data SAutoLineLabel = SAutoLineLabel {- _sAutoLineLabel_index :: Int -- index relative to _sAutoLine_midpoints for where the midpoint lives- , _sAutoLineLabel_position :: SAutoLineLabelPosition- , _sAutoLineLabel_text :: Text- --, _sAutoLineLabel_vertical :: Bool -- WIP true if vertically oriented-} deriving (Eq, Generic)--instance Show SAutoLineLabel where- show SAutoLineLabel {..} = "SAutoLineLabel: " <> show _sAutoLineLabel_index <> " " <> show _sAutoLineLabel_position <> " " <> show _sAutoLineLabel_text--instance FromJSON SAutoLineLabel-instance ToJSON SAutoLineLabel-instance Binary SAutoLineLabel-instance NFData SAutoLineLabel--instance Default SAutoLineLabel where- def = SAutoLineLabel {- -- anchor index, text shows AFTER index- _sAutoLineLabel_index = 0- , _sAutoLineLabel_position = SAutoLineLabelPositionRelative 0- , _sAutoLineLabel_text = ""- --, _sAutoLineLabel_vertical = False- }----- |-data SAutoLine = SAutoLine {- _sAutoLine_start :: XY- , _sAutoLine_end :: XY- , _sAutoLine_superStyle :: SuperStyle-- -- TODO you need one for start/end of line (LineStyle, LineStyle)- , _sAutoLine_lineStyle :: LineStyle- , _sAutoLine_lineStyleEnd :: LineStyle-- -- NOTE attachments currently are not guaranteed to exist- -- in particular, if you copy a line, delete its target and paste, it will be attached to something that doesn't exist- -- tinytools will attempt to correct attachment in some cases but don't get too cozy about it!- , _sAutoLine_attachStart :: Maybe Attachment- , _sAutoLine_attachEnd :: Maybe Attachment-- , _sAutoLine_midpoints :: [SAutoLineConstraint]- , _sAutoLine_labels :: [SAutoLineLabel] -- WIP currently does nothing-} deriving (Eq, Generic)--instance FromJSON SAutoLine-instance ToJSON SAutoLine-instance Binary SAutoLine-instance NFData SAutoLine--instance Show SAutoLine where- show SAutoLine {..} = r where- start = maybe (show _sAutoLine_start) show _sAutoLine_attachStart- end = maybe (show _sAutoLine_end) show _sAutoLine_attachEnd- r = "SAutoLine: " <> start <> " " <> end <> " " <> show _sAutoLine_midpoints <> " " <> show _sAutoLine_labels---- makes writing tests easier...-instance Default SAutoLine where- def = SAutoLine {- _sAutoLine_start = 0- , _sAutoLine_end = 0- , _sAutoLine_superStyle = def- , _sAutoLine_lineStyle = def- , _sAutoLine_lineStyleEnd = def- , _sAutoLine_attachStart = Nothing- , _sAutoLine_attachEnd = Nothing- , _sAutoLine_midpoints = []- , _sAutoLine_labels = []- }- -type TextAreaMapping = Map XY PChar---- | abitrary text confined to a box-data STextArea = STextArea {- _sTextArea_box :: LBox- , _sTextArea_text :: TextAreaMapping- -- TODO consider using SuperStyle here instead and using Fill property only- , _sTextArea_transparent :: Bool-} deriving (Eq, Generic, Show)--instance Default STextArea where- def = STextArea {- _sTextArea_box = LBox 0 0- , _sTextArea_text = Map.empty- , _sTextArea_transparent = True- }--instance FromJSON STextArea-instance ToJSON STextArea-instance Binary STextArea-instance NFData STextArea---- TODO consider removing this all together and serializing Owl stuff directly-data SElt =- SEltNone- | SEltFolderStart- | SEltFolderEnd- | SEltBox SBox- | SEltLine SAutoLine- | SEltTextArea STextArea- deriving (Eq, Generic, Show)--instance FromJSON SElt-instance ToJSON SElt-instance Binary SElt-instance NFData SElt---- TODO consider removing this all together and serializing Owl stuff directly-data SEltLabel = SEltLabel {- _sEltLabel_name :: Text- , _sEltLabel_sElt :: SElt-} deriving (Eq, Generic, Show)--instance FromJSON SEltLabel-instance ToJSON SEltLabel-instance Binary SEltLabel-instance NFData SEltLabel
src/Potato/Flow/Serialization/Snake.hs view
@@ -1,83 +1,7 @@-{-# LANGUAGE RecordWildCards #-}--module Potato.Flow.Serialization.Snake where--import Relude--import Potato.Flow.Types-import Potato.Flow.Controller.Types--import qualified Data.Aeson as Aeson-import qualified Data.Aeson.Encode.Pretty as PrettyAeson-import qualified Data.Binary as Binary-import qualified Data.ByteString.Lazy as LBS-import qualified Data.Text.Encoding as Text------ | list of all version supported-versions :: [Int]-versions = [1]---- | version of the current build-currentVersion :: Int-currentVersion = 1--data Snake = Snake {- _snake_version :: Int- -- string instead of enum type to ensure compatibility if new formats are ever added- -- currently supports "binary" and "json"- , _snake_format :: String- , _snake_data :: Text-} deriving (Eq, Generic, Show)--instance Aeson.FromJSON Snake-instance Aeson.ToJSON Snake-instance Binary.Binary Snake-instance NFData Snake--data SnakeFormat = SF_Json | SF_Binary--serialize :: SnakeFormat -> (SPotatoFlow, ControllerMeta) -> LBS.ByteString-serialize f x = r where- (inner, format) = case f of- SF_Json -> (PrettyAeson.encodePretty x, "json")- SF_Binary -> (Binary.encode x, "binary")- outer = Snake {- _snake_version = currentVersion- , _snake_format = format- , _snake_data = Text.decodeUtf8 (LBS.toStrict inner)- }- r = PrettyAeson.encodePretty outer--deserialize :: LBS.ByteString -> Either String (SPotatoFlow, ControllerMeta)-deserialize lbs = case Aeson.eitherDecode lbs of- Left e -> Left $ "failed to decode Snake with error " <> e- Right vso -> deserialize_internal vso---deserialize_internal :: Snake -> Either String (SPotatoFlow, ControllerMeta)-deserialize_internal Snake {..} = do- if _snake_version /= currentVersion - then Left $ "version mismatch, got: " <> show _snake_version <> " expected: " <> show currentVersion- else return ()- case _snake_format of- "json" -> Aeson.eitherDecodeStrict (Text.encodeUtf8 _snake_data)- "binary" -> case Binary.decode (LBS.fromStrict $ Text.encodeUtf8 _snake_data) of- Just x -> Right x- Nothing -> Left "failed to decode binary"- x -> Left $ "unrecognized fromat" <> show x---decodeFile :: FilePath -> IO (Either String (SPotatoFlow, ControllerMeta))-decodeFile fp = do- vsobs <- LBS.readFile fp- return $ deserialize vsobs+module Potato.Flow.Serialization.Snake (+ + module Potato.Flow.Serialization.Versions.V1.SElts+) where -decodeFileMaybe :: FilePath -> IO (Maybe (SPotatoFlow, ControllerMeta))-decodeFileMaybe fp = do- x <- decodeFile fp- case x of- Left _ -> return Nothing- Right x -> return (Just x)+import Potato.Flow.Serialization.Versions.V1.SElts
+ src/Potato/Flow/Serialization/SnakeWrangler.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE RecordWildCards #-}++module Potato.Flow.Serialization.SnakeWrangler where++import Relude++import Potato.Flow.Types+import Potato.Flow.Controller.Types++import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Encode.Pretty as PrettyAeson+import qualified Data.Binary as Binary+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text.Encoding as Text++++-- | list of all version supported+versions :: [Int]+versions = [1]++-- | version of the current build+currentVersion :: Int+currentVersion = 1++data Snake = Snake {+ _snake_version :: Int+ -- string instead of enum type to ensure compatibility if new formats are ever added+ -- currently supports "binary" and "json"+ , _snake_format :: String+ , _snake_data :: Text+} deriving (Eq, Generic, Show)++instance Aeson.FromJSON Snake+instance Aeson.ToJSON Snake+instance Binary.Binary Snake+instance NFData Snake++data SnakeFormat = SF_Json | SF_Binary++serialize :: SnakeFormat -> (SPotatoFlow, ControllerMeta) -> LBS.ByteString+serialize f x = r where+ (inner, format) = case f of+ SF_Json -> (PrettyAeson.encodePretty x, "json")+ SF_Binary -> (Binary.encode x, "binary")+ outer = Snake {+ _snake_version = currentVersion+ , _snake_format = format+ , _snake_data = Text.decodeUtf8 (LBS.toStrict inner)+ }+ r = PrettyAeson.encodePretty outer++deserialize :: LBS.ByteString -> Either String (SPotatoFlow, ControllerMeta)+deserialize lbs = case Aeson.eitherDecode lbs of+ Left e -> Left $ "failed to decode Snake with error " <> e+ Right vso -> deserialize_internal vso+++deserialize_internal :: Snake -> Either String (SPotatoFlow, ControllerMeta)+deserialize_internal Snake {..} = do+ if _snake_version /= currentVersion + then Left $ "version mismatch, got: " <> show _snake_version <> " expected: " <> show currentVersion+ else return ()+ case _snake_format of+ "json" -> Aeson.eitherDecodeStrict (Text.encodeUtf8 _snake_data)+ "binary" -> case Binary.decode (LBS.fromStrict $ Text.encodeUtf8 _snake_data) of+ Just x -> Right x+ Nothing -> Left "failed to decode binary"+ x -> Left $ "unrecognized fromat" <> show x+++decodeFile :: FilePath -> IO (Either String (SPotatoFlow, ControllerMeta))+decodeFile fp = do+ vsobs <- LBS.readFile fp+ return $ deserialize vsobs+++decodeFileMaybe :: FilePath -> IO (Maybe (SPotatoFlow, ControllerMeta))+decodeFileMaybe fp = do+ x <- decodeFile fp+ case x of+ Left _ -> return Nothing+ Right x -> return (Just x)
+ src/Potato/Flow/Serialization/Versions/V1/SElts.hs view
@@ -0,0 +1,460 @@+{-# LANGUAGE RecordWildCards #-}++module Potato.Flow.Serialization.Versions.V1.SElts where++import Relude++import Potato.Flow.Math+import Potato.Data.Text.Unicode+import Potato.Flow.DebugHelpers++import Control.Exception (assert)+import Data.Aeson+import Data.Binary+import Data.Default+import qualified Text.Show+import qualified Data.Text as T+import qualified Data.List as L+import qualified Data.Map as Map+import qualified Potato.Data.Text.Zipper as TZ+import Data.Ratio++++type REltId = Int+type PChar = Char+type MPChar = Maybe PChar++getPCharWidth :: Char -> Int8+getPCharWidth = getCharWidth+++data FillStyle = FillStyle_Blank | FillStyle_Simple PChar deriving (Eq, Generic, Show)++instance FromJSON FillStyle+instance ToJSON FillStyle+instance Binary FillStyle+instance NFData FillStyle++instance Default FillStyle where+ def = FillStyle_Simple ' '++-- TODO add line ends?+-- TODO add line thickness?+-- TODO add line fill?+data SuperStyle = SuperStyle {+ _superStyle_tl :: MPChar+ , _superStyle_tr :: MPChar+ , _superStyle_bl :: MPChar+ , _superStyle_br :: MPChar+ , _superStyle_vertical :: MPChar+ , _superStyle_horizontal :: MPChar+ , _superStyle_point :: MPChar -- used for 1x1 boxes and 1x lines+ , _superStyle_fill :: FillStyle+} deriving (Eq, Generic)++instance FromJSON SuperStyle+instance ToJSON SuperStyle+instance Binary SuperStyle+instance NFData SuperStyle++instance Default SuperStyle where+ def = SuperStyle {+ _superStyle_tl = Just '╔'+ , _superStyle_tr = Just '╗'+ , _superStyle_bl = Just '╚'+ , _superStyle_br = Just '╝'+ , _superStyle_vertical = Just '║'+ , _superStyle_horizontal = Just '═'+ , _superStyle_point = Just '█'+ , _superStyle_fill = def+ }++instance Show SuperStyle where+ show = superStyle_toListFormat++superStyle_fromListFormat :: [PChar] -> SuperStyle+superStyle_fromListFormat chars = assert (l == 7 || l == 8) $ r where+ l = length chars+ r = SuperStyle {+ _superStyle_tl = Just $ chars L.!! 0+ , _superStyle_tr = Just $ chars L.!! 1+ , _superStyle_bl = Just $ chars L.!! 2+ , _superStyle_br = Just $ chars L.!! 3+ , _superStyle_vertical = Just $ chars L.!! 4+ , _superStyle_horizontal = Just $ chars L.!! 5+ , _superStyle_point = Just $ chars L.!! 6+ , _superStyle_fill = if l == 7 then FillStyle_Blank else FillStyle_Simple (chars `debugBangBang` 7)+ }++-- superStyle_fromListFormat "╔╗╚╝║═█" `shouldBe` def+-- empty styles are converted to space character+superStyle_toListFormat :: SuperStyle -> [PChar]+superStyle_toListFormat SuperStyle {..} = r where+ mfill = case _superStyle_fill of+ FillStyle_Blank -> []+ FillStyle_Simple c -> [c]+ r = [+ fromMaybe ' ' _superStyle_tl+ ,fromMaybe ' ' _superStyle_tr+ ,fromMaybe ' ' _superStyle_bl+ ,fromMaybe ' ' _superStyle_br+ ,fromMaybe ' ' _superStyle_vertical+ ,fromMaybe ' ' _superStyle_horizontal+ ,fromMaybe ' ' _superStyle_point+ ] <> mfill++-- |+data TextAlign = TextAlign_Left | TextAlign_Right | TextAlign_Center deriving (Eq, Generic, Show)++instance FromJSON TextAlign+instance ToJSON TextAlign+instance Binary TextAlign+instance NFData TextAlign++instance Default TextAlign where+ def = TextAlign_Left++convertTextAlignToTextZipperTextAlignment :: TextAlign -> TZ.TextAlignment+convertTextAlignToTextZipperTextAlignment = \case+ TextAlign_Left -> TZ.TextAlignment_Left+ TextAlign_Right -> TZ.TextAlignment_Right+ TextAlign_Center -> TZ.TextAlignment_Center++-- |+data TextStyle = TextStyle {+ -- margins+ _textStyle_alignment :: TextAlign+} deriving (Eq, Generic)++instance FromJSON TextStyle+instance ToJSON TextStyle+instance Binary TextStyle+instance NFData TextStyle++instance Default TextStyle where+ def = TextStyle { _textStyle_alignment = def }++instance Show TextStyle where+ show TextStyle {..} = show _textStyle_alignment+++-- TODO you need support for AL_Any and maybe AL_Center+-- TODO lowercase plz+data AttachmentLocation = AL_Top | AL_Bot | AL_Left | AL_Right | AL_Any deriving (Eq, Generic, Show)++instance FromJSON AttachmentLocation+instance ToJSON AttachmentLocation+instance Binary AttachmentLocation+instance NFData AttachmentLocation++type AttachmentOffsetRatio = Ratio Int++data Attachment = Attachment {+ _attachment_target :: REltId+ , _attachment_location :: AttachmentLocation+ -- you can prob just delete these, don't think we need them.+ -- 1 is right/down most, 0 is left/top most, `1 % 2` is the middle+ , _attachment_offset_rel :: AttachmentOffsetRatio+} deriving (Eq, Generic, Show)++instance FromJSON Attachment+instance ToJSON Attachment+instance Binary Attachment+instance NFData Attachment+++attachment_offset_rel_default :: Ratio Int+attachment_offset_rel_default = 1 % 2++attachment_create_default :: REltId -> AttachmentLocation -> Attachment+attachment_create_default rid al = Attachment {+ _attachment_target = rid+ , _attachment_location = al+ , _attachment_offset_rel = attachment_offset_rel_default+ }++-- |+data SBoxTitle = SBoxTitle {+ _sBoxTitle_title :: Maybe Text+ , _sBoxTitle_align :: TextAlign+} deriving (Eq, Generic)++instance FromJSON SBoxTitle+instance ToJSON SBoxTitle+instance Binary SBoxTitle+instance NFData SBoxTitle++instance Default SBoxTitle where+ def = SBoxTitle {+ _sBoxTitle_title = Nothing+ , _sBoxTitle_align = def+ }++instance Show SBoxTitle where+ show SBoxTitle {..} = "SBoxTitle: " <> show _sBoxTitle_align <> " " <> show _sBoxTitle_title++-- |+data SBoxText = SBoxText {+ _sBoxText_text :: Text+ , _sBoxText_style :: TextStyle+} deriving (Eq, Generic)++instance FromJSON SBoxText+instance ToJSON SBoxText+instance Binary SBoxText+instance NFData SBoxText++instance Default SBoxText where+ def = SBoxText {+ _sBoxText_text = ""+ , _sBoxText_style = def+ }++instance Show SBoxText where+ show SBoxText {..} = "SBoxText: " <> T.unpack _sBoxText_text <> " " <> show _sBoxText_style+++data SBoxType = SBoxType_Box | SBoxType_NoBox | SBoxType_BoxText | SBoxType_NoBoxText deriving (Eq, Generic, Show)++instance FromJSON SBoxType+instance ToJSON SBoxType+instance Binary SBoxType+instance NFData SBoxType++instance Default SBoxType where+ def = SBoxType_Box++sBoxType_isText :: SBoxType -> Bool+sBoxType_isText sbt = sbt == SBoxType_BoxText || sbt == SBoxType_NoBoxText++sBoxType_hasBorder :: SBoxType -> Bool+sBoxType_hasBorder sbt = sbt == SBoxType_Box || sbt == SBoxType_BoxText++make_sBoxType :: Bool -> Bool -> SBoxType+make_sBoxType border text = if border+ then if text+ then SBoxType_BoxText+ else SBoxType_Box+ else if text+ then SBoxType_NoBoxText+ else SBoxType_NoBox++-- |+data SBox = SBox {+ _sBox_box :: LBox+ , _sBox_superStyle :: SuperStyle+ , _sBox_title :: SBoxTitle+ , _sBox_text :: SBoxText+ , _sBox_boxType :: SBoxType+} deriving (Eq, Generic)++instance FromJSON SBox+instance ToJSON SBox+instance Binary SBox+instance NFData SBox++instance Default SBox where+ def = SBox {+ _sBox_box = LBox 0 0+ , _sBox_superStyle = def+ , _sBox_title = def+ , _sBox_text = def+ , _sBox_boxType = SBoxType_Box+ }++instance Show SBox where+ show SBox {..} = "SBox: " <> show _sBox_box <> " " <> show _sBox_title <> " " <> show _sBox_text <> " " <> show _sBox_boxType <> " " <> show _sBox_superStyle++sBox_hasLabel :: SBox -> Bool+sBox_hasLabel sbox = sBoxType_hasBorder (_sBox_boxType sbox) && (isJust . _sBoxTitle_title ._sBox_title $ sbox)++-- TODO DELETE no longer used with SAutoLine+data LineAutoStyle =+ LineAutoStyle_Auto+ | LineAutoStyle_AutoStraight+ | LineAutoStyle_StraightAlwaysHorizontal+ | LineAutoStyle_StraightAlwaysVertical+ deriving (Eq, Generic, Show)++instance FromJSON LineAutoStyle+instance ToJSON LineAutoStyle+instance Binary LineAutoStyle+instance NFData LineAutoStyle++instance Default LineAutoStyle where+ def = LineAutoStyle_AutoStraight+++data LineStyle = LineStyle {+ _lineStyle_leftArrows :: Text+ , _lineStyle_rightArrows :: Text+ , _lineStyle_upArrows :: Text+ , _lineStyle_downArrows :: Text+} deriving (Eq, Generic)++instance FromJSON LineStyle+instance ToJSON LineStyle+instance Binary LineStyle+instance NFData LineStyle++instance Default LineStyle where+ def = LineStyle {+ _lineStyle_leftArrows = "<"+ , _lineStyle_rightArrows = ">"+ , _lineStyle_upArrows = "^"+ , _lineStyle_downArrows = "v"+ }++lineStyle_fromListFormat :: ([PChar], [PChar], [PChar], [PChar]) -> LineStyle+lineStyle_fromListFormat (l,r,u,d) = LineStyle {+ _lineStyle_leftArrows = T.pack l+ , _lineStyle_rightArrows = T.pack r+ , _lineStyle_upArrows = T.pack u+ , _lineStyle_downArrows = T.pack d+ }++lineStyle_toListFormat :: LineStyle -> ([PChar], [PChar], [PChar], [PChar])+lineStyle_toListFormat LineStyle {..} = (T.unpack _lineStyle_leftArrows, T.unpack _lineStyle_rightArrows, T.unpack _lineStyle_upArrows, T.unpack _lineStyle_downArrows)+++instance Show LineStyle where+ show ls = r where+ (a, b, c, d) = lineStyle_toListFormat ls+ r = "LineStyle: " <> a <> " " <> b <> " " <> c <> " " <> d++-- someday we might have more than one constraint...+data SAutoLineConstraint = SAutoLineConstraintFixed XY deriving (Eq, Generic, Show)++instance FromJSON SAutoLineConstraint+instance ToJSON SAutoLineConstraint+instance Binary SAutoLineConstraint+instance NFData SAutoLineConstraint++-- TODO provide absolute and relative positioning args+data SAutoLineLabelPosition =+ SAutoLineLabelPositionRelative Float -- 0 is at "left" anchor point and 1 is at "right" anchor point+ deriving (Eq, Generic, Show)++instance FromJSON SAutoLineLabelPosition+instance ToJSON SAutoLineLabelPosition+instance Binary SAutoLineLabelPosition+instance NFData SAutoLineLabelPosition++data SAutoLineLabel = SAutoLineLabel {+ _sAutoLineLabel_index :: Int -- index relative to _sAutoLine_midpoints for where the midpoint lives+ , _sAutoLineLabel_position :: SAutoLineLabelPosition+ , _sAutoLineLabel_text :: Text+ --, _sAutoLineLabel_vertical :: Bool -- WIP true if vertically oriented+} deriving (Eq, Generic)++instance Show SAutoLineLabel where+ show SAutoLineLabel {..} = "SAutoLineLabel: " <> show _sAutoLineLabel_index <> " " <> show _sAutoLineLabel_position <> " " <> show _sAutoLineLabel_text++instance FromJSON SAutoLineLabel+instance ToJSON SAutoLineLabel+instance Binary SAutoLineLabel+instance NFData SAutoLineLabel++instance Default SAutoLineLabel where+ def = SAutoLineLabel {+ -- anchor index, text shows AFTER index+ _sAutoLineLabel_index = 0+ , _sAutoLineLabel_position = SAutoLineLabelPositionRelative 0+ , _sAutoLineLabel_text = ""+ --, _sAutoLineLabel_vertical = False+ }+++-- |+data SAutoLine = SAutoLine {+ _sAutoLine_start :: XY+ , _sAutoLine_end :: XY+ , _sAutoLine_superStyle :: SuperStyle++ -- TODO you need one for start/end of line (LineStyle, LineStyle)+ , _sAutoLine_lineStyle :: LineStyle+ , _sAutoLine_lineStyleEnd :: LineStyle++ -- NOTE attachments currently are not guaranteed to exist+ -- in particular, if you copy a line, delete its target and paste, it will be attached to something that doesn't exist+ -- tinytools will attempt to correct attachment in some cases but don't get too cozy about it!+ , _sAutoLine_attachStart :: Maybe Attachment+ , _sAutoLine_attachEnd :: Maybe Attachment++ , _sAutoLine_midpoints :: [SAutoLineConstraint]+ , _sAutoLine_labels :: [SAutoLineLabel] -- WIP currently does nothing+} deriving (Eq, Generic)++instance FromJSON SAutoLine+instance ToJSON SAutoLine+instance Binary SAutoLine+instance NFData SAutoLine++instance Show SAutoLine where+ show SAutoLine {..} = r where+ start = maybe (show _sAutoLine_start) show _sAutoLine_attachStart+ end = maybe (show _sAutoLine_end) show _sAutoLine_attachEnd+ r = "SAutoLine: " <> start <> " " <> end <> " " <> show _sAutoLine_midpoints <> " " <> show _sAutoLine_labels++-- makes writing tests easier...+instance Default SAutoLine where+ def = SAutoLine {+ _sAutoLine_start = 0+ , _sAutoLine_end = 0+ , _sAutoLine_superStyle = def+ , _sAutoLine_lineStyle = def+ , _sAutoLine_lineStyleEnd = def+ , _sAutoLine_attachStart = Nothing+ , _sAutoLine_attachEnd = Nothing+ , _sAutoLine_midpoints = []+ , _sAutoLine_labels = []+ }+ +type TextAreaMapping = Map XY PChar++-- | abitrary text confined to a box+data STextArea = STextArea {+ _sTextArea_box :: LBox+ , _sTextArea_text :: TextAreaMapping+ -- TODO consider using SuperStyle here instead and using Fill property only+ , _sTextArea_transparent :: Bool+} deriving (Eq, Generic, Show)++instance Default STextArea where+ def = STextArea {+ _sTextArea_box = LBox 0 0+ , _sTextArea_text = Map.empty+ , _sTextArea_transparent = True+ }++instance FromJSON STextArea+instance ToJSON STextArea+instance Binary STextArea+instance NFData STextArea++-- TODO consider removing this all together and serializing Owl stuff directly+data SElt =+ SEltNone+ | SEltFolderStart+ | SEltFolderEnd+ | SEltBox SBox+ | SEltLine SAutoLine+ | SEltTextArea STextArea+ deriving (Eq, Generic, Show)++instance FromJSON SElt+instance ToJSON SElt+instance Binary SElt+instance NFData SElt++-- TODO consider removing this all together and serializing Owl stuff directly+data SEltLabel = SEltLabel {+ _sEltLabel_name :: Text+ , _sEltLabel_sElt :: SElt+} deriving (Eq, Generic, Show)++instance FromJSON SEltLabel+instance ToJSON SEltLabel+instance Binary SEltLabel+instance NFData SEltLabel
src/Potato/Flow/Types.hs view
@@ -50,7 +50,7 @@ import Relude import Potato.Flow.Math-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake import Control.Exception (assert) import Data.Aeson
test/Potato/Flow/AttachmentsSpec.hs view
@@ -12,7 +12,7 @@ import Potato.Flow.Methods.LineDrawer import Potato.Flow.Methods.LineTypes import Potato.Flow.Math-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake spec :: Spec spec = do
test/Potato/Flow/Controller/Manipulator/BoxSpec.hs view
@@ -16,6 +16,44 @@ import Potato.Flow.Common import Potato.Flow.Controller.Manipulator.TestHelpers ++constrainDeltaLBox_test :: Spec+constrainDeltaLBox_test = do+ it "constrains as expected" $ do+ constrainDeltaLBox 1 (DeltaLBox 0 (V2 (-10) (-10))) ((LBox 0 (V2 5 5))) `shouldBe` DeltaLBox 0 (V2 (-4) (-4))+ constrainDeltaLBox 1 (DeltaLBox 0 (V2 (-10) 5)) ((LBox 0 (V2 5 5))) `shouldBe` DeltaLBox 0 (V2 (-4) 5)+ constrainDeltaLBox 1 (DeltaLBox (V2 10 0) (V2 (-10) 0)) ((LBox 0 (V2 5 5))) `shouldBe` DeltaLBox (V2 4 0) (V2 (-4) 0)++fetchLatestBox :: OwlPFState -> Either Text SBox+fetchLatestBox pfs = do+ sowl <- case maybeGetMostRecentlyCreatedOwl' pfs of+ Nothing -> Left "failed, no 🦉s"+ Just x -> Right x+ case _owlItem_subItem (_superOwl_elt sowl) of+ OwlSubItemBox x -> Right x+ x -> Left $ "expected SBox got: " <> show x++verifyMostRecentlyCreatedBoxLabelHasSize :: (Int, Int) -> GoatTester ()+verifyMostRecentlyCreatedBoxLabelHasSize (x, y) = verifyStateObjectHasProperty "verifyMostRecentlyCreatedBoxLabelHasSize" fetchLatestBox checkfn where + checkfn sbox = r where+ LBox _ (V2 x' y') = _sBox_box sbox+ r = if x == x' && y == y'+ then Nothing+ else Just $ "got size " <> show (x', y') <> " expected " <> show (x, y)++verifyMostRecentlyCreatedBoxHasText :: Maybe Text -> GoatTester ()+verifyMostRecentlyCreatedBoxHasText mt = verifyStateObjectHasProperty "verifyMostRecentlyCreatedBoxHasText" fetchLatestBox checkfn where+ checkfn sbox = r where+ istext = sBoxType_isText (_sBox_boxType sbox)+ r = case + mt of + Nothing -> if istext then Just "expected no text" else Nothing+ Just t -> if not istext + then Just "expected text" + else if t == _sBoxText_text (_sBox_text sbox)+ then Nothing + else Just $ "got text " <> show (_sBox_text sbox) <> " expected " <> t+ initSimpleBox :: GoatTester () initSimpleBox = drawCanvasBox (0, 0, 100, 100) @@ -26,7 +64,6 @@ -- TODO - basic_cancel_test :: Spec basic_cancel_test = hSpecGoatTesterWithOwlPFState emptyOwlPFState $ do @@ -51,9 +88,42 @@ initSimpleBox +noinvert_test :: Spec+noinvert_test = hSpecGoatTesterWithOwlPFState emptyOwlPFState $ do + setMarker "draw a box"+ drawCanvasBox (0, 0, 101, 101)++ setMarker "resize the box"+ canvasMouseDown (101,101)+ canvasMouseDown (-10,-10)+ canvasMouseUp (-10,-10)+ verifyMostRecentlyCreatedBoxLabelHasSize (1, 1)++ +boxtext_test :: Spec+boxtext_test = hSpecGoatTesterWithOwlPFState emptyOwlPFState $ do++ setMarker "draw a box"+ drawCanvasBox (0, 0, 101, 101)++ verifyMostRecentlyCreatedBoxHasText Nothing++ setMarker "click in the box to convert it to a text box"+ canvasMouseDown (50,50)+ canvasMouseUp (50,50)+ verifyMostRecentlyCreatedBoxHasText (Just "")++ setMarker "write some text"+ pressKeys "meow meow meow meow"+ verifyMostRecentlyCreatedBoxHasText (Just "meow meow meow meow")++ spec :: Spec spec = do describe "Box" $ do describe "basic" $ basic_test describe "basic_cancel" $ basic_cancel_test+ describe "constrainDeltaLBox" $ constrainDeltaLBox_test+ describe "noinvert" $ noinvert_test+ describe "boxtext" $ boxtext_test
test/Potato/Flow/Controller/Manipulator/LayersSpec.hs view
@@ -32,9 +32,23 @@ verifyLayersCount n = verifyState ("layers count is " <> show n) $ \s -> if (countentriesfn s) == n then Nothing else Just $ "expected " <> show n <> " elts, got " <> show (countentriesfn s) where countentriesfn = Seq.length . _layersState_entries . _goatState_layersState -basic_test :: Spec-basic_test = hSpecGoatTesterWithOwlPFState emptyOwlPFState $ do+verifyNthEntryInLayersIs :: Int -> REltId -> GoatTester()+verifyNthEntryInLayersIs n rid = verifyState (show n <> " entry in layers is " <> show rid) $ vf where+ vf s = r where+ lentries = _layersState_entries . _goatState_layersState $ s+ mfirstentry = Seq.lookup n lentries+ r = case mfirstentry of+ Nothing -> Just $ "no " <> show n <> " entry in layers"+ Just lentry -> if firstentry == rid then Nothing else Just $ "expected REltId " <> show rid <> ", got " <> show firstentry where+ firstentry = _superOwl_id . _layerEntry_superOwl $ lentry +verifyFirstEntryInLayersIs :: REltId -> GoatTester()+verifyFirstEntryInLayersIs = verifyNthEntryInLayersIs 0+ ++create_select_test :: Spec+create_select_test = hSpecGoatTesterWithOwlPFState emptyOwlPFState $ do+ setMarker "create a folder" verifyOwlCount 0 addFolder someFolderName@@ -50,10 +64,37 @@ verifyFolderSelected someFolderName +rename_focus_clickCanvas_test :: Spec+rename_focus_clickCanvas_test = hSpecGoatTesterWithOwlPFState emptyOwlPFState $ do -rename_focus_test :: Spec-rename_focus_test = hSpecGoatTesterWithOwlPFState emptyOwlPFState $ do+ setMarker "draw a box"+ drawCanvasBox (0, 0, 100, 100)+ verifyOwlCount 1 + setMarker "select the box via layers"+ layerMouseDownUpRel LMO_Normal 0 0+ verifySelectionCount 1++ setMarker "begin renaming the box"+ layerMouseDownUpRel LMO_Normal 0 0+ pressKeys "aoeu"++ let+ origname = "<box>"+ -- NOTE, when when have multi-select, we should auto-select the previous name such that it gets deleted+ expectedname = "aoeu<box>"++ setMarker "verify the name has not been changed yet (no preview)"+ verifyMostRecentlyCreatedOwl $ \sowl -> if hasOwlItem_name sowl == origname then Nothing else Just $ "expected name " <> show origname <> " got " <> show (hasOwlItem_name sowl)++ setMarker "change focus by clicking on canvas and ensure rename took effect"+ canvasMouseDownUp (50, 50)+ verifyMostRecentlyCreatedOwl $ \sowl -> if hasOwlItem_name sowl == expectedname then Nothing else Just $ "expected name " <> show expectedname <> " got " <> show (hasOwlItem_name sowl)++-- same as rename_focus_clickCanvas_test but calls setFocus instead+rename_focus_setFocus_test :: GoatFocusedArea -> Spec+rename_focus_setFocus_test gfa = hSpecGoatTesterWithOwlPFState emptyOwlPFState $ do+ setMarker "draw a box" drawCanvasBox (0, 0, 100, 100) verifyOwlCount 1@@ -75,7 +116,7 @@ verifyMostRecentlyCreatedOwl $ \sowl -> if hasOwlItem_name sowl == origname then Nothing else Just $ "expected name " <> show origname <> " got " <> show (hasOwlItem_name sowl) setMarker "change focus and ensure rename took effect"- setFocusArea GoatFocusedArea_Other+ setFocusArea gfa verifyMostRecentlyCreatedOwl $ \sowl -> if hasOwlItem_name sowl == expectedname then Nothing else Just $ "expected name " <> show expectedname <> " got " <> show (hasOwlItem_name sowl) create_in_folder_and_collapse_test :: Spec@@ -132,6 +173,7 @@ layerMouseDownUpRel LMO_Collapse 0 0 verifyLayersCount 2 + setMarker "expand the second folder" layerMouseDownUpRel LMO_Collapse 1 1 verifyLayersCount 4@@ -171,15 +213,135 @@ canvasMouseDownUp (5,5) verifySelectionCount 1 +drag_folder_test :: Spec+drag_folder_test = hSpecGoatTesterWithOwlPFState emptyOwlPFState $ do+ setMarker "create a folder"+ verifyOwlCount 0+ addFolder someFolderName+ verifyOwlCount 1+ verifyFolderSelected someFolderName+ folderrid <- _superOwl_id <$> mustGetMostRecentlyCreatedOwl + verifyFirstEntryInLayersIs folderrid + setMarker "create box 1"+ drawCanvasBox (0,0,10,10)+ verifySelectionCount 1+ -- TODO verify the box is in the folder+ verifyFirstEntryInLayersIs folderrid++ setMarker "unselect the box so that the next box is not in the folder"+ pressEscape+ verifySelectionCount 0++ setMarker "create box 2"+ drawCanvasBox (10,10,10,10)+ verifySelectionCount 1+ boxrid <- _superOwl_id <$> mustGetMostRecentlyCreatedOwl + verifyFirstEntryInLayersIs boxrid++ beforeDragTheFolder <- getLayersState + setMarker "select and drag the folder"+ layerMouseDownUpRel LMO_Normal 1 0+ layerMouseDownRel LMO_Normal 1 0+ layerMouseDownRel LMO_Normal 0 0+ layerMouseUpRel LMO_Normal 0 0+ -- TODO verify the folder is in the first position in layers+ verifyFirstEntryInLayersIs folderrid++ beforeUndo <- getLayersState++ setMarker "undo"+ pressUndo+ afterPressUndo <- getLayersState+ verifyEqual "undo state is same as before drag the folder" beforeDragTheFolder afterPressUndo++ setMarker "redo"+ pressRedo+ afterPressRedo <- getLayersState+ verifyEqual "undo state is same as before undo redo" beforeUndo afterPressRedo++drag_folder2_test :: Spec+drag_folder2_test = hSpecGoatTesterWithOwlPFState emptyOwlPFState $ do++ setMarker "setup scene"+ drawCanvasBox (0,0,10,10) -- 1+ addFolder someFolderName -- 2+ drawCanvasBox (10,10,10,10) -- 3+ addFolder "innerfolder" -- 4+ -- 2testfolder + -- 4innerfolder+ -- 3<box>+ -- 1<box> ++ setMarker "drag second box into inner folder"+ layerMouseDownUpRel LMO_Normal 2 1+ layerMouseDownRel LMO_Normal 2 1+ -- need to drag away first in order to move it into the folder+ layerMouseDownRel LMO_Normal 1 1+ layerMouseDownRel LMO_Normal 2 1+ layerMouseDownRel LMO_Normal 2 1+ layerMouseUpRel LMO_Normal 2 1+ verifyNthEntryInLayersIs 2 3+ -- 2testfolder+ -- 4innerfolder+ -- 3<box>+ -- 1<box>++ beforeDrag <- getLayersState++ -- DELETE+ --failWithMessage ("\n" <> show beforeDrag)++ setMarker "drag inner folder outside of outer folder"+ layerMouseDownUpRel LMO_Normal 1 1+ layerMouseDownRel LMO_Normal 1 1+ layerMouseDownRel LMO_Normal 5 0+ layerMouseUpRel LMO_Normal 5 0+ verifyNthEntryInLayersIs 2 4+ -- 2testfolder+ -- 1<box>+ -- 4innerfolder+ -- 3<box>++ -- DELETE+ --afterDrag <- getLayersState+ --failWithMessage ("\n" <> show afterDrag)++ setMarker "undo"+ pressUndo+ afterUndo <- getLayersState+ verifyEqual "undo state is same as before drag the folder" beforeDrag afterUndo++ -- DELETE+ --failWithMessage ("\n" <> show afterUndo)++ setMarker "collapse the inner folder"+ layerMouseDownUpRel LMO_Collapse 1 1++ -- DELETE+ --ls <- getLayersState+ --failWithMessage ("\n" <> show ls)++ verifyNthEntryInLayersIs 1 4+ verifyNthEntryInLayersIs 2 1+ -- 2testfolder+ -- 4innerfolder+ -- 1<box>+ ++ spec :: Spec spec = do describe "Layers" $ do- describe "basic" $ basic_test- describe "rename_focus_test" $ rename_focus_test+ describe "create_select_test" $ create_select_test+ describe "rename_focus_clickCanvas_test" $ rename_focus_clickCanvas_test + describe "rename_focus_setFocus_test canvas" $ rename_focus_setFocus_test GoatFocusedArea_Canvas+ describe "rename_focus_setFocus_test other" $ rename_focus_setFocus_test GoatFocusedArea_Other describe "create_in_folder_and_collapse_test" $ create_in_folder_and_collapse_test describe "folder_collapse_test" $ folder_collapse_test- describe "hide_select_test" $ lock_or_hide_select_test LMO_Hide- describe "lock_select_test" $ lock_or_hide_select_test LMO_Lock+ describe "lock_or_hide_select_test hide" $ lock_or_hide_select_test LMO_Hide+ describe "lock_or_hide_select_test lock" $ lock_or_hide_select_test LMO_Lock+ describe "drag_folder_test" $ drag_folder_test+ describe "drag_folder2_test" $ drag_folder2_test
test/Potato/Flow/Controller/Manipulator/PanSpec.hs view
@@ -25,7 +25,16 @@ pan = (x,y) +verifyScreenSize :: V2 Int -> GoatTester ()+verifyScreenSize expected = verifyState "verifyScreenSize" f where+ f gs = if screensize == expected+ then Nothing+ else Just $ "got " <> show screensize <> " expected " <> show expected+ where+ screensize = _goatState_screenRegion gs ++ -- TODO broken... basic_test :: Spec basic_test = hSpecGoatTesterWithOwlPFState emptyOwlPFState $ do@@ -34,17 +43,22 @@ drawCanvasBox (0, 0, 10, 10) -- TODO verify box position - let pan = (5, -7)+ let + pan1 = (1, 1)+ pan2 = (5, -7)+ -- after panning to pan1 when we pan to pan2 it's actually panning to pan2+pan1+ pan2p1 = (6,-6) setMarker "pan" verifyPan (0,0) setTool Tool_Pan canvasMouseDown (0, 0)- canvasMouseDown (1, 1)- verifyPan (1, 1)- canvasMouseDown pan- verifyPan pan- canvasMouseUp pan- verifyPan pan+ canvasMouseDown pan1+ verifyPan pan1+ canvasMouseDown pan2+ verifyPan pan2p1+ -- now we are at + canvasMouseUp (0, 0)+ verifyPan pan2p1 setMarker "draw a box" drawCanvasBox (0, 0, 10, 10)@@ -82,9 +96,45 @@ verifyOwlCount 1 +pan_resize_pan_test :: Spec+pan_resize_pan_test = hSpecGoatTesterWithOwlPFState emptyOwlPFState $ do++ let+ pan = (5, 10)+ minuspan = (-5, -10)+ newscreensize = V2 150 150++ setMarker "draw a box"+ drawCanvasBox (0, 0, 10, 10)+ + setMarker "pan"+ verifyPan (0,0)+ setTool Tool_Pan+ canvasMouseDown (0, 0)+ canvasMouseUp pan+ verifyPan pan++ setMarker "resize"+ verifyScreenSize goatTesterInitialScreenSize+ resizeScreen newscreensize+ verifyScreenSize newscreensize+ + setMarker "pan back"+ setTool Tool_Pan+ canvasMouseDown (0, 0)+ canvasMouseUp minuspan+ verifyPan (0, 0)+ -- TODO verify box position on screen++ setMarker "resize back"+ resizeScreen goatTesterInitialScreenSize+ verifyScreenSize goatTesterInitialScreenSize+ -- TODO verify something+ spec :: Spec spec = do describe "Pan" $ do- --describe "basic_test" $ basic_test+ describe "basic_test" $ basic_test describe "cancel_test" $ cancel_test describe "middle_button_pan_test" $ middle_button_pan_test+ describe "pan_resize_pan_test" $ pan_resize_pan_test
test/Potato/Flow/Deprecated/Controller/Manipulator/BoxTextSpec.hs view
@@ -265,7 +265,7 @@ , EWCLabel "exit BoxText" , EWCKeyboard (KeyboardData KeyboardKey_Esc []) - , EWCLabel "resize box to 0"+ , EWCLabel "resize box to 1" , EWCMouse (LMouseData (V2 12 12) False MouseButton_Left [] False) , EWCMouse (LMouseData (V2 10 10) False MouseButton_Left [] False) , EWCMouse (LMouseData (V2 10 10) True MouseButton_Left [] False)@@ -287,11 +287,11 @@ , LabelCheck "exit BoxText" , checkHandlerNameAndState handlerName_box False - , LabelCheck "resize box to 0"+ , LabelCheck "resize box to 1" , AlwaysPass , AlwaysPass , firstSuperOwlPredicate (Just "<text>") $ \sowl -> case hasOwlItem_toSElt_hack sowl of- SEltBox (SBox lbox _ _ _ _) -> lbox == LBox (V2 10 10) (V2 0 0)+ SEltBox (SBox lbox _ _ _ _) -> lbox == LBox (V2 10 10) (V2 1 1) _ -> False ]
test/Potato/Flow/GoatTester.hs view
@@ -20,6 +20,10 @@ import Data.Tuple.Extra +goatTesterInitialScreenSize :: V2 Int+goatTesterInitialScreenSize = V2 100 100++ type GoatTesterTrackingState = (Text, Int, Int) -- (marker, operations since start of test, operations since last marker) -- TODO include ref to rendered canvas and then you can render it on failure cases!!@@ -42,7 +46,7 @@ instance Default GoatTesterState where def = GoatTesterState {- _goatTesterState_goatState = makeGoatState (V2 100 100) (emptyOwlPFState, emptyControllerMeta)+ _goatTesterState_goatState = makeGoatState goatTesterInitialScreenSize (emptyOwlPFState, emptyControllerMeta) , _goatTesterState_rawOperationCount = 0 , _goatTesterState_marker = "__START__" , _goatTesterState_rawOperationCountSinceLastMarker = 0@@ -99,6 +103,14 @@ verify desc mf = GoatTesterT $ do unGoatTesterT $ putRecord desc mf +verifyBool :: (Monad m) => Text -> Bool -> GoatTesterT m ()+verifyBool desc b = GoatTesterT $ do+ unGoatTesterT $ putRecord desc (if b then Nothing else Just "failed")++verifyEqual :: (Monad m, Show a, Eq a) => Text -> a -> a -> GoatTesterT m ()+verifyEqual desc a b = GoatTesterT $ do+ unGoatTesterT $ putRecord desc (if a == b then Nothing else Just $ "expected: " <> show a <> "\ngot: " <> show b)+ verifyState' :: (Monad m) => Text -> (GoatState -> Maybe Text) -> GoatTesterT m Bool verifyState' desc fn = GoatTesterT $ do gts <- get@@ -112,6 +124,9 @@ --verifyStateFatal :: (GoatState -> Maybe Text) -> GoatTesterT m () --verifyStateFatal = undefined +failWithMessage :: (Monad m) => Text -> GoatTesterT m ()+failWithMessage = putRecord "failed: " . Just+ runGoatTesterT :: (Monad m) => GoatState -> GoatTesterT m a -> m [GoatTesterRecord] runGoatTesterT gs m = do gts <- execStateT (unGoatTesterT m) $ def { _goatTesterState_goatState = gs }@@ -166,6 +181,10 @@ pfs <- getOwlPFState return $ fromJust $ maybeGetMostRecentlyCreatedOwl' pfs +getLayersState :: (Monad m) => GoatTesterT m LayersState+getLayersState = GoatTesterT $ do+ gts <- get+ return $ _goatState_layersState $ _goatTesterState_goatState gts -- operation helpers @@ -276,9 +295,12 @@ pressRedo :: (Monad m) => GoatTesterT m () pressRedo = runEndo $ endoGoatCmdKeyboard (KeyboardData (KeyboardKey_Char 'y') [KeyModifier_Ctrl]) - markSaved :: (Monad m) => GoatTesterT m () markSaved = runEndo $ endoGoatCmdMarkSaved ()++resizeScreen :: (Monad m) => V2 Int -> GoatTesterT m ()+resizeScreen (V2 w h) = runEndo $ endoGoatCmdSetCanvasRegionDim (V2 w h)+ -- verification helpers
+ test/Potato/Flow/Methods/SEltMethodsSpec.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-unused-local-binds #-}++module Potato.Flow.Methods.SEltMethodsSpec(+ spec+) where++import Relude hiding (empty, fromList)++import Test.Hspec++import qualified Data.Map as Map+import Data.Default (def)++import Potato.Flow+++spec :: Spec+spec = do+ let+ testsstyle = def { _superStyle_fill = FillStyle_Simple '@' }+ renderfn sd = _sEltDrawer_renderFn sd emptyOwlTree+ describe "SEltMethod" $ do+ describe "getDrawerFromSEltForTest" $ do+ describe "SBox" $ do+ let+ somesbox1 style = def {+ _sBox_box = LBox 0 (V2 5 5)+ , _sBox_text = def {+ _sBoxText_text = "m ow meow meow"+ }+ , _sBox_boxType = style+ , _sBox_superStyle = testsstyle+ }+ somesbox2 style = def {+ _sBox_box = LBox 0 (V2 1 1)+ , _sBox_boxType = style+ , _sBox_superStyle = testsstyle+ }+ somesbox3 style = def {+ _sBox_box = LBox 0 (V2 10 10)+ , _sBox_text = def {+ _sBoxText_text = "m ow meeuew ee meow hello boop no12 meow whatever"+ , _sBoxText_style = TextStyle TextAlign_Right+ }+ , _sBox_boxType = style+ , _sBox_superStyle = testsstyle+ }+ somesbox4 style = def {+ _sBox_box = LBox 0 (V2 10 10)+ , _sBox_text = def {+ _sBoxText_text = "ｔｈｅｒｅ ａｒｅ ｎｏ ｓｐａｃｅ ｂｅｔｗｅｅｎ ａｄｊａｃｅｎｔ ｃｈａｒａｃｔｅｒｓ"+ , _sBoxText_style = TextStyle TextAlign_Left+ }+ , _sBox_boxType = style+ , _sBox_superStyle = testsstyle+ }+ somesbox5 style = def {+ _sBox_box = LBox 0 (V2 10 5)+ , _sBox_text = def {+ _sBoxText_text = "aoeuaoeu"+ }+ , _sBox_title = SBoxTitle {+ _sBoxTitle_title = Just "boop"+ , _sBoxTitle_align = TextAlign_Right+ }+ , _sBox_boxType = style+ , _sBox_superStyle = testsstyle+ }+ it "SBoxType_NoBoxText" $ do+ let+ sd = getDrawerFromSEltForTest (SEltBox (somesbox1 SBoxType_NoBoxText))+ renderfn sd (V2 100 0) `shouldBe` Nothing+ renderfn sd (V2 (-1) 0) `shouldBe` Nothing+ renderfn sd (V2 0 0) `shouldBe` Just 'm'+ renderfn sd (V2 1 0) `shouldBe` Just ' '+ renderfn sd (V2 2 0) `shouldBe` Just 'o'+ -- TODO it seems EOL space characters are not rendered and this gives the fill char. Maybe this is desired behavior thought?+ --renderfn sd (V2 3 0) `shouldBe` Just ' '+ renderfn sd (V2 1 1) `shouldBe` Just 'e'+ renderfn sd (V2 4 4) `shouldBe` Just '@'+ it "SBoxType_Box" $ do+ let+ sd = getDrawerFromSEltForTest (SEltBox (somesbox2 SBoxType_Box))+ --forM_ (sEltDrawer_renderToLines sd emptyOwlTree) putTextLn+ renderfn sd (V2 0 0) `shouldBe` _superStyle_point def+ it "SBoxType_NoBoxText_alignRight" $ do+ let+ sd = getDrawerFromSEltForTest (SEltBox (somesbox3 SBoxType_NoBoxText))+ --forM_ (sEltDrawer_renderToLines sd emptyOwlTree) putTextLn+ renderfn sd (V2 0 0) `shouldBe` Just '@'+ it "SBoxType_NoBoxText_widechar" $ do+ let+ sd = getDrawerFromSEltForTest (SEltBox (somesbox4 SBoxType_NoBoxText))+ --forM_ (sEltDrawer_renderToLines sd emptyOwlTree) putTextLn+ renderfn sd (V2 0 0) `shouldBe` Just 'ｔ'+ renderfn sd (V2 1 0) `shouldBe` Nothing+ renderfn sd (V2 2 0) `shouldBe` Just 'ｈ'+ renderfn sd (V2 3 0) `shouldBe` Nothing+ it "box label" $ do+ let+ sd = getDrawerFromSEltForTest (SEltBox (somesbox5 SBoxType_BoxText))+ --forM_ (sEltDrawer_renderToLines sd emptyOwlTree) putTextLn+ renderfn sd (V2 0 0) `shouldBe` Just '╔'+ renderfn sd (V2 8 0) `shouldBe` Just 'p'+ describe "STextArea" $ do+ let+ sometextarea = STextArea {+ _sTextArea_box = LBox (V2 1 1) (V2 10 10)+ , _sTextArea_text = Map.fromList [((V2 0 0),'a'),((V2 1 1),'b'),((V2 9 9),'c')]+ , _sTextArea_transparent = False+ }+ it "basic" $ do+ let+ sd = getDrawerFromSEltForTest (SEltTextArea $ sometextarea)+ --forM_ ((sEltDrawer_renderToLines sd) emptyOwlTree sd) putTextLn+ renderfn sd (V2 1 1) `shouldBe` Just 'a'+ renderfn sd (V2 10 10) `shouldBe` Just 'c'+ renderfn sd (V2 100 0) `shouldBe` Nothing
test/Potato/Flow/OwlSpec.hs view
@@ -15,7 +15,7 @@ import Potato.Flow.Deprecated.TestStates import Potato.Flow.Deprecated.State import Potato.Flow.Types-import Potato.Flow.SElts+import Potato.Flow.Serialization.Snake -- | 'owlTree_toSEltTree' may change SEltFolderEnd name and REltId during reconstruction@@ -55,8 +55,8 @@ let sowl1 = owlTree_mustFindSuperOwl owlTree0 2 -- b1 sowl2 = owlTree_mustFindSuperOwl owlTree0 1 -- fstart2- ot1 = owlTree_removeSuperOwl sowl1 owlTree0- ot2 = owlTree_removeSuperOwl sowl2 owlTree0+ ot1 = owlTree_removeSuperOwl False sowl1 owlTree0+ ot2 = owlTree_removeSuperOwl False sowl2 owlTree0 owlTree_owlCount ot1 `shouldBe` 8 owlTree_owlCount ot2 `shouldBe` 4 fst (owlTree_validate ot1) `shouldBe` True
− test/Potato/Flow/SEltMethodsSpec.hs
@@ -1,119 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_GHC -fno-warn-unused-local-binds #-}--module Potato.Flow.SEltMethodsSpec(- spec-) where--import Relude hiding (empty, fromList)--import Test.Hspec--import qualified Data.Map as Map-import Data.Default (def)--import Potato.Flow---spec :: Spec-spec = do- let- testsstyle = def { _superStyle_fill = FillStyle_Simple '@' }- renderfn sd = _sEltDrawer_renderFn sd emptyOwlTree- describe "SEltMethod" $ do- describe "getDrawerFromSEltForTest" $ do- describe "SBox" $ do- let- somesbox1 style = def {- _sBox_box = LBox 0 (V2 5 5)- , _sBox_text = def {- _sBoxText_text = "m ow meow meow"- }- , _sBox_boxType = style- , _sBox_superStyle = testsstyle- }- somesbox2 style = def {- _sBox_box = LBox 0 (V2 1 1)- , _sBox_boxType = style- , _sBox_superStyle = testsstyle- }- somesbox3 style = def {- _sBox_box = LBox 0 (V2 10 10)- , _sBox_text = def {- _sBoxText_text = "m ow meeuew ee meow hello boop no12 meow whatever"- , _sBoxText_style = TextStyle TextAlign_Right- }- , _sBox_boxType = style- , _sBox_superStyle = testsstyle- }- somesbox4 style = def {- _sBox_box = LBox 0 (V2 10 10)- , _sBox_text = def {- _sBoxText_text = "ｔｈｅｒｅ ａｒｅ ｎｏ ｓｐａｃｅ ｂｅｔｗｅｅｎ ａｄｊａｃｅｎｔ ｃｈａｒａｃｔｅｒｓ"- , _sBoxText_style = TextStyle TextAlign_Left- }- , _sBox_boxType = style- , _sBox_superStyle = testsstyle- }- somesbox5 style = def {- _sBox_box = LBox 0 (V2 10 5)- , _sBox_text = def {- _sBoxText_text = "aoeuaoeu"- }- , _sBox_title = SBoxTitle {- _sBoxTitle_title = Just "boop"- , _sBoxTitle_align = TextAlign_Right- }- , _sBox_boxType = style- , _sBox_superStyle = testsstyle- }- it "SBoxType_NoBoxText" $ do- let- sd = getDrawerFromSEltForTest (SEltBox (somesbox1 SBoxType_NoBoxText))- renderfn sd (V2 100 0) `shouldBe` Nothing- renderfn sd (V2 (-1) 0) `shouldBe` Nothing- renderfn sd (V2 0 0) `shouldBe` Just 'm'- renderfn sd (V2 1 0) `shouldBe` Just ' '- renderfn sd (V2 2 0) `shouldBe` Just 'o'- -- TODO it seems EOL space characters are not rendered and this gives the fill char. Maybe this is desired behavior thought?- --renderfn sd (V2 3 0) `shouldBe` Just ' '- renderfn sd (V2 1 1) `shouldBe` Just 'e'- renderfn sd (V2 4 4) `shouldBe` Just '@'- it "SBoxType_Box" $ do- let- sd = getDrawerFromSEltForTest (SEltBox (somesbox2 SBoxType_Box))- --forM_ (sEltDrawer_renderToLines sd emptyOwlTree) putTextLn- renderfn sd (V2 0 0) `shouldBe` _superStyle_point def- it "SBoxType_NoBoxText_alignRight" $ do- let- sd = getDrawerFromSEltForTest (SEltBox (somesbox3 SBoxType_NoBoxText))- --forM_ (sEltDrawer_renderToLines sd emptyOwlTree) putTextLn- renderfn sd (V2 0 0) `shouldBe` Just '@'- it "SBoxType_NoBoxText_widechar" $ do- let- sd = getDrawerFromSEltForTest (SEltBox (somesbox4 SBoxType_NoBoxText))- --forM_ (sEltDrawer_renderToLines sd emptyOwlTree) putTextLn- renderfn sd (V2 0 0) `shouldBe` Just 'ｔ'- renderfn sd (V2 1 0) `shouldBe` Nothing- renderfn sd (V2 2 0) `shouldBe` Just 'ｈ'- renderfn sd (V2 3 0) `shouldBe` Nothing- it "box label" $ do- let- sd = getDrawerFromSEltForTest (SEltBox (somesbox5 SBoxType_BoxText))- --forM_ (sEltDrawer_renderToLines sd emptyOwlTree) putTextLn- renderfn sd (V2 0 0) `shouldBe` Just '╔'- renderfn sd (V2 8 0) `shouldBe` Just 'p'- describe "STextArea" $ do- let- sometextarea = STextArea {- _sTextArea_box = LBox (V2 1 1) (V2 10 10)- , _sTextArea_text = Map.fromList [((V2 0 0),'a'),((V2 1 1),'b'),((V2 9 9),'c')]- , _sTextArea_transparent = False- }- it "basic" $ do- let- sd = getDrawerFromSEltForTest (SEltTextArea $ sometextarea)- --forM_ ((sEltDrawer_renderToLines sd) emptyOwlTree sd) putTextLn- renderfn sd (V2 1 1) `shouldBe` Just 'a'- renderfn sd (V2 10 10) `shouldBe` Just 'c'- renderfn sd (V2 100 0) `shouldBe` Nothing
tinytools.cabal view
@@ -1,17 +1,14 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.------ see: https://github.com/sol/hpack- name: tinytools-version: 0.1.0.4+version: 0.1.0.5 description: tinytools is a mono-space unicode diagram editor homepage: https://github.com/minimapletinytools/tinytools#readme bug-reports: https://github.com/minimapletinytools/tinytools/issues author: minimaple maintainer: minimapletinytools@gmail.com-synopsis: tinytools is a mono-space unicode diagram editor+synopsis: tinytools is a monospace unicode diagram editor+category: User Interfaces copyright: 2023 minimaple (Peter Lu) license: BSD3 license-file: LICENSE@@ -72,9 +69,10 @@ Potato.Flow.Reflex.GoatWidget Potato.Flow.Render Potato.Flow.RenderCache- Potato.Flow.SEltMethods- Potato.Flow.SElts+ Potato.Flow.Methods.SEltMethods Potato.Flow.Serialization.Snake+ Potato.Flow.Serialization.SnakeWrangler+ Potato.Flow.Serialization.Versions.V1.SElts Potato.Flow.TestStates Potato.Flow.Types hs-source-dirs:@@ -143,12 +141,11 @@ , pretty-simple , random-shuffle , ref-tf- , reflex >= 0.8 && <1+ , reflex >= 0.9.2 && < 1 , reflex-potatoes >=0.1- , reflex-test-host >=0.1.2+ , reflex-test-host >=0.1.2.3 , relude , semialign- , template-haskell , text , text-icu , these@@ -190,7 +187,7 @@ Potato.Flow.Methods.LineDrawerSpec Potato.Flow.OwlSpec Potato.Flow.RenderSpec- Potato.Flow.SEltMethodsSpec+ Potato.Flow.Methods.SEltMethodsSpec Paths_tinytools hs-source-dirs: test@@ -260,12 +257,11 @@ , pretty-simple , random-shuffle , ref-tf- , reflex >= 0.8 && <1+ , reflex >= 0.9.2 && < 1 , reflex-potatoes >=0.1- , reflex-test-host >=0.1.2+ , reflex-test-host >=0.1.2.3 , relude , semialign- , template-haskell , text , text-icu , these