/usr/share/doc/libghc-free-doc/html/examples/Teletype.lhs is in libghc-free-doc 4.12.4-3build4.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 | > {-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts #-} --
> import Control.Monad (mfilter)
> import Control.Monad.Loops (unfoldM)
> import Control.Monad.Free (liftF, Free, iterM, MonadFree)
> import Control.Monad.Free.TH (makeFree)
> import Control.Applicative ((<$>))
> import System.IO (isEOF)
> import Control.Exception (catch)
> import System.IO.Error (ioeGetErrorString)
> import System.Exit (exitSuccess)
First, we define a data type with the primitive actions of a teleprinter. The
@param@ will stand for the next action to execute.
> type Error = String
>
> data Teletype param = Halt -- Abort (ignore all following instructions)
> | NL param -- Newline
> | Read (Char -> param) -- Get a character from the terminal
> | ReadOrEOF { onEOF :: param,
> onChar :: Char -> param } -- GetChar if not end of file
> | ReadOrError (Error -> param)
> (Char -> param) -- GetChar with error code
> | param :\^^ String -- Write a message to the terminal
> | (:%) param String [String] -- String interpolation
> deriving (Functor)
By including a 'makeFree' declaration:
> makeFree ''Teletype
the following functions have been made available:
@
halt :: (MonadFree Teletype m) => m a
nL :: (MonadFree Teletype m) => m ()
read :: (MonadFree Teletype m) => m Char
readOrEOF :: (MonadFree Teletype m) => m (Maybe Char)
readOrError :: (MonadFree Teletype m) => m (Either Error Char)
(\\^^) :: (MonadFree Teletype m) => String -> m ()
(%) :: (MonadFree Teletype m) => String -> [String] -> m ()
@
To make use of them, we need an instance of 'MonadFree Teletype'. Since 'Teletype' is a
'Functor', we can use the one provided in the 'Control.Monad.Free' package.
> type TeletypeM = Free Teletype
Programs can be run in different ways. For example, we can use the
system terminal through the @IO@ monad.
> runTeletypeIO :: TeletypeM a -> IO a
> runTeletypeIO = iterM run where
> run :: Teletype (IO a) -> IO a
> run Halt = do
> putStrLn "This conversation can serve no purpose anymore. Goodbye."
> exitSuccess
>
> run (Read f) = getChar >>= f
> run (ReadOrEOF eof f) = isEOF >>= \b -> if b then eof
> else getChar >>= f
>
> run (ReadOrError ferror f) = catch (getChar >>= f) (ferror . ioeGetErrorString)
> run (NL rest) = putChar '\n' >> rest
> run (rest :\^^ str) = putStr str >> rest
> run ((:%) rest format tokens) = ttFormat format tokens >> rest
>
> ttFormat :: String -> [String] -> IO ()
> ttFormat [] _ = return ()
> ttFormat ('\\':'%':cs) tokens = putChar '%' >> ttFormat cs tokens
> ttFormat ('%':cs) (t:tokens) = putStr t >> ttFormat cs tokens
> ttFormat (c:cs) tokens = putChar c >> ttFormat cs tokens
Now, we can write some helper functions:
> readLine :: TeletypeM String
> readLine = unfoldM $ mfilter (/= '\n') <$> readOrEOF
And use them to interact with the user:
> hello :: TeletypeM ()
> hello = do
> (\^^) "Hello! What's your name?"; nL
> name <- readLine
> "Nice to meet you, %." % [name]; nL
> halt
We can transform any @TeletypeM@ into an @IO@ action, and run it:
> main :: IO ()
> main = runTeletypeIO hello
@
Hello! What's your name?
$ Dave
Nice to meet you, Dave.
This conversation can serve no purpose anymore. Goodbye.
@
When specifying DSLs in this way, we only need to define the semantics
for each of the actions; the plumbing of values is taken care of by
the generated monad instance.
|