diff options
| author | aarne <aarne@cs.chalmers.se> | 2008-06-25 16:43:48 +0000 |
|---|---|---|
| committer | aarne <aarne@cs.chalmers.se> | 2008-06-25 16:43:48 +0000 |
| commit | b96b36f43de3e2f8b58d5f539daa6f6d47f25870 (patch) | |
| tree | 0992334be13cec6538a1dea22fbbf26ad6bdf224 /src/GF/Fudgets | |
| parent | fe367412e0aeb4ad5c02de68e6eca382e0f96984 (diff) | |
removed src for 2.9
Diffstat (limited to 'src/GF/Fudgets')
| -rw-r--r-- | src/GF/Fudgets/ArchEdit.hs | 30 | ||||
| -rw-r--r-- | src/GF/Fudgets/CommandF.hs | 134 | ||||
| -rw-r--r-- | src/GF/Fudgets/EventF.hs | 51 | ||||
| -rw-r--r-- | src/GF/Fudgets/FudgetOps.hs | 59 | ||||
| -rw-r--r-- | src/GF/Fudgets/UnicodeF.hs | 37 |
5 files changed, 0 insertions, 311 deletions
diff --git a/src/GF/Fudgets/ArchEdit.hs b/src/GF/Fudgets/ArchEdit.hs deleted file mode 100644 index 5bc0dc84b..000000000 --- a/src/GF/Fudgets/ArchEdit.hs +++ /dev/null @@ -1,30 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : (Module) --- Maintainer : (Maintainer) --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:46:05 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Fudgets.ArchEdit ( - fudlogueEdit, fudlogueWrite, fudlogueWriteUni - ) where - -import GF.Fudgets.CommandF -import GF.Fudgets.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 deleted file mode 100644 index 15af12215..000000000 --- a/src/GF/Fudgets/CommandF.hs +++ /dev/null @@ -1,134 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : CommandF --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:15 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- a graphical shell for any kind of GF with Zipper editing. AR 20\/8\/2001 ------------------------------------------------------------------------------ - -module GF.Fudgets.CommandF where - -import GF.Data.Operations - -import GF.UseGrammar.Session -import GF.Shell.Commands - -import Fudgets -import GF.Fudgets.FudgetOps - -import GF.Fudgets.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 2.0- 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 deleted file mode 100644 index 7ea058dfa..000000000 --- a/src/GF/Fudgets/EventF.hs +++ /dev/null @@ -1,51 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : EventF --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:16 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Fudgets.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 deleted file mode 100644 index 4aba5eec5..000000000 --- a/src/GF/Fudgets/FudgetOps.hs +++ /dev/null @@ -1,59 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : FudgetOps --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:17 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- auxiliary Fudgets for GF syntax editor ------------------------------------------------------------------------------ - -module GF.Fudgets.FudgetOps where - -import Fudgets - --- 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 deleted file mode 100644 index 024205698..000000000 --- a/src/GF/Fudgets/UnicodeF.hs +++ /dev/null @@ -1,37 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : UnicodeF --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:17 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Fudgets.UnicodeF (fudlogueWriteU) where -import Fudgets - -import GF.Data.Operations -import GF.Text.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) - |
