module TextArea where
import Lexer
import Preprocessor as Pre
import InterfaceDT as IDT
import Graphics.UI.Gtk
import Data.Map as Map
import Control.Monad.Trans (liftIO)
import qualified Control.Exception as Exc
import System.IO
import Data.IORef
import Data.Maybe
import Data.Either
data EntryMode = LeftToRight | UpToDown | Smart deriving (Eq)
--textArea is a pointer to:
data TextArea = TextArea
Layout
(IORef (Int,Int)) --pointer to current selected entry
(IORef (Map.Map (Int,Int) Entry)) {-pointer to hashmap of entrys with
(x,y) coords as key starting by (0,0)-}
(IORef (Int,Int)) --pointer to the size of the textArea
--returns the layout
getLayout (TextArea layout _ _ _) = layout
--returns a point to the current selected entry
getPointerToCurrentInFocus (TextArea _ current _ _) = current
--returns a pointer to hashmap of entrys
getPointerToEntryMap (TextArea _ _ map _) = map
--returns a pointer to the textArea size
getPointerToSize (TextArea _ _ _ size) = size
--returns the grid2D from a IDT.IPL grid2D
getGrid2dFromPreProc2Lexer(IDT.IPL grid2D) = grid2D
-- creates a new textArea
textAreaNew :: Layout -- the layout which entrys would be placed on
-> Int --number of entrys in width
-> Int --numer of entry in height
-> IO TextArea --A textArea ready for writing
textAreaNew layout x y = do
currentInFocus <- newIORef (0,0)
hashMap <- newIORef Map.empty
size <- newIORef (0,0)
let area = TextArea layout currentInFocus hashMap size
createTextArea area x y
return area
--Subfunction of textAreaNew which invokes the entry-creation
createTextArea :: TextArea --the empty textArea
-> Int --number of entrys in width
-> Int --numer of entry in height
-> IO()
createTextArea area@(TextArea layout current hmap size) x y = do
createTextAreaH area 0 (pred x) 0 (pred y)
writeIORef size (x-1,y-1)
return ()
--Subfunction of createTextArea. This fct creates the lines of textArea
createTextAreaH :: TextArea
-> Int--current x coord in textArea
-> Int--max x coord in textArea
-> Int--current y coord in textArea
-> Int--max y coord in textArea
-> IO()
createTextAreaH area@(TextArea _ _ _ size) xnr xnrS ynr ynrS = do
(maxX,maxY) <- readIORef size
if xnr == xnrS && ynr == ynrS
then entryInsert area xnrS xnrS
else if xnr == xnrS && ynr < ynrS
then do
entryInsert area xnr ynr--inserts the textEntry
createTextAreaH area 0 xnrS (succ ynr) ynrS
else do
entryInsert area xnr ynr--inserts the textEntry
createTextAreaH area (succ xnr) xnrS ynr ynrS
--function to react on a "Return" keypress
handleReturn area@(TextArea layout current hMap size)x y = do
hmap <- readIORef hMap
let nextEntry = Map.lookup (0,y+1) hmap
if isNothing nextEntry
then do
(xm,ym) <- readIORef size
expandYTextArea area xm ym
hmap <- readIORef hMap
let nEntry = fromJust $ Map.lookup (0,y+1) hmap
widgetGrabFocus nEntry
return True
else do
let nEntry = fromJust nextEntry
widgetGrabFocus nEntry
return True
--function to react on a "Left-Arrow" keypress
handleLeft area@(TextArea layout current hMap size)x y = do
hmap <- readIORef hMap
let prevEntry = Map.lookup (x-1,y) hmap
if isJust prevEntry
then do
widgetGrabFocus (fromJust prevEntry)
return True
else do
(xm,ym) <- readIORef size
if y>0
then do
widgetGrabFocus $ fromJust $ Map.lookup (xm, y-1) hmap
return True
else return False
--function to react on a "Right-Arrow" keypress
handleRight area@(TextArea layout current hMap size)x y = do
hmap <- readIORef hMap
let nextEntry = Map.lookup (x+1,y) hmap
if isJust nextEntry
then do
widgetGrabFocus $ fromJust nextEntry
return True
else do
(xm,ym) <- readIORef size
if y<ym
then do
widgetGrabFocus $ fromJust $ Map.lookup (0, y+1) hmap
return True
else return False
--function to react on a "Up-Arrow" keypress
handleUp area@(TextArea layout current hMap size) x y = do
hmap <- readIORef hMap
let nextEntry = Map.lookup (x,y-1) hmap
if isJust nextEntry
then do
widgetGrabFocus $ fromJust nextEntry
return True
else return False
--function to react on a "Down-Arrow" keypress
handleDown area@(TextArea layout current hMap size) x y = do
hmap <- readIORef hMap
let nextEntry = Map.lookup (x,y+1) hmap
if isJust nextEntry
then do
widgetGrabFocus $ fromJust nextEntry
return True
else return False
--function to react on a "Tab" keypress
handleTab area@(TextArea layout current hMap size)x y = do
hmap <- readIORef hMap
let nextEntry = Map.lookup (x+4,y) hmap
if isNothing nextEntry
then do
(xm,ym) <- readIORef size
expandXTextAreaN area xm ym 4
hmap <- readIORef hMap
let nEntry = fromJust $ Map.lookup (x+4,y) hmap
widgetGrabFocus nEntry
return True
else do
let nEntry = fromJust nextEntry
widgetGrabFocus nEntry
return True
--function to react on a "Backspace" keypress
handleBackspace area@(TextArea layout current hMap size) entry x y = do
hmap <- readIORef hMap
let prevEntry = Map.lookup (x-1,y) hmap
thisChar <- entryGetText entry
if thisChar /= ""
then do
set entry [entryText := ""]
return False
else
if isJust prevEntry
then do
entrySetText (fromJust prevEntry) ""
widgetGrabFocus (fromJust prevEntry)
return True
else do
(xm,ym) <- readIORef size
if y>0
then do
widgetGrabFocus $ fromJust $ Map.lookup (xm, y-1) hmap
return True
else return False
--Inserts a new entry to the textArea and sets up its keypressHandler
entryInsert :: TextArea
-> Int --x coord to insert
-> Int --y coord to insert
-> IO()
entryInsert area@(TextArea layout current hMap size) x y = do
--creation and config and insert
entry <- entryNew
set entry [entryWidthChars := 1, entryText := " "]
entrySetMaxLength entry 1
entrySetHasFrame entry False
layoutPut layout entry (x*12) (18*y+20)
hamp <- readIORef hMap
let hMapN = Map.insert (x,y) entry hamp
writeIORef hMap hMapN
--Handler setup
entry `on` focusInEvent $ tryEvent $ liftIO $ writeIORef current (x,y)
--KeyEventHandler gets a anonymus function
on entry keyPressEvent $ do
key <- eventKeyName
val <- eventKeyVal
liftIO $ do
--Just keyhandling and expanding the entry if full
if isJust (keyToChar val)
then do
set entry [entryText := (
if isNothing (keyToChar val)
then ""
else [fromJust $ keyToChar val])]
hmap <- readIORef hMap
let nextEntry = Map.lookup (x+1,y) hmap
if isNothing nextEntry
then do
(xm,ym) <- readIORef size
expandXTextArea area xm ym
hmap <- readIORef hMap
let nEntry = fromJust $ Map.lookup (x+1,y) hmap
widgetGrabFocus nEntry
return True
else do
let nEntry = fromJust nextEntry
widgetGrabFocus nEntry
return True
else case key of
"Return" -> handleReturn area x y
"Left" -> handleLeft area x y
"Right" -> handleRight area x y
"Tab" -> handleTab area x y
"BackSpace" -> handleBackspace area entry x y
"Up" -> handleUp area x y
"Down" -> handleDown area x y
_ -> return False
--Syntaxhighlighting starts here
syntaxHighlighting area
return True
return ()
--Handler to catch errors from Preprocessor.hs
handler :: Exc.ErrorCall -> IO ()
handler _ = putStrLn "No main function"
syntaxHighlighting area@(TextArea layout current hMap size) = do
(code,indexes) <- serializeIt area (0,0) ("",[])
Exc.catch (do
let grid2D = getGrid2dFromPreProc2Lexer $ Pre.process (IIP code)
(xm,ym) <- readIORef size
paintItRed area 0 0 xm ym
changeColorOfCurrentEntry area (Color 65535 0 0)
--print"new Lexerturn"
highlightFcts area grid2D indexes
return ()) handler
-- this is needed to clear the textArea
clearTextArea area = do
hmap <- readIORef $ getPointerToEntryMap area
let list = toList hmap
mapM_ (\(_,entry) -> set entry [entryText := ""]) list
return ()
-- maps string to textArea content
deserializeTextArea area string = do
clearTextArea area
expandTextAreaTo area newX newY
readStringListInEntryMap (getPointerToEntryMap area) lined (0,0)
where newX = maximum $ Prelude.map length lined
newY = length lined
lined = lines string
-- help function for deserialization
readStringListInEntryMap _ [] _ = return ()
readStringListInEntryMap hmap (e:es) (x,y) = do
readStringInEntryMap hmap e (0,y)
readStringListInEntryMap hmap es (0,(y+1));
-- help function for deserialization
readStringInEntryMap _ [] _ = return ()
readStringInEntryMap hmap (s:ss) (x,y) = do
entryMap <- readIORef hmap
let entry = fromJust $ Map.lookup (x,y) entryMap
set entry [entryText := [s]]
readStringInEntryMap hmap ss (succ x,y)
-- this is needed to expand the textArea to x y
expandTextAreaTo area newX newY = do
let sizePtr = getPointerToSize area
(x,y) <- readIORef sizePtr
let xDelta = newX-x
let yDelta = newY-y
expandXTextAreaN area x y xDelta
expandYTextAreaN area x y yDelta
--this is needed to expand the textArea in y n times(#line times)
expandYTextAreaN area oldX oldY n
| n <= 0 = return ()
| otherwise = do
expandYTextArea area oldX oldY
expandYTextAreaN area oldX (succ oldY) (n-1)
--this is needed to expand the textArea in x n times(#line times)
expandXTextAreaN area oldX oldY n
| n == 0 = return ()
| otherwise = do
expandXTextArea area oldX oldY
expandXTextAreaN area (succ oldX) oldY (n-1)
--Subfunction of expandXTextAreaN
expandXTextArea area@(TextArea layout current hMap size) oldX oldY= do
expandXTextAreaH area oldX oldY
(xmax,ymax) <- readIORef size
writeIORef size (succ xmax,ymax)
--insert the new entrys at the end of a line
expandXTextAreaH area@(TextArea _ _ hMap _) oldX oldY =
if oldY == 0
then do
entryInsert area (succ oldX) 0
hmap <- readIORef hMap
let newEntry = fromJust $ Map.lookup (succ oldX,oldY) hmap
widgetShow newEntry
else do
entryInsert area (succ oldX) oldY
hmap <- readIORef hMap
let newEntry = fromJust $ Map.lookup (succ oldX,oldY) hmap
widgetShow newEntry
expandXTextAreaH area oldX (pred oldY)
--this is needed to expand the textArea in y (newline)
expandYTextArea area@(TextArea layout current hMap size) oldX oldY= do
expandYTextAreaH area oldX oldY
(xmax,ymax) <- readIORef size
writeIORef size (xmax,succ ymax)
--Insert a new line
expandYTextAreaH area@(TextArea _ _ hMap _) oldX oldY =
if oldX == 0
then do
entryInsert area 0 (succ oldY)
hmap <- readIORef hMap
let newEntry = fromJust $ Map.lookup (oldX,succ oldY) hmap
widgetShow newEntry
else do
entryInsert area oldX (succ oldY)
hmap <- readIORef hMap
let newEntry = fromJust $ Map.lookup (oldX,succ oldY) hmap
widgetShow newEntry
expandYTextAreaH area (pred oldX) oldY
--This overwrites the entry text with "" at (x,y)
clearEntryByCoord :: TextArea
-> (Int,Int)--coord
-> IO()
clearEntryByCoord (TextArea _ _ hMap _) (x,y) = do
hashMap <- readIORef hMap
let mayEntry = Map.lookup (x,y) hashMap
if isJust mayEntry
then do
let entry = fromJust mayEntry
set entry [entryText := ""]
else return ()
--This overwrites the current entry text with ""
clearCurrentEntry :: TextArea -> IO()
clearCurrentEntry (TextArea _ current hMap _) = do
currentCoord <- readIORef current
hashMap <- readIORef hMap
let currentEntry = fromJust $ Map.lookup currentCoord hashMap
set currentEntry [entryText := ""]
--changes the foreground color of the entry at (x,y) in textArea
changeColorOfEntryByCoord :: TextArea
-> (Int,Int)--coord
-> Color--r g b range from 0 (low -)to 65535 (highest intensity)
-> IO()
changeColorOfEntryByCoord (TextArea _ _ hMap _) (x,y) color = do
hashMap <- readIORef hMap
let mayEntry = Map.lookup (x,y) hashMap
if isJust mayEntry
then do
let entry = fromJust mayEntry
widgetModifyText entry StateNormal color
else return ()
--changes the foreground color of the current entry in textArea
changeColorOfCurrentEntry :: TextArea
-> Color--r g b range from 0 (low -)to 65535 (highest intensity)
-> IO()
changeColorOfCurrentEntry (TextArea _ current hMap _) color = do
currentCoord <- readIORef current
hashMap <- readIORef hMap
let currentEntry = fromJust $ Map.lookup currentCoord hashMap
widgetModifyText currentEntry StateNormal color
-- colors all entry red in a rect from x,y to xMax,yMax
-- This function is needed to recolor after editing
paintItRed :: TextArea
-> Int-- x coord start
-> Int--y coord str
-> Int--x coord end
-> Int--y coord end
-> IO()
paintItRed textArea x y xMax yMax= do
map <- readIORef $ getPointerToEntryMap textArea
let entry = Map.lookup (x,y) map
case entry of
Nothing -> return ()
_ ->
if x == (xMax-1) && y == (yMax-1)
then do
widgetModifyText (fromJust entry) StateNormal red
return ()
else
if x == (xMax-1)
then do
widgetModifyText (fromJust entry) StateNormal red
paintItRed textArea 0 (y+1) xMax yMax
else do
widgetModifyText (fromJust entry) StateNormal red
paintItRed textArea (x+1) y xMax yMax
return ()
where red = Color 65535 0 0
-- highlight all rail-functions
highlightFcts :: TextArea
-> [Grid2D]-- List of funtions in line-representation
-> [Int]-- start indexes of function(y coord of textArea)
-> IO IP
highlightFcts area [] _ = return crash
highlightFcts area _ [] = return crash
highlightFcts area (x:xs) (y:ys) = do
highlight area x start y
highlightFcts area xs ys
{- to do different colors
main highlighting process which highlights a single rail-function.
Colors:
comments : red
$ : orange
rails : black
built in function blue
constans green
-}
highlight :: TextArea
-> Grid2D
-> IP
-> Int
-> IO IP
highlight _ [] _ _ = return crash
highlight textArea grid2D ip yOffset = do
print "step"
print $ show ip
case ip == crash of
True -> return ip
_ -> do
(lex, parseIP)<- return $ parse grid2D ip
print "parsedIp"
print (show parseIP)
case lex of
Just NOP -> changeColorOfEntryByCoord textArea (xC,yC) blue
Just Boom -> changeColorOfEntryByCoord textArea (xC,yC) blue
Just EOF -> changeColorOfEntryByCoord textArea (xC,yC) blue
Just Input -> changeColorOfEntryByCoord textArea (xC,yC) blue
Just Output -> changeColorOfEntryByCoord textArea (xC,yC) blue
Just IDT.Underflow -> changeColorOfEntryByCoord textArea (xC,yC) blue
Just RType -> changeColorOfEntryByCoord textArea (xC,yC) blue
Just (Constant str) -> do
if [(current grid2D parseIP)] == "]" ||
[(current grid2D parseIP)] == "["
then do
colorMoves textArea grid2D (length str+2)
(turnaround parseIP) green
highlight textArea grid2D (step grid2D parseIP)yOffset
else do
changeColorOfEntryByCoord textArea (xC,yC) green
highlight textArea grid2D (step grid2D parseIP)yOffset
return ()
Just (Push str)-> do
colorMoves textArea grid2D (length str+2)
(turnaround parseIP) blue
highlight textArea grid2D (step grid2D parseIP)yOffset
return ()
Just (Pop str) -> do
colorMoves textArea grid2D (length str+4)
(turnaround parseIP) blue
highlight textArea grid2D (step grid2D parseIP)yOffset
return ()
Just (Call str) -> do
colorMoves textArea grid2D (length str+2)
(turnaround parseIP) blue
highlight textArea grid2D (step grid2D parseIP)yOffset
return ()
Just Add1 -> changeColorOfEntryByCoord textArea (xC,yC) blue
Just Divide -> changeColorOfEntryByCoord textArea (xC,yC) blue
Just Multiply -> changeColorOfEntryByCoord textArea (xC,yC) blue
Just Subtract -> changeColorOfEntryByCoord textArea (xC,yC) blue
Just Remainder -> changeColorOfEntryByCoord textArea (xC,yC) blue
Just Cut -> changeColorOfEntryByCoord textArea (xC,yC) blue
Just Append -> changeColorOfEntryByCoord textArea (xC,yC) blue
Just Size -> changeColorOfEntryByCoord textArea (xC,yC) blue
Just Nil -> changeColorOfEntryByCoord textArea (xC,yC) blue
Just Cons -> changeColorOfEntryByCoord textArea (xC,yC) blue
Just Breakup -> changeColorOfEntryByCoord textArea (xC,yC) blue
Just Greater -> changeColorOfEntryByCoord textArea (xC,yC) blue
Just Equal -> changeColorOfEntryByCoord textArea (xC,yC) blue
Just Start -> changeColorOfEntryByCoord textArea (xC,yC) gold
Just Finish -> changeColorOfEntryByCoord textArea (xC,yC) gold
Just (Junction _) -> do
changeColorOfEntryByCoord textArea (xC,yC) gold
(falseIP,trueIP) <- return $ junctionturns grid2D parseIP
print "junction"
print(show falseIP)
print(show trueIP)
highlight textArea grid2D falseIP yOffset
highlight textArea grid2D trueIP yOffset
return ()
Nothing -> changeColorOfEntryByCoord textArea (xC,yC) black
case lex of
Just (Junction 0) -> return crash
Just (Push _) -> return crash
Just (Pop _) -> return crash
Just (Call _) -> return crash
Just (Constant _) -> return crash
_ -> do
let nexIP = step grid2D parseIP
highlight textArea grid2D nexIP yOffset
where
xC = posx ip
yC = posy ip+yOffset
blue = Color 2478 13810 63262
green = Color 3372 62381 5732
gold = Color 65535 30430 0
black = Color 0 0 0
{- moves the grid and colors the entrys used to handel Push Pop
and Call
-}
colorMoves :: TextArea -> Grid2D -> Int -> IP -> Color -> IO IP
colorMoves _ _ 0 _ _ = return crash
colorMoves area grid2D stepsBack ip color = do
changeColorOfEntryByCoord area (posx ip,posy ip+yOffset) color
colorMoves area grid2D (stepsBack-1) (move ip Forward) color
return crash
{-Serializes the code and delets whitespaces at the end of lines.
It also returns the y coord of $ of functions
-}
serializeIt :: TextArea
-> (Int,Int)
-> (String,[Int])
-> IO(String,[Int])
serializeIt textArea (w,h) (code,indexes) = do
(x,y) <- readIORef $ getPointerToSize textArea
if h > y then return (code, indexes) else
(do
map <- readIORef $ getPointerToEntryMap textArea
line <- serializeItHelp map (w,h) (x,y) ""
let clearLine = (reverse.dropWhile(==' ').reverse) line
serializeIt textArea (0, h + 1)
(if not (Prelude.null clearLine) && head clearLine == '$' then
(code ++ (line ++ "\n"), indexes ++ [h]) else
(code ++ (line ++ "\n"), indexes)))
serializeItHelp :: Map (Int,Int) Entry
-> (Int,Int)
-> (Int,Int)
-> String
-> IO String
serializeItHelp map (w,h) (xMax,yMax) line =
if w >= xMax then return line else
(do
let elem = Map.lookup (w,h) map
if isNothing elem then
serializeItHelp map (w+1,h) (xMax,yMax) (line++" ") else
(do
let entry = fromJust elem
content <- entryGetText entry
serializeItHelp map (w+1,h) (xMax,yMax) (line++content)))
serializeTextAreaContent area@(TextArea layout current hMap size) = do
hmap <- readIORef hMap
let list = toList hmap
let sortedList = quicksort list
result <- listToString sortedList [] 0
let rightOrder = unlines $ Prelude.filter (/="") $ Prelude.map (reverse . dropWhile (== ' ') . reverse) (lines $ reverse result)
return rightOrder
where
quicksort :: [((Int,Int),Entry)] -> [((Int,Int),Entry)]
quicksort [] = []
quicksort (x:xs) = quicksort [a | a <- xs, before a x] ++ [x] ++ quicksort [a | a <- xs, not $ before a x]
listToString :: [((Int,Int),Entry)] -> String -> Int -> IO String
listToString list akku beforeY =
if Prelude.null list
then return akku
else do
text <- entryGetText (snd $ head list)
let (x,y) = fst $ head list
if y > beforeY
then listToString (tail list) (headE text : '\n' : akku) y
else listToString (tail list) (headE text : akku) y
headE a | length a == 0 = ' '
| otherwise = head a
before :: ((Int,Int),Entry) -> ((Int,Int),Entry) -> Bool
before ((a,b),_) ((c,d),_) = b < d || (b == d && a <= c)