{-# 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)
import Brick.Forms ((@@=), checkboxField, editField, formState, newForm, Form)
import Gen
type Binder = String
data NoCustomEvent
data Name
= LeftViewport | RightViewport
| FormField String
deriving (Eq, Ord, Show)
data Trans
= Step Int
| Name String
| Search String
deriving (Eq, Ord, Show)
data OptionsUI term = OptionsUI
{ _opts :: Options term
, _trans :: Trans
}
makeLenses ''OptionsUI
data VizState term = VizState
{ _steps :: History term (Ctx term)
, _prevState :: Maybe (VizState term)
, _curExpr :: term
, _curStep :: 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 trans
(FormField "Trans")
(Just 1)
(pack . concat . tail . words . show)
(readTrans . unpack . head)
(txt . head)
id
]
where
readTrans x | Just n <- readMaybe x :: Maybe Int = Just $ Step n
| '%':'s':' ':s <- x = Just $ Search s
| '%':'t':' ':s <- x = Just $ Name 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
, _trans = 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 }
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)
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
}
unstep st = case st^.prevState of
Nothing -> st
Just prev -> prev
reset first@(VizState _ Nothing _ _) = first
reset (VizState _ (Just prev) _ _) = reset prev
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
=> (VizState term -> VizState term)
-> String -> VizState term -> VizState term
nextTrans f (map toLower -> s) v0 = go (f v0)
where
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 (f v)