module Graphics.UI.LUI.Widgets.TextEdit
(Mutable(..)
,aMutableCursor
,aMutableText
,Cursor
,defaultCursorWidth
,new
,DelegatedMutable
,aDelegatedMutableCursor
,aDelegatedMutableText
,delegatedMutable
,newDelegatedWith
,newDelegated
)
where
import qualified Graphics.UI.LUI.Widget as Widget
import qualified Graphics.UI.LUI.Draw as Draw
import qualified Graphics.UI.LUI.Widgets.FocusDelegator as FocusDelegator
import Graphics.UI.LUI.Widget(WidgetFuncs(..))
import Graphics.UI.LUI.Func(result)
import Graphics.UI.LUI.List(isSorted)
import Graphics.UI.LUI.Accessor(Accessor, accessor, (^.), (^>), write)
import qualified Graphics.UI.SDL as SDL
import qualified Graphics.UI.HaskGame.Key as Key
import qualified Graphics.UI.HaskGame.Keys as Keys
import Graphics.UI.HaskGame.Key(asKeyGroup, noMods, ctrl)
import Graphics.UI.HaskGame.Vector2(Vector2(..))
import Graphics.UI.HaskGame.Color(Color)
import Graphics.UI.HaskGame.Font(Font)
import qualified Data.Map as Map
import Data.Map((!))
import Control.Arrow(first, second)
type Cursor = Int
defaultCursorWidth :: Int
defaultCursorWidth = 2
data Mutable = Mutable
{
mutableText :: String
, mutableCursor :: Cursor
}
aMutableCursor :: Accessor Mutable Cursor
aMutableCursor = accessor mutableCursor (\n x -> x{mutableCursor=n})
aMutableText :: Accessor Mutable String
aMutableText = accessor mutableText (\n x -> x{mutableText=n})
insert :: Mutable -> Key.ModKey -> Mutable
insert (Mutable oldText oldCursor) key =
let iText = Keys.keysUnicode!key
(preOldText, postOldText) = splitAt oldCursor oldText
newText = concat [preOldText, iText, postOldText]
newCursor = oldCursor + length iText
in Mutable newText newCursor
delBackward :: Int -> Mutable -> Mutable
delBackward count (Mutable oldText oldCursor) =
let (oldPreText, oldPostText) = splitAt oldCursor oldText
newPreText = take (length oldPreText count) oldPreText
newText = newPreText ++ oldPostText
newCursor = length newPreText
in Mutable newText newCursor
delForward :: Int -> Mutable -> Mutable
delForward count (Mutable oldText oldCursor) =
let (oldPreText, oldPostText) = splitAt oldCursor oldText
newPostText = drop count oldPostText
newText = oldPreText ++ newPostText
in Mutable newText oldCursor
moveCursor :: (Cursor -> Cursor) -> Mutable -> Mutable
moveCursor cursorFunc (Mutable text oldCursor) =
let newCursor = cursorFunc oldCursor
in Mutable text $ if isSorted [0, newCursor, length text]
then newCursor
else oldCursor
goHome :: Mutable -> Mutable
goHome (Mutable text _) = Mutable text 0
goEnd :: Mutable -> Mutable
goEnd (Mutable text _) = Mutable text (length text)
actBackspace, actDelete, actMovePrev, actMoveNext, actHome, actEnd ::
(String, Mutable -> Mutable)
actBackspace = ("Delete previous character", delBackward 1)
actDelete = ("Delete next character", delForward 1)
actMovePrev = ("Move to previous character", moveCursor (subtract 1))
actMoveNext = ("Move to next character", moveCursor (+1))
actHome = ("Move to beginning of text", goHome)
actEnd = ("Move to end of text", goEnd)
keysMap :: Mutable -> Widget.ActionHandlers Mutable
keysMap mutable = Map.fromList . (map . first) ((,) Widget.KeyDown) $
(Keys.printableGroup, ("Insert", insert mutable)) :
(map . second . second) (const . ($mutable)) (normalActions mutable ++ ctrlActions mutable)
cond :: Bool -> [a] -> [a]
cond p i = if p then i else []
normalActions :: Mutable -> [(Key.KeyGroup, (String, Mutable -> Mutable))]
normalActions mutable =
let cursor = mutableCursor mutable
text = mutableText mutable
in (map . first) (asKeyGroup noMods) . concat $
[cond (cursor > 0)
[(SDL.SDLK_BACKSPACE, actBackspace)
,(SDL.SDLK_LEFT, actMovePrev)
,(SDL.SDLK_HOME, actHome)]
,cond (cursor < length text)
[(SDL.SDLK_DELETE, actDelete)
,(SDL.SDLK_RIGHT, actMoveNext)
,(SDL.SDLK_END, actEnd)]
]
ctrlActions :: Mutable -> [(Key.KeyGroup, (String, Mutable -> Mutable))]
ctrlActions mutable =
let cursor = mutableCursor mutable
text = mutableText mutable
in (map . first) (asKeyGroup ctrl) . concat $
[cond (cursor > 0)
[(SDL.SDLK_h, actBackspace)
,(SDL.SDLK_a, actHome)]
,cond (cursor < length text)
[(SDL.SDLK_d, actDelete)
,(SDL.SDLK_e, actEnd)]
]
new :: Int -> Color -> Color -> Font -> Color -> Widget.New model Mutable
new cursorWidth bgColor cursorColor font textColor acc model =
let mutable@(Mutable text cursor) = model ^. acc
in WidgetFuncs
{
widgetDraw = \drawInfo -> do
if Widget.diHasFocus drawInfo
then do
textSize <- Draw.computeToDraw . Draw.textSize font $ text
Vector2 w h <- Draw.computeToDraw . Draw.textSize font $ take cursor text
let cursorSize = Vector2 cursorWidth h
cursorPos = Vector2 w 0
Draw.rect bgColor textSize
Draw.text textColor font text
Draw.move cursorPos $ Draw.rect cursorColor cursorSize
return textSize
else
Draw.text textColor font text
, widgetSize = \_ -> Draw.textSize font text
, widgetGetKeymap =
let applyToModel newMutable = acc `write` newMutable $ model
in Just $
(Map.map . second . result) applyToModel $ keysMap mutable
}
type DelegatedMutable = FocusDelegator.DelegatedMutable Mutable
aDelegatedMutableCursor :: Accessor DelegatedMutable Cursor
aDelegatedMutableCursor = FocusDelegator.aDelegatedMutable ^> aMutableCursor
aDelegatedMutableText :: Accessor DelegatedMutable String
aDelegatedMutableText = FocusDelegator.aDelegatedMutable ^> aMutableText
delegatedMutable :: Bool -> String -> Cursor -> DelegatedMutable
delegatedMutable startInside text cursor =
(FocusDelegator.Mutable startInside, Mutable text cursor)
newDelegatedWith :: Color -> Int -> Color -> Color -> Font -> Color ->
Widget.New model DelegatedMutable
newDelegatedWith focusColor cursorWidth bgColor cursorColor font textColor acc =
let textEdit = new cursorWidth bgColor cursorColor font textColor $
acc ^> FocusDelegator.aDelegatedMutable
in FocusDelegator.newWith focusColor "Start editing" "Stop editing" textEdit $
acc ^> FocusDelegator.aFocusDelegatorMutable
newDelegated :: Color -> Color -> Font -> Color ->
Widget.New model DelegatedMutable
newDelegated = newDelegatedWith FocusDelegator.defaultFocusColor defaultCursorWidth