packages feed

fudgets (empty) → 0.18.3

raw patch · 374 files changed

+26265/−0 lines, 374 filesdep +arraydep +basedep +containerssetup-changed

Dependencies added: array, base, containers, directory, fudgets, old-time, parallel, process, random, time, unix

Files

@@ -0,0 +1,12 @@+The authors have the copyright to all files distributed as part of the+fudget library, except where an explicit copyright notice states+otherwise.++The files may be distributed and used free of charge for+non-commercial purposes only. Commercial use of the fudget library+requires an agreement with the authors.++This file should be included unchanged in all copies.+++Magnus Carlsson & Thomas Hallgren
+ Contrib/AuxShellF.hs view
@@ -0,0 +1,31 @@+module AuxShellF where+import Fudgets+import TitleShellF(wmShellF')++auxShellF = auxShellF' standard+delayedAuxShellF = delayedAuxShellF' standard++delayedAuxShellF' pm title fud =+    auxShellF' pm title fud >=^^< emptyDownSP+  where+    -- 3x3 state transition table:+    emptyDownSP = getPopSP emptyDownSP upSP      downSP+    downSP    x = getPopSP (downSP x)  (msgSP x) downSP+    upSP        = getPopSP emptyDownSP upSP      msgSP++    msgSP x = putSP (Right x) upSP++    getPopSP downSP upSP msgSP = getSP $ either popSP msgSP+      where popSP b = putSP (Left b) $ if b then upSP else downSP++auxShellF' pm title fud =+  mapEither (const False) id >^=<+  wmShellF' (pm . setVisible False) title fud+  >=^< mapEither Right id++{-+auxShellF lbl title fud =+  loopThroughRightF+    (wmShellF' (setVisible False) title fud)+    (Right>^=<toggleButtonF lbl>=^<const False)+-}
+ Contrib/BitmapF.hs view
@@ -0,0 +1,52 @@+module BitmapF (bitmapButtonF, bitmapDispF, bitmapDispBorderF) where+import AllFudgets++windowKernel filename =+  allocNamedColorPixel defaultColormap "black" $ \fg ->+  allocNamedColorPixel defaultColormap "white" $ \bg ->+  changeBackPixel "white" $+  wCreateGC rootGC [GCFunction GXcopy,+                    GCForeground fg,+                    GCBackground bg,+                    GCGraphicsExposures False] $ \drawGC ->+  let displayImage size bitmapid =+        createPixmap size copyFromParent (\pixmapid ->+          putsK [Low (pmCopyPlane pixmapid drawGC (Pixmap bitmapid) +                    (Rect (Point 0 0) size) (Point 0 0) 0),+                lxcmd (ChangeWindowAttributes [CWBackPixmap pixmapid]),+                lxcmd (FreePixmap bitmapid),+                lxcmd (FreePixmap pixmapid),+                Low (layoutRequestCmd (plainLayout size True True)),+                lxcmd ClearWindow] +               displayproc)+      lxcmd = Low . XCmd+      displayproc =+        getK (\msg ->+          case msg of+            Low (XEvt (Expose _ 0)) -> xcommandK ClearWindow displayproc +            High BitmapBad -> error ("Invalid bitmap file")+            High (BitmapReturn size _ bitmapid) -> displayImage size bitmapid+            _ -> displayproc)+  in readBitmapFile filename (\bmr ->+       case bmr of+         BitmapBad -> error ("Invalid bitmap file " ++ filename)+         BitmapReturn size _ bitmapid -> displayImage size bitmapid)++bitmapDispF :: FilePath -> F BitmapReturn a+bitmapDispF filename =+  let wattrs = [CWBackingStore WhenMapped, CWEventMask [ExposureMask]]+      kernelF =  windowF ([XCmd $ ChangeWindowAttributes wattrs])+                         (windowKernel filename)+  in marginHVAlignF 0 aCenter aCenter kernelF++bitmapDispBorderF :: Int -> FilePath -> F BitmapReturn a+bitmapDispBorderF width filename =+  let wattrs = [CWBackingStore WhenMapped, CWEventMask [ExposureMask]]+      kernelF = windowF [XCmd (ChangeWindowAttributes wattrs),+                         XCmd (ConfigureWindow [CWBorderWidth width])]+                         (windowKernel filename)+  in marginHVAlignF 0 aCenter aCenter kernelF++bitmapButtonF keys filename =+  let kernelF = bitmapDispBorderF 0 filename +  in fromRight >^=< (pushButtonF keys kernelF)
+ Contrib/CompletionStringF.hs view
@@ -0,0 +1,104 @@+module CompletionStringF+    (stdcc,completeFromList,+     completionStringF,completionStringF',completionStringF'')+  where+import Fudgets+import Data.List(isPrefixOf) +import HbcUtils(mapSnd)++completionStringF = completionStringF' stdcc standard++stdcc = argReadKey "stdcc" ' ' -- standard completion char++completionStringF' cc cust = completionStringF'' cc cust >=^< mapEither id Right++completionStringF'' cc cust =  -- cc = completion character+    loopThroughRightF (absF completeSP0) (stringF'' cust)+  where+    completeSP0 = completeSP (const []) ([],[]) ""++    completeSP listfun updownlist current =+        getSP $ either fromStringF fromOutside+      where+        list = listfun current++        same = completeSP listfun updownlist current+	newList listfun' = completeSP listfun' ([],[]) current+	newString' p s = putSP (toOutput (InputChange s)) $+			 completeSP listfun p s+	newString = newString' ([],[])+++        toStringF'' = Left+        toString = toStringF'' . Right+	toCustomiser = toStringF'' . Left+	toOutput = Right . Right+	toCompletionList = Right . Left++	fromOutside = either newList inputToStringF''+	inputToStringF'' msg = putSP (toStringF'' msg) same++        fromStringF msg = +	  case msg of+	    InputDone "Up"   _ -> goto above+	    InputDone "Down" _ -> goto below+	    InputDone "Tab"  _ -> doCompletion+	    InputDone _ _ -> putSP (toOutput msg) same+	    InputChange s ->+	      if s==current++[cc]+	      then doCompletion+	      else if fromupdownlist s+	           then same+		   else newString s -- erase completion list?++        fromupdownlist s =+ 	    case updownlist of+	      (_,(_,s'):_) -> s==s'+	      _ -> False++        goto (_,[]) = same+        goto l@(_,item@(_,s):_) =+	    putSP (toString s) $+	    putSP (toCompletionList [item]) $+	    putSP (toOutput (InputChange s)) $+	    newString' l current++	above = case updownlist of+		  ([],[]) -> case reverse updownlist' of+			       x:xs -> (xs,[x])+			       _ -> ([],[])+		  (x:xs,ys) -> (xs,x:ys)+		  _ -> updownlist++        below = case updownlist of+		  ([],[]) -> ([],updownlist')+		  (xs,x1:x2:ys) -> (x1:xs,x2:ys)+		  _ -> updownlist++        updownlist' = mapSnd (current++) list++        doCompletion =+	    putSP (toCompletionList list) $+	    putNewString (current++commonPrefix (map snd list))++        putNewString new =+	  putSP (toString new) $+	  putSP (toCustomiser (setCursorPos (length new))) $+	  newString new++commonPrefix ((c:s):ss) =+  case filter ((/=[c]).take 1) ss of+    [] -> c:commonPrefix (s:map tail ss)+    _ -> []+commonPrefix _ = []++pos y xs =+  case [ix|ix@(i,x)<-number 0 xs,y `isPrefixOf` x] of+    []      -> (0,False)+    (i,x):_ -> (i,x==y)++completeFromList list current =+    [(current,compl)|(pre,compl)<-splits,pre==current]+  where+    splits = map (splitAt n) list+    n = length current
+ Contrib/ConnectF.hs view
@@ -0,0 +1,58 @@+module ConnectF where+import Fudgets(F,(>+<))++infixl :&:,>&<+++--leaf :: (o->h)->F i o->(F i o,o->h,i->i)+tagF handler fud = TagF fud handler id++--data TagF a b c = TagF a b c+data TagF i o h t = TagF (F i o) (o->h) (t i)+-- TagF makes the type more readable but also more restrictive...++tf1 >&< tf2 = compTagF (>+<) tf1 tf2++compTagF compF (TagF fud1 get1 tag1) (TagF fud2 get2 tag2) =+    TagF (compF fud1 fud2) (either get1 get2) (etag1 :&: etag2)+  where+    etag1 = extend Left tag1+    etag2 = extend Right tag2++mapTF f (TagF fud get tag) = TagF (f fud) get tag++ltr ih (TagF fud get tag) =+  (fud,either get ih,Right :&: extend Left tag)++class Tag f where+  extend :: (b->c) -> f b -> f c++data Tags f1 f2 a = (f1 a) :&: (f2 a)++instance Tag ((->) a) where+  extend = (.)++instance (Tag f1,Tag f2) => Tag (Tags f1 f2) where+  extend f (g1:&:g2) = extend f g1:&:extend f g2++{-+newtype Selector d a = S (d a->Maybe a)++instance Tag (Selector d) where+  extend f +++f d1 d2 = (either d1 no,either no d2)+ :: (d1 a -> Maybe a) ->+    (d2 b -> Maybe b) ->+    (Either (d1 a) (d2 b)->Maybe a,Either (d1 a) (d2 b)->Maybe b)++a->Maybe b -> Either a c -> Maybe b+-}++no _ = Nothing+yes s = Just s+left f = either f no+right = either no+leftleft = left . left+leftyes = left yes
+ Contrib/ContribFudgets.hs view
@@ -0,0 +1,51 @@+-- | Contributed add-ons to the Fudget Library+module ContribFudgets(+  -- * Contributed add-ons to the Fudget Library+--  module SuperMenuF,+  module BitmapF,+  module ShapedButtonsF,+--  module MenuBar,+  module TitleShellF,+  module AuxShellF,+  module SmileyF,+  module MenuBarF,+  module HelpBubbleF,+  module FileShellF,+  module FilePickPopupF,+  module CompletionStringF,+  module EndButtonsF,+  module MeterF,+  --module HandleF,+  --module LinearSplitP,+  module SplitF,+  module SocketServer,+  module TypedSockets,+  module HyperGraphicsF2,+  module ConnectF,+  module ReactiveF,+  module TreeBrowser+  ) where++import BitmapF+--import MenuBar+import ShapedButtonsF+import SuperMenuF() -- not exported because of name clashes, import SuperMenuF.+import TitleShellF+import AuxShellF+import SmileyF+import MenuBarF+import HelpBubbleF+import FileShellF+import FilePickPopupF+import CompletionStringF+import EndButtonsF+import MeterF+--import HandleF+--import LinearSplitP+import SplitF+import SocketServer+import TypedSockets+import HyperGraphicsF2+import ConnectF+import ReactiveF+import TreeBrowser
+ Contrib/DynRadioGroupF.hs view
@@ -0,0 +1,19 @@+module DynRadioGroupF where+import Fudgets++dynRadioGroupF alts startalt = dynRadioGroupF' standard alts startalt++dynRadioGroupF' pm alts startalt =+    loopThroughRightF (mapstateF ctrl (alts,startalt))+                      (dynF (rgF alts startalt))+  where+    rgF = radioGroupF' pm++    ctrl (alts,current) = either fromRadioGroupF fromOutside+      where+        fromRadioGroupF choice = ((alts,choice),[Right (alts,choice)])+	fromOutside (alts',current') =+	  ((alts',current'),+	   if map fst alts' == map fst alts+	   then [Left (Right current')]+	   else [Left (Left (rgF alts' current'))])
+ Contrib/EndButtonsF.hs view
@@ -0,0 +1,19 @@+module EndButtonsF where+import AllFudgets++endButtonsF =+    noStretchF False True $ matrixF 2 (ok >+< cancel)+  where+    ok = buttonF "OK"+    cancel = buttonF' pm "Cancel"+      where+        pm = setKeys [([],"Escape")]+++endButtonsF' =+    noStretchF False True $ matrixF 2 (ok >+< cancel) >=^< Left+  where+    ok = buttonF'' standard "OK" >=^< Left . setLabel >=^^< idempotSP+    cancel = buttonF' pm "Cancel"+      where+        pm = setKeys [([],"Escape")]
+ Contrib/FilePickPopupF.hs view
@@ -0,0 +1,239 @@+module FilePickPopupF(filePickF,filePickF',filePickPopupF,filePickPopupF',filePickPopupOptF,filePickPopupOptF',startDir,aFilePath,popup) where+import AllFudgets+import EndButtonsF+--import Files+import Data.List(sort,partition)+import HbcUtils(uncurry3)+import DialogueIO hiding (IOError)+import CompletionStringF+import UnsafePerformIO(unsafePerformIO)+import System.Directory(getCurrentDirectory)++popup = ("OK",Nothing)++filePickPopupF = filePickPopupF' noextrabuttons+filePickPopupOptF = filePickPopupOptF' noextrabuttons+filePickF = filePickF' noextrabuttons++noextrabuttons = [] :: ([(AFilePath->AFilePath,KeySym,String)])++filePickPopupF' btns = mapFilterSP ok >^^=< filePickPopupOptF' btns+  where+    ok (x,Nothing) = Nothing+    ok (x,Just y) = Just (x,y)+++filePickPopupOptF' btns =+  --delayF $ -- commented out to avoid a layout problem under XQuartz+  popupShellF "File Selection" Nothing (filePickF' btns >=^< snd)+++filePickF' btns =+    loopThroughRightF (ctrlF (aFilePath startDir,"")) (partsF btns)+  where+    ctrlF st@(dir,file) = getF $ either internal external+      where+        same = ctrlF st++        internal = either (either dirDisp goto) (either fileInput done)++	external (lbl,optpath) = putF (toButtons lbl) (external2 optpath)+          where+	    external2 Nothing = putF (toDirDispDir dir) same+	    external2 (Just s) = newpath (aFilePath s)++        dirDisp = either pick dirList+        dirList list = putF (toFileCompletion (completeFromList (map fst list))) same++        pick inp =+	    pathPartsF (compactPath path) $ \ st'@(dir',file') ->+	    if file'==""+	    then change (dir',file) -- keep previous file name+	    else case inputDone inp of+	           Nothing -> change st'+		   Just _ -> if file'==file -- Hmm. Check dir too.+		             then output path+			     else same -- false double click+	  where+	    path = stripInputMsg inp++	goto f = change (f dir,file)++        fileInput = either completionList filename++        completionList = flip putF same . toDirDispCompletions++	filename inp =+	    case inputDone inp of+	      Nothing -> ctrlF (dir,stripInputMsg inp)+	      Just "" -> same+	      --Just name@('/':_) -> newname (aFilePath name)+	      --Just name -> newname (extendPath dir name)+	      Just path' -> newname (joinPaths dir (aFilePath path'))+	  where+	     newname path =+	       pathPartsF (compactPath path) $ \ st'@(dir',file') ->+	       if file'==""+	       then change st'+	       else output (extendPath dir' file')++	done = either ok cancel+	  where+	    ok _ = putF (out (Just (filePath (extendPath dir file)))) same+	    cancel _ = putF (out Nothing) same++        newpath path = pathPartsF (compactPath path) change++	change st@(dir',file') =+	   putsF ([toFileInput file']+++	          (if dir'/=dir then [toDirDispDir dir'] else [])) $+	   ctrlF st++        output path =+	    putF (out (Just (filePath path'))) (newpath path')+	  where+	    path' = compactPath path++        out = Right+	toDirDisp = Left. Left. Left+	toDirDispDir = toDirDisp. Right+	toDirDispCompletions = toDirDisp. Left+	toFileInput= Left. Right. Left. Right+	toFileCompletion=Left. Right. Left. Left+	toButtons=Left. Right. Right++partsF btns =+  vBoxF ((dirDispF>+<gotoButtonsF btns)>+<(fileInputF>+<endButtonsF'))++dirDispF =+    stripEither >^=< vBoxF (pathDispF >+< dirListF) >=^^< concatMapSP pre+  where+    pre (Left completions) = [Right (Left completions)]+    pre (Right path) = [Left newdir,Right (Right newdir)]+      where newdir = filePath path++    pathDispF = displayF' pm+      where pm = setAlign aCenter.+                 setBgColor bgColor.+		 setBorderWidth 0.+		 setFont labelFont++    dirListF = loopThroughRightF (mapstateF ctrl []) (pickListF fst >+< lsF)+      where+        ctrl list = either (either fromPickListF fromLsF) fromInput+	  where+	    fromInput = either completions newDir+	    completions cs = put (toPickListF hilite)+	      where+	        hilite = highlightItems+	                       [i|(i,(n,_))<-zip [0..] list,n `elem` ns]+		ns = [pre++compl|(pre,compl)<-cs]+	    newDir = put . toLsF+	    fromPickListF msg =+	      put2 (outPick . mapInp (snd.snd) $ msg)+	           (toPickListF.highlightItems.(:[]).fst.stripInputMsg $ msg)+	    fromLsF list' = (list',[outDir list',toPickListF (replaceAll list')])++	    put x = (list,[x])+	    put2 x y = (list,[x,y])++	    out = Right+	    outDir = out . Right+	    outPick = out . Left+	    loop = Left+	    toPickListF = loop . Left+	    toLsF = loop . Right++    lsF = showFilesF>==<paths>^=<readDirF+      where+	paths (dir,resp) =+	    case resp of+	      Right files -> (map (extendPath sdir) . sortFiles) files+	      Left err   -> [extendPath sdir (show err)]+	  where sdir = aFilePath dir+	        sortFiles files =+		  case partition isDotFile files of+		    (dfs,fs) -> sort fs +++		                sort [ f | f<-dfs, f `notElem` [".",".."]]+		isDotFile ('.':_) = True+		isDotFile _ = False++	showFilesF = contMapF showFiles+	showFiles = conts showFile+        showFile = if argFlag "slowshowfile" True+	           then slowShowFile+		   else fastShowFile++	slowShowFile path c =+	  isDirF (filePath path)+		 (c (file++"/",path))+		 (c (file,path))+	  where file = pathTail path++        fastShowFile path c = c (pathTail path,path)++gotoButtonsF btns =+   haskellIOF (GetEnv "HOME") $ \ homeresp ->+   noStretchF False True $+   matrixF 4 (untaggedListF ([rootF,parentF]++homeF homeresp++extra btns))+  where+    rootF = fButtonF (const rootPath) "r" "/ Root"+    parentF = fButtonF (compactPath.flip extendPath "..") "p" ".. Parent"++    homeF resp=+      case resp of+        Str d@(_:_) -> [fButtonF (const (aFilePath d)) "h" "Home"]+	_ -> []++    fButtonF f k lbl = const f >^=< buttonF' (setKeys [([metaKey],k)]) lbl++    extra = map (uncurry3 fButtonF)++fileInputF = "File" `labLeftOfF` completionStringF++pathPartsF path cont =+    isDirF (filePath path) yes no+  where+    yes = cont (path,"")+    no = cont (pathHead path,pathTail path)+    {-+    no  = case path of+            [] -> cont ([],[]) -- not likely to happen, since the root is a dir+	    file:dir -> cont (dir,file)+    -}+++--- Candidates for inclusion in the Fudget library:++isDirF file yes no =+  haskellIOF (StatusFile file) $ \ resp ->+  case resp of+    Str ('d':_) -> yes+    _ -> no++contMapF f =+  getF $ \ x ->+  f x $ \ y ->+  putF y $+  contMapF f++----++-- #ifdef __NHC__+--startDir = argKey "startdir" "/"  -- hmm. should retreive current directory.+-- #else+startDir = unsafePerformIO getCurrentDirectory+-- #endif++{-+ - reloadknapp?+ - alltid absolut path+ - meddelande för att+     välja kataloger+     spara++ - completion och uppnerpilar+ -++ - pixlar kvar i picklistan+-}
+ Contrib/FileShellF.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE CPP #-}+module FileShellF(+#ifndef __NHC__+  fileShellF,fileShellF',+   textFileShellF,textFileShellF',+   showReadFileShellF,showReadFileShellF'+#endif+ ) where+import Fudgets+import FilePickPopupF+import TitleShellF(titleShellF')+import MenuBarF+#ifndef __NHC__+          (menuBarF,menu,idT,item,cmdItem,key)+#endif+import DialogueIO+import Prelude hiding (IOError)+import Data.Maybe(isJust,fromJust,fromMaybe)+import Data.Char(isSpace)++#ifndef __NHC__++textFileShellF = textFileShellF' standard+textFileShellF' customiser = fileShellF' customiser textConv+  where textConv = (id,Right,Just "")++showReadFileShellF empty = showReadFileShellF' standard empty+showReadFileShellF' customiser empty =+    fileShellF' customiser (show,parse,empty)+  where+    parse contents =+      case reads contents of+        [(x,cs)] | all isSpace cs -> Right x+	_ -> Left "Syntax error in input"++++fileShellF = fileShellF' standard++fileShellF' customiser conv title0 appF =+    stubF $ loopOnlyF $ titleShellF' customiser title0 mainF+  where+    mainF = ctrlF title0 conv >==<+            (popupsF>+<vBoxF (fileShellMenuBarF hasNew>+<appF))+      where hasNew = case conv of (_,_,e) -> isJust e++    popupsF = filePickPopupF' >+<(messagePopupF>+<nullF{-confirmPopupF-})+      where+        filePickPopupF' = putsF (map f (take 1 args)) filePickPopupF+	f x = ((Open,popup),x)+++messageF = putF . toMessage+toFilePick = Right . Left . Left+toMessage = Right . Left . Right . Left+--toConfirm = Right . Left . Right . Left+toApp = Right . Right . Right+toTitle = Left++ctrlF title0 (show,parse,optEmpty) = start+ where+  start = loop Nothing Nothing+  changeTitle name = putF (toTitle (title0++": "++name))+  loop filename document =+    getF $ {-either quitMsg-} (either fromPopups (either fromMenu fromApp))+   where+    same = loop filename document+    newName name document' = changeTitle name $ loop (Just name) document'+    errMsg err = messageF err same++    quitMsg () = terminateProgram++    fromPopups = either fromFilePick (either fromMessage fromConfirm)+    fromMessage _ = same+    fromConfirm _ = same -- !!++    fromMenu filecmd =+      case filecmd of+	Open -> putF (toFilePick (Open,("Open",Nothing))) same+        Save -> flip (maybe same) document $ \ doc ->+	        flip (maybe (fromMenu SaveAs)) filename $ \ name ->+		saveF show name doc errMsg $+	        same+	SaveAs -> flip (maybe same) document $ \ _ ->+	          putF (toFilePick (SaveAs,("Save",Just (fromMaybe "" filename)))) same+	Quit -> terminateProgram+	New  -> flip (maybe $ errMsg "New not implemented") optEmpty $ \empty ->+	        changeTitle "Empty file" $+	        putF (toApp empty) $+		start+	_ -> same++    terminateProgram = hIOSuccF (Exit 0) same++    fromFilePick ((action,_),filename) =+      case action of+        Open -> openF parse filename errMsg+		      (\ contents ->+	               putF (toApp contents) $+	               newName filename (Just contents))+        SaveAs -> saveF show filename (fromJust document) errMsg $+                  newName filename document+	_ -> undefined -- shouldn't happen++    fromApp inpmsg =+      case inputDone inpmsg of+	Just doc ->+	  case filename of+	    Just name -> saveF show name doc errMsg $+	                 loop filename (Just doc)+            Nothing   -> putF (toFilePick (SaveAs,("Save",filename))) $+	                 loop filename (Just doc)+	Nothing -> loop filename (Just (stripInputMsg inpmsg))+++data FileMenuItem = New | Open | Save | SaveAs | Quit deriving (Eq)+++fileShellMenuBarF hasNew =+    fromLeft >^=< hBoxF (fileMenuF hasNew >+< gcWarnF) >=^< Left+  where gcWarnF = spacer1F (hvAlignS aRight aCenter) gcWarningF++fileMenuF hasNew =+    spacer1F (noStretchS True True `compS` leftS) (menuBarF menuBar)+  where+    menuBar = [item fileMenu "File"] -- more?+    fileMenu = menu idT $+               (if hasNew then (cmdItem New    "New":) else id)+	       [cmdItem Open   "Open..."     `key` "o",+		cmdItem Save   "Save"        `key` "s",+		cmdItem SaveAs "Save As..."  `key` "a",+		cmdItem Quit   "Quit"        `key` "q" ]++saveF showdoc filename doc errcont cont =+  hIOerrF (WriteFile filename (showdoc doc))+	  (errcont.show)+	  (const cont)++openF parse filename errcont cont =+  hIOerrF (ReadFile filename) (errcont.show) $ \ (Str contents) ->+  either errcont cont (parse contents)++--messageF msg = contDynF $ (startupF [msg] messagePopupF>=^^<nullSP)+-- contDynF doesn't seem to work properly++#endif
+ Contrib/HandleF.hs view
@@ -0,0 +1,92 @@+module HandleF(hHandleF,vHandleF) where+import AllFudgets++hHandleF = handleF' Horizontal 108+vHandleF = handleF' Vertical 116++sepSize = max 2 defaultSep -- !! see note about layoutreq below+sepD dir =+    -- the size of the drawing must be sepSize (in the dir direction)+    placedD (margS d (d2-d) `spacerP` linearP dir 0) $+    boxD [fgD [shadowColor,"black"] l,fgD [shineColor,"white"] l]+  where l = g line+        d2 = sepSize-2+	d = d2 `div` 2++	margS = colinear dir hMarginS vMarginS+	line = colinear dir vFiller hFiller 1++handleF' dir cur alignment =+    --showCommandF "handleF" $+    nullSP >^^=<+    postMapLow post (groupF startcmds handleK0 (labelF (sepD dir)))+    >=^< Left+    --windowF startcmds handleK0+  where+    -- Hack: all layout requests must come from the same address, otherwise+    -- two boxes will be placed instead of one...+    post ([L],cmd@(LCmd _)) = ([R,R],cmd)+    post tcmd = tcmd++    startcmds =+      [--layoutRequestCmd layoutreq,+       XCmd $ ChangeWindowAttributes [CWEventMask eventmask,+                                      CWBackPixmap parentRelative]]++    eventmask = [ButtonPressMask,ButtonReleaseMask,ButtonMotionMask]++    -- It's important that the size of sepD and this request agree!!+    layoutreq = plainLayout (diag sepSize) isHoriz (not isHoriz)+    isHoriz = dir==Horizontal+    wantposreq size p = layoutreq{wantedPos=Just(p,size,alignment)}++    handleK0 = +      setFontCursor cur $+      handleK++    handleK = idleK 0 0+      where+        idleK parentp size = getK $ message low high+	  where+	    same = idleK parentp size+	    high size' = idleK parentp size'+	    low event =+	      case event of+		XEvt ButtonEvent {type'=Pressed,rootPos=pabs} ->+		  dragK parentp size (pabs-parentp) pabs+		LEvt (LayoutPos parentp') -> idleK parentp' size+		_ -> same++	dragK parentp size refp curp = getK $ message low high+	  where+	    moveto = dragK parentp size refp+	    same = moveto curp+	    putpos = putK . Low . layoutRequestCmd . wantposreq size++            high size' = dragK parentp size' refp curp++	    low event =+	      case event of+		LEvt (LayoutPos parentp') -> dragK parentp' size refp curp+		XEvt ButtonEvent {type'=Released,rootPos=curp0'} ->+		    (if curp'==curp+		    then id+		    else putpos (curp'-refp)) $+		    idleK parentp size+		  where curp' = constrain size (curp0'-refp)+refp+		XEvt MotionNotify {rootPos=curp0',state=mods} ->+		    if curp'==curp || Shift `elem` mods+		    then same+		    else putpos (curp'-refp) $+		         moveto curp'+		  where curp' = constrain size (curp0'-refp)+refp+		_ -> same++--constrain _ = id+--{-+-- Try to limit split position to reasonable values:+constrain size =+  if size>defaultSep+  then pmin (size-defaultSep) . pmax defaultSep+  else id+--}
+ Contrib/HelpBubbleF.hs view
@@ -0,0 +1,56 @@+module HelpBubbleF(helpBubbleF) where+import AllFudgets++data BubbleState = Idle | Armed | Up++helpBubbleF help fud =+    if useBubbles+    then loopCompThroughLeftF $+         groupF startcmds ctrlK0 ((timerF>+<bubbleF) >+< fud)+    else fud+ where+   bubbleF = bubbleRootPopupF (labelF' lblpm help)+   lblpm = setBgColor "white" . setFont helpFont+   eventmask = [EnterWindowMask,LeaveWindowMask]+   startcmds = [XCmd $ ChangeWindowAttributes [CWEventMask eventmask],+                XCmd $ ConfigureWindow [CWBorderWidth 0]]++   ctrlK0 = ctrlK 0 0 Idle++   toTimer = High . Left+   toBubble = High . Right++   ctrlK size pos bubbleState =+      getK $ message event (either fromTimer fromBubble)+     where+       same = ctrlK size pos bubbleState+       idle = ctrlK size pos Idle+       newSize size' = ctrlK size' pos bubbleState+       timerOff s = putK (toTimer Nothing) $ ctrlK size pos s+       timerOn pos' = putK (toTimer (Just (0,500))) $ ctrlK size pos' Armed++       fromBubble _ = same++       fromTimer Tick =+         case bubbleState of+	   Armed ->+	       putK (toBubble (Popup (pos+offset) ())) $+	       timerOff Up+	     where offset = pP (xcoord size `div` 2) 3+	   _ -> same+       event e =+         --echoK (show e) $+         case e of+	   XEvt EnterNotify { pos=pos,rootPos=rootPos } -> timerOn (rootPos-pos)++	   XEvt LeaveNotify { } ->+	     case bubbleState of+	       Idle -> same+	       Armed -> timerOff Idle+	       Up -> putK (toBubble Popdown) $ idle++	   LEvt (LayoutSize size') -> newSize size'+	   _ -> same++useBubbles = argFlag "helpbubbles" True+helpFont = argKey "helpfont" "-*-new century schoolbook-medium-r-*-*-12-*-*-*-*-*-iso8859-1"
+ Contrib/HyperGraphicsF2.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE CPP #-}+module HyperGraphicsF2(+  module HyperGraphicsF2,+  GfxCommand(..),GfxChange(..),GfxEvent(..),replaceGfx,highlightGfx+ ) where+import AllFudgets+import Data.Maybe(fromJust,mapMaybe)+import HbcUtils(mapFst)+import qualified Data.Map as Map+--import Fudget+--import Defaults(paperColor)+--import InputMsg(inputDone)+--import Utils(swap)+--import Xtypes(ColorName)+--import Loops(loopThroughRightF)+--import SerCompF(mapstateF)+--import Graphic+--import Drawing+--import DrawingOps+--import GraphicsF+--import FDefaults+--import ListUtil(assoc)+--import Sizing(Sizing(..))+--import GCAttrs() -- instances+--import Event(Pressed(..))+--import Maptrace(ctrace) -- debugging+--import SpyF(teeF) -- debugging+--import CompOps((>==<)) -- debugging++#include "../hsrc/exists.h"++hyperGraphicsF2 x = hyperGraphicsF2' standard x++hyperGraphicsF2' custom init =+    loopThroughRightF+	(mapstateF ctrl state0)+	({-teeF show "\n" >==<-} graphicsDispF' (custom . params))+  where+    --tr x = ctrace "hyper" (show x) x -- debugging+    params = setInitDisp init .+	     setGfxEventMask [GfxButtonMask] .+	     setSizing Dynamic+    state0 = (annotPaths init,init)++    ctrl state@(paths,drawing) = either gfxEvent gfxCommand+      where+        same = (state,[])+	lbl2path lbl = fromJust (Map.lookup lbl paths)++        gfxCommand lcmd =+	    case mapGfxCommandPath lbl2path lcmd of+	      cmd@(ChangeGfx changes) -> (changeState changes,[Left cmd])+	      cmd -> (state,[Left cmd])+	  where+	    changeState changes = (paths',drawing')+	      where+	        drawing' = foldr replace drawing changes++		replace (path,GfxReplace (_,Just d)) drawing =+                    replacePart drawing path d+                replace (path,GfxReplace _) drawing = drawing+                replace (path,GfxGroup from count) drawing =+                    updatePart drawing path (groupParts from count)+                replace (path,GfxUngroup pos) drawing =+                    updatePart drawing path (ungroupParts pos)++		paths' = annotPaths drawing'+			-- Space leak: drawing' isn't used until user clicks+			-- in the window, so the old drawing is retained in+			-- the closure for drawing'++        gfxEvent msg = (state,[Right msg'])+	  where+	    msg' = mapGfxEventPath path2lbl msg++        path2lbl path = do let part = drawingAnnotPart drawing path+			   LabelD a _ <- maybeDrawingPart drawing part+			   return a++    annotPaths = Map.fromList . map swap . drawingAnnots++mouseClicksSP = mapFilterSP isMouseClick++isMouseClick msg =+    case msg of+      GfxButtonEvent { gfxType=Pressed, gfxPaths=(path,_):_ } -> Just path+      _ -> Nothing++---++mapGfxCommandPath f cmd =+    case cmd of+      ChangeGfx changes -> ChangeGfx (mapFst f changes)+      ShowGfx path a -> ShowGfx (f path) a+      GetGfxPlaces paths -> GetGfxPlaces (map f paths)+      -- _ -> cmd -- Operationally, the rest is the same as this line.+      ChangeGfxBg c -> ChangeGfxBg c+      ChangeGfxBgPixmap pm b -> ChangeGfxBgPixmap pm b+#ifdef USE_EXIST_Q+      ChangeGfxBgGfx gfx -> ChangeGfxBgGfx gfx+#endif+      ChangeGfxCursor cursor -> ChangeGfxCursor cursor+      ChangeGfxFontCursor shape -> ChangeGfxFontCursor shape+      BellGfx n -> BellGfx n+++mapGfxEventPath f event =+  case event of+    GfxButtonEvent t s ty b ps -> GfxButtonEvent t s ty b (mapPaths ps)+    GfxMotionEvent t s ps   -> GfxMotionEvent t s (mapPaths ps)+    GfxKeyEvent t m k l     -> GfxKeyEvent t m k l+    GfxFocusEvent b         -> GfxFocusEvent b+    GfxPlaces rs            -> GfxPlaces rs+    GfxResized s            -> GfxResized s+  where+    -- mapPats :: [(a,(Point,Rect))] -> [(b,(Point,Rect))]+    mapPaths = mapMaybe f'+    -- f' :: (a,(Point,Rect)) -> Maybe (b,(Point,Rect))+    f' (path,place) = fmap (\p->(p,place)) (f path)++-- nullPath = null . gfxPaths -- would be ok if gfxPaths was a total function+nullPath = maybe False null . gfxEventPaths++gfxEventPaths event =+  case event of+    -- enumerate all constructors that have a path argument:+    GfxButtonEvent {gfxPaths=ps} -> Just ps+    GfxMotionEvent {gfxPaths=ps}  -> Just ps+    _ -> Nothing++isGfxButtonEvent (GfxButtonEvent {gfxType=Pressed,gfxButton=b}) = Just b+isGfxButtonEvent _ = Nothing
+ Contrib/KeyGfx.hs view
@@ -0,0 +1,34 @@+module KeyGfx(keyGfx) where+import Fudgets+import Data.Char(toUpper)++keyGfx gfx k = hboxD' 12 [g gfx,keyD (keyCap k)]+  where+    keyD c = spacedD (hAlignS aRight `compS` hMarginS 0 3) $+	     hboxD' 0 [diamondD,spacedD alignKeysS $ g c]+    diamondD = spacedD vCenterS $ g $ FlexD 10 False False d+    d (Rect p (Point w h)) = [FillPolygon Convex CoordModeOrigin+		      [p+pP w2 0,p+pP w h2,p+pP w2 h,p+pP 0 h2]]+      where w2 = w `div` 2+	    h2 = h `div` 2++alignKeysS = minSizeS (pP 12 10) `compS` hCenterS+  -- This is a hack to make the keybord shortcuts align nicely in a column.+  -- It assumes that no character is wider than 12 pixels.++--ctrlkey = argFlag "menuctrlkey" False++keyCap k =+  case k of+    [c] -> [toUpper c]+    "period" -> "."+    "comma" -> ","+    "plus" -> "+"+    "minus" -> "-"+    "slash" -> "/"+    "asterisk" -> "*"+    "apostrophe" -> "'"+    "question" -> "?"+    "less" -> "<"+    "greater" -> ">"+    _ -> k -- ??
+ Contrib/LinearSplitP.hs view
@@ -0,0 +1,64 @@+module LinearSplitP where+import AllFudgets+--import ListUtil(chopList)+import HbcUtils(apFst,chopList)+import Data.Maybe(isJust,listToMaybe)++horizontalSplitP = horizontalSplitP' defaultSep+verticalSplitP = verticalSplitP' defaultSep++horizontalSplitP' = linearSplitP Horizontal+verticalSplitP' = linearSplitP Vertical++linearSplitP dir sep = P linearSplitP'+  where+    linearSplitP' [] = linearP' []+    linearSplitP' [r] = linearP' [r]+    linearSplitP' reqs0 = (req,placer2)+      where+        reqss = chopReqs reqs0+        (reqs1,placers2) = unzip (fmap linearP' reqss)+	--reqs2 = zipWith adjSize (sizes reqss) reqs1+	(req,placer2a) = linearP' reqs1+	positions = fmap ( \ r->listToMaybe r >>= wantedPos) reqss+	placer2 r@(Rect _ s) =+ 	  concat . zipWith id placers2 . adjPlaces s positions . placer2a $ r++    adjPlaces asize (_:ps) (r:rs) = adjPlaces' ps r rs+      where+	adjPlaces' (optp:ps) r1@(Rect p1 s1) (r2@(Rect p2 s2):rs) =+	  case optp of+	    Nothing -> r1:adjPlaces' ps r2 rs -- shouldn't happen+	    Just (p0,s,a) -> r1' : adjPlaces' ps r2' rs+	      where v = mkp dir d 0+	             where+		       d = max 1 (d0+d1)-d1 -- try to avoid sizes <= 0+		       d0 = xc dir p-xc dir (rectpos r2)+		       d1 = xc dir s1+		    p = p0 + scalePoint a (asize-s)+		    r1' = Rect p1 (s1+v)+		    r2' = Rect (p2+v) (s2-v)+	adjPlaces' [] r [] = [r]+++    chopReqs = chopList splitReqs++    splitReqs (r:rs) = apFst (r:) (break wantPos rs)+    splitReqs [] = ([],[])++    wantPos = isJust . wantedPos++    linearP' = unP (linearP dir sep)++    {-+    adjSize Nothing req = req+    adjSize (Just s1) req@(Layout{minsize=s2}) =+        req{minsize=size, wAdj=const size, hAdj=const size}+      where size = mkp dir (xc dir s1) (yc dir s2)++    sizes = sizes' . (Just 0:) . tail . positions+    sizes' ps = zipWith size ps (tail ps++[Nothing])+      where size optp1 optp2 = do p1 <- optp1+                                  p2 <- optp2+				  return (p2-p1-mkp dir sep 0)+    -}
+ Contrib/MenuBarF.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE CPP #-}+module MenuBarF(+#ifndef __NHC__+	menuF,menuBarF,MenuBar(..),Menu(..),MenuItem'(..),+	Item,item,item',key,itemValue,+	cmdItem,subMenuItem,toggleItem,sepItem,+	radioGroupItem,dynRadioGroupItem,+	delayedSubMenuItem,+	MenuItem(..),menu,Transl(..),idT,compT,+	menuIcon+#endif+  ) where+import Control.Monad((<=<))+import AllFudgets hiding (menuF)+import HbcUtils(mapFst)+--import MonadUtil((@@))+import DynRadioGroupF+import KeyGfx++#ifndef __NHC__+#include "../hsrc/exists.h"++tr x = ctrace "menubar" x x++--- Top level calls, eta expanded because of the monomorphism restriction+menuBarF menu = menuListF Horizontal menu+menuF menu =  menuListF Vertical menu++type MenuBar a = Menu a+type Menu a = [MenuItem' a]+type Keys = [(ModState,KeySym)]++type MenuItem' a = Item (MenuItem a)++data Item a = Item a Gfx Keys+item i = item' [] i -- eta expanded because of the monomorphism restriction+item' k i g = Item i (G g) k+itemValue  (Item a _ _) = a++key (Item a g _) k = Item a (G (keyGfx g k)) [([metaKey],k)]+			-- this creates some unnecessary nested G (G ..)++instance Graphic (Item a) where+  measureGraphicK (Item _ gfx _) = measureGraphicK gfx++instance Eq a => Eq (Item a) where+  Item x _ _ == Item y _ _ = x==y++cmdItem x = item . MenuCommand $ x -- eta expanded because of the monomorphism restriction+toggleItem tr = item . MenuToggle tr+subMenuItem tr = item . SubMenu False tr+delayedSubMenuItem tr = item . SubMenu True tr+radioGroupItem tr items = item . MenuRadioGroup tr items+dynRadioGroupItem tr items = item . MenuDynRadioGroup tr items+sepItem = item MenuLabel (padD 3 $ g $ hFiller 1)++data MenuItem a+  = MenuCommand a+  | MenuToggle (Transl Bool a) Bool+  | EXISTS(b) (Eq EQV(b)) => MenuRadioGroup (Transl EQV(b) a) [Item EQV(b)] EQV(b)+  | EXISTS(b) (Eq EQV(b)) => MenuDynRadioGroup (Transl ([Item EQV(b)],EQV(b)) a) [Item EQV(b)] EQV(b)+  | EXISTS(b) (Eq EQV(b)) => SubMenu Bool (Transl EQV(b) a) (Menu EQV(b))+  | MenuLabel++-- eta expanded because of the monomorphism restriction:+menu t = SubMenu False t++type MMsg a = Either MenuState a+type MF a b = F (MMsg a) (MMsg b)++data Transl l g = Transl (l->g) (g->Maybe l)++--- +menuItemF :: Eq a => LayoutDir -> MenuItem' a -> MF a a+menuItemF dir (Item item gfx keys) =+  case item of+    MenuCommand a -> translF (click a) (buttonF' (setAlign aLeft . pm) gfx)+    MenuToggle tr init ->+	translF tr (delayItF>==<startupF [init] (toggleButtonF' pm gfx))+    MenuRadioGroup tr items init ->+	translF tr (delayItF>==<gfx `labAboveF` radioGroupF' pm alts init)+      where alts = [(a,g)|Item a g _<-items]+	    pm = setFont menuFont .+		 setPlacer (verticalP' 0) -- (the default is verticalLeftP' 0)+    MenuDynRadioGroup tr items init ->+	translF tr' (delayItF>==<gfx `labAboveF` dynRadioGroupF' pm alts init)+      where alts = [(a,g)|Item a g _<-items]+	    pm = setFont menuFont .+		 setPlacer (verticalP' 0) -- (the default is verticalLeftP' 0)+	    tr' = compT tr dynRadioT+	    dynRadioT = Transl f g+	      where+	        f (alts,alt) = ([Item i g []|(i,g)<-alts],alt)+		g (items,alt) = Just ([(a,g)|Item a g _<-items],alt)++    SubMenu d tr m  -> translMenuF tr (btnMenuF d dir gfx ({-delayF' d $-} subMenuF m))+    MenuLabel     -> graphicsLabelF gfx+--    MenuDelayed item' -> delayF' $ menuItemF dir (Item item' gfx keys)+  where+    --pm = setKeys keys . setFont menuFont+    -- becuase of the mononorphism restriction:+    pm x = setKeys keys . setFont menuFont $ x++{-+    delayF' delayed =+      if delayed+      then delayF''+      else id++    delayF'' fud =+      if argFlag "teemenu" False+      then delayF fud >==< idRightF (teeF show "menuItemF: ")+      else delayF fud+-}++btnMenuF :: Bool -> LayoutDir -> Gfx -> F (MMsg a) a -> MF a a+btnMenuF delayed dir gfx mF =+    buttonMenuF' delayed dir menuFont agfx [] mF >=^< mapEither id Right+  where+    agfx = hboxcD' 3 [g gfx,g menuIcon]++translF (Transl f g) fud =+  Right . f >^=< fud >=^^< mapFilterSP (either (const Nothing) g)++translMenuF (Transl f g) fud =+  mapEither id f >^=< fud >=^^< idLeftSP (mapFilterSP g)++click a = Transl (const a) (\b->if a==b then Just Click else Nothing)+idT = Transl id (const Nothing)+--idT = Transl id Just -- why not this?+compT (Transl f1 g1) (Transl f2 g2) = Transl (f1 . f2) (g2 <=< g1)++-- There should be only one grabberF outside the top level menu.+menuListF :: Eq a => LayoutDir -> Menu a -> F a a+menuListF dir menu = grabberF (menuKeys menu) $ menuListF' dir menu+  where+    menuKeys :: Menu a -> [(a,Keys)]+    menuKeys = concatMap itemKeys+    itemKeys (Item m _ keys) =+	case m of+	  SubMenu _ (Transl f _) menu -> mapFst f (menuKeys menu)+	  MenuRadioGroup (Transl f _) items init ->+	    [(f a,ks)|Item a _ ks<-items]+	  --MenuCommand cmd -> [(cmd,keys)]+	  --MenuToggle (Transl f _) init -> [(f init,keys)] -- hmm+	  _ -> []++subMenuF :: Eq a => Menu a -> F (MMsg a) a+subMenuF menu = filterRightSP >^^=< menuListF' Vertical menu++menuListF' :: Eq a => LayoutDir -> Menu a -> MF a a+menuListF' dir m =+    loopLeftF $+    concatMapSP post >^^=< placerF (linearP dir 0) (listF nms)+    >=^^< concatMapSP pre+  where+    nms = [(i,menuItemF dir e) | (i,e) <- number 0 m]+    ns = map fst nms+    post (i,Right x) = [Right $ Right x]+    post (i,Left b) = [Right $ Left b,Left (i,b)]+    pre (Right (Right x)) = ctrace "menubar" "got input" [(i,Right x) | i<-ns]+    pre (Right (Left b)) =  [(i,Left b) | i<-ns]+    pre (Left (j,b)) = [(i,Left b) | i<-ns, i/=j]++delayItF = idF+{-+delayItF = loopThroughRightF (absF idleSP) timerF+  where+    idleSP = getSP $ either (const idleSP) delaySP+    delaySP x = putSP (Left (Just (0,delay))) $ waitSP x+    waitSP x = getSP $ either doneSP waitSP+      where doneSP _ = putSP (Left Nothing) $ putSP (Right x) idleSP++    delay = argReadKey "delay" 200+-}++--- temporary hack:+{-+--subMenuF gfx mF = menuPopupF mF >==< throughF (buttonF agfx>=^^<nullSP)+menuPopupF mF =+    post >^=<+    inputPopupF "Menu" (inputMsg>^=<mF>=^^<filterRightSP) Nothing+     >=^< pre+  where+    pre cmd = (Nothing,Just cmd)+    post = snd+-}++menuIcon =+  FixD 12 [+    DrawRectangle (rR 1 0 8 10),+    DrawLine (lL 4 3 6 3),+    DrawLine (lL 4 5 6 5),+    DrawLine (lL 4 7 6 7),+    DrawLine (lL 3 11 10 11),+    DrawLine (lL 10 2 10 11)]+    ++#endif
+ Contrib/MeterF.hs view
@@ -0,0 +1,33 @@+module MeterF where+import AllFudgets+import Data.Ratio++meterF :: RealFrac v => InF v (Ratio Int) -- because of the monomorphism restr+meterF = meterF' standard++meterF' pm =+   post >^^=< border3dF True 1 (graphicsDispF' params) >=^< pre+ where+   params = pm .+	    --setSizing Static .+	    --setGfxEventMask [GfxButtonMask,GfxDragMask] .+	    setBgColor meterBg .+	    setFgColorSpec meterFg .+	    setBorderWidth 0+   pre = Right . replaceAllGfx . meterD+   post = mapFilterSP pick+   pick (GfxButtonEvent {gfxType=Pressed,gfxPaths=p:_}) = change p+   pick (GfxButtonEvent {gfxType=Released,gfxPaths=p:_}) = done p+   pick (GfxMotionEvent {gfxPaths=p:_}) = change p+   pick _ = Nothing+   change = Just . inputChange . extr+   done = Just . inputMsg . extr+   extr (_,(p,Rect p0 s)) = xcoord (p-p0) % xcoord s++meterD r = FlexD (Point 50 5) False True drawfun+  where+    drawfun (Rect p (Point w h)) = [FillRectangle (Rect p (Point w' h))]+      where w' = scale r w++meterFg = colorSpec $ argKeyList "meterfg" ["blue2",fgColor,"black"]+meterBg = colorSpec $ argKeyList "meterbg" [bgColor,"white"]
+ Contrib/ReactionM.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE CPP #-}+module ReactionM where+import Data.Maybe(isJust)+import Control.Applicative+import Control.Monad(ap)+#if MIN_VERSION_base(4,12,0)+#if MIN_VERSION_base(4,13,0)+#else+import Control.Monad.Fail+#endif+#endif++-- | Writer & State & Exception monad+newtype ReactionM s o a = M (s -> [o] -> Maybe (s,[o],a))++instance Functor (ReactionM s o) where+  fmap f m = do x <- m; return (f x)++instance Applicative (ReactionM s o) where+  pure = return+  (<*>) = ap++instance Monad (ReactionM s o) where+  return x = M (\s o->Just (s,o,x))+  (M f1) >>= xm2 =+    M $ \ s0 o0 ->+      let r1 = f1 s0 o2+          Just (s1,o1,x1) = r1+          M f2 = xm2 x1+	  r2 = f2 s1 o0+	  Just (s2,o2,x2) = r2+      in if isJust r1 && isJust r2+         then Just (s2,o1,x2)+	 else Nothing+#if MIN_VERSION_base(4,12,0)+instance MonadFail (ReactionM s o) where+#endif+  fail _ = rfail++react (M f) s0 = case f s0 [] of Just (s,o,_) -> (s,o); _ -> (s0,[])+put o = M $ \ s os -> Just (s,o:os,())+set s = M $ \ _ os -> Just (s,os,())+get = M $ \ s os -> Just (s,os,s)+field f = f <$> get+update f = M $ \ s os -> Just (f s,os,())++rfail = M $ \ _ _ -> Nothing++lift m = maybe rfail return m+nop = return ()+nop :: Monad m => m ()
+ Contrib/ReactiveF.hs view
@@ -0,0 +1,9 @@+-- | Program stateful abstract fudgets in a monadic style+module ReactiveF(reactiveF,reactiveSP,module ReactionM) where+import Fudgets+import ReactionM++reactiveF  = mapstateF  . mf+reactiveSP = mapstateSP . mf++mf rM s m = react (rM m) s
+ Contrib/ShapedButtonsF.hs view
@@ -0,0 +1,298 @@+module ShapedButtonsF (radioF1, radioGroupF1, toggleF1, toggleButtonF1, RBBT (..)) where+import AllFudgets+import HbcUtils(lookupWithDefault)++data RBBT = Circle | Square | Triangle+type RadioButtonBorderType = RBBT++radioF1 bbt fname alts startalt =+    radioGroupF1 bbt fname (map fst alts) startalt +      (lookupWithDefault alts (error "radioF"))++radioGroupF1 :: Eq a => RadioButtonBorderType -> FontName -> [a] -> a -> +                        (a -> String) -> F a a+radioGroupF1 bbt fname alts startalt show_alt =+    let radioAlts = radioButtonsF1 bbt fname alts show_alt+        buttons = radioAlts >=^< stripEither+    in  loopLeftF (excludeF1 startalt >==< buttons) >=^<+        (\x -> pair x True)++radioButtonsF1 bbt fname alts show_alt =+    let radiobutton alt =+            (+             alt,+             noStretchF False True +               (toggleButtonF1 bbt fname [] (show_alt alt))+            )+    in  listLF (verticalP' 0) (map radiobutton alts)++excludeF1 start =+    let excl last' =+            let same = excl last'+                cont last'' = excl last''+            in  getSP (\msg ->+                       case msg of+                         (new, False) -> if new == last' then+                                             putsSP [Left (new, True)] (cont new)+                                         else+                                             same+                         (new, True) -> if new == last' then+                                            putsSP [Right new] (cont new)+                                        else+                                            putsSP [Left (last', False), Right new]+                                                  (cont new))+    in  absF (putsSP [Left (start, True)] (excl start))++toggleF1 bbt keys f =+  case bbt of+    Square ->+      let edgew = 3+          dsize = Point 10 10+          innersep = 3+          fudgetsep = 5+          toggleK =+              let cid False = 0+                  cid True = 1+              in  allocNamedColorPixel defaultColormap+                                  onColor1+                                  (\onC ->+                                   allocNamedColorPixel defaultColormap+                                                   offColor1+                                                   (\offC ->+                                                    let toggle s =+                                                            map (Low . XCmd)+                                                                [ChangeWindowAttributes [CWBackPixel (if s then onC else offC)],+                                                                 ClearWindow]+                                                        k (High s) = toggle s+                                                        k _ = []+                                                    in  putsK (Low (layoutRequestCmd (plainLayout dsize True True)) :+                                                              toggle False)+                                                             (K $ concmapSP k)))+          toggleb =+                buttonBorderF1 bbt edgew+                              (marginF innersep+                                    (windowF [{-ConfigureWindow [CWBorderWidth 0]-}] toggleK))+          togglebd =+              let post (Left a) = Left a+                  post (Right b) = stripEither b+              in  stripEither >^=<+                  (marginHVAlignF 0 aCenter aCenter toggleb >+#<+                   (fudgetsep, LeftOf, f))+      in  toggleGroupF keys (marginHVAlignF 0 aLeft aCenter togglebd)+    Triangle ->+      let edgew = 3+          dsize = Point 12 12+          innersep = 6+          fudgetsep = 5+          toggleK =+              let cid False = 0+                  cid True = 1+              in  allocNamedColorPixel defaultColormap+                                  onColor1+                                  (\onC ->+                                   allocNamedColorPixel defaultColormap+                                                   offColor1+                                                   (\offC ->+                                                    let toggle s =+                                                            map (Low . XCmd)+                                                                [ChangeWindowAttributes [CWBackPixel (if s then onC else offC)],+                                                                 ClearWindow]+                                                        k (High s) = toggle s+                                                        k _ = []+                                                    in  putsK (Low (layoutRequestCmd (plainLayout dsize True True)) :+                                                              toggle False)+                                                             (K $ concmapSP k)))+          vormT punt = [FillPolygon Nonconvex CoordModeOrigin [origin, padd origin (Point 0 ((ycoord punt)-1)),+                        padd origin (Point ((xcoord punt)-1) (((ycoord punt)`div`2)-1))]]+          toggleb =+                buttonBorderF1 bbt edgew+                              (marginF innersep+                                    (windowF [{-ConfigureWindow [CWBorderWidth 0]-}]+                                              (shapeK vormT toggleK)))+          togglebd =+              let post (Left a) = Left a+                  post (Right b) = stripEither b+              in  stripEither >^=<+                  (marginHVAlignF 0 aCenter aCenter toggleb >+#<+                   (fudgetsep, LeftOf, f))+      in  toggleGroupF keys (marginHVAlignF 0 aLeft aCenter togglebd)+    Circle ->+      let edgew = 3+          dsize = Point 16 16+          innersep = 2+          fudgetsep = 5+          toggleK =+              let cid False = 0+                  cid True = 1+              in  allocNamedColorPixel defaultColormap+                                  onColor1+                                  (\onC ->+                                   allocNamedColorPixel defaultColormap+                                                   offColor1+                                                   (\offC ->+                                                    let toggle s =+                                                            map (Low . XCmd)+                                                                [ChangeWindowAttributes [CWBackPixel (if s then onC else offC)],+                                                                 ClearWindow]+                                                        k (High s) = toggle s+                                                        k _ = []+                                                    in  putsK (Low (layoutRequestCmd (plainLayout dsize True True)) :+                                                              toggle False)+                                                             (K $ concmapSP k)))+          vormC punt = [FillArc (Rect origin (Point ((xcoord punt)-1) ((ycoord punt)-1))) (0*64) (360*64)]+          toggleb =+                buttonBorderF1 bbt edgew+                              (marginF innersep+                                    (windowF [{-ConfigureWindow [CWBorderWidth 0]-}]+                                             (shapeK vormC toggleK)))+          togglebd =+              let post (Left a) = Left a+                  post (Right b) = stripEither b+              in  stripEither >^=<+                  (marginHVAlignF 0 aCenter aCenter toggleb >+#<+                   (fudgetsep, LeftOf, f))+      in  toggleGroupF keys (marginHVAlignF 0 aLeft aCenter togglebd)++toggleButtonF1 :: RadioButtonBorderType -> String -> [(ModState, KeySym)] -> String -> F Bool Bool+toggleButtonF1 bbt fname keys text =+  stripEither >^=<+  toggleF1 bbt keys (noStretchF True True (labelF' (setFont fname) text))+  >=^< Left++offColor1 = argKey "toggleoff" bgColor++onColor1 = argKey "toggleon" fgColor++buttonBorderF1 :: RadioButtonBorderType -> Int -> (F a b) -> F (Either Bool a) b+buttonBorderF1 = stdButtonBorderF1++stdButtonBorderF1 bbt edgew f =+    let kernel =+          allocNamedColorDefPixel defaultColormap shineColor "white" $ \shine ->+          allocNamedColorDefPixel defaultColormap shadowColor "black" $ \shadow ->+          wCreateGC rootGC [GCFunction GXcopy, GCForeground shadow,+                            GCBackground shine] $ \drawGC ->+          wCreateGC rootGC [GCFunction GXcopy, GCForeground shine, GCBackground shine] $ \extraGC ->+          wCreateGC rootGC (invertColorGCattrs shine shadow) $ \invertGC ->+          let+              dRAWS s =+                    let bpx = edgew+                        bpy = edgew+                        upperLeftCorner = Point bpx bpy+                        size@(Point sx sy) = psub s (Point 1 1)+                        rect = Rect origin size+                        upperRightCorner = Point (sx - bpx) bpy+                        lowerLeftCorner = Point bpx (sy - bpy)+                        lowerRightCorner = psub size upperLeftCorner+                        leftBorder = Line upperLeftCorner lowerLeftCorner+                        upperBorder = Line upperLeftCorner upperRightCorner+                        upperLeftLine = Line origin upperLeftCorner+                        lowerRightLine = Line lowerRightCorner size+                        incx = padd (Point 1 0)+                        incy = padd (Point 0 1)+                        decx = padd (Point (-1) 0)+                        decy = padd (Point 0 (-1))+                        lowerBorderPoints = [lowerLeftCorner, lowerRightCorner,+                                             upperRightCorner, Point sx 0, size, Point 0 sy]+                        borderPoints =+                          [pP 1 1, pP 1 sy, size, pP sx 1, origin, upperLeftCorner,+                           incy lowerLeftCorner, (incx . incy) lowerRightCorner,+                           incx upperRightCorner, upperLeftCorner]+                        rectPoints = [origin, padd origin (Point (sx-1) 0), size, padd origin (Point 0 (sy-1))]+                    in  (map Low [+                                  wFillPolygon extraGC Convex CoordModeOrigin rectPoints,+                                  wFillPolygon drawGC Nonconvex CoordModeOrigin lowerBorderPoints,+                                  wDrawLine drawGC leftBorder,+                                  wDrawLine drawGC upperBorder,+                                  wDrawLine drawGC upperLeftLine,+                                  wDrawLine invertGC lowerRightLine,+                                  wDrawRectangle drawGC rect+                                 ],+                                 [Low (wFillPolygon invertGC Nonconvex CoordModeOrigin borderPoints)])+              dRAWT s =+                    let bpx = edgew+                        bpy = edgew+2+                        upperLeftCorner = Point bpx bpy+                        size@(Point sx sy) = psub s (Point 1 1)+                        ap = padd origin (Point 5 2)+                        bp = padd origin (Point 5 (sy-3))+                        cp = Point (sx) (((sy - bpy)`div`2)+2)+                        dp = padd ap (Point bpx bpy)+                        ep = padd bp (Point bpx (-bpy))+                        fp = psub cp (Point (bpx+4) 0)+                        l1 = Line ap bp+                        l2 = Line bp cp+                        l3 = Line cp ap+                        l4 = Line dp ep+                        l5 = Line ep fp+                        l6 = Line fp dp+                        l7 = Line ap dp+                        l8 = Line bp ep+                        l9 = Line cp fp+                        incx = padd (Point 1 0)+                        incy = padd (Point 0 1)+                        decx = padd (Point (-1) 0)+                        decy = padd (Point 0 (-1))+                        tBorderPoints = [(incx . incy) ap, decy bp, decx cp, (incx . incy) ap, dp, fp, ep, dp]+                        tLowerBorderPoints = [ep,bp,cp,fp]+                        trianglePoints = [ap,bp,cp]+                    in  (map Low [+                                  wFillPolygon extraGC Nonconvex CoordModeOrigin trianglePoints,+                                  wFillPolygon drawGC Nonconvex CoordModeOrigin tLowerBorderPoints,+                                  wDrawLine drawGC l1,+                                  wDrawLine drawGC l2,+                                  wDrawLine drawGC l3,+                                  wDrawLine drawGC l4,+                                  wDrawLine drawGC l5,+                                  wDrawLine drawGC l6,+                                  wDrawLine drawGC l7,+                                  wDrawLine drawGC l8,+                                  wDrawLine drawGC l9+                                 ],+                                 [+                                  Low (wFillPolygon invertGC Nonconvex+                                  CoordModeOrigin tBorderPoints)+                                 ])+              dRAWC s =+                    let bpx = edgew+                        bpy = edgew+                        upperLeftCorner = Point bpx bpy+                        size@(Point sx sy) = psub s (Point 1 1)+                        groteRechthoek = Rect origin size+                        groteRechthoek2 = Rect (psub origin (Point 1 1)) size+                        kleineRechthoek = Rect (padd origin (Point edgew edgew)) (Point (sx-(2*edgew)) (sy-(2*edgew)))+                    in  (map Low [+                                  wFillArc extraGC groteRechthoek (0*64) (360*64),+                                  wFillArc drawGC groteRechthoek (-135*64) (180*64),+                                  wDrawArc drawGC groteRechthoek (0*64) (360*64),+                                  wFillArc extraGC kleineRechthoek (0*64) (360*64),+                                  wDrawArc drawGC kleineRechthoek (0*64) (360*64)+                                 ],+                                 [Low (wFillArc invertGC groteRechthoek2 (0*64) (360*64))])+              proc pressed size =+                  getK $ \bmsg ->+                  let same = proc pressed size+                      (drawit_size, pressit_size) = case bbt of+                                                      Square -> dRAWS size+                                                      Triangle -> dRAWT size+                                                      Circle -> dRAWC size+                      redraw b = if (b == pressed) then [] else pressit_size+                  in  case bmsg of+                        Low (XEvt (Expose _ 0)) -> putsK (drawit_size +++                            (if pressed then pressit_size else [])) same+                        Low (LEvt (LayoutSize newsize)) -> proc pressed newsize+                        High change -> putsK (redraw change) (proc change size)+                        _ -> same+              proc0 pressed =+                  getK $ \msg ->+                  case msg of+                    Low (LEvt (LayoutSize size)) -> proc pressed size+                    High change -> proc0 change+                    _ -> proc0 pressed+          in  proc0 False++        startcmds =+          [XCmd $ ConfigureWindow [CWBorderWidth 0],+           XCmd $ ChangeWindowAttributes [CWEventMask [ExposureMask]]]+    in  stripEither >^=< (((groupF startcmds (changeBg bgColor kernel)) . marginF (edgew + 1)) f)+
+ Contrib/SmileyF.hs view
@@ -0,0 +1,28 @@+module SmileyF where+import Fudgets++data SmileyMode = Sad | Indifferent | Happy deriving (Eq,Ord,Enum,Show)++smileyF = smileyF' standard++smileyF' :: Customiser (DisplayF SmileyMode) -> F SmileyMode void+smileyF' pm = displayF' pm'+  where pm' = pm .+	      setInitDisp Indifferent .+	      setInitSize Indifferent .+	      setStretchable (False,False) .+	      (setMargin 1 :: (Customiser (DisplayF SmileyMode)))++smileyD mode =+  FixD (Point 15 15) [+    drawCircle (Point 2 2) 2,	-- eye+    drawCircle (Point 10 2) 2,	-- eye+    DrawLine (lL 7 5 7 9),	-- nose+    case mode of+      Sad -> DrawArc (rR 3 11 8 4) 0 (64*180)		-- mouth+      Indifferent -> DrawLine (lL 3 12 11 12)		-- mouth+      Happy -> DrawArc (rR 3 9 8 4) (64*180) (64*180)	-- mouth+  ]++instance Graphic SmileyMode where+  measureGraphicK = measureGraphicK . smileyD
+ Contrib/SocketServer.hs view
@@ -0,0 +1,41 @@+module SocketServer(ClientMsg(..),SocketMsg(..),mapSocketMsg,socketServerF) where+import AllFudgets+import DialogueIO hiding (IOError)++data ClientMsg a = ClientMsg a | ClientEOS | ClientNew deriving (Show)+data SocketMsg a = SocketMsg a | SocketEOS deriving (Show)++mapSocketMsg f (SocketMsg a) = SocketMsg (f a)+mapSocketMsg f SocketEOS = SocketEOS++instance Functor SocketMsg where fmap = mapSocketMsg++socketServerF port f = +    loopThroughRightF (concatMapF router) (listenerF >+< dynListF)+  where+    router = either (either fromListener fromDynList) fromOutside+      where+	fromListener (i,f) = [todyn (i,DynCreate f), out (i,ClientNew)]++	fromDynList (i,m) =+	  case m of+	    SocketMsg m' -> [out (i,ClientMsg m')]+	    SocketEOS    -> [out (i,ClientEOS), todyn (i,DynDestroy)]++	fromOutside (i,m) = [todyn (i,DynMsg m)]++        todyn = Left . Right+	out = Right++    listenerF =+        openLSocketF port $ \lsocket ->+	select [LSocketDe lsocket] $+	accepter 0+      where+	accepter i = +	  getMessageFu $ \e ->+	  case e of+	    Low (DResp (AsyncInput (_,SocketAccepted socket peer))) ->+		  putF (i,f socket peer) $+		  accepter (i+1)+	    _ -> accepter i
+ Contrib/SplitF.hs view
@@ -0,0 +1,39 @@+module SplitF where+import AllFudgets+import HandleF(vHandleF,hHandleF)+import LinearSplitP(linearSplitP)++hSplitF = hSplitF' aCenter+vSplitF = vSplitF' aCenter++hSplitF' = splitF' Horizontal+vSplitF' = splitF' Vertical++splitF' dir alignment fud1 fud2 =+    loopCompThroughRightF $+    groupF startcmds sizeK $+    placerF (linearSplitP dir defaultSep) $+    fud1>+<hF>+<fud2+  where+    startcmds = [XCmd $ ChangeWindowAttributes [CWBackPixmap parentRelative]]++    hF = colinear dir hHandleF vHandleF alignment++    toLoop = Just . High . Left+    out = Just . High . Right+    toHandle = toLoop . Left . Right+    toFud1 = toLoop . Left . Left+    toFud2 = toLoop . Right++    sizeK = K (mapFilterSP route)+    route = message low high++    low (LEvt (LayoutSize size)) = toHandle size+    low event = ignore event+    +    high = either fromLoop (either toFud1 toFud2)+    fromLoop = either (either fromFud1 ignore) fromFud2+    fromFud1 = out . Left+    fromFud2 = out . Right++    ignore _ = Nothing
+ Contrib/SuperMenuF.hs view
@@ -0,0 +1,239 @@+module SuperMenuF (superMenuF, MenuItem (..)) where+--module SuperMenuF where+import AllFudgets+import Data.Maybe(fromJust) --,fromMaybe+import HbcUtils(breakAt)++data MenuItem a =+       Item a+       | Submenu (String, [MenuItem a])+       deriving (Eq, Ord, Show)++data MenuTag a =+       ItemTag a+       | SubTag String+       deriving (Eq, Ord)++data PopupSubMenu =+       PopupSub Point+       | PopdownSub+          +mainTag = SubTag "Joost Bossuyt"++modstate = []++mousebutton = Button 1++menuButtonF1 gcs optrect text =+  let mask =+        [EnterWindowMask, LeaveWindowMask, ButtonPressMask, ButtonReleaseMask,+         ExposureMask]+      startcmds =+        [XCmd $ ChangeWindowAttributes [CWEventMask mask, CWBackingStore Always]]+      optsize = fmap rectsize optrect+  in swindowF startcmds+             optrect+             (buttonDisplayK gcs optsize text)++lxcmd = Low . XCmd++buttonDisplayK (drawGC,invertGC,fs) opsize text =+    let Rect spos ssize = string_rect fs text+        margin = Point 3 1+        size =case opsize of+                Just s -> s+                Nothing -> padd ssize (padd margin margin)+        invertitif b size' =+          if b then [Low (wFillRectangle invertGC (Rect origin size'))]+               else []+        drawit state size' =+          let textpos = psub margin spos+          in [lxcmd ClearWindow, Low (wDrawImageString drawGC textpos text)]+                ++ invertitif (state == BMInverted) size'+        buttonproc bstate size' =+          let same = buttonproc bstate size'+              cont b = buttonproc b size'+              redraw b s = putsK (drawit b s) (buttonproc b s)+          in getK $ \bmsg ->+               case bmsg of+                 Low (XEvt (Expose _ 0)) -> redraw bstate size'+                 Low (LEvt (LayoutSize size'')) -> redraw bstate size''+                 Low (XEvt (ButtonEvent _ _ _ _ Released _)) ->+                   putsK (invertitif (bstate == BMInverted) size'+                           ++ [High (BMClick, Nothing)])+                        (cont BMNormal)+                 Low (XEvt (EnterNotify {pos=winpos,rootPos=rootpos})) ->+                   let width = Point (xcoord size') (-1) +                       pos = padd (psub rootpos winpos) width+                   in putsK (invertitif (bstate /= BMInverted) size'+                              ++ [High (BMInverted, Just pos)])+                        (cont BMInverted)+                 Low (XEvt (LeaveNotify {})) ->+                   putsK (invertitif (bstate /= BMNormal) size') (cont BMNormal)+                 _ -> same+    in putsK [Low (layoutRequestCmd (plainLayout size True True))]+            (buttonproc BMNormal size)++menuListF gcs alts show_alt =+  let --show_MenuTag :: MenuTag a -> String+      show_MenuTag x =+        case x of+          ItemTag a -> show_alt a+          SubTag s -> s+      altButton alt = (alt, menuButtonF1 gcs Nothing (show_MenuTag alt))+  in listLF (verticalP' 0) (map altButton alts)++subMenuF gcs optrect alts show_alt =+    let wattrs = [CWEventMask [], CWSaveUnder True, CWOverrideRedirect True]+        startcmds = [lxcmd $ ChangeWindowAttributes wattrs,+	             lxcmd $ ConfigureWindow [CWBorderWidth 1]]+        fudget = menuListF gcs alts show_alt +    in delayF $+       loopCompThroughRightF $+       shellKF' (setMargin 0.setVisible False) (putsK startcmds subMenuK) fudget++subMenuK =+  let popdown = map lxcmd [UnmapWindow]+      popup p = map lxcmd [moveWindow p, MapRaised]+      downK =+        getK (\msg ->+          case msg of+            High (Right (PopupSub p )) -> putsK (popup p) upK+            _ -> downK)+      upK =+        getK (\msg ->+          case msg of+            High (Right PopdownSub) -> putsK popdown downK+            High (Left (alt, (bm, pos))) ->+              putsK [High (Right (alt, (bm, pos)))] upK+            _ -> upK)+  in setFontCursor 110 downK++controlF list = loopCompThroughRightF (kernelF controlK >+< listF list)++controlK ::+  (Eq a) =>K (Either (MenuTag a,(MenuTag a,(BMevents,Maybe Point))) PopupSubMenu)+             (Either (MenuTag a,PopupSubMenu) a)+controlK =+  let proc active =+        getK (\msg ->+          case msg of+            High (Left (tag, (SubTag s, (bm, opoint)))) ->+              (case bm of+                 BMClick ->+                   let oldlist = map (\x -> High (Left (x, PopdownSub))) active+                   in putsK oldlist (proc [])+                 BMInverted ->+                   let (olist, nlist) = breakAt tag active+                       newlist = [SubTag s, tag] ++ nlist+                       oldlist = map (\x -> High (Left (x, PopdownSub))) olist+                       pos = fromJust opoint+                   in putsK (oldlist ++ [High(Left(SubTag s, PopupSub pos))])+                           (proc newlist)+                 _ -> proc active)+            High (Left (tag, (ItemTag a, (bm, opoint)))) ->+              (case bm of+                 BMClick ->+                   let oldlist = map (\x -> High (Left (x, PopdownSub))) active+                   in putsK (oldlist ++ [High (Right a)]) (proc [])+                 BMInverted ->+                   let (olist, nlist) = breakAt tag active+                       newlist = [tag] ++ nlist+                       oldlist = map (\x -> High (Left (x, PopdownSub))) olist+                   in putsK oldlist (proc newlist)+                 _ -> proc active)+            High (Right (PopupSub pos)) ->+              putsK [High (Left (mainTag, PopupSub pos))] (proc [mainTag])+            High (Right PopdownSub) ->+              let oldlist = map (\x -> High (Left (x, PopdownSub))) active+              in putsK oldlist (proc [])+            _ -> proc active)+  in proc []++clickF1 gcs optrect name =+  let topopup = High . Left+      routeClick = Left+      optsize = fmap rectsize optrect+      proc (Low (XEvt (ButtonEvent _ winpos rootpos [] Pressed (Button 1)))) =+          topopup (True, PopupSub (psub rootpos winpos))+      proc (Low (XEvt (ButtonEvent _ _ _ _ Released (Button 1)))) =+          topopup (False, PopdownSub)+      proc (Low (XEvt (LeaveNotify {mode=NotifyUngrab}))) =+          topopup (False, PopdownSub)+      proc (Low msg) = Low msg+      proc (High hi) = High (Right hi)+      wattrs =+        [CWEventMask [ExposureMask, ButtonPressMask, ButtonReleaseMask,+         OwnerGrabButtonMask, LeaveWindowMask, EnterWindowMask]]+      startcmds = [XCmd $ ChangeWindowAttributes wattrs,+                   XCmd $ ConfigureWindow [CWBorderWidth 1]]+      K cdisp = clickDisplayK gcs optsize name+  in swindowF startcmds+             optrect+             (K $ preMapSP cdisp  proc)++clickDisplayK (drawGC,invertGC,fs) optsize name0 =+  let Rect spos ssize = string_rect fs name0+      strsize = string_box_size fs+      margin = Point 3 1+      size = fromMaybe (padd ssize (padd margin margin)) optsize+      invertitif b size' =+        if b+          then [Low (wFillRectangle invertGC (Rect origin size'))]+          else []+      drawname name hi size =+        let textpos = scalePoint 0.5 (size `psub` strsize name) `psub` spos+        in [lxcmd ClearWindow, Low (wDrawImageString drawGC textpos name)]+               ++ invertitif hi size+      buttonproc highlighted size' name =+        let fixpos (PopupSub p) =+              PopupSub (p `padd` pP (-1) (ycoord size'))+            fixpos msg = msg+            same = buttonproc highlighted size' name+            cont b = buttonproc b size' name+            contn n = buttonproc highlighted size' n+            redraw b s = putsK (drawname name b s) (buttonproc b s name)+            newname name' = putsK (drawname name' highlighted size')+                                 (contn name')+        in getK $ \bmsg ->+             case bmsg of+               Low (XEvt (Expose _ 0)) -> redraw highlighted size'+               Low (LEvt (LayoutSize size'')) -> redraw highlighted size''+               Low (XEvt (LeaveNotify {})) ->+                 putsK (invertitif highlighted size') (cont False)+               Low (XEvt (EnterNotify {})) ->+                 putsK (invertitif (not highlighted) size') (cont True)+               High (Left (hi, msg)) ->+                  putsK (invertitif (hi /= highlighted) size' +++                        [High (fixpos msg)])+                       (cont hi)+               High (Right name') -> newname name'+               _ -> same+  in putsK [Low (layoutRequestCmd (plainLayout size True True))]+          (buttonproc False size name0)++superMenuF :: (Eq a) => (Maybe Rect) -> FontName -> String -> [MenuItem a]+                        -> (a -> String) -> F String a+superMenuF oplace fname text alts show_alt =+   safeLoadQueryFont fname $ \fs ->+   allocNamedColorPixel defaultColormap "black" $ \ black ->+   allocNamedColorPixel defaultColormap "white" $ \ white ->+   wCreateGC rootGC [GCFunction GXcopy, GCFont (font_id fs)] $ \drawGC ->+   wCreateGC drawGC (invertColorGCattrs black white) $ \invertGC ->+   let gcs = (drawGC,invertGC,fs)+       parse tag source current done =+        if source == []+          then if current == []+                 then done+                 else done ++ [(tag, subMenuF gcs Nothing current show_alt)]+          else let (x : xs) = source+               in case x of+                    Item y -> parse tag+                                    xs +                                    (current ++ [ItemTag y])+                                    done+                    Submenu (s, z) -> parse tag+                                             xs+                                            (current ++ [SubTag s])+                                            (parse (SubTag s) z [] done)+   in controlF (parse mainTag alts [] []) >==< clickF1 gcs oplace text
+ Contrib/TitleShellF.hs view
@@ -0,0 +1,26 @@+module TitleShellF where+import AllFudgets++titleShellF = titleShellF' standard++--titleShellF' :: Customiser ShellF -> String -> F (Either () i) (Either String o) -> F i o++titleShellF' pm title fud =+    filterRightSP >^^=< wmShellF' pm' title fud >=^< mapEither Left id+  where+    pm' = pm . setDeleteWindowAction (Just DeleteQuit)++wmShellF = wmShellF' standard++wmShellF' pm0 title fud =+    shellKF' pm titleK0 fud+  where pm = setDeleteWindowAction Nothing . pm0+	action = maybe (Just reportK)+	               (fmap action')+		       (getDeleteWindowActionMaybe' pm0)+	  where+	    action' DeleteQuit = exitK+	    action' DeleteUnmap = unmapWindowK++        titleK0 = startupK [High (Left title)] titleK+        titleK = wmK action
+ Contrib/TreeBrowser.hs view
@@ -0,0 +1,144 @@+module TreeBrowser(Tree(..),treeBrowserF',treeDisplayF') where+import AllFudgets hiding (Tree(..))+import qualified ReactiveF as R++data Tree leaf node+  = Leaf leaf+  | Node node [Tree leaf node]+  deriving (Show)+++--treeBrowserF = treeBrowserF standard++treeDisplayF' t = treeBrowserF'' drawStaticTree t+treeBrowserF' t = treeBrowserF'' drawTree t++--treeBrowserF' ::Tree n l -> F (Tree n l) ([n],Maybe l)+treeBrowserF'' drawTree t =+    wCreateGCtx rootGCtx (gcFgA linecolor) $ \ lgc ->+    wCreateGCtx rootGCtx (gcFgA paperColor) $ \ bggc ->+    treeBrowserF''' drawTree (bggc,lgc) t+++treeBrowserF''' drawTree gcs@(bggc,lgc) t =+   loopThroughRightF (R.reactiveF ctrl d0) (graphicsDispF' pm)+  where+    pm1 :: Graphic a => Customiser (GraphicsF a)+    pm1 = setBgColor bgColor . setSizing Dynamic+    pm = pm1 . setInitDisp d0+    d0 = drawTree gs t+    ctrl = either fromLoop fromOutside+      where+	fromOutside t = do let d = drawTree gs t +			   R.set d+			   R.put (toLoop $ replaceAllGfx d)++	fromLoop gfxevent =+	  do (path,lbl) <- clickedpart gfxevent+	     case lbl of+	       Left vis -> toggle path (not vis)+	       Right part -> R.put (toOutside part)++	toggle path vis =+	  do (ppath,LabelD rt@(Right (Node n _))+	                   (ComposedD _ (_:ds))) <- parentpathpart path+	     let td' = LabelD rt (nodeD gs vis n ds)+	     R.update $ \ d -> replacePart d ppath td'+	     R.put (toLoop $ replaceGfx ppath td')++    toLoop = Left+    toOutside = Right++    --gd = softAttribD [GCLineStyle LineOnOffDash] . g+    --gd x = g x+    gl = hardAttribD lgc . g+    gbg = hardAttribD bggc . g+    gs = (gbg,gl)++clickedpart gfxevent =+  case gfxevent of+    GfxButtonEvent{gfxType=Pressed, gfxPaths=(path,_):_} -> pathlbl path+    _ -> R.rfail++pathlbl path =+  do (lpath,LabelD lbl _) <- pathpart path+     return (lpath,lbl)++pathpart path =+  do drawing <- R.get+     let lpath = drawingAnnotPart drawing path+     part <- R.lift $ maybeDrawingPart drawing lpath+     return (lpath,part)++parentpathpart = pathpart . up++drawStaticTree gs t = placedD (verticalLeftP' 0) $ drawTree' gs Nothing t+drawTree gs t = placedD (verticalLeftP' 0) $ drawTree' gs opendepthlimit t++staticNodeD gs n ds = boxD (hboxD' 0 [sframeD 3 gs (g n)]:ds)++nodeD gs@(gbg,gl) vis n ds =+    boxVisibleD vcnt (hboxD' 0 [sframeD 3 gs (g n),gl hLineFD,markD]:ds)+  where+    vcnt = 1+(if vis then length ds else 0)+    markD = labelD (Left vis) $ circleD (if vis then g "-" else g "+")++    circleD d =+        spacedD centerS $+	stackD [gbg filledEllipse,gl ellipse,spacedD sqpadS d]+      where sqpadS  = resizeS sq `compS` centerS+	    sq (Point w h) = Point m m where m = max w h++sframeD sep gs d = spacedD (vMarginS sep 0) $ frameD gs d++frameD (gbg,gl) d =+   stackD [gbg $ filler False False 1,gl frame,padD 2 d]+++nodeD' gs Nothing = staticNodeD gs+nodeD' gs (Just d) = nodeD gs (d>0)++drawTree' gs@(_,gl) depth t =+    spacedD leftS $+    labelD (Right t) $+    case t of+      Leaf l -> --hboxD' 0 [gl hLineFD,frameD gs $ g l]+		sframeD 1 gs $ g l+      Node n ts -> nodeD' gs depth n [drawTrees gs (fmap (+(-1)) depth) ts]++drawTrees gs@(_,gl) depth ts = vboxlD' 0 $ zipWith drawSubTree [n-1,n-2..0] ts+  where+    n = length ts+    drawSubTree i t = placedD (tableP' 2 Vertical 0) $+		      boxD [fork i,line i,drawTree' gs depth t]+    --drawSubTree i t = hboxD' 0 [fork i,drawTree' gs depth t]+    fork 0 = gl lowerRightFD+    fork _ = gl forkRightFD+    line 0 = blankD 0+    line _ = gl vLineFD+++---++lowerRightFD = flex' (pP 14 10) f+  where f (Rect p s) =+	    [DrawLines CoordModePrevious [p+pP mw 0,pP 0 mh,pP mw 0]]+	  where Point mw mh = rectMiddle (Rect 0 s)++forkRightFD = flex' (pP 14 10) f+  where f (Rect p s@(Point w h)) =+	    [DrawLine (Line (p+pP mw 0) (p+pP mw h)),+	     DrawLine (Line (p+m) (p+pP w mh))]+	  where m@(Point mw mh) = rectMiddle (Rect 0 s)++vLineFD = flex' (pP 10 1) f+  where f (Rect p s@(Point _ h)) = [DrawLine (Line (p+pP mw 0) (p+pP mw h))]+	  where Point mw _ = rectMiddle (Rect 0 s)++hLineFD = flex' 10 f+  where f (Rect p s@(Point w _)) = [DrawLine (Line (p+pP 0 mh) (p+pP w mh))]+	  where Point _ mh = rectMiddle (Rect 0 s)++linecolor = argKey "linecolor" "blue"+opendepthlimit = argReadKey "opendepthlimit" (Just opendepth) -- not a good name+opendepth = argReadKey "opendepth" 1::Int
+ Contrib/TypedSockets.hs view
@@ -0,0 +1,44 @@+-- | Type-safe network sockets, as described in+-- [Client/Server Applications with Fudgets](http://www.altocumulus.org/Fudgets/ftp/client-server.pdf).+module TypedSockets(TPort,tPort,tSocketServerF,TServerAddress,tServerAddress,tTransceiverF,ClientMsg(..),SocketMsg(..)) where++import Fudgets+import SocketServer+import Debug.Trace+--import DialogueIO hiding (IOError)++newtype TPort a b = TPort Port++tPort :: (Show a, Read a,Show b,Read b) => Port -> TPort a b+tPort p = TPort p++newtype TSocket t r = TSocket Socket+newtype TLSocket t r = TLSocket LSocket+data TServerAddress c s = TServerAddress Host (TPort c s)++tServerAddress host port = TServerAddress host port++tSocketServerF ::+  (Read c, Show s) => +  TPort c s -> (Peer -> F s (SocketMsg c) -> F a (SocketMsg b)) ->+  F (Int, a) (Int, ClientMsg b)+tSocketServerF (TPort p) f = socketServerF p (\ s p -> f p (textTransceiver s))++--texttransceiver :: (Show t,Read r) => Socket -> F t (SocketMsg r)+textTransceiver s = postSP >^^=< transceiverF s >=^< pre+  where+    pre s = shows s "\n"++    postSP = prepostMapSP eos stripEither $+             idLeftSP (mapFilterSP reader -==- inputLinesSP)++    eos "" = Left SocketEOS+    eos s = Right s++    reader s = case reads s of +      [(a,"")] -> Just (SocketMsg a)+      _ -> trace ("No parse from socket: "++s) Nothing++tTransceiverF :: (Show c, Read s) => TServerAddress c s -> F c (SocketMsg s)+tTransceiverF (TServerAddress host (TPort port)) = +   openSocketF host port textTransceiver
+ Demos/Mandelbrot/Explore.hs view
@@ -0,0 +1,82 @@+import AllFudgets+import Data.Array+import Mandelbrot+import ZoomF+import UserCoords+import Control.Parallel+--import Trace++main = fudlogue $ shellF "Mandelbrot Explorer" mainF++mainF =+    allocColorScale $ \ colors ->+    loopCompThroughLeftF (zoomF (dispF colors >=^^< preSP)) >==< resetF+  where+    dispF colors = nullSP>^^=<graphicsDispF >=^< replaceAllGfx . image colors+    resetF = const area0>^=<buttonF "Reset"+    preSP = putSP area0 $ mapstateSP zoom area0+    zoom area = either zoom reset+      where+        reset area' = new area'+	zoom msg =+	  case msg of+	    ZoomIn s p  -> new (zoomin s p area)+	    ZoomOut s p -> new (zoomout s p area)+	    ZoomRect size (Rect p s) ->+	      if s =.> 2+	      then new (zoomrect (size,area) p (p+s))+	      else same+	    _ -> same+	same = (area,[])+	new area' = (area',[area'])++--sizeF = "Size:" `labLeftOfF` startupF [100] intInputF++image :: Array Int Pixel -> Area -> Drawing nothing FlexibleDrawing+image grays area = atomicD (FlexD 700 False False drawfunc)+  where+    drawfunc (Rect p size0@(Point w0 h0)) =+        stripes 5 (CreatePutImage (Rect p size) zPixmap pixels)+      where+	w = min w0 h0+	size = diag w -- keep it square+	pixels = {-parallel-} [grays!g (Point ix iy) | iy <- [0..w-1], ix<-[0..w-1]]+	g = pickColor . mandelbrot . userp (size,area)+	pickColor z = z `mod` colorCount+	rw = real w++-- Color department++-- We interpolate a scale of colors from two specified end colors+allocColorScale return =+    allocNamedColor defaultColormap color1 $ \ (Color _ rgb1) ->+    allocNamedColor defaultColormap color2 $ \ (Color _ rgb2) ->+    conts (allocColorPixelF defaultColormap) (rgbs rgb1 rgb2) $+    return . listArray (0,high)+  where+    rgbs rgb1 rgb2 = [mixRGB rgb1 rgb2 i | i<-[0..high]]+    high = colorCount-1+    mixRGB (RGB r1 g1 b1) (RGB r2 g2 b2) k = RGB (m r1 r2) (m g1 g2) (m b1 b2)+      where m i1 i2 = (i1*(high-k) + i2*k) `div` high++colorCount = argReadKey "colorcount" 16 :: Int+color1 = argKey "color1" "navyblue"+color2 = argKey "color2" "white"++-- Extra++-- stripes splits one big CreatePutImage command into a number of smaller+-- so you don't have wait for the entire image to be computed before you+-- can see anything.+stripes sh dcmd@(CreatePutImage (Rect p (Point w h)) fmt pxls) =+  if h<=sh+  then [dcmd]+  else let rect' = Rect (p+(Point 0 sh)) (Point w (h-sh))+	   (pxls1,pxls2) = splitAt (w*sh) pxls+           ss = stripes sh (CreatePutImage rect' fmt pxls2)+       in par ss $ par (pxls1==pxls1) $+          CreatePutImage (Rect p (Point w sh)) fmt pxls1 :+          ss++parallel [] = []+parallel xxs@(x:xs) = seq (parallel xs) $ par x xxs
+ Demos/Mandelbrot/Mandelbrot.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}+module Mandelbrot where+--import UnsafePerformIO(unsafePerformIO)++area0 = ((-2.0,2.0),(-2.0,2.0))++#if 0+-- The code generated by GHC is about as fast as this:+mandelbrot :: (Double,Double) -> Int+mandelbrot (x0,y0) =+  unsafePerformIO $+  _casm_ ``+    {int n=0;+    double x0=%0,y0=%1,x=0,y=0;+    while(n<200 && x*x+y*y<=4) n++,x=x*x-y*y+x0,y=2*x*y+y0;+    %r=n;+    };'' x0 y0+#else++mandelbrot :: (Double,Double) -> Int+mandelbrot (x0,y0) = m 0 0 0+  where m :: Int -> Double -> Double -> Int+        m n x y = if sqabs x y<= 4 && n< 1024+		  then m (n+1) (x*x-y*y+x0) (2*x*y+y0)+		  else n++	sqabs :: Double -> Double -> Double+	sqabs x y = x*x+y*y++#endif
+ Demos/SpaceInvaders/BitmapOps.hs view
@@ -0,0 +1,44 @@+module BitmapOps(doubleBM,explodeBM,bm,Bitmap(..),E(..),Size,Byte) where+--import AllFudgets(BitmapData(..),Point(..),Size)+--import Data.List.Split(chunksOf)++data Bitmap = Bitmap Size [Byte]+data E = E Size [[Bit]] deriving Eq+type Bit = Bool+type Byte = Int+type Size = (Int,Int)++doubleBM = implodeE . doubleE . explodeBM++doubleE (E (w,h) rows) = E (2*w,2*h) (double (map double rows))++double = foldr (\x r->x:x:r) []++{-+instance Show E where+  show (E _ rows) = unlines [[".*"!!fromEnum b|b<-row]|row<-rows]+  showList = (++) . unlines . map show+-}++explodeBM (Bitmap s@(w,h) bytes) = E s rows+  where+    b = (w+7) `div` 8+    rows = map (take w . concatMap explode) (chunksOf b bytes)++implodeE (E s@(w,h) rows) = Bitmap s bytes+   where+     bytes = concatMap (map implode . chunksOf 8) rows++implode = foldr (\b r->fromEnum (b::Bit)+2*r) 0++explode = take 8.expl+  where+    expl n = (n `mod` 2 /= 0):expl (n `div` 2)++bm w h = Bitmap (w,h)++---++chunksOf n [] = []+chunksOf n xs = xs1:chunksOf n xs2+  where (xs1,xs2) = splitAt n xs
+ Demos/SpaceInvaders/GUI.hs view
@@ -0,0 +1,184 @@+module GUI(Draw(..),HasSize(..),PlacedPict,pp,clear,clearpm,clearRect,wDraw,+           Pict,GCId,objGC,readPict,rectangles,text,+           overlaps,diffRect,message,Move(..),Rect(..),Point(..),pP,lL,Drawing,+           line2rect,inRect,rR,hboxD,atomicD,Click,Tick,+           argReadKey,reactiveSP,+           putLivesMkc,G,putGUI,putsGUI,putLives,putScore,getG,+	   spaceF,spaceF',--nullG,+           shotColor, shelterColor, ufoColor, readObjPict,readObjPicts,+           bmScale,spaceSize,spaceWidth,spaceHeight+           ) where+import Control.Applicative+import AllFudgets hiding (draw,wDraw,size,state,rect,put)+import ReactiveF+import ReadPic+import InvaderTypes+import Metrics++{-+type G i o = K i o++nullG = nullK+putLives l = putK (High (Left l))+putScore s = putK (High (Right s))+putGUI gfx = putK (Low gfx)+putsGUI gfx = putsK (map Low gfx)+-}+type G i o = KSP i o++--nullG = nullSP+putLivesMkc _ l = toMkc $ putSP (High (Left l))+putLives _ l = put (High (Left l))+putScore s = put (High (Right s))+putGUI gfx = put (Low gfx)+putsGUI gfx = mapM_ (put . Low) gfx++spaceF' = spaceF++m = if argFlag "1x" False then metrics1 else metrics2++spaceF initK playK =+    windowF startcmds (changeBg "black" (K playKSP)) >==<idRightF tickF+  where+    playKSP = unMk (initK m) (\ w0 ->playK m w0 `serCompSP` getGSP)+    +    startcmds = [layoutRequestCmd (plainLayout (spaceSize m) True True),+                 XCmd $ ChangeWindowAttributes [CWEventMask eventmask]]+    eventmask = [KeyPressMask,KeyReleaseMask,+                 ButtonPressMask,ButtonReleaseMask,+		 LeaveWindowMask,EnterWindowMask,ExposureMask]++    tickF = startupF [False] (timerF>=^<pre)+      where+        pre True = Nothing+	pre False = Just (dt,dt)++dt = argReadKey "dt" 20::Int++--------------------------------------------------------------------------------++getGSP = getG $ flip putSP getGSP++getG return = loop+  where+    loop = getSP (message low high)++    high = return . High++    retLow = return . Low++    low (XEvt ev) = event ev+    low _ = loop++    event ev =+      case ev of+        Expose r 0     -> retLow Redraw+        ButtonEvent {} -> btn (type' ev) (button ev)+        KeyEvent    {} -> key (type' ev) (keySym ev)+        _              -> loop++    btn Pressed (Button 2) = retLow (Key Fire Down)+    btn pressed (Button 1) = updown pressed MoveLeft+    btn pressed (Button 3) = updown pressed MoveRight+    btn _       _          = loop++    key Pressed "space"   = retLow (Key Fire Down)+    key pressed "Shift_L" = updown pressed MoveLeft+    key pressed "Shift_R" = updown pressed MoveRight+    key pressed "Left"    = updown pressed MoveLeft+    key pressed "Right"   = updown pressed MoveRight+    key pressed "comma"   = updown pressed MoveLeft+    key pressed "period"  = updown pressed MoveRight+--  key Pressed _         = putGUI bell loop+    key _ _               = loop++    updown Pressed  a = retLow (Key a Down)+    updown Released a = retLow (Key a Up)+    updown _        _ = loop++--------------------------------------------------------------------------------++data PlacedPict = PP Pict Point+type Pict = FixedColorDrawing++pp = PP+drawPP (PP (FixCD s gcdcmds) p) = [(gc,move p dcmds)|(gc,dcmds)<-gcdcmds]+drawIt obj = concatMap drawPP (drawing obj)+wDraw obj = wDrawMany (drawIt obj)++class Draw obj where drawing :: obj -> [PlacedPict]++instance Draw obj => Draw [obj] where drawing = concatMap drawing++instance (Draw o1,Draw o2) => Draw (o1,o2) where+  drawing (o1,o2) = drawing o1++drawing o2++instance (Draw o1,Draw o2,Draw o3) => Draw (o1,o2,o3) where+  drawing (o1,o2,o3) = drawing o1++drawing o2++drawing o3++--------------------------------------------------------------------------------+unMkc op ksp = ksp'+  where K ksp' = unMk op (\c->K (ksp c))++objGC fg = Mk $ unMkc (objGC' fg)++objGC' fg =+  do ~(Just bgpixel) <- Mk (tryConvColorK "black")+     ~(Just fgpixel) <- Mk (tryConvColorK [fg,"white"])+     let attrs = [GCBackground bgpixel,GCForeground fgpixel]+     Mk (wCreateGC rootGC (GCGraphicsExposures False:attrs))+++readObjPicts m (obj1,obj2)  = (,) <$> readObjPict m obj1 <*> readObjPict m obj2++readObjPict m obj = flip (readPict m) obj =<< objGC (objectColor obj)++readPict m gc path = pmPict gc <$> readPic' m path++readPic' m path = Mk $ unMkc (readPic m path)++pmPict gc pm@(PixmapImage size _) = FixCD size (copy gc pm 0)++rectangles gc s rs = FixCD s [(gc,map FillRectangle rs)]++text gc s = FixCD (pP (6*length s) 13) [(gc,[DrawString 0 s])] -- !!++clearpm p pict = clear p (size pict)++clear p size = clearRect (Rect p size) False++clearRect r e = XCmd $ ClearArea r e++copy gc pm p = [(gc,[copy' pm p])]+copy' (PixmapImage size pm) p = CopyPlane (Pixmap pm) (Rect origin size) p 0++bell = XCmd (Bell 0)++--------------------------------------------------------------------------------++class HasSize a where size :: a -> Size++instance HasSize PixmapImage where size (PixmapImage s pm) = s+instance HasSize FixedColorDrawing where size (FixCD s _) = s+instance HasSize FixedDrawing where size (FixD s _) = s++--------------------------------------------------------------------------------++objectColor obj =+  case obj of+    Vader r    _ -> vaderColor r+    VExplode r   -> vaderColor r+    VShot      _ -> vshotColor+    Base         -> baseColor+    Explode      -> baseColor+    Ufo          -> ufoColor++baseColor    = argKey "baseColor"    "cyan"+shotColor    = argKey "shotColor"    "lavender"+vshotColor   = argKey "vshotColor"   "orange"+shelterColor = argKey "shelterColor" "yellow"+ufoColor     = argKey "ufoColor"     "grey"++vaderColor r = argKey ("vader"++show (rowNum r)++"Color")  (rowColor r)++rowColor r = case r of R1-> "blue"; R2 -> "green"; R3 -> "red"
+ Demos/SpaceInvaders/InvaderTypes.hs view
@@ -0,0 +1,18 @@+module InvaderTypes where++data GEvent = Redraw | Key Action UpDown+data Action = MoveLeft | MoveRight | Fire+data UpDown = Up | Down++data Phase = A | B  deriving (Eq,Show)+data Row = R1 | R2 | R3 deriving (Eq,Enum,Show)++rows = [R1,R2,R3]+phases f = (f A,f B)++rowNum :: Row -> Int+rowNum = succ . fromEnum++data Object = Vader Row Phase | VExplode Row | VShot Phase+            | Base | Explode | Ufo+            deriving (Eq,Show)
+ Demos/SpaceInvaders/MainF.hs view
@@ -0,0 +1,34 @@+module MainF where+import Fudgets+import AllFudgets(toggleButtonF')+import ScoreF++--{- +mainF worldF = nameLayoutF layout spaceInvadersF+  where+    layout = vBoxNL' 2 [a s,w,hBoxNL [l,n,p]]+      where+        [w,n,p,l,s] = map leafNL ["w","n","p","l","s"]+	a = marginHVAlignNL 0 aRight aTop++    spaceInvadersF = outF>==<nameF "w" worldF>==<inF++    inF = nameF "p" pauseF>+<nameF "n" (buttonF "New")+    pauseF = toggleButtonF' (setKeys [([Control],"p")]) "Pause"++    outF = nameF "l" livesF >+< nameF "s" scoreF++    livesF = displayF' (setBgColor "black" . setFgColor "white")+--}+{-+mainF worldF = spaceInvadersF+  where+    spaceInvadersF = vBoxF (outF>==<worldF (Point 480 390)>==<inF)++    inF = swapEither >^=< hBoxF (buttonF "New" >+< pauseF)+    pauseF = toggleButtonF' (setKeys [([Control],"p")]) "Pause"++    outF = hBoxF (livesF >+< scoreF)++    livesF = displayF' (setBgColor "black" . setFgColor "white")+--}
+ Demos/SpaceInvaders/Metrics.hs view
@@ -0,0 +1,16 @@+module Metrics where+import Pics as P2+import Pics1 as P1+import BitmapOps(Bitmap)+import InvaderTypes(Object)+import AllFudgets++metrics1 = M 1 (pP 240 195) P1.pics+metrics2 = M 2 (scaleP 2 (spaceSize metrics1)) P2.pics++data Metrics = M { bmScale::Int, spaceSize::Size, pics::Object->Bitmap }++spaceWidth = xcoord . spaceSize+spaceHeight = ycoord . spaceSize++scaleP k (Point x y) = Point (k*x) (k*y)
+ Demos/SpaceInvaders/Pics.hs view
@@ -0,0 +1,39 @@+module Pics where+import BitmapOps(doubleBM,bm)+import Pics1+import InvaderTypes++bmScale = 2 :: Int++pics obj =+  case obj of+    Base       -> doubleBM base1+    Explode    -> explode2+    Ufo        -> spacer2+    VExplode _ -> vexplode2+    _          -> doubleBM (Pics1.pics obj)++explode2 = bm 30 20 explode2_bits+explode2_bits = [+ 0x00,0xc0,0x00,0x00,0x00,0xc0,0x00,0x00,0x00,0xf0,0x03,0x00,0x00,0xf0,0x03,+ 0x00,0x00,0xf0,0x03,0x00,0x00,0xf0,0x03,0x00,0x00,0xfc,0x0f,0x00,0x00,0xfc,+ 0x0f,0x00,0xfc,0xff,0xff,0x0f,0xfc,0xff,0xff,0x0f,0x07,0x00,0x00,0x38,0xf3,+ 0x00,0x00,0x33,0x33,0x01,0x80,0x33,0x33,0x01,0xc0,0x30,0x33,0x39,0xce,0x30,+ 0xf3,0x6c,0xdb,0x31,0x33,0x6c,0xdb,0x30,0x33,0x38,0xce,0x30,0xff,0xff,0xff,+ 0x3f,0xff,0xff,0xff,0x3f]++spacer2 = bm 32 16 spacer2_bits+spacer2_bits = [+ 0x00,0xf0,0x0f,0x00,0x00,0xf0,0x0f,0x00,0x00,0xff,0xff,0x00,0x00,0xff,0xff,+ 0x00,0xc0,0xff,0xff,0x03,0xc0,0xff,0xff,0x03,0xf0,0xff,0xff,0x0f,0xf0,0xff,+ 0xff,0x0f,0x38,0xcf,0xf3,0x1c,0x38,0xcf,0xf3,0x1c,0xfc,0xff,0xff,0x3f,0xfc,+ 0xff,0xff,0x3f,0xf0,0x03,0xc0,0x0f,0xf0,0x03,0xc0,0x0f,0xc0,0x00,0x00,0x03,+ 0xc0,0x00,0x00,0x03]+ +vexplode2 = bm 28 16 vexplode2_bits+vexplode2_bits = [+ 0x00,0x20,0x00,0x00,0x00,0x24,0x01,0x00,0x00,0xa8,0x10,0x00,0xc0,0xa8,0x0c,+ 0x00,0x00,0x03,0x02,0x00,0x60,0x00,0x60,0x00,0x00,0x00,0x00,0x00,0xf0,0x00,+ 0xf0,0x00,0x00,0x00,0x00,0x00,0x80,0x00,0x10,0x00,0x60,0x04,0x64,0x00,0x00,+ 0x53,0x09,0x00,0xc0,0x50,0x11,0x00,0x00,0x48,0x02,0x00,0x00,0x40,0x00,0x00,+ 0x00,0x00,0x00,0x00]
+ Demos/SpaceInvaders/Pics1.hs view
@@ -0,0 +1,93 @@+module Pics1 where+import BitmapOps(bm)+import InvaderTypes++bmScale = 1 :: Int++pics obj =+  case obj of+    Base       -> base1+    Explode    -> explode1+    Ufo        -> spacer1+    VShot A    -> sperma1+    VShot B    -> spermb1+    Vader R1 A -> vader1a1+    Vader R1 B -> vader1b1+    Vader R2 A -> vader2a1+    Vader R2 B -> vader2b1+    Vader R3 A -> vader3a1+    Vader R3 B -> vader3b1+    VExplode _ -> vexplode1++{-+Copyright notice:++This is mine.  I'm only letting you use it.  Period.  Feel free to rip off+any of the code you see fit, but have the courtesy to give me credit.+Otherwise great hairy beasties will rip your eyes out and eat your flesh+when you least expect it.++Jonny Goldman <jonathan@think.com>++Wed May  8 1991+-}++--pics1 = [base1,explode1,spacer1,sperma1,spermb1,+--         vader1a1,vader1b1,vader2a1,vader2b1,vader3a1,vader3b1,vexplode1]++base1 = bm 15 10 base1_bits+base1_bits = [+   0x80, 0x00, 0xc0, 0x01, 0xc0, 0x01, 0xe0, 0x03, 0xfe, 0x3f, 0xff, 0x7f,+   0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f]++explode1 = bm 15 10 explode1_bits+explode1_bits = [+   0x80, 0x00, 0xc0, 0x01, 0xc0, 0x01, 0x20, 0x02, 0x3e, 0x3e, 0x0d, 0x50,+   0x15, 0x48, 0x6d, 0x5b, 0x65, 0x4b, 0xff, 0x7f]++spacer1 = bm 16 8 spacer1_bits+spacer1_bits = [+   0xc0, 0x03, 0xf0, 0x0f, 0xf8, 0x1f, 0xfc, 0x3f, 0xb6, 0x6d, 0xff, 0xff,+   0x1c, 0x38, 0x08, 0x10]++sperma1 = bm 3 7 sperma1_bits+sperma1_bits = [0x02, 0x01, 0x02, 0x04, 0x02, 0x01, 0x02]++spermb1 = bm 3 7 spermb1_bits+spermb1_bits = [0x02, 0x04, 0x02, 0x01, 0x02, 0x04, 0x02]++vader1a1 = bm 10 8 vader1a1_bits+vader1a1_bits = [+   0x30, 0x00, 0x78, 0x00, 0xfc, 0x00, 0xb6, 0x01, 0xfe, 0x01, 0xb4, 0x00,+   0x02, 0x01, 0x84, 0x00]++vader1b1 = bm 10 8 vader1b1_bits+vader1b1_bits = [+   0x30, 0x00, 0x78, 0x00, 0xfc, 0x00, 0xb6, 0x01, 0xfe, 0x01, 0xb4, 0x00,+   0x48, 0x00, 0x84, 0x00]++vader2a1 = bm 12 8 vader2a1_bits+vader2a1_bits = [+   0x08, 0x01, 0x90, 0x00, 0xf8, 0x01, 0x6c, 0x03, 0xfe, 0x07, 0xfa, 0x05,+   0x0a, 0x05, 0x90, 0x00]++vader2b1 = bm 12 8 vader2b1_bits+vader2b1_bits = [+   0x08, 0x01, 0x92, 0x04, 0xfa, 0x05, 0x6e, 0x07, 0xfc, 0x03, 0xf8, 0x01,+   0x08, 0x01, 0x04, 0x02]++vader3a1 = bm 14 8 vader3a1_bits+vader3a1_bits = [+   0xe0, 0x01, 0xfc, 0x0f, 0xfe, 0x1f, 0xce, 0x1c, 0xfe, 0x1f, 0x38, 0x07,+   0xcc, 0x0c, 0x18, 0x06]++vader3b1 = bm 14 8 vader3b1_bits+vader3b1_bits = [+   0xe0, 0x01, 0xfc, 0x0f, 0xfe, 0x1f, 0xce, 0x1c, 0xfe, 0x1f, 0x38, 0x07,+   0xcc, 0x0c, 0x06, 0x18]++vexplode1 = bm 14 8 vexplode1_bits+vexplode1_bits = [+   0x48, 0x04, 0x50, 0x02, 0x00, 0x00, 0x06, 0x18, 0x10, 0x02, 0x88, 0x04,+   0x80, 0x00, 0x00, 0x00]+
+ Demos/SpaceInvaders/ReadPic.hs view
@@ -0,0 +1,16 @@+module ReadPic(readPic,readPics,bmScale) where+import Control.Applicative+import AllFudgets+--import Pics+import BitmapOps+import Metrics++readPics m (file1,file2) = (,) <$> readPic m file1 <*> readPic m file2++readPic m name =+  case pics m name of+    Bitmap (w,h) bytes ->+      do bmr <- Mk (bitmapFromData (BitmapData (Point w h) Nothing bytes))+         case bmr of+           BitmapReturn size _ pm -> return (PixmapImage size pm)+           BitmapBad -> error ("Can't read bitmap "++show name)
+ Demos/SpaceInvaders/ScoreF.hs view
@@ -0,0 +1,20 @@+module ScoreF where+import Fudgets+import AllFudgets(appStorageF)++scoreF = placerF autoP (currentF>*<highF)>=^^<sumSP++highF = dispF "High:" >==<+        loopThroughRightF (toBothF >=^^< maxSP >=^< stripEither) storageF+  where+    storageF = appStorageF "SpaceInvaders.highscore" 0++currentF = dispF "Score:"++sumSP = accSP (\s->maybe 0 (s+)) 0+maxSP = accSP max 0++accSP f = mapstateSP (\s x->let x'=f s x in (x',[x']))++dispF lbl = lbl `labLeftOfF` intDispF' custom+  where custom = setFgColor "white" . setBgColor "black" . setInitSize 999999
+ Demos/SpaceInvaders/SpaceInvaders2.hs view
@@ -0,0 +1,8 @@++import System.Random(newStdGen)+import Fudgets+import WorldF+import MainF++main = do g <- newStdGen+          fudlogue (shellF "Space Invaders" (mainF (worldF g)))
+ Demos/SpaceInvaders/WorldF.hs view
@@ -0,0 +1,490 @@+-- | The entire world, implemented as a single fudget, instead of one fudget+-- per object in the world.+module WorldF(worldF,worldF') where+import System.Random+import Control.Applicative+import Control.Monad(when)+import Data.List(nub)+import ReactionM+import GUI+import InvaderTypes hiding (Phase(..))++data World    = W {rnd::StdGen, shelters::Shelters, base::Base, ufo::Ufo,+                   torpedo::Torpedo, vshots::VShots, invaders::Invaders}+data Base     = B {bPict,exbPict::Pict, bPos::Point, lives::Int, bSpeed::Speed}+              | ExB {bPict,exbPict::Pict, bPos::Point, lives::Int, exbAge::Int}+--data Shelters = Sh [PlacedPict] -- hmm+type Shelters = [Shelter]+data Shelter  = Sh {shGC::GCId,shBR::Rect,shRs::[Rect]}+data Torpedo  = T Pict (Maybe Point)+data Ufo      = U Pict GCId UfoState+data UfoState = Wait Ticks | Moving Score Speed Point | Hit Ticks Score Point+data VShots   = V Speed (Pict,Pict) [Point]+data VShot    = V1 Speed (Pict,Pict) Point+data Invaders = Invs {invs::[Invader], level::Int, step::Speed, delay::Ticks}+data Invader  = Inv {invPict::(Pict,Pict),exvPict::Pict,+                     invScore::Int,invPos::Point}+              | Exv {exvPict::Pict, invPos::Point} -- exploded+type ExVader  = Pict+type Speed = Int+type Ticks = Int+type Score = Int++modBase = update . updateBase+updateBase f w@W{base=b} = w{base=f b}+--updateTorpedo f =w@W{torpedo=t} = w{torpedo=f b}++exBase (B pm ex p l v) = ExB pm ex p l 0+exBase base = base++alive w = case base w of B {} -> True; _-> False++spare pm n = if n>=0+             then hboxD (replicate n (atomicD (Right pm)))+             else atomicD (Left "Game over!")++--------------------------------------------------------------------------------++worldF g = spaceF (initWorldK g) objectsK+worldF' g = spaceF' (initWorldK g) objectsK++--------------------------------------------------------------------------------++initWorldK g m =+  W g <$> initSheltersK m <*> initBaseK m <*> initUfoK m+      <*> initTorpedoK m <*> initVShotsK m <*> initInvadersK m++initSheltersK metrics =+    do gc <- objGC shelterColor+       let sh p = Sh gc (Rect p s) (move p shape)+       return $ map sh ps+  where+    s@(Point w h) = shelterSize metrics+    m = (spaceWidth metrics -3*3-7*w) `div` 2+    y = spaceHeight metrics-margin metrics-3*h+    xs = [m+2*(w+3)*i|i<-[0..3]]+    ps = [Point x y|x<-xs]++    shape = [v x roofy h|x<-[0..roofx-1]]+++            [v x 0     h|x<-[roofx..legx-1]]+++            [v x 0 (h-legy)|x<-[legx..w-legx-1]]+++            [v x 0     h|x<-[w-legx..w-roofx-1]]+++            [v x roofy h|x<-[w-roofx..w-1]]+    v x y1 y2 = rR x y1 1 (y2-y1)+    legx = w `div` 3 - 1+    legy = h `div` 4+    roofy = legy+    roofx = w `div` 10++initBaseK m =+  do pict <- readObjPict m Base+     ex   <- readObjPict m Explode+     let startpos = (baseStartPos m pict){xcoord= -width pict}+         lives = 3+     putLivesMkc m (spare pict lives)+     return (ExB pict ex startpos (lives+1) 50)++baseStartPos m pict = Point (margin m) (spaceHeight m-height pict-margin m)++initUfoK m =+  do gc <- objGC ufoColor+     pict <- readPict m gc Ufo+     return $ U pict gc (Wait ufoDelay)+  +initTorpedoK m =+  do gc <- objGC shotColor+     let s = torpedoSize m+         pict = rectangles gc s [Rect 0 s]+     return (T pict Nothing)++initVShotsK m = flip (V (vshotDy m)) [] <$> readObjPicts m (phases VShot)++initInvadersK m =+    invaders <$> mapM (readObjPicts m . phases . Vader) rows+             <*> mapM (readObjPict m . VExplode) rows+  where+    invaders is es = Invs invs startLevel dx0 16+      where+        invs = zipWith centerI (concatMap row [i3,i3,i2,i2,i1]) places +        [i1,i2,i3] = zip3 is es [30,20,10]+    row = replicate hcount+    places = [Point (margin m+hsep*x) (margin m+vsep*y+offset)|+                 y<-[5,4..1],x<-[0..hcount-1]]+    offset = invHeight m * min 8 startLevel++    centerI (pm@(pm1,_),ex,score) p =+        Inv pm ex score (p + pP ((invWidth m-width pm1) `div` 2) 0)+    hsep = invWidth m+2*bmScale m+    vsep = invHeight m+4*bmScale m+    dx0 = invDx m++--------------------------------------------------------------------------------++type Output = Either Bases (Maybe Score)+type Input = Either Tick Click+type Bases = Drawing () Pict++--getGs = toMs getG+--putLivesMs l = toMsc (putLives l)+--putScoreMs s = toMsc (putScore s)+--putGUIMs g = toMsc (putGUI g)+--puatsGUIMs gs = toMsc (putsGUI gs)++--objectsK :: Size -> World -> Mk (G Input Output) ()+objectsK m world0 = reactiveSP (objectsKs m world0) world0++--objectsKs :: Size -> World -> Ms (G Input Output) World noreturn+objectsKs m world0 = playK+  where+    playK = message low high+      where+        high = either (const tickK) (const newK)++        newK = do set world1+                  putGUI (clearRect (Rect 0 (spaceSize m)) True)+                  putScore Nothing+                  b <- field base+                  putLives m (spare (bPict b) (lives b-1))+          where+            world1 = world0{invaders=invs1}+            invs1 = invs0{invs=[],delay=100}+            invs0 = invaders world0++        low ev =+          case ev of+	    Redraw        -> draw =<< get+            Key Fire Down -> fireTorpedo+            Key a    p    -> modBase (accelerate p a)++    accelerate pressed button b@ExB{} = b+    accelerate pressed button b@B{bSpeed=v} = b{bSpeed=v'}+      where+	v'   = case pressed of Down -> bdir ; _ -> 0+	bdir = case button of+                  MoveLeft -> -baseDx m+                  MoveRight -> baseDx m+                  _ -> 0+      ++    tickK =+      do tickInvadersK+         tickUfoK+         W g shelters base ufo torpedo vshots invaders <- get+         base' <- tickBaseK base+         (torpedo',invaders',shelters',ufo')<-+                tickTorpedoK torpedo invaders shelters ufo+         set (W g shelters' base' ufo' torpedo' vshots invaders')+         tickVShotsK vshots base'++    tickInvadersK =+      do state@W{invaders=inv} <- get+         let t = delay inv-1+         case t of+           0 -> do let invcnt = length (invs inv)+                       l = level inv+1+                       offset = pP 0 (invHeight m*(min 8 l-startLevel))+                       inv' = if invcnt==0+                              then move offset (invaders world0){level=l}+                              else inv{delay=(invcnt+6) `div` 4}+                   set state{invaders=inv'}+                   moveInvadersK+                   update fireVShot+           _ -> do let inv' = inv{delay=t}+                   set state{invaders=inv'}++    --tickBaseK :: Base -> Ms (G hi (Either Bases x)) s Base+    tickBaseK b@(ExB pm ex p@(Point x y) l t) =+        case t of+          50 -> putGUI (clearpm p pm) >> return b'{bPos=Point (-width pm) y}+          95  | l>0 -> putLives m (spare pm (l-2)) >> return b'+          100 | l>1 -> do let b' = B pm ex (baseStartPos m pm) (l-1) 0+                          draw b'+                          return b'+          _ -> return b'+      where+        b' = b{exbAge=t+1}+        new = B pm ex+    tickBaseK b@(B pm ex p@(Point x y) l v) =+      case v of+        0 -> return b+	_ -> putGUI (clearpm p pm) >> draw b' >> return b'+	  where b' = B pm ex p' l v+	        p' = Point x' y+                x' = min (spaceWidth m-margin m-width pm) (max (margin m) (x+v))++    tickUfoK =+      do state@W{rnd=g,ufo=u@(U pm gc s)} <- get+         let ufoWidth = xcoord (size pm)+         case s of+           Wait 0 -> do let u'=U pm gc (Moving score dx (pP x0 (margin m)))+                            score = 50*n+                            (x0,dx) = if rev+                                      then (spaceWidth m,-ufoDx m)+                                      else (-ufoWidth,ufoDx m)+                            (n,g') = randomR (1,6) g+                            (rev,g'') = random g'+                        draw u'+                        set state{rnd=g'',ufo=u'}+           Wait t -> set state{ufo=U pm gc (Wait (t-1))}+           Hit 0 s p -> do putGUI (clearpm p pm)+                           set state{ufo=U pm gc (Wait ufoDelay)}+           Hit t s p -> set state{ufo=U pm gc (Hit (t-1) s p)}+           Moving s dx p ->+             if dx>0 && xcoord p>=spaceWidth m ||+                dx<0 && xcoord p< -ufoWidth+             then do putGUI (clearpm p pm)+                     set state{ufo=U pm gc (Wait ufoDelay)}+             else do let p' = p + pP dx 0+                         u' = U pm gc (Moving s dx p')+                     putGUI (clearpm p pm)+                     draw u'+                     set state{ufo=u'}++    tickTorpedoK t@(T pm optp) inv sh ufo = +      case optp of+        Nothing -> return (t,inv,sh,ufo)+	Just p@(Point x y) ->+	  if y<torpedoDy m+	  then putGUI (clearpm p pm) >> return (T pm Nothing,inv,sh,ufo)+	  else case p `invHit` inv of+	         (inv1,Inv (p1,_) ex score ip:inv2) ->+		     do putsGUI [clear p (torpedoSize m), clearpm ip p1]+                        draw exv+                        putScore (Just score)+		        return (T pm Nothing,inv{invs=inv'},sh,ufo)+                   where+                     inv' = inv1++exv:inv2+                     exv = Exv ex ip+		 _ -> case shelterHit' sh r d of+                        Just sh' -> do putGUI (clearRect d False)+                                       return (T pm Nothing,inv,sh',ufo)+                        _ -> case Rect p (size pm) `ufoHit` ufo of+                               Just ufo'@(U upm _ (Hit _ score up)) ->+                                 do putGUI (clearpm p pm)+                                    putGUI (clearpm up upm)+                                    draw ufo'+                                    putScore (Just score)+                                    return (T pm Nothing,inv,sh,ufo')+                               _ -> do let t' = move (pP 0 (-torpedoDy m)) t+                                       putGUI (clearpm p pm)+                                       draw t'+                                       return (t',inv,sh,ufo)+                    where s = size pm+                          r = Rect (p+pP 0 (torpedoDy m `div` 2)) s+                          d = Rect (p-pP 1 0) (s+pP 2 0)++    r `ufoHit` U pm gc (Moving s dx p)+               | overlaps r (Rect p (size pm)) = Just (U pm gc (Hit 100 s p))+    r `ufoHit` _  = Nothing++    p `invHit` Invs{invs=is} = break isHit is+      where+        isHit Exv{} = False+        isHit (Inv (p1,_) _ _ ip) = p `inRect` r+	  where r = Rect (ip + Point 2 0) (size p1 - Point 4 0)++    fireTorpedo = do a <- field alive+                     when a $ do update fire; draw =<< field torpedo+    +    fire w@W{torpedo=T gc t} =+      case t of+        Nothing -> w{torpedo=T gc (Just (firePos m (base w)))}+	_ -> w++    fireVShot w@W{vshots=V dy pm@(p1,_) ps,invaders=Invs{invs=is},rnd=g0} =+        if null is || length ps>5 +        then w+        else if r<9+             then w{rnd=g1}+             else w{vshots=V dy pm (p:ps),rnd=g'}+      where+        p = Point (x+(invWidth m-width p1) `div` 2) (y+invHeight m-3*bmScale m)+        y = maximum [ycoord p|Inv{invPos=p}<-is,abs (xcoord p-x)<h]+        h = invWidth m `div` 2+        x = xs !! ix+        xs = nub [xcoord p|Inv{invPos=p}<-is]+        +        (ix,g') = randomR (0,length xs-1) g1+        (r,g1) = randomR (0,9::Int) g0+      +    tickVShotsK (V dy pm@(p1,_) ps) base =+        do ps0' <- mapM moveVShot ps+           w <- get+           set w{vshots=V dy pm [p|Just p<-ps0']}+      where+        br = Rect (bPos base) (size base)++        v = pP 0 dy+        ss@(Point w h) = size p1++        moveVShot p =+            if hitBase+            then do putGUI (clearpm p p1)+                    let base' = exBase base+                    draw base'+                    modBase (const base')+                    return Nothing+            else do sh <- field shelters+                    case shelterHit' sh hr dr of+                      Just sh' -> do w<-get+                                     set w{shelters=sh'}+                                     putGUI (clearRect dr False)+                                   --draw sh'+                                     return Nothing+                      _ -> if ycoord p' < spaceHeight m+                           then do putsGUI [clearpm p p1,wDraw (V1 dy pm p')]+                                   return (Just p')+                           else do putGUI (clearpm p p1)+                                   return Nothing+          where+            p' = p+v+            sr = Rect p ss+            hr = move (pP 0 (dy-h)) sr+            dr = sr+            hitBase = overlaps br sr++    moveInvadersK =+        do w@W{invaders=invs0,shelters=ss} <- get+           let (movecmds,br',invs') = moveInvaders invs0+           putsGUI (concat movecmds)+           ss' <- if any (overlaps br' . shBR) ss+                  then let shHit ss i@Inv{} = maybe ss id.shelterHit ss $ rect i+                           shHit ss _       = ss+                       in return $ foldl shHit ss (invs invs')+                  else return ss+           set w{invaders=invs',shelters=ss'}++    moveInvaders (Invs is l dx dt) = (movecmds,br,Invs is' l dx' dt')+      where+        dt' = if null is' then 200 else if off_bottom then -1 else dt+        (dx',d) = if dx>0 && off_right || dx<0 && off_left+	          then (-dx,pP 0 (invDy m))+		  else (dx,pP dx 0)+	(xs,ys) = unzip [(x,y)|Inv{invPos=Point x y}<-is]+	off_left = min_x < margin m+	off_right = max_x > spaceWidth m-margin m+        off_bottom = max_y > spaceHeight m-margin m+        min_x = minimum xs+        min_y = minimum ys+        max_x = maximum xs + invWidth m+        max_y = maximum ys + invHeight m+        br = if null xs+             then Rect 0 0+             else move d $ line2rect (lL min_x min_y max_x max_y)++	(movecmds,is0') = unzip (map moveInvader is)+        is' = [i|Just i<-is0']++        moveInvader (Exv p1 p) = ([clearpm p p1],Nothing)+	moveInvader (Inv (p1,p2) ex s p) =+	    case ycoord d of+	      0 -> ([wDraw i'],Just i')+	      _ -> ([clearpm p p1,wDraw i'],Just i')+	  where+	    i' = Inv (p2,p1) ex s (p+d)++shelterHit ss r = shelterHit' ss r r++shelterHit' ss r d =+  case break (hitSh r) ss of+    (pps1,Sh gc br rs:pps2) ->+        if any (overlaps r) rs && rs' /= rs+        then if null rs'+             then Just (pps1++pps2)+             else Just (pps1++Sh gc br rs':pps2)+        else Nothing+      where+        rs' = concat [diffRect sr d|sr<-rs]+    _ -> Nothing++hitSh r (Sh _ br _) = overlaps r br++--------------------------------------------------------------------------------++draw obj = putGUI (wDraw obj)++instance Draw World where+  drawing w =drawing (ufo w,(shelters w,base w,torpedo w),(vshots w,invaders w))++--instance Draw Shelters where+--  drawing (Sh pps) = pps++instance Draw Shelter where+  drawing (Sh gc (Rect p s) rs) = [pp (rectangles gc s rs) 0]++instance Draw Base where+  drawing (B pm ex p _ _) = [pp pm p]+  drawing (ExB pm ex p _ _) = [pp ex p]++instance Draw Torpedo where+  drawing (T _ Nothing) = []+  drawing (T pm (Just p)) = [pp pm p]++instance Draw Ufo where+  drawing (U pm _  (Moving s dx p)) = [pp pm p]+  drawing (U pm gc (Hit t s p)) = [pp (text gc (show s)) (p+pP 0 (height pm))]+  drawing _ = []++instance Draw Invaders where+  drawing = drawing . invs++instance Draw Invader where+  drawing (Inv (pm,_) _ _ p) = [pp pm p]+  drawing (Exv pm p) = [pp pm p]++instance Draw VShots where+  drawing (V dy pm ps) = drawing [V1 dy pm p|p<-ps]++instance Draw VShot where+  drawing (V1 dy (pm1,pm2) p) =  [pp pm p]+    where+      pm = if even (ycoord p `div` dy) then pm1 else pm2++--------------------------------------------------------------------------------+class HasSize a => HasRect a where rect :: a -> Rect++width obj = xcoord (size obj)+height obj = ycoord (size obj)++instance HasSize Base where size = size . bPict+instance HasRect Base where rect (B pm _ p _ _) = Rect p (size pm)++--instance HasSize Torpedo where size _ = torpedoSize++instance HasSize Invader where+  size inv@Inv{invPict=(p1,_)} = size p1+  size inv@Exv{exvPict=p1} = size p1++instance HasRect Invader where+  rect inv = Rect (invPos inv) (size inv)++instance Move Base     where move v (B pm ex p l dx) = B pm ex (p+v) l dx+instance Move Torpedo  where move v (T pm op) = T pm (move v op)+instance Move Invaders where move v (Invs is l dx dt) = Invs (move v is) l dx dt+instance Move Invader  where move v inv@Inv{invPos=p} = inv{invPos=move v p}+instance Move VShots   where move v (V dy pm ps) = V dy pm (move v ps)++--------------------------------------------------------------------------------+firePos m base = bPos base + pP (width base `div` 2) (-torpedoHeight m)++shelterSize m = pP (20*bmScale m) (16*bmScale m)++torpedoSize m = pP 1 (torpedoHeight m)+torpedoHeight m = 8*bmScale m+torpedoDy m = 6*bmScale m++ufoDelay = argReadKey "ufodelay" 2500+ufoDx = bmScale++vshotDy m = 2*bmScale m++invHeight m = 8*bmScale m+invWidth m = 12*bmScale m+invDy m = 3*invHeight m `div` 4+invDx = bmScale++margin m = 5*bmScale m+baseDx m = argReadKey "dx" (2*bmScale m-1)::Int -- base speed++hcount = argReadKey "hcount" 11::Int+startLevel = argReadKey "level" 0::Int
+ Demos/Tiles/BoardF.hs view
@@ -0,0 +1,53 @@+module BoardF(boardF) where++import AllFudgets+import DrawingF+import Tiles+import MyUtils++boardF :: F (Either ChangeTileNo [Tile]) a+boardF = marginHVAlignF 0 aCenter aCenter (noStretchF True True (loopLeftF ((Left >^=< gridUF) >==< gridControlF)))++--left :: a -> Either a b+--left x = Left x++gridUF = (gridF,Above) >#+< updateF++updateF = buttonF "update with new current tile"++gridControlF :: F (Either (Either (Int, Event) Click) (Either ChangeTileNo [Tile])) +			(Either (Int, ChangeTile) a)+gridControlF =+	let startState = (sameTN, [[]|x<-[0..7]], [NoTile|x<-[0..24]])+	    step (cn, ts, ns) m = +		-- cn = function to change a tile number+		-- ts = set of rotations/reflections of current tile+		-- ns = tile numbers associated with each grid position+		let toGrid = Left+		in case m of+		-- looped back from Grid+		    (Left (Left (n, _))) -> ((cn, ts, nns), ct nn)+			where nn = cn (ns!!n)+			      nns = (take n ns) ++ [nn] ++ (drop (n+1) ns)+			      ct bt = case bt of+				NoTile   -> []+				TileNo t -> [toGrid (n,changeToT (ts!!t))]+		-- looped back from Update button+		    (Left (Right Click)) -> ((cn, ts, ns), changeAll)+			where changeAll = [ct n | n <- [0..24]]+			      ct n = case (ns!!n) of+				NoTile -> toGrid (n, sameT)+				TileNo t -> toGrid (n, changeToT (ts!!t))+		-- from Tools+		    (Right (Left ncn)) -> ((ncn, ts, ns), [])+		-- from Choice+		    (Right (Right nts)) -> ((cn, nts, ns), [])+	in absF (mapstateSP step startState)++gridF :: F (Int, ChangeTile) (Int, Event)+gridF = +	let b v = drawDisplayCF (Point 50 50) v+	    tiles = [ (x, b []) | x <- [0..24] ]+	    layout = matrixP' 5 Horizontal 0+	in listLF layout tiles+
+ Demos/Tiles/ChoiceF.hs view
@@ -0,0 +1,31 @@+module ChoiceF(choiceF) where++import Fudgets+import RadioDrawF+import Tiles+import MyUtils++choiceF = marginHVAlignF 0 aCenter aCenter (noStretchF True True choice')+choice' = loopLeftF (throRight (radioDrawDF layout choices) >==< choiceControlF)++layout = verticalP++choices = [tile n | n <- [0..3]]++choiceControlF :: F (Either (Int, Tile) Tile) +			(Either (Int, Tile) (Either Tile (Either [Tile] [Tile])))+choiceControlF =+	let startstate = 0+	    step c m = +		let toButtons = Left+		    toDesign = Right. Left+		    toTools = Right. Right. Left+		    toBoard = Right. Right. Right+		in case m of+			-- from Buttons+			(Left (n, t)) -> (n, [toDesign t, toTools (setT t), +							toBoard (setT t)])+			-- from Design+			(Right t) -> (c, [toButtons (c, t), toTools (setT t),+							toBoard (setT t)])+	in absF (mapstateSP step startstate)
+ Demos/Tiles/DesignF.hs view
@@ -0,0 +1,74 @@+module DesignF(designF) where++import AllFudgets+import DrawingF+import MyUtils+import Tiles++data DesignState = Init | Start Point++designSize = 250+gridNo = 10++designF :: F Tile Tile+designF = marginHVAlignF 0 aCenter aCenter (loopLeftF ((throRight padF) >==< designControlF))++padF = (drawDisplayCKF (Point designSize designSize) gridlines,Above)+		>#+< updateBF++updateBF = buttonF "finished design -> current tile"++designControlF :: F (Either (Either Event Click) Tile) (Either (Either ChangeTile a) Tile)+designControlF = +	let startstate = ([], Init)+	    step (c, s) m = +		let grid = gridlines +		    grow = magT dtRatio+		    toDesign = Left. Left. changeToT+		    toChoice = Right+		in case m of+			-- from the grid+			(Left (Left (ButtonEvent _ ap _ _ Pressed (Button b)))) -> (+				let p = snap ap +				in case s of+					Init    -> ((c, Start p), [toDesign ((mark p)++(grow c))])+					Start f -> ((newDraw, Init), [toDesign (grow newDraw)])+						where newDraw = case b of+							3         -> delLine x1 y1 x2 y2 c+							otherwise -> (line x1 y1 x2 y2) ++ c+						      Point x1 y1 = scalePoint tdRatio f+						      Point x2 y2 = scalePoint tdRatio p )+			-- from the update button+			(Left (Right Click)) -> ((c, s), [toChoice c])+			-- from Choice+			(Right t) -> ((t, Init), [toDesign (grow t)])+	in absF (mapstateSP step startstate)++snap :: Point -> Point+snap p = sp+	where sp = Point sx sy+	      sx = ((px+halfGridSize) `div` gridSize) * gridSize+	      sy = ((py+halfGridSize) `div` gridSize) * gridSize+	      Point px py = p ++delLine _ _ _ _ [] = [] +delLine x1 y1 x2 y2 (c:cs) = +	let rest = delLine x1 y1 x2 y2 cs+	in case c of+		DrawLine (Line (Point x3 y3) (Point x4 y4)) -> +			if ((x1==x3) && (y1==y3) && (x2==x4) && (y2==y4)) ||+			   ((x1==x4) && (y1==y4) && (x2==x3) && (y2==y3))+				then rest else c:rest+		otherwise -> c:rest++mark p = circle x y (designSize `div` 50)+	where Point x y = p++gridlines = concat [(line (l*gridSize) 0 (l*gridSize) designSize) +++	       (line 0 (l*gridSize) designSize (l*gridSize)) | +			l <- [1..(gridNo-1)]]++gridSize = designSize `div` gridNo+halfGridSize = gridSize `div` 2+tdRatio = (fromIntegral tileSize) / (fromIntegral designSize)+dtRatio = designSize `div` tileSize
+ Demos/Tiles/DrawingF.hs view
@@ -0,0 +1,107 @@+module DrawingF where++import AllFudgets+import MyUtils++{-+drawDisplayF size drawing =+  let startcmds = [ ConfigureWindow [CWBorderWidth 0],+		    layoutRequestCmd (plainLayout size True True),+		    ChangeWindowAttributes [ CWEventMask [ExposureMask]+					     --,CWBackingStore WhenMapped+					   ]+		  ]+  in windowF startcmds (drawDisplayK drawing)++drawDisplayK drawing =+  wCreateGC rootGC [GCFunction GXcopy] (\gc -> drawDisplayP gc drawing)++drawDisplayP gc drawing0 =+  let draw drawing = map (Low . Draw MyWindow gc) drawing+  in let step drawing msg =+	   case msg of+		Low (Expose _ 0) -> (drawing, draw drawing)+		High drawing'   -> (drawing',Low ClearWindow:(draw drawing'))+		_		 -> (drawing,[])+  in putsK (draw drawing0) $ mapstateSP step drawing0+-}+------++drawDisplayCF size drawing =+  let startcmds =  [ XCmd $ ConfigureWindow [CWBorderWidth 0],+		    layoutRequestCmd (plainLayout size True True),+		     XCmd $ ChangeWindowAttributes [ CWEventMask [ExposureMask+							,ButtonPressMask]+					     --,CWBackingStore WhenMapped+					   ]+		  ]+  in windowF startcmds (drawDisplayCK drawing)++drawDisplayCK drawing =+  wCreateGC rootGC [GCFunction GXcopy] (\gc -> drawDisplayCP gc drawing)++drawDisplayCP gc drawing0 =+  let draw drawing = map (Low . wDraw gc) drawing+  in let step drawing msg =+	   case msg of+		Low (XEvt (Expose _ 0)) -> (drawing, draw drawing)+		High drawingf'   -> let drawing' = drawingf' drawing+				    in (drawing',Low (XCmd ClearWindow):(draw drawing'))+		Low (XEvt (ButtonEvent t x y m Pressed b)) -> +		    (drawing,High (ButtonEvent t x y m Pressed b):(draw drawing))+		_		 -> (drawing,[])+  in putsK (draw drawing0) $ K $ mapstateSP step drawing0++------++drawDisplayCKF size drawing =+  let startcmds = [ XCmd $ ConfigureWindow [CWBorderWidth 0],+		    layoutRequestCmd (plainLayout size True True),+		    XCmd $ ChangeWindowAttributes [ CWEventMask [ExposureMask+							,ButtonPressMask]+					     --,CWBackingStore WhenMapped+					   ]+		  ]+  in windowF startcmds (drawDisplayCKK drawing)++drawDisplayCKK drawing =+  wCreateGC rootGC [GCFunction GXcopy] (\gc -> drawDisplayCKP gc drawing)++drawDisplayCKP gc drawing0 =+  let draw drawing = map (Low . wDraw gc) (drawing0++drawing)+  in let step drawing msg =+	   case msg of+		Low (XEvt (Expose _ 0)) -> (drawing, draw drawing)+		High drawingf'   -> let drawing' = drawingf' drawing+				    in (drawing',Low (XCmd ClearWindow):(draw drawing'))+		Low (XEvt (ButtonEvent t x y m Pressed b)) -> +		    (drawing,High (ButtonEvent t x y m Pressed b):(draw drawing))+		_		 -> (drawing,[])+  in putsK (draw []) $ K $ mapstateSP step drawing0++------++drawDisplayDF size drawing =+  let startcmds = [ XCmd $ ConfigureWindow [CWBorderWidth 0],+		    layoutRequestCmd (plainLayout size True True),+		    XCmd $ ChangeWindowAttributes [ CWEventMask [ExposureMask+							,ButtonPressMask]+					     --,CWBackingStore WhenMapped+					   ]+		  ]+  in windowF startcmds (drawDisplayDK drawing)++drawDisplayDK drawing =+  wCreateGC rootGC [GCFunction GXcopy] (\gc -> drawDisplayDP gc drawing)++drawDisplayDP gc drawing0 =+  let draw drawing = map (Low . wDraw gc) drawing+  in let step drawing msg =+	   case msg of+		Low (XEvt (Expose _ 0)) -> (drawing, draw drawing)+		High drawingf'   -> let drawing' = drawingf' drawing+				    in (drawing',Low (XCmd ClearWindow):(draw drawing'))+		Low (XEvt (ButtonEvent _ _ _ _ Pressed _)) -> +		    (drawing,High (drawing):(draw drawing))+		_		 -> (drawing,[])+  in putsK (draw drawing0) $ K $ mapstateSP step drawing0
+ Demos/Tiles/Main.hs view
@@ -0,0 +1,38 @@+module Main(main) where++import Fudgets+import BoardF+import ToolsF+import ChoiceF+import Tiles+import DesignF+import MyUtils++main = fudlogue (shellF "Escher" escherF)++escherF = placerF (revP (horizontalP' 10)) (playF >==< workF)++playF :: F (Either [Tile] [Tile]) c+playF = vBoxF (boardF >==< throRight toolsF)++workF :: F b (Either [Tile] [Tile])+workF = loopLeftF (hBoxF (worka >==< workb))++workb :: F (Either Tile c) (Either Tile (Either [Tile] [Tile]))+workb = choiceF >=^< fromLeft++worka :: F (Either Tile a) (Either Tile a)+worka = throRight (designF)++{--- older versions: ---++escherF = (playF >==#< (10, LRightOf, workF)) >==#< (10, LRightOf, quitButtonF)++playF = (boardF,Above) >#==< throRight toolsF++workF = loopLeftF ((worka,LeftOf) >#==< workb)++fromLeft :: Either a b -> a+fromLeft (Left x) = x++--}
+ Demos/Tiles/MyUtils.hs view
@@ -0,0 +1,11 @@+module MyUtils where++import Fudgets++throRight :: F a b -> F (Either a c) (Either b c)+throRight = idRightF++line x1 y1 x2 y2 = [DrawLine (Line (Point x1 y1) (Point x2 y2))]++circle x y r =+	[FillArc (Rect (psub (Point x y) (Point r r)) (Point (2*r) (2*r))) 0 (64*360)]
+ Demos/Tiles/RadioDrawF.hs view
@@ -0,0 +1,44 @@+module RadioDrawF(radioDrawCF, radioDrawDF) where++import AllFudgets+import ToggleDrawGroupF+import Tiles+import MyUtils++radioDrawCF l c = loopLeftF (throRight (toggleDrawGroupCF l c) +				>==< radioControlCF)++radioControlCF :: F (Either (Int, Event) (Int, Tile)) +			(Either (Int, (Either Bool ChangeTile)) (Int, Event))+radioControlCF = +	let outsideC n e = High (Right (n, e))+	    toggleButC n b = High (Left (n, Left b))+	    changeButC n d = High (Left (n, Right (changeToT d)))+	    startStateC = 0+	    press = ButtonEvent 0 (Point 0 0) (Point 0 0) [] Pressed (Button 1)+	    firstMsgC = [toggleButC 0 True, outsideC 0 press]+	    stepC c m = case m of+		High (Left (n, b)) -> (n, [toggleButC c False, +						toggleButC n True, +						outsideC n b])+		High (Right (n, t)) -> (c, [changeButC n t, outsideC c press])+	in putMessagesF firstMsgC $ F $ mapstateSP stepC startStateC+++radioDrawDF l c = loopLeftF (throRight (toggleDrawGroupDF l c) +				>==< radioControlDF (head c))++radioControlDF :: Tile -> F (Either (Int, Tile) (Int, Tile)) +			(Either (Int, (Either Bool ChangeTile)) (Int, Tile))+radioControlDF t0 = +	let outsideD n t = High (Right (n, t))+	    toggleButD n b = High (Left (n, Left b))+	    changeButD n d = High (Left (n, Right (changeToT d)))+	    startStateD = 0+	    firstMsgD = [toggleButD startStateD True,+			 outsideD startStateD t0]+	    stepD c m = case m of+		High (Left (n, t)) -> (n, [toggleButD c False, +					toggleButD n True, outsideD n t])+		High (Right (n, t)) -> (c, [changeButD n t])+	in putMessagesF (firstMsgD) $ F $ mapstateSP stepD startStateD
+ Demos/Tiles/Tiles.hs view
@@ -0,0 +1,83 @@+module Tiles where++import AllFudgets+import MyUtils++type Tile = [DrawCommand]+type ChangeTile = (Tile -> Tile)+type ChangeTileNo = (BoardTileNo -> BoardTileNo)+data BoardTileNo = NoTile | TileNo Int++tileSize :: Int+tileSize = 50++-- functions ending in 'T' manipulate tiles+-- functions ending in 'TN' manipulate tile numbers+-- (setT defines the relationship between tiles and tile numbers)++changeToT t = (\x -> t)+changeToTN :: BoardTileNo -> (BoardTileNo -> BoardTileNo)+changeToTN t = (\x -> t)++sameT = (\t -> t)+sameTN :: BoardTileNo -> BoardTileNo+sameTN = (\t -> t)++rotateT :: Tile -> Tile+rotateT [] = []+rotateT (t:ts) = let rest = rotateT ts+		 in case t of+	DrawLine (Line (Point x1 y1) (Point x2 y2)) -> +		DrawLine (Line (Point (tileSize-y1) x1) (Point (tileSize-y2) x2)):rest+rotateTN tn = case tn of+		NoTile    -> NoTile+		otherwise -> let TileNo n = tn+				 d = n `div` 4 in+			     TileNo (((n+1) `mod` 4) + (d*4))++mirrorVT [] = []+mirrorVT (t:ts) = let rest = mirrorVT ts+		 in case t of+	DrawLine (Line (Point x1 y1) (Point x2 y2)) -> +		DrawLine (Line (Point (tileSize-x1) y1) (Point (tileSize-x2) y2)):rest+mirrorVTN tn = +	      case tn of+		NoTile    -> NoTile+		otherwise -> let TileNo n = tn+				 d = n `div` 4+		 		 m = n `mod` 4 in +			     TileNo (((d+1) `mod` 2)*4 + m)++mirrorHT [] = []+mirrorHT (t:ts) = let rest = mirrorHT ts+		 in case t of+	DrawLine (Line (Point x1 y1) (Point x2 y2)) -> +		DrawLine (Line (Point x1 (tileSize-y1)) (Point x2 (tileSize-y2))):rest+mirrorHTN tn = case tn of+		NoTile    -> NoTile+		otherwise -> let TileNo n = tn+				 d = n `div` 4 in+			     TileNo (((d+1) `mod` 2)*4 + ((n+2) `mod` 4))++magT m [] = []+magT m (t:ts) = let rest = magT m ts+		 in case t of+	DrawLine (Line (Point x1 y1) (Point x2 y2)) -> +		DrawLine (Line (Point (x1*m) (y1*m)) (Point (x2*m) (y2*m))):rest++setT :: Tile -> [Tile]+setT t = [t, rotateT t, (rotateT.rotateT) t, (rotateT.rotateT.rotateT) t,+	  mirrorVT t, (rotateT.mirrorVT) t, (rotateT.rotateT.mirrorVT) t,+	  (rotateT.rotateT.rotateT.mirrorVT) t]++tile 0 = (line 0 25 25 0) ++ (line 25 50 50 25)+tile 1 = (line 25 0 25 50) ++ (line 0 25 50 25)+tile 2 = (line 0 25 25 0) ++ (line 25 0 25 50) ++ (line 25 50 50 25)+tile 3 = (line 0 25 25 0) ++ (line 25 0 50 25) ++ (line 50 25 25 50) +++                (line 25 50 0 25)+tileRotL = (line 10 25 10 10) ++ (line 10 10 40 10) ++ (line 40 10 40 25) +++                (line 40 25 35 20) ++ (line 40 25 45 20)+tileRotR = mirrorVT tileRotL+tileMirH = (line 25 5 25 45) ++ (line 20 10 25 5) ++ (line 25 5 30 10) +++                (line 20 40 25 45) ++ (line 25 45 30 40)+tileMirV = rotateT tileMirH
+ Demos/Tiles/ToggleDrawGroupF.hs view
@@ -0,0 +1,24 @@+module ToggleDrawGroupF(toggleDrawGroupCF, toggleDrawGroupDF) where++import Fudgets+import DrawingF++--toggleDrawCF :: size -> drawing -> F (Either Bool ChangeTile) Event+toggleDrawCF size init = buttonBorderF 5 (drawDisplayCF size init)++--toggleDrawGroupCF :: layout -> choices +--	-> F (Int, (Either Bool ChangeTile)) (Int, Event)+toggleDrawGroupCF layout choices = +	let t v = toggleDrawCF (Point 50 50) v+	    toggles = zip [0..((length choices) - 1)] (map t choices)+	in listLF layout toggles++--toggleDrawDF :: size -> drawing -> F (Either Bool ChangeTile) Tile+toggleDrawDF size init = buttonBorderF 5 (drawDisplayDF size init)++--toggleDrawGroupDF :: layout choices +--	-> F (Int, (Either Bool ChangeTile)) (Int, Tile)+toggleDrawGroupDF layout choices = +	let t v = toggleDrawDF (Point 50 50) v+	    toggles = zip [0..((length choices) - 1)] (map t choices)+	in listLF layout toggles
+ Demos/Tiles/ToolsF.hs view
@@ -0,0 +1,46 @@+module ToolsF(toolsF) where++import Fudgets+import DrawingF+import RadioDrawF+import Tiles+import MyUtils++toolsF = loopLeftF ((throRight (radioDrawCF layout choices)) >==< toolControlF)++layout = matrixP 6 --matrixL 6 Horizontal 5++choices = [[], [], [], []] ++ [tileRotL] ++ [tileRotR] +++	[[], [], [], []] ++ [tileMirH] ++ [tileMirV]++--toolControlF :: F (Either (Int, XEvent) [Tile]) (Either (Int, Tile) ChangeTileNo)+toolControlF = +	let toButtons = Left+	    toBoard = Right+	    startstate = 0+	    step c m = case m of+		-- from Buttons+		(Left (n, _)) -> (n, [toBoard (t n)])+		-- from Choice+		(Right nt) -> (c, [toButtons (0, nt!!0),+					toButtons (1, nt!!1),+					toButtons (2, nt!!2),+					toButtons (3, nt!!3),+					toButtons (6, nt!!4),+					toButtons (7, nt!!5),+					toButtons (8, nt!!6),+					toButtons (9, nt!!7)])+	in absF (mapstateSP step startstate)++t 0  = changeToTN (TileNo 0)+t 1  = changeToTN (TileNo 1)+t 2  = changeToTN (TileNo 2)+t 3  = changeToTN (TileNo 3)+t 4  = rotateTN+t 5  = rotateTN . rotateTN . rotateTN+t 6  = changeToTN (TileNo 4)+t 7  = changeToTN (TileNo 5)+t 8  = changeToTN (TileNo 6)+t 9  = changeToTN (TileNo 7)+t 10 = mirrorHTN+t 11 = mirrorVTN
+ Demos/clock/ClockF.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE CPP #-}+module ClockF(clockShellF) where+import AllFudgets+--import DialogueIO hiding (IOError)+import Data.Maybe(fromMaybe)+#ifdef VERSION_old_time+import System.Time(CalendarTime(..))+#else+import Data.Time(TimeOfDay(..),localTimeOfDay,zonedTimeToLocalTime)+#endif++--default(Int)++trace x y = y+--ctr s x = ctrace s (show x) x++data ClockMode = Analog | Digital deriving (Show,Eq)++clockShellF =+  let size = fsize+      gcattrs = [GCFont digFont,+		 GCLineWidth width,+		 GCCapStyle CapRound]+      clockShellK = safeLoadQueryFont digFont (\font ->+		       dynShapeK gcattrs (const [])+				 (clockK startMode (digsize font)+			                 (Point 0 (font_ascent font))+			                 size))+      menuF = menuAltsF menuFont [Analog,Digital] show -- >=^<Left+      tickF = (Left. Right. Right)>^=<startupF [Just (update,1000)] timerF+      startcmds = map (Low . XCmd) [StoreName "ClockFudget"+                   --,ConfigureWindow [CWBorderWidth 5] -- testing+		  ]+      route msg =+	 case msg of+	   Left (Right (Left shape)) -> Left (Left shape)+	   Left (Right (Right pop)) -> Right pop+	   Right mode -> Left (Right (Left mode))+  in loopOnlyF (route>^=<shellKF (putsK startcmds clockShellK) menuF)>==<tickF++clockK :: ClockMode -> Size -> Point -> Size -> K (Either ClockMode Tick) (Either (Point->[DrawCommand]) PopupMenu)+clockK dig digsize bp size =+  let clockP dig size =+        let redraw s t = putsK [--Low (ConfigureWindow [CWBorderWidth 5]), -- testing+	                       High (Left (clockface dig bp t))] (clockP dig s)+            --gettime dig s = putLow (DReq GetLocalTime) (clockP dig s)+#ifdef VERSION_old_time+            gettime dig s = getLocalTime (redraw s)+#else+            gettime dig s = getZonedTime (redraw s)+#endif+            same = clockP dig size+        in getK $ \msg ->+	   case msg of+	     --Low (Expose _ 0)-> gettime dig size -- ??+	     --Low (DResp (Dbl t))-> redraw size t+	     Low (XEvt ev@(ButtonEvent _ _ rootpos _ Pressed _)) ->+	       putK (High (Right (PopupMenu rootpos ev))) same+	     Low (XEvt (ButtonEvent _ _ _ _ Released _))->+	       putK (High (Right PopdownMenu)) same+	     High (Right _) -> gettime dig size+	     High (Left mode) -> if mode==dig+			        then same+				else putK (layout mode) (gettime mode size)+	     _-> same++      layout mode =+        let s = case mode of+	          Digital-> digsize+		  Analog-> size+	in Low (layoutRequestCmd (plainLayout s False False))+      layout0 = layout dig+      startcmds =+        [ layout0,+          Low (XCmd $ GrabButton True AnyButton [] [ButtonPressMask,ButtonReleaseMask])+	]+  in changeBg color (putsK startcmds (clockP dig size))++#ifdef VERSION_old_time+timeofday CalendarTime{ctHour=h,ctMin=min,ctSec=s} =+  let t = s+60*(min+60*h)+      m = itof t / 60.0+  in (fmod (m/60.0) 24.0 ,fmod m 60.0)+#else+timeofday zt = (fmod (m/60.0) 24.0 ,fmod m 60.0)+  where+    t = round s+60*(min+60*h)+    m = itof t / 60+    TimeOfDay h min s = localTimeOfDay (zonedTimeToLocalTime zt)+#endif++clockface mode bp t size =+    case mode of+      Digital-> [DrawString bp (digits t)]+      Analog-> hands t size ++ scalemarks size++digits t =+  let (h,m) = aboth floor' (timeofday t)+  in show h ++ ":" ++ drop 1 (show (100+m))++hands t size =+  let (h,m) = timeofday t+  in hand h 12 0.6 size ++ hand m 60 0.95 size++hand v d r size =+  let a = v / itof d * 2.0 * pi+      h = scalePoint 0.5 size+  in [DrawLine (Line h (toRect r h a))]++scalemarks size =+  let r = scalePoint 0.5 size+      w2 = width*2+  in let mark n =+	  let a = itof n*pi/6.0+	  in Rect (psub (toRect 0.9 r a) (Point width width)) (Point w2 w2)+  in [FillArc (mark n) 0 (64*360) | n<-[0..11]]++toRect k (Point w h) r = Point (w+floor' (k*itof w*sin r)) (h+floor' (k*itof (-h)*cos r))++fmod :: Double -> Double -> Double+fmod a b =+  let y = a - b * fromIntegral (floor' (a/b))+  in {-if y<0.0 && argFlag "floor" False +     then trace (show (a,b,y)) y+     else -}y++digsize font = string_box_size font "88:88"++width = argReadKey "width" 10+fsize = fromMaybe (diag (argReadKey "size" 200)) defaultSize+color = argKey "color" "gold"+update = (argReadKey "update" 20) * 1000+startMode = if argKey "mode" "analog" == "digital" then Digital else Analog+digFont = defaultFont++itof=fromIntegral++rightadj s n pad = [pad|i<-[length s+1..n]]++s++floor' x = floor x+-- Solves a problem on slip-02 with direct calls to PfloorDouble2Int. TH 970314.
+ Demos/clock/fudgetclock.hs view
@@ -0,0 +1,5 @@+module Main where+import Fudgets+import ClockF++main = fudlogue clockShellF
+ Demos/graph/Compat.hs view
@@ -0,0 +1,18 @@+--+-- Library with LML compatible functions.+--+module Compat where+import Data.Char(isAlpha,isDigit)++mix :: [[a]] -> [a] -> [a]+mix [] d = []+mix (x:xs) d = x++case xs of [] -> []; _ -> d ++ mix xs d++takeWord :: String -> (String, String)+takeWord [] = ([],[])+takeWord (' ':cs) = takeWord cs+takeWord ('\n':cs) = takeWord cs+takeWord ('\t':cs) = takeWord cs+takeWord (c:cs) | isAlpha c = let (w,cs') = span (\c->isAlpha c || isDigit c || c=='_') cs in (c:w,cs')+		| isDigit c = let (w,cs') = span isDigit cs in (c:w, cs')+		| otherwise = ([c], cs)
+ Demos/graph/Diff.hs view
@@ -0,0 +1,42 @@+module Diff(diff,diffCmd) where+import Exp+import Ops+import Simp++diffCmd cmd =+  case cmd of+    Fun e -> Fun (diff e)+    Approx a n e -> Approx a n (diff e)++diff e =+  case e of+     Var -> one+     Const _ -> zero'+     Pow b e -> ce e `mul` diff b `mul` pow b (e-1)+     Binop bop e1 e2 -> diffbinop bop e1 e2+     Unop uop e -> mul (diff e) (uopdiff uop e)+++diffbinop bop e1 e2 =+  case bop of+     Badd -> add (diff e1) (diff e2)+     Bsub -> sub (diff e1) (diff e2)+     Bmul -> add (mul e1 (diff e2)) (mul (diff e1) e2)+     Bdiv -> div' (sub (mul (diff e1) e2) (mul e1 (diff e2))) (mul e2 e2)+     _ -> unimpl+++uopdiff unop e =+  case unop of+     Uneg -> neg one+     Usin -> Unop Ucos e+     Ucos -> neg (Unop Usin e)+     Uexp -> Unop Uexp e+     Utan -> add one (mul (Unop Utan e) (Unop Utan e))+     Uln -> inv e+     Uabs -> Unop Usgn e+     _ -> unimpl+++unimpl = error "Unimplemented diff\n"+
+ Demos/graph/Eval.hs view
@@ -0,0 +1,28 @@+module Eval where+import Exp+import Ops+--import List(union)++eval e =+  case e of+     Var ->  id+     Const k -> const k+     Pow b e -> let bv = eval b+                in \ x -> bv x ^^ e+     Binop bop e1 e2 ->+       let f = binopfun bop+           v1 = eval e1+           v2 = eval e2+       in \x -> f (v1 x) (v2 x)+     Unop unop e ->+       let f = unopfun unop+       in f . eval e++{-+freevars e =+  case e of+     Var x -> [x]+     Const _ -> []+     Binop _ e1 e2 -> union (freevars e1) (freevars e2)+     Unop _ e -> freevars e+-}
+ Demos/graph/Exp.hs view
@@ -0,0 +1,29 @@+module Exp where+import Ops++data Cmd+  = Fun Exp+  | Approx Approx Int Exp++data Approx = Trapets | RectU | RectO++--type Id = (Char, Int)++type Value = Double++data Exp+  = Var+  | Const Value+  | Pow Exp Int+  | Binop Bop Exp Exp+  | Unop Uop Exp+  deriving (Eq)++{-+stoid :: String -> Id+stoid (a:ds) = (a,read ds)++idtos :: Id -> String+idtos (c,n) = c:show n++-}
+ Demos/graph/ExpF.hs view
@@ -0,0 +1,42 @@+module ExpF(expF) where+import Fudgets+import Show+import Parser+import Lex+import Diff+import Exp(Exp)++expF =+    noStretchF False True $+    loopLeftF (toBothF>==<((throughExpInputF,LeftOf)>#==<diffF))+    --loopLeftF (toBothF>==<(throughExpInputF>==<diffF))++throughExpInputF = stripEither >^=< throughF expInputF++expInputF =+	concatMapF parse>==<+	(inputDoneSP>^^=<spacerF vCenterS (labLeftOfF "f(x)=" stringF))>=^<+	show_Cmds++parse s =+	case (cmds . lex') s of+	   Right (e,[])-> [e]+	   _ -> []	-- should generate error message++diffF =	map diffCmd>^=<+		(bufSP>^^=<+		(idF>+<buttonF "Derivate"))++bufSP =+  let buf b =+        getSP $ \x->+	case x of+         Left d -> buf (Just d)+         Right _ -> case b of+		    Nothing -> buf b+		    Just d -> putSP d $ buf b+  in buf Nothing++++
+ Demos/graph/Graph.hs view
@@ -0,0 +1,46 @@+import Fudgets+import PlotF+import ExpF+import Exp(Cmd(..))+import Eval+import Root+import Show(showf,showp)++main = fudlogue $ shellF' (setSizing Static) "Graph" $+       if argFlag "namel" True+       then nameLayoutF layout mainF+       else mainF++layout = v [l f,+	    l gr,+	    h [v [--l p,+		  l a]{-,l q-}]]+  where --al = alignSepNL 0 aCenter aCenter+	h = hBoxNL+	v = vBoxNL+	l = leafNL++f:gr:a:p:q:_ = map show [(1::Int)..]+        +mainF = --nameF q (stubF quitButtonF)>==<+        (nameF a showareaF>+<nullF{-nameF p showpointF-})>==<+	nameF gr grF>==<+	nameF f funcF++funcF =(Left . map evalr)>^=<expF+  where+    evalr cmd =+      case cmd of+        Fun e -> RFunc (eval e,root e)+	Approx a n e -> RLines a n (eval e)++grF = plotF Nothing++showareaF = displayF >=^<showarea+--showpointF = displayF >=^<showp++showarea (xa,(y1,y2)) =+	"x: " ++ showinterval xa ++ ", y: " ++ showinterval (y2,y1)++showinterval (a,b) = "[" ++ showf a ++ ", " ++ showf b ++ "]"+
+ Demos/graph/Lex.hs view
@@ -0,0 +1,23 @@+module Lex where+import HbcUtils(chopList,breakAt)+import Compat(takeWord)+import Data.Char++lex' = lexfix . filter (/=[]) . chopList taketoken++lexfix [] = []+lexfix (a:".":b:xs) = if isDigit (head a) && isDigit (head b)+ 			  then (a++"."++b):lexfix xs+			  else a:".":lexfix (b:xs)+lexfix (x:xs) = x:lexfix xs++-- taketoken = takeword++taketoken [] = ([],[])+taketoken ccs@(c:cs) =+	case c of+	  '\"' -> let (s,rest) = breakAt '"' cs+		  in (c:s,rest)+	  _ -> takeWord ccs++
+ Demos/graph/Ops.hs view
@@ -0,0 +1,87 @@+module Ops(Bop(..),Uop(..),unops,addops,mulops,binoplex,binopfun,unoplex,unopfun,+	show_Bop,show_Uop,addopt,mulopt{-,powopt-})+where++data Bop = Badd | Bsub | Bmul | Bdiv | Bmin -- | Bpow+           deriving (Eq)++data Uop = Uneg | Usin | Ucos | Utan | Uexp | Ulog | Uln | Usqrt |+	   Uabs | Ufloor | Uceil | Uround | Utanh | Ucosh | Usinh | Ugamma |+	   Uatan | Uacos | Uasin | Usgn | Utheta+		deriving (Eq)++assocdef x xs e = maybe e id $ lookup x xs++binoplex binop = fst (assocdef binop binoptab (error "undefined binop"))+binopfun binop = assocdef binop (map snd binoptab) (error "undefined binop")++binoptab = addopfuncs ++ mulopfuncs -- ++ powopfuncs++addopfuncs =+  [("+",(Badd,(+))),+   ("-",(Bsub,(-)))+  ]++mulopfuncs =+  [("*",(Bmul,(*))),+   ("/",(Bdiv,(/))),+   ("!",(Bmin,min))+  ]++{-+powopfuncs =+  [("^",(Bpow,pow))+  ]+-}++addops = map fst addopfuncs+mulops = map fst mulopfuncs+--powops = map fst powopfuncs++addopt = map (fst . snd) addopfuncs+mulopt = map (fst . snd) mulopfuncs+--powopt = map (fst . snd) powopfuncs++unoplex unop = fst (assocdef unop unoptab (error "undefined unop"))+unopfun unop = assocdef unop (map snd unoptab) (error "undefined unop")++unoptab =+  [("-",(Uneg,negate)),+   ("sin",(Usin,sin)),+   ("cos",(Ucos,cos)),+   ("tan",(Utan,tan)),+   ("exp",(Uexp,exp)),+   ("log",(Ulog,log)),+   ("ln",(Uln,log)),+   ("log",(Uln,log)),+   ("sqrt",(Usqrt,sqrt)),+   ("fabs",(Uabs,abs)),+   ("abs",(Uabs,abs)),+   ("floor",(Ufloor,fromIntegral.floor)),+   ("round",(Uround,fromIntegral.round)),+   --("ceil",(Uceil,ceil)),+   ("tanh",(Utanh,tanh)),+   ("cosh",(Ucosh,cosh)),+   ("sinh",(Usinh,sinh)),+   --("gamma",(Ugamma,gamma)),+   ("atan",(Uatan,atan)),+   ("acos",(Uacos,acos)),+   ("asin",(Uasin,asin)),+   ("sgn",(Usgn,sgn)),+   ("theta",(Utheta,theta))+  ]++theta :: Double->Double+theta x = if x<0.0 then 0.0 else 1.0+sgn x = theta x - theta (0.0-x)++--pow x y = exp (y * log x)+--pow x y = x**y+--pow x y = x^^y++unops = map fst unoptab++show' tab x = assocdef x (map (\(x,(y,_))->(y,x)) tab) (error "show' in Ops.hs")++show_Uop = show' unoptab+show_Bop = show' binoptab
+ Demos/graph/Parser.hs view
@@ -0,0 +1,64 @@+module Parser(parse_Exp,expr,cmds,complete) where+import Parsop+import Exp+import Ops+import Compat(mix)+import Data.Char++cmds = seq' cmd (lit ",")++cmd+    = (lit "A" +<+ approx +++ int +++ expr ==> approxcmd)+  ||| (expr ==> Fun)+  where+    approxcmd ((a,n),e) = Approx a n e++approx+    = (lit "t" ==> const Trapets)+  ||| (lit "u" ==> const RectU)+  ||| (lit "o" ==> const RectO)++parse_Exp = complete . expr++--exprs = seq' expr (lit ",")+expr = leftAssoc term addop++term = leftAssoc factor mulop++factor = (aexp +++ optexponent) ==> (%%) (flip id)++aexp+    = num+  ||| var +  ||| ((unop +++ factor) ==> (%%) Unop)+  ||| (lit "(" +<+ expr +>+ lit ")")++mulop = is (\t->elem t mulops) ==> binoplex+addop = is (\t->elem t addops) ==> binoplex+unop = is (\t->elem t unops) ==> unoplex+--ident = is iscellid ==> stoid+var = lit "x" ==> const Var+num = is (isDigit . head) ==> (Const . readf)++optexponent = cond exponent id+  where+     exponent = (lit "^" +<+ int) ==> (flip Pow)++int = is (all isDigit) ==> read++leftAssoc item op = item +++ (***) (op +++ item) ==> (%%) tree++tree e1 [] = e1+tree e1 ((op,e2):oes) = tree (Binop op e1 e2) oes++iscellid (c1:cs) = cs/=[] && isAlpha c1 && all isDigit cs++readf :: String -> Double+readf s = if '.' `elem` s then read s else read (s++".0")++complete ts =+  case ts of+     Right(e,[])->Right e+     Left ts-> Left ("Syntax error before: " ++ mix (take 10 ts) " ")+     Right(_,ts)-> Left ("Trailing garbage: " ++ mix (take 10 ts) " ")+
+ Demos/graph/Parsop.hs view
@@ -0,0 +1,83 @@+module	Parsop where+infixl |||, +++, +>+, +<++{-+infix "==>";+prefix "***";+infix "+<+";+infix "+>+";+infix "iff";+prefix "%%";+-}+{-+export	empty,+-- matches the empty string+	+++,+-- sequence, returns a pair+	|||,+-- alternative+	is,+-- terminal tested with a predicate+	`,+-- terminal tested with equality+	***,+-- 0 or many (transitive closure)+	+<+,+-- sequence, throw away first part+	+>+,+-- sequence, throw away second part+	==>,+-- transform+	cond,+-- 0 or one+	seq',+-- sequence of 0 or many with a separator+	seq1,+-- sequence of 1 or many with a separator+	iff,+-- conditional+	%%;+-- uncurry+-}+trycase pf fail succeed ws=+  case pf ws of+     Left _ -> fail ws+     Right(x,ws) -> succeed x ws+++failure ws= Left ws+success x ws = Right(x,ws)++try pf cont = trycase pf failure cont++is p [] = Left []+is p (w:ws) = if p w+		  then Right(w,ws)+		  else Left (w:ws)++lit w = is (==w)++pf1 +++ pf2 = try pf1 (\x ->try pf2 (\y -> success(x,y)))++pf1 ||| pf2 = trycase pf1 pf2 success++pf ==> f = try pf (success . f)++(***) pf = ((pf +++ (***) pf) ==> (%%) (:)) ||| success []++sep +<+ pf1 = (sep +++ pf1) ==> snd+pf1 +>+ sep = (pf1 +++ sep) ==> fst++--seq1 pf sep = ((pf +++ (sep +<+ seq1 pf sep)) ==> %% (.)) ||| (pf ==> (:[]))+seq1 pf sep = (pf +++ ((sep +<+ seq1 pf sep) ||| empty [])) ==> (%%) (:)++seq' pf sep = seq1 pf sep ||| empty []++empty = success++cond pf x = pf ||| empty x++pf `iff` p = try pf (\x -> if p x+			  then success x+			  else failure)++(%%) = uncurry
+ Demos/graph/PlotF.hs view
@@ -0,0 +1,201 @@+module PlotF+    (plotF,ToPlot(..),Area(..),Interval(..),Func(..))+  where+import AllFudgets+import Data.List(sortBy)+import Data.Maybe(fromMaybe)+import ZoomF+import HbcUtils(apSnd)+import UserCoords+import Exp(Approx(..))++data Plot = Grid | Axes | Functions [Double->Double] | Lines [(Double,Double)]++plotReal size0 area plot = FlexD size0 False False draw+  where+    draw (Rect p size) = move p (drawgraph size area plot)++gridstep w xa h ya = max (gridstep' w xa) (gridstep' h (swap ya))+  where+    gridstep' w (x0,x1) =+       if mag>=minstep+       then mag+       else if mag2>=minstep+            then mag2+	    else if mag5>=minstep+	         then mag5+		 else mag10+      where+        maxcnt = w `div` 8+	minstep = d / fromIntegral maxcnt+	mag = 10^^floor (log10 minstep)+	mag2 = 2*mag+	mag5 = 5*mag+	mag10 = 10*mag+        d = x1-x0+++drawgraph (Point w h) (xa,ya) plot =+    case plot of+      Grid -> drawgrid+        where+	  drawgrid = hlines++vlines+	  d = gridstep w xa h ya+	  hlines = [DrawLine (lL 0 y xh y) |+	            let lo=ceiling' d (snd ya),+		    yu<-[lo,lo+d .. floor' d (fst ya)],+		    let y=wdw h ya yu]+	  vlines = [DrawLine (lL x 0 x yh) |+	            let lo=ceiling' d (fst xa),+		    xu<-[lo,lo+d .. floor' d (snd xa)],+		    let x=wdw w xa xu]+      Axes -> drawaxes+        where+	  drawaxes =+	     [DrawLine (lL 0 y0 xh y0),+	      drawLines [pP (xh-d) (y0-d),pP xh y0,pP (xh-d) (y0+d)],+	      DrawLine (lL x1 (y0-d) x1 (y0+d)),+	      DrawLine (lL x0 0 x0 yh),+	      drawLines [pP (x0-d) d,pP x0 0,pP (x0+d) d],+	      DrawLine (lL (x0-d) y1 (x0+d) y1)]+      Functions fs -> map drawfunc fs +	where+	  drawfunc f =+	    drawLines [Point wx ((wdw h ya . f . user w xa) wx) | wx<-[0,2..w]]+      Lines ps -> [drawLines [Point (wdw w xa x) (wdw h ya y)|(x,y)<-ps]]+  where+    drawLines = DrawLines CoordModeOrigin+    y0 = wdw h ya 0.0+    y1 = wdw h ya 1.0+    x0 = wdw w xa 0.0+    x1 = wdw w xa 1.0+    yh = h-1+    xh = w-1+    d = 4++ceiling' d x = fromIntegral (ceiling (x/d)) * d+floor' d x = fromIntegral (floor (x/d)) * d+log10 x = log x / log 10++showroot (Point w h) ((xa@(x1,x2)),ya) roots p@(Point wx wy)=+    case sortroots [x | root<-roots, Just x<-[root (user w xa wx) eps]] of+      x:_ -> Popup (pP (wdw w xa x) (wdw h ya 0.0)) ("x=" ++ show x)+      [] -> Popup p "No root?"+  where+    sortroots = sortBy cmpdist+    cmpdist x1 x2 = compare (dist x1) (dist x2)+    dist x = abs (x-x0)+    x0 = user w xa wx+    eps = abs (x0/1.0e10)+    rnd x = real (round (x * r)) / r  -- keep approx 5 significant digits+      where r = scaleFloat (17+exponent x) 0.5++rmroot = Popdown++data ToPlot+  = RFunc Func+  | RLines Approx Int (Double->Double)++type Func = (Double->Double,Double->Double->Maybe Double)++zoomDispF size = zoomF dispF+  where+    dispF = graphicsDispGroupF' custom rootDispF+    custom = setInitDisp initD . setSizing Static .+             (setBgColor paper :: (Customiser (GraphicsF a)))+    initD = plotD size startarea []++plotD size area@(xa,_) fs =+    stackD (fgD grid (g gr):+            softAttribD (gcattrs fgColor) (g axes):+            ps)+  where+    ps = zipWith p1 (cycle pens) fs+    p1 pen f = softAttribD (gcattrs pen) (g (p f))+    p :: ToPlot -> FlexibleDrawing+    p (RFunc (f,_)) = plotReal size area (Functions [f])+    p (RLines Trapets n f) = plotReal size area (Lines (trapets xa n f))+    p (RLines RectO n f) = plotReal size area (Lines (rect max xa n f))+    p (RLines RectU n f) = plotReal size area (Lines (rect min xa n f))+    gr = plotReal size area Grid+    axes = plotReal size area Axes+    gcattrs fg = [GCForeground (colorSpec fg), GCLineWidth lw,+		  GCCapStyle CapProjecting+		  ]++    rect :: (Double->Double->Double)->(Double,Double) -> Int -> (Double->Double) -> [(Double,Double)]+    rect est xa n = vlines . hlines . trapets xa n+     where+      hlines ((x1,y1):ps@((x2,y2):_)) = (x1,x2,est y1 y2):hlines ps+      hlines _ = []++      vlines [] = []+      vlines ((x1,x2,y):hs) = (x1,y):(x2,y):vlines' y hs++      vlines' y [] = []+      vlines' y ((x1,x2,y2):hs) =+        if y==y2+	then (x2,y2):vlines' y2 hs+	else (x1,y2):(x2,y2):vlines' y2 hs++    trapets :: (Double,Double) -> Int -> (Double->Double) -> [(Double,Double)]+    trapets (x1,x2) n f = [pairwith f (x i)|i<-[0..n]]+      where+	x i = x1+dx*fromIntegral i+	dx = (x2-x1)/fromIntegral n++startarea = ((-6.5,6.5),(6.5,-6.5))++--plotF :: Maybe Size -> F (Either [Func] Area) (Either Area (Double,Double))+plotF optsize =+    loopThroughRightF ctrlF (zoomDispF size)+  where+    size = fromMaybe (Point 400 400) optsize++    --f0 x = 0.0 -- dummy+    --r0 x dx = Just x -- dummy+    state0 = (startarea,[])++    plot area funcs = replaceAllGfx $ plotD size area funcs++    toGfx = Left . Right+    toDisp = toGfx . Left+    toRootDisp = toGfx . Right++    ctrlF = putF (Right (Left startarea)) $ mapstateF ctrl state0++    ctrl state@(area,func) = either fromLoop fromOutsize+      where+        output x  = apSnd (Right x:)+        same = (state,[])+	redraw area' func' =+	  ((area',func'),[toRootDisp rmroot,toDisp (plot area' func')])+	zoom area' = output (Left area') $ redraw area' func+	newfunc f = redraw area f++	fromOutsize = either newfunc zoom+        fromLoop = either fromZoom fromGfx+	fromGfx _ = same++	fromZoom zoomMsg =+	  case zoomMsg of+	    ZoomIn s p  -> zoom (zoomin s p area)+	    ZoomOut s p -> zoom (zoomout s p area)+	    ZoomRect size (Rect p s) ->+	      if s =.> 2+	      then zoom (zoomrect (size,area) p (p+s))+	      else same+	    ZoomPick s p ->+	      (state,[toRootDisp (showroot s area [r|RFunc (_,r)<-func] p)])+	    ZoomResize _ -> (state,[toRootDisp rmroot])++rootDispF =+    --delayF $+    bubblePopupF (displayF' pm)+  where+    pm = setBorderWidth 0.setMargin 0.setSizing Dynamic. setBgColor "white"++pens = argKeyList "pens" ["blue3","red3","green4","orange"]+grid = argKey "grid" "grey"+paper = argKey "plotpaper" "grey90"+lw = argReadKey "linewidth" 2 -- 0 looks better than 1.
+ Demos/graph/Root.hs view
@@ -0,0 +1,23 @@+module Root where+import Eval+import Diff+import Exp+import Ops(Bop,Uop)++root e x0 dx =+  let f = eval e+      f' = eval (diff e)+      step x =  let y'=f' x+		in if y'==0.0+		   then Nothing+		   else Just (x - f x / y')+      infapproxs x = x:(case step x of+		          Nothing -> []+		          Just x2 -> infapproxs x2)+      approxs = take 20 (infapproxs x0)+      root (x1:x2:xs) = if abs (x1-x2)<dx+			then Just x2+			else root (x2:xs)+      root _ = Nothing++  in root approxs
+ Demos/graph/Show.hs view
@@ -0,0 +1,57 @@+module Show(show_Exp,show_Cmds,show_Cmd,showf,showp) where+import Exp+import Ops+import Numeric(showGFloat)+import Compat(mix)+--import Printf -- From hbc_library, comment out if not compiling with hbc.++--- hbc version:+--showf x = printf "%.5g" [UDouble x]+--showp (x,y) = printf "(%.5g,%.5g)" [UDouble x,UDouble y]+--- standard version:+--showf = show+showf x = showGFloat (Just 5) x ""+showp (x,y) = "("++show x++","++show y++")"+---++show_Cmds cmds = mix (map show_Cmd cmds) ", "++show_Cmd cmd =+  case cmd of+    Fun e -> show_Exp e+    Approx a n e -> "A "++show_Approx a++" "++show n++" "++show_Exp e++show_Approx Trapets = "t"+show_Approx RectO = "o"+show_Approx RectU = "u"++--show_Exps es = mix (map show_Exp es) ", "+show_Exp e =+  case e of+     Binop Badd e1 e2 -> show_Exp e1 ++ show_Bop Badd ++ show_Exp e2+     Binop bop e1 e2 | bop `elem` addopt -> show_Exp e1 ++ show_Bop bop ++ show_term e2+     Unop uop e | uop==Uneg -> show_Uop Uneg ++ show_term e+     _ -> show_term e++show_term e =+  case e of+     Binop bop e1 e2 | bop `elem` mulopt -> show_term e1 ++ show_Bop bop ++ show_power e2+     _ -> show_power e++show_power e =+  case e of+    Pow b n -> show_aexp b ++ "^" ++ show n+    _ -> show_aexp e++show_aexp e =+  case e of+     Var -> "x"+     Const x -> show x+     Unop uop e | uop/=Uneg -> show_Uop uop ++ show_argexp e+     e -> "(" ++ show_Exp e ++ ")"+++show_argexp e =+  case show_aexp e of+     s@('(' : _) -> s+     s -> " " ++ s
+ Demos/graph/Simp.hs view
@@ -0,0 +1,61 @@+module Simp where+import Exp+import Ops++default(Int)++add (Const x) (Const y) = Const (x + y)+add (Const x) e = add e (Const x)+ -- || add (Unop Uneg e) e2 = sub e2 e -- changes the order of terms, confusing+add e (Unop Uneg e2) = sub e e2+add (Binop Badd e1 e2) e3 = add e1 (add e2 e3)+add e (Binop Bmul (k@(Const _)) e2) | e==e2 = mul (add k one) e+add (Binop Bmul (k1@(Const _)) e1) (Binop Bmul (k2@(Const _)) e2) | e1==e2 = mul (add k1 k2) e1+add e1 e2 = if e2==zero' then e1+		else if e1==e2 then mul two e1+		else Binop Badd e1 e2++sub (Const x) (Const y) = Const (x - y)+sub e1 (Unop Uneg e2) = add e1 e2+sub e1 e2 = if e2==zero' then e1+		else if e1==zero' then Unop Uneg e2+		else if e1==e2 then zero'+		else Binop Bsub e1 e2++mul (Const x) (Const y) = Const (x * y)+mul Var Var = pow Var 2+mul Var (Pow Var n) = Pow Var (n+1)+mul (Pow Var n) Var = Pow Var (n+1)+mul (Pow Var n) (Pow Var m) = Pow Var (n+m)+mul e (Const y) = mul (Const y) e+mul e1 (Unop Uneg e2) = neg (mul e1 e2)+mul (Unop Uneg e1) e2 = neg (mul e1 e2)+mul e1 (Binop Bmul e2 e3) = mul (mul e1 e2) e3+ -- || mul (k1 @ (Const _)) (Binop Bmul (k2 @ (Const _)) e) = mul (mul k1 k2) e+mul e1 e2 = if e1==one then e2+		else if e1==zero' then zero'+		else if e1==minusone then neg e2+		else Binop Bmul e1 e2++div' (Const x) (Const y) = Const (x / y)+div' e1 (Unop Uneg e2) = neg (div' e1 e2)+div' (Unop Uneg e1) e2 = neg (div' e1 e2)+div' (Binop Bmul (Const x) e) (Const y) = mul (Const (x/y)) e+div' e1 e2 = if e2==one then e1+		else Binop Bdiv e1 e2++pow b 0 | b/=zero'= one+pow b 1 = b+pow b e = if b==one then one else Pow b e++neg (Const x) = (Const (0.0 - x))+neg (Unop Uneg e) = e+neg e = Unop Uneg e++inv e = div' one e++zero' = Const 0.0+one = Const 1.0+two = Const 2.0+minusone = neg one+ce = Const . fromIntegral
+ Demos/graph/UserCoords.hs view
@@ -0,0 +1,41 @@+module UserCoords where+import Fudgets(Point(..))++type Interval =(Double,Double)+type Area = (Interval,Interval)++wdw h (u1,u2) u = ftoi' (0.5+(u-u1)/(u2-u1)*real h)+user w (u1,u2) u = (real u-0.5)/real w*(u2-u1)+u1++userp ((Point w h),(xa,ya)) (Point x y) = (user w xa x,user h ya y)+wdwp ((Point w h),(xa,ya)) (x,y) = Point (wdw w xa x) (wdw h ya y)++zoom k (Point w h) (Point x y) (xa,ya) = (zoom2 k w x xa,zoom2 k h y ya)+  where+    zoom2 k tot rel ua@(u1,u2) = (zoom1 k u1 u0,zoom1 k u2 u0)+      where+        u0 = user tot ua rel+	zoom1 k u u0 = k*(u-u0)+u0++zoomin = zoom 0.5+zoomout = zoom 2.0++zoomrect sa p1 p2 =+  let (nx1,ny1) = userp sa p1+      (nx2,ny2) = userp sa p2+  in ((nx1,nx2),(ny1,ny2))++--++real :: Int->Double+real = fromIntegral++ftoi :: Double->Int+ftoi = floor++ftoi' x =     let maxint = 32767 -- Xlib limitation+	          max = real maxint+	          negmax = 0.0-max+	      in if x>max then maxint+		 else if x<negmax then -maxint+		 else ftoi x
+ Demos/graph/ZoomF.hs view
@@ -0,0 +1,84 @@+module ZoomF(ZoomOutput(..),zoomF) where+import AllFudgets++data ZoomOutput+  = ZoomIn Size Point+  | ZoomOut Size Point+  | ZoomRect Size Rect+  | ZoomPick Size Point +  | ZoomResize Size+  deriving (Eq,Show)++zoomF fud = groupF startcmds zoomK0 fud+  where+    startcmds = map XCmd $ +                 [ConfigureWindow [CWBorderWidth 0],+                 ChangeWindowAttributes [CWEventMask eventmask],+		 clickGrab 1,+		 clickGrab 3,+		 GrabButton False (Button 2) []+				 [ButtonPressMask,+				 PointerMotionMask,+				 ButtonReleaseMask]]+    clickGrab n = GrabButton False (Button n) [] []+    eventmask = [ButtonPressMask]++    zoomK0 =+	setFontCursor 130 $+        allocNamedColorPixel defaultColormap bgColor $ \ bg ->+        allocNamedColorPixel defaultColormap fgColor $ \ fg ->+        wCreateGC rootGC (GCSubwindowMode IncludeInferiors:+	                  GCFunction GXxor:+			  invertColorGCattrs fg bg) $ \ gcinv ->+        waitForMsg layoutsize $ \ size ->+        zoomK gcinv size+      where+        layoutsize (Low (LEvt (LayoutSize size))) = Just size+	layoutsize _ = Nothing++    zoomK gcinv size =+        getK $ message low high+      where+        same = zoomK gcinv size+	high _ = same+	low event =+	  case event of+	    XEvt ButtonEvent {pos=p,state=mods} | Shift `elem` mods ->+		  put (ZoomPick size p) same+	    XEvt ButtonEvent {pos=p,button=Button 1} -> put (ZoomIn size p) same+	    XEvt ButtonEvent {pos=p,button=Button 3} -> put (ZoomOut size p) same+	    XEvt ButtonEvent {pos=p,button=Button 2,type'=Pressed} ->+	      putLow (wDrawRectangle gcinv (Rect p (Point 1 1))) $+	      rubberBandK gcinv size p p $ \ size' ->+	      zoomK gcinv size'+	    --XEvt MotionNotify {} ->+	    LEvt (LayoutSize size') ->+	      put (ZoomResize size') $+	      zoomK gcinv size'+	    _ -> same++rubberBandK gcinv size p0 p1 return =+     getK $ message low high+  where+    cont p = rubberBandK gcinv size p0 p return+    resize size' = rubberBandK gcinv size' p0 p1 return+    same = cont p1+    toggle p0 p1 = putLow $ wDrawRectangle gcinv (rect' p0 p1)+    high _ = same+    low event =+      case event of+        XEvt MotionNotify {pos=p} ->+	  toggle p0 p1 $+	  toggle p0 p $+	  cont p+	XEvt ButtonEvent {pos=p,type'=Released,button=Button 2} ->+	  toggle p0 p1 $+	  put (ZoomRect size (rect' p0 p1)) $+	  return size+        LEvt (LayoutSize size') -> resize size'+	_ -> same++rect' p1 p2 =+  let p0 = pmin p1 p2+      p = pmax p1 p2+  in Rect p0 (p-p0+1)
+ Demos/life/Generate.hs view
@@ -0,0 +1,17 @@+module Generate where++import Utils2++generate (bounds,g) = (bounds,newg)+    where (xm,ym) = bounds+	  wrap u m = (u+m) `mod` m+	  newg = (cond g . foldl insert [] . reverse) [(wrap u xm, wrap v ym) | (x,y) <- g, u <- [x-1..x+1], v <- [y-1..y+1]]+	  insert (pn@(p1,n):l) p | p == p1 = (p1,n+1):l+				 | p > p1  = pn : insert l p+	  insert l p = (p,1) : l+	  cond l ((p,n):nbs) = if not lived && n == 3 || lived && (n == 3 || n == 4) then p : rest else rest+			       where (l',lived) = mapgen (\l->(l,True)) (flip const) (\l->(l,False)) p l+				     rest = cond l' nbs +	  cond _ [] = []++
+ Demos/life/Life.hs view
@@ -0,0 +1,40 @@+module Life{-(life)-} where+import AllFudgets+import Utils2++life :: Int -> Generation -> F LifeCmds LifeEvts+--life cellsize (bnds,gen) = simpleF "Life" lifeK (topoint s0 bnds) s0+life cellsize (bnds,gen) = simpleWindowF lifeK (topoint s0 bnds) False False s0+			      where s0 = (cellsize,bnds,gen)++pointPair (x,y) = Point x y+pairPoint (Point x y) = (x,y)++--fillCircle pos d = let s = Point d d in FillArc (Rect pos s) 0 (64 * 360)++lifeK draw clear s event = +    case event of+       High (NewCell (pos,l))      -> (s1, pattern s1 pos l) where s1 = sGen (setgen l pos (gen s)) s+       High (NewGen (nb,ng))       -> (s1, redrawgen s1) where s1 = sGen ng (sBnds nb s)+       High (NewCellSize ncs)      -> (s1,[(High . NewBounds . topos s1 . topoint s . bnds) s]) where s1 = sCellsize ncs s+       Low (XEvt (Expose _ 0))     -> (s,redrawgen s)+       Low (XEvt (ButtonEvent _ p _ _ Pressed _)) -> (s,[(High . MouseClick . topos s) p])+       Low (LEvt (LayoutSize nsize)) -> (s, [(High . NewBounds . topos s) nsize])+       _ -> (s,[])++    where+	pattern s p l = map (Low . (if l then draw else clear)) [fillCircle (topoint s p) (truncate (cellsize s))]+	redrawgen s = Low (XCmd ClearWindow) : concat [pattern s p True | p <- gen s] ++ [Low $ XCmd Flush]++topoint s = scalePoint (cellsize s) . pointPair+topos s = pairPoint . scalePoint (1 / (cellsize s))++cellsize (cs,b,g) = (fromIntegral cs)+bnds     (cs,b,g) = b+gen      (cs,b,g) = g+xm = fst . bnds+ym = snd . bnds++sCellsize cs1 (cs,b,g) = (cs1,b,g)+sBnds     b1  (cs,b,g) = (cs,b1,g)+sGen      g1  (cs,b,g) = (cs,b,g1)
+ Demos/life/Main.hs view
@@ -0,0 +1,31 @@+module Main(main,control) where++import Fudgets+import Life+import Utils2+import Panel+import Generate++--import NonStdTrace++main = fudlogue $ shellF "Life" (hBoxF control)++control = loopLeftF ((Left >^=< life defaultcellsize s0) >==< absF (mapstateSP c s0)) >==< panel+    where c state@(bounds@(xm,ym), gen) msg = +	      case msg of+	          Left fromMatrix ->+                     case fromMatrix of+			 MouseClick p -> ((bounds,newgen), [NewCell (p,newcell)])+			     where (newgen,newcell) = togglegen p gen++			 NewBounds (b@(xm,ym)) -> redraw (b,[(x,y) | (x,y) <- gen, x < xm, y < ym])+		  Right fromPanel ->+		      case fromPanel of+			  Right newSize -> (state, [NewCellSize newSize])+			  Left tick -> redraw (generate state)+		  _ -> (state,[])+	  redraw ns = (ns,[NewGen ns])+	    +bounds0 = (20,20)++s0 = (bounds0,[])
+ Demos/life/Panel.hs view
@@ -0,0 +1,20 @@+module Panel  where -- (panel,defaultcellsize) where++import Fudgets+import Timer+{-+quitShell title f = shellF title +	  (stripEither >^=< (f >+< quitButtonF) >=^< Left)+-}+panel = {-shellF "Panel"-}+        (noStretchF True True $ vBoxF $ runButton >+< sizegroup)++runButton = timer interval >==< toggleButtonF "Run" ++interval = argReadKey "interval" 200 -- milliseconds++sizegroup = radioGroupF sizes defaultcellsize++sizes = [(3::Int,"Tiny"), (5,"Small"),(10,"Medium"),(25,"Huge")]++defaultcellsize = fst (sizes !! 2)
+ Demos/life/Timer.hs view
@@ -0,0 +1,6 @@+module Timer(timer) where++import Fudgets++timer :: Int -> F Bool Tick+timer t = timerF >=^< \b -> if b then Just (t,0) else Nothing
+ Demos/life/Utils2.hs view
@@ -0,0 +1,20 @@+module Utils2 where++import HbcUtils(apFst)++type Life = Bool+type Pos = (Int, Int)+type Bounds = Pos+type Generation = (Bounds,[Pos])++data LifeCmds = NewCell (Pos, Life) | NewGen Generation | NewCellSize Int+data LifeEvts = NewBounds Bounds | MouseClick Pos++mapgen found more notfound p l = mg l+    where mg (p1:l) | (p == p1) = found l+	            | (p >  p1) = more p1 (mg l)+	  mg l = notfound l++togglegen p = mapgen (\l->(l,False)) (apFst . (:)) (\l->(p:l,True)) p+setgen t p = mapgen c (:) c p where c = if t then (p:) else id+
+ Demos/mines/Box.hs view
@@ -0,0 +1,59 @@+module Box(boxF,readAllBitmaps) where+import AllFudgets+import HbcUtils(lookupWithDefault)+import MineField+import Pics++pictSize :: Size+pictSize = Point 32 32++initcmds = [XCmd $ ChangeWindowAttributes [CWEventMask [ExposureMask]], but 1, but 2, but 3] +           where but t = XCmd $ GrabButton True (Button t) [] [ButtonPressMask, ButtonReleaseMask]++boxF :: [(Symbol,PixmapId)] -> F Symbol (Coord -> MInput)+boxF sps = windowF initcmds (simpleK (boxK sps) pictSize SBlank)++boxK :: [(Symbol,PixmapId)] -> Drawer -> Drawer -> Fms' Symbol Symbol (Coord -> MInput)+boxK ps draw _clear s event =+    case event of+      High s'                                              -> (s', redraw ps s')+      Low (XEvt (Expose _ 0))                              -> (s, redraw ps s)+      Low (XEvt (ButtonEvent _ _ _ ms Pressed (Button b))) ->+          (s, case (ms,b) of+                ([]       ,1) -> [High Move]+                ([Control],1) -> [High Bomb]+                ([Shift]  ,1) -> [High Free]+                (_        ,2) -> [High Bomb]+                (_        ,3) -> [High Free]+                _             -> [])+--    Low (LayoutSize nsize)                     -> (s, ??)+      _ -> (s,[])+    where redraw ps SBlank = [Low $ XCmd ClearWindow]+          redraw ps s = +		let p = lookupWithDefault ps (error ("No bitmap for "++show s)) s+		in  [Low $ XCmd ClearWindow, Low (draw (CopyPlane (Pixmap p) (Rect 0 pictSize) 0 0))]+{-+          redraw ps (SNumber 0) = [Low ClearWindow, Low (draw (CopyPlane (Pixmap ps) (Rect (Point 0 0) (Point 32 32)) (Point 0 0) 0))]+          redraw ps (SNumber n) = [Low ClearWindow, Low (draw (DrawImageString tp (show n)))]+          redraw ps (SCurrent n) = [Low ClearWindow, Low (draw (DrawImageString tp ("X"++show n)))]+	  redraw ps SBombX = [Low ClearWindow, Low (draw (DrawImageString tp "BX"))]+	  redraw ps SBombDone = [Low ClearWindow, Low (draw (DrawImageString tp "BD"))]+	  redraw ps SBomb = [Low ClearWindow, Low (draw (DrawImageString tp "B"))]+	  redraw ps SFree = [Low ClearWindow, Low (draw (DrawImageString tp "F"))]+tp = Point 10 18+-}++bitmaps = +    [(SNumber n,num!!n) | n<-[0..5]] +++    [(SCurrent n,cur!!n) | n<-[0..5]] +++    [(SBombX, bombx), (SBombDone, bombdone), (SBomb, bomb), (SFree, free)]++readAllBitmaps f = readBitmaps bitmaps f++--readBitmaps :: [(Symbol,String)] -> ([PixmapId] -> K a b) -> K a b+readBitmaps ns f = readb [] ns f+	where readb ps [] f = f ps+              readb ps ((n,bm):ns) f = bitmapFromData bm $ \r ->+	                          case r of+				    BitmapBad -> error ("Cannot read bitmap "++show n)+				    BitmapReturn _ _ p -> readb (ps++[(n,p)]) ns f
+ Demos/mines/FUtil.hs view
@@ -0,0 +1,35 @@+module FUtil(module FUtil,F) where+import Fudgets++ignoreI :: F a b -> F aa b+ignoreI f = f >=^< (\x->error "ignoreI") +ignoreO :: F a b -> F a bb+ignoreO f = (\x->error "ignoreO") >^=< f++stripLeftF = concatMapF g where g (Left x) = [x]; g _ = []+stripRightF = concatMapF g where g (Right x) = [x]; g _ = []++{-+debugF :: (a ->String) -> (b->String) -> String -> F a b -> F a b+debugF iShow oShow title f =+	let disp s = labLeftOfF s displayF+	    it = disp "Input: "+	    im = disp "                              "+	    ot = disp "Output:"+	    om = im+	    ts = ignoreI (untaggedListLF verticalP [it, ot])+	    ms = untaggedListLF verticalP [im, om] >=^< (\x->case x of { Right x -> (0,iShow x); Left y -> (1,oShow y)})+	    box = untaggedListLF horizontalP [ts, ms] >=^< (\x->(1,x))+	    shell = shellF ("Debug - "++title) box+	    tb :: F a b -> F a (Either b a)+	    tb f = idRightF f >==< toBothF+--	    g (Right (Left x)) = [x]+--	    g _             = []+	in  stripLeftF >==< stripRightF >==< tb shell >==< tb f++debugShowF t f = debugF show show t f+-}++intWF :: Int -> Int -> F Int (InputMsg Int)+intWF s n = startupF [n] intF+
+ Demos/mines/MineField.hs view
@@ -0,0 +1,186 @@+module MineField(MInput(..),MOutput(..),Symbol(..),Coord(..),play,playSP,initMineCount,mineFieldSize) where+--import RandomHBC(randomInts)+import System.Random(StdGen,randomRs,split)+import Data.List(union, intersect)+import Fudgets(getSP,putsSP) -- SP operations+import Data.Array+import Data.List((\\),nub)++type Coord = (Int,Int)			-- mine field coordinate+type RandInt = Int+type MineCount = Int+type MineField = Array (Int,Int) Bool 	-- number of mines and the array representing the mine field+data Moves = Moves Coord [Coord] [Coord] -- current pos, places, border+	     deriving (Eq, Ord{-, Text-})++mineFieldSizeX, mineFieldSizeY :: Int+mineFieldSizeX = 12+mineFieldSizeY = 12+mineFieldSize :: Coord+mineFieldSize = (mineFieldSizeX, mineFieldSizeY)++newField :: StdGen -> MineCount -> MineField			-- random numbers gives a new field+newField g n =+  let (nx, ny) = mineFieldSize+    --rs = newRands r+    --xs = map (`rem` nx) (everyOther rs)+    --ys = map (`rem` ny) (everyOther (tail rs))+      (g1,g2) = split g+      ps = randomRs (1,nx) g1 `zip` randomRs (1,ny) g2+      xys = take ((n `min` (nx * ny)) `max` 0) $+            nub (ps \\ [(1,1),mineFieldSize])+      b = ((0,0),(nx+1,ny+1))+  in  array b [(p, p `elem` xys) | p<-range b]++++--newRands r = randomInts ((r `max` 1) `min` 2147483562) (((r+123457) `max` 1) `min` 2147483398)+--everyOther (x:_:xs) = x:everyOther xs++initMoves = Moves (1,1) [(1,1)] [(1,2), (2,1), (2,2)]++moveTo :: Moves -> Coord -> Maybe Moves+moveTo (Moves _ visited border) xy | xy `elem` border =+        let visited' = xy:visited+	in  Just (Moves xy visited' (union border (neighbours xy) \\ visited'))+moveTo (Moves _ visited border) xy | xy `elem` visited =+	Just (Moves xy visited border)+moveTo _ _ = Nothing+	+neighbours :: Coord -> [Coord]+neighbours (x,y) = +	let (xm,ym) = mineFieldSize+	in  [(xi,yi) | xi<-[x-1..x+1], xi>0 && xi<=xm, yi<-[y-1..y+1], yi>0 && yi<=ym]++data Symbol = SBlank | SNumber Int | SCurrent Int | SFree | SBomb | SBombX | SBombDone deriving (Eq, Ord, Show)+data MInput = Move Coord | Bomb Coord | Free Coord | Hint | New | SetSize Int | Noop deriving (Eq, Ord{-, Text-})+data MOutput = Repaint [(Coord, Symbol)] | Msg String | Status String deriving (Eq, Ord{-, Text-})+type Counters = (Int,Int) -- moves, hints+type Bombs = [Coord]+data State = Go StdGen MineCount MineField Moves Counters Bombs Bombs+           | Stop StdGen MineCount+           --deriving (Eq, Ord{-, Text-})++initMineCount :: MineCount+initMineCount = 26+newState :: StdGen -> MineCount -> State+newState g n = Go g1 n (newField g2 n) initMoves (0, 0) [] []+  where (g1,g2) = split g+doMove :: State -> MInput -> (State, [MOutput])+doMove s@(Go rs n mf ms c@(i,j) bs fs) (Move xy) =+    if xy `elem` bs then+	(s, [])+    else+	case moveTo ms xy of+	   Nothing -> (s, [])+	   Just ms' -> +	        let c' = (i+1,j) in+		if mf ! xy then+		    let as = allBombs mf in+		    (Stop rs n, [Msg "You just exploded!", stat c' bs fs, Repaint [paintBomb bs a | a<-as], Repaint [(xy,SBombX) | xy<-bs, xy `notElem` as]])+		else +		    if xy == mineFieldSize then+		        (Stop rs n, [Msg "You honestly made it!", stat c' bs fs, Repaint (map (paint mf ms' bs) (changes ms ms'))])+		    else+		        (Go rs n mf ms' c' bs fs, [Msg (mineMsg mf xy), stat c' bs fs, Repaint (map (paint mf ms' bs) (changes ms ms'))])+doMove s@(Go rs n mf ms@(Moves _ vis _) c bs fs) (Bomb xy) =+        if xy `elem` vis then+	    (s, [])+	else if xy `elem` bs then+	    let bs' = bs \\ [xy] in (Go rs n mf ms c bs' fs,          [stat c bs' fs, Repaint [(xy, SBlank)]])+	else+	    let bs' = xy:bs+                fs' = fs \\ [xy]+            in  (Go rs n mf ms c bs' fs', [stat c bs' fs', Repaint [(xy, SBomb)]])+doMove s@(Go rs n mf ms@(Moves _ vis _) c bs fs) (Free xy) =+        if xy `elem` vis then+	    (s, [])+	else if xy `elem` fs then+	    let fs' = fs \\ [xy] in (Go rs n mf ms c bs fs',          [stat c bs fs', Repaint [(xy, SBlank)]])+	else+	    let fs' = xy:fs+                bs' = bs \\ [xy]+            in  (Go rs n mf ms c bs' fs', [stat c bs' fs', Repaint [(xy, SFree)]])+doMove (Go rs n _ _ _ _ _) New = doMove (Stop rs n) New+doMove (Stop rs n) New =+	let (s@(Go _ _ a _ _ _ _), os) = doMove (newState rs n) (Move (1,1))+	in  (s, Repaint [((x,y), SBlank) | x<-[1..mineFieldSizeX], y<-[1..mineFieldSizeY]] : Repaint [((1,1), SCurrent (countBombs a (1,1)))] : stat (0,0) [] []:os)+doMove (Go rs _ mf ms c bs fs) (SetSize n) = (Go rs n mf ms c bs fs, [])+doMove (Go rs n mf ms@(Moves _ _ ps) (i,j) bs fs) Hint = +        let m = case filter (\xy->not (mf ! xy)) ps of+                  [] -> Msg "Impossible"+		  xy:_ -> Repaint [(xy, SFree)]+            c' = (i,j+1)+        in  (Go rs n mf ms c' bs fs, [stat c' bs fs, m])+doMove (Stop rs _) (SetSize n) = (Stop rs n, [])+doMove s _ = (s, [])++stat :: Counters -> Bombs -> Bombs -> MOutput+stat (i, j) bs fs = Status ("Moves: "++show i++"   Hints: "++show j++"   Safes: "++show (length fs)++"   Mines: "++show (length bs))++mineMsg a xy =+	case countBombs a xy of+	   0 -> "No mines nearby."+	   1 -> "1 mine nearby."+	   n -> shows n " mines nearby."++changes :: Moves -> Moves -> [Coord]+changes (Moves cur vis bor) (Moves cur' vis' bor') =+	let chg l l' = union l l' \\ intersect l l'+	in  nub (chg [cur] [cur'] ++ chg vis vis' ++ chg bor bor')++paint :: MineField -> Moves -> Bombs -> Coord -> (Coord, Symbol)+paint a (Moves cur vis _) bs xy =+	(xy, +	if xy == cur then+	    SCurrent (countBombs a xy)+	else if xy `elem` vis then+	    SNumber (countBombs a xy)+	else if xy `elem` bs then+	    SBomb+	else+	    SBlank)++countBombs a = length . filter id . map (a!) . neighbours++allBombs a = [(x,y) | x<-[1..mineFieldSizeX], y<-[1..mineFieldSizeY], a!(x,y)]++paintBomb bs xy =+	(xy,+	if xy `elem` bs then+		SBomb+	else+		SBombDone)++firstState :: StdGen -> (State, [MOutput])+firstState g =+	{-let r = truncate d+	in-}  doMove (newState g initMineCount) New++stripR = filter f where f (Repaint []) = False+                        f _ = True++doMoves :: State -> [MInput] -> [[MOutput]]+doMoves s [] = []+doMoves s (i:is) =+	let (s', os) = doMove s i+	in  stripR os : doMoves s' is++play :: StdGen -> [MInput] -> [[MOutput]]+play d is =+	let (s, os) = firstState d+	in  stripR os : doMoves s is+++-- Stream Processor version of play & doMoves (hallgren 930525):++--doMovesSP :: State -> SP MInput MOutput+doMovesSP s =+	getSP $ \i ->+	let (s', os) = doMove s i+	in  putsSP (stripR os) $ doMovesSP s'++--playSP :: Double -> SP MInput MOutput+playSP d =+	let (s, os) = firstState d+	in  putsSP (stripR os) $ doMovesSP s
+ Demos/mines/Pics.hs view
@@ -0,0 +1,200 @@+module Pics where+import AllFudgets(BitmapData(..),pP)++bm w h = BitmapData (pP w h) Nothing++cur = [cur_0,cur_1,cur_2,cur_3,cur_4,cur_5]+num = [num_0,num_1,num_2,num_3,num_4,num_5]++bomb = bm 32 32 bomb_bits+bomb_bits = [+   0xff, 0xff, 0xff, 0xff, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,+   0x01, 0x00, 0x00, 0x80, 0x81, 0x01, 0x00, 0x80, 0xa1, 0x02, 0x00, 0x80,+   0x21, 0x30, 0x00, 0x80, 0x05, 0x24, 0x00, 0x80, 0x39, 0x09, 0x00, 0x80,+   0xa1, 0x00, 0x00, 0x80, 0x81, 0x00, 0x00, 0x80, 0x81, 0x00, 0x00, 0x80,+   0x05, 0xc7, 0x07, 0x80, 0x39, 0xef, 0x1f, 0x80, 0x01, 0xdf, 0x3f, 0x80,+   0x01, 0xde, 0x7f, 0x80, 0x01, 0xdc, 0xff, 0x80, 0x01, 0xe2, 0xff, 0x80,+   0x01, 0xff, 0xff, 0x81, 0x01, 0xff, 0xff, 0x81, 0x01, 0xff, 0xff, 0x81,+   0x01, 0xff, 0xff, 0x81, 0x01, 0xff, 0xff, 0x81, 0x01, 0xfe, 0xff, 0x80,+   0x01, 0xfe, 0xff, 0x80, 0x01, 0xfc, 0x7f, 0x80, 0x01, 0xf8, 0x3f, 0x80,+   0x01, 0xf0, 0x1f, 0x80, 0x01, 0xc0, 0x07, 0x80, 0x01, 0x00, 0x00, 0x80,+   0x01, 0x00, 0x00, 0x80, 0xff, 0xff, 0xff, 0xff]+bombdone = bm 32 32 bombdone_bits+bombdone_bits = [+ 0xff,0xff,0xff,0xff,0x00,0x00,0x00,0xc0,0x00,0x00,0x00,0xc0,0x00,0x00,0x00,+ 0xc0,0xc0,0x00,0x00,0xc0,0x50,0x01,0x00,0xc0,0x10,0x18,0x00,0xc0,0x02,0x12,+ 0x00,0xc0,0x9c,0x04,0x00,0xc0,0x50,0x00,0x00,0xc0,0x40,0x00,0x00,0xc0,0x40,+ 0x00,0x00,0xc0,0x82,0xe3,0x03,0xc0,0x9c,0xf7,0x0f,0xc0,0x80,0xef,0x1f,0xc0,+ 0x00,0xef,0x3f,0xc0,0x00,0xee,0x7f,0xc0,0x00,0x31,0x7e,0xc0,0x80,0x1f,0xfc,+ 0xc0,0x80,0x0f,0xf8,0xc0,0x80,0x07,0xf0,0xc0,0x80,0x07,0xf0,0xc0,0x80,0x07,+ 0xf0,0xc0,0x00,0x0f,0x78,0xc0,0x00,0x1f,0x7c,0xc0,0x00,0x3e,0x3e,0xc0,0x00,+ 0xfc,0x1f,0xc0,0x00,0xf8,0x0f,0xc0,0x00,0xe0,0x03,0xc0,0x00,0x00,0x00,0xc0,+ 0x00,0x00,0x00,0xc0,0xff,0xff,0xff,0xff]+bombx = bm 32 32 bombx_bits+bombx_bits = [+ 0x00,0x00,0x00,0x80,0xfc,0xff,0xff,0x8f,0xf8,0xff,0xff,0x87,0xf1,0xff,0xff,+ 0xa3,0x23,0xff,0xff,0xb1,0x87,0xfe,0xff,0xb8,0x8f,0xe7,0x7f,0xbc,0x1d,0xed,+ 0x3f,0xbe,0x23,0xfa,0x1f,0xbf,0x2f,0xfc,0x8f,0xbf,0xbf,0xfc,0xc7,0xbf,0xbf,+ 0xff,0xe7,0xbf,0x7d,0x1c,0xfc,0xbf,0x63,0x08,0xf0,0xbf,0x7f,0x10,0xe0,0xbf,+ 0xff,0x10,0xc0,0xbf,0xff,0x11,0x80,0xbf,0xff,0x0e,0x80,0xbf,0x7f,0x00,0x00,+ 0xbf,0x7f,0x00,0x00,0xbf,0x7f,0x00,0x00,0xbf,0x7f,0x00,0x00,0xbf,0x7f,0x00,+ 0x00,0xbf,0xff,0x00,0x80,0xbf,0x9f,0x00,0x80,0xbf,0x8f,0x01,0xc0,0xbc,0xc7,+ 0x03,0xe0,0xb8,0xe3,0x07,0xf0,0xb1,0xf1,0x1f,0xfc,0xa3,0xf8,0xff,0xff,0x87,+ 0xfc,0xff,0xff,0x8f,0x00,0x00,0x00,0x80]+cur_0 = bm 32 32 cur_0_bits+cur_0_bits = [+ 0xff,0xff,0xff,0xff,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,+ 0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x0e,+ 0x00,0x80,0x01,0x11,0x00,0x80,0x01,0x11,0x00,0x80,0x01,0x11,0x00,0x80,0x01,+ 0x0e,0x00,0x80,0x01,0x04,0x00,0x80,0x01,0x04,0x00,0x80,0x01,0x04,0x00,0x80,+ 0x81,0x3f,0x00,0x80,0x01,0x04,0x00,0x80,0x01,0x04,0xe0,0x80,0x01,0x04,0x10,+ 0x81,0x01,0x04,0x10,0x81,0x01,0x04,0x90,0x81,0x01,0x04,0x50,0x81,0x01,0x04,+ 0x30,0x81,0x01,0x0a,0x10,0x81,0x01,0x11,0x10,0x81,0x01,0x11,0xe0,0x80,0x81,+ 0x20,0x00,0x80,0x41,0x40,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,+ 0x01,0x00,0x00,0x80,0xff,0xff,0xff,0xff]+cur_1 = bm 32 32 cur_1_bits+cur_1_bits = [+   0xff, 0xff, 0xff, 0xff, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,+   0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,+   0x01, 0x00, 0x00, 0x80, 0x01, 0x0e, 0x00, 0x80, 0x01, 0x11, 0x00, 0x80,+   0x01, 0x11, 0x00, 0x80, 0x01, 0x11, 0x00, 0x80, 0x01, 0x0e, 0x00, 0x80,+   0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80,+   0x81, 0x3f, 0x00, 0x80, 0x01, 0x04, 0x40, 0x80, 0x01, 0x04, 0x60, 0x80,+   0x01, 0x04, 0x50, 0x80, 0x01, 0x04, 0x40, 0x80, 0x01, 0x04, 0x40, 0x80,+   0x01, 0x04, 0x40, 0x80, 0x01, 0x04, 0x40, 0x80, 0x01, 0x0a, 0x40, 0x80,+   0x01, 0x11, 0x40, 0x80, 0x01, 0x11, 0xf0, 0x81, 0x81, 0x20, 0x00, 0x80,+   0x41, 0x40, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,+   0x01, 0x00, 0x00, 0x80, 0xff, 0xff, 0xff, 0xff]+cur_2 = bm 32 32 cur_2_bits+cur_2_bits = [+   0xff, 0xff, 0xff, 0xff, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,+   0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,+   0x01, 0x00, 0x00, 0x80, 0x01, 0x0e, 0x00, 0x80, 0x01, 0x11, 0x00, 0x80,+   0x01, 0x11, 0x00, 0x80, 0x01, 0x11, 0x00, 0x80, 0x01, 0x0e, 0x00, 0x80,+   0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80,+   0x81, 0x3f, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0xe0, 0x80,+   0x01, 0x04, 0x10, 0x81, 0x01, 0x04, 0x00, 0x81, 0x01, 0x04, 0x80, 0x80,+   0x01, 0x04, 0x40, 0x80, 0x01, 0x04, 0x20, 0x80, 0x01, 0x0a, 0x10, 0x80,+   0x01, 0x11, 0x10, 0x80, 0x01, 0x11, 0xf0, 0x81, 0x81, 0x20, 0x00, 0x80,+   0x41, 0x40, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,+   0x01, 0x00, 0x00, 0x80, 0xff, 0xff, 0xff, 0xff]+cur_3 = bm 32 32 cur_3_bits+cur_3_bits = [+   0xff, 0xff, 0xff, 0xff, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,+   0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,+   0x01, 0x00, 0x00, 0x80, 0x01, 0x0e, 0x00, 0x80, 0x01, 0x11, 0x00, 0x80,+   0x01, 0x11, 0x00, 0x80, 0x01, 0x11, 0x00, 0x80, 0x01, 0x0e, 0x00, 0x80,+   0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80,+   0x81, 0x3f, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0xe0, 0x80,+   0x01, 0x04, 0x10, 0x81, 0x01, 0x04, 0x00, 0x81, 0x01, 0x04, 0x00, 0x81,+   0x01, 0x04, 0xc0, 0x80, 0x01, 0x04, 0x00, 0x81, 0x01, 0x0a, 0x00, 0x81,+   0x01, 0x11, 0x10, 0x81, 0x01, 0x11, 0xe0, 0x80, 0x81, 0x20, 0x00, 0x80,+   0x41, 0x40, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,+   0x01, 0x00, 0x00, 0x80, 0xff, 0xff, 0xff, 0xff]+cur_4 = bm 32 32 cur_4_bits+cur_4_bits = [+   0xff, 0xff, 0xff, 0xff, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,+   0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,+   0x01, 0x00, 0x00, 0x80, 0x01, 0x0e, 0x00, 0x80, 0x01, 0x11, 0x00, 0x80,+   0x01, 0x11, 0x00, 0x80, 0x01, 0x11, 0x00, 0x80, 0x01, 0x0e, 0x00, 0x80,+   0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80,+   0x81, 0x3f, 0x00, 0x80, 0x01, 0x04, 0x40, 0x80, 0x01, 0x04, 0x60, 0x80,+   0x01, 0x04, 0x50, 0x80, 0x01, 0x04, 0x48, 0x80, 0x01, 0x04, 0xfc, 0x80,+   0x01, 0x04, 0x40, 0x80, 0x01, 0x04, 0x40, 0x80, 0x01, 0x0a, 0x40, 0x80,+   0x01, 0x11, 0x40, 0x80, 0x01, 0x11, 0xe0, 0x80, 0x81, 0x20, 0x00, 0x80,+   0x41, 0x40, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,+   0x01, 0x00, 0x00, 0x80, 0xff, 0xff, 0xff, 0xff]+cur_5 = bm 32 32 cur_5_bits+cur_5_bits = [+   0xff, 0xff, 0xff, 0xff, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,+   0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,+   0x01, 0x00, 0x00, 0x80, 0x01, 0x0e, 0x00, 0x80, 0x01, 0x11, 0x00, 0x80,+   0x01, 0x11, 0x00, 0x80, 0x01, 0x11, 0x00, 0x80, 0x01, 0x0e, 0x00, 0x80,+   0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80,+   0x81, 0x3f, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0xf0, 0x81,+   0x01, 0x04, 0x10, 0x80, 0x01, 0x04, 0x10, 0x80, 0x01, 0x04, 0x20, 0x80,+   0x01, 0x04, 0xc0, 0x80, 0x01, 0x04, 0x00, 0x81, 0x01, 0x0a, 0x00, 0x81,+   0x01, 0x11, 0x10, 0x81, 0x01, 0x11, 0xe0, 0x80, 0x81, 0x20, 0x00, 0x80,+   0x41, 0x40, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,+   0x01, 0x00, 0x00, 0x80, 0xff, 0xff, 0xff, 0xff]+free = bm 32 32 free_bits+free_bits = [+ 0xff,0xff,0xff,0xff,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,+ 0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,+ 0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,+ 0x00,0x02,0x80,0x01,0x00,0x02,0x80,0x01,0x38,0x12,0x80,0x01,0x44,0x0a,0x80,+ 0x01,0x44,0x06,0x80,0x01,0x44,0x06,0x80,0x01,0x44,0x0a,0x80,0x01,0x44,0x12,+ 0x80,0x01,0x38,0x22,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,+ 0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,+ 0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,+ 0x01,0x00,0x00,0x80,0xff,0xff,0xff,0xff]+num_0 = bm 32 32 num_0_bits+num_0_bits = [+ 0xff,0xff,0xff,0xff,0x01,0x00,0x00,0x80,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,+ 0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,+ 0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x01,0x40,0x95,0xa9,+ 0x82,0x83,0xaa,0x55,0x41,0x44,0x95,0xa9,0x42,0x84,0xaa,0x55,0x41,0x46,0x95,+ 0xa9,0x42,0x85,0xaa,0x55,0xc1,0x44,0x95,0xa9,0x42,0x84,0xaa,0x55,0x41,0x44,+ 0x95,0xa9,0x82,0x83,0xaa,0x55,0x01,0x40,0x95,0xa9,0x02,0x80,0xaa,0x55,0x55,+ 0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,+ 0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,+ 0x01,0x00,0x00,0x80,0xff,0xff,0xff,0xff]+num_1 = bm 32 32 num_1_bits+num_1_bits = [+ 0xff,0xff,0xff,0xff,0x01,0x00,0x00,0x80,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,+ 0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,+ 0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x01,0x40,0x95,0xa9,+ 0x82,0xa0,0xaa,0x55,0xc1,0x40,0x95,0xa9,0xa2,0xa0,0xaa,0x55,0x81,0x40,0x95,+ 0xa9,0x82,0xa0,0xaa,0x55,0x81,0x40,0x95,0xa9,0x82,0xa0,0xaa,0x55,0x81,0x40,+ 0x95,0xa9,0xe2,0xa3,0xaa,0x55,0x01,0x40,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,+ 0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,+ 0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,+ 0x01,0x00,0x00,0x80,0xff,0xff,0xff,0xff]+num_2 = bm 32 32 num_2_bits+num_2_bits = [+ 0xff,0xff,0xff,0xff,0x01,0x00,0x00,0x80,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,+ 0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,+ 0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x01,0x40,0x95,0xa9,+ 0xc2,0xa1,0xaa,0x55,0x21,0x42,0x95,0xa9,0x02,0xa2,0xaa,0x55,0x01,0x42,0x95,+ 0xa9,0x02,0xa1,0xaa,0x55,0x81,0x40,0x95,0xa9,0x42,0xa0,0xaa,0x55,0x21,0x40,+ 0x95,0xa9,0xe2,0xa3,0xaa,0x55,0x01,0x40,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,+ 0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,+ 0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,+ 0x01,0x00,0x00,0x80,0xff,0xff,0xff,0xff]+num_3 = bm 32 32 num_3_bits+num_3_bits = [+ 0xff,0xff,0xff,0xff,0x01,0x00,0x00,0x80,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,+ 0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,+ 0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x01,0x40,0x95,0xa9,+ 0xc2,0xa1,0xaa,0x55,0x21,0x42,0x95,0xa9,0x02,0xa2,0xaa,0x55,0x01,0x42,0x95,+ 0xa9,0x82,0xa1,0xaa,0x55,0x01,0x42,0x95,0xa9,0x02,0xa2,0xaa,0x55,0x21,0x42,+ 0x95,0xa9,0xc2,0xa1,0xaa,0x55,0x01,0x40,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,+ 0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,+ 0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,+ 0x01,0x00,0x00,0x80,0xff,0xff,0xff,0xff]+num_4 = bm 32 32 num_4_bits+num_4_bits = [+   0xff, 0xff, 0xff, 0xff, 0x01, 0x00, 0x00, 0x80, 0x55, 0x55, 0x55, 0x95,+   0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x55, 0x55, 0x95, 0xa9, 0xaa, 0xaa, 0xaa,+   0x55, 0x55, 0x55, 0x95, 0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x55, 0x55, 0x95,+   0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x01, 0x40, 0x95, 0xa9, 0x82, 0xa1, 0xaa,+   0x55, 0x41, 0x41, 0x95, 0xa9, 0x22, 0xa1, 0xaa, 0x55, 0x11, 0x41, 0x95,+   0xa9, 0xf2, 0xa3, 0xaa, 0x55, 0x01, 0x41, 0x95, 0xa9, 0x02, 0xa1, 0xaa,+   0x55, 0x01, 0x41, 0x95, 0xa9, 0x82, 0xa3, 0xaa, 0x55, 0x01, 0x40, 0x95,+   0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x55, 0x55, 0x95, 0xa9, 0xaa, 0xaa, 0xaa,+   0x55, 0x55, 0x55, 0x95, 0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x55, 0x55, 0x95,+   0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x55, 0x55, 0x95, 0xa9, 0xaa, 0xaa, 0xaa,+   0x01, 0x00, 0x00, 0x80, 0xff, 0xff, 0xff, 0xff]+num_5 = bm 32 32 num_5_bits+num_5_bits = [+   0xff, 0xff, 0xff, 0xff, 0x01, 0x00, 0x00, 0x80, 0x55, 0x55, 0x55, 0x95,+   0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x55, 0x55, 0x95, 0xa9, 0xaa, 0xaa, 0xaa,+   0x55, 0x55, 0x55, 0x95, 0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x55, 0x55, 0x95,+   0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x01, 0x40, 0x95, 0xa9, 0xe2, 0xa3, 0xaa,+   0x55, 0x21, 0x40, 0x95, 0xa9, 0x22, 0xa0, 0xaa, 0x55, 0x41, 0x40, 0x95,+   0xa9, 0x82, 0xa1, 0xaa, 0x55, 0x01, 0x42, 0x95, 0xa9, 0x02, 0xa2, 0xaa,+   0x55, 0x21, 0x42, 0x95, 0xa9, 0xc2, 0xa1, 0xaa, 0x55, 0x01, 0x40, 0x95,+   0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x55, 0x55, 0x95, 0xa9, 0xaa, 0xaa, 0xaa,+   0x55, 0x55, 0x55, 0x95, 0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x55, 0x55, 0x95,+   0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x55, 0x55, 0x95, 0xa9, 0xaa, 0xaa, 0xaa,+   0x01, 0x00, 0x00, 0x80, 0xff, 0xff, 0xff, 0xff]
+ Demos/mines/XMine.hs view
@@ -0,0 +1,60 @@+module Main where+--import Trace+--import Word+import Fudgets+import FUtil+import MineField+--import BitMaps+--import Time+import System.Random(newStdGen)+import Box++main = newStdGen >>= fudlogue . shellF "FXMines v1.2" . xmines++--getTimeDouble = randomRIO (0,2e9)+                  ++--myFont = defaultFont+--separation = 5::Int++xmines d =+  let title = nullF -- untaggedListLF horizontalP [labelF "FXMines v1.2"]+      controls = untaggedListLF horizontalP [labelF "Mine count", inp initMineCount, bf "Hint" Hint, bf "Restart" New{-, bq "Quit"-}]+      msg1 = disp ""+      msg2 = disp ""+      panel = untaggedListLF verticalP [ignoreI title,  		-- 0+                                        ignoreI controls, 		-- 1+                                        msg1 >=^< (\(Status s)->s),	-- 2+                                        msg2 >=^< (\(Msg s)->s), 	-- 3+                                        boxes' >=^< (\(Repaint l)->l)] >=^< directMsg -- 4+                             where directMsg m@(Repaint l) = (4, m)+                                   directMsg m@(Msg s)     = (3, m)+                                   directMsg m@(Status s)  = (2, m)+      but s = buttonF s+      bf s f = (\_ -> f) >^=< but s+      bq s = quitF >==< but s+      disp s = displayF+      inp n = (\x->case x of { InputChange n -> SetSize n; _ -> Noop} ) >^=< ignoreI (intWF 8 n)+      (xn, yn) = mineFieldSize+      boxes = mapstateSP action Move >^^=< vBoxF (actionF >+< boxes1) >=^< Right+        where+          action _ (Left (Fun f)  ) = (f,[])+          action f (Right (Move p)) = (f,[f p])+          action f (Right m       ) = (f,[m])++      actionF =+        radioGroupF' (setPlacer (spacerP centerS horizontalP) .+                      setLabelInside True)+                     [(Fun Move,"Move"),(Fun Free,"ok"),(Fun Bomb,"Bomb")]+                     (Fun Move)++      boxes1 :: F [(Coord, Symbol)] MInput+      boxes1 = readAllBitmaps $ \ ps ->+              (\(a,f)->f a) >^=< listLF (matrixP xn) [((x,y), boxF ps) | x<-[1..xn], y<-[1..yn]] >=^^< concatSP+      boxes' = --allcacheF+               boxes+  in  loopF ({-debugF show show-} panel >==< absF (playSP d))++data Fun = Fun (Coord->MInput)+instance Eq Fun where+  Fun f1 == Fun f2 = f1 (0,0) == f2 (0,0)
+ Demos/paint/GraphF.hs view
@@ -0,0 +1,84 @@+module GraphF(graphF,PaintCommand(..),ToolFunc(..)) where+import AllFudgets+--import Word()++data PaintCommand+	= ChangeTool ToolFunc+	| ChangeColor ColorName++type ToolFunc = Point->Point->DrawCommand++graphK size func bgcol gc gcinv =+	let same = graphK size func bgcol gc gcinv+	    newf f = graphK size f bgcol gc gcinv+	    resize s = graphK s func bgcol gc gcinv+	    newgc = graphK size func bgcol+	in getK $ \msg ->+	     case msg of+	        High (ChangeTool func) -> newf func+	        High (ChangeColor color) -> changeColorK bgcol color newgc+	        Low (LEvt (LayoutSize newsize)) -> resize newsize+	        Low (XEvt (Expose _ 0)) -> same -- !!!+	        Low (XEvt (ButtonEvent _ p _ _ Pressed (Button _))) ->+		       rubberBandK size func bgcol gc gcinv p p+	        _  -> same++rubberBandK s f bgcol gc gcinv p0 p1 =+	let cont p = rubberBandK s f bgcol gc gcinv p0 p+	in let same = cont p1+               draw gc p0 p1 = Low (wDraw gc (f p0 p1))+        in let toggle = draw gcinv+	in putK (toggle p0 p1) $+	   getK $ \msg ->+	     case msg of+	        Low (XEvt (MotionNotify _ p _ _)) -> putK (toggle p0 p1) (cont p)+	        Low (XEvt (ButtonEvent _ p _ _ Released _)) ->+		  putsK [toggle p0 p1, draw gc p0 p] (graphK s f bgcol gc gcinv)+	        _ -> same++idleGraphK size bgcol gc gcinv =+	let same = idleGraphK size bgcol gc gcinv+	    resize size' = idleGraphK size' bgcol gc gcinv +	in getK $ \msg ->+	     case msg of+	        High (ChangeTool func) -> graphK size func bgcol gc gcinv+	        Low (LEvt (LayoutSize size')) -> resize size'+	        _ -> same++changeColorK bgcol fg k =+  let gcattr fgcol = [GCForeground fgcol, GCLineWidth 3]+      invattrs bg fg = if bg==fg+	               then invertColorGCattrs (Pixel 0) (Pixel 170) -- hmm+		       else invertColorGCattrs bg fg+  in allocNamedColorPixel defaultColormap fg  $ \fgcol ->+     wCreateGC rootGC (gcattr fgcol) $ \gc ->+     wCreateGC gc (invattrs bgcol fgcol) $ \gcinv ->+     k gc gcinv++graphF =+  let evmask =[ExposureMask{-,ButtonReleaseMask-}]+  in let wattrs = [CWBackingStore WhenMapped,+		CWEventMask evmask,+		CWBitGravity NorthWestGravity+		]+  in let startcmds = map XCmd +                      [ ChangeWindowAttributes wattrs,+			--ConfigureWindow [CWBorderWidth 0],+			GrabButton True (Button 1) []+				[ButtonPressMask,+				PointerMotionMask,+				ButtonReleaseMask]+			{-,+			GrabButton True (Button 1) []+				[ButtonReleaseMask],+			GrabButton True (Button 3) []+				[ButtonReleaseMask]+			-}+		     ]+         size = Point 300 300+  in windowF startcmds $+	setFontCursor 130 $+	changeGetBackPixel "white" $ \bgcol ->+	changeColorK bgcol "black" $ \gc gcinv ->+	putK (Low (layoutRequestCmd (plainLayout size False False))) $+	idleGraphK size bgcol gc gcinv
+ Demos/paint/Paint.hs view
@@ -0,0 +1,63 @@+module Main where+import Fudgets+import GraphF++main = fudlogue $ shellF "FudPaint" mainF++mainF = hBoxF (graphF >==< vBoxF toolscolorsF)++toolscolorsF =+    noStretchF True True $ spacerF centerS $ vBoxF $+    stripEither >^=< (toolsF >+< colorsF)++toolsF =+    "Tools" `labAboveF`+    ((ChangeTool. tool)>^=< radioGroupF' pm (map (pairwith pict) tools) LineTool)+  where pm = setLabelInside True++colorsF =+    "Colors" `labAboveF`+    (ChangeColor >^=< radioGroupF' pm (map col colors) "Black")+  where col c = (c,stackD [fgD c (g (cpict BlockTool)),+                           g (cpict RectTool)])+        pm = setLabelInside True . setPlacer (matrixP' 3 Horizontal 0)++tools = [LineTool, RectTool, BlockTool, OvalTool, FilledOvalTool]++colors = [ "Black", "Grey", "White",+           "Blue", "Blue3", "Blue4",+           "Green", "Green3", "Green4",+           "Yellow","Orange", "Brown",+ 	   "Red", "Red3", "Red4" ]++data Tool = LineTool | RectTool | BlockTool | OvalTool | FilledOvalTool+            deriving (Eq)++tool LineTool = drawline+tool RectTool = drawrect+tool BlockTool = fillrect+tool OvalTool = drawoval+tool FilledOvalTool = filloval++pict = pict' (Point 30 15)+cpict = pict' (Point 15 15)+pict' s t = FixD (s+1) [tool t 0 (s-1)]++{-+pict LineTool = "Line"+pict RectTool = "Rect"+pict BlockTool = "Block"+pict OvalTool = "Oval"+pict FilledOvalTool = "Blob"+-}++drawline p0 p1 = DrawLine (Line p0 p1)+drawrect p0 p1 = DrawRectangle (rect' p0 p1)+fillrect p0 p1 = FillRectangle (rect' p0 p1)+drawoval p0 p1 = DrawArc (rect' p0 p1) 0 (64*360)+filloval p0 p1 = FillArc (rect' p0 p1) 0 (64*360)++rect' p1 p2 =+  let p0 = pmin p1 p2+      p = pmax p1 p2+  in Rect p0 (padd (psub p p0) (Point 1 1))
+ Examples/FancyHello.hs view
@@ -0,0 +1,26 @@+-- Fancy version of the "Hello, world!" program+import Fudgets++main = fudlogue (shellF "Hello" helloF)++helloF = labelF (fancyTextD greeting)++fancyTextD text =+    stackD [bgD,+	    spacedD (hvMarginS (5+dist) 5) shadowTxtD,+	    spacedD (hvMarginS 5 (5+dist)) fgTxtD]+  where+    shadowTxtD = fgD shadow txtD+    fgTxtD = fgD color txtD+    txtD = spacedD centerS $ fontD font (g text)+    bgD = vboxD' 0 [fgD sky fillD,fgD ground fillD]+    fillD = g (filler False False 10)++-- Everything can be changed with command line switches:+color = argKey "color" "red"+shadow = argKey "shadow" "black"+sky = argKey "sky" "skyblue"+ground = argKey "ground" "blue"+greeting = argKey "greeting" "Hello, world!"+dist = diag (argReadKey "dist" 2)+font = argKey "font" "-*-helvetica-bold-r-*-*-24-*-*-*-*-*-iso8859-1"
+ Examples/StopWatch.hs view
@@ -0,0 +1,23 @@+module Main where+-- A simple stop watch with a run/stop button and a reset button.+import Fudgets++main = fudlogue (shellF "Stop Watch" stopWatchF)++stopWatchF = +  timeDispF >==< (counterSP 0 >^^=< idRightF (timerF >=^< timeprep))+   >==< (runF >+< resetF)+  -- >+<quitButtonF++timeprep True = Just (100,100)+timeprep False = Nothing++runF = toggleButtonF "Run"+resetF = buttonF "Reset"++timeDispF = intDispF  -- to be improved++counterSP no = getSP $ \msg -> let out n = putSP n $ counterSP n +			       in case msg of+				    Left _ -> out (no+1)+				    Right _ -> out 0
+ Examples/texteditor.hs view
@@ -0,0 +1,6 @@+import Fudgets+import ContribFudgets(textFileShellF)++main = fudlogue $ textFileShellF "Text Editor" edF++edF = spacer1F (minSizeS (Point 500 400)) (scrollF inputEditorF)
+ README.md view
@@ -0,0 +1,71 @@++# ¤ Fudgets ¤++[Fudgets](https://www.altocumulus.org/Fudgets/)+is primarily a Graphical User Interface Toolkit implemented in Haskell+on top of its own binding to the+[Xlib library](https://tronche.com/gui/x/xlib/) of the+[X Windows system](https://www.x.org/).+Fudgets also makes it easy to create client/server applications that+communicate via the Internet.+[The Hello world program](https://www.altocumulus.org/Fudgets/Intro/ex1.html)+fits on a single line:++```haskell+main = fudlogue (shellF "Hello" (labelF "Hello world!"))+```++The key abstraction is+[*the fudget*](https://www.altocumulus.org/Fudgets/Intro/concept.html).+A fudget is a *stream processor* with+high-level and low-level streams. The high level streams are used for+communication between fudgets within a program.+The low level streams are for communication with the I/O system.++> ![](https://www.altocumulus.org/~hallgren/WebFudgets/doc/P/the_fudget2.jpg)++Fudgets are combined using various combinators for parallel composition,+serial composition and loops.++> ![](https://www.altocumulus.org/~hallgren/WebFudgets/doc/P/fudget_plumbing2.jpg)++Fudgets was originally implemented in Lazy ML in the early 1990s,+then converted to Haskell. It was thus designed before monadic IO was+introduced in Haskell and early versions did not make use of Haskell's+type classes at all.++## Documentation++- [Your first 8 Fudgets program](https://www.altocumulus.org/Fudgets/Intro/).+  Gentle Introduction.+- [Fudgets User's Guide](https://www.altocumulus.org/Fudgets/userguide.html).+  Naming conventions and some other practical things.+- [Fudget Library Reference Manual](https://www.altocumulus.org/Fudgets/Manual/). (Haddock did not exist back when Fudgets were created.)+- [The FPCA-93 paper about Fudgets](https://www.altocumulus.org/Fudgets/fpca93-abstract.html),+  the first publication describing Fudgets.+- See the [Fudgets home page](https://www.altocumulus.org/Fudgets/) for more info.++## Installing Fudgets from Hackage++### On Linux systems++- `sudo apt install libxext-dev` (installs Xlib etc on Debian-based+  distributions, the command will be different on other Linux distributions.)+- `cabal install fudgets`++### On macOS++- Install [XQuartz](https://www.xquartz.org/).+- `brew install gcc` (need the version of `cpp` included with gcc, since there+  are some issues with cpp from clang.+  Note: `fudgets.cabal` refers to `cpp-11`, you might need to change this+  if you install a different version of gcc.)++- If you are using ghc>=8.10.3: unfortunately it seems that the+  `-pgmP` option no longer works, so you need to+  change a line in `$PREFIX/lib/ghc-*/lib/settings` instead:++    ```  ,("Haskell CPP command", "gcc-11")```++- `cabal install fudgets`+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ fudgets.cabal view
@@ -0,0 +1,539 @@+Name: fudgets+-- The version number also appears in hsrc/utils/FudVersion.hs+Version: 0.18.3+Cabal-Version: >=1.10+Synopsis: The Fudgets Library+Homepage: https://www.altocumulus.org/Fudgets/+Category: GUI, Network, Concurrency+          -- Graphics?, User Interfaces?++Description: <https://www.altocumulus.org/Fudgets/ Fudgets> is a Graphical+             User Interface Toolkit built in Haskell on top of the X11+             Windows system in the early 1990s. There is an+             <https://www.altocumulus.org/Fudgets/fpca93-abstract.html FPCA-93 paper>+             about it. Fudgets also makes it easy to create+             client/server applications that communicate via the Internet.+             .+             This package includes the Fudgets library and a few small+             examples and demo applications.++Author: Thomas Hallgren and Magnus Carlsson+Maintainer: Thomas Hallgren+Build-Type: Simple+License: OtherLicense+License-File: COPYRIGHT+Tested-With: GHC==7.4.1, GHC==7.6.3, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.3, GHC==8.8.2, GHC==8.10.2, GHC==8.10.7, GHC==9.0.2, GHC==9.2.2++Extra-Source-Files: README.md+                    hsrc/exists.h+                    hsrc/defaults/defaults.h+                    hsrc/ghc-dialogue/asyncinput.h+                    hsrc/ghc-dialogue/ccalls.h+                    hsrc/ghc-dialogue/cfuns.h+                    hsrc/ghc-dialogue/cfundefs.h+                    hsrc/ghc-dialogue/cimports.h+                    hsrc/ghc-dialogue/csizes.h+                    hsrc/ghc-dialogue/newstructfuns.h+                    hsrc/ghc-dialogue/structs.h+                    xlib/socketlib/defs.h++Flag developer+  Description: Enable options useful for developers of this library+  Manual:      True+  Default:     False++Flag old-time+  Description: Use the old-time package+  Default:     True++Library+  --Exposed: False+  Exposed-modules: AllFudgets Fudgets ContribFudgets+    TreeBrowser HyperGraphicsF2 SuperMenuF ConnectF TypedSockets+    ReactiveF ReactionM DialogueIO DoRequest+    IOUtil+    --NonStdTrace+    HbcUtils+    -- GhcFudgets++  Build-Depends: base>=4 && <5, process, directory>=1.2.3,+               --packedstring,+                 containers, array, time,+                 unix++  if flag(old-time)+    Build-Depends: old-time++  Hs-source-dirs: Contrib hsrc+    hsrc/utils hsrc/sp hsrc/types hsrc/xtypes hsrc/combinators hsrc/containers+    hsrc/drawing hsrc/filters hsrc/fudgets hsrc/defaults hsrc/internals+    hsrc/kernelutils hsrc/layout hsrc/infix hsrc/lowlevel hsrc/io hsrc/debug+    hsrc/ghc-dialogue hsrc/ghc+    -- The only module used from hbc_library is FudUTF8+    hsrc/hbc_library++  Default-language: Haskell98+  Default-extensions: ForeignFunctionInterface Rank2Types+                      ExistentialQuantification+                      MultiParamTypeClasses FunctionalDependencies+                      FlexibleInstances FlexibleContexts TypeSynonymInstances++--if impl(ghc>=8.6) && impl(ghc<8.8)+--  Default-extensions: NoMonadFailDesugaring++  Include-dirs: hsrc hsrc/ghc-dialogue hsrc/defaults++  if os(darwin)+    Extra-lib-dirs: /opt/X11/lib +    Include-dirs: /opt/X11/include+    -- Run 'brew install gcc', then you should have gcc-11 and cpp-11, or+    -- possibly another version, in which case you need to adapt the line below:+    if impl(ghc<8.10.3)+      -- Use the -pgmP in ghc<8.10.3+      ghc-options: -pgmP cpp-11 -optP -traditional+    --else+      -- Unfortunately -pgmP doesn't work in ghc>=8.10.3, so you need to+      -- change a line in $PREFIX/lib/ghc-*/lib/settings insead:+      -- ,("Haskell CPP command", "gcc-11")++  Extra-Libraries: X11 Xext++  ghc-options: -fno-warn-tabs+  +  if flag(developer)+    ghc-options: -fwarn-unused-imports+    ghc-prof-options: -fprof-auto++  if impl(ghc>=8.6)+    ghc-options: -haddock++  c-sources: hsrc/ghc-dialogue/cfuns.c xlib/fdzero.c xlib/socketlib/inet.c+  cc-options: "-DVERSION=\"SOCKET Version 1.3\"" -DHAS_H_ERRNO++  -- Sigh. Why can't Cabal fill this in?+  -- ghc --make has no problem finding all the reqired modules.+  Other-Modules:+    AlignP+    Alignment+--  Ap+    AppStorage+    AsyncInput+    AsyncTransmitter+    AutoLayout+    AutoPlacer+    AuxShellF+    AuxTypes+    BellF+    BgF+    BitmapDrawing+    BitmapF+    Border3dF+    BranchF+    BubbleF+    ButtonBorderF+    ButtonF+    ButtonGroupF+    CSizes+    CString16+    CmdLineEnv+    Color+    Combinators+    Command+    CompF+    CompFfun+    CompOps+    CompSP+    CompiledGraphics+    CompletionStringF+    CondLayout+    Cont+    ContDynF+    Containers+    ContinuationIO+    Convgc+    Cursor+    DButtonF+    DDisplayF+    DFudIO+    DLValue+    DRadioF+    DShellF+    DStringF+    DToggleButtonF+    Debug+    DefaultParams+    Defaults+    DialogF+    DialogueSpIO+    Direction+    Display+    Dlayout+    DoXCommand+    DoXRequest+    DoubleClickF+    DragF+    DrawCompiledGraphics+    DrawCompiledGraphics1+    DrawInPixmap+    DrawInWindow+    DrawTypes+    Drawcmd+    Drawing+    DrawingModules+    DrawingOps+    DrawingUtils+    DynListF+    DynListLF+    DynRadioGroupF+    DynSpacerF+    Dynforkmerge+    Edit+    Editfield+    Editor+    Edtypes+    EitherUtils+    EncodeEvent+    EndButtonsF+    Event+    EventMask+    Expose+    FDefaults+    FRequest+    FilePaths+    FilePickF+    FilePickPopupF+    FileShellF+    Filters+    FixedDrawing+    FlexibleDrawing+    FocusMgr+    Font+    FontProperty+    FreeGroupF+    FudIO+    FudUTF8+    FudUtilities+    FudVersion+    Fudget+    FudgetIO+    GCAttrs+    GCtx+    Gc+    GcWarningF+    Geometry+    GetModificationTime+    GetTime+    GetVisual+    GetWindowProperty+    Graphic+    Graphic2Pixmap+    GraphicsF+    GreyBgF+    GuiElems+    HandleF+    HaskellIO+--  HbcLibrary+    HbcWord+    HelpBubbleF+    HorizontalAlignP+    HyperGraphicsF+    IdempotSP+    Image+    InOut+    InfixOps+    InputEditorF+    InputF+    InputMsg+    InputSP+    IntMemo+    InternAtom+    IoF+    IsRequest+    KernelUtils+    KeyGfx+--  LA+    LabelF+    Layout+    LayoutDir+    LayoutDoNow+    LayoutF+    LayoutHints+    LayoutOps+    LayoutRequest+    LayoutSP+    Layoutspec+    LinearSplitP+    List2+    ListF+    ListRequest+    LoadFont+    Loop+    LoopCompF+    LoopLow+    Loops+    Loopthrough+    LowLevel+    MGOps+    MapstateK+    MapstateMsg+    Maptrace+    Marshall+    MatrixP+    MeasuredGraphics+    MenuBarF+    MenuButtonF+    MenuF+    MenuPopupF+    Message+    MeterF+    MoreF+    MoreFileF+    MyForeign+    NameLayout+    NewCache+    NullF+    OldLayoutOps+    OnOffDispF+    OpenSocket+    PQueue+    P_IO_data+    PackedString+    ParF+    ParK+    ParSP+    ParagraphP+    Path+    PathTree+    Pixmap+    PixmapGen+    Placer+    Placers+    Placers2+    PopupF+    PopupGroupF+    PopupMenuF+    Popupmsg+    PosPopupShellF+    Process+    ProdF+    PushButtonF+    QueryPointer+    QueryTree+    Queue+    QuitButtonF+    QuitF+    QuitK+    RadioF+    ReadFileF+    Rects+    ResourceIds+    RootWindowF+    Route+    SP+    SPmonad+    SPstateMonad+    ScrollF+    SelectionF+    SerCompF+    ShapeGroupMgr+    ShapeK+    ShapedButtonsF+    Shells+    ShowCommandF+    ShowFailure+    ShowFun+    SimpleF+    Sizing+    SizingF+    SmileyF+    SocketServer+    Socketio+    Sockets+    SpEither+    SpIO+    Spacer+    Spacers+    Spinterp+    SplitF+    Spops+    SpyF+    Srequest+    StateMonads+    StdIoUtil+    StreamProc+    StreamProcIO+    StringEdit+    StringF+    StringUtils+    StructFuns+    Table+    TableP+    Tables+    Tables2+    TagEvents+    TerminalF+    TextExtents+    TextF+    TimerF+    TitleShellF+    ToggleButtonF+    ToggleGroupF+    TransCoord+    Transceivers+    Tree234+    TreeF+    TryLayout+    Types+    UndoStack+    UnsafeGetDLValue+    UnsafePerformIO+    UserLayoutF+    Utils+    Visual+    WindowF+    WriteFile+    XCallTypes+    XDraw+    XStuff+    XTypesModules+    Xcommand+    Xlib+    Xrequest+    Xtypes++Executable Graph+  hs-source-dirs: Demos/graph+  main-is: Graph.hs+  Other-modules: Compat Diff Eval Exp ExpF Lex Ops Parser Parsop PlotF Root+                 Show Simp UserCoords ZoomF+  build-depends: base, fudgets+  Default-language: Haskell98++  ghc-options: -fno-warn-tabs+  if impl(ghc>=7.0)+    ghc-options: -rtsopts++Executable fudgetclock+  hs-source-dirs: Demos/clock+  main-is: fudgetclock.hs+  Other-modules: ClockF+  Default-language: Haskell98+  build-depends: base, fudgets+  if flag(old-time)+    Build-Depends: old-time+  else+    Build-Depends: time++  ghc-options: -fno-warn-tabs+  if impl(ghc>=7.0)+    ghc-options: -rtsopts++Executable StopWatch+  hs-source-dirs: Examples+  main-is: StopWatch.hs+  Default-language: Haskell98+  build-depends: base, fudgets++  ghc-options: -fno-warn-tabs+  if impl(ghc>=7.0)+    ghc-options: -rtsopts++Executable texteditor+  hs-source-dirs: Examples+  main-is: texteditor.hs+  Default-language: Haskell98+  build-depends: base, fudgets++  ghc-options: -fno-warn-tabs+  if impl(ghc>=7.0)+    ghc-options: -rtsopts++Executable FancyHello+  hs-source-dirs: Examples+  main-is: FancyHello.hs+  Default-language: Haskell98+  build-depends: base, fudgets++  ghc-options: -fno-warn-tabs+  if impl(ghc>=7.0)+    ghc-options: -rtsopts++Executable SpaceInvaders2+  hs-source-dirs: Demos/SpaceInvaders+  main-is: SpaceInvaders2.hs+  Other-modules: BitmapOps GUI InvaderTypes MainF Pics Pics1 ReadPic ScoreF WorldF Metrics+  Default-language: Haskell98+  build-depends: base, fudgets, random+--, split>=0.2++  ghc-options: -fno-warn-tabs+--if impl(ghc>=8.6)+--  Default-extensions: NoMonadFailDesugaring+  if impl(ghc>=7.0)+    ghc-options: -rtsopts++Executable Explore+  hs-source-dirs: Demos/Mandelbrot Demos/graph+  main-is: Explore.hs+  Other-modules: Mandelbrot UserCoords ZoomF+  Default-language: Haskell98+  ghc-options: -threaded+  build-depends: base, fudgets, array, parallel++  ghc-options: -fno-warn-tabs+  if impl(ghc>=7.0)+    ghc-options: -rtsopts -with-rtsopts=-N++Executable FudPaint+  hs-source-dirs: Demos/paint+  main-is: Paint.hs+  Other-modules: GraphF+  Default-language: Haskell98+  build-depends: base, fudgets++  ghc-options: -fno-warn-tabs+  if impl(ghc>=7.0)+    ghc-options: -rtsopts++Executable Life+  hs-source-dirs: Demos/life+  main-is: Main.hs+  other-modules: Generate Life Panel Timer Utils2+  Default-language: Haskell98+  build-depends: base, fudgets++  ghc-options: -fno-warn-tabs+  if impl(ghc>=7.0)+    ghc-options: -rtsopts++Executable Tiles+  hs-source-dirs: Demos/Tiles+  main-is: Main.hs+  Other-modules: BoardF ChoiceF DesignF DrawingF MyUtils RadioDrawF Tiles+                 ToggleDrawGroupF ToolsF+  Default-language: Haskell98+  build-depends: base, fudgets++  ghc-options: -fno-warn-tabs+  if impl(ghc>=7.0)+    ghc-options: -rtsopts++Executable XMine+  hs-source-dirs: Demos/mines+  main-is: XMine.hs+  Other-modules: Box FUtil MineField Pics+  Default-language: Haskell98+  build-depends: base, fudgets, array, random++  ghc-options: -fno-warn-tabs+  if impl(ghc>=7.0)+    ghc-options: -rtsopts++Executable doRequest+  main-is: hsrc/doRequest.hs+  Default-language: Haskell98+  build-depends: base, fudgets++  ghc-options: -fno-warn-tabs+  if impl(ghc>=7.0)+    ghc-options: -rtsopts
+ hsrc/AllFudgets.hs view
@@ -0,0 +1,33 @@+-- | This module exposes everything, but there is very little documentation+-- here. See the+-- <http://www.altocumulus.org/Fudgets/Manual/ Fudget Library Reference Manual>+-- instead.+module AllFudgets + (module Combinators, module Containers,module Debug,module DrawingModules,+  module Filters,module GuiElems,module InfixOps,module KernelUtils,+  module Layout,module LowLevel,module Types,module XTypesModules,+  module FudUtilities,module StreamProc,module InOut,module DefaultParams) where+import GuiElems+import Combinators+import InfixOps+import Layout+import Containers+import Filters+import DrawingModules+import KernelUtils+import StreamProc+import InOut+import LowLevel+import XTypesModules+import Types+import FudUtilities+import Debug+import DefaultParams++{-+#ifdef __NHC_HASKELL__+-- nhc bug workaround+blaha1=Pixel 1+blaha2=Width 1+#endif+-}
+ hsrc/Fudgets.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE CPP #-}+#include "exists.h"+-- | Programmers' index. There is very little documentation here. See the+-- <http://www.altocumulus.org/Fudgets/Manual/ Fudget Library Reference Manual>+-- instead.+module Fudgets(+ -- * GUI+ buttonF, border3dF, buttonBorderF, pushButtonF,+ BMevents(..),+ popupMenuF, Click(..),+ radioGroupF, radioGroupF', intF, passwdF, stringF,+ intInputF, stringInputF, passwdInputF,+ intInputF', stringInputF', passwdInputF',+ toggleButtonF,+ -- ** Popups+ inputPopupOptF, inputPopupF,+ passwdPopupOptF, passwdPopupF, stringPopupOptF, stringPopupF,+ confirmPopupF, ConfirmMsg(..), oldConfirmPopupF, oldMessagePopupF,+ messagePopupF, intDispF, displayF, labelF,+ -- ** Text editor+ EditStop(..), editF,+ EditEvt(..), EditCmd(..), editorF, editorF', selectall, loadEditor,+ newline, EDirection(..), inputEditorF, inputEditorF', EditorF,+ EditStopFn(..), EditStopChoice(..), IsSelect(..),setEditorCursorPos,+ -- ** List and text+ oldFilePickF, PickListRequest(..),+ textF, textF',-- textF'',+ TextRequest(..), TextF, HasInitText(..), HasSizing(..),Sizing(..),+ ListRequest(..),+ replaceAll, replaceAllFrom, deleteItems, insertItems, appendItems,+ changeItems, replaceItems, highlightItems, pickItem, applyListRequest, + smallPickListF, labRightOfF, labLeftOfF, labBelowF, labAboveF,+ tieLabelF, menuF, PopupMenu(..), menuPopupF,+ pickListF, moreShellF,pickListF', moreShellF',+ moreFileShellF, moreFileF, moreF, moreF',+ terminalF, cmdTerminalF, TerminalCmd(..),+ -- ** Graphics+ hyperGraphicsF, hyperGraphicsF',GraphicsF,setAdjustSize,+ -- * Fudgets and combinators+ contDynF,+ Fudget(..), F, --F(..),+ listF,+ untaggedListF, loopCompF, loopCompSP, loopF, loopLeftF, loopRightF, loopOnlyF,+ loopThroughRightF, loopCompThroughLeftF, loopCompThroughRightF,+ loopThroughBothF,+ --Message,+ delayF, getF, putF, putsF, startupF, appendStartF, ++ nullF, parF, prodF, absF, bypassF, concatMapF, idF, idLeftF,+ idRightF, mapF, mapstateF, serCompLeftToRightF, serCompRightToLeftF, stubF,+ throughF, toBothF, (>*<), (>+<), (>=^<), (>=^^<),+ (>#+<), (>#==<), (>==<), (>^=<), (>^^=<),+ prepostMapHigh,++ quitIdF, quitF,++ DynFMsg(..), dynF, dynListF, DynMsg(..), --Either(..),+ FudgetIO(..),+ --Fa(..),Direction, TCommand(..),TEvent(..),++ {- FCommand(..), FEvent(..), K(..), KCommand(..), KEvent(..),+ TCommand(..), TEvent(..), -}+ -- ** Input+ InF(..), InputMsg(..), inputDoneSP, inputLeaveDoneSP,+ inputListSP, inputPairSP, inputThroughF, inputPairF, inputListF, inputChange,+ inputListLF, inputPairLF, -- obsolete+ stripInputSP,+ inputButtonKey, inputLeaveKey, inputMsg, mapInp, stripInputMsg,+ inputDone, inputLeaveDone,+ tstInp,++ -- * Layout+ Orientation(..),+ alignF, marginHVAlignF, layoutModifierF, noStretchF,+ marginF, sepF,+ autoP, flipP, permuteP, revP, idP,+ Alignment(..), aBottom, aCenter, aLeft, aRight, aTop,+ -- barP, rightBelowP,+ dynListLF, LayoutDir(..),+ listLF, nullLF, holeF,+ --rbLayoutF,+ untaggedListLF, LayoutRequest,+ Placer, center, center', fixedh, fixedv, flipPoint,+ flipRect, flipReq,++ NameLayout, LName(..),hvAlignNL, marginHVAlignNL, hBoxNL, hBoxNL',+ nullNL, leafNL, spaceNL, placeNL, + listNF, modNL, nameF, nameLayoutF, sepNL, marginNL, vBoxNL, vBoxNL',++ hBoxF, matrixF, placerF, spacerF, spacer1F, revHBoxF, revVBoxF, spacerP,+ tableF, vBoxF, horizontalP, horizontalP', matrixP, matrixP',+ verticalP, verticalP',paragraphP,paragraphP',paragraphP'',+ dynPlacerF, dynSpacerF, -- There are pitfalls with using these...++ Distance(..), Spacer, bottomS, centerS, compS, flipS,+ hAlignS, sizeS, maxSizeS, minSizeS, hCenterS, hMarginS, marginHVAlignS,+ hvAlignS, hvMarginS, idS, leftS, marginS, sepS, noStretchS,+ rightS, topS, vAlignS, vCenterS, vMarginS, tableP, tableP', bubbleF,+ bubblePopupF, bubbleRootPopupF, shellF, PotRequest(..), PotState(..),+ containerGroupF, hPotF, vPotF, popupShellF, popupShellF', PopupMsg(..),+ posPopupShellF, hScrollF, scrollF, scrollShellF, vScrollF,+ ESelCmd(..), ESelEvt(..), SelCmd(..), SelEvt(..), eselectionF,+ selectionF, allcacheF,+ {-+ bitmapdatacacheF, bitmapfilecacheF,+ colorcacheF, fontcacheF, fontcursorcacheF, fstructcacheF, gCcacheF,+ -}+ doubleClickF, Time(..),+ -- * Stream processors+ -- ** Combining stream processors+ (-+-),(-*-),(-==-),+ compEitherSP, idLeftSP, idRightSP, postMapSP, preMapSP,+ prepostMapSP, serCompSP, loopLeftSP, loopSP, loopOnlySP, loopThroughRightSP,+ loopThroughBothSP,+ parSP, seqSP,+ -- ** Stream processor primitives+ SP,nullSP,putSP,putsSP,getSP,+ StreamProcIO(..),runSP, walkSP, pullSP,++ {-SPm(..), bindSPm, getSPm, monadSP, nullSPm, putsSPm, thenSPm, toSPm, unitSPm,-}++ -- ** Convenient stream processors+ idSP, filterSP, filterJustSP, filterLeftSP, filterRightSP, mapFilterSP,+ splitSP, toBothSP,+ concatSP, concSP,+ mapSP, concatMapSP, concmapSP,+ concatMapAccumlSP, mapstateSP, mapAccumlSP,+ zipSP,+ -- ** Stream processor behaviour+ Cont(..),+ appendStartSP, chopSP, delaySP, feedSP,+ splitAtElemSP, startupSP, stepSP,+ cmdContSP, conts, getLeftSP, getRightSP, waitForSP, waitForF, dropSP, contMap,+ -- * System (stdio, files, network, subprocesses)+ -- ** Dialogue IO+ hIOF,+ hIOSuccF, hIOerrF, haskellIOF,+ inputLinesSP, linesSP,+ -- ** Stdio+ outputF, stderrF, stdinF,+ stdioF, stdoutF,+ -- ** Subprocesses+ subProcessF,+ -- ** Files and directories+ appStorageF,+ readDirF, readFileF, writeFileF,+ -- ** Sockets+ Host(..), LSocket(..), Peer(..), Port(..), Socket(..),+ openLSocketF,+ openSocketF, receiverF, transceiverF, transmitterF, asyncTransmitterF,+ asyncTransceiverF,+ -- ** Timer+ Tick(..), timerF,+ --dropF,+ -- ** Running a fudget+ fudlogue, fudlogue', Fudlogue,+ -- * Command line, environment and defaults+ argFlag, argKey, argReadKey, argKeyList, args, progName,+ bgColor, buttonFont, defaultFont, defaultSize,+ defaultPosition, defaultSep, edgeWidth, fgColor, labelFont, look3d,+ menuFont, options, paperColor, shadowColor, shineColor,+ -- * Utilities for the Either type+ filterLeft, filterRight, isLeft, isRight, mapEither,+ fromLeft, fromRight, plookup, splitEitherList, stripEither, stripLeft,+ --  mapfilter, isM, stripMaybe, stripMaybeDef,+     -- use Maybe.mapMaybe,isJust,fromJust,fromMaybe!+ stripRight, swapEither,+ -- * Geometry+ (=.>),+ Line(..), Point(..), Rect(..), Size(..), Move(..), confine, diag, freedom,+ growrect, inRect, lL, line2rect, moveline, moverect, origin, pMax,+ pMin, pP, padd, plim, pmax, pmin, posrect, psub, rR, rect2line,+ rectMiddle,+ rmax, rsub, scale, scalePoint, sizerect,+ --xcoord, ycoord, rectpos, rectsize,+ -- * Utilities+ aboth, anth, gmap, -- afst, asnd, dropto, + issubset, lhead, loop, lsplit, ltail, mapPair, number, oo, pair,+ pairwith, part, remove, replace, swap, unionmap, module FudVersion,++ -- * Xlib types+ XCommand, XEvent, Path(..),+ Button(..), ColorName(..), FontName(..), KeySym(..), FontStruct, RGB(..),+ WindowAttributes, + ModState(..), Modifiers(..), +  -- * Graphics and drawings+ CoordMode(..),Shape(..),+ DrawCommand(..),fillCircle,drawCircle,+ Graphic(..),+ Drawing(..),atomicD,labelD,up,boxD,hboxD,hboxD',vboxD,vboxD',tableD,tableD',+ hboxcD,hboxcD',vboxlD,vboxlD',matrixD,matrixD',+ attribD,softAttribD,hardAttribD,fontD,fgD,stackD,spacedD,placedD,+ blankD,filledRectD,rectD,+ DPath(..),+#ifdef USE_EXIST_Q+ Gfx,+#endif+ g,+ FixedDrawing(..),FixedColorDrawing(..),gctx2gc,+ FlexibleDrawing(..),flex,flex',+ filler,hFiller,vFiller,frame,frame',ellipse,ellipse',arc,arc',+ filledEllipse,filledEllipse',filledarc,filledarc',+ lpar,rpar,lbrack,rbrack,lbrace,rbrace,+ triangleUp,triangleDown,filledTriangleUp,filledTriangleDown,+ BitmapFile(..),+ ColorGen(..),FontGen(..),FontSpec,ColorSpec,--Name(..),--ColorFallback(..),+#ifdef USE_EXIST_Q+ colorSpec,fontSpec,+#endif+ GCtx,rootGCtx,wCreateGCtx,createGCtx,gcFgA,gcBgA,gcFontA,+ GCAttributes(..),GCFillStyle(..),GCCapStyle(..),GCLineStyle(..),GCFunction(..),+ Width(..),++ -- * Customisation+ Customiser(..), PF(..), standard,++ HasClickToType(..), HasVisible(..), HasFontSpec(..), setFont,+ HasKeys(..), HasWinAttr(..), --HasTitle(..),+ HasBorderWidth(..), HasBgColorSpec(..), HasFgColorSpec(..), HasMargin(..),+ setBgColor,setFgColor,+ HasAlign(..),+ {- HasAllowedChar(..), HasShowString(..), -}+ setAllowedChar, setShowString, setCursorPos,+ HasCache(..),+ setDeleteQuit,setDeleteWindowAction,DeleteWindowAction(..),--HasDeleteQuit(..),+ HasInitSize(..),+ HasInitDisp(..),+ --setInitDisp, getInitDisp,+ setSpacer,+ HasStretchable(..),+ HasLabelInside(..),setPlacer,++ ShellF, shellF', setInitPos,+ unmappedSimpleShellF, unmappedSimpleShellF',+ ButtonF, buttonF', buttonF'', setLabel,+ DisplayF, displayF',-- displayF'',+ labelF', --labelF'',+ StringF, stringF', stringF'', setInitString, setInitStringSize,+ passwdF', passwdF'',+ intF', intF'',+ intDispF', --intDispF'',+ -- * Miscellaneous+ gcWarningF,bellF,+ --D_IOError,+ -- * Time+#ifdef VERSION_old_time+ getTime,getLocalTime,+#endif+#ifdef VERSION_time+ getCurrentTime,getZonedTime,+#endif+ -- * Debugging+ spyF,teeF, ctrace,showCommandF) where++import AllFudgets -- hiding (Cont,PCont,Fa)+import FudVersion++-- I hate this file /TH+-- I still hate this file /TH
+ hsrc/combinators/BranchF.hs view
@@ -0,0 +1,70 @@+module BranchF(branchF,branchFSP) where+import Direction+import Fudget+--import Path(Path(..))+import Route+import SP+--import Message(Message(..))++branchF :: (F (Path, a) b) -> (F (Path, a) b) -> F (Path, a) b+branchF (F f1) (F f2) = F{-ff-} (branchFSP f1 f2)++branchFSP :: (FSP (Path, a) b) -> (FSP (Path, a) b) -> FSP (Path, a) b+branchFSP f1 f2 =+    case f1 of+      PutSP (Low tcmd) f1' -> PutSP (compTurnLeft tcmd) (branchFSP f1' f2)+      PutSP msg f1' -> PutSP msg (branchFSP f1' f2)+      GetSP xf1 -> branchF1 xf1 f2+      NullSP -> restF2 f2++--and branchF1:: (FEvent *a->F *a *b) -> F *c *d -> F (Either *a *c) (Either *b *d)+branchF1 xf1 f2 =+    case f2 of+      PutSP (Low tcmd) f2' -> PutSP (compTurnRight tcmd) (branchF1 xf1 f2')+      PutSP msg f2' -> PutSP msg (branchF1 xf1 f2')+      GetSP xf2 -> GetSP (branchF12 xf1 xf2)+      NullSP -> GetSP (restF1x xf1)++--and branchF2:: F *a *b -> (FEvent *c->F *c *d) -> F (Either *a *c) (Either *b *d)+branchF2 f1 xf2 =+    case f1 of+      PutSP (Low tcmd) f1' -> PutSP (compTurnLeft tcmd) (branchF2 f1' xf2)+      PutSP msg f1' -> PutSP msg (branchF2 f1' xf2)+      GetSP xf1 -> GetSP (branchF12 xf1 xf2)+      NullSP -> GetSP (restF2x xf2)++--and branchF12:: (FEvent *a->F *a *b) -> (FEvent *c->F *c *d) -> FEvent (Either *a *c) -> F (Either *a *c) (Either *b *d)+branchF12 xf1 xf2 msg =+    case msg of+      High (L : path', x) -> branchF2 (xf1 (High (path', x))) xf2+      High (R : path', y) -> branchF1 xf1 (xf2 (High (path', y)))+      Low (L : path', x) -> branchF2 (xf1 (Low (path', x))) xf2+      Low (R : path', y) -> branchF1 xf1 (xf2 (Low (path', y)))+      _ -> GetSP (branchF12 xf1 xf2)++restF2 f2 =+    case f2 of+      PutSP (Low tcmd) f2' -> PutSP (compTurnRight tcmd) (restF2 f2')+      PutSP msg f2' -> PutSP msg (restF2 f2')+      GetSP xf2 -> GetSP (restF2x xf2)+      NullSP -> NullSP++restF2x xf2 msg =+    case msg of+      High (R : path', y) -> restF2 (xf2 (High (path', y)))+      Low (R : path', ev) -> restF2 (xf2 (Low (path', ev)))+      _ -> GetSP (restF2x xf2)++restF1 f1 =+    case f1 of+      PutSP (Low tcmd) f1' -> PutSP (compTurnLeft tcmd) (restF1 f1')+      PutSP msg f1' -> PutSP msg (restF1 f1')+      GetSP xf1 -> GetSP (restF1x xf1)+      NullSP -> NullSP++restF1x xf1 msg =+    case msg of+      High (L : path', x) -> restF1 (xf1 (High (path', x)))+      Low (L : path', ev) -> restF1 (xf1 (Low (path', ev)))+      _ -> GetSP (restF1x xf1)+
+ hsrc/combinators/Combinators.hs view
@@ -0,0 +1,19 @@+module Combinators (-- * Combinators+  module BranchF,module CompF,module ParF,module CompFfun,module DynListF,module ListF,module LoopLow,module Loops,module LoopCompF,module NullF,module ProdF,module Route,module SerCompF,module StateMonads,module TreeF,module InputF,module ContDynF) where+import BranchF+import CompF+import ParF+import CompFfun+import DynListF+import ListF+import LoopLow+import Loops+import LoopCompF+import NullF+import ProdF+import Route+import SerCompF+import StateMonads+import TreeF+import InputF+import ContDynF
+ hsrc/combinators/CompF.hs view
@@ -0,0 +1,72 @@+module CompF(compF) where+import Fudget+--import Message(Message(..))+import Route+import SP+import Direction+import LayoutHints++--import Maptrace(ctrace) -- debugging++compF (F f1) (F f2) = layoutHintF parHint (F{-ff-} (compF' f1 f2))++compF' :: FSP a b -> FSP c d -> FSP (Either a c) (Either b d)+compF' f1 f2 =+    case f1 of+      PutSP (High x) f1' -> PutSP (High (Left x)) (compF' f1' f2)+      PutSP (Low tcmd) f1' -> PutSP (compTurnLeft tcmd) (compF' f1' f2)+      GetSP xf1 -> compF1 xf1 f2+      NullSP -> restF2 f2++compF1 :: (FEvent a -> FSP a b) -> FSP c d -> FSP (Either a c) (Either b d)+compF1 xf1 f2 =+    case f2 of+      PutSP (High y) f2' -> PutSP (High (Right y)) (compF1 xf1 f2')+      PutSP (Low tcmd) f2' -> PutSP (compTurnRight tcmd) (compF1 xf1 f2')+      GetSP xf2 -> GetSP (compF12 xf1 xf2)+      NullSP -> GetSP (restF1x xf1)++compF2 :: FSP a b -> (FEvent c -> FSP c d) -> FSP (Either a c) (Either b d)+compF2 f1 xf2 =+    case f1 of+      PutSP (High x) f1' -> PutSP (High (Left x)) (compF2 f1' xf2)+      PutSP (Low tcmd) f1' -> PutSP (compTurnLeft tcmd) (compF2 f1' xf2)+      GetSP xf1 -> GetSP (compF12 xf1 xf2)+      NullSP -> GetSP (restF2x xf2)++compF12 :: (FEvent a -> FSP a b) -> (FEvent c -> FSP c d) -> (FEvent (Either a c)) -> FSP (Either a c) (Either b d)+compF12 xf1 xf2 msg =+    case msg of+      High (Left x) -> compF2 (xf1 (High x)) xf2+      High (Right y) -> compF1 xf1 (xf2 (High y))+      Low (tag, ev) -> case tag of+                         L : tag' -> compF2 (xf1 (Low (tag', ev))) xf2+                         R : tag' -> compF1 xf1 (xf2 (Low (tag', ev)))+                         _ -> {-ctrace "drop" (tag,ev) $-} GetSP (compF12 xf1 xf2)++restF2 f2 =+    case f2 of+      PutSP (High y) f2' -> PutSP (High (Right y)) (restF2 f2')+      PutSP (Low tcmd) f2' -> PutSP (compTurnRight tcmd) (restF2 f2')+      GetSP xf2 -> GetSP (restF2x xf2)+      NullSP -> NullSP++restF2x xf2 msg =+    case msg of+      High (Right y) -> restF2 (xf2 (High y))+      Low (R : tag, ev) -> restF2 (xf2 (Low (tag, ev)))+      _ -> GetSP (restF2x xf2)++restF1 f1 =+    case f1 of+      PutSP (High y) f1' -> PutSP (High (Left y)) (restF1 f1')+      PutSP (Low tcmd) f1' -> PutSP (compTurnLeft tcmd) (restF1 f1')+      GetSP xf1 -> GetSP (restF1x xf1)+      NullSP -> NullSP++restF1x xf1 msg =+    case msg of+      High (Left x) -> restF1 (xf1 (High x))+      Low (L : tag, ev) -> restF1 (xf1 (Low (tag, ev)))+      _ -> GetSP (restF1x xf1)+
+ hsrc/combinators/CompFfun.hs view
@@ -0,0 +1,61 @@+module CompFfun where+import CompSP+import Fudget+import Message+--import Path(Path(..))+--import SP++postProcessHigh postsp (F sp) = F{-ff-} (postProcessHigh' postsp sp)+postProcessLow postsp (F sp) = F{-ff-} (postProcessLow' postsp sp)+preProcessHigh (F sp) presp = F{-ff-} (preProcessHigh' sp presp)+preProcessLow (F sp) presp = F{-ff-} (preProcessLow' sp presp)+preMapHigh (F sp) pre = F{-ff-} (preMapHigh' sp pre)+postMapHigh post (F sp) = F{-ff-} (postMapHigh' post sp)+preMapLow (F sp) pre = F{-ff-} (preMapLow' sp pre)+postMapLow post (F sp) = F{-ff-} (postMapLow' post sp)++postProcessHighK postsp (K sp) = K{-kk-} (postProcessHigh' postsp sp)+postProcessLowK postsp (K sp) = K{-kk-} (postProcessLow' postsp sp)+preProcessHighK (K sp) presp = K{-kk-} (preProcessHigh' sp presp)+preProcessLowK (K sp) presp = K{-kk-} (preProcessLow' sp presp)+preMapHighK (K sp) pre = K{-kk-} (preMapHigh' sp pre)+postMapHighK post (K sp) = K{-kk-} (postMapHigh' post sp)+preMapLowK (K sp) pre = K{-kk-} (preMapLow' sp pre)+postMapLowK post (K sp) = K{-kk-} (postMapLow' post sp)++postProcessHigh' :: (SP a b) -> (Fa c d e a) -> Fa c d e b+postProcessHigh' p f = serCompSP (idLowSP p) f++postProcessLow' :: (SP a b) -> (Fa c a d e) -> Fa c b d e+postProcessLow' p f = serCompSP (idHighSP p) f++preProcessHigh' :: (Fa a b c d) -> (SP e c) -> Fa a b e d+preProcessHigh' f p = serCompSP f (idLowSP p)++preProcessLow' :: (Fa a b c d) -> (SP e a) -> Fa e b c d+preProcessLow' f p = serCompSP f (idHighSP p)++preMapHigh' :: (Fa a b c d) -> (e -> c) -> Fa a b e d+preMapHigh' f pre = preMapSP f (aHigh pre)++preMapLow' :: (Fa a b c d) -> (e -> a) -> Fa e b c d+preMapLow' f pre = preMapSP f (aLow pre)++postMapHigh' :: (a -> b) -> (Fa c d e a) -> Fa c d e b+postMapHigh' post f = postMapSP (aHigh post) f++postMapLow' :: (a -> b) -> (Fa c a d e) -> Fa c b d e+postMapLow' post f = postMapSP (aLow post) f++prepostMapHigh' :: (a -> b) -> (c -> d) -> (Fa e f b c) -> Fa e f a d+prepostMapHigh' pre post f = prepostMapSP (aHigh pre) (aHigh post) f+++prepostMapHigh pre post (F sp) = F{-ff-} (prepostMapHigh' pre post sp)+prepostMapHighK pre post (K sp) = K{-kk-} (prepostMapHigh' pre post sp)++prepostMapLow' :: (a -> b) -> (c -> d) -> (Fa b c e f) -> Fa a d e f+prepostMapLow' pre post f = prepostMapSP (aLow pre) (aLow post) f++prepostMapLow pre post (F sp) = F (prepostMapLow' pre post sp)+prepostMapLowK pre post (K sp) = K (prepostMapLow' pre post sp)
+ hsrc/combinators/ContDynF.hs view
@@ -0,0 +1,27 @@+module ContDynF where++import Fudget+--import Xtypes+import Command+import FRequest+--import LayoutRequest(LayoutRequest)+--import Geometry+--import Message+import Spops(getSP,putSP,walkSP,pullSP)+import Path(here)+--import Direction+import Cont+--import Dynforkmerge+--import NullF(getMessageF,putMessageF)+--import LayoutDir++contDynF :: F a b -> Cont (F a d) b+contDynF (F sp) = fContWrap (contDynFSP sp)++contDynFSP :: FSP a b -> Cont (FSP a d) b+contDynFSP f c = cdf (pullSP f)+  where cdf (outf,f') = out f' outf +        out f' [] = getSP $ \msg -> cdf (walkSP f' msg)+        out f' (x:xs) = case x of+	   High msg -> putSP (Low (here,XCmd DestroyWindow)) $ c msg+	   Low cmd -> putSP (Low cmd) $ out f' xs
+ hsrc/combinators/DynListF.hs view
@@ -0,0 +1,40 @@+module DynListF(dynF, DynFMsg(..), dynListF) where+import Command+import FRequest+--import Xtypes+import CompOps((>^=<),(>=^^<))+import CompSP+import Dynforkmerge+import Fudget+--import Message(Message(..))+import NullF+import Spops+import Direction+import Path+import LayoutRequest++type DynFMsg a b = DynMsg a (F a b)++dynListF :: F (Int, DynFMsg a b) (Int, b)+dynListF =+    let prep (High (t, DynMsg m)) = [High (t, DynMsg (High m))]+        prep (High (t, DynDestroy)) = +	    map tag [XCmd DestroyWindow,LCmd LayoutDestroy] +		++ [High (t, DynDestroy)] +	    where tag m = Low (turn (Dno t) here, m)+        prep (High (t, DynCreate (F f))) = [High (t, DynCreate f)]+        prep (Low ([], ev)) = []+        prep (Low (tag, ev)) =+            case path tag of+              (Dno i, tag') -> [High (i, DynMsg (Low (tag', ev)))]+	      _ -> [] -- wrong address!+        post (High (t, High m)) = High (t, m)+        post (High (i, Low (tag, cmd))) = Low (turn (Dno i) tag, cmd)+        post (Low c) = Low c+    in F{-ff-} $ serCompSP (postMapSP post (idLowSP dynforkmerge)) (concmapSP prep)++dynF :: (F a b) -> F (Either (F a b) a) b+dynF f0 =+    let prep (Left f) = [(0, DynDestroy), (0, DynCreate f)]+        prep (Right m) = [(0, DynMsg m)]+    in (snd >^=< startupF [(0, DynCreate f0)] dynListF) >=^^< concmapSP prep
+ hsrc/combinators/InputF.hs view
@@ -0,0 +1,29 @@+module InputF(module InputF) where+import Fudget+import InputMsg+import CompOps+import ListF(listF)+import Placer(placerF)+import LayoutF(orientP)+import EitherUtils(stripEither)+import Spops+import InputSP+import AuxTypes() -- synonym KeySym, for hbc+import SpEither(splitSP)+import SerCompF(mapF,toBothF)++type InF a b = F a (InputMsg b)++inputPairLF orient f1 f2 = placerF (orientP orient) $ inputPairF f1 f2+inputListLF placer tfs = placerF placer $ inputListF tfs++inputPairF :: InF a1 b1 -> InF a2 b2 -> InF (a1,a2) (b1,b2)+inputPairF f1 f2 = inputPairSP >^^=< (f1>+<f2) >=^^< splitSP++inputListF :: (Eq a) => [(a, InF b c)] -> InF [(a, b)] [(a, c)] +inputListF tfs =+  inputListSP (map fst tfs) >^^=< listF [(t,f)|(t,f)<-tfs] >=^^< concatSP++inputThroughF :: InF a a -> InF a a+inputThroughF f = stripEither>^=<(f>+<mapF InputChange)>==<toBothF+
+ hsrc/combinators/ListF.hs view
@@ -0,0 +1,74 @@+module ListF(listF,untaggedListF) where+import CompF+import CompSP(prepostMapSP)+import CompSP(preMapSP)+import CompOps((>^=<),(>=^^<))+import Direction+import Fudget+--import ListMap(lookupWithDefault)+--import Message(Message(..))+--import NullF+--import Path(Path(..))+import Spops+import TreeF+import Utils(number,pair)+import HbcUtils(apSnd,lookupWithDefault)+import LayoutHints++untaggedListF :: [F a b] -> F a b+untaggedListF fs = snd >^=< listF tfs >=^^< concatMapSP broadcast+  where+    tfs = number 0 fs+    ns = map fst tfs+    broadcast x = map (`pair` x) ns++listF :: {-Prelude.-}Eq a => [(a, F b c)] -> F (a, b) (a, c)+listF = layoutHintF listHint . F{-ff-} . listF'++listF' :: Eq a => [(a, F b c)] -> FSP (a, b) (a, c)+listF' [(tag, F w)] =+    let prepinp (High (t, a)) =+            if t == tag then High a else error "Unknown tag in listF"+        prepinp (Low tev) = Low tev+        prepout (High b) = High (tag, b)+        prepout (Low cmd) = Low cmd+    in  prepostMapSP prepinp prepout w+listF' [(ltag, lw), (rtag, rw)] =+    let prepinp (High (tag, a)) =+            if tag == ltag then+                High (Left a)+            else+                if tag == rtag then+                    High (Right a)+                else+                    error "Unknown tag in listF"+        prepinp (Low tev) = Low tev+        prepout (High (Left b)) = High (ltag, b)+        prepout (High (Right b)) = High (rtag, b)+        prepout (Low cmd) = Low cmd+        F lwrw = compF lw rw+    in  prepostMapSP prepinp prepout lwrw+listF' [] = nullSP+listF' wtab =+    let tree = balancedTree wtab+        paths = pathtab tree+        prepinp (High (tag, a)) =+            let path' = lookupWithDefault paths (error "Unknown tag in listF") tag+            in  High (path', a)+        prepinp (Low tev) = Low tev+    in  preMapSP (treeF' tree) prepinp++pathtab (Leaf (t, _)) = [(t, [])]+pathtab (Branch l r) =+    map (apSnd (L :)) (pathtab l) ++ map (apSnd (R :)) (pathtab r)++balancedTree xs =+    case xs of+      [x] -> Leaf x+      _ -> let (l, r) = split2 xs+           in  Branch (balancedTree l) (balancedTree r)++split2 l =+    let sp = length l `quot` 2+    in  (take sp l, drop sp l)+
+ hsrc/combinators/LoopCompF.hs view
@@ -0,0 +1,30 @@+module LoopCompF(loopCompF,loopCompSP,loopThroughBothF,loopThroughBothSP) where+import Fudget        +import CompFfun(prepostMapHigh)+import CompF(compF)+import CompSP(compSP,prepostMapSP)+import Loop(loopLeftSP)+import Loops(loopLeftF)++-- loopComp = symmetric version of loopThroughRight++loopCompF :: F (Either (Either r2l inl) (Either l2r inr))+               (Either (Either l2r outl) (Either r2l outr)) ->+	     F (Either inl inr) (Either outl outr)+loopCompF = loopLeftF . prepostMapHigh pre post++loopThroughBothF fud1 fud2 = loopCompF (fud1 `compF` fud2)+loopThroughBothSP sp1 sp2 = loopCompSP (sp1 `compSP` sp2)++loopCompSP = loopLeftSP . prepostMapSP pre post++post (Left  (Left  x)) = Left (Left x)+post (Left  (Right x)) = Right (Left x)+post (Right (Left x)) = Left (Right x)+post (Right (Right x)) = Right (Right x)+-- post = either (either (Left.Left) (Right.Left))  (either (Left.Right) (Right.Right))++pre (Right (Left x)) = Left (Right x)+pre (Right (Right x)) = Right (Right x)+pre (Left (Left x)) = Right (Left x)+pre (Left (Right x)) = Left (Left x)
+ hsrc/combinators/LoopLow.hs view
@@ -0,0 +1,46 @@+module LoopLow(loopLow,loopThroughLowSP,loopThroughLowF) where+--import Command(Command(..))+import CompSP+--import Event(Event(..))+import Fudget+import Loop+--import Message(Message(..))+--import Path(Path(..))+--import SP+import Loopthrough(loopThroughRightSP)++loopLow :: (SP TCommand (FCommand a)) -> (SP (FEvent a) TEvent) -> (F b c) -> F b c+loopLow ch eh (F f) =+    let prep (Left msg) = Low (High msg)+        prep (Right (High msg)) = High msg+        prep (Right (Low msg)) = Low (Low msg)+        post (High msg) = Right (High msg)+        post (Low (High msg)) = Left msg+        post (Low (Low msg)) = Right (Low msg)+    in F{-ff-} $+	loopLeftSP+	  (prepostMapSP prep post	+		        (idHighSP ch `serCompSP` f `serCompSP` idHighSP eh))++loopThroughLowSP :: SP (Either c e) (Either c e) -> +		    SP (Message e a) (Message c b) ->+ 	            SP (Message e a) (Message c b)++loopThroughLowSP ctrl f =+    loopThroughRightSP (prepostMapSP prep post (idHighSP ctrl)) f+  where+    prep msg = case msg of+		 Right (High a) -> High (Left a)+		 Left (High a) -> High (Right a)+		 Right (Low e) -> Low (Right e)+		 Left (Low c) -> Low (Left c)++    post msg = case msg of+		 High (Left msg) -> Left (High msg)+		 High (Right msg) -> Right (High msg)+		 Low (Left c) -> Right (Low c)+		 Low (Right e) -> Left (Low e)++loopThroughLowF+  :: SP (Either TCommand TEvent) (Either TCommand TEvent) -> F i o -> F i o+loopThroughLowF ctrlSP (F fudSP) = F $ loopThroughLowSP ctrlSP fudSP
+ hsrc/combinators/Loops.hs view
@@ -0,0 +1,76 @@+module Loops(loopF, loopThroughRightF, loopCompThroughRightF, loopCompThroughLeftF, loopRightF, loopLeftF, loopOnlyF) where+import Maptrace(ctrace) -- debugging -- syntax error if you put this is last in the import list. TH 960428+--import Command(Command(..))+import CompFfun(prepostMapHigh)+--import CompSP(prepostMapSP)+import CompOps+--import Event(Event(..))+import Fudget+import Loop+--import Message(Message(..))+--import Path(Path(..))+--import SP+import SpEither(toBothSP,mapFilterSP)+import EitherUtils(stripEither, swapEither)+import LayoutHints+import Route+import Direction+import Loopthrough+import CompSP+++loopLeftF :: (F (Either a b) (Either a c)) -> F b c+loopLeftF (F sp) =+    let post (Low x) = Right (Low x)+        post (High (Right x)) = Right (High x)+        post (High (Left x)) = Left x+        pre (Right (Low x)) = Low x+        pre (Right (High x)) = High (Right x)+        pre (Left xs) = High (Left xs)+    in {-layoutHintF loopHint-} (F{-ff-} $ loopLeftSP (prepostMapSP pre post sp))++loopRightF :: (F (Either a b) (Either c b)) -> F a c+loopRightF f = loopLeftF (prepostMapHigh swapEither swapEither f)++loopThroughRightF :: F (Either a b) (Either c d) -> F c a -> F b d+loopThroughRightF (F m) (F s) = +   --loopThroughRightSP (prepostMapSP pre post (idRightSP m)) s where+   layoutHintF loopHint $+   F{-ff-} $+   loopThroughRightSP+      (post `postMapSP` (idRightSP m) `serCompSP` mapFilterSP pre) s where++   post (Left (Low c)) = Right (compTurnLeft c)+   post (Right (Left c)) = Right (compTurnRight c)+   post (Right (Right e)) = Left (Low e)+   post (Left (High (Left m))) = Left (High m)+   post (Left (High (Right m))) = Right (High m)++   pre (Right (Low (p,e))) =+     case p of+       L:p -> Just $ Left (Low (p,e))+       R:p -> Just $ Right (Right (p,e))+       _   -> ctrace "drop" (p,e) $ Nothing --error "Dno in loopThroughRightF"+   pre (Left (Low c)) = Just $ Right (Left c)+   pre (Right (High m)) = Just $ Left (High (Right m))+   pre (Left (High m)) = Just $ Left (High (Left m))++loopCompThroughRightF :: (F (Either (Either a b) c) (Either (Either c d) a)) -> F b d+loopCompThroughRightF w =+    let post (Left (Left x)) = Left (Right x)+        post (Left (Right x)) = Right x+        post (Right x) = Left (Left (Left x))+        pre (Left x) = x+        pre (Right x) = Left (Right x)+    in  loopLeftF (prepostMapHigh pre post w)+++loopCompThroughLeftF :: (F (Either a (Either b c)) (Either b (Either a d))) -> F c d+loopCompThroughLeftF f =+    loopCompThroughRightF (prepostMapHigh swapEither swapEither f)++loopOnlyF :: F a a -> F a b+loopOnlyF f = loopLeftF (prepostMapHigh stripEither Left f)++loopF :: F a a -> F a a+loopF f = loopLeftF (toBothSP>^^=<f>=^<stripEither)
+ hsrc/combinators/NullF.hs view
@@ -0,0 +1,87 @@+module NullF(module NullF, Cont(..),K,F,StreamProcIO(..),FudgetIO(..)) where+import Utils(pair)+import Fudget+import Message(aLow,stripHigh) --Message(..),+import Path(here)+import Spops+import Cont(dropSP,kContWrap,fContWrap,waitForK,waitForFu)+import StreamProcIO+import FudgetIO++--{- -}+instance StreamProcIO F where+  put = putF+  get = getF -- Discards low level input! Leave undefined?+  end = nullF++instance StreamProcIO K where+  put = putHigh+  get = getHigh+  end = nullK++instance FudgetIO F where+  waitForMsg = waitForFu+  putMsg = putMessageFu+  --nullMsg = nullF+  --getMsg = getMessageFu+++instance FudgetIO K where+  putMsg = putK+  waitForMsg = waitForK+  --nullMsg = nullK+  --getMsg = getK++---}++----++nullK = K{-kk-} nullSP+nullF = F{-ff-} nullSP++--putK :: KCommand ho -> K hi ho -> K hi ho+putK o (K sp) = kk (putSP o sp)++putF = putMessageF . High++putsF = puts :: ([b] -> F a b -> F a b)+--putsF his f = foldr putF f his+putsK = putMsgs :: ([KCommand b] -> K a b -> K a b)+--putsK msgs k = foldr putK k msgs++putMessageF msg (F sp) = F{-ff-} (putSP msg sp)+putMessageFu = putMessageF . aLow (pair here)++putMessagesF hos (F sp) = F{-ff-} (putsSP hos sp)+putMessagesFu = putMsgs :: ([KCommand b] -> F a b -> F a b)+--putMessagesFu msgs f = foldr putMessageFu f msgs++--appendStartK :: [KCommand b] -> K a b -> K a b+appendStartK kcmds (K sp) = kk (appendStartSP kcmds sp)++--appendStartMessageF :: [FCommand b] -> F a b -> F a b+appendStartMessageF fcmds (F sp) = F{-ff-} (appendStartSP fcmds sp)++--appendStartF :: [b] -> F a b -> F a b+appendStartF = appendStartMessageF . map High++getK = kContWrap getSP -- :: (Cont (K a b) (KEvent a))++getMessageF = fContWrap getSP -- :: (Cont (F a b) (FEvent a))+getMessageFu = fContWrap (getSP . (. aLow snd)) :: (Cont (F a b) (KEvent a))++--getF :: Cont (F a b) a+getF = fContWrap (dropSP stripHigh)++--startupK :: ([KEvent a] -> K a b -> K a b)+startupK kevs (K sp) = kk (startupSP kevs sp)+--startupMessageF :: ([FEvent a] -> F a b -> F a b)+startupMessageF fevs (F sp) = F{-ff-} (startupSP fevs sp)++--startupMessageFu = startupMessageF . map (aLow (pair here)) -- error prone++--startupF :: [a] -> F a b -> F a b+startupF = startupMessageF . map High++--delayF :: (F a b -> F a b)+delayF (F sp) = F{-ff-} (delaySP sp)
+ hsrc/combinators/ParF.hs view
@@ -0,0 +1,10 @@+module ParF(parF) where+--import Fudget+import EitherUtils(stripEither)+import CompF(compF)+--import SerCompF(serCompF)+import CompFfun(postMapHigh,preProcessHigh)+import SpEither(toBothSP)++-- Quick (i.e. slow) implementation+parF f1 f2 = stripEither `postMapHigh` compF f1 f2 `preProcessHigh` toBothSP
+ hsrc/combinators/ProdF.hs view
@@ -0,0 +1,8 @@+module ProdF where+import CompOps((>+<), (>=^^<))+import Fudget+import SpEither(splitSP)++prodF :: (F a b) -> (F c d) -> F (a, c) (Either b d)+prodF leftw rightw = (leftw >+< rightw) >=^^< splitSP+
+ hsrc/combinators/Route.hs view
@@ -0,0 +1,13 @@+module Route(compTurnRight, compTurnLeft, compPath) where+import Direction+import Message(Message(..))+import Path({-Path(..),-}path, turn)++compPath (tag, ev) wrongaddr c =+    case path tag of+      (L, tag') -> c $ Left (Low (tag', ev))+      (R, tag') -> c $ Right (Low (tag', ev))+      _ -> wrongaddr++compTurnLeft  (tag, cmd) = Low (turn L tag, cmd)+compTurnRight (tag, cmd) = Low (turn R tag, cmd)
+ hsrc/combinators/SerCompF.hs view
@@ -0,0 +1,87 @@+module SerCompF(stubF, bypassF, throughF, toBothF,+                idF, concatMapF, mapF, mapstateF, absF, idLeftF,+                idRightF, serCompLeftToRightF, serCompRightToLeftF,+		serCompF) where+--import Command(Command(..))+import CompF+import CompFfun(postMapHigh)+import CompSP+--import Direction+--import Event(Event(..))+import Fudget+import Loop+--import Message(Message(..))+import NullF+--import Path(Path(..))+import Route+import Spops+import EitherUtils(stripEither)+import LayoutHints++serCompF (F f1) (F f2) = layoutHintF serHint (F{-ff-} $ serCompF' f1 f2)++serCompF' :: FSP a b -> FSP c a -> FSP c b+serCompF' f1 f2 =+    let post (Left (High x)) = High x+        post (Left (Low tcmd)) = compTurnLeft tcmd+        post (Right tcmd) = compTurnRight tcmd+        mid (Left ltev) = Left ltev+        mid (Right (Low tcmd)) = Right tcmd+        mid (Right (High x)) = Left (High x)+        pre (High x) = [Right (High x)]+        pre (Low ([], _)) = []+        pre (Low tev) = compPath tev [] (:[])+    in  serCompSP (postMapSP post+                             (serCompSP (idRightSP f1)+                                        (postMapSP mid (idLeftSP f2))))+                  (concmapSP pre)++serCompRightToLeftF :: (F (Either a b) (Either c a)) -> F b c+serCompRightToLeftF (F sp) =+    let post (Low x) = Right (Low x)+        post (High (Left x)) = Right (High x)+        post (High (Right x)) = Left x+        pre (Right (Low x)) = Low x+        pre (Right (High x)) = High (Right x)+        pre (Left xs) = High (Left xs)+    in F{-ff-} $ loopLeftSP (prepostMapSP pre post sp)++serCompLeftToRightF :: (F (Either a b) (Either b c)) -> F a c+serCompLeftToRightF (F sp) =+    let post (Low x) = Right (Low x)+        post (High (Right x)) = Right (High x)+        post (High (Left x)) = Left x+        pre (Right (Low x)) = Low x+        pre (Right (High x)) = High (Left x)+        pre (Left xs) = High (Right xs)+    in F{-ff-} $ loopLeftSP (prepostMapSP pre post sp)++idRightF :: (F a b) -> F (Either a c) (Either b c)+--and idRightF w = w:+:idF+idRightF w = compF w idF++idLeftF w = compF idF w++absF :: (SP a b) -> F a b+absF sp =+    let pre (High x) = [x]+        pre (Low y) = []+    in F{-ff-} $ serCompSP (postMapSP High sp) (concmapSP pre)++concatMapF = absF . concatMapSP+mapF = absF . mapSP+mapstateF f x = absF (mapstateSP f x)++idF = mapF id++toBothF = concatMapF (\x -> [Left x, Right x])++throughF w = serCompF (idRightF w) toBothF++--and throughF w = idRightF w:==:toBothF+bypassF :: (F a a) -> F a a+bypassF f = postMapHigh stripEither (throughF f)++stubF :: F a b -> F c d+stubF f = serCompF (serCompF nullF f) nullF+
+ hsrc/combinators/StateMonads.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE CPP #-}+module StateMonads where+import Control.Applicative+import Control.Monad(ap)+import Fudget(K) --,KEvent+import FudgetIO+import StreamProcIO+import EitherUtils(Cont(..))+import NullF(getK)++--------------------------------------------------------------------------------++-- | The continuation monad+#ifdef __HBC__+newtype Mk k r = Mk (Cont k r)+unMk (Mk mk) = mk+#else+newtype Mk k r = Mk {unMk::Cont k r}+#endif+-- | Continuation monad with unit result+type Mkc k = Mk k ()++instance Functor (Mk k) where+  fmap f (Mk m) = Mk (\k -> m (k.f))++instance Applicative (Mk k) where+  pure = return+  (<*>) = ap+  +instance Monad (Mk k) where+  return r =  Mk ($ r)+  Mk m1 >>= xm2 = Mk (m1 . flip (unMk . xm2))++--------------------------------------------------------------------------------++-- | Continuation monad with state (just an instance of the continuation monad)+type Ms k s r = Mk (s -> k) r+type Msc k s = Ms k s ()++loadMs  :: Ms k s s+storeMs :: s -> Msc k s+modMs   :: (s -> s) -> Msc k s+fieldMs :: (s -> f) -> Ms k s f++loadMs    = Mk (\ k s -> k s s)+storeMs s = Mk (\ k _ -> k () s)+modMs   f = Mk (\ k s -> k () (f s))+fieldMs r = Mk (\ k s -> k (r s) s)++nopMs :: Msc k s+nopMs = return ()++--------------------------------------------------------------------------------++toMkc :: (k -> k) -> Mkc k+toMkc k = Mk (\f -> k (f ()))++toMs :: Cont k r -> Ms k s r+toMs f = Mk (bmk f)+bmk f = (f .) . flip++toMsc :: (k -> k) -> Msc k r+toMsc k = Mk (\f -> k . f ())++--------------------------------------------------------------------------------+-- | Fudget Kernel Monad with State (just an instance...)+type Ks i o s ans = Ms (K i o) s ans+--type Ksc i o s = Ks i o s ()++{-+putsKs :: [KCommand a] -> Ksc b a c+putKs  :: KCommand a -> Ksc b a c+getKs  :: Ks a b c (KEvent a)+nullKs :: Ks i o s ()+loadKs :: Ks i o s s+storeKs :: s -> Ks i o s ()+-}+putHighsMs c = toMsc (puts c)+putHighMs  c = toMsc (put c)+putLowsMs  c = toMsc (putLows c)+putLowMs   c = toMsc (putLow c)+getKs        = toMs getK+++-- Some synonyms, kept mostly for backwards compatibility+nullKs   =  nopMs+storeKs  = storeMs+loadKs   = loadMs+unitKs x = return x+bindKs m1 xm2 = m1>>=xm2+thenKs m1 m2 = m1>>m2+mapKs f = fmap f++-- Running a kernel monad++--stateMonadK :: s -> Ks i o s ans -> (ans -> K i o) -> K i o+stateMonadK s0 (Mk ks) k = ks (\ans state->k ans) s0++--stateK :: a -> (Ksc b c a) -> (K b c) -> K b c+stateK s (Mk ksc) k = ksc (const (const k)) s
+ hsrc/combinators/TreeF.hs view
@@ -0,0 +1,19 @@+module TreeF where+import BranchF+import CompFfun(prepostMapHigh')+import Utils(pair)+import Fudget++data Tree a = Leaf a | Branch (Tree a) (Tree a)  deriving (Eq, Ord)++treeF :: Tree (a, F b c) -> F (Path, b) (a, c)+treeF = F{-ff-} . treeF'++treeF' :: Tree (a, F b c) -> FSP (Path, b) (a, c)+treeF' (Leaf (t, f)) = leafF t f+treeF' (Branch l r) = branchFSP (treeF' l) (treeF' r)++leafF t (F sp) =+    let pre ([], x) = x+        pre _ = error "unknown path in treeF"+    in  prepostMapHigh' pre (pair t) sp
+ hsrc/containers/BubbleF.hs view
@@ -0,0 +1,86 @@+module BubbleF(bubbleF, bubblePopupF, bubbleRootPopupF) where+--import Alignment(Alignment(..))+import Command+import XDraw+import CompOps((>=^<), (>^=<))+import Dlayout(groupF)+import Event+import Fudget(F)+--import FudgetIO+import FRequest+import NullF()+import Gc+import Geometry(origin,pP,Point(..),psub,padd)+import LayoutRequest(LayoutResponse(..))+import Message(Message(..))+import PopupGroupF+--import Popupmsg+import Spacer(sepF)+import ShapeK+import MapstateK+import EitherUtils(stripEither)+import Xtypes++default(Int) -- mostly for Hugs++bubblePopupF f =+    popupGroupF (bubbleOffset, wattrs, bubbleShapeK) (bubbleF f)++bubbleRootPopupF f =+    rootPopupF (bubbleOffset, rwattrs, bubbleShapeK) (bubbleF f)++bubbleF :: (F a b) -> F a b+bubbleF f =+  let startcmds = [XCmd $ ChangeWindowAttributes wattrs]+  in stripEither >^=<+     groupF startcmds bubbleShapeK (sepF sep f) >=^< Right++wattrs = [CWEventMask [ExposureMask]]+rwattrs = CWOverrideRedirect True:wattrs++bubbleShapeK =+  wCreateGC rootGC [GCLineWidth 2] $+  shapeK fillBubble . bubbleK++bubbleK gc =+  let bubbleT state@size msg =+	case msg of+	  Low (LEvt (LayoutSize size')) -> (size', [])+	  Low (XEvt (Expose _ 0)) ->+	    (state, if size == origin+	            then []+		    else [Low $ wDraw gc (drawBubble (size-1))])+	  _ -> (state, [])+  in mapstateK bubbleT origin++drawBubble size = DrawLines CoordModeOrigin (bubblePoints size)+fillBubble size = [FillPolygon Convex CoordModeOrigin (bubblePoints size)]++c = 4+ah = 12+ax = 12+aw = 6+atx = 6+bubbleBorder = ah + c+sep = pP (2 * c) (2 * c + bubbleBorder)+bubbleOffset (Point _ h) = Point atx (h - c)++bubblePoints size =+    let Point w h = psub size (pP 0 (2 * bubbleBorder))+    in  map (padd (pP 0 bubbleBorder))+            [pP c 0,+             pP (w - c) 0,+             pP w c,+             pP w (h - c),+             pP (w - c) h,+             pP (ax + aw) h,+             pP atx (h + ah),+             pP ax h,+             pP c h,+             pP 0 (h - c),+             pP 0 c,+             pP c 0]++--drawlines (p1 : p2 : ps) = DrawLine (Line p1 p2) : drawlines (p2 : ps)+--drawlines _ = []+
+ hsrc/containers/Containers.hs view
@@ -0,0 +1,21 @@+module Containers ( -- * Containers+  module BubbleF,module Dlayout,module DragF,module PopupF,module PopupGroupF,module PosPopupShellF,module ScrollF,module SelectionF,module DShellF,module Shells,module RootWindowF) where+import BubbleF+import Dlayout+import DragF+import PopupF+import PopupGroupF+import PosPopupShellF+import ScrollF+import SelectionF+import DShellF+import Shells+import RootWindowF++{-+import Fudget+import Geometry(Rect,Size(..),Point)+import Popupmsg(PopupMsg)+import Xtypes(Button,ModState(..),Modifiers,WindowAttributes,KeySym(..),ColorName(..),FontName(..))+import FDefaults+-}
+ hsrc/containers/DShellF.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE CPP #-}+module DShellF(ShellF,shellF, shellF', shellKF, shellKF',+       setDeleteWindowAction,+       getDeleteWindowActionMaybe', -- for use in titleShellF+       DeleteWindowAction(..),setDeleteQuit,+       HasClickToType(..),setInitPos,setFocusMgr,+       HasVisible(..)) where++import FDefaults+import Dlayout(sF)+import AutoLayout(autoLayoutF',nowait)+import QuitK+import Fudget+import EitherUtils+import CompOps+import Geometry(Point(..))+import Command+import Xcommand+import Xtypes+import Defaults(defaultSep,defaultPosition)+import CmdLineEnv(argFlag)+import FocusMgr(focusMgr)+--import Placer+--import Spacers+import Spacer(marginF)+--import LayoutRequest+import Sizing(Sizing(..))+import NullF+import ParK+--import Maptrace(ctrace) -- debugging+#include "defaults.h"++newtype ShellF = Pars [Pars]+data Pars+  = WinAttr [WindowAttributes]+  | DeleteWindowAction (Maybe DeleteWindowAction)+  | ClickToType Bool+  | FocusMgr Bool -- mainly for internal use+  | Visible Bool+  | Margin Int+  | Sizing Sizing+  | InitPos (Maybe Point)++data DeleteWindowAction = DeleteQuit | DeleteUnmap deriving (Eq,Show)++parameter(InitPos)+parameter(FocusMgr)++parameter_instance(WinAttr,ShellF)++parameter(DeleteWindowAction)+getDeleteWindowActionMaybe' pm =+  getDeleteWindowActionMaybe (pm (Pars []))++-- Backwards compatibility:+setDeleteQuit b = setDeleteWindowAction (if b then Just DeleteQuit else Nothing)++parameter_class(ClickToType,Bool)+parameter_instance(ClickToType,ShellF)+++parameter_class(Visible,Bool)+parameter_instance(Visible,ShellF)++parameter_instance(Margin,ShellF)+parameter_instance(Sizing,ShellF)++shellF = shellF' standard+shellF' pmod s f = stripEither >^=< shellKF' pmod k f >=^< Right where+	k = xcommandK (StoreName s) nullK++shellKF = shellKF' standard++shellKF' :: (Customiser ShellF)->K a b -> F c d -> F (Either a c) (Either b d)+shellKF' pmod k f = genShellF siz clicktt focusmgr vis pos sep [] kernel f+ where+   ps = pmod (Pars [WinAttr [],DeleteWindowAction (Just DeleteQuit),+                    ClickToType ctt, FocusMgr defFocusMgr,+                    InitPos defaultPosition, -- hmm+		    Visible True,Margin defaultSep,Sizing Dynamic])+						-- !! Change default Sizing?+   d_action = getDeleteWindowAction ps+   clicktt = getClickToType ps+   focusmgr = getFocusMgr ps+   sep = getMargin ps+   vis = getVisible ps+   wa = getWinAttr ps+   siz = getSizing ps+   pos = getInitPos ps+   kernel = xcommandK (ChangeWindowAttributes wa) $+	    maybe (wmDeleteWindowK (const k)) -- see (*) in QuitK.hs+		  (\ a -> quitK (action a) `parK` k)+		  d_action++   action DeleteQuit = exitK+   action DeleteUnmap = unmapWindowK++genShellF sizing ctt focusmgr map pos sep cmds k f = +       sF (not map) pos cmds k (filter (sepf f)) where+   filter = if focusmgr+            then focusMgr sizing ctt+            else autoLayoutF' nowait sizing -- usually sits inside a groupF in focusMgr+   sepf = if sep == 0 then id else marginF sep++ctt = argFlag "ctt" True+defFocusMgr = argFlag "focusmgr" True
+ hsrc/containers/Dlayout.hs view
@@ -0,0 +1,142 @@+module Dlayout(invisibleGroupF,+               simpleGroupF, unmappedGroupF, groupF, groupF',+	       sgroupF, swindowF,+               windowF,sF) where+--import Alignment(Alignment(..))+import Command+import CompFfun(prepostMapHigh)+--import CompOps((>=^^<), (>^=<),(>..=<))+import Defaults(bgColor)+import CmdLineEnv(resourceName)+import Event+import Fudget+import FRequest+import Geometry(Point(..), Rect(..), origin, pmax)+import GreyBgF(changeBg)+import LayoutRequest+import LoopLow+--import Message(Message(..))+import NullF+import Spops+--import SpEither(mapFilterSP)+import AutoLayout(autoLayoutF',nowait)+import Sizing(Sizing(..))+import EitherUtils(stripEither)+--import Utils(oo)+import WindowF+import Xtypes+--import Placer(placerF,spacerF)+--import Spacers+--import AutoPlacer(autoP)+import ParSP+--import CompSP+import Path(turn,here)+import Direction(Direction(..))++addEventMask addmask =+    let addem [] = []+        addem (CWEventMask mask : wattrs) =+            CWEventMask (addmask ++ mask) : wattrs+        addem (wattr : wattrs) = wattr : addem wattrs+    in  addem++shell :: Bool -> (F a b) -> F a b+shell nomap f =+    let eventmask = [StructureNotifyMask,KeyPressMask,KeyReleaseMask,FocusChangeMask]++        prep ss@(osize,sizeq, Just ltag) (Low (tag, XEvt (ConfigureNotify (Rect _ nsize) _)))+           | tag == kernelTag = case sizeq of +	     (size:sizeq') | size == nsize -> ((nsize,sizeq',Just ltag),[])+	     _ -> if nsize == osize then (ss,[]) else+	        ((nsize,sizeq,Just ltag),[(ltag,LEvt $ LayoutPlace (Rect origin nsize))])+        prep s (Low (t,e@(XEvt (FocusIn  {})))) | t == kernelTag = (s,[(focusMgrTag, e)])+        prep s (Low (t,e@(XEvt (FocusOut {})))) | t == kernelTag = (s,[(focusMgrTag, e)])+        prep s (Low (t,e@(XEvt (KeyEvent {})))) | t == kernelTag = (s,[(focusMgrTag, e)])+        prep s (Low msg) = (s, [msg])+        prep (osize,sizeq, _) (High (tag, nsize)) = +	  ((osize,sizeq++ (if null sizeq || last sizeq /= nsize then [nsize] else []), Just tag),+	   [(tag, LEvt $ LayoutPlace (Rect origin nsize))])++        focusMgrTag = turn R $ turn L here -- hardwired assumption+        minSize = Point 1 1++        post nomap' (tag, LCmd lreq) = case lreq of+	  LayoutRequest (Layout {minsize=size}) ->+            (True,+             High (tag, size) :+             toKernel ([XCmd $ resizeWindow (pmax minSize size)] +++                       (if nomap' then [] else [XCmd $ MapRaised])))+            -- we should actually wait with MapRaised until f reports OK somehow...+          _ -> (nomap',[]) {- filter all other layout msgs -}+        post nomap' (tag, XCmd (ChangeWindowAttributes wattrs)) | tag == kernelTag =+            (nomap',+             [Low (tag, XCmd $ ChangeWindowAttributes (addEventMask eventmask wattrs))])+        post nomap' (_,XCmd MeButtonMachine) = (nomap', [])+        post nomap' cmd@(tag, XCmd (ChangeWindowAttributes wattrs)) = (nomap',[Low cmd])+        post nomap' cmd = (nomap', [Low cmd])+        startcmds = toKernel [XCmd $ ChangeWindowAttributes [CWEventMask []],+                              XCmd $ SetWMHints True]+    in  loopLow (mapstateSP' post nomap)+                (mapstateSP prep ((Point 10 10),[], Nothing)) {- 10 10 from windowKF... -}+                (myAppendStartF startcmds f)++mapstateSP' f s0 =+    getSP (\x ->+           case f s0 x of+             (s, y) -> putsSP y (mapstateSP' f s))+{-+-- causes a space leak with nhc13 and ghc-7.6+mapstateSP' f s0 =+    getSP (\x ->+           let (s, y) = f s0 x+           in putsSP y (mapstateSP' f s))+-}+-- myAppendStart will let f speak all its initial msgs, not just the first one.+myAppendStartF cmds (F f) = {-F-}ff $ parSP f (putsSP cmds nullSP)++windowF :: [FRequest] -> (K a b) -> F a b+windowF cmds = swindowF cmds Nothing++swindowF cmd oplace k = +    prepostMapHigh Left stripEither (group0F sizing False cmd oplace k Nothing)+  where sizing = if oplace==Nothing then Static else Dynamic++sF nomap pos lc k f =+    let r = Nothing -- temporary+        p =+            case r of+              Just (Rect p _) -> Just p+              Nothing -> pos+        lc' =+            case p of+              Just p' -> XCmd (SetNormalHints p') : XCmd (moveWindow p') : lc+              Nothing -> lc+    in shell nomap+          (windowKF (XReq . flip CreateRootWindow resourceName) True nomap lc' r (bgK k) f)++group0F sizing nomap cmds r k mf =+    case mf of+      Nothing -> w nullF+      Just f -> w $ autoLayoutF' nowait sizing f+  where w = windowKF (XReq . CreateMyWindow) False nomap cmds r k ++sgroupF sizing cmds r k = group0F sizing False cmds r k . Just+groupF' sizing cmds = sgroupF sizing cmds Nothing+groupF = groupF' Dynamic++unmappedGroupF sizing cmds k = group0F sizing True cmds Nothing k . Just+++simple sf sizing startcmds k w =+    prepostMapHigh Right stripEither (sf sizing startcmds k w)++bgK = changeBg bgColor++--sGF :: (K a b) -> [WindowAttributes] -> (F a b) -> F a b+sGF sizing k wattrs =+  simple groupF' sizing [XCmd $ ChangeWindowAttributes wattrs] k++simpleGroupF = sGF Dynamic (bgK nullK)+invisibleGroupF sizing cmds = +     sGF sizing (bgK (putsK (map Low cmds) nullK))+
+ hsrc/containers/DragF.hs view
@@ -0,0 +1,250 @@+module DragF(containerGroupF,hPotF,hPotF',vPotF,vPotF',PotRequest(..),PotState(..)) where+import Command+import CompOps((>=^<), (>^=<))+import CompFfun(prepostMapHigh)+import Cursor+import Dlayout(groupF,groupF')+import Sizing(Sizing(..))+import Event+--import Color+import Fudget+--import FudgetIO+import FRequest+import NullF+import Geometry+import GreyBgF+import Border3dF(border3dF)+import LayoutRequest(LayoutResponse(..))+import LayoutF(holeF')+import Spacers(hvMarginS)+import DynSpacerF(dynSpacerF)+import Spacer(noStretchF)+import Alignment+import Loops(loopCompThroughRightF,loopLeftF)+--import Message(Message(..))+import EitherUtils(stripEither)+import Data.Maybe(fromMaybe)+import CmdLineEnv(argReadKey)+import Xtypes+--import Maptrace(ctrace)++data PotRequest = ResizePot Int Int -- frame size, total size+                | MovePot   Int     -- new position+		| PotMkVisible Int Int (Maybe Alignment) -- pos, length, alignm+		| PotInput (ModState, KeySym) -- remote control++type PotState = (Int,Int,Int)  -- position, frame size, total size++knobS knob@(Rect kp ks) box@(Rect bp bs) =+  --ctrace "knobS" (knob,box) $+  hvMarginS (kp+margin) (bs+margin-kp-ks)++knobK box knob pabs =+    let cont knob' pabs' = knobK box knob' pabs'+        newbox box' knob' = knobK box' knob' pabs+        same = cont knob pabs+	output knob = putK (High (Right knob))+	repos knob box = putK (High (Left (knobS knob box)))+    in  getK $ \msg ->+        case msg of+          Low (XEvt (MotionNotify {rootPos=pabs',state=mods})) ->+	    let knob' = moverect knob (psub pabs' pabs)+	        knob'' = confine box knob'+		pabs'' = padd pabs' (rsub knob'' knob')+            in  repos knob'' box $+                (if Shift `elem` mods then id else output knob'') $+	        cont knob'' pabs''+          Low (XEvt (ButtonEvent {rootPos=pabs',type'=Pressed})) -> cont knob pabs'+          Low (XEvt (ButtonEvent {type'=Released})) -> output knob $ same+          High (newknob, box') ->+	    let knob' = confine box' newknob+                msgs = (if knob'/=knob || box'/=box+                        then repos knob' box'+			else id) .+		       (if knob'/=knob -- was: knob/=newknob+		        then output knob'+			else id)+            in msgs $+               newbox box' knob'+          _ -> same++-- New version, using new more general containterGroupF+-- containterGroupF should be replaced.+containerGroupF knob box cursorshape buttons modifiers fudget =+    loopLeftF $+    prepostMapHigh pre post $+    dynSpacerF $+    groupF initcmds+           (setFontCursor cursorshape (knobK box knob origin))+           fudget+  where attrs = [CWEventMask []]+        initcmds = map XCmd +	           [ChangeWindowAttributes attrs,+		    GrabButton False buttons modifiers+                        [PointerMotionMask, ButtonReleaseMask]]+		    --MapRaised]+        pre = id+	post = either (either Left (Right. Left)) (Right. Right)++knobF cursor box knob =+    (stripEither >^=< containerGroupF knob box cursor (Button 1) [] vF ) >=^<+    Left+  where vF = raisedF (holeF' s)+	s = rectsize knob++staticBorder3dF down fud = border3dF down 2 fud >=^< Right+raisedF = staticBorder3dF False+loweredF = staticBorder3dF True++--topleft = diag 2+--margin = diag 6+topleft = diag 0+margin = diag (argReadKey "potmargin" 0)++absknobpos size (pos, frame, tot) =+    if tot == 0+    then (0, max 1 size)+    else ((pos * size + tot `div` 2) `quot` tot, max 1 (frame * size `quot` tot))++newkpos :: PotState -> (Int,Int) -> PotState+newkpos (_, frame, tot) (pos, size) = (pos * tot `quot` size, frame, tot)++knobup d (pos, frame, tot) = (0 `max` (pos - d), frame, tot)+knobdown d (pos, frame, tot) = ((tot - frame) `min` (pos + d), frame, tot)+pageup knob@(_, frame, _) = knobup frame knob+pagedown knob@(_, frame, _) = knobdown frame knob++stepup len knob = knobup (stepsize len knob) knob+stepdown len knob = knobdown (stepsize len knob) knob+stepsize size (_,_,tot) = (tot+size-1) `quot` size++knobhome (_, frame, tot) = (0, frame, tot)+knobend (_, frame, tot) = (tot - frame, frame, tot)++resizePot (pos,_,_) frame tot = (pos,frame,tot) -- !! should adjust pos if necessary+movePot (_,frame,tot) pos = (pos,frame,tot) -- !! should keep pos within boundaries++--and adjkpos (pos,frame,tot) frame' tot' = (min (tot'-frame') (pos*tot'/tot),frame',tot')++keyAction mods s len =+    case s of+      s | s == "space"  || s == "Next"  -> Just (shift knobend pagedown)+      s | s `elem` pageupKeys           -> Just (shift knobhome pageup)+      s | s == "Home"                   -> Just knobhome+      s | s == "End"                    -> Just knobend+      s | s == "Down"   || s == "Right" -> Just (stepdown len)+      s | s == "Up"     || s == "Left"  -> Just (stepup len)+      _ -> Nothing+  where+    shift = if Shift `elem` mods then const else const id+    pageupKeys = ["Delete","BackSpace","Prior"]++mkVisible (pos,frame,tot) first last optAlign =+  case optAlign of+    Just a -> Just (max 0 (min (tot-frame) pos'),frame,tot)+      where pos' = first+truncate (a*fromIntegral (last-first-frame))+    _ ->+      if first<pos || last-first>frame+      then Just (first,frame,tot)+      else if last>pos+frame+	   then Just (last-frame,frame,tot)+	   else Nothing++potF hori par ort vect shape grav acceptFocus optsize =+    loopCompThroughRightF potGroupF+  where+    potGroupF =+	noStretchF (not hori) hori $+	loweredF $ +	groupF' Static startcmds +	       (darkGreyBgK potK0)+	       (knobF shape box0 (knob length0 kpos0))+      where wattrs = [CWEventMask eventmask]+	    alwayseventmask = [ButtonPressMask,Button2MotionMask]+	    focuseventmask = [EnterWindowMask, LeaveWindowMask, KeyPressMask]+	    eventmask = alwayseventmask ++ +	                if acceptFocus then focuseventmask else []+	    startcmds = [--XCmd $ LayoutMsg (Layout wsize (not hori) hori),+			 XCmd $ ChangeWindowAttributes wattrs]+    wsize    = fromMaybe (vect 50 11) optsize+    boxsize0 = psub wsize margin+    length0  = par boxsize0+    boxwidth = ort boxsize0+    knob length' kpos' =+	let (pos, size) = absknobpos length' kpos'+	in  Rect (padd topleft (vect pos 0)) (vect size boxwidth)+    box0 = Rect topleft boxsize0+    potK0 = potK1 --allocNamedColorPixel defaultColormap "white" potK1+    potK1 = potK kpos0 length0 where+      potK kpos len =+	  let cont kpos' = potK kpos' len+	      newlen kpos' len' = potK kpos' len'+	      same = cont kpos+	      report kpos' = --ctrace "report" kpos' $+	                     High (Right kpos')+	      changeknob len' kpos' =+		  High (Left (knob len' kpos',+			     Rect topleft (vect len' boxwidth)))+	      moveknob kpos' = --ctrace "moveknob" kpos' $+			       putsK [changeknob len kpos'{-,report kpos'-}] $+			       -- Rely on the knob to report the new position,+			       -- after it has been confined to the box. This+			       -- is a fix for button2Action that result in+			       -- positions outside the box...+			       same -- cont kpos'+	      keyInput mods key = maybe same act (keyAction mods key len)+		where act action = moveknob (action kpos)++	      button2Action p = newkpos kpos (par p, len)++	      buttonAction (Button 2) mods p = button2Action p+	      buttonAction b mods p =+		case (par p < par (rectpos (knob len kpos)),+		      Shift `elem` mods || Control `elem` mods) of+	          (True, False) -> pageup   kpos+	    	  (True, True ) -> knobhome kpos+		  (False,False) -> pagedown kpos+		  (False,True ) -> knobend  kpos++	  in getK $ \msg ->+	     case msg of+	       Low (XEvt (ButtonEvent {button=b,pos=p,state=mods,type'=Pressed})) ->+	         moveknob (buttonAction b mods p)+	       Low (XEvt (MotionNotify {pos=p,state=mods})) | Button2 `elem` mods ->+	         moveknob (button2Action p)+	       Low (LEvt (LayoutSize size')) ->+		 let len' = par size' - par margin+		 in if len'/=len+	            then putsK [changeknob len' kpos] (newlen kpos len')+		    else same+	       Low (XEvt (KeyEvent _ _ _ mods Pressed _ key _)) ->+	          keyInput mods key+	       Low (XEvt (FocusIn {detail=d})) | d /= NotifyInferior -> +		  lightGreyBgK same+	       Low (XEvt (FocusOut {detail=d})) | d /= NotifyInferior -> +		  darkGreyBgK same+	       High (Right (PotInput (mods,key))) -> keyInput mods key+	       High (Right (ResizePot frame tot)) ->+		 let kpos' = resizePot kpos frame tot+		 in putK (changeknob len kpos') (cont kpos')+	       High (Right (MovePot pos)) ->+		 let kpos' = movePot kpos pos+		 in putK (changeknob len kpos') (cont kpos')+	       High (Right (PotMkVisible pos size optAlign)) ->+		 case mkVisible kpos pos (pos+size) optAlign of+		   Just kpos' -> moveknob kpos'+		   Nothing    -> same+	       High (Left newknob) ->+                 --ctrace "newknob" newknob $	       +		 let kpos' = newkpos kpos (par (rsub newknob box0), len)+		 in  if kpos'==kpos -- False+		     then same+		     else putK (report kpos') (cont kpos')+	       _ -> same+    kpos0 = (0,1,1)++vPotF' = potF False ycoord xcoord (\x -> \y -> Point y x) 116 NorthEastGravity+hPotF' = potF True xcoord ycoord Point 108 SouthWestGravity++vPotF = vPotF' True Nothing+hPotF = hPotF' True Nothing
+ hsrc/containers/FreeGroupF.hs view
@@ -0,0 +1,56 @@+module FreeGroupF(freeGroupF) where+--import Fudget+import EitherUtils+import Path(here)+import LayoutRequest+import Geometry+--import Command+--import Event+--import Xtypes++import Dlayout(groupF)+import UserLayoutF(userLayoutF)+import Spops+--import SpEither(mapFilterSP)+import NullF(nullK)+import SerCompF(absF)+import LoopCompF(loopCompF)+import CompOps+import Defaults(bgColor)+import GreyBgF(changeBg)++freeGroupF f =+    loopCompF (absF placeSP0>+<innerF)+  where+    innerF = userLayoutF $+             stripEither >^=< groupF [] (bgK nullK) f >=^< Right++    placeSP0 = placeSP False here (rR 0 0 0 0) {- dummy initial path & place -}++    placeSP placed path place =+      let same = placeSP placed path place+      in +      getSP $ \ msg ->+      case msg of+        Left (path',layoutmsg) ->+	  case layoutmsg of+	    LayoutRequest req ->+	      let place' = sizerect place (minsize req)+	      in putSP (Right layoutmsg) $ placeSP False path' place'+	    LayoutMakeVisible _ _ -> putSP (Right layoutmsg) same+	    LayoutScrollStep _ -> putSP (Right layoutmsg) same+            _ -> same -- ignore other msgs for now+	Right (Right pos) ->+	  let place' = posrect place pos+	  in putSP (Left (path,place')) $+	     placeSP True path place'+	Right (Left newtotsize) ->+	  let place' = sizerect place newtotsize+	  in ifSP (not placed || place'/=place)+                  (putSP (Left (path,place'))) $+	    --  ^^ dangerous optimization?+	     placeSP True path place'++ifSP b th = if b then th else id++bgK = changeBg bgColor
+ hsrc/containers/PopupF.hs view
@@ -0,0 +1,53 @@+module PopupF(popupShellF,popupShellF') where+import Command+import DShellF+import FDefaults+import Fudget+import FRequest+import Xcommand+import Geometry(Point(..), pP)+--import LayoutRequest(LayoutRequest)+import Loops(loopCompThroughRightF)+--import Message(Message(..))+--import Spops+import MapstateK+import Xtypes+--import NullF(putsK)+import CompSP+import Path(here)++popupShellF = popupShellF' standard++popupShellF' :: Customiser ShellF -> String -> Maybe Point -> F a b -> F a (a,b)+popupShellF' pm title optpos (F f) =+  let pos = case optpos of+              Just pos -> pos+              Nothing -> pP 300 300+      params = pm . setVisible False . setDeleteQuit False+  in loopCompThroughRightF (shellKF' params (popupK title pos) +			   (F{-ff-} $ prepostMapSP pre post (idRightSP f)))++pre (Low m) = Left (Low m)+pre (High (Left a)) = Left (High a)+pre (High (Right a)) = Right a+post (Right a) = Low (here,a)+post (Left (Low m)) = Low m+post (Left (High a)) = High a++popupK title pos =+  let kf s@(mapped,trig) msg =+	  case msg of+	    High (Right trig') -> ((True,trig'), +	      [High (Left (Left trig')),lowfromf (GrabEvents True)] +++	       if not mapped then [Low $ XCmd MapRaised] else [])+	    High (Left x) -> ((False,trig),+			      (if mapped then unmapcmds else []) ++ +			      [lowfromf UngrabEvents,High (Right (trig, x))])+	    Low _ -> (s, [])+      lowfromf = High . Left . Right . XCmd+      unmapcmds = [Low $ XCmd UnmapWindow,Low $ XCmd Flush]+      startcmds =+	  [StoreName title, SetNormalHints pos, moveWindow pos,+	   ChangeWindowAttributes [CWSaveUnder True]]+  in xcommandsK startcmds $+     mapstateK kf (False,error "premature output from fudget inside popupShellF")
+ hsrc/containers/PopupGroupF.hs view
@@ -0,0 +1,66 @@+module PopupGroupF(popupGroupF,rootPopupF) where+import Command+import CompOps((>=^^<), (>^^=<))+--import Direction+import Dlayout(unmappedGroupF)+import Sizing(Sizing(..))+import Shells(unmappedShellF)+--import Event+import Fudget+import FRequest+import Geometry(psub,pP)+import LayoutRequest+import LoopLow+--import Message(Message(..))+import ParK+--import Path(Path(..))+import Popupmsg+--import Spops+import MapstateK+import SpEither(filterRightSP)+--import SerCompF(concatMapF)+import Spops+--import Xtypes++popupGroupF = popupF (unmappedGroupF Dynamic)+rootPopupF  = popupF unmappedShellF++popupF grF (offset, wattrs, k) f =+    let post (tag, cmd) =+            case cmd of+              LCmd req ->+	        case req of+--		  Layout size fh' fv -> [High (tag, LEvt $ LayoutPlace (Rect origin size))]+		  LayoutRequest (Layout {minsize=size}) ->+		    [High (tag, LEvt $ LayoutSize size)]+		    -- treated specially in windowKF.+		  _ -> []+              cmd' -> [Low (tag, cmd')]+        pre ev =+            case ev of+              High ev' -> [ev']+              Low (_, LEvt (LayoutPlace _)) -> [] -- shouldn't happen?+              Low tev -> [tev]+        distr (Popup p x) = [Right x, Left (Left (Just p))]+        distr Popdown = [Left (Left Nothing)]+        startcmds = [XCmd $ ChangeWindowAttributes wattrs]+    in  (filterRightSP >^^=<+         loopLow (concmapSP post)+                 (concmapSP pre)+                 (grF startcmds (compK (placeK offset) k) f)) >=^^<+        concatMapSP distr++placeK offset = mapstateK sizeT (False,pP 0 0)+  where+    sizeT s@(mapped,size) msg =+      case msg of+        High (Just p) ->+	  ((True,size),+	   [Low $ XCmd (moveWindow (psub p (offset size)))] +++	   if not mapped then [Low $ XCmd MapRaised] else [])+	High Nothing ->+	  ((False,size),if mapped then [Low $ XCmd UnmapWindow] else [])+	Low (LEvt (LayoutSize size')) ->+	  ((mapped,size'), [])+	_ -> (s, [])+
+ hsrc/containers/PosPopupShellF.hs view
@@ -0,0 +1,45 @@+module PosPopupShellF(posPopupShellF) where+import Command+import Shells(unmappedShellF)+--import Event(Event(..))+import Fudget+import FRequest+import Geometry(origin, pP, psub)+--import LayoutRequest(LayoutRequest)+import Loops(loopCompThroughRightF)+--import Message(Message(..))+import NullF+--import Path(Path(..))+import QueryPointer+--import SP+--import Xtypes++posPopupShellF title wattrs f =+    loopCompThroughRightF (unmappedShellF startcmds popupK f)+  where+    startcmds =+        [XCmd $ StoreName title,+	 XCmd $ SetNormalHints origin,+	 XCmd $ ChangeWindowAttributes wattrs]++popupK = kf (error "premature output from fudget inside posPopupShellF")+  where+    pickPos p cont =+      case p of+        Just pos -> cont pos+	Nothing -> queryPointerK (\(_, r, _, _) -> cont (psub r (pP 5 5)))++    kf s@(mapped,trig) =+        getK $ \msg ->+        case msg of+          High (Right (trig', optpos)) ->+	    pickPos optpos $ \pos ->+            putsK ([Low $ XCmd $ moveWindow pos,+                    High (Left trig')] +++                   if not mapped then [Low $ XCmd MapRaised] else []) $+            kf (True,trig')+          High (Left y) ->+	    putsK ((if mapped then [Low $ XCmd UnmapWindow] else []) +++		   [High (Right (trig, y))]) $+            kf (False,trig)+          _ -> kf s
+ hsrc/containers/RootWindowF.hs view
@@ -0,0 +1,50 @@+module RootWindowF where+import Command+--import Event+--import Font(FontStruct)+--import Fudget+--import Message(Message(..))+import Geometry(Rect(..),origin,pP)+--import Path+import WindowF(kernelF)+--import NullF(putK)+--import Xrequest(xrequestF)+import Xcommand(xcommandK)+import QueryTree+import UserLayoutF(userLayoutF)+import CompOps+import SerCompF(absF)+import Loops(loopThroughRightF)+import Spops(mapSP)+import AutoLayout(autoLayoutF)+--import CmdLineEnv(argReadKey)+--import NullF(nullF)+import WindowF(kernelTag)++{-+rootWindowF k =+    defaultRootWindowF $ \ root ->+    kernelF (putK (Low (ReparentToMe kernelTag root)) k) >*< nullF+-}+  +rootWindowF k =+    defaultRootWindowF $ \ root ->+    kernelF (xcommandK (SelectWindow root) k)+  +rootGroupF k f =+    k' >+< f'+  where+    k' = kernelF (+            defaultRootWindowK $ \ root ->+            xcommandK (ReparentToMe kernelTag root) k)+    f' = loopThroughRightF (absF ctrlSP) (userLayoutF (autoLayoutF f))+    ctrlSP = mapSP ctrl+    ctrl msg =+      case msg of+        Left (Left (path,req)) -> Left (Left (path,screenrect))+	Left (Right x) -> Right x+	Right x -> Left (Right x)+	+    screenrect = Rect origin (pP 1152 900)+    -- !!! no Read instance...+    --screenrect = Rect origin (argReadKey "screensize" (pP 1152 900)) -- !!!
+ hsrc/containers/ScrollF.hs view
@@ -0,0 +1,181 @@+module ScrollF(scrollShellF,+               scrollF,oldScrollF,+               vScrollF,oldVscrollF,+	       hScrollF,oldHscrollF,+	       grabScrollKeys) where+import Fudget+import EitherUtils+import CmdLineEnv(argFlag)+import Utils(remove)+import LayoutRequest+import Geometry+import Command+import FRequest+import Event+import Xtypes++import FreeGroupF+import Dlayout(groupF)+import DShellF(shellF)+import Spops+import NullF(nullF)+import Cont(waitForSP)+import SpEither(mapFilterSP)+import DragF(hPotF',vPotF',PotRequest(..))+import Placer(tableF,hBoxF,vBoxF)+import SerCompF(absF)+import Loops(loopThroughRightF)+import CompOps+--import Maptrace(ctrace)++scrollShellF name initlimits = shellF name . oldScrollF True initlimits++grabScrollKeys = argFlag "grabscrollkeys" False+ -- True is not good if there are two or more scrollFs in the same shell window.++-- Std versions with arbirarily chosen limits...+scrollF = oldScrollF grabScrollKeys (pP 50 30,pP 550 700)+vScrollF = oldVscrollF grabScrollKeys (pP 50 30,pP 550 700)+hScrollF = oldHscrollF grabScrollKeys (pP 50 10,pP 550 700)++scroll foc = (const,plainAdjLayout,tableF 2,vPotF' foc Nothing >+< hPotF' foc Nothing)+vscroll foc = (const,wAdjLayout,hBoxF,vPotF' foc Nothing >+< nullF)+hscroll foc = (const,hAdjLayout,vBoxF,nullF>+<hPotF' foc Nothing)++oldScrollF grabKeys  = gScrollF (scroll  (not grabKeys)) grabKeys+oldVscrollF grabKeys = gScrollF (vscroll (not grabKeys)) grabKeys+oldHscrollF grabKeys = gScrollF (hscroll (not grabKeys)) grabKeys++gScrollF (outCoupling,inCoupling,placer,scrollbarsF) grabKeys initlimits fud =+    loopThroughRightF (placer mainF) (absF (initSP ctrlSP))+  where+    mainF =+        post>^=<+	(groupF start visibleK (freeGroupF fud)>+<scrollbarsF)+	>=^<pre+      where+        post = swapRight.mapEither assocLeft id -- (KV+(T+a))+S -> ((KV+T)+S)+a+	pre = mapEither assocRight id.swapRight -- converse++        start = map XCmd $+	        transinit+++	        [ChangeWindowAttributes [CWBackPixmap parentRelative],+		 ConfigureWindow [CWBorderWidth 1]]++	transinit =+	    if grabKeys+	    then [TranslateEvent tobutton [KeyPressMask]]+	    else []++      --tobutton k@(KeyEvent t p1 p2 s Pressed _ ks _) | (s, ks) `elem` keys =+	tobutton e@(KeyEvent {state=s,type'=Pressed,keySym=ks})+	           | (s, ks) `elem` keys =+	    Just e+        -- Mouse Wheel support:+	tobutton e@(ButtonEvent {button=Button 4,type'=Pressed}) = Just e+	tobutton e@(ButtonEvent {button=Button 5,type'=Pressed}) = Just e+	tobutton _ = Nothing++        keys = map ((,) []) keys' ++ map ((,) [Shift]) keys'+	  where keys' = ["Prior","Next","Home","End"]++    -- visibleK reports the current visible size and grabbed keys+    visibleK = K{-kk-} $ mapFilterSP visible+      where+	visible (Low (LEvt (LayoutSize vissize))) = Just (High (Right vissize))+	visible (Low (XEvt (KeyEvent{state=mods,type'=Pressed,keySym=key}))) =+	    Just (High (Left (mods,key)))+	visible (Low (XEvt (ButtonEvent{button=Button 4,type'=Pressed,state=mods}))) =+	    Just (High (Left (mods,"Prior")))+	visible (Low (XEvt (ButtonEvent{button=Button 5,type'=Pressed,state=mods}))) =+	    Just (High (Left (mods,"Next")))+	visible (High vissize) =+	    Just (Low (layoutRequestCmd (plainLayout vissize False False)))+	visible _ = Nothing++    initSP cont =+        waitForSP initreq $ \ req ->+	let vissize = limit initlimits rtotsize+            rtotsize = minsize req+	    adj = inCoupling req+	in putSP (Left (Left vissize)) $+	   cont vissize rtotsize adj+      where initreq (Left (Right (LayoutRequest req))) = Just req+            initreq _ = Nothing++    -- ctrlSP :: SP ((KV+T)+S) ((V+T)+S)+    -- cltrSP implements the scrolling+    -- Input : KV = grabbed keys or visible size (from visibleK)+    --       : T = total size (from freeGroupF)+    --       : S = scroll bar positions+    -- Output: V = requested visible size (to visibleK)+    --         S = scroll bar adjustments on size changes+    --         T = position adjustments on scroll bar changes,+    --             notification of current visible size+    ctrlSP visible total adj =+        concatMapAccumlSP ctrlT (visible, total, pP 0 0,adj) -- limits??+      where+        ctrlT s@(visible, total, pos, adj) msg =+	    case msg of+	      Left (Left (Left key)) -> (s,potKeyInput key)+	      Left (Left (Right visible')) -> adjustVisible visible' adj+	      Left (Right req) ->+	        case req of+		  LayoutRequest req -> adjustVisible visible adj'+		     where adj' = inCoupling req+		  LayoutMakeVisible rect align ->+		    (s, mkvisible rect align)+		  --LayoutScrollStep step -> ...+		  _ -> (s, [])+	      Right (Left (y,_,_)) -> vmove pos (-y)+	      Right (Right (x,_,_)) -> hmove pos (-x)+	  where+	    potKeyInput key@(mods,k) =+	      if Shift `elem` mods+	      then [Right (Right (PotInput (remove Shift mods,k)))]+	      else [Right (Left  (PotInput key))]+	    adjustVisible visible' adj' =+		((visible', total', pos, adj'),+		 Left (Right (Left total')):+		 adjustPots visible' total')+	      where total' = adj' visible'+	    adjustPots (Point visw vish) size@(Point totw toth) =+		    [Right (Right (ResizePot visw totw)),+		     Right (Left (ResizePot vish toth))]+	    mkvisible r@(Rect (Point x y) (Point w h)) (halign,valign) =+	      --ctrace "mkvisible" r $+		    [Right (Right (PotMkVisible x w halign)),+		     Right (Left (PotMkVisible y h valign))]+	    vmove pos@(Point x _) y =+	        --ctrace "vmove" (pos,pos') $+	        ((visible,total,pos',adj),[Left (Right (Right pos'))])+	      where pos' = Point x y+	    hmove pos@(Point _ y) x =+	        --ctrace "hmove" (pos,pos')+	        ((visible,total,pos',adj),[Left (Right (Right pos'))])+	      where pos' = Point x y+++limit (min', max') size = pmax min' (pmin max' size)+++type SizeCoupling = Size    -> Size      -> Size+--                  my size    other size   my new size++stdCoupling = pmax+vCoupling (Point tw th) (Point vw vh) = Point vw (max th vh)+hCoupling (Point tw th) (Point vw vh) = Point (max tw vw) vh++plainAdjLayout (Layout {minsize=total'}) = stdCoupling total'+wAdjLayout (Layout {wAdj=wa}) = s (flip vCoupling) (wa . xcoord)+hAdjLayout (Layout {hAdj=ha}) = s (flip hCoupling) (ha . ycoord)++s f g x = f x (g x)++-- assocLeft :: a+(b+c) -> (a+b)+c+-- assocRight :: (a+b)+c -> a+(b+c)+assocLeft = either (Left. Left) (either (Left. Right) Right)+assocRight = either (either Left (Right. Left)) (Right. Right)++--swapRight :: (a+b)+c -> (a+c)+b+swapRight = either (either (Left. Left) Right) (Left. Right)
+ hsrc/containers/SelectionF.hs view
@@ -0,0 +1,109 @@+module SelectionF where +import FudUTF8(decodeUTF8,encodeUTF8)+import Command+import CompOps((>=^<), (>^=<))+import Cont(conts,cmdContK')+import Shells(unmappedShellF)+import Event+import Fudget+import FRequest+import Xcommand+import GetWindowProperty+import InternAtom+--import Message(Message(..))+import NullF+import LayoutF(nullLF)+import Spops(putSP,getSP)+import Loops(loopThroughRightF)+import EitherUtils(stripEither)+import SerCompF(absF)+import Xtypes++{- +Supports cut/paste of UTF-8 encoded Unicode Strings.+Cut/paste of Unicode strings between two fudgets program works.+Cut/paste between a fudget program and xterm -u8 from XFree86 4.0 works.+/TH 2000-04-02+-}++data SelCmd a = Sel a | ClearSel | PasteSel  deriving (Eq, Ord)+data SelEvt a = LostSel | SelNotify a  deriving (Eq, Ord)++data ESelCmd a = OwnSel | SelCmd (SelCmd a) deriving (Eq, Ord)+data ESelEvt a =  WantSel | SelEvt (SelEvt a) deriving (Eq, Ord)++eselectionF :: F (ESelCmd String) (ESelEvt String)+eselectionF =+    (stripEither >^=< unmappedShellF [] selK nullLF) >=^<+    Left where+ selK =+    conts (flip internAtomK True) +      ["PRIMARY", "STRING", "NONE", "ATOM"] $ +      \ [primaryA, stringA, noneA, atomA] ->+    conts (flip internAtomK False) ["FUDGETS_UTF8","UTF8_STRING"] $+      \ [fudgetsA, utf8A] -> let+      sevt = High. SelEvt+      l =+	  getK $ \ev ->+	  case ev of+	    High esc -> case esc of+	      SelCmd sc -> case sc of+		 Sel t -> l -- select t+		 ClearSel -> deselect+		 PasteSel -> paste_utf8string -- try UTF-8 first...+	      OwnSel -> select+	    Low (XEvt ev) -> case ev of+	      SelectionClear s | s == primaryA -> putK (sevt LostSel) l+	      SelectionRequest t w s -> selectionrequest t w s+	      SelectionNotify t s -> selectionnotify s+	      _ -> l+	    Low _ -> l+      selectionrequest time w sel@(Selection s t p) =+	if t `notElem` [stringA,utf8A]+	then notify time w (Selection s noneA p) l+	else+	  let p' = if p == noneA then t else p+	      wait (High (SelCmd (Sel t))) = Just t+	      wait _ = Nothing+	  in cmdContK' (High WantSel) wait $ \rawtext ->+	     let text = if t==utf8A+	                then encodeUTF8 rawtext+			else rawtext in+	     xcommandK (ChangeProperty w p' t 8 propModeReplace text) $+	     notify time w (Selection s t p') l+      notify t w sel = xcommandK (SendEvent w False [] (SelectionNotify t sel))+      paste_string = paste' stringA+      paste_utf8string = paste' utf8A+      paste' typ =+	  xcommandK (ConvertSelection (Selection primaryA typ fudgetsA)) l+      paste_failed = putK (sevt (SelNotify "")) l+      selectionnotify sel@(Selection s t p) =+          if p==noneA+	  then if t==utf8A  -- UTF8_STRING wasn't supported, try STRING+	       then paste_string+	       else paste_failed+	  else if t `notElem` [stringA,utf8A]+	       then paste_failed+	       else getWindowPropertyK 0 p True t $ +			  \(typ, format, nitems, after,seltext) ->+		    let s' = if t==utf8A then decodeUTF8 seltext else seltext in+		    putK (sevt (SelNotify s')) l+      select = select' True+      deselect = select' False+      -- should check that setselectionowner succeeded.+      select' b = xcommandK (SetSelectionOwner b primaryA) l+    in l++selectionF :: F (SelCmd String) (SelEvt String)+selectionF = loopThroughRightF (absF (selSP "")) (eselectionF) where+  selSP text = +    let same = selSP text +	toesel = Left+	toout = Right in+    getSP $ \msg -> case msg of+	Right ocmd -> case ocmd of+	   Sel t -> putSP (toesel OwnSel) $ selSP t+	   _ -> putSP (toesel (SelCmd ocmd)) same+	Left esevt -> case esevt of+	   WantSel -> putSP (toesel (SelCmd (Sel text))) same+	   SelEvt se -> putSP (toout se) same
+ hsrc/containers/Shells.hs view
@@ -0,0 +1,42 @@+module Shells where++import FDefaults+import Fudget+import FRequest+import Xcommand+import DShellF+import EitherUtils+--import NullF+import CompOps+import Command+import FudgetIO+import Event+import Spops(concatMapSP)+import MapstateK++unmappedShellF cmds = unmappedShellF' standard cmds++unmappedShellF' pm cmds k =+    shellKF' (pm. setVisible False. setMargin 0)+	     (putLows cmds k)+   +unmappedSimpleShellF = unmappedSimpleShellF' standard++unmappedSimpleShellF' :: Customiser ShellF -> String -> F i o -> F i o+unmappedSimpleShellF' pm name f = +   stripEither >^=< shellKF' params k f  >=^^< mapraiseSP where+     params = setVisible False . pm+     startcmds = [StoreName name]+     mapraiseSP = concatMapSP ( \msg -> [Right msg, Left True])+     k = xcommandsK startcmds mapWindowK++mapWindowK = mapstateK k1 False+  where+    k1 False  (High True)                  = (True,   [Low $ XCmd $ MapRaised])+    k1 True   (High False)               = (False,  [Low $ XCmd $ UnmapWindow])+    k1 _      (Low (XEvt (UnmapNotify _))) = (False,  [])+    k1 _      (Low (XEvt (MapNotify _)))   = (True,   [])+    k1 mapped _                            = (mapped, [])++-- Retained for backwards compatibility:+simpleShellF name wattrs = shellF' (setWinAttr wattrs) name
+ hsrc/debug/Debug.hs view
@@ -0,0 +1,5 @@+module Debug (-- * Debug+  module Maptrace,module ShowCommandF,module SpyF) where+import Maptrace+import ShowCommandF+import SpyF
+ hsrc/debug/Maptrace.hs view
@@ -0,0 +1,10 @@+module Maptrace(maptrace,ctrace) where+import Debug.Trace(trace)+import CmdLineEnv(argFlag)++maptrace s = map (\x -> if x == x then trace s x else error "?")++ctrace flag =+       if argFlag flag False+       then \e -> trace (flag++": "++show e)+       else const id
+ hsrc/debug/ShowCommandF.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE CPP #-}+module ShowCommandF(showCommandF) where+import CompOps((>.=<), (>=.<))+import Fudget+--import Geometry(Line, Point, Rect, Size(..))+--import LayoutRequest(LayoutRequest)+--import Message(Message)+import Path(showPath)+import Debug.Trace(trace)+import Xtypes+import Command+import Event+--import ResourceIds+import Sockets+import CmdLineEnv(argFlag)+--import DialogueIO hiding (IOError)++showCommandF :: String -> (F a b) -> F a b+showCommandF s f = const (if not (argFlag s False) then f else+    let showit show' d (t, c) =+            trace (s ++ " " ++ d ++ ": " ++ showPath t ++ ": " ++ show' c+#ifdef __NHC__+		   ++ "\n"+#endif+		   )+                  (t, c)+    in  (showit show "out" >.=< f) >=.< showit show "in") x++{-+showEv e = case e of+       IOResponse (XResponse x) -> "IOResponse (XResponse ..."++show x++")"+       _ -> show e+-}++-- Hack: The following is to avoid show methods from hlib++x = [show (m :: Display),+     show (m :: Command),+     show (m :: Event),+     show (m :: WindowId),+     show (m :: Descriptor)]++m = error "module ShowCommandF"
+ hsrc/debug/ShowFailure.hs view
@@ -0,0 +1,6 @@+module ShowFailure where++import qualified DialogueIO++showFailure :: DialogueIO.IOError -> String+showFailure = show
+ hsrc/debug/SpyF.hs view
@@ -0,0 +1,22 @@+module SpyF where+import Fudget+import CompOps+import IoF(ioF)+import StdIoUtil(echoStderrK)+--import EitherUtils+import NullF(getK,putK{-,F,K-})+--import FudgetIO+--import ContinuationIO(stderr)++spyF f = teeF show "OUT: " >==< f >==< teeF show "IN: "++teeF show prefix = ioF teeK+  where+    teeK =+      getK $ \msg ->+      case msg of+	Low _ -> teeK+	High msg -> echoStderrK (prefix++show msg) $+		    putK (High msg) $+		    teeK+
+ hsrc/defaults/DefaultParams.hs view
@@ -0,0 +1,8 @@+module DefaultParams(-- * Default parameters+  module FDefaults) where+import FDefaults++{-+import Fudget+import Xtypes(ColorName(..),FontName(..),KeySym(..),ModState(..),Modifiers,WindowAttributes)+-}
+ hsrc/defaults/FDefaults.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE CPP #-}+module FDefaults(module FDefaults,module Alignment,fromMaybe) where++import Fudget+import CompOps+import Xtypes+import Alignment(Alignment(..))+--import Geometry(pmax)+import Data.Maybe(fromMaybe)+import Sizing(Sizing)+import GCAttrs --(ColorSpec,colorSpec)+#include "defaults.h"++type Customiser a = a ->  a+cust :: (a->a) -> Customiser a -- to obtain better type signatures+cust = id++type PF p a b = F (Either (Customiser p) a) b+type PK p a b = K (Either (Customiser p) a) b++getpar pp = fromMaybe (error "getpar:: missing default") . getparMaybe pp++getparMaybe pp [] = Nothing+getparMaybe pp (p:ps) =+     case pp p of+       Just a -> Just a+       Nothing -> getparMaybe pp ps++noPF :: PF p a b -> F a b+noPF f = f >=^< Right++standard :: Customiser a+standard = id++parameter_class(FontSpec,FontSpec)+setFont f = setFontSpec (fontSpec f)++--parameter_class(Title,String)+parameter_class(Keys,[(ModState,KeySym)])+parameter_class(WinAttr,[WindowAttributes])+parameter_class(BorderWidth,Int)++parameter_class(BgColorSpec,ColorSpec)+parameter_class(FgColorSpec,ColorSpec)+-- eta expanded because of the stupid monomorphism restriction+setBgColor c = setBgColorSpec . colorSpec $ c+setFgColor c = setFgColorSpec . colorSpec $ c+--getBgColor c = getBgColorSpec $ c+--getFgColor c = getFgColorSpec $ c++parameter_class(Margin,Int)+parameter_class(Align,Alignment)+parameter_class1(InitSize)+parameter_class1(InitDisp)+parameter_class(Stretchable,(Bool,Bool))+parameter_class(InitText,[String])+parameter_class(Sizing,Sizing)
+ hsrc/defaults/defaults.h view
@@ -0,0 +1,33 @@+{-+HBC uses "cpp -C -traditional" which causes all the /**/ to be left behind+when the macro definitions are processed. That is why the definitions+are inside a comment.++#define parameter_class(name,type) parameter_class_gen(name,name,type)++#define parameter_class_gen(classname,par,type) \+class Has/**/classname xxx where {\+    set/**/par :: (type) -> Customiser xxx; \+    get/**/par :: xxx -> (type); \+    get/**/par/**/Maybe :: xxx -> Maybe (type); \+    get/**/par = fromMaybe (error "get par: missing default") . get/**/par/**/Maybe }++#define parameter_class1(par) class Has/**/par xxx where {\+   set/**/par :: a -> Customiser (xxx a); \+   get/**/par/**/Maybe :: xxx a -> Maybe a; \+   get/**/par :: xxx a -> a; \+   get/**/par = fromMaybe (error "get par: missing default") . get/**/par/**/Maybe }++#define parameter_instance1(par,type) parameter_instance(par,type a)++#define parameter_instance(par,type) instance Has/**/par (type) where {\+  set/**/par p (Pars ps) = Pars (par p:ps); \+  get/**/par/**/Maybe (Pars ps) = getparMaybe (\x->case x of par p -> Just p; _-> Nothing) ps }++/* non-overloaded parameters: */+#define parameter(par) \+set/**/par p = cust (\ (Pars ps) -> Pars (par p:ps)); \+get/**/par (Pars ps) = getpar (\x->case x of par p -> Just p; _-> Nothing) ps; \+get/**/par/**/Maybe (Pars ps) = getparMaybe (\x->case x of par p -> Just p; _-> Nothing) ps+  +-}
+ hsrc/doRequest.hs view
@@ -0,0 +1,17 @@+import Control.Monad(forever)+import System.IO+import DoRequest++main =+  do state <- initXCall+     forever (print' =<< doRequest state =<< readLn')++print' x = do --hPutStr stderr "OR: "+            --hPrint stderr x+              print x+              hFlush stdout++readLn' = do r <- readLn+           --hPutStr stderr "IR: "+           --hPrint stderr r+             return r
+ hsrc/drawing/BitmapDrawing.hs view
@@ -0,0 +1,35 @@+module BitmapDrawing where+import Graphic+import MeasuredGraphics(MeasuredGraphics(..))+import GCtx(GCtx(..))+--import Command+import Event(BitmapReturn(..))+import DrawTypes+import Geometry(Rect(..),origin)+import Xtypes+--import FudgetIO+import NullF() -- instances, for hbc+import LayoutRequest(refpLayout,plainLayout)+import Gc+import StdIoUtil(echoStderrK)+import Pixmap(readBitmapFile)+import Data.Maybe(maybeToList)+--import ContinuationIO(stderr)++data BitmapFile = BitmapFile String++instance Graphic BitmapFile where+  measureGraphicK (BitmapFile filename) (GC gc _) k =+    readBitmapFile filename $ \ bmret ->+    case bmret of+      BitmapReturn size optrefp pixmap ->+          wCreateGC gc [GCGraphicsExposures False] $ \ gc' ->+          k (LeafM ll (drawit gc'))+	where r = Rect origin size+              ll = refpLayout size True True (maybeToList optrefp)+	      drawit gc (Rect p _) = [(gc,[CopyPlane (Pixmap pixmap) r p 0])]+      _ ->+          echoStderrK ("Failed to load bitmap "++filename) $+          k (LeafM ll drawit)+	where ll = plainLayout 20 False False+	      drawit r = [(gc,[FillRectangle r])]
+ hsrc/drawing/Color.hs view
@@ -0,0 +1,71 @@+module Color(tryAllocColor,tryAllocColorF,+	     allocColor,allocColorF,+	     allocColorPixel,allocColorPixelF,+             tryAllocNamedColor,tryAllocNamedColorF,+	     allocNamedColor,allocNamedColorF,+	     allocNamedColorPixel,allocNamedColorPixelF,+	     allocNamedColorDef,+	     allocNamedColorDefPixel,+	     queryColor,queryColorF+             ) where+import Command+import Event+--import Fudget+import Xrequest+import Xtypes+import Cont+--import NullF(F,K)+import StdIoUtil(echoStderrK)+--import ContinuationIO(stderr)++genTryAlloc cmd xr =+    let expected (ColorAllocated color) = Just color+        expected _ = Nothing+    in xr cmd expected++genTryAllocColor xr cmap rgb = genTryAlloc (AllocColor cmap rgb) xr+genTryAllocNamedColor xr cmap cname = genTryAlloc (AllocNamedColor cmap cname) xr++tryAllocColor x = genTryAllocColor xrequest x+tryAllocColorF = genTryAllocColor xrequestF++tryAllocNamedColor x = genTryAllocNamedColor xrequest x+tryAllocNamedColorF = genTryAllocNamedColor xrequestF++--allocNamedColorDef :: ColormapId -> ColorName -> ColorName -> Cont (K a b) Color+allocNamedColorDef cmap cname fallback = +    tryGet (tryAllocNamedColor cmap cname)+	   (echoStderrK+		      ("Warning, cannot allocate background color \""++cname+++		      -- backround ??+		       "\", using \""++fallback++"\" instead.") .+	    allocNamedColor cmap fallback)++--allocNamedColorDefPixel :: ColormapId -> ColorName -> ColorName -> Cont (K a b) Pixel+allocNamedColorDefPixel cmap cname fallback = allocNamedColorDef cmap cname fallback+  . (.colorPixel)++safe req cmap c = tryM (req cmap c) (error ("Cannot allocate color: "++show c))++pixel :: (a->b->Cont c Color) -> a->b->Cont c Pixel+pixel req cmap c = req cmap c . (.colorPixel)++allocNamedColor x = safe tryAllocNamedColor x+allocNamedColorF = safe tryAllocNamedColorF++allocNamedColorPixel x = pixel allocNamedColor x+allocNamedColorPixelF = pixel allocNamedColorF++allocColor x = safe tryAllocColor x+allocColorF = safe tryAllocColorF++allocColorPixel x = pixel allocColor x+allocColorPixelF = pixel allocColorF++querycolor xr cmap pixel =+    let expected (ColorQueried c) = Just c+        expected _ = Nothing+    in xr (QueryColor cmap pixel) expected++queryColorF = querycolor xrequestF+queryColor x = querycolor xrequest x
+ hsrc/drawing/Convgc.hs view
@@ -0,0 +1,32 @@+module Convgc(convGCattrsK) where+import Color+--import Font(FontStruct)+--import Fudget+import LoadFont+--import Spops+import Xtypes+import EitherUtils() -- synonym Cont, for hbc++convGCattrsK attrs = gcattrsK attrs []++gcattrsK [] outattrs dr = dr (reverse outattrs)+gcattrsK (attr : attrs) outattrs dr =+  let cp attr' = gcattrsK attrs (attr' : outattrs) dr+  in case attr of+       GCForeground colname ->+         allocNamedColorPixel defaultColormap colname $ \fg ->+	 gcattrsK attrs (GCForeground fg : outattrs) dr+       GCBackground colname ->+         allocNamedColorPixel defaultColormap colname $ \fg ->+	 gcattrsK attrs (GCBackground fg : outattrs) dr+       GCFont fname ->+         loadFont fname $ \font ->+	 gcattrsK attrs (GCFont font : outattrs) dr+       GCFunction f -> cp (GCFunction f)+       GCLineWidth w -> cp (GCLineWidth w)+       GCLineStyle s -> cp (GCLineStyle s)+       GCCapStyle s -> cp (GCCapStyle s)+       GCJoinStyle s -> cp (GCJoinStyle s)+       GCSubwindowMode m -> cp (GCSubwindowMode m)+       GCGraphicsExposures b -> cp (GCGraphicsExposures b)+
+ hsrc/drawing/Cursor.hs view
@@ -0,0 +1,22 @@+module Cursor where+import Command+import Event+import Fudget+import Xrequest+import Xcommand+import Xtypes++createFontCursor shape =+    let cmd = CreateFontCursor shape+        expected (CursorCreated cursor) = Just cursor+        expected _ = Nothing+    in  xrequestK cmd expected++setFontCursor :: Int -> K a b -> K a b+setFontCursor shape process =+    createFontCursor shape $ \ cursor ->+    xcommandK (ChangeWindowAttributes [CWCursor cursor]) $+    process++defineCursor cursor = xcommandK (ChangeWindowAttributes [CWCursor cursor])+undefineCusror = xcommandK (ChangeWindowAttributes [CWCursor cursorNone])
+ hsrc/drawing/Drawing.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DeriveFunctor #-}+module Drawing(Drawing(..),labelD,placedD,atomicD,DPath(..),up,GCSpec) where+import Graphic+import MeasuredGraphics(MeasuredGraphics(..),DPath(..),up)+--import FudgetIO+import NullF() -- instances, for hbc+import GCtx(GCSpec(..),wCreateGCtx)+import Placers2(overlayP)+import LayoutRequest+--import EitherUtils(Cont(..))+import GCAttrs(ColorSpec,FontSpec)+import Xtypes(GCAttributes)+--import Geometry() -- Show instances++data Drawing lbl leaf+  = AtomicD   leaf+  | LabelD    lbl  (Drawing lbl leaf)+  | AttribD   GCSpec (Drawing lbl leaf)+  | SpacedD   Spacer (Drawing lbl leaf)+  | PlacedD   Placer (Drawing lbl leaf)+  | ComposedD Int    [Drawing lbl leaf]   -- ^ Int=how many visible components+  | CreateHardAttribD GCtx [GCAttributes ColorSpec FontSpec] (GCtx -> +                      Drawing lbl leaf)+  deriving (Show,Functor)++labelD = LabelD+placedD = PlacedD+atomicD = AtomicD++instance Graphic leaf => Graphic (Drawing annot leaf) where+  measureGraphicK = drawK+  measureGraphicListK = drawListK overlayP  -- or autoP ??+++drawK d gctx{-@(GC gc fs)-} k =+  case d of+    AtomicD x -> measureGraphicK x gctx k+    LabelD _ d -> drawK d gctx (k . MarkM gctx)+    AttribD gcspec d ->+      wCreateGCtx' gctx gcspec $ \ gctx' ->+      drawK d gctx' (k . MarkM gctx')+    SpacedD spacer d ->+      drawK d gctx $ \ g ->+      k (SpacedM spacer g)+    PlacedD placer d ->+      drawK d gctx $ \ g ->+      k (PlacedM placer g)+    ComposedD n ds ->+      -- take the n visible components, remaining parts are invisible.+      drawsK gctx (take n ds) $ \ gs ->+      k (ComposedM gs)+    CreateHardAttribD templ attrs d ->+      wCreateGCtx templ attrs $ \tx ->+      drawK (d tx) gctx k+{-+  where+    replaceFontK fs gcattrs k = font gcattrs (k fs) (\fid -> queryFont fid k)+    font [] kdef _ = kdef+    font (GCFont fid:gcattrs) _ kfont = kfont fid+    font (_:gcattrs) kdef kfont = font gcattrs kdef kfont+-}++drawListK placer ds gctx k =+  drawsK gctx ds $ \ gs ->+  k (PlacedM placer $ ComposedM gs)++drawsK gctx [] k = k []+drawsK gctx (d:ds) k =+  drawK d gctx $ \ g ->+  drawsK gctx ds $ \ gs ->+  k (g:gs)++wCreateGCtx' gctx gcspec k =+  case gcspec of+    HardGC gctx' -> k gctx'+    SoftGC gcattrs -> wCreateGCtx gctx gcattrs k
+ hsrc/drawing/DrawingModules.hs view
@@ -0,0 +1,42 @@+module DrawingModules(-- * Drawing+  -- ** Colors+  module Color,+  -- ** Cursors+  module Cursor,+  -- ** Fonts+  module Font,module LoadFont,+  -- ** Graphics Contexts+  module Gc,module Convgc,module GCAttrs,module GCtx,+  -- ** class Graphic+  module Graphic,+  -- ** Atomic Drawings+  module FixedDrawing,module FlexibleDrawing,+  module BitmapDrawing,module Pixmap,module PixmapGen,+  -- ** Composed drawings+  module Drawing,module DrawingUtils,module DrawingOps,+  module Graphic2Pixmap,+  -- ** Misc+  module TransCoord,+  module MeasuredGraphics, module CompiledGraphics+) where+import Color+import Convgc+import Cursor+import Font+import Gc+import LoadFont+import Pixmap+import TransCoord+import DrawingUtils+import FixedDrawing+import FlexibleDrawing+import BitmapDrawing+import PixmapGen+import GCAttrs+import GCtx+import Graphic+import Drawing+import DrawingOps+import Graphic2Pixmap+import MeasuredGraphics+import CompiledGraphics
+ hsrc/drawing/DrawingOps.hs view
@@ -0,0 +1,226 @@+module DrawingOps where+import Drawing(Drawing(..),DPath(..),up)+import Utils(number)++drawingPart drawing path =+  case maybeDrawingPart drawing path of+    Just part -> part+    Nothing -> error ("bad path in drawingPart "++show path)++maybeDrawingPart drawing path =+  case (path::DPath) of+    [] -> Just drawing+    p:ps -> part drawing+      where+        part0 d = if p==0+	          then maybeDrawingPart d ps+		  else Nothing+        part drawing =+	  case drawing of+	    AtomicD           _  -> Nothing+	    LabelD    _       d  -> part0 d+	    AttribD   gcattrs d  -> part0 d+	    SpacedD   spacer  d  -> part0 d+	    PlacedD   placer  d  -> part0 d+	    ComposedD _       ds ->+	      if 1<=p && p<=length ds+	      then maybeDrawingPart (ds !! (p-1)) ps+	      else Nothing++drawingAnnotPart = drawingAnnotPart' (const True)++drawingAnnotPart' p drawing path =+      case path of+        [] -> []+	_ -> case maybeDrawingPart drawing path of+	       Just (LabelD a _) | p a -> path+	       _ -> drawingAnnotPart' p drawing (up path)++isVisibleDrawingPart drawing path =+  case (path::DPath) of+    [] -> True+    p:ps -> visible drawing+      where+        visible0 d = p==0 && isVisibleDrawingPart d ps -- ??+        visible drawing =+	  case drawing of+	    AtomicD           _  -> True -- ??+	    LabelD    _       d  -> visible0 d+	    AttribD   gcattrs d  -> visible0 d+	    SpacedD   spacer  d  -> visible0 d+	    PlacedD   placer  d  -> visible0 d+	    ComposedD n       ds ->+	      1<=p && p<=n && isVisibleDrawingPart (ds !! (p-1)) ps++visibleAncestor drawing path =+  case path::DPath of+    [] -> path+    p:ps ->+      case drawing of+        AtomicD           _  -> path+	LabelD    _       d  -> skip d+	AttribD   gcattrs d  -> skip d+	SpacedD   spacer  d  -> skip d+	PlacedD   placer  d  -> skip d+	ComposedD n       ds ->+	  if 1<=p && p<=n+	  then p:visibleAncestor (ds!!(p-1)) ps+	  else []+      where skip d = 0:visibleAncestor d ps++replacePart drawing path new = updatePart drawing path (const new)++updatePart drawing path new =+  case (path::DPath) of+    [] -> new drawing+    p:ps  -> repl drawing+      where+        err = error "bad path in updatePart"+        repl0 d = if p==0 then updatePart d ps new else err+        repl drawing =+	  case drawing of+	    AtomicD           _  -> err+	    AttribD   gcattrs d  -> AttribD gcattrs (repl0 d)+	    LabelD    label   d  -> LabelD label (repl0 d)+	    SpacedD   spacer  d  -> SpacedD spacer (repl0 d)+	    PlacedD   placer  d  -> PlacedD placer (repl0 d)+	    ComposedD n       ds ->+	      let (pre,d:post) = splitAt (p-1) ds+              in ComposedD n (pre++updatePart d ps new:post)++mapLabelDrawing f = ma+  where+    ma d =+      case d of+	AtomicD           x  -> AtomicD x+	AttribD   gcattrs d  -> AttribD gcattrs (ma d)+	LabelD    label   d  -> LabelD (f label) (ma d)+	SpacedD   spacer  d  -> SpacedD spacer (ma d)+	PlacedD   placer  d  -> PlacedD placer (ma d)+	ComposedD n       ds -> ComposedD n (map ma ds)++mapLeafDrawing f = ma+  where+    ma d =+      case d of+	AtomicD           x  -> AtomicD (f x)+	AttribD   gcattrs d  -> AttribD gcattrs (ma d)+	LabelD    label   d  -> LabelD label (ma d)+	SpacedD   spacer  d  -> SpacedD spacer (ma d)+	PlacedD   placer  d  -> PlacedD placer (ma d)+	ComposedD n       ds -> ComposedD n (map ma ds)++{-+drawingArity drawing =+  case drawing of+    AtomicD     _  -> 0+    LabelD    _ d  -> drawingArity d+    AttribD   _ d  -> drawingArity d+    SpacedD   _ d  -> drawingArity d+    PlacedD   _ d  -> drawingArity d+    ComposedD _ ds -> length ds+-}++annotChildren = annotChildren' (const True)++annotChildren' :: (a -> Bool) -> (Drawing a d) -> [(DPath, Drawing a d)]   +annotChildren' p drawing =+    case drawing of+      LabelD _ d -> ac0 d+      d -> ac d+  where +    ac0 d0 = [(0:p,d)| (p,d)<-ac d0]+    ac d =+      case d of+        AtomicD     _  -> []+        LabelD    a d' -> if p a then [([],d)] else ac0 d'+	AttribD   _ d  -> ac0 d+	SpacedD   _ d  -> ac0 d+	PlacedD   _ d  -> ac0 d+	ComposedD _ ds -> [(i:p,d) | (i,cs) <- number 1 (map ac ds), (p,d)<-cs]++{-+drawingAnnots :: Drawing a d -> [(DPath,a)]   +drawingAnnots drawing = da drawing+  where +    da d =+      case d of+        AtomicD     _  -> []+        LabelD    a d' -> ([],a):da d'+	AttribD   _ d  -> da d+	SpacedD   _ d  -> da d+	PlacedD   _ d  -> da d+	ComposedD _ ds -> [(i:p,d) | (i,cs) <- number 1 (map da ds), (p,d)<-cs]+-}++drawingAnnots drawing = extractParts drawing sel+  where sel (LabelD a d) = Just a+	sel _ = Nothing++extractParts :: Drawing lbl leaf -> (Drawing lbl leaf -> Maybe a) -> [(DPath,a)]+extractParts drawing sel = extr drawing+  where+    extr0 d = [(0:p,d') | (p,d') <- extr d]+    extr d =+      (case sel d of+	 Just x -> (([],x):)+	 _ -> id) $+      case d of+        AtomicD     _  -> []+        LabelD    a d' -> extr0 d'+	AttribD   _ d  -> extr0 d+	SpacedD   _ d  -> extr0 d+	PlacedD   _ d  -> extr0 d+	ComposedD _ ds -> [(i:p,d) | (i,cs) <- number 1 (map extr ds), (p,d)<-cs]++deletePart drawing [] = drawing -- !! error report?+deletePart drawing path =+    updatePart drawing (init path) (deleteElem (last path))+  where+    deleteElem i = di+      where di d =+              case d of+		ComposedD n       ds ->+		  case splitAt (i-1) ds of+		    (ds1,_:ds2) -> ComposedD n' (ds1++ds2)+		    _ -> d -- !! error report?+		  where n' = if i<=n+		             then n-1+			     else n+		_                    -> d   -- !! error report?+{-+		AtomicD           x  -> d   -- !! error report?+		AttribD   gcattrs d  -> AttribD gcattrs (di d)+		LabelD    label   d  -> LabelD  label   (di d)+		SpacedD   spacer  d  -> SpacedD spacer  (di d)+		PlacedD   placer  d  -> PlacedD placer  (di d)+-}++groupParts pos0 len0 drawing =+  case drawing of+    ComposedD n ds -> ComposedD n1 (ds1++ComposedD n2 ds2:ds3)+      where+        (ds1,ds2a) = splitAt (pos0-1) ds+        (ds2,ds3) = splitAt len0 ds2a+        pos = length ds1+        len = length ds2+        -- keep the same parts visible+        (n1,n2) = if n<=pos then (n,0)+                  else if n<=pos+len+                       then (pos+1,n-pos)+                       else (n-len+1,len)++ungroupParts pos drawing =+  case drawing of+    ComposedD n1 ds ->+      case splitAt (pos-1) ds of+        (ds1,ComposedD n2 ds2:ds3) -> ComposedD n (ds1++ds2++ds3)+          where+            -- Can't preserve visibility when some of ds3 was visible+            -- but some of ds2 was hidden+            n = if n1<=pos then n1+                else if n1==pos+1+                     then pos+n2+                     else n1-1+length ds2 -- all of ds2 becomes visible!!+        _ -> drawing -- hmm!!+    _ -> drawing -- hmm!!
+ hsrc/drawing/DrawingUtils.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE CPP #-}+module DrawingUtils where+import Xtypes+import Drawing+import Graphic+import FixedDrawing+import FlexibleDrawing(blank')+import GCAttrs+import GCtx+import Placers+import MatrixP(matrixP,matrixP')+import Spacers+import Placers2+import TableP(tableP,tableP')+import Geometry+import DrawTypes(DrawCommand(..))+import Alignment(aLeft,aCenter,aTop)+import LayoutDir(LayoutDir(..))+--import EitherUtils(Cont(..))+--import Fudget(K)++#include "exists.h"++boxVisibleD = ComposedD+boxD ds = ComposedD (length ds) ds+stackD = PlacedD overlayP . boxD+vertD = PlacedD verticalP+vertD' = PlacedD . verticalP'+horizD = PlacedD horizontalP+horizD' = PlacedD . horizontalP'+vboxD = vertD . boxD+hboxD = horizD . boxD+vboxD' sep = vertD' sep . boxD+hboxD' sep = horizD' sep . boxD++vertlD = PlacedD verticalLeftP+vertlD' = PlacedD . verticalLeftP'+vboxlD = vertlD . boxD+vboxlD' sep = vertlD' sep . boxD+horizcD = PlacedD horizontalCenterP+horizcD' = PlacedD . horizontalCenterP'+hboxcD = horizcD . boxD+hboxcD' sep = horizcD' sep . boxD++tableD n = PlacedD (tableP n) . boxD+tableD' sep n = PlacedD (tableP' n Horizontal sep) . boxD++matrixD n = PlacedD (matrixP n) . boxD+matrixD' sep n = PlacedD (matrixP' n Horizontal sep) . boxD++westD = spacedD $ hvAlignS aLeft aCenter+northwestD = spacedD $ hvAlignS aLeft aTop++padD = spacedD.marginS++fontD fn = softAttribD [GCFont (fontSpec fn)]++--fgnD :: ColorName -> Drawing lbl leaf -> Drawing lbl leaf+--fgnD = fgD.Name++--fontnD :: FontName -> Drawing lbl leaf -> Drawing lbl leaf+--fontnD = fontD.Name++fgD color = softAttribD [GCForeground (colorSpec color)]+bgD color = softAttribD [GCBackground (colorSpec color)]+fatD = softAttribD [GCLineWidth 5,GCCapStyle CapRound]+--attribD = belowAnnotD.AttribD --hmm+attribD = AttribD +softAttribD = attribD.SoftGC+hardAttribD = attribD.HardGC+--spacedD = belowAnnotD.SpacedD  --hmm+spacedD = SpacedD++--belowAnnotD f (LabelD a d) = LabelD a (belowAnnotD f d)+--belowAnnotD f d = f d++#ifdef USE_EXIST_Q+data Gfx = EXISTS(a) TSTHACK((Graphic EQV(a)) =>) G EQV(a)+-- deriving Show -- doesn't work because of a HBC bug++instance Show Gfx where showsPrec n (G x) s = "G "++{-showsPrec 10 x-} s++instance Graphic Gfx where+  measureGraphicK (G x) = measureGraphicK x++g x = atomicD (G x)++#else++g = atomicD++#endif++filledRectD size = g (FixD (size) [FillRectangle (Rect origin size)])+rectD size = g (FixD (size+1) [DrawRectangle (Rect origin size)])+                   -- size+1 assumes that the line width is 1+blankD = g . blank' ++holeD =+    fgD "blue3" $ rectD size+    --stack [fgD "white" (filledRectD size),rectD size]+  where+    size = pP 15 13
+ hsrc/drawing/Expose.hs view
@@ -0,0 +1,27 @@+module Expose where++import Message+import Cont+--import Command+--import LayoutRequest+import Fudget+--import Xtypes+import Geometry(Rect,rmax)+import FRequest+import Event+--import Font++collectExposeK :: Bool -> Rect -> Int -> ([Rect] -> K a b) -> K a b+collectExposeK grX r aft c = collect [r] aft+   where collect rs aft = +	   if aft == 0 then c rs+	   else waitForK (\r ->+			case r of+			 Low (XEvt (Expose r aft')) | not grX -> Just (r,aft')+			 Low (XEvt (GraphicsExpose r aft' _ _)) | grX -> Just (r,aft')+			 _ -> Nothing) $ \(r,aft')->+			collect (r:rs) aft'+++maxExposeK grX r aft c = collectExposeK grX r aft $ \rs ->+		     c (foldl1 rmax rs)
+ hsrc/drawing/FixedDrawing.hs view
@@ -0,0 +1,35 @@+module FixedDrawing where+import Graphic+import MeasuredGraphics(MeasuredGraphics(..),measureImageString)+import GCtx(GCtx(..))+import ResourceIds(GCId)+import LayoutRequest+import Geometry(Rect(..),Size(..))+import Command(DrawCommand)+import Drawcmd(move)+--import EitherUtils(Cont(..))++data FixedDrawing = FixD Size [DrawCommand] deriving Show++instance Graphic FixedDrawing where+  measureGraphicK (FixD s dcmds) (GC gc _) k =+      k (LeafM (plainLayout s True True) drawit)+    where+      drawit (Rect p _) = [(gc,move p dcmds)]++data FixedColorDrawing = FixCD Size [(GCId,[DrawCommand])] deriving Show++instance Graphic FixedColorDrawing where+  measureGraphicK (FixCD s gcdcmds) _ k =+      k (LeafM (plainLayout s True True) drawit)+    where+      drawit (Rect p _) =+        if p==0+	then gcdcmds+	else [(gc,move p dcmds)|(gc,dcmds)<-gcdcmds]+++newtype ImageString = ImageString String++instance Graphic ImageString where+  measureGraphicK (ImageString s) = measureImageString s
+ hsrc/drawing/FlexibleDrawing.hs view
@@ -0,0 +1,141 @@+module FlexibleDrawing where+import Geometry+import DrawTypes+--import Xtypes(CoordMode(..),Shape(..))+import LayoutRequest+--import EitherUtils(Cont(..))+import Utils(aboth)+import Graphic+import MeasuredGraphics(MeasuredGraphics(..))+import GCtx(GCtx(..))++data FlexibleDrawing = FlexD Size Bool Bool (Rect->[DrawCommand]) deriving Show++instance Graphic FlexibleDrawing where+  measureGraphicK (FlexD s fh fv drawf) (GC gc _) k =+      k (LeafM (plainLayout s fh fv) drawf')+    where drawf' r = [(gc,drawf r)]++filler fh fv d = FlexD (diag d) fh fv (\r->[FillRectangle r])++--filledRect = filler False False+hFiller = filler False True+vFiller = filler True False++flex' s = FlexD s False False+flex = flex' 5++blank' s = flex' s (const [])+blank = blank' 5++frame' s  = flex' s (\r->[DrawRectangle (r `growrect` (-1))])+frame     = frame' 5++ellipse = ellipse' 5+ellipse' s = arc' s 0 (360*64)+arc = arc' 5+arc' s a1 a2 = flex' s (drawarc a1 a2)++filledEllipse = filledEllipse' 5+filledEllipse' s = filledarc' s 0 (360*64)+filledarc = filledarc' 5+filledarc' s a1 a2 = flex' s (fillarc a1 a2)++drawarc a1 a2 r = [DrawArc (r `growrect` (-1)) a1 a2]+fillarc a1 a2 r = [FillArc (r `growrect` (-1)) a1 a2]++rpar = bFlex (drawarc (-60*64) (120*64).doubleleft)+lpar = bFlex (drawarc (120*64) (120*64).doubleright)++doubleleft (Rect p s@(Point w _)) = Rect (p-d) (s+d) where d=Point w 0+doubleright (Rect p s@(Point w _)) = Rect p (s+d) where d=Point w 0++-- top level pattern bindings (with pbu) can't be trusted...+lbrack = fst bracks+rbrack = snd bracks++bracks = aboth bFlex (draw False, draw True)+  where+    draw right r = [DrawLine (Line p1 p2) | (p1,p2) <- ls ]+      where (p1,p2,p3,p4) = corners (r `moverect` 1 `growrect` (-2))+            ls = if right+	         then [(p1,p2),(p2,p4),(p3,p4)]+		 else [(p1,p2),(p1,p3),(p3,p4)]++corners (Rect p s@(Point w h)) = (p,p+pP w 0,p+pP 0 h,p+s)++lbrace = fst braces+rbrace = snd braces++braces = aboth bFlex2 (draw False, draw True)+  where+    draw right r = [DrawLines CoordModePrevious ls]+      where (tl,tr,bl,br) = corners (r `moverect` 1 `growrect` (-2))+            h = ycoord (bl-tl)+	    d = h `div` 2 - 4+            ls = if right+	         then [tl,east 1,se 2,south d,se 2,sw 2,south d,sw 2,west 1]+	         else [tr,west 1,sw 2,south d,sw 2,se 2,south d,se 2,east 1]++            west n = pP (-n) 0+	    east n = pP n 0+	    sw n = pP (-n) n+	    se n = pP n n+	    south n = pP 0 n++{-+polyLine p [] = []+polyLine p (v:vs) = (p,p'):polyLine p' vs+  where p' = p+v+-}++bFlex2 = bFlex' (pP 8 12)+bFlex = bFlex' (pP 5 10)+bFlex' size = FlexD size True False++rAngleBracket = bFlex2 (drawpoly . hMirror abPoints)+lAngleBracket = bFlex2 (drawpoly . abPoints)++abPoints = abPoints'+abPoints' r = [ur,ml,lr]+  where+    (ul@(Point lx ty),ur,_,lr@(Point rx by)) =+      corners (r `moverect` 1 `growrect` (-2))+    ml = Point (rx-d) my+    my = ty+h2+    h2 = (by-ty) `div` 2+    d = (h2 `div` 2) `min` (rx-lx)++triangleUp = flex' size (drawpoly . trianglePoints')+filledTriangleUp = flex' size (fillpoly . trianglePoints')+triangleDown = flex' size (drawpoly . vMirror trianglePoints')+filledTriangleDown = flex' size (fillpoly . vMirror trianglePoints')++size = Point 18 14++drawpoly ps = [DrawLines CoordModeOrigin ps]+fillpoly ps = [FillPolygon Convex CoordModeOrigin ps]+shrink = flip growrect (-1)++trianglePoints' = trianglePoints . shrink++trianglePoints (Rect p s@(Point w h)) = [p1,p2,p3,p1]+  where m = w `div` 2+	p1 = p+pP m 0+	p2 = p+s+	p3 = p+pP 0 h+++vMirror f r@(Rect (Point x0 y0) s@(Point _ h)) =+    [ m p | p <- f (Rect (Point x0 0) s)]+  where m (Point x y) = Point x (y1-y)+        y1 = y0+h-1+++hMirror f r@(Rect (Point x0 y0) s@(Point w _)) =+    [ m p | p <- f (Rect (Point 0 y0) s)]+  where m (Point x y) = Point (x1-x) y+        x1 = x0+w-1++padFD d (FlexD s fh fv f) = FlexD (s+diag (2*d)) fh fv f'+  where f' (Rect p s) = f (Rect (p+diag d) (s-diag d))
+ hsrc/drawing/Font.hs view
@@ -0,0 +1,194 @@+module Font(CharStruct(CharStruct,char_width,char_rbearing),+            FontStruct(..),FontStructList(..),+            FontStructF(FontStruct,font_id,font_ascent,font_descent,font_prop),+            FontDirection(..), FontProp(..), update_font_id, font_range,+            split_string, string_len, -- string_rect_mono,+            string_rect, string_box_size, string_bounds,+            next_pos, poslist, linespace,fsl2fs) where+import Geometry(Point(..), Rect(..), Size, pP, rR, rectsize, xcoord)+import Xtypes(Atom,FontId)+--import Utils(aboth)+--import HbcUtils(mapFst)+import Data.List(mapAccumL)+import Maptrace(ctrace) -- debugging+import Data.Array+--import qualified Data.Array as LA+--import qualified LA -- GHC bug workaround, can't use LA.!++default(Int)++data CharStruct = CharStruct {char_lbearing, char_rbearing,+                              char_width, char_ascent, char_descent :: Int}+		  deriving (Eq, Ord, Show, Read)++data FontDirection = FontLeftToRight | FontRightToLeft +                     deriving (Eq, Ord, Show, Read, Enum)++data FontProp = FontProp Atom Int deriving (Eq, Ord, Show, Read)++-- Only 8-bit characters and 2-byte matrixes. See fsl2fs too!+type FontStruct = FontStructF (Array Char CharStruct)+data FontStructF per_char =+    FontStruct {font_id :: FontId,+                font_dir :: FontDirection,+                first_char, last_char :: Char,+                font_complete :: Bool, -- all chars exist+                default_char :: Char,+                font_prop :: [FontProp],+                max_bounds, min_bounds :: CharStruct,+                per_char :: Maybe per_char,+                font_ascent, font_descent :: Int+                  -- ^ logical extent above/below baseline for spacing+               }+    deriving (Eq, Ord, Show, Read)+{-+font_id      (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = fid+font_ascent  (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = asc+font_descent (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = de+per_char     (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = ca+max_bounds   (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = maxb+min_bounds   (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = minb+font_range   (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = (fc,lc)+default_char (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = dc+font_prop    (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = fps+-}+font_range fs = (first_char fs,last_char fs)++--update_font_id (FontStruct _ fd fc lc all' dc fps minb maxb ca asc de) fid = +--  FontStruct fid fd fc lc all' dc fps minb maxb ca asc de+update_font_id fs fid = fs{font_id=fid}++linespace fs = font_ascent fs + font_descent fs++char_struct default' fs c =+    case per_char fs of+      Nothing -> default' fs+      Just ca -> --ca ! c+                 ca ! (if inRange (font_range fs) c   -- or: bounds ca+                       then -- debugging+		            if inRange (bounds ca) c+			    then c+			    else ctrace "fontrange" (font_range fs,bounds ca,c) (default_char fs)+		       else let c' = default_char fs+		            in if inRange (bounds ca) c'+			       then c'+			       else ctrace "fontrange" (font_range fs,"default char",c') ' ')++lbearing fs = char_lbearing . char_struct min_bounds fs+rbearing fs = char_rbearing . char_struct max_bounds fs++poslist :: FontStruct -> String -> [Int]+poslist fs = map (char_width . char_struct max_bounds fs)++next_pos :: FontStruct -> String -> Int+next_pos fs = sum . poslist fs++-- string_bounds gives enclosing rect with respect to first character's origin+string_bounds :: FontStruct -> String -> Rect+string_bounds fs [] = Rect (Point 0 0) (Point 0 0)+string_bounds fs s =+    let cs = char_struct max_bounds fs+        x = lbearing fs (head s)+        y = -(maximum . map (char_ascent . cs)) s+        width = next_pos fs (take (length s - 1) s) + rbearing fs (last s)+        height = (maximum . map (char_descent . cs)) s - y+    in  Rect (Point x y) (Point width height)++string_len :: FontStruct -> String -> Int+string_len fs s = (xcoord . rectsize . string_bounds fs) s++string_rect :: FontStruct -> String -> Rect+string_rect fs s =+    rR 0 (-font_ascent fs) (string_len fs s) (linespace fs)++string_box_size :: FontStruct -> String -> Size+string_box_size fs s = pP (next_pos fs s) (linespace fs)++split_string:: FontStruct -> String -> Int -> (String,String,Int)+split_string fs s x =+   -- find the first char that ends to the right of the wanted x position+   case dropWhile (\(_,_,xr)->xr<x) nxs of+     (n,xl,xr):_ ->+	-- xl<=x<=xr, wanted x position is inside the nth character+	if x-xl<xr-x+	then split n -- left edge of nth char is closer+	else split (n+1) -- right edge of nth char is closer+     [] -> (s,[],n) -- x position is after the last char of the string+  where+    split n = case splitAt n s of (s1,s2) -> (s1,s2,n)++    --n=length s, nxs= string & screen positions of all characters in the string+    ((n,_),nxs) = mapAccumL (\(n,x) w -> ((n+1,x+w),(n,x,x+w))) ((0,0)::(Int,Int)) ws++    -- Width of all characters:+    ws = poslist fs s+    ++{- old:+    let dist s' = abs (next_pos font s' - x)+        nearer (pre1, _, _) (pre2, _, _) = dist pre1 <= dist pre2+	better x y = if nearer x y then x else y+    in foldr1 better (allsplits s)++--allsplits s = [(take n s, drop n s, n) | n <- [0 .. length s]])+allsplits [] = [([],[],0)]+allsplits xxs@(x:xs) = ([],xxs,0): map (\(xs,ys,n)->(x:xs,ys,n+1)) (allsplits xs)+-}++--------++-- This is a temporary fix until we know how to construct Haskell arrays from C+type FontStructList = FontStructF [CharStruct]+{-+data FontStructList = FontStructList+                             FontId+                             FontDirection+			     Char -- first character+			     Char -- last character+			     Bool -- all chars exist+			     Char -- default char+			     [FontProp]+			     CharStruct -- min bounds+			     CharStruct -- max bounds+			     (Maybe [CharStruct])+			     Int -- logical extent above baseline for spacing+			     Int -- logical extent below baseline for spacing +                  deriving (Eq, Ord, Show, Read)+-}++--fontl_prop (FontStructList fid fd fc lc all' dc fps minb maxb ca asc de) = fps+fontl_prop = font_prop++fsl2fs (FontStruct fid fd fc lc all' dc fps minb maxb optclist asc de) =+    FontStruct fid fd fc lc all' dc fps minb maxb optca asc de+  where optca = fmap l2a optclist+        l2a clist = array (fc, lc) (zip ixs clist)+	-- !! This assumes single byte font, or 2 byte matrix font.+	-- !! Linear 16-bit fonts will not work.+	-- ! Using a linear array for a 2 byte matrix font wastes space!+	ixs = [toEnum (256*byte1+byte2) | byte1<-range (min_byte1,max_byte1),+	                         byte2<-range (min_byte2,max_byte2)]+	(min_byte1,min_byte2) = fromEnum fc `divMod` 256+	(max_byte1,max_byte2) = fromEnum lc `divMod` 256+{-+-- hack to circumvent limitation in generational garbage collector++data Array a b = Arr (a,a) (LA.Array Int (LA.Array Int b))+	deriving (Eq,Ord,Show,Read)++array :: (Ix a, Enum a) => (a,a) -> [(a,b)] -> Array a b+array bds l = Arr bds (LA.listArray (0,dix b2i-dix b1i)+                       [LA.array rng (filter (inRange rng.fst) (mapFst fromEnum l))+                        | offs <- [b1i,b1i+maxsize..b2i],+			  rng <- [(offs,(offs+maxsize-1) `min` b2i)]])+  where (b1i,b2i) = aboth fromEnum bds++(!) :: (Ix a, Enum a) => Array a b -> a -> b+(!) (Arr (b1,b2) a) i = (a `LA.sub` dix (ii-fromEnum b1)) `LA.sub` ii where ii = fromEnum i++bounds :: (Ix a, Enum a) => Array a b -> (a,a)+bounds (Arr bds a) = bds++maxsize = 255+dix i = i `div` maxsize+-}
+ hsrc/drawing/FontProperty.hs view
@@ -0,0 +1,27 @@+module FontProperty (fontProperty) where++import Font(FontProp(..))+import InternAtom(internAtom,atomName)+import Xtypes(Atom(..))++-- The font_prop element of the FontStruct contains a list of FontProp,+-- each containing a pair of Int's: the first is the property name atom number,+-- the secind is the property value atom number. To get a property of a font+-- (which may or may not exist) it is necessary to try to get the atom+-- number for the property name, and, if successful, find out the element+-- of the list containing that number. Then, using the second number +-- in the element found, retrieve the value. If more than one property +-- with the same name is found, only the first will be returned.++fontProperty fsprops propn cont = +  let match an' (FontProp an vn) = an' == an+      valatom (FontProp an vn) = vn+  in  internAtom propn True $ \pna ->+      case pna of+        Atom 0 -> cont Nothing+        a ->+          case (map valatom (filter (match a) fsprops)) of+            [] ->   cont Nothing+            vn:_ -> atomName (Atom (fromIntegral vn)) $ \vna -> cont vna++
+ hsrc/drawing/GCAttrs.hs view
@@ -0,0 +1,277 @@+{-# LANGUAGE CPP #-}+module GCAttrs(module GCAttrs,Cont(..)) where+--import Fudget+--import NullF(F,K)+import FudgetIO+import Xtypes+import EitherUtils(Cont(..))+import Font(FontStruct,font_id,font_range, font_prop, update_font_id)+import Color(tryAllocNamedColor,tryAllocColor)+import LoadFont(listFontsWithInfo,loadFont,loadQueryFont)+import FontProperty(fontProperty)+import CmdLineEnv(argKey)+import Utils(aboth,segments)+--import ListUtil(chopList,breakAt)++#include "exists.h"++data FontData+   = FID FontStruct+   | FS FontStruct++fdFontId (FID fs) = font_id fs+fdFontId (FS fs) = font_id fs++fontdata2struct (FS fs) k = k fs+fontdata2struct (FID fs) k = k fs++--newtype Name = Name String deriving (Eq,Show)+  -- The type Name is used instead of String since String is a type synonym+  -- and therefore can't be made an instance of a class.++#ifdef USE_EXIST_Q+data ColorSpec = EXISTS(a) TSTHACK((Show EQV(a),ColorGen EQV(a)) =>) ColorSpec EQV(a)+ -- deriving Show -- doesn't work because of a HBC bug+instance Show ColorSpec where showsPrec n (ColorSpec c) = showsPrec n c++data FontSpec = EXISTS(a) TSTHACK((Show EQV(a),FontGen EQV(a)) =>) FontSpeci EQV(a)+ -- deriving Show -- doesn't work because of a HBC bug+instance Show FontSpec where showsPrec n (FontSpeci f) = showsPrec n f++colorSpec x = ColorSpec x+fontSpec x = FontSpeci x+#else+data ColorSpec = StringCS ColorName | RGBCS RGB | PixelCS Pixel | ListCS [ColorSpec] deriving (Show)+data FontSpec = StringFS FontName | FontIdFS FontId | FontStructFS FontStruct | ListFS [FontSpec] deriving (Show)+#endif++--data ColorFallback = CF ColorName ColorName++--type GCAttrsSpec = GCAttributes ColorSpec FontSpec++class ColorGen a where+  IFNOEXIST(colorSpec :: a -> ColorSpec)+  tryConvColorK :: FudgetIO f => a -> Cont (f i o) (Maybe Pixel)++  -- Methods with defaults, to be overidden only in the Char instance:+  IFNOEXIST(colorSpecList :: [a] -> ColorSpec)+  convColorListK :: FudgetIO f => [a] -> Cont (f i o) (Maybe Pixel)++  convColorListK = convList tryConvColorK+  IFNOEXIST(colorSpecList = ListCS . map colorSpec)++convColorK c = tryConvColorK c . maybe err+  where err = error ("Can't allocate color: "++show c)++class FontGen a where+  IFNOEXIST(fontSpec :: a -> FontSpec)+  tryConvFontK :: FudgetIO f => a -> Cont (f i o) (Maybe FontData)++  -- Methods with defaults, to be overidden only in the Char instance:+  IFNOEXIST(fontSpecList :: [a] -> FontSpec)+  convFontListK :: FudgetIO f => [a] -> Cont (f i o) (Maybe FontData)++  IFNOEXIST(fontSpecList = ListFS . map fontSpec)+  convFontListK  = convList tryConvFontK++convFontK f k = tryConvFontK f $ maybe (tryConvFontK "fixed" $ maybe err k) k+  where err = error ("Can't load font: "++show f)++convList try xs cont = conv xs+  where conv [] = cont Nothing+        conv (x:xs) = try x $ maybe (conv xs) (cont . Just)+++#ifdef USE_EXIST_Q+instance ColorGen ColorSpec where tryConvColorK (ColorSpec c) = tryConvColorK c+instance FontGen FontSpec where tryConvFontK (FontSpeci c) = tryConvFontK c+#else+instance ColorGen ColorSpec where+  colorSpec = id+  tryConvColorK cs =+    case cs of+      StringCS s -> tryConvColorK s+--      NameCS name -> tryConvColorK name+      PixelCS pixel -> tryConvColorK pixel+      RGBCS rgb -> tryConvColorK rgb+--      FallbackCS fb -> tryColorColorK fb+      ListCS cs -> tryConvColorK cs++instance FontGen FontSpec where+  fontSpec = id+  tryConvFontK fs =+    case fs of+--      NameFS (Name name) -> tryConvFontK name k+      StringFS name -> tryConvFontK name+      FontStructFS fstr -> tryConvFontK fstr+      ListFS fs -> tryConvFontK fs+#endif++--instance ColorGen ColorFallback where+--  IFNOEXIST(colorSpec = FallbackCS)+--  convColorK = convColorFallbackK++--convColorFallbackK (CF c1 c2) = allocNamedColorDefPixel defaultColormap c1 c2++instance ColorGen c => ColorGen [c] where+  IFNOEXIST(colorSpec = colorSpecList)+  tryConvColorK = convColorListK++instance FontGen a => FontGen [a] where+  IFNOEXIST(fontSpec = fontSpecList)+  tryConvFontK = convFontListK++-- To be able to allow Strings as color names, we have to make an instance for+-- Char. We actually don't want single Chars to be allowed as color names, but+-- to avoid run-time errors they are allowed (and treated as one-char Strings).+instance ColorGen Char where+  IFNOEXIST(colorSpec c = StringCS [c])+  IFNOEXIST(colorSpecList s = StringCS s)+  tryConvColorK c = convColorListK [c]+  convColorListK s k = tryAllocNamedColor defaultColormap s (k . fmap colorPixel)++-- In the "auto mode":++-- if a font is less than 256 chars, load it as is+-- if a font is monospaced, reuse the FontStruct, inserting+--   a font ID obtained for the font via loadFont (as the font name was returned+--   by listFontsWithInfo, we are safe assuming that it exists)+-- if a font is proportional and large then keep its FID in order+--   to query the server for characters metrics.++getFontData :: FudgetIO f => [Char] -> Cont (f i o) (Maybe FontData)+getFontData =+    case usefontstructs of+      "yes" -> qf+      "no" -> lf+      _ -> autof+  where+    qf fname k = loadQueryFont fname (k . fmap FS)+    lf fname k = +      listFontsWithInfo fname 1 $ \ fis ->+      case fis of+        [] -> k Nothing+        (fn,fs):_ -> loadFont fname $ \fid -> k $ Just $ FID $ update_font_id fs fid+    autof fname k =+      listFontsWithInfo fname 1 $ \ fis ->+      case fis of+        [] -> k Nothing+	(fn,fs):_ -> let fprops = font_prop fs+                     in  fontProperty fprops "SPACING" $ \spacing ->+                         fontProperty fprops "FONT" $ \font ->+                         if char_count<=256+	                   then qf fn k+                           else let fscons = if (fixed_width font spacing)+                                               then FS+                                               else FID+                                in  loadFont fname $ \fid ->+                                    k $ Just $ fscons $ update_font_id fs fid+	   where+	     char_count = hi-lo+	     (lo,hi) = aboth fromEnum (font_range fs)++             fixed_width fnt spcng = +               let spc = segments (/='-') fn+                   spct = segments (/= '-') fnt'+                   monosp = ["m", "c", "M", "C"]+                   [fnt', spcng'] = map (\s -> case s of+                                                 Just c -> c+                                                 _      -> "\xFF") [fnt, spcng]+                   lspc = length spc+                   lspct = length spct+               in  spcng' `elem` monosp ||                     -- font property tells "monospaced"+                   lspct > 11 && (spct !! 11) `elem` monosp || -- from font property if XLFD+                   lspc > 11 && (spc !! 11) `elem` monosp ||   -- from font name if XLFD+                   lspc == 1 && (head spc) == "fixed"          -- no XLFD, guess by font alias++{--+	     fixed_width = spc !! 11 `elem` ["m","c"]+--}+{--+	     fixed_width+               | (spacing == (Just c)) = c `elem` monosp+               | ((length spct) > 11) = (spct !! 11) `elem` monosp+               | ((length spc) > 11) = (spc !! 11) `elem` monosp+               | ((length spc) == 1) && ((head spc) == "fixed") = True+               | otherwise = False++	     fixed_width = if length spc>11+			   then spc !! 11 `elem` ["m","c"]+			   else --XFLD is missing, assume proportional, unless+			        --the name of the font is "fixed"+                                fn=="fixed"++	     spc = chopList (breakAt '-') fn+             spct = chopList (breakAt '-') font+             monosp = ["m", "c", "M", "C"]+--}++instance FontGen Char where+  IFNOEXIST(fontSpec c = StringFS [c])+  IFNOEXIST(fontSpecList s = StringFS s)+  tryConvFontK f = convFontListK [f]+  convFontListK = getFontData++--instance ColorGen Name where+--  IFNOEXIST(colorSpec = NameCS)+--  tryConvColorK (Name s) = tryConvColorK s++tryConvColorRGBK rgb k = tryAllocColor defaultColormap rgb (k . fmap colorPixel)++instance ColorGen RGB where+  IFNOEXIST(colorSpec = RGBCS)+  tryConvColorK = tryConvColorRGBK++--instance FontGen Name where+--  IFNOEXIST(fontSpec = NameFS)+--  convFontK (Name s) = safeLoadQueryFont s+  +instance ColorGen Pixel where+  IFNOEXIST(colorSpec = PixelCS)+  tryConvColorK p k = k (Just p)++instance FontGen FontStruct where+  IFNOEXIST(fontSpec = FontStructFS)+  tryConvFontK fs k = k (Just (FS fs))++{--++instance FontGen FontId where+  IFNOEXIST(fontSpec = FontIdFS)+  tryConvFontK fs k = k (Just (FID fs))++--}++--convGCSpecK :: GCSpec -> (GCAttributeList->FontStruct->K i o) -> K i o+convGCSpecK fs attrs = gcattrsK fs attrs []+  where+    gcattrsK fs [] outattrs dr = dr (reverse outattrs) fs+    gcattrsK fs (attr : attrs) outattrs dr =+      let cp attr' = gcattrsK fs attrs (attr' : outattrs) dr+      in case attr of+	   GCForeground colspec ->+	     convColorK colspec $ \fg ->+	     gcattrsK fs attrs (GCForeground fg : outattrs) dr+	   GCBackground colspec ->+	     convColorK colspec $ \fg ->+	     gcattrsK fs attrs (GCBackground fg : outattrs) dr+	   GCFont fspec ->+	     convFontK fspec $ \fs' ->+	     gcattrsK fs' attrs (GCFont (fdFontId fs') : outattrs) dr+	   GCFunction f -> cp (GCFunction f)+	   GCLineWidth w -> cp (GCLineWidth w)+	   GCLineStyle s -> cp (GCLineStyle s)+	   GCCapStyle s -> cp (GCCapStyle s)+	   GCJoinStyle s -> cp (GCJoinStyle s)+	   GCSubwindowMode m -> cp (GCSubwindowMode m)+	   GCGraphicsExposures b -> cp (GCGraphicsExposures b)++gcFgA,gcBgA :: c -> [GCAttributes c FontSpec]+gcBgA c = [GCBackground c]+gcFgA c = [GCForeground c]++gcFontA :: f -> [GCAttributes ColorSpec f]+gcFontA f = [GCFont f]+++usefontstructs = argKey "fontstructs" "auto"
+ hsrc/drawing/GCtx.hs view
@@ -0,0 +1,38 @@+module GCtx where+import GCAttrs+import Xtypes+import Gc(createGC)+import Command(Drawable(..))+--import Font(FontStruct)+--import FudgetIO+--import NullF(F,K)+--import Maptrace(ctrace)++data GCtx = GC GCId FontData+ --deriving (Show) -- don't want to see FontStruct+instance Show GCtx where+  showsPrec d (GC gc fs) = ("GC "++) . showsPrec 10 gc . ("<<FontStruct>>"++)++gctx2gc (GC gc _) = gc++rootGCtx = GC rootGC (error "GCtx.rootGCtx0")+--  if usefontstructs then rootGCtx2 else rootGCtx0++--rootGCtx0 = GC rootGC (FID (error "GCtx.rootGCtx0"))+--rootGCtx1 = ...+--rootGCtx2 = GC rootGC (FS (error "GCtx.rootGCtx2"))++data GCSpec -- move to module Drawing?+  = SoftGC [GCAttributes ColorSpec FontSpec]+  | HardGC GCtx+  deriving (Show)++createGCtx drawable gctx@(GC gc fd) gcattrs k =+  --ctrace "gctrace" gc $+  convGCSpecK fd gcattrs $ \ gcattrs' fd' ->+  createGC drawable gc gcattrs' $ \ gc' ->+  --ctrace "gctrace" gc' $+  k (GC gc' fd')++wCreateGCtx x = createGCtx MyWindow $ x+pmCreateGCtx x = createGCtx . Pixmap $ x
+ hsrc/drawing/Gc.hs view
@@ -0,0 +1,26 @@+module Gc(pmCreateGC, wCreateGC, createGC, createGCF, wCreateGCF, pmCreateGCF) where+import Command+import Event+--import FudgetIO+import NullF(F{-,K-})+import Xrequest+import Xtypes+--import Maptrace(ctrace)++createGC drawable template attr =+    let cmd = CreateGC drawable template attr+        expected (GCCreated gc) = {-ctrace "gctrace" gc $-} Just gc+        expected _ = Nothing+    in xrequest cmd expected++--createGCK :: Drawable -> GCId -> GCAttributeList -> (GCId -> K a b) -> K a b+--createGCK = createGC++createGCF :: Drawable -> GCId -> GCAttributeList -> (GCId -> F a b) -> F a b+createGCF = createGC++wCreateGC x = createGC MyWindow x+pmCreateGC x = (createGC . Pixmap) x++wCreateGCF = createGCF MyWindow+pmCreateGCF = createGCF . Pixmap
+ hsrc/drawing/Graphic.hs view
@@ -0,0 +1,51 @@+module Graphic(module Graphic,MeasuredGraphics,emptyMG,emptyMG',GCtx,Cont(..)) where+import Fudget+import FudgetIO+import EitherUtils(Cont(..))+import Cont(conts)+import MeasuredGraphics(MeasuredGraphics(..),measureString,measurePackedString,emptyMG,emptyMG')+import GCtx(GCtx)+import PackedString(PackedString)+import Geometry() -- instance Num Point++class Graphic a where+  measureGraphicK :: FudgetIO k => a -> GCtx -> Cont (k i o) MeasuredGraphics+  measureGraphicListK :: FudgetIO k => [a] -> GCtx -> Cont (k i o) MeasuredGraphics+  -- Default method for lists:+  measureGraphicListK xs gctx cont =+	conts (`measureGraphicK` gctx) xs $ \ mgs ->+	cont (ComposedM mgs)++instance Graphic MeasuredGraphics where+  measureGraphicK cgfx gctx c = c cgfx++instance Graphic Char where+  measureGraphicK c = measureString [c]+  measureGraphicListK = measureString++instance Graphic a => Graphic [a] where+  measureGraphicK = measureGraphicListK++instance (Graphic a,Graphic b) => Graphic (a,b) where+  measureGraphicK (x,y) gctx cont =+    measureGraphicK x gctx $ \ mx ->+    measureGraphicK y gctx $ \ my ->+    cont (ComposedM [mx,my])++measureText x = (measureString.show) x++-- instance Text a => Graphics a where measureGraphicK = measureText+instance Graphic Int          where measureGraphicK = measureText+instance Graphic Integer      where measureGraphicK = measureText+instance Graphic Bool         where measureGraphicK = measureText+instance Graphic Float        where measureGraphicK = measureText+instance Graphic Double       where measureGraphicK = measureText+instance Graphic PackedString where measureGraphicK = measurePackedString++instance (Graphic a,Graphic b) => Graphic (Either a b) where+  measureGraphicK = either measureGraphicK measureGraphicK++instance Graphic a => Graphic (Maybe a) where+  measureGraphicK = maybe (measureGraphicK (emptyMG 5)) measureGraphicK++--instance Graphic Void
+ hsrc/drawing/Graphic2Pixmap.hs view
@@ -0,0 +1,31 @@+module Graphic2Pixmap(graphic2PixmapImage,PixmapImage(..)) where+import DrawCompiledGraphics(drawK')+import MeasuredGraphics(compileMG)+import Graphic+import PixmapGen+import Pixmap(createPixmap)+import LayoutRequest(minsize)+import XDraw+import ResourceIds(copyFromParent)+import FixedDrawing+import FudgetIO+import NullF() -- instance FudgetIO K++graphic2PixmapImage g gctx cont =+  measureGraphicK g gctx $ \ mg -> convToPixmapK mg cont++measuredGraphics2Pixmap mg cont =+  let (cg,req) = compileMG id mg+      size = minsize req+  in createPixmap size copyFromParent $ \ pm ->+     drawK' (Pixmap pm) (undefined,const []) (const []) cg $+     cont (PixmapImage size pm)++instance PixmapGen MeasuredGraphics where+  convToPixmapK = measuredGraphics2Pixmap++instance PixmapGen FixedColorDrawing where+  convToPixmapK (FixCD size gcdcmds) cont =+    createPixmap size copyFromParent $ \ pm ->+    putLow (pmDrawMany pm gcdcmds) $+    cont (PixmapImage size pm)
+ hsrc/drawing/LoadFont.hs view
@@ -0,0 +1,72 @@+module LoadFont(loadQueryFont, queryFont, loadFont, loadQueryFontF, +                queryFontF, loadFontF,safeLoadQueryFont, safeLoadQueryFontF,+                listFonts,listFontsF,listFontsWithInfo,tryLoadFont) where+import Command(XRequest(..))+import Event+import Font(fsl2fs) --FontStruct,FontStructList,+--import Fudget+--import Geometry(Line, Point, Rect, Size(..))+--import EitherUtils(stripMaybe,mapMaybe)+import Data.Maybe(fromJust)+import HbcUtils(mapSnd)+import Cont(tryM)+import Xrequest+import Xtypes++lf k fontname =+    let cmd = LoadFont fontname+        expected (FontLoaded fid) = Just fid+        expected _ = Nothing+    in k cmd expected++loadFont x = lf xrequest x+loadFontF = lf xrequestF++qf k fid =+    let cmd = QueryFont fid+        expected (FontQueried fs) = Just (fsl2fs (fromJust fs))+        expected _ = Nothing+    in  k cmd expected++queryFont x = qf xrequest x+queryFontF = qf xrequestF++lqf k fontname =+    let cmd = LoadQueryFont fontname+        expected (FontQueried optfs) = Just (fmap fsl2fs optfs)+        expected _ = Nothing+    in  k cmd expected++loadQueryFont x = lqf xrequest x+loadQueryFontF = lqf xrequestF++safeLqf lqf fn k =+  tryM (lqf fn)+       (lqf ("fixed"::FontName) $ \ (Just fs) -> k fs)+       k++safeLoadQueryFont x = safeLqf loadQueryFont x+safeLoadQueryFontF = safeLqf loadQueryFontF++lif k pattern maxnames =+    let cmd = ListFonts pattern maxnames+        expected (GotFontList fns) = Just fns+	expected _ = Nothing+    in k cmd expected++listFonts x = lif xrequest x+listFontsF = lif xrequestF++listFontsWithInfo pattern maxnames =+    let cmd = ListFontsWithInfo pattern maxnames+        expected (GotFontListWithInfo fis) = Just (mapSnd fsl2fs fis)+--      expected (GotFontListWithInfo fis) = Just (map ((,) pattern . fsl2fs) fis)+	expected _ = Nothing+    in xrequest cmd expected++-- Since loadFont succeeds and returns a FontId even if the font doesn't exist:+tryLoadFont fn k =+  listFonts fn 1 $ \ fns ->+  case fns of+    fn:_ -> loadFont fn (k . Just)+    _ -> k Nothing
+ hsrc/drawing/Pixmap.hs view
@@ -0,0 +1,30 @@+module Pixmap(bitmapFromData, readBitmapFile, createPixmap) where+import Command+import Event+--import Font(FontStruct)+--import Fudget+--import Geometry(Line, Point, Rect, Size(..))+--import LayoutRequest(LayoutRequest)+--import Message(Message(..))+--import Path(Path(..))+import Xrequest+--import Xtypes++createPixmap size depth =+    let cmd = CreatePixmap size depth+        expected (PixmapCreated pixmap) = Just pixmap+        expected _ = Nothing+    in  xrequest cmd expected++readBitmapFile name =+    let cmd = ReadBitmapFile name+        expected (BitmapRead b) = Just b+        expected _ = Nothing+    in  xrequest cmd expected++bitmapFromData bd =+    let cmd = CreateBitmapFromData bd+        expected (BitmapRead b) = Just b+        expected _ = Nothing+    in  xrequest cmd expected+
+ hsrc/drawing/PixmapGen.hs view
@@ -0,0 +1,43 @@+module PixmapGen where+import Graphic+import MeasuredGraphics(MeasuredGraphics(..))+import GCtx(GCtx(..))+--import Command+--import Event+import DrawTypes+import Geometry(Rect(..),Size,origin)+import Xtypes+import FudgetIO+import NullF() -- instances, for hbc+import LayoutRequest(plainLayout)+import Gc+--import EitherUtils(Cont(..))+--import Io(appendChanK)+--import Pixmap(readBitmapFile)+--import Maybe(maybeToList)+--import ContinuationIO(stderr)++data PixmapImage = PixmapImage Size PixmapId++instance Graphic PixmapImage where+    measureGraphicK (PixmapImage size pixmap) (GC gc _) k =+      wCreateGC gc [GCGraphicsExposures False] $ \ gc' ->+      let r = Rect origin size+	  ll = plainLayout size True True+	  drawit (Rect p _) = [(gc,[CopyArea (Pixmap pixmap) r p])]+      in k (LeafM ll drawit)++---++class PixmapGen a where+  convToPixmapK :: FudgetIO c => a -> Cont (c i o) PixmapImage++measureImageK a gctx k =+  convToPixmapK a $ \ pmi ->+  measureGraphicK pmi gctx k++--This is not allowed in Haskell...+--instance PixmapGen a => Graphic a where  measureGraphicsK = measureImageK++instance PixmapGen PixmapImage where+  convToPixmapK pmi k = k pmi
+ hsrc/drawing/TextExtents.hs view
@@ -0,0 +1,12 @@+module TextExtents where+import Xrequest(xrequest)+import Command+import Event++queryTextExtents16K fid str k =+    xrequest cmd expected $ \ (a,d,cs) -> k a d cs+  where+    cmd = QueryTextExtents16 fid str++    expected (TextExtents16Queried a d cs) = Just (a,d,cs)+    expected _ = Nothing
+ hsrc/drawing/TransCoord.hs view
@@ -0,0 +1,23 @@+module TransCoord where+import Command+import Event+import Fudget+import FRequest+import Geometry(Point)+import Xrequest+import Cont(cmdContK)+import Xtypes++getWindowRootPoint :: Cont (K a b) Point+getWindowRootPoint =+    let cmd = TranslateCoordinates+        expected (CoordinatesTranslated p) = Just p+        expected _ = Nothing+    in  xrequestK cmd expected+++getWindowId :: Cont (K a b) Window+getWindowId = cmdContK (XCmd GetWindowId)+	      (\r->case r of XEvt (YourWindowId w) -> Just w; _ -> Nothing)++-- Why is GetWindowId an XCommand?
+ hsrc/exists.h view
@@ -0,0 +1,33 @@+#if defined(__HBC__) || defined(__GLASGOW_HASKELL__) || defined(__NHC__) || defined(__PFE__)+#define USE_EXIST_Q+#else+#warning No existential types! The type Gfx will be omitted and the function g will be less general.+#endif++#ifdef USE_EXIST_Q+#define IFNOEXIST(e)+#define IFEXIST(e) e+#else+#define IFNOEXIST(e) e+#define IFEXIST(e)+#endif++-- Syntax for existential quantification varies:+#if defined(__HBC__)+#define EQV(x) ?x+#define EXISTS(x) +#elif defined(__GLASGOW_HASKELL__) || defined(__PFE__)+#define EQV(x) x+#define EXISTS(x) forall x .+#else+-- assume any free type variable is existential (like in NHC and old HBC)+#define EQV(x) x+#define EXISTS(x) +#endif+++#ifdef __PFE__+#define TSTHACK(e) e+#else+#define TSTHACK(e) e+#endif
+ hsrc/filters/DoubleClickF.hs view
@@ -0,0 +1,27 @@+module DoubleClickF where+import Fudget+import FRequest+import Xtypes+import Event+--import Font(FontStruct)+import Spops+--import Geometry(Point,Rect,Size(..))+import CompOps((>=..<))++doubleClickF :: Time -> F a b -> F a b+doubleClickF timeout fudget = fudget >=..< doubleClickSP 0 dummy+  where+    dummy = error "bug in DoubleClickF.hs"+    doubleClickSP n last =+      getSP $ \ tev@(path,ev) ->+      case ev of+        XEvt (ButtonEvent t wp rp mods press btn) ->+	    if n==0 || press/=Pressed || t>lasttime+timeout ||+	       btn/=lastbtn || mods/=lastmods || path/=lastpath+	    then putSP tev $ doubleClickSP 1 tev+	    else let n' = n+1+		     tev' = (path,XEvt (ButtonEvent t wp rp mods (MultiClick n') btn))+	         in putSP tev' $ doubleClickSP n' tev'+	  where+	    (lastpath,XEvt (ButtonEvent lasttime _ _ lastmods _ lastbtn)) = last+	_ -> putSP tev $ doubleClickSP n last
+ hsrc/filters/Filters.hs view
@@ -0,0 +1,15 @@+module Filters (+  -- * Filters+  --module Cache,+  module NewCache,+  module ShapeGroupMgr,module DoubleClickF) where+--import Cache+import NewCache+import ShapeGroupMgr+import DoubleClickF++{-+import Fudget+import Geometry(Rect)+import Xtypes(WindowAttributes,Time(..))+-}
+ hsrc/filters/FocusMgr.hs view
@@ -0,0 +1,179 @@+module FocusMgr(focusMgr) where+import Data.List((\\),sortBy)+import Data.Maybe(listToMaybe)+import Command+--import Direction+import Dlayout(invisibleGroupF)+import Event+--import Font(FontStruct)+import Fudget+import FRequest+--import Geometry(origin) --Line(..), Point(..), Rect(..), Size(..), origin)+--import LayoutRequest(LayoutRequest)+import LoopLow+import HbcUtils(union)+--import Message(Message(..))+import Path+import PathTree hiding (pos)+--import SP+import Spops+import CompSP+import Utils+import CmdLineEnv(argKey,argReadKey)+import WindowF(kernelTag,autumnize)+import Xtypes+--import List2(sort)++import Maptrace++getEventMask [] = Nothing+getEventMask (CWEventMask m : _) = Just m+getEventMask (_ : l) = getEventMask l++setEventMask em [] = [CWEventMask em]+setEventMask em (CWEventMask m : l) = CWEventMask em : l+setEventMask em (wa : l) = wa : setEventMask em l++focusBtn = Button 1+focusMods = [] --rotMods+rotMods = argReadKey "rotmods" [] :: ModState+rotKs = argKey "rotkey" "Tab" :: KeySym++entrymask = [KeyPressMask, EnterWindowMask, LeaveWindowMask]+mask = [KeyPressMask, KeyReleaseMask, EnterWindowMask, LeaveWindowMask]++mkFocusEvent io = io NotifyNonlinearVirtual NotifyNormal++focusMgr sizing ctt f = loopThroughLowF focusK0 igF+  where+  igF = invisibleGroupF sizing [] [CWEventMask mask] f+  focusK0 = prepostMapSP pre post +	       (focusK' False emptyPathTree False [] mask [] [] []) where+      pre (Left (t,m)) = (t,Left m)+      pre (Right (t,m)) = (t,Right m)+      post (t,Left m) = Left (t,m)+      post (t,Right m) = Right (t,m)++  --focusK' :: PathTree Bool ->  Bool ->  [(Bool,Path)] -> [EventMask] -> [(Path,(XEvent -> Maybe XEvent))] -> [Path] -> [(Bool,Path)] -> SP (Path,Either Command Event) (Path,Either Command Event) +  focusK' focusin mapped inw grab mask tt shellTags etags = same where+   focusK = focusK' focusin mapped+   focusm = focusK inw grab mask tt+   modMapped tag raised = changeFocusc' mapped' id +         [(and (spineVals mapped' t),t) | (_,t) <- etags]+      where mapped' = updateNode id True mapped (autumnize tag) (const raised)+   changeFocusc' mapped' c netags = +       inw && listToMaybe (mappedtags etags) /= listToMaybe (mappedtags netags)+         `thenC` (leaveFocus etags . enterFocus netags) $ +       c $+       focusK' focusin mapped' inw grab mask tt shellTags netags +   changeFocusc = changeFocusc' mapped+   changeFocus = changeFocusc id+   rotate ts = case break fst ts of+       (unmapped,[]) -> ts+       (unmapped,t:mapped) -> mapped ++ unmapped ++ [t]+   nexttag = rotate etags+   prevtag = reverse (rotate (reverse etags))+   enterFocus et = putFocus et FocusIn `ifC` inw+   leaveFocus et = putFocus et FocusOut `ifC` inw+   putFocus et f = putFocus' et (mkFocusEvent f)+   mappedtags et = [t |(True,t)<- et]+   putFocus' et ev = case mappedtags et of +	 [] -> id+	 (t:_) -> putSP (t, Right (XEvt ev))+   same = getSP focushandle+   focushandle tmsg@(tag,msg) = case msg of +      Left cmd ->+        case cmd of +	  XCmd xcmd -> case xcmd of+	    GrabEvents t -> putSP (tag, Left (XCmd $ GrabEvents (t || stag))) $+			    stag `thenC` (leaveFocus etags .+					  enterFocus [(True,tag)]) $+			    focusK inw ((not stag,tag):grab) +					   mask tt shellTags etags+	    UngrabEvents -> null grab' && inw `thenC` enterFocus etags $+			    pass $ focusK inw grab' mask tt shellTags etags+			  where grab' = drop 1 grab+	    TranslateEvent t tmask ->  putSP (kernelTag, +	       Left (XCmd $ ChangeWindowAttributes [CWEventMask umask])) $+		  focusK inw grab umask ((tag,t):tt) shellTags etags +	      where umask = union mask tmask+	    ChangeWindowAttributes cwa | ctt && not ktag && not stag ->+	       case getEventMask cwa of+		  Just em -> if issubset entrymask em then+				putSP (tag, Left (XCmd $ ChangeWindowAttributes +				       (setEventMask ((ButtonPressMask:+					      em) \\ entrymask) cwa))) $+				null etags `thenC` enterFocus etags' $+				focusm shellTags etags'+			     else passame+			where etags' = sortBy (\(_,x) (_,y)-> compare x y)+					      ((False,tag):etags)+		  Nothing -> passame+	    DestroyWindow -> pass $ +		 -- not (null etags) && not (keep (head etags)) `thenC`+	       enterFocus etags' $+	       focusK inw grab mask tt' shellTags' (etags' :: [(Bool,Path)])+	      where keep = not . subPath tag+		    etags' = filter (keep.snd) etags+		    shellTags' = filter keep shellTags+		    tt' = filter (keep.fst) tt+	    MapRaised   -> changeMapping tag True+	    UnmapWindow -> changeMapping tag False+	    _ -> passame+	  XReq (CreateMyWindow _) -> changeMapping tag False+	  XReq (CreateRootWindow _ _) {-  | not ktag -} ->+	     pass $ focusm (autumnize tag: shellTags) etags+	  XReq (CreateSimpleWindow rchild _) -> +	      changeMapping (absPath (autumnize tag) rchild) False+	  _ -> passame+       where changeMapping tag raised = ctrace "focus1" (raised,tag) $ pass $ modMapped tag raised+      Right (XEvt ev) ->+        if stag then passame+	else case ev of+	   ButtonEvent {state=mods,type'=Pressed,button=bno} | ctt && mods == focusMods +	      && bno == focusBtn && etag -> changeFocusc pass (aft++bef)+ 	      where (bef,aft) = break (flip subPath tag.autumnize.snd) etags+	   _ -> case flookup ev tt of+	       Just (t,e) -> putSP (t,Right (XEvt e)) same+	       Nothing -> if not ctt then passame else +	         case ev of+		  KeyEvent {state=mods,type'=Pressed,keySym=ks} | ks == rotKs && ktag ->+		    if (Shift:rotMods) `issubset` mods then changeFocus prevtag+		    else if rotMods    `issubset` mods then changeFocus nexttag+		    else passame+		  KeyEvent {} |tag==kernelTag || gtag' -> toFocus same+		  EnterNotify {detail=d,focus=True} | tag==kernelTag -> handleEL False d True+		  LeaveNotify {detail=d,focus=True} | tag==kernelTag -> handleEL False d False+		  FocusIn  {detail=d} | tag==kernelTag || gtag' -> handleEL True d True+		  FocusOut {detail=d} | tag==kernelTag || gtag' -> handleEL True d False+		  _ -> passame+	where toFocus = putFocus' etags ev +	      handleEL isFocusEv d e = if d == NotifyInferior +                                       || (not isFocusEv && focusin) -- focus events have priority over crossing events+                       then passame else+		       (case grab of+			  (my,t):_ -> if my then if ktag then focusEvToFocus+						 else pass+				      else if ktag then +					     putSP (t,Right (XEvt ev))+					    else pass+			  [] -> if ktag then focusEvToFocus else pass ) $ +		       focusK' focusin' mapped inw' grab mask tt shellTags etags+		  where inw' = if ktag then e else inw+                        focusin' = if ktag && isFocusEv then e else focusin+                        focusEvToFocus = putFocus etags (if e then FocusIn else FocusOut)+      Right _ -> passame+    where pass = putSP tmsg+	  passame = pass same+	  ktag = tag == kernelTag || gtag+	  stag = inGroup shellTags+	  etag = inGroup (map (autumnize.snd) etags)+	  gtag = case grab of (_,t):_ -> t == tag; [] -> False+	  gtag' = case grab of (True,t):_ -> t == tag; [] -> False -- event grabbed by something in my shell+          inGroup tags = any (flip subPath tag) tags++flookup index' [] = Nothing+flookup index' ((t, p) : table') =+    case p index' of+      Nothing -> flookup index' table'+      Just e -> Just (t, e)
+ hsrc/filters/NewCache.hs view
@@ -0,0 +1,64 @@+module NewCache(allcacheF) where+import Command+--import Event+import FRequest+--import Fudget+--import Loopthrough+import Spops+import LoopLow+import Cont+import IsRequest+--import DialogueIO hiding (IOError)+import qualified Data.Map as OM++--import Maptrace(ctrace) -- debug+--import NonStdTrace(trace)++-- A new implementation of the X resource cache.+-- TODO: reference counters and the ability to free unused resources.++allcacheable xreq =+  case xreq of+    LoadFont fn -> True+    QueryFont f -> True+    LoadQueryFont s -> True+    ListFonts pat max -> True+    ListFontsWithInfo pat max -> True+    CreateGC d t as -> True+    -- FreeGC gcid +    AllocNamedColor cm cn -> True+    AllocColor cm rgb -> True+    -- FreeColors cm [pixel] (Pixel 0)+    CreateFontCursor shape -> True+    ReadBitmapFile name -> True+    CreateBitmapFromData bdata -> True -- hmm, big request, small result...+    _ -> False++allcacheF = cacheF allcacheable++cacheF cacheable fud = loopThroughLowF (cc OM.empty) fud where+  cc table = same where+     same = getSP cachehandle+     cachehandle msg = case msg of +       Left tc@(tag,c) ->+	   case c of+	     XReq xreq ->+	       if cacheable xreq+	       then case OM.lookup xreq table of+		      Just r -> putSP (Right (tag,r)) $+				cc table+		      Nothing -> waitresp $ \r ->+				 --ctrace "trcache" ("alloc",c,d,r) $+				 cc (OM.insert xreq r table)+	       else waitresp $ \r -> same+	     _ -> if isRequest c+		  then waitresp $ \r -> same+		  else psame+         where waitresp c = cmdContSP (Left tc)+		 (\msg->case msg of Right te@(_,e) | isResponse e -> Just te+				    _ -> Nothing) $ \tr@(_,r) ->+		 putSP (Right tr) $ c r+       Right _ -> psame+      where+       pass = putSP msg+       psame = pass same
+ hsrc/filters/ShapeGroupMgr.hs view
@@ -0,0 +1,75 @@+module ShapeGroupMgr(shapeGroupMgr) where++--import Path+import LoopLow+import Command+--import Event+import Fudget+import FRequest+import Geometry+--import Message(Message(..))+--import NullF+--import Spacers+--import Alignment+import Spops+--import EitherUtils+import Data.Maybe(fromMaybe,mapMaybe)+import Utils+import Xtypes+import WindowF(kernelTag,getBWidth,adjustBorderWidth,border_width)+--import AuxTypes(Ordering(..)) -- HBC bug workaround 960405 TH.+--import Prelude hiding (Ordering)++doConfigure tag wins cws = lookup tag wins >>= \br ->+    let br' = upd br cws +        upd br [] = br+	upd br@(bw,r@(Rect (Point x y) (Point w h))) (c:cs) = +	   upd (case c of+		 CWX x' -> (bw,Rect (Point x' y) (Point w h))+		 CWY y' -> (bw,Rect (Point x y') (Point w h))+		 CWWidth w' -> (bw,Rect (Point x y) (Point w' h))+		 CWHeight h' -> (bw,Rect (Point x y) (Point w h'))+		 CWBorderWidth bw' -> (bw',r)+		 _ -> br) cs+    in if br  == br' then Nothing else Just $ replace (tag,br') wins++filterBorderwidth = mapMaybe (\c->case c of CWBorderWidth _ -> Nothing+					    _-> Just c)+shapeGroupMgr :: F a b -> F a b+shapeGroupMgr f  = loopThroughLowF (sg (border_width,[])) f where+   sg state@(bw,wins) =+      getSP $ \msg -> +      let same = sg state+          pass = putSP msg+	  passame = pass same +          reshape bw wins = shape ShapeBounding bw $+			    shape ShapeClip 0 $ sg (bw,wins) where+	     shape kind bw =+	       putSP (Left (kernelTag,+	                      XCmd $+	                      ShapeCombineRectangles +			        kind+				origin+				(map (adj bw.snd) wins) ShapeSet Unsorted))+	  adj bw (lbw,Rect p s) = Rect (p `psub` (Point bw bw))+			               (adjustBorderWidth (lbw+bw) s)+      in case msg of+        Left (tag,cmd) -> +            case cmd of+	      XReq (CreateSimpleWindow stag r) | tag == kernelTag ->+	         pass $ sg (bw,(stag,(border_width,r)):wins)+	      XCmd (ConfigureWindow cws) | tag == kernelTag ->+	         let bw' = fromMaybe bw (getBWidth cws) +		     cws'= filterBorderwidth cws+		 in+		 putSP (Left (tag,XCmd (ConfigureWindow cws'))) $+		 if bw == bw' then same else reshape bw' wins+	      XCmd (ConfigureWindow cws) -> +	         case doConfigure tag wins cws of+		    Nothing -> passame+		    Just wins' -> pass $ reshape bw wins'+	      XCmd DestroyWindow ->+		 pass $ sg (bw,filter ((/=tag).fst) wins)+	      _ -> passame+        _ -> passame+
+ hsrc/fudgets/BellF.hs view
@@ -0,0 +1,9 @@+module BellF where+import NullF(getF,putF)+import Command+import Xcommand++bellF = getF $ \ x ->+ 	xcommandF (Bell 0) $+	putF x $+ 	bellF
+ hsrc/fudgets/Border3dF.hs view
@@ -0,0 +1,146 @@+module Border3dF(border3dF) where+--import ButtonGroupF+import Color+import Command+import XDraw+import CompOps((>^=<))+import Defaults(bgColor, shadowColor, shineColor,new3d)+--import CmdLineEnv(argFlag)+import Dlayout(groupF)+import Event+import Fudget+--import FudgetIO+import FRequest+import Xcommand+import Gc+import Geometry(Point(..), origin, pP)+import GreyBgF(changeBg)+import LayoutRequest+--import Message(Message(..))+import NullF+import Spacer(marginF)+import EitherUtils(stripEither)+import Utils(swap)+import Xtypes+import GCtx(wCreateGCtx,GCtx(..))+import GCAttrs(gcFgA)++border3dF =+  if new3d+  then newBorder3dF+  else oldBorder3dF+ +newBorder3dF :: Bool -> Int -> F a b -> F (Either Bool a) b+newBorder3dF down edgew f =+    stripEither >^=< ((groupF startcmds kernel . marginF edgew) f)+  where+    startcmds =+      [XCmd $ ChangeWindowAttributes [CWEventMask [ExposureMask],+	                              CWBitGravity NorthWestGravity]]+				      -- bit gravity reduces flicker on resize++    wCreateGC gc0 gcas cont =+       wCreateGCtx (GC gc0 undefined) gcas $ \ (GC gc _) -> cont gc+    gcFg x = wCreateGC rootGC $ gcFgA x+    kernel =+      changeBg bgColor $+      gcFg shineColor $ \ whiteGC ->+      gcFg "black" $ \ blackGC ->+      gcFg [shadowColor,"black"] $ \ shadowGC ->+      let dRAW s pressed =+	    let lrc@(Point w h) = s-1+		ulc = 0; llc = pP 0 h; urc = pP w 0+		uli = 1; lli = llc+nw; lri = lrc-1; uri = urc-nw+		nw = pP 1 (-1)+		upper1 = [llc,ulc,urc]+		upper2 = [lli,uli,uri]+		lower1 = [llc,lrc,urc]+		lower2 = [lli,lri,uri]+	    in if pressed+	       then draw lower1 upper1 upper2+	       else draw upper1 lower1 lower2+	  drawlines gc ls = (gc,[DrawLines CoordModeOrigin ls])+	  draw wls bls dls =+	       [ClearWindow,+		DrawMany MyWindow [+		 drawlines shadowGC dls,+		 drawlines whiteGC wls,+		 drawlines blackGC bls]]+	  proc pressed size =+	      getK $ \bmsg ->+	      let same = proc pressed size+		  draw = dRAW size+		  redraw = draw pressed+	      in case bmsg of+		   Low (XEvt (Expose _ 0)) -> xcommandsK redraw same+		   Low (LEvt (LayoutSize newsize)) | newsize/=size ->+		     xcommandsK (dRAW newsize pressed) $ +		     -- redraw needed here because of bit gravity+		     proc pressed newsize+		   High change | change/=pressed ->+		     xcommandsK (draw change) (proc change size)+		   _ -> same+	  proc0 pressed =+	      getK $ \msg ->+	      case msg of+		Low (LEvt (LayoutSize size)) -> proc pressed size+		High change -> proc0 change+		_ -> proc0 pressed+      in proc0 down++oldBorder3dF :: Bool -> Int -> F a b -> F (Either Bool a) b+oldBorder3dF down edgew f =+    stripEither >^=< ((groupF startcmds kernel . marginF edgew) f)+  where+    startcmds =+      [XCmd $ ChangeWindowAttributes [CWEventMask [ExposureMask],+	                              CWBitGravity NorthWestGravity]]+				      -- bitgravity reduces flicker on resize+    kernel =+      changeBg bgColor $+      allocNamedColorPixel defaultColormap shineColor $ \shine ->+      allocNamedColorPixel defaultColormap shadowColor $ \shadow ->+      wCreateGC rootGC [GCFunction GXcopy,+			GCForeground shadow] $ \shadowGC ->+      wCreateGC shadowGC [GCForeground shine] $ \shineGC ->+      let dRAW s pressed =+	    let lrc@(Point w h) = s+		e = edgew+		ulc = origin+		urc = pP w 0	-- pP (w - 1) 0+		llc = pP 0 h	-- pP 0 (h - 1)+		uli = pP e e+		lli = pP e (h - edgew)+		lri = pP (w - edgew) (h - edgew)+		uri = pP (w - edgew) e+		upper = [ulc, urc, uri, uli, lli, llc]+		lower = [llc, lrc, urc, uri, lri, lli]+		(upperGC, lowerGC) = (if pressed+				      then swap+				      else id) (shineGC, shadowGC)+	    in [ClearWindow,+		DrawMany MyWindow [+		  (lowerGC,[FillPolygon Nonconvex CoordModeOrigin lower]),+		  (upperGC,[FillPolygon Nonconvex CoordModeOrigin upper])]]+	  proc pressed size =+	      getK $ \bmsg ->+	      let same = proc pressed size+		  draw = dRAW size+		  redraw = draw pressed+	      in case bmsg of+		   Low (XEvt (Expose _ 0)) -> xcommandsK redraw same+		   Low (LEvt (LayoutSize newsize)) ->+		     if newsize==size+		     then same+		     else xcommandsK (dRAW newsize pressed) $ +			  -- redraw needed here because of bit gravity+			  proc pressed newsize+		   High change -> xcommandsK (draw change) (proc change size)+		   _ -> same+	  proc0 pressed =+	      getK $ \msg ->+	      case msg of+		Low (LEvt (LayoutSize size)) -> proc pressed size+		High change -> proc0 change+		_ -> proc0 pressed+      in proc0 down
+ hsrc/fudgets/ButtonBorderF.hs view
@@ -0,0 +1,95 @@+module ButtonBorderF(buttonBorderF) where+--import BgF+import Border3dF+--import ButtonGroupF+import Color+import Command(XCommand(ChangeWindowAttributes,ClearArea,DrawMany,Draw))+import XDraw+import CompOps((>^=<))+import Defaults(look3d, shadowColor, shineColor,bgColor)+import Dlayout(groupF)+import Event+import Fudget+--import FudgetIO+import FRequest+import Xcommand+import Gc+import Geometry(Line(..), Point(..), Rect(..), origin, pP, padd, psub)+import LayoutRequest+--import Message(Message(..))+import NullF+import Spacer(marginF)+import EitherUtils(stripEither)+import Xtypes+import GreyBgF(changeBg)++buttonBorderF :: Int -> F a b -> F (Either Bool a) b+buttonBorderF = if look3d then border3dF False else stdButtonBorderF++stdButtonBorderF edgew f =+    let kernel =+          changeBg bgColor $+	  allocNamedColorDefPixel defaultColormap shineColor "white" $ \shine->+	  allocNamedColorDefPixel defaultColormap shadowColor "black" $ \shadow ->+	  wCreateGC rootGC [GCFunction GXcopy, GCForeground shadow,+			    GCBackground shine] $ \drawGC ->+	  wCreateGC drawGC [GCForeground shine] $ \shineGC ->+	  wCreateGC rootGC (invertColorGCattrs shine shadow) $ \invertGC ->+	  let bpx = edgew+	      bpy = edgew+	      upperLeftCorner = Point bpx bpy+	      dRAW s = +		 let size@(Point sx sy) = psub s (Point 1 1)+		     rect = Rect origin size+		     upperRightCorner = Point (sx - bpx) bpy+		     lowerLeftCorner = Point bpx (sy - bpy)+		     lowerRightCorner = psub size upperLeftCorner+		     leftBorder = Line upperLeftCorner lowerLeftCorner+		     upperBorder = Line upperLeftCorner upperRightCorner+		     upperLeftLine = Line origin upperLeftCorner+		     lowerRightLine = Line lowerRightCorner size+		     incx = padd (Point 1 0)+		     incy = padd (Point 0 1)+		     decx = padd (Point (-1) 0)+		     decy = padd (Point 0 (-1))+		     lowerBorderPoints = [lowerLeftCorner, lowerRightCorner, +					  upperRightCorner, Point sx 0, size, Point 0 sy]+		     borderPoints =+		       [pP 1 1, pP 1 sy, size, pP sx 1, origin, upperLeftCorner, +		        incy lowerLeftCorner, (incx . incy) lowerRightCorner, +			incx upperRightCorner, upperLeftCorner]+		 in  ( [ClearArea rect False, +		        DrawMany MyWindow [+			  (shineGC,[FillPolygon Nonconvex CoordModeOrigin+			            borderPoints]),+			  (drawGC,[FillPolygon Nonconvex CoordModeOrigin +			           lowerBorderPoints, +			           DrawLine leftBorder, +			           DrawLine upperBorder, +			           DrawLine upperLeftLine]), +			  (invertGC,[DrawLine lowerRightLine]), +			  (drawGC,[DrawRectangle rect])]], +			 [Draw MyWindow invertGC $ FillPolygon Nonconvex +				  CoordModeOrigin borderPoints])+	      proc pressed size =+		  getK $ \bmsg ->+		  let same = proc pressed size+		      (drawit_size, pressit_size) = dRAW size+		      redraw b = if b == pressed then [] else pressit_size+		  in  case bmsg of+			Low (XEvt (Expose _ 0)) -> xcommandsK (drawit_size ++ +			    (if pressed then pressit_size else [])) same+			Low (LEvt (LayoutSize newsize)) -> proc pressed newsize+			High change -> xcommandsK (redraw change) (proc change size)+			_ -> same+	      proc0 pressed =+		  getK $ \msg ->+		  case msg of+		    Low (LEvt (LayoutSize size)) -> proc pressed size+		    High change -> proc0 change+		    _ -> proc0 pressed+	  in  proc0 False++        startcmds = [XCmd $ ChangeWindowAttributes [CWEventMask [ExposureMask]]]+    in  stripEither >^=< ((groupF startcmds kernel . marginF (edgew + 1)) f)+
+ hsrc/fudgets/ButtonF.hs view
@@ -0,0 +1,40 @@+module ButtonF(oldButtonF) where+import CompOps((>^^=<),(>=^<))+--import Defaults(argKey, bgColor, fgColor)+import GraphicsF(graphicsDispF',replaceAllGfx,setGfxEventMask)+import FDefaults+import Sizing(Sizing(..))+import Drawing() -- instance, for hbc+import Graphic()+--import GCAttrs+--import GCtx(wCreateGCtx,rootGCtx)+import DrawingUtils+--import FDefaults+import PushButtonF+--import Placer(spacerF)+import Spacers(marginS,compS)+import Alignment(aCenter)+import CondLayout(alignFixedS')+import SpEither(filterRightSP)+--import Xtypes+--import NullF()+--import FudgetIO()++-- All this just because of the !@?! monomorphism restriction+--import Fudget(F)+--import GraphicsF(GfxEvent)+--import MeasuredGraphics(DPath)+--import DrawingUtils --(Gfx)++oldButtonF halign margin fname bg fg keys lbl =+    filterRightSP >^^=< pushButtonF keys lblF+ where+   --lblF :: Graphic lbl => F lbl (GfxEvent DPath) -- the monorestr+   lblF = let --lblD :: Graphic lbl => lbl -> Drawing a Gfx -- the monorestr+	      lblD = spacedD spacer . g+	      custom x = setInitDisp (lblD lbl) .+	               setGfxEventMask [] . setSizing Static .+		       setBorderWidth 0 . setBgColorSpec bg .+		       setFont fname . setFgColor fg $ x+              spacer = marginS margin `compS` alignFixedS' halign aCenter+	  in graphicsDispF' custom >=^< replaceAllGfx . lblD
+ hsrc/fudgets/ButtonGroupF.hs view
@@ -0,0 +1,121 @@+module ButtonGroupF(+	buttonGroupF, menuButtonGroupF,+	--buttonMachineF,+	BMevents(..))+where+import Command+import CompOps((>=^<))+import Defaults(bgColor)+import Dlayout(groupF)+import Event+import Fudget+import FRequest+import Xcommand+--import Geometry(Line, Point, Rect, Size(..))+import GreyBgF(changeBg)+--import LayoutRequest(LayoutRequest)+import Loops(loopLeftF)+import Message(message) --Message(..),+import NullF+--import SpEither(mapFilterSP)+import Xtypes+import Utils++data BMevents = BMNormal | BMInverted | BMClick  deriving (Eq, Ord, Show)++buttonGroupF     = buttonGroupF' cmdButton+menuButtonGroupF = buttonGroupF' menuButton []++buttonGroupF' bp keys f = loopLeftF (buttonMachineF' bp keys f >=^< Right)++--buttonMachineF = buttonMachineF' cmdButton++buttonMachineF' bp keys = groupF [] (changeBg bgColor (buttonK bp keys))++data ButtonParams =+  BP { modstate :: ModState,+       mbutton :: Button,+       bmachine :: Button -> ModState -> K Bool BMevents }++elbMask = [EnterWindowMask, LeaveWindowMask, ButtonPressMask, ButtonReleaseMask]++cmdButton =+  BP { modstate = [],+       mbutton = Button 1,+       bmachine = buttonMachine }++menuButton =+  BP { modstate = [],+       mbutton = Button 1, -- not used+       bmachine = mbuttonMachine }++buttonMachine mousebutton modstate =+    setEventMask [] $+    xcommandK (GrabButton False mousebutton modstate grabbedMask) $+    bm BMNormal+  where+    grabbedMask = elbMask+    switch newme = putK (High newme) (bm newme)+    pressed = switch BMInverted+    normal = switch BMNormal+    clicked = putsK [High BMNormal, High BMClick] (bm BMNormal)+    changeMode =+	-- switch to menu button mode+	xcommandK (UngrabButton mousebutton modstate) $+	mbuttonMachine mousebutton modstate+    bm me =+      let nochange = bm me+      in getK $ \msg ->+	 case msg of+	   Low (XEvt event) ->+	     case event of+	       (EnterNotify {detail=d}) | d /= NotifyInferior -> pressed+	       (LeaveNotify {detail=d}) | d /= NotifyInferior -> normal+	       (ButtonEvent {state=s,type'=Pressed,button=b})+	         | b == mousebutton && modstate `issubset` s -> pressed+	       (ButtonEvent {type'=Released,button=b})+	         | b == mousebutton -> if me == BMInverted+	                               then clicked+				       else nochange+	       (MenuPopupMode True) -> changeMode+	       _ -> nochange+	   High True -> changeMode+	   _ -> nochange++mbuttonMachine mousebutton modstate =+    setEventMask elbMask $+    loop+  where+    loop = getK $ message low high+    out e = putK (High e) loop+    normal = out BMNormal+    pressed = out BMInverted+    clicked = out BMClick++    low (XEvt ev) = event ev+    low _ = loop+    event (ButtonEvent {type'=Released}) = clicked+    event (EnterNotify {}) = pressed+    event (LeaveNotify {}) = normal+    event (MenuPopupMode False) = buttonMachine mousebutton modstate+    event _ = loop++    high False = buttonMachine mousebutton modstate+    high _ = loop++buttonK :: ButtonParams -> [(ModState, KeySym)] -> K Bool BMevents+buttonK (BP {mbutton=mbutton, modstate=modstate, bmachine=bmachine }) keys =+    xcommandsK initcmds $ bmachine mbutton modstate+  where+    initcmds = transinit ++ [MeButtonMachine]++    transinit =+	if null keys+	then []+	else [TranslateEvent tobutton [KeyPressMask, KeyReleaseMask]]++    tobutton (KeyEvent t p1 p2 s pressed _ ks _) | (s, ks) `elem` keys =+	Just (ButtonEvent t p1 p2 modstate pressed mbutton)+    tobutton _ = Nothing++setEventMask mask = xcommandK (ChangeWindowAttributes [CWEventMask mask])
+ hsrc/fudgets/DButtonF.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE CPP #-}+module DButtonF(+  ButtonF,buttonF,buttonF',buttonF'',setLabel+  ) where+import FDefaults+import ButtonF(oldButtonF)+--import Fudget+--import Geometry(Rect)+import PushButtonF(Click)+import Xtypes+import Defaults(buttonFont,fgColor,bgColor)+import CmdLineEnv(argKeyList)+import CompOps((>^=<),(>=^^<))+--import Spops(concmapSP)+import SpEither(mapFilterSP)--filterRightSP+import EitherUtils(stripEither)+import SerCompF(idRightF)+import Spacers(Distance(..))+import Alignment(aCenter) --,Alignment(..)+import Graphic+import GCAttrs --(ColorSpec,colorSpec) -- + instances++#include "defaults.h"++newtype ButtonF lbl = Pars [Pars lbl]+data Pars lbl+  = FontSpec FontSpec+  | Keys [(ModState, KeySym)]+  | FgColorSpec ColorSpec+  | BgColorSpec ColorSpec+  | Margin Distance+  | Align Alignment+  | Label lbl++parameter_instance1(FontSpec,ButtonF)+parameter_instance1(Keys,ButtonF)+parameter_instance1(FgColorSpec,ButtonF)+parameter_instance1(BgColorSpec,ButtonF)+parameter_instance1(Margin,ButtonF)+parameter_instance1(Align,ButtonF)+parameter(Label)++buttonF s = buttonF' standard s+buttonF' pm s = noPF $ buttonF'' pm s++buttonF'' ::+  Graphic lbl => Customiser (ButtonF lbl) -> lbl -> PF (ButtonF lbl) Click Click+buttonF'' pmod s =+    stripEither >^=<+    idRightF (oldButtonF align marg font bg fg keys lbl >=^^< mapFilterSP relbl)+  where+    lbl  = getLabel ps+    font = getFontSpec ps+    keys = getKeys ps+    ps   = pmod ps0+    bg   = getBgColorSpec ps+    fg   = getFgColorSpec ps+    marg = getMargin ps+    align = getAlign ps+    ps0  = Pars [FontSpec (fontSpec buttonFont), Keys [],Margin 2,Align aCenter,+		 FgColorSpec buttonfg, BgColorSpec buttonbg, Label s]+    --relbl pmod' = [lbl | let Pars ps'=pmod' (Pars []), Label lbl<-ps']+    relbl pmod' = getLabelMaybe (pmod' (Pars []))++buttonbg = colorSpec (argKeyList "buttonbg" [bgColor,"white"])+buttonfg = colorSpec (argKeyList "buttonfg" [fgColor,"black"])
+ hsrc/fudgets/DDisplayF.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE CPP #-}+module DDisplayF(--HasInitDisp(..),+		 setSpacer,+		 DisplayF,+                 displayF,displayF',--displayF'',+                 intDispF,intDispF',--intDispF'',+                 labelF,labelF' --,labelF''+		) where+import FDefaults+import GraphicsF(graphicsDispF',replaceAllGfx,setGfxEventMask)--GfxCommand+import Graphic+import Drawing() -- instances+import DrawingUtils(spacedD,g)--vboxD,blankD,hardAttribD,+import GCAttrs --(ColorSpec,colorSpec) -- + instances+--import GCtx(GCtx(..),wCreateGCtx,rootGCtx)+--import EitherUtils(mapEither)+--import FudgetIO+--import Fudget+import NullF(F)+--import Xtypes+import ResourceIds() -- synonym ColorName, for hbc+import Defaults(defaultFont,labelFont,paperColor,fgColor,bgColor)+import CmdLineEnv(argKeyList)+import CompOps((>=^^<),(>=^<),(>^^=<))+import CompSP(idLeftSP)+import Spops(nullSP)+import SpEither(filterRightSP)+import Alignment(aRight,aLeft,aCenter)+--import AlignF(noStretchF)+--import LoadFont(safeLoadQueryFont)+--import Font(string_box_size)+import Spacers(marginS,compS,hAlignS)--minSizeS,noStretchS,+import LayoutRequest(Spacer)+import Sizing(Sizing(..))+import CondLayout(alignFixedS')+--import Maybe(fromMaybe)++#include "defaults.h"++newtype DisplayF a = Pars [Pars a]++data Pars a+  = BorderWidth Int+  | FgColorSpec ColorSpec+  | BgColorSpec ColorSpec+  | FontSpec FontSpec+--  | Align Alignment+  | Spacer Spacer+  | Margin Int+  | InitDisp a+  | InitSize a+  | Sizing Sizing+  | Stretchable (Bool,Bool)+-- Don't forget to adjust instance Functor DisplayF above if you add stuff here!++type StringDisplayF = DisplayF String++parameter_instance1(BorderWidth,DisplayF)+parameter_instance1(FgColorSpec,DisplayF)+parameter_instance1(BgColorSpec,DisplayF)+parameter_instance1(FontSpec,DisplayF)+--parameter_instance1(Align,DisplayF)+parameter_instance1(Margin,DisplayF)++parameter_instance(InitDisp,DisplayF)+parameter(Spacer)+parameter_instance(InitSize,DisplayF)+parameter_instance1(Stretchable,DisplayF)+parameter_instance1(Sizing,DisplayF)++-- For backwards compatibility:+instance HasAlign (DisplayF a) where+  setAlign align (Pars ps) = Pars (Spacer (alignFixedS' align aCenter):ps)++labelDisplayF :: Graphic g => F g void -- because of monomorphism restriction+labelDisplayF = labelDisplayF' standard+labelDisplayF' pm = noPF $ labelDisplayF'' pm++labelDisplayF''+  :: Graphic g => Customiser (DisplayF g) -> PF (DisplayF g) g void+labelDisplayF'' pmod = +    nullSP >^^=<+    graphicsDispF' custom >=^<+    pre >=^^<+    filterRightSP+  where+    custom =+     	maybe id (setInitDisp . draw) initDisp .+	maybe id (setInitSize . draw) initSize .+	setGfxEventMask [] . setSizing sizing .+	setBorderWidth borderWidth . setBgColorSpec bgColor .+	setFont font . setFgColorSpec fgColor .+	setStretchable stretch+    pre = replaceAllGfx . draw +    draw = marginD . g+    marginD = spacedD (marginS margin `compS` spacer)++    margin = getMargin ps+    borderWidth = getBorderWidth ps+    bgColor = getBgColorSpec ps+    fgColor = getFgColorSpec ps+    font = getFontSpec ps+    spacer = getSpacer ps+    stretch = getStretchable ps+    sizing = getSizing ps+    initSize = getInitSizeMaybe ps+    initDisp = getInitDispMaybe ps+    ps = pmod (Pars [Margin 4,BorderWidth 0,+                     FgColorSpec dispfg, BgColorSpec dispbg,+		     FontSpec (fontSpec defaultFont),+		     Spacer (alignFixedS' aLeft aCenter),+		     Stretchable (False,False),+		     Sizing Dynamic{-,InitSize "",InitDisp ""-}])++displayF :: Graphic g => F g void -- because of monomorphism restriction+displayF = displayF' standard+displayF' custom = noPF $ displayF'' custom++displayF'' :: Graphic g => Customiser (DisplayF g) -> PF (DisplayF g) g void+displayF'' pmod = labelDisplayF'' pmod'+  where+    pmod' = pmod .+            --setInitSize "XXXXX" .+	    setBorderWidth 1 .+	    setStretchable (True,False) .+	    setSpacer (hAlignS aLeft) .+	    setSizing Growing+++labelF lbl = labelF' standard lbl+labelF' pm = noPF . labelF'' pm++labelF'' :: Graphic g => Customiser (DisplayF g) -> g -> PF (DisplayF g) a b+labelF'' pmod lbl = labelDisplayF'' pmod' >=^^< idLeftSP nullSP+  where+   pmod' = pmod.+	   setInitDisp lbl.+           (setFgColor lblfg::(Customiser (DisplayF g))).+	   setBgColor lblbg.+	   setFont labelFont.+	   setMargin 0 .+	   setSizing Static++-- cu works around a deficiency in the type inference algorithm.+-- cu x y = id x y :: (Customiser (DisplayF a))++intDispF = intDispF' standard+intDispF' = noPF . intDispF''+intDispF'' :: Customiser (DisplayF Int) -> PF (DisplayF Int) Int a+intDispF'' pm = displayF'' (pm' 0) -- >=^< mapEither id show+  where pm' x = pm.setAlign aRight+                  .setInitDisp x+		  .setInitSize ((-maxBound) `asTypeOf` x)+--	 	  .forgetInitDisp -- should be built into setInitDisp+                  .(setSizing Static::(Customiser (DisplayF Int)))+		  .setStretchable (False,False)++dispbg = colorSpec (argKeyList "dispbg" [paperColor,"white"])+dispfg = colorSpec (argKeyList "dispfg" [fgColor,"black"])++lblbg = colorSpec (argKeyList "lblbg" [bgColor,"white"])+lblfg = colorSpec (argKeyList "lblfg" [fgColor,"black"])++{-+forgetInitDisp :: DisplayF a -> DisplayF b+forgetInitDisp (Pars ps) = Pars (forget ps)+  where+    forget ps =+      case ps of+	[] -> []+	BorderWidth i:ps -> BorderWidth i:forget ps+	FgColor c:ps -> FgColor c:forget ps+	BgColor c:ps -> BgColor c:forget ps+	Font f:ps -> Font f:forget ps+	Align a:ps -> Align a:forget ps+	Margin i:ps -> Margin i:forget ps+	InitDisp x:ps -> forget ps+	InitSize s:ps -> InitSize s:forget ps+	Sizing s:ps -> Sizing s:forget ps+	Stretchable bb:ps -> Stretchable bb:forget ps+    +-}++{-+instance Functor DisplayF where+  map f (Pars ps) = Pars (map (mapPars f) ps)+    where+      mapPars f p =+	case p of+	  BorderWidth i -> BorderWidth i+	  FgColor c -> FgColor c+	  BgColor c -> BgColor c+	  Font f -> Font f+	  Align a -> Align a+	  Margin i -> Margin i+	  InitDisp x -> InitDisp (f x)+	  InitSize s -> InitSize s+	  Sizing s -> Sizing s+	  Stretchable bb -> Stretchable bb+-}
+ hsrc/fudgets/DRadioF.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE CPP #-}+module DRadioF(+  RadioGroupF,radioGroupF,radioGroupF',+  setPlacer+  ) where+import FDefaults+import RadioF(radioF)+import DToggleButtonF(HasLabelInside(..))+import NullF(F)+import LayoutRequest(Placer)+import Spacers() -- synonym Distance, for hbc+import Placers2(verticalLeftP')+--import Xtypes+import ResourceIds() -- synonym FontName, for hbc+import Defaults(buttonFont)+import Graphic+import GCAttrs --(FontSpec,fontSpec)++#include "defaults.h"++newtype RadioGroupF = Pars [Pars]+data Pars = LabelInside Bool | FontSpec FontSpec | Placer Placer++parameter(Placer)+parameter_instance(LabelInside,RadioGroupF)+parameter_instance(FontSpec,RadioGroupF)++radioGroupF lbl = radioGroupF' standard lbl++radioGroupF' :: (Graphic lbl,Eq alt )=> Customiser RadioGroupF -> [(alt,lbl)] -> alt -> F alt alt+radioGroupF' pmod alts startalt = +    radioF placer inside font alts startalt+  where+    placer  = getPlacer ps+    inside  = getLabelInside ps+    font    = getFontSpec ps+    ps      = pmod ps0+    ps0     = Pars [LabelInside False,FontSpec (fontSpec buttonFont),Placer placer0]+    placer0 = verticalLeftP' 0
+ hsrc/fudgets/DStringF.hs view
@@ -0,0 +1,44 @@+module DStringF(+  stringF,stringF',--stringF'',+  passwdF,passwdF',passwdF'',+  intF,intF',intF''+  ,stringInputF,intInputF,passwdInputF+  ,stringInputF',intInputF',passwdInputF'+  ) where+import FDefaults+import StringF+--import Fudget+import CompOps+--import Geometry(Rect)+--import Xtypes+--import SpEither(filterRightSP)+import InputMsg(InputMsg,mapInp)+import InputSP(inputDoneSP)--InF(..),+import EitherUtils(mapEither)+import Data.Char(isDigit)++stringInputF = stringInputF' standard+intInputF = intInputF' standard+passwdInputF = passwdInputF' standard+stringInputF' pmod = inputDoneSP >^^=< stringF' pmod+intInputF' pmod = inputDoneSP >^^=< intF' pmod+passwdInputF' pmod = inputDoneSP >^^=< passwdF' pmod++stringF = stringF' standard+stringF' = noPF . stringF''++passwdF = passwdF' standard+passwdF' = noPF . passwdF''+passwdF'' = stringF'' . (.setShowString (map (const '*')))++intF = intF' standard+intF' = noPF . intF''++intF'' :: (Customiser StringF) -> PF StringF Int (InputMsg Int)+intF'' pmod = mapInp read' >^=<+              stringF'' (pmod.pm) >=^<+	      mapEither id show+  where+    pm = setAllowedChar isDigit -- . setInitSize "1999999999"+    read' "" = 0+    read' s = read s
+ hsrc/fudgets/DToggleButtonF.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE CPP #-}+module DToggleButtonF(+  HasLabelInside(..),ToggleButtonF,+  toggleButtonF,toggleButtonF' --,toggleButtonF''+  ) where+import FDefaults+import ToggleButtonF(oldToggleButtonF')+import NullF(F)+import Xtypes+import Defaults(buttonFont)+import Graphic+import GCAttrs --(FontSpec,fontSpec) -- + instances++#include "defaults.h"++newtype ToggleButtonF = Pars [Pars]+data Pars = LabelInside Bool | FontSpec FontSpec | Keys [(ModState, KeySym)]++parameter_class(LabelInside,Bool)++parameter_instance(LabelInside,ToggleButtonF)+parameter_instance(FontSpec,ToggleButtonF)+parameter_instance(Keys,ToggleButtonF)++toggleButtonF lbl = toggleButtonF' standard lbl++toggleButtonF' :: (Graphic lbl)=> Customiser ToggleButtonF -> lbl -> F Bool Bool+toggleButtonF' pmod lbl = +    oldToggleButtonF' inside font keys lbl+  where+    inside = getLabelInside ps+    font   = getFontSpec ps+    keys   = getKeys ps+    ps     = pmod ps0+    ps0    =  Pars [LabelInside False,FontSpec (fontSpec buttonFont), Keys []]
+ hsrc/fudgets/DialogF.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE CPP #-}+module DialogF(inputPopupOptF, inputPopupF, passwdPopupOptF,+               passwdPopupF, stringPopupOptF, stringPopupF,+	       confirmPopupF, ConfirmMsg(..),+	       oldConfirmPopupF, oldMessagePopupF,+               messagePopupF) where+import Spacer(marginHVAlignF,marginF)+import Alignment+import PushButtonF(Click(..))+import DButtonF+import FDefaults+import CompOps+import CompSP(preMapSP)+import Defaults(labelFont,bgColor,defaultSep)--buttonFont,fgColor,+import CmdLineEnv(argFlag)+import DDisplayF+import PopupF(popupShellF)+import Fudget+import Geometry(pP)+import Spops+import SpEither(filterJustSP,filterRightSP)+import StringF+import InputF(InF(..))+import InputMsg(ConfirmMsg(..),toConfirm,fromConfirm,InputMsg(..),inputLeaveKey)+--import EitherUtils(isM)+import Data.Maybe(isJust,maybeToList)+--import TextF(textF')+--import ListRequest(replaceAll)+--import NullF(startupF)+import Placer(vBoxF,hBoxF)+import AutoPlacer(autoP')+import Sizing+import Xtypes() -- synonyms, for hbc+import Graphic -- instances (+ class Graphic, because of the monomorphism restr)+import Drawing+import GCAttrs() -- instances++default(Int)++oldMessagePopupF = popupShellF "Message" Nothing (labelabove 50 ok >=^< Left)+oldConfirmPopupF = popupShellF "Confirm" Nothing (labelabove 50 confirm >=^< Left)++-- Grr! Type signatures required because of the mononorphism restriction+confirmPopupF :: Graphic msg => F msg (msg,ConfirmMsg)+messagePopupF :: Graphic msg => F msg (msg,Click)+confirmPopupF = msgPopupF confirm+messagePopupF = msgPopupF ok++msgPopupF buttons =+    popupShellF "Confirm" Nothing+      (filterRightSP>^^=< vBoxF (msgF>+<buttons)>=^<Left . layoutfix)+  where+#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)+    msgF :: Graphic a => F (Drawing lbl a) b+#endif+    msgF = marginHVAlignF 5 aCenter aCenter $ displayF' pm+     where pm = setBgColor [bgColor,"white"] . setSizing Dynamic .+		setFont labelFont . setBorderWidth 0+    layoutfix = PlacedD (autoP' (pP defaultSep 0)) . AtomicD++genStringPopupOptF title inp default' =+    inputPopupOptF title (inp default') (Just default')++genStringPopupF title inp default' =+    filterMaybePairF (genStringPopupOptF title inp default')++stringPopupOptF = genStringPopupOptF "String Entry" oldStringF+stringPopupF default' = filterMaybePairF (stringPopupOptF default')++passwdPopupOptF = genStringPopupOptF "Password Entry" oldPasswdF+passwdPopupF default' = filterMaybePairF (passwdPopupOptF default')++inputPopupOptF :: String -> InF a b -> Maybe b -> F (Maybe String, Maybe a) ((Maybe String, Maybe a), Maybe b)+inputPopupOptF title f default' =+    let stringconfirm =+            (filterDoneSP default' >^^=< vBoxF (f >+< confirm')) >=^< Left+    in  popupShellF title+		   Nothing+		   (marginF 5 ((labelabove 50 stringconfirm >=^^< distPairSP)))++inputPopupF title f def = filterMaybePairF (inputPopupOptF title f def)++button k s = buttonF' (setKeys [([],k)]) s++button' k s =+  if argFlag "okkey" False+  then button k s+  else buttonF s+       -- This is a fix for the problem that when you press return in a+       -- stringPopupF, the next time the popup appears the string in it+       -- isn't selected.++#ifdef __HUGS__+label :: F String a -- for Hugs+#endif+label = displayF' pm+  where pm = setBorderWidth 0 . setBgColor [bgColor,"white"].setFont labelFont++ok = marginHVAlignF 0 aLeft aBottom (button "Return" "OK")+ok' = marginHVAlignF 0 aLeft aBottom (button' "Return" "OK")+cancel = marginHVAlignF 0 aRight aBottom (button "Escape" "Cancel")++confirm = toConfirm >^=< hBoxF (ok >+< cancel) >=^< fromConfirm+confirm' = toConfirm >^=< hBoxF (ok' >+< cancel) >=^< fromConfirm++labelabove len f = filterRightSP >^^=< vBoxF (label >+< f)++filterMaybePairF :: (F a (b, Maybe c)) -> F a (b, c)+filterMaybePairF f = preMapSP filterJustSP liftOpt >^^=< f++liftOpt (x, Nothing) = Nothing+liftOpt (x, Just y) = Just (x, y)++distPairSP = concmapSP (\(x, y) -> otol Left x ++ otol Right y)+  where otol f = maybeToList . fmap f++filterDoneSP =+    let fd s =+            getSP $ \msg ->+            let same = fd s+            in case msg of+	         Right Confirm -> if isJust s then putSP s same else same+		 Right Cancel -> putSP Nothing same+		 Left (InputChange s') -> fd (Just s')+		 Left (InputDone k s') | k /= inputLeaveKey -> putSP (Just s') $+                                                              fd (Just s')+                 Left _ -> same+    in  fd++#ifdef __NHC__+-- nhc bug workaround+blaha=undefined::DisplayF+#endif
+ hsrc/fudgets/Edit.hs view
@@ -0,0 +1,362 @@+{-# LANGUAGE CPP #-}+module Edit(EditStop(..),editF, EditEvt(..), EditCmd(..)) where+import BgF+import Color+import Command+import DrawInWindow+import XDraw(clearArea)+import Defaults(inputFg, inputBg)+import CmdLineEnv(argReadKey, argKey)+import Dlayout(windowF)+import Edtypes+import Editfield+import Event+import Font+import Fudget+import FRequest+import Gc+import Geometry+import LayoutRequest(plainLayout,LayoutResponse(..))+import Message(message) --Message(..),+import NullF+import StateMonads+import Control.Monad(when)+import HbcUtils(apSnd)+import Xtypes+import UndoStack+import TryLayout+import Expose+import Maptrace+import GCAttrs(convFontK,fontdata2struct,FontSpec) -- instances+import InputMsg(InputMsg(InputChange))++default (Int) -- mostly for Hugs++data EditStop = +     EditStopFn EditStopFn +   | EditPoint Point +   | EditLine EDirection++data EditCmd = +     EditShowCursor Bool+   | EditMove EditStop IsSelect+   | EditReplace String+   | EditGetText+   | EditGetField+   | EditGetSelection+   | EditUndo+   | EditRedo +     +data EditEvt+    = EditText String+    | EditField (String,String,String)+    | EditCursor Rect+    | EditChange (InputMsg String)+    deriving (Eq, Ord)++godir wanted current = if wanted < current then ELeft else ERight++toedstop :: (a ->String->String->(a,Maybe EDirection)) -> a -> EditStopFn+toedstop sf st b a = case sf st b a of+		      (_,Nothing) -> EdStop+		      (st',Just dir) -> EdGo dir (toedstop sf st')++notnull = not . null++inputbg = argKey "editbg" inputBg+inputfg = argKey "editfg" inputFg++selectbg = argKey "selectbg" inputfg+selectfg = argKey "selectfg" inputbg++editF :: FontSpec -> F EditCmd EditEvt+editF fontspec =+  let eventmask = [ExposureMask]+      startcmds = [XCmd $ ChangeWindowAttributes [CWBitGravity NorthWestGravity,+						  CWEventMask eventmask]]+  in  windowF startcmds (editK fontspec)++splitwith c [] = (([], False), [])+splitwith c (a : b) =+    if a == c+    then (([], True), b)+    else let ((x, g), y) = splitwith c b+	 in  ((a : x, g), y)++splitwithnl = splitwith newline+tabstop = 8+untab t s =+    case s of+      '\t':s -> let t' = (t `div` tabstop + 1) * tabstop+		in spaces (t'-t) ++ untab t' s+      c:s -> c:untab (if c == newline then 0 else (t+1)) s+      [] -> []++spaces n = replicate n ' '++editK fontspec = +  convFontK fontspec $ \ fd ->+  fontdata2struct fd $ \ font ->+  changeGetBackPixel inputbg $ \bg -> +  allocNamedColorPixel defaultColormap inputfg $ \fg -> +  allocNamedColorPixel defaultColormap selectbg $ \sbg -> +  allocNamedColorPixel defaultColormap selectfg $ \sfg -> +  let fid = font_id font+      creategcs fg bg cont =+	wCreateGC rootGC [GCFunction GXcopy, GCFont fid,+			 GCForeground fg, GCBackground bg] $ \gc ->+	wCreateGC gc [GCForeground bg, GCBackground fg] $ \igc -> cont (gc,igc)+  in creategcs fg bg $ \drawGCs ->+     creategcs sfg sbg $ \selectGCs ->+     wCreateGC rootGC (invertColorGCattrs bg fg) $ \invertGC -> +  let drawimagestring =+	if snd (font_range font) > '\xff'+	then wDrawImageString16+	else wDrawImageString+      getCurp = apSnd (eolx.fst) . getLnoEdge+      getLCurp = getCurp . setFieldDir ELeft+      getRCurp = getCurp . setFieldDir ERight+      npos = next_pos font+      eolx = npos . reverse . fst . splitnl+      maxrmargin x s =+	if null s+	then x+	else let (l,r) = splitnl s+	     in ctrace "editF1" (s,l,r,npos l) $ (x + npos l) `max` maxrmargin 0 r+      lno = fst+      xp = snd+      p2line (Point x y) = (y `quot` lheight, x - xoffset)+      line2p (l, x) = Point (x + xoffset) (l * lheight)+      lheight = linespace font+      move issel estop =+	do field <- loadField+	   lastpos <- loadLastpos+	   invIfShowCursor+	   let curp = getCurp field+	       stoppoint wantp p@(l, x) bef aft = +		 let dircomp = godir wantp+		     dist p' = abs (lno wantp - lno p') + abs (xp wantp - xp p')+		     dir = dircomp p+		     ahead = if dir == ELeft then bef else aft+		 in case ahead of+		      [] -> (p, Nothing)+		      c:cs -> let p' = if c == newline+				       then (dirint dir + l, if dir == ERight+							     then 0+							     else eolx cs)+				       else (l, x + dirint dir * npos [c])+			      in  (p', if dir == dircomp p'+				       then Just dir+				       else if dist p' < dist p+					    then Just dir+					    else Nothing)+	       mf sf = moveField issel field sf+	       (field', acc) =+		 case estop of+		   EditStopFn stopf -> mf stopf+		   EditPoint p -> let lp = p2line p+				      dir = godir lp curp+				  in  mf (toedstop (stoppoint lp) curp)+		   EditLine dir -> let wantp = (dirint dir + lno curp, xp lastpos)+				   in  mf (toedstop (stoppoint wantp) curp)+	   storeField field'+	   let ol = lno curp+	       nl = lno $ getCurp field'+	   if issel+	      then showlines (min ol nl) (max ol nl)+	      else if notnull (getSelection field)+		   then showSelLines field >> showlines nl nl+		   else invIfShowCursor+      showSelLines field = +	     showlines (lno $ getLCurp field) (lno $ getRCurp field) +      setSize (l,x) =+	  do old@(ol,ox) <- loadTextWidth+	     let new@(_,x') = (l,max x minWidth)+	     when (old /= new) $+	       do storeTextWidth new+		  mtrace ("before trylayout "++show(x,x',ox))+		  x <- toMs $ tryLayoutK $+			 plainLayout (line2p (l,x') `padd` llmargin) True True+		  mtrace "after trylayout"+		  storeSize x+	    where mtrace x = toMsc (ctrace "editF" x)+      replace' s =+	  do field <- loadField+	     size <- loadSize+	     width <- loadWidth+	     let (ll,lx) = getLCurp field+		 uts = untab (length $ fst $ splitnl $ getBef field) s+		 rl = lno $ getRCurp field+		 field' = replaceField field uts+		 nls = nlines uts+		 nldown = nls - (rl - ll)+		 copy src dest h =+		   let srcp = line2p src+		       r = Rect srcp (pP width h)+		   in when (h>0) $+			putLowMs (wCopyArea (fst drawGCs) MyWindow+					    r (line2p dest))+	     (nlines,tw) <- loadTextWidth+	     let changemarg new f = maxrmargin lx (new ++ fst (splitnl (getAft f)))+		 oldm = changemarg (getSelection field) field+		 newm = changemarg uts field'+		 tw' = if newm >= tw+		       then newm+		       else if oldm < tw+			    then tw+			    else maxrmargin 0 (getField field')+		 ss = (getLastLineNo field' + 1, tw')+	     setSize ss+	     storeField' field'+	     us <- loadUndoStack+	     us' <- doit us (field',ss) return+	     storeUndoStack us'+	     when (nldown /= 0) $+		let tleft a = (rl + a + 1, 0)+		    tnl = tleft nldown+		in  copy (tleft 0) tnl (ycoord size - lheight * lno tnl)+	     showlines ll (ll + nls)+      dolines first last doline = du+	 where du s p@(l,x) = let ((line,nl), rest) = splitwithnl s+			      in if l > last || null s then return p+			      else when (l >= first) (doline p (line,nl)) >> +				   du rest (if nl then (l+1,0) else (l,x+npos line))+      showLine (gc,rgc) lp (line, withnl) = +	do let p = line2p lp+	       d = pP 0 (font_ascent font)+	   when (xp lp == 0) $+	     putLowMs (clearArea (rR 0 (ycoord p) xoffset lheight) False)+	   when (notnull line) $+	     putLowMs (drawimagestring gc (p+d) line)+	   when withnl $+	     do width <- loadWidth+		let pc = padd p (pP (npos line) 0)+		    size = Point (width - xcoord pc) lheight+		putLowMs (wFillRectangle rgc (Rect pc size))+      showlines first last =+	  do field <- loadField+	     showc <- loadShowCursor+	     let clno = lno $ getLCurp field+		 sel = getSelection field+		 aft = getAft field+		 takenl n s = let (l,r) = splitnl s+			      in if n <= 0 then l else l++newline:takenl (n-1) r+		 bef = reverse $ takenl (clno-first) $ getBef field+		 show gcs = dolines first last (showLine gcs)+	     show drawGCs bef (clno-nlines bef,0) >>=+		show (if showc then selectGCs else drawGCs) sel >>=+		show drawGCs (aft++[newline]) >>= \_ ->+		when (clno >= first && clno <= last) invIfShowCursor+      showCursor v = do cv <- loadShowCursor+			when (v /= cv ) $+			  do field <- loadField+			     storeShowCursor v+			     if null (getSelection field) then+			       invCursor+			       else showSelLines field+      invIfShowCursor = do cv <- loadShowCursor+			   when cv invCursor+      invCursor = do field <- loadField+		     let lp = getCurp field+			 sel = getSelection field+		     when (null sel) $+		       let p = line2p (apSnd ((-1) +) lp)+			   s = pP 1 lheight+			   cur = Rect p s+		       in  putLowMs (wFillRectangle invertGC cur)+      redraw = do --field <- loadField+		  size <- loadSize+		  putLowMs (clearArea (Rect origin size) True)+      expose r = let Line l1 l2 = rect2line r+		 in showlines (lno (p2line l1)) (lno (p2line l2) + 1)+      undoredo d =+	do us <- loadUndoStack+	   case d us of+	     Nothing -> nopMs+	     Just ((field,size),us') -> do storeUndoStack us'+					   storeField' field+					   setSize size+					   redraw++      storeField' field' =+	do storeField field'+	   putHighMs (EditChange $ InputChange $ getField field')++      puttext' f = do field <- loadField+		      putHighMs (f field)++      puttext f = puttext' (EditText . f)++      putCursor =+        do field <- loadField+	   let lastpos = getCurp field+	   putHighMs (EditCursor $ Rect (line2p lastpos `psub` Point xoffset 0) +					(Point xoffset lheight `padd` llmargin))++      handleLow msg =+	case msg of+	  XEvt (Expose r aft) -> toMs (maxExposeK False r aft) >>= expose+	  XEvt (GraphicsExpose r aft _ _) -> toMs (maxExposeK True r aft) >>= expose+	  LEvt (LayoutSize s) -> storeSize s+          _ -> nopMs++      handleHigh cmd =+	do case cmd of+	     EditShowCursor s -> showCursor s+	     EditMove estop issel -> move issel estop+	     EditReplace s -> replace' s+	     EditGetText -> puttext getField+	     EditGetField -> puttext' (EditField . getField')+	     EditGetSelection -> puttext getSelection+	     EditUndo -> undoredo undo+	     EditRedo -> undoredo redo+	   putCursor+	   field <- loadField+	   let lastpos = getCurp field+	   case cmd of+	     EditMove (EditLine _) _ -> nopMs+	     _ -> storeLastpos lastpos++      proc = do message handleLow handleHigh =<< getKs+		proc+++  in  stateK initstate (setSize (1,0) >> proc) nullK++minWidth = 10+xoffset = 2+llmargin = Point 2 2++defaultuslimit = Nothing+uslimit = let ul = argReadKey "undodepth" (-1)+	  in if ul == -1 then defaultuslimit else Just ul++data EditState a = S { shocur :: Bool,+		       twidth :: (Int,Int),+		       undostack :: UndoStack a,+		       field :: EditField,+		       size :: Point,+		       lastpos :: (Int,Int)+		       }++--initstate = (False,(1,0),undoStack uslimit, createField "", origin, (0, 0))+initstate = S False (1,0) (undoStack uslimit) (createField "") origin (0, 0)++loadShowCursor = fieldMs shocur+loadTextWidth = fieldMs  twidth+loadUndoStack = fieldMs  undostack+loadField = fieldMs field+loadSize = fieldMs size+loadLastpos = fieldMs lastpos+--loadWidth = loadSize >>= \size -> return (xcoord size)+loadWidth = fmap xcoord loadSize+++#define MODMS(lbl) ( \ lbl -> (modMs ( \ s -> s { lbl=lbl } )))++storeShowCursor = MODMS(shocur)+storeTextWidth  = MODMS(twidth)+storeUndoStack  = MODMS(undostack)+storeField      = MODMS(field)+storeSize       = MODMS(size)+storeLastpos    = MODMS(lastpos)
+ hsrc/fudgets/Editor.hs view
@@ -0,0 +1,214 @@+module Editor(oldEditorF,selectall,loadEditor,setEditorCursorPos) where+import Command+import CompOps((>+<))+import Cont(cmdContK')+import Cursor+import Defaults(menuFont,bgColor,metaKey)--defaultFont+import CmdLineEnv(argReadKey)+import QueryPointer+import TimerF+import Dlayout(groupF)+import Edtypes+import Edit--(EditStopT(..), EditCmd(..), EditEvt(..), IsSelect(..), editF)+import Event+--import Font(FontStruct)+import Fudget+import FRequest+import Geometry() -- instances, for hbc+import LayoutRequest+import Loops(loopCompThroughRightF)+--import Message(Message(..))+import NullF+--import Path(Path(..))+import PopupMenuF+--import SP+import SelectionF+--import Utils(mapList)--loop,+import Xtypes+import Data.Char(isAlpha,toLower,isPrint)+--import Graphic+import InputMsg(InputMsg(..))++default(Int) -- mostly for Hugs++ems = EditMove . EditStopFn+stopafter n dir = ems (sa n) +	  where sa n b a = if (n::Int) <= 0 then EdStop else EdGo dir (sa (n-1))+stop1 = stopafter 1++ifhd p l = not (null l) && p (head l)+aheadl dir b a = if dir == ELeft then b else a+ifdirhd p dir b a = ifhd p (aheadl dir b a)+stopwhen p dir = ems sw+   where sw b a = if ifdirhd p dir b a then EdStop+	          else EdGo dir sw+stopat c = stopwhen (==c)+stopnl = stopat newline++stopborder p dir = ems sw+  where sw b a = if ifdirhd (not . p) dir b a &&+		    ifdirhd p dir a b then EdStop+		 else EdGo dir sw++stopword = stopborder isAlpha++neverstop = stopwhen (const False)++-- replaceAll is used for TextRequests+loadEditor s = selectall++[EditReplace s]+selectall = [neverstop ELeft False,+	     neverstop ERight True]++setEditorCursorPos (row,col) =+   EditMove (EditPoint 0) False :+   concat (replicate (row-1) (down `funmap` False)) +++   [stopafter (col-1) ERight False]++horiz dir meta = stop1 dir : if meta then [stopword dir] else []+left = horiz ELeft+right = horiz ERight+up = [EditMove (EditLine ELeft)]+down = [EditMove (EditLine ERight)]++undo = [const EditUndo]+redo = [const EditRedo]++cursorbindings meta = +    [("left", left meta), +     ("right",right meta),+     ("up",up),+     ("down",down),+     ("b",left meta),+     ("f",right meta)] ++ctrls  = [("e",[stopnl ERight]),+         ("a",[stopnl ELeft]),+	 ("p",up),+	 ("n",down),+	 ("b",left False),+	 ("f",right False),+	 ("slash",undo),+	 ("question",redo)]++selectleft meta = funmap (left meta) True+fl `funmap` x = [f x | f <- fl]+hasMeta mods = metaKey `elem` mods+hasControl mods = Control `elem` mods+cursorkey mods key = flip lookup (if hasControl mods then ctrls +			     else cursorbindings (hasMeta mods))+			    (map toLower key) +		     >>= \l-> Just (funmap l (Shift `elem` mods))++isEnterKey key = key == "Return" || key == "KP_Enter"+printorenter mods key ascii =+    if hasMeta mods then Nothing+    else if isEnterKey key then+        Just [newline]+    else if key == "Tab" then Just ['\t']+    else if not (hasControl mods) then+        case ascii of+          c : _ | isPrint c -> Just [c]+          _ -> Nothing+   else Nothing+toEdF = High . Left . Right . Right++toSelF = High . Left . Right . Left . Left+toTimerF = High . Left . Right . Left . Right++toOut = High . Right++getEdSel = getEd EditGetSelection+getEdText = getEd EditGetText++getEd ecmd =+    cmdContK' (toEdF ecmd)+              (\e ->+               case e of+                 High (Left (Right (Right (EditText t)))) -> Just t+                 _ -> Nothing)++getSel =+    cmdContK' (toSelF PasteSel)+              (\e ->+               case e of+                 High (Left (Right (Left (Left (SelNotify t))))) -> Just t+                 _ -> Nothing)++replace' s = putK (toEdF $EditReplace s)+clearSel = replace' ""+copySel k = getEdSel $ (\s -> putK (toSelF (Sel s)) k)+click issel p = putK (toEdF $ EditMove (EditPoint p) issel)+starttimer = putK (toTimerF $ Just (scrolldel,scrolldel))+stoptimer = putK (toTimerF $ Nothing)+scrolldel = argReadKey "scrolldel" 200++oldEditorF font = loopCompThroughRightF g where+   g = groupF (map XCmd [ChangeWindowAttributes +	       [CWEventMask [KeyPressMask,EnterWindowMask,LeaveWindowMask]],+	       ConfigureWindow [CWBorderWidth 1],+	       GrabButton True (Button 1) [Any] +	          [ButtonPressMask,PointerMotionMask,ButtonReleaseMask]])+	      (setFontCursor 152 $ editorK False False)+	      (menu ((selectionF >+< timerF) >+< editF font))+   editorK bpressed focus = same where+     same = +      getK $ \msg ->+        case msg of+         Low (XEvt event) ->+	   case event of+	     KeyEvent _ _ _ mods Pressed _ key ascii -> +		if hasMeta mods && isEnterKey key+		then putInputDoneMsg key+		else+		case printorenter mods key ascii of+		   Just s -> replace' s same+		   Nothing -> case cursorkey mods key of+		      Just eds -> putsK (map toEdF eds) same+		      Nothing -> +			 if key `elem` ["Delete","BackSpace"] +			 then getEdSel $ \s -> +			      (if null s +			       then putsK (map toEdF +					      (selectleft (hasMeta mods)))+			       else id) $ clearSel same+			 else same+	     MotionNotify {pos=p,state=mods} -> click True p same+	     ButtonEvent {pos=p,state=mods,type'=Pressed,button=Button 1} ->+		starttimer $+		click (Shift `elem` mods) p $ showCursor True focus+	     ButtonEvent {type'=Released,button=Button 1} -> +		stoptimer $ showCursor False focus+	     FocusIn {mode=NotifyNormal} -> showCursor bpressed True+	     FocusOut {mode=NotifyNormal} -> showCursor bpressed False+	     _ -> same+	 High (Left (Right (Left (Right Tick)))) ->+	   queryPointerK $ \(_,_,p,_) -> click True p same+	 High (Left (Left mencmd)) -> case mencmd of+				      MenCut -> copySel $ clearSel same+				      MenCopy -> copySel same+				      MenPaste -> getSel $ \s ->+						  replace' s same+	 High (Left (Right (Right ecmd))) -> +	    (case ecmd of+		  EditCursor r -> putK (Low $ LCmd $+					layoutMakeVisible r)+		  _ -> id) $+	    putK (toOut ecmd) same+	 High (Right ocmd) -> putK (toEdF ocmd) same+	 _ -> same+     showCursor b f = putK (toEdF (EditShowCursor (b || f))) $ +		    editorK b f+     putInputDoneMsg key =+       getEdText $ \ s ->+       putK (toOut $ EditChange (InputDone key s)) $+       putsK (map toEdF selectall) $+       same++data MenEvt = MenCut | MenCopy | MenPaste  deriving (Eq, Ord)++menu = oldPopupMenuF bgColor True menuFont (Button 3) [] [] +     [(MenCut, []), (MenCopy, []), (MenPaste, [])]+               (\x -> case x of+                  MenCut -> "Cut"+                  MenCopy -> "Copy"+                  MenPaste -> "Paste")
+ hsrc/fudgets/Edtypes.hs view
@@ -0,0 +1,12 @@+module Edtypes where++data EDirection = ELeft | ERight deriving (Eq, Ord)+++newline = '\n'++type EditStopFn = String -> String -> EditStopChoice+data EditStopChoice = EdGo EDirection EditStopFn | EdStop+type IsSelect = Bool++
+ hsrc/fudgets/FilePickF.hs view
@@ -0,0 +1,64 @@+module FilePickF(oldFilePickF,smallPickListF) where+import List2(sort)+import MoreF(pickListF)--,PickListRequest(..)+import ListRequest(replaceAll)+import CompOps+--import Defaults(menuFont)+import FilePaths+import IoF(ioF)+import HaskellIO(hIOerr)+import Fudget+import NullF(startupF,getK,putK)--F,K,+--import FudgetIO+import ReadFileF(readDirF)+--import Geometry(Point(..))+import LayoutDir(Orientation(..))+import LayoutOps+--import Spacer(layoutModifierF)+import Loops(loopLeftF)+import SerCompF(bypassF)+import InputMsg(stripInputMsg)--InputMsg(..),+import InputSP(inputLeaveDoneSP)--,inputDoneSP+import InputF(inputThroughF)--,InF(..)+import DStringF(stringF)+import EitherUtils(stripEither)+--import Message(Message(..))+import DialogueIO hiding (IOError)++dirF = aFilePath >^=< bypassF (inputLeaveDoneSP >^^=< stringF) -- startpath ?!!!++shownameF = inputThroughF stringF++startpath = "."++lsF = paths>^=<readDirF>=^<filePath+  where+    paths (dir,resp) =+        case resp of+          Right files -> (map (extendPath sdir) . sort . filter (/=".")) files+	  --Left err   -> [show err, filePath sdir]+	  Left err   -> [aFilePath "Error", sdir]+      where sdir = aFilePath dir++smallPickListF f = {-layoutModifierF lf-} (snd.stripInputMsg>^=<pickListF f>=^<replaceAll)+--  where lf (Layout _ fh fv) = Layout (Point 240 120) fh fv++oldFilePickF =+    let showdirF =+            startupF [aFilePath startpath]+                     ((compactPath >^=< filePickListF) >==< lsF)+	filePickListF = smallPickListF pathTail+        routeK =+	    getK $ \ msg ->+	    case msg of+	      High p ->+	        let s = filePath p+		    cont r = putK (High (r s)) routeK+		    fileCont = cont Right+		    dirCont = cont Left+		    checkCont (Str ('d':_)) = dirCont+		    checkCont _ = fileCont+		in hIOerr (StatusFile s) (const fileCont) checkCont+        f1 >=#=< f2 = (f1,Below) >#==< f2+    in  shownameF >=#=<+        loopLeftF (((ioF routeK >==< showdirF) >=#=< dirF) >=^< stripEither)
+ hsrc/fudgets/GcWarningF.hs view
@@ -0,0 +1,43 @@+-- If you get a type error when compiling this with HBC, try removing -O.+module GcWarningF where+import Dlayout(windowF)+import Command(XCommand(ClearWindow,ChangeWindowAttributes,SetGCWarningHack))+import DrawInPixmap+import LayoutRequest+import Geometry(Rect(..))+import Xtypes+import FudgetIO+import FRequest(layoutRequestCmd)+import Xcommand+import NullF(nullK)+--import ResourceIds+import Pixmap(createPixmap)+import GCtx(GCtx(..),pmCreateGCtx,rootGCtx)+--import GCAttrs+import Defaults(bgColor)++-- Garbage Collection Warning Fudget++gcWarningF = windowF startcmds warnK+  where+    startcmds = [layoutRequestCmd (plainLayout size True True)]++    warnK =+	createPixmap size copyFromParent $ \ gcon ->+	createPixmap size copyFromParent $ \ gcoff ->+	fg gcon [bgColor,"white"] $ \ (GC bg _) ->+	fg gcon ["red","black"] $ \ (GC red _) ->+	putLow (pmFillRectangle gcon bg r) $+	putLow (pmFillRectangle gcoff bg r) $+	putLow (pmFillArc gcon red r 0 (360*64)) $+	xcommandK (SetGCWarningHack gcon gcoff) $+	xcommandK (ChangeWindowAttributes [CWBackPixmap gcoff]) $+	xcommandK ClearWindow $+	nullK+      where+	r = Rect 0 size+	fg pm colspec =+	  pmCreateGCtx pm rootGCtx+	    ([GCForeground colspec]::[GCAttributes [String] String])++    size = 10
+ hsrc/fudgets/GraphicsF.hs view
@@ -0,0 +1,576 @@+{-# LANGUAGE CPP #-}+module GraphicsF(GraphicsF,setCursorSolid,setGfxEventMask,+                 setAdjustSize,setCursor,setDoubleBuffer,+                 graphicsF,graphicsF',+		 graphicsGroupF,graphicsGroupF',+		 graphicsDispGroupF,graphicsDispGroupF',+		 graphicsLabelF,graphicsLabelF',+		 graphicsDispF,graphicsDispF',+		 GfxEventMask(..),GfxChange(..),GfxCommand(..),GfxEvent(..),+                 GfxFCmd,GfxFEvent,+		 replaceGfx,replaceAllGfx,showGfx,highlightGfx) where+import Fudget+import FudgetIO+import Xcommand+import FRequest+import NullF(putK,putsK,getK,nullF)+import Spops(nullSP)+import CompSP(postMapSP)+import SpEither(filterLeftSP)--mapFilterSP+--import SerCompF(stubF)+import Command+import DrawInPixmap(pmFillRectangle,pmDrawPoint)+--import DrawInWindow(wCopyArea)+import Event+import Xtypes+import Geometry+import Gc+import Pixmap+import Cursor+--import Color+--import Font(font_id,string_box_size)+--import LoadFont(safeLoadQueryFont)+import BgF(changeGetBackPixel)+import Defaults(fgColor,bgColor,paperColor,labelFont)+import CmdLineEnv(argFlag,argKeyList,argReadKey)+import LayoutRequest+import Alignment+import Spacers(noStretchS,compS,minSizeS)+import Message+import CompOps+import CompSP(idRightSP)+import Dlayout(groupF)+import Utils(number,pairwith)+import HbcUtils(mapFst,mapSnd)+--import InputMsg+import Graphic+import CompiledGraphics+import MeasuredGraphics(MeasuredGraphics(SpacedM,MarkM),compileMG,DPath(..))--,emptyMG,emptyMG'+import Graphic2Pixmap+import GCtx(GCtx(..),wCreateGCtx,rootGCtx)+import GCAttrs+import MGOps(parentGctx,replaceMGPart,updateMGPart,groupMGParts,ungroupMGParts)+import IdempotSP+import DrawCompiledGraphics+import Rects(intersectRects,overlaps)+import EitherUtils(stripEither)--,mapEither+import Sizing(newSize,Sizing(..))+--import HO(apSnd)+--import Maybe(fromMaybe)+import Xrequest(xrequestK)+import StdIoUtil(echoStderrK)+--import ContinuationIO(stderr)+--import Maptrace(ctrace) -- debugging++import FDefaults+#include "defaults.h"+#include "exists.h"+--  Commands for grapihcsF: ---------------------------------------------------++data GfxChange gfx+  = GfxReplace (Bool,Maybe gfx)+  | GfxGroup Int Int -- position & length+  | GfxUngroup Int -- position+  +data GfxCommand path gfx+  = ChangeGfx [(path,GfxChange gfx)]+  | ChangeGfxBg ColorSpec+  | ChangeGfxBgPixmap PixmapId Bool -- True = free pixmap+#ifdef USE_EXIST_Q+  | EXISTS(bg) TSTHACK((Graphic EQV(bg)) =>) ChangeGfxBgGfx EQV(bg)+#endif+  | ChangeGfxCursor CursorId+  | ChangeGfxFontCursor Int+  | ShowGfx path (Maybe Alignment,Maybe Alignment) -- makes the selected part visible+  | BellGfx Int -- sound the bell+  | GetGfxPlaces [path] -- ask for rectangles of listed paths++replaceAllGfx = replaceGfx []+replaceGfx path gfx = ChangeGfx [(path,GfxReplace (False,Just gfx))]+showGfx path = ShowGfx path (Nothing,Nothing)+highlightGfx path on = ChangeGfx [(path,GfxReplace (on,Nothing))]++instance Functor GfxChange where+  fmap f (GfxReplace r) = GfxReplace (fmap (fmap f) r)+  fmap f (GfxGroup from count) = GfxGroup from count+  fmap f (GfxUngroup at) = GfxUngroup at++instance Functor (GfxCommand path) where+  fmap f cmd =+    case cmd of+      ChangeGfx changes -> ChangeGfx (mapSnd (fmap f) changes)+      -- _ -> cmd -- Operationally, the rest is the same as this line.+      ChangeGfxBg c -> ChangeGfxBg c+      ChangeGfxBgPixmap pm b -> ChangeGfxBgPixmap pm b+#ifdef USE_EXIST_Q+      ChangeGfxBgGfx gfx -> ChangeGfxBgGfx gfx+#endif+      ChangeGfxCursor cursor -> ChangeGfxCursor cursor+      ChangeGfxFontCursor shape -> ChangeGfxFontCursor shape+      ShowGfx path a -> ShowGfx path a+      BellGfx n -> BellGfx n+      GetGfxPlaces paths -> GetGfxPlaces paths++--  Events from graphicsF: ----------------------------------------------------++data GfxEvent path+  = GfxButtonEvent { gfxTime  :: Time,+                     gfxState :: ModState,+		     gfxType  :: Pressed,+                     gfxButton:: Button,+		     gfxPaths :: [(path,(Point,Rect))] }+  | GfxMotionEvent { gfxTime  :: Time,+                     gfxState :: ModState,+		     gfxPaths :: [(path,(Point,Rect))] }+  | GfxKeyEvent    { gfxTime  :: Time,+                     gfxState::ModState,+                     gfxKeySym::KeySym,+		     gfxKeyLookup::KeyLookup }+  | GfxFocusEvent  { gfxHasFocus :: Bool }+  | GfxPlaces [Rect] -- response to GetGfxPlaces+  | GfxResized Size+  deriving (Eq,Show)+++--  graphicsF event masks: ----------------------------------------------------++data GfxEventMask = GfxButtonMask | GfxMotionMask | GfxDragMask | GfxKeyMask++allGfxEvents = [GfxButtonMask, GfxMotionMask, GfxDragMask, GfxKeyMask]+gfxMouseMask = [GfxButtonMask, GfxDragMask] -- backward compat++gfxEventMask = concatMap events+  where+    events GfxButtonMask = buttonmask+    events GfxMotionMask = motionmask+    events GfxDragMask   = dragmask+    events GfxKeyMask    = keventmask++    buttonmask = [ButtonPressMask,ButtonReleaseMask]+    motionmask = [PointerMotionMask]+    dragmask = [Button1MotionMask]+    keventmask =+	 [KeyPressMask,+          EnterWindowMask, LeaveWindowMask -- because of CTT implementation+	 ]++--  Customisers for graphicsF: ------------------------------------------------++newtype GraphicsF gfx = Pars [Pars gfx]++data Pars gfx+  -- Standard customisers:+  = BorderWidth Int+  | BgColorSpec ColorSpec+  | FgColorSpec ColorSpec+  | FontSpec FontSpec+  | Sizing Sizing+  | Stretchable (Bool,Bool)+  | InitSize gfx+  | InitDisp gfx+  -- Special customisers:+  | CursorSolid Bool+  | GfxEventMask [GfxEventMask]+  | AdjustSize Bool+  | Cursor Int -- pointer cursor shape for XCreateFontCursor+  | DoubleBuffer Bool+-- Could also support:+--  | Align Alignment+--  | Spacer Spacer+--  | Margin Int++parameter_instance1(BorderWidth,GraphicsF)+parameter_instance1(BgColorSpec,GraphicsF)+parameter_instance1(FgColorSpec,GraphicsF)+parameter_instance1(Sizing,GraphicsF)+parameter_instance1(FontSpec,GraphicsF)+parameter_instance1(Stretchable,GraphicsF)+parameter_instance(InitSize,GraphicsF)+parameter_instance(InitDisp,GraphicsF)+parameter(CursorSolid)+parameter(GfxEventMask)+parameter(AdjustSize)+parameter(Cursor)+parameter(DoubleBuffer)++-------------------------------------------------------------------------------++type GfxFCmd a = GfxCommand DPath a+type GfxFEvent = GfxEvent DPath++graphicsDispF :: Graphic a => F (GfxFCmd a) (GfxFEvent)+graphicsDispF = graphicsDispF' standard++graphicsLabelF lbl = graphicsLabelF' standard lbl++graphicsLabelF' customiser gfx = nullSP >^^=< d >=^^< nullSP'+  where d = graphicsF' (customiser . params)+	params = setInitDisp gfx .setGfxEventMask [] . setSizing Static .+		 setBgColor bgColor . setBorderWidth 0+	nullSP' = nullSP -- :: (SP anything (GfxCommand MeasuredGraphics))+	-- this is a workaround necessary to resolve the overloading++graphicsDispF' :: Graphic gfx => Customiser (GraphicsF gfx) -> F (GfxFCmd gfx) (GfxFEvent)+graphicsDispF' customiser  = graphicsF' (customiser . dispCustomiser)+graphicsDispGroupF fud = graphicsGroupF' dispCustomiser fud+graphicsDispGroupF' customiser fud =+  graphicsGroupF' (customiser . dispCustomiser) fud++dispCustomiser =+  setCursorSolid True . setGfxEventMask gfxMouseMask . setSizing Growing++graphicsF :: Graphic gfx => F (GfxFCmd gfx) (GfxFEvent)+graphicsF = graphicsF' standard++graphicsF' custom = filterLeftSP >^^=< graphicsGroupF' custom nullF >=^< Left++graphicsGroupF :: Graphic gfx => F i o -> F (Either (GfxFCmd gfx) i) (Either (GfxFEvent) o)+graphicsGroupF = graphicsGroupF' standard++--graphicsGroupF' :: (Graphic init,Graphic gfx => Customiser (GraphicsF init) -> F i o -> F (Either (GfxFCmd gfx) i) (Either (GfxFEvent) o)+graphicsGroupF' :: Graphic gfx => Customiser (GraphicsF gfx) -> F i o -> F (Either (GfxFCmd gfx) i) (Either (GfxFEvent) o)+graphicsGroupF' customiser fud = +  let solid = getCursorSolid params+      mask = getGfxEventMask params+      sizing = getSizing params+      adjsize = getAdjustSize params+      doublebuffer = getDoubleBuffer params+      optcursor = getCursorMaybe params+      font = getFontSpec params+      bw = getBorderWidth params+      bgcol = getBgColorSpec params+      fgcol = getFgColorSpec params+      optx = getInitDispMaybe params+      optstretch = getStretchableMaybe params+      optinitsize = getInitSizeMaybe params+      params = customiser defaults+      defaults = Pars [BorderWidth 1,+                       BgColorSpec (colorSpec paperColor),+                       FgColorSpec (colorSpec fgColor),+		       Sizing Dynamic,+		       CursorSolid False,+		       GfxEventMask allGfxEvents,+		       AdjustSize True,+		       DoubleBuffer defaultdoublebuffer,+		       FontSpec (fontSpec labelFont)]+      eventmask = ExposureMask:+	          gfxEventMask mask+      --grabmask =  [ButtonReleaseMask, PointerMotionMask]+      -- NOTE: some code below assumes that motion events occur ONLY+      --       while Button1 is pressed!+      startcmds = [ChangeWindowAttributes [CWEventMask eventmask,+                                           CWBitGravity NorthWestGravity],+                    ConfigureWindow [CWBorderWidth bw]--,+		    --GrabButton False (Button 1) [] grabmask,+		    --GrabButton False (Button 2) [] [ButtonReleaseMask]+		  ]+  in --compMsgSP layoutOptSP (idRightSP idempotSP) `serCompSP`+     idRightSP (stripEither `postMapSP` idRightSP idempotSP) >^^=<+     groupF (fmap XCmd startcmds)+        (initK doublebuffer font optcursor fgcol bgcol $+	 graphicsK0 solid sizing adjsize optstretch optinitsize optx)+        fud++dbeSwapBuffers cont =+  xrequestK (DbeSwapBuffers swapaction) Just $ \ (DbeBuffersSwapped _) -> cont++optDoubleBufferK False cont = cont Nothing+optDoubleBufferK True cont =+  xrequestK DbeQueryExtension Just $ \ (DbeExtensionQueried status major minor) ->+  let ok=status/=0+  in if not ok+     then echoStderrK "Sorry, double buffering not available." $+	  cont Nothing+     else xrequestK (DbeAllocateBackBufferName swapaction) Just $ \ (DbeBackBufferNameAllocated backbuf) ->+          --xcommandK ClearWindow $+          cont (Just backbuf)++initK doublebuffer font optcursor fgcol bgcol k =+  changeGetBackPixel bgcol $ \ bg ->+  maybe id setFontCursor optcursor $+  convColorK [fgcol,colorSpec "black"] $ \ fg ->+  wCreateGCtx rootGCtx [GCFont [font,fontSpec "fixed"],GCForeground fg,GCBackground bg] $ \ gctx@(GC gc _) ->+  wCreateGC rootGC [GCForeground bg] $ \ cleargc ->+  createCursorGC gc bg fg $ \ higc ->+  optDoubleBufferK doublebuffer $ \ optbackbuf ->+  k optbackbuf gctx bg cleargc higc++optCompileGraphicK gctx optgfx cont =+  case optgfx of+    Nothing -> cont Nothing+    Just gfx ->+      measureGraphicK gfx gctx $ \ mg ->+      cont (Just (mg,compileMG id mg))++graphicsK0 solid sizing adjsize optstretch optinitsize optx optbackbuf gctx bg cleargc higc =+    graphicsK1 +  where+    graphicsK1 =+      optCompileGraphicK gctx optinitsize $ \ optcgsize ->+      optCompileGraphicK gctx optx $ \ optcgx ->+      graphicsK2 optcgsize optcgx+    graphicsK2 optcgsize optcgx =+        graphicsK init+      where+	optSizeS    = fmap (minSizeS . minsize . snd . snd) optcgsize+        optStretchS = fmap stretchS optstretch+          where stretchS (sh,sv) = noStretchS (not sh) (not sv)+        spacerM =+	  case (optStretchS,optSizeS) of+	    (Just stretchS,Just sizeS) -> SpacedM (stretchS `compS` sizeS)+	    (Just stretchS,_         ) -> SpacedM stretchS+	    (_            ,Just sizeS) -> SpacedM sizeS+	    _                          -> MarkM gctx++        -- All incoming and outgoing paths have to be adjusted because of+	-- the extra spacer. The functions pathIn & pathOut handle this.+	init = pairwith (compileMG id) $ spacerM $ maybe (emptyMG 10) fst optcgx+         -- Stretchiness is applied to all drawings as it should be, but+	 -- optinitsize should be applied only to the first drawing!!!+    +    pathIn path = 0:path+    -- pathOut (0:path) = path++    -- locatePointOut p = mapFst pathOut . locatePoint p+    locatePointOut p (CGMark cg) = locatePoint p cg+    -- bug if top node isn't a CGMark !!++    graphicsK (mg,(cg,req)) =+      putLayoutReq req $+      idleK cleargc req mg cg solid []++    idleK cleargc req mg cg active es =+        seq size $ -- prevents a space leak when sizing==Dynamic, TH 980724+	getK $ message lowK highK+      where+	size = minsize req -- == current window size most of the time+	curR = hiR (solid||active)+	same = idleK cleargc req mg cg active es+	newcleargc cleargc' = idleK cleargc' req mg cg active es++	optInsertNew mg cg gctx path optreq optnew k =+	  case optnew of+	    Nothing  -> k mg cg optreq+	    Just new -> measureGraphicK new gctx $ \ newmg ->+			let mg' = replaceMGPart mg path newmg+			    (cg',req) = compileMG (newSize sizing size) mg'+			in k mg' cg' (Just req)++	updGraphicsK mg cg optreq [] c =+	  case optreq of+	    Just req' | not (similar req' req)+		 	     -> --ctrace "updgfx" (show (req,req')) $+				putLayoutReq req' $ c req' mg cg False+	    _                -> c req mg cg True+	updGraphicsK mg cg optreq ((path,change):changes) c =+          case change of+            GfxReplace r -> replace r+            GfxGroup from count -> group from count+            GfxUngroup pos -> ungroup pos+          where+            replace (hi,optnew) =+              optInsertNew mg cg (parentGctx gctx mg path) path optreq optnew $ \ mg' cg' optreq' ->+              let cg'' = case (hi,optnew) of+                           (False,Nothing) -> cgupdate cg' path removecursor+                           (True,_)        -> cgupdate cg' path addcursor+                           _ -> cg'+              in updGraphicsK mg' cg'' optreq' changes c++            group from count = updGraphicsK mg' cg' optreq changes c+              where mg' = updateMGPart mg path (groupMGParts from count)+                    cg' = cgupdate cg path (cgGroup from count)++            ungroup pos = updGraphicsK mg' cg' optreq changes c+              where mg' = updateMGPart mg path (ungroupMGParts pos)+                    cg' = cgupdate cg path (cgUngroup pos)++        bufDrawChangesK = maybe drawChangesK backBufDrawChangesK optbackbuf+	bufDrawK = maybe drawK backBufDrawK optbackbuf++        backBufDrawChangesK backbuf beQuick cur new old changes cont =+            drawChangesK' (Just (DbeBackBuffer backbuf,cleargc)) False cur new old changes $+	    dbeSwapBuffers $+	    cont+	backBufDrawK backbuf cur clip cg cont =+            drawK' (DbeBackBuffer backbuf) cur clip cg $+	    dbeSwapBuffers $+	    --putLow (wCopyArea gc (DbeBackBuffer backbuf) (Rect 0 size) 0) $+	    cont+          where (GC gc _) = gctx++	buttonEvent t p state type' button =+	  -- High level output tagged Left is sent through idempotSP+	  putHigh (Left $+	           GfxButtonEvent t state type' button (locatePointOut p cg)) $+	  same+	motionEvent t p state =+	  -- High level output tagged Left is sent through idempotSP+	  putHigh (Left $ GfxMotionEvent t state (locatePointOut p cg)) $+	  same+	key t mods sym lookup =+	  putHigh (Right $ GfxKeyEvent t mods sym lookup) $ same++	highK (ShowGfx path align) = mkPathVisible cg (pathIn path) align same+	highK (BellGfx n) = xcommandK (Bell n) same++	highK (GetGfxPlaces paths) =+	  putHigh (Right $ GfxPlaces $ fmap (cgrect . cgpart cg . pathIn) paths) $+	  same+	highK (ChangeGfxBg bgspec) =+	  convColorK bgspec $ \ bgcol ->+	  xcommandK (ChangeWindowAttributes [CWBackPixel bgcol]) $+	  xcommandK clearWindowExpose $+	  wCreateGC rootGC [GCForeground bgcol] $ \ cleargc' ->+	  -- FreeGC cleargc+	  newcleargc cleargc'+	highK (ChangeGfxBgPixmap pixmap freeIt) =+	  xcommandK (ChangeWindowAttributes [CWBackPixmap pixmap]) $+	  xcommandK clearWindowExpose $+	  wCreateGC rootGC [GCFillStyle FillTiled,GCTile pixmap] $ \ cleargc' ->+	  -- FreeGC cleargc+	  (if freeIt then xcommandK (FreePixmap pixmap) else id) $+	  newcleargc cleargc'+#ifdef USE_EXIST_Q+        highK (ChangeGfxBgGfx gfx) =+	  graphic2PixmapImage gfx gctx $ \ (PixmapImage size pm) ->+	  highK (ChangeGfxBgPixmap pm True)+#endif+        highK (ChangeGfxCursor cursor) =+          defineCursor cursor $+          xcommandK Flush $+	  same+        highK (ChangeGfxFontCursor shape) =+          setFontCursor shape $+          xcommandK Flush $+	  same+	highK (ChangeGfx changes0) =+	    updGraphicsK mg cg Nothing changes $ \ req' mg' cg' beQuick ->+	    bufDrawChangesK beQuick (higc,curR) cg' cg (fmap fst changes) $+	    --mkChangeVisible cg' changes $+	    idleK cleargc req' mg' cg' active []+	  where changes = mapFst pathIn changes0++	changeActive active' =+	  if active'==active+	  then same+	  else putHigh (Left $ GfxFocusEvent { gfxHasFocus=active' }) $+	       bufDrawChangesK True (higc,hiR (solid||active')) cg cg (cursorPaths cg) $+	       idleK cleargc req mg cg active' es++        lowK (XEvt e) = eventK e+	lowK (LEvt lresp) = layoutK lresp+	lowK _ = same++        layoutK lresp =+	  case lresp of+	    LayoutSize size'+		| adjsize ->+		    if size' == size then same+		    else let cg'' = foldr restorecursor cg' (cgcursors cg)+			       where+			         restorecursor path cg = cgupdate cg path addcursor+				 (cg',_) = compileMG (const size') mg+			 in putHigh (Left $ GfxResized size') $+			    bufDrawChangesK True (higc,curR) cg'' cg [] $+			    idleK cleargc req' mg cg'' active es+		| otherwise -> idleK cleargc req' mg cg active es+	      where req' = mapLayoutSize (const size') req+	    _ -> same++	eventK event =+	  case event of+	    Expose r 0 ->+	      let rs = r:es+	      in bufDrawK (higc,curR) (intersectRects rs) (prune rs cg) $+                 idleK cleargc req mg cg active []+	    Expose r _ -> idleK cleargc req mg cg active (r:es)+	    FocusIn  {} -> changeActive True+	    FocusOut {} -> changeActive False++	    ButtonEvent {time=t, pos=pos, type'=type', button=button, state=state} ->+	       buttonEvent t pos state type' button+	    MotionNotify {time=t,pos=pos,state=state} -> motionEvent t pos state+	    KeyEvent t _ _ mods Pressed _ sym lookup -> key t mods sym lookup+	    _ -> same++prune rs (CGMark cg) = CGMark (prune rs cg)+prune rs (CGraphics r cur cmds cgs) =+  if any (overlaps r) rs+  then if null cmds --  || all (null.snd) cmds+       then CGraphics r cur cmds (fmap (prune rs) cgs)+       else CGraphics r cur cmds cgs+             -- cmds may overlap with cgs, so+	     -- if cmds are redrawn then all cgs should be redrawn too.+  else CGraphics r cur [] [] -- subtree rectangles are inside parent rectangles.++{-+locatePoint' p cg = fmap addrect $ locatePoint p cg+  where+    addrect = pairwith (cgrect . cgpart cg)+-}++locatePoint p (CGMark cg) = [(0:path,geom)|(path,geom)<-locatePoint p cg]+ --  ^^ the wrong geometry will be return if CGMark came from a SpacerM !!+locatePoint p (CGraphics r _ _ gs) =+  if p `inRect` r+  then let ps = fmap (locatePoint p) gs+       in case [ (i:path,pr) | (i,paths)<-number 1 ps, (path,pr)<-paths] of+            [] -> [([],(p-rectpos r,r))]+	    ps -> ps+  else []++cursorPaths (CGMark cg) = fmap (0:) (cursorPaths cg)+cursorPaths (CGraphics _ cur _ gs) =+  if cur+  then [[]]+  else [i:p | (i,g)<-number 1 gs, p<-cursorPaths g]++hiR True = solidCursorRects+hiR False = hollowCursorRects++solidCursorRects r = [r]++hollowCursorRects (Rect (Point x y) (Point w h)) =+   [rR x y w lw,rR x y lw h,rR x (y+h-lw) w lw,rR (x+w-lw) y lw h]+ where lw=minimum [2,w,h]++--putSize cg = putLayoutReq (Layout (cgsize cg) False False)++mkChangeVisible cg changes =+  case [ path | (path,(True,_))<-changes] of+    path:_ -> mkPathVisible cg path (Nothing,Nothing)+    _ -> id++mkPathVisible cg path align =+    putLayout (lMkVis (cgrect (cgpart cg path)))+  where+    lMkVis r = LayoutMakeVisible (r `growrect` 5) align+			 -- growrect compensates for a layout bug !!++putLayoutReq = putLayout . LayoutRequest+--putSpacer = putLayout . LayoutSpacer+putLayout = putK . Low . LCmd++createCursorGC gc bg fg cont =+  --allocNamedColorDefPixel defaultColormap cursorcolor "white" $ \ hipix ->+  tryConvColorK cursorcolor $ \ opthipix ->+  let hipix = fromMaybe fg opthipix+  in if hipix/=bg && hipix/=fg && not mono+     then wCreateGC gc [GCForeground hipix] $ \ cursorgc ->+	  cont cursorgc+     else createPixmap (Point 2 2) copyFromParent $ \ pm ->+	  wCreateGC gc [GCForeground bg] $ \ cleargc ->+	  putsK [Low $ pmFillRectangle pm cleargc (rR 0 0 2 2),+		 Low $ pmDrawPoint pm gc 0] $+	  wCreateGC gc [GCFillStyle FillTiled,GCTile pm] $ \ cursorgc ->+	  cont cursorgc++similar l1 l2 =+  minsize l1==minsize l2 &&+  fixedh l1==fixedh l2 &&+  fixedv l1==fixedv l2++cursorcolor = argKeyList "cursor" ["yellow"]+mono = argFlag "mono" False+defaultdoublebuffer = argFlag "doublebuffer" False+swapaction = argReadKey "swapaction" DbeCopied
+ hsrc/fudgets/GuiElems.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE CPP #-}+module GuiElems (+  -- * GUI elements+  -- ** Buttons+  module DButtonF, module DRadioF, module DToggleButtonF,+  module Border3dF,module ButtonBorderF,+  module ButtonF,module ButtonGroupF,+  module PushButtonF,module QuitButtonF,+  module QuitF,module RadioF,+  module ToggleButtonF,module ToggleGroupF,+  -- ** Graphics+  module GraphicsF,+  module HyperGraphicsF,+  -- ** Menus+  module MenuButtonF,module MenuF,module MenuPopupF,+  -- ** Popups+  module DialogF,+  module PopupMenuF,+  module FilePickF,+  -- ** Text elements+  module LabelF,+  module DDisplayF,module DStringF,+  module MoreF, module MoreFileF,+  module StringF, module TextF,+  module TerminalF,+  -- ** Special indicators+  module OnOffDispF,+  module GcWarningF,+  module BellF,+  -- ** Editors+  module Edit,module Editor,module Edtypes,module InputEditorF+ ) where+import Border3dF+import ButtonBorderF+import ButtonF+import ButtonGroupF+import DialogF+import Edit+import Editor+import Edtypes+import InputEditorF+import FilePickF+import GraphicsF+import HyperGraphicsF+import LabelF+import MenuButtonF+import MenuF+import MenuPopupF+import TextF+import MoreF+import MoreFileF+import PopupMenuF+import PushButtonF+import QuitButtonF+import QuitF+import RadioF+import StringF+import TerminalF+import ToggleGroupF+import ToggleButtonF+import OnOffDispF+import DButtonF+import DToggleButtonF+import DRadioF+import DDisplayF+import DStringF+import GcWarningF+import BellF++#ifdef __NHC__+import FDefaults -- Needed re-export instances for these classes+#endif
+ hsrc/fudgets/HyperGraphicsF.hs view
@@ -0,0 +1,76 @@+module HyperGraphicsF where+--import Fudget+--import Defaults(paperColor)+--import InputMsg(inputDone)+import Utils(swap)+--import Xtypes(ColorName)+import Loops(loopThroughRightF)+import SerCompF(mapstateF)+--import Graphic+import Drawing+import DrawingOps+import GraphicsF+import FDefaults+import HbcUtils(assoc)+import Sizing(Sizing(..))+--import GCAttrs() -- instances+import Event(Pressed(..))+--import Maptrace(ctrace) -- debugging+--import SpyF(teeF) -- debugging+--import CompOps((>==<)) -- debugging++hyperGraphicsF x = hyperGraphicsF' standard x++{-+hyperGraphicsF' :: (Eq annot,Graphic g) =>+                  Customiser (GraphicsF (Drawing annot g)) ->+                  Drawing annot g ->+		  F (Either (Drawing annot g) (annot,Drawing annot g))+		    annot+-}+hyperGraphicsF' custom init =+    loopThroughRightF+	(mapstateF ctrl state0)+	({-teeF show "\n" >==<-} graphicsDispF' (custom . params))+  where+    --tr x = ctrace "hyper" (show x) x -- debugging+    params = setInitDisp init .+	     setGfxEventMask [GfxButtonMask] .+	     setSizing Dynamic+    state0 = (annotPaths init,init)++    ctrl state@(paths,drawing) = either input output+      where+        same = (state,[])+        output = either new newpart+	  where+	    --new d = newpart' d []+	    -- avoid space leak for this common case:+	    new d = ((annotPaths d,d),[Left (replaceAllGfx d)])+	    newpart (a,d) = assoc (newpart' d) same paths a+	    newpart' d path = ((paths',drawing'),[Left (replaceGfx path d)])+	      where drawing' = replacePart drawing path d+	            paths' = annotPaths drawing'+			-- Space leak: drawing' isn't used until user clicks+			-- in the window, so the old drawing is retained in+			-- the closure for drawing'++        input msg =+	    case msg of+	      GfxButtonEvent { gfxType=Pressed, gfxPaths=gfxPaths } ->  mouse gfxPaths+	      _ -> same+	  where+	    lblPart = maybeDrawingPart drawing . drawingAnnotPart drawing . fst+	    mouse paths =+	      --ctrace "hyper" (show paths) $+	      case [lbl|Just (LabelD lbl _)<-map lblPart (reverse paths)] of+		lbl:_ -> (state,[Right lbl])+{- -- All nodes have unique paths now, so this should not be necessary:+		    Just d ->+		      case annotChildren d of+		        ([],LabelD a _):_ -> (state,[Right a])+			_ -> same+-}+		_ -> same++    annotPaths = map swap . drawingAnnots
+ hsrc/fudgets/InputEditorF.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE CPP #-}+module InputEditorF(+    EditorF,+    inputEditorF,inputEditorF',+    editorF,editorF')+  where+import Editor(oldEditorF,loadEditor)+import Edit(EditEvt(..))+--import InputMsg(InputMsg(..))+import CompOps+import SpEither(mapFilterSP)+import Spops(concatMapSP)+import ResourceIds() -- synonym FontName, for hbc+import GCAttrs --(FontSpec,fontSpec)+import Defaults(defaultFont)+import FDefaults++#include "defaults.h"++inputEditorF = inputEditorF' standard++inputEditorF' pm =+    mapFilterSP change >^^=< editorF' pm >=^^< concatMapSP loadEditor+  where+    change (EditChange inputmsg) = Just inputmsg+    change _ = Nothing++editorF = editorF' standard++editorF' customiser = oldEditorF font+  where+    font = fromMaybe (fontSpec defaultFont) $ getFontSpecMaybe ps+    ps = (customiser::(Customiser EditorF))  (Pars [])++newtype EditorF = Pars [Pars]++data Pars+  = FontSpec FontSpec++parameter_instance(FontSpec,EditorF)
+ hsrc/fudgets/LabelF.hs view
@@ -0,0 +1,28 @@+module LabelF(labRightOfF, labLeftOfF, labBelowF, labAboveF, tieLabelF) where+import Spacer(noStretchF,marginHVAlignF)+import Alignment+import CompOps((>=^<), (>^=<))+import DDisplayF(labelF)+--import Fudget+--import Geometry+import LayoutDir(Orientation(..))+import LayoutOps+import EitherUtils(stripEither)+--import Xtypes++--tieLabelF :: Orientation -> Alignment -> String -> F a b -> F a b+tieLabelF orient align text fudget =+    let disp = labelF text+        fv = orient == Above || orient == Below+        fh = not fv+        lblF = noStretchF fh fv (marginHVAlignF 0 align align disp)+    in  (stripEither >^=< ((lblF,orient) >#+< fudget)) >=^< Right+++labF orient = tieLabelF orient aCenter+labAboveF   x = labF Above x+labBelowF   x = labF Below x+labLeftOfF  x = labF LeftOf x+labRightOfF x = labF RightOf x++-- eta expanded because of monomorphism restriction
+ hsrc/fudgets/MenuButtonF.hs view
@@ -0,0 +1,44 @@+module MenuButtonF(menuButtonF,menuLabelF) where+import ButtonGroupF+import CompOps((>^^=<),(>=^<))+import SpEither(filterRightSP)+import SerCompF(idRightF)+import Defaults(inputFg,inputBg)+--import EitherUtils(stripEither)+import PushButtonF(Click(..))+import ResourceIds(FontName(..))--ColorName(..),+import Spacers(sepS)+import GraphicsF+import FDefaults+import DrawingUtils(g,boxD,spacedD)--fgD,fontD,+import Graphic+import Drawing(DPath)+import Geometry(pP)+import Fudget+import Sizing(Sizing(..))+import GCAttrs()++menuButtonF :: Graphic lbl => FontName -> lbl -> F lbl Click+menuButtonF fname label =+    filterRightSP >^^=< menuButtonGroupF (idRightF lblF >=^< prep)+  where+    lblF = menuLabelF fname label+    toDisp = Left+    through = Right+    prep (Left BMNormal) = toDisp (Left False)+    prep (Left BMInverted) = toDisp (Left True)+    prep (Left BMClick) = through Click+    prep (Right e) = toDisp (Right e)++menuLabelF :: Graphic lbl => FontName -> lbl -> F (Either Bool lbl) (GfxEvent DPath)+menuLabelF fname label =+    lblF >=^< pre+  where+    lblF = graphicsDispF' custom+    custom = setBgColor inputBg . setInitDisp (lblD label) .+	     setGfxEventMask [] . setSizing Dynamic . setBorderWidth 0 .+	     setFgColor inputFg . setFont fname+    lblD label = boxD [spacedD (sepS (pP 3 1)) $ g label]++    pre (Left highlight) = highlightGfx [] highlight+    pre (Right label')  = replaceAllGfx (lblD label')
+ hsrc/fudgets/MenuF.hs view
@@ -0,0 +1,254 @@+module MenuF(simpleMenuF, menuAltsF, menuF, oldMenuF, buttonMenuF, buttonMenuF', grabberF, MenuState,menuDown,EqSnd(..),fstEqSnd,sndEqSnd,toEqSnd) where+import Command+import Event+import Geometry(pP,Point(..),Size,inRect,Rect(..))+import Message(message )--Message(..),+import Fudget+import FRequest+import FudgetIO+import StreamProcIO+import Xcommand+import NullF+import CompOps((>^=<), (>=^<), (>=^^<), (>^^=<),(>+<))+import Dlayout(groupF)+import SerCompF(bypassF)--,idRightF+import Loops(loopCompThroughRightF)+import LayoutDir(LayoutDir(..))+import LayoutF(listLF)+import LayoutRequest(LayoutResponse(..))+import Placers+import Spacers() -- synonym Distance, for hbc+import MenuButtonF+import MenuPopupF+import Spops(nullSP)+import MapstateK+import SpEither(filterRightSP)+import EitherUtils(mapEither)--stripEither+import Xtypes+import Defaults(menuFont)+import CmdLineEnv(argFlag)+import Graphic+import Data.Array+--import DialogueIO hiding (IOError)+import ShowCommandF(showCommandF)+import Debug.Trace(trace)++data EqSnd a b = EqSnd a b++instance (Eq b) => Eq (EqSnd a b) where+    EqSnd a1 b1 == EqSnd a2 b2  =  b1 == b2++fstEqSnd (EqSnd a b) = a+sndEqSnd (EqSnd a b) = b+toEqSnd x = map (uncurry EqSnd) x++menuF :: (Graphic mlbl,Graphic albl) => mlbl -> [(alt,albl)] -> F alt alt+menuF name altlbls =+    bypassF ((nalts!) . sndEqSnd >^=< +      simpleMenuF menuFont name lblns fstEqSnd >=^^< nullSP)+  where+    (alts,lbls) = unzip altlbls+    lblns = zipWith EqSnd lbls ixs+    n = length alts+    ixs =  [1 .. n]+    nalts = array (1,n) (zip ixs alts)+++simpleMenuF fname name = oldMenuF fname name . map (\x -> (x,[]))++oldMenuF :: (Graphic c, Eq b, Graphic a) => FontName -> a -> [(b, [(ModState, KeySym)])] -> (b -> c) -> F a b +oldMenuF fname name alts show_alt =+    grabberF [] (buttonMenuF Horizontal fname name alts menuAlts>=^<mapEither id Left)+  where+    menuAlts = menuAltsF' fname (map fst alts) show_alt >=^^< filterRightSP++menuAltsF' fname alts show_alt =+    fst >^=< listLF (verticalP' 0) (map altButton alts)+  where+    altButton (alt{-, keys-}) = (alt, menuButtonF fname {-keys-} (show_alt alt))++menuAltsF fname alts show_alt =+   menuPopupF (menuAltsF' fname alts show_alt) >=^< Left++grabberF alts mF = loopCompThroughRightF (groupF startcmds grabK0 mF)+  where+    startcmds = map XCmd transinit+    grabK0 = grabK False++    transinit =+        if null keys+	then []+        else  [TranslateEvent tobutton [KeyPressMask, KeyReleaseMask]]+      where+        keys = concatMap snd alts+        tobutton e@(KeyEvent {state=s,keySym=ks}) | (s, ks) `elem` keys = Just e+	tobutton _ = Nothing+    grabK up = getK $ message low high+      where+	keyalts = [(k,a)|(a,ks)<-alts,k<-ks]+	same = grabK up+	popdown = grabK False+	popup = grabK True+	low event =+	  case event of+	    XEvt (KeyEvent {state=s,keySym=ks,type'=Pressed}) ->+		puts [Left (Right alt)|(key,alt)<-keyalts,(s,ks)==key] same+	    _ ->  same+	high = either fromLoop fromOutside+	fromLoop = either menuCoordination menuSelection+	fromOutside x = putHigh (Left (Right x)) same+	menuSelection x = putHigh (Right x) same+	menuCoordination newState =+	  case (up,newState) of+	    (False,MenuUp _) ->+	      --trace "grabberF: GrabEvents False" $+	      xcommandK (GrabEvents False) popup+	    (True,MenuDown) ->+	      --trace "grabberF: UngrabEvents" $+	      xcommandK UngrabEvents popdown+	    _ -> same++data MenuState = MenuDown | MenuUp MenuMode deriving (Show)+type MenuMode = Bool -- True = sticky+menuDown = MenuDown+menuUpSticky = MenuUp True+menuUpMPopup = MenuUp False+-- Invariant: menu state never changes directly from MenuDown to menuUpSticky,+-- i.e., when a menu first pops up, it always outputs menuUpMPopup++data ButtonMenuState =+  S { mpopup,othermpopup,sticky,debug::Bool, size::Size } deriving (Show)+bstate0 = S False False False False 0++{-+buttonMenuF :: (Graphic a) =>+	 LayoutDir -> FontName -> a ->+	 [(b, [(ModState, KeySym)])] ->+	 F (Either MenuState b) b ->+	 F (Either MenuState (Either a b)) (Either MenuState b)+-}+buttonMenuF x = buttonMenuF' False x+buttonMenuF' delayed dir fname name alts menuAltsF =+    loopCompThroughRightF $+    showCommandF "buttonMenuF" $+    groupF startcmds+	   (mapstateK proc bstate0)+	   (filterRightSP >^^=< (menuLabelF fname name >+< theMenuF))+  where+    theMenuF = menuPopupF' delayed menuAltsF+    topopup = High . Left . Right . Left+    tosubmenus = High . Left . Right . Right . Left+    inputtosubmenus = High . Left . Right . Right . Right+    out = High . Right . Right+    othermenu = High . Right . Left+    toDisp = High . Left . Left+    relabel = toDisp . Right+    adjust =+	case dir of+	  Vertical -> \ (Point w _) -> pP w (-1)+	  Horizontal -> \ (Point _ h) -> pP (-1) h+    proc state@(S{mpopup=mpopup,othermpopup=othermpopup,sticky=sticky,size=size,debug=debug}) =+	message low high+      where+	dbg x = if debug then trace ("buttonMenuF "++x) else id++	popdownyield = popdown' True [] --pop down because other menu popped up+	popdownlast = -- pop down, no other menu is up+	  dbg "popdownlast" $+	  popdown' False [othermenu MenuDown]+	popdown' mpopup' msgs =+	  (state{othermpopup=mpopup'},+	   msgs++[tosubmenus menuDown,topopup PopdownMenu])++	stickyMode =+	  dbg "othermenu menuUpSticky" $+	  (state{sticky=True},+	   [othermenu menuUpSticky,topopup PopupMenuStick])++	mPopupMode b = (state{mpopup=b},[])+	highlight = toDisp . Left+	put msgs = (state,msgs)++	high = either fromMenu (either fromOtherMenu fromOutside)+	fromOutside = either newLabel altInput+	newLabel lbl = (state,[relabel lbl])+	altInput x = (state,[inputtosubmenus x])++	fromOtherMenu newMode =+	  dbg ("fromOtherMenu "++show newMode) $+	  case newMode of+	    MenuUp False -> popdownyield -- other menu popped up, pop down+	    MenuUp True -> (state{othermpopup=False},[])+	    MenuDown -> popdown' False []++	fromMenu alt =+	  (state{sticky=False},+	   [tosubmenus menuDown,othermenu menuDown,out alt])+	low resp =+	  dbg (unlines [show state, show resp,""]) $+	  case resp of+	    XEvt event ->+	      case event of+		ButtonEvent {button=Button 2,type'=Pressed,state=mods} ->+		  trace "Button 2" $+		  (state{debug=Control `elem` mods},[])+		--ButtonEvent _ winpos rootpos mods Pressed (Button 1) ->+		ButtonEvent {pos=winpos,rootPos=rootpos,state=mods,type'=Pressed,button=Button 1} ->+		  dbg "output othermenu True" $+		  (state{sticky=False},+		   [othermenu menuUpMPopup, -- tell other menus to pop down+		    topopup (PopupMenu (rootpos-winpos+adjust size) event)+		    --highlight True,+		    --Low (GrabEvents False)+		    ])+		LeaveNotify {mode=NotifyUngrab,detail=NotifyInferior}+		    | stickyMenus && not mpopup -> stickyMode+		LeaveNotify {mode=NotifyUngrab} {-  | not sticky-} -> popdownlast+		--  ^^ these events get lost in focusMgr it seems+		ButtonEvent {pos=pos,button=Button 1,type'=Released}+		    | not (stickyMenus && pos `inRect` (Rect 0 size)) -> popdownlast+			     --workaround+		LeaveNotify {detail=detail}+		    | detail/=NotifyInferior ->+			if False --mpopup+			then popdownlast+			else put [highlight False]+		EnterNotify {rootPos=rootpos,pos=winpos,mode=NotifyNormal}+		  | mpopup || othermpopup ->+		      dbg "output othermenu True" $+		      (state{sticky=False},+		       [othermenu menuUpMPopup, -- tell other menus to pop down+			topopup (PopupMenu (rootpos-winpos+adjust size) event),+			highlight True])+		  | otherwise -> put [highlight True]+		KeyEvent {state=s,type'=Pressed,keySym=ks} ->+		  case [ a | (a,keys) <- alts, (s,ks) `elem` keys] of+		    a:_ -> put [out a]+		    _ -> error "MenuF.clickF bug"+		MenuPopupMode b -> mPopupMode b+		_ -> (state,[])+	    LEvt (LayoutSize size') -> (state{size=size'},[])+	    _ -> (state,[])++    startcmds = map XCmd (MeButtonMachine : grab +++	                  [ConfigureWindow [CWBorderWidth 1],+			   ChangeWindowAttributes wattrs] +++			  transinit)+    grab = [GrabButton True (Button 1) [] ptrmask]+    ptrmask = [ButtonPressMask, ButtonReleaseMask]+    wattrs = [CWEventMask eventmask]+    eventmask = [LeaveWindowMask, EnterWindowMask,+		 ButtonPressMask -- Button 2 press, for debuggin only!+		]++    keys = concatMap snd alts++    transinit =+        if null keys+	then []+        else  [TranslateEvent tobutton [KeyPressMask, KeyReleaseMask]]+      where+        tobutton e@(KeyEvent {state=s,keySym=ks}) | (s, ks) `elem` keys = Just e+	tobutton _ = Nothing++stickyMenus = argFlag "stickymenus" False
+ hsrc/fudgets/MenuPopupF.hs view
@@ -0,0 +1,117 @@+module MenuPopupF(PopupMenu(..), menuPopupF, menuPopupF') where+import Command+import Cursor+import Shells(unmappedShellF')+import FDefaults() -- synonym Customiser, for hbc+import DShellF(setFocusMgr)+import Event+import Fudget+import FRequest+import Geometry(Point)+import Loops(loopCompThroughRightF,loopThroughRightF)+--import Message(Message(..))+import CompSP(prepostMapSP)+import SerCompF(mapstateF)+import NullF+import Xtypes+import Data.List(union)++data PopupMenu+  = PopupMenu Point XEvent -- Time to pop up the menu.+  | PopupMenuStick	   -- The mouse button has been released, but stay up.+  | PopdownMenu		   -- Time to hide the menu.+  deriving Show+  --deriving (Eq, Ord)++menuPopupF = menuPopupF' False++menuPopupF' delayed menu =+    loopCompThroughRightF (dF $ unmappedShellF' pm startcmds popupShellK menu')+  where+    dF = if delayed then delayF else id+    pm = setFocusMgr False+    menu' = handleButtonMachinesF menu+    startcmds = [XCmd $ ChangeWindowAttributes wattrs,+		 XCmd $ ConfigureWindow [CWBorderWidth 1]]+    wattrs = [CWEventMask [], CWSaveUnder True, CWOverrideRedirect True]++popupShellK =+    setFontCursor 110 downK+  where+    mouse (ButtonEvent {}) = True+    mouse (EnterNotify {}) = True+    mouse _ = False+    samekey (KeyEvent {keySym=ks}) ks' = ks == ks'+    samekey _ _ = False++    toMenu = High . Left . Right+    toBms = High . Left . Left+    out = High . Right++    popdown = map (Low . XCmd) [UnmapWindow]+    popup p = toBms True:map (Low . XCmd) [moveWindow p, MapRaised]++    downK =+      getK $ \msg ->+      case msg of+	High (Right (Left (PopupMenu p ev))) -> putsK (popup p)     $ upK ev+	High (Right (Right x))               -> putK  (toMenu x)    $ downK+	High (Left x)                        -> putK  (out x)       $ downK+	_ -> downK++    upK ev =+      getK $ \msg ->+      case msg of+	High (Right (Left (PopupMenu p ev))) -> putsK (popup p)     $ upK ev+	High (Right (Left PopdownMenu))      -> putsK popdown       $ downK+	High (Right (Left PopupMenuStick))   -> putK  (toBms False) $ upK ev+	High (Right (Right x))               -> putK  (toMenu x)    $ upK ev+	High (Left x) ->+	  if mouse ev+	  then putsK (out x : popdown) $ downK+	  else putK  (out x)           $ upK ev+	Low (XEvt (KeyEvent {type'=Released, keySym=ks})) ->+	  if samekey ev ks+	  then putsK popdown downK+	  else upK ev+	_ -> upK ev++{- handleButtonMachineF fud records the paths of all button machines in fud, so+   that a message can be broadcast to them when the MenuPopup mode changes.+   It also keeps track of the current mode to avoid sending the same mode twice.+-}++handleButtonMachinesF fud =+    loopThroughRightF ctrlF (liftbm fud)+  where+    ctrlF = mapstateF ctrl (False,[])++    ctrl state@(mode,bms) = either fromLoop fromOutside+      where+	fromLoop (Left path) = addbm path+	fromLoop (Right y) = out y++        fromOutside (Left mode') = changeMode mode'+	fromOutside (Right x) = inp x++        addbm path = ((mode,[path] `union` bms),[Left (Left (path,mode))])+	  -- Tell the new button the current mode. (Needed in case it is+	  -- dynamically created inside a menu.)+        out y = (state,[Right y])+	inp x = (state,[Left (Right x)])++	changeMode mode' =+	  if mode'/=mode+	  then ((mode',bms),[Left (Left (path,mode')) | path<-bms])+	      -- !! This will send msgs also to buttons that have been destroyed+	  else (state,[])++    liftbm (F sp) = F $ prepostMapSP pre post sp+      where+	pre (High (Left (path,mode))) = Low (path,XEvt (MenuPopupMode mode))+	pre (High (Right x)) = High x+	pre (Low tevent) = Low tevent++	post (Low (path,XCmd MeButtonMachine)) = High (Left path)+	post (Low tcmd) = Low tcmd+	post (High y) = High (Right y)
+ hsrc/fudgets/MoreF.hs view
@@ -0,0 +1,65 @@+module MoreF(+  moreF,moreF',+  pickListF,pickListF',PickListRequest(..)+) where++import Fudget+--import Xtypes+import ResourceIds() -- synonym ColorName, for hbc+import Spops+import Geometry+import ScrollF(oldVscrollF,grabScrollKeys)+import TextF+import Spacer(marginF)+import SerCompF(absF)+import Loops(loopThroughRightF)+import CompOps((>=^<))+import StringUtils(rmBS,expandTabs)+import Defaults(labelFont,paperColor)+import GCAttrs() -- instances++import FDefaults+--import Alignment+import InputMsg(InputMsg,mapInp)+import ListRequest(ListRequest(..),replaceAll,replaceItems,applyListRequest)++txtF' pmod = marginF 5 $+             --alignSepF 5 aLeft aTop $+	     textF' pmod++--stringListF :: Size -> FontName -> F TextRequest (InputMsg (Int,String))+stringListF' size pmod = oldVscrollF grabScrollKeys (size,size) (txtF' pmod)++moreF = moreF' standard++moreF' :: Customiser TextF -> F [String] (InputMsg (Int,String))+moreF' pmod =+    stringListF' (pP 480 260) pmod' >=^<(replaceAll.map (rmBS.expandTabs 8))+  where+    pmod' = pmod.setBgColor paperColor++type PickListRequest a = ListRequest a++pickListF = pickListF' standard++pickListF' :: Customiser TextF -> (a->String) -> F (PickListRequest a) (InputMsg (Int,a))+pickListF' pmod show =+    loopThroughRightF (absF (pickSP [])) altListF+  where+    pmod' = pmod.setFont labelFont+    altListF = oldVscrollF grabScrollKeys (Point 240 260,Point 480 390) (txtF' pmod')+    pickSP alts =+      getSP $ \msg ->+      case msg of+        Right plreq@(ReplaceItems from cnt newalts') ->+	  let alts' = applyListRequest plreq alts+	      newalts = map show newalts'+	  in putSP (Left (replaceItems from cnt newalts)) $+	     evalSpine alts' $ -- prevents a space leak+	     pickSP alts'+        Right (HighlightItems ns) -> putSP (Left (HighlightItems ns)) $ pickSP alts+	Right (PickItem n) ->  putSP (Left (PickItem n)) $ pickSP alts+	Left msg -> putSP (Right (mapInp (\(n,_)->(n,alts!!n)) msg)) (pickSP alts)++evalSpine [] = id+evalSpine (x:xs) = evalSpine xs
+ hsrc/fudgets/MoreFileF.hs view
@@ -0,0 +1,44 @@+module MoreFileF(+  moreFileShellF,+  moreShellF,moreShellF',+  moreFileF+) where+import MoreF(moreF')+import Command+import CompOps((>==<), (>=^<), (>^=<), (>=^^<))+import Shells(unmappedShellF, unmappedSimpleShellF)+import Fudget+import FRequest+import ReadFileF(readFileF)+--import Message(Message(..))+import SpEither(toBothSP)+import Spops(concmapSP)+--import Xtypes+import EitherUtils(stripEither)+import FDefaults+import InputMsg(InputMsg)+import DialogueIO() -- instances, for hbc+++moreShellF' pmod name = unmappedSimpleShellF name $ moreF' pmod+moreShellF = moreShellF' standard++moreFileF :: F String (InputMsg (Int, String))+moreFileF = moreFileF' standard+moreFileF' pmod = moreF' pmod >=^< contents >==< readFileF++moreFileShellF =+  let startcmds = [XCmd $ StoreName "More Fudget"]+      titleK = K{-kk-} $ concmapSP changeName  -- titleK never outputs anything+  in stripEither >^=< unmappedShellF startcmds titleK moreFileF >=^^< toBothSP++contents (name,file) =+  case file of+    Right s -> lines s+    Left err -> [name++": "++show err] -- missing Show instance for IOError+    --Left err -> [name++": error"]++changeName msg =+  case msg of+    High name -> [Low $ XCmd $ StoreName name, Low $ XCmd MapRaised]+    _ -> []
+ hsrc/fudgets/OnOffDispF.hs view
@@ -0,0 +1,30 @@+module OnOffDispF where+import CompOps((>=^<),(>^^=<))+import NullF(F)+import Spops(nullSP)+--import Xtypes+import ResourceIds() -- synonym ColorName, for hbc+import Geometry(Point(..))+import MeasuredGraphics(emptyMG)+import GraphicsF(graphicsDispF',GfxCommand(..),setGfxEventMask)+import FDefaults+import GCAttrs+--import Drawing( ) -- instances+import Graphic( )+import Defaults(bgColor, fgColor)+import CmdLineEnv(argKey)+import Sizing(Sizing(..))++onOffDispF :: Bool -> F Bool nothing+onOffDispF start = nullSP >^^=< graphicsDispF' custom >=^< pre+  where+    custom = setInitDisp (emptyMG dsize) . setGfxEventMask [] .+	     setSizing Static . setBorderWidth 0 .+	     setBgColor (color start)+    color on = if on then onColor else offColor+    dsize = Point 7 7+    --pre :: Bool -> GfxCommand Bool -- resolving overloading...+    pre = ChangeGfxBg . colorSpec . color++offColor = argKey "toggleoff" bgColor+onColor  = argKey "toggleon" fgColor
+ hsrc/fudgets/PopupMenuF.hs view
@@ -0,0 +1,90 @@+module PopupMenuF(popupMenuF,oldPopupMenuF,oldPopupMenuF') where+--import ButtonGroupF+import Command+import CompOps((>=^<), (>^=<),(>+<))--(>==<), +import InfixOps((>=..<))--(>^^=<),+import Dlayout(groupF)+import Event+--import Font(FontStruct)+import Fudget+import FRequest+--import Geometry(Line, Point, Rect, Size(..))+import GreyBgF(changeBg)+--import LayoutRequest(LayoutRequest)+import MenuF(menuAltsF,toEqSnd,fstEqSnd,sndEqSnd)--EqSnd,+import MenuPopupF(PopupMenu(..))+import DynListF(dynF)+--import Message(Message(..))+import Path(here)+import SerCompF(serCompLeftToRightF)--idRightF,+import Spops+import EitherUtils(mapEither)+import Xtypes+import CompSP(serCompSP)+import Defaults(bgColor,menuFont)+import Utils(pair)+import NullF(delayF)+--import ShowCommandF(showCommandF) -- debugging+--import SpyF(teeF) -- debugging++--popupMenuF :: [(alt,String)] -> F i o -> F (Either x i) (Either alt o)+popupMenuF alts f =+    mapEither fstEqSnd id>^=<+    oldPopupMenuF bgColor True menuFont (Button 3) [] []+                  (pre alts) sndEqSnd f+    >=^< mapEither pre id+  where+    pre = map (`pair` []) . toEqSnd++oldPopupMenuF bgcolor grab fname button mods keys alts show_alt f = + serCompLeftToRightF $+ oldPopupMenuF' bgcolor grab fname button mods keys alts show_alt f++oldPopupMenuF' bgcolor grab fname button mods keys alts show_alt f =+    let grabeventmask = [ButtonPressMask, ButtonReleaseMask]+        grabcmd = if grab then [GrabButton True button mods grabeventmask]+	          else []+        eventmask =+	  (if null keys then [] else [KeyPressMask, KeyReleaseMask]) +++          (if grab then [] else (OwnerGrabButtonMask:grabeventmask)) +++	  [LeaveWindowMask]+        startcmds = grabcmd ++ [ChangeWindowAttributes [CWEventMask eventmask]]+        ungrab = concatMapSP un where+	       un (High m) = [High m,Low (here,XCmd UngrabEvents)]+	       un m = [m]++        F dynAltsFSP = dynAltsF+	dynAltsF =+	    dynF (altsF alts) >=^< mapEither altsF id+	  where+	    altsF alts' = delayF' (menuAltsF fname (map fst alts') show_alt)+	     -- !! keyboard shortcuts ignored !!+	    delayF' f = delayF f >=..< filterSP notDestroy+	    --delayF' = id+	    --delayF' f = delayF (showCommandF "altsF" f >==< teeF show "altsF: ")+	    notDestroy (_,XEvt (DestroyNotify _)) = False+	    notDestroy _ = True++    in  (groupF (map XCmd startcmds)+               (changeBg bgcolor (actionK grab button keys mods))+               (F{-ff-} (ungrab `serCompSP` dynAltsFSP) >+< f))++actionK grab button keys mods = K{-kk-} $ concmapSP action where+    toF = High . Right+    toMenu = High . Left . Right+    newMenu = High . Left . Left+    action msg = case msg of+      High (Right hmsg) -> [toF hmsg]+      High (Left alts) -> [newMenu alts] -- breaks backwards compatibility...+      Low (XEvt ev) -> case ev of+        ButtonEvent {rootPos=rootPos,state=m,type'=Pressed,button=b} | m == mods && b == button -> +	       [Low $ XCmd (GrabEvents True),toMenu (PopupMenu rootPos ev)]+        KeyEvent {rootPos=rootPos,state=m,type'=Pressed,keySym=ks} | (m, ks) `elem` keys -> +	       [toMenu (PopupMenu rootPos ev)]+        LeaveNotify {mode=NotifyUngrab} -> +	       [Low $ XCmd UngrabEvents,toMenu PopdownMenu]+        ButtonEvent {type'=Released} -> +	       [Low $ XCmd UngrabEvents,toMenu PopdownMenu]+        KeyEvent {type'=Released} -> [toMenu PopdownMenu]+        _ -> []+      Low _ -> []
+ hsrc/fudgets/PushButtonF.hs view
@@ -0,0 +1,21 @@+module PushButtonF(pushButtonF, pushButtonF', Click(..)) where+import ButtonBorderF+import ButtonGroupF+import InputMsg(Click(..))+import CompOps((>=^<))+import Defaults(edgeWidth)+--import Fudget+import SerCompF(idRightF)++pushButtonF = pushButtonF' edgeWidth++pushButtonF' edgew keys f =+    buttonGroupF keys (idRightF (buttonBorderF edgew f) >=^< prep)+  where+    toBorder = Left . Left+    toFudget = Left . Right+    through = Right+    prep (Left BMNormal) = toBorder False+    prep (Left BMInverted) = toBorder True+    prep (Left BMClick) = through Click+    prep (Right e) = toFudget e
+ hsrc/fudgets/QuitButtonF.hs view
@@ -0,0 +1,21 @@+module QuitButtonF where+import Spacer(marginHVAlignF)+import Alignment+import DButtonF+import FDefaults+import CompOps((>==<))+--import Defaults(buttonFont)+--import Event(Event(..))+--import Fudget+--import PushButtonF+import QuitF+--import AuxTypes(Modifiers(..))+import Defaults(metaKey)+import Graphic( )++quitButtonF =+    quitF >==<+    marginHVAlignF 0 aRight aBottom+    (buttonF' (setKeys [([metaKey], "q")]) "Quit")++
+ hsrc/fudgets/QuitF.hs view
@@ -0,0 +1,19 @@+module QuitF(quitIdF, quitF) where+import FudgetIO+import HaskellIO+import NullF+import DialogueIO hiding (IOError) -- Exit++--quitF :: F a b+quitF =+    getHigh $ \ _ ->+    hIOSuccF (Exit 0) $+    nullF++--quitIdF :: (a -> Bool) -> F a a+quitIdF p =+    getHigh $ \ msg ->+    (if p msg+     then hIOSuccF (Exit 0)+     else putHigh msg) $+    quitIdF p
+ hsrc/fudgets/RadioF.hs view
@@ -0,0 +1,49 @@+module RadioF(radioF, oldRadioGroupF) where+import Spacer(noStretchF)+--import Alignment(Alignment(..))+--import ButtonGroupF+import CompOps((>==<), (>=^<))+import HbcUtils(lookupWithDefault)+--import Fudget+--import Geometry(Point, Rect, Size(..))+import LayoutF(listLF)+--import Placers+import Loops(loopLeftF)+import SerCompF(absF)+import Spops+import EitherUtils(stripEither)+import ToggleButtonF(oldToggleButtonF')+--import Xtypes+import Utils(pair)++radioF placer inside fname alts startalt =+  oldRadioGroupF placer inside fname (map fst alts) startalt (lookupWithDefault alts (error "radioF"))++oldRadioGroupF placer inside fname alts startalt show_alt =+    let radioAlts = radioButtonsF placer inside fname alts show_alt+        buttons = radioAlts >=^< stripEither+    in  loopLeftF (excludeF startalt >==< buttons) >=^< (`pair` True)++radioButtonsF placer inside fname alts show_alt =+  listLF placer (map radiobutton alts)+  where+     radiobutton alt =+        (alt, noStretchF False True $ +              oldToggleButtonF' inside fname [] (show_alt alt))++excludeF start =+    absF (putsSP [Left (start, True)] (excl start))+  where+    excl last' =+      getSP $ \msg ->+      case msg of+	(new, False) -> if new == last'+			then putsSP [Left (new, True)] (cont new)+			else same+	(new, True)  -> if new == last'+		        then putsSP [Right new] (cont new)+		        else putsSP [Left (last', False), Right new] (cont new)+      where+        same = excl last'+	cont last'' = excl last''+
+ hsrc/fudgets/StringF.hs view
@@ -0,0 +1,339 @@+{-# LANGUAGE CPP #-}+module StringF(+  stringF'',StringF,+  {-HasBorderWidth(..),HasAllowedChar(..),HasShowString(..),-}+  getAllowedChar,setAllowedChar,getShowString,setShowString,+  setInitStringSize,+  getCursorPos,setCursorPos,getInitString,setInitString,+  generalStringF, oldIntF, oldPasswdF, oldStringF, bdStringF, oldGeneralStringF+  ) where+import BgF(changeGetBackPixel)+--import Color+import Command+import DrawInWindow+import CompOps((>=^<), (>^=<))+--import Utils(bitand)+import HbcWord+import Cursor+import Defaults(defaultFont, inputFg, inputBg, metaKey)+import CmdLineEnv(argKey, argKeyList)+import Dlayout(windowF)+import Event+import Font(split_string,font_ascent,next_pos,linespace,font_id,string_box_size,font_range)+import Fudget+--import FudgetIO+import FRequest+import Xcommand+import Gc+import Xtypes+import Geometry(Point(..), pP, rR,pmax)+import LayoutRequest(plainLayout,LayoutResponse(..))+--import LoadFont+--import Message(Message(..))+import NullF+--import Spops+import StringEdit+import InputMsg(InputMsg(..),mapInp,inputLeaveKey)+import InputF(InF(..))+import SelectionF+import Loops(loopThroughRightF)+import Sizing+#ifdef __GLASGOW_HASKELL__+import FDefaults hiding (setInitSize,getInitSize,getInitSizeMaybe)+#else+-- Some versions of HBC fail if you mention a constructor class in an import spec.+--import FDefaults hiding (HasInitSize)+import FDefaults(cust,getpar,getparMaybe,HasBorderWidth(..),HasSizing(..),HasBgColorSpec(..),HasFgColorSpec(..),HasFontSpec(..),Customiser(..),PF(..))+#endif+import Data.Char(isPrint,isDigit)+import GCAttrs --(ColorSpec,colorSpec,convColorK) -- + instances++default(Int)++-- chr/ord are defined in *some* versions of the library module Char...+chr' = toEnum . wordToInt :: (Word->Char)+ord' = fromIntegral . fromEnum :: (Char->Word)+++#include "defaults.h"++newtype StringF = Pars [Pars]++parameter(AllowedChar)+parameter(ShowString)+parameter(CursorPos)+parameter(InitString)++parameter_instance(BorderWidth,StringF)+parameter_instance(FgColorSpec,StringF)+parameter_instance(BgColorSpec,StringF)+parameter_instance(FontSpec,StringF)+parameter_instance(Sizing,StringF)+--parameter_instance(InitSize,StringF) -- StringF has wrong kind for this+parameter(InitSize)++setInitStringSize = setInitSize -- avoid name clash++data Pars+  = BorderWidth Int+  | FgColorSpec ColorSpec+  | BgColorSpec ColorSpec+  | FontSpec FontSpec+  | AllowedChar (Char->Bool)+  | ShowString (String->String)+  | InitSize String+  | Sizing Sizing+  | CursorPos Int -- puts cursor after the nth character+  | InitString String++isTerminator key = key `elem` ["Escape", "Return", "KP_Enter", "Tab", "Up", "Down"]++isBackSpace (c : _) = c == '\BS' || c == '\DEL'+isBackSpace _ = False++ctrl c = chr' (bitAnd (ord' c) (65535-96))++isCtrl c (c':_) = c' == ctrl c+isCtrl _ _      = False++isKill = isCtrl 'u'++modchar mods c0 = if metaKey `elem` mods then chr' (ord' c0 `bitOr` 128) else c0++cursorBindings' =+  [(([], "Left"), moveCursorLeft),+   (([], "Right"), moveCursorRight),+   (([], "Home"), moveCursorHome),+-- (([], "Up"), moveCursorHome),+   (([], "End"), moveCursorEnd),+-- (([], "Down"), moveCursorEnd),+--   (([Shift],"Control"), moveCursorHome), -- ???+--   (([Shift],"Control"), moveCursorEnd), -- ???+   (([Shift],"Left"), extendCursorLeft),+   (([Shift],"Right"), extendCursorRight),+   (([Shift],"Home"), extendCursorHome),+   (([Shift],"Up"), extendCursorHome),+   (([Shift],"End"), extendCursorEnd),+   (([Shift],"Down"), extendCursorEnd)]+   ++ emacsBindings++emacsBindings = +  [(([Control], "b"), moveCursorLeft),+   (([Control], "f"), moveCursorRight),+   (([Control], "e"), moveCursorEnd),+   (([Control], "a"), moveCursorHome)]++cursorKey' mods key = lookup (filter (<=Mod5) mods,key) cursorBindings'++hmargin = 3+vmargin = 2++placecursor font (Point x _) field =+    case getField field of+      [] -> field+      cs -> let (lcs, rcs, _) = split_string font cs (x - hmargin)+            in  createField2 (lcs, rcs)++showinputfield gc gcinv font show' = showinputfield'+  where+    drimstr = if snd (font_range font) > '\xff'+              then wDrawImageString16+	      else wDrawImageString++    showinputfield' active field =+      let y = font_ascent font + 1+	  draw x s = if null s then [] else [drimstr gc (pP x y) s]+	  showpart gc' s0 (x, cmds) =+	      let s = show' s0+	      in  (x + next_pos font s, draw x s ++ cmds)+	  showcursor s (x1, cmds) =+	      let (x2, cmds') = showpart gc s (x1, cmds)+		  cmd = if active+			then [wFillRectangle gcinv+					     (rR (x1 - 1) 1+						 (x2 - x1 + 1) (linespace font))]+		        else []+	      in  (x2, cmds' ++ cmd)+      in  snd (showField (showpart gc) showcursor field (hmargin, []))++createField' pos s =+  if pos<0+  then createField s+  else createField2 (splitAt pos s)++stringK bw initsize sizing bgcolor fgcolor fontspec allowedchar show' cursor defaultText active =+    setFontCursor 152 $+    xcommandK (ConfigureWindow [CWBorderWidth bw]) $+    changeGetBackPixel bgcolor $ \bg ->+    convColorK fgcolor $ \fg ->+    convFontK fontspec $ \ fd ->+    fontdata2struct fd $ \ font ->+    wCreateGC rootGC [GCFunction GXcopy, GCFont (font_id font),+                      GCForeground fg, GCBackground bg] $ \drawGC ->+    wCreateGC rootGC (invertColorGCattrs bg fg) $ \invertGC ->+    let drawit field active = map Low (XCmd ClearWindow : drawcmds)+          where drawcmds = shinpf active field+	shinpf = showinputfield drawGC invertGC font show'+	stringproc size' field active =+	   let redraw f =+	         putsK (drawit f active) (stringproc size' f active)+	       nochange = stringproc size' field active+	       newsize s = stringproc s field active+	       changeactive a = putsK (drawit field a) $+	                        stringproc size' field a+	       emit msg f a = putsK (drawit f a ++ [High (Right msg)]) $+	                      stringproc size' f a+	       emitchange f =+	          let gf = getField f+		  in  updlayout size' gf (emit (InputChange gf) f active)+	       emitdone key f = emit (InputDone key (getField f)) f active+	       emitleave =+	         emit (InputDone inputLeaveKey (getField field)) field False+	       paste = putK (High (Left PasteSel)) nochange+	       copy = putK (High (Left (Sel (getField field)))) nochange+	   in getK $ \msg ->+	      case msg of+	        Low (XEvt event) ->+		  case event of+	            Expose _ _ -> redraw field+		    KeyEvent _ _ _ mods Pressed _ key ascii ->+		      case ascii of+			c0 : _ | allowedchar c -> ec (insertItem field c)+			   where c = modchar mods c0+			_ | isTerminator key ->+			       emitdone key (createField (getField field))+			  | isBackSpace ascii -> ec (deleteItemLeft field)+			  | isCtrl 'd' ascii  -> ec (deleteItemRight field)+			  | isCtrl 'k' ascii  -> ec (deleteToEnd field)+			  | isCtrl 'y' ascii  -> paste+			  | isCtrl 'c' ascii  -> copy+			  | isCtrl 'w' ascii  -> copy -- should acutally be cut+			  | isKill     ascii  -> ec (createField "")+			  | otherwise ->+			       case cursorKey' mods key of+				 Just ed -> redraw (ed field)+				 _ -> case key of+					"SunPaste" -> paste+					"SunCopy" -> copy+					_ -> --putK (Low (Bell 0)) $+					     nochange+		       where ec = emitchange+	            ButtonEvent {pos=p, button=Button 1} ->+		      redraw (placecursor font p field)+	            ButtonEvent {button=Button 2} -> paste+		    FocusIn  {} -> changeactive True+		    FocusOut {} -> emitleave+                    _ -> nochange+		Low (LEvt (LayoutSize nsize)) -> newsize nsize+		High (Right (Right newtext)) ->+		   if newtext/=getField field+		   then emitchange (createField newtext)+		   --else updlayout size' newtext (redraw (createField newtext))+		   else nochange+		High (Right (Left customiser)) ->+		  reconfigure customiser field active+		High (Left (SelNotify cs)) ->+		     emitchange (insertItemsSelected field s)+		   where s = filter allowedchar cs+		_ -> nochange++	reconfigure pmod field active =+	    -- !! unload fonts, free GCs & colors...+	    stringK bw' initsize' sizing' bgcolor' fgcolor' fontspec' allowed' show'' cursor' txt' active+	    -- !!! Bad: active will be reset to False.+	    -- !! A new layout request will be output (useful if font changed).+	  where ps = pmod (Pars [BorderWidth bw,+                                 BgColorSpec bgcolor,+				 FgColorSpec fgcolor,+				 FontSpec fontspec,+				 AllowedChar allowedchar,+				 ShowString show',+				 CursorPos (-1), -- !!+				 InitSize initsize,+				 Sizing sizing])+		bw' = getBorderWidth ps+		initsize' = txt' --getInitSize ps -- hmm !!+		sizing' = getSizing ps+		bgcolor' = getBgColorSpec ps+		fgcolor' = getFgColorSpec ps+		fontspec' = getFontSpec ps+		allowed' = getAllowedChar ps+		show'' = getShowString ps+		txt' = getField field+		cursor' = getCursorPos ps++	sizetext text = pP (2*hmargin) (2*vmargin) + string_box_size font text+	size = pmax (sizetext defaultText) (sizetext initsize)+	updlayout curSize gf =+	   let reqSize = sizetext gf+	       nsize = newSize sizing curSize reqSize+	   in if nsize /= curSize then putlayoutlims nsize else id+	putlayoutlims size' =+	   putK (Low (layoutRequestCmd (plainLayout size' False True)))+    in putlayoutlims size $+       stringproc size (createField' cursor defaultText) active++generalStringF bw initsize sizing bg fg fontspec allowedchar show' cursor txt =+   loopThroughRightF winF selectionF+  where+    eventmask = [ExposureMask, KeyPressMask, ButtonPressMask,+		 EnterWindowMask, LeaveWindowMask -- to be removed+		 ]+    startcmds = [XCmd $ +                 ChangeWindowAttributes [CWBitGravity NorthWestGravity,+					 CWEventMask eventmask+					 {-,CWBackingStore Always-}]+		]+    winF = windowF startcmds +	           (stringK bw initsize sizing bg fg fontspec+		            allowedchar show' cursor txt False)++stringF'' :: (Customiser StringF) -> PF StringF String (InputMsg String)+stringF'' pmod = generalStringF bw initsize sizing bg fg font allowed show cursor initstring+  where+    ps = pmod (Pars [BorderWidth 1,+                     BgColorSpec inputbg,+		     FgColorSpec inputfg,+		     FontSpec stringfont,+		     AllowedChar isPrint',+		     ShowString id,+		     InitSize "xxxxx",+		     Sizing Growing,+		     CursorPos (-1),+		     InitString ""])+    bw = getBorderWidth ps+    bg = getBgColorSpec ps+    fg = getFgColorSpec ps+    font = getFontSpec ps+    allowed = getAllowedChar ps+    show = getShowString ps+    --initsize = "xxxxx"+    initsize = getInitSize ps+    sizing = getSizing ps+    cursor = getCursorPos ps+    initstring = getInitString ps+++oldGeneralStringF bw sizing font allowed show txt =+  generalStringF bw "xxxxx" sizing inputbg inputfg font allowed show (-1) txt >=^< Right++bdStringF bw dyn font = oldGeneralStringF bw dyn font isPrint' id++oldStringF :: String -> InF String String+oldStringF = bdStringF 1 Growing stringfont++oldPasswdF :: String -> InF String String+oldPasswdF = oldGeneralStringF 1 Static stringfont isPrint' (map (const '*'))++oldIntF :: Int -> InF Int Int+oldIntF default' =+    mapInp read >^=<+    oldGeneralStringF 1 Static stringfont isDigit id (show default') >=^<+    show++stringfont = fontSpec (argKey "inputfont" defaultFont)+inputbg = colorSpec (argKeyList "stringbg" [inputBg])+inputfg = colorSpec (argKeyList "stringfg" [inputFg])++-- Workaround limitations of HBC's Char.isPrint to allow Unicode input.+isPrint' c = c>'\xff' || isPrint c
+ hsrc/fudgets/TerminalF.hs view
@@ -0,0 +1,130 @@+module TerminalF(terminalF,cmdTerminalF,TerminalCmd(..)) where+import Spacer(marginF)+--import Alignment(Alignment(..))+import BgF+import Color+import Command+import FRequest+import DrawInWindow(wDrawImageString,wDrawImageString16,wCopyArea)+import XDraw+import Defaults(paperColor, fgColor)+import Dlayout(simpleGroupF, windowF)+import Event+import Font+import Fudget+--import FudgetIO+import Gc+import Geometry(Point(..), Rect(..), origin, pP, padd,)-- rectsize+import LayoutRequest+--import Placer(spacerF)+--import Spacers+import LoadFont+--import Message(Message(..))+import NullF+import StateMonads+--import EitherUtils(mapMaybe, stripMaybeDef)+import Xtypes+import CompOps+import GCAttrs() -- instances++grmarginF m f = simpleGroupF [] (marginF m f)++data TerminalCmd+  = TermText String -- add string on a new line+  | TermAppend String -- append string to last line+  | TermClear++terminalF :: FontName -> Int -> Int -> F String a+terminalF fname nrows ncols = cmdTerminalF fname nrows ncols >=^< TermText++cmdTerminalF :: FontName -> Int -> Int -> F TerminalCmd a+cmdTerminalF fname nrows ncols =+    let wattrs = [CWBackingStore WhenMapped, CWEventMask [ExposureMask]]+    in  grmarginF 2+                (windowF [XCmd $ ChangeWindowAttributes wattrs,+			  XCmd $ ConfigureWindow [CWBorderWidth 1]]+                         (terminalK fname nrows ncols))++terminalK fname nrows ncols =+    safeLoadQueryFont fname $ \fs ->+    allocNamedColorPixel defaultColormap fgColor $ \fg ->+    changeGetBackPixel paperColor $ \bg ->+    wCreateGC rootGC [GCFunction GXcopy, GCFont (font_id fs), GCForeground fg, GCBackground bg]+				 (terminalK1 fs nrows ncols)++m1 $$$ m2 = m1>>m2++m1 $> xm2 = m1 >>= xm2++terminalK1 fs nrows ncols gc =+    let charsize@(Point charw charh) = string_box_size fs "M"+        startsize = curpos nrows ncols+        size = startsize+        curpos row col = pP (charw * col) (charh * row)+        drawpos row col = padd (curpos row col) (pP 0 (font_ascent fs))+	drimstr = if snd (font_range fs) > '\xff'+		  then wDrawImageString16+		  else wDrawImageString+        k =+            getKs $>+            (\msg ->+             (case msg of+                Low (XEvt (Expose _ 0)) -> redraw+                Low (LEvt (LayoutSize newsize)) -> setSize newsize+                Low _ -> nopMs+                High cmd -> case cmd of+		  TermText line -> addDrawLine line+		  TermAppend s -> appendDrawLine s+		  TermClear -> clearit) $$$+             k)+        drawline (r, l) =+            loadMs $>+            (\(lines', row, col, nrows', ncols') ->+             putLowMs (drimstr gc (drawpos r 0) l))+        redraw =+            loadMs $>+            (\(lines', row, col, nrows', ncols') ->+             putLowMs clearWindow $$$+             foldr (\l -> (drawline l $$$)) nopMs (zip [0 ..] (reverse lines')))+        setSize (Point x y) =+            loadMs $>+            (\(lines', row, col, nrows', ncols') ->+             let ncols'' = x `quot` charw+                 nrows'' = y `quot` charh+                 row' = row `min` nrows''+                 col' = col `min` ncols''+                 lines'' = take nrows'' lines'+             in  storeMs (lines'', row', col', nrows'', ncols'') $$$ redraw)+        addLine line =+            loadMs $>+            (\(lines', row, col, nrows', ncols') ->+             if row < nrows' - 1 then+                 let lines'' = line : lines'+                     row' = row + 1+                 in  storeMs (lines'', row', col, nrows', ncols')+             else+                 let lines'' = take nrows' (line : lines')+                 in  storeMs (lines'', row, col, nrows', ncols') $$$+                     putLowsMs [wCopyArea gc+                                           MyWindow+                                           (Rect (pP 0 charh)+                                                 (curpos (nrows' - 1) ncols'))+                                           origin,+                                clearArea  (Rect (curpos row 0)+                                                 (curpos 1 ncols'))+                                           False])+        appendLine s =+            loadMs $> \(lines', row, col, nrows', ncols') ->+	    case lines' of+	      []   -> storeMs ([s],row+1,col,nrows',ncols')+	      l:ls -> storeMs ((l++s):ls, row, col, nrows', ncols')+        clearit = loadMs $> \(lines, row, col, nrows, ncols) ->+		  storeMs ([],-1,0,nrows,ncols) $$$ redraw+        addDrawLine line =+            (addLine line $$$ loadMs) $> +            (\(lines', row, col, nrows', ncols') -> drawline (row, line))+	appendDrawLine s =+	    (appendLine s $$$ loadMs) $>+            (\(line:_, row, col, nrows', ncols') -> drawline (row, line))+    in  putK (Low (layoutRequestCmd (plainLayout size False False))) $+        stateK ([], -1, 0, nrows, ncols) k nullK
+ hsrc/fudgets/TextF.hs view
@@ -0,0 +1,300 @@+{-# LANGUAGE CPP #-}+module TextF(textF,textF',textF'',TextF,+	     TextRequest(..)) where+import Fudget+import FudgetIO+import FRequest+import NullF+import Utils+import Geometry+import Xtypes+import Event+import Command+import XDraw+import Dlayout+import DoubleClickF+import BgF+--import Color+--import EitherUtils(mapfilter)+import Data.Maybe(mapMaybe)+import Message(message) --Message(..),+import Font+--import LoadFont+import Gc+import InputMsg+import LayoutRequest+import Alignment(aLeft) --Alignment(..),+import Defaults(defaultFont,bgColor,fgColor)+import Sizing+import FDefaults+import GCAttrs --(ColorSpec,convColorK,colorSpec)+import ListRequest(ListRequest(..),listEnd)+#include "../defaults/defaults.h"++default(Int) -- mostly for Hugs+++#ifndef __HBC__+#define fromInt fromIntegral+#endif++type TextRequest = ListRequest String++newtype TextF = Pars [Pars]++data Pars+  = BorderWidth Int+  | FgColorSpec ColorSpec+  | BgColorSpec ColorSpec+  | FontSpec FontSpec+  | Align Alignment+  | Margin Int+  | InitText [String]+--  | InitSize String+  | Stretchable (Bool,Bool)+  | Sizing Sizing++parameter_instance(BorderWidth,TextF)+parameter_instance(FgColorSpec,TextF)+parameter_instance(BgColorSpec,TextF)+parameter_instance(FontSpec,TextF)+parameter_instance(Align,TextF)+parameter_instance(Margin,TextF)+parameter_instance(InitText,TextF)+--parameter_instance(InitSize,TextF)+parameter_instance(Sizing,TextF)+parameter_instance(Stretchable,TextF)++textF = textF' standard+textF' pm = noPF $ textF'' pm++textF'' :: Customiser TextF ->+           PF TextF TextRequest (InputMsg (Int, String))+textF'' pmod =+  let ps :: TextF+      ps = pmod (Pars [BorderWidth 0,+                       FgColorSpec textfg,+		       BgColorSpec textbg,+		       Margin 2,+		       Align aLeft,+		       InitText [],--InitSize "",+		       Stretchable (False,False),+		       Sizing Dynamic,+		       FontSpec (fontSpec defaultFont)])+      bw = getBorderWidth ps+      fg = getFgColorSpec ps+      bg = getBgColorSpec ps+      font = getFontSpec ps+      init = getInitText ps+      minstr = "" --getInitSize ps+      margin = getMargin ps+      align = getAlign ps+      sizing = getSizing ps+      stretch = getStretchable ps++      eventmask = [ExposureMask, ButtonPressMask]+      startcmds = map XCmd +                  [ConfigureWindow [CWBorderWidth bw],+  		   ChangeWindowAttributes+		     [CWEventMask eventmask+		      ,CWBitGravity (horizAlignGravity align)+		      ,CWBackPixmap none -- elim flicker caused by XClearArea+		      ]]+  in doubleClickF doubleClickTime $+     windowF startcmds $ textK0 bg fg font stretch align sizing margin minstr init+++textK0 bg fg font (flexh,flexv) align sizing margin minstr init =+    changeGetBackPixel bg $ \ bgcol ->+    convColorK fg $ \ fgcol ->+    --allocNamedColorPixel defaultColormap fg $ \ fgcol ->+    convFontK font $ \ fd ->+    fontdata2struct fd $ \ fs ->+    wCreateGC rootGC [GCFont (font_id fs),+  		      GCForeground fgcol,+		      GCBackground bgcol] $ \gc ->+    wCreateGC gc     [GCForeground bgcol,+		      GCBackground fgcol] $ \gcinv ->+    let minw = next_pos fs minstr+    in textK1 bgcol gc gcinv fs (not flexh) (not flexv) align sizing margin minw init++textK1 bgcol gc gcinv fs fh fv align sizing margin minw =+    replaceTextK origin origin [] [] 0 listEnd+  where+    ll size = Low (layoutRequestCmd (plainLayout size fh fv))+    ls = linespace fs+    base = font_ascent fs + margin+    margsize = diag (2*margin)++    measure = map (pairwith (next_pos fs))+    txtwidth mtxt = maximum (1:minw:map snd mtxt)+                         -- 0 width not allowed for windows++    drimstr = if snd (font_range fs) > '\xff'+              then DrawImageString16+	      else DrawImageString++    txtsize mtxt =+      let width = txtwidth mtxt+	  height = max 1 (ls*length mtxt)  -- 0 height not allowed for windows+      in Point width height++    replaceTextK winsize@(Point winwidth winheight) size sel mtxt dfrom dcnt newtxt=+      let lines     = length mtxt+	  from      = min lines (if dfrom==listEnd then lines else dfrom)+	  after     = lines-from+	  cnt       = min after (if dcnt==listEnd then after else dcnt)+	  newcnt    = length newtxt+	  diff      = newcnt-cnt+	  scrollsize= after-cnt+	  newlines  = lines+diff+	  sel'      = mapMaybe reloc sel+	  reloc n   = if n<from then Just n+		      else if n<from+cnt then Nothing+		      else Just (n+diff)+	  mtxt'     = take from mtxt ++ measure newtxt ++ +		      (if scrollsize>0 then drop (from+cnt) mtxt else [])+	  newwidth  = txtwidth mtxt'+	  newsize   = Point newwidth (ls*newlines)+	  llcmd     = let realwinsize@(Point w h) = winsize+diag margin+	                  winsize'@(Point w' h') = newsize +margsize+	                  change =+			    winsize==origin ||+			    newSize sizing realwinsize winsize'/=realwinsize+	              in if change+		      then [ll (newsize + margsize)]+		      else []+	  --width     = xcoord size+	  drawwidth = max newwidth (winwidth-margin)+		       -- !! always scrolls/clears the full width of the window+	  scrollrect= rR margin (margin+ls*(from+cnt))+	                 drawwidth (ls*scrollsize)+	  scrolldest= Point margin (margin+ls*(from+newcnt))+	  scrollcmd = if scrollsize>0 && diff/=0+		      then [Low (wDraw gc $ CopyArea MyWindow scrollrect scrolldest)]+		      else []+	  drawrect  = rR margin (margin+ls*from) (drawwidth+margin) (ls*newcnt)+	                 -- add margin to width to erase text in the margin+			 -- when the text is wider than the window.+	  belowrect = rR margin (margin+ls*newlines) drawwidth (-ls*diff)+	  clearcmd  = (if newcnt>0+		       then let vrect = growrect drawrect (pP 5 5) -- !! tmp fix+		           in clearArea drawrect True+++		              [Low (LCmd (layoutMakeVisible vrect))]+		       else [])+++		       (if diff<0+		        then [Low $ XCmd $ ClearArea belowrect False]+			     -- Needed because of margin and other things+			     -- that cause the window to be taller than the+			     -- text.+			     -- clearcmd must be done after scrollcmd !!+			else [])+	  clearArea r e = map (Low . XCmd) +	                  [ChangeWindowAttributes [CWBackPixmap none],+	                   ClearArea r e,+			   ChangeWindowAttributes [CWBackPixel bgcol]]+			-- Some backround may be lost if the windows becomes+			-- obscured while the BackPixmap is none !!!+      in if diff>0+	 then resizeK llcmd $ \ newwinsize ->+	      putsK (scrollcmd++clearcmd) $+	      textK (newwinsize - diag margin) newsize sel' mtxt'+	 else putsK (scrollcmd++clearcmd++llcmd) $+	      textK winsize newsize sel' mtxt'++    textK :: Size -> Size -> [Int] -> [(String,Int)] ->+             PK TextF TextRequest (InputMsg (Int,String))+    textK winsize@(Point winwidth _) size sel mtxt =+       -- winsize is the size of the window excluding the right & bottom margins+	getK $ message lowK (either paramChangeK textRequestK)+      where+        same = textK winsize size sel mtxt+	textRequestK msg =+	    case msg of+	      ReplaceItems dfrom dcnt newtxt ->+		replaceTextK winsize size sel mtxt dfrom dcnt newtxt+	      HighlightItems sel' ->+		changeHighlightK sel' $+		textK winsize size sel' mtxt+	      PickItem n -> output inputMsg n+	      _ -> same+	lowK event =+	    case event of+	      XEvt (ButtonEvent {button=Button 1,pos=Point _ y, type'=press}) ->+		let l=y `quot` ls+		    pressmsg = case press of+				 MultiClick 2 -> inputMsg+				 _ -> InputChange+		in output pressmsg l+	      XEvt (Expose {rect=r}) ->+		redrawTextK r $+		same+	      XEvt (GraphicsExpose {rect=r}) ->+		redrawTextK r $+		same+	      LEvt (LayoutSize newwinsize) ->+	        textK (newwinsize - diag margin) size sel mtxt+	      _ -> same+	paramChangeK _ = same -- !!! Dynamic customisation not implemented yet+        output pressmsg l = (if l>=0 && l<length mtxt+	                     then putK (High (pressmsg (l,fst(mtxt!!l))))+			     else id) $ same++	changeHighlightK sel' =+	    putsK (mkvis++[Low $ wDrawMany (map draw changes)])+	  where+	    changed n = (n `elem` sel) /= (n `elem` sel')+	    nmtxt = number 0 mtxt+	    changes = [l | l@(n,_)<-nmtxt, changed n]+	    selected = [l | l@(n,_)<-nmtxt, n `elem` sel']+	    draw (n,(s,w)) = (dgc sel' n,[drimstr (Point (x0 w) (base+n*ls)) s])+	    mkvis =+	      case (selected,last selected) of -- needs lazy evalution!+		([],_) -> []+		((n1,(_,w1)):_,(n2,(_,w2))) ->+		    [Low (LCmd (layoutMakeVisible vrect))]+		  where vrect = rR x1 y1 (x2-x1+5) (y2-y1+5)+                        x1 = min (x0 w1) (x0 w2) -- !!! Should use min/max+			x2 = max (x0 w1) (x0 w2) -- !!! of all changes.+			y1 = n1*ls+			y2 = (n2+1)*ls++	redrawTextK r@(Rect (Point x y) (Point w h)) =+	  let first = (max 0 (y-margin)) `quot` ls+	      last = (y+h-1) `quot` ls+	      lines = number first (take (last-first+1) (drop first mtxt))+	      firsty = base+ls*first+	      ys = [firsty,firsty+ls..]+	  in putsK [Low $ XCmd $ ClearArea r False,+		    Low $ wDrawMany+	             [(dgc sel n,[drimstr (Point x1 ly) s]) | +		     ((n,s,x1,x2),ly)<-zip (map xi lines) ys,x<x2 && (x+w)>=x1]]+		     -- !! The x coordnates should probably be stored+		     -- rather than recomputed every time the text is+		     -- redrawn...++        xi (n,(s,w)) = (n,s,x1,x2) where x1=x0 w; x2=x1+w+        x0 w = margin+floor (align*fromInt (winwidth-margin-w))+	       -- !!! Problem: can't be sure that bitgravity moves stuff+	       -- to the same pixel coordinates that are computed here...++    dgc sel n = if n `elem` sel -- inefficient !!+                then gcinv+		else gc++resizeK cmd cont = putsK cmd $ waitForMsg ans $ cont+  where ans (Low (LEvt (LayoutSize newsize))) = Just newsize+        ans _ = Nothing++doubleClickTime = 400 -- The double click timeout should not be hard wired like this...+textbg = colorSpec [bgColor,"white"]+textfg = colorSpec [fgColor,"black"]++horizAlignGravity align =+    case (align::Alignment) of+      0 -> NorthWestGravity+      0.5 -> NorthGravity+      1 -> NorthEastGravity+      _ -> ForgetGravity++--take' n | n>=0 = take n
+ hsrc/fudgets/ToggleButtonF.hs view
@@ -0,0 +1,37 @@+module ToggleButtonF(toggleF, oldToggleButtonF, oldToggleButtonF') where+--import Alignment+import Spacer(marginF)+import CompOps((>=^<), (>^=<),(>+<),(>=^^<))+import CompSP(idRightSP)+import SpEither(filterRightSP)+import Spacers(compS,vCenterS,noStretchS)--,centerS,hvAlignS,spacerP+--import Placers(horizontalP)+import Placer(hBoxF,spacer1F)+import EitherUtils(stripEither)+import OnOffDispF+import ButtonBorderF+import ToggleGroupF+--import Geometry(Point(..))+import GraphicsF(graphicsLabelF')+import Defaults(look3d, edgeWidth)+import FDefaults -- setFont++toggleF inside keys lblF =+   toggleGroupF keys $+   if inside+   then buttonBorderF edgew (mF lblF) >=^^< idRightSP filterRightSP+   else stripEither >^=< hBoxF (sF (buttonBorderF edgew indicatorF) >+< cF lblF)+ where+    indicatorF = mF (onOffDispF False)+    mF = marginF innersep+    sF = spacer1F (noStretchS True True `compS` vCenterS)+    cF = spacer1F (noStretchS False True `compS` vCenterS)+    innersep = 2+    edgew    = if look3d then edgeWidth else max 0 (edgeWidth-1)++oldToggleButtonF x = oldToggleButtonF' False x++oldToggleButtonF' inside fname keys lbl =+    stripEither >^=< toggleF inside keys lblF >=^< Left+  where+    lblF = graphicsLabelF' (setFont fname) lbl
+ hsrc/fudgets/ToggleGroupF.hs view
@@ -0,0 +1,25 @@+module ToggleGroupF(toggleGroupF) where+import ButtonGroupF+import CompOps((>=^^<))+import Spops(mapstateSP)+import Fudget+--import Geometry(Line(..), Point(..), Rect(..), Size(..))+--import Message(Message)+import SerCompF(idLeftF)+import Xtypes(KeySym(..), ModState(..))++toggleGroupF :: [(ModState, KeySym)] -> (F (Either (Either Bool Bool) a) b) -> F (Either Bool a) (Either Bool b)+toggleGroupF keys f =+    let toPressed = Right . Left . Left+        toStateF = Right . Left . Right+        toFudget = Right . Right+        through = Left+        change s = (s, [toStateF s, through s])+        prep s (Right (Left ns)) = change ns+        prep s (Left BMClick) = change (not s)+        prep s (Left BMNormal) = (s, [toPressed False])+        prep s (Left BMInverted) = (s, [toPressed True])+        prep s (Right (Right m)) = (s, [toFudget m])+    in  buttonGroupF keys (idLeftF f >=^^< mapstateSP prep False)++
+ hsrc/ghc-dialogue/AsyncInput.hs view
@@ -0,0 +1,415 @@+{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}+{- Obsolete OPTIONS -optc-I/usr/X11R6/include -optc-DNON_POSIX_SOURCE -fvia-C -}+--+module AsyncInput+   (doSocketRequest,doSelect,getAsyncInput',initXCall,XCallState)+  where+import P_IO_data({-Request(..),-}Response(..))+import Xtypes+import Sockets as S+import DLValue+import Unsafe.Coerce -- !!!+--import ResourceIds+import Utils(swap)++import XCallTypes+import StructFuns+import Xlib+import EncodeEvent+import Marshall+import MyForeign+import GHC.Exts(addrToAny# )+import GHC.Ptr(FunPtr(..))++--import Ap+import HbcUtils(lookupWithDefault)+import Data.Maybe(mapMaybe)+import Control.Monad(when)+import Data.Traversable(traverse)++import PQueue++import Data.IORef(newIORef,readIORef,writeIORef,IORef)+import System.Posix.DynamicLinker as DL++import PackedString(unpackPS,lengthPS{-,packCBytesST,psToByteArray-})++default (Int)++#include "newstructfuns.h"++H_STRUCTTYPE(fd_set)++allocaInt = allocaElem (0::Int)++type AiTable = [(Fd,Descriptor)]++type IOVar a = IORef a++newIOVar = newIORef+readIOVar = readIORef+writeIOVar = writeIORef++type MsTime = Int++data XCallState = XCallState+      Cfd_set -- ^ read fd_set+      (IOVar Fd) -- ^ highest fd in read fd_set+      (IOVar AiTable)+      (IOVar (PQueue MsTime (MsTime,Timer)))+      (IOVar Time)++initXCall =+ XCallState+  <$> newPtr+  <*> newIOVar 0+  <*> newIOVar []+  <*> newIOVar empty+  <*> newIOVar 0++type Fd = Int32++foreign import ccall "unistd.h read" cread :: Fd -> Addr -> CSize -> IO CSize+foreign import ccall "unistd.h write" cwrite :: Fd -> CString -> CSize -> IO CSize+foreign import ccall "sys/socket.h" accept :: Fd -> CsockAddr -> Addr -> IO Fd++getAsyncInput' (XCallState fds maxfdvar aitable tq tno) =+ AsyncInput <$> do+   ai <- readIOVar aitable+   let timeLeft =+	  do tqv <- readIOVar tq+	     case inspect tqv of+	       Nothing -> return Nothing+	       Just ((t,_),_) ->+		 do ms <- mstime+		    return . Just . max 0 $ t - ms+   +   let doSelect = do+	  timeout <- traverse newTimeVal =<< timeLeft+          readfds <- newPtr+--	  _casm_ ``bcopy(%0,%1,sizeof(fd_set));'' fds readfds+	  bcopy_fdset fds readfds+          maxfdvar <- readIOVar maxfdvar+	  n <- select (maxfdvar+1) readfds timeout+	  maybe (return ()) freePtr timeout+	  let findFd fd = do+		  s <- fromC <$>+--		       _casm_ ``%r=FD_ISSET(%0,(fd_set*)%1);'' fd readfds+		       fd_isset fd readfds+		  if not s then findFd (fd+1) +		    else let d = lookAi fd in case d of+		       DisplayDe _ -> mkEvent fd d+		       SocketDe _ ->+		         let bufsize = 2000+			 in alloca bufsize $ \ buf ->+			 do got <- tryP "read" (>=0) $ cread fd buf (fromIntegral bufsize)+			    str <- unmarshallString' (CString buf) (fromIntegral got)+			    return (d,SocketRead str)+		       LSocketDe _ ->+		         allocaInt $ \ addrlen ->+			 do addr <- newsockAddr+			    sfd <- tryP "accept" (>=0) $ +				--_ccall_ ACCEPT fd addr addrlen+				accept fd addr addrlen+			    sf <- getfilep sfd "r+"+			    --buf <- stToIO $ newCharArray (1,1000)+			    --tryP "hostName" (==0) $ _ccall_ hostName addr buf+			    --peer <- cstring <$> mutByteArr2Addr buf+			    let peer = ""+			    return (d,SocketAccepted (So sf) peer)++		       _ -> error "getAsyncInput3"+          e <- if n == -1 then error . ("select "++) =<< strerror =<< errno+	       else if n > 0 then findFd 0+	            else do tno <- removetimeq tq+	                    return (TimerDe tno,TimerAlarm)+	  freePtr readfds+	  return e++       mkEvent fd d = do+           (window,fev) <- {-motionCompress display =<<-} getNextEvent display+	   return (descriptor,XEvent (window,fev))+         where descriptor@(DisplayDe display) = d+         +       lookAi = lookupWithDefault ai (error "getAsyncInput2")+       dispde x@(fd,DisplayDe _) = Just x+       dispde _ = Nothing+   case mapMaybe dispde ai of+       [] -> doSelect+       (fd,d@(DisplayDe display)):_ -> do+         q <- xPending display+         if q>0 then mkEvent fd d else doSelect++newTimeVal tleft =+  do timeout <- newPtr+     SET(timeVal,Int,timeout,tv_usec,(tleft `mod` 1000) * 1000)+     SET(timeVal,Int,timeout,tv_sec,(tleft `div` 1000))+     return timeout++foreign import ccall "sys/select.h select" cselect :: Int32 -> Cfd_set -> Cfd_set -> Cfd_set -> CtimeVal -> IO Int32+--foreign import ccall "unistd.h" getdtablesize :: IO Int++select :: Int32 -> Cfd_set -> Maybe CtimeVal -> IO Int32+select nfds readfds timeout = start where+ start = do+    n <- cselect nfds readfds nullPtr nullPtr (maybe nullPtr id timeout)+{-+      case timeout of+        Nothing -> +           _casm_ ``%r=select(getdtablesize(),%0,NULL,NULL,NULL);'' readfds+	Just t -> +           _casm_ ``%r=select(getdtablesize(),%0,NULL,NULL,%1);'' readfds t+-}+    +    if n /= -1 then return n else do+       e <- errno+       if e == CCONST(EINTR) --- || e == CCONST(EAGAIN)+         then start -- again+         else return n+--}+foreign import ccall "asyncinput.h get_errno" errno :: IO Int+--errno :: IO Int+--errno = _casm_ ``%r=errno;''++foreign import ccall "sys/socket.h" listen :: Fd -> Int32 -> IO Int+foreign import ccall "sys/socket.h" socket :: Int32 -> Int32 -> Int32 -> IO Fd+foreign import ccall "stdio.h" fopen :: CString -> CString -> IO Int -- hmm+foreign import ccall "stdio.h" fclose :: Int -> IO Int++foreign import ccall "asyncinput.h" in_connect :: CString -> Int32 -> Int32 -> IO Int32+foreign import ccall "asyncinput.h" in_bind :: Int32 -> Int32 -> IO Fd+foreign import ccall "asyncinput.h" get_stdin :: IO Int++doSocketRequest (XCallState fds maxfdvar aitable tq tno) sr =+ case sr of+   CreateTimer interval first -> do+          tqv <- readIOVar tq+          tnov <- readIOVar tno+	  now <- mstime+	  writeIOVar tq (insert tqv (now+first,(interval,Ti tnov)))+	  writeIOVar tno (tnov+1)+	  returnS (Timer (Ti tnov))+   DestroyTimer t -> do+          tqv <- readIOVar tq+	  writeIOVar tq (remove tqv t)+	  return Success+   OpenSocket host port -> do+     chost <- marshallString host+     s <- tryP "in_connect" (>=0) $ +--           _casm_ ``%r=in_connect(%0,%1,SOCK_STREAM);'' chost port+           in_connect chost (fromIntegral port) (fromIntegral CCONST(SOCK_STREAM))+     sf <- getfilep s "r+"+     freePtr chost+     returnS (Socket (So sf))+   OpenLSocket port -> do+      s <- tryP "in_bind" (>=0) $ if port == 0 +--         then _casm_ ``%r=socket(AF_INET,SOCK_STREAM,0);''+           then socket (fromIntegral CCONST(AF_INET)) (fromIntegral CCONST(SOCK_STREAM)) 0+--	   else _casm_ ``%r=in_bind(%0,SOCK_STREAM);'' port+	   else in_bind (fromIntegral port) (fromIntegral CCONST(SOCK_STREAM))+      tryP "listen" (==0) $ listen s 5+      SocketResponse . LSocket . LSo <$> getfilep s "r+"+   WriteSocket s str -> writeSocket s str+   WriteSocketPS s str ->+      do writeSocket s (unpackPS str) -- grr!+         returnS (Wrote (lengthPS str)) -- grr!+{-+     do+      fd <- fileno s+      r <- tryP "WriteSocket[out]" (>=0) $ +        _casm_ ``%r=write(fileno((FILE*)%0),%1,%2);'' s (psToByteArray str) (lengthPS str)+--        bawrite fd (psToByteArray str) (lengthPS str)+      return (SocketResponse (Wrote r))+-}+   CloseSocket (So s) -> close s+   CloseLSocket (LSo s) -> close s+   GetStdinSocket -> SocketResponse . Socket . So <$>+--        _casm_ ``%r=stdin;''+	get_stdin+   GetSocketName (So s) -> socketname s+   GetLSocketName (LSo s) -> socketname s+   StartProcess cmd doIn doOut doErr -> startProcess cmd doIn doOut doErr+   DLOpen path -> do dh <- dlopen path [RTLD_LAZY]+                     case dh of+                       Null -> failu =<< dlerror+                       _ -> returnS $ S.DLHandle (DL dh)+   DLClose (DL dh) -> do dlclose dh ; return Success+   DLSym (DL dh) name ->+       do FunPtr fp <- dlsym dh name+          case addrToAny# fp of+            (# hval #) -> returnS . DLVal $ DLValue (unsafeCoerce hval)+   OpenFileAsSocket name mode -> do+     cname <- marshallString name+     cmode <- marshallString mode+     s <- tryP "OpenSocketAsFile[fopen]" (/=0) $ fopen cname cmode+     freePtr cname+     freePtr cmode+     returnS $ (Socket . So) s+   _ -> error ("Not implemented: "++show sr)+ where returnS = return . SocketResponse+       close s = do+          fclose s+	  return Success+       socketname s =+          allocaInt $ \ lenp ->+          do sa <- newsockAddr+--	     tryP "GetLSocketName" (==0) $ _ccall_ GETSOCKNAME (s::Int) sa lenp+	     tryP "GetLSocketName" (==0) $ getsockname s sa lenp+	     len <- peek lenp+	     strp <- GETC(sockAddr,char *,CString,sa,sa_data)+--	     Str . unpackPS <$> (stToIO $ packCBytesST len strp)+	     Str <$> unmarshallString' strp len++writeSocket (So s) str =+   do let n = length str+      fd <- get_fileno s+      cstr <- marshallString' str n+      tryP "WriteSocket[out]" (>=0) $ +--        _casm_ ``%r=write(fileno((FILE*)%0),%1,%2);'' s cstr n+        cwrite fd cstr (fromIntegral n)+      freePtr cstr+      return Success++foreign import ccall "sys/socket.h" getsockname :: Int -> CsockAddr -> Addr -> IO Int+foreign import ccall "stdio.h" fdopen :: Int32 -> CString -> IO Int++getfilep s mode = tryP "fdopen" (/=0) $+  do cmode <- marshallString (mode::String)+--     _ccall_ fdopen (s::Int) cmode :: IO Int+     fdopen s cmode :: IO Int++foreign import ccall "string.h strerror" cstrerror :: Int -> IO CString+strerror e = unmarshallString =<< cstrerror e++tryP e p io = do+    r <- io+    if p (r{-::Int-}) then return r else do+--      cstr <- _casm_ ``%r=strerror(errno);''+      s <- strerror =<< errno+      failu (e++": "++ s)+++peekq tq = do+   tqv <- readIOVar tq+   return (inspect tqv)++removetimeq tq = do+   tqv <- readIOVar tq+   case inspect tqv of+     Just ((first,v@(interval,tnov)),tqv') -> do+        let tqv2 = if interval == 0 then tqv'+	           else insert tqv' (first+interval,v)+        writeIOVar tq tqv2+	return tnov+	+foreign import ccall "sys/time.h" gettimeofday :: CtimeVal -> Addr -> IO ()++mstime = do+    now <- newtimeVal+--    _casm_ ``gettimeofday(%0,NULL);'' now+    gettimeofday now nullAddr+    s <- GET(timeVal,Int,now,tv_sec)+    us <- GET(timeVal,Int,now,tv_usec)+    return (s * 1000 + us `div` 1000 :: Int)+++foreign import ccall "asyncinput.h" fdzero :: Cfd_set -> IO ()+foreign import ccall "asyncinput.h fdset" fd_set :: Fd -> Cfd_set -> IO ()+foreign import ccall "asyncinput.h fdisset" fd_isset :: Fd -> Cfd_set -> IO Int+foreign import ccall "asyncinput.h" bcopy_fdset :: Cfd_set -> Cfd_set -> IO ()++doSelect :: XCallState -> [Descriptor] -> IO Response+doSelect (XCallState fds maxfdvar aitable _ _) dl =+ do+  fdzero fds+  ait <- concat <$> mapM descriptor dl+  let fds = map fst ait+  writeIOVar aitable ait+  writeIOVar maxfdvar (maximum fds)+  mapM_ fdset fds+  return Success+ where descriptor d = case d of+	   LSocketDe (LSo s) -> withd $ get_fileno s+	   SocketDe (So s) ->  withd $ get_fileno s+	   OutputSocketDe (So s) ->  withd $ get_fileno s+	   DisplayDe ({-Display-} d) -> withd $ +--	         _casm_ ``%r=((Display*)%0)->fd;'' d+		 xConnectionNumber d -- hmm+	   TimerDe _ -> return []+           _ -> do putStr "Unexpected descriptor: ";print d;return []+          where withd m = m >>= \fd -> return [(fd,d)]++       fdset :: Fd -> IO ()+       --fdset s =  _casm_ ``FD_SET(%0,(fd_set*)%1);'' s fds+       fdset s =  fd_set s fds++foreign import ccall "asyncinput.h" get_fileno :: Int -> IO Fd+{-++-- Register problems with FD_ZERO under Redhat 6.1 Linux-i386...+--fdzero :: Cfd_set -> IO ()+--fdzero fds = _casm_ ``{ fd_set *s=%0; FD_ZERO(s);}'' fds+--fdzero fds = _ccall_ FD_ZERO fds++mutByteArr2Addr :: MutableByteArray RealWorld Int -> IO  Addr+mutByteArr2Addr arr  = _casm_ `` %r=(void *)%0; '' arr+--}++foreign import ccall "unistd.h" fork :: IO Int+foreign import ccall "unistd.h" execl :: CString -> CString -> CString -> CString -> Int -> IO Int+foreign import ccall "unistd.h" pipe :: Addr -> IO Int+foreign import ccall "unistd.h" dup :: Fd -> IO Fd+foreign import ccall "asyncinput.h" disable_timers :: IO ()++startProcess cmd doIn doOut doErr =+  do inPipe <- optPipe doIn+     outPipe <- optPipe doOut+     errPipe <- optPipe doErr+--     pid <- _ccall_ fork+     pid <- fork+     case pid::Int of+       -1 -> failu "fork" -- use tryP instead+       0 -> do -- child process+	       -- Disable virtual timer, used by the GHC RTS+	       disable_timers+	       optDupIn 0 inPipe+	       optDupOut 1 outPipe+	       optDupOut 2 errPipe+	       binsh <- marshallString "/bin/sh"+	       sh <- marshallString "sh"+	       dashc <- marshallString "-c"+	       ccmd <- marshallString cmd+	       execl binsh sh dashc ccmd (0::Int)+	       --_ccall_ _exit 1+	       failu "execl"+       _ -> do -- parent process+	       inS <- optPipeIn inPipe+	       outS <- optPipeOut outPipe+	       errS <- optPipeOut errPipe+	       return $ SocketResponse $ ProcessSockets inS outS errS+  where+    optPipe False = return Nothing+    optPipe True = Just `fmap` newPipe+    newPipe = do pa <- newArray 2+		 ok <- pipe (addrOf (pa::CInt32))+		 [p0,p1] <- readArray pa 2+		 freePtr pa+		 when (ok/=0) $ failu "pipe" -- use tryP instead+		 return (p0,p1)++    optDupIn d = optDupOut d . fmap swap+    optDupOut d = maybe (return ()) (dupOut d)+    dupOut d (p0,p1) = do cclose d+			  dup p1+			  cclose p0+			  cclose p1+			  return ()++    optPipeIn = optPipeS "w" . fmap swap+    optPipeOut = optPipeS "r"+    optPipeS m = maybe (return Nothing) (fmap Just . pipeS m)+    pipeS m (p0,p1) = do cclose p1+			 fmap So (getfilep p0 m)+			 ++foreign import ccall "unistd.h close" cclose :: Int32 -> IO Int32
+ hsrc/ghc-dialogue/CSizes.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE CPP #-}+module CSizes where++#define CSIZE(ctype) foreign import ccall "cfuns.h" fudsizeof_/**/ctype :: Int++#include "csizes.h"
+ hsrc/ghc-dialogue/CString16.hs view
@@ -0,0 +1,16 @@+module CString16 where+import Marshall++-- A quick hack...++type CString16 = CString -- !!++marshallString16 s = marshallString16' s (length s)++marshallString16' s n = marshallString' (split s) (2*n)+  where+    split [] = []+    split (c:cs) = toEnum (i `div` 256):toEnum (i `mod` 256):split cs+      where i = fromEnum c++-- unmarshallString16 = ...
+ hsrc/ghc-dialogue/ContinuationIO.hs view
@@ -0,0 +1,169 @@+module ContinuationIO{-(module ContinuationIO, module DialogueIO)-} where+--import DialogueIO+--import XStuff+--import P_IO_data hiding (Bin)+--import Prelude hiding (IOError,appendFile,interact,print,readFile,writeFile)+{-+type SuccCont    =                Dialogue+type StrCont     =  String     -> Dialogue+type BinCont     =  Bin        -> Dialogue+type FailCont    =  IOError    -> Dialogue+type StrListCont =  [String]   -> Dialogue+type Bin = ()+-}+stdin = "stdin"+stdout = "stdout"+stderr = "stderr"+{-+done	      ::                                             Dialogue+readFile      :: String ->           FailCont -> StrCont  -> Dialogue+writeFile     :: String -> String -> FailCont -> SuccCont -> Dialogue+appendFile    :: String -> String -> FailCont -> SuccCont -> Dialogue+--readBinFile   :: String ->           FailCont -> BinCont  -> Dialogue+--writeBinFile  :: String -> Bin    -> FailCont -> SuccCont -> Dialogue+--appendBinFile :: String -> Bin    -> FailCont -> SuccCont -> Dialogue+deleteFile    :: String ->           FailCont -> SuccCont -> Dialogue+statusFile    :: String ->           FailCont -> StrCont  -> Dialogue+readChan      :: String ->           FailCont -> StrCont  -> Dialogue+appendChan    :: String -> String -> FailCont -> SuccCont -> Dialogue+--readBinChan   :: String ->           FailCont -> BinCont  -> Dialogue+--appendBinChan :: String -> Bin    -> FailCont -> SuccCont -> Dialogue+echo          :: Bool   ->           FailCont -> SuccCont -> Dialogue+getArgs	      ::		     FailCont -> StrListCont -> Dialogue+getEnv	      :: String ->	     FailCont -> StrCont  -> Dialogue+setEnv	      :: String -> String -> FailCont -> SuccCont -> Dialogue+getProgName   ::		     FailCont -> StrCont  -> Dialogue+readFileScattered :: String -> [Int] -> FailCont -> StrListCont  -> Dialogue++done resps    =  []++readFile name fail succ resps =+    ReadFile name : strDispatch fail succ resps++readFileScattered name offs fail succ resps =+    ReadFileScattered name offs : strListDispatch fail succ resps++writeFile name contents fail succ resps =+    WriteFile name contents : succDispatch fail succ resps++appendFile name contents fail succ resps =+    AppendFile name contents : succDispatch fail succ resps++{-+readBinFile name fail succ resps =+    ReadBinFile name : binDispatch fail succ resps++writeBinFile name contents fail succ resps =+    WriteBinFile name contents : succDispatch fail succ resps++appendBinFile name contents fail succ resps =+    AppendBinFile name contents : succDispatch fail succ resps++readBinChan name fail succ resps =+    ReadBinChan name : binDispatch fail succ resps++appendBinChan name contents fail succ resps =+    AppendBinChan name contents : succDispatch fail succ resps+-}++deleteFile name fail succ resps =+    DeleteFile name : succDispatch fail succ resps++statusFile name fail succ resps =+    StatusFile name : strDispatch fail succ resps++readChan name fail succ resps =+    ReadChan name : strDispatch fail succ resps++appendChan name contents fail succ resps =+    AppendChan name contents : succDispatch fail succ resps++echo bool fail succ resps =+    Echo bool : succDispatch fail succ resps++getArgs fail succ resps =+    GetArgs : strListDispatch fail succ resps++getProgName fail succ resps =+    GetProgName : strDispatch fail succ resps++getEnv name fail succ resps =+    GetEnv name : strDispatch fail succ resps++setEnv name val fail succ resps =+    SetEnv name val : succDispatch fail succ resps+++strDispatch  fail succ (resp:resps) = case resp of +					Str val      -> succ val resps+					Failure msg  -> fail msg resps++binDispatch  fail succ (resp:resps) = case resp of +					Bn val       -> succ val resps+					Failure msg  -> fail msg resps++succDispatch fail succ (resp:resps) = case resp of+					Success     -> succ resps+					Failure msg -> fail msg resps++strListDispatch fail succ (resp:resps) = case resp of+					StrList val -> succ val resps+					Failure msg -> fail msg resps+++abort		:: FailCont+abort msg	=  done++exit		:: FailCont+exit err	= appendChan stderr (msg ++ "\n") abort done+		  where msg = case err of ReadError s   -> s+		  			  WriteError s  -> s+		  			  SearchError s -> s+		      			  FormatError s -> s+		      			  OtherError s  -> s++print		:: (Show a) => a -> Dialogue+print x		=  appendChan stdout (show x) exit done+prints          :: (Show a) => a -> String -> Dialogue+prints x s	=  appendChan stdout (shows x s) exit done++interact	:: (String -> String) -> Dialogue+interact f	=  readChan stdin exit+			    (\x -> appendChan stdout (f x) exit done)++------------------------------------ hbc bonus+type DblCont = Double -> Dialogue++sleep           :: Double ->           FailCont -> SuccCont    -> Dialogue+changeDirectory :: String ->           FailCont -> SuccCont    -> Dialogue+getTime         ::                     FailCont -> DblCont     -> Dialogue+deleteDirectory :: String ->           FailCont -> SuccCont    -> Dialogue+readDirectory   :: String ->           FailCont -> StrListCont -> Dialogue+getCpuTime      ::                     FailCont -> DblCont     -> Dialogue+getLocalTime    ::                     FailCont -> DblCont     -> Dialogue+readDirectory name fail succ resps =+    ReadDirectory name : strListDispatch fail succ resps++getLocalTime fail succ resps =+    GetLocalTime : dblDispatch fail succ resps++sleep dbl fail succ resps =+    Sleep dbl : succDispatch fail succ resps++changeDirectory str fail succ resps =+    ChangeDirectory str : succDispatch fail succ resps++deleteDirectory str fail succ resps =+    DeleteDirectory str : succDispatch fail succ resps++getTime fail succ resps =+    GetTime : dblDispatch fail succ resps++getCpuTime fail succ resps =+    GetCpuTime : dblDispatch fail succ resps++dblDispatch  fail succ (resp:resps) = case resp of +                                        Dbl val      -> succ val resps+                                        Failure msg  -> fail msg resps++-}
+ hsrc/ghc-dialogue/DialogueIO.hs view
@@ -0,0 +1,21 @@+-- | Haskell 1.2 Dialogue I/O+module DialogueIO(Request(..), Response(..), IOError(..)+       , Dialogue(..), SigAct(..) , dialogueToIO+       --, module _LibDialogue+	) where+import Prelude hiding (IOError)+import P_IO_data+import DoRequest+import Control.Concurrent.Chan++-- | Included just to illustrate that it is possible to convert a Dialogue+-- IO function to a monadic IO function. The implementation relies on+-- 'getChanContents' to construct the lazy list of responses needed by+-- the dialogue IO function.+dialogueToIO :: Dialogue -> IO ()+dialogueToIO f =+  do st <- initXCall+     respchan <- newChan+     reqs <- f `fmap` getChanContents respchan+     let doReq req = writeChan respchan =<< doRequest st req+     mapM_ doReq reqs
+ hsrc/ghc-dialogue/DoRequest.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE CPP #-}+module DoRequest(XCallState,initXCall,doRequest,getAsyncInput) where+import Control.Applicative+--import DialogueIO+import P_IO_data+import ContinuationIO(stdin,stdout,stderr)+import qualified System.IO as IO+import System.Environment as IO(getEnv,getProgName)+import System.Process as IO(system)+import System.Exit as IO+import qualified IOUtil as IO+import System.IO(openBinaryFile,withBinaryFile,IOMode(..),hPutStr,hGetContents)+import System.Directory+#ifdef VERSION_old_time+import System.Time(getClockTime,toCalendarTime)+#endif+#ifdef VERSION_time+import Data.Time(getCurrentTime,getZonedTime)+#endif++import DoXCommand+import DoXRequest+import AsyncInput(XCallState,initXCall,getAsyncInput',doSelect,doSocketRequest)+import CmdLineEnv(argFlag)++--import System+import Prelude hiding (IOError)++--import Ap++deb = argFlag "dorequest" False++doRequest =+    if not deb+    then doRequest'+    else \state req -> do+         eprint req+	 resp <- doRequest' state req+	 eprint resp+	 return resp+  where+    eprint x = IO.hPutStrLn IO.stderr . take 239 . show $ x++doRequest' :: XCallState -> Request -> IO Response+doRequest' state req =+  case req of+    ReadFile   filename          -> rdCatch (readFile filename)+    WriteFile  filename contents -> wrCatch (writeFile filename contents)+    ReadBinaryFile filename      -> rdCatch (readBinaryFile filename)+    WriteBinaryFile filename contents ->+                                    wrCatch (writeBinaryFile filename contents)+    AppendFile filename contents -> wrCatch (appendFile filename contents)+    StatusFile filename          -> catchIo SearchError (statusFile filename)+      where+        statusFile path =+	  do f <- doesFileExist path+	     if f then permissions 'f' path+               else do d <- doesDirectoryExist path+		       if d then permissions 'd' path+			  else fail path+	permissions t path =+	  do p <- getPermissions path+	     let r = if readable p then 'r' else '-'+		 w = if writable p then 'w' else '-'+	     return (Str [t,r,w])+    RenameFile from to         -> otCatch (renameFile from to>>ok)+    GetCurrentDirectory        -> Str <$> getCurrentDirectory+#ifdef VERSION_old_time+    GetModificationTime path   -> catchIo SearchError (ClockTime <$> IO.getModificationTime path)+#else+    GetModificationTime path   -> catchIo SearchError (UTCTime <$> IO.getModificationTime path)+#endif+    ReadDirectory dir          -> rdCatch' StrList (getDirectoryContents dir)+    DeleteFile filename        -> otCatch (removeFile filename>>ok)+    CreateDirectory path mask  -> otCatch (createDirectory path>>ok)+    ReadXdgFile xdg path      -> rdCatch $+                                 do dir <- getAppXdgDir xdg+                                    readFile (dir++"/"++path)+    WriteXdgFile xdg path s   -> wrCatch $+                                 do dir <- getAppXdgDir xdg+                                    createDirectoryIfMissing True dir+                                    writeFile (dir++"/"++path) s+    ReadChan channelname ->+      if channelname==stdin+      then rdCatch getContents+      else rfail $ ReadError $ "ReadChan: unknown channel "++channelname+    AppendChan channelname contents+        | channelname==stdout -> wr IO.stdout+        | channelname==stderr -> wr IO.stderr+        | otherwise           -> rfail $ WriteError $ "AppendChan: unknown channel "++channelname+      where wr chan = wrCatch (IO.hPutStr chan contents>>IO.hFlush chan)+    XRequest r      -> otCatch $ XResponse <$> doXRequest r+    XCommand c      -> otCatch $ (doXCommand c >> ok)+    GetAsyncInput   -> getAsyncInput state+    SocketRequest r -> otCatch $ doSocketRequest state r+    Select dl       -> otCatch $ doSelect state dl+    Exit n	    -> exitWith (if n==0 then ExitSuccess else ExitFailure n)+#ifdef VERSION_old_time+    GetLocalTime    -> otCatch $ do+		         CalendarTime <$> (toCalendarTime =<< getClockTime)+			 --s <- readIO (formatCalendarTime undefined "%s" t)+			 --GHC bug(?) workaround:+                         --let s = ctSec t+60*(ctMin t+60*(ctHour t))+			 --return (Dbl (fromIntegral s))+    GetTime         -> otCatch $ ClockTime <$> getClockTime+    ToCalendarTime t -> CalendarTime <$> toCalendarTime t+#endif+    GetEnv var      -> catchIo SearchError (Str <$> getEnv var)+    System cmd      -> do exitcode <- system cmd+		          case exitcode of+		            ExitSuccess -> ok+			    ExitFailure n -> rfail $ OtherError $ "System: Return code="++show n+#ifdef VERSION_time+    GetCurrentTime  -> otCatch $ UTCTime   <$> getCurrentTime+    GetZonedTime    -> otCatch $ ZonedTime <$> getZonedTime+#endif+    _ -> do IO.hPutStrLn IO.stderr msg+            rfail $ OtherError msg+         where msg = "doRequest: unimplemented request: "++show req++ok = return Success+rfail = return . Failure++getAsyncInput state = otCatch $ getAsyncInput' state++rdCatch = rdCatch' Str+rdCatch' c io = catchIo ReadError (c <$> io)+wrCatch io = catchIo WriteError (io >> ok)+otCatch = catchIo OtherError+catchIo e io = IO.catch io (rfail . e . show)++---- Should be put elsewhere:+-- #ifndef __GLASGOW_HASKELL__+-- instance Functor IO where map f io = io >>= (return . f)+-- #endif++--+readBinaryFile path = hGetContents =<< openBinaryFile path ReadMode+writeBinaryFile path s = withBinaryFile path WriteMode (flip hPutStr s)++getAppXdgDir xdg = getXdgDirectory xdg =<< getProgName
+ hsrc/ghc-dialogue/DoXCommand.hs view
@@ -0,0 +1,366 @@+{-# LANGUAGE CPP #-}+{- unused options -optc-I/usr/X11R6/include -#include <X11/Xlib.h> -#include <X11/Xutil.h> -fvia-C -}+-- -O+module DoXCommand(doXCommand) where++import Command+import Event+import Geometry+import Xtypes+--import Font+--import ResourceIds+import DrawTypes+import HbcUtils(chopList)++import DoXRequest(getGCValues,translateCoordinates)+import XCallTypes+import StructFuns+import Xlib+import Marshall+import MyForeign+--import CCall+import CString16++import System.IO(hPutStr,hPutStrLn,stderr) -- for error reporting++import PackedString(lengthPS,unpackPS)+--import Word(Word32)+import Data.Bits++--import IO(hFlush,stdout) -- debugging++default (Int)++{-+#include "newstructfuns.h"+-}+-- For debugging only:+{-+doXCommand req@(d,_,_) =+  do r <- doXCommand' req+   --hFlush stdout+     xSync d False+     return r+--}+--doXCommand cmd@(display,_,_) = withLockedDisplay display $ doXCommand' cmd++doXCommand :: (Display, Window, XCommand) -> IO ()+doXCommand (d,w,req) =+  case req of+   CloseDisplay d -> xCloseDisplay d+   DestroyWindow -> xDestroyWindow d w+   MapRaised -> xMapRaised d w+   LowerWindow -> xLowerWindow d w+   UnmapWindow -> xUnmapWindow d w+   ClearWindow -> xClearWindow d w+   StoreName s -> xStoreName d w s+   FreeGC gc -> xFreeGC d gc+   UngrabPointer -> xUngrabPointer d currentTime+   Flush -> xFlush d+   ClearArea (Rect (Point x y) (Point wi he)) exposures ->+      xClearArea d w x y wi he exposures+   GrabButton oe button ms evm ->+      xGrabButton d (toC button) anyModifier w oe (toC evm) grabModeAsync grabModeAsync windowNone  cursorNone+   UngrabButton b ms ->+     --_casm_ ``XUngrabButton(%0,%1,AnyModifier,%2);'' d (toC b) w+     xUngrabButton d (toC b) anyModifier w+   FreePixmap p -> xFreePixmap d p+   Draw drawable gc cmd -> doDrawCommand (getdr drawable) gc cmd+   DrawMany drawable gccmds -> mapM_ doDrawMany gccmds+      where+        dr = getdr drawable+	doDrawMany (gc,cmds) = mapM_ (doDrawCommand dr gc) cmds+   ChangeGC gc gcattrs -> do+     (gcvals,mask) <- getGCValues gcattrs+     xChangeGC d gc mask gcvals+   ChangeWindowAttributes was -> do+     (attrs,mask) <- getWindowAttributes was+     --putStr "CWA mask ";print mask+     xChangeWindowAttributes d w mask attrs+   ConfigureWindow wc -> do+     (chgs,mask) <- getWindowChanges wc+     xConfigureWindow d w mask chgs+   SetNormalHints (Point x y) -> do+      h <- newXSizeHints +      SET(XSizeHints,Int,h,x,x)+      SET(XSizeHints,Int,h,y,y)+      SET(XSizeHints,Int,h,flags,CCONST(USPosition)::Int)+      xSetNormalHints d w h+      freePtr h+   SetWMHints i -> do+      h <- newXWMHints+      SET(XWMHints,Int,h,flags,CCONST(InputHint)::Int)+      SET(XWMHints,Int,h,input,toC i)+      xSetWMHints d w h+      freePtr h+   ShapeCombineMask kind (Point x y) p op ->+     xShapeCombineMask d w kind x y p op+   ShapeCombineRectangles kind (Point x y) rs op ord -> do+      (rsa,size) <- storeRectangles rs+      xShapeCombineRectangles d w kind x y rsa size op ord+      freePtr rsa+   ShapeCombineShape dst (Point x y)  p src op ->+       xShapeCombineShape d w dst x y p src op+   --RmDestroyDatabase RmDatabase |+   --RmCombineDatabase RmDatabase RmDatabase Bool |+   --RmPutLineResource RmDatabase String |+   SetWMProtocols atoms -> xSetWMProtocols d w atoms (length atoms)+   SendEvent dst propagate evm e -> do+     xe <- getEvent dst e+     status <- xSendEvent d dst propagate (fromIntegral $ toC evm) xe+     return ()+   SetSelectionOwner getit sel ->+     xSetSelectionOwner d sel (if getit then w else windowNone)  currentTime+   ConvertSelection  (Selection s t p) ->+     xConvertSelection d s t p w currentTime+   ChangeProperty w p t form@8 mode s -> -- !!+     xChangeProperty d w p t form mode s (length s)+   FreeColors cm pixls planes ->+     do cmid <- dcmap d cm+	(pxarr,size) <- toArray [fromIntegral p|Pixel p<-pixls] -- hmm+	xFreeColors d cmid pxarr size planes+   ReparentWindow newParent0 ->+     do newParent <- if newParent0==rootWindow+                     then xDefaultRootWindow d+                     else return newParent0+        mp <- translateCoordinates d w newParent+        case mp of+          Nothing -> hPutStr stderr "XTranslateCoordinates: windows on different screens!\n"+          Just (Point x y) -> xReparentWindow d w newParent x y+   --WarpPointer Point |+   SetRegion gc r -> -- !!! modifies a GC -- cache problems!+     do (rsa,_) <- storeRectangles [r]+	r <- xCreateRegion+	xUnionRectWithRegion rsa r r+	xSetRegion d gc r+	xDestroyRegion r+	freePtr rsa+   --AddToSaveSet |+   --RemoveFromSaveSet +   Bell n -> xBell d n++   _ -> hPutStr stderr (notImplemented req)+ where getdr = getdrawable w++       doDrawCommand drw gc cmd = case cmd of+	  DrawLine (Line (Point x1 y1) (Point x2 y2)) -> +	    xDrawLine d drw gc x1 y1 x2 y2+	  DrawImageString (Point x y) s ->+	    xDrawImageString d drw gc x y s (length s)+	  DrawString (Point x y) s ->+	    xDrawString d drw gc x y s (length s)+	  DrawImageString16 (Point x y) s ->+	    do let n = length s+	       cs <- marshallString16' s n+	       xDrawImageString16 d drw gc x y cs n+	  DrawString16 (Point x y) s ->+	    do let n = length s+	       cs <- marshallString16' s n+	       xDrawString16 d drw gc x y cs n+	  DrawRectangle (Rect (Point x1 y1) (Point x2 y2)) ->+            xDrawRectangle d drw gc x1 y1 x2 y2+	  FillRectangle (Rect (Point x1 y1) (Point x2 y2)) ->+            xFillRectangle d drw gc x1 y1 x2 y2+	  FillPolygon shape coordmode ps -> do+	      (xpoints,size) <- storePoints ps+	      xFillPolygon d drw gc xpoints size shape coordmode+	      freePtr xpoints+	  DrawLines coordmode ps -> do+	      (xpoints,size) <- storePoints ps+	      xDrawLines d drw gc xpoints size coordmode+	      freePtr xpoints+	  DrawArc (Rect (Point x y) (Point wi he)) a1 a2 ->+	      xDrawArc d drw gc (f x) (f y) (f wi) (f he) (f a1) (f a2)+            where f = fromIntegral+	  FillArc (Rect (Point x y) (Point wi he)) a1 a2 ->+	      xFillArc d drw gc (f x) (f y) (f wi) (f he) (f a1) (f a2)+            where f = fromIntegral+	  CopyArea src (Rect (Point srcx srcy) (Point wi he))+		       (Point dstx dsty) ->+	    xCopyArea d (getdr src) drw gc (i32 srcx) (i32 srcy) (u32 wi) (u32 he) (i32 dstx) (i32 dsty)+	  CopyPlane src (Rect (Point srcx srcy) (Point wi he)) +			(Point dstx dsty) plane ->+            --print (gc,drw,cmd) >>+	    xCopyPlane d (getdr src)+		       drw gc (f srcx) (f srcy) (f wi) (f he)+                       (f dstx) (f dsty) (shiftL 1 plane)+            -- >>putStrLn "done"+            where f = fromIntegral+	  DrawPoint (Point x y) -> xDrawPoint d drw gc x y+	  CreatePutImage rect format pixels -> createPutImage drw gc rect format pixels+	  DrawImageStringPS (Point x y) s ->+	    xDrawImageString d drw gc x y (unpackPS s) (lengthPS s) -- !!+	  DrawStringPS (Point x y) s ->+	    xDrawString d drw gc x y (unpackPS s) (lengthPS s) -- !!+          _ -> hPutStr stderr (notImplemented cmd)++       createPutImage drw gc rect@(Rect (Point x y) (Point w h)) (ImageFormat format) pixels =+        do --hPutStrLn stderr $ "Entering createPutImage "++show rect+	   screen <- xDefaultScreen d+	   depth <- xDefaultDepth d screen+	   bpp <- default_bpp d depth+	   --hPutStrLn stderr ("bpp="++show bpp)+	   let byte_depth = (depth+7) `div` 8+	       bytes_pp = (bpp+7) `div` 8+	       bitmap_pad = 32+	       bytes_per_line = ((w*bytes_pp+3) `div` 4) * 4 -- assumes bitmap_pad == 32+	       nullCount = bytes_per_line - w*bytes_pp+	       size= w*h+	       pxlines = chopList (splitAt w) pixels+	   byteOrder <- xImageByteOrder d+#if 1+	   -- High level solution, not fast enough:+	   let pxlToBytes = if byteOrder==LSBFirst then lsb else msb+	       msb (Pixel p) = pad ++ reverse (lsb' byte_depth (fromIntegral p))+	       pad = replicate (bytes_pp-byte_depth) '\0'+	       lsb (Pixel p) = lsb' byte_depth (fromIntegral p) ++ pad+	       lsb' 0 _ = []+	       lsb' n p = toEnum (p `mod` 256) : lsb' (n-1) (p `div` 256)+	       linePad = replicate nullCount '\0'+	       byteLine pxls = concatMap pxlToBytes pxls ++ linePad+	       bytes = concatMap byteLine pxlines+	       --imgdata = psToByteArray (packString bytes)+           --hPutStrLn stderr "Checkpoint 1 in createPutImage"+           --hPutStrLn stderr $ "nullCount="++show nullCount+#else+	   -- Low level solution, faster, but still not fast enough:+	   imgdata <- stToIO $ newCharArray (1,bytes_per_line*h)+	   let convImage = convLines 0 pixels+	       convLines y pixels | y>=h = return ()+	                          | otherwise =+	         do pixels' <- convLine y pixels+		    convLines (y+1) pixels'+	       convLine y pixels = convPixels (y*bytes_per_line) 0 pixels+	       convPixels i x pixels | x>=w = return pixels+	       convPixels i x (Pixel p:pixels) =+		 do convPixel i p+		    convPixels (i+bytes_pp) (x+1) pixels+	       convPixel =+	         if byteOrder==(CCONST(LSBFirst)::Int)+		 then convPixelLSB+		 else convPixelMSB+	       convPixelLSB i p =+	           pixelBytes i p byte_depth+		   -- pad with zeros?+	         where+		   pixelBytes i p 0 = return ()+		   pixelBytes i p n =+		     do SINDEX(char,imgdata,i::Int,p::Int)+		        pixelBytes (i+1) (p `div` 256) (n-1)+	       convPixelMSB i p =+	           do let i' = i+bytes_pp-1+		      -- pad with zeros?+		      pixelBytes i' p bytes_pp+	         where+		   pixelBytes i p 0 = return ()+		   pixelBytes i p n =+		     do SINDEX(char,imgdata,i::Int,p::Int)+		        pixelBytes (i-1) (p `div` 256) (n-1)+		 +	    in convImage+#endif+	   dv <- xDefaultVisual d screen+           --hPutStrLn stderr "Checkpoint 2 in createPutImage"+           --if bytes==bytes then return () else undefined+           --hPutStrLn stderr "Checkpoint 3 in createPutImage"+	   cbytes <- marshallString' bytes (h*bytes_per_line)+	   image <- xCreateImage d dv depth format 0 cbytes w h bitmap_pad bytes_per_line+           --hPutStrLn stderr $ "Checkpoint 4 in createPutImage "++show image+	   xPutImage d drw gc image 0 0 (i32 x) (i32 y) (i32 w) (i32 h)+--	   ioCmd $ _casm_ ``((XImage *)(%0))->data=NULL;XDestroyImage((XImage *)%0);'' image+	   --_casm_ ``((XImage *)(%0))->data=NULL;'' image+           --hPutStrLn stderr "Checkpoint 5 in createPutImage"+	   setXImage_data image nullAddr+           --hPutStrLn stderr "Checkpoint 6 in createPutImage"+	   xDestroyImage image+           --hPutStrLn stderr "Checkpoint 7 in createPutImage"+	   freePtr cbytes+           --hPutStrLn stderr "Returning from createPutImage"+{-+       default_bpp :: Display -> Int -> IO Int+       default_bpp (Display display) depth =+         _casm_+	    ``{int i,cnt,bpp;+	       XPixmapFormatValues *ps=XListPixmapFormats(%0,&cnt);+	       bpp=%1; /* Hmm. Something is wrong if depth isn't found. */+	       for(i=0;i<cnt;i++)+	         if(ps[i].depth==%1) {+		   bpp=ps[i].bits_per_pixel;+		   break;+		 }+	       XFree(ps);+	       %r=bpp;}'' display depth+-}+foreign import ccall "asyncinput.h" default_bpp :: Display -> Int -> IO Int+foreign import ccall "asyncinput.h" setXImage_data :: CXImage -> Addr -> IO ()++i32 :: Int->Int32+i32 = toEnum+u32 :: Int->Unsigned32+u32 = toEnum++getWindowAttributes = getValues newXSetWindowAttributes getWindowAttribute+ where+  getWindowAttribute swa wa =+   case wa of+    CWEventMask em    	 -> (SETWa(swa,event_mask,toC em),CWORD32(CWEventMask))+    CWBackingStore bs 	 -> (SETWa(swa,backing_store,toC bs),CWORD32(CWBackingStore))+    CWSaveUnder b     	 -> (SETWa(swa,save_under,toC b),CWORD32(CWSaveUnder))+    CWDontPropagate em   -> (SETWa(swa,do_not_propagate_mask,toC em),CWORD32(CWDontPropagate))+    CWOverrideRedirect b -> (SETWa(swa,override_redirect,toC b),CWORD32(CWOverrideRedirect))+    CWBackPixel p	 -> (SETWa(swa,background_pixel,toC p),CWORD32(CWBackPixel))+    CWCursor c		 -> (SETWaXID(swa,cursor,toXID c),CWORD32(CWCursor))+    CWBitGravity g 	 -> (SETWa(swa,bit_gravity,toC g),CWORD32(CWBitGravity))+    CWWinGravity g 	 -> (SETWa(swa,win_gravity,toC g),CWORD32(CWWinGravity))+    CWBackPixmap p       -> (SETWaXID(swa,background_pixmap,toXID p),CWORD32(CWBackPixmap))+    CWBorderPixmap p     -> (SETWaXID(swa,border_pixmap,toXID p),CWORD32(CWBorderPixmap))+    CWBorderPixel p      -> (SETWa(swa,border_pixel,toC p),CWORD32(CWBorderPixel) :: Bitmask)+    -- _ -> (return (),0) -- to skip unimplemented fields++getWindowChanges = getValues newXWindowChanges getWindowChange where+  getWindowChange s wc = case wc of+     CWX x 	      -> (SET(XWindowChanges,Int,s,x,x),CWORD32(CWX))+     CWY y 	      -> (SET(XWindowChanges,Int,s,y,y),CWORD32(CWY))+     CWWidth w        -> (SET(XWindowChanges,Int,s,width,w),CWORD32(CWWidth))+     CWHeight h       -> (SET(XWindowChanges,Int,s,height,h),CWORD32(CWHeight))+     CWBorderWidth w  -> (SET(XWindowChanges,Int,s,border_width,w),CWORD32(CWBorderWidth))+     CWStackMode sm   -> (SET(XWindowChanges,Int,s,stack_mode,toC sm),CWORD32(CWStackMode) :: Bitmask) ++{- deriving toEnum & fromEnum appears broken (not anymore /TH 2000-11-28) -}++instance ToC CoordMode where toC = getEnum CoordModeOrigin+instance ToC Shape where toC = getEnum Complex+instance ToC BackingStore where toC = getEnum NotUseful+instance ToC Gravity where toC = getEnum ForgetGravity+instance ToC StackMode where toC = getEnum StackAbove+instance ToC ShapeKind where toC = getEnum ShapeBounding+instance ToC ShapeOperation where toC = getEnum ShapeSet+instance ToC Ordering' where toC = getEnum Unsorted++instance ToC Button where toC AnyButton  = CCONST(AnyButton)+			  toC (Button i) = i++getEvent w e = do+    xe <- newXEvent+    SET(XAnyEvent,Window,xe,window,w::Window)+    case e of+      SelectionNotify time (Selection sel target props) -> do+        SET(XSelectionEvent,Int,xe,type,CCONST(SelectionNotify)::Int)+        SET(XSelectionEvent,Atom,xe,selection, sel)+        SET(XSelectionEvent,Atom,xe,target, target)+        SET(XSelectionEvent,Atom,xe,property, props)+        SET(XSelectionEvent,Time,xe,time,time)+    return xe+++storePoints ps = getArray newXPointArray+	          (\xpoints (i,Point x y) -> do SETI(XPoint,Int,xpoints,i,x,x)+					        SETI(XPoint,Int,xpoints,i,y,y)) ps++storeRectangles rs =+  getArray newXRectangleArray+           (\rsa (i,Rect (Point x y) (Point w h)) -> do+		     SETI(XRectangle,Int,rsa,i,x,x)+		     SETI(XRectangle,Int,rsa,i,y,y)+		     SETI(XRectangle,Int,rsa,i,width,w)+		     SETI(XRectangle,Int,rsa,i,height,h)) rs
+ hsrc/ghc-dialogue/DoXRequest.hs view
@@ -0,0 +1,488 @@+{-# LANGUAGE CPP #-}+{- Obsolete OPTIONS -#include <X11/Xlib.h> -#include <X11/Xutil.h> -#include <X11/extensions/Xdbe.h> -fvia-C -}+--  -optc-I/usr/X11R6/include+module DoXRequest(doXRequest,getGCValues,translateCoordinates) where++--import P_IO_data(Request(..),Response(..))+import Geometry+import Command+import Event+import Xtypes+import Font+--import ResourceIds+import Visual+import HbcWord(intToWord) -- for Visual+import IOUtil(getEnvi)+--import CmdLineEnv(argFlag)++import XCallTypes+import StructFuns+import Xlib+import Marshall+import MyForeign -- debugging+import CString16++--import Ap++{-+#include "newstructfuns.h"+-}++newXID = newPtr :: IO CXID+newLong = newPtr :: IO CLong+newLongs n = sequence (replicate n newLong)+readLong = readCVar :: CLong -> IO Int+newInt32 = newPtr :: IO CInt32+newInt32s n = sequence (replicate n newInt32)+readInt32 = readCVar :: CInt32 -> IO Int32+freePtrs xs = mapM_ freePtr xs++--synchronize = argFlag "synchronize" False++{-+doXRequest req@(display,_,_) =+  do r <- doXRequest' req+     if synchronize && display/=noDisplay then xSync display False else return ()+     return r+-}+{-+doXRequest req@(display,_,_) | display/=noDisplay =+    withLockedDisplay display $ doXRequest' req+doXRequest req = doXRequest' req+-}+doXRequest (d@display,wi,req) =+ case req of+   OpenDisplay optname ->+      do name <- if null optname+		 then case getEnvi "DISPLAY" of+		        Just n -> return n+	                Nothing -> failu "DISPLAY variable is not set"+		 else return optname+         d <- xOpenDisplay name+	 --xSynchronize d synchronize -- has no effect?!+	 return (DisplayOpened d)+   CreateSimpleWindow p r -> WindowCreated <$> createWindow wi r+   CreateRootWindow r resname -> WindowCreated <$> do+       dr <- xDefaultRootWindow display+       this <- createWindow dr r+       setClassHint display this resname "Fudgets"+	  /* This is a hack that solves a focus problem with twm.+	     The twm option NoTitleFocus also solves the problem. */+       -- xSetWMHints display this InputHint True+       return this+   CreateGC dr oldgc gcattrs -> GCCreated <$> do+     wi' <- if wi == noWindow then xDefaultRootWindow display else return wi+     gcvals <- getGCValues gcattrs+     gc <- createGC display (getdrawable wi' dr)+     if oldgc == rootGC then do+        screen <- xDefaultScreen display+        xSetForeground display gc =<< xBlackPixel display screen+	xSetBackground display gc =<< xWhitePixel display screen+      else copyGC display oldgc gc+     changeGC display gc gcvals+     return gc+   LoadFont fn -> FontLoaded <$> xLoadFont display fn+   CreateFontCursor shp -> CursorCreated <$> xCreateFontCursor display shp+   GrabPointer b evm ->+     PointerGrabbed <$> xGrabPointer display wi b (toC evm)+	  grabModeAsync grabModeAsync windowNone cursorNone currentTime+   AllocNamedColor cm cn ->+      ColorAllocated <$> (allocNamedColor display cn =<< dcm cm)+   AllocColor cm rgb ->+       ColorAllocated <$> (allocColor display rgb =<< dcm cm)+   CreatePixmap (Point w h) depth -> PixmapCreated <$> do+     depth' <- if depth == copyFromParent+		  then xDefaultDepth display =<< xDefaultScreen display+		  else return depth+     WindowId wi' <- if wi == noWindow then xDefaultRootWindow display else return wi+     xCreatePixmap display (DrawableId wi') w h depth'+   ReadBitmapFile filename -> do+      bm <- newXID+      ints@[w,h,xhot,yhot] <- newInt32s 4+      WindowId root <- xDefaultRootWindow display+      cfilename <- marshallString filename -- GHC gives faulty code for marshallM?+      --putStrLn "about to call xReadBitmapFile"+      --writeCVar xhot 0+      --putStrLn filename+      --putStrLn =<< unmarshall cfilename+      --print =<< readLong xhot+      r <- xReadBitmapFile display (DrawableId root) cfilename w h bm xhot yhot+      --putStrLn "returned from call to xReadBitmapFile"+      freePtr cfilename -- crash?!!+      --putStrLn "about to read xhot"+      x <- fromIntegral <$> readInt32 xhot+      --putStr "xhot =";print x+      ret <-+        if (r::Int) == CCONST(BitmapSuccess) then do+	    hot <- if x == -1 then return Nothing +			      else Just . Point x . fromIntegral <$> readInt32 yhot+	    BitmapReturn+	      <$> (Point <$> (fromIntegral <$> readInt32 w) <*> (fromIntegral <$> readInt32 h))+	     <*> return hot +	     <*> (PixmapId <$> readCVar bm)+        else return BitmapBad+      --putStrLn "about to free int parameters"+      freePtrs ints+      freePtr bm+      return (BitmapRead ret)+   CreateBitmapFromData (BitmapData size@(Point w h) hot bytes) ->+     do cbytes <- marshallString' (map toEnum bytes) (((w+7) `div` 8)*h)+        WindowId wi' <- if wi == noWindow then xDefaultRootWindow display else return wi+        let cw = fromIntegral w+            ch = fromIntegral h+        pm <- xCreateBitmapFromData display (DrawableId wi') cbytes cw ch+        freePtr cbytes+        return (BitmapRead (BitmapReturn size hot pm))+   --RmGetStringDatabase str ->+   --RmGetResource rmd s1 s2 ->+   TranslateCoordinates ->+     do rootwin <- xDefaultRootWindow display+        CoordinatesTranslated . maybe origin id+          <$> translateCoordinates display wi rootwin+   InternAtom str b -> GotAtom <$> xInternAtom display str b++   GetAtomName a -> +     do at_ret <- xGetAtomName display a+        if (at_ret == nullStr)+           then return (GotAtomName Nothing)+           else+             do at_name <- unmarshallString at_ret+                xFree at_ret+                -- putStrLn at_name+                case (length at_name) of+                   0 -> return (GotAtomName Nothing)+                   _ -> return (GotAtomName $ Just at_name)++   GetWindowProperty offset property delete req_type ->+     do let length = 1000 +	actual_type <- newPtr+	actual_format <- newPtr+	nitems <- newLong+	bytes_after <- newLong+	prop_return <- newCString+	xGetWindowProperty display wi property offset+			   (length `div` (4::Int)) delete req_type+	       actual_type actual_format nitems bytes_after prop_return+	at <- readCVar actual_type+	af <- readCVar actual_format+	n <- readLong nitems+	ba <- readLong bytes_after+	str <- if (af::Int) == CCONST(None) then return "" else+	    do let got = af*n `div` 8+	       cstr <- readCVar prop_return+	       str <- unmarshallString' cstr got+	       xFree cstr+	       return str+	freePtr actual_type+	freePtr actual_format+	freePtr nitems+	freePtr bytes_after+	freePtr prop_return+	return $ GotWindowProperty at af n ba str+   QueryPointer -> do+     ints@[root,child,root_x,root_y,win_x,win_y,mask] <- newLongs 7+     same <- xQueryPointer display wi root child root_x root_y win_x win_y mask+     ret <- PointerQueried same+	      <$> mkPoint (readLong root_x) (readLong root_y)+	     <*> mkPoint (readLong win_x) (readLong win_y)+	     <*> (fromC <$> readLong mask)+     freePtrs ints+     return ret++   QueryFont fid -> FontQueried <$> queryFont display fid+   LoadQueryFont fn -> FontQueried <$> loadQueryFont display fn++   QueryColor cmid (Pixel px) -> do+      c <- newXColor+      SET(XColor,Word,c,pixel,px)+      cm <- dcm cmid+      xQueryColor display cm c+      r <- mkColor c+      freePtr c+      return (ColorQueried r)++   ListFonts pattern maxnames ->+     do cnt <- newLong+	fnarr <- xListFonts display pattern maxnames cnt+	fns <- unmarshallArray fnarr =<< readLong cnt+	xFreeFontNames fnarr+	freePtr cnt+	return (GotFontList fns)+   --QueryTree ->+   DefaultRootWindow -> GotDefaultRootWindow <$> xDefaultRootWindow display+   --GetGeometry ->+   --GetResource rms ->+   DefaultVisual ->+     GotVisual <$> (mkVisual =<< xDefaultVisual d =<< xDefaultScreen d)+   Sync b -> xSync display b >> return Synced+   QueryTextExtents16 fid s ->+     do let n = length s+	cs <- marshallString16' s n+        ints@[dir,ascent,descent,overall] <- newLongs 4+        overall <- newPtr+	xQueryTextExtents16 display fid cs n dir ascent descent overall+        [asc,desc] <- mapM readLong [ascent,descent]+        ov <- mkCharStruct overall+        freePtrs ints+	freePtr overall+        return $ TextExtents16Queried asc desc ov+   ListFontsWithInfo pattern maxnames ->+     GotFontListWithInfo <$> listFontsWithInfo d pattern maxnames+   DbeQueryExtension ->+     do ints@[major,minor] <- newLongs 2+        status <- xdbeQueryExtension display major minor+	ma <- readLong major+	mi <- readLong minor+	freePtrs ints+	return (DbeExtensionQueried status ma mi)+   DbeAllocateBackBufferName swapAction ->+       DbeBackBufferNameAllocated <$> xdbeAllocateBackBufferName d wi swapAction+   DbeSwapBuffers swapAction -> -- applies only to the fudget's own window.+       do (swapinfo,cnt) <- storeSwapAction [(wi,swapAction)]+          status <- xdbeSwapBuffers display swapinfo cnt+	  freePtr swapinfo+	  return (DbeBuffersSwapped status)+   _ -> error (notImplemented req)+ where+  createWindow parent (Rect (Point x y) (Point w h)) = do+    screen <- xDefaultScreen display+    blackP <- xBlackPixel display screen+    whiteP <- xWhitePixel display screen+    let border_width = 0 -- should agree with border_width in WindowF.hs !!+    this <- xCreateSimpleWindow display parent x y w h border_width blackP whiteP+    xStoreName display this "Fudgets"+    return this+  dcm = dcmap display++{-+type BorderWidth = Int+type FontShape = Int+-}++setClassHint :: Display -> Window -> String -> String -> IO ()+setClassHint d w resName resClass =+  do class_hints <- newPtr+     rn<-marshallString resName+     SET(XClassHint,CString,class_hints,res_name,rn)+     rc<-marshallString resClass+     SET(XClassHint,CString,class_hints,res_class,rc)+     xSetClassHint d w class_hints+     freePtr rn+     freePtr rc++createGC :: Display -> DrawableId -> IO GCId+createGC d w = xCreateGC d w 0 nullPtr+--    _casm_ ``%r=XCreateGC(%0,%1,0,NULL);'' d w++copyGC :: Display -> GCId -> GCId -> IO ()+copyGC d oldgc gc = +  --xCopyGC d oldgc ``(1<<(GCLastBit+1))-1)''gc+  xCopyGC d oldgc 8388607  gc+--   _casm_ ``XCopyGC(%0,%1,(1<<(GCLastBit+1))-1,%2);'' d oldgc gc++changeGC d gc (gcvals,mask) = xChangeGC d gc mask gcvals++allocNamedColor :: Display -> String -> ColormapId -> IO (Maybe Color)+allocNamedColor d colname cm = do+   exact <- newPtr+   screen <- newPtr+   status <- xAllocNamedColor d cm colname screen exact+   r <- returnColor status screen+   freePtr exact+   freePtr screen+   return r++returnColor status c = + if status /= (0::Int)+    then Just <$> mkColor c+    else return Nothing++mkColor xcol = + Color . Pixel+  <$> GET(XColor,Word,xcol,pixel)+  <*> (RGB+	 <$> GET(XColor,Int,xcol,red)+	 <*> GET(XColor,Int,xcol,green)+	 <*> GET(XColor,Int,xcol,blue)+      )++allocColor :: Display -> RGB -> ColormapId -> IO (Maybe Color)+allocColor d rgb cm = do+  color <- newXColor+  setRGB rgb color+  status <- xAllocColor d cm color+  r <- returnColor status color+  freePtr color+  return r++setRGB (RGB red green blue) color = do+  SET(XColor,Int,color,red,red)+  SET(XColor,Int,color,green,green)+  SET(XColor,Int,color,blue,blue)++type XGCValuesMask = (CXGCValues,Bitmask)++getGCValues :: GCAttributeList -> IO XGCValuesMask+getGCValues = getValues newPtr getGCValue where+  getGCValue gcv ga = case ga of+    GCFunction f           -> (SET(XGCValues,Int,gcv,function,fromEnum f),CWORD32(GCFunction)::Bitmask)+    GCForeground p         -> (SET(XGCValues,Int,gcv,foreground,toC p),CWORD32(GCForeground))+    GCBackground p         -> (SET(XGCValues,Int,gcv,background,toC p),CWORD32(GCBackground))+    GCLineWidth w          -> (SET(XGCValues,Int,gcv,line_width,w),CWORD32(GCLineWidth))+    GCLineStyle s          -> (SET(XGCValues,Int,gcv,line_style,fromEnum s),CWORD32(GCLineStyle))+    GCFont f               -> (SET(XGCValues,XID,gcv,font,toXID f),CWORD32(GCFont))+    GCCapStyle s           -> (SET(XGCValues,Int,gcv,cap_style,fromEnum s),CWORD32(GCCapStyle))+    GCJoinStyle s          -> (SET(XGCValues,Int,gcv,join_style,fromEnum s),CWORD32(GCJoinStyle))+    GCSubwindowMode m      -> (SET(XGCValues,Int,gcv,subwindow_mode,fromEnum m),CWORD32(GCSubwindowMode))+    GCGraphicsExposures g  -> (SET(XGCValues,Int,gcv,graphics_exposures, fromEnum g),CWORD32(GCGraphicsExposures))+    GCFillStyle f          -> (SET(XGCValues,Int,gcv,fill_style,fromEnum f),CWORD32(GCFillStyle))+    GCTile p               -> (SET(XGCValues,XID,gcv,tile,toXID p),CWORD32(GCTile))+    GCStipple p            -> (SET(XGCValues,XID,gcv,stipple,toXID p),CWORD32(GCStipple) :: Bitmask)+    -- _ -> (return (),0)+++loadQueryFont :: Display -> FontName -> IO (Maybe FontStructList)+loadQueryFont d fn = mkFontStructList =<< xLoadQueryFont d fn++queryFont :: Display -> FontId -> IO (Maybe FontStructList)+queryFont d fi = mkFontStructList =<< xQueryFont d fi++listFontsWithInfo :: Display -> FontName -> Int -> IO [(FontName,FontStructList)]+listFontsWithInfo d pattern maxnames =+  do cnt <- newInt32+     fsarrp <- newCXFontStruct+     --putStrLn "About to call xListFontsWithInfo"+     fnarr <- xListFontsWithInfo d pattern (fromIntegral maxnames) cnt fsarrp+     --putStrLn "Returned from call xListFontsWithInfo"+     n <- readInt32 cnt+     --putStr "Number of fonts: " ; print n+     freePtr cnt+     fsarr <- readCVar fsarrp+     freePtr fsarrp+     --putStrLn "After free fsarrp"+     if fnarr==nullStr then return []+      else do+       --putStrLn "Non-null name array"+       fns <- unmarshallArray fnarr (fromIntegral n)+       --putStrLn "Got name list";print fns+       fss <- readArray fsarr (fromIntegral n)+       --putStrLn "Got fontstruct list"+       xFreeFontInfo fnarr fsarr n+       --putStrLn "Freed fontinfo, returning"+       return (zip fns fss)++instance CVar CXFontStruct FontStructList+instance Storable FontStructList where -- just for readArray...+--sizeOf _ = sizeOf (undefined::CXFontStruct) -- Wrong size!!!+  sizeOf _ = SIZEOF(XFontStruct)+  alignment _ = alignment (undefined::CXFontStruct)+  peek = mkFontStructList' . CXFontStruct++mkFontStructList :: CXFontStruct -> IO (Maybe FontStructList)+mkFontStructList fs =+   if fs == CXFontStruct nullAddr+   then return Nothing+   else do fsl <- mkFontStructList' fs+           --_casm_ ``XFreeFontInfo(NULL, %0, 1); '' fs+	   xFreeFontInfo nullStr fs 1+	   return (Just fsl)++#if 0+#define DEBUG(cmd) (putStrLn "cmd before">>(cmd)>>= \r->putStrLn "after">>return r)+#else+#define DEBUG(cmd) (cmd)+#endif++mkFontStructList' :: CXFontStruct -> IO FontStructList+mkFontStructList' fs =+  do --putStrLn "Enter mkFontStructList'"+     min_char_or_byte2 <- GET(XFontStruct,Int,fs,min_char_or_byte2)+     min_byte1 <-GET(XFontStruct,Int,fs,min_byte1)+     max_char_or_byte2 <- GET(XFontStruct,Int,fs,max_char_or_byte2)+     max_byte1 <-GET(XFontStruct,Int,fs,max_byte1)+     n_prop <-GET(XFontStruct,Int,fs,n_properties)+     -- putStrLn $ "font properties: " ++ (show n_prop)+     --putStrLn "after min max"+     let min = min_char_or_byte2 + 256*min_byte1+         max = max_char_or_byte2 + 256*max_byte1+         arrsize = (max_char_or_byte2 - min_char_or_byte2 + 1) *+		   (max_byte1 - min_byte1 + 1)+         --arrsize = max - min  :: Int -- This is wrong!+     --print ("min max arrsize",min,max,arrsize)+     per_char <- GET(XFontStruct,HT(XCharStruct),fs,per_char)+     --putStrLn "after per_char"+     elem9 <- if per_char /= nullPtr -- CCONST(NULL) +       then Just <$> mapM (\i -> INDEX(XCharStruct) per_char i >>= mkCharStruct) [0..arrsize-1] +       else return Nothing+     --putStrLn "after elem9"+     f_prop <- GET(XFontStruct,HT(XFontProp),fs,properties)+     elemprop <- if f_prop /= nullPtr+       then mapM (\i -> INDEX(XFontProp) f_prop i >>= mkFontProp) [0..n_prop-1]+       else return []+     -- putStrLn $ show elemprop+     fsl <- FontStruct . FontId+	<$> DEBUG(GET(XFontStruct,XID,fs,fid))+	<*> fmap toEnum DEBUG(GET(XFontStruct,Int,fs,direction))+	<*> return (toEnum min)+	<*> return (toEnum max)+	<*> fmap toEnum DEBUG(GET(XFontStruct,Int,fs,all_chars_exist))+	<*> DEBUG(GET(XFontStruct,Char,fs,default_char))+	<*> return elemprop+	<*> (mkCharStruct =<< DEBUG(AGET(XFontStruct,HT(XCharStruct),fs,min_bounds)))+	<*> (mkCharStruct =<< DEBUG(AGET(XFontStruct,HT(XCharStruct),fs,max_bounds)))+	<*> return elem9+	<*> DEBUG(GET(XFontStruct,Int,fs,ascent))+	<*> DEBUG(GET(XFontStruct,Int,fs,descent))+     -- putStrLn $ "Returning from mkFontStructList'" ++ (show fsl)+     return fsl++-- Intermediate data for FontProp, containing just two integers:+-- atom values will (hopefully) be retrieved lazily.++mkFontProp :: CXFontProp -> IO FontProp++mkFontProp fp = +  FontProp+   <$> GET(XFontProp,Atom,fp,name)+  <*> GET(XFontProp,Int,fp,card32)++mkCharStruct :: CXCharStruct -> IO CharStruct+mkCharStruct cs = +    CharStruct+     <$> GET(XCharStruct,Int,cs,lbearing)+     <*> GET(XCharStruct,Int,cs,rbearing)+     <*> GET(XCharStruct,Int,cs,width)+     <*> GET(XCharStruct,Int,cs,ascent)+     <*> GET(XCharStruct,Int,cs,descent)++mkVisual :: CVisual -> IO Visual+mkVisual cv =+  Visual+   <$> GET(Visual,VisualID,cv,visualid)+   <*> fmap toEnum GET(Visual,Int,cv,class)+   <*> fmap intToWord GET(Visual,Int,cv,red_mask)+   <*> fmap intToWord GET(Visual,Int,cv,green_mask)+   <*> fmap intToWord GET(Visual,Int,cv,blue_mask)+   <*> GET(Visual,Int,cv,bits_per_rgb)+   <*> GET(Visual,Int,cv,map_entries)++storeSwapAction :: [(WindowId,SwapAction)] -> IO (CXdbeSwapInfoArray,Int)+storeSwapAction =+  getArray newXdbeSwapInfoArray+	   (\si (i,(wi,sa)) ->+              do SETI(XdbeSwapInfo,WindowId,si,i,swap_window,wi)+		 SETI(XdbeSwapInfo,Int,si,i,swap_action,fromEnum sa))++translateCoordinates display window dstwindow =+  do dx <- newPtr+     dy <- newPtr+     child <- newPtr+     ok <- xTranslateCoordinates display window dstwindow 0 0 dx dy child+     p <- if ok+          then Just <$> (Point <$> (fromEnum <$> readInt32 dx)+                               <*> (fromEnum <$> readInt32 dy))+          else return Nothing+     freePtrs [dx,dy]+     freePtr child+     return p+
+ hsrc/ghc-dialogue/EncodeEvent.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE CPP #-}+{- Obsolete OPTIONS -optc-I/usr/X11R6/include -#include <X11/Xlib.h> -#include <X11/Xutil.h> -fvia-C -}+module EncodeEvent(getNextEvent,motionCompress) where++import Event+import Xtypes+--import ResourceIds++import XCallTypes+import StructFuns+import Xlib+import Marshall+import MyForeign+import qualified Foreign as F++import FudUTF8(decodeUTF8)+import Data.Maybe(fromMaybe)+--import Ap++--import GlaExts hiding(Word) --(primIOToIO,CCallable,CReturnable,Addr)+--import MutableArray(MutableByteArray#)+--import PrelGHC+--import PrelBase+--import GhcWord+--import CString(unpackCStringIO)+--import Command+--import Font++#include "newstructfuns.h"++getNextEvent d = do+   ev <- newXEvent+   xNextEvent d ev+   window <- GET(XAnyEvent,WindowId,ev,window)+   fev <- encodeEvent ev+   return (window,fev) -- no freePtr?!++checkWindowEvent d w evmask = do+   ev <- newXEvent+   found <- xCheckWindowEvent d w (toC (evmask::[EventMask])) ev+   if found+     then Just <$> encodeEvent ev+     else freePtr ev >> return Nothing++motionCompress d e@(w,fev@MotionNotify{}) =+  do me <- checkWindowEvent d w [PointerMotionMask]+     case me of+       Nothing -> return e+       Just fev' -> motionCompress d (w,fev')+motionCompress _ e = return e+++encodeEvent ev = do+   evno <- GET(XAnyEvent,Int,ev,type)+   case evno :: Int of++{- ghc doesn't handle literal (``KeyPress'') patterns yet -}++#define X_KeyPress		2+#define X_KeyRelease		3+#define X_ButtonPress		4+#define X_ButtonRelease		5+#define X_MotionNotify		6+#define X_EnterNotify		7+#define X_LeaveNotify		8+#define X_FocusIn		9+#define X_FocusOut		10+#define X_KeymapNotify		11+#define X_Expose		12+#define X_GraphicsExpose	13+#define X_NoExpose		14+#define X_VisibilityNotify	15+#define X_CreateNotify		16+#define X_DestroyNotify		17+#define X_UnmapNotify		18+#define X_MapNotify		19+#define X_MapRequest		20+#define X_ReparentNotify	21+#define X_ConfigureNotify	22+#define X_ConfigureRequest	23+#define X_GravityNotify		24+#define X_ResizeRequest		25+#define X_CirculateNotify	26+#define X_CirculateRequest	27+#define X_PropertyNotify	28+#define X_SelectionClear	29+#define X_SelectionRequest	30+#define X_SelectionNotify	31+#define X_ColormapNotify	32+#define X_ClientMessage		33+#define X_MappingNotify		34+     X_KeyPress      	-> putKeyEvent ev Pressed+     X_KeyRelease    	-> putKeyEvent ev Released+     X_ButtonPress   	-> putButtonEvent ev Pressed+     X_ButtonRelease 	-> putButtonEvent ev Released+     X_MotionNotify  	-> putMotionEvent ev+     X_EnterNotify   	-> putCrossingEvent ev True+     X_LeaveNotify   	-> putCrossingEvent ev False+     X_FocusIn       	-> putFocusChangeEvent ev True+     X_FocusOut      	-> putFocusChangeEvent ev False+     X_KeymapNotify  	-> return KeymapNotify+     X_Expose	       	-> putExposeEvent ev+     X_GraphicsExpose	-> putGraphicsExposeEvent ev+     X_NoExpose		-> return NoExpose+     X_VisibilityNotify	-> putVisibilityEvent ev+     X_CreateNotify	-> putStructEvent ev CreateNotify+     X_DestroyNotify	-> putStructEvent ev DestroyNotify+     X_UnmapNotify	-> putStructEvent ev UnmapNotify+     X_MapNotify	-> putStructEvent ev MapNotify+     X_MapRequest	-> putStructEvent ev MapRequest+     X_ReparentNotify	-> return ReparentNotify+     X_ConfigureNotify	-> putConfigureEvent ev+     X_ConfigureRequest	-> return ConfigureRequest+     X_GravityNotify	-> return GravityNotify+     X_ResizeRequest	-> putResizeRequestEvent ev+     X_CirculateNotify	-> return CirculateNotify+     X_CirculateRequest	-> return CirculateRequest+     X_PropertyNotify	-> return PropertyNotify+     X_SelectionClear	-> putSelectionClearEvent ev+     X_SelectionRequest	-> putSelectionRequestEvent ev+     X_SelectionNotify	-> putSelectionNotifyEvent ev+     X_ColormapNotify	-> return ColormapNotify+     X_ClientMessage	-> putClientMessageEvent ev+     X_MappingNotify	-> return MappingNotify++mkClientData ev = do+  format <- GET(XClientMessageEvent,Int,ev,format)+  d <- AGET(XClientMessageEvent,Addr,ev,data)+  case format::Int of+    32 -> Long <$> mapM (CINDEX(long) (d::Addr)) [0..(4::Int)]+    16 -> Short <$> mapM (CINDEX(short) d) [0..(9::Int)]+    8  -> Byte <$> mapM (CINDEX(char) d) [0..(19::Int)]++putKeyEvent ev p = do+  (key,l) <- xLookupString ev 100+  KeyEvent+   <$> GET(XKeyEvent,Time,ev,time)+   <*> mkPoint GET(XKeyEvent,Int,ev,x) GET(XKeyEvent,Int,ev,y)+   <*> mkPoint GET(XKeyEvent,Int,ev,x_root) GET(XKeyEvent,Int,ev,y_root)+   <*> fmap fromC GET(XKeyEvent,Int,ev,state)+   <*> return p+   <*> fmap KeyCode GET(XKeyEvent,Int,ev,keycode)+   <*> return key+   <*> return (decodeUTF8 l)+             -- !! Assume that XLookupString returns a UTF-8 string+             -- https://gitlab.freedesktop.org/xorg/lib/libx11/-/issues/39++putButtonEvent ev p =+   ButtonEvent+   <$> GET(XButtonEvent,Time,ev,time)+   <*> mkPoint GET(XButtonEvent,Int,ev,x) GET(XButtonEvent,Int,ev,y)+   <*> mkPoint GET(XButtonEvent,Int,ev,x_root) GET(XButtonEvent,Int,ev,y_root)+   <*> fmap fromC GET(XButtonEvent,Int,ev,state)+   <*> return p+   <*> fmap Button GET(XButtonEvent,Int,ev,button)++putMotionEvent ev =+   MotionNotify+   <$> GET(XMotionEvent,Time,ev,time)+   <*> mkPoint GET(XMotionEvent,Int,ev,x) GET(XMotionEvent,Int,ev,y)+   <*> mkPoint GET(XMotionEvent,Int,ev,x_root) GET(XMotionEvent,Int,ev,y_root)+   <*> fmap fromC GET(XMotionEvent,Int,ev,state)++putCrossingEvent ev c =+   (if c then EnterNotify else LeaveNotify)+   <$> GET(XCrossingEvent,Time,ev,time)+   <*> mkPoint GET(XCrossingEvent,Int,ev,x) GET(XCrossingEvent,Int,ev,y)+   <*> mkPoint GET(XCrossingEvent,Int,ev,x_root) GET(XCrossingEvent,Int,ev,y_root)+   <*> fmap fromC GET(XCrossingEvent,Int,ev,detail)+   <*> fmap fromC GET(XCrossingEvent,Int,ev,mode)+   <*> fmap fromC GET(XCrossingEvent,Int,ev,focus)+++putFocusChangeEvent ev c =+   (if c then FocusIn else FocusOut)+   <$> fmap fromC GET(XFocusChangeEvent,Int,ev,detail)+   <*> fmap fromC GET(XFocusChangeEvent,Int,ev,mode)++putExposeEvent ev =+   Expose+   <$> mkRect GET(XExposeEvent,Int,ev,x) GET(XExposeEvent,Int,ev,y)+	       GET(XExposeEvent,Int,ev,width) GET(XExposeEvent,Int,ev,height) +   <*> GET(XExposeEvent,Int,ev,count)++putGraphicsExposeEvent ev =+   GraphicsExpose +   <$> mkRect GET(XGraphicsExposeEvent,Int,ev,x) GET(XGraphicsExposeEvent,Int,ev,y)+	       GET(XGraphicsExposeEvent,Int,ev,width) GET(XGraphicsExposeEvent,Int,ev,height) +   <*> GET(XGraphicsExposeEvent,Int,ev,count)+   <*> GET(XGraphicsExposeEvent,Int,ev,major_code)+   <*> GET(XGraphicsExposeEvent,Int,ev,minor_code)++putVisibilityEvent ev =+  VisibilityNotify . fromC <$> GET(XVisibilityEvent,Int,ev,state)++putStructEvent ev c = c <$> GET(XMapEvent,WindowId,ev,window)++putConfigureEvent ev =+   ConfigureNotify+   <$> mkRect GET(XConfigureEvent,Int,ev,x) GET(XConfigureEvent,Int,ev,y)+               GET(XConfigureEvent,Int,ev,width) GET(XConfigureEvent,Int,ev,height)+   <*> GET(XConfigureEvent,Int,ev,border_width)++putResizeRequestEvent ev =+   ResizeRequest +  <$> mkPoint GET(XResizeRequestEvent,Int,ev,width)+             GET(XResizeRequestEvent,Int,ev,height)++putSelectionClearEvent ev = SelectionClear+ <$> GET(XSelectionClearEvent,Atom,ev,selection)++putSelectionRequestEvent ev =+  SelectionRequest+  <$> GET(XSelectionRequestEvent,Time,ev,time)+  <*> GET(XSelectionRequestEvent,WindowId,ev,requestor)+  <*> (Selection <$> GET(XSelectionRequestEvent,Atom,ev,selection)+		<*> GET(XSelectionRequestEvent,Atom,ev,target)+		<*> GET(XSelectionRequestEvent,Atom,ev,property))++putSelectionNotifyEvent ev =+  SelectionNotify+  <$> GET(XSelectionEvent,Time,ev,time)+  <*> (Selection <$> GET(XSelectionEvent,Atom,ev,selection)+		<*> GET(XSelectionEvent,Atom,ev,target)+		<*> GET(XSelectionEvent,Atom,ev,property))++putClientMessageEvent ev =+  ClientMessage+  <$> GET(XClientMessageEvent,Atom,ev,message_type)+  <*> mkClientData ev++foreign import ccall "X11/Xlib.h XLookupString"+  cXLookupString :: CXKeyEvent -> Addr -> Int -> F.Ptr XlibKeySym -> Addr -> IO Int++xLookupString :: CXKeyEvent -> Int -> IO (KeySym,String)+xLookupString xev len =+    alloca len $ \ arr ->+    F.alloca $ \ keysyma ->+    do len' <- {- _casm_ ``%r=(int)XLookupString((XKeyEvent *)%0,+					  (char *)%1,+					  (int)%2,+					  (KeySym *)%3,+					  NULL);'' xev arr len keysyma -}+           cXLookupString xev arr len keysyma nullAddr+       keysym <- F.peek keysyma+       key <- xKeysymToString keysym+       let key' = fromMaybe "(undefined)" key+       str <- unmarshallString' (CString arr) len'+       return (key',str)++instance FromC Detail where fromC = toEnum' NotifyAncestor+instance FromC Mode where fromC = toEnum' NotifyNormal+instance FromC Visibility where fromC = toEnum' VisibilityUnobscured+++instance F.Storable XID where+  sizeOf (XID x) = F.sizeOf x+  alignment (XID x) = F.alignment x++  peek a = fmap XID (F.peek (F.castPtr a))+  poke a (XID x) = F.poke (F.castPtr a) x
+ hsrc/ghc-dialogue/IOUtil.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE CPP #-}+module IOUtil(-- ** Some utilities that are a little dirty, but not very+              getEnvi, progName, progArgs,+              -- ** Backward compatibility+              IOUtil.catch, try, getModificationTime) where++import qualified Control.Exception as E+import qualified System.Directory as D(getModificationTime)+import System.Environment(getEnv,getProgName,getArgs)+#ifdef VERSION_old_time+import Data.Time(UTCTime)+import Data.Time.Clock.POSIX(utcTimeToPOSIXSeconds)+import System.Time(ClockTime(..))+#endif+import UnsafePerformIO(unsafePerformIO)++getEnvi :: String -> Maybe String+getEnvi s = either (const Nothing) Just $ unsafePerformIO $ try (getEnv s)++progName :: String+progName = unsafePerformIO getProgName++progArgs :: [String]+progArgs = unsafePerformIO getArgs++-- * GHC 6.12-7.6 compatibility+catch = E.catch :: IO a -> (IOError -> IO a) -> IO a+try   = E.try   :: IO a -> IO (Either IOError a)++#ifdef VERSION_old_time+getModificationTime path = toClockTime `fmap` D.getModificationTime path++class    ToClockTime a         where toClockTime :: a -> ClockTime+instance ToClockTime ClockTime where toClockTime = id+instance ToClockTime UTCTime   where +    toClockTime = flip TOD 0 . floor . realToFrac . utcTimeToPOSIXSeconds+#else+getModificationTime path = D.getModificationTime path+#endif
+ hsrc/ghc-dialogue/Marshall.hs view
@@ -0,0 +1,187 @@+module Marshall where+import MyForeign+import Control.Monad(zipWithM_)+--import Ap++class HasAddr a where+   addrOf :: a -> Addr+   --atAddr :: Addr -> a++freePtr p = free (addrOf p)++class HasAddr a => IsPtr a where+   nullPtr :: a+   newPtr :: IO a+   newArray :: Int -> IO a++   newPtr = newArray 1++class (Storable h, HasAddr c) => CVar c h | c -> h where+  readCVar :: c -> IO h+  writeCVar :: c -> h -> IO ()+  indexCVar :: c -> Int -> IO h+  writeArray :: c -> [h] -> IO ()+  readArray :: c -> Int -> IO [h]++  readCVar = peek . addrOf+  writeCVar = poke . addrOf+  indexCVar = peekElemOff . addrOf+  writeArray arr = zipWithM_ (pokeElemOff (addrOf arr)) [0..]+  readArray arr n = mapM (indexCVar arr) [0..(n-1)]++toArray xs =+  do let n = length xs+     a <- newArray n+     writeArray a xs+     return (a,n)++{-+instance (Storable a,Storable b) => (Storable (a,b)) where+  sizeOf (a,b) = sizeOf a+sizeOf b+  alignment (a,b) = max (alignment a) (alignment b)+  poke p (a,b) = poke p a >> poke (p `plusAddr` sizeOf a) b+  peek p = do a <- peek p+	      b <- peek (p `plusAddr` sizeOf a) p+	      return (a,b)+-}++-------------------+class PrimArg ha pa r | ha->pa where+  --marshall :: haskell -> IO (prim,IO ())+  marshall :: (pa->r)->ha->r++-- marshallM x = marshall return x -- GHC generates buggy code, it seems++instance PrimArg Int Int c where marshall = id+instance PrimArg Int32 Int32 c where marshall = id+--instance PrimArg Char Char c where marshall = id+instance PrimArg Bool Bool c where marshall = id+--instance PrimArg () Int c where marshall f () = f 0+instance PrimArg Addr Addr c where marshall = id+instance PrimArg CLong CLong c where marshall = id+instance PrimArg CInt32 CInt32 c where marshall = id+instance PrimArg CString CString c where marshall = id++class    Bind f                where bind :: IO o->(o->f)->f+				     thn :: f->IO ()-> f+instance Bind (IO a)           where bind = (>>=)+				     thn f io = do r<-f;io;return r+instance Bind f => Bind (a->f) where bind ioo oaf = bind ioo . flip oaf+				     thn f io a = f a `thn` io++instance Bind f => PrimArg String CString f where+  marshall f str =+     marshallString str `bind` \ cstr ->+     f cstr `thn`+     freePtr cstr++class PrimResult prim haskell where+  unmarshall :: prim -> haskell++instance PrimResult () () where unmarshall = id+instance PrimResult Bool Bool where unmarshall = id+instance PrimResult Char Char where unmarshall = id+instance PrimResult Int Int where unmarshall = id+instance PrimResult Int32 Int32 where unmarshall = id++--instance PrimResult Int (IO Int) where unmarshall = return++instance PrimResult (IO ()) (IO ()) where unmarshall = id+instance PrimResult (IO Int) (IO Int) where unmarshall = id+instance PrimResult (IO Int32) (IO Int32) where unmarshall = id+instance PrimResult (IO Bool) (IO Bool) where unmarshall = id+instance PrimResult (IO CString) (IO CString) where unmarshall = id++unmarshallM m = unmarshall =<< m+unmarshallArray a n = mapM unmarshall =<< readArray a n++instance PrimResult (IO CString) (IO (Maybe String)) where+  unmarshall addrIO =+    do cstr <- addrIO+       if addrOf cstr==nullAddr+        then return Nothing+        else Just <$> unmarshall cstr++instance PrimResult CString (IO String) where unmarshall = unmarshallString+instance PrimResult (IO CString) (IO String) where unmarshall = unmarshallM++instance (PrimArg ha pa pb,PrimResult pb hb) => PrimResult (pa->pb) (ha->hb) where+    -- have: marshall      :: (pa->pb)->(ha->pb)+    -- have: unmarshall    :: pb->hb+    -- produce: unmarshall :: (pa->pb)->(ha->hb)+    unmarshall papb ha = unmarshall (marshall papb ha)++--- Primitive marshalling++newtype CString = CString Addr deriving (Eq)+instance HasAddr CString where addrOf (CString a) = a --; atAddr = CString+instance CVar CString CString+instance Storable CString where+  sizeOf (CString a) = sizeOf a+  alignment (CString a) = alignment a+  peek p = CString <$> peek p+  poke p (CString a) = poke p a++nullStr = CString nullAddr++marshallString :: String -> IO CString+marshallString s = marshallString' s (length s)++marshallString' :: String -> Int -> IO CString+marshallString' s n = +  do a <- mallocElems (head s) (n+1)+     zipWithM_ (pokeElemOff a) [0..n-1] s+     pokeElemOff a n '\0'+     return (CString a)+++unmarshallString :: CString -> IO String+unmarshallString (CString addr) = get 0+  where +    get i =+      do c <- peekElemOff addr i+	 if c=='\0'+	  then return []+	  else (c:) <$> get (i+1)+              +unmarshallString' :: CString -> Int -> IO String+unmarshallString' (CString addr) n = get 0+  where+    get i =+      if i<n+      then (:) <$> peekElemOff addr i <*> get (i+1)+      else return []+     ++---++-- | Pointer to long int (same size as pointers, 64 bits on 64-bit systems)+newtype CLong = CLong Addr+newtype CXID = CXID Addr++instance HasAddr CLong where addrOf (CLong a) = a --;atAddr = CLong+instance HasAddr CXID where addrOf (CXID a) = a --;atAddr = CLong++instance IsPtr CLong where+  nullPtr = CLong nullAddr+  newPtr = CLong <$> mallocElem (0::Int)+  newArray n = CLong <$> mallocElems (0::Int) n++instance IsPtr CXID where+  nullPtr = CXID nullAddr+  newPtr = CXID <$> mallocElem (0::Int)+  newArray n = CXID <$> mallocElems (0::Int) n++instance CVar CLong Int++-- | Pointer to C int (32 bits even on 64-bit system)+newtype CInt32 = CInt32 Addr++instance HasAddr CInt32 where addrOf (CInt32 a) = a --;atAddr = CInt++instance IsPtr CInt32 where+  nullPtr = CInt32 nullAddr+  newPtr = CInt32 <$> mallocElem (0::Int32)+  newArray n = CInt32 <$> mallocElems (0::Int32) n++instance CVar CInt32 Int32
+ hsrc/ghc-dialogue/MyForeign.hs view
@@ -0,0 +1,93 @@+module MyForeign(module MyForeign,(<$>),(<*>),F.Int32,F.CSize(..)) where+import Control.Applicative+import qualified Foreign as F+import qualified Foreign.C as F+import Foreign.C.String(castCCharToChar,castCharToCChar)+--import CCall+import Control.Exception(bracket)+--import Ap+-- Emulate GHC 4.08 libraries on top of GHC 5.00 libraries...++newtype Addr = Addr (F.Ptr F.Word8) deriving (Eq,Show)+type AddrOff = Int++--instance CCallable Addr+--instance CReturnable Addr++class Storable a where+  sizeOf      :: a -> Int+  alignment   :: a -> Int++  peekElemOff :: Addr -> Int          -> IO a+  pokeElemOff :: Addr -> Int     -> a -> IO ()++  peekByteOff :: Addr -> AddrOff      -> IO a+  pokeByteOff :: Addr -> AddrOff -> a -> IO ()++  peek        :: Addr                 -> IO a+  poke        :: Addr            -> a -> IO ()++  peek a = peekByteOff a 0+  poke a = pokeByteOff a 0++  peekElemOff a i =+    let iox = peekByteOff a (i*sizeOf (u iox))+	u :: IO a -> a+	u = undefined+    in iox+  pokeElemOff a i x = pokeByteOff a (i*sizeOf x) x++  peekByteOff a i = peek (a `plusAddr` i)+  pokeByteOff a i = poke (a `plusAddr` i)++malloc n = Addr <$> F.mallocBytes n+mallocElem x = malloc (sizeOf x)+mallocElems x n = malloc (n*sizeOf x)+free (Addr p) = F.free p+alloca n = bracket (malloc n) free+allocaElem x = bracket (mallocElem x) free+allocaElems x n = bracket (mallocElems x n) free++nullAddr = Addr F.nullPtr+plusAddr (Addr p) n = Addr (F.plusPtr p n)+minusAddr (Addr p1) (Addr p2) = F.minusPtr p1 p2++instance Storable Addr where+  sizeOf (Addr a) = F.sizeOf a+  alignment (Addr a) = F.alignment a++  peek a = Addr <$> fpeek a+  poke a (Addr x) = fpoke a x++instance Storable Char where+  sizeOf _ = 1+  alignment _ = 1++  peek a = castCCharToChar <$> fpeek a+  poke a c = fpoke a (castCharToCChar c)++fpeek (Addr p) = F.peek (F.castPtr p)+fpoke (Addr p) = F.poke (F.castPtr p)++instance Storable Int where+  sizeOf x = F.sizeOf x+  alignment x = F.alignment x++  peek = fpeek+  poke = fpoke+++instance Storable F.Int32 where+  sizeOf x = F.sizeOf x+  alignment x = F.alignment x++  peek = fpeek+  poke = fpoke+++instance Storable F.Word32 where+  sizeOf x = F.sizeOf x+  alignment x = F.alignment x++  peek = fpeek+  poke = fpoke
+ hsrc/ghc-dialogue/PQueue.hs view
@@ -0,0 +1,16 @@+module PQueue where++newtype PQueue a b = PQueue [(a,b)] deriving Show++empty = PQueue []++insert (PQueue q) v@(p,a) = PQueue $ insert' q where+   insert' [] = [v]+   insert' q@(v'@(p',_):q') | p < p'    = v : q+			    | otherwise = v' : insert' q'++inspect (PQueue q) = case q of+	[] -> Nothing+	(x:xs) -> Just (x,PQueue xs)++remove (PQueue q) i = PQueue $ filter (\((_,(_,i')))->i'/=i) q
+ hsrc/ghc-dialogue/P_IO_data.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE CPP #-}+-- | Types for Haskell 1.2 dialogue I/O+module P_IO_data {-(module XStuff, module P_IO_data)-} where+import XStuff+import ShowFun()+import Prelude hiding (IOError)+import System.Directory(XdgDirectory)+#ifdef VERSION_old_time+import System.Time(ClockTime,CalendarTime)+#endif+#ifdef VERSION_time+import Data.Time(UTCTime,ZonedTime)+#endif++data Request =	-- file system requests:+			  ReadFile      String         +			| WriteFile     String String+			| AppendFile    String String+			| ReadBinFile   String +			| WriteBinFile  String Bin+			| AppendBinFile String Bin+			| DeleteFile    String+			| StatusFile    String+                 -- useful for IO with GHC >=6.12+ 			| ReadBinaryFile  String         + 			| WriteBinaryFile String String+                -- Files at standard locations for application data+                        | ReadXdgFile XdgDirectory String+                        | WriteXdgFile XdgDirectory String String+		-- channel system requests:+			| ReadChan	String +			| AppendChan    String String+			| ReadBinChan   String +			| AppendBinChan String Bin+			| StatusChan    String+		-- environment requests:+			| Echo          Bool+			| GetArgs+			| GetEnv        String+			| SetEnv        String String+		-- optional+			| ReadChannels	[String]+			| ReadBinChannels [String]+			| CreateProcess	Dialogue+			| CreateDirectory String String+			| OpenFile	String Bool+			| OpenBinFile	String Bool+			| CloseFile	File+			| ReadVal	File+			| ReadBinVal	File+			| WriteVal	File Char+			| WriteBinVal	File Bin+		-- hbc bonus+			| Sleep		Double+			| ChangeDirectory String+			| GetTime -- returns ClockTime -- /TH 2002-04-14+			| DeleteDirectory String+			| System	String+	                | ReadDirectory String+	                | XCommand    (XDisplay,XWId,XCommand)+	                | GetAsyncInput+			| GetCpuTime+			| GetProgName+                        | GetLocalTime -- return CalendarTime+#ifdef VERSION_old_time+                        | ToCalendarTime ClockTime -- returns CalendarTime+#endif+			| SigAction Int SigAct+			| Exit Int+			| ReadFileScattered String [Int]+			| Select       [Descriptor]+			| SocketRequest SocketRequest+			| XRequest     (XDisplay,XWId,XRequest)+			| ReadFileFast String         +			| RenameFile String String+			| GetCurrentDirectory++		        | GetModificationTime FilePath -- returns ClockTime+                        | GetCurrentTime               -- returns UTCTime+                        | GetZonedTime                 -- returns ZonedTime+{-+			-- Haskell 1.3 I/O+			| H_OpenFile String Int		-- return Fil+			| H_Close File			-- return Success+			| H_FileSize File		-- return IntResp+			| H_IsEOF File			-- return IntResp+			| H_SetBuffering File Int	-- return Success+			| H_GetBuffering File		-- return IntResp+			| H_Flush File			-- return Success+			| H_Seek File Int Int		-- return IntResp+			| H_GetFlags File		-- return IntResp+			| H_GetChar File		-- return IntResp+			| H_UnGetChar File Int		-- return Success+			| H_PutChar File Int		-- return Success+			| H_PutString File String	-- return Success+			| H_GetFile File		-- return Str+			| H_Select ([File], [File], [Double]) -- return SelectResp, last list is a Maybe+			| H_CCall _CPointer [_CUnion] _CUnion -- return CCallResp+			| __RunAnswer __Answer		-- never returns+			| H_GetTime			-- returns GetTimeResp+			| H_GetErrno			-- returns IntResp+-}+                      deriving (Show,Read)++{-+data __Answer = __Answer EXISTVAR++instance Text __Answer where+    showsType _ = showString "__Answer"+++data _CUnion  =		  _CUInt Int+			| _CUDouble Double +			| _CUString String +			| _CUPointer _CPointer+#ifdef P_IO_data+			| _CUByteVector _ByteVector._ByteVector+#endif+		deriving (Eq, Text)++ISO(_CPointer , _CPointer , Int) deriving (Eq, Text)+-}+data SigAct   =		  SAIgnore+			| SADefault+			| SACatch (String -> Dialogue)+		deriving (Show,Read)++data Response =		  Success+			| Str String +			| Bn  Bin+			| Failure IOError+			| Tag [(String, Char)]+			| BinTag [(String, Bin)]+	                | StrList [String]+			| Fil File+			| Dbl Double+	                | AsyncInput AsyncInput+			| SocketResponse SocketResponse+			| XResponse XResponse+			| IntResp Int+			| SelectResp [([File], [File], [Double])]+			| SigActResp SigAct+--			| CCallResp _CUnion+--			| GetTimeResp Double Bool String Int+#ifdef VERSION_old_time+			| ClockTime ClockTime -- response to GetTime --+			| CalendarTime CalendarTime -- response to GetLocalTime+#endif+#ifdef VERSION_time+                        | UTCTime UTCTime         -- response to GetCurrentTime+                        | ZonedTime ZonedTime     -- response to GetZonedTime+#endif+		deriving (Show,Read)++data IOError =		  WriteError   String+			| ReadError    String+			| SearchError  String+			| FormatError  String+			| OtherError   String+		deriving (Show,Read)+++type Bin = Unused+type Dialogue = [Response] -> [Request] -- not useful anymore+--type _CUnion = Unused+type File = Unused++type Unused = ()++#ifdef VERSION_old_time+instance Read ClockTime -- !!!+#endif
+ hsrc/ghc-dialogue/StructFuns.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE CPP #-}+{- Obsolete OPTIONS -fvia-C -}+module StructFuns(module StructFuns,module CSizes) where+import MyForeign+import Marshall+import Xlib+import CSizes+import Xtypes(XID(..),Atom(..),Time,WindowId(..),Window)+import Visual(VisualID(..))+import HbcWord(Word)+import Data.Word(Word32)++--import GlaExts hiding (Word,(<#),Addr)++{-+#include "structs.h"+#include "cimports.h"+-}+#include "ccalls.h"++H_STRUCTTYPE(timeVal)+H_STRUCTTYPE(sockAddr)++type Cchar = Char+type Clong = Int+type Cshort = Int
+ hsrc/ghc-dialogue/XCallTypes.hs view
@@ -0,0 +1,116 @@+{- unused options -#include <X11/Xlib.h> -#include <X11/Xutil.h> -fvia-C -}+-- -optc-I/usr/X11R6/include+module XCallTypes+ --(module XCallTypes,newCharArray,MutableByteArray(..))+ where++import Data.Bits+import Data.Word(Word32)+import Control.Applicative+import Control.Monad(foldM)+--import MyForeign(Int32)++import Utils(number)+import Xtypes+import Geometry+--import Ap(foldR)+--import PackedString(unpackPS,byteArrayToPS{-,packCString-})++-- #include "structs.h"++getEnum bla = fromEnum+toEnum' bla = toEnum+{-+toEnum' s = (a!)+  where a = listArray (0,length l - 1) l+        l = [s..]++getEnum s = (a!)+  where a = listArray (s,last [s..]) [(0::Int)..]+-}++class ToC a where toC :: a -> Int+class ToCl a where toCl :: [a] -> Int+class FromC a where fromC :: Int -> a++class ToXID a where toXID :: a -> XID+--class FromXID a where fromXID :: XID -> a++instance (ToCl a) => ToC [a] where toC = toCl++instance ToCl EventMask where +   toCl = fromIntegral . foldr getE (0::Word32)+     where+       getE e m = setBit m (fromEnum e)++instance ToC Bool where toC False = 0+                        toC True = 1++instance FromC Bool where fromC 0 = False+                          fromC _ = True+++instance ToXID PixmapId where toXID (PixmapId p) = p+instance ToC Pixel where toC (Pixel p) = fromIntegral p+instance ToXID ColormapId where toXID (ColormapId p) = p+instance ToXID CursorId where toXID (CursorId p) = p+instance ToXID FontId where toXID (FontId p) = p+--instance ToC WindowId where toC (WindowId p) = p+--instance ToC Display where toC (Display p) = p+--instance ToC Width where toC (Width p) = p+--instance ToC Atom where toC (Atom p) = p+--instance ToC PropertyMode where toC (PropertyMode p) = p++--pIoCmd x = primIOToIO x :: IO ()+--pIoCmd x = stToIO x :: IO ()+ioCmd x = x :: IO ()++getValues new getValue vl = do+  vs <- new+  let maskf mask val = do set; return (mask .|. m)+                  where (set,m) = getValue vs val+  mask <- foldM maskf 0 vl+  return (vs,mask)++failu :: String -> IO a+failu = ioError . userError++--unpackCharArray len a = fmap (take len . unpackPS . byteArrayToPS) $+--    stToIO $ unsafeFreezeByteArray a++--cstring :: Addr -> String -- This type looks a bit suspicious... /TH 990211+--cstring = unpackCString++getArray new mod l = do+       arr <- new size+       mapM_ (mod arr) (number 0 l)+       return (arr,size)+   where size = length l+++{-+H_ARRAY(int)+newInt = newintArray 1+readInt i = CINDEX(int) (i::Cint) (0::Int) :: IO Int+writeInt i v = SINDEX(int,i::Cint,0::Int,v::Int)+-}++mkPoint x y = Point <$> x <*> y+mkRect x y w h = Rect <$> mkPoint x y <*> mkPoint w h++--mkAtom a = fmap Atom a+--mkSelection s t p = Selection <$> mkAtom s <*> mkAtom t <*> mkAtom p+--mkSelection s t p = Selection <$> s <*> t <*> p++instance FromC ModState where + fromC ni = [toEnum i|i<-[15,14..0],testBit ni i]+{-+     concatMap toModifier [15,14..0]+   where+     toModifier i = [toEnum i|testBit ni i]+--   toe = toEnum' Shift -- . fromIntegral+--   n = fromIntegral ni :: Word32+-}++notImplemented x = take 79 ("Not implemented: "++show x)++"\n"+
+ hsrc/ghc-dialogue/Xlib.hs view
@@ -0,0 +1,344 @@+{-# LANGUAGE CPP #-}+{- Obsolete OPTIONS -optc-I/usr/X11R6/include -#include <X11/Xlib.h> -#include <X11/Xutil.h> -#include <X11/extensions/shape.h> -#include <X11/extensions/Xdbe.h> -fvia-C -}+module Xlib where+import Marshall+import MyForeign+import CSizes+import Xtypes+import Visual+import Font(FontDirection)+import CString16(CString16)++import DrawTypes++import Control.Monad(zipWithM_)+--import Ap+import Data.Word(Word,Word32)+--import CCall+default(Int)++#include "structs.h"++type Unsigned = Int -- hmm+type Unsigned32 = Int32 -- hmm+type Status = Int+type Screen = Int+type Bitmask = Word32+type XlibKeySym = XID -- KeySym in Xlib, defined as String in Fudgets+type ClipOrdering = Ordering'+type CPixelArray = CLong+type CStringArray = CString+type CXFontStructArray = CXFontStruct+type CDisplay = Addr+type CGCId = Addr+newtype Region = Region Addr++#define FI(f) foreign import ccall unsafe "f" prim/**/f+#define PXlib(f,p,h) FI(X/**/f) :: p ; x/**/f :: h ; x/**/f = call primX/**/f+#define Xlib(f,h) PXlib(f,h,h)++#define PReq0(f,pr,r) PXlib(f,CDisplay -> IO pr, Display -> IO r)+#define Req0(f,r) PReq0(f,r,r)+#define Req(f,t,r) PReq(f,t,r,t,r)+#define PReq(f,p,pr,t,r) PXlib(f,CDisplay -> p -> IO pr, Display-> t ->IO r)+#define WindowReq(f,t,r) Req(f,Window->t,r)+#define PWindowReq(f,pt,pr,t,r) PReq(f,Window->pt,pr,Window->t,r)+#define WindowReqP(f,t,pr,r) PReq(f,Window->t,pr,Window->t,r)+#define DrawReq(f,t,r) Req(f,DrawableId->t,r)+#define DrawReqP(f,t,pr,r) PReq(f,DrawableId->t,pr,DrawableId->t,r)++#define Cmd0(f) PXlib(f,CDisplay -> IO (), Display-> IO ())+#define Cmd(f,t) Req(f,t,())+#define PCmd(f,p,t) PXlib(f,CDisplay -> p -> IO (), Display-> t ->IO ())+#define WindowCmd0(f) Cmd(f,Window)+#define WindowCmd(f,t) Cmd(f,Window->t)+#define PWindowCmd(f,p,t) PCmd(f,Window->p,Window->t)+#define DrawCmd(f,t) PCmd(f,DrawableId->CGCId->t,DrawableId->GCId->t)+#define DrawPCmd(f,p,t) PCmd(f,DrawableId->CGCId->p,DrawableId->GCId->t)++--- Calls ---------------------------------------------------------------------+PXlib(OpenDisplay,  CString -> IO CDisplay, String -> IO Display)+Cmd0(CloseDisplay)+Req0(ConnectionNumber,Int32)+Cmd0(Flush)+Cmd(NextEvent,CXEvent)+WindowReq(CheckWindowEvent,Int->CXEvent,Bool)+Req0(Pending,Int)+Cmd(FreePixmap,PixmapId)+Cmd(Synchronize,Bool) -- result is ignored.+Cmd(Sync,Bool)+Cmd(Bell,Int)++FI(XInitThreads) :: IO Int+xInitThreads = fmap (/=0) primXInitThreads+Cmd0(LockDisplay)+Cmd0(UnlockDisplay)++FI(XFree) :: Addr -> IO ()+xFree p = primXFree (addrOf p)++Req0(DefaultScreen,Screen)+Req0(DefaultRootWindow,Window)+PReq0(ImageByteOrder,Int,ByteOrder)+Req(DefaultDepth,Screen,Int)+Req(BlackPixel,Int,Unsigned)+Req(WhitePixel,Int,Unsigned)+Req(DefaultColormap,Int,ColormapId)+Req(DefaultVisual,Screen,CVisual)++PReq(LoadFont,CString,FontId,String,FontId)+Req(QueryFont,FontId,CXFontStruct)+PReq(LoadQueryFont,CString,CXFontStruct,String,CXFontStruct)+PReq(ListFonts,CString->Int->CLong,CStringArray,String->Int->CLong,CStringArray)+Xlib(FreeFontNames,CStringArray->IO())+PReq(ListFontsWithInfo,CString->Int->CInt32->CCXFontStruct,CStringArray,String->Int->CInt32->CCXFontStruct,CStringArray)+Xlib(FreeFontInfo,CStringArray->CXFontStructArray->Int32->IO ())+Cmd(QueryTextExtents16,FontId->CString16->Int->CLong->CLong->CLong->CXCharStruct)++Req(CreateFontCursor,Int,CursorId)+Req(CreatePixmap,DrawableId->Unsigned->Unsigned->Unsigned,PixmapId)+PReq(InternAtom,CString->Bool,Atom,String->Bool,Atom)+Req(GetAtomName,Atom,CString)+Req(AllocColor,ColormapId->CXColor,Status)+PReq(AllocNamedColor,ColormapId->CString->CXColor->CXColor,Status,ColormapId->String->CXColor->CXColor,Status)+Cmd(QueryColor,ColormapId->CXColor)+Cmd(FreeColors,ColormapId->CPixelArray->Int->Pixel)+{- -- This creates a dangling reference to the image data!+PReq(CreateImage,CVisual->Int->Int->Int->CString->Int->Int->Int->Int,CXImage,+                 CVisual->Int->Int->Int->String->Int->Int->Int->Int,CXImage)+-}+Req(CreateImage,CVisual->Int->Int->Int->CString->Int->Int->Int->Int,CXImage)++DrawCmd(PutImage,CXImage->Int32->Int32->Int32->Int32->Int32->Int32)++-- Xlib(DestroyImage,CXImage->IO ()) -- XDestroyImage is a macro in X11/Xutil.h+foreign import ccall "asyncinput.h" xDestroyImage :: CXImage -> IO ()+++WindowCmd0(DestroyWindow)+WindowCmd0(MapRaised)+WindowCmd0(LowerWindow)+WindowCmd0(UnmapWindow)+WindowCmd0(ClearWindow)+WindowCmd(ClearArea,Int->Int->Int->Int->Bool)+WindowReq(CreateSimpleWindow,Int->Int->Unsigned->Unsigned->Unsigned->Unsigned->Unsigned,Window)+PWindowCmd(StoreName,CString,String)+WindowCmd(SetClassHint,CXClassHint)+WindowCmd(ConfigureWindow,Bitmask->CXWindowChanges)+WindowCmd(ChangeWindowAttributes,Bitmask->CXSetWindowAttributes)+WindowCmd(ReparentWindow,Window->Int->Int)+PWindowCmd(SetWMProtocols,CAtomArray->Int,[Atom]->Int)+WindowCmd(SetNormalHints,CXSizeHints)+WindowCmd(SetWMHints,CXWMHints)+WindowReq(SendEvent,Bool->Bitmask->CXEvent,Status)+PWindowCmd(ChangeProperty,Atom->Atom->Int->PropertyMode->CString->Int,Atom->Atom->Int->PropertyMode->String->Int)+WindowReq(GetWindowProperty,Atom->Int->Int->Bool->Atom->CAtom->CLong->CLong->CLong->CCString,Int)+WindowReq(QueryPointer,CLong->CLong->CLong->CLong->CLong->CLong->CLong,Bool)+WindowReq(TranslateCoordinates,Window->Int->Int->CInt32->CInt32->CLong,Bool)+PWindowCmd(ShapeCombineMask,Int->Int->Int->PixmapId->Int,ShapeKind->Int->Int->PixmapId->ShapeOperation)+PWindowCmd(ShapeCombineRectangles,Int->Int->Int->CXRectangleArray->Int->Int->Int,ShapeKind->Int->Int->CXRectangleArray->Int->ShapeOperation->ClipOrdering)+PWindowCmd(ShapeCombineShape,Int->Int->Int->PixmapId->Int->Int,ShapeKind->Int->Int->PixmapId->ShapeKind->ShapeOperation)++Cmd(GrabButton,Int->Int->Window->Bool->Unsigned->Int->Int->Window->CursorId)+Cmd(UngrabButton,Int->Int->Window)+WindowReqP(GrabPointer,Bool->Unsigned->Int->Int->Window->CursorId->Time,Int,GrabPointerResult)+Cmd(UngrabPointer,Time)+Cmd(SetSelectionOwner,Atom->Window->Time)+Cmd(ConvertSelection,Atom->Atom->Atom->Window->Time)++DrawCmd(DrawPoint,Int->Int)+DrawCmd(DrawLine,Int->Int->Int->Int)+DrawPCmd(DrawLines,CXPointArray->Int->Int,CXPointArray->Int->CoordMode)+DrawPCmd(DrawImageString,Int->Int->CString->Int,Int->Int->String->Int)+DrawPCmd(DrawString,Int->Int->CString->Int,Int->Int->String->Int)+DrawPCmd(DrawImageString16,Int->Int->CString16->Int,Int->Int->CString16->Int)+DrawPCmd(DrawString16,Int->Int->CString16->Int,Int->Int->CString16->Int)+DrawCmd(DrawRectangle,Int->Int->Int->Int)+DrawCmd(FillRectangle,Int->Int->Int->Int)+DrawCmd(DrawArc,Int32->Int32->Unsigned32->Unsigned32->Int32->Int32)+DrawCmd(FillArc,Int32->Int32->Unsigned32->Unsigned32->Int32->Int32)+DrawPCmd(FillPolygon,CXPointArray->Int->Int->Int,CXPointArray->Int->Shape->CoordMode)+PCmd(CopyArea,DrawableId->DrawableId->CGCId->Int32->Int32->Unsigned32->Unsigned32->Int32->Int32,DrawableId->DrawableId->GCId->Int32->Int32->Unsigned32->Unsigned32->Int32->Int32)+PCmd(CopyPlane,DrawableId->DrawableId->CGCId->Int32->Int32->Unsigned32->Unsigned32->Int32->Int32->Word,DrawableId->DrawableId->GCId->Int32->Int32->Unsigned32->Unsigned32->Int32->Int32->Word)++#define GCCmd(f,t) PCmd(f,CGCId->t,GCId->t)++DrawReqP(CreateGC,Bitmask->CXGCValues,CGCId,GCId)+PCmd(CopyGC,CGCId->Bitmask->CGCId,GCId->Bitmask->GCId)+GCCmd(ChangeGC,Bitmask->CXGCValues)+PCmd(FreeGC,CGCId,GCId)++GCCmd(SetForeground,Unsigned)+GCCmd(SetBackground,Unsigned)+GCCmd(SetPlaneMask,Bitmask)+PCmd(SetFunction,CGCId->Int,GCId->GCFunction)+PCmd(SetState,CGCId->Unsigned->Unsigned->Int->Unsigned,GCId->Unsigned->Unsigned->GCFunction->Unsigned)++PXlib(KeysymToString,XlibKeySym->IO CString,XlibKeySym->IO (Maybe String))++Req(ReadBitmapFile,DrawableId->CString->CInt32->CInt32->CXID->CInt32->CInt32,Int)+Req(CreateBitmapFromData,DrawableId->CString->Int32->Int32,PixmapId)++--- Regions -------------------------------------------------------------------+Xlib(CreateRegion,IO Region)+PCmd(SetRegion,CGCId->Region,GCId->Region)+Xlib(DestroyRegion,Region->IO ())+Xlib(UnionRectWithRegion,CXRectangle->Region->Region->IO ())+IDAR(Region)++--- Double buffer extension ---------------------------------------------------+Req(dbeQueryExtension,CLong->CLong,Int)+PWindowReq(dbeAllocateBackBufferName,Int,DbeBackBufferId,SwapAction,DbeBackBufferId)+Req(dbeSwapBuffers,CXdbeSwapInfoArray->Int,Status)++H_ARRAY(XdbeSwapInfo)+ENUMAR(SwapAction)+IDAR(DbeBackBufferId)+--- Types ---------------------------------------------------------------------++IORC(CDisplay,Display,fmap (Display . a2i))+instance PrimArg Display CDisplay c where marshall c (Display d) = c (i2a d)++IORC(CGCId,GCId,fmap (GCId . a2i))++instance PrimArg GCId CGCId c where marshall c (GCId d) = c (i2a d)+++-- Instances for resource identifiers and simple values+IDAR(Atom)+IDAR(ColormapId)+IDAR(CursorId)+IDAR(DrawableId)+IDAR(FontId)+IDAR(Pixel)+IDAR(PixmapId)+IDAR(PropertyMode)+IDAR(VisualID)+IDAR(Window)+IDAR0(Word32)+IDAR0(Word)+IDAR0(XID)+ENUMAR(ByteOrder)+ENUMAR(CoordMode)+ENUMAR(DisplayClass)+ENUMAR(FontDirection)+ENUMAR(GrabPointerResult)+ENUMAR(GCFunction)+ENUMAR(GCLineStyle)+ENUMAR(GCCapStyle)+ENUMAR(GCJoinStyle)+ENUMAR(GCSubwindowMode)+ENUMAR(GCFillStyle)+ENUMAR(ClipOrdering)+ENUMAR(Shape)+ENUMAR(ShapeKind)+ENUMAR(ShapeOperation)++IDAR0(CXID)+ISTORE(XID)++instance CVar CXID XID++--- Structured types ----------------------------------------------------------+H_STRUCTTYPE(XColor)+H_STRUCTTYPE(XClassHint)+H_STRUCTTYPE(XGCValues)+H_STRUCTTYPE(XSetWindowAttributes)+H_STRUCTTYPE(XSizeHints)+H_STRUCTTYPE(XWMHints)+H_STRUCTTYPE(XWindowChanges)++H_ARRAY(Atom)+ISTORE(Atom)+instance CVar CAtom Atom+instance PrimArg [Atom] CAtom (Int->IO a) where+  marshall pf as n =+    do aa <- newArray n+       zipWithM_ (pokeElemOff (addrOf aa)) [0..(n-1)] [a|Atom a<-as]+       r<-pf aa n+       freePtr aa+       return r++H_STRUCTTYPE(XEvent)+type CXAnyEvent = CXEvent+type CXKeyEvent = CXEvent+type CXButtonEvent = CXEvent+type CXMotionEvent = CXEvent+type CXCrossingEvent = CXEvent+type CXFocusChangeEvent = CXEvent+type CXExposeEvent = CXEvent+type CXGraphicsExposeEvent = CXEvent+type CXNoExposeEvent = CXEvent+type CXVisibilityEvent = CXEvent+type CXCreateWindowEvent = CXEvent+type CXDestroyWindowEvent = CXEvent+type CXUnmapEvent = CXEvent+type CXMapEvent = CXEvent+type CXMapRequestEvent = CXEvent+type CXReparentEvent = CXEvent+type CXConfigureEvent = CXEvent+type CXGravityEvent = CXEvent+type CXResizeRequestEvent = CXEvent+type CXConfigureRequestEvent = CXEvent+type CXCirculateEvent = CXEvent+type CXClientMessageEvent = CXEvent+type CXSelectionClearEvent = CXEvent+type CXSelectionRequestEvent = CXEvent+type CXSelectionEvent = CXEvent++H_ARRAY(XPoint)+H_ARRAY(XRectangle)+C_STRUCTTYPE(XFontStruct);IDAR0(CXFontStruct)++--C_STRUCTTYPE(XCharStruct);IDAR0(CXCharStruct)+NEWTYPE(HT(XCharStruct));IPTR(XCharStruct);ISTORE(HT(XCharStruct));+INSTCCALL(HT(XCharStruct));IDAR0(CXCharStruct)++C_STRUCTTYPE(Visual);IDAR0(CVisual)+C_STRUCTTYPE(XImage);IDAR0(CXImage)+INSTCCALL(CString)++NEWTYPE(HT(XFontProp));IPTR(XFontProp);ISTORE(HT(XFontProp));+INSTCCALL(HT(XFontProp));IDAR0(CXFontProp)++C_STRUCTTYPE(CXFontStruct);IDAR0(CCXFontStruct)+newCXFontStruct = CCXFontStruct <$> mallocElem nullAddr+instance CVar CCXFontStruct CXFontStruct++C_STRUCTTYPE(CString);IDAR0(CCString)+newCString = CCString <$> mallocElem nullAddr+instance CVar CCString CString+--- Constants -----------------------------------------------------------------+anyModifier = 2^(15 :: Int)+grabModeAsync = 1 :: Int+--- Auxiliary functions/types -------------------------------------------------+call f = unmarshall f+uio f = fmap f++a2i :: Addr -> Int+a2i a = minusAddr a nullAddr++{-# NOINLINE i2a #-} -- Workaround a GHC bug on 64-bit systems /TH 2016-12-29+i2a :: Int -> Addr+i2a = plusAddr nullAddr++newtype DrawableId = DrawableId XID deriving Show+getdrawable _ (Pixmap (PixmapId i)) = DrawableId i+getdrawable (WindowId w) MyWindow = DrawableId w+getdrawable _ (DbeBackBuffer (DbeBackBufferId b)) = DrawableId b++dcmap display cmap =+    if cmap == defaultColormap+    then xDefaultScreen display >>= xDefaultColormap display+    else return cmap++data ByteOrder = LSBFirst | MSBFirst deriving (Eq,Enum)++--withLockedDisplay display cmd = cmd+{-+withLockedDisplay display cmd =+  do xLockDisplay display+     result <- cmd+     xUnlockDisplay display+     return result+-}
+ hsrc/ghc-dialogue/asyncinput.h view
@@ -0,0 +1,41 @@+/*#ifndef ASYNCINPUT_H*/+/* This file seems to be incldued twice for some strange reason... */+#define ASYNCINPUT_H++#undef _POSIX_SOURCE++#include <sys/types.h>+#include <sys/time.h>+#include <unistd.h>++#include <sys/socket.h>+#define XLIB_ILLEGAL_ACCESS+#include <X11/Xlib.h>+#include <X11/Xutil.h>++typedef struct timeval timeVal;++typedef struct sockaddr sockAddr;++/* Things from socketlib, doesn't really belong here: */+int in_connect(char *host,short port,int type);+int in_bind(short port,	int type) ;+void fdzero(fd_set *s);+void fdset(int fd,fd_set *s);+int fdisset(int fd,fd_set *s);+void bcopy_fdset(fd_set *,fd_set *);+int get_errno(void);+long get_stdin(void);+int get_fileno(long); /* The true argument type is FILE * */++void xDestoryImage(XImage *ximage);+int default_bpp(Display *,int depth);+void setXImage_data(XImage *ximage,char *data);++void disable_timers(void);++/* Quick hack to work around typing problem: */+/* #define GETSOCKNAME(s,a,len) getsockname(s,(struct sockaddr *)a,len) */+/* #define ACCEPT(s,a,len) accept(s,(struct sockaddr *)a,len) */++/*#endif*/
+ hsrc/ghc-dialogue/ccalls.h view
@@ -0,0 +1,208 @@+AGET(XClientMessageEvent,Addr,ev,data)+AGET(XFontStruct,HT(XCharStruct),fs,max_bounds)+AGET(XFontStruct,HT(XCharStruct),fs,min_bounds)+CCONST(AF_INET)+CCONST(AnyButton)+CCONST(BitmapSuccess)+CCONST(EAGAIN)+CCONST(EINTR)+CCONST(InputHint)+CCONST(LSBFirst)+CCONST(None)+CCONST(SOCK_STREAM)+CCONST(SelectionNotify)+CCONST(USPosition)+CINDEX(char)+CINDEX(long)+CINDEX(short)+CWORD32(CWBackPixel)+CWORD32(CWBackPixmap)+CWORD32(CWBackingStore)+CWORD32(CWBitGravity)+CWORD32(CWBorderPixel)+CWORD32(CWBorderPixmap)+CWORD32(CWBorderWidth)+CWORD32(CWCursor)+CWORD32(CWDontPropagate)+CWORD32(CWEventMask)+CWORD32(CWHeight)+CWORD32(CWOverrideRedirect)+CWORD32(CWSaveUnder)+CWORD32(CWStackMode)+CWORD32(CWWidth)+CWORD32(CWWinGravity)+CWORD32(CWX)+CWORD32(CWY)+CWORD32(GCBackground)+CWORD32(GCCapStyle)+CWORD32(GCJoinStyle)+CWORD32(GCFillStyle)+CWORD32(GCFont)+CWORD32(GCForeground)+CWORD32(GCFunction)+CWORD32(GCGraphicsExposures)+CWORD32(GCLineStyle)+CWORD32(GCLineWidth)+CWORD32(GCStipple)+CWORD32(GCSubwindowMode)+CWORD32(GCTile)+GET(Visual,Int,cv,bits_per_rgb)+GET(Visual,Int,cv,blue_mask)+GET(Visual,Int,cv,class)+GET(Visual,Int,cv,green_mask)+GET(Visual,Int,cv,map_entries)+GET(Visual,Int,cv,red_mask)+GET(Visual,VisualID,cv,visualid)+GET(XAnyEvent,Int,ev,type)+GET(XAnyEvent,WindowId,ev,window)+GET(XButtonEvent,Int,ev,button)+GET(XButtonEvent,Int,ev,state)+GET(XButtonEvent,Int,ev,x)+GET(XButtonEvent,Int,ev,x_root)+GET(XButtonEvent,Int,ev,y)+GET(XButtonEvent,Int,ev,y_root)+GET(XButtonEvent,Time,ev,time)+GET(XCharStruct,Int,cs,ascent)+GET(XCharStruct,Int,cs,descent)+GET(XCharStruct,Int,cs,lbearing)+GET(XCharStruct,Int,cs,rbearing)+GET(XCharStruct,Int,cs,width)+GET(XFontProp,Atom,fp,name)+GET(XFontProp,Int,fp,card32)+GET(XClientMessageEvent,Atom,ev,message_type)+GET(XClientMessageEvent,Int,ev,format)+GET(XColor,Int,xcol,blue)+GET(XColor,Int,xcol,green)+GET(XColor,Int,xcol,red)+GET(XColor,Word,xcol,pixel)+GET(XConfigureEvent,Int,ev,border_width)+GET(XConfigureEvent,Int,ev,height)+GET(XConfigureEvent,Int,ev,width)+GET(XConfigureEvent,Int,ev,x)+GET(XConfigureEvent,Int,ev,y)+GET(XCrossingEvent,Int,ev,detail)+GET(XCrossingEvent,Int,ev,focus)+GET(XCrossingEvent,Int,ev,mode)+GET(XCrossingEvent,Int,ev,x)+GET(XCrossingEvent,Int,ev,x_root)+GET(XCrossingEvent,Int,ev,y)+GET(XCrossingEvent,Int,ev,y_root)+GET(XCrossingEvent,Time,ev,time)+GET(XExposeEvent,Int,ev,count)+GET(XExposeEvent,Int,ev,height)+GET(XExposeEvent,Int,ev,width)+GET(XExposeEvent,Int,ev,x)+GET(XExposeEvent,Int,ev,y)+GET(XFocusChangeEvent,Int,ev,detail)+GET(XFocusChangeEvent,Int,ev,mode)+GET(XFontStruct,Char,fs,default_char)+GET(XFontStruct,HT(XCharStruct),fs,per_char)+GET(XFontStruct,HT(XFontProp),fs,properties)+GET(XFontStruct,Int,fs,all_chars_exist)+GET(XFontStruct,Int,fs,ascent)+GET(XFontStruct,Int,fs,descent)+GET(XFontStruct,Int,fs,direction)+GET(XFontStruct,XID,fs,fid)+GET(XFontStruct,Int,fs,max_byte1)+GET(XFontStruct,Int,fs,max_char_or_byte2)+GET(XFontStruct,Int,fs,min_byte1)+GET(XFontStruct,Int,fs,min_char_or_byte2)+GET(XFontStruct,Int,fs,n_properties)+GET(XGraphicsExposeEvent,Int,ev,count)+GET(XGraphicsExposeEvent,Int,ev,height)+GET(XGraphicsExposeEvent,Int,ev,major_code)+GET(XGraphicsExposeEvent,Int,ev,minor_code)+GET(XGraphicsExposeEvent,Int,ev,width)+GET(XGraphicsExposeEvent,Int,ev,x)+GET(XGraphicsExposeEvent,Int,ev,y)+GET(XKeyEvent,Int,ev,keycode)+GET(XKeyEvent,Int,ev,state)+GET(XKeyEvent,Int,ev,x)+GET(XKeyEvent,Int,ev,x_root)+GET(XKeyEvent,Int,ev,y)+GET(XKeyEvent,Int,ev,y_root)+GET(XKeyEvent,Time,ev,time)+GET(XMapEvent,WindowId,ev,window)+GET(XMotionEvent,Int,ev,state)+GET(XMotionEvent,Int,ev,x)+GET(XMotionEvent,Int,ev,x_root)+GET(XMotionEvent,Int,ev,y)+GET(XMotionEvent,Int,ev,y_root)+GET(XMotionEvent,Time,ev,time)+GET(XResizeRequestEvent,Int,ev,height)+GET(XResizeRequestEvent,Int,ev,width)+GET(XSelectionClearEvent,Atom,ev,selection)+GET(XSelectionEvent,Atom,ev,property)+GET(XSelectionEvent,Atom,ev,selection)+GET(XSelectionEvent,Atom,ev,target)+GET(XSelectionEvent,Time,ev,time)+GET(XSelectionRequestEvent,Atom,ev,property)+GET(XSelectionRequestEvent,Atom,ev,selection)+GET(XSelectionRequestEvent,Atom,ev,target)+GET(XSelectionRequestEvent,Time,ev,time)+GET(XSelectionRequestEvent,WindowId,ev,requestor)+GET(XVisibilityEvent,Int,ev,state)+GET(timeVal,Int,now,tv_sec)+GET(timeVal,Int,now,tv_usec)+GETC(sockAddr,char *,CString,sa,sa_data)+INDEX(XCharStruct)+INDEX(XFontProp)+SET(XAnyEvent,Window,xe,window,w::Window)+SET(XClassHint,CString,class_hints,res_class,rc)+SET(XClassHint,CString,class_hints,res_name,rn)+SET(XColor,Int,color,blue,blue)+SET(XColor,Int,color,green,green)+SET(XColor,Int,color,red,red)+SET(XColor,Word,c,pixel,px)+SET(XGCValues,Int,gcv,background,toC p)+SET(XGCValues,Int,gcv,cap_style,fromEnum s)+SET(XGCValues,Int,gcv,join_style,fromEnum s)+SET(XGCValues,Int,gcv,fill_style,fromEnum f)+SET(XGCValues,XID,gcv,font,toXID f)+SET(XGCValues,Int,gcv,foreground,toC p)+SET(XGCValues,Int,gcv,function,fromEnum f)+SET(XGCValues,Int,gcv,graphics_exposures, fromEnum g)+SET(XGCValues,Int,gcv,line_style,fromEnum s)+SET(XGCValues,Int,gcv,line_width,w)+SET(XGCValues,XID,gcv,stipple,toXID p)+SET(XGCValues,Int,gcv,subwindow_mode,fromEnum m)+SET(XGCValues,XID,gcv,tile,toXID p)+SET(XSelectionEvent,Atom,xe,property, props)+SET(XSelectionEvent,Atom,xe,selection, sel)+SET(XSelectionEvent,Atom,xe,target, target)+SET(XSelectionEvent,Int,xe,type,CCONST(SelectionNotify)::Int)+SET(XSelectionEvent,Time,xe,time,time)+SET(XSizeHints,Int,h,flags,CCONST(USPosition)::Int)+SET(XSizeHints,Int,h,x,x)+SET(XSizeHints,Int,h,y,y)+SET(XWMHints,Int,h,flags,CCONST(InputHint)::Int)+SET(XWMHints,Int,h,input,toC i)+SET(XWindowChanges,Int,s,border_width,w)+SET(XWindowChanges,Int,s,height,h)+SET(XWindowChanges,Int,s,stack_mode,toC sm)+SET(XWindowChanges,Int,s,width,w)+SET(XWindowChanges,Int,s,x,x)+SET(XWindowChanges,Int,s,y,y)+SET(timeVal,Int,timeout,tv_sec,(tleft `div` 1000))+SET(timeVal,Int,timeout,tv_usec,(tleft `mod` 1000) * 1000)+SETI(XPoint,Int,xpoints,i,x,x)+SETI(XPoint,Int,xpoints,i,y,y)+SETI(XRectangle,Int,rsa,i,height,h)+SETI(XRectangle,Int,rsa,i,width,w)+SETI(XRectangle,Int,rsa,i,x,x)+SETI(XRectangle,Int,rsa,i,y,y)+SETI(XdbeSwapInfo,Int,si,i,swap_action,fromEnum sa)+SETI(XdbeSwapInfo,WindowId,si,i,swap_window,wi)+SETWa(swa,background_pixel,toC p)+SETWaXID(swa,background_pixmap,toXID p)+SETWa(swa,backing_store,toC bs)+SETWa(swa,bit_gravity,toC g)+SETWa(swa,border_pixel,toC p)+SETWaXID(swa,border_pixmap,toC p)+SETWaXID(swa,cursor,toXID c)+SETWa(swa,do_not_propagate_mask,toC em)+SETWa(swa,event_mask,toC em)+SETWa(swa,override_redirect,toC b)+SETWa(swa,save_under,toC b)+SETWa(swa,win_gravity,toC g)+SINDEX(char,imgdata,i::Int,p::Int)
+ hsrc/ghc-dialogue/cfundefs.h view
@@ -0,0 +1,50 @@++#define SETI(ctype,fhtype,p1,i1,field,v1) \+  void seti_##ctype##_##field(ctype p[],int i,typeof(p[i].field) v) \+    BODY({ p[i].field=v; })++#define SINDEX(ctype,p1,i1,v1) \+  void sindex_##ctype(ctype p[],int i,typeof(p[i]) v) \+    BODY({ p[i]=v; })++/*(_casm_ ``((ctype *)%0)[%1]=%2;'' (p) (i) (v) :: IO ())*/++#define SET(ctype,fhtype,p1,field,v1) \+  void set_##ctype##_##field(ctype *p,typeof(p->field) v) \+    BODY({ p->field=v; })++#define SETWa(swa,field,v) SET(XSetWindowAttributes,Int,swa,field,v)+#define SETWaXID(swa,field,v) SET(XSetWindowAttributes,XID,swa,field,v)++/* (_casm_ ``((ctype *)%0)->field=%1;'' (addrOf (p)) (v) :: IO ())*/++#define GET(ctype,rhtype,p1,field) \+  typeof(((ctype *)0)->field) get_##ctype##_##field(ctype *p) \+    BODY({ return p->field; })++#define GETC(ctype,crtype,rhtype,p1,field) \+  crtype get_##ctype##_##field(ctype *p) \+    BODY({ return p->field; })++/* (_casm_ `` %r = ((ctype *)%0)->field; '' (addrOf (p))) */++#define AGET(ctype,rhtype,p1,field) \+  typeof(&(((ctype *)0)->field)) aget_##ctype##_##field(ctype *p) \+    BODY({ return &(((ctype *)p)->field); })++/* (_casm_ `` %r = &(((ctype *)%0)->field); '' ((p)::HT(ctype))) */++#define INDEX(ctype) \+  ctype *index_##ctype(ctype *p,int i) \+    BODY({ return p+i; })++/* (\pP iI -> _casm_ ``%r = (ctype *)%0 + (int)%1;'' ((pP) :: HT(ctype)) iI) */++#define CINDEX(t) \+  t cindex_##t(t p[],int i) \+    BODY({ return p[i]; })++/* (\pP iI -> _casm_ ``%r = ((t *)%0)[(int)%1];'' pP iI) */++#define CCONST(c)  int const_##c(void) BODY({ return (c);})+#define CWORD32(c) int const_##c(void) BODY({ return (c);})
+ hsrc/ghc-dialogue/cfuns.c view
@@ -0,0 +1,4 @@+#include <errno.h>++#define BODY(b) b+#include "cfuns.h"
+ hsrc/ghc-dialogue/cfuns.h view
@@ -0,0 +1,11 @@+#include "asyncinput.h"+#include <X11/extensions/Xdbe.h>++#ifndef BODY+#define BODY(b) ;+#endif+#include "cfundefs.h"+#include "ccalls.h"++#define CSIZE(ctype) int fudsizeof_##ctype(void) BODY({ return sizeof(ctype); })+#include "csizes.h"
+ hsrc/ghc-dialogue/cimports.h view
@@ -0,0 +1,41 @@+#define FI foreign import ccall unsafe "cfuns.h"++#define SETI(ctype,fhtype,p1,i1,field,v1) \+  FI seti_/**/ctype/**/_/**/field :: HTA(ctype) -> Int -> (fhtype) -> IO ()++/*  (_casm_ ``((ctype *)%0)[%1].field=%2;'' ((p)::HT(ctype)) (i) (v) :: IO ()) */+#define SINDEX(ctype,p1,i1,v1) \+  FI sindex_/**/ctype :: Addr -> Int -> HT(ctype)  -> IO ()++/*(_casm_ ``((ctype *)%0)[%1]=%2;'' (p) (i) (v) :: IO ())*/++#define SET(ctype,fhtype,p1,field,v1) \+  FI set_/**/ctype/**/_/**/field :: HT(ctype) -> fhtype -> IO ()++/* (_casm_ ``((ctype *)%0)->field=%1;'' (addrOf (p)) (v) :: IO ())*/++#define SETWa(swa,field,v) SET(XSetWindowAttributes,Int,swa,field,v)+#define SETWaXID(swa,field,v) SET(XSetWindowAttributes,XID,swa,field,v)+++#define GET(ctype,rhtype,p1,field) \+  FI get_/**/ctype/**/_/**/field :: HT(ctype) -> IO rhtype++#define GETC(ctype,rctype,rhtype,p1,field) GET(ctype,rhtype,p1,field)++/* (_casm_ `` %r = ((ctype *)%0)->field; '' (addrOf (p))) */++#define AGET(ctype,rhtype,p1,field) FI aget_/**/ctype/**/_/**/field :: HT(ctype) -> IO (rhtype)++/* (_casm_ `` %r = &(((ctype *)%0)->field); '' ((p)::HT(ctype))) */++#define INDEX(ctype)  FI index_/**/ctype :: HT(ctype) -> Int -> IO HT(ctype)++/* (\pP iI -> _casm_ ``%r = (ctype *)%0 + (int)%1;'' ((pP) :: HT(ctype)) iI) */++#define CINDEX(t) FI cindex_/**/t :: Addr -> Int -> IO (HT(t))++/* (\pP iI -> _casm_ ``%r = ((t *)%0)[(int)%1];'' pP iI) */++#define CCONST(c) FI const_/**/c :: Int+#define CWORD32(c) FI const_/**/c :: Word32
+ hsrc/ghc-dialogue/csizes.h view
@@ -0,0 +1,19 @@++CSIZE(Atom)+CSIZE(XEvent)+CSIZE(XPoint)+CSIZE(XColor)+CSIZE(XGCValues)+CSIZE(XWMHints)+CSIZE(XdbeSwapInfo)+CSIZE(XClassHint)+CSIZE(XSetWindowAttributes)+CSIZE(XSizeHints)+CSIZE(XWindowChanges)+CSIZE(XRectangle)+CSIZE(XCharStruct)+CSIZE(XFontStruct)+CSIZE(XFontProp)+CSIZE(timeVal)+CSIZE(sockAddr)+CSIZE(fd_set)
+ hsrc/ghc-dialogue/newstructfuns.h view
@@ -0,0 +1,17 @@+#include "structs.h"++#define SETI(ctype,fhtype,p,i,field,v) (seti_/**/ctype/**/_/**/field (p) (i) (v))+#define SINDEX(ctype,p,i,v) (sindex_/**/ctype (p) (i) (v))+#define SET(ctype,fhtype,p,field,v) (set_/**/ctype/**/_/**/field (p) (v))+#define GET(ctype,rhtype,p,field) (get_/**/ctype/**/_/**/field (p))+#define GETC(ctype,rctype,rhtype,p,field) GET(ctype,rhtype,p,field)+#define INDEX(ctype) index_/**/ctype+#define CINDEX(t) cindex_/**/t++#define SETWa(swa,field,v) SET(XSetWindowAttributes,Int,swa,field,v)+#define SETWaXID(swa,field,v) SET(XSetWindowAttributes,XID,swa,field,v)++#define AGET(ctype,rhtype,p,field) (aget_/**/ctype/**/_/**/field (p))++#define CCONST(c) const_/**/c+#define CWORD32(c) CCONST(c)
+ hsrc/ghc-dialogue/structs.h view
@@ -0,0 +1,57 @@+--- New stuff for GHC 4.08.1, 2000-11-25 /TH++#define IORC(p,t,c) instance PrimResult (IO (p)) (IO (t)) where{unmarshall=(c)}+#define CA(t,p,c) instance PrimArg (t) (p) r where {marshall f = f .(c)}++#define IDR(t) instance PrimResult (IO (t)) (IO (t)) where {unmarshall=id}+#define IDA(t) CA(t,t,id)+#define IDAR(t) IDR(t);IDA(t);INSTCCALL(t)+#define IDAR0(t) IDR(t);IDA(t)++#define ENUMR(t) IORC(Int,t,fmap toEnum)+#define ENUMA(t) CA(t,Int,fromEnum)+#define ENUMAR(t) ENUMR(t);ENUMA(t)++--- Old stuff, modified to fit with the new stuff, 2000-11-25 /TH++#define HT(ctype) C/**/ctype+#define HTA(ctype) HT(ctype)Array++#define NEWTYPE(t) newtype t = t Addr deriving (Eq,Show)+#define HASADDR(t) instance HasAddr t where {addrOf (t addr) = addr}+#if 0+#define INSTCCALL(t) instance CCallable t;instance CReturnable t+#else+#define INSTCCALL(t)+#endif++#define ISTORE(t) \+  instance Storable t where { \+    sizeOf (t a) = sizeOf a; \+    alignment (t a) = alignment a; \+    peek p = t <$> peek p; \+    poke p (t a) = poke p a }++#define SIZEOF(ctype) (fudsizeof_/**/ctype)++#define IPTR(ctype) \+  new/**/ctype/**/Array n = HT(ctype) `fmap` malloc (n*SIZEOF(ctype)); \+  new/**/ctype = new/**/ctype/**/Array 1; \+  HASADDR(HT(ctype)); \+  instance IsPtr HT(ctype) where { \+    nullPtr = HT(ctype) nullAddr;\+    newPtr = new/**/ctype ;\+    newArray = new/**/ctype/**/Array}++-- freePtr (HT(ctype) addr) = free addr++#define H_STRUCTTYPE(ctype) \+  NEWTYPE(HT(ctype));IPTR(ctype);IDAR(HT(ctype))++#define H_ARRAY(ctype) H_STRUCTTYPE(ctype); ISTORE(HT(ctype)) ; type HTA(ctype) = HT(ctype)++#define C_STRUCTTYPE(ctype) \+  NEWTYPE(HT(ctype)); \+  HASADDR(HT(ctype)); \+  ISTORE(HT(ctype)); \+  INSTCCALL(HT(ctype))
+ hsrc/ghc/DFudIO.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE CPP #-}+module DFudIO(Fudlogue,fudlogue,fudlogue'{-,fudIO,fudIO'-},HasCache(..)) where++import FDefaults+import FudIO(fudIO1)+--import FudIO2(fudIO2)+import Fudget+--import Xtypes+--import Cache(allcacheF)+import NewCache(allcacheF)+import CmdLineEnv(argFlag)++#include "defaults.h"++data Fudlogue = Pars [Pars]+data Pars = Cache Bool++parameter_class(Cache,Bool)+parameter_instance(Cache,Fudlogue)++fudlogue = fudlogue' standard+fudlogue' :: Customiser Fudlogue -> F a b -> IO ()+fudlogue' pmod f = fudIO1 (cache pmod f)+{-+fudIO = fudIO' standard+--fudIO' :: Customiser Fudlogue -> F a b -> IO ()+fudIO' pmod inCh outCh f = fudIO2 inCh outCh (cache pmod f)+-}++cache pmod = if getCache ps then allcacheF else id+  where ps = pmod (Pars [Cache usecache])++usecache = argFlag "cache" True
+ hsrc/ghc/DialogueSpIO.hs view
@@ -0,0 +1,55 @@+module DialogueSpIO where+import System.IO(hFlush,stdout)+import SP+import DoRequest(initXCall,doRequest,getAsyncInput)+import DialogueIO(Request(XCommand,GetAsyncInput))+import Queue+import CmdLineEnv(argFlag)++--dialogueSpIO :: SP FResponse FRequest -> IO ()+{-+--Old, simple implementation:+dialogueSpIO sp =+    case sp of+      PutSP req sp' ->+        do resp <- doRequest req+	   dialogueSpIO (startupSP [resp] sp')+      GetSP xsp ->+        do resp <- doRequest GetAsyncInput+	   dialogueSpIO (xsp resp)+      NullSP -> return ()+-}++dialogueSpIO = if argFlag "dialogue-to-stdio" False+               then stdioDialogueSpIO+               else normalDialogueSpIO++normalDialogueSpIO = dialogueSpIO' initXCall doRequest getAsyncInput++stdioDialogueSpIO = dialogueSpIO' initXCall doRequest getAsyncInput+  where+    initXCall = return ()+    doRequest _ req = do print req+                         hFlush stdout+                         readLn+    getAsyncInput state = doRequest state GetAsyncInput++-- More efficient queueing of responses+dialogueSpIO' initXCall doRequest getAsyncInput sp = do+  iostate <- initXCall+  let doIO sp respq =+	case sp of+	  PutSP req sp' ->+	    do resp <- doRequest iostate req+	       case req of+		 -- The response to an XCommand is always Success+		 -- and is not propagated to the originating fudget.+	         XCommand {} -> doIO sp' respq+		 _ -> doIO sp' (enter respq resp)+	  GetSP xsp ->+	    case qremove respq of+	      Just (resp,respq') -> doIO (xsp resp) respq'+	      Nothing -> do resp <- getAsyncInput iostate+			    doIO (xsp resp) respq+	  NullSP -> return ()+  doIO sp empty
+ hsrc/ghc/FudIO.hs view
@@ -0,0 +1,16 @@+module FudIO(fudIO1) where+import CmdLineEnv(argFlag)+--import Fudget+import SpIO+import TagEvents+import FudVersion++--fudIO1 :: F a b -> IO ()+fudIO1 mainF =+    if argFlag "version" False+    then showVersion+    else spIO mainSP+  where+    mainSP = tagEventsSP mainF++    showVersion = putStrLn ("Fudget library " ++ version)
+ hsrc/ghc/GetModificationTime.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE CPP #-}+module GetModificationTime where+import HaskellIO+import DialogueIO++#ifdef VERSION_old_time+getModificationTime path err cont =+    hIOerr (GetModificationTime path) err $ \ (ClockTime t) ->+    cont t+#else+getModificationTime path err cont =+    hIOerr (GetModificationTime path) err $ \ (UTCTime t) ->+    cont t+#endif
+ hsrc/ghc/GetTime.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE CPP #-}+module GetTime where+import HaskellIO(hIO)+import DialogueIO++#ifdef VERSION_old_time+getTime      cont = hIO GetTime      $ \ (ClockTime t)    -> cont t+getLocalTime cont = hIO GetLocalTime $ \ (CalendarTime t) -> cont t+#endif++#ifdef VERSION_time+getCurrentTime cont = hIO GetCurrentTime $ \ (UTCTime t)   -> cont t+getZonedTime   cont = hIO GetZonedTime   $ \ (ZonedTime t) -> cont t+#endif
+ hsrc/ghc/HbcWord.hs view
@@ -0,0 +1,15 @@+module HbcWord(module HbcWord,Word) where+import Data.Word+import Data.Bits++--type Word=Word.Word32+--type Short=Word16++bitAnd x y = x .&. y+bitOr x y = x .|. y+bitXor x y = xor x y+bitRsh x y = shiftR x y+bitLsh x y = shiftL x y++intToWord = fromIntegral :: Int->Word+wordToInt = fromIntegral :: Word->Int
+ hsrc/ghc/List2.hs view
@@ -0,0 +1,3 @@+module List2(sort) where+-- List(sort) seem to be missing in ghc 2.01+import Data.List(sort)
+ hsrc/ghc/LowLevel.hs view
@@ -0,0 +1,12 @@+module LowLevel (-- * Low level+  module Cont,module Display,module SpIO,module TagEvents,module WindowF,module Xrequest,module Xcommand,module Srequest,module DFudIO, module FudgetIO) where+import Cont+import Display+import SpIO+import TagEvents+import WindowF+import Xrequest+import Xcommand+import Srequest+import DFudIO+import FudgetIO
+ hsrc/ghc/PackedString.hs view
@@ -0,0 +1,22 @@+-- | Fake PackedString type+module PackedString{-(module PS)-} where+--import Data.PackedString as PS++newtype PackedString = PS String deriving (Eq,Ord)++instance Show PackedString where+  showsPrec n (PS s) r = s++r++instance Read PackedString where+  readsPrec n s0 = [(PS s,r)|(s,r)<-readsPrec n s0]++packString = PS+unpackPS (PS s) = s++nullPS (PS s) = null s+lengthPS (PS s) = length s++appendPS (PS s1) (PS s2) = PS (s1++s2)+mapPS f (PS s) = PS (map f s)+nilPS = PS ""+reversePS (PS s) = PS (reverse s)
+ hsrc/ghc/ShowFun.hs view
@@ -0,0 +1,9 @@+module ShowFun where+import Text.Show.Functions()++{-+In Haskell 98, the function type is no longer an instance of the Show class.+This means that you can't derive Show for data types containing functions...+-}++instance Read (a->b)
+ hsrc/ghc/SpIO.hs view
@@ -0,0 +1,50 @@+module SpIO(spIO) where+--import Command+--import Event+import Loopthrough+import Path(Path(..))+import Cont(getRightSP)+import ShowFailure+--import Sockets+import Spops+import SP(SP)+import Tables2+--import Xtypes+import DialogueSpIO+import DialogueIO hiding (IOError)+--import Table(Table) -- nhc bug workaround++spIO :: (SP (Path, Response) (Path, Request)) -> IO ()+spIO mainSP = dialogueSpIO (loopThroughRightSP tagRequestsSP mainSP)++tagRequestsSP = tagRequests dtable0+tagRequests dtable =+  getSP $ \msg ->+  case msg of+    Left (path', cmd) ->+      case cmd of+	Select ds -> let dtable' = updateDe path' ds dtable+		     in doReqSP (Select (listDe dtable')) $ \ resp ->+			checkErr resp (tagRequests dtable')+	XCommand _ -> putReqSP cmd $  -- \ resp ->+		      -- The response to an XCommand is always Success+		      -- and is not propagated to the originating fudget.+		      tagRequests dtable+	_ -> doReqSP cmd $ \ resp ->+	     putSP (Left (path', resp)) $+	     tagRequests dtable+    Right ai@(AsyncInput (d, i)) ->+      putSP (Left (lookupDe dtable d, ai)) $+      tagRequests dtable+    _ -> error ("tagRequests: " ++ show msg ++ "\n")++checkErr resp cont =+    case resp of+      Success -> cont+      Failure ioerr -> error ("IOerror: " ++ showFailure ioerr)++doReqSP req = putReqSP req . getRespSP+  where+    getRespSP = getRightSP++putReqSP = putSP . Right
+ hsrc/ghc/UnsafePerformIO.hs view
@@ -0,0 +1,3 @@+module UnsafePerformIO(unsafePerformIO) where+import System.IO.Unsafe(unsafePerformIO)+
+ hsrc/hbc_library/FudUTF8.hs view
@@ -0,0 +1,34 @@+-- | From the Char module supplied with HBC.+module FudUTF8 where+++decodeUTF8 :: String -> String+decodeUTF8 "" = ""+decodeUTF8 (c:cs) | c < '\x80' = c : decodeUTF8 cs+decodeUTF8 (c:c':cs) | '\xc0' <= c  && c  <= '\xdf' && +		      '\x80' <= c' && c' <= '\xbf' =+	toEnum ((fromEnum c `mod` 0x20) * 0x40 + fromEnum c' `mod` 0x40) : decodeUTF8 cs+decodeUTF8 (c:c':c'':cs) | '\xe0' <= c   && c   <= '\xef' && +		          '\x80' <= c'  && c'  <= '\xbf' &&+		          '\x80' <= c'' && c'' <= '\xbf' =+	toEnum ((fromEnum c `mod` 0x10 * 0x1000) + (fromEnum c' `mod` 0x40) * 0x40 + fromEnum c'' `mod` 0x40) : decodeUTF8 cs+decodeUTF8 _ = error "UniChar.decodeUTF8: bad data"++-- | Take a Unicode string and encode it as a string+-- with the UTF8 method.+encodeUTF8 :: String -> String+encodeUTF8 "" = ""+encodeUTF8 (c:cs) =+	if c > '\x0000' && c < '\x0080' then+	    c : encodeUTF8 cs+	else if c < toEnum 0x0800 then+	    let i = fromEnum c+	    in  toEnum (0xc0 + i `div` 0x40) : +	        toEnum (0x80 + i `mod` 0x40) : +		encodeUTF8 cs+	else+	    let i = fromEnum c+	    in  toEnum (0xe0 + i `div` 0x1000) : +	        toEnum (0x80 + (i `mod` 0x1000) `div` 0x40) : +		toEnum (0x80 + i `mod` 0x40) : +		encodeUTF8 cs
+ hsrc/infix/CompOps.hs view
@@ -0,0 +1,48 @@+module CompOps where+import CompF(compF)+import ParF(parF)+import CompFfun+import Fudget+import SerCompF(serCompF)+import CompSP(serCompSP,compEitherSP)+import ParSP(parSP)++-- Change priority??+infixl 5 >+<+infixl 5 >*<+infixr 4 >==<+infixr 8 -==-, -+-, -*-+infixr 7 >^^=<+infixr 5 >..=<+infixl 6 >=^^<+infixl 6 >=..<+infixr 7 >^=<+infixr 6 >.=<+infixl 6 >=^<+infixl 6 >=.<++-- Infix operators for common stream processor combinators.++sp1 -==- sp2 = serCompSP sp1 sp2+sp1 -+- sp2 = compEitherSP sp1 sp2+sp1 -*- sp2 = parSP sp1 sp2++-- Infix operators for common fudget combinators.++w1 >+< w2 = compF w1 w2+w1 >*< w2 = parF w1 w2+w1 >==< w2 = serCompF w1 w2++(>^^=<) :: (SP a b) -> (F e a) -> F e b+f >^^=< w = postProcessHigh f w+(>=^^<) :: (F c d) -> (SP e c) -> F e d+w >=^^< f = preProcessHigh w f+(>^=<) :: (a -> b) -> (F e a) -> F e b+f >^=< w = postMapHigh f w+(>=^<) :: (F c d) -> (e -> c) -> F e d+w >=^< f = preMapHigh w f++f >..=< w = postProcessLow f w+w >=..< f = preProcessLow w f+f >.=< w = postMapLow f w+w >=.< f = preMapLow w f
+ hsrc/infix/InfixOps.hs view
@@ -0,0 +1,8 @@+module InfixOps (-- * InfixOps+  module CompOps,module LayoutOps,module OldLayoutOps) where+import CompOps+import LayoutOps+import OldLayoutOps++--import Fudget+--import LayoutDir(Orientation)
+ hsrc/infix/LayoutOps.hs view
@@ -0,0 +1,11 @@+module LayoutOps((>#==<), (>#+<)) where+--import Fudget+--import LayoutDir(Orientation)+import LayoutF(compLF,serCompLF)++infixl >#+<, >#==<++-- Infix operators for common layout combinators.++f1o >#+<  f2 = compLF f1o f2+f1o >#==< f2 = serCompLF f1o f2
+ hsrc/infix/OldLayoutOps.hs view
@@ -0,0 +1,27 @@+module OldLayoutOps((>==#<), (>+#<)) where+--import Fudget+import LayoutDir(Orientation(..))+import Placers(horizontalP',verticalP')+import Placer(placerF)+import AlignP(revP)+--import LayoutRequest+--import Geometry+import CompF(compF)+import SerCompF(serCompF)++infixl >+#<, >==#<++-- Old version of infix operators for common layout combinators.+-- Provided for backwards compatibility only.++f1 >+#<  of2 = cLF compF f1 of2+f1 >==#< of2 = cLF serCompF f1 of2++cLF cF f1 (dist,ori,f2) =+    let placer =+            case ori of+              Above -> verticalP'+              Below -> revP . verticalP'+              LeftOf -> horizontalP'+              RightOf -> revP . horizontalP'+    in placerF (placer dist) (cF f1 f2)
+ hsrc/internals/CompiledGraphics.hs view
@@ -0,0 +1,145 @@+module CompiledGraphics where+import Geometry(Rect(..))+import Utils(number)+import DrawTypes(DrawCommand)+import ResourceIds(GCId,rootGC)+import Rects(overlaps,boundingRect)+import Maptrace(ctrace)++{-+--Version 1:+data CompiledGraphics = CGraphics Rect GCtx [DrawCommand] [CompiledGraphics]+-}++{-+--Version 2:+data CompiledGraphics = CGraphics Rect [XCommand] [CompiledGraphics]+       -- The only XCommand used is Draw MyWindow some_GC some_DrawCommand+-}++{-+--Version 3:+data CompiledGraphics = CGraphics Rect Cursor [XCommand] [CompiledGraphics]+       -- The only XCommand used is Draw MyWindow some_GC some_DrawCommand+-}++{-+--Version 4:+data CompiledGraphics+  = CGraphics Rect Cursor [XCommand] [CompiledGraphics]+       -- The only XCommand used is Draw MyWindow some_GC some_DrawCommand+  | CGMark CompiledGraphics -- path preserving dummy nodes+-}++--Version 5:+data CompiledGraphics+  = CGraphics Rect Cursor [(GCId,[DrawCommand])] [CompiledGraphics]+  | CGMark CompiledGraphics -- path preserving dummy nodes+  deriving (Show)++type Cursor = Bool++cgLeaf r rcmds =+    --ctrace "gctrace" cmds $+    cg+  where+    cg = CGraphics r False  cmds []+    --cmds = (map (Draw MyWindow gc) (f r))+    cmds = rcmds r++cgMark = CGMark++cgCompose r cgs = CGraphics r False cmds cgs+  where+    cmds = if anyOverlap cgs+	   then ctrace "cgoverlap" (map cgrect cgs) $+		[(rootGC,[])] --trick coding to force all subtrees to be redrawn+	   else []++    -- This is O(n^2) in general, but the bounding rect makes it O(n) for+    -- linear placers. It may also help somewhat for tables...+    -- Sorting the rectangles can cut down the complexity too...+    -- Better to let the placers tell if they produce overlapping parts...+    anyOverlap [] = False+    anyOverlap (cg:cgs) = anyOverlaps' [r] r cgs+      where r = cgrect cg++    anyOverlaps' rs bounding [] = False+    anyOverlaps' rs bounding (cg:cgs) =+        r `overlaps` bounding && any (overlaps r) rs ||+	anyOverlaps' (r:rs) (boundingRect bounding r) cgs+      where r = cgrect cg++cgrect (CGMark cg) = cgrect cg+cgrect (CGraphics r _ _ _) = r+cgsize = rectsize.cgrect++addcursor (CGMark cg) = CGMark (addcursor cg) -- hmm!!+addcursor (CGraphics r _ cmds cgs) = CGraphics r True cmds cgs+removecursor (CGMark cg) = CGMark (removecursor cg) -- hmm!!+removecursor (CGraphics r _ cmds cgs) = CGraphics r False cmds cgs+hascursor (CGMark cg) = hascursor cg -- hmm!!+hascursor (CGraphics _ cur _ _) = cur++cgpart cg [] = cg+cgpart (CGMark cg) (0:ps) = cgpart cg ps+cgpart (CGraphics _ _ _ parts) (p:ps) =+  if p<1||p>length parts then error "bad path in CompiledGraphics.cgpart " else+  cgpart (parts !! ((p::Int)-1)) ps++cgreplace cg path new = cgupdate cg path (const new)++{-+cgupdate cg ps f =+  (if any (<1) ps+  then ctrace "cgupdate" ps+  else id) $ cgupdate' cg ps f+-}++cgupdate cg                            []     f = f cg+cgupdate (CGMark cg)                   (0:ps) f = CGMark (cgupdate cg ps f)+cgupdate (CGMark cg)                   ps     f =+   ctrace "badpath" ("(CGMark _) "++show ps) $+   CGMark (cgupdate cg ps f)+cgupdate cg                            (0:ps) f =+   ctrace "badpath" (cg,0:ps) $+   CGMark (cgupdate cg ps f)+cgupdate (CGraphics r cur dcmds parts) (p:ps) f =+    CGraphics r cur dcmds (pre++cgupdate cg' ps f:post)+  where pre = take (p-1) parts+        cg':post = drop ((p-1)::Int) parts++cgcursors :: CompiledGraphics -> [[Int]]+cgcursors (CGMark cg) = map (0:) (cgcursors cg)+cgcursors (CGraphics _ cur _ parts) =+    if cur+    then []:partcursors+    else partcursors+  where+    partcursors =+      concatMap (\(n,ps) -> map (n:) (cgcursors ps)) (number 1 parts)++cgGroup pos len (CGMark cg) = CGMark (cgGroup pos len cg) -- hmm!!+cgGroup pos len (CGraphics r cur dcmds parts) =+    CGraphics r cur dcmds (ds1++cgCompose r2 ds2:ds3)+  where+    (ds1,ds2a) = splitAt (pos-1) parts+    (ds2,ds3) = splitAt len ds2a+    r2 = foldr (boundingRect.cgrect) (Rect 0 0) ds2++cgUngroup pos (CGMark cg) = CGMark (cgUngroup pos cg) -- hmm!!+cgUngroup pos cg@(CGraphics r cur dcmds parts) =+    case splitAt (pos-1) parts of+      (ds1,d2:ds3) ->+        case unmark 0 d2 of+          (m,CGraphics r2 cur2 dcmds2 ds2) ->+            CGraphics r cur (dcmds++dcmds2) (ds1++map (mark m) ds2++ds3)+          _ -> cg -- hmm!!++      _ -> cg -- hmm!!+  where+    unmark n (CGMark cg) = unmark (n+1) cg+    unmark n cg = (n,cg)++    mark 0 cg = cg+    mark n cg = mark (n-1) (CGMark cg)
+ hsrc/internals/DLValue.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE CPP #-}+module DLValue where++#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)+data DLValue = DLValue (forall a. a)+#elif defined(__NHC__) || defined(__PFE__)+-- not supported+data DLValue = DLValue+#else+data DLValue = DLValue a +#endif++instance Show DLValue where+   showsPrec i d = ("DLValue"++)++instance Read DLValue
+ hsrc/internals/DrawCompiledGraphics.hs view
@@ -0,0 +1,24 @@+module DrawCompiledGraphics(drawK,drawK',drawChangesK,drawChangesK') where+import qualified DrawCompiledGraphics1 as D1+--import qualified DrawCompiledGraphics2 as D2+--import qualified DrawCompiledGraphics3 as D3+import DrawTypes(Drawable(MyWindow))+import CmdLineEnv(argReadKey)++drawK x = D1.drawK' MyWindow x+drawChangesK x = D1.drawChangesK' Nothing x++drawK' x = D1.drawK' x+drawChangesK' x = D1.drawChangesK' x+--drawK' = drawChoice D1.drawK' D2.drawK' D3.drawK'+--drawChangesK' = drawChoice D1.drawChangesK' D2.drawChangesK' D3.drawChangesK'+++drawChoice =+  case choice of+    1 -> \ d1 d2 d3 -> d1+--  2 -> \ d1 d2 d3 -> d2+--  3 -> \ d1 d2 d3 -> d3+    _ -> error "unkown version of DrawCompiledGraphics"+  where+    choice = argReadKey "draw" (1::Int)
+ hsrc/internals/DrawCompiledGraphics1.hs view
@@ -0,0 +1,94 @@+module DrawCompiledGraphics1(drawK',drawChangesK',GCId) where+--import Fudget+import Xtypes+import XDraw(DrawCommand(FillRectangle),clearArea,draw,drawMany,Drawable(..))+import Geometry(growrect,(=.>),Rect(rectsize))+--import Message+--import NullF(putsK,putK)+import Utils(number)+--import EitherUtils(mapfilter)+import Data.Maybe(mapMaybe)+import CompiledGraphics+--import Rects+--import Maptrace(ctrace) -- debug+--import Io(echoK) -- debug+import FudgetIO(putLow)++--tr x = seq x $ ctrace "drawtrace" x x+--trLow = Low . tr+--trLow = tr . Low+--maptrLow = map trLow+--debugK = echoK++--drawK = drawK' MyWindow+drawK' d (higc,hiR) clip cg =+    case draw cg [] of+      [] -> id+      cmds -> putLow $ drawMany d cmds+  where+    draw (CGMark cg) = draw cg+    draw (CGraphics r cur cmds gs) =+      (if cur+       then ((higc,[FillRectangle cr | hr<-hiR r,cr<-clip hr]):)+       else id).+      (cmds++) .+      draws gs+    draws [] = id+    draws (g:gs) = draw g . draws gs++drawChangesK' d beQuick higc  (CGMark cg) (CGMark ocg) changes =+    --debugK (show [ ps | ps<-changes, take 1 ps/=[0]]) .+    drawChangesK' d beQuick higc cg ocg (mapMaybe drop0 changes)+  where drop0 [] = Just []+        drop0 (0:ps) = Just ps+	drop0 _ = Nothing++drawChangesK' d beQuick higc  cg@(CGraphics r  _ cmds cgs )+                          ocg@(CGraphics or _ ocmds ocgs) changes =+    --debugK (unwords ["Changes:",show changes,"or",show or,"nr",show r]) .+    if r/=or || [] `elem` changes+       -- Hack for overlapping parts:+       || not (null changes || null cmds && null ocmds)+    then --debugK "Drawing" .+         -- !! test if scrolling is enough+	 eraseOldK d r or .+         reDrawK' d beQuick higc cg+    else if null changes+         then --debugK "Pruning" .+	      id+	 else --debugK "Descending" .+	      let changes' i= [ p | i':p <- changes, i'==i]+	      in foldr (.) id [drawChangesK' d beQuick higc cg ocg (changes' i) |+				(i,(cg,ocg))<-number 1 (zip cgs ocgs)]+drawChangesK' d beQuick higc  cg ogc _ =+    --debugK "drawNewK" .+    drawNewK cg+  where+    drawNewK (CGMark cg) = drawNewK cg+    drawNewK cg@(CGraphics r _ _ _) =+      eraseOldK d r (cgrect ogc) .+      reDrawK' d beQuick higc cg++eraseOldK Nothing newrect oldrect =+  -- It's enough to clear the part of oldrect that is outside newrect.+  ifK (newrect/=oldrect)+      (putLow $ clearArea (growrect oldrect 1) False)+eraseOldK (Just (d,cleargc)) newrect oldrect =+  ifK (newrect/=oldrect)+      (putLow $ draw d cleargc (FillRectangle (growrect oldrect 1)))++reDrawK' d beQuick higc (CGMark cg) = reDrawK' d beQuick higc cg+reDrawK' Nothing beQuick higc cg@(CGraphics r _ _ _) =+  -- When drawing directly in a window:+  if (not beQuick || rectsize r =.> 400) -- heuristic+  then -- for big areas: wait for exposure event and draw only the+       -- visible part+       putLow (clearArea r True)+  else -- for small areas: draw everything immediately (reduced flicker)+       putLow (clearArea r False) . drawK' MyWindow higc (:[]) cg+reDrawK' (Just (d,cleargc)) beQuick higc cg@(CGraphics r _ _ _) =+       -- For drawing in a back buffer or a pixmap (assumes d/=MyWindow):+       putLow (draw d cleargc (FillRectangle r)) .+       drawK' d higc (:[]) cg++ifK b k = if b then k else id
+ hsrc/internals/Editfield.hs view
@@ -0,0 +1,84 @@+module Editfield(EditField, moveField, replaceField, setFieldDir, getField,getField',+                 deselectField, getSelection, getLastLineNo, getAft, getBef, getLnoEdge,+                 createField, dirint, splitnl, nlines) where+import HbcUtils(breakAt)+import Edtypes++--export EditField,newline,nlines,splitnl,+data EditField = F EDirection String String String Int Int +                 deriving (Eq, Ord)++--               bef     sel   aft     ^  lastlineno+--                            lno for selection edge++nlines s = length (filter (== newline) s)++splitnl = breakAt newline++dirint ERight = 1+dirint ELeft = -1++befaft dir bef sel aft =+    if dir == ELeft then (bef, sel ++ aft) else (sel ++ bef, aft)++createField s = F ERight [] [] s 0 (nlines s)+getLnoEdge (F dir bef sel aft elno lno) =+    (elno, befaft dir bef sel aft)+getBef (F dir bef sel aft elno lno) = bef+getAft (F dir bef sel aft elno lno) = aft+getLastLineNo (F dir bef sel aft elno lno) = lno+getSelection (F dir bef sel aft elno lno) =+    if dir == ELeft then sel else reverse sel++deselectField (F dir bef sel aft elno lno) =+    let (bef', aft') = befaft dir bef sel aft+    in  F dir bef' [] aft' elno lno++getField f = reverse (getBef f) ++ getSelection f ++ getAft f+getField' f = (reverse (getBef f),getSelection f,getAft f)++setFieldDir ndir field@(F dir bef sel aft elno lno) =+    if ndir == dir then+        field+    else+        let elno' = elno + dirint ndir * nlines sel+        in  F ndir bef (reverse sel) aft elno' lno++replaceField (F dir bef sel aft elno lno) s =+    let linessel = nlines sel+        liness = nlines s+        elno' = elno + liness - (if dir == ERight then linessel else 0)+        lno' = lno + (liness - linessel)+    in  F ERight (reverse s ++ bef) [] aft elno' lno'++moveField :: IsSelect -> EditField -> EditStopFn -> (EditField,String)+moveField issel (F dir bef sel aft elno lno) sf =+    let mo dir' bef' sel' aft' elno' acc sf =+            let stop = (F dir' bef' sel' aft' elno' lno, acc)+                (b, a) = befaft dir' bef' sel' aft'+            in case sf b a of +		 EdStop -> stop+		 EdGo wdir sf' -> +		    let next c dir'' bef'' sel'' aft'' =+			    let elno'' =+				    if c == newline then+					dirint wdir + elno'+				    else+					elno'+			    in  mo dir'' bef'' sel'' aft'' elno'' (c:acc) sf'+		    in  if wdir == dir' || null sel' then+			    case wdir of+			      ELeft -> case bef' of+					 [] -> stop+					 c:bef'' -> next c wdir bef'' (c:sel') aft'+			      ERight -> case aft' of+					  [] -> stop+					  c:aft'' -> next c wdir bef' (c:sel') aft''+			else+			    let c:sel'' = sel'+			    in  case dir' of+				  ELeft -> next c dir' (c:bef') sel'' aft'+				  ERight -> next c dir' bef' sel'' (c:aft')+        (field, acc) = mo dir bef sel aft elno [] sf+    in  if issel then (field, acc) else (deselectField field, [])+
+ hsrc/internals/IntMemo.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE CPP #-}+module IntMemo(memoInt) where+import Prelude hiding (lookup)+import CmdLineEnv(argFlag)++#ifndef __NHC__+#define STRICTARG(x) (x){-#STRICT#-}+#else+#define STRICTARG(x) (x)+#endif++data IntMemo a+  = Tip+  | Node a (IntMemo a) (IntMemo a)++lookup :: Int -> IntMemo a -> Maybe a+lookup n m =+  case m of+    Tip -> Nothing+    Node x l r ->+      case n of+	0 -> Just x+        _ -> lookup (n `div` 2) (STRICTARG(if n `mod` 2==0 then l else r))++memoInt :: (Int->a)->(Int->a)+memoInt f = if memoOn then g else f+  where+    g n = if n<0+          then case lookup (-n) negtable of Just x -> x+	  else case lookup n table of Just x -> x+    table = tabulate 0 1+    negtable = tabulate 0 (-1)+    tabulate n b = Node (f n) (tabulate n (STRICTARG(2*b)))+			      (tabulate (STRICTARG(n+b)) (STRICTARG(2*b)))++memoOn = argFlag "memoint" True
+ hsrc/internals/IsRequest.hs view
@@ -0,0 +1,18 @@+module IsRequest where++import FRequest+import DialogueIO hiding (IOError)++isRequest c =+  case c of+    DReq (Select _) -> False+    DReq _ -> True+    XReq _ -> True+    SReq _ -> True+    _ -> False++isResponse e =+  case e of+    XEvt _ -> False+    LEvt _ -> False+    _ -> True
+ hsrc/internals/MGOps.hs view
@@ -0,0 +1,101 @@+module MGOps where+import MeasuredGraphics(MeasuredGraphics(..))+import Maptrace(ctrace)+import Utils(anth)++{-+mgPart drawing path =+  case path of+    [] -> drawing+    p:ps -> part drawing+      where+        part drawing =+	  case drawing of+	    LeafM _ _ _     -> error "bad path in mgPart"+	    SpacedM   _  d  -> part d+	    PlacedM   _  d  -> part d+	    ComposedM    ds -> mgPart (ds !! ((p::Int)-1)) ps+-}++{-    +replaceMGPart drawing path new =+  (if any (<1) path+  then ctrace "replaceMGPart" path+  else id) $ replaceMGPart' drawing path new+-}++replaceMGPart drawing path new = updateMGPart drawing path (const new)++-- Replacing a part without changing the structure+updateMGPart drawing path f =+  case path of+    [] -> f drawing+    p:ps  -> repl drawing+      where+        err = error ("bad path in replaceMGPart: "++show path)+	repl0 d = if p==0+	          then updateMGPart d ps f+		  else err+        repl drawing =+	  case drawing of+	    LeafM _ _            -> err+	    MarkM     gctx    d  -> MarkM gctx (repl0 d)+	    SpacedM   spacer  d  -> SpacedM spacer (repl0 d)+	    PlacedM   placer  d  -> PlacedM placer (repl0 d)+	    ComposedM         ds -> ComposedM ds'+              where ds' = anth p (\d->updateMGPart d ps f) ds++-- Changing the structure but not the appearance+groupMGParts pos len drawing =+  case drawing of+    ComposedM ds -> ComposedM (ds1++ComposedM ds2:ds3)+      where+        (ds1,ds2a) = splitAt (pos-1) ds+        (ds2,ds3) = splitAt len ds2a+    _ -> drawing++-- Changing the structure but not the appearance+ungroupMGParts pos drawing =+  case drawing of+    ComposedM ds ->+        case splitAt (pos-1) ds of+          (ds1,ComposedM ds2:ds3) -> ComposedM (ds1++ds2++ds3)+          _ -> drawing+    _ -> drawing++parentGctx gctx mg path =+  case path of+    [] -> gctx+    0:ps ->+      case mg of+        MarkM gctx' mg' -> parentGctx gctx' mg' ps+	SpacedM _   mg' -> parentGctx gctx mg' ps+	PlacedM _   mg' -> parentGctx gctx mg' ps+	_ -> ctrace "badpath" path gctx -- This is actually an error+    p:ps ->+      case mg of+	ComposedM   mgs ->+	  --{-+	  if p>length mgs+	  then ctrace "badpath" path gctx -- This is actually an error+	  else --}+	  parentGctx gctx (mgs!!(p-1)) ps+	_ -> ctrace "badpath" path gctx -- This is actually an error+{-+seqMG mg k =+  case mg of+    LeafM _ _ -> k+    SpacedM _ mg -> seqMG mg k+    PlacedM _ mg -> seqMG mg k+    MarkM _ mg -> seqMG mg k+    ComposedM mgs -> foldr seqMG k mgs+++sizeMG mg =+  case mg of+    LeafM _ _ -> 1::Int+    SpacedM _ mg -> 1+sizeMG mg+    PlacedM _ mg -> 1+sizeMG mg+    MarkM _ mg -> 1+sizeMG mg+    ComposedM mgs -> 1+sum (map sizeMG mgs)+-}
+ hsrc/internals/MeasuredGraphics.hs view
@@ -0,0 +1,123 @@+module MeasuredGraphics(DPath,up,MeasuredGraphics(..),compileMG,emptyMG,emptyMG',measureString,measureImageString,measurePackedString) where+import Geometry+import LayoutRequest+--import Placers2(overlayP)+import AutoPlacer(autoP)+import XDraw+import ResourceIds(GCId)+import Font+import TextExtents(queryTextExtents16K)+import Rects(boundingRect)+import CompiledGraphics+import GCtx(GCtx(..))+import GCAttrs(FontData(..))+import PackedString(unpackPS)+import Utils(lunconcat)+--import CmdLineEnv(argFlag)+import Debug.Trace(trace)++tr x y = y++type DPath = [Int] -- path to a part of a drawing++up :: DPath -> DPath+up [] = []+up path = init path++data MeasuredGraphics+--  = LeafM LayoutRequest GCtx (Rect->[DrawCommand])+	    -- GCtx should be replaced by GCId !+  = LeafM LayoutRequest (Rect->[(GCId,[DrawCommand])])+  | SpacedM Spacer MeasuredGraphics+  | PlacedM Placer MeasuredGraphics+  | MarkM GCtx MeasuredGraphics -- path & Gctx preserving nodes+  | ComposedM [MeasuredGraphics]++emptyMG size = emptyMG' (plainLayout size False False)+emptyMG' layout = LeafM layout (const [])++compileMG f mg = (cg,req)+  where+    (reqs,cg) = tr "layoutMG" $ layoutMG mg places+    (req0,placer2) = unP autoP reqs+    req = mapLayoutSize f req0+    place = tr "Rect" $ Rect origin (minsize req)+    places = placer2 place++    layoutMG :: MeasuredGraphics -> [Rect] -> ([LayoutRequest],CompiledGraphics)+    layoutMG mg rs =+      case mg of+        MarkM _ mg' -> (lls,cgMark cg)+	  where (lls,cg) = layoutMG mg' rs+	LeafM ll rcmds -> (tr "LeafM"  [ll],cgLeaf r rcmds)+	  where [r] = rs -- bug if length rs/=1 !!+	SpacedM (S spacer1) mg' -> (tr "SpaceM" lls',cgMark cg)+	  where (lls,cg) = layoutMG mg' rs'+	        (lls',spacer2s) = unzip (map spacer1 lls)+	        rs' = map2' id spacer2s rs+	PlacedM (P placer1) mg -> (tr "PlacedM" [ll'],cgMark cg)+	  where (lls,cg) = layoutMG mg rs'+		(ll',placer2) = placer1 lls+		rs' = placer2 r+		[r] = tr ("#rs="++show (length rs)) rs+	ComposedM [] -> (tr "ComposedM []" [],cgCompose (Rect origin origin) [])+	ComposedM mgs -> (tr "ComposedM" lls',cgCompose r cgs)+	  where (llss,cgs) = unzip (map2' layoutMG mgs rss)+	        lls' = concat llss+		r = case rs of+		      [] -> trace ("ComposedM, rs=[], length mgs="++show (length mgs)) (rR 0 0 1 1)+		      _ -> foldr1 boundingRect rs -- !!+	        rss = lunconcat llss rs++measureString'' unpack draw s (GC gc fd) k =+     measure $ \ a d next size ->+     let p1 = Point 0 a+	 p2 = Point next a+	 drawit (Rect p (Point _ h)) = [(gc,[draw (p+(Point 0 (h-d))) s])]+	 size' = Point (xcoord p2) (ycoord size) -- paragraphP bug workaround+     in --trace (unwords ["measureString ",unpack s,"rect",show r]) $+        k (LeafM (refpLayout size' True True [p1,p2]) drawit)+  where+    us = unpack s+    measure k =+      case fd of+        FS fs -> k a d next size+	  where+	    Rect _ size = string_rect fs us+	    a = font_ascent fs+	    d = font_descent fs+	    next = next_pos fs us+	FID fs ->+          let fid = font_id fs+	  in  if null us+   	      then queryTextExtents16K fid " " $ \ a d cs ->+	           k a d 0 (Point 0 (a+d))+	      else queryTextExtents16K fid us $ \ a d cs ->+	           k a d (char_width cs) (Point (char_rbearing cs) (a+d))++measureString' draw8 draw16 s gctx@(GC _ fd) k =+    measureString'' id draw s gctx k+  where+    draw =+      case fd of+        FS fs | snd (font_range fs) <= '\xff' -> draw8+	_ -> draw16++measureString s = measureString' DrawString DrawString16 s+measureImageString s = measureString' DrawImageString DrawImageString16 s++{- old:+measureString =+  if argFlag "string16bit" False+  then measureString' id DrawString16+  else measureString' id DrawString+-}++measurePackedString ps = measureString'' unpackPS DrawStringPS ps+++-- map2' is a lazier version of map2 (aka zipWith)+-- length (map2' f xs ys) = length xs,+-- map2' f xs ys = map2' f xs (ys++repeat undefined)+map2' f [] _ = []+map2' f (x:xs) ~(y:ys) = f x y:map2' f xs ys
+ hsrc/internals/PathTree.hs view
@@ -0,0 +1,182 @@+module PathTree+  (+    PathTree(..),DynTree(..),+    -- PathTree should be abstract...+    emptyPathTree,updateNode,mapPathTree,node,subTree,listNodes,+    attrMapPathTree,+    pruneTree,+    pos,unpos,spineVals+  ) where+import Direction+--import Path+import HbcUtils(apSnd)+import Maptrace(ctrace)++data PathTree n+   = Node n (PathTree n) (PathTree n)+   | Dynamic (DynTree (PathTree n))+   | Tip+   deriving (Eq, Ord, Show)++data DynTree n+  = DynNode n (DynTree n) (DynTree n)+  | DynTip +  deriving (Eq, Ord, Show)++emptyPathTree = Tip+lookupPath f z = subTree (\(Node w _ _) -> f w) z+subNodes x = subTree (listNodes []) [] x++listNodes ns t =+    case t of+      Tip -> ns+      Node n l r -> listNodes (listNodes (n : ns) l) r+      Dynamic dt -> listDynNodes ns dt++listDynNodes ns dt =+    case dt of+      DynTip -> ns+      DynNode t l r -> listNodes (listDynNodes (listDynNodes ns r) l) t++subTree f z Tip _ = z+subTree f z (Dynamic dt) p = dynSelect (subTree f z) z dt p+subTree f z n [] = f n+subTree f z (Node _ l _) (L : path') = subTree f z l path'+subTree f z (Node _ _ r) (R : path') = subTree f z r path'+--subTree _ _ t p = error ("subTree _ _ "++show t++" "++show p)+-- Other cases of ill matching trees/paths return z, so why shouldn't this one?+subTree _ z t p = ctrace "subTree" ("subTree _ _ "++show t++" "++show p) z++{-+dynSubTree f z DynTip _ _ = z+dynSubTree f z (DynNode t _ _) 0 path' = subTree f z t path'+dynSubTree f z (DynNode _ l r) n path' =+    dynSubTree f z (if n `rem` 2 == 0 then l else r) (n `quot` 2) path'+-}+dynSelect f z dn (Dno n:p) = dynSelect' dn (pos n) where+   dynSelect' DynTip _ = z+   dynSelect' (DynNode t l r) n = if n == 0 then f t p else+	     dynSelect' (if n `rem` 2 == 0 then l else r) (n `quot` 2)+dynSelect f z dn _ = z++pruneNode e = insertTree e Tip+insertTree n = updTree id n . const+pruneTree i e t path = updTree i e (const Tip) t path++updateNode i e t path f = updTree i e g t path+  where g Tip = Node (f e) Tip Tip+        g (Node n l r) = Node (f n) l r++updTree i e f t path' =+    case path' of+      [] -> f t+      L : path'' -> updLeft i e f t path''+      R : path'' -> updRight i e f t path''+      Dno n : path'' -> updateDyn i e f t (pos n) path''++updLeft i e f t path' =+    case t of+      Tip -> Node e (updTree i e f Tip path') Tip+      Node n l r -> Node (i n) (updTree i e f l path') r+                    -- !!! space leak danger if i n is never used+		    -- need stingy evaluation!!+      Dynamic _ -> error "PathTree.hs: updLeft (Dynamic _)"++updRight i e f t path' =+    case t of+      Tip -> Node e Tip (updTree i e f Tip path')+      Node n l r -> Node (i n) l (updTree i e f r path')+                    -- !!! space leak danger if i n is never used+		    -- need stingy evaluation!!+      Dynamic _ -> error "PathTree.hs: updRight (Dynamic _)"++updateDyn i e f t n path' =+    case t of+      Tip -> Dynamic (updateDyn' i e f DynTip n path')+      Node _ _ _ -> Dynamic (updateDyn' i e f DynTip n path') -- throwing away part of the tree !!!+      Dynamic t' -> Dynamic (updateDyn' i e f t' n path')++updateDyn' i e f DynTip 0 path' =+    DynNode (updTree i e f Tip path') DynTip DynTip+updateDyn' i e f (DynNode t l r) 0 path' = DynNode (updTree i e f t path') l r+updateDyn' i e f t n path' =+    (if n `rem` 2 == 0 then updDynLeft else updDynRight) i e f+                                                         t+                                                         (n `quot` 2)+                                                         path'++updDynLeft i e f t n path' =+    case t of+      DynTip -> DynNode Tip (updateDyn' i e f DynTip n path') DynTip+      DynNode t' l r -> DynNode t' (updateDyn' i e f l n path') r++updDynRight i e f t n path' =+    case t of+      DynTip -> DynNode Tip DynTip (updateDyn' i e f DynTip n path')+      DynNode t' l r -> DynNode t' l (updateDyn' i e f r n path')++pos :: Int->Int+pos 0 = 0+pos n = if n < 0 then (-2) * n else 2 * n + 1++unpos :: Int->Int+unpos n =+  if even n+  then -(n `quot` 2)+  else n `quot` 2++mapPathTree f t =+  case t of+    Node n lt rt -> Node (f n) (mapPathTree f lt) (mapPathTree f rt)+    Dynamic dt -> Dynamic (mapDyn (mapPathTree f) dt)+    Tip -> Tip++mapDyn f dt =+  case dt of+    DynNode n lt rt -> DynNode (f n) (mapDyn f lt) (mapDyn f rt)+    DynTip -> DynTip++attrMapPathTree :: (i -> [s] -> a -> (i,s,b)) -> i -> PathTree a -> +		   ([s],PathTree b)+attrMapPathTree f i t = case t of+   Node n lt rt -> ([s],Node n' lt' rt') where+      (sl,lt') = attrMapPathTree f i' lt+      (sr,rt') = attrMapPathTree f i' rt+      (i',s,n') = f i (sl++sr) n+      -- should perhaps extract ++ and []+   Tip -> ([],Tip)+   Dynamic dt -> apSnd Dynamic (attrMapDyn f i dt)++attrMapDyn f i dt = case dt of+   DynTip -> ([],DynTip)+   DynNode t lt rt -> (s++sl++sr,DynNode t' lt' rt') where+	     --        order?+      (sl,lt') = attrMapDyn f i lt+      (sr,rt') = attrMapDyn f i rt+      (s,t') = attrMapPathTree f i t++spineVals t p = case t of+	  Tip -> []+	  Node v l r -> v : case p of+	       L:p' -> spineVals l p'+	       R:p' -> spineVals r p'+	       _    -> []+          Dynamic dt -> dynSelect spineVals [] dt p++node t =+  case t of+    Node i lt rt -> (Just i,children lt (children rt []))+    Tip -> (Nothing,[])+    Dynamic dt -> (Nothing,dynChildren dt [])++children t ts =+  case t of+    Tip -> ts+    Node _ _ _ -> t:ts+    Dynamic dt -> dynChildren dt ts++dynChildren dt ts =+  case dt of+    DynTip -> ts+    DynNode t lt rt -> (children t . dynChildren lt . dynChildren rt) ts+      -- !! order??
+ hsrc/internals/Queue.hs view
@@ -0,0 +1,17 @@+module Queue(QUEUE, qmember, isempty, qremove, enter, empty) where++data QUEUE a = Queue [a] [a]  deriving (Eq, Ord)++empty = Queue [] []++enter (Queue outl' inl) x = Queue outl' (x : inl)++isempty (Queue [] []) = True+isempty _ = False++qremove (Queue (a : outl') inl) = Just (a, Queue outl' inl)+qremove (Queue [] []) = Nothing --error "qremove from empty queue"+qremove (Queue [] inl) = qremove (Queue (reverse inl) [])++qmember (Queue outl' inl) x = x `elem` outl' || x `elem` inl+
+ hsrc/internals/StringEdit.hs view
@@ -0,0 +1,51 @@+module StringEdit(+       moveCursorHome,moveCursorEnd,extendCursorHome,extendCursorEnd,+       moveCursorRight, moveCursorLeft, extendCursorLeft,extendCursorRight,+       deleteItemRight, deleteItemLeft, deleteToEnd, deleteToHome,+       insertItem, insertItemsSelected, showField, getField,+       createField2, createField, Field) where++data Field a = F [a] [a] [a]  deriving (Eq, Ord)++createField s = F [] s []++createField2 (before, after) = F (reverse before) [] after++getField (F l c r) = reverse l ++ c ++ r++showField show' show_cursor (F l c r) =+    show' r . show_cursor c . show' (reverse l)++insertItem (F l c r) i = F (i : l) [] r+insertItemsSelected (F l c r) i = F l i r++deleteItemLeft f@(F [] [] _) = f+deleteItemLeft (F (i : l) [] r) = F l [] r+deleteItemLeft (F l c r) = F l [] r++deleteItemRight f@(F _ [] []) = f+deleteItemRight (F l [] (i : r)) = F l [] r+deleteItemRight (F l c r) = F l [] r++deleteToEnd (F l c r) = F l [] []+deleteToHome (F l c r) = F [] [] r++extendCursorRight (F l c (i : r)) = F l (c ++ [i]) r+extendCursorRight f@(F _ _ []) = f++extendCursorLeft (F (i : l) c r) = F l (i : c) r+extendCursorLeft f@(F [] _ _) = f++moveCursorLeft f@(F [] [] _) = f+moveCursorLeft (F (i : l) [] r) = F l [] (i : r)+moveCursorLeft (F l c r) = F l [] (c ++ r)++moveCursorRight f@(F _ [] []) = f+moveCursorRight (F l [] (i : r)) = F (i : l) [] r+moveCursorRight (F l c r) = F (reverse c ++ l) [] r++moveCursorHome f = F [] [] (getField f)+moveCursorEnd  f = F (reverse (getField f)) [] []++extendCursorHome (F l c r) = F [] (reverse l++c) r+extendCursorEnd (F l c r) = F l (c++r) []
+ hsrc/internals/Table.hs view
@@ -0,0 +1,23 @@+module Table(table, mapTable, listTable, tableUpdate, tableLookup, emptyTable,+             Table) where+import Tree234++newtype Table a = T (Tree234 a) deriving (Eq, Ord,Show)++emptyTable = T initTree234++tableLookup n j x (T t) = treeSearch n j (keyCmp x) t++tableUpdate x (T t) = T (update' x t)++update' x = treeAdd const keyCmp x++mapTable f (T t) = T (treeMap f t)++listTable (T t) = treeList t++table xs = T (treeFromList const keyCmp xs)++keyCmp (a, _) (b, _) lt eq gt =+    if a == b then eq else if a < b then lt else gt+
+ hsrc/internals/Tables.hs view
@@ -0,0 +1,99 @@+module Tables(PathTable(..), WidTable(..), updatePath, lookupPath, wid2path0,+              pruneWid, updateWid, subWids, lookupWid, path2wid0, PathTree,+	      moveWids,movePaths, prunePath) where+import Direction+--import Fudget+import Path+import Table+import PathTree+import Utils(oo)+import Xtypes++-- Most functions here should be imported from PathTree instead !!!++type WidTable = PathTree WindowId++path2wid0 = Tip++lookupWid = subTree (\(Node w _ _) -> w) noWindow++moveWids path2wid opath npath = insertTree st pt npath where+    st = subTree id Tip path2wid opath +    pt = pruneWid path2wid opath++subWids = oo (filter (/= noWindow)) (subTree (listWids []) [])++listWids = listNodes++updateWid t path' wid = insertTree (Node wid Tip Tip) t path'++pruneWid t path' = insertTree Tip t path'++insertTree = updTree . const+updTree f t path' =+    case path' of+      [] -> f t+      L : path'' -> updLeft f t path''+      R : path'' -> updRight f t path''+      Dno n : path'' -> updateDyn f t (pos n) path''++updLeft f t path' =+    case t of+      Tip -> Node nowid (updTree f Tip path') Tip+      Node w l r -> Node w (updTree f l path') r+      Dynamic _ -> error "tables.m: updLeft (Dynamic _)"++updRight f t path' =+    case t of+      Tip -> Node nowid Tip (updTree f Tip path')+      Node w l r -> Node w l (updTree f r path')+      Dynamic _ -> error "tables.m: updRight (Dynamic _)"++updateDyn f t n path' =+    case t of+      Tip -> Dynamic (updateDyn' f DynTip n path')+      Dynamic t' -> Dynamic (updateDyn' f t' n path')++updateDyn' f DynTip 0 path' =+    DynNode (updTree f Tip path') DynTip DynTip+updateDyn' f (DynNode t l r) 0 path' = DynNode (updTree f t path') l r+updateDyn' f t n path' =+    (if n `rem` 2 == 0 then updDynLeft else updDynRight) f+                                                         t+                                                         (n `quot` 2)+                                                         path'++updDynLeft f t n path' =+    case t of+      DynTip -> DynNode Tip (updateDyn' f DynTip n path') DynTip+      DynNode t' l r -> DynNode t' (updateDyn' f l n path') r++updDynRight f t n path' =+    case t of+      DynTip -> DynNode Tip DynTip (updateDyn' f DynTip n path')+      DynNode t' l r -> DynNode t' l (updateDyn' f r n path')++nowid = noWindow++-------+type PathTable = Table (WindowId, Path)++nopath = here -- error "window not associated with a path"++wid2path0 = emptyTable++-- This part should be replaced with something more efficient!!+lookupPath wid2path wid =+    tableLookup nopath snd (wid, nopath) wid2path++-- normal code+updatePath wid2path wid path' = tableUpdate (wid, path') wid2path++movePaths wid2path opath npath = mapTable move wid2path where+  move (wid,path) = (wid,repath opath path) where+     repath [] rest = absPath npath rest+     repath (x:xs) (y:ys) | x == y = repath xs ys+     repath _ _ = path++-- should be implemented in Tree234+prunePath wid2path w = table $ filter ((/=w).fst) $ listTable wid2path
+ hsrc/internals/Tables2.hs view
@@ -0,0 +1,24 @@+module Tables2(DTable(..), dtable0, lookupDe, listDe, updateDe) where+import Utils(pair)+import Direction() -- instances+import Path(here,Path(..))+import Sockets(Descriptor)+import Table++type DTable = Table (Descriptor, Path)++updateDe :: Path -> [Descriptor] -> DTable -> DTable+updateDe path' ds dtable =+    table (map (`pair` path') ds +++           filter ((/= path') . snd) (listTable dtable))++listDe :: DTable -> [Descriptor]+listDe dtable = map fst (listTable dtable)++lookupDe :: DTable -> Descriptor -> Path+lookupDe dtable de =+    tableLookup (error ("Descriptor without path: "++show de)) snd (de, here) dtable++dtable0 :: DTable+dtable0 = table []+
+ hsrc/internals/Tree234.hs view
@@ -0,0 +1,239 @@+module Tree234(treeMap, treeCombine, treeRebuild, treeFromList, treeMapList,+               treeList, treeUpdate, treeSearch, treeAdd, initTree234, Tree234) where++data Tree234 a = Leaf |+                 Leaf2 a |+                 Leaf3 a a |+                 Leaf4 a a a |+                 Node2 a (Tree234 a) (Tree234 a) |+                 Node3 a a (Tree234 a) (Tree234 a) (Tree234 a) |+                 Node4 a a a (Tree234 a) (Tree234 a) (Tree234 a) (Tree234 a) +                 deriving (Eq, Ord,Show)++initTree234 = Leaf++treeAdd comb cmp a t = treeAdd' comb cmp a id Node2 t++treeSearch fail cont p Leaf = fail+treeSearch fail cont p (Leaf2 a1) = p a1 fail (cont a1) fail+treeSearch fail cont p (Leaf3 a1 a2) =+    p a1 fail (cont a1) (p a2 fail (cont a2) fail)+treeSearch fail cont p (Leaf4 a1 a2 a3) =+    p a2 (p a1 fail (cont a1) fail) (cont a2) (p a3 fail (cont a3) fail)+treeSearch fail cont p (Node2 a1 t1 t2) =+    p a1 (treeSearch fail cont p t1) (cont a1) (treeSearch fail cont p t2)+treeSearch fail cont p (Node3 a1 a2 t1 t2 t3) =+    p a1+      (treeSearch fail cont p t1)+      (cont a1)+      (p a2+         (treeSearch fail cont p t2)+         (cont a2)+         (treeSearch fail cont p t3))+treeSearch fail cont p (Node4 a1 a2 a3 t1 t2 t3 t4) =+    p a2+      (p a1+         (treeSearch fail cont p t1)+         (cont a1)+         (treeSearch fail cont p t2))+      (cont a2)+      (p a3+         (treeSearch fail cont p t3)+         (cont a3)+         (treeSearch fail cont p t4))++treeUpdateFailed = error "treeUpdate couldn't find the node"++treeUpdate update p Leaf = Leaf+treeUpdate update p (Leaf2 a1) =+    p a1 treeUpdateFailed (Leaf2 (update a1)) treeUpdateFailed+treeUpdate update p (Leaf3 a1 a2) =+    p a1+      treeUpdateFailed+      (Leaf3 (update a1) a2)+      (p a2 treeUpdateFailed (Leaf3 a1 (update a2)) treeUpdateFailed)+treeUpdate update p (Leaf4 a1 a2 a3) =+    p a2+      (p a1 treeUpdateFailed (Leaf4 (update a1) a2 a3) treeUpdateFailed)+      (Leaf4 a1 (update a2) a3)+      (p a3 treeUpdateFailed (Leaf4 a1 a2 (update a3)) treeUpdateFailed)+treeUpdate update p (Node2 a1 t1 t2) =+    p a1+      (Node2 a1 (treeUpdate update p t1) t2)+      (Node2 (update a1) t1 t2)+      (Node2 a1 t1 (treeUpdate update p t2))+treeUpdate update p (Node3 a1 a2 t1 t2 t3) =+    p a1+      (Node3 a1 a2 (treeUpdate update p t1) t2 t3)+      (Node3 (update a1) a2 t1 t2 t3)+      (p a2+         (Node3 a1 a2 t1 (treeUpdate update p t2) t3)+         (Node3 a1 (update a2) t1 t2 t3)+         (Node3 a1 a2 t1 t2 (treeUpdate update p t3)))+treeUpdate update p (Node4 a1 a2 a3 t1 t2 t3 t4) =+    p a2+      (p a1+         (Node4 a1 a2 a3 (treeUpdate update p t1) t2 t3 t4)+         (Node4 (update a1) a2 a3 t1 t2 t3 t4)+         (Node4 a1 a2 a3 t1 (treeUpdate update p t2) t3 t4))+      (Node4 a1 (update a2) a3 t1 t2 t3 t4)+      (p a3+         (Node4 a1 a2 a3 t1 t2 (treeUpdate update p t3) t4)+         (Node4 a1 a2 (update a3) t1 t2 t3 t4)+         (Node4 a1 a2 a3 t1 t2 t3 (treeUpdate update p t4)))++treeMapList f Leaf = []+treeMapList f (Leaf2 a1) = f a1+treeMapList f (Leaf3 a1 a2) = f a1 ++ f a2+treeMapList f (Leaf4 a1 a2 a3) = f a1 ++ f a2 ++ f a3+treeMapList f (Node2 a1 t1 t2) =+    treeMapList f t1 ++ f a1 ++ treeMapList f t2+treeMapList f (Node3 a1 a2 t1 t2 t3) =+    treeMapList f t1 +++    f a1 ++ treeMapList f t2 ++ f a2 ++ treeMapList f t3+treeMapList f (Node4 a1 a2 a3 t1 t2 t3 t4) =+    treeMapList f t1 +++    f a1 +++    treeMapList f t2 +++    f a2 ++ treeMapList f t3 ++ f a3 ++ treeMapList f t4++treeMap f Leaf = Leaf+treeMap f (Leaf2 a1) = Leaf2 (f a1)+treeMap f (Leaf3 a1 a2) = Leaf3 (f a1) (f a2)+treeMap f (Leaf4 a1 a2 a3) = Leaf4 (f a1) (f a2) (f a3)+treeMap f (Node2 a1 t1 t2) =+    Node2 (f a1) (treeMap f t1) (treeMap f t2)+treeMap f (Node3 a1 a2 t1 t2 t3) =+    Node3 (f a1) (f a2) (treeMap f t1) (treeMap f t2) (treeMap f t3)+treeMap f (Node4 a1 a2 a3 t1 t2 t3 t4) =+    Node4 (f a1)+          (f a2)+          (f a3)+          (treeMap f t1)+          (treeMap f t2)+          (treeMap f t3)+          (treeMap f t4)++treeFromList comb cmp l = treeAddList comb cmp l Leaf++treeAddList comb cmp [] t = t+treeAddList comb cmp (x : xs) t =+    treeAddList comb cmp xs (treeAdd comb cmp x t)++treeRebuild comb cmp t = treeFromList comb cmp (treeMapList (: []) t)++treeCombine comb cmp t1 t2 =+    treeAddList comb cmp (treeMapList (: []) t2) t1++treeAdd' comb cmp a keep split Leaf = keep (Leaf2 a)+treeAdd' comb cmp a keep split (Leaf2 a1) =+    keep (cmp a a1 (Leaf3 a a1) (Leaf2 (comb a a1)) (Leaf3 a1 a))+treeAdd' comb cmp a keep split (Leaf3 a1 a2) =+    keep (cmp a+              a1+              (Leaf4 a a1 a2)+              (Leaf3 (comb a a1) a2)+              (cmp a a2 (Leaf4 a1 a a2) (Leaf3 a1 (comb a a2)) (Leaf4 a1 a2 a)))+treeAdd' comb cmp a keep split (Leaf4 a1 a2 a3) =+    cmp a+        a2+        (cmp a+             a1+             (split a2 (Leaf3 a a1) (Leaf2 a3))+             (keep (Leaf4 (comb a a1) a2 a3))+             (split a2 (Leaf3 a1 a) (Leaf2 a3)))+        (keep (Leaf4 a1 (comb a a2) a3))+        (cmp a+             a3+             (split a2 (Leaf2 a1) (Leaf3 a a3))+             (keep (Leaf4 a1 a2 (comb a a3)))+             (split a2 (Leaf2 a1) (Leaf3 a3 a)))+treeAdd' comb cmp a keep split (Node2 a1 t1 t2) =+    keep (cmp a+              a1+              (treeAdd' comb+                        cmp+                        a+                        (\t1' -> Node2 a1 t1' t2)+                        (\a0' -> \t0' -> \t1' -> Node3 a0' a1 t0' t1' t2)+                        t1)+              (Node2 (comb a a1) t1 t2)+              (treeAdd' comb+                        cmp+                        a+                        (\t2' -> Node2 a1 t1 t2')+                        (\a2' -> \t2' -> \t3' -> Node3 a1 a2' t1 t2' t3')+                        t2))+treeAdd' comb cmp a keep split (Node3 a1 a2 t1 t2 t3) =+    keep (cmp a+              a1+              (treeAdd' comb+                        cmp+                        a+                        (\t1' -> Node3 a1 a2 t1' t2 t3)+                        (\a0' -> \t0' -> \t1' -> Node4 a0' a1 a2 t0' t1' t2 t3)+                        t1)+              (Node3 (comb a a1) a2 t1 t2 t3)+              (cmp a+                   a2+                   (treeAdd' comb+                             cmp+                             a+                             (\t2' -> Node3 a1 a2 t1 t2' t3)+                             (\a1_5' ->+                              \t1_5' ->+                              \t2' -> Node4 a1 a1_5' a2 t1 t1_5' t2' t3)+                             t2)+                   (Node3 a1 (comb a a2) t1 t2 t3)+                   (treeAdd' comb+                             cmp+                             a+                             (\t3' -> Node3 a1 a2 t1 t2 t3')+                             (\a3' ->+                              \t3' -> \t4' -> Node4 a1 a2 a3' t1 t2 t3' t4')+                             t3)))+treeAdd' comb cmp a keep split (Node4 a1 a2 a3 t1 t2 t3 t4) =+    cmp a+        a2+        (cmp a+             a1+             (split a2+                    (treeAdd' comb+                              cmp+                              a+                              (\t1' -> Node2 a1 t1' t2)+                              (\a0' -> \t0' -> \t1' -> Node3 a0' a1 t0' t1' t2)+                              t1)+                    (Node2 a3 t3 t4))+             (keep (Node4 (comb a a1) a2 a3 t1 t2 t3 t4))+             (split a2+                    (treeAdd' comb+                              cmp+                              a+                              (\t2' -> Node2 a1 t1 t2')+                              (\a2' -> \t2' -> \t3' -> Node3 a1 a2' t1 t2' t3')+                              t2)+                    (Node2 a3 t3 t4)))+        (keep (Node4 a1 (comb a a2) a3 t1 t2 t3 t4))+        (cmp a+             a3+             (split a2+                    (Node2 a1 t1 t2)+                    (treeAdd' comb+                              cmp+                              a+                              (\t3' -> Node2 a3 t3' t4)+                              (\a2' -> \t2' -> \t3' -> Node3 a2' a3 t2' t3' t4)+                              t3))+             (keep (Node4 a1 a2 (comb a a3) t1 t2 t3 t4))+             (split a2+                    (Node2 a1 t1 t2)+                    (treeAdd' comb+                              cmp+                              a+                              (\t4' -> Node2 a3 t3 t4')+                              (\a4' -> \t4' -> \t5' -> Node3 a3 a4' t3 t4' t5')+                              t4)))++treeList t = treeMapList (: []) t+
+ hsrc/internals/UndoStack.hs view
@@ -0,0 +1,27 @@+module UndoStack(UndoStack,undoStack,doit,undo,redo) where+--import EitherUtils(mapMaybe)++data UndoStack a = U (Maybe Int) [a] [a] [a]+--                   depth limit undos temp-undos temp-redos+undoStack:: Maybe Int -> UndoStack a+undoStack on = U (fmap (\n -> max 0 n + 1) on) [] [] []++otake on l = case on of+	        Nothing -> l+		Just n -> take n l++doit :: UndoStack a -> a -> (UndoStack a -> c) -> c+doit (U on u tu tr) a c = seq (length u') $ c (U on u' (tail u') [])+    where u' = otake on (a:take 1 tr++u)++undo :: UndoStack a -> Maybe (a,UndoStack a)+undo (U on u tu tr) = case tu of+			a:tu' -> Just (a,U on u tu' (a:tr))+			[] -> Nothing++redo :: UndoStack a -> Maybe (a,UndoStack a)+redo (U on u tu tr) = +     case tr of+       a:b:tr' -> Just (b,U on u (a:tu) (b:tr'))+       [a] -> Just (head u,U on u (a:tu) [])+       [] -> Nothing
+ hsrc/io/AppStorage.hs view
@@ -0,0 +1,20 @@+module AppStorage where+import System.Directory(XdgDirectory(..))+import ReadFileF+import WriteFile+import HbcUtils(apSnd)+import CompOps+import NullF+import Spops++appStorageF :: (Read a,Show a) => String -> a -> F a a+appStorageF key d =+  either (const d) (maybe d id . readM) . snd+  >^=< startupF [key] (readXdgFileF XdgData)+  >=^^< nullSP+  >==< writeXdgFileF XdgData+  >=^< (,) key . show++readM x = case reads x of+            [(x,s)] | lex s == [("","")] -> Just x+            _ -> Nothing
+ hsrc/io/AsyncTransmitter.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE CPP #-}+module AsyncTransmitter(asyncTransmitterF,asyncTransmitterF',closerF) where+import Sockets+import Srequest+import FRequest+import Message(message)+import NullF(getK,nullK,nullF)+import Fudget()+import FudgetIO+import CompOps((>==<))+import IoF(ioF)+import DialogueIO hiding (IOError)+import qualified PackedString as PS+import Queue(QUEUE,empty,enter,qremove)++{- asyncTransmitterF has two states:++   - Idle state: we have nothing to send and don't want to be notified when+                 the socket becomes writable.++   - Blocked state: we have something to send and want to be notified when+                   the socket becomes writable.++   idleK handles the idle state. Transistion to the idleState is done+   with goIdleK. idleK should only be called when in the idle state.++   blockedK handles the blocked state. Transition to the blocked state is done+   with goBlockedK. blockedK should only be called when in the blocked state.++   writeK is called in blocked mode when the socket become writable. If there+   is something left in the buffer to write, writeK writes a chunk to the+   socket and continues in blocked mode, otherwise writeK switches to+   idle mode.+-}++asyncTransmitterF socket = closerF socket >==< asyncTransmitterF' socket++asyncTransmitterF' socket =+    -- Start in idle mode+    ioF idleK+  where+    -- To be called while in idle mode only:+    idleK = getMsg (const idleK) high+      where+	high "" = closeK+	high str = goBlockedK (buf1 str)++    -- To swich from blocked to idle mode:+    goIdleK = select [] $ idleK++    -- To switch from idle mode to blocked mode:+    goBlockedK buf =+      select [OutputSocketDe socket] $+      blockedK buf initblocksize++    -- To be called while in blocked mode only:+    blockedK buf n = getMsg low high+      where+        low (DResp (AsyncInput (_,SocketWritable))) = writeK buf n+	high str = blockedK (putbuf buf str) n++    -- To be called while in blocked mode, when socket becomes writable:+    writeK buf n =+      case getbuf buf n of+        Empty -> goIdleK+	EoS   -> closeK+	More ps buf' -> sIOerr (WriteSocketPS socket ps) errK okK+	  where+	    okK (Wrote n')  = blockedK buf' n+	    errK _          = blockedK buf' n -- Ignore errors?!++    closeK =+      select [] $+      --sIOsucc (CloseSocket socket) $+      -- Can't close the socket until the receiver (if any) has deselected it!+      putHigh () $+      nullK++closerF socket =+  getHigh $ \ _ ->+  sIOsucc (CloseSocket socket) $+  nullF++getMsg l h = getK $ message l h++data Buffer = Buf String (QUEUE String)+data GetBuf = More PS.PackedString Buffer | Empty | EoS++--buf0 = Buf "" empty+buf1 str = Buf str empty -- pre: str/=""++putbuf (Buf s q) str = Buf s (enter q str) -- str=="" to indicate eos++getbuf (Buf s q) n = getbuf' s q+  where+    getbuf' "" q =+      case qremove q of+        Nothing -> Empty+	Just (s,q') ->+	  if null s+	  then EoS+	  else getbuf'' s q'++    getbuf' s q = getbuf'' s q++    getbuf'' s q =+      case splitAt n s of+        (s1,s2) -> More (PS.packString s1) (Buf s2 q)+++initblocksize = 512 :: Int++#if defined(__GLASGOW_HASKELL__) || defined(__PFE__)+nullPS = PS.nullPS+#else+nullPS = PS.null+#endif
+ hsrc/io/HaskellIO.hs view
@@ -0,0 +1,63 @@+module HaskellIO{-(hIOSucc, hIOSuccK, hIOSuccF,+	         hIO, hIOK, hIOF,+	         hIOerr, hIOerrK, hIOerrF,+	         haskellIO, haskellIOK, haskellIOF)-} where+import Prelude hiding (IOError)+--import Command+--import Cont(cmdContF)+import FudgetIO+import NullF(F)+import FRequest+--import Event+--import Fudget+--import Message(Message(..))+import ShowFailure+--import Sockets+--import Xtypes+import DialogueIO++hIOSucc req = hIO req . const++hIOerr req fcont scont =+  haskellIO req $ \ resp ->+  case resp of+    Failure f -> fcont f+    _ -> scont resp++haskellIO request = cmdContLow (DReq request) expected+  where+    expected (DResp response) = Just response+--  expected (SResp sresp) = Just (SocketResponse sresp) -- for backward compat+    expected _ = Nothing++hIO req = hIOerr req (\e -> error ("IOError: " ++ showFailure e))++------++haskellIOF :: Request -> (Response -> F a b) -> F a b+haskellIOF = haskellIO++hIOerrF :: Request -> (IOError -> F a b) -> (Response -> F a b) -> F a b+hIOerrF = hIOerr++hIOF :: Request -> (Response -> F a b) -> F a b+hIOF = hIO++hIOSuccF :: Request -> (F a b) -> F a b+hIOSuccF = hIOSucc++{---++haskellIOK :: Request -> (Response -> K a b) -> K a b+haskellIOK = haskellIO++hIOerrK :: Request -> (IOError -> K a b) -> (Response -> K a b) -> K a b+hIOerrK = hIOerr++hIOK :: Request -> (Response -> K a b) -> K a b+hIOK = hIO++hIOSuccK :: Request -> (K a b) -> K a b+hIOSuccK = hIOSucc++---}
+ hsrc/io/InOut.hs view
@@ -0,0 +1,17 @@+module InOut (-- * IO+  module HaskellIO,module StdIoUtil,module IoF,module Socketio,module OpenSocket,module Transceivers,module AsyncTransmitter,module TimerF,module ReadFileF,module WriteFile,module AppStorage,module Process,module UnsafeGetDLValue,module GetTime,module GetModificationTime) where+import HaskellIO+import StdIoUtil+import IoF+import Socketio+import OpenSocket+import Transceivers+import AsyncTransmitter+import TimerF+import ReadFileF+import WriteFile+import AppStorage+import Process+import UnsafeGetDLValue+import GetTime -- compiler dependent!+import GetModificationTime -- compiler dependent!
+ hsrc/io/IoF.hs view
@@ -0,0 +1,14 @@+module IoF(ioF) where+--import Command(Command(..), XCommand)+--import Direction+--import Event(Event(..))+--import Fudget+--import Geometry(Line(..), Point(..), Rect(..), Size(..))+--import Message(Message)+--import Path(Path(..))+--import SP+import WindowF(kernelF)+--import Xtypes(WindowAttributes)++ioF = kernelF+
+ hsrc/io/OpenSocket.hs view
@@ -0,0 +1,28 @@+module OpenSocket(+  openSocketF,openSocketErrF,+  openLSocketF,openLSocketErrF,+  openFileAsSocketF,openFileAsSocketErrF+  ) where+import Srequest+import Sockets++-- All eta expanstion are due to the monomorphism restriction++openSocketF h = openSocketF' sIO h+openLSocketF p = openLSocketF' sIO p+openFileAsSocketF h = openFileAsSocketF' sIO h++openSocketErrF h p e = openSocketF' (sIOerr' e) h p+openLSocketErrF p e = openLSocketF' (sIOerr' e) p+openFileAsSocketErrF n m e = openFileAsSocketF' (sIOerr' e) n m++openSocketF' sio host port cont =+  sio (OpenSocket host port) $ \ (Socket socket) -> cont socket++openLSocketF' sio port cont =+  sio (OpenLSocket port) $ \(LSocket lsocket) -> cont lsocket++openFileAsSocketF' sio name mode cont =+  sio (OpenFileAsSocket name mode) $ \ (Socket socket) -> cont socket++sIOerr' e r = sIOerr r e
+ hsrc/io/Process.hs view
@@ -0,0 +1,15 @@+module Process where+--import Fudget+--import Xtypes+import Srequest+import NullF()+--import FudgetIO+import Sockets+import Transceivers+import CompOps+--import DialogueIO hiding (IOError)++subProcessF cmd =+  sIO (StartProcess cmd True True True) $+     \ (ProcessSockets (Just sin) (Just sout) (Just serr)) ->+     (receiverF sout>+<receiverF serr)>==<transmitterF sin
+ hsrc/io/ReadFileF.hs view
@@ -0,0 +1,40 @@+module ReadFileF(readFileF,readBinaryFileF,readXdgFileF,readDirF) where+import Fudget() -- synonym KEvent, for hbc+import NullF+import FudgetIO+import IoF(ioF)+import HaskellIO(haskellIO)+import Message(Message(..))+import DialogueIO hiding (IOError)++readFileF = ioF readFileK+readBinaryFileF = ioF readBinaryFileK+readXdgFileF = ioF . readXdgFileK++readFileK = readFileK' ReadFile+readBinaryFileK = readFileK' ReadBinaryFile+readXdgFileK = readFileK' . ReadXdgFile++readFileK' req =+  getK $ \ msg ->+  case msg of+    High filename ->+      haskellIO (req filename) $ \ resp ->+      putHigh (filename,case resp of+                          Str s -> Right s+		          Failure err -> Left err)+      readFileK+    _ -> readFileK++readDirF = ioF readDirK++readDirK =+  getK $ \ msg ->+  case msg of+    High dirname ->+      haskellIO (ReadDirectory dirname) $ \ resp ->+      putHigh (dirname,case resp of+		         StrList filenames -> Right filenames+			 Failure err -> Left err)+      readDirK+    _ -> readDirK
+ hsrc/io/Socketio.hs view
@@ -0,0 +1,34 @@+module Socketio where+import Fudget+import FudgetIO+import FRequest+import Srequest+--import Message(Message(..))+import NullF+import Sockets+import Utils(loop)+--import Xtypes+import DialogueIO hiding (IOError)++transmitterF' s =+  loop $ \l -> getF $ \str ->+  if null str+  then putHigh () nullF+  else sIOsucc (WriteSocket s str) l++receiverF' s =+    select [SocketDe s] $+    loop $ \l ->+          getMessageFu $ \e ->+           case e of+             Low (DResp (AsyncInput (_, SocketRead str))) ->+	       if null str+	       then closeDown+	       else putF str l+             High _ -> closeDown+  where+    closeDown =+      select [] $+      putHigh "" $+      sIOsucc (CloseSocket s) $+      nullF
+ hsrc/io/StdIoUtil.hs view
@@ -0,0 +1,60 @@+module StdIoUtil(linesSP, inputLinesSP, echoK, echoStderrK,+          appendChanK, appendStdoutK, appendStderrK,+          outputF, stdioF, stderrF, stdoutF, stdinF) where+--import Command+import CompOps((>==<))+import CompSP(serCompSP)+--import Event+import HaskellIO(hIOSucc)+import Srequest+import IoF+import Message(message)+import Transceivers(receiverF)+import Sockets+import Spops+--import Xtypes+import Fudget+--import FudgetIO+import NullF(getK{-,F,K-})+import ContinuationIO(stdout,stderr)+import DialogueIO hiding (IOError)++stdoutF = outputF stdout+stderrF = outputF stderr+stdioF = stdinF >==< stdoutF++outputF :: String -> F String a+outputF = ioF . outputK++stdinF = sIO GetStdinSocket $ \ (Socket s) -> receiverF s++{-+outputK chan =+    let f msg =+            case msg of+              High s -> [Low (DoIO (AppendChan chan s))]+              _ -> []+    in  concmapSP f+-}++outputK chan =+  getK $ message (const $ outputK chan) $ \ s ->+  appendChanK chan s $+  outputK chan++appendChanK chan s = hIOSucc (AppendChan chan s)++appendStdoutK s = appendChanK stdout s+appendStderrK s = appendChanK stderr s+echoK         s = appendStdoutK (s ++ "\n")+echoStderrK   s = appendStderrK (s ++ "\n")++linesSP = lnSP []+  where+    lnSP acc =+      getSP $ \msg ->+      case msg of+        '\n' -> putSP (reverse acc) (lnSP [])+	c    -> lnSP (c : acc)++inputLinesSP = linesSP `serCompSP` concatSP -- inefficient!!!
+ hsrc/io/TimerF.hs view
@@ -0,0 +1,37 @@+module TimerF(timerF,Tick(..)) where+import Fudget+import FudgetIO+import FRequest+import Srequest(sIO,sIOsucc,select)+--import Message(Message(..))+import NullF+import Sockets+--import Xtypes+import DialogueIO hiding (IOError)++data Tick = Tick deriving (Show,Eq)++--timerF :: F (Maybe (Int,Int)) Tick+timerF =  f Nothing+  where+    f oTno =+      getMessageFu $ \ msg ->+      let same = f oTno+	  settimer int first = case oTno of+	    Just _ -> same+	    Nothing ->+	      sIO (CreateTimer int first) $ \ (Timer tno) ->+	      -- error handling?!+	      select [TimerDe tno] $+	      f (Just tno)+	  removetimer = case oTno of+		Just tno -> sIOsucc (DestroyTimer tno) $+			    select [] $+			    f Nothing+		Nothing -> same+      in case msg of+	   High (Just (interval, first)) -> settimer interval first+	   High Nothing -> removetimer+	   Low (DResp (AsyncInput (_, TimerAlarm))) ->+	     putHigh Tick $+	     same
+ hsrc/io/Transceivers.hs view
@@ -0,0 +1,13 @@+module Transceivers where+import Socketio+import AsyncTransmitter+import CompOps((>==<),(>=^^<))+import Spops(nullSP)++transmitterF s = closerF s >==< transmitterF' s++receiverF s = receiverF' s >=^^< nullSP++transceiverF s = receiverF' s >==< transmitterF' s++asyncTransceiverF s = receiverF' s >==< asyncTransmitterF' s
+ hsrc/io/UnsafeGetDLValue.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE CPP #-}+module UnsafeGetDLValue where+import DLValue++--unsafeDLValue :: DLValue -> anytype+#if defined(__NHC__) || defined(__PFE__)+unsafeGetDLValue DLValue = error "unsafeGetDLValue not implemented yet"+#else+unsafeGetDLValue (DLValue v) = v+#endif++-- This is unsafe, because the response from DLSym contains a DLValue of+-- a particular type. unsafeGetDLValue allows it to be used at any type.
+ hsrc/io/WriteFile.hs view
@@ -0,0 +1,18 @@+module WriteFile where+import HaskellIO(haskellIOF)+--import CompOps((>^=<))+import Cont(contMap)+--import NullF+import DialogueIO hiding (IOError)++writeFileF = writeFileF' WriteFile+writeXdgFileF = writeFileF' . WriteXdgFile++writeFileF' write = contMap wr+    where+      wr (file,contents) cont =+        haskellIOF (write file contents) $ \ resp ->+	cont (file,post resp)++      post (Failure e) = Left e+      post Success = Right ()
+ hsrc/kernelutils/BgF.hs view
@@ -0,0 +1,21 @@+module BgF(changeBackPixel, changeGetBackPixel) where+--import Color+import Command+--import Fudget+--import FudgetIO+--import Message(Message(..))+import Xcommand+--import NullF+import Xtypes+--import HaskellIO+import GCAttrs++--changeGetBackPixel :: ColorName -> Cont (K a b) Pixel+changeGetBackPixel bgcol f =+    --allocNamedColorDefPixel defaultColormap bgcol "white" $ \bgp ->+    convColorK [colorSpec bgcol,colorSpec "white"] $ \ bgp ->+    xcommandK (ChangeWindowAttributes [CWBackPixel bgp]) $+    xcommandK clearWindowExpose $+    f bgp++changeBackPixel bgcol = changeGetBackPixel bgcol . const
+ hsrc/kernelutils/GetVisual.hs view
@@ -0,0 +1,9 @@+module GetVisual where+import Command(XRequest(..))+import Event(XResponse(..))+import Xrequest(xrequest)++defaultVisual cont = xrequest DefaultVisual gotit cont+  where gotit (GotVisual v) = Just v+        gotit _ = Nothing+
+ hsrc/kernelutils/GetWindowProperty.hs view
@@ -0,0 +1,19 @@+module GetWindowProperty(getWindowPropertyK,getGeometryK) where+import Command+import Event+--import Font(FontStruct)+--import Fudget+--import Geometry(Line, Point, Rect, Size(..))+--import LayoutRequest(LayoutRequest)+--import Path(Path(..))+import Xrequest+--import Xtypes++getWindowPropertyK offset prop delete req_type =+    let gotit (GotWindowProperty typ format nitems after str) =+            Just (typ, format, nitems, after, str)+        gotit _ = Nothing+    in  xrequestK (GetWindowProperty offset prop delete req_type) gotit++getGeometryK = xrequestK GetGeometry+   (\r -> case r of GotGeometry r bw d -> Just (r,bw,d); _ -> Nothing)
+ hsrc/kernelutils/GreyBgF.hs view
@@ -0,0 +1,85 @@+module GreyBgF(changeBg, darkGreyBgK, lightGreyBgK, greyBgK, knobBgK, changeBackPixmap) where+import BgF(changeBackPixel)+import Color+import Command+import XDraw+--import Event(XEvent,BitmapReturn)+import Fudget+--import FudgetIO+import Xcommand+import Gc+import Geometry(Rect(..), lL, pP)+--import LayoutRequest(LayoutRequest)+--import Message(Message(..))+--import NullF+import Pixmap+import Cont(tryM)+import Xtypes+import GCAttrs(convColorK) -- + instances++--changeBackPixmap :: ColorName -> ColorName -> Size -> [DrawCommand] -> (K a b) -> K a b+changeBackPixmap fgcol bgcol size draw f =+    convColorK fgcol $ \fg ->+    convColorK bgcol $ \bg ->+    changeBackPixmapCol fg bg size draw f++changeBackPixmapCol fg bg size draw f =+    createPixmap size copyFromParent $ \pm ->+    wCreateGC rootGC [{-GCFunction GXcopy,-}+                      GCForeground fg, GCBackground bg,+		      GCGraphicsExposures False] $ \gc ->+    wCreateGC gc [GCForeground bg] $ \gcbg ->+    xcommandsK [DrawMany (Pixmap pm)+                  [(gcbg,[FillRectangle (Rect (pP 0 0) size)]),+		   (gc, draw)],+		ChangeWindowAttributes [CWBackPixmap pm],+		clearWindowExpose,+		FreePixmap pm]+    f++knobBgK cont =+    try2 "grey33" "black" $ \ (Color fg _) ->+    try2 "grey" "white" $ \ (Color bg  _) ->+    changeBackPixmapCol fg bg (pP 8 8)+                        [DrawLine (lL 0 0 2 2), DrawLine (lL 4 6 6 4)] cont++dithered50BgK fg bg =+  changeBackPixmapCol fg bg (pP 2 2) [DrawLine (lL 0 0 1 1)]++dithered25BgK fg bg =+  changeBackPixmapCol fg bg (pP 2 2) [DrawLine (lL 0 0 0 0)]++dithered75BgK fg bg = dithered25BgK bg fg++trySolidGreyBgK cname dithK cont =+  alloc3 cname $ \ (Color black b) (Color white w) (Color gray g) ->+  if g==b || g==w+  then dithK white black cont+  else xcommandsK [ChangeWindowAttributes [CWBackPixel gray],+                   clearWindowExpose] $+       cont++greyBgK = trySolidGreyBgK "grey" dithered50BgK+darkGreyBgK = trySolidGreyBgK "dark grey" dithered25BgK+lightGreyBgK = trySolidGreyBgK "light grey" dithered75BgK++changeBg :: ColorName -> (K a b) -> K a b+changeBg bg =+  case bg of+    "Nothing" -> id+    "grey" -> greyBgK+    _ -> changeBackPixel bg++alloc3 colorname cont =+    allocNamedColor defaultColormap "black" $ \black ->+    allocNamedColor defaultColormap "white" $ \white ->+    tryAllocNamedColor defaultColormap colorname $ \ ocolor ->+    let color = case ocolor of+	         Nothing -> black+		 Just c -> c in+    cont black white color+    +try2 cname1 cname2 cont =+  tryM (tryAllocNamedColor defaultColormap cname1)+       (allocNamedColor defaultColormap cname2 cont)+       cont
+ hsrc/kernelutils/InternAtom.hs view
@@ -0,0 +1,35 @@+module InternAtom(internAtomK, internAtomF, internAtom,+                  atomNameK, atomNameF, atomName) where+import Command+import Event+--import Font(FontStruct)+--import Fudget+--import Geometry(Line, Point, Rect, Size(..))+--import LayoutRequest(LayoutRequest)+import Xrequest+--import Xtypes++internAtomK = ia xrequestK++internAtomF = ia xrequestF++internAtom a e = ia xrequest a e++ia k atomNm ifExists =+    let gotit (GotAtom atom) = Just atom+        gotit _ = Nothing+    in  k (InternAtom atomNm ifExists) gotit++atomNameK = an xrequestK++atomNameF = an xrequestF++atomName a = an xrequest a++-- Here we need a Maybe String, so add an extra Just (the inner Just+-- is stripped by the fudlogue).++an k atom = +    let gotit (GotAtomName (Just s)) = Just (Just s)+        gotit _ = Nothing+    in  k (GetAtomName atom) gotit
+ hsrc/kernelutils/KernelUtils.hs view
@@ -0,0 +1,14 @@+module KernelUtils (-- * Kernel utilities+  module BgF,module GetWindowProperty,module GreyBgF,module InternAtom,module ParK,module QueryPointer,module QuitK,module ShapeK,module SimpleF,module QueryTree,module GetVisual,module MapstateK) where+import BgF+import GetWindowProperty+import GreyBgF+import InternAtom+import ParK+import QueryPointer+import QuitK+import ShapeK+import SimpleF+import QueryTree+import GetVisual+import MapstateK
+ hsrc/kernelutils/MapstateK.hs view
@@ -0,0 +1,5 @@+module MapstateK where+import Fudget+import Spops(mapstateSP)++mapstateK f s = K $ mapstateSP f s
+ hsrc/kernelutils/ParK.hs view
@@ -0,0 +1,52 @@+module ParK(parK,compK) where+--import Command(Command(..))+import CompSP+--import Event(Event(..))+import Fudget+--import Message(Message(..))+--import Path(Path(..))+--import SP+import Spops+import IsRequest+import CompFfun+import SpEither+++parK :: K a b -> K a b -> K a b+parK (K l) (K r) = K{-kk-} (parKSP l r)++parKSP :: KSP a b -> KSP a b -> KSP a b+parKSP l r = pkp [] (l `compEitherSP` r) where+   pkp routeq k = pk routeq (pullSP k)+   pk routeq (os,k) = pos os where+      pos os =+        case os of+         [] ->+	   getSP $ \msg ->+	   case msg of+	    Low e | isResponse e ->+	      case routeq of+	        [] -> pos [] -- response without request?+		r:routeq -> feed routeq [r msg]+            _ -> feedr [Left msg, Right msg]+           where feed routeq l = pkp routeq (startupSP l k)+		 feedr = feed routeq+	 o:os -> case o of+		   Right (High a) -> out (High a)+		   Left (High a) -> out (High a)+		   Right (Low c) -> lowout c Right+		   Left (Low c) -> lowout c Left+           where+             lowout c route =+	       putSP (Low c) $ +	       if isRequest c+	       then pk (routeq++[route]) (os,k)+	       else pos os+             out m = putSP m $ pos os++compK :: K a b -> K c d -> K (Either a c) (Either b d)+compK (K l) (K r) = K{-kk-} (compKSP l r)++compKSP :: KSP a b -> KSP c d -> KSP (Either a c) (Either b d)+compKSP l r = parKSP (Left `postMapHigh'` l `preProcessHigh'` filterLeftSP)+		     (Right `postMapHigh'` r `preProcessHigh'` filterRightSP)
+ hsrc/kernelutils/QueryPointer.hs view
@@ -0,0 +1,15 @@+module QueryPointer(queryPointerK) where+import Command+import Event+--import Font(FontStruct)+--import Fudget+--import Geometry(Line, Point, Rect, Size(..))+--import LayoutRequest(LayoutRequest)+import Xrequest+--import Xtypes++queryPointerK =+    let f (PointerQueried s r w m) = Just (s, r, w, m)+        f _ = Nothing+    in  xrequestK QueryPointer f+
+ hsrc/kernelutils/QueryTree.hs view
@@ -0,0 +1,45 @@+module QueryTree where+import Command+import Event+--import Font(FontStruct)+--import Fudget+--import Geometry(Line, Point, Rect, Size(..))+--import LayoutRequest(LayoutRequest)+--import Path(Path(..))+import Xrequest+--import Xtypes++queryTreeK = +    xrequestK QueryTree gotit+  where+    gotit (TreeQueried r p cs) = Just (r,p,cs)+    gotit _ = Nothing++queryTreeF = +    xrequestF QueryTree gotit+  where+    gotit (TreeQueried r p cs) = Just (r,p,cs)+    gotit _ = Nothing++{-+(defaultRootWindowK,defaultRootWindowF) =+    (xrequestK DefaultRootWindow gotit,xrequestF DefaultRootWindow gotit)+  where+    gotit (GotDefaultRootWindow w) = Just w+    gotit _ = Nothing++Doesn't work???+-}++defaultRootWindowK = +    xrequestK DefaultRootWindow gotit+  where+    gotit (GotDefaultRootWindow w) = Just w+    gotit _ = Nothing++defaultRootWindowF = +    xrequestF DefaultRootWindow gotit+  where+    gotit (GotDefaultRootWindow w) = Just w+    gotit _ = Nothing+
+ hsrc/kernelutils/QuitK.hs view
@@ -0,0 +1,61 @@+module QuitK where+import Command+import Event+import Fudget+--import FudgetIO+import FRequest+import Xcommand+import HaskellIO(haskellIO)+import InternAtom+--import Message(Message(..))+import NullF+import Spops(nullSP)+import CompFfun(postProcessHighK,preProcessHighK)+--import Sockets+import Xtypes+import DialogueIO hiding (IOError)++quitK action =+   nullSP `postProcessHighK`+   wmK (Just action)+   `preProcessHighK` nullSP++-- (*) wmK always enables the WM_DELETE_WINDOW protocol, since some window+-- managers provide a close button that destroy the window if the protocol+-- is disabled. Sigh.++wmK optAction =+    wmDeleteWindowK $ \dw -> -- (*)+    case optAction of+      Just action ->+        -- wmDeleteWindowK $ \dw -> -- (*)+    	internAtomK "WM_PROTOCOLS" False $ \ pr ->+    	wmK' (lowHandler action pr dw)+      Nothing -> wmK' (const id)+  where+    lowHandler action pr dw event =+      case event of+	XEvt (ClientMessage a (Long (p : _))) | a == pr && Atom (fromIntegral p) == dw ->+	  action +        _ -> id++    wmK' lowHandler = loop+      where+	loop =+	  getK $ \msg ->+	  case msg of+	    Low event -> lowHandler event loop+	    High (Left title) -> xcommandK (StoreName title) loop+	    High (Right True) -> xcommandK MapRaised loop+	    High (Right False) -> unmapWindowK loop+	    _ -> loop++-- Some handlers:+exitK cont = haskellIO (Exit 0) (const nullK)+unmapWindowK = xcommandK UnmapWindow+reportK = putK (High ())++wmDeleteWindowK cont =+    internAtomK "WM_DELETE_WINDOW" False $ \dw ->+    xcommandK (SetWMProtocols [dw]) $+    cont dw
+ hsrc/kernelutils/ShapeK.hs view
@@ -0,0 +1,55 @@+module ShapeK(dynShapeK, shapeK) where+import Command(XCommand(FreeGC,FreePixmap,ShapeCombineMask,DrawMany))+import XDraw+import CompFfun(prepostMapHigh')+import Convgc+--import Event+import LayoutRequest(LayoutResponse(..))+import FRequest+import Gc+import Fudget+--import FudgetIO+import Xcommand+import NullF+import ParK+import Pixmap+import EitherUtils(stripEither)+import Data.Maybe(fromJust)+import Geometry(pP,Rect(..),origin,Size)+import Xtypes++dynShapeK gcattrs shapeCmds f = compK (shapeK1 gcattrs shapeCmds) f++shapeK :: (Size -> [DrawCommand]) -> K a b -> K a b+shapeK shapeCmds f =+    K{-kk-} (prepostMapHigh' Right stripEither dk)+  where+    K dk = dynShapeK [] shapeCmds f++shapeK1 gcattrs shape =+    convGCattrsK gcattrs (\gcattrs' -> shapeP gcattrs' shape Nothing)++shapeP gcattrs shape size =+    let reshape shape' size' =+          createPixmap size' 1 $ \pm ->+	  pmCreateGC pm rootGC [GCFunction GXcopy, GCForeground pixel0] $ \gcclr ->+	  pmCreateGC pm gcclr (GCForeground pixel1 :+                               GCBackground pixel0 :+                               gcattrs) $ \gc ->+	  xcommandsK [drawshape pm size' shape' gc gcclr,+	              ShapeCombineMask ShapeBounding (pP 0 0) pm ShapeSet,+		      FreePixmap pm,+		      FreeGC gcclr,+		      FreeGC gc] $+	  shapeP gcattrs shape' (Just size')+    in getK $ \msg ->+       case msg of+         Low (LEvt (LayoutSize size')) -> reshape shape size'+	 High shape' | size /= Nothing -> reshape shape' (fromJust size)+	 _ -> shapeP gcattrs shape size++drawshape pm size shapeCmds gc gcclr =+    DrawMany (Pixmap pm) [+      (gcclr,[FillRectangle (Rect origin size)]),+      (gc,shapeCmds size)]+
+ hsrc/kernelutils/SimpleF.hs view
@@ -0,0 +1,48 @@+module SimpleF(Drawer(..), Fms'(..), MapState(..), simpleF, simpleWindowF, simpleK) where+import Color+import Command+import XDraw+import Dlayout(windowF)+import DShellF+--import FDefaults+--import Event+import Fudget+import FudgetIO+import FRequest+--import Xcommand+import Gc+import Geometry(Size)+import LayoutRequest+--import Message(Message(..))+--import NullF+--import Spops+import MapstateK+import Xtypes++type MapState a b c = a -> b -> (a, c)++type Fms' a b c = MapState a (KEvent b) [KCommand c]++type Drawer = DrawCommand -> FRequest++simpleK k size s0 = simpleK' k size True True s0++simpleK' :: (Drawer->Drawer->Fms' a b c) -> Size -> Bool -> Bool -> a -> K b c+simpleK' k size fixedh fixedv s0 =+    allocNamedColorPixel defaultColormap "black" $ \fg ->+    allocNamedColorPixel defaultColormap "white" $ \bg ->+    wCreateGC rootGC [GCFunction GXcopy,GCForeground fg,GCBackground bg] $ \fgc ->+    wCreateGC fgc [GCForeground bg] $ \bgc ->+    putLow (layoutRequestCmd (plainLayout size fixedh fixedv)) $+    mapstateK (k (wDraw fgc) (wDraw bgc)) s0++simpleF title k size s0 =+    shellF title $+    simpleWindowF k size False False s0++simpleWindowF k size fh fv s0 =+    windowF [XCmd $ ChangeWindowAttributes [CWEventMask eventmask]] $+    simpleK' k size fh fv s0+  where+    eventmask = [ExposureMask, KeyPressMask, KeyReleaseMask, ButtonPressMask,+                 ButtonReleaseMask]
+ hsrc/layout/AlignP.hs view
@@ -0,0 +1,35 @@+module AlignP where+--import Alignment(Alignment(..))+--import Geometry(Line(..), Point(..), Rect(..), Size(..), padd, psub, rR)+--import LayoutDir(LayoutDir)+import LayoutRequest+import Utils(mapPair, number, swap)+import HbcUtils(apSnd)+import List2(sort)+--import Spacers++-- placer operations++idP :: Placer+idP = P $ \ [req] -> (req, (: []))++--revP :: Placer -> Placer+revP = mapP revP'+  where revP' placer = apSnd (reverse .) . placer . reverse++mapP f (P p) = P (f p)++flipP :: Placer -> Placer+flipP = mapP flipP'+  where+    flipP' placer = mapPair (flipReq,flipP2) . placer . map flipReq+    flipP2 p2 = map flipRect.p2.flipRect++permuteP :: [Int] -> Placer -> Placer+permuteP perm = mapP permuteP'+  where+    permuteP' placer = apSnd (rpermf .) . placer . fpermf+    rperm = (map snd . sort . map swap . number 0) perm+    fpermf = permf perm+    rpermf = permf rperm+    permf perm xs = map (xs!!) perm
+ hsrc/layout/Alignment.hs view
@@ -0,0 +1,12 @@+module Alignment where++type Alignment = Double++aTop = 0 :: Alignment+aBottom = 1 :: Alignment++aLeft = 0 :: Alignment+aRight = 1 :: Alignment++aCenter = 0.5 :: Alignment+
+ hsrc/layout/AutoLayout.hs view
@@ -0,0 +1,352 @@+{-# LANGUAGE CPP #-}+module AutoLayout(autoLayoutF,autoLayoutF',nowait) where+--import Prelude hiding (IO)+import LayoutRequest(LayoutMessage(..),LayoutResponse(..),LayoutRequest(minsize),LayoutHint,Spacer,Placer(..),Placer2,unS)+import LayoutDoNow+import PathTree hiding (pos)+import Geometry(Rect)+import Fudget+--import Spops+--import FudgetIO+import NullF(getK,putK,putsK) --,F,K+import Loops(loopThroughRightF)+import UserLayoutF+--import Xtypes+--import Event+--import Command+import FRequest+--import Path+import Direction+--import Placers+--import LayoutDir(LayoutDir)+--import CompOps+import IoF(ioF)+import CmdLineEnv(argFlag)+--import EitherUtils()+import Data.Maybe(isJust)+import HbcUtils(apFst,apSnd)+import Spacers(idS,compS,spacerP)+import AutoPlacer(autoP)+import SizingF+#ifdef __NHC__+import qualified Sizing+#else+import qualified Sizing(Sizing(..))+#endif+--import ContinuationIO(stderr)++-- debugging:+import StdIoUtil(echoStderrK)+--import NonStdTrace(trace)+--import Maptrace(ctrace)+--import SpyF++debugK :: String -> K hi ho -> K hi ho+debugK =+    if dbg+    then \ msg -> echoStderrK ("AutoLayout: "++msg)+    else const id+  where+    dbg = argFlag "ad" False++type LayoutTree = PathTree LayoutInfo++mapLT lf nf = mapPathTree (mapLayoutInfo lf nf)++top0 = Node (NodeInfo (Just "top",NoPlacerInfo)) Tip Tip++data LayoutInfo+  = NodeInfo NodeInfo+  | LeafInfo LeafInfo -- only in leaves+  deriving (Show)++mapLayoutInfo lf nf n = case n of+     NodeInfo n -> NodeInfo (nf n)+     LeafInfo l -> LeafInfo (lf l)++type LeafInfo = (LayoutRequest,Maybe Rect)+  -- (Layout s fh fv,Nothing) : received layout req, layout not computed+  -- (Layout s fh fv,Just rect) : rect is current placement.++type NodeInfo = ((Maybe LayoutHint), PlacerInfo)++data PlacerInfo =+   NoPlacerInfo |+   JustSpacer Spacer |+   SpacerPlacer Spacer Placer (Maybe Placer2) Spacer +  deriving (Show)++data PlacementState+  = Placed (Rect->Rect)+  | Waiting +  deriving (Show)++autoLayoutF = autoLayoutF' nowait Sizing.Dynamic++nowait = argFlag "nowait" False++autoLayoutF' :: Bool -> Sizing.Sizing -> F a b -> F a b+autoLayoutF' nowait sizing fud =+    loopThroughRightF +      (userLayoutF (layoutDoNow fud)) +      ({- spyF -} (sizingF sizing (ioF (autoLayoutMgrK0 state0 top0))))+	-- Note that the sizingF filter is not wrapped around fud and hence+	-- does not have to examine all commands and events!+  where+    state0 = if nowait then Placed id else Waiting++autoLayoutMgrK0 pstate ltree =+  debugK "autoLayoutMgrK" $+  autoLayoutMgrK pstate ltree++autoLayoutMgrK pstate ltree =+    --echoK (show (pstate,ltree)) $+    getK $ \ msg ->+    case msg of+      High (path,layoutmsg) ->+        case layoutmsg of+	  LayoutDoNow ->+	    debugK "LayoutDoNow" $+	    debugK (show ltree) $+	    newPlace ltree+	  LayoutRequest req ->+	       debugK (show path ++ " Layout "++show (minsize req)) $+	       debugK (show ltree') $+	       changePlacement ltree'+	    where ltree' = updateLeaf path req ltree''+	          ltree'' = if newBox ltree path+		            then forgetPlaces ltree+			    else ltree+	  -- LayoutHint & LayoutPlacer are only sent during initialisation.+	  -- They will be received before any child Layout requests.+	  LayoutHint hint ->+	    debugK (show path ++ " LayoutHint "++ show hint) $+	    updnode (insertHint hint)+	  LayoutPlacer placer ->+	    debugK (show path ++ " LayoutPlacer ...") $+	    updnode (insertPlacer placer)+	  LayoutSpacer spacer ->+	    debugK (show path ++ " LayoutSpacer ...") $+	    updnode (insertSpacer spacer)+	  -- LayoutReplaceSpacer is sent by dynSpacerF.+	  LayoutReplaceSpacer spacer ->+	    debugK (show path ++ " LayoutReplaceSpacer ...") $+	    replnode (replaceSpacer spacer)+	  LayoutReplacePlacer placer ->+	    debugK (show path ++ " LayoutReplacePlacer ...") $+	    replnode (replacePlacer placer)+	  LayoutDestroy -> +	    debugK (show (path,ltree) ++ " LayoutDestroy") $+	    -- should check if the subtree contains anything but hints.+	    if newBox ltree path then debugK ("not in tree") same else+	    changePlacement (forgetPlaces (pruneLTree path ltree))+	      -- !! forgetPlaces should be called when the structure changes,+	      -- but not when an existing fudget requests a new size...+	  LayoutMakeVisible _ _ -> putK (Low (LCmd layoutmsg)) $ same+	  LayoutScrollStep  _ -> putK (Low (LCmd layoutmsg)) $ same+	  _ -> same -- !!! handle other layout requests?!+        where updnode  u = newTree (updateLNode path u ltree)+	      replnode u = changePlacement (forgetPlaces (updateLNode path u ltree))+      Low (LEvt (LayoutPlace rect)) ->+          debugK ("splitting 1 Place into "++show (length msgs)) $+          putsK (map High msgs) $+	  newTree ltree'+	where (ltree',msgs) = doLayout (s2 rect) ltree+	      s2 = case pstate of+			Placed s2 -> s2+			_ -> id+      Low _ -> debugK "Ignored low level msg" same+  where+    same = autoLayoutMgrK pstate ltree+    newTree t' = newState pstate t'+    newState p' t' = autoLayoutMgrK p' t'+    changePlacement ltree' =+      case pstate of+        Placed _ -> newPlace ltree'+	Waiting -> newTree ltree'+    newPlace ltree =+      let ltree' = chooseLayout ltree+      in case collectReqs ltree' of+           ([],_) -> debugK "newPlace without any requests in ltree" same+	   ((req,s2):_,ltree2) ->+	     putK (Low (layoutRequestCmd req)) $+	     newState (Placed s2) ltree2++updateLNode path i t = updateNode id emptyNode t path $+     \(NodeInfo ni) -> NodeInfo (i ni)++insertHint hint (_,pi) = (case pi of+	   SpacerPlacer _ _ _ _ -> Nothing+	   _ -> Just hint,pi)++insertPlacer placer (hint,pi) = (Nothing,case pi of+   NoPlacerInfo -> SpacerPlacer idS placer Nothing idS+   JustSpacer s -> SpacerPlacer s placer Nothing idS+   SpacerPlacer s1 p _ s2 -> SpacerPlacer (s1 `compS` s2) (p `compP` placer)+			           Nothing idS)+     where compP :: Placer -> Placer -> Placer+	   compP (P p1) (P p2) = P $ \ reqs ->+	       let (req1,p1r) = p1 [req2]+	           (req2,p2r) = p2 reqs+	       in (req1,p2r.head.p1r)++insertSpacer spacer (hint,pi) = (hint,case pi of+   NoPlacerInfo -> JustSpacer spacer+   JustSpacer s -> JustSpacer (s `compS` spacer)+   SpacerPlacer s1 p p2 s2 -> SpacerPlacer s1 p p2 (s2 `compS` spacer))++replaceSpacer spacer (hint,pi) = (hint,pi')+  where+    pi' = case pi of+            NoPlacerInfo -> JustSpacer spacer+	    JustSpacer s -> JustSpacer spacer+	    SpacerPlacer s1 p p2 s2 -> SpacerPlacer spacer p p2 s2 -- hmm++replacePlacer placer (hint,pi) = (hint,pi')+  where+    pi' = case pi of+            NoPlacerInfo -> SpacerPlacer idS placer Nothing idS+	    JustSpacer s -> SpacerPlacer s placer Nothing idS+	    SpacerPlacer s1 p p2 s2 -> SpacerPlacer s1 placer Nothing s2++updateLeaf path l t =+  updateNode invalid emptyNode t path (const (LeafInfo (l,Nothing)))++pruneLTree path t = pruneTree invalid emptyNode t path++forgetPlaces = mapLT (apSnd (const Nothing)) id+ +newBox x = subTree (const False) True x++invalid (NodeInfo i) = NodeInfo (invalid' i)+  where+    invalid' (hi,SpacerPlacer s p p2 s2) = (hi,SpacerPlacer s p Nothing s2)+    invalid' ni = ni++emptyNode = NodeInfo (Nothing,NoPlacerInfo)++hasPlacer (Nothing,SpacerPlacer _ _ _ _) = True+hasPlacer _ = False++-- strip hints below placer, insert autoP where there are hints left+chooseLayout = snd . attrMapLT lf nf False where+  lf strip _ i = (strip,(),i)+  nf strip _ n = (strip',(),n') where+     strip' = case n of+	    (Nothing,SpacerPlacer _ _ _ _) -> True+	    _ -> strip --+     n' = if strip then n else choosePlacer n++choosePlacer i = case i of+   (hi@(Just _),pi) -> (hi,case pi of+     NoPlacerInfo -> SpacerPlacer idS autoP Nothing idS+     JustSpacer s -> SpacerPlacer s autoP Nothing idS+     p -> p)+   i -> i++attrMapLT lf nf = attrMapPathTree f where+   f i s a = case a of+     LeafInfo li -> a3 LeafInfo $ lf i s li+     NodeInfo ni -> a3 NodeInfo $ nf i s ni+   a3 c (i,s,b) = (i,s,c b)++collectReqs = apFst (flip compose []) . attrMapLT lf nf idS where+  lf s _ i@(req,oplace) = (s,reqf,i) where +       reqf = (unS s lr:)+       lr = case oplace of+{- -- You can use static sizing of shell windows instead of this:+	      Just (Rect _ currentsize) ->+		-- use current size, not originally requested size+		--ctrace "spacer" ("current",i) $+		mapLayoutSize (const currentsize) req+-}+	      _ -> --ctrace "spacer" ("nocurrent",i)+	           req+  nf s reqfs n@(hi,pi) = case pi of+       NoPlacerInfo -> (s,reqf,n)+       JustSpacer s1 ->+	 --ctrace "spacer" (fst ((s `compS` s1) (Layout origin False False))) $+	 (s `compS` s1,reqf,n)+       SpacerPlacer s1 p orp2 s2 ->+	  --ctrace "spacer" (n,fst (compp $ [Layout origin False False])) $ +	             (inherS,syntreq,n') where+		   rp2@(req2,p2) = compp `spacer2P` reqfl+		   reqfl = reqf []+		   compp = if hashint then p else sl `spacerP` p+		   inherS = if hashint then sl `compS` s2 else s2+		   syntreq = if null reqfl then id else (unS idS req2:)+		   sl = s `compS` s1+		   hashint = isJust hi+		   orp2' = if null reqfl then Nothing else Just rp2+		   n' = (hi,SpacerPlacer s1 p orp2' s2)+--	  Just (req,_) -> ctrace "spacer" (n,req) (s2,(idS req:),n)+    where reqf = compose reqfs++  compose = foldr (.) id++doLayout rect tree = runIO (doLayoutIO tree []) [rect]++spacer2P (P p) reqfs = (req,s2f.p2) where+   (reqs,s2s) = unzip reqfs+   s2f rs = [s2 r | (s2,r) <- zip s2s rs]+   (req,p2) = p reqs++doLayoutIO t path =+  case t of+    Tip -> returnIO t+    Node (LeafInfo (l,maybeOldRect)) _ _ ->+      getIO `bindIO` \ r ->+      putIO (reverse path,r) `thenIO` +         -- check if r is different from old rect?+      returnIO (Node (LeafInfo (l,Just r)) Tip Tip)+    Dynamic dt -> returnIO Dynamic `ap` dynDoLayoutIO dt path 0 1+    Node ni@(NodeInfo (_,pi)) lt rt ->+	case pi of+	  SpacerPlacer s1 p orp2  s2 ->+	    case orp2 of+	      Just (req,placer2) ->+		   getIO `bindIO` \ r ->+		   ungetIO (placer2 r) `thenIO`+		   doBranches+	      Nothing -> returnIO t -- no requests in this tree+	  _ -> doBranches+      where+        doBranches =+	  returnIO (Node ni) `ap` doLayoutIO lt (L:path)+	                      `ap` doLayoutIO rt (R:path)+++dynDoLayoutIO dt path n i =+  case dt of+    DynTip -> returnIO dt+    DynNode t lt rt ->+      returnIO DynNode `ap`+      doLayoutIO t (Dno (unpos n):path) `ap`+      dynDoLayoutIO lt path n (2*i) `ap`+      dynDoLayoutIO rt path (n+i) (2*i)++--++type IO' a i o = i -> o -> (a,(i,o))++runIO io i =+  let (a,(_,o)) = io i []+  in (a,o)++returnIO a i o = (a,(i,o))+putIO o1 is os = ((),(is,o1:os))+getIO (i:is) os  = (i, (is,os))+--getIO (i:is) os  = (Just i, (is,os))+--getIO []     os  = (Nothing,(is,os))+ungetIO is' is os = ((),(is'++is,os))++bindIO io1 xio2 i0 o0  =+  let (x,(i1,o2)) = io1 i0 o1+      (y,(i2,o1)) = xio2 x i1 o0+  in (y,(i2,o2))++thenIO f1 f2 = f1 `bindIO` const f2++fIO `ap` xIO = fIO `bindIO` \ f ->+               xIO `bindIO` \ x ->+	       returnIO (f x)
+ hsrc/layout/AutoPlacer.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE CPP #-}+module AutoPlacer(autoP,autoP') where+import LayoutRequest+import Geometry+import Placers(horizontalP',verticalP')+import Spacers() -- synonym Distance, for hbc+import AlignP(idP)+--import LayoutDir+import CmdLineEnv(argFlag)+import Defaults(defaultSep)+import Data.Ratio+import Debug.Trace(trace)++-- should get hints somehow+autoP = autoP' defaultSep++autoP' :: Size -> Placer+autoP' (Point hsep vsep) = P $ \ requests ->+ case requests of+   [] -> trace "autoP []" $ (plainLayout 1 True True, \ r -> [])+   [r] -> unP idP requests+   _ -> p where+        h2@(h,_) = unP (horizontalP' hsep) requests+	v2@(v,_) = unP (verticalP' vsep) requests+	p = if goodness h2 requests<goodness v2 requests+            then h2 else v2++{-+--godness : measure how good a layout is.+-- 1st: a layout is better if it uses less screen space.+-- 2nd: a layout is better if it is more quadratic +-- (rather than long and narrow)+goodness (Layout {minsize=Point x y}) = (x*y,x+y)+                                 -- (area, circumference of rect / 2)+-- This doesn't work, because of separation between fudgets...+-}++goodness =+  if argFlag "sg" False+  then \ p1 rs -> (1%1,simpleGoodness (fst p1))+  else newGoodness++simpleGoodness (Layout {minsize=Point w h}) = w+h++#if 1+-- normal version+newGoodness (Layout {minsize=s@(Point w h)},placer2) reqs =+    (wasted % (w*h),w+h)+  where+    wasted = sum (zipWith waste reqs (placer2 (Rect origin s)))+    waste (Layout {minsize=Point rw rh,fixedh=fh,fixedv=fv}) (Rect _ (Point aw ah)) =+      case (fh,fv) of+        (True,True) -> aw*ah-rw*rh+	(False,False) -> 0+	(True,False) -> (aw-rw)*ah+	(False,True) -> (ah-rh)*aw+#else+-- Röjemo's debug version+-- needs updating+newGoodness (Layout {minsize=s@(Point w h)},placer2) reqs =+     trace ("w = " ++ show w ++ "\n"+         ++ "h = " ++ show h ++ "\n"+         ++ "wlist = " ++ show wlist ++ "\n"+         ++ "wasted = " ++ show wasted ++ "\n"+         ++ "w*h = " ++ show (w*h) ++ "\n"+         ++ "(wasted % (w*h),w+h) = " ++ show     (wasted % (w*h),w+h) ++ "\n")+    (wasted % (w*h),w+h)+  where+    wlist =  (zipWith waste reqs (placer2 (Rect origin s)))+    wasted = sum wlist+    waste (Layout (Point rw rh) fh fv) (Rect _ (Point aw ah)) =+      case (fh,fv) of+        (True,True) ->    trace ("aw*ah-rw*rh = " ++ show aw ++ '*':show ah ++ '-':show rw ++ '*':show rh ++ "\n") $ aw*ah-rw*rh+        (False,False) ->  trace ("0\n")  0+        (True,False) ->   trace ("(aw-rw)*ah = (" ++ show aw ++ '-':show rw ++ ")*" ++ show ah ++ "\n") $ (aw-rw)*ah+        (False,True) ->   trace ("(ah-rh)*aw = (" ++ show ah ++ '-':show rh ++ ")*" ++ show aw ++ "\n") $ (ah-rh)*aw+#endif
+ hsrc/layout/CondLayout.hs view
@@ -0,0 +1,32 @@+module CondLayout(ifSizeP,ifSizeS,stretchCaseS,alignFixedS,alignFixedS') where+import LayoutRequest+--import Geometry(Size)+import Spacers(idS,hAlignS,vAlignS,hvAlignS,compS,noStretchS)++--ifSizeP :: (Size->Size->Bool) -> Placer -> Placer -> Placer+--ifSizeS :: (Size->Size->Bool) -> Spacer -> Spacer -> Spacer+ifSizeP b (P p1) (P p2) = P $ ifSize b p1 p2+ifSizeS b (S s1) (S s2) = S $ ifSize b s1 s2++ifSize p primP spareP reqs =+    if p primSize spareSize+    then primP2+    else spareP2+  where+    primP2@(Layout {minsize=primSize},_) = primP reqs+    spareP2@(Layout {minsize=spareSize},_) = spareP reqs++stretchCaseS :: ((Bool,Bool)->Spacer) -> Spacer+stretchCaseS sS = S $ \ req -> unS (sS (fixedh req,fixedv req)) req++alignFixedS ha va =+  stretchCaseS $ \ fixedhv ->+  case fixedhv of+    (False,False) -> idS+    (True, False) -> hAlignS ha+    (False,True)  -> vAlignS va+    (True, True)  -> hvAlignS ha va++alignFixedS' ha va =+  stretchCaseS $ \ fhv ->+   uncurry noStretchS fhv `compS` alignFixedS ha va
+ hsrc/layout/DynListLF.hs view
@@ -0,0 +1,34 @@+module DynListLF(dynListLF) where+import Fudget+import CompOps((>+<))+import DynListF+import Dynforkmerge(DynMsg(..))+import Loops(loopThroughRightF)+import SerCompF(concatMapF)+import UserLayoutF+--import Geometry+import LayoutRequest+import LayoutSP(dynLayoutMgrF)+import LayoutF(LayoutDirection(..))++dynListLF :: Placer -> F (Int, DynFMsg a b) (Int, b)+dynListLF lter =+  loopThroughRightF+    (concatMapF ctrl) (dynLayoutMgrF 0 Forward lter>+<userLayoutF dynListF)++ctrl msg =+  case msg of+    Right dyn@(i,dynmsg) ->+      case dynmsg of+        DynCreate _ -> [toMgrDyn (i,True),toDyn dyn]+	DynDestroy -> [toMgrDyn (i,False),toDyn dyn]+	DynMsg _ -> [toDyn dyn]+    Left (Left pp) -> [toDynL pp]+    Left (Right (Left ll)) -> [toMgr ll]+    Left (Right (Right x)) -> [out x]++toDyn=Left. Right. Right+toDynL=Left. Right. Left+toMgr=Left. Left. Left+toMgrDyn=Left. Left. Right+out=Right
+ hsrc/layout/DynSpacerF.hs view
@@ -0,0 +1,18 @@+module DynSpacerF(dynSpacerF,dynPlacerF) where+import Fudget+import LayoutRequest+import SerCompF(idLeftF)+import CompSP(postMapSP)+import Path(here)+import Message+--import Command+import FRequest++dynSpacerF = dynLayoutMsgF LayoutReplaceSpacer+dynPlacerF = dynLayoutMsgF LayoutReplacePlacer++dynLayoutMsgF lmsg fud = F (post `postMapSP` fudsp)+  where+    F fudsp = idLeftF fud+    post = message Low (either sendLmsg High)+    sendLmsg x = Low (here,LCmd (lmsg x))
+ hsrc/layout/HorizontalAlignP.hs view
@@ -0,0 +1,96 @@+module HorizontalAlignP where+import Data.List(mapAccumL)+import LayoutRequest+import Geometry+import Spacers(Distance(..),layoutModifierS,idS)+import Defaults(defaultSep)++-- Better names:+alignP = horizontalAlignP+alignP' = horizontalAlignP'++horizontalAlignP = horizontalAlignP' defaultSep++horizontalAlignP' :: Distance -> Placer+horizontalAlignP' sep = P haP+  where+    haP reqs = (req,placer2)+      where+	sepp = pP sep 0+	req = refpLayout rsize fh fv [ref1,ref2]+	fh = all fixedh reqs+	fv = False -- any fixedv reqs+	reqrects0 = snd $ mapAccumL reqrect (-sepp) reqs+	  where+	    reqrect ref0 (Layout {minsize=s,fixedh=fh,fixedv=fv,refpoints=rps}) =+		(ref2',((Rect d s,(fh,fv)),(d+ref1,ref2')))+	      where d = ref0-ref1+sepp+		    ref2' = d+ref2+		    (ref1,ref2) = case rps of+				    [] -> middleRefs s+				    _  -> (head rps,last rps)++	reqrects = map adj reqrects0+	  where adj ((r,f),(ref1,ref2)) =+		  ((moverect r (-minp),f),(ref1-minp,ref2-minp))+		minp = pMin (0:[d | ((Rect d _,_),_) <- reqrects0])++	rsize = pMax (1:[p+s | ((Rect p s,_),_) <- reqrects])+	(ref1,ref2) =+	  case reqrects of+	    [] -> middleRefs rsize+	    _ -> (fst . snd . head $ reqrects,snd . snd . last $ reqrects)++	placer2 rect@(Rect p asize) = [moverect r d | ((r,_),_)<-reqrects]+	  where d = p -- + scalePoint 0.5 (pmax 0 (asize-rsize))++--refMiddleS :: Spacer+refMiddleS = S refMiddleS'++refMiddleS' req =+ let (ref1,ref2) = middleRefs (minsize req)+ in (req{refpoints=[ref1,ref2]},id)+-- in (Layout s fh fv wa ha [ref1,ref2] wanted,id)++--refEdgesS :: Spacer+refEdgesS = S refEdgesS'+  where+    refEdgesS' req@(Layout {refpoints=[]}) = refMiddleS' req+    refEdgesS' req@(Layout {minsize=Point w _,refpoints=rps}) =+        (req {refpoints=[ref1,ref2]},id)+      where+        ref1 = (head rps){xcoord=0}+	ref2 = (last rps){xcoord=w}++middleRefs (Point w h) = (pP 0 h2,pP w h2)+  where h2 = h `div` 2++noRefsS :: Spacer+noRefsS = S $ \ req -> (req {refpoints=[]},id)++moveRefsS :: Point -> Spacer+moveRefsS d = layoutModifierS (mapLayoutRefs (d+))++---++spacersP :: Placer -> [Spacer] -> Placer+spacersP (P placer) spacers = P $ \ reqs ->+  let+    (reqs',spacers2) = unzip (zipWith unS (spacers++repeat idS) reqs)+    (req,placer2) = placer reqs'+    placer2' = zipWith id spacers2 . placer2+  in  (req,placer2')++---+overlayAlignP :: Placer+overlayAlignP = P $ \ ls ->+  let maxrp = maximum [head (refpoints l) | l<-ls, not (null (refpoints l))]+      ss = [f ms rps | Layout { minsize=ms,refpoints=rps}<-ls ]+	where f s [] = s+	      f s (rp:_) = s+maxrp-rp+      req = refpLayout (pMax ss) (any fixedh ls) (any fixedv ls) [maxrp]+      placer2 r = [f r rps | Layout {refpoints=rps} <- ls]+	where f r [] = r+	      f (Rect p s) (rp:_) = Rect (p+d) (s-d)+		where d=maxrp-rp+  in (req,placer2)
+ hsrc/layout/Layout.hs view
@@ -0,0 +1,29 @@+module Layout (-- * Layout+  module AutoLayout,module AlignP,module Alignment,+ --module Barlayouter,+ module LayoutDir,module LayoutF,module LayoutRequest,module Placers,module MatrixP,module Layoutspec,module TableP,module TryLayout,module NameLayout,module UserLayoutF,module AutoPlacer,module DynListLF,module Placer,module Spacer,module Spacers,module Placers2,module DynSpacerF,module Sizing,module CondLayout,module HorizontalAlignP,module ParagraphP) where+import AutoLayout+import AlignP+import Alignment+--import Barlayouter+import LayoutDir+import LayoutF+import LayoutRequest+import Placers+import MatrixP+import Layoutspec+import TableP+import TryLayout+import NameLayout+import UserLayoutF+import DynListLF+import AutoPlacer+import Placer+import Spacer+import Spacers+import Placers2+import DynSpacerF+import Sizing+import CondLayout+import HorizontalAlignP+import ParagraphP
+ hsrc/layout/LayoutDir.hs view
@@ -0,0 +1,35 @@+module LayoutDir where+import Geometry(Point(..), xcoord, ycoord)+import LayoutRequest+import Utils(swap)++data Orientation = Above | Below | RightOf | LeftOf+                   deriving (Eq, Ord, Show)++data LayoutDir = Horizontal | Vertical  deriving (Eq, Ord, Show)+++xc Horizontal = xcoord+xc Vertical = ycoord++yc Horizontal = ycoord+yc Vertical = xcoord++fixh Horizontal = fixedh+fixh Vertical = fixedv++fixv Horizontal = fixedv+fixv Vertical = fixedh++mkp Horizontal x y = Point x y+mkp Vertical x y = Point y x++vswap Horizontal = id+vswap Vertical = swap++colinear Horizontal h v = h+colinear Vertical   h v = v++orthogonal Horizontal h v = v+orthogonal Vertical   h v = h+
+ hsrc/layout/LayoutDoNow.hs view
@@ -0,0 +1,27 @@+module LayoutDoNow where++import Fudget+--import Command+import FRequest+--import Event+--import Message+import Spops+--import SP(SP)+import Path(here)+import LayoutRequest+import IsRequest++layoutDoNow (F sp) = F{-ff-} (layoutDoNow' sp)++layoutDoNow' f = donow 0 (pullSP f) where+  donow pendingreqs (os,f) = +      putsSP os $ +      let n' = pendingreqs + newreqs+          newreqs = length (filter isReq os)+	  isReq (Low (_,c)) = isRequest c+	  isReq _ = False+	  nResp (Low (_,e)) | isResponse e = 1+	  nResp _ = 0+      in if n' == 0 then putSP (Low (here,LCmd LayoutDoNow)) f+	 else +      getSP $ \msg -> donow (n' - nResp msg) (walkSP f msg)
+ hsrc/layout/LayoutF.hs view
@@ -0,0 +1,52 @@+module LayoutF(serCompLF, compLF, listLF, untaggedListLF,+	       --rbLayoutF,+               nullLF, holeF, holeF', lF, LayoutDirection(..),orientP) where+--import TableP+import CompF+import CompOps((>^=<))+import Fudget+import FRequest+import Geometry() -- instances+import LayoutDir(Orientation(..))+import LayoutRequest+import Placers+import ListF+import NullF+import FudgetIO+import SerCompF(serCompF)+import Utils(number)+--import Xtypes+import AlignP(revP)+import Placer(placerF)++data LayoutDirection = Forward | Backward  deriving (Eq, Ord,Show)++holeF' s = putLow (layoutRequestCmd (plainLayout s False False)) nullF+holeF = holeF' 0+nullLF = holeF++--listLF :: Eq a => Placer -> [(a, F b c)] -> F (a, b) (a, c)+listLF placer fl = lF (length fl) Forward placer (listF fl)++untaggedListLF :: Placer -> [F a b] -> F (Int, a) b+untaggedListLF layout fs = snd >^=< listLF layout (number 0 fs)++compLF = cLF compF+serCompLF = cLF serCompF+--rbLayoutF sep = lF 3 Forward (rightBelowP sep)++cLF :: ((F a b) -> (F c d) -> F e f) -> (F a b,Orientation) -> F c d -> F e f+cLF cF (f1,ori) f2 = lF 2 Forward (orientP ori) (cF f1 f2)++lF :: Int -> LayoutDirection -> Placer -> (F a b) -> F a b+lF 0 _ _ f = nullLF+lF nofudgets dir placer f = placerF placer' f where +     placer' = if dir == Backward then revP placer else placer++orientP :: Orientation -> Placer+orientP ori =+   case ori of+     Above -> verticalP+     Below -> revP verticalP+     LeftOf -> horizontalP+     RightOf -> revP horizontalP
+ hsrc/layout/LayoutHints.hs view
@@ -0,0 +1,15 @@+module LayoutHints(module LayoutHints,LayoutHint(..)) where+import Fudget+import LayoutRequest+import FRequest+--import Geometry(Point, Size(..),Rect)+import NullF(putMessageFu)+--import Command++serHint  = "ser" :: LayoutHint+parHint  = "par" :: LayoutHint+listHint = "list" :: LayoutHint+loopHint = "loop" :: LayoutHint++layoutHintF :: LayoutHint -> F a b -> F a b+layoutHintF hint = putMessageFu (Low (LCmd (LayoutHint hint)))
+ hsrc/layout/LayoutRequest.hs view
@@ -0,0 +1,81 @@+module LayoutRequest where+import Geometry(Point(..), Size(..),Rect(..){-,padd,psub,pmax,pP-})+--import EitherUtils(mapMaybe)+--import HO(apFst)+--import Maptrace(ctrace) -- debugging+import Alignment+import ShowFun()++data LayoutRequest+  = Layout { minsize :: Size,+	     fixedh, fixedv :: Bool,+	     wAdj, hAdj :: Int -> Size,+		-- If the available width is w+		-- then the size of this box should be wAdj w.+		-- Analogously for hAdj.+	     refpoints :: [Point], -- used by some placers+	     wantedPos :: Maybe (Point,Size,Alignment)+           }+  deriving (Show)++plainLayout s fh fv = refpLayout s fh fv []+refpLayout s fh fv rps = Layout s fh fv wa ha rps Nothing+  where+    wa w = {-ctrace "wa" (show (w::Int,s)) $-} s+    ha h = {-ctrace "ha" (show (h::Int,s)) $-} s+    --wa = if fh then const s else \ w -> pmax s (pP w 0)+    --ha = if fv then const s else \ h -> pmax s (pP 0 h)++data LayoutMessage+  = LayoutRequest LayoutRequest+  | LayoutMakeVisible Rect (Maybe Alignment,Maybe Alignment)+  | LayoutScrollStep Int+  | LayoutName String+  | LayoutPlacer Placer+  | LayoutSpacer Spacer+  | LayoutHint LayoutHint+  | LayoutDoNow+  | LayoutDestroy+  | LayoutReplaceSpacer Spacer  -- for use by dynSpacerF+  | LayoutReplacePlacer Placer  -- for use by dynPlacerF+  deriving (Show)++data LayoutResponse+  = LayoutPlace Rect+  | LayoutSize Size+  | LayoutPos Point -- Position in parent window. Occationally useful.+  deriving Show++layoutMakeVisible r = LayoutMakeVisible r (Nothing,Nothing)++newtype Placer = P Placer1 deriving (Show)++type Placer1 = ([LayoutRequest] -> Placer2)+type Placer2 = (LayoutRequest, Rect -> [Rect])+unP (P p) = p++newtype Spacer = S Spacer1 deriving (Show)+type Spacer1 = (LayoutRequest -> Spacer2)+type Spacer2 = (LayoutRequest, Rect -> Rect)+unS (S s) = s++type LayoutHint = String -- ??++--mapLayoutSize f req@(Layout {minsize=s}) = req{minsize=f s}+mapLayoutSize f = mapAdjLayoutSize f id id++mapAdjLayoutSize f wf hf req@(Layout {minsize=s,wAdj=wa,hAdj=ha}) =+  req{minsize=f s, wAdj=f.wa.wf, hAdj=f.ha.hf}++mapLayoutRefs f req@(Layout{refpoints=rps}) = req{refpoints=map f rps}++flipReq (Layout p fh fv wa ha rps wanted) =+  Layout (flipPoint p) fv fh+	 (flipPoint . ha) (flipPoint . wa)+	 (map flipPoint rps)+	 (fmap flipWanted wanted)++flipWanted (p,s,a) = (flipPoint p,flipPoint s,a)++flipRect (Rect p s) = Rect (flipPoint p) (flipPoint s)+flipPoint (Point x y) = Point y x
+ hsrc/layout/LayoutSP.hs view
@@ -0,0 +1,125 @@+module LayoutSP(layoutMgrF,dynLayoutMgrF) where+--import Command+import Data.List(sortBy)+--import Direction+--import Event+import FRequest+import Fudget+import CompOps((>=^<))+import Geometry(Rect,rR)+import LayoutRequest+import Path(here,showPath{-,Path(..),subPath-})+import Spops+--import EitherUtils(mapMaybe)+--import Utils(number, replace)+import HbcUtils(apFst)+--import Xtypes+--import NonStdTrace(trace)+--import CmdLineEnv(argKey)+import LayoutF(LayoutDirection(..))+import Maptrace(ctrace)++default (Int)++mytrace x = ctrace "layoutftrace" x++layoutMgrF :: Int -> LayoutDirection -> Placer -> F (Path, LayoutMessage) (Path, Rect)+layoutMgrF fudgetCnt dir lter1 = dynLayoutMgrF fudgetCnt dir lter1 >=^< Left++dynLayoutMgrF :: Int -> LayoutDirection -> Placer -> F (Either (Path, LayoutMessage) (Int,Bool)) (Path, Rect)+dynLayoutMgrF fudgetCnt0 dir (P lter1) = F{-ff-} $ getNLimits fudgetCnt0 []+  where+   sortTags = sortBy (order dir)+     where+       order Forward = ofst compare+       order Backward = ofst (flip compare)+       ofst r (x,_) (y,_) = r x y+   getNLimits 0 l = doLter1 Nothing $ sortTags l+   getNLimits n l =+    let same = getNLimits n l in+    getSP $ \msg -> case msg of+      High (Left (path,lmsg)) ->+        case lmsg of+	 LayoutRequest lr -> getNLimits (n-1) ((path,lr):l)+	 _ -> putSP (Low (path,LCmd lmsg)) same -- !!!+      High (Right (dyn,created)) ->+        if created+	then getNLimits (n+1) l+	else mytrace "fudget destroyed during getNLimits in layoutMgrF" $+	     --let l' =+	     -- if {-already received layout request from the destoyed fudget-}+	     -- then {-remove it from l-}+	     -- else l+	     -- in getNLimits (n-1) l'+	     same+      Low _ -> mytrace "unexpected event in getNLimits in layoutMgrF" $+               same+   doLter1 oplace slims =+     let (req,lter2) = lter1 (map snd slims)+     in mytrace ("req is"++show req) $ +        putSP (Low (here,layoutRequestCmd req)) $+	mytrace ("enter loop with "++show (length slims)) $+	loop lter2 slims oplace+   loop lter2 slims oplace =+    let same = loop lter2 slims oplace+    in+    getSP $ \msg -> case msg of+      High (Left (path,LayoutRequest lr)) ->+	 case upd slims path lr of+	   Nothing -> case (oplace >>= \place ->+			    flip lookup (zip (map fst slims) (snd place)) path) of+			Nothing -> same+			Just r -> putSP (High (path,r)) same+	   Just slims' -> mytrace ("reenter: "++show (length slims')) $+	                  doLter1 (fmap (apFst (const $ rR 0 0 0 0)) oplace) slims'+         where upd slims path lr =+	         try path Nothing $+		 mytrace ("lF: trying subPath"+++		          show(path,slims,longesteq path (map fst slims)::Path)) $+		 try (longesteq path (map fst slims)) (Just path) Nothing+                 where try path orepl fail = u slims []+			  where u [] _ = fail+				u (pl@(path',lr'):rest) l = +				  let nslims p = Just (reverse l ++ ((p,lr):rest)) in+				  if path'==path then case orepl of+				       Nothing -> {-if lr == lr' then Nothing else -} nslims path+				       Just repl -> nslims repl++				  else u rest (pl:l)+      High (Left (path,lr)) -> putSP (Low (path,LCmd lr)) same -- !!!+      High (Right (dyn,created)) ->+        if created+	then getNLimits 1 slims+	else mytrace "fudget destroyed in loop in layoutMgrF" $+	     -- remove it!+	     same+      Low (path,LEvt (LayoutPlace r)) -> mytrace ("Layoutplace "++showPath path++","++show r) $+	case oplace of +	  Just (r',_) | r == r' -> mytrace ("lF: same rect "++show r) same+	  _ -> let rects = lter2 r+		   slims' = slims {-map (\((path,Layout s v h),Rect p s') ->+				   mytrace (show (showPath path,s,s'))$(path,Layout s' v h)) $ zip slims rects-}+		   paths = map fst slims+		   crects = zip paths rects {- case oplace of+		    Nothing -> zip paths rects+		    Just (_,orects) -> +			   [(path,r) | +			    (path,r,r') <- zip3 paths rects orects, r /= r']-}+	       in --mytrace (show$slims'==slims') $+		  putsSP [mytrace ("putsSP "++show (showPath path,r))$High pr | pr@(path,r) <- crects] $+		  loop (snd $ lter1 (map snd slims')) slims' (Just (r,rects))+      Low _ -> mytrace "unexpected event in loop in layoutMgrF" $+               same++--{-+--This is a fix for a problem with dynF, I (th) suppose. I think you can fix it in dynF instead.+begineqlen x = eq 0 x where+  eq n (x:xs) (y:ys) | x == y = eq (n+1) xs ys+  eq n _ _ = n++longesteq p1 (p:ps) = le (p1,begineqlen p1 p) ps where+  le (pm,l) [] = pm+  le (pm,l) (p:ps) = let len = begineqlen p1 p+                         pl1 = if len > l then (p,len) else (pm,l)+		     in le pl1 ps+-- -}
+ hsrc/layout/Layoutspec.hs view
@@ -0,0 +1,60 @@+module Layoutspec(marginHVAlignLs, hvAlignLs, marginLs, sepLs,hBoxLs', vBoxLs',+        placeLs,spaceLs,revLs, permLs, leafLs, layoutF, Layout) where+import AlignP+--import Alignment(Alignment(..))+import Fudget+--import Geometry(Point, Rect, Size(..))+--import LayoutDir(LayoutDir, Orientation)+import LayoutF(LayoutDirection(..), lF)+import LayoutRequest+import Placers+import Spacers+import Utils(oo,unconcat)++data Layout = LeafL | NodeL Placer [Layout]  --deriving (Eq, Ord)++layoutF :: Layout -> (F a b) -> F a b+layoutF layout f =+    let (n, lter) = layouter layout+    in  lF n Forward lter f++leafLs = LeafL++revLs LeafL = LeafL+revLs (NodeL lter ls') = NodeL (revP lter) ls'++npermLs _    LeafL = LeafL+permLs perm (NodeL lter ls') = NodeL (permuteP perm lter) ls'++modLs ltermod l =+    case l of+      LeafL -> NodeL (ltermod idP) [LeafL]+      NodeL lter ls' -> NodeL (ltermod lter) ls'++placeLs = NodeL+spaceLs = modLs . spacerP++vBoxLs' = placeLs . verticalP'+hBoxLs' = placeLs . horizontalP'++sepLs = spaceLs . sepS+marginLs = spaceLs . marginS+hvAlignLs = oo spaceLs hvAlignS+marginHVAlignLs sep ha va = spaceLs (marginHVAlignS sep ha va)++--layouter :: Layout -> (Int, Placer)+layouter layout =+    case layout of+      LeafL -> (1, idP)+      NodeL lter ls' -> let (ns, lters) = unzip (map layouter ls')+                        in  (sum ns, combl lter ns lters)++combl rootlter ns nodelters = P $ \ leafreqs ->+    let (nodereqs, noderess) =+            unzip (zipWith unP nodelters (unconcat ns leafreqs))+        (rootreq, rootres) = unP rootlter nodereqs+        leafres rootrect = concatMap apply (zip noderess (rootres rootrect))+    in  (rootreq, leafres)++apply (f, x) = f x+
+ hsrc/layout/MatrixP.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE CPP #-}+module MatrixP(matrixP,matrixP') where+import Geometry+import LayoutRequest+import LayoutDir(LayoutDir(..),xc,yc,mkp)+import Spacers(Distance)+import Defaults(defaultSep)+import Data.List(mapAccumL)++#ifndef __HBC__+#define fromInt fromIntegral+#endif++matrixP n = matrixP' n Horizontal defaultSep++matrixP' :: Int -> LayoutDir -> Distance -> Placer+matrixP' count' ld sep = P $ \ requests ->+    let n = length requests+        maxsize = (pMax . (origin:) . map minsize) requests+	rps' = concatMap refpoints requests+        maxh = xc ld maxsize+        maxv = yc ld maxsize+        ncols = count' `min` n+        nrows = (n - 1) `quot` count' + 1+        his = sep * (ncols - 1)+        vis = sep * (nrows - 1)+        h = his + maxh * ncols+        v = vis + maxv * nrows+        mat2 (Rect gotpos gotsize) =+            let x0 = xc ld gotpos+	        y0 = yc ld gotpos+		width = xc ld gotsize+		height = yc ld gotsize+                goth,gotv :: Double+                goth = fromInt (width - his) / fromInt ncols+                gotv = fromInt (height - vis) / fromInt nrows+                pl i _ =+		  let (x, y) = (i `rem` count', i `quot` count')+		  in (i + 1, Rect+		   (mkp ld (x0 + truncate (fromInt x * (goth + fromInt sep)))+			   (y0 + truncate (fromInt y * (gotv + fromInt sep))))+		   (mkp ld (truncate goth)+			   (truncate gotv)))+            in  snd (mapAccumL pl 0 requests)+    in  (refpLayout (mkp ld h v) False False rps', mat2)++#ifdef __NHC__+fromInt = fromIntegral+#endif
+ hsrc/layout/NameLayout.hs view
@@ -0,0 +1,193 @@+module NameLayout(LName(..),placeNL,spaceNL,modNL,marginNL,sepNL,hvAlignNL,marginHVAlignNL,nullNL,hBoxNL,hBoxNL',vBoxNL, vBoxNL',leafNL, NameLayout, nameF,+ listNF, nameLayoutF) where++--import NonStdTrace(trace)+import LayoutRequest+import NullF+import Spops+--import Command+--import Event+import FRequest+--import Xtypes+import EitherUtils(plookup)+import Data.Maybe(fromJust)+import Fudget+import Path+import Geometry+import Placers+import Spacers+--import Message+import ListF+import Loopthrough+import Cont+--import LayoutDir+import AlignP+--import Alignment+import Utils+import Maptrace+import AutoLayout+import ParF++type LName = String+newtype NameLayout = NL (MLNode LName) -- abstract++-- The layout structure datatype+type MLNode a = (Maybe LayoutRequest, LNode a)+data LNode a = +      LNode Int Placer (Maybe (Rect -> [Rect])) [MLNode a]+    | LLeaf (LLeaf a) deriving Show++data LLeaf a = Name a | Req LayoutRequest deriving Show++type NPath = [Int]++-----------------------------------------------------------------------------------+-- Exported functions++placeNL :: Placer -> [NameLayout] -> NameLayout+placeNL lter ns = let dns = map deNL ns in+   buildnl $ LNode (length (filter (nothing.fst) dns)) lter Nothing dns++spaceNL :: Spacer -> NameLayout -> NameLayout+spaceNL = modNL . spacerP++modNL :: (Placer -> Placer) -> NameLayout -> NameLayout+modNL ltermod (NL (req,n)) = NL $ case n of+   LNode i lter f ls -> (req,LNode i (ltermod lter) f ls)+   LLeaf l -> +      let lter = ltermod idP+          P lter' = lter in +      case l of+	 Req r -> leafReq $ fst $ lter' $ [r]+	 _ -> (Nothing,LNode 1 lter Nothing [(req,n)])++marginNL = spaceNL . marginS+sepNL = spaceNL . sepS++hvAlignNL = spaceNL `oo` hvAlignS+marginHVAlignNL sep ha va = spaceNL (marginHVAlignS sep ha va)++hBoxNL = placeNL $ horizontalP+hBoxNL' d = placeNL $ horizontalP' d+vBoxNL = placeNL $ verticalP+vBoxNL' d = placeNL $ verticalP' d+leafNL name = buildnl $ LLeaf $ Name name+nullNL = NL $ leafReq $ plainLayout (Point 1 1) False False++nameF :: LName -> F a b -> F a b+nameF n = putMessageFu (Low (LCmd (LayoutName n))) . autoLayoutF++-- local++nothing Nothing = True+nothing _ = False++buildnl :: LNode LName -> NameLayout+buildnl x = NL (Nothing,x)+deNL (NL x) = x++leafReq :: LayoutRequest -> MLNode a+leafReq req = (Just req,LLeaf $ Req $ req)++listNF :: (Eq a, Show a) => [(a, F b c)] -> F (a, b) (a, c)  +listNF fs = listF [(t, nameF (show t) f) | (t, f) <- fs]++-- The main layout function+nameLayoutF :: NameLayout -> F a b -> F a b+nameLayoutF (NL ltree) (F fsp) =+    let layoutSP =+            getAllPNames (countLNames ltree) [] $ \pnames ->+            let (pathTable, ltree') = rebuildTree pnames [] ltree+	    in lSP pathTable ltree'+        lSP pt ltree = +            let same = lSP pt ltree in+            getSP $ \msg ->+	    case msg of+	      -- A message from the fudget+	      Left (Low (path, LCmd (LayoutRequest lr))) ->+		  ctrace "nameLayoutF" lr $+		  let ltree' = updateTree path (pathlookup pt path) ltree lr+		  in case ltree' of +			(Just lreq, _) -> --trace (show ltree') $+			    putSP (Right (Low ([], layoutRequestCmd lreq))) $+			    lSP pt ltree'+			_ -> lSP pt ltree'+	      Left x -> putSP (Right x) $ same+	      -- A message to the fudget+	      Right (Low (path, LEvt (LayoutPlace r))) ->+		  putsSP (map (Left. Low) $ traverseTree r ltree) $ same+	      Right x -> putSP (Left x) $ same+    in parF nullF $ F{-ff-} $ loopThroughRightSP layoutSP fsp+--  fix for autolayout++-----------------------------------------------------------------------------------+-- Local functions++-- Counts the number of named leafs in a layout structure+countLNames :: MLNode a -> Int+countLNames (_, LLeaf (Name _)) = 1+countLNames (_, LLeaf _) = 0+countLNames (_, LNode _ _ _ ns) = sum (map countLNames ns)++-- Traverses the layout structure, returning a mapping from leaf names to paths+getAllPNames :: Int -> [(LName, Path)] -> +	     Cont (SP (Either (FCommand a) b) c) [(LName,Path)]+getAllPNames 0 pnames c = c pnames+getAllPNames n pnames c =+    waitForSP layoutName $ \pname ->+    getAllPNames (n-1) (pname:pnames) c+    where layoutName (Left (Low (path, LCmd (LayoutName name)))) = +              Just(name, path)+          layoutName _ = Nothing++-- Rebuilds the layout structure. +-- Returns also a mapping from ordinary paths to number paths.+rebuildTree :: [(LName, Path)] -> NPath -> MLNode LName ->+               ([(Path, NPath)], MLNode Path)+rebuildTree pnames np (_, LLeaf (Name name)) = +    case lookup name pnames of+        Nothing -> error ("Couldn't find name "++ show name ++ +			  " in (name, path) table.")+	Just path -> ([(path, np)], (Nothing, LLeaf $ Name path))+rebuildTree pnames np (_, (LLeaf (Req r))) = ([],(Just r, (LLeaf (Req r))))+rebuildTree pnames np (_, LNode c lter Nothing ns) =+    (concat ts, (Nothing, LNode c lter Nothing ns'))+    where (ts, ns') = unzip (zipWith (rebuildTree pnames) +                                     (map ((np++) . (:[])) [1..]) ns)+++-- Inserts layout requests in the layout structure.+-- Trigged by some fudget emitting a layout request+updateTree :: Path -> +              Maybe NPath -> +	      MLNode Path -> +	      LayoutRequest -> +              MLNode Path+updateTree path Nothing _ lr = +    error ("Hmmm. Couldn't find path " ++ show path +++    "in updateTree\nSomeone has probably forgotten to name a fudget.")+updateTree path (Just npath) lo lr = snd $ upd npath lo lr+    where upd _ (mlr, LLeaf (Name p)) lr = +                 (nothing mlr, (Just lr, LLeaf (Name path)))+          upd (n:np) (mlr, LNode c lter@(P lter') mr ns) lr =+	      let (before, this:after) = splitAt (n-1) ns+	          (ready, child) = upd np this lr+	          c' = if ready then max (c-1) 0 else c+		  ns' = before ++ [child] ++ after+	      in if c' == 0 then+	             let (lreq, rectf) = lter' (map (fromJust . fst) ns')+		     in (nothing mlr, +		         (Just lreq, LNode c' lter (Just rectf) ns'))+		 else+		     (False, (Nothing, LNode c' lter mr ns'))+          upd _ othernode _ = (False,othernode)++-- We have got a rectangle. Emit commands to all subfudgets saying how large+-- they should be. +traverseTree :: Rect -> MLNode Path -> [TEvent]+traverseTree r (_, LLeaf (Name path)) = [(path, LEvt $ LayoutPlace r)]+traverseTree r (_, LLeaf _) = []+traverseTree r (_, LNode _ _ (Just rectf) ns) =+    concat (zipWith traverseTree (rectf r) ns) ++pathlookup table p = plookup (flip subPath p) table
+ hsrc/layout/ParagraphP.hs view
@@ -0,0 +1,51 @@+module ParagraphP where+import LayoutRequest+import Geometry+--import ListUtil(chopList)+import HbcUtils(apFst,chopList)+import Defaults(defaultSep)+import Placers(verticalP')+import Spacers() -- synonym Distance, for hbc+import HorizontalAlignP(horizontalAlignP')+--import Maptrace(ctrace)+import Utils(oo)+import CmdLineEnv(argReadKey)+--import IntMemo++paragraphP = paragraphP' defaultSep+paragraphP' = paragraphP'' horizontalAlignP'++paragraphP'' :: (Int->Placer) -> Size -> Placer+paragraphP'' horizP' (Point hsep vsep) = P paP+  where+    paP reqs = ({-ctrace "paraReq" (req, wAdj req $ xcoord $ minsize req)-} req,paraPlacer2)+      where+	width0 = argReadKey "paragraph-width" 600 :: Int+	req = (paraReq width0) { wAdj=minsize . paraReq }+	paraReq width = fst (paraP width)+	paraPlacer2 rect@(Rect _ (Point w _)) =+	  --ctrace "paraPlacer2" rect $+	  snd (paraP w) rect+	paraP = {-memoInt-} paraP' -- memoInt slows down and consumes a lot of heap+	paraP' width = (vreq,placer2)+	  where+	    (vreq,vplacer2) = unP (verticalP' vsep) hreqs+	    placer2 = concat . zipWith id hplacers2 . vplacer2+	    (hreqs,hplacers2) =+	      unzip . map (unP (horizP' hsep)) . breakLines width $ reqs++	breakLines w rs = {-ctrace "breakLines" (w,map length rss)-} rss+	    where rss = breakLines' w rs++	breakLines' = chopList . (atLeastOne `oo` takeLine)+	takeLine wremain reqs = +	  case reqs of+	    [] -> ([],[])+	    r:rs -> --ctrace "takeLine" (wremain,w) $+		    if wremain<w+		    then ([],reqs)+		    else apFst (r:) (takeLine (wremain-w-hsep) rs)+	      where w=xcoord (minsize r)++atLeastOne ([],x:xs) = ([x],xs)+atLeastOne xsys = xsys
+ hsrc/layout/Placer.hs view
@@ -0,0 +1,34 @@+module Placer where+import Fudget+import LayoutRequest+import FRequest+--import Geometry(Point, Size(..),Rect)+import NullF(putMessageFu)+--import Command+--import Defaults(defaultSep)+import Placers(horizontalP,verticalP)+import MatrixP(matrixP)+import Spacers(spacerP)+import TableP(tableP)+import AlignP(revP)+import AutoPlacer(autoP)++--import AlignP+--import Alignment++placerF :: Placer -> F a b -> F a b+placerF placer = putMessageFu (Low (LCmd (LayoutPlacer placer)))++spacerF :: Spacer -> F a b -> F a b+spacerF spacer = putMessageFu (Low (LCmd (LayoutSpacer spacer)))++spacer1F s = placerF (s `spacerP` autoP)++hBoxF = placerF horizontalP+vBoxF = placerF verticalP++revHBoxF = placerF (revP horizontalP)+revVBoxF = placerF (revP verticalP)++matrixF = placerF . matrixP+tableF  = placerF . tableP
+ hsrc/layout/Placers.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE CPP #-}+module Placers(linearP, verticalP, horizontalP, horizontalP', verticalP') where+import Geometry+import LayoutDir+import LayoutRequest+import Spacers(Distance(..))+import Data.List(mapAccumL)+import Utils(part)+import Defaults(defaultSep)+import Maptrace(ctrace) -- debugging+--import NonStdTrace(trace)+import IntMemo++#ifndef __HBC__+#define fromInt fromIntegral+#endif+ +horizontalP = horizontalP' defaultSep+verticalP = verticalP' defaultSep++horizontalP' = linearP Horizontal+verticalP' = linearP Vertical++linearP :: LayoutDir -> Distance -> Placer+linearP ld sep = P $ linearP' ld sep++linearP' ld sep [] = ctrace "linearP" ("linearP "++show ld++" []") $+		    (plainLayout 1 (ld==Horizontal) (ld==Vertical),\ r -> [])+linearP' ld sep requests =+    let minsizes = map minsize requests+        totis = sep * (max 0 (length requests - 1))+        h = max 0 (h'-sep)   -- totis + sum (map (xc ld) minsizes)+	(h',rpss) = mapAccumL adjust 0 requests+	  where adjust x (Layout {minsize=rsz,refpoints=rps}) =+		    (x+rw+sep,map adj1 rps)+		  where adj1 p = mkp ld (x+xc ld p) (yc ld p)+		        rw = xc ld rsz+        v = (maximum . (0:) . map (yc ld)) minsizes+        line2 gotr =+            let goth = (fromInt . xc ld . rectsize) gotr - fromInt totis+                gotv = (yc ld . rectsize) gotr+                startx = (fromInt . xc ld . rectpos) gotr+                starty = (yc ld . rectpos) gotr+#if 0+-- Old solution+		requests' = requests+#else+-- New, experimental solution:+		requests' = map req' requests+		  where+		    req' req = req {minsize=adj gotv}+		      where adj=orthogonal ld (wAdj req) (hAdj req)+#endif+                (fih, flh) = part (fixh ld) requests'+                fixedh' =+		  (fromInt . sum . map (xc ld . minsize)) fih+                floath = (fromInt . sum . map (xc ld . minsize)) flh+                fixedR = if floath > 0.0 then 1.0 else goth / fixedh'+                floatR =+                    if floath == 0.0 then 1.0 else (goth - fixedh') / floath+                rR' req = if fixh ld req then fixedR else floatR+                pl x req =+                    let width = (fromInt . xc ld . minsize) req * rR' req+                    in  (x + width + fromInt sep,+                         Rect (mkp ld (truncate x) starty)+                              (mkp ld (truncate width) gotv))+            in  snd (mapAccumL pl startx requests')+	(fh',fv') = vswap ld (allf and fixh,allf or fixv)+	rps' = concat rpss --concatMap refpoints requests+	allf conn fix = conn (map (fix ld) requests)+	req0 = refpLayout (mkp ld h v) fh' fv' rps'+	req =+	  case ld of+	    Horizontal -> req0 { hAdj=memoInt ha } +	      where ha h = Point (totis+sum ws) h+		      where ws = map (xcoord . flip hAdj h) requests+	    Vertical -> req0 { wAdj=memoInt wa } +	      where wa w = Point w (totis+sum hs)+		      where hs = map (ycoord . flip wAdj w) requests+    in (req,line2)++#ifdef __NHC__+fromInt = fromIntegral+#endif
+ hsrc/layout/Placers2.hs view
@@ -0,0 +1,72 @@+module Placers2(overlayP,+		verticalLeftP,verticalLeftP',+		horizontalCenterP,horizontalCenterP') where+import LayoutRequest+import Spacers(Distance(..))+import Geometry+import Defaults(defaultSep)+import Data.List(mapAccumL)+import IntMemo++overlayP :: Placer+overlayP = P overlayP'+  where+    overlayP' ls = (req,placer2)+      where+	ss = map minsize ls+	rps = concatMap refpoints ls+	wa w = Point w (maximum (1:map (ycoord . flip wAdj w) ls))+	ha h = Point (maximum (1:map (xcoord . flip hAdj h) ls)) h+	req = (refpLayout (pMax ss) (any fixedh ls) (any fixedv ls) rps) {wAdj=memoInt wa,hAdj=memoInt ha}+	placer2 r = [r | _ <- ls]++verticalLeftP = verticalLeftP' defaultSep++verticalLeftP' :: Distance -> Placer +verticalLeftP' sep = P vlP+  where+    vlP ls = (req,placer2)+      where+	req = (refpLayout (Point w h) False (and fvs) (concat rpss)) {wAdj=memoInt wa}+	wa aw = Point aw (sum hs+totsep)+	  where hs = [ycoord (wAdj (min aw w)) | Layout{minsize=Point w _,wAdj=wAdj}<-ls]+	totsep = sep*(length ls-1)+	(ss,fhs,fvs) = unzipsfhv ls+	(ws,hs) = unzip [(w,h) | Point w h <- ss]+	w = maximum (1:ws)+	h = max 1 (h'-sep) -- (sum hs + sep*(length hs-1))+	(h',rpss) = mapAccumL adjust 0 ls+	  where adjust y (Layout {minsize=Point _ rh,refpoints=rps}) =+		    (y+rh+sep,map adj1 rps)+		  where adj1 (Point rx ry) = Point rx (y+ry)+	placer2 (Rect (Point x0 y0) _) = placer2' hs ss y0+	  where placer2' (h:hs) (s:ss) y =+		   Rect (Point x0 y) s:placer2' hs ss (y+sep+h)+		placer2' _ _ _ = []++horizontalCenterP = horizontalCenterP' defaultSep++horizontalCenterP' :: Distance -> Placer +horizontalCenterP' sep = P hcP+  where+    hcP ls = (req,placer2)+      where+	req = (refpLayout (Point w h) (and fhs) False (concat rpss)) {hAdj=memoInt ha}+	(ss,fhs,fvs) = unzipsfhv ls+	ha ah = Point (sum ws+totsep) ah+	  where ws = [xcoord (hAdj (min ah h)) | Layout{minsize=Point _ h,hAdj=hAdj}<-ls]+	totsep = sep*(length ls-1)+	(ws,hs) = unzip [(w,h) | Point w h <- ss]+	w = max 1 w' --(sum ws + sep*(length ws-1))+	h = maximum (1:hs)+	(w',rpss) = mapAccumL adjust 0 ls+	  where adjust x (Layout {minsize=Point rw rh,refpoints=rps}) =+		    (x+rw+sep,map adj1 rps)+		  where adj1 (Point rx ry) = Point (x+rx) (ry+(h-rh) `div` 2)+	placer2 (Rect (Point x0 y0) (Point _ ah)) = placer2' ws hs ss x0+	  where placer2' (w:ws) (h:hs) (s:ss) x =+		  Rect (Point x (y0+(ah-h) `div` 2)) s:placer2' ws hs ss (x+sep+w)+		placer2' _ _ _ _ = []++unzipsfhv ls =+  unzip3 [(s,fh,fv) | Layout {minsize=s,fixedh=fh,fixedv=fv} <- ls]
+ hsrc/layout/Sizing.hs view
@@ -0,0 +1,14 @@+module Sizing where+import Geometry(pmax)++data Sizing+  = Static | Growing | Dynamic+--  | StaticDebug+  deriving (Eq,Show,Read)++newSize sizing curSize reqSize =+  case sizing of+    Static  -> curSize+--    StaticDebug  -> curSize+    Growing -> pmax curSize reqSize+    Dynamic -> reqSize
+ hsrc/layout/SizingF.hs view
@@ -0,0 +1,47 @@+module SizingF(sizingF) where+import LoopLow(loopThroughLowF)+import Spops(mapAccumlSP)+import LayoutRequest+import FRequest+--import Event+--imaport Command+import Geometry(Rect(..))+--import Fudget+import Sizing(newSize)+--import Maptrace(ctrace) -- debugging++sizingF = loopThroughLowF . sizingSP++sizingSP sizing = mapAccumlSP sizingT state0+  where+    --tr = if sizing==StaticDebug then ctrace "dsizing" else const id+    state0 = Nothing++    sizingT Nothing msg =+      case msg of+	Left (path,LCmd (LayoutRequest (Layout size' fh' fv' wa' ha' rps' wanted'))) ->+	  (Just (Nothing,size',fh',fv'{-,rps'-}),msg)+	_ -> (Nothing,msg)+    sizingT s@(Just state@(optpos,size,fh,fv{-,rps-})) msg =+      case msg of+	Left (path,LCmd (LayoutRequest r@(Layout size' fh' fv' wa' ha' rps' wanted'))) ->+	    case (state' == state,optpos) of+	      (True,Just pos) -> (s,Right (path,LEvt (LayoutPlace (Rect pos size))))+	      _ -> --tr (show (state,state'))+	            (Just state',msg')+	  where size'' = newSize sizing size size'+	        state' = (optpos,size'',fh',fv'{-,rps'-})+	        msg' = Left (path,layoutRequestCmd r{minsize=size''})+	Right (_,LEvt (LayoutPlace rect@(Rect pos' size'))) -> (Just (Just pos',size',fh,fv{-,rps-}),msg)+	_ -> (s,msg)++{-+sizingF prevents a fudget from outputting a layout request that doesn't change+anything. The sizing parameter also restricts what kind of resizing is allowed.++sizingF assumes that the argument fudget has only ONE layout box and will+confuse things if layout requests are received from several different paths.++sizingF is used in autoLayoutF and there is probably no reason to use it in+other places (i.e., use autoLayoutF' if there seems to be a need for sizingF).+-}
+ hsrc/layout/Spacer.hs view
@@ -0,0 +1,17 @@+-- replaces modules AlignF and SepF+module Spacer(module Spacer,Distance(..)) where+--import LayoutRequest+import Spacers+import Placer(spacer1F)++marginHVAlignF m h v = spacer1F $ marginHVAlignS m h v++alignF uladd bradd halign valign =+  spacer1F (hvMarginS uladd bradd `compS` hvAlignS halign valign)++layoutModifierF = spacer1F . layoutModifierS++noStretchF fh fv = spacer1F (noStretchS fh fv)++sepF = spacer1F . sepS+marginF = spacer1F . marginS
+ hsrc/layout/Spacers.hs view
@@ -0,0 +1,112 @@+module Spacers where+import LayoutRequest+import Geometry+import Utils(mapPair)+import Alignment++---- Spacer types++type Distance = Int+++---- Primitive Spacers++-- Fixed margins++hMarginS, vMarginS :: Distance -> Distance -> Spacer+hMarginS dLeft dRight = hvMarginS (pP dLeft 0) (pP dRight 0)+vMarginS dTop dBottom = hvMarginS (pP 0 dTop) (pP 0 dBottom)++hvMarginS :: Size -> Size -> Spacer+hvMarginS dUpperLeft dBottomRight = S $ \ req ->+  let growth = dUpperLeft + dBottomRight+  in (mapLayoutRefs (+dUpperLeft) $+        mapAdjLayoutSize (+growth) (+(-xcoord growth)) (+(-ycoord growth)) req,+      center' dUpperLeft growth)++center p (Rect r s) = Rect (r+p) (s-(p+p))+center' offset shrink (Rect r s) = Rect (r+offset) (s-shrink)++sepS :: Size -> Spacer+sepS s = hvMarginS s s++marginS :: Distance -> Spacer+marginS d = sepS (diag d)++-- Flexible margins++leftS = hAlignS aLeft+hCenterS = hAlignS aCenter+rightS = hAlignS aRight++vAlignS = flipS . hAlignS+topS = flipS leftS+vCenterS = flipS hCenterS+bottomS = flipS rightS++hvAlignS hpos vpos = hAlignS hpos `compS` vAlignS vpos+centerS = vCenterS `compS` hCenterS++hAlignS :: Alignment -> Spacer+hAlignS hpos = S $ \ (Layout size@(Point rw _) fh fv wa ha rps wanted) ->+  let+    wa' w = wa (min rw w)+    hAlignR (Rect p@(Point x y) s@(Point aw ah)) =+	Rect (pP (x+spaceLeft) y) (pP rw' ah)+      where+	space = aw-rw'+	spaceLeft = scale hpos space+	rw' = min rw aw+	rw = xcoord (ha ah)+  in (Layout size False{-fh-} fv wa' ha rps wanted,hAlignR)++marginHVAlignS sep halign valign = marginS sep `compS` hvAlignS halign valign++--- Spacer operations++spacerP :: Spacer -> Placer -> Placer+spacerP (S spacer) (P placer) = P $ \ reqs ->+  let   (req',placer2) = placer reqs+        (req'',spacer2) = spacer req'+  in (req'',placer2.spacer2)++--flipS :: Spacer -> Spacer+flipS = mapS flipS'+  where+    flipS' spacer = mapPair (flipReq,flipS2) . spacer . flipReq+    flipS2 spacer2 = flipRect.spacer2.flipRect++mapS f (S sp) = S (f sp)++--idS :: Spacer+idS = S $ \ req -> (req,id)++compS :: Spacer -> Spacer -> Spacer+compS (S spa) (S spb) = S $ \ req ->+  let   (req',spb2) = spb req+        (req'',spa2) = spa req'+  in (req'',spb2.spa2)+++sizeS,maxSizeS,minSizeS :: Size -> Spacer+sizeS    = resizeS . const+maxSizeS = resizeS . pmin+minSizeS = resizeS . pmax++resizeS :: (Size->Size) -> Spacer+resizeS = layoutModifierS . mapLayoutSize+-- The above and below lines now mean the same+--resizeS f = layoutModifierS (mapAdjLayoutSize f id id)++noStretchS :: Bool -> Bool -> Spacer+noStretchS fh fv = layoutModifierS lf+  where lf req = req { fixedh=fh, fixedv=fv }+--noStretchS fh fv req = (mapLayout lf req ,id)+--  where lf size _ _ wa ha rps = Layout size fh fv wa ha rps++mapLayout f req =+  case req of+    Layout size fh fv wa ha rps wanted -> f size fh fv wa ha rps wanted++--layoutModifierS :: (LayoutRequest -> LayoutRequest) -> Spacer+layoutModifierS lf = S $ \ req -> (lf req,id)
+ hsrc/layout/TableP.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE CPP #-}+module TableP(tableP,tableP') where+import Geometry(Point(..), Rect(..), rR, xcoord, ycoord)+import LayoutDir(LayoutDir(..), vswap)+import LayoutRequest+import Spacers(Distance(..))+import HbcUtils(chopList)+import Data.List(transpose,mapAccumL)+import Utils(lhead)+import Defaults(defaultSep)+import IntMemo++import Maptrace(ctrace)+tr x = ctrace "tableP" x x++tableP n = tableP' n Horizontal defaultSep++tableP' :: Int -> LayoutDir -> Distance -> Placer+tableP' count' ld sep = P $ \ requests ->+    let --sizes = map minsize requests+        (rows, columns) =+            let hmatrix = chopList (splitAt count') requests+                vmatrix = transpose hmatrix+            in  vswap ld (hmatrix, vmatrix)+        nrows = length rows+        ncols = length columns+        vsep = (nrows - 1) * sep+        hsep = (ncols - 1) * sep+        rowhs = map (maximum . (0:) . map (ycoord.minsize)) rows+        colws = map (maximum . (0:) . map (xcoord.minsize)) columns+	--rowfixws = map (and . map fixedh) rows+	rowfixhs = map (or . map fixedv) rows+	colfixws = map (or . map fixedh) columns+	--colfixhs = map (and . map fixedv) columns+        h = sum rowhs+        w = sum colws+        toth = h + vsep+        totw = w + hsep+	tot = Point totw toth+	totfh = and rowfixhs+	totfw = and colfixws+        rps = concatMap (\(r,p)->map (p+) (refpoints r)) (zip requests cellps)+	  where	cellps = [Point x y | y<-place 0 sep rowhs,x<-place 0 sep colws]+--	  where	cellps = [Point x y | y<-0:init rowhs,x<-0:init colws] --sep??+        table2 (Rect (Point x0 y0) got@(Point width height)) =+            let --Point extraw extrah = (got `psub` tot) --`pmax` origin+#if 0+-- old solution+		rowhs' = arowhs height --pad flexh extrah rowhs rowfixhs+		colws' = acolws width --pad flexw extraw colws colfixws+#else+-- new solution+		((colws',rowhs'),(w',h')) =+		  if width<=totw -- hmm...+		  then (adjrowhs width,(width,sum rowhs'+vsep))+		  else (adjcolws height,(sum colws'+hsep,height))+#endif+		colws'' = adjsizes (tr (width-w')) colws' colfixws+		rowhs'' = adjsizes (tr (height-h')) rowhs' rowfixhs+		xs = place x0 sep colws''+		ys = place y0 sep rowhs''+		placedrows =+		  [[rR x y w h|(x,w)<-zip xs colws'']|(y,h)<-zip ys rowhs'']+{- old+		w' = sum colws'+		h' = sum rowhs'+		hscale,vscale :: Double+                hscale = fromInt (width - hsep) / fromInt w'+                vscale = fromInt (height - vsep) / fromInt h'+                placecols x y h' [] = []+                placecols x y h' (w' : ws) =+                    let w'' = scale hscale w'+                    in  rR x y w'' h' : placecols (x + w'' + sep) y h' ws+                placerows y [] = []+                placerows y (h' : hs) =+                    let h'' = scale vscale h'+                    in  placecols x0 y h'' colws' : placerows (y + h'' + sep) hs+                placedrows = placerows y0 rowhs'+-}++                rectss =+                    case ld of+                      Horizontal -> placedrows+                      Vertical -> transpose placedrows+		rects = concat rectss+            in (if length rects<length requests +	        then ctrace "tableP" (length requests,length rects)+	        else id) $+	       lhead requests rects++	acolws aw = adjsizes (aw-totw) colws colfixws+	arowhs ah = adjsizes (ah-toth) rowhs rowfixhs++	adjsizes extra ss fixs = pad flex extra ss fixs+	  where+	    flex = sum [s | (s,fixed) <-zip ss fixs, not fixed]++	    pad _    0     ws _ = ws+	    pad 0    extra ws _ = ws+	    pad flex extra (w:ws) (fixed:fs) =+	      if fixed+	      then w:pad flex extra ws fs+	      else let e = (extra*w `quot` flex) `max` (-w)+		   in w+e:pad (flex-w) (extra-e) ws fs+	    pad _ _ _ _ = []++	adjrowhs = memoInt adjrowhs'+	adjrowhs' w = (colws,map maximum (transpose colhs))+	  where colhs = [map (ycoord . flip wAdj colw) column |+			  (colw,column) <- zip colws columns]+	        colws = acolws w++	adjcolws = memoInt adjcolws'+	adjcolws' h = (map maximum (transpose rowws),rowhs)+	  where rowws = [map (xcoord . flip hAdj rowh) row |+			  (rowh,row) <- zip rowhs rows]+		rowhs = arowhs h++	wa w = ctrace "tablePwa" s s+	  where s = Point w (vsep+h)+	        h = sum (snd (adjrowhs w))+{- --old:+		h = sum . map maximum . transpose $ colhs+		colhs =  [map (ycoord . flip wAdj colw) col |+			  (colw,col) <- zip (acolws w) columns]+-}+	ha h = Point (hsep+w) h+	  where w = sum (fst (adjcolws h))+{- --old:+		w = sum . map maximum . transpose $ rowws+		rowws =  [map (xcoord . flip hAdj rowh) row |+			  (rowh,row) <- zip (arowhs h) rows]+-}+    in ((refpLayout tot totfw totfh rps){wAdj=memoInt wa,hAdj=memoInt ha}, table2)++place pos0 sep = snd . mapAccumL f pos0+  where f pos size = (pos+size+sep,pos)++#ifdef __NHC__+fromInt = fromIntegral+#endif
+ hsrc/layout/TryLayout.hs view
@@ -0,0 +1,16 @@+module TryLayout(tryLayoutK) where++import FRequest+--import Message+import Cont+import LayoutRequest+--import Command+--import Fudget+--import Xtypes+--import Event++tryLayoutK lreq =+  cmdContK (layoutRequestCmd lreq) $ \r ->+  case r of+    LEvt (LayoutSize s) -> Just s+    _ -> Nothing
+ hsrc/layout/UserLayoutF.hs view
@@ -0,0 +1,26 @@+module UserLayoutF where+import Fudget+import FRequest+--import Command+--import Event+import Geometry(Rect)+--import CompOps+import Spops(concatMapSP)+import CompSP(preMapSP,serCompSP)+import LayoutRequest+--import Message(Message(..))++userLayoutF :: F a b -> F (Either (Path,Rect) a) (Either (Path,LayoutMessage) b)+userLayoutF (F fud) = F{-ff-} (concatMapSP post `serCompSP` fud `preMapSP` pre)+  where+    pre msg =+      case msg of+        High (Right x) -> High x+	High (Left (p,place)) -> Low (p,LEvt (LayoutPlace place))+	Low pev -> Low pev+    post msg =+      case msg of+        High x -> [High (Right x)]+	Low (p,LCmd req) -> [High (Left (p,req))]+	--Low d@(p,XCmd DestroyWindow) -> [Low d] --,High (Left (p,LayoutDestroy))]+	Low pcmd -> [Low pcmd]
+ hsrc/lowlevel/Cont.hs view
@@ -0,0 +1,97 @@+module Cont(Cont(..),conts, tryM, cmdContF, cmdContK, cmdContK', waitForSP, waitForK, waitForF, waitForFu, cmdContSP,tryGet,getLeftSP,getRightSP,fContWrap,kContWrap,dropSP,contMap) where+--import Direction+import Fudget+import Message(stripHigh, stripLow, aLow) --Message(..),+import Path(here)+--import SP+import Spops+import StreamProcIO+import EitherUtils(stripLeft,stripRight)++cmdContSP :: a -> (b -> Maybe c) -> Cont (SP b a) c+cmdContSP cmd expected process =+    putsSP [cmd] (waitForSP expected process)++waitForSP expected process =+    let contSP pending =+            getSP (\msg ->+                   case expected msg of+                     Just answer -> startupSP (reverse pending) (process answer)+                     Nothing -> contSP (msg : pending))+    in  contSP []++waitForK expected = kContWrap (waitForSP expected)++waitForF :: (a -> Maybe b) -> Cont (F a c) b+waitForF expected = fContWrap (waitForSP expectHigh)+  where expectHigh msg = stripHigh msg >>= expected++waitForFu :: (KEvent hi -> Maybe ans) -> Cont (F hi ho) ans+waitForFu expected = fContWrap (waitForSP expectk)+  where expectk = expected . aLow snd++getLeftSP = waitForSP stripLeft+getRightSP = waitForSP stripRight++waitForLow expected = waitForSP expectLow+  where expectLow msg = stripLow msg >>= expected++cmdContLow cmd expected = putSP (Low cmd) . waitForLow expected++{- old:+cmdContLow cmd exp' =+    cmdContSP (Low cmd)+              (\msg ->+               case msg of+                 Low ev -> exp' ev+                 _ -> Nothing)+-}++cmdContK :: FRequest -> (FResponse -> Maybe a) -> Cont (K b c) a+cmdContK xcmd expected = kContWrap (cmdContLow xcmd expected)++cmdContK' msg expected = kContWrap (cmdContSP msg expected)++cmdContF :: FRequest -> (FResponse -> Maybe a) -> Cont (F b c) a+cmdContF cmd exp' =+    fContWrap $+    cmdContLow (here, cmd)+               (\tev ->+                case tev of+                  (t, ev) | t == here -> exp' ev+                  _ -> Nothing)++conts :: (a -> Cont c b) -> [a] -> Cont c [b]+conts g sl c =+    let co al [] = c (reverse al)+        co al (s : sl') = g s (\a -> co (a : al) sl')+    in  co [] sl++tryM :: Cont c (Maybe a) -> c -> Cont c a+tryM e errc c = e $ \ov ->+                case ov of+		   Nothing -> errc+		   Just v -> c v++tryGet :: Cont c (Maybe a) -> (Cont c a) -> Cont c a+tryGet e errc c = tryM e (errc c) c++dropSP expected c = dropit where+    dropit =+      getSP $ \msg ->+      case expected msg of+	Just m -> c m+	Nothing -> dropit++contMap op = m+  where m = get $ \ x -> op x $ \ y -> put y $ m+-- or:  where m = get $ flip op $ flip put m+++fContWrap :: Cont (FSP hi ho) a -> Cont (F hi ho) a+fContWrap waitsp = F{-ff-} . waitsp . fContSP+  where fContSP contF x = case contF x of F sp -> sp++kContWrap :: Cont (KSP hi ho) a -> Cont (K hi ho) a+kContWrap waitsp = K{-kk-} . waitsp . kContSP+  where kContSP contK x = case contK x of K sp -> sp
+ hsrc/lowlevel/Display.hs view
@@ -0,0 +1,17 @@+module Display(openDisplay) where+import Command+import Event+--import Font(FontStruct)+--import Fudget+--import Geometry(Line, Point, Rect, Size(..))+--import LayoutRequest(LayoutRequest)+import Xrequest+--import Xtypes++-- DECONSTR :: (a<->b) -> b -> (Maybe a) +openDisplay name =+    xrequestF (OpenDisplay name)+              (let e (DisplayOpened a) = Just a+                   e _ = Nothing+               in  e)+
+ hsrc/lowlevel/FudgetIO.hs view
@@ -0,0 +1,32 @@+module FudgetIO where+import Fudget+import EitherUtils(Cont(..))+import Message(stripLow,stripHigh)++{-+The purpose of the FudgetIO class is to allow the many IO operations that+can be performed from both fudgets and fudget kernels, e.g., createGC,+loadQueryFont and allocNamedColor, to use one overloaded name instead of+two separate names.+-}++class FudgetIO f where+  waitForMsg :: (KEvent hi -> Maybe ans) -> Cont (f hi ho) ans+  putMsg :: KCommand ho -> f hi ho -> f hi ho++  -- Less useful methods:+  --nullMsg :: f hi ho -- name ?!+  --getMsg :: (KEvent hi -> f hi ho) -> f hi ho++putMsgs msgs k = foldr putMsg k msgs+putHigh x = (putMsg . High) x+putLow x = (putMsg . Low) x+putLows lows k = foldr putLow k lows++getHigh x = waitForMsg stripHigh x+getLow x = waitForMsg stripLow x++cmdContMsg msg expected = putMsg msg . waitForMsg expected++cmdContLow cmd expected = cmdContMsg (Low cmd) expectLow+  where expectLow msg = stripLow msg >>= expected
+ hsrc/lowlevel/Srequest.hs view
@@ -0,0 +1,48 @@+module Srequest(select,sIOsucc,sIOstr,sIOerr,sIO,Cont(..)) where+import FRequest+import FudgetIO+import EitherUtils(Cont(..))+--import NullF(F,K)+import DialogueIO hiding (IOError) -- Select+import ShowFailure++sIOsucc sreq cont =+  socketIO sreq sFail $ \ r ->+  case r of+    Left Success -> cont+    Left r -> error ("sIOsucc: Expected Success, but got "++show r)+    Right r -> error ("sIOsucc: Expected Success, but got "++show r)++sIO sreq = sIOerr sreq sFail++sIOerr sreq fcont rcont =+    socketIO sreq fcont $ \ r ->+    case r of+      Right sr -> rcont sr+      Left dr -> error ("Socket IO: expected a SocketResponse, but got "++show dr)++sIOstr sreq cont =+  socketIO sreq sFail $ \ r ->+  case r of+    Left (Str s) -> cont s+    Left r -> error ("sIOsucc: Expected Str, but got "++show r)+    Right r -> error ("sIOsucc: Expected Str, but got "++show r)+    +---++sFail f = error ("Socket IO error: "++showFailure f)++socketIO sreq econt scont =+    cmdContLow (SReq sreq) expect $ either econt scont+  where expect msg =+          case msg of+            SResp sr -> Just (Right (Right sr))+	    DResp (Failure f) -> Just (Left f)+	    DResp r -> Just (Right (Left r))+            _ -> Nothing++----++select ds = putLow . DReq . Select $ ds+ -- no response from Select+-- eta expanded because of the monomorphism restriction
+ hsrc/lowlevel/TagEvents.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE CPP #-}+module TagEvents(tagEventsSP) where+import Command+import CompSP(preMapSP,serCompSP)+import SpEither(mapFilterSP)+import Cont(cmdContSP)+import CmdLineEnv(argFlag)+--import Direction+import Event+--import Font(FontStruct)+import Fudget+import FRequest+--import Geometry(Line, Point, Rect, Size(..))+import IOUtil(getEnvi)+--import LayoutRequest(LayoutRequest)+import Loopthrough+import Message(stripLow) --Message(..),+import Path+import WindowF(autumnize)+import ShowCommandF+import Sockets+import Spops+import Tables+--import Version+import Xtypes+--import Maptrace+--import EitherUtils+import Data.Maybe(isNothing)+import ShowFailure+import DialogueIO+import Prelude hiding (IOError)++--mtrace = ctrace "tagEvents"+mtrace x y = y++tagEventsSP :: F i o -> SP (Path, Response) (Path, Request)+tagEventsSP mainF =+    loopThroughRightSP+      tagEventsCtrlSP+      (mapFilterSP stripLow `serCompSP` mainFSP `preMapSP` Low)+  where+    F mainFSP = traceit mainF++openDisplay' cont =+    if isNothing (getEnvi "DISPLAY")+    then cont faildisp+    else+    cmdContSP (tox $ XRequest (noDisplay, noWindow, OpenDisplay ""))+              (\e ->+               case e of+                 Right (_, XResponse (DisplayOpened d)) -> Just d+                 Right (_, Failure f) -> error ("Cannot open the display (the program is probably not linked with the X routines): "++showFailure f)+                 _ -> Nothing)+              (\disp ->+               if disp == Display 0 then+                   error "Cannot open display"+               else+                   putSP (tox $ Select [DisplayDe disp]) $ cont disp)+  where faildisp = error "the environment variable DISPLAY is not set!"+        tox x = Right (here,x)++tagEventsCtrlSP::+    SP (Either TCommand (Path,Response)) (Either TEvent (Path,Request))+tagEventsCtrlSP =+    openDisplay' tagEventsCtrlSP'+  where+    tagEventsCtrlSP' disp =+	tagSP noSel Nothing path2wid0 wid2path0+      where+	noSel = here+	tagSP selp grabpath path2wid wid2path =+	  let same = tagSP selp grabpath path2wid wid2path+	      tagSPs = tagSP selp+	      tagSPns s = tagSP s grabpath path2wid wid2path+	  in getSP $ \msg -> case msg of+	    Left (path', cmd) ->+	      let newwindow path'' wid = +		    putSP (Left (path'', XResp (WindowCreated wid))) $+		    tagAdd path'' wid+		  tox xc = Right (path',xc)+		  convertcmd = convert (lookupWid path2wid path')+		  convert w cmd = putSP (tox (XCommand (disp, w, cmd)))+		  tagAdd p w = tagSPs grabpath (updateWid path2wid p w) +					       (updatePath wid2path w p)+	      in case cmd of+		 XCmd xcmd@(SetSelectionOwner s atom) ->+		 -- currently, different selections are not distinguished+		   convertcmd xcmd $ +		   (if s && selp /= noSel && path' /= selp then +		       putSP (Left (selp,XEvt (SelectionClear atom))) else id) $+		   tagSPns (if s then path' else noSel)+		 XCmd (ReparentToMe rchild w) -> +		   -- lookup w in table, change path to rchild, emit reparent cmd+		   -- TODO: change subpaths too!+		   let npath' = newChildPath path' rchild+		       npath = autumnize npath' -- used in repTest (?)+		       wpath = lookupPath wid2path w+		       opath = autumnize wpath+		       nparent = lookupWid path2wid path'+		       npath2wid = moveWids path2wid opath npath+		       nwid2path = movePaths wid2path opath npath+		   in convert w (ReparentWindow nparent) $+		      if null wpath+		      then {-ctrace "rep" (npath',opath,w) $-} tagAdd npath' w+		      else tagSPs grabpath npath2wid nwid2path+		 XCmd (SelectWindow w) -> tagAdd path' w+		 XCmd GetWindowId -> putSP (Left (path',XEvt (YourWindowId wid))) same+		     where wid = lookupWid path2wid path'+		 XCmd DestroyWindow ->+		   putsSP [tox (XCommand (disp, wid, DestroyWindow))+			  | wid <- subWids path2wid path']+			 (tagSPs grabpath (pruneWid path2wid path') wid2path)+		 XCmd (GrabEvents toMe) -> mtrace ("Grab",toMe,msg) $+		   tagSPs (Just (toMe,path',autumnize path')) path2wid wid2path+		 XCmd UngrabEvents -> tagSPs Nothing path2wid wid2path+		 --DoXCommands xcmds -> foldr convertcmd same xcmds+		 XCmd (DrawMany w gcdcmdss) | not optimizeDrawMany ->+		    foldr convertcmd same+		      [Draw w gc dcmd | (gc,dcmds)<-gcdcmdss,dcmd<-dcmds]+		 XCmd xcmd -> convertcmd xcmd same+		 DReq req -> putSP (tox req) same+		 SReq sreq -> putSP (tox (SocketRequest sreq)) same+		 XReq xreq ->+		   case xreq of+		     CreateMyWindow _ -> error "GUI fudget outside a shell fudget"+		     CreateSimpleWindow rchild _ ->+			createWindow disp xreq (lookupWid path2wid path')+				      (newwindow (newChildPath path' rchild))+		     CreateRootWindow _ _ -> +			 createWindow disp xreq rootWindow (newwindow path')+		     _ -> putSP (tox (XRequest (disp, +				  lookupWid path2wid path', xreq))) same+		 LCmd _ -> same -- layout pseudo command+	    Right (path', resp) -> case resp of+	      AsyncInput (_, XEvent (wid, event)) ->+		case event of+		  MappingNotify -> same+		  ButtonEvent {} -> checkGrab+		  KeyEvent {} -> checkGrab+		  MotionNotify {} -> checkGrab+		  SelectionClear atom -> pass $ tagSPns noSel+		  DestroyNotify w -> if argFlag "destroyPrune" False then+		     pass $ tagSPs grabpath path2wid' (prunePath wid2path w)+		    else passame+		    where path2wid' = if null path2' then path2wid+						    else pruneWid path2wid path2'+		  _ -> passame+		where path2' = lookupPath wid2path wid+		      passto p = putSP (Left (p, XEvt event))+		      pass = passto path2'+		      passame = pass same+		      checkGrab = case grabpath of+				    Nothing -> passame+				    Just (toMe,kpath,path) -> +				      if path `subPath` path2' then passame+				      else if toMe then passto kpath same+					   else same+              XResponse xresp -> putSP (Left (path',XResp xresp)) same+	      SocketResponse sresp -> putSP (Left (path',SResp sresp)) same+	      _ -> putSP (Left (path', DResp resp)) same++newChildPath parent rchild = absPath (autumnize parent) rchild+  +createWindow disp xreq wid cont =+    cmdContSP (Right (here, XRequest (disp, wid, xreq)))+              (\msg -> case msg of+                         Right (_, XResponse (WindowCreated wid')) -> Just wid'+                         _ -> Nothing)+              cont++traceit = showCommandF "debug"++optimizeDrawMany =+  argFlag "optdrawmany"+#ifdef __GLASGOW_HASKELL__+    True+#else+    False+#warning "not optimising DrawMany"+#endif
+ hsrc/lowlevel/WindowF.hs view
@@ -0,0 +1,148 @@+module WindowF(adjustBorderWidth,border_width,getBWidth,kernelF, toKernel, kernelTag,autumnize, windowKF) where+import Command+import CompOps((>+<))+import CompSP(prepostMapSP)+--import CompSP(serCompSP)+import Utils(pair,mapList)+import Direction+import Event+--import Font(FontStruct)+import Fudget+import FRequest+import Geometry(Point(..), Rect(..), origin, padd, pmax, rR)+import LayoutRequest+import LoopLow+--import Message(Message(..))+import NullF+import Path+--import SerCompF(idRightF)+import CompFfun(prepostMapLow)+import Spops+--import EitherUtils+import Data.Maybe(fromMaybe,isJust)+import Xtypes+import CmdLineEnv(argFlag)+--import DialogueIO hiding (IOError)++kernelF :: (K a b) -> F a b+kernelF (K proc) =+    let prep (High a) = High a+        prep (Low (_, b)) = Low b+        post (High a) = High a+        post (Low b) = Low (here, b)+    in  {-F-}ff (prepostMapSP prep post proc)++toLowHere = mapList (Low . pair here)++winF :: (Rect -> FRequest) -> [FRequest] -> Rect -> K a b -> F a b+winF winCmd startcmds rect w =+    putMessagesF (toLowHere (winCmd rect : startcmds)) (kernelF w)++newKTag = not (argFlag "oldKTag" True) -- trouble with autolayout...++kernelTag = if newKTag then here else turn L here+autumnize  = if newKTag then id else autumnize' where+  autumnize' [] = []+  autumnize' l = (reverse . tail . reverse) l+++toKernel x = mapList (Low . pair kernelTag) x++getBWidth cws = case cws of+   [] -> Nothing+   CWBorderWidth bw':_ -> Just bw'+   _:cws -> getBWidth cws++adjustBorderWidth b (Point x y) = Point (x+b2) (y+b2) where b2 = 2*b++border_width = 0::Int -- Should agree with the value in the core for XCreateSimpleWindow in xdecode.c and ghc-dialogue/DoXRequest.hs++windowKF :: (Rect -> FRequest) -> Bool -> Bool -> [FRequest] -> Maybe Rect -> K a b -> F c d -> F (Either a c) (Either b d)+windowKF winCmd isShell nomap startcmds oplace k f =+ let ctrlSP (bw,nomap) =+       getSP $ \msg ->+       let same = ctrlSP (bw,nomap)+           pass = putSP msg +	   passame = pass same+	   adjB b s = if isShell then s else adjustBorderWidth b s+       in case msg of+         Left (tag,cmd) -> case cmd of+            XReq (CreateMyWindow r) | tag /= kernelTag ->+		   putSP (Left (kernelTag, +	                    XReq (CreateSimpleWindow tag r))) same+	    XCmd (ReparentToMe r w) | r == here && tag /= kernelTag ->+		   putSP (Left (kernelTag,XCmd (ReparentToMe tag w))) same+            XCmd (ConfigureWindow cws) | tag == kernelTag -> +	        -- hopefully, this occurs before LayoutMsg+		let bw' = fromMaybe bw (getBWidth cws) in+		if bw'==bw' then pass $ ctrlSP (bw',nomap) else error "windowKF"+            LCmd (LayoutRequest req) ->+	        putSP (Left (tag,layoutRequestCmd (mapLayoutSize (adjB bw) req))) $+		same+	    _ -> passame+	 Right (tag,evt) -> case evt of+	    XResp (WindowCreated _) | tag==kernelTag -> same +	    -- does not correspond to internal request+            LEvt (LayoutPlace (Rect p s)) -> let ads = adjB (-bw) s in+	       putsSP ([Right (tag, LEvt (LayoutPlace (Rect origin ads))),+		      Right (kernelTag, LEvt (LayoutSize ads)),+		      Right (kernelTag, LEvt (LayoutPos p))] ++   -- TH 990321+		       (if isShell then []+		        else mapList (Left. pair kernelTag)+			         ([XCmd $ moveResizeWindow (checkSize (Rect p ads))] +++			          (if nomap || static then []+				   else [XCmd MapRaised])))) $+               ctrlSP (bw,True)+	    -- The LayoutSize message is not sent by the ordinary layout+	    -- system, but by popupGroupF for convenience, to resize the+	    -- window without moving it.+            LEvt (LayoutSize s) -> let ads = adjB (-bw) s in+	       putsSP ([Right (tag, LEvt (LayoutPlace (Rect origin ads))),+		      Right (kernelTag, LEvt (LayoutSize ads))] +++		       (if isShell then []+		        else [(Left. pair kernelTag)+			        (XCmd $ resizeWindow (pmax ads minSize))])) $+               same+	    _ -> passame++     minSize = Point 1 1+     checkSize (Rect p s) = Rect p (pmax s minSize)+     static = isJust oplace+     startplace =+	 case oplace of+	   Nothing -> rR 0 0 10 10+	   Just p -> p+     statlimits (Rect p s) = layoutRequestCmd (plainLayout (padd p s) True True)+     wf =+	 winF winCmd+	      (startcmds +++	       (case oplace of+		  Nothing -> []+		  Just r -> [statlimits r] +++			    (if nomap then [] else [XCmd MapRaised])))+	      startplace+	      k+     wff = adjTag (wf>+<f)+     adjTag = if newKTag then prepostMapLow addktag removektag else id where+	    addktag ([],m) = ([L],m)+	    addktag tm = tm+	    removektag ([L],m) = ([],m)+	    removektag tm = tm++     windowf = loopThroughLowF (ctrlSP (border_width,nomap)) wff+     --windowf = windowf' ctrlSP nomap wf f+ in  case oplace of+          Nothing -> windowf+          Just place -> let prep' (High ltag) = [(ltag, LEvt (LayoutPlace place))]+                            prep' (Low (_, LEvt (LayoutPlace _))) = []+                            prep' (Low msg) = [msg]+                            post' (ltag, LCmd _) = [High ltag]+                            post' cmd = [Low cmd]+                        in  loopLow (concmapSP post') (concmapSP prep') windowf++{-+windowf' ctrlSP nomap wf f =+  let wff = wf>+<f+      windowf = loopThroughLowF (ctrlSP (border_width,nomap)) wff+  in windowf+--}
+ hsrc/lowlevel/Xcommand.hs view
@@ -0,0 +1,15 @@+module Xcommand(+  xcommand,xcommandK,xcommandF,+  xcommands,xcommandsK,xcommandsF) where+import FRequest+import FudgetIO+import NullF(F,K)++xcommandK = xcommand :: (XCommand -> K i o -> K i o)+xcommandF = xcommand :: (XCommand -> F i o -> F i o)++xcommandsK = xcommands :: ([XCommand] -> K i o -> K i o)+xcommandsF = xcommands :: ([XCommand] -> F i o -> F i o)++xcommand xcmd = putLow (XCmd xcmd)+xcommands xcmds = putLows (map XCmd xcmds)
+ hsrc/lowlevel/Xrequest.hs view
@@ -0,0 +1,31 @@+module Xrequest(xrequest,xrequestF, xrequestK,Cont(..)) where+--import Command(XRequest)+--import Event(XResponse)+import FRequest+import FudgetIO+import EitherUtils(Cont(..))+import NullF(F,K)+--import DialogueIO hiding (IOError)++xrequestK = xrequest :: (XRequest -> (XResponse -> Maybe a) -> Cont (K b c) a)+xrequestF = xrequest :: (XRequest -> (XResponse -> Maybe a) -> Cont (F b c) a)++xrequest xreq expected = cmdContLow (XReq xreq) expectXResp+  where expectXResp msg =+          case msg of+            XResp xr -> expected xr+            _ -> Nothing++{- old:+xrequestK = xrequest cmdContK++xrequestF = xrequest cmdContF++xrequest k cmd exp' =+    k (DoXRequest cmd)+      (\msg ->+       case msg of+         IOResponse (XResponse xr) -> exp' xr+         _ -> Nothing)++-}
+ hsrc/sp/CompSP.hs view
@@ -0,0 +1,156 @@+module CompSP(prepostMapSP, postMapSP, preMapSP, idRightSP, idLeftSP, idHighSP,+              idLowSP, compMsgSP, compSP, compEitherSP, serCompSP) where+import Message(Message(..))+import SP+import Spops++--serCompSP :: SP b c -> SP a b -> SP a c+serCompSP sp1 sp2 =+    case sp1 of+      PutSP y sp1' -> PutSP y (serCompSP sp1' sp2)+      GetSP xsp1 -> serCompSP1 xsp1 sp2+      NullSP -> NullSP++serCompSP1 xsp1 sp2 =+    case sp2 of+      PutSP y sp2' -> serCompSP (xsp1 y) sp2'+      GetSP xsp2 -> GetSP (serCompSP1 xsp1 . xsp2)+      NullSP -> NullSP++---++compSP = compEitherSP++--compEitherSP :: SP a1 b1 -> SP a2 b2 -> SP (Either a1 a2) (Either b1 b2)+compEitherSP sp1 sp2 =+    case sp1 of+      PutSP y sp1' -> PutSP (Left y) (compEitherSP sp1' sp2)+      GetSP xsp1 -> compEitherSP1 xsp1 sp2+      NullSP -> rEitherSP sp2++--and compEitherSP1 :: (*a1->SP *a1 *b1) -> SP *a2 *b2 -> SP (Either *a1 *a2) (Either *b1 *b2)+compEitherSP1 xsp1 sp2 =+    case sp2 of+      PutSP y sp2' -> PutSP (Right y) (compEitherSP1 xsp1 sp2')+      GetSP xsp2 -> compEitherSP12 xsp1 xsp2+      NullSP -> lEitherSP (GetSP xsp1)++--and compEitherSP2 :: (SP *a1 *b1) -> (*a2->SP *a2 *b2) -> SP (Either *a1 *a2) (Either *b1 *b2)+compEitherSP2 sp1 xsp2 =+    case sp1 of+      PutSP y sp1' -> PutSP (Left y) (compEitherSP2 sp1' xsp2)+      GetSP xsp1 -> compEitherSP12 xsp1 xsp2+      NullSP -> rEitherSP (GetSP xsp2)++--and compEitherSP12 :: (*a1->SP *a1 *b1) -> (*a2->SP *a2 *b2) -> SP (Either *a1 *a2) (Either *b1 *b2)+compEitherSP12 xsp1 xsp2 =+    GetSP (\x ->+           case x of+             Left a -> compEitherSP2 (xsp1 a) xsp2+             Right b -> compEitherSP1 xsp1 (xsp2 b))++lEitherSP sp1 =+    case sp1 of+      PutSP y sp1' -> PutSP (Left y) (lEitherSP sp1')+      GetSP xsp1 -> lEitherSP1 xsp1+      NullSP -> NullSP++lEitherSP1 xsp1 =+    GetSP (\x ->+           case x of+             Left a -> lEitherSP (xsp1 a)+             Right b -> lEitherSP1 xsp1)++rEitherSP sp2 =+    case sp2 of+      PutSP y sp2' -> PutSP (Right y) (rEitherSP sp2')+      GetSP xsp2 -> rEitherSP2 xsp2+      NullSP -> NullSP++rEitherSP2 xsp2 =+    GetSP (\x ->+           case x of+             Right a -> rEitherSP (xsp2 a)+             Left b -> rEitherSP2 xsp2)++---+--and preMapSP :: SP *b *c -> (*a->*b) -> SP *a *c+preMapSP sp pre =+    case sp of+      PutSP y sp' -> PutSP y (preMapSP sp' pre)+      GetSP xsp -> GetSP (\x -> preMapSP (xsp (pre x)) pre)+      NullSP -> NullSP++--and postMapSP :: (*b->*c) -> SP *a *b -> SP *a *c+postMapSP post sp =+    case sp of+      PutSP y sp' -> PutSP (post y) (postMapSP post sp')+      GetSP xsp -> GetSP (\x -> postMapSP post (xsp x))+      NullSP -> NullSP++prepostMapSP pre post sp =+    case sp of+      PutSP y sp' -> PutSP (post y) (prepostMapSP pre post sp')+      GetSP xsp -> GetSP (\x -> prepostMapSP pre post (xsp (pre x)))+      NullSP -> NullSP++---+idLowSP sp = compMsgSP idSP sp++idHighSP sp = compMsgSP sp idSP++idLeftSP sp = compEitherSP idSP sp++idRightSP sp = compEitherSP sp idSP++---+--and compMsgSP :: SP *a1 *b1 -> SP *a2 *b2 -> SP (Message *a1 *a2) (Message *b1 *b2)+-- compMsgSP was constructed from compEitherSP with some global substitutions+compMsgSP sp1 sp2 =+    case sp1 of+      PutSP y sp1' -> PutSP (Low y) (compMsgSP sp1' sp2)+      GetSP xsp1 -> compMsgSP1 xsp1 sp2+      NullSP -> rMsgSP sp2++compMsgSP1 xsp1 sp2 =+    case sp2 of+      PutSP y sp2' -> PutSP (High y) (compMsgSP1 xsp1 sp2')+      GetSP xsp2 -> compMsgSP12 xsp1 xsp2+      NullSP -> lMsgSP (GetSP xsp1)++compMsgSP2 sp1 xsp2 =+    case sp1 of+      PutSP y sp1' -> PutSP (Low y) (compMsgSP2 sp1' xsp2)+      GetSP xsp1 -> compMsgSP12 xsp1 xsp2+      NullSP -> rMsgSP (GetSP xsp2)++compMsgSP12 xsp1 xsp2 =+    GetSP (\x ->+           case x of+             Low a -> compMsgSP2 (xsp1 a) xsp2+             High b -> compMsgSP1 xsp1 (xsp2 b))++lMsgSP sp1 =+    case sp1 of+      PutSP y sp1' -> PutSP (Low y) (lMsgSP sp1')+      GetSP xsp1 -> lMsgSP1 xsp1+      NullSP -> NullSP++lMsgSP1 xsp1 =+    GetSP (\x ->+           case x of+             Low a -> lMsgSP (xsp1 a)+             High b -> lMsgSP1 xsp1)++rMsgSP sp2 =+    case sp2 of+      PutSP y sp2' -> PutSP (High y) (rMsgSP sp2')+      GetSP xsp2 -> rMsgSP2 xsp2+      NullSP -> NullSP++rMsgSP2 xsp2 =+    GetSP (\x ->+           case x of+             High a -> rMsgSP (xsp2 a)+             Low b -> rMsgSP2 xsp2)+
+ hsrc/sp/Dynforkmerge.hs view
@@ -0,0 +1,34 @@+module Dynforkmerge(DynMsg(..), DynSPMsg(..), dynforkmerge) where+import SP+import Utils(part)++data DynMsg a b = DynCreate b |+                  DynDestroy |+                  DynMsg a +                  deriving (Eq, Ord)++type DynSPMsg a b = DynMsg a (SP a b)++dynforkmerge :: Eq a => SP (a, DynSPMsg b c) (a, c)+dynforkmerge = dfm []++dfm dynxsps =+    GetSP (\msg ->+           case msg of+             (t, DynCreate dynsp) -> dfmout t dynsp dynxsps+             (t, DynMsg msg') -> dfmin t msg' dynxsps+             (t, DynDestroy) -> dfmrm t dynxsps)++dfmout t dynsp dynxsps =+    case dynsp of+      PutSP y sp' -> PutSP (t, y) (dfmout t sp' dynxsps)+      GetSP xsp -> dfm ((t, xsp) : dynxsps)+      NullSP -> dfm dynxsps++dfmin t msg dynxsps =+    case part ((== t) . fst) dynxsps of+      ([], _) -> dfm dynxsps+      ([(_, xsp)], dynxsps') -> dfmout t (xsp msg) dynxsps'+      _ -> error "Same tag used twice in dynforkmerge (or dynListF)."++dfmrm t dynxsps = dfm (filter ((t /=) . fst) dynxsps)
+ hsrc/sp/IdempotSP.hs view
@@ -0,0 +1,17 @@+module IdempotSP where+import Spops(getSP,putSP)+import SP(SP)++idempotSP :: Eq a => SP a a+idempotSP =+    getSP $ \ x ->+    putSP x $+    idempotSP' x+  where+    idempotSP' x =+      getSP $ \ x' ->+      (if x'==x+       then id+       else putSP x') $+      idempotSP' x'+
+ hsrc/sp/InputSP.hs view
@@ -0,0 +1,70 @@+module InputSP where+import InputMsg+import Spops+import CompSP(serCompSP)+import SpEither(mapFilterSP)+import Utils(replace,setFst,setSnd)++-- New version: works with abstract InputMsg.+inputPairSP = mapFilterSP lift `serCompSP` ipSP (Nothing,Nothing)+  where+    ipSP optvalues = getSP $ either (change setFst) (change setSnd)+      where+	change setOne inputmsg =+	    putSP (mapInp (const optvalues') inputmsg) $+	    ipSP optvalues'+	  where+	    optvalues' = setOne optvalues (Just $ stripInputMsg inputmsg)++    lift = liftMaybeInputMsg . mapInp liftMaybePair++    liftMaybePair (Just x,Just y) = Just (x,y)+    liftMaybePair _               = Nothing++    liftMaybeInputMsg m = fmap im (stripInputMsg m)+      where im x = mapInp (const x) m++{- -- old version:+inputPairSP = ipSP Nothing Nothing+  where+    ipSP optx opty =+        getSP $ \msg ->+          case msg of+	    Left (InputChange x) -> changeL InputChange x+	    Left (InputDone k x) -> changeL (InputDone k) x+	    Right (InputChange y) -> changeR InputChange y+	    Right (InputDone k y) -> changeR (InputDone k) y+      where+        changeL f x =+            case opty of+	      Just y -> putsSP [f (x,y)] cont+	      Nothing -> cont+	  where cont = ipSP (Just x) opty+        changeR f y =+            case optx of+	      Just x -> putsSP [f (x,y)] cont+	      Nothing -> cont+	  where cont = ipSP optx (Just y)+-}++inputListSP tags = ilSP [(tag,Nothing)|tag<-tags]+  where+    ilSP acc =+        getSP $ \(t,msg) ->+          case msg of+	    InputChange x -> change t InputChange x+	    InputDone k x -> change t (InputDone k) x+      where+        change t f x = putsSP [f [(t,x)|(t,Just x)<-acc']] (ilSP acc')+	  where acc' = replace (t,Just x) acc+++stripInputSP = mapFilterSP notLeave+  where +    notLeave (InputChange s) = Just s+    notLeave (InputDone k s) = if k == inputLeaveKey+                               then Nothing+			       else Just s++inputDoneSP = mapFilterSP inputDone+inputLeaveDoneSP = mapFilterSP inputLeaveDone
+ hsrc/sp/Loop.hs view
@@ -0,0 +1,69 @@+module Loop(loopLeftSP,loopSP,loopOnlySP) where+import SP+import Queue++-- New versions with explicit queues for improved efficiency:+-- (Adding a message to the loop queue is O(1) instead of O(n), n=queue length.)++loopLeftSP sp = llSP empty sp+  where+    llSP q sp =+      case sp of+	PutSP (Right out) sp' -> PutSP out (llSP q sp')+	PutSP (Left loop') sp' -> llSP (enter q loop') sp'+	GetSP xsp ->+	  case qremove q of+	    Just (loop',q') -> llSP q' (xsp (Left loop'))+	    Nothing -> GetSP (loopLeftSP.xsp.Right)+	NullSP -> NullSP++loopSP sp = lSP empty sp+  where+    lSP q sp =+      case sp of+	PutSP x sp' -> PutSP x (lSP (enter q x) sp')+	GetSP xsp ->+	  case qremove q of+	    Just (x,q') -> lSP q' (xsp x)+	    Nothing -> GetSP (loopSP.xsp)+	NullSP -> NullSP++loopOnlySP sp = loSP empty sp+  where+    loSP q sp =+      case sp of+	PutSP x sp' -> loSP (enter q x) sp'+	GetSP xsp ->+	  case qremove q of+	    Just (x,q') -> loSP q' (xsp x)+	    Nothing -> GetSP (loopOnlySP.xsp)+	NullSP -> NullSP+++{--- old:++loopLeftSP sp =+    case sp of+      PutSP (Right out) sp' -> PutSP out (loopLeftSP sp')+      PutSP (Left loop') sp' -> loopLeftSP (feed1SP (Left loop') sp')+      GetSP xsp -> GetSP (loopLeftSP.xsp.Right)+      NullSP -> NullSP++loopSP sp =+  case sp of+    PutSP x sp' -> PutSP x (loopSP (feed1SP x sp'))+    GetSP xsp -> GetSP (loopSP.xsp)+    NullSP -> NullSP++loopOnlySP sp =+  case sp of+    PutSP x sp' -> loopOnlySP (feed1SP x sp')+    GetSP xsp -> GetSP (loopOnlySP.xsp)+    NullSP -> NullSP++feed1SP x sp =+    case sp of+      PutSP y sp' -> PutSP y (feed1SP x sp')+      GetSP xsp' -> xsp' x+      NullSP -> NullSP+-}
+ hsrc/sp/Loopthrough.hs view
@@ -0,0 +1,79 @@+module Loopthrough(loopThroughRightSP) where+import SP+--import Spops+import Queue++loopThroughRightSP sp1 sp2 = ltrSP empty sp1 sp2++-- When sp1 and sp2 are unknown:+ltrSP q sp1 sp2 =+    case sp1 of+      PutSP (Right out) sp1' -> PutSP out (ltrSP q sp1' sp2)+      PutSP (Left loop') sp1' -> ltrSP (enter q loop') sp1' sp2+      GetSP xsp1 -> ltrSP1 q xsp1 sp2+      NullSP -> NullSP++-- When sp1 is waiting for input:+ltrSP1 q xsp1 sp2 =+    case sp2 of+      PutSP x sp2' -> ltrSP q (xsp1 (Left x)) sp2'+      GetSP xsp2 ->+	case qremove q of+	  Just (x,q') -> ltrSP1 q' xsp1 (xsp2 x)+	  Nothing -> GetSP (\x -> ltrSP2 (xsp1 (Right x)) xsp2)+      NullSP -> GetSP (lltrSP . xsp1 . Right)++-- When sp2 is waiting for input:+ltrSP2 sp1 xsp2 =+    case sp1 of+      PutSP (Right out) sp1' -> PutSP out (ltrSP2 sp1' xsp2)+      PutSP (Left loop') sp1' -> loopThroughRightSP sp1' (xsp2 loop')+      GetSP xsp1 -> GetSP (\x -> ltrSP2 (xsp1 (Right x)) xsp2)+      NullSP -> NullSP++-- When sp2 has terminated:+lltrSP sp1 =+    case sp1 of+      PutSP (Right out) sp1' -> PutSP out (lltrSP sp1')+      PutSP (Left loop') sp1' -> lltrSP sp1'+      GetSP xsp1 -> GetSP (lltrSP . xsp1 . Right)+      NullSP -> NullSP++{- old (inefficient queueing and too strict in sp2):++loopThroughRightSP sp1 sp2 =+    case sp1 of+      PutSP (Right out) sp1' -> PutSP out (loopThroughRightSP sp1' sp2)+      PutSP (Left loop') sp1' -> case sp2 of+                                  GetSP xsp2 -> loopThroughRightSP sp1'+                                                                   (xsp2 loop')+                                  NullSP -> lltrSP sp1'+                                  _ -> loopThroughRightSP sp1'+                                                          (feedSP' loop' [] sp2)+      GetSP xsp1 -> ltrSP1 xsp1 sp2+      NullSP -> NullSP++ltrSP1 xsp1 sp2 =+    case sp2 of+      PutSP x sp2' -> loopThroughRightSP (xsp1 (Left x)) sp2'+      GetSP xsp2 -> GetSP (\x -> ltrSP2 (xsp1 (Right x)) xsp2)+      NullSP -> GetSP (lltrSP . xsp1 . Right)++ltrSP2 sp1 xsp2 =+    case sp1 of+      PutSP (Right out) sp1' -> PutSP out (ltrSP2 sp1' xsp2)+      PutSP (Left loop') sp1' -> loopThroughRightSP sp1' (xsp2 loop')+      GetSP xsp1 -> GetSP (\x -> ltrSP2 (xsp1 (Right x)) xsp2)+      NullSP -> NullSP++lltrSP sp1 =+    case sp1 of+      PutSP (Right out) sp1' -> PutSP out (lltrSP sp1')+      PutSP (Left loop') sp1' -> lltrSP sp1'+      GetSP xsp1 -> GetSP (lltrSP . xsp1 . Right)+      NullSP -> NullSP++-- normal code+feedSP' = feedSP++-}
+ hsrc/sp/ParSP.hs view
@@ -0,0 +1,21 @@+module ParSP(seqSP, parSP) where+import SP++parSP sp1 sp2 =+    case sp1 of+      PutSP y sp1' -> PutSP y (parSP sp1' sp2)+      GetSP xsp1 -> parSP1 xsp1 sp2+      NullSP -> sp2++parSP1 xsp1 sp2 =+    case sp2 of+      PutSP y sp2' -> PutSP y (parSP1 xsp1 sp2')+      GetSP xsp2 -> GetSP (\x -> parSP (xsp1 x) (xsp2 x))+      NullSP -> GetSP xsp1++seqSP sp1 sp2 =+    case sp1 of+      PutSP y sp1' -> PutSP y (seqSP sp1' sp2)+      GetSP xsp -> GetSP (\x -> seqSP (xsp x) sp2)+      NullSP -> sp2+
+ hsrc/sp/SP.hs view
@@ -0,0 +1,8 @@+module SP where+import ShowFun() -- show instance for function types++data SP a b = PutSP b (SP a b) |+              GetSP (a -> SP a b) |+              NullSP +          deriving (Show)+
+ hsrc/sp/SPmonad.hs view
@@ -0,0 +1,26 @@+module SPmonad where+import SP(SP)+import ParSP(seqSP)+import Spops+import StateMonads(Mk(..),toMkc) --,bmk,toMs++type SPm i o ans = Mk (SP i o) ans++putsSPm :: [o] -> SPm i o ()+putsSPm = toMkc . putsSP++putSPm :: o -> SPm i o ()+putSPm = toMkc . putSP++getSPm :: SPm i o i+getSPm = Mk getSP++nullSPm :: SPm i o ()+nullSPm = return ()++monadSP :: (SPm i o ()) -> SP i o+monadSP (Mk spm) = spm (const nullSP)++toSPm :: (SP i o) -> SPm i o ()+toSPm sp = toMkc (seqSP sp)+
+ hsrc/sp/SPstateMonad.hs view
@@ -0,0 +1,23 @@+module SPstateMonad where+import SP(SP)+import Spops+import StateMonads(Mk(..),Ms(..),toMs,toMsc,loadMs,storeMs)++type SPms i o s ans = Ms (SP i o) s ans++putsSPms :: [o] -> SPms i o s ()+putSPms :: o -> SPms i o s ()+getSPms :: SPms i o s i+nullSPms :: SPms i o s ()+loadSPms :: SPms i o s s+storeSPms :: s -> SPms i o s ()+stateMonadSP :: s -> SPms i o s ans -> (ans -> SP i o) -> SP i o++putsSPms  = toMsc . putsSP+putSPms   = toMsc . putSP+getSPms   = toMs getSP+nullSPms  = return ()+loadSPms  = loadMs+storeSPms = storeMs++stateMonadSP s0 (Mk spm) sp = spm (\ans state->sp ans) s0
+ hsrc/sp/SpEither.hs view
@@ -0,0 +1,19 @@+module SpEither where+import SP+import EitherUtils(stripLeft,stripRight)+import Spops(concatMapSP)++mapFilterSP f = m+  where m = GetSP $ \x->+	    case f x of+	      Just y  -> PutSP y m+	      Nothing -> m++filterLeftSP = mapFilterSP stripLeft+filterRightSP = mapFilterSP stripRight++filterJustSP = mapFilterSP id++splitSP = concatMapSP (\(x, y) -> [Left x, Right y])++toBothSP = concatMapSP (\x -> [Left x, Right x])
+ hsrc/sp/Spinterp.hs view
@@ -0,0 +1,9 @@+module Spinterp(interpSP) where+import SP++interpSP put get null' sp =+    case sp of+      PutSP x sp' -> put x (interpSP put get null' sp')+      GetSP xsp -> get (\x -> interpSP put get null' (xsp x))+      NullSP -> null'+
+ hsrc/sp/Spops.hs view
@@ -0,0 +1,96 @@+module Spops(module Spops,Cont(..)) where+import SP+import EitherUtils(Cont(..))++{- INLINE nullSP -}+nullSP :: SP a b+nullSP = NullSP++putsSP :: [b] -> SP a b -> SP a b+putsSP [] sp = sp+putsSP (x : xs) sp = PutSP x (putsSP xs sp)++{- INLINE putSP -}+putSP :: b -> SP a b -> SP a b+putSP = PutSP++appendStartSP :: [b] -> SP a b -> SP a b+appendStartSP zs (PutSP y sp) = PutSP y (putsSP zs sp)+appendStartSP zs sp = putsSP zs sp++stepSP :: [b] -> Cont (SP a b) a+stepSP ys xsp = putsSP ys (GetSP xsp)++getSP :: Cont (SP a b) a+getSP = GetSP++walkSP sp x =+    case sp of+      PutSP y sp' -> let (ys, sp'') = walkSP sp' x+                     in  (y : ys, sp'')+      GetSP xsp' -> pullSP (xsp' x)+      NullSP -> ([], NullSP)++pullSP sp =+    case sp of+      PutSP y sp' -> let (ys, sp'') = pullSP sp'+                     in  (y : ys, sp'')+      _ -> ([], sp)++runSP sp xs =+    case sp of+      PutSP y sp' -> y : runSP sp' xs+      GetSP xsp -> case xs of+                     x : xs' -> runSP (xsp x) xs'+                     [] -> []+      NullSP -> []++feedSP :: a -> [a] -> SP a b -> SP a b+feedSP x xs sp =+    case sp of+      PutSP y sp' -> PutSP y (feedSP x xs sp')+      GetSP xsp' -> startupSP xs (xsp' x)+      NullSP -> NullSP++startupSP :: [a] -> SP a b -> SP a b+startupSP [] sp = sp+startupSP (x : xs) sp = feedSP x xs sp++delaySP sp = GetSP (\x -> startupSP [x] sp)++mapSP f = m where m = GetSP (\x -> PutSP (f x) m)++idSP = GetSP (\x -> PutSP x idSP)++--and concatMapSP :: (*a->[*b]) -> SP *a *b+concatMapSP f = m where m = GetSP (\x -> putsSP (f x) m)++concmapSP = concatMapSP++concatMapAccumlSP f s0 =+    GetSP (\x ->+           let (s, y) = f s0 x+           in putsSP y (concatMapAccumlSP f s))++mapstateSP = concatMapAccumlSP++mapAccumlSP f s0 =+    GetSP (\x ->+           let (s, y) = f s0 x+           in PutSP y (mapAccumlSP f s))++concatSP = GetSP (\xs -> putsSP xs concatSP)+concSP = concatSP++zipSP (x : xs) = getSP (\y -> putSP (x, y) (zipSP xs))+zipSP [] = nullSP++filterSP p = getSP (\x -> (if p x then putSP x else id) (filterSP p))++splitAtElemSP :: (a -> Bool) -> Cont (SP a b) [a]+splitAtElemSP p xsp =+    let lSP acc =+            getSP (\x -> if p x then xsp (reverse acc) else lSP (x : acc))+    in  lSP []++chopSP splitSP' = splitSP' (\xs -> putSP xs (chopSP splitSP'))
+ hsrc/sp/StreamProc.hs view
@@ -0,0 +1,16 @@+module StreamProc (-- * Stream processors+  module CompSP,module Dynforkmerge,module Loop,module Loopthrough,module ParSP,module SP,module SPmonad,module SPstateMonad,module Spinterp,module Spops,module SpEither,module IdempotSP,module StreamProcIO,module InputSP) where+import CompSP+import Dynforkmerge+import Loop+import Loopthrough+import ParSP+import SP(SP)+import SPmonad+import SPstateMonad+import Spinterp+import Spops+import SpEither+import IdempotSP+import StreamProcIO+import InputSP
+ hsrc/sp/StreamProcIO.hs view
@@ -0,0 +1,14 @@+module StreamProcIO where+import SP++class StreamProcIO sp where -- or: SPIO SP_IO SpIO SpIo ?+  put :: o -> sp i o -> sp i o+  get :: (i -> sp i o) -> sp i o+  end :: sp i o -- null?++puts xs sp = foldr put sp xs++instance StreamProcIO SP where+  put = PutSP+  get = GetSP+  end = NullSP
+ hsrc/types/Direction.hs view
@@ -0,0 +1,3 @@+module Direction(Direction(..)) where++data Direction = L | R | Dno Int  deriving (Eq, Ord, Read, Show)
+ hsrc/types/Drawcmd.hs view
@@ -0,0 +1,37 @@+module Drawcmd(move, moveDrawCommands, moveDrawCommand) where+import DrawTypes+import Geometry(Move(..))+--import Xtypes++instance Move DrawCommand where move = flip moveDrawCommand++moveDrawCommand cmd v =+    case cmd of+      DrawLine l -> DrawLine (move v l)+      DrawLines cm ps -> DrawLines cm (movePoints cm ps v)+      DrawImageString p s -> DrawImageString (move v p) s+      DrawString p s -> DrawString (move v p) s+      DrawRectangle r -> DrawRectangle (move v r)+      FillRectangle r -> FillRectangle (move v r)+      FillPolygon shape coordMode ps ->+	FillPolygon shape coordMode (movePoints coordMode ps v)+      DrawArc r a1 a2 -> DrawArc (move v r) a1 a2+      FillArc r a1 a2 -> FillArc (move v r) a1 a2+      CopyArea d r p -> CopyArea d r (move v p)+      CopyPlane d r p n -> CopyPlane d r (move v p) n+      DrawPoint p -> DrawPoint (move v p)+      CreatePutImage r fmt pxls -> CreatePutImage (move v r) fmt pxls+      DrawImageStringPS p s -> DrawImageStringPS (move v p) s+      DrawStringPS p s -> DrawStringPS (move v p) s+      DrawImageString16 p s -> DrawImageString16 (move v p) s+      DrawString16 p s -> DrawString16 (move v p) s++movePoints cm ps v =+ case cm of+   CoordModeOrigin -> move v ps+   CoordModePrevious ->+     case ps of+       p:ps' -> move v p:ps'+       [] -> []++moveDrawCommands cmds p = map (`moveDrawCommand` p) cmds
+ hsrc/types/Fudget.hs view
@@ -0,0 +1,44 @@+module Fudget(+  module Fudget,SP,+  --XCommand,XEvent,+  FRequest,FResponse,+  Message(..),Path(..),Direction) where+--import Command(XCommand)+--import Event(XEvent)+import FRequest(FRequest,FResponse)+import Message(Message(..))+import Direction(Direction)+import Path(Path(..))+import SP(SP)++type TEvent   = (Path, FResponse)+type TCommand = (Path, FRequest)++type Fa a b c d = SP (Message a c) (Message b d)++type FEvent a = Message TEvent a+type KEvent a = Message FResponse a++type FCommand a = Message TCommand a+type KCommand a = Message FRequest a++type Fudget a b = F a b++-- Traditional definitions:+--type F a b = Fa TEvent TCommand a b+--type K a b = Fa XEvent XCommand a b++-- New definitions:++type FSP hi ho = SP (FEvent hi) (FCommand ho)     --  = old def of F hi ho+type KSP hi ho = SP (KEvent hi) (KCommand ho)     --  = old def of K hi ho++newtype F hi ho = F (FSP hi ho)+newtype K hi ho = K (KSP hi ho)+--data F hi ho = F (FSP hi ho)+--data K hi ho = K (KSP hi ho)++kk=K+ff=F+unK (K sp) = sp+unF (F sp) = sp
+ hsrc/types/InputMsg.hs view
@@ -0,0 +1,41 @@+-- | Types for messages from buttons and input fields+module InputMsg where+import AuxTypes(KeySym(..))++-- | Button clicks+data Click = Click  deriving (Eq, Ord, Show)++-- | Output from dialog popups with OK and Cancel buttons+data ConfirmMsg = Confirm | Cancel  deriving (Eq, Ord, Show)++toConfirm (Left _)  = Confirm+toConfirm (Right _) = Cancel+fromConfirm Confirm = Left Click+fromConfirm Cancel  = Right Click++data InputMsg a = InputChange a |+                  InputDone KeySym a +                  deriving (Eq, Ord, Show)++inputMsg = InputDone inputButtonKey+inputChange = InputChange++inputButtonKey = "." :: KeySym+inputLeaveKey  = ""  :: KeySym++stripInputMsg (InputDone _ x) = x+stripInputMsg (InputChange x) = x++tstInp p (InputChange s) = p s+tstInp p (InputDone k s) = p s++mapInp f (InputChange s) = InputChange (f s)+mapInp f (InputDone k s) = InputDone k (f s)++instance Functor InputMsg where fmap = mapInp++inputDone (InputDone k s) | k /= inputLeaveKey = Just s+inputDone _ = Nothing++inputLeaveDone (InputDone _ s) = Just s+inputLeaveDone _ = Nothing
+ hsrc/types/ListRequest.hs view
@@ -0,0 +1,31 @@+module ListRequest where++default (Int)++data ListRequest a+  = ReplaceItems Int Int [a] -- from, how many, new lines+  | HighlightItems [Int]     -- replaces list of highlighted lines+  | PickItem Int            -- as if user clicked on a line+listEnd = -1++replaceAll          = ReplaceItems 0    listEnd           -- replace all text+replaceAllFrom from = ReplaceItems from listEnd+deleteItems from cnt = ReplaceItems from cnt     []+insertItems from     = ReplaceItems from 0+appendItems          = ReplaceItems listEnd listEnd+changeItems from txt = ReplaceItems from (length txt) txt++replaceItems = ReplaceItems+highlightItems = HighlightItems+pickItem = PickItem++--applyListRequest (ReplaceItems 0 cnt newtxt) oldtxt | cnt==listEnd = newtxt+applyListRequest (ReplaceItems from cnt newtxt) oldtxt =+  let before = if from==listEnd+               then oldtxt+	       else take from oldtxt+      after  = if from==listEnd || cnt==listEnd+               then []+	       else drop (from+cnt) oldtxt+  in before++newtxt++after+applyListRequest _ oldtxt = oldtxt
+ hsrc/types/Message.hs view
@@ -0,0 +1,33 @@+module Message where++data Message a b = Low a | High b  deriving (Eq, Ord, Show)++isHigh (High _) = True+isHigh _ = False++isLow (Low _) = True+isLow _ = False++stripHigh (High a) = Just a+stripHigh _ = Nothing++stripLow (Low b) = Just b+stripLow _ = Nothing++mapMessage fl fh' (Low l) = Low (fl l)+mapMessage fl fh' (High h) = High (fh' h)++message fl fh (Low l) = fl l+message fl fh (High h) = fh h++aLow f (Low l) = Low (f l)+aLow f (High h) = High h++aHigh f (High h) = High (f h)+aHigh f (Low l) = Low l++pushMsg (High xs) = fmap High xs+pushMsg (Low xs) = fmap Low xs++instance Functor (Message a) where+  fmap = aHigh
+ hsrc/types/Path.hs view
@@ -0,0 +1,30 @@+module Path(showPath, subPath, absPath, path, turn, here, Path(..)) where+import Direction+import Utils(lhead)++type Path = [Direction]++here :: Path+here = []++turn :: Direction -> Path -> Path+turn dir p = dir : p++path :: Path -> (Direction, Path)+path (dir : p) = (dir, p)+path [] = error "path.m: path []"++absPath :: Path -> Path -> Path+absPath absp relp = absp ++ relp++subPath :: Path -> Path -> Bool+subPath subp p = length subp <= length p && lhead subp p == subp++showPath :: Path -> String+showPath =+    concatMap (\x ->+               case x of+                 L -> "L"+                 R -> "R"+                 Dno n -> "N(" ++ show n ++ ")")+
+ hsrc/types/Popupmsg.hs view
@@ -0,0 +1,5 @@+module Popupmsg where+import Geometry++data PopupMsg a = Popup Point a | Popdown  deriving (Eq, Ord)+
+ hsrc/types/Rects.hs view
@@ -0,0 +1,52 @@+module Rects where+import Geometry++--newtype Region = Region [Rect]++intersectRects rs (Rect p2 s2) = ir rs+  where+    br2 = p2+s2+    ir [] = []+    ir (Rect p1 s1:es) =+      let ul = pmax p1 p2+          br = pmin (p1+s1) br2+	  s@(Point w h) = br-ul+      in if w<=0 || h<=0 then ir es else Rect ul s:ir es++overlaps (Rect (Point x1 y1) (Point w1 h1))+         (Rect (Point x2 y2) (Point w2 h2)) =+  x1<x2+w2 && x2<x1+w1 && y1<y2+h2 && y2<y1+h1+--x1<=x2+w2 && x2<=x1+w1 && y1<=y2+h2 && y2<=y1+h1+-- rR 0 0 10 10 doesn't overlap with rR 0 10 10 10++boundingRect r1@(Rect p1 s1) r2@(Rect p2 s2) =+    if s1==0 then r2 else if s2==0 then r1 else Rect p s+  where p = pmin p1 p2+        s = pmax (p1+s1) (p2+s2) - p++diffRect r1 r2@(Rect (Point x2 y2) (Point w2 h2)) =+    if overlaps r1 r2 -- faster handling of common(?) case+    then intersectRects outside_r2 r1+    else [r1]+  where+    u@(Rect p1@(Point x1 y1) s1@(Point w1 h1)) = boundingRect r1 r2+    outside_r2 = [a,b,c,d]+    a = Rect p1 (Point w1 (y2-y1))+    b = Rect (Point x1 y2) (Point (x2-x1) h2)+    c = Rect (Point xc y2) (Point (x1+w1-xc) h2) where xc = x2 + w2+    d = Rect (Point x1 yd) (Point w1 (y1+h1-yd)) where yd = y2+h2++{-+    u:+       +-----------------------------++       |            a                |+       |                             |+       +--------+-------+------------++       |   b    |  r2   |     c      |+       |        |       |            |+       +--------+-------+------------++       |                             |+       |             d               |+       |                             |+       +-----------------------------++-}
+ hsrc/types/Types.hs view
@@ -0,0 +1,11 @@+module Types (-- * Types+  module Direction,module Drawcmd,module Fudget,module Message,module Path,module Popupmsg,module InputMsg,module ListRequest,module Rects) where+import Direction+import Drawcmd+import Message+import Path+import Popupmsg+import InputMsg+import ListRequest+import Fudget+import Rects
+ hsrc/utils/CmdLineEnv.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE CPP #-}+module CmdLineEnv(options, progName, resourceName, args, argKey, argReadKey, argFlag, argKeyList) where+import IOUtil(progArgs,progName,getEnvi)+import FilePaths(aFilePath,pathTail)+--import ListUtil(chopList,breakAt)+import Utils(segments)+import HbcUtils(apFst, apSnd, breakAt)+import Data.Char+import Data.Maybe(fromMaybe)+--import NonStdTrace(trace)++argReadKey key def = case lookupOptions key of+	   Nothing -> def+	   Just a -> case reads a of+		(v,_):_ -> v+		_ -> error (" Illegal value to flag -"++key+++			    " (default value is "++show def++" of type "+++			    showType def++"): "++a)+#ifndef __HBC__+  where showType _ = "<type??>"+#endif++argKey key def = lookupOptions key `elseM` def+argFlag key def = argKey key (if def then yes else no) == yes+argKeyList key def = maybe def (segments (/=':')) (lookupOptions key)++lookupOptions key = lookup key options+	      `orM` (env ("FUD_"++ removePath progName++"_"++key))+	      `orM` (env ("FUD_"++key))++    where removePath = reverse . fst . breakAt '/' . reverse+	  env e = getEnvi e >>= \v -> Just (if v == "" then yes else v)+	  --getEnvi' e = trace ("getEnvi "++e) $ getEnvi e++orM :: Maybe a -> Maybe a -> Maybe a+--orM = (++)+orM Nothing  b = b+orM a        b = a++elseM :: Maybe a -> a -> a+elseM = flip fromMaybe+--elseM (Just a) a' = a+--elseM Nothing  a' = a'++yes = "yes"+no = "no"++(args, options) =+    let parse (('-' : ak) : av : al) = case av of+	      '-':avr -> if not (null avr) && isAlpha (head avr)+	          && reverse (take 4 (reverse ak)) /= "font" +		  then apSnd ((ak, yes) :) (parse (av:al))+		  else thearg+	      _ -> thearg+            where thearg = apSnd ((ak, av) :) (parse al)+        parse ['-' : ak] = ([], [(ak, yes)])+        parse ("-":al) = (al,[])+        parse (a : al) = apFst (a :) (parse al)+        parse [] = ([], [])+    in  parse progArgs+++resourceName = pathTail (aFilePath progName)
+ hsrc/utils/Defaults.hs view
@@ -0,0 +1,56 @@+module Defaults(look3d, new3d, edgeWidth, defaultSep,+		paperColor, fgColor, bgColor, inputFg, inputBg,+		shadowColor, shineColor,+		defaultPosition, defaultSize, defaultFont, menuFont,+                buttonFont, labelFont, metaKey) where+import Geometry(pP)+--import ListUtil(chopList,breakAt)+import Utils(segments)+import AuxTypes(Modifiers(..))+import ResourceIds(FontName(..),ColorName(..))+import CmdLineEnv++argFont = argKey :: ( String -> FontName -> FontName)+argColor = argKey :: (String -> ColorName -> ColorName)++buttonFont  = argFont "buttonfont" labelFont+menuFont    = argFont "menufont"   labelFont+labelFont   = argFont "labelfont"  "variable"+defaultFont = argFont "font"       "fixed"++shineColor  = argColor "shine"   (if look3d then "white" else "lightgrey")+shadowColor = argColor "shadow"  (if look3d+                                  then if new3d+				       then "grey45"+				       else "black"+				  else "grey30")+paperColor  = argColor "paper"   "white"+inputFg     = argColor "inputfg" fgColor+inputBg     = argColor "inputbg" paperColor+fgColor     = argColor "fg"      "black"+bgColor     = argColor "bg"      "grey"++--defaultSep :: Int+defaultSep :: (Num a) => a+defaultSep = fromIntegral (argReadKey "sep" 5::Int)++defaultPosition =+    case segments (/='+') (argKey "geometry" "") of+      [_, x, y] -> Just (pP (read x) (read y))+      _ -> Nothing++defaultSize =+    case segments (/='x') (takeWhile (/='+') (argKey "geometry" "")) of+      [x, y] -> Just (pP (read x) (read y))+      _ -> Nothing++edgeWidth :: Int+edgeWidth = argReadKey "edgew" (if look3d then 2 else 4)++look3d = argFlag "look3d" True+new3d = argFlag "new3d" True+++-- | This should be modifier corresponding to Meta_L & Meta_R (see xmodmap).+-- It is usually Mod1, but in XQuartz it appears to be Mod2 instead...+metaKey = argReadKey "metakey" Mod1
+ hsrc/utils/EitherUtils.hs view
@@ -0,0 +1,51 @@+module EitherUtils where+import Data.Maybe+import Data.List(find)++type Cont c a = (a -> c) -> c++plookup p = fmap snd . find (p.fst)++-- mapfilter = Maybe.mapMaybe+-- stripMaybe = Maybe.fromJust+-- stripMaybeDef = Maybe.fromMaybe+-- isM = Maybe.isJust++--mapMaybe :: (a->b) -> Maybe a -> Maybe b+--mapMaybe = fmap++stripLeft (Left a) = Just a+stripLeft _ = Nothing++stripRight (Right b) = Just b+stripRight _ = Nothing++stripEither (Left a) = a+stripEither (Right b) = b++filterLeft = mapMaybe stripLeft++filterRight = mapMaybe stripRight++isLeft (Left _) = True+isLeft _ = False++isRight (Right _) = True+isRight _ = False++mapEither fl fr (Left l) = Left (fl l)+mapEither fl fr (Right r) = Right (fr r)++swapEither (Left x) = Right x+swapEither (Right y) = Left y++-- JSP 920929+splitEitherList [] = ([], [])+splitEitherList (x : xs) =+    let (lefts, rights) = splitEitherList xs+    in  case x of+          Left a -> (a : lefts, rights)+          Right a -> (lefts, a : rights)++fromLeft (Left x) = x+fromRight (Right y) = y
+ hsrc/utils/FilePaths.hs view
@@ -0,0 +1,86 @@+module FilePaths(AFilePath,rootPath,aFilePath,filePath,+                 compactPath,isAbsolute,joinPaths,pathRelativeTo,+		 extendPath,pathTail,pathHead,pathLength) where+import Data.List(intersperse)+--import IO(openDirectory, statFile)+--import ListUtil(chopList,breakAt)+import Utils(segments)++newtype AFilePath = P [String] deriving (Eq,Ord)+-- data AFilePath = Root | Cwd | AFilePath :/ String++aFilePath :: FilePath -> AFilePath+aFilePath = P . splitpath++rootPath = P [""]++filePath :: AFilePath -> FilePath+filePath (P path) = joinpath path++compactPath (P path) = P (compactpath path)++extendPath (P path) node = P (node:path)++pathTail :: AFilePath -> String+pathTail (P []) = "." -- ??+pathTail (P [""]) = "/" -- ??+pathTail (P (t:_)) =  t++pathHead (P []) = (P []) -- ??+pathHead (P (t:h)) = P h++pathLength (P path) = length path++isAbsolute (P ns) = isabsolute ns++joinPaths (P parent) (P child) =+ if isabsolute child+ then P child+ else P (child++parent) -- compactpath?++P file `pathRelativeTo` P dir =+    if take dirlen rfile == rdir+    then P (reverse (drop dirlen rfile))+    else P file+  where+    rdir = reverse dir+    rfile = reverse file+    dirlen = length rdir++isabsolute [] = False+isabsolute ns = null (last ns)++splitpath = reverse . segments (/='/')++joinpath [] = "."+joinpath [""] = "/"+joinpath ns = concat (intersperse "/" (reverse ns))++compactpath [] = []+compactpath (".." : xs) =+  case compactpath xs of+    [""] -> [""] -- parent of root directory, stay in root directory+    ys@("..":_) -> "..":ys -- relative path to grandparent, keep ".."+    _:ys -> ys -- parent of child, optimize+    ys -> "..":ys -- other, keep ".."+--compactpath ["..",""] = [""] -- parent of root directory+--compactpath (".." : "." : xs) = compactpath ("..":xs)+--compactpath (".." : x : xs) | x /= ".." = compactpath xs+compactpath ("" : xs@(_:_)) = compactpath xs+compactpath ("." : xs) = compactpath xs+compactpath (x : xs) = x : compactpath xs++{-+ls s =+    let paths = map (: s) . sort . filter (/= ".")+    in  case openDirectory (joinpath s) of+          Right files -> paths files+          Left msg -> [msg : s]++isdir s =+    case statFile (joinpath s) of+      Right ns -> let mode = ns !! (3 - 1)+                  in  bitand mode 61440 == 16384+      Left _ -> False++-}
+ hsrc/utils/FudUtilities.hs view
@@ -0,0 +1,15 @@+module FudUtilities (-- * Utilities+  module Defaults, module CmdLineEnv, module FilePaths,  module Geometry, module MapstateMsg, module EitherUtils, module StringUtils, module Utils, module FudVersion) where+import Defaults+import CmdLineEnv+import Geometry+import FilePaths+import MapstateMsg+import EitherUtils+import StringUtils+import Utils+import FudVersion++--import Message(Message)+--import SP(SP)+--import Xtypes(FontName(..))
+ hsrc/utils/FudVersion.hs view
@@ -0,0 +1,7 @@+module FudVersion where++version = version_0_18_3++version_0_18_3 = "version 0.18.3" -- only for documentation, use "version" instead++-- The version number should be increased immediately after a public release.
+ hsrc/utils/Geometry.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE CPP #-}+module Geometry where+-- This module should be moved to ../types/++import Data.Ix++class Move a where move :: Point -> a -> a++fmove 0 = id+fmove p = fmap (move p)++instance Move a => Move [a]       where move = fmove+instance Move a => Move (Maybe a) where move = fmove++data Point = Point { xcoord, ycoord :: Int }+   deriving (Eq, Ord, Show, Read, Ix)+type Size = Point+data Line = Line Point Point  deriving (Eq, Ord, Show, Read)+data Rect = Rect {rectpos::Point, rectsize::Size}+ deriving (Eq, Ord, Show, Read)+{-+instance Show Point where showsPrec d (Point x y) = showsPrec d (x,y)+instance Read Point where readsPrec d s = [(pP x y,r)|((x,y),r)<-readsPrec d s]++instance Show Rect where+  showsPrec d (Rect p s) =+    showParen (d>=10) $+    showString "R " . showsPrec 10 p . showChar ' ' . showsPrec 10 s+-}+-- convenient abbreviations:+origin = Point 0 0+pP x y = Point x y+lL x1 y1 x2 y2 = Line (Point x1 y1) (Point x2 y2)+rR x y w h = Rect (Point x y) (Point w h)+diag x = Point x x++-- selectors:+--xcoord (Point x _) = x+--ycoord (Point _ y) = y++--rectsize (Rect _ size) = size+--rectpos (Rect pos _) = pos++-- basic operations:+padd (Point x1 y1) (Point x2 y2) = Point (x1 + x2) (y1 + y2)+psub (Point x1 y1) (Point x2 y2) = Point (x1 - x2) (y1 - y2)++instance Num Point where+	 (+) = padd+	 (-) = psub+	 Point x1 y1 * Point x2 y2 = Point (x1*x2) (y1*y2) -- hmm+	 negate = psub origin+	 abs (Point x y) = Point (abs x) (abs y) -- hmm+	 signum (Point x y) = Point (signum x) (signum y) -- hmm+	 fromInteger i = let i' = fromInteger i in Point i' i'+#ifdef __HBC__+	 fromInt i = Point i i+#endif++rsub (Rect p1 _) (Rect p2 _) = psub p1 p2++posrect (Rect pos size) newpos = Rect newpos size+moverect (Rect pos size) delta = Rect (padd pos delta) size+sizerect (Rect pos size) newsize = Rect pos newsize+growrect (Rect pos size) delta = Rect pos (padd size delta)++moveline (Line p1 p2) delta = Line (padd p1 delta) (padd p2 delta)++rect2line (Rect p s) = Line p (p `padd` s)+line2rect (Line p1 p2) = Rect p1 (p2 `psub` p1)++instance Move Point where move = padd+instance Move Rect where move = flip moverect+instance Move Line where move = flip moveline++-- misc:+Point x1 y1 =.> Point x2 y2 = x1 >= x2 && y1 >= y2+inRect pt (Rect p1 p2) = pt =.> p1 && p2 =.> psub pt p1+scale k i = truncate (k * fromIntegral i)+scalePoint k (Point x y) = Point (scale k x) (scale k y)+rectMiddle (Rect (Point x y) (Point w h)) =+    Point (x + w `quot` 2) (y + h `quot` 2)++freedom (Rect _ outer) (Rect _ inner) = psub outer inner++pmin (Point x1 y1) (Point x2 y2) = Point (x1 `min` x2) (y1 `min` y2)+pmax (Point x1 y1) (Point x2 y2) = Point (x1 `max` x2) (y1 `max` y2)++pMin (p : pl) = foldr pmin p pl+pMin [] = error "pMin on []"++pMax (p : pl) = foldr pmax p pl+pMax [] = error "pMax on []"++plim p0 p1 p = pmax p0 (pmin p1 p)++-- | confine outer inner: moves an shrinks inner to fit within outer+confine (Rect outerpos outersize) (Rect innerpos innersize) =+    let newsize = pmin outersize innersize+        maxpos = padd outerpos (psub outersize newsize)+    in  Rect (plim outerpos maxpos innerpos) newsize++-- | rmax gives an enclosing rect+rmax r1 r2 = line2rect (Line (pmin lp1 lp2) (pmax lp1' lp2'))+   where Line lp1 lp1' = rect2line r1+	 Line lp2 lp2' = rect2line r2
+ hsrc/utils/HbcUtils.hs view
@@ -0,0 +1,44 @@+-- | Useful functions from hbc-library modules ListSet, ListMap, ListUtil, HO+-- and UTF8+module HbcUtils(module HbcUtils,module FudUTF8) where+import Data.List((\\))+import FudUTF8++-- * From ListSet++-- | Union of sets as lists+union :: (Eq a) => [a] -> [a] -> [a]+union xs ys = xs ++ (ys \\ xs)+++-- * From ListMap+lookupWithDefault :: (Eq a) => [(a, b)] -> b -> a -> b+lookupWithDefault [] d _ = d+lookupWithDefault ((x,y):xys) d x' = if x == x' then y else lookupWithDefault xys d x'+++-- * From ListUtil+mapFst f = map (apFst f)+mapSnd f = map (apSnd f)++breakAt c = apSnd (drop 1) . break (==c)++chopList :: ([a] -> (b, [a])) -> [a] -> [b]+chopList f l = unfoldr f null l+  where+    -- | Repeatedly extract (and transform) values until a predicate hold.  Return the list of values.+    unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b]+    unfoldr f p x | p x       = []+                  | otherwise = y:unfoldr f p x'+                                  where (y, x') = f x++assoc :: Eq k => (v -> r) -> r -> [(k, v)] -> k -> r+assoc f z xs k = maybe z f (lookup k xs)++-- * From HO++apFst f (x, y) = (f x, y)+apSnd f (x, y) = (x, f y)++curry3 f x y z = f (x,y,z)+uncurry3 f ~(x,y,z) = f x y z
+ hsrc/utils/MapstateMsg.hs view
@@ -0,0 +1,26 @@+module MapstateMsg(mapLow, mapHigh, mapstateLow, mapstateHigh) where+import Message(Message(..))+--import SP(SP)+import Spops+import HbcUtils(apSnd)++mapstateHigh p s =+    let ms s' (Low msg) = (s', [Low msg])+        ms s' (High msg) = apSnd (map High) (p s' msg)+    in  mapstateSP ms s++mapstateLow p s =+    let ms s' (High msg) = (s', [High msg])+        ms s' (Low msg) = apSnd (map Low) (p s' msg)+    in  mapstateSP ms s++mapHigh p =+    let ms (High msg) = map High (p msg)+        ms (Low msg) = [Low msg]+    in  concmapSP ms++mapLow p =+    let ms (Low msg) = map Low (p msg)+        ms (High msg) = [High msg]+    in  concmapSP ms+
+ hsrc/utils/StringUtils.hs view
@@ -0,0 +1,17 @@+module StringUtils where+--import Char(isAlpha,isAlphanum,isDigit)++expandTabs n = exp (n::Int)+  where+    exp k [] = []+    exp k ('\t':xs) = [' '|_<-[1..k]] ++ exp n xs+    exp k (x:xs) = x:exp (if k==1 then n else k-1) xs++rmBS "" = ""+rmBS (c:'\b':cs) = rmBS cs+rmBS (c:cs) = c:rmBS cs++wrapLine n xs =+    let first = take n xs+        rest = drop n xs+    in  first : (if null rest then [] else wrapLine n rest)
+ hsrc/utils/Utils.hs view
@@ -0,0 +1,101 @@+module Utils where+--import ListSet(union)+--import HbcWord+import HbcUtils++infixr 1 `thenC`+infixl 1 `ifC`++aboth f (x, y) = (f x, f y)+mapPair (f, g) (x, y) = (f x, g y)+pairwith f x = (x, f x)+swap (x, y) = (y, x)+pair = (,)++setFst (_,y) x = (x,y)+setSnd (x,_) y = (x,y)++oo f g x y = f (g x y)++-- | Apply a function to the nth element of a list+anth :: Int -> (a->a) -> [a] -> [a]+anth _ _ [] = []+anth 1 f (x : xs) = f x : xs+anth n f (x : xs) = x : anth (n - 1) f xs++--dropto p = while (\l -> l /= [] && (not . p . head) l) tail++number :: Int -> [a] -> [(Int,a)]+number _ [] = []+number i (x : xs) = (i, x) : number (i + 1) xs++loop f =+    let yf = f yf+    in  yf++ifC c b = if b then c else id+thenC = flip ifC++gmap g f = foldr (\x -> \ys -> g (f x) ys) []++unionmap f = gmap union f++-- | Remove the first occurence+remove a (b : bs) | a == b = bs+remove a (b : bs) = b : remove a bs+remove a [] = []++-- | Replace the first occurence+replace p [] = [p]+replace (t, v) ((t', v') : ls') | t == t' = (t, v) : ls'+replace p (l : ls') = l : replace p ls'++unconcat [] _ = []+unconcat (n : ns) xs = xs1:unconcat ns xs2+  where (xs1,xs2) = splitAt n xs++-- | lunconcat xss ys = unconcat (map length xss) ys+lunconcat [] _ = []+lunconcat (n : ns) xs = xs1:lunconcat ns xs2+  where (xs1,xs2) = lsplit n xs+++-- | lhead xs ys = take (length xs) ys, but the rhs is stricter+lhead (x : xs) (y : ys) = y : lhead xs ys+lhead _ _ = []++-- | ltail xs ys = drop (length xs) ys, but the rhs is stricter+ltail [] ys = ys+ltail _ [] = []+ltail (x : xs) (y : ys) = ltail xs ys++-- | lsplit xs ys = (lhead xs ys,ltail xs ys), but without the space leak, -fpbu+lsplit [] ys = ([], ys)+lsplit _ [] = ([], [])+lsplit (x : xs) (y : ys) =+    let (yhs, yts) = lsplit xs ys+    in  (y : yhs, yts)++-- | JSP 920928+part p [] = ([], [])+part p (x : xs) =+    let (ys, zs) = part p xs+    in  if p x then (x : ys, zs) else (ys, x : zs)++issubset a b = all (`elem` b) a++-- | To avoid problems caused by poor type inference for constructor classes in+-- Haskell 1.3:+mapList = map :: ((a->b)->[a]->[b])++-- From Compat.hs:+--bitxor,bitand::Int->Int->Int+--bitxor x y = wordToInt (bitXor (fromIntegral x) (fromIntegral y))+--bitand x y = wordToInt (bitAnd (fromIntegral x) (fromIntegral y))+++-- | @chopList (breakAt c) == segments (/=c)@+segments p [] = []+segments p xs = case span p xs of+                  (xs1,_:xs2) -> xs1:segments p xs2+                  (xs1,_) -> [xs1]
+ hsrc/xtypes/AuxTypes.hs view
@@ -0,0 +1,56 @@+-- | Auxiliary Xlib types+module AuxTypes where++data Gravity = ForgetGravity |+               NorthWestGravity |+               NorthGravity |+               NorthEastGravity |+               WestGravity |+               CenterGravity |+               EastGravity |+               SouthWestGravity |+               SouthGravity |+               SouthEastGravity |+               StaticGravity +               deriving (Eq, Ord, Read, Show, Bounded, Enum)++data ShapeKind = ShapeBounding | ShapeClip+                 deriving (Eq, Ord, Show, Read, Bounded, Enum)++data ShapeOperation = ShapeSet |+                      ShapeUnion |+                      ShapeIntersect |+                      ShapeSubtract |+                      ShapeInvert +                      deriving (Eq, Ord, Show, Read, Bounded, Enum)++-- There already is an Ordering in the 1.3 Prelude+data Ordering' = Unsorted | YSorted | YXSorted | YXBanded+     deriving (Eq, Ord, Show, Read, Bounded, Enum)++type RmClass = String+type RmName = String+type RmQuery = (RmClass, RmName)+type RmSpec = [RmQuery]+type RmValue = String+type RmDatabase = Int++rmNothing = 0::Int++data Modifiers = Shift | Lock | Control+               | Mod1 | Mod2 | Mod3 | Mod4 | Mod5+               | Button1 | Button2 | Button3 | Button4 | Button5+               | Mod13 | Mod14 -- non-standard, but used in XQuartz+               | Any +               deriving (Eq, Ord, Show, Read, Bounded, Enum)++clModifiers =+    [Shift, Lock, Control, Mod1, Mod2, Mod3, Mod4, Mod5,+     Button1, Button2, Button3, Button4, Button5]++data Button = AnyButton | Button Int  deriving (Eq, Ord, Read, Show)++type ModState = [Modifiers]++type KeySym = String+
+ hsrc/xtypes/Command.hs view
@@ -0,0 +1,132 @@+module Command(module Command,DrawCommand,Drawable(..)) where+import Event(XEvent)+import Direction() -- for hbc+import Path(Path(..))+import Geometry+--import LayoutRequest(LayoutMessage(..))+import Xtypes+import DrawTypes+--import DialogueIO(Request)+import ShowFun()++-- Same order as in .../lml/src/lib/xlib/xlib.h+data XCommand -- X commands+  = CloseDisplay Display+  | DestroyWindow+  | MapRaised+  | LowerWindow+  | UnmapWindow+  | Draw Drawable GCId DrawCommand+  | DrawMany Drawable [(GCId,[DrawCommand])] -- use instead of XDoCommands+  | ClearArea Rect Bool+  | ClearWindow+  | ChangeGC GCId GCAttributeList+  | FreeGC GCId+  | ChangeWindowAttributes [WindowAttributes]+  | ConfigureWindow [WindowChanges]+  | StoreName String+  | SetNormalHints Point+  | SetWMHints Bool -- input+  | UngrabPointer+  | GrabButton Bool Button ModState [EventMask]+  | UngrabButton Button ModState+  | Flush+  | FreePixmap PixmapId+  | ShapeCombineMask ShapeKind Point PixmapId ShapeOperation+  | ShapeCombineRectangles ShapeKind Point [Rect] ShapeOperation Ordering'+  | ShapeCombineShape ShapeKind Point PixmapId ShapeKind ShapeOperation+  | RmDestroyDatabase RmDatabase+  | RmCombineDatabase RmDatabase RmDatabase Bool+  | RmPutLineResource RmDatabase String+  | SetWMProtocols [Atom]+  | SendEvent Window Bool [EventMask] XEvent+  | SetSelectionOwner Bool Atom+  | ConvertSelection Selection+  | ChangeProperty Window Atom Atom Int PropertyMode String+  | FreeColors ColormapId [Pixel] Pixel{-planes-}+  | ReparentWindow Window {- parent -}+  | WarpPointer Point+  | SetRegion GCId Rect -- !!! modifies a GC -- cache problems!+  | AddToSaveSet+  | RemoveFromSaveSet+  | Bell Int+  | SetGCWarningHack {gcon,gcoff::PixmapId}+-- ONLY Pseudo commands below, add new Xlib command above this line !!!+  | GrabEvents Bool+  | UngrabEvents+  | TranslateEvent (XEvent -> Maybe XEvent) [EventMask]+  | ReparentToMe Path Window+  | GetWindowId -- move to XRequest?+  | SelectWindow Window+-- Layout pseudo commands+--  | LayoutMsg LayoutMessage+-- An I/O request to be passed through the top level (not anymore)+--  | DoIO Request+--  | DoXRequest XRequest+--+--  | DoXCommands [XCommand]+		-- Drawing speed hack, bypasses caches and resource management.+		-- Do not put any Alloc/Free, Create/Destroy, Grab/Ungrab type+		-- of commands inside DoXCommands!+--+  | MeButtonMachine -- tells menuPopupF where the buttons are+  deriving (Show,Read)++-- layoutRequestCmd = LayoutMsg . LayoutRequest++data XRequest+  = OpenDisplay DisplayName+  | CreateSimpleWindow Path Rect+  | CreateRootWindow Rect String -- resource name+  | CreateGC Drawable GCId GCAttributeList+  | LoadFont FontName+  | CreateFontCursor Int+  | GrabPointer Bool [EventMask]+  | LMLQueryFont FontId -- doesn't work in Haskell+  | AllocNamedColor ColormapId ColorName+  | AllocColor ColormapId RGB+  | CreatePixmap Size Depth+  | ReadBitmapFile FilePath+  | CreateBitmapFromData BitmapData+  | RmGetStringDatabase String+  | RmGetResource RmDatabase String String+  | TranslateCoordinates+  | InternAtom String Bool+  | GetAtomName Atom+  | GetWindowProperty Int Atom Bool Atom+  | QueryPointer+  | QueryFont FontId+  | LoadQueryFont FontName+  | QueryColor ColormapId Pixel+  | QueryTree+  | DefaultRootWindow+  | GetGeometry+  | DefaultVisual+  | Sync Bool -- discard::Bool+  | QueryTextExtents16 FontId String+  | ListFonts FontName Int -- pattern, maxnames+  | ListFontsWithInfo FontName Int -- pattern, maxnames+  | GetResource RmSpec+  | DbeQueryExtension+  | DbeAllocateBackBufferName SwapAction+  | DbeSwapBuffers SwapAction -- applies only to the fudget's own window.+  -- ONLY Pseudo requests below:+  | CreateMyWindow Rect+  deriving (Eq, Ord, Show, Read)++type Command = XCommand++data BitmapData = BitmapData Size (Maybe Point) [Int] +                  deriving (Eq, Ord, Show, Read)++type DisplayName = String++-- Convenient abbreviations:+moveWindow (Point x y) = ConfigureWindow [CWX x, CWY y]+resizeWindow (Point w h) = ConfigureWindow [CWWidth w, CWHeight h]+moveResizeWindow (Rect (Point x y) (Point w h)) =+    ConfigureWindow [CWX x, CWY y, CWWidth w, CWHeight h]++clearWindowExpose = ClearArea (rR 0 0 0 0) True+                    -- Clears the window and generates appropriate+		    -- exposure events.See man page for XClearArea.
+ hsrc/xtypes/DrawInPixmap.hs view
@@ -0,0 +1,23 @@+module DrawInPixmap where+--import Geometry+import XDraw++-- convenient abbreviations for drawing in pixmaps:+pmDrawLine pm gc l = draw (Pixmap pm) gc (DrawLine l)+pmDrawLines pm gc mode ps = draw (Pixmap pm) gc (DrawLines mode ps)+pmDrawImageString pm gc p s = draw (Pixmap pm) gc (DrawImageString p s)+pmDrawString pm gc p s = draw (Pixmap pm) gc (DrawString p s)+pmDrawImageString16 pm gc p s = draw (Pixmap pm) gc (DrawImageString16 p s)+pmDrawString16 pm gc p s = draw (Pixmap pm) gc (DrawString16 p s)+pmDrawImageStringPS pm gc p s = draw (Pixmap pm) gc (DrawImageStringPS p s)+pmDrawStringPS pm gc p s = draw (Pixmap pm) gc (DrawStringPS p s)+pmDrawRectangle pm gc r = draw (Pixmap pm) gc (DrawRectangle r)+pmFillRectangle pm gc r = draw (Pixmap pm) gc (FillRectangle r)+pmFillPolygon pm gc shape mode ps =+   draw (Pixmap pm) gc (FillPolygon shape mode ps)+pmDrawArc pm gc r a1 a2 = draw (Pixmap pm) gc (DrawArc r a1 a2)+pmFillArc pm gc r a1 a2 = draw (Pixmap pm) gc (FillArc r a1 a2)+pmCopyArea dst gc src r p = draw (Pixmap dst) gc (CopyArea src r p)+pmCopyPlane dst gc src r p i = draw (Pixmap dst) gc (CopyPlane src r p i)+pmDrawPoint dst gc p = draw (Pixmap dst) gc (DrawPoint p)+pmCreatePutImage dst gc r s d = draw (Pixmap dst) gc (CreatePutImage r s d)
+ hsrc/xtypes/DrawInWindow.hs view
@@ -0,0 +1,24 @@+module DrawInWindow where+--import Geometry+import XDraw++-- convenient abbreviations for drawing in windows:+wDrawLine gc l = draw MyWindow gc (DrawLine l)+wDrawLines gc mode ps = draw MyWindow gc (DrawLines mode ps)+wDrawImageString gc p s = draw MyWindow gc (DrawImageString p s)+wDrawString gc p s = draw MyWindow gc (DrawString p s)+wDrawImageString16 gc p s = draw MyWindow gc (DrawImageString16 p s)+wDrawString16 gc p s = draw MyWindow gc (DrawString16 p s)+wDrawImageStringPS gc p s = draw MyWindow gc (DrawImageStringPS p s)+wDrawStringPS gc p s = draw MyWindow gc (DrawStringPS p s)+wDrawRectangle gc r = draw MyWindow gc (DrawRectangle r)+wFillRectangle gc r = draw MyWindow gc (FillRectangle r)+wFillPolygon gc shape mode ps = draw MyWindow gc (FillPolygon shape mode ps)+wDrawArc gc r a1 a2 = draw MyWindow gc (DrawArc r a1 a2)+wFillArc gc r a1 a2 = draw MyWindow gc (FillArc r a1 a2)+wDrawCircle gc p r = draw MyWindow gc (drawCircle p r)+wFillCircle gc p r = draw MyWindow gc (fillCircle p r)+wCopyArea gc src r p = draw MyWindow gc (CopyArea src r p)+wCopyPlane gc src r p i = draw MyWindow gc (CopyPlane src r p i)+wDrawPoint gc p = draw MyWindow gc (DrawPoint p)+wCreatePutImage gc r s d = draw MyWindow gc (CreatePutImage r s d)
+ hsrc/xtypes/DrawTypes.hs view
@@ -0,0 +1,44 @@+module DrawTypes where+import Geometry(Point,Rect,Line)+import PackedString(PackedString)+import Xtypes(Pixel,PixmapId,ImageFormat,DbeBackBufferId)++data DrawCommand+-- Don't forget to change ../types/Drawcmd.hs too, if you change things here!!+  = DrawLine Line+  | DrawImageString Point String+  | DrawString Point String+  | DrawRectangle Rect+  | FillRectangle Rect+  | FillPolygon Shape CoordMode [Point]+  | DrawArc Rect Int Int+  | FillArc Rect Int Int+  | CopyArea Drawable Rect Point+  | CopyPlane Drawable Rect Point Int+  | DrawPoint Point+  | CreatePutImage Rect ImageFormat [Pixel]+  --+  | DrawImageStringPS Point PackedString+  | DrawStringPS Point PackedString+  --+  | DrawLines CoordMode [Point]+  | DrawImageString16 Point String+  | DrawString16 Point String+  deriving (Eq, Ord, Show, Read)++data Drawable+  = MyWindow+  | Pixmap PixmapId+  | DbeBackBuffer DbeBackBufferId+   deriving (Eq, Ord, Show, Read)++data CoordMode+  = CoordModeOrigin+  | CoordModePrevious +  deriving (Eq, Ord, Show, Read, Bounded, Enum)++data Shape+  = Complex+  | Nonconvex+  | Convex+  deriving (Eq, Ord, Show, Read, Bounded, Enum)
+ hsrc/xtypes/Event.hs view
@@ -0,0 +1,122 @@+module Event(module Event,FontStructList,FontStruct) where+import Font(FontStruct,FontStructList,CharStruct)+import Visual(Visual)+import Geometry+import Xtypes+--import DialogueIO hiding (IOError)++newtype KeyCode = KeyCode Int deriving (Eq, Ord, Show, Read)++data Pressed = Pressed | Released | MultiClick Int+               deriving (Eq, Ord, Show, Read)++data Detail = NotifyAncestor |+              NotifyVirtual |+              NotifyInferior |+              NotifyNonlinear |+              NotifyNonlinearVirtual |+              NotifyPointer |+              NotifyPointerRoot |+              NotifyDetailNothing +              deriving (Eq, Ord, Show, Read, Bounded, Enum)++data Mode = NotifyNormal |+            NotifyGrab |+            NotifyUngrab |+            NotifyWhileGrabbed +            deriving (Eq, Ord, Show, Read, Bounded, Enum)++data Visibility = VisibilityUnobscured |+                  VisibilityPartiallyObscured |+                  VisibilityFullyObscured +                  deriving (Eq, Ord, Show, Read, Bounded, Enum)++data ClientData = Byte String |+                  Short [Int] |+                  Long [Int] +                  deriving (Eq, Ord, Show, Read)++data XEvent+  = FocusIn   { detail::Detail, mode::Mode }+  | FocusOut  { detail::Detail, mode::Mode }+  | KeymapNotify+  | GraphicsExpose { rect::Rect, count::Int, major_code, minor_code::Int}+  | KeyEvent { time::Time, pos,rootPos::Point, state::ModState, type'::Pressed, keycode::KeyCode, keySym::KeySym, keyLookup::KeyLookup }+  | ButtonEvent { time::Time, pos,rootPos::Point, state::ModState, type'::Pressed, button::Button}+  | MotionNotify { time::Time, pos,rootPos::Point, state::ModState }+  | EnterNotify  { time::Time, pos,rootPos::Point, detail::Detail, mode::Mode, focus::Bool }+  | LeaveNotify  { time::Time, pos,rootPos::Point, detail::Detail, mode::Mode, focus::Bool }+  | Expose {rect::Rect, count::Int}+  | NoExpose+  | VisibilityNotify Visibility+  | CreateNotify Window+  | DestroyNotify Window+  | UnmapNotify Window+  | MapNotify Window+  | MapRequest Window+  | ReparentNotify+  | ConfigureNotify Rect Int+  | ConfigureRequest+  | GravityNotify+  | ResizeRequest Point+  | CirculateNotify+  | CirculateRequest+  | PropertyNotify+  | SelectionClear Atom+  | SelectionRequest Time Window Selection+  | SelectionNotify Time Selection+  | ColormapNotify+  | ClientMessage Atom ClientData+  | MappingNotify+  -- Pseudo event below:+--  | IOResponse Response+--+--  | LayoutPlace Rect+--  | LayoutSize Size+--  | LayoutPos Point -- Position in parent window. Occationally useful.+  | YourWindowId Window+  | MenuPopupMode Bool -- used by buttonmachine to adjust its behaviour+  deriving (Show,Read)++type Event = XEvent++data XResponse+  = DisplayOpened Display+  | WindowCreated Window+  | GCCreated GCId+  | CursorCreated CursorId+  | PointerGrabbed GrabPointerResult+  | FontLoaded FontId+  | LMLFontQueried FontStruct+  | ColorAllocated (Maybe Color)+  | PixmapCreated PixmapId+  | BitmapRead BitmapReturn+  | RmDatabaseCreated RmDatabase+  | GotResource (Maybe (String, RmValue))+  | CoordinatesTranslated Point+  | GotAtom Atom+  | GotAtomName (Maybe String)+  | GotEvent (Window, XEvent)+  | GotWindowProperty Atom Int Int Int String+  | PointerQueried Bool Point Point ModState+  | FontQueried (Maybe FontStructList)+  | ColorQueried Color+  | TreeQueried Window Window [Window]  -- root parent children+  | GotDefaultRootWindow Window+  | GotGeometry Rect Int Int+  | GotVisual Visual+  | Synced+  | TextExtents16Queried Int Int CharStruct -- ascent descent overall+  | GotFontList [FontName]+  | GotFontListWithInfo [(FontName,FontStructList)]+--  | GotFontListWithInfo [(FontStructList)]+  | DbeExtensionQueried Int Int Int -- status (/=0 means ok), major, minor+  | DbeBuffersSwapped Int -- status (useless?)+  | DbeBackBufferNameAllocated DbeBackBufferId+  deriving (Show,Read)++data BitmapReturn+  = BitmapBad+  | BitmapReturn Size (Maybe Point) PixmapId +  deriving (Eq, Ord, Show, Read)+
+ hsrc/xtypes/EventMask.hs view
@@ -0,0 +1,37 @@+module EventMask where++-- Same order as in X+data EventMask = KeyPressMask |+                 KeyReleaseMask |+                 ButtonPressMask |+                 ButtonReleaseMask |+                 EnterWindowMask |+                 LeaveWindowMask |+                 PointerMotionMask |+                 PointerMotionHintMask |+                 Button1MotionMask |+                 Button2MotionMask |+                 Button3MotionMask |+                 Button4MotionMask |+                 Button5MotionMask |+                 ButtonMotionMask |+                 KeymapStateMask |+                 ExposureMask |+                 VisibilityChangeMask |+                 StructureNotifyMask |+                 ResizeRedirectMask |+                 SubstructureNotifyMask |+                 SubstructureRedirectMask |+                 FocusChangeMask |+                 PropertyChangeMask |+                 ColormapChangeMask |+                 OwnerGrabButtonMask +                 deriving (Eq, Ord, Show, Read, Bounded, Enum)++clEventMask =+    [KeyPressMask, KeyReleaseMask, ButtonPressMask, ButtonReleaseMask, EnterWindowMask,+     LeaveWindowMask, PointerMotionMask, PointerMotionHintMask, Button1MotionMask,+     Button2MotionMask, Button3MotionMask, Button4MotionMask, Button5MotionMask,+     ButtonMotionMask, KeymapStateMask, ExposureMask, VisibilityChangeMask, StructureNotifyMask,+     ResizeRedirectMask, SubstructureNotifyMask, SubstructureRedirectMask, FocusChangeMask,+     PropertyChangeMask, ColormapChangeMask, OwnerGrabButtonMask]
+ hsrc/xtypes/FRequest.hs view
@@ -0,0 +1,34 @@+-- | Fudget low-level message types+module FRequest(+  module FRequest,+  XCommand,XEvent,XRequest,XResponse,+  SocketRequest,SocketResponse,+  LayoutMessage,LayoutResponse+  --AsyncInput(..)+) where+import Command(XCommand,XRequest)+import Event(XEvent,XResponse)+import Sockets(SocketRequest,SocketResponse{-,AsyncInput-})+import DialogueIO(Request,Response)+import LayoutRequest(LayoutMessage(..),LayoutResponse)++data FRequest+  = XCmd XCommand+  | LCmd LayoutMessage+  -- asynchronous above, synchronous below, but see ../internal/IsRequest.hs+  | XReq XRequest+  | SReq SocketRequest+  | DReq Request+  deriving Show++data FResponse+  = XEvt  XEvent+  | LEvt  LayoutResponse+--  | SEvt  AsyncInput -- still represented as DResp (AsyncInput ...)+  -- asynchronous above, synchronous below, but see ../internal/IsRequest.hs+  | XResp XResponse+  | SResp SocketResponse+  | DResp Response+  deriving Show++layoutRequestCmd = LCmd . LayoutRequest
+ hsrc/xtypes/Image.hs view
@@ -0,0 +1,7 @@+module Image where++newtype ImageFormat = ImageFormat Int deriving (Eq, Ord, Read, Show)++xyBitmap = ImageFormat 0+xyPixmap = ImageFormat 1+zPixmap  = ImageFormat 2
+ hsrc/xtypes/ResourceIds.hs view
@@ -0,0 +1,44 @@+module ResourceIds where+--import Data.Word(Word32)++newtype XID = XID Int deriving (Eq,Ord)++instance Show XID where showsPrec d (XID w32) = showsPrec d w32+instance Read XID where readsPrec d s = [(XID w,r)|(w,r)<-readsPrec d s]++newtype WindowId = WindowId XID deriving (Eq, Ord, Show, Read)++type Window = WindowId+type XWId = WindowId++rootWindow = WindowId (XID 0)+noWindow = WindowId (XID (-1))+windowNone = WindowId (XID 0)++newtype PixmapId = PixmapId XID deriving (Eq, Ord, Show, Read)+newtype DbeBackBufferId = DbeBackBufferId XID deriving (Eq, Ord, Show, Read)+newtype FontId = FontId XID deriving (Eq, Ord, Read, Show)+newtype GCId = GCId Int deriving (Eq, Ord, Read, Show)+newtype CursorId = CursorId XID deriving (Eq, Ord, Read, Show)+newtype ColormapId = ColormapId XID deriving (Eq, Ord, Read, Show)++defaultColormap = ColormapId (XID 0)+cursorNone = CursorId (XID 0)++newtype Atom = Atom Int deriving (Eq, Ord, Show, Read)+++type ColorName = String+type FontName = String++type Time = Int+currentTime = 0::Time++type Depth = Int++copyFromParent = 0 :: Depth+parentRelative = PixmapId (XID 1)+none = PixmapId (XID 0)++rootGC = GCId 0+
+ hsrc/xtypes/Sockets.hs view
@@ -0,0 +1,68 @@+module Sockets(DLValue,module Sockets) where+import Event(XEvent)+import Xtypes(WindowId,Display)+import PackedString(PackedString)+import DLValue+import System.Posix.DynamicLinker(DL)++-- NOTE: Matching definitions for the C world appear in xlib/sockets.h --------++data SocketRequest = OpenLSocket Port                -- -> SR LSocket+                   | OpenSocket Host Port            -- -> SR Socket+                   | WriteSocket Socket String       -- -> SR Success+                   | CloseSocket Socket              -- -> SR Success+                   | CloseLSocket LSocket            -- -> SR Success+                   | GetStdinSocket                  -- -> SR Socket+                   | CreateTimer Int Int             -- -> SR Timer+                   | DestroyTimer Timer              -- -> Success+		   | GetLSocketName LSocket          -- -> Str+		   | GetSocketName Socket            -- -> Str+		   | StartProcess String Bool Bool Bool -- -> ProcessSockets+		   | DLOpen String                   -- -> SR DLHandle+		   | DLClose DLHandle		     -- -> Success+                   | DLSym DLHandle String           -- -> SR DLValue+		   | OpenFileAsSocket String String  -- -> SR Socket+		                   -- name,  mode  (as in fopen(name,mode))+		   | WriteSocketPS Socket PackedString -- -> SR Wrote+                   | GetStdoutSocket                 -- -> SR Socket+                      deriving (Show,Read)++data SocketResponse = LSocket LSocket+                    | Socket Socket+                    | Timer Timer+		    | ProcessSockets (Maybe Socket) (Maybe Socket) (Maybe Socket)+                    | DLHandle DLHandle+                    | DLVal DLValue+		    | Wrote Int+                      deriving (Show,Read) --(Eq, Ord, Text)++type Port = Int+type Host = String+type Peer = Host++newtype Socket = So Int deriving (Eq,Ord,Show,Read)+newtype LSocket = LSo Int deriving (Eq,Ord,Show,Read)++newtype Timer = Ti Int deriving (Eq,Ord,Show,Read)++type AsyncInput = (Descriptor, AEvent)++data Descriptor+  = LSocketDe LSocket+  | SocketDe Socket+  | OutputSocketDe Socket+  | TimerDe Timer+  | DisplayDe Display +  deriving (Eq, Ord, Read, Show)++data AEvent+  = SocketAccepted Socket Peer+  | SocketRead String+  | SocketWritable+  | TimerAlarm+  | XEvent (WindowId, XEvent) +  deriving (Show,Read)++newtype DLHandle = DL DL deriving Show++instance Read DLHandle
+ hsrc/xtypes/Visual.hs view
@@ -0,0 +1,19 @@+module Visual where+import HbcWord++data DisplayClass+  = StaticGray | GrayScale+  | StaticColor | PseudoColor+  | TrueColor | DirectColor+  deriving (Eq,Show,Read,Bounded,Enum)++newtype VisualID = VisualID Int deriving (Eq,Show,Read)++data Visual+  = Visual { visualid :: VisualID,+	     visualClass :: DisplayClass,+	     red_mask,green_mask,blue_mask :: Word,+	     bits_per_rgb :: Int,+	     map_entries :: Int+	   }+  deriving (Show,Read)
+ hsrc/xtypes/XDraw.hs view
@@ -0,0 +1,20 @@+module XDraw(module DrawTypes,module XDraw) where+import Command(XCommand(Draw,DrawMany,ClearArea,ClearWindow))+import FRequest+import Geometry(Rect(..),Point(..))+import DrawTypes++draw d gc dcmd = XCmd (Draw d gc dcmd)+drawMany d dcmds = XCmd (DrawMany d dcmds)++wDraw = draw MyWindow+wDrawMany = drawMany MyWindow++pmDraw = draw . Pixmap +pmDrawMany = drawMany . Pixmap++clearArea r b = XCmd (ClearArea r b)+clearWindow = XCmd ClearWindow++fillCircle p r = FillArc (Rect p (Point r r)) 0 (64 * 360)+drawCircle p r = DrawArc (Rect p (Point r r)) 0 (64 * 360)
+ hsrc/xtypes/XStuff.hs view
@@ -0,0 +1,8 @@+module XStuff(XCommand,XEvent,XWId(..),WindowId,XRequest,XResponse,AsyncInput(..),AEvent,SocketRequest,Descriptor,SocketResponse,XDisplay(..),Display) where+import Command+import Event+import Sockets+import Xtypes++-- This file part is NOT part of the Fudget library. It is used+-- to create an interface file for use in the Prelude construction.
+ hsrc/xtypes/XTypesModules.hs view
@@ -0,0 +1,11 @@+module XTypesModules (-- * X types+  module FRequest,module Command,module Event,module Sockets ,module Xtypes,module Visual,module XDraw,module DrawInPixmap, module DrawInWindow) where+import FRequest+import Command+import Event+import Sockets+import Xtypes+import Visual+import XDraw+import DrawInPixmap+import DrawInWindow
+ hsrc/xtypes/Xtypes.hs view
@@ -0,0 +1,164 @@+module Xtypes(module Xtypes,module EventMask,module AuxTypes,module ResourceIds,module Image) where+--import Geometry(Line, Point, Rect)+import EventMask+import AuxTypes+import ResourceIds+import Image+import Data.Ix+import HbcWord++-- #ifdef __NHC__+-- Bug in export of newtype+-- #define newtype data+-- #endif++newtype Display = Display Int deriving (Eq, Ord, Show, Read)+type XDisplay = Display++noDisplay = Display (-1)++type KeyLookup = String+type Width = Int++newtype Pixel = Pixel Word deriving (Eq, Ord, Show, Read)++type PlaneMask = Pixel++pixel0 = Pixel 0+pixel1 = Pixel 1+--black = Pixel 0 -- not always true !!+--white = Pixel 1 -- not always true !!++data RGB = RGB Int Int Int deriving ( Eq, Ord, Show, Read, Ix )+data Color = Color { colorPixel::Pixel, colorRGB::RGB }+             deriving (Eq, Ord, Show, Read)++maxRGB :: Int -- for hugs+maxRGB = 65535+grayRGB x = RGB x x x+whiteRGB = grayRGB maxRGB+blackRGB = grayRGB 0++data Selection = Selection Atom Atom Atom  deriving (Eq, Ord, Show, Read)+++newtype PropertyMode = PropertyMode Int deriving (Eq, Ord, Show, Read)++propModeReplace = PropertyMode 0+propModePrepend = PropertyMode 1+propModeAppend  = PropertyMode 2++--data EventMask -- moved to EventMask.hs++data BackingStore+  = NotUseful | WhenMapped | Always +  deriving (Eq, Ord, Show, Read, Bounded, Enum)++data GrabPointerResult+  = GrabSuccess+  | AlreadyGrabbed+  | GrabInvalidTime+  | GrabNotViewable+  | GrabFrozen +  deriving (Eq, Ord, Show, Read, Bounded, Enum)++-- Same order as in X.h+data GCFunction+  = GXclear+  | GXand+  | GXandReverse+  | GXcopy+  | GXandInverted+  | GXnoop+  | GXxor+  | GXor+  | GXnor+  | GXequiv+  | GXinvert+  | GXorReverse+  | GXCopyInverted+  | GXorInverted+  | GXnand+  | GXset +  deriving (Eq, Ord, Show, Read, Bounded, Enum)+++-- Same order as in X.h+data GCLineStyle+  = LineSolid | LineDoubleDash | LineOnOffDash +  deriving (Eq, Ord, Show, Read, Bounded, Enum)++data GCCapStyle+  = CapNotLast | CapButt | CapRound | CapProjecting +  deriving (Eq, Ord, Show, Read, Bounded, Enum)++data GCJoinStyle+  = JoinMiter | JoinRound | JoinBevel+  deriving (Eq, Ord, Show, Read, Bounded, Enum)+  +data GCSubwindowMode+  = ClipByChildren | IncludeInferiors +  deriving (Eq, Ord, Show, Read, Bounded, Enum)++data GCFillStyle+  = FillSolid | FillTiled | FillStippled | FillOpaqueStippled+  deriving (Eq, Ord, Show, Read, Bounded, Enum)++data GCAttributes a b+  = GCFunction GCFunction+  | GCForeground a+  | GCBackground a+  | GCLineWidth Width+  | GCLineStyle GCLineStyle+  | GCFont b+  | GCCapStyle GCCapStyle+  | GCSubwindowMode GCSubwindowMode+  | GCGraphicsExposures Bool+  | GCFillStyle GCFillStyle+  | GCTile PixmapId+  | GCStipple PixmapId+  | GCJoinStyle GCJoinStyle+  deriving (Eq, Ord, Show, Read)++type GCAttributeList = [GCAttributes Pixel FontId]++--invertGCattrs = invertColorGCattrs white black++invertColorGCattrs bgcol fgcol =+    [GCFunction GXxor, GCForeground (invcol bgcol fgcol)]++invcol (Pixel bg) (Pixel fg) = Pixel (bitXor bg fg)++data WindowAttributes+  = CWEventMask [EventMask]+  | CWBackingStore BackingStore+  | CWSaveUnder Bool+  | CWDontPropagate [EventMask]+  | CWOverrideRedirect Bool+  | CWBackPixel Pixel+  | CWCursor CursorId+  | CWBitGravity Gravity+  | CWWinGravity Gravity+  | CWBackPixmap PixmapId+  | CWBorderPixmap PixmapId+  | CWBorderPixel Pixel+  deriving (Eq, Ord, Show, Read)++data WindowChanges+  = CWX Int+  | CWY Int+  | CWWidth Int+  | CWHeight Int+  | CWBorderWidth Int+  | CWStackMode StackMode +  deriving (Eq, Ord, Show, Read)++data StackMode+  = StackAbove | StackBelow | TopIf | BottomIf | Opposite +  deriving (Eq, Ord, Read, Show, Bounded, Enum)+++-- DBE (double buffering extension):+data SwapAction+  = DbeUndefined | DbeBackground | DbeUntouched | DbeCopied+  deriving (Eq, Ord, Show, Read, Bounded, Enum)
+ xlib/fdzero.c view
@@ -0,0 +1,53 @@+#include <sys/types.h>+#include <errno.h>+#include <stdio.h>+#include <X11/Xlib.h>+#include <X11/Xutil.h>+#ifdef __MACH__+#include <sys/time.h>+#endif++/* For use in ghc-dialogue/AsyncInput.hs since+   calling FD_ZERO from _casm_ doesn't work with ghc on Linux-386. gcc+   compilains about a spilled register. /TH 2000-03-17++   Used for more functions after getting rid of _casm_/_ccall_ for GHC 6.2... +   /TH 2004-03-25+*/++void fdzero(fd_set *s) { FD_ZERO(s); }+void fdset(int fd,fd_set *s) { FD_SET(fd,s); }+int fdisset(int fd,fd_set *s) { return FD_ISSET(fd,s); }+/* void bcopy_fdset(fd_set *src,fd_set *dst) { bcopy(src,dst,sizeof(fd_set)); } */+void bcopy_fdset(fd_set *src,fd_set *dst) { *dst=*src; }++int get_errno(void) { return errno; }+long get_stdin(void) { return (long)stdin; }+int get_fileno(long f) { return fileno((FILE *)f); }++void xDestroyImage(XImage *ximage) { XDestroyImage(ximage); }+void setXImage_data(XImage *ximage,char *data) { ximage->data=data; }++int default_bpp(Display *d,int depth) {+  int i,cnt,bpp;+  XPixmapFormatValues *ps=XListPixmapFormats(d,&cnt);+  bpp=depth; /* Hmm. Something is wrong if depth isn't found. */+  for(i=0;i<cnt;i++)+    if(ps[i].depth==depth) {+      bpp=ps[i].bits_per_pixel;+      break;+    }+  XFree(ps);+  /*fprintf(stderr,"default_bpp(%d,%d)=%d\n",(int)d,depth,bpp);*/+  return bpp;+}++void disable_timers(void) {+#ifdef __MACH__+  /* Disable timers set up by the GHC RTS. */+  struct itimerval zero;+  timerclear(&zero.it_interval);+  timerclear(&zero.it_value);+  setitimer(ITIMER_VIRTUAL,&zero,NULL);+#endif+}
+ xlib/socketlib/defs.h view
@@ -0,0 +1,18 @@+/*+ * (c) Copyright 1991 by Panagiotis Tsirigotis+ * Read the file COPYRIGHT for more details.+ * + */+/*+ * $Header: /home/magnus/cvs/Fudgets/xlib/socketlib/defs.h,v 1.1.1.1 1996-03-10 16:56:13 magnus Exp $+ */++#define SYSCALL_ERROR		-1+#define RESOLVER_ERROR		-2+#define OPTION_ERROR			-3++/*+ * How many times to try gethostbyname+ */+#define MAX_TRIES				3+
+ xlib/socketlib/inet.c view
@@ -0,0 +1,404 @@+/*+ * (c) Copyright 1991 by Panagiotis Tsirigotis+ * Read the file COPYRIGHT for more details.+ * + */+/*+ * Internet support library.+ *+ * INTERFACE:+ *+ *		in_address			: form an internet address+ *		in_bind				: bind a socket to an internet address+ *		in_bind_opt			: bind a socket to an internet address and+ *								  set (for now, binary) options+ *		in_connect			: connect to an internet address+ *		in_connect_opt		: connect to an internet address and+ *								  set (for now, binary) options+ *+ */+++#include <sys/types.h>+#include <sys/socket.h>+#include <netinet/in.h>+#include <arpa/inet.h>+#include <netdb.h>+/* #include <stdarg.h> */+#include <stdio.h>+#include <ctype.h>+#include <string.h>+#include <unistd.h>+#include <errno.h>    /* on some systems, errno is not a variable */+/* extern int errno ; */++#include <sys/param.h>+#ifdef MAXHOSTNAMELEN+#define HOST_NAME_LEN		MAXHOSTNAMELEN+#else+#define HOST_NAME_LEN		32+#endif++#include "defs.h"++#if defined(__NetBSD__) || defined(_HPUX_SOURCE)+extern int h_errno;+#endif++/*+ * $Header: /home/magnus/cvs/Fudgets/xlib/socketlib/inet.c,v 1.7 2013-07-28 12:09:13 hallgren Exp $+ */++#define PRIVATE				static++static char *version = VERSION ;++enum status_e { OK, ERROR } ;+++/*+ * Close a file descriptor without destroying errno+ */+#define CLOSE( sd, t )				t = errno ;						\+											(void) close( sd ) ;			\+											errno = t+#ifndef FALSE+#define FALSE			0+#define TRUE			1+#endif+++/*+ * Returns TRUE if the host argument has the form:+ *		<num>.<num>+ *		<num>.<num>.<num>+ *		<num>.<num>.<num>.<num>+ */+PRIVATE int is_number_address( host )+	char *host ;+{+	register int dot_count = 0 ;+	register char *p ;++	if ( host == NULL )+		return( FALSE ) ;+	+	for ( p = host ; *p ; p++ )+		if ( isascii( *p ) && isdigit( *p ) )		/* skip digits */+			continue ;+		else if ( *p == '.' )							/* count dots */+		{+			dot_count++ ;+			if ( dot_count > 3 )+				return( FALSE ) ;+		}+		else													/* reject everything else */+			return( FALSE ) ;+	return( dot_count > 0 ) ;+}++++/*+ * Form an Internet address.+ * If host is NULL, the current host is assumed (but this does not+ * guarantee the use of the loopback address)+ *+ * Return value:+ *		0					: if successful+ *		RESOLVER_ERROR	: if an error occurs+ *+ * In case of error, errno is set to the value of h_errno, if the OS+ * supports h_errno; if not, the value of errno is undefined.+ */+int in_address( host, port, address )+	char *host ;+	short port ;+	struct sockaddr_in *address ;+{+	char host_name[ HOST_NAME_LEN ] ;+	char *the_host ;+	struct hostent *hp ;++	bzero( (char *) address, sizeof( *address ) ) ;++	/*+	 * Determine the host name+	 */+	if ( host == NULL )+	{+		(void) gethostname( host_name, HOST_NAME_LEN ) ;+		the_host = host_name ;+	}+	else+		the_host = host ;+	+	/*+	 * Get host address+	 */+	if ( is_number_address( host ) )+		address->sin_addr.s_addr = inet_addr( host ) ;+	else+	{++#ifndef HAS_H_ERRNO+		if ( ( hp = gethostbyname( the_host ) ) == NULL )+			return( RESOLVER_ERROR ) ;+#else+		int tries = 0 ;++		while ( ( hp = gethostbyname( the_host ) ) == NULL &&+				  (h_errno == TRY_AGAIN+#if __FreeBSD__ == 2+   /* Needed because of FreeBSD 2.2-961014-SNAP bug? */+				   || h_errno == NETDB_INTERNAL+#endif+				   ) &&+				  tries < MAX_TRIES )+			tries++ ;+		if ( hp == NULL )+		{+			errno = h_errno ;+			return( RESOLVER_ERROR ) ;+		}+#endif	/* HAS_H_ERRNO */++		bcopy( hp->h_addr, (char *) &address->sin_addr, hp->h_length ) ;+	}++	address->sin_family = AF_INET ;+	address->sin_port = htons( port ) ;++	return( 0 ) ;+}++++/*+ * Bind an internet address. Port is the port that will be used; the+ * address is that of the machine the program runs on.+ * Type is the type of socket; this also defines the protocol+ * that will be used (i.e. for SOCK_STREAM use TCP etc)+ *+ * Return value:+ *		a file descriptor	:  if the operation is successful+ *		SYSCALL_ERROR 		: if there is a system call error+ *		RESOLVER_ERROR 	: if there is a resolver error+ * In case of error, errno contains a description of the error+ */+PRIVATE	int bind_address() ;++int in_bind( port, type )+	short port ;+	int type ;+{+	int sd ;++	if ( ( sd = socket( AF_INET, type, 0 ) ) == -1 )+		return( SYSCALL_ERROR ) ;+	+	return( bind_address( sd, port ) ) ;+}++#if 0+PRIVATE	va_list apply_options() ;+#endif++/*+ * Same as in_bind but also sets socket-level options.+ * The option list is a list of pairs (option, option_value) terminated+ * by NULL.+ */+#if 0+int in_bind_opt( port, type, va_alist )+	short port ;+	int type ;+	va_dcl+{+	int sd ;+	enum status_e status ;+	va_list ap ;+	+	if ( ( sd = socket( AF_INET, type, 0 ) ) == -1 )+		return( SYSCALL_ERROR ) ;+	+	va_start( ap ) ;+	ap = apply_options( sd, ap, &status );+	va_end( ap ) ;+	if ( status == ERROR )+		return( OPTION_ERROR ) ;++	return( bind_address( sd, port ) ) ;+}+#endif++++/*+ * bind_address binds the address <INADDR_ANY,port> to a socket.+ * Return value:+ *		socket			: if successful+ *		SYSCALL_ERROR	: if bind fails+ *		RESOLVER_ERROR	: if it can't get the address of the local host+ */+PRIVATE int bind_address( sd, port )+	int sd ;+	short port ;+{+	struct sockaddr_in sin ;+	int errno_save ;++	sin.sin_family = AF_INET ;+	sin.sin_addr.s_addr = INADDR_ANY ;+	sin.sin_port = htons( port ) ;++	if ( bind( sd, (struct sockaddr *) &sin, sizeof( sin ) ) == -1 )+	{+		CLOSE( sd, errno_save ) ;+		return( SYSCALL_ERROR ) ;+	}+	return( sd ) ;+}+++/*+ * Apply the options in the option_list.+ * Return value:+ *		The remaining part of the argument list+ *+ * The status argument shows if there has been an error.+ * In case of error, the socket is closed.+ */+#if 0+PRIVATE va_list apply_options( sd, option_list, status )+	int sd ;+	va_list option_list ;+	enum status_e *status ;+{+	register int option ;+	int errno_save ;++	/*+	 * Apply the options+	 */+	while ( ( option = va_arg( option_list, int ) ) != NULL )+	{+		int option_value ;++		/*+		 * For the moment accept only boolean options+		 */+		switch ( option )+		{+			case SO_DEBUG:+			case SO_REUSEADDR:+			case SO_KEEPALIVE:+			case SO_DONTROUTE:+			case SO_BROADCAST:+			case SO_OOBINLINE:+				option_value = va_arg( option_list, int ) ;+				if ( setsockopt( sd, SOL_SOCKET, option,+							&option_value, sizeof( option_value ) ) == -1 )+				{+					CLOSE( sd, errno_save ) ;+					*status = ERROR ;+					return( option_list ) ;+				}+				break ;++			default:+				break ;+		}+	}+	*status = OK ;+	return( option_list ) ;+}+#endif++PRIVATE	int connect_to_host() ;++/*+ * Connect to an internet address. The address is specified by the+ * host, port arguments. Type is the type of the socket which+ * defines the type of the protocol to be used.+ * If host is NULL, then the local host is implied.+ *+ * Return value:+ *		a file descriptor	:  if the operation is successful+ *		SYSCALL_ERROR 		: if there is a system call error+ *		RESOLVER_ERROR 	: if there is a resolver error+ * In case of error errno contains a description of the error+ */+int in_connect( host, port, type )+	char *host ;+	short port ;+	int type ;+{+	int sd ;++	if ( ( sd = socket( AF_INET, type, 0 ) ) == -1 )+		return( SYSCALL_ERROR ) ;+	+	return( connect_to_host( sd, host, port ) ) ;+}++++/*+ * Same as in_connect but also sets socket-level options+ */+#if 0+int in_connect_opt( host, port, type, va_alist )+	char *host ;+	short port ;+	int type ;+	va_dcl+{+	int sd ;+	enum status_e status ;+	va_list ap ;+	int connect_to_host() ;+	va_list apply_options() ;++	if ( ( sd = socket( AF_INET, type, 0 ) ) == -1 )+		return( SYSCALL_ERROR ) ;+	+	va_start( ap ) ;+	ap = apply_options( sd, ap, &status ) ;+	va_end( ap ) ;+	if ( status == ERROR )+		return( OPTION_ERROR ) ;+	+	return( connect_to_host( sd, host, port ) ) ;+}+#endif++/*+ * connect_to_host tries to connect socket sd to the address <host,port>+ * Return value:+ *		socket				: if the operation is successful+ *		RESOLVER_ERROR		: if there is a resolver error+ *		SYSCALL_ERROR		: if connect(2) fails+ */+PRIVATE int connect_to_host( sd, host, port )+	int sd ;+	char *host ;+	short port ;+{+	struct sockaddr_in sin ;+	int errno_save ;++	if ( in_address( host, port, &sin ) == RESOLVER_ERROR )+	{+		CLOSE( sd, errno_save ) ;+		return( RESOLVER_ERROR ) ;+	}++	if ( connect( sd, (struct sockaddr *) &sin, sizeof( sin ) ) == -1 )+	{+		CLOSE( sd, errno_save ) ;+		return( SYSCALL_ERROR ) ;+	}+	return( sd ) ;+}+