diff --git a/ltk.cabal b/ltk.cabal
--- a/ltk.cabal
+++ b/ltk.cabal
@@ -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
diff --git a/src/Default.hs b/src/Default.hs
--- a/src/Default.hs
+++ b/src/Default.hs
@@ -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
diff --git a/src/Graphics/UI/Editor/Basics.hs b/src/Graphics/UI/Editor/Basics.hs
--- a/src/Graphics/UI/Editor/Basics.hs
+++ b/src/Graphics/UI/Editor/Basics.hs
@@ -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)
diff --git a/src/Graphics/UI/Editor/Composite.hs b/src/Graphics/UI/Editor/Composite.hs
--- a/src/Graphics/UI/Editor/Composite.hs
+++ b/src/Graphics/UI/Editor/Composite.hs
@@ -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
diff --git a/src/Graphics/UI/Editor/DescriptionPP.hs b/src/Graphics/UI/Editor/DescriptionPP.hs
--- a/src/Graphics/UI/Editor/DescriptionPP.hs
+++ b/src/Graphics/UI/Editor/DescriptionPP.hs
@@ -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 -> ""
diff --git a/src/Graphics/UI/Editor/MakeEditor.hs b/src/Graphics/UI/Editor/MakeEditor.hs
--- a/src/Graphics/UI/Editor/MakeEditor.hs
+++ b/src/Graphics/UI/Editor/MakeEditor.hs
@@ -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
diff --git a/src/Graphics/UI/Editor/Parameters.hs b/src/Graphics/UI/Editor/Parameters.hs
--- a/src/Graphics/UI/Editor/Parameters.hs
+++ b/src/Graphics/UI/Editor/Parameters.hs
@@ -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
diff --git a/src/Graphics/UI/Editor/Simple.hs b/src/Graphics/UI/Editor/Simple.hs
--- a/src/Graphics/UI/Editor/Simple.hs
+++ b/src/Graphics/UI/Editor/Simple.hs
@@ -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
diff --git a/src/Graphics/UI/Frame/Panes.hs b/src/Graphics/UI/Frame/Panes.hs
--- a/src/Graphics/UI/Frame/Panes.hs
+++ b/src/Graphics/UI/Frame/Panes.hs
@@ -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
diff --git a/src/Graphics/UI/Frame/ViewFrame.hs b/src/Graphics/UI/Frame/ViewFrame.hs
--- a/src/Graphics/UI/Frame/ViewFrame.hs
+++ b/src/Graphics/UI/Frame/ViewFrame.hs
@@ -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 ("" ++ group ++ "")
- labelBox <- mkLabelBox label (groupPrefix ++ group)
+ liftIO $ labelSetMarkup label ("" <> group <> "")
+ 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 "" ++ text ++ ""
+ then "" <> text <> ""
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
diff --git a/src/MyMissing.hs b/src/MyMissing.hs
--- a/src/MyMissing.hs
+++ b/src/MyMissing.hs
@@ -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
diff --git a/src/Text/PrinterParser.hs b/src/Text/PrinterParser.hs
--- a/src/Text/PrinterParser.hs
+++ b/src/Text/PrinterParser.hs
@@ -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