module Main where

import Maybe
import FranTk
import ViewTypes
import Label
import Edit
import List (intersperse)

main :: IO ()
main = display $  treeEdit

------------------------------------------------------------------------------------------------------
-- tree editor

treeEdit :: WComponent
treeEdit = do 

 -- input direction
 dirToggle <- mkBVar True
 let dirB = bvarBehavior dirToggle
 let dirMenu = dirmenu (bvarInput dirToggle)


 -- wire that all key inputs talk to
 keyWire <- mkWire
 -- xs :: Event (String,[Command])
 xs <- scanner (event keyWire)

 -- wire that all commands talk to
 commandWire <- mkWire

 -- commands event - merges actual commands and key events
 let commEvents :: Event Command
     commEvents = event commandWire .|. (fromListE (xs ==> snd)) 

 -- tree updates
 let commandsE :: Event Edit1
     commandsE = withSnapE fromCommand dirB commEvents 

 t <- mkTreeCollection (empty,[]) commandsE (input commandWire)

 -- file handling
 saveListener   <-  mkGUIL saveTree
 let saveListen =   snapshotL_ (lift1 subtreeOfEdit (treeBehavior t)) 
                               (saveListener)
 loadListen     <-  mapGUIL_ loadTree (input commandWire)
 let fileMenu   =   filemenu loadListen saveListen

 -- status label for displaying partial commands
 commBehavior  <- stepper [] (xs ==> fst)
 let commLabel =  mkLabel [textB commBehavior]

 -- visible clipboard
 clipvis <- mkBVar True
 let visB = bvarBehavior clipvis
 let visMenu = vismenu (bvarInput clipvis) visB
 
 -- clipboard view
 
 let clipcontents = lift1 snd (treeBehavior t)

 let win = mkWindow [title "Clipboard Contents",
                     onClose (tellL (bvarInput clipvis) False)] $ 
	       (mkScrollableEdit [readOnly True,
                                  textB $ lift1 prettyForest $ clipcontents,
                                  font $namedFont "Courier" 14 [Roman]] [] [])
 let clipwin = ifB visB win emptyComponent

 let menus = mkMenu [] [fileMenu,dirMenu,visMenu]

 docB <- fromTreeCollection t

 -- the window
 pile [
  withRootWindow [title "Structure Editor",useMenu menus] $ do
   (keyPressAny (input keyWire) $ 
      mkScrollableEdit [focus,setDocB docB,
                        readOnly True,font $namedFont "Courier" 14 [Roman] ] 
                       [] [])
   `above`
   commLabel,
   clipwin
   ]

------------------------------------------------------------------------------------------------------
-- command dispatcher

fromCommand :: Command -> Bool -> Edit1
fromCommand (Ins l) True   = entry l
fromCommand (Ins l) False  = entryR l
fromCommand Kill _         = lift kill 
fromCommand (Load t) _     = lift (replace t) -.- nav toRoot'

fromCommand Up  _          = nav up'
fromCommand Lft _          = nav left'
fromCommand Rght _         = nav right'
fromCommand Down _         = nav down'

fromCommand Cpy _          = copy
fromCommand Pste _         = lift paste
fromCommand Clear _        = clear


fromCommand Open _         = open
fromCommand Close True     = close
fromCommand Close False    = closeR
fromCommand Nxt  True      = nav (liftnav forward)
fromCommand Nxt  False     = nav (liftnav backward)


fromCommand Promo _        = lift promote
fromCommand Demo True      = lift demote
fromCommand Demo False     = lift demoteR
fromCommand Flt _          = lift flatass
fromCommand Skip _         = idEdit
fromCommand Ct True        = lift cut
fromCommand Ct False       = lift cutR

fromCommand (Navigate loc) _ = navigate loc
fromCommand (Bracket loc) _ = bracket loc

fromCommand _ _ = undefined

------------------------------------------------------------------------------------------------------
-- file handling

vismenu :: Listener Bool -> Behavior Bool -> MenuItem
vismenu setvis isvis = mcascade [text "View"] (mkMenu [] [mcheckbutton [text "View Clipboard",checkValB isvis] setvis])

filemenu :: Listener () -> Listener () ->  MenuItem
filemenu load saver  = mcascade [text "File"] 
                                 (mkMenu [] [mbutton [text "Load"] load,mbutton [text "Save"] saver])
                                 


loadTree :: GUI Command
loadTree = do    n <- getOpenFileName
                 case n of
                   Nothing -> return Skip
                   Just fn -> do xs <- liftIO $ readFile fn
                                 return (Load (read xs))

saveTree :: Bracket -> GUI ()
saveTree st =      do n <- getSaveFileName
                      case n of
                        Nothing -> return ()
                        Just fn -> liftIO $ writeFile fn (show (host (flatten st)))
------------------------------------------------------------------------------------------------------
-- direction toggling
           
dirmenu :: Listener Bool ->  MenuItem
dirmenu dir  = mcascade [text "Direction"] 
                        (mkMenu [] [mcheckbutton  [text "Left-to-right",checkVal True] dir])
                        

showDir :: Bool -> String
showDir True = "left-to-right"
showDir False = "right-to-left"

------------------------------------------------------------------------------------------------------
-- tree collections

type EStatus = EditSt Bracket [Tree]

data TreeCollection = TreeCollection {treeInput    :: Listener Command,
                                      treeEvent    :: Event (EStatus, [Bracket]),
                                      treeBehavior :: Behavior EStatus,
                                      treeInit     :: EStatus}


mkTreeCollection :: EStatus -> Event Edit1 -> Listener Command 
                 -> GUI TreeCollection
mkTreeCollection s ev' set = do
 ev <- scanlE (\(e,_) f -> f e) (s,[]) ev' 
 bh <- stepper s (ev ==> fst)
 return $ TreeCollection set ev bh s

fromTreeCollection :: TreeCollection -> GUI DocumentB 
fromTreeCollection (TreeCollection set e bh st) =
 let select :: Listener TreeTag
     select = mapL (Navigate . locOfTag ) set

     brack :: Listener TreeTag
     brack = mapL (Bracket . locOfTag) set
 
     mkTg :: EStatus -> Maybe (TIndex,TIndex)
     mkTg (s,c) = let x = getSelectedTag s
                  in Just (tindexTagFirst x,tindexTagLast x)
 in
 mkDocumentB 
  (insertTagIDoc 
        (mkEditTag [backgroundB (grey 0.8),
                withIndexB $ lift1 mkTg bh]) $
         structured
             (SGroup $ viewTree (subtreeOfEdit st) select brack)
	     )
		
  (mapE (alterOp select brack) e)
      
getSelectedTag :: Bracket -> Ident
getSelectedTag = identify . tagOfLoc . location . flatten

alterOp :: Listener TreeTag -> Listener TreeTag -> (EditSt Bracket  [Tree], [Bracket]) -> (IDoc -> IDoc)
alterOp lst lst' ((st,c),past) = foldr (.) id $ reverse $ map alter past
 where alter nst = replaceStructured (head (viewTree nst lst lst')) 
                                     (getSelectedTag nst)


------------------------------------------------------------------------------------------------------
-- scanner

special c = elem c specialChars

domain = map fst

data Command = Ins TreeLabel | Kill | 
               Up | Lft | Rght | Down | 
               Open | Close | 
               Load Tree | Skip | 
               Nxt  | Promo | Demo | Flt | Ct | 
               Pste | Cpy | Clear|
               Navigate Loc | Bracket Loc
    
newtoken (s,_) l = if not (null s) then ([],[Ins (Letter s), l]) else ([],[l])

scanner :: Event Key -> GUI (Event (String,[Command]))
scanner e = accumE ("",[]) (e ==> apply)                       
            where apply (KeyChar '(')   sx    = newtoken sx Open
                  apply (KeyChar ')')   sx    = newtoken sx Close
                  apply (KeyChar x)     (s,y) = case (lookup [x] commandStrings) of
                                                  Nothing -> case (lookup sx commandStrings) of
                                                              (Just j) -> ([],[Ins j])
                                                              Nothing    -> if special x && not (null s)
                                                                            then ([x],[Ins (Letter s)])
                                                                            else (sx,[])
                                                  Just m  -> newtoken (s,y) (Ins m)
                                                where sx = s++[x]
                  apply CursorUp       sx     = newtoken sx Up
                  apply CursorDown     sx     = newtoken sx Down
                  apply CursorRight    sx     = newtoken sx Rght
                  apply CursorLeft     sx     = newtoken sx Lft
                  apply Delete         sx     = newtoken sx Kill
                  apply BackSpace      (s,x)  = if null s then (s,x) else (init s,x)
                  apply Return         sx     = newtoken sx Nxt
                  apply (F 1)          sx     = newtoken sx Cpy
                  apply (F 2)          sx     = newtoken sx Pste
                  apply (F 3)          sx     = newtoken sx Clear
                  apply (F 4)          sx     = newtoken sx Promo
                  apply (F 5)          sx     = newtoken sx Demo
                  apply (F 6)          sx     = newtoken sx Flt
                  apply (F 7)          sx     = newtoken sx Skip
                  apply (F 8)          sx     = newtoken sx Ct
                  apply _              (s,_)  = if null s then ([],[]) else ([],[Ins (Letter s)])


-----------------------------------------------------------------------------------------------------
-- pretty printing

prettyForest :: [Tree] -> String
prettyForest = concat . intersperse "\n\n" . map prettyTree
prettyTree :: Tree -> String
prettyTree t = concat (map structuredToString (viewTree ([], t) undefined undefined))

viewTree :: Bracket -> Listener TreeTag -> Listener TreeTag -> [Structured]
viewTree st lst lst' = [viewTree' (selected' st) (location (flatten st)) lst lst' (indentation st)]
 
viewTree' :: Tree -> Loc ->  Listener TreeTag -> Listener TreeTag-> Int -> Structured
viewTree' (Fork l ts) loc lst lst' n =
 STextTagged (concat (map ($n) (map (($lst').($lst)) 
              (viewLabel l  (map (viewTree'' loc) (zip ts [0..])) tag) )))
              (mkEditTag [useIdent (identify tag)])
 where tag =  tagOfLoc loc

viewTree'' :: Loc -> (Tree,Int) -> Listener TreeTag -> Listener TreeTag -> Int -> [Structured]
viewTree'' loc (t,i) lst lst' n = [viewTree' t (i:loc) lst lst' n]

indentation :: Bracket -> Int
indentation = sum . map ind . concat . fst


structuredToString :: Structured -> String
structuredToString (SText s) = s
structuredToString (STextTagged ss _) = concat (map structuredToString ss)
structuredToString (STextMark _) = []