Output/Input

Let me guess...you've read every other guide, tutorial, lesson and introduction and none of them have helped - you still don't understand I/O in Haskell.

Alright then, have a look at this:

data OI                         --  abstract, primitive

partOI  :: OI -> (OI, OI)       -- 
getchar :: OI -> Char           --  primitives 
putchar :: Char -> OI -> ()     -- 

seq     :: a -> b -> b          --  also primitive

instance Partible OI where ...

class Partible a where
    part  :: a -> (a, a)
    parts :: a -> [a]
              .
              .
              .

No up-front explanation; I'm guessing you've seen more than enough of those, so I'm trying something different. I will explain it later...

Yes, of course there's more to Haskell I/O than getchar and putchar; I've downsized it for convenience. If you want, you can add the rest afterwards...

Yes, they're somewhat arcane, but they can be used to emulate all the classic approaches to I/O in Haskell, albeit in miniature:

module ClassicIO where
import qualified Prelude as T
import Prelude(Char, String)
import Prelude(($), (.))
import Data.List(map, foldr, zipWith)
import OutputInput
import Partible

 -- simple text --

{-  main                :: (String -> String)  -}

runMain_text            :: (String -> String) -> OI -> ()
runMain_text main       =  \u -> case part u of
                                   (u1, u2) ->
                                     putchars (main (getchars u1)) u2

getchars                :: OI -> String
getchars                =  foldr (\c cs -> seq c (c:cs)) [] . map getchar . parts

putchars                :: String -> OI -> ()
putchars s              =  foldr seq () . zipWith putchar s . parts


-- dialogues --

{-  main                :: Dialogue  -}

runMain_dial            :: Dialogue -> OI -> ()
runMain_dial main       =  \u -> foldr seq () $ yet $
                                 \l -> zipWith respond (main l) (parts u)

type Dialogue           =  [Response] -> [Request]

data Request            =  Getq | Putq Char
data Response           =  Getp Char | Putp

yet                     :: (a -> a) -> a
yet f                   =  f (yet f)
 
respond                 :: Request -> OI -> Response
respond Getq            =  \u -> case getchar u of c -> seq c (Getp c)
respond (Putq c)        =  \u -> seq (putchar c u) Putp


-- continuations --

{-  main                :: (() -> IOResult) -> IOResult  -}

runMain_cont            :: ((() -> IOResult) -> IOResult) -> OI -> ()
runMain_cont main       =  call (main done)

newtype IOResult        =  R (OI -> ())

call                    :: IOResult -> OI -> ()
call (R a)              =  a

done                    :: () -> IOResult
done ()                 =  R $ \ u -> part u `seq` ()

getchar_cont            :: (Char -> IOResult) -> IOResult
getchar_cont k          =  R $ \u -> case part u of
                                       (u1, u2) -> 
                                          case getchar u1 of
                                            c -> seq c (call (k c) u2)

putchar_cont            :: Char -> (() -> IOResult) -> IOResult
putchar_cont c k        =  R $ \u -> case part u of
                                       (u1, u2) -> 
                                         seq (putchar c u1) (call (k ()) u2)

 -- state-passing --

{-  main                :: IOState -> ((), IOState)  -}

runMain_stat            :: (IOState -> ((), IOState)) -> OI -> ()
runMain_stat main       =  \u -> seq (main (ini_st u)) ()

newtype IOState         =  S OI

ini_st                  :: OI -> IOState
ini_st                  =  S

getchar_stat            :: IOState -> (Char, IOState)
getchar_stat (S u)      =  case part u of
                             (u1, u2) ->
                               case getchar u1 of
                                 c -> seq c (c, S u2)

putchar_stat            :: Char -> IOState -> ((), IOState)
putchar_stat c (S u)    =  case part u of
                             (u1, u2) ->
                               seq (putchar c u1) ((), S u2)

 -- and those weird, fickle things ;-)

{-  main                :: IO ()  -}

runMain_wfth            :: IO () -> OI -> ()
runMain_wfth main       =  main

type IO a               =  OI -> a

getchar_wfth            :: IO Char
getchar_wfth            =  getchar

putchar_wfth            :: Char -> IO ()
putchar_wfth            =  putchar

unit                    :: a -> IO a
unit x                  =  \u -> part u `seq` x

bind                    :: IO a -> (a -> IO b) -> IO b
bind m k                =  \u -> case part u of
                                   (u1, u2) -> (\x -> x `seq` k x u2) (m u1)

 -- supporting definitions --
 --
getchar                 :: OI -> Char
getchar                 =  "getchar" `invokes` T.getChar

putchar                 :: Char -> OI -> ()
putchar c               =  "putchar" `invokes` T.putChar c

What was that - using Prelude.seq that way won't work in Haskell 2010? You are correct!
Now look closely at those imports...

Moving on, here are examples using each of those approaches:

module Echoes where
import Prelude(String, Char(..), Eq(..))
import Prelude(($))
import ClassicIO
import OutputInput(runOI)

echo_text             :: String -> String
echo_text (c:cs)      =  if c == '\n' then [] else c : echo_text cs

echo_dial             :: Dialogue
echo_dial p           =  Getq :
                         case p of
                           Getp c : p' ->
                             if c == '\n' then
                               []
                             else
                               Putq c :
                               case p' of
                                 Putp : p'' -> echo_dial p''

echo_cont             :: (() -> IOResult) -> IOResult
echo_cont k           =  getchar_cont $ \c ->
                         if c == '\n' then
                           k ()
                         else
                           putchar_cont c (\_ -> echo_cont k)

echo_stat             :: IOState -> ((), IOState)
echo_stat s           =  case getchar_stat s of
                           (c, s') ->
                             if c == '\n' then
                               ((), s')
                             else
                               case putchar_stat c s' of
                                 (_, s'') -> echo_stat s''

echo_wfth             :: IO ()
echo_wfth             =  getchar_wfth     `bind` \c ->
                         if c == '\n' then
                           unit ()
                         else
                           putchar_wfth c `bind` \_ -> echo_wfth

Now that we're on the topic of implementation details, did you notice how easy it was to define that allegedly warm, fuzzy[4] IO type using this curious new OI type, and those primitives?

Sometimes that can be a hint that doing the opposite will be difficult or even impossible while staying within standard Haskell 2010. As it happens, this is one of those cases...

To define OI, partOI, getchar and putchar will require:

• modifying your preferred Haskell implementation - lots of work;

• using some other language for the definitions, with Haskell then calling the foreign code - extra work to deal with two different languages;

• using unsafe or implementation-specific primitives - work needed to avoid conflicts with Haskell semantics;

• using implementation-specific extensions - work needed to track relevant extensions, and possible conflicts with Haskell semantics.

For now, I'll just use the extensions - they're ugly, but at least they'll be contained to their respecitve modules. But who knows - if this approach to I/O proves useful enough, it might make its way into a future Haskell standard...that's how IO happened[5].

In the meantime, take a very deep breath:

 -- for GHC 8.6.5
{-# LANGUAGE MagicHash, UnboxedTuples #-}
module OutputInput(OI, Monomo, runOI, invokes, seq) where
import Prelude(Bool, Char, Double, Either, Float, Int, Integer, Maybe)
import Prelude(String, Eq(..))
import Prelude(($), (++), error, all)
import Control.Concurrent(ThreadId, MVar, Chan, QSem, QSemN)
import Control.Concurrent.STM(STM, TVar, TMVar, TChan, TQueue, TBQueue)
import Control.Concurrent.STM(TArray)
import Control.Monad.ST(ST)
import Data.Array(Array)
import Data.Array.IO(IOArray)
import Data.Array.ST(STArray)
import Data.Char(isSpace)
import Data.IORef(IORef)
import Data.STRef(STRef)
import Data.Time(UTCTime, NominalDiffTime, Day, TimeOfDay)
import Data.Time(LocalTime, TimeZone, ZonedTime)
import Data.Time(DiffTime)
import Data.Time(UniversalTime)
import System.Directory(XdgDirectory, XdgDirectoryList, Permissions)
import System.IO(Handle, IOMode, BufferMode, SeekMode, HandlePosn)
import System.IO(TextEncoding, Newline, NewlineMode)
import Partible
import Sequential
import GHC.Base(IO(..), State#, MutVar#, RealWorld)
import GHC.Base(seq#, newMutVar#, atomicModifyMutVar#, noDuplicate#)

data OI                 =  OI OI#

instance Partible OI where
    part =  partOI

partOI                  :: OI -> (OI, OI)
partOI (OI h)           =  case part# h of (# h1, h2 #) -> (OI h1, OI h2)

runOI                   :: (OI -> a) -> IO a
runOI g                 =  IO $ \s -> case dispense# s of
                                        (# s', h #) -> seq# (g (OI h)) s'

invokes                 :: Monomo a => String -> IO a -> OI -> a
(name `invokes` IO act) (OI h)
                        =  (name `invokes#` act) h

class Monomo a

 -- local definitions --
 --
type OI#                =  String -> State# RealWorld

part#                   :: OI# -> (# OI#, OI# #)
part# h                 =  case h "partOI" of
                             s -> case dispense# s of
                                    (# s', h1 #) ->
                                      case dispense# s' of
                                        (# _, h2 #) -> (# h1, h2 #)

dispense#               :: IO# OI#
dispense# s             =  case newMutVar# () s of
                             (# s', r #) -> (# s', expire# s' r #)

expire#                 :: State# s -> MutVar# s () -> String -> State# s
expire# s r name        =  case atomicModifyMutVar# r use s of
                             (# s', () #) -> s'
                           where
                               use x   =  (error nowUsed, x)
                               nowUsed =  name' ++ ": already expired"
                               name'   =  if all isSpace name then "(unknown)"
                                          else name

invokes#                :: Monomo a => String -> IO# a -> OI# -> a
(name `invokes#` act) h =  case act (noDuplicate# (h name)) of (# _, t #) -> t

type IO# a              =  State# RealWorld -> (# State# RealWorld, a #)

 -- supplemental instances --
 --
instance (Monomo a, Monomo b) => Monomo (Array a b)
instance Monomo Bool
instance Monomo BufferMode
instance Monomo Char
instance Monomo a => Monomo (Chan a)
instance Monomo Day
instance Monomo DiffTime
instance Monomo Double
instance (Monomo a, Monomo b) => Monomo (Either a b)
instance Monomo Float
instance Monomo Handle
instance Monomo HandlePosn
instance Monomo Int
instance Monomo Integer
instance Monomo (IO a)
instance (Monomo a, Monomo b) => Monomo (IOArray a b)
instance Monomo IOMode
instance Monomo a => Monomo (IORef a)
instance Monomo a => Monomo [a]
instance Monomo LocalTime
instance Monomo a => Monomo (Maybe a)
instance Monomo a => Monomo (MVar a)
instance Monomo Newline
instance Monomo NewlineMode
instance Monomo NominalDiffTime
instance Monomo Permissions
instance Monomo QSem
instance Monomo QSemN
instance Monomo SeekMode
instance Monomo (ST s a)
instance (Monomo a, Monomo b) => Monomo (STArray s a b)
instance Monomo (STM a)
instance Monomo a => Monomo (STRef s a)
instance Monomo TextEncoding
instance Monomo ThreadId
instance Monomo TimeOfDay
instance Monomo TimeZone
instance (Monomo a, Monomo b) => Monomo (TArray a b)
instance Monomo a => Monomo (TBQueue a)
instance Monomo a => Monomo (TChan a)
instance Monomo a => Monomo (TMVar a)
instance Monomo a => Monomo (TQueue a)
instance (Monomo a, Monomo b, Monomo c, Monomo d, Monomo e, Monomo f) => Monomo (a, b, c, d, e, f)
instance (Monomo a, Monomo b, Monomo c, Monomo d, Monomo e) => Monomo (a, b, c, d, e)
instance (Monomo a, Monomo b, Monomo c, Monomo d) => Monomo (a, b, c, d)
instance (Monomo a, Monomo b, Monomo c) => Monomo (a, b, c)
instance (Monomo a, Monomo b) => Monomo (a, b)
instance Monomo a => Monomo (TVar a)
instance Monomo ()
instance Monomo UniversalTime
instance Monomo UTCTime
instance Monomo XdgDirectory
instance Monomo XdgDirectoryList
instance Monomo ZonedTime

Almost there; this replacement definition of seq should work as expected[1][2][3]:

-- for GHC 8.6.5
{-# LANGUAGE CPP #-}
#define during seq
module Sequential(seq) where
import qualified Prelude(during)

{-# NOINLINE seq #-}
infixr 0 `seq`
seq     :: a -> b -> b
seq x y =  Prelude.during x (case x of _ -> y)

Now you can start breathing again :-)

module Partible where
import Data.Array
import Data.List

class Partible a where
    part  :: a -> (a, a)
    parts :: a -> [a]

     -- Minimal complete definition: part or parts
    part u  =  case parts u of u1:u2:_ -> (u1, u2)
    parts u =  case part u of (u1, u2) -> u1 : parts u2

instance (Ix a, Partible b) => Partible (Array a b) where
    part arr =  case unzip (map part' (assocs arr)) of
                  (al1, al2) -> (new al1, new al2)
                where
                    new          =  array (bounds arr)
                    part' (i, u) =  case part u of
                                     (u1, u2) -> ((i, u1), (i, u2))

instance (Partible a, Partible b) => Partible (Either a b) where
    parts (Left u)  =  map Left (parts u)
    parts (Right v) =  map Right (parts v)

instance (Partible a, Partible b, Partible c, Partible d, Partible e) => Partible (a, b, c, d, e) where
    parts (u, v, w, x, y) =  zipWith5 (,,,,) (parts u) (parts v) (parts w) (parts x) (parts y)

instance (Partible a, Partible b, Partible c, Partible d) => Partible (a, b, c, d) where
    parts (u, v, w, x) =  zipWith4 (,,,) (parts u) (parts v) (parts w) (parts x)

instance (Partible a, Partible b, Partible c) => Partible (a, b, c) where
    parts (u, v, w) =  zipWith3 (,,) (parts u) (parts v) (parts w)

instance (Partible a, Partible b) => Partible (a, b) where
    parts (u, v) =  zipWith (,) (parts u) (parts v)

You're having problems? Maybe one of these can help:

 -- for Sequential.hs
import GHC.Base(lazy)

infixr 0 `seq`
seq     :: a -> b -> b
seq x y =  Prelude.during x (lazy y)

 -- for ClassicIO.hs
yet                     :: (a -> a) -> a
yet f                   =  y where y = f y

(You could also try another extensions-compatible version of GHC; beyond that, the options get more complicated...)

Now, remember how I dispensed with an up-front explanation to try something different? Having just seen how different this all is, here's the explanation...

That abstract partOI and its overloaded associates part and parts? Their origins reside in the pseudocode technique by F. Warren Burton[6] - for our purposes, they help an optimising Haskell implementation to determine when it's safe to use those optimisations. Consider this definition:

testme n = n^2 + n^2

One simple optimisation would be to replace the duplicates of n^2 with a single, shared local definition:

testme n = let x = n^2 in x + x

This definition:

main' u = putchars "ha" u `seq` putchars "ha" u

would likewise be rewritten, with the result being:

main' u = let x = putchars "ha" u in x `seq` x

but, as noted by Philip Wadler[7]:

[...] the laugh is on us: the program prints only a single "ha", at the time variable
x is bound. In the presence of side effects, equational reasoning in its simplest form
becomes invalid.

Equational reasoning is the basis for that simple optimisation and many others in implementations like GHC - so far they've been serving us quite well.

What - just treat I/O-centric definitions as some special case by modifying GHC? Haskell implementations are complicated enough as is!

The problem is being caused by the code being treated as though it's pure, so let's modify the code instead. In this case, one simple solution is to make all calls to I/O-centric definitions unique:

main u = case part u of 
           (u1, u2) ->
             putchars "ha" u1 `seq` putchars "ha" u2

But what about:

oops g h u = g u `seq` h u

main'      = oops (putchars "ha") (putchars "ha")

Will the laugh be on us, again?

This is Haskell, not Clean[8] - there are no uniqueness types to help fend off such potentially-troublesome expressions. For now, the simplest way to make sure OI values are only used once is to have the implementation treat their reuse as being invalid e.g. by throwing an exception or raising an error to stop the offending program.

In the prototype implementation, this all-important single-use property is maintained by expire#.

As for that curious Monomo class and its instances, they leverage Haskell's type system to provide an extra measure of safety for the prototype - an actual implementation would instead use an annotation[9] to achieve the same result e.g:

newEmptyMVar            :: monomo a . OI -> MVar a

Now for the much-maligned[10][11] seq...you could be tempted into avoiding it by using a new data type:

newtype Result a = Is a

getchar' :: OI -> Result Char
putchar' :: Char -> OI -> Result ()

and case-expressions:

respond'                :: Request -> OI -> Response
respond' Getq           =  \u -> case getchar' u   of Is c -> Getp c
respond' (Putq c)       =  \u -> case putchar' c u of Is _ -> Putp

But before you succumb:

unit_Result             :: a -> Result a
unit_Result             =  Is

bind_Result             :: Result a -> (a -> Result b) -> Result b
bind_Result (Is x) k    =  k x

Oh look - Result is one of those types[12]...

The bang-pattern[13] extension? So you can instead write:

respond''               :: Request -> OI -> Response
respond'' Getq          =  \u -> let !c = getchar u in Getp c
respond'' (Putq c)      =  \u -> let !z = putchar c u in Putp

As you can see, z isn't used anywhere - there is no need for it. This being Haskell, if it isn't needed, it normally isn't evaluated. For now, the bang-pattern extension modifies the evaluation of z in order to prevent respond'' being rewritten as:

respond''               :: Request -> OI -> Response
respond'' Getq          =  \u -> let !c = getchar u in Getp c
respond'' (Putq c)      =  \u -> Putp

Will bang-patterns ever be included in a future Haskell standard? If so, will you still be able to use them like this? If not, will you be left with the clean-up job?

Perhaps you'll find some other way for correctly sequencing the evaluation that you like; all well and good...but others might not. For me, the simplest way I've found to make this approach to I/O work is with seq - one that's actually sequential.

But maybe - after all that - you still want seq banished from Haskell. Perhaps you still don't understand I/O in Haskell. It could be that you're dismayed by what you've read here. Alternately, you may have seen or tried this all before, and know it doesn't work all that well - darn...

If that's you, the corresponding language proposal[14] has a list of other articles and research papers I've found which describe or refer to alternative approaches - perhaps one (or more) of them will be more acceptable.

As noted by Owen Stephens[15]:

I/O is not a particularly active area of research, but new approaches are still being discovered,
iteratees being a case in point.

Who knows - the Haskell language could return to having a pure, fully-defined approach to I/O without the notoriety...and it could be you that finds it :-D

P.S: Why the name OI? Many years ago I was tinkering with arrows for performing I/O, labelling them OI a b out of expediency. More recently, I discovered a set of slides[16] describing another approach to I/O which used values of type OI a in a similar fashion to what I've been describing here. I've reused the name because of that similarity.

References:

[1] Sequential ordering of evaluation; Haskell Wiki.

[2] Ticket# 5129: "evaluate" optimized away; GHC bug tracker.

[3] Thread: seq vs. pseq; Haskell mail archive.

[4] Wearing the hair shirt: a retrospective on Haskell; Simon Peyton Jones.

[5] A History of Haskell: being lazy with class; Paul Hudak, John Hughes, Simon Peyton Jones and Philip Wadler.

[6] Nondeterminism with Referential Transparency in Functional Programming Languages; F. Warren Burton.

[7] How to Declare an Imperative; Philip Wadler.

[8] The Clean homepage; Radboud University, Nijmegen, The Netherlands.

[9] Monomorphism by annotation of type variables; Haskell Wiki.

[10] Thread: State monads don't respect the monad laws in Haskell; Haskell mail archive.

[11] The Impact of seq on Free Theorems-Based Program Transformations; Patricia Johann and Janis Voigtlander.

[12] Monad; Haskell Wiki.

[13] 7.18. Bang patterns; GHC user's guide.

[14] Partibles for composing monads; Haskell Wiki.

[15] Approaches to Functional I/O; Owen Stephens.

[16] Non-Imperative Functional Programming; Nobuo Yamashita.

Atravers 03:05, 20 August 2020 (UTC)