InputT.hs 8.62 KB
Newer Older
judah's avatar
judah committed
1
module System.Console.Haskeline.InputT where
2
3


4
import System.Console.Haskeline.History
5
import System.Console.Haskeline.Command.History
6
import System.Console.Haskeline.Command.Undo
7
import System.Console.Haskeline.Command.KillRing
8
import System.Console.Haskeline.Monads as Monads
9
10
import System.Console.Haskeline.Prefs
import System.Console.Haskeline.Completion
judah's avatar
judah committed
11
12
import System.Console.Haskeline.Backend
import System.Console.Haskeline.Term
13
14
15

import System.Directory(getHomeDirectory)
import System.FilePath
16
import Control.Applicative
17
import Control.Monad (liftM, ap)
Alexander Vieth's avatar
Alexander Vieth committed
18
import Control.Monad.Fix
19
import System.IO
20
import Data.IORef
21

22
-- | Application-specific customizations to the user interface.
23
24
25
26
27
28
data Settings m = Settings {complete :: CompletionFunc m, -- ^ Custom tab completion.
                            historyFile :: Maybe FilePath, -- ^ Where to read/write the history at the
                                                        -- start and end of each
                                                        -- line input session.
                            autoAddHistory :: Bool -- ^ If 'True', each nonblank line returned by
                                -- @getInputLine@ will be automatically added to the history.
29

30
31
32
33
                            }

-- | Because 'complete' is the only field of 'Settings' depending on @m@,
-- the expression @defaultSettings {completionFunc = f}@ leads to a type error
judah's avatar
judah committed
34
-- from being too general.  This function works around that issue, and may become unnecessary if another field
35
36
37
38
39
40
-- depending on @m@ is added.

setComplete :: CompletionFunc m -> Settings m -> Settings m
setComplete f s = s {complete = f}


41
42
-- | A monad transformer which carries all of the state and settings
-- relevant to a line-reading application.
43
44
45
46
47
48
49
newtype InputT m a = InputT {unInputT :: 
                                ReaderT RunTerm
                                -- Use ReaderT (IO _) vs StateT so that exceptions (e.g., ctrl-c)
                                -- don't cause us to lose the existing state.
                                (ReaderT (IORef History)
                                (ReaderT (IORef KillRing)
                                (ReaderT Prefs
50
                                (ReaderT (Settings m) m)))) a}
51
                            deriving (Functor, Applicative, Monad, MonadIO, MonadException)
52
53
54
55
                -- NOTE: we're explicitly *not* making InputT an instance of our
                -- internal MonadState/MonadReader classes.  Otherwise haddock
                -- displays those instances to the user, and it makes it seem like
                -- we implement the mtl versions of those classes.
judah's avatar
judah committed
56

judah's avatar
judah committed
57
instance MonadTrans InputT where
58
    lift = InputT . lift . lift . lift . lift . lift
59

Alexander Vieth's avatar
Alexander Vieth committed
60
61
62
instance ( MonadFix m ) => MonadFix (InputT m) where
    mfix f = InputT (mfix (unInputT . f))

63
-- | Get the current line input history.
64
getHistory :: MonadIO m => InputT m History
65
getHistory = InputT get
66
67

-- | Set the line input history.
68
putHistory :: MonadIO m => History -> InputT m ()
69
putHistory = InputT . put
70
71

-- | Change the current line input history.
72
modifyHistory :: MonadIO m => (History -> History) -> InputT m ()
73
modifyHistory = InputT . modify
74

judah's avatar
judah committed
75
-- for internal use only
76
77
78
type InputCmdT m = StateT Layout (UndoT (StateT HistLog (ReaderT (IORef KillRing)
                        -- HistLog can be just StateT, since its final state
                        -- isn't used outside of InputCmdT.
79
                (ReaderT Prefs (ReaderT (Settings m) m)))))
80

81
runInputCmdT :: MonadIO m => TermOps -> InputCmdT m a -> InputT m a
82
runInputCmdT tops f = InputT $ do
83
    layout <- liftIO $ getLayout tops
84
85
    history <- get
    lift $ lift $ evalStateT' (histLog history) $ runUndoT $ evalStateT' layout f
86

87
instance MonadException m => CommandMonad (InputCmdT m) where
judah's avatar
judah committed
88
89
90
    runCompletion lcs = do
        settings <- ask
        lift $ lift $ lift $ lift $ lift $ lift $ complete settings lcs
91

judah's avatar
judah committed
92
-- | Run a line-reading application.  Uses 'defaultBehavior' to determine the
93
-- interaction behavior.
judah's avatar
judah committed
94
runInputTWithPrefs :: MonadException m => Prefs -> Settings m -> InputT m a -> m a
judah's avatar
judah committed
95
runInputTWithPrefs = runInputTBehaviorWithPrefs defaultBehavior
96
97
98

-- | Run a line-reading application.  This function should suffice for most applications.
--
judah's avatar
judah committed
99
-- This function is equivalent to @'runInputTBehavior' 'defaultBehavior'@.  It 
100
101
-- uses terminal-style interaction if 'stdin' is connected to a terminal and has
-- echoing enabled.  Otherwise (e.g., if 'stdin' is a pipe), it uses file-style interaction.
judah's avatar
judah committed
102
103
104
105
--
-- If it uses terminal-style interaction, 'Prefs' will be read from the user's @~/.haskeline@ file
-- (if present).
-- If it uses file-style interaction, 'Prefs' are not relevant and will not be read.
judah's avatar
judah committed
106
runInputT :: MonadException m => Settings m -> InputT m a -> m a
judah's avatar
judah committed
107
runInputT = runInputTBehavior defaultBehavior
108

