{-# LANGUAGE OverloadedStrings, TemplateHaskell, Rank2Types #-}
module Types where
import Data.Char (toLower)
import Data.List (delete, elemIndex, find, isInfixOf, groupBy, nub, sortOn)
import Data.Maybe (fromJust)
import Data.Map ((!), Map, insert, fromList)
import Text.Read (readMaybe)
import Data.Text (pack, unpack)
import Lens.Micro ((^.), (&), (.~), (%~), Lens', lens)
import Lens.Micro.TH (makeLenses)
import Brick ((<+>), str, txt, CursorLocation)
import Brick.Forms ((@@=), checkboxField, editField, formState, newForm, Form)
import Gen
type Binder = String
data NoCustomEvent
data Name
= LeftViewport | RightViewport
| FormField String
| SearchResult Int
| Other
deriving (Eq, Ord, Show)
type Cursor = CursorLocation Name
data Command
= Step Int
| Trans String
| Search String
deriving (Eq, Ord, Show)
data OptionsUI term = OptionsUI
{ _opts :: Options term
, _com :: Command
}
makeLenses ''OptionsUI
data VizState term = VizState
{ _steps :: History term (Ctx term)
, _prevState :: Maybe (VizState term)
, _curExpr :: term
, _curStep :: Int
, _curOccur :: Int
, _leftN :: Int
, _rightN :: Int
}
makeLenses ''VizState
data VizStates term = VizStates
{ _binders :: [Binder]
, _curBinder :: Binder
, _states :: Map Binder (VizState term)
, _form :: Form (OptionsUI term) NoCustomEvent Name
, _showBot :: Bool
, _width :: Int
, _height :: Int
, _scroll :: Bool
}
makeLenses ''VizStates
mkForm :: forall term. Diff term
=> OptionsUI term
-> Form (OptionsUI term) NoCustomEvent Name
mkForm = newForm $
map (\(f, g, s) -> checkboxField (opts . lens f g) (FormField s) (pack s))
(flagFields @term)
++
[ (str "move to " <+>) @@=
editField com
(FormField "Command")
(Just 1)
(pack . concat . tail . words . show)
(readCom . unpack . head)
(txt . head)
id
]
where
readCom x | Just n <- readMaybe x :: Maybe Int = Just $ Step n
| '%':'s':' ':s <- x = Just $ Search s
| '%':'t':' ':s <- x = Just $ Trans s
| otherwise = Nothing
createVizStates :: forall term. Diff term
=> History term (Ctx term)
-> VizStates term
createVizStates hist = VizStates
{ _binders = top : (delete top $ nub bndrs)
, _curBinder = top
, _states = fromList
$ map (\h -> (head h ^. bndrS, initialState h))
$ groupBy (\ x y -> x^.bndrS == y^.bndrS)
$ sortOn _bndrS hist
, _form = mkForm @term (OptionsUI { _opts = initOptions @term
, _com = Step 1 })
, _showBot = False
, _width = 0
, _height = 0
, _scroll = True
}
where bndrs = _bndrS <$> hist
top = fromJust $ find (topEntity @term `isInfixOf`) bndrs
initialState :: Diff term => History term (Ctx term) -> VizState term
initialState hist = VizState { _steps = hist
, _prevState = Nothing
, _curExpr = initialExpr hist
, _curStep = 1
, _curOccur = 0
, _leftN = 0
, _rightN = 0 }
currentStepName :: VizState term -> String
currentStepName v =
case v^.steps of
[] -> "THE END"
(st:_) -> st^.name
getStep :: VizStates term
-> Binder
-> (Int , Int , String )
getStep vs bndr = (cur, cur + length (v^.steps), currentStepName v)
where v = (vs^.states) ! bndr
cur = v^.curStep
getCurrentState :: VizStates term -> VizState term
getCurrentState vs = (vs^.states) ! (vs^.curBinder)
getSearchString :: Diff term => VizStates term -> String
getSearchString vs = case vs^.formData.com of { Search s -> s; _ -> "" }
formData :: forall term
. Diff term
=> Lens' (VizStates term) (OptionsUI term)
formData f vs = (\fm' -> vs {_form = mkForm @term fm'}) <$> f (formState $ _form vs)
updateState :: VizStates term -> VizState term -> VizStates term
updateState vs v = vs & states .~ insert (vs^.curBinder) v (vs^.states)
getCodeWidth :: VizStates term -> Int
getCodeWidth vs = vs^.width `div` 2
stepBinder, unstepBinder :: VizStates term -> VizStates term
stepBinder vs = vs & curBinder .~ findNext (vs^.curBinder) (vs^.binders)
where findNext :: Eq a => a -> [a] -> a
findNext x xs
| Just i <- x `elemIndex` xs, i < (length xs - 1) = xs !! (i + 1)
| otherwise = x
unstepBinder vs = vs & curBinder .~ findPrev (vs^.curBinder) (vs^.binders)
where findPrev :: Eq a => a -> [a] -> a
findPrev x xs
| Just i <- x `elemIndex` xs, i > 0 = xs !! (i - 1)
| otherwise = x
step, unstep, reset :: Diff term => VizState term -> VizState term
step prev@(VizState [] _ _ _ _ _ _) = prev
step prev@(VizState (t:ts) _ curE curS _ _ _) =
VizState { _steps = ts
, _prevState = Just prev
, _curExpr = patch curE (t^.ctx) (t^.after)
, _curStep = curS + 1
, _curOccur = 0
, _leftN = 0
, _rightN = 0 }
unstep st = case st^.prevState of
Nothing -> st
Just prev -> prev
reset first@(VizState _ Nothing _ _ _ _ _) = first
reset (VizState _ (Just prev) _ _ _ _ _) = reset prev
data Direction = Forward | Backward
moveTo :: Diff term => Int -> VizState term -> VizState term
moveTo n v = if (v^.curStep) == (v'^.curStep) then v else moveTo n v'
where v' = case n `compare` (v^.curStep) of { EQ -> v
; LT -> unstep v
; GT -> step v }
nextTrans :: Diff term => Direction -> String -> VizState term -> VizState term
nextTrans dir (map toLower -> s) v0 = go (next v0)
where
next = case dir of { Forward -> step ; Backward -> unstep }
startStep = v0^.curStep
go v
| v^.curStep == startStep = v
| [] <- v^.steps = go (reset v)
| (st:_) <- v^.steps
, s `isInfixOf` (toLower <$> st^.name) = v
| otherwise = go (next v)
nextOccur :: Diff term => Direction -> VizState term -> VizState term
nextOccur Forward v = v & curOccur %~ (+ 1)
nextOccur Backward v = v & curOccur %~ back
where back 0 = max 0 (v^.leftN + v^.rightN - 1)
back i = i - 1