ltk 0.13.2.0 → 0.14.0.0
raw patch · 12 files changed
+272/−234 lines, 12 filesdep +textdep ~glibdep ~gtkdep ~gtk3
Dependencies added: text
Dependency ranges changed: glib, gtk, gtk3
Files
- ltk.cabal +4/−4
- src/Default.hs +6/−0
- src/Graphics/UI/Editor/Basics.hs +17/−5
- src/Graphics/UI/Editor/Composite.hs +24/−20
- src/Graphics/UI/Editor/DescriptionPP.hs +7/−3
- src/Graphics/UI/Editor/MakeEditor.hs +8/−5
- src/Graphics/UI/Editor/Parameters.hs +8/−6
- src/Graphics/UI/Editor/Simple.hs +45/−32
- src/Graphics/UI/Frame/Panes.hs +20/−18
- src/Graphics/UI/Frame/ViewFrame.hs +103/−98
- src/MyMissing.hs +6/−23
- src/Text/PrinterParser.hs +24/−20
ltk.cabal view
@@ -1,5 +1,5 @@ name: ltk-version: 0.13.2.0+version: 0.14.0.0 cabal-version: >= 1.8 build-type: Simple license: GPL@@ -26,16 +26,16 @@ Library build-depends: Cabal >=1.6.0 && <1.19, base >=4.0.0.0 && <4.8, containers >=0.2 && <0.6, filepath >=1.1.0 && <1.4,- glib >=0.10.0 && <0.13,+ glib >=0.13.0.0 && <0.14, text >=0.11.0.6 && <1.2, mtl >=1.1.0.2 && <2.2, parsec >=2.1.0.1 && <3.2, pretty >=1.0.1.0 && <1.2, transformers >=0.2.2.0 && <0.4, ghc -any if flag(gtk3)- build-depends: gtk3 >=0.12.4 && <0.13+ build-depends: gtk3 >=0.13.0.0 && <0.14 cpp-options: -DMIN_VERSION_gtk=MIN_VERSION_gtk3 else- build-depends: gtk >=0.12.4 && <0.13+ build-depends: gtk >=0.13.0.0 && <0.14 exposed-modules: Default MyMissing Control.Event Graphics.UI.Editor.Basics Graphics.UI.Editor.Composite
src/Default.hs view
@@ -17,6 +17,9 @@ Default(..) ) where +import Data.Text (Text)+import qualified Data.Text as T (empty)+ -- -- | A class for providing default values for certain types of editors --@@ -37,6 +40,9 @@ instance Default [alpha] where getDefault = []++instance Default Text where+ getDefault = T.empty instance Default (Maybe alpha) where getDefault = Nothing
src/Graphics/UI/Editor/Basics.hs view
@@ -1,6 +1,8 @@-{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, FlexibleContexts, RankNTypes,- ExistentialQuantification, TypeFamilies, ImpredicativeTypes #-}-+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : Graphics.UI.Editor.Basics@@ -39,9 +41,13 @@ , propagateAsChanged ) where +import Prelude+import Text.Show+ import Graphics.UI.Gtk import Data.Unique import Data.IORef+import Data.Text (Text) import Control.Monad import Control.Monad.Trans (liftIO) @@ -53,7 +59,13 @@ import Unsafe.Coerce (unsafeCoerce) import Control.Arrow (first) import MyMissing (allOf)+import qualified Data.Text as T (pack) +fromString = Just . T.pack++ifThenElse True t _ = t+ifThenElse _ _ f = f+ -- --------------------------------------------------------------------- -- * Basic Types --@@ -92,7 +104,7 @@ -- data GUIEvent = GUIEvent { selector :: GUIEventSelector-, eventText :: String+, eventText :: Text , gtkReturn :: Bool -- ^ True means that the event has been completely handled, -- gtk shoudn't do any further action about it (Often not -- a good idea@@ -276,7 +288,7 @@ Just handlers -> do name <- if (widget `isA` gTypeWidget) then widgetGetName (castToWidget widget)- else return "no widget - no name"+ else return "no widget - no name" :: IO Text eventList <- mapM (\f -> do let ev = GUIEvent eventSel "" False f ev)
src/Graphics/UI/Editor/Composite.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : Graphics.UI.Editor.Composite@@ -23,7 +25,7 @@ , ColumnDescr(..) , filesEditor-, stringsEditor+, textsEditor , versionEditor , versionRangeEditor@@ -35,6 +37,8 @@ import Control.Monad import Data.IORef import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T (pack, unpack, null) import Default import Control.Event@@ -198,7 +202,7 @@ -- | An editor with a subeditor which gets active, when a checkbox is selected -- or deselected (if the positive Argument is False) ---maybeEditor :: Default beta => (Editor beta, Parameters) -> Bool -> String -> Editor (Maybe beta)+maybeEditor :: Default beta => (Editor beta, Parameters) -> Bool -> Text -> Editor (Maybe beta) maybeEditor (childEdit, childParams) positive boolLabel parameters notifier = do coreRef <- newIORef Nothing childRef <- newIORef Nothing@@ -316,7 +320,7 @@ -- | An editor with a subeditor which gets active, when a checkbox is selected -- or grayed out (if the positive Argument is False) ---disableEditor :: Default beta => (Editor beta, Parameters) -> Bool -> String -> Editor (Bool,beta)+disableEditor :: Default beta => (Editor beta, Parameters) -> Bool -> Text -> Editor (Bool,beta) disableEditor (childEdit, childParams) positive boolLabel parameters notifier = do coreRef <- newIORef Nothing childRef <- newIORef Nothing@@ -450,7 +454,7 @@ -- | An editor with a subeditor which gets active, when a checkbox is selected -- or deselected (if the positive Argument is False) eitherOrEditor :: (Default alpha, Default beta) => (Editor alpha, Parameters) ->- (Editor beta, Parameters) -> String -> Editor (Either alpha beta)+ (Editor beta, Parameters) -> Text -> Editor (Either alpha beta) eitherOrEditor (leftEditor,leftParams) (rightEditor,rightParams) label2 parameters notifier = do coreRef <- newIORef Nothing@@ -546,7 +550,7 @@ -- and a nontrivial: -- [("Package",\(Dependency str _) -> [cellText := str]) -- ,("Version",\(Dependency _ vers) -> [cellText := showVersionRange vers])])-data ColumnDescr row = ColumnDescr Bool [(String,(row -> [AttrOp CellRendererText]))]+data ColumnDescr row = ColumnDescr Bool [(Text,(row -> [AttrOp CellRendererText]))] -- -- | An editor with a subeditor, of which a list of items can be selected@@ -576,8 +580,8 @@ return (castToBox b,castToButtonBox bb) (frameS,injS,extS) <- singleEditor sParams cnoti mapM_ (propagateEvent notifier [cnoti]) allGUIEvents- addButton <- buttonNewWithLabel "Add"- removeButton <- buttonNewWithLabel "Remove"+ addButton <- buttonNewWithLabel ("Add" :: Text)+ removeButton <- buttonNewWithLabel ("Remove" :: Text) containerAdd buttonBox addButton containerAdd buttonBox removeButton listStore <- listStoreNew ([]:: [alpha])@@ -689,21 +693,21 @@ return () -filesEditor :: Maybe FilePath -> FileChooserAction -> String -> Editor [FilePath]+filesEditor :: Maybe FilePath -> FileChooserAction -> Text -> Editor [FilePath] filesEditor fp act label p = multisetEditor- (ColumnDescr False [("",(\row -> [cellText := row]))])+ (ColumnDescr False [("",(\row -> [cellText := T.pack row]))]) (fileEditor fp act label, emptyParams) (Just sort) (Just (==)) (paraShadow <<<- ParaShadow ShadowIn $ paraDirection <<<- ParaDirection Vertical $ p) -stringsEditor :: (String -> Bool) -> Bool -> Editor [String]-stringsEditor validation trimBlanks p =+textsEditor :: (Text -> Bool) -> Bool -> Editor [Text]+textsEditor validation trimBlanks p = multisetEditor (ColumnDescr False [("",(\row -> [cellText := row]))])- (stringEditor validation trimBlanks, emptyParams)+ (textEditor validation trimBlanks, emptyParams) (Just sort) (Just (==)) (paraShadow <<<- ParaShadow ShadowIn $ p)@@ -711,25 +715,25 @@ dependencyEditor :: [PackageIdentifier] -> Editor Dependency dependencyEditor packages para noti = do (wid,inj,ext) <- pairEditor- (comboEntryEditor ((sort . nub) (map (display . pkgName) packages))+ (comboEntryEditor ((sort . nub) (map (T.pack . display . pkgName) packages)) , paraName <<<- ParaName "Select" $ emptyParams) (versionRangeEditor,paraName <<<- ParaName "Version" $ emptyParams) (paraDirection <<<- ParaDirection Vertical $ para) noti- let pinj (Dependency pn@(PackageName s) v) = inj (s,v)+ let pinj (Dependency pn@(PackageName s) v) = inj (T.pack s,v) let pext = do mbp <- ext case mbp of Nothing -> return Nothing Just ("",v) -> return Nothing- Just (s,v) -> return (Just $ Dependency (PackageName s) v)+ Just (s,v) -> return (Just $ Dependency (PackageName (T.unpack s)) v) return (wid,pinj,pext) dependenciesEditor :: [PackageIdentifier] -> Editor [Dependency] dependenciesEditor packages p noti = multisetEditor- (ColumnDescr True [("Package",\(Dependency (PackageName str) _) -> [cellText := str])- ,("Version",\(Dependency _ vers) -> [cellText := display vers])])+ (ColumnDescr True [("Package",\(Dependency (PackageName str) _) -> [cellText := T.pack str])+ ,("Version",\(Dependency _ vers) -> [cellText := T.pack $ display vers])]) (dependencyEditor packages, paraOuterAlignment <<<- ParaInnerAlignment (0.0, 0.5, 1.0, 1.0) $ paraInnerAlignment <<<- ParaOuterAlignment (0.0, 0.5, 1.0, 1.0)@@ -750,7 +754,7 @@ maybeEditor ((eitherOrEditor (pairEditor- (comboSelectionEditor v1 show, emptyParams)+ (comboSelectionEditor v1 (T.pack . show), emptyParams) (versionEditor, paraName <<<- ParaName "Enter Version" $ emptyParams), (paraDirection <<<- ParaDirection Vertical $ paraName <<<- ParaName "Simple"@@ -760,7 +764,7 @@ $ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0) $ emptyParams)) (tupel3Editor- (comboSelectionEditor v2 show, emptyParams)+ (comboSelectionEditor v2 (T.pack . show), emptyParams) (versionRangeEditor, paraShadow <<<- ParaShadow ShadowIn $ emptyParams) (versionRangeEditor, paraShadow <<<- ParaShadow ShadowIn $ emptyParams), paraName <<<- ParaName "Complex"@@ -835,7 +839,7 @@ versionEditor :: Editor Version versionEditor para noti = do- (wid,inj,ext) <- stringEditor (\s -> not (null s)) True para noti+ (wid,inj,ext) <- stringEditor (not . null) True para noti let pinj v = inj (display v) let pext = do s <- ext
src/Graphics/UI/Editor/DescriptionPP.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : Graphics.UI.Editor.DescriptionPP@@ -30,6 +31,9 @@ import Graphics.UI.Editor.MakeEditor --import IDE.Core.State import Graphics.UI.Editor.Basics (Applicator(..),Editor(..),Setter(..),Getter(..),Notifier(..),Extractor(..),Injector(..))+import qualified Data.Text as T (unpack)+import Data.Monoid ((<>))+import Data.Text (Text) data FieldDescriptionPP alpha gamma = FDPP { parameters :: Parameters@@ -39,7 +43,7 @@ , applicator :: alpha -> alpha -> gamma ()} | VFDPP Parameters [FieldDescriptionPP alpha gamma] | HFDPP Parameters [FieldDescriptionPP alpha gamma]- | NFDPP [(String,FieldDescriptionPP alpha gamma)]+ | NFDPP [(Text,FieldDescriptionPP alpha gamma)] type MkFieldDescriptionPP alpha beta gamma = Parameters ->@@ -57,11 +61,11 @@ in FDPP parameters (\ dat -> (PP.text (case getParameterPrim paraName parameters of Nothing -> ""- Just str -> str) PP.<> PP.colon)+ Just str -> T.unpack str) PP.<> PP.colon) PP.$$ (PP.nest 15 (printer (getter dat))) PP.$$ (PP.nest 5 (case getParameterPrim paraSynopsis parameters of Nothing -> PP.empty- Just str -> PP.text $"--" ++ str)))+ Just str -> PP.text . T.unpack $ "--" <> str))) (\ dat -> P.try (do symbol (case getParameterPrim paraName parameters of Nothing -> ""
src/Graphics/UI/Editor/MakeEditor.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- --group_Test -- Module : Graphics.UI.Editor.MakeEditor@@ -30,7 +31,9 @@ import Graphics.UI.Gtk import Control.Monad-import Data.List (intersperse, unzip4)+import Data.List (unzip4, intersperse)+import Data.Text (Text)+import Data.Monoid ((<>), mconcat) import Control.Event import Graphics.UI.Editor.Parameters@@ -57,7 +60,7 @@ alpha -> Extractor alpha , Notifier)) | VFD Parameters [FieldDescription alpha] | HFD Parameters [FieldDescription alpha]- | NFD [(String,FieldDescription alpha)]+ | NFD [(Text,FieldDescription alpha)] parameters :: FieldDescription alpha -> Parameters parameters (FD p _) = p@@ -209,20 +212,20 @@ -- | Convenience method to validate and extract fields ---extractAndValidate :: alpha -> [alpha -> Extractor alpha] -> [String] -> Notifier -> IO (Maybe alpha)+extractAndValidate :: alpha -> [alpha -> Extractor alpha] -> [Text] -> Notifier -> IO (Maybe alpha) extractAndValidate val getExts fieldNames notifier = do (newVal,errors) <- foldM (\ (val,errs) (ext,fn) -> do extVal <- ext val case extVal of Just nval -> return (nval,errs)- Nothing -> return (val, (' ' : fn) : errs))+ Nothing -> return (val, (" " <> fn) : errs)) (val,[]) (zip getExts fieldNames) if null errors then return (Just newVal) else do triggerEvent notifier (GUIEvent { selector = ValidationError,- eventText = concat (intersperse ", " errors),+ eventText = mconcat (intersperse ", " errors), gtkReturn = True}) return Nothing
src/Graphics/UI/Editor/Parameters.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : Graphics.UI.Editor.Parameters@@ -40,6 +41,7 @@ import Graphics.UI.Gtk import Data.Maybe+import Data.Text (Text) import qualified Data.List as List @@ -56,8 +58,8 @@ -- type Parameters = [Parameter] -data Parameter = ParaName String- | ParaSynopsis String+data Parameter = ParaName Text+ | ParaSynopsis Text | ParaDirection Direction | ParaShadow ShadowType | ParaShowLabel Bool@@ -71,7 +73,7 @@ -- | paddingTop paddingBottom paddingLeft paddingRight | ParaMinSize (Int, Int) | ParaHorizontal HorizontalAlign- | ParaStockId String+ | ParaStockId Text | ParaMultiSel Bool | ParaPack Packing deriving (Eq,Show)@@ -88,11 +90,11 @@ emptyParams :: [Parameter] emptyParams = [] -paraName :: (Parameter -> (Maybe String))+paraName :: (Parameter -> (Maybe Text)) paraName (ParaName str) = Just str paraName _ = Nothing -paraSynopsis :: (Parameter -> (Maybe String))+paraSynopsis :: (Parameter -> (Maybe Text)) paraSynopsis (ParaSynopsis str) = Just str paraSynopsis _ = Nothing @@ -132,7 +134,7 @@ paraHorizontal (ParaHorizontal d) = Just d paraHorizontal _ = Nothing -paraStockId :: (Parameter -> (Maybe String))+paraStockId :: (Parameter -> (Maybe Text)) paraStockId (ParaStockId str) = Just str paraStockId _ = Nothing
src/Graphics/UI/Editor/Simple.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : Graphics.UI.Editor.Simple@@ -19,6 +20,7 @@ , boolEditor2 , enumEditor , clickEditor+, textEditor , stringEditor , multilineStringEditor , intEditor@@ -48,7 +50,7 @@ --import Graphics.UI.Editor.Basics import Graphics.UI.Editor.MakeEditor import Control.Event-import MyMissing (trim, allOf)+import MyMissing (allOf) import qualified Graphics.UI.Gtk.Gdk.Events as Gtk (Event(..)) import Unsafe.Coerce (unsafeCoerce) import Graphics.UI.Editor.Basics@@ -57,6 +59,9 @@ import Control.Exception as E (catch, IOException) import Control.Monad.IO.Class (MonadIO(..)) import Control.Applicative ((<$>))+import qualified Data.Text as T (strip, unpack, pack, empty)+import Data.Monoid ((<>))+import Data.Text (Text) -- ------------------------------------------------------------ -- * Simple Editors@@ -103,13 +108,13 @@ Just button -> do r <- toggleButtonGetActive button return (Just r))- (paraName <<<- ParaName "" $ parameters)+ (paraName <<<- ParaName T.empty $ parameters) notifier -- -- | Editor for a boolean value in the form of two radio buttons -----boolEditor2 :: String -> Editor Bool+boolEditor2 :: Text -> Editor Bool boolEditor2 label2 parameters notifier = do coreRef <- newIORef Nothing mkEditor@@ -122,8 +127,8 @@ radio2 <- radioButtonNewWithLabelFromWidget radio1 label2 boxPackStart box radio1 PackGrow 2 boxPackStart box radio2 PackGrow 2- widgetSetName radio1 $ getParameter paraName parameters ++ ".1"- widgetSetName radio2 $ getParameter paraName parameters ++ ".2"+ widgetSetName radio1 $ getParameter paraName parameters <> ".1"+ widgetSetName radio2 $ getParameter paraName parameters <> ".2" containerAdd widget box if bool then toggleButtonSetActive radio1 True@@ -148,7 +153,7 @@ -- -- | Editor for an enum value in the form of n radio buttons -----enumEditor :: forall alpha . (Show alpha, Enum alpha, Bounded alpha) => [String] -> Editor alpha+enumEditor :: forall alpha . (Show alpha, Enum alpha, Bounded alpha) => [Text] -> Editor alpha enumEditor labels parameters notifier = do coreRef <- newIORef Nothing let vals :: [alpha] = allOf@@ -158,16 +163,16 @@ case core of Nothing -> do box <- vBoxNew True 2- let label0 = if length labels > 0 then labels !! 0 else show (vals !! 0)+ let label0 = if length labels > 0 then labels !! 0 else T.pack (show (vals !! 0)) button0 <- radioButtonNewWithLabel label0 buttons <- mapM (\ v -> do let n = fromEnum v- let label = if length labels > n then labels !! n else show v+ let label = if length labels > n then labels !! n else T.pack (show v) radio <- if n == 0 then return button0 else radioButtonNewWithLabelFromWidget button0 label boxPackStart box radio PackGrow 2- widgetSetName radio (label ++ show n)+ widgetSetName radio (label <> T.pack (show n)) return radio) vals containerAdd widget box mapM_@@ -243,10 +248,10 @@ notifier ----- | Editor for a string in the form of a text entry+-- | Editor for a Text in the form of a text entry ---stringEditor :: (String -> Bool) -> Bool -> Editor String-stringEditor validation trimBlanks parameters notifier = do+textEditor :: (Text -> Bool) -> Bool -> Editor Text+textEditor validation trimBlanks parameters notifier = do coreRef <- newIORef Nothing mkEditor (\widget string -> do@@ -258,24 +263,32 @@ mapM_ (activateEvent (castToWidget entry) notifier Nothing) genericGUIEvents propagateAsChanged notifier [KeyPressed] containerAdd widget entry- entrySetText entry (if trimBlanks then trim string else string)+ entrySetText entry (if trimBlanks then T.strip string else string) writeIORef coreRef (Just entry)- Just entry -> entrySetText entry (if trimBlanks then trim string else string))+ Just entry -> entrySetText entry (if trimBlanks then T.strip string else string)) (do core <- readIORef coreRef case core of Nothing -> return Nothing Just entry -> do r <- entryGetText entry if validation r- then return (Just (if trimBlanks then trim r else r))+ then return (Just (if trimBlanks then T.strip r else r)) else return Nothing) parameters notifier --+-- | Editor for a String in the form of a text entry+--+stringEditor :: (String -> Bool) -> Bool -> Editor String+stringEditor validation trimBlanks parameters notifier = do+ (wid,inj,ext) <- textEditor (validation . T.unpack) True parameters notifier+ return (wid, inj . T.pack, (T.unpack <$>) <$> ext)++-- -- | Editor for a multiline string in the form of a multiline text entry ---multilineStringEditor :: Editor String+multilineStringEditor :: Editor Text multilineStringEditor parameters notifier = do coreRef <- newIORef Nothing mkEditor@@ -381,7 +394,7 @@ -- -- | Editor for the selection of some element from a static list of elements in the -- | form of a combo box-comboSelectionEditor :: Eq beta => [beta] -> (beta -> String) -> Editor beta+comboSelectionEditor :: Eq beta => [beta] -> (beta -> Text) -> Editor beta comboSelectionEditor list showF parameters notifier = do coreRef <- newIORef Nothing mkEditor@@ -422,7 +435,7 @@ notifier -- | Like comboSelectionEditor but allows entry of text not in the list-comboEntryEditor :: [String] -> Editor String+comboEntryEditor :: [Text] -> Editor Text comboEntryEditor list parameters notifier = do coreRef <- newIORef Nothing mkEditor@@ -490,7 +503,7 @@ treeViewAppendColumn listView col cellLayoutPackStart col renderer True cellLayoutSetAttributes col renderer listStore- $ \row -> [ cellText := show row ]+ $ \row -> [ cellText := T.pack (show row) ] treeViewSetHeadersVisible listView False listStoreClear listStore mapM_ (listStoreAppend listStore) objs@@ -517,7 +530,7 @@ -- | Editor for the selection of some elements from a static list of elements in the -- | form of a list box with toggle elements -staticListMultiEditor :: (Eq beta) => [beta] -> (beta -> String) -> Editor [beta]+staticListMultiEditor :: (Eq beta) => [beta] -> (beta -> Text) -> Editor [beta] staticListMultiEditor list showF parameters notifier = do coreRef <- newIORef Nothing mkEditor@@ -592,7 +605,7 @@ -- | Editor for the selection of some elements from a static list of elements in the -- | form of a list box -staticListEditor :: (Eq beta) => [beta] -> (beta -> String) -> Editor beta+staticListEditor :: (Eq beta) => [beta] -> (beta -> Text) -> Editor beta staticListEditor list showF parameters notifier = do coreRef <- newIORef Nothing mkEditor@@ -657,7 +670,7 @@ -- -- | Editor for the selection of a file path in the form of a text entry and a button, -- | which opens a gtk file chooser-fileEditor :: Maybe FilePath -> FileChooserAction -> String -> Editor FilePath+fileEditor :: Maybe FilePath -> FileChooserAction -> Text -> Editor FilePath fileEditor mbFilePath action buttonName parameters notifier = do coreRef <- newIORef Nothing mkEditor@@ -666,11 +679,11 @@ case core of Nothing -> do button <- buttonNewWithLabel buttonName- widgetSetName button $ getParameter paraName parameters ++ "-button"+ widgetSetName button $ getParameter paraName parameters <> "-button" mapM_ (activateEvent (castToWidget button) notifier Nothing) (Clicked:genericGUIEvents) entry <- entryNew- widgetSetName entry $ getParameter paraName parameters ++ "-entry"+ widgetSetName entry $ getParameter paraName parameters <> "-entry" -- set entry [ entryEditable := False ] mapM_ (activateEvent (castToWidget entry) notifier Nothing) genericGUIEvents registerEvent notifier Clicked (buttonHandler entry)@@ -685,23 +698,23 @@ boxPackStart box entry PackGrow 0 boxPackEnd box button PackNatural 0 containerAdd widget box- entrySetText entry filePath+ entrySetText entry (T.pack filePath) writeIORef coreRef (Just entry)- Just entry -> entrySetText entry filePath)+ Just entry -> entrySetText entry (T.pack filePath)) (do core <- readIORef coreRef case core of Nothing -> return Nothing Just entry -> do str <- entryGetText entry- return (Just str))+ return (Just (T.unpack str))) parameters notifier where buttonHandler entry e = do mbFileName <- do dialog <- fileChooserDialogNew- (Just "Select File")- Nothing+ (Just ("Select File"::Text))+ Nothing action [("gtk-cancel" ,ResponseCancel)@@ -727,7 +740,7 @@ -- let relative = case mbFilePath of -- Nothing -> fn -- Just rel -> makeRelative rel fn- entrySetText entry fn+ entrySetText entry (T.pack fn) triggerEvent notifier (GUIEvent { selector = MayHaveChanged, eventText = "",@@ -737,7 +750,7 @@ -- -- | Editor for a font selection ---fontEditor :: Editor (Maybe String)+fontEditor :: Editor (Maybe Text) fontEditor parameters notifier = do coreRef <- newIORef Nothing mkEditor@@ -806,7 +819,7 @@ -- | An editor, which opens another editor -- You have to inject a value before the button can be clicked. ---otherEditor :: (alpha -> String -> IO (Maybe alpha)) -> Editor alpha+otherEditor :: (alpha -> Text -> IO (Maybe alpha)) -> Editor alpha otherEditor func parameters notifier = do coreRef <- newIORef Nothing mkEditor
src/Graphics/UI/Frame/Panes.hs view
@@ -1,8 +1,7 @@-{-# OPTIONS_GHC- -XExistentialQuantification- -XMultiParamTypeClasses- -XFunctionalDependencies- -XNoMonomorphismRestriction -XCPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Core.Panes@@ -46,6 +45,9 @@ import Graphics.UI.Editor.Basics (Connection(..), Connection, Connections) import Control.Monad.IO.Class (MonadIO)+import Data.Text (Text)+import Data.Monoid ((<>))+import qualified Data.Text as T (pack) -- --------------------------------------------------------------------- -- Panes and pane layout@@ -59,7 +61,7 @@ -- -- | An element of a path to a pane ---data PanePathElement = SplitP PaneDirection | GroupP String+data PanePathElement = SplitP PaneDirection | GroupP Text deriving (Eq,Show,Read) --@@ -75,10 +77,10 @@ data PaneLayout = HorizontalP PaneLayout PaneLayout Int | VerticalP PaneLayout PaneLayout Int | TerminalP {- paneGroups :: Map String PaneLayout+ paneGroups :: Map Text PaneLayout , paneTabs :: Maybe PaneDirection , currentPage :: Int- , detachedId :: Maybe String+ , detachedId :: Maybe Text , detachedSize :: Maybe (Int, Int) } deriving (Eq,Show,Read) @@ -90,13 +92,13 @@ getTopWidget :: alpha -> Widget -- ^ gets the top Widget of this pane- paneId :: alpha -> String- primPaneName :: alpha -> String+ paneId :: alpha -> Text+ primPaneName :: alpha -> Text paneName :: alpha -> PaneName paneName b = if getAddedIndex b == 0 then primPaneName b- else primPaneName b ++ "(" ++ show (getAddedIndex b) ++ ")"+ else primPaneName b <> "(" <> T.pack (show $ getAddedIndex b) <> ")" getAddedIndex :: alpha -> Int getAddedIndex _ = 0@@ -120,19 +122,19 @@ getPane :: delta (Maybe alpha) getPane = getThisPane - forceGetPane :: Either PanePath String -> delta alpha+ forceGetPane :: Either PanePath Text -> delta alpha forceGetPane pp = do mbPane <- getOrBuildPane pp case mbPane of Nothing -> error "Can't get pane " Just p -> return p - getOrBuildPane :: Either PanePath String -> delta (Maybe alpha)+ getOrBuildPane :: Either PanePath Text -> delta (Maybe alpha) getOrBuildPane = getOrBuildThisPane displayPane :: alpha -> Bool -> delta () displayPane = displayThisPane - getAndDisplayPane :: Either PanePath String -> Bool -> delta (Maybe alpha)+ getAndDisplayPane :: Either PanePath Text -> Bool -> delta (Maybe alpha) getAndDisplayPane pps b = do mbP <- getOrBuildThisPane pps case mbP of@@ -153,12 +155,12 @@ setFrameState :: FrameState delta -> delta () getFrameState :: delta (FrameState delta) runInIO :: forall alpha beta. (beta -> delta alpha) -> delta (beta -> IO alpha)- panePathForGroup:: String -> delta PanePath+ panePathForGroup:: Text -> delta PanePath getThisPane :: forall alpha beta . RecoverablePane alpha beta delta => delta (Maybe alpha) displayThisPane :: forall alpha beta . RecoverablePane alpha beta delta => alpha -> Bool -> delta () getOrBuildThisPane- :: forall alpha beta . RecoverablePane alpha beta delta => Either PanePath String -> delta (Maybe alpha)+ :: forall alpha beta . RecoverablePane alpha beta delta => Either PanePath Text -> delta (Maybe alpha) buildThisPane :: forall alpha beta . RecoverablePane alpha beta delta => PanePath -> Notebook ->@@ -167,7 +169,7 @@ activateThisPane :: forall alpha beta . RecoverablePane alpha beta delta => alpha -> Connections -> delta () closeThisPane :: forall alpha beta . RecoverablePane alpha beta delta => alpha -> delta Bool -type PaneName = String+type PaneName = Text data IDEPane delta = forall alpha beta. (RecoverablePane alpha beta delta) => PaneC alpha @@ -178,7 +180,7 @@ (<=) (PaneC x) (PaneC y) = paneName x <= paneName y instance Show (IDEPane delta) where- show (PaneC x) = "Pane " ++ paneName x+ show (PaneC x) = show $ "Pane " <> paneName x type StandardPath = PanePath
src/Graphics/UI/Frame/ViewFrame.hs view
@@ -6,6 +6,8 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Core.ViewFrame@@ -98,6 +100,7 @@ import Data.Maybe import Data.Unique import Data.Typeable+import Data.Text (Text) import Graphics.UI.Frame.Panes import Graphics.UI.Editor.Parameters@@ -109,11 +112,11 @@ import Graphics.UI.Gtk.General.CssProvider (cssProviderNew, cssProviderLoadFromString) import Graphics.UI.Gtk.General.StyleContext (styleContextAddProvider) #endif-import MyMissing+import MyMissing (forceJust, forceHead) import Graphics.UI.Gtk.Gdk.EventM (TimeStamp(..)) import Graphics.UI.Editor.MakeEditor (mkField, FieldDescription(..), buildEditor)-import Graphics.UI.Editor.Simple (stringEditor, okCancelFields)+import Graphics.UI.Editor.Simple (stringEditor, textEditor, okCancelFields) import Control.Event (registerEvent) import Graphics.UI.Editor.Basics (eventText, GUIEventSelector(..))@@ -124,14 +127,16 @@ import Control.Monad (when, liftM, foldM) import Control.Applicative ((<$>)) import qualified Control.Monad.Reader as Gtk (liftIO)+import qualified Data.Text as T (pack, stripPrefix, unpack)+import Data.Monoid ((<>)) --import Debug.Trace (trace)-trace a b = b+trace (a::Text) b = b groupPrefix = "_group_" -withoutGroupPrefix :: String -> String-withoutGroupPrefix s = case groupPrefix `stripPrefix` s of+withoutGroupPrefix :: Text -> Text+withoutGroupPrefix s = case groupPrefix `T.stripPrefix` s of Nothing -> s Just s' -> s' @@ -178,7 +183,7 @@ setPanesSt (Map.insert (paneName pane) (PaneC pane) panes') return True else do- trace ("ViewFrame>addPaneAdmin:pane with this name already exist" ++ paneName pane) $+ trace ("ViewFrame>addPaneAdmin:pane with this name already exist" <> paneName pane) $ return False getPanePrim :: RecoverablePane alpha beta delta => delta (Maybe alpha)@@ -198,12 +203,12 @@ notebookInsertOrdered :: PaneMonad alpha => (NotebookClass self, WidgetClass child) => self -> child -- child - the Widget to use as the contents of the page.- -> String- -> Maybe Label -- the label for the page as String or Label+ -> Text+ -> Maybe Label -- the label for the page as Text or Label -> Bool -> alpha () notebookInsertOrdered nb widget labelStr mbLabel isGroup = do- label <- case mbLabel of+ label <- case mbLabel of Nothing -> liftIO $ labelNew (Just labelStr) Just l -> return l menuLabel <- liftIO $ labelNew (Just labelStr)@@ -222,7 +227,7 @@ notebookSetCurrentPage nb realPos -- | Returns a label box-mkLabelBox :: PaneMonad alpha => Label -> String -> alpha EventBox+mkLabelBox :: PaneMonad alpha => Label -> Text -> alpha EventBox mkLabelBox lbl paneName = do (tb,lb) <- liftIO $ do miscSetAlignment (castToMisc lbl) 0.0 0.0@@ -233,36 +238,36 @@ innerBox <- hBoxNew False 0 tabButton <- buttonNew- widgetSetName tabButton "leksah-close-button"+ widgetSetName tabButton ("leksah-close-button"::Text) buttonSetFocusOnClick tabButton False buttonSetRelief tabButton ReliefNone buttonSetAlignment tabButton (0.0,0.0) iconTheme <- iconThemeGetDefault- mbIcon <- iconThemeLoadIcon iconTheme "window-close" 10 IconLookupUseBuiltin+ mbIcon <- iconThemeLoadIcon iconTheme ("window-close"::Text) 10 IconLookupUseBuiltin image <- case mbIcon of Just i -> imageNewFromPixbuf i Nothing -> imageNewFromStock stockClose IconSizeMenu #ifdef MIN_VERSION_gtk3 provider <- cssProviderNew- cssProviderLoadFromString provider $- ".button {\n" ++- "-GtkButton-default-border : 0px;\n" ++- "-GtkButton-default-outside-border : 0px;\n" ++- "-GtkButton-inner-border: 0px;\n" ++- "-GtkWidget-focus-line-width : 0px;\n" ++- "-GtkWidget-focus-padding : 0px;\n" ++- "padding: 0px;\n" ++- "}"+ cssProviderLoadFromString provider (+ ".button {\n" <>+ "-GtkButton-default-border : 0px;\n" <>+ "-GtkButton-default-outside-border : 0px;\n" <>+ "-GtkButton-inner-border: 0px;\n" <>+ "-GtkWidget-focus-line-width : 0px;\n" <>+ "-GtkWidget-focus-padding : 0px;\n" <>+ "padding: 2px;\n" <>+ "}" :: Text) context <- widgetGetStyleContext tabButton styleContextAddProvider context provider 600 #endif containerSetBorderWidth tabButton 0 containerAdd tabButton image - boxPackStart innerBox lbl PackNatural 0- boxPackEnd innerBox tabButton PackNatural 0+ boxPackStart innerBox tabButton PackNatural 0+ boxPackStart innerBox lbl PackGrow 0 containerAdd labelBox innerBox dragSourceSet labelBox [Button1] [ActionCopy,ActionMove]@@ -279,7 +284,7 @@ return lb where closeHandler :: PaneMonad alpha => () -> alpha ()- closeHandler _ = case groupPrefix `stripPrefix` paneName of+ closeHandler _ = case groupPrefix `T.stripPrefix` paneName of Just group -> do closeGroup group Nothing -> do@@ -287,12 +292,12 @@ closePane pane return () -groupLabel :: PaneMonad beta => String -> beta EventBox+groupLabel :: PaneMonad beta => Text -> beta EventBox groupLabel group = do- label <- liftIO $ labelNew Nothing+ label <- liftIO $ labelNew (Nothing::Maybe Text) liftIO $ labelSetUseMarkup label True- liftIO $ labelSetMarkup label ("<b>" ++ group ++ "</b>")- labelBox <- mkLabelBox label (groupPrefix ++ group)+ liftIO $ labelSetMarkup label ("<b>" <> group <> "</b>")+ labelBox <- mkLabelBox label (groupPrefix <> group) liftIO $ widgetShowAll labelBox return labelBox @@ -308,16 +313,16 @@ Nothing -> return () Just container -> do children <- containerGetChildren container- let label = castToLabel $ forceHead children "ViewFrame>>markLabel: empty children"- text <- widgetGetName topWidget+ let label = castToLabel $ forceHead (tail children) "ViewFrame>>markLabel: empty children"+ (text :: Text) <- widgetGetName topWidget labelSetUseMarkup (castToLabel label) True labelSetMarkup (castToLabel label) (if modified- then "<span foreground=\"red\">" ++ text ++ "</span>"+ then "<span foreground=\"red\">" <> text <> "</span>" else text) -- | Constructs a unique pane name, which is an index and a string-figureOutPaneName :: PaneMonad alpha => String -> Int -> alpha (Int,String)+figureOutPaneName :: PaneMonad alpha => Text -> Int -> alpha (Int,Text) figureOutPaneName bn ind = do bufs <- getPanesSt let ind = foldr (\(PaneC buf) ind ->@@ -327,14 +332,14 @@ 0 (Map.elems bufs) if ind == 0 then return (0,bn)- else return (ind,bn ++ "(" ++ show ind ++ ")")+ else return (ind,bn <> "(" <> T.pack (show ind) <> ")") paneFromName :: PaneMonad alpha => PaneName -> alpha (IDEPane alpha) paneFromName pn = do mbPane <- mbPaneFromName pn case mbPane of Just p -> return p- Nothing -> error $ "ViewFrame>>paneFromName:Can't find pane from unique name " ++ pn+ Nothing -> error $ "ViewFrame>>paneFromName:Can't find pane from unique name " ++ T.unpack pn mbPaneFromName :: PaneMonad alpha => PaneName -> alpha (Maybe (IDEPane alpha)) mbPaneFromName pn = do@@ -347,15 +352,15 @@ paneMap <- getPaneMapSt case Map.lookup pn paneMap of Just it -> return it- otherwise -> error $"Cant't find guiProperties from unique name " ++ pn+ otherwise -> error $"Cant't find guiProperties from unique name " ++ T.unpack pn posTypeToPaneDirection PosLeft = LeftP-posTypeToPaneDirection PosRight = RightP +posTypeToPaneDirection PosRight = RightP posTypeToPaneDirection PosTop = TopP-posTypeToPaneDirection PosBottom = BottomP +posTypeToPaneDirection PosBottom = BottomP paneDirectionToPosType LeftP = PosLeft-paneDirectionToPosType RightP = PosRight +paneDirectionToPosType RightP = PosRight paneDirectionToPosType TopP = PosTop paneDirectionToPosType BottomP = PosBottom @@ -440,15 +445,15 @@ return (castToPaned h) Vertical -> do v <- hPanedNew return (castToPaned v)- rName <- widgetGetName activeNotebook+ rName::Text <- widgetGetName activeNotebook widgetSetName newpane rName- widgetSetName nb altname+ widgetSetName nb (altname :: Text) panedPack2 newpane nb True True nbIndex <- if parent `isA` gTypeNotebook then notebookPageNum ((castToNotebook' "viewSplit'1") parent) activeNotebook else trace ("ViewFrame>>viewSplit': parent not a notebook: ") return Nothing containerRemove (castToContainer parent) activeNotebook- widgetSetName activeNotebook name+ widgetSetName activeNotebook (name :: Text) panedPack1 newpane activeNotebook True True return (newpane,nbIndex) case (reverse panePath, nbi) of@@ -537,7 +542,7 @@ $Map.toList paneMap panesToMove <- mapM paneFromName paneNamesToMove mapM_ (\(PaneC p) -> move panePath p) panesToMove- let groupNames = map (\n -> groupPrefix ++ n) $+ let groupNames = map (\n -> groupPrefix <> n) $ getGroupsFrom otherSidePath layout1 mapM_ (\n -> move' (n,activeNotebook)) groupNames -- 2. Remove unused notebook from admin@@ -578,7 +583,7 @@ else liftIO $ do boxPackStart (castToVBox grandparent) activeNotebook PackGrow 0 boxReorderChild (castToVBox grandparent) activeNotebook 2- widgetSetName activeNotebook "root"+ widgetSetName activeNotebook ("root" :: Text) -- 4. Change panePathFromNotebook adjustNotebooks panePath newPanePath -- 5. Change paneMap@@ -586,7 +591,7 @@ -- 6. Change layout adjustLayoutForCollapse panePath -getGroupsFrom :: PanePath -> PaneLayout -> [String]+getGroupsFrom :: PanePath -> PaneLayout -> [Text] getGroupsFrom path layout = case layoutFromPath path layout of t@(TerminalP _ _ _ _ _) -> Map.keys (paneGroups t)@@ -604,14 +609,14 @@ if groupName `Set.member` allGroupNames layout then liftIO $ do md <- messageDialogNew (Just mainWindow) [] MessageWarning ButtonsClose- ("Group name not unique " ++ groupName)+ ("Group name not unique " <> groupName) dialogRun md widgetDestroy md return () else viewNest groupName Nothing -> return () -newGroupOrBringToFront :: PaneMonad alpha => String -> PanePath -> alpha (Maybe PanePath,Bool)+newGroupOrBringToFront :: PaneMonad alpha => Text -> PanePath -> alpha (Maybe PanePath,Bool) newGroupOrBringToFront groupName pp = do layout <- getLayoutSt if groupName `Set.member` allGroupNames layout@@ -622,7 +627,7 @@ viewNest' realPath groupName return (Just (realPath ++ [GroupP groupName]),True) -bringGroupToFront :: PaneMonad alpha => String -> alpha (Maybe PanePath)+bringGroupToFront :: PaneMonad alpha => Text -> alpha (Maybe PanePath) bringGroupToFront groupName = do layout <- getLayoutSt case findGroupPath groupName layout of@@ -635,11 +640,11 @@ -- Yet another stupid little dialog -groupNameDialog :: Window -> IO (Maybe String)+groupNameDialog :: Window -> IO (Maybe Text) groupNameDialog parent = liftIO $ do dia <- dialogNew set dia [ windowTransientFor := parent- , windowTitle := "Enter group name" ]+ , windowTitle := ("Enter group name" :: Text) ] #ifdef MIN_VERSION_gtk3 upper <- castToVBox <$> dialogGetContentArea dia #else@@ -656,23 +661,23 @@ boxPackStart upper widget PackGrow 7 boxPackStart lower widget2 PackNatural 7 widgetShowAll dia- resp <- dialogRun dia- value <- ext ("")+ resp <- dialogRun dia+ value <- ext ("") widgetDestroy dia case resp of- ResponseOk | value /= Just "" -> return value+ ResponseOk | value /= Just "" -> return value _ -> return Nothing where- moduleFields :: FieldDescription String+ moduleFields :: FieldDescription Text moduleFields = VFD emptyParams [ mkField (paraName <<<- ParaName ("New group ") $ emptyParams) id (\ a b -> a)- (stringEditor (const True) True)]+ (textEditor (const True) True)] -viewNest :: PaneMonad alpha => String -> alpha ()+viewNest :: PaneMonad alpha => Text -> alpha () viewNest group = do mbPanePath <- getActivePanePath case mbPanePath of@@ -680,7 +685,7 @@ Just panePath -> do viewNest' panePath group -viewNest' :: PaneMonad alpha => PanePath -> String -> alpha ()+viewNest' :: PaneMonad alpha => PanePath -> Text -> alpha () viewNest' panePath group = do activeNotebook <- (getNotebook' "viewNest' 1") panePath mbParent <- liftIO $ widgetGetParent activeNotebook@@ -692,7 +697,7 @@ case paneLayout of (TerminalP {}) -> do nb <- newNotebook (panePath ++ [GroupP group])- liftIO $ widgetSetName nb (groupPrefix ++ group)+ liftIO $ widgetSetName nb (groupPrefix <> group) notebookInsertOrdered activeNotebook nb group Nothing True liftIO $ widgetShowAll nb --widgetGrabFocus activeNotebook@@ -701,13 +706,13 @@ adjustLayoutForNest group panePath _ -> return () -closeGroup :: PaneMonad alpha => String -> alpha ()+closeGroup :: PaneMonad alpha => Text -> alpha () closeGroup groupName = do layout <- getLayout let mbPath = findGroupPath groupName layout mainWindow <- getMainWindow case mbPath of- Nothing -> trace ("ViewFrame>>closeGroup: Group path not found: " ++ groupName) return ()+ Nothing -> trace ("ViewFrame>>closeGroup: Group path not found: " <> groupName) return () Just path -> do panesMap <- getPaneMapSt let nameAndpathList = filter (\(a,pp) -> path `isPrefixOf` pp)@@ -715,7 +720,7 @@ continue <- case nameAndpathList of (_:_) -> liftIO $ do md <- messageDialogNew (Just mainWindow) [] MessageQuestion ButtonsYesNo- ("Group " ++ groupName ++ " not empty. Close with all contents?")+ ("Group " <> groupName <> " not empty. Close with all contents?") rid <- dialogRun md widgetDestroy md case rid of@@ -742,9 +747,9 @@ case mbPanePath of Nothing -> return Nothing Just panePath -> do- viewDetach' panePath id+ viewDetach' panePath (T.pack id) -viewDetach' :: PaneMonad alpha => PanePath -> String -> alpha (Maybe (Window,Widget))+viewDetach' :: PaneMonad alpha => PanePath -> Text -> alpha (Maybe (Window,Widget)) viewDetach' panePath id = do activeNotebook <- (getNotebook' "viewDetach'") panePath mbParent <- liftIO $ widgetGetParent activeNotebook@@ -757,7 +762,7 @@ (TerminalP{detachedSize = size}) -> do window <- liftIO $ do window <- windowNew- set window [ windowTitle := "Leksah detached window"+ set window [ windowTitle := ("Leksah detached window" :: Text) , widgetName := Just id ] case size of Just (width, height) -> do@@ -779,11 +784,11 @@ -handleReattach :: PaneMonad alpha => String -> Window -> () -> alpha Bool+handleReattach :: PaneMonad alpha => Text -> Window -> () -> alpha Bool handleReattach windowId window _ = do layout <- getLayout case findDetachedPath windowId layout of- Nothing -> trace ("ViewFrame>>handleReattach: panePath for id not found: " ++ windowId)+ Nothing -> trace ("ViewFrame>>handleReattach: panePath for id not found: " <> windowId) $ do windows <- getWindowsSt setWindowsSt $ delete window windows@@ -823,7 +828,7 @@ Nothing -> return Nothing Just window -> liftIO $ Just <$> windowGetScreen window -groupMenuLabel :: PaneMonad beta => String -> beta (Maybe Label)+groupMenuLabel :: PaneMonad beta => Text -> beta (Maybe Label) groupMenuLabel group = liftM Just (liftIO $ labelNew (Just group)) handleNotebookSwitch :: PaneMonad beta => Notebook -> Int -> beta ()@@ -838,7 +843,7 @@ Nothing -> return () Just (PaneC p) -> makeActive p where- findPaneFor :: PaneMonad beta => String -> beta (Maybe (IDEPane beta))+ findPaneFor :: PaneMonad beta => Text -> beta (Maybe (IDEPane beta)) findPaneFor n1 = do panes' <- getPanesSt foldM (\r (PaneC p) -> do@@ -907,10 +912,10 @@ panes <- getPanesSt layout <- getLayout frameState <- getFrameState- case groupPrefix `stripPrefix` paneName of+ case groupPrefix `T.stripPrefix` paneName of Just group -> do case findGroupPath group layout of- Nothing -> trace ("ViewFrame>>move': group not found: " ++ group) return ()+ Nothing -> trace ("ViewFrame>>move': group not found: " <> group) return () Just fromPath -> do groupNBOrPaned <- getNotebookOrPaned fromPath castToWidget fromNB <- (getNotebook' "move'") (init fromPath)@@ -933,13 +938,13 @@ return () Nothing -> case paneName `Map.lookup` panes of- Nothing -> trace ("ViewFrame>>move': pane not found: " ++ paneName) return ()+ Nothing -> trace ("ViewFrame>>move': pane not found: " <> paneName) return () Just (PaneC pane) -> do case toNB `Map.lookup` (panePathFromNB frameState) of Nothing -> trace "ViewFrame>>move': panepath for Notebook not found2" return () Just toPath -> case paneName `Map.lookup`paneMap of- Nothing -> trace ("ViewFrame>>move': pane data not found: " ++ paneName)+ Nothing -> trace ("ViewFrame>>move': pane data not found: " <> paneName) return () Just (fromPath,_) -> do let child = getTopWidget pane@@ -1014,7 +1019,7 @@ -- -- | Get a standard path. ---getBestPathForId :: PaneMonad alpha => String -> alpha PanePath+getBestPathForId :: PaneMonad alpha => Text -> alpha PanePath getBestPathForId id = do p <- panePathForGroup id l <- getLayout@@ -1076,30 +1081,30 @@ ++ terminalsWithPP (SplitP BottomP : pp) b terminalsFromGroup pp (name,layout) = terminalsWithPP (GroupP name : pp) layout -findGroupPath :: String -> PaneLayout -> Maybe PanePath+findGroupPath :: Text -> PaneLayout -> Maybe PanePath findGroupPath group layout = let terminalPairs = terminalsWithPanePath layout in case (filter filterFunc terminalPairs) of [] -> Nothing (pp,_) : [] -> Just (pp ++ [GroupP group])- _ -> error ("ViewFrame>>group name not unique: " ++ group)+ _ -> error ("ViewFrame>>group name not unique: " ++ T.unpack group) where filterFunc (_,(TerminalP groups _ _ _ _)) = group `Set.member` Map.keysSet groups filterFunc _ = error "ViewFrame>>findGroupPath: impossible" -findDetachedPath :: String -> PaneLayout -> Maybe PanePath+findDetachedPath :: Text -> PaneLayout -> Maybe PanePath findDetachedPath id layout = let terminalPairs = terminalsWithPanePath layout in case (filter filterFunc terminalPairs) of [] -> Nothing (pp,_) : [] -> Just pp- _ -> error ("ViewFrame>>window id not unique: " ++ id)+ _ -> error ("ViewFrame>>window id not unique: " ++ T.unpack id) where filterFunc (_,(TerminalP _ _ _ (Just lid) _)) = lid == id filterFunc _ = False -allGroupNames :: PaneLayout -> Set String+allGroupNames :: PaneLayout -> Set Text allGroupNames pl = Set.unions $ map getFunc (terminalsWithPanePath pl) where getFunc (_,(TerminalP groups _ _ _ _)) = Map.keysSet groups@@ -1151,7 +1156,7 @@ layoutsFromPath pp l = error $"inconsistent layout (layoutsFromPath) " ++ show pp ++ " " ++ show l -getWidgetNameList :: PanePath -> PaneLayout -> [String]+getWidgetNameList :: PanePath -> PaneLayout -> [Text] getWidgetNameList path layout = reverse $ nameList (reverse path) (reverse $ layoutsFromPath path layout) where nameList [] _ = reverse ["Leksah Main Window","topBox","root"]@@ -1168,10 +1173,10 @@ -- | Get the notebook widget for the given pane path -- getNotebook :: PaneMonad alpha => PanePath -> alpha Notebook-getNotebook p = getNotebookOrPaned p (castToNotebook' ("getNotebook " ++ show p))+getNotebook p = getNotebookOrPaned p (castToNotebook' ("getNotebook " <> T.pack (show p))) -getNotebook' :: PaneMonad alpha => String -> PanePath -> alpha Notebook-getNotebook' str p = getNotebookOrPaned p (castToNotebook' ("getNotebook' " ++ str ++ " " ++ show p))+getNotebook' :: PaneMonad alpha => Text -> PanePath -> alpha Notebook+getNotebook' str p = getNotebookOrPaned p (castToNotebook' ("getNotebook' " <> str <> " " <> T.pack (show p))) --@@ -1217,15 +1222,15 @@ -- -- | Translates a pane direction to the widget name ---paneDirectionToWidgetName :: PaneDirection -> String+paneDirectionToWidgetName :: PaneDirection -> Text paneDirectionToWidgetName TopP = "top" paneDirectionToWidgetName BottomP = "bottom" paneDirectionToWidgetName LeftP = "left" paneDirectionToWidgetName RightP = "right" -panePathElementToWidgetName :: PanePathElement -> String+panePathElementToWidgetName :: PanePathElement -> Text panePathElementToWidgetName (SplitP dir) = paneDirectionToWidgetName dir-panePathElementToWidgetName (GroupP group) = groupPrefix ++ group+panePathElementToWidgetName (GroupP group) = groupPrefix <> group -- -- | Changes a pane path in the pane map@@ -1240,7 +1245,7 @@ adjustNotebooks :: PaneMonad alpha => PanePath -> PanePath -> alpha () adjustNotebooks fromPane toPane = do- npMap <- trace ("+++ adjustNotebooks from: " ++ show fromPane ++ " to " ++ show toPane)+ npMap <- trace ("+++ adjustNotebooks from: " <> T.pack (show fromPane) <> " to " <> T.pack (show toPane)) getPanePathFromNB setPanePathFromNB (Map.map (\pp -> case stripPrefix fromPane pp of@@ -1265,7 +1270,7 @@ -- -- | Changes the layout for a nest ---adjustLayoutForNest :: PaneMonad alpha => String -> PanePath -> alpha ()+adjustLayoutForNest :: PaneMonad alpha => Text -> PanePath -> alpha () adjustLayoutForNest group path = do layout <- getLayoutSt let paneLayout = layoutFromPath path layout@@ -1278,7 +1283,7 @@ -- -- | Changes the layout for a detach ---adjustLayoutForDetach :: PaneMonad alpha => String -> PanePath -> alpha ()+adjustLayoutForDetach :: PaneMonad alpha => Text -> PanePath -> alpha () adjustLayoutForDetach id path = do layout <- getLayoutSt let paneLayout = layoutFromPath path layout@@ -1311,7 +1316,7 @@ -- -- | Changes the layout for a move ---adjustLayoutForGroupMove :: PaneMonad alpha => PanePath -> PanePath -> String -> alpha ()+adjustLayoutForGroupMove :: PaneMonad alpha => PanePath -> PanePath -> Text -> alpha () adjustLayoutForGroupMove fromPath toPath group = do layout <- getLayout let layoutToMove = layoutFromPath fromPath layout@@ -1321,7 +1326,7 @@ -- -- | Changes the layout for a remove ---adjustLayoutForGroupRemove :: PaneMonad alpha => PanePath -> String -> alpha ()+adjustLayoutForGroupRemove :: PaneMonad alpha => PanePath -> Text -> alpha () adjustLayoutForGroupRemove fromPath group = do layout <- getLayout setLayoutSt (removeGL fromPath layout)@@ -1373,13 +1378,13 @@ -- -- | Get the widget from a list of strings ---widgetFromPath :: Widget -> [String] -> IO (Widget)+widgetFromPath :: Widget -> [Text] -> IO (Widget) widgetFromPath w [] = return w widgetFromPath w path = do children <- containerGetChildren (castToContainer w) chooseWidgetFromPath children path -chooseWidgetFromPath :: [Widget] -> [String] -> IO (Widget)+chooseWidgetFromPath :: [Widget] -> [Text] -> IO (Widget) chooseWidgetFromPath _ [] = error $"Cant't find widget (empty path)" chooseWidgetFromPath widgets (h:t) = do names <- mapM widgetGetName widgets@@ -1388,25 +1393,25 @@ Nothing -> error $"Cant't find widget path " ++ show (h:t) ++ " found only " ++ show names Just ind -> widgetFromPath (widgets !! ind) t -widgetGet :: PaneMonad alpha => [String] -> (Widget -> b) -> alpha (b)+widgetGet :: PaneMonad alpha => [Text] -> (Widget -> b) -> alpha (b) widgetGet strL cf = do windows <- getWindowsSt r <- liftIO $chooseWidgetFromPath (map castToWidget windows) strL return (cf r) -widgetGetRel :: Widget -> [String] -> (Widget -> b) -> IO (b)+widgetGetRel :: Widget -> [Text] -> (Widget -> b) -> IO (b) widgetGetRel w sl cf = do r <- widgetFromPath w sl return (cf r) -getUIAction :: PaneMonad alpha => String -> (Action -> a) -> alpha (a)+getUIAction :: PaneMonad alpha => Text -> (Action -> a) -> alpha (a) getUIAction str f = do uiManager <- getUiManagerSt liftIO $ do findAction <- uiManagerGetAction uiManager str case findAction of Just act -> return (f act)- Nothing -> error $"getUIAction can't find action " ++ str+ Nothing -> error $"getUIAction can't find action " ++ T.unpack str getThis :: PaneMonad delta => (FrameState delta -> alpha) -> delta alpha getThis sel = do@@ -1415,7 +1420,7 @@ setThis :: PaneMonad delta => (FrameState delta -> alpha -> FrameState delta) -> alpha -> delta () setThis sel value = do st <- getFrameState- trace ("!!! setFrameState " ++ show (sel st value)) $ setFrameState (sel st value)+ trace ("!!! setFrameState " <> T.pack (show $ sel st value)) $ setFrameState (sel st value) getWindowsSt = getThis windows setWindowsSt = setThis (\st value -> st{windows = value})@@ -1438,8 +1443,8 @@ getMainWindow = liftM head getWindows getLayout = getLayoutSt -castToNotebook' :: GObjectClass obj => String -> obj -> Notebook+castToNotebook' :: GObjectClass obj => Text -> obj -> Notebook castToNotebook' str obj = if obj `isA` gTypeNotebook then castToNotebook obj- else error ("Not a notebook " ++ str)+ else error . T.unpack $ "Not a notebook " <> str
src/MyMissing.hs view
@@ -18,21 +18,15 @@ , forceJust , forceHead , split-, replace , nonEmptyLines-, trim ) where +import Data.Text (Text)+import qualified Data.Text as T (unpack) import Data.List (find,unfoldr) import Data.Maybe (isJust) import Data.Char (isSpace) ---- | remove leading and trailing spaces-trim :: String -> String-trim = f . f- where f = reverse . dropWhile isSpace- nonEmptyLines :: String -> [String] nonEmptyLines = filter (\line -> isJust $ find (not . isSpace) line) . lines @@ -43,17 +37,17 @@ -- --------------------------------------------------------------------- -- Convenience methods with error handling ---forceJust :: Maybe alpha -> String -> alpha+forceJust :: Maybe alpha -> Text -> alpha forceJust mb str = case mb of- Nothing -> error str+ Nothing -> error (T.unpack str) Just it -> it -- --------------------------------------------------------------------- -- Convenience methods with error handling ---forceHead :: [alpha] -> String -> alpha+forceHead :: [alpha] -> Text -> alpha forceHead (h:_) str = h-forceHead [] str = error str+forceHead [] str = error (T.unpack str) -- ---------------------------------------------------------------------@@ -69,14 +63,3 @@ | otherwise = Just (h, drop 1 t) where (h, t) = span (/=c) l --- ------------------------------------------------------------------------ Simple replacement-----replace :: Eq a => [a] -> [a] -> [a] -> [a]-replace _ _ [] = []-replace from to xs@(a:as) =- if isPrefixOf from xs- then to ++ replace from to (drop (length from) xs)- else a : replace from to as- where isPrefixOf as bs = and $ zipWith (== ) as bs
src/Text/PrinterParser.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables, OverloadedStrings #-} -- -- | Module for saving and restoring preferences and settings --@@ -45,11 +45,15 @@ import Graphics.UI.Editor.Parameters import Graphics.UI.Editor.Basics import Data.Maybe (listToMaybe)+import Data.Monoid ((<>)) import Graphics.UI.Gtk (Color(..)) import Data.List (foldl') import qualified Text.ParserCombinators.Parsec as P ((<?>), CharParser(..), parseFromFile) import Control.Exception as E (catch, IOException)+import qualified Data.Text as T (pack, unpack)+import Data.Text (Text)+import Control.Applicative ((<$>)) type Printer beta = beta -> PP.Doc@@ -77,12 +81,12 @@ mkFieldS parameter printer parser getter setter = FDS parameter (\ dat -> (PP.text (case getParameterPrim paraName parameter of- Nothing -> ""- Just str -> str) PP.<> PP.colon)+ Nothing -> ""+ Just str -> T.unpack $ str) PP.<> PP.colon) PP.$$ (PP.nest 15 (printer (getter dat))) PP.$$ (PP.nest 5 (case getParameterPrim paraSynopsis parameter of Nothing -> PP.empty- Just str -> PP.text $"--" ++ str)))+ Just str -> PP.text . T.unpack $ "--" <> str))) (\ dat -> try (do symbol (case getParameterPrim paraName parameter of Nothing -> ""@@ -134,18 +138,18 @@ return (v1,v2) <?> "pair parser" -stringParser :: CharParser () String+stringParser :: CharParser () Text stringParser = do char '"' str <- many (noneOf ['"']) char '"'- return (str)+ return (T.pack str) <?> "string parser" -lineParser :: CharParser () String+lineParser :: CharParser () Text lineParser = do str <- many (noneOf ['\n'])- return (str)+ return (T.pack str) <?> "line parser" @@ -181,12 +185,12 @@ whiteSpace :: CharParser st () whiteSpace = P.whiteSpace lexer -symbol :: String -> CharParser st String-symbol = P.symbol lexer+symbol :: Text -> CharParser st Text+symbol = (T.pack <$>) . P.symbol lexer . T.unpack -identifier, colon :: CharParser st String-identifier = P.identifier lexer-colon = P.colon lexer+identifier, colon :: CharParser st Text+identifier = T.pack <$> P.identifier lexer+colon = T.pack <$> P.colon lexer integer = P.integer lexer @@ -194,8 +198,8 @@ -- * Printing -- ------------------------------------------------------------ -- | pretty-print with the default style and 'defaultMode'.-prettyPrint :: Pretty a => a -> String-prettyPrint a = PP.renderStyle PP.style (pretty a)+prettyPrint :: Pretty a => a -> Text+prettyPrint a = T.pack $ PP.renderStyle PP.style (pretty a) -- | Things that can be pretty-printed class Pretty a where@@ -213,18 +217,18 @@ maybePP _ Nothing = PP.empty maybePP pp (Just a) = pp a -instance Pretty String where- pretty str = PP.text str+instance Pretty Text where+ pretty str = PP.text $ T.unpack str -- ------------------------------------------------------------ -- * Read and write -- ------------------------------------------------------------ writeFields :: FilePath -> alpha -> [FieldDescriptionS alpha] -> IO ()-writeFields fpath date dateDesc = writeFile fpath (showFields date dateDesc)+writeFields fpath date dateDesc = writeFile fpath (T.unpack $ showFields date dateDesc) -showFields :: alpha -> [FieldDescriptionS alpha] -> String-showFields date dateDesc = PP.render $+showFields :: alpha -> [FieldDescriptionS alpha] -> Text+showFields date dateDesc = T.pack . PP.render $ foldl' (\ doc (FDS _ printer _) -> doc PP.$+$ printer date) PP.empty dateDesc readFields :: FilePath -> [FieldDescriptionS alpha] -> alpha -> IO alpha