judah's avatar
judah committed
109
-- | Returns 'True' if the current session uses terminal-style interaction.  (See 'Behavior'.)
110
haveTerminalUI :: Monad m => InputT m Bool
111
haveTerminalUI = InputT $ asks isTerminalStyle
112
113


judah's avatar
judah committed
114
{- | Haskeline has two ways of interacting with the user:
115

judah's avatar
judah committed
116
 * \"Terminal-style\" interaction provides an rich user interface by connecting
117
118
119
   to the user's terminal (which may be different than 'stdin' or 'stdout').  
 
 * \"File-style\" interaction treats the input as a simple stream of characters, for example
120
    when reading from a file or pipe.  Input functions (e.g., @getInputLine@) print the prompt to 'stdout'.
121
 
judah's avatar
judah committed
122
 A 'Behavior' is a method for deciding at run-time which type of interaction to use.  
123
 
judah's avatar
judah committed
124
 For most applications (e.g., a REPL), 'defaultBehavior' should have the correct effect.
125
-}
judah's avatar
judah committed
126
data Behavior = Behavior (IO RunTerm)
127
128
129

-- | Create and use a RunTerm, ensuring that it will be closed even if
-- an async exception occurs during the creation or use.
judah's avatar
judah committed
130
131
withBehavior :: MonadException m => Behavior -> (RunTerm -> m a) -> m a
withBehavior (Behavior run) f = bracket (liftIO run) (liftIO . closeTerm) f
132
133
134

-- | Run a line-reading application according to the given behavior.
--
judah's avatar
judah committed
135
136
137
138
139
-- If it uses terminal-style interaction, 'Prefs' will be read from the
-- user's @~/.haskeline@ file (if present).
-- If it uses file-style interaction, 'Prefs' are not relevant and will not be read.
runInputTBehavior :: MonadException m => Behavior -> Settings m -> InputT m a -> m a
runInputTBehavior behavior settings f = withBehavior behavior $ \run -> do
140
141
142
143
144
145
    prefs <- if isTerminalStyle run
                then liftIO readPrefsFromHome
                else return defaultPrefs
    execInputT prefs settings run f

-- | Run a line-reading application.
judah's avatar
judah committed
146
147
148
149
runInputTBehaviorWithPrefs :: MonadException m
    => Behavior -> Prefs -> Settings m -> InputT m a -> m a
runInputTBehaviorWithPrefs behavior prefs settings f
    = withBehavior behavior $ flip (execInputT prefs settings) f
150
151
152
153
154
155
156
157
158
159

-- | Helper function to feed the parameters into an InputT.
execInputT :: MonadException m => Prefs -> Settings m -> RunTerm
                -> InputT m a -> m a
execInputT prefs settings run (InputT f)
    = runReaderT' settings $ runReaderT' prefs
            $ runKillRing
            $ runHistoryFromFile (historyFile settings) (maxHistorySize prefs)
            $ runReaderT f run

judah's avatar
judah committed
160
161
-- | Map a user interaction by modifying the base monad computation.
mapInputT :: (forall b . m b -> m b) -> InputT m a -> InputT m a
162
mapInputT f = InputT . mapReaderT (mapReaderT (mapReaderT
judah's avatar
judah committed
163
164
                                  (mapReaderT (mapReaderT f))))
                    . unInputT
165
166
167

-- | Read input from 'stdin'.  
-- Use terminal-style interaction if 'stdin' is connected to
judah's avatar
judah committed
168
169
-- a terminal and has echoing enabled.  Otherwise (e.g., if 'stdin' is a pipe), use
-- file-style interaction.
170
--
judah's avatar
judah committed
171
172
173
-- This behavior should suffice for most applications.  
defaultBehavior :: Behavior
defaultBehavior = Behavior defaultRunTerm
174
175

-- | Use file-style interaction, reading input from the given 'Handle'.  
judah's avatar
judah committed
176
177
useFileHandle :: Handle -> Behavior
useFileHandle = Behavior . fileHandleRunTerm
178
179

-- | Use file-style interaction, reading input from the given file.
judah's avatar
judah committed
180
181
useFile :: FilePath -> Behavior
useFile file = Behavior $ do
182
183
184
185
186
187
188
            h <- openBinaryFile file ReadMode
            rt <- fileHandleRunTerm h
            return rt { closeTerm = closeTerm rt >> hClose h}

-- | Use terminal-style interaction whenever possible, even if 'stdin' and/or 'stdout' are not
-- terminals.
--
judah's avatar
judah committed
189
-- If it cannot open the user's terminal, use file-style interaction, reading input from 'stdin'.
judah's avatar
judah committed
190
191
preferTerm :: Behavior
preferTerm = Behavior terminalRunTerm
192

193

judah's avatar
judah committed
194
195
196
-- | Read 'Prefs' from @~/.haskeline.@   If there is an error reading the file,
-- the 'defaultPrefs' will be returned.
readPrefsFromHome :: IO Prefs
197
readPrefsFromHome = handle (\(_::IOException) -> return defaultPrefs) $ do
198
    home <- getHomeDirectory
199
    readPrefs (home </> ".haskeline")
200