diff options
Diffstat (limited to 'src/GF/Fudgets')
| -rw-r--r-- | src/GF/Fudgets/ArchEdit.hs | 16 | ||||
| -rw-r--r-- | src/GF/Fudgets/CommandF.hs | 120 | ||||
| -rw-r--r-- | src/GF/Fudgets/EventF.hs | 36 | ||||
| -rw-r--r-- | src/GF/Fudgets/FudgetOps.hs | 47 | ||||
| -rw-r--r-- | src/GF/Fudgets/UnicodeF.hs | 23 |
5 files changed, 242 insertions, 0 deletions
diff --git a/src/GF/Fudgets/ArchEdit.hs b/src/GF/Fudgets/ArchEdit.hs new file mode 100644 index 000000000..82653595d --- /dev/null +++ b/src/GF/Fudgets/ArchEdit.hs @@ -0,0 +1,16 @@ +module ArchEdit ( + fudlogueEdit, fudlogueWrite, fudlogueWriteUni + ) where + +import CommandF +import UnicodeF + +-- architecture/compiler dependent definitions for unix/ghc, if Fudgets works. +-- If not, use the modules in for-ghci + +fudlogueEdit font = fudlogueEditF ---- +fudlogueWrite = fudlogueWriteU +fudlogueWriteUni _ _ = do + putStrLn "sorry no unicode available in ghc" + + diff --git a/src/GF/Fudgets/CommandF.hs b/src/GF/Fudgets/CommandF.hs new file mode 100644 index 000000000..8bf791a61 --- /dev/null +++ b/src/GF/Fudgets/CommandF.hs @@ -0,0 +1,120 @@ +module CommandF where + +import Operations + +import Session +import Commands + +import Fudgets +import FudgetOps + +import EventF + +-- a graphical shell for any kind of GF with Zipper editing. AR 20/8/2001 + +fudlogueEditF :: CEnv -> IO () +fudlogueEditF env = + fudlogue $ gfSizeP $ shellF ("GF 1.1 Fudget Editor") (gfF env) + +gfF env = nameLayoutF gfLayout $ (gfOutputF env >==< gfCommandF env) >+< quitButF + +( quitN : menusN : newN : transformN : filterN : displayN : + navigateN : viewN : outputN : saveN : _) = map show [1..] + +gfLayout = placeNL verticalP [generics,output,navigate,menus,transform] + where + generics = placeNL horizontalP (map leafNL + [newN,saveN,viewN,displayN,filterN,quitN]) + output = leafNL outputN + navigate = leafNL navigateN + menus = leafNL menusN + transform = leafNL transformN + +gfSizeP = spacerF (sizeS (Point 720 640)) + +gfOutputF env = + ((nameF outputN $ (writeFileF >+< textWindowF)) + >==< + (absF (saveSP "EMPTY") + >==< + (nameF saveN (popupStringInputF "Save" "foo.tmp" "Save to file:") + >+< + mapF (displayJustStateIn env)))) + >==< + mapF Right + +gfCommandF :: CEnv -> F () SState +gfCommandF env = loopCommandsF env >==< getCommandsF env >==< mapF (\_ -> Click) + +loopCommandsF :: CEnv -> F Command SState +loopCommandsF env = loopThroughRightF (mapGfStateF env) (mkMenusF env) + +mapGfStateF :: CEnv -> F (Either Command Command) (Either SState SState) +mapGfStateF env = mapstateF execFC (initSState) where + execFC e0 (Left c) = (e,[Right e,Left e]) where e = execECommand env c e0 + execFC e0 (Right c) = (e,[Left e,Right e]) where e = execECommand env c e0 + +mkMenusF :: CEnv -> F SState Command +mkMenusF env = + nameF menusN $ + labAboveF "Select Action on Subterm" + (mapF fst >==< smallPickListF snd >==< mapF (mkRefineMenu env)) + +getCommandsF env = + newF env >*< + viewF >*< + menuDisplayF env >*< + filterF >*< + navigateF >*< + transformF + +key2command ((key,_),_) = case key of + "Up" -> CBack 1 + "Down" -> CAhead 1 + "Left" -> CPrevMeta + "Right" -> CNextMeta + "space" -> CTop + + "d" -> CDelete + "u" -> CUndo + "v" -> CView + + _ -> CVoid + +transformF = + nameF transformN $ + mapF (either key2command id) >==< (keyboardF $ + placerF horizontalP $ + cPopupStringInputF CRefineParse "Parse" "" "Parse in concrete syntax" >*< + --- to enable Unicode: ("Refine by parsing" `labLeftOfF` writeInputF) + cPopupStringInputF CRefineWithTree "Term" "" "Parse term" >*< + cMenuF "Modify" termCommandMenu >*< + cPopupStringInputF CAlphaConvert "Alpha" "x_0 x" "Alpha convert" >*< + cButtonF CRefineRandom "Random" >*< + cButtonF CUndo "Undo" + ) + +quitButF = nameF quitN $ quitF >==< buttonF "Quit" + +newF env = nameF newN $ cMenuF "New" (newCatMenu env) +menuDisplayF env = nameF displayN $ cMenuF "Menus" $ displayCommandMenu env +filterF = nameF filterN $ cMenuF "Filter" stringCommandMenu + +viewF = nameF viewN $ cButtonF CView "View" + +navigateF = + nameF navigateN $ + placerF horizontalP $ + cButtonF CPrevMeta "?<" >*< + cButtonF (CBack 1) "<" >*< + cButtonF CTop "Top" >*< + cButtonF CLast "Last" >*< + cButtonF (CAhead 1) ">" >*< + cButtonF CNextMeta ">?" + +cButtonF c s = mapF (const c) >==< buttonF s +cMenuF s css = menuF s css >==< mapF (\_ -> CVoid) + +cPopupStringInputF comm lab def msg = + mapF comm >==< popupStringInputF lab def msg >==< mapF (const []) + diff --git a/src/GF/Fudgets/EventF.hs b/src/GF/Fudgets/EventF.hs new file mode 100644 index 000000000..cfcf3e401 --- /dev/null +++ b/src/GF/Fudgets/EventF.hs @@ -0,0 +1,36 @@ +module EventF where +import AllFudgets + +-- The first string is the name of the key (e.g., "Down" for the down arrow key) +-- The modifiers list shift, control and alt keys that were active while the +-- key was pressed. +-- The last string is the text produced by the key (for keys that produce +-- printable characters, empty for control keys). + +type KeyPress = ((String,[Modifiers]),String) + +keyboardF :: F i o -> F i (Either KeyPress o) +keyboardF fud = idRightSP (concatMapSP post) >^^=< oeventF mask fud + where + post (KeyEvent {type'=Pressed,keySym=sym,state=mods,keyLookup=s}) = + [((sym,mods),s)] + post _ = [] + + mask = [KeyPressMask, + EnterWindowMask, LeaveWindowMask -- because of CTT implementation + ] + +-- Output events: +oeventF em fud = eventF em (idLeftF fud) + +-- Feed events to argument fudget: +eventF eventmask = serCompLeftToRightF . groupF startcmds eventK + where + startcmds = [XCmd $ ChangeWindowAttributes [CWEventMask eventmask], + XCmd $ ConfigureWindow [CWBorderWidth 0]] + eventK = K $ mapFilterSP route + where route = message low high + low (XEvt event) = Just (High (Left event)) + low _ = Nothing + high h = Just (High (Right h)) + diff --git a/src/GF/Fudgets/FudgetOps.hs b/src/GF/Fudgets/FudgetOps.hs new file mode 100644 index 000000000..6c4e1a8b2 --- /dev/null +++ b/src/GF/Fudgets/FudgetOps.hs @@ -0,0 +1,47 @@ +module FudgetOps where + +import Fudgets + +-- auxiliary Fudgets for GF syntax editor + +-- save and display + +showAndSaveF fud = (writeFileF >+< textWindowF) >==< saveF fud + +saveF :: F a String -> F (Either String a) (Either (String,String) String) +saveF fud = + absF (saveSP "EMPTY") + >==< + (popupStringInputF "Save" "foo.tmp" "Save to file:" >+< fud) + +saveSP :: String -> SP (Either String String) (Either (String,String) String) +saveSP contents = getSP $ \msg -> case msg of + Left file -> putSP (Left (file,contents)) (saveSP contents) + Right string -> putSP (Right string) (saveSP string) + +textWindowF = writeOutputF + +-- to replace stringInputF by a pop-up slot behind a button +popupStringInputF :: String -> String -> String -> F String String +popupStringInputF label deflt msg = + mapF snd + >==< + (popupSizeP $ stringPopupF deflt) + >==< + mapF (\_ -> (Just msg,Nothing)) + >==< + decentButtonF label + >==< + mapF (\_ -> Click) + +decentButtonF = spacerF (sizeS (Point 80 20)) . buttonF + +popupSizeP = spacerF (sizeS (Point 240 100)) + +--- the Unicode stuff should be inserted here + +writeOutputF = moreF >==< mapF lines + +writeInputF = stringInputF + + diff --git a/src/GF/Fudgets/UnicodeF.hs b/src/GF/Fudgets/UnicodeF.hs new file mode 100644 index 000000000..22a250658 --- /dev/null +++ b/src/GF/Fudgets/UnicodeF.hs @@ -0,0 +1,23 @@ +module UnicodeF where +import Fudgets + +import Operations +import Unicode + +-- AR 12/4/2000, 18/9/2001 (added font parameter) + +fudlogueWriteU :: String -> (String -> String) -> IO () +fudlogueWriteU fn trans = + fudlogue $ + shellF "GF Unicode Output" (writeF fn trans >+< quitButtonF) + +writeF fn trans = writeOutputF fn >==< mapF trans >==< writeInputF fn + +displaySizeP = placerF (spacerP (sizeS (Point 440 500)) verticalP) + +writeOutputF fn = moreF' (setFont fn) >==< justWriteOutputF + +justWriteOutputF = mapF (map (wrapLines 0) . filter (/=[]) . map mkUnicode . lines) + +writeInputF fn = stringInputF' (setShowString mkUnicode . setFont fn) + |