therning.org/ magnus

I’ve many times heard that Haskell can be used to prevent certain kind of programmer mistakes. In a presentation on Darcs it was explained how GADTs (especially phantom types) are used in Darcs to make sure that operations on patches follow certain rules. Another way, and at least it sounds easier, is to limit the available functions by running code in some sort of container. This being Haskell, that container is often a monad. I’ve really never seen this presentedⁱ, so I thought I’d try to do it, and indeed it turns out to be very simple.

I started with a data type:

newtype HideIO a = HideIO { runHideIO :: IO a }

which I then made into a Monad in order to make it easy to work with:

instance Monad HideIO where
    return = HideIO . return
 
    (>>=) m f = HideIO $ runHideIO m >>= runHideIO . f

Then I can create an IO function that are allowed in the HideIO monad:

hioPutStrLn = HideIO . putStrLn

In ghci I can then do the following:

> runHideIO $ hioPutStrLn "Hello, World!"
Hello, World!

But I can’t do much else.

1. Most probably due do my weak searching-fu than anything else.[back]

A few days ago I decided to explore the idea of using iteratee to do IO in Haskell. I read most of what Oleg has written on input processing using left-fold enumerators. Only a little wiser I took a look at the Iteratee IO package on Hackage. Unfortunately it still hadn’t quite sunk in. To be honest I couldn’t quite make heads or tails of it. Often just lining up the types properly will just work, even if I don’t understand whyⁱ and soon after I usually gain some sort of understanding. This strategy didn’t seem to work with this particular package though

Somewhat based on Don’s answer to my question on Stackoverflow.com I thought I’d try to work through an implementation of my own. I just really hope I’ve got it right

I must admit I used Iteratee for inspiration at times. However, I couldn’t copy it straight off since I decided to first implement iteratee without involving monads. Sure, it’s rather silly to do “input processing” in Haskell without involving monads, but I find that including monads often clouds the problem at hand. So, I left them out to begin with, and add them again once I feel I know what I’m doing. So, here goes nothing…

The basic idea is to process a stream of data, presented in chunks. Each chunk is handed to an iteratee by an enumerator. For each chunk the iteratee signals to the enumerator whether it’s done or requires more data. These are the types I cooked up for this.

data Stream c e
    = Eof
    | Chunk (c e)
 
data Stepper c e a
    = Done a (Stream c e)
    | NeedAnotherChunk (Iteratee c e a)
 
data Iteratee c e a = Iteratee
    { runIteratee :: (Stream c e) -> (Stepper c e a) }
 
type Enumerator c e a = Iteratee c e a -> Iteratee c e a

I found it rather useful to implement Show for the two first, but I’ll leave that out of this post since it’s a simple thing to do.

I should probably point out that the container type for the stream (that’s the ‘c’ in Stream c e) is rather pointless in what I’ve done; it’s always going to be [] in this post. Keeping it in does provide some more similarity with the Iteratee on Hackage.

At this point I jumped to turning a list into an enumerator. The way I implemented it the list is split up in chunk of 3 items and present each chunk in order to the passed in iteratee.

enumList l iter = loop grouped iter
    where
        grouped = groupList 3 l
 
        groupList n l = let
                (p, r) = splitAt n l
            in case p of
                [] -> []
                xs -> xs:groupList n r

The loop function is the main part. Ending when the chunks are all used up is the easy part:

        loop [] i = let
                s = runIteratee i Eof
            in case s of
                Done v str -> Iteratee $ \ _ -> s
                NeedAnotherChunk i -> i

It is arguably an error if the iteratee returns NeedAnotherChunk when passed an Eof stream, but for now I’ll leave it the way it is. Doing the recursive step is very similar:

        loop (x:xs) i = let
                s = runIteratee i (Chunk x)
            in case s of
                Done v str -> Iteratee $ \ _ -> s
                NeedAnotherChunk i' -> loop xs i'

Here it is worth noticing that the iteratee is expected to return any part of the chunk that wasn’t processed.

Next I coded up my first iteratee, a map over the stream:

iFMap f = let
        doAcc acc Eof = Done acc Eof
        doAcc acc (Chunk i) = NeedAnotherChunk $ Iteratee $ doAcc (acc `mappend` (fmap f i))
    in Iteratee $ doAcc mempty

Now I can run the iterator over a list enumerator:

> runIteratee (enumList [1..9] (iFMap (*2))) Eof
Stepper Done <<[2,4,6,8,10,12,14,16,18]>> <<Stream: Eof>>

I found that a bit verbose, especially for interactive experimentation so the following simplifies it a bit

run iter = case (runIteratee iter) Eof of
    Done a _ -> a
    NeedAnotherChunk _ -> error "run: Iterator didn't finish on Eof"

As Oleg pointed out in his writings it turns out that Iteratee c e is a monad.

instance Monad (Iteratee c e) where
    return x = Iteratee $ \ s -> Done x s

The implementation of return is obvious, there really isn’t any other option than to encode is a continuation that returns Done irrespective of what is offered, and passes along the rest of the stream no matter what’s passed in. Bind (>>=) is a bit more complicated:

    i >>= f = Iteratee $ \ s ->
        let
            c = runIteratee i s
        in case c of
            Done v str -> runIteratee (f v) str
            NeedAnotherChunk i' -> NeedAnotherChunk $ i' >>= f

My understanding is that the left iteratee should be stepped along until it returns Done, at that point the result is passed to the right-side function, which results in an iteratee. The rest of the stream is then passed on to the new iteratee.

I implemented two other iteratees, iDrop :: Int -> Iteratee [] e () and iTakeWhile :: (e -> Bool) -> Iteratee [] e [e] with the obvious implementations. This then allows me to write a little test like this:

iTest = do
    iDrop 2
    t <- iTakeWhile (< 5)
    a <- return 'c'
    m <- iFMap (+ 3)
    return (t, a, m)

Running it gives the expected result:

> run (enumList [1..9] iTest)
([3,4],'c',[8,9,10,11,12])

That’s pretty much it. Not that much to it. At least not as long as I’ve actually understood iteratees.

1. This reminds me of a math professor I had at university who said something like: “When it feels like the pen understands more than your head, persevere! It means you are close to getting it.”[back]

The time has come for the final installment of this series of “discussions of a refactoring”. These are the earlier installments. This is where I finally add the ability to collapse a list item. This is a rather terse description of the changes, since I feel all of them are fairly obvious, and hence require no lengthy explanation.

First the Option type has to be changed to keep track of whether an item is collapsed or not:

data Option = Option
    { optionRange::(Int, Int)
    , optionCollapsed::Bool
    , optionS1::String
    , optionS2::String
    } deriving (Show)

Next the rendering of an item has to be changed, so that collapsed items really appear collapsed. I thought displaying a collapsed item as its first line, with “…” added to the end would be acceptable for a first version:

instance Pretty Option where
    pretty (Option _ False s1 s2) = string s1 <> line <> indent 2 (string s2)
    pretty (Option _ True s1 _) = string s1 <> string "..."

Later on I’ll need to update the range of an item. For the forgetful, the range of an item is the starting and ending line. Obviously the range changes when an item is collapsed:

optionUpdateRange o = let
        (b, _) = optionRange o
        l = length $ lines $ show $ pretty o
    in o { optionRange = (b, b + l - 1) }

The implementation of optionsIsInRange has to change due to adding the optionCollapsed field. It’ll also be useful to have a few functions for manipulating the collapsed state of an item:

optionIsInRange (Option (b, e) _ _ _) i = b <= i && i <= e
 
optionIsCollapsed (Option _ c _ _) = c
optionToggleCollapse o = o { optionCollapsed = not (optionCollapsed o) }
optionCollapse o = o { optionCollapsed = True }
optionExpand o = o { optionCollapsed = False }

One thing that I didn’t think about until after doing some manual testing was that moving the cursor up in the list should always put the cursor on the line above, even when moving from one item to the previous. This was a bug in the previous version

ozPreviousLine o@(OptionZipper 0 _ _) = o
ozPreviousLine o = let
        c = fromJust $ ozCursor o
        i = ozIdx o
    in if optionIsInRange c (i - 1)
        then o { ozIdx = i - 1 }
        else ozJumpToCursorBottom $ ozLeft o

I also have to change ozCursorMod due to adding the new field:

ozCursorMod f o@(OptionZipper _ _ (r:rs)) = let
        _r = f r
    in o { ozRS = (_r:rs) }
ozCursorMod _ o = o

It turns out the be useful to be able to jump to the top and bottom of an item (there’s already an example of the latter above):

ozJumpToCursorTop o@(OptionZipper _ _ (r:rs)) = let
        (newIdx, _) = optionRange r
    in o { ozIdx = newIdx }
 
ozJumpToCursorBottom o@(OptionZipper _ _ (r:rs)) = let
        (_, newIdx) = optionRange r
    in o { ozIdx = newIdx }

Creating the list of items need a slight modification as well:

options = ozFromListWithMod (optionSetRange 0) [Option (0, 0) False ((show i) ++ " Foo") "Bar" | i <- [0..2]]

The last change is adding actually collapsing of an item in the UI controller code:

_getChoice vt opts sx sy =
    let
        _converted_opts = lines $ show $ pretty opts
        _idx = ozIdx opts
        _calcTop winHeight listLength idx = max 0 ((min listLength ((max 0 (idx - winHeight `div` 2)) + winHeight)) - winHeight)
        _top = _calcTop sy (length _converted_opts) _idx
        _visible_opts = take sy (drop _top _converted_opts)
    in do
        update vt (render _visible_opts (_idx - _top) sx)
        k <- getEvent vt
        case k of
            EvKey (KASCII ' ') [] -> let
                    newOpts = ozJumpToCursorTop $ ozCursorMod (optionUpdateRange . optionToggleCollapse) opts
                in _getChoice vt newOpts sx sy
            EvKey KDown [] -> _getChoice vt (ozNextLine opts) sx sy
            EvKey KUp [] -> _getChoice vt (ozPreviousLine opts) sx sy
            EvKey KEsc [] -> shutdown vt >> return Nothing
            EvKey KEnter [] -> shutdown vt >> return (Just $ (_idx, ozCursor opts))
            EvResize nx ny -> _getChoice vt opts nx ny
            _ -> _getChoice vt opts sx sy

That’s it.

Here’s some simple code I put together. I’m mostly posting it so I won’t have any problems finding it in the future.

module Main where
 
import Control.Monad
import System.Exit
import System.Posix.IO
import System.Posix.Process
 
executeChild = do
    mapM_ closeFd [stdInput, stdOutput, stdError]
    devnull <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags
    dup devnull; dup devnull
    executeFile "./Child" False [] Nothing
 
main = do
    child <- forkProcess executeChild
    putStrLn "ForkExec: main - forked, going to wait"
    s <- getProcessStatus True True child
    case s of
        Nothing -> -- this shouldn't happen, ever
            print s >>  exitFailure
        Just s -> do
            print s
            case s of
                Exited _ -> putStrLn "Child exited properly, though possibly unsuccessfully"
                Terminated _ -> putStrLn "Terminated!"
                Stopped _ -> putStrLn "Stopped (only SIGSTOP?)"
            exitSuccess
    exitFailure

It’d be really nice to be able to, after the fork, close all open file descriptors in the child. But how can I find all the open file descriptors in a process? Ideally it should be fairly portable, though portability to major Unix/Linux systems is enough for me.

The other day I wanted to experiment a bit with the JSON interface to AUR. Of course my first stop was at HackageDB to look for a Haskell package for parsing JSON. There are several of them, but only one that seemed suitable for some quick experimentation, especially I wanted to avoid pre-defining data types for the objects in the JSON interface. That failed however and I ended up switching to Python. It did bother me though, and later on, when I had some more time I decided to have another look at json. I was also helped by Don’s recent work on wrapping up the AUR JSON interface in Haskell.

After some searching online I found a reasonably good exampleⁱ:

{ "ID": "SGML"
, "SortAs": "SGML"
, "GlossDef":
    { "para": "A meta-markup language, used to create markup languages such as DocBook."
    , "GlossSeeAlso": ["GML", "XML"]
    }
}

As a slight aside, the absolutely easiest way to add JSON to your program is to derive Data (and by implication Typeable too). This is the way I might have represented the data above in Haskellⁱⁱ :

data GlossDef = GlossDef
    { glossDefPara :: String
    , glossDefSeeAlso :: [String]
    } deriving (Eq, Show, Typeable, Data) 
 
data GlossEntry = GlossEntry
    { glossEntryId :: String
    , glossEntrySortAs :: String
    , glossEntryGlossDef :: GlossDef
    } deriving (Eq, Show, Typeable, Data)

After that it’s as easy as using Text.JSON.Generic.toJSON followed by Text.JSON.encode:

> let gd = GlossDef "foo" ["bar", "baz"]
> let ge = GlossEntry "aa" "bb" gd
> putStrLn $ encode $ toJSON ge
{"glossEntryId":"aa","glossEntrySortAs":"bb","glossEntryGlossDef":{"glossDefPara":"foo","glossDefSeeAlso":["bar","baz"]}}

As can be seen the “names” of the members are derived from the field names in the datatypes. Great for when you are designing new JSON objects, not when you are writing code to parse an already existing object. For that there is another, more verbose way to do it.

Start with the same data types, but without deriving Typeable and Data:

data GlossDef = GlossDef
    { glossDefPara :: String
    , glossDefSeeAlso :: [String]
    } deriving (Eq, Show)
 
data GlossEntry = GlossEntry
    { glossEntryId :: String
    , glossEntrySortAs :: String
    , glossEntryGlossDef :: GlossDef
    } deriving (Eq, Show)

Then you have to implement Text.JSON.JSON. Only two of the four functions must be implemented, showJSON and readJSON. Starting with GlossDef:

instance JSON GlossDef where
    showJSON gd = makeObj
        [ ("para", showJSON $ glossDefPara gd)
        , ("GlossSeeAlso", showJSON $ glossDefSeeAlso gd)
        ]

Basically this part defers to the already supplied implementations for the fields’ types. The same approach works for readJSON too:

    readJSON (JSObject obj) = let
            jsonObjAssoc = fromJSObject obj
        in do
            para <- mLookup "para" jsonObjAssoc >>= readJSON
            seeAlso <- mLookup "GlossSeeAlso" jsonObjAssoc >>= readJSON
            return $ GlossDef
                { glossDefPara = para
                , glossDefSeeAlso = seeAlso
                }
 
    readJSON _ = fail ""

The function mLookup is a wrapper around lookup that makes it a bit nicer to work with in monads other than Maybe:

mLookup a as = maybe (fail $ "No such element: " ++ a) return (lookup a as)

(The choice to include the key in the string passed to fail limits the usefulness somewhat in the general case, but for this example it doesn’t make any difference.)

Implementing the interface for GlossEntry is analogous:

instance JSON GlossEntry where
    showJSON ge = makeObj
        [ ("ID", showJSON $ glossEntryId ge)
        , ("SortAs", showJSON $ glossEntrySortAs ge)
        , ("GlossDef", showJSON $ glossEntryGlossDef ge)
        ]
 
    readJSON (JSObject obj) = let
            jsonObjAssoc = fromJSObject obj
        in do
            id <- mLookup "ID" jsonObjAssoc >>= readJSON
            sortAs <- mLookup "SortAs" jsonObjAssoc >>= readJSON
            gd <- mLookup "GlossDef" jsonObjAssoc >>= readJSON
            return $ GlossEntry
                { glossEntryId = id
                , glossEntrySortAs = sortAs
                , glossEntryGlossDef = gd
                }

With the JSON object mentioned at the top in the file test.json the following is possible:

> f <- readFile "test.json"
> let (Ok j) = decode f :: Result GlossEntry
> putStrLn $ encode j
{"ID":"SGML","SortAs":"SGML","GlossDef":{"para":"A meta-markup language, used to create markup languages such as DocBook.","GlossSeeAlso":["GML","XML"]}}

I have a feeling the implemention of readJSON could be simplified by using an applicative style, but I leave that as an excercise for the reader

1. it’s a modified version of what I found here.[back]
2. The file should include {-# LANGUAGE DeriveDataTypeable #-} and both Data.Typeable and Data.Data must be imported.[back]

Arch is somewhat of a hybrid distribution in the sense that if you have any sort of ‘peculiar’ needs then you are likely to have to build packages from source. As expected developing in Haskell is a “peculiar need”

After every upgrade of GHC I find myself in the situation where the system (pacman) and GHC have different views of what packages are available. What is needed then is somehow finding out the difference, and this is how I found that difference after the recent 6.10.3 -> 6.10.4 upgrade of GHC. Once I know what packages are missing from GHC’s view of the world I can use pacman to first remove and then yaourt to rebuild the packages.

First I noted that the old package.conf file wasn’t deleted during the upgrade, apparently pacman noted the changes that installing packages resulted in and saved the file as package.conf.pacsave. Finding the name of all the ‘missing’ packages was then as simple as loading both /usr/lib/ghc-6.10.3/package.conf.pacsave and /usr/lib/ghc-6.10.4/package.conf, filter out the package names and take the difference:

printMissingPackages = let
        pkgNameStr = PackageName . display . packageName
    in do
        oldPackConf <- readFile "/usr/lib/ghc-6.10.3/package.conf.pacsave"
        curPackConf <- readFile "/usr/lib/ghc-6.10.4/package.conf"
        let oldPacks = (read oldPackConf) :: [InstalledPackageInfo_ String]
        let curPacks = (read curPackConf) :: [InstalledPackageInfo_ String]
        let gonePacks = (map pkgNameStr oldPacks) \\ (map pkgNameStr curPacks)
        putStrLn "Missing packages:"
        mapM_ (putStrLn . display) gonePacks

That isn’t the most useful output however, so I decided to modify it to print out the name of the Arch package that needed re-compilation. The following functions generates the name of the .hi of the first module in the Haskell package, it then uses pacman to look up the owner of the file:

ghcPkg2ArchPkg pkg = let
        hsFileLoc = head $ libraryDirs pkg
        hsFile = map (\ c -> if c == '.' then '/' else c) $ head $ exposedModules pkg
        hsFullFile = hsFileLoc </> hsFile <.> "hi"
    in do
        exists <- doesDirectoryExist hsFullFile
        if exists
            then liftM Just $ archOwnerOfFile hsFullFile
            else return Nothing
 
archOwnerOfFile fn = let
        pkgFromPacmanOutput = head . tail . reverse . words
    in do
        res <- rawSystemStdout silent "/usr/bin/pacman" ["-Qo", fn]
        return $ pkgFromPacmanOutput res

Now I can find the list of Arch packages that aren’t known to the new version of GHC by mapping ghcPkg2ArchPkg over gonePkgs. In other words that is the list of packages that need to be removed, but that can be different from the list of packages that needs to be rebuilt with yaourt (basically I only want to tell it to build and install the ‘top-level’ packages, i.e. packages that aren’t dependencies of any other packages. It’s of course possible to build that second list from the first one, with the help of pacman.

archGetRequiredBy pkg = let
        extractPkgs pkgDesc = let
                deps = (drop 3 . words . head . filter (isPrefixOf "Required By") . lines) pkgDesc
            in
                if deps == ["None"]
                    then []
                    else deps
    in do
        res <- rawSystemStdout silent "/usr/bin/pacman" ["-Qi", pkg]
        return $ extractPkgs res

Now I can modify printMissingPackages to print some more useful information. This is the full function:

printMissingPackages = let
        pkgNameStr = PackageName . display . packageName
    in do
        oldPackConf <- readFile "/usr/lib/ghc-6.10.3/package.conf.pacsave"
        curPackConf <- readFile "/usr/lib/ghc-6.10.4/package.conf"
        let oldPacks = (read oldPackConf) :: [InstalledPackageInfo_ String]
        let curPacks = (read curPackConf) :: [InstalledPackageInfo_ String]
        let gonePacks = (map pkgNameStr oldPacks) \\ (map pkgNameStr curPacks)
        putStrLn "Missing packages:"
        mapM_ (putStrLn . display) gonePackprints
        let gonePkgs = filter (\ p -> pkgNameStr p `elem` gonePacks) oldPacks
        archPkgs <- liftM catMaybes $ mapM ghcPkg2ArchPkg gonePkgs
        putStrLn "Packages to remove:"
        mapM_ putStrLn archPkgs
        archTopPkgs <- filterM (liftM ([] ==) . archGetRequiredBy) archPkgs
        putStrLn "\nPackages to install:"
        mapM_ putStrLn archTopPkgs

On my system it produced the following output:

Missing packages:
terminfo
vty
wl-pprint

Packages to remove:
haskell-terminfo
haskell-vty
haskell-wl-pprint

Packages to install:
haskell-vty
haskell-wl-pprint

And after a quick pacman -Rn ... and a not so quick yaourt -S ... I reran it and the output was

Packages to remove:

Packages to install:

Exactly as expected.

After part 3 in this series, which might have been the longest post I’ve ever put on this blog, follows a much short post. In fact it’s so short it’s rather silly.

In this post I’ll modify the Option type to render into multiple lines; two in fact (it’s easy to see that it would work with more lines).

So, to start off, I add a second string to Option:

data Option = Option { optionRange::(Int, Int), optionS1::String, optionS2::String }
    deriving (Show)

Next the definition for Pretty is changed to render an Option on two lines:

instance Pretty Option where
    pretty (Option _ s1 s2) = string s1 <> line <> indent 2 (string s2)

Due to the change to Option I also need to modify optionIsInRange:

optionIsInRange (Option (b, e) _ _) i = b <= i && i <= e

Finally the options need to be modified as well:

options = ozFromListWithMod (optionSetRange 0) [Option (0, 0) ((show i) ++ " Foo") "Bar" | i <- [0..2]]

That’s all there’s to it. Short and sweet.

This is the third part, and it’s likely to be the longest one in the series. The three previous parts have been rather short, but now it’s time for a longer post because in this one I completely change the representation of the options that are rendered.

Instead of using a list and an integer I’ll use what is basically a zipper (with some extra fields for book keeping). At the same time I also add a new field to the Option type to keep track of how many lines the option renders to. At the moment it will always be one line, but the next part will actually make use of it. (Yes, that part probably should have been kept in a separate part, but this happens to be how I wrote the code.)

First some changes to the Option type and its implementation of Pretty:

data Option = Option { optionRange::(Int, Int), optionS1::String }
    deriving (Show)
 
instance Pretty Option where
    pretty (Option _ s) = string s

Then two functions related to the “range” of an Option. The first to update based on a new start line (new beginning), the second checks whether a line falls within the range of an Option:

optionSetRange nb o = let
        l = length $ lines $ show $ pretty o
    in o { optionRange = (nb, nb + l - 1) }
 
optionIsInRange (Option (b, e) _) i = b <= i && i <= e

Now it’s time to introduce the zipper that replaces the list of options. The basic idea is that there are two parts to a list, the left side (ozLS) and the right side (ozRS), and a current item. In this list zipper the current item is the first item on the right side:

data OptionZipper = OptionZipper { ozIdx::Int, ozLS::[Option], ozRS::[Option]
}
    deriving (Show)

Making the zipper an instance of Pretty is as simple as this:

instance Pretty OptionZipper where
    pretty = vcat . map pretty . ozToList

It’s useful to be able to both convert to and from lists (as seen just above in the Pretty instance):

ozFromList l = OptionZipper 0 [] l
ozFromListWithMod f = ozCursorMod f . ozFromList
 
ozToList (OptionZipper _ l r) = reverse l ++ r

The function for getting the current item is obvious. At the same time I’ll define a function that applies a function to the item at the cursor.

ozCursor (OptionZipper _ _ (r:_)) = Just r
ozCursor _ = Nothing
 
ozCursorMod f o@(OptionZipper _ _ (r:rs)) = o { ozRS = (f r:rs) }
ozCursorMod _ o = o

Usually a list zipper has functions to move the cursor, i.e. move items between the left and right sides. In this zipper there is some extra bookkeeping that has to be done to make sure that the index is correct and that the current item has a correct range:

ozLeft (OptionZipper _ (l:ls) rs) = let
        (newIdx, _) = optionRange l
    in OptionZipper newIdx ls (l:rs)
ozLeft o = o
 
ozRight (OptionZipper _ ls (r:rs)) = let
        (_, pe) = optionRange r
    in ozCursorMod (optionSetRange $ pe + 1) $ OptionZipper (pe + 1) (r:ls) rs
ozRight o = o

That’s all good and well, but what I really need is to be able to navigate based on lines. Expressing that using ozLeft and ozRight is fairly straight forward. Let’s start with shifting to the next line, ozNextLine, it has two cases, one general case and one when the cursor points to the last item:

ozNextLine o@(OptionZipper i _ [c]) =
    if optionIsInRange c (i + 1)
        then o { ozIdx = i + 1 }
        else o
ozNextLine o = let
        c = fromJust $ ozCursor o
        i = ozIdx o
    in if optionIsInRange c (i + 1)
        then o { ozIdx = i + 1 }
        else ozRight o

Anyone who pays attention will realise that this definition of ozNextLine isn’t complete. The zipper is capable of pointing to the empty spot after the last item (when ozRS is [], as would be the case for an empty list turned into a zipper). For this occasion that is all right, but this would need some attention when using this in a proper program.

The definition of ozPreviousLine also has two cases:

ozPreviousLine o@(OptionZipper 0 _ _) = o
ozPreviousLine o = let
        c = fromJust $ ozCursor o
        i = ozIdx o
    in if optionIsInRange c (i - 1)
        then o { ozIdx = i - 1 }
        else ozLeft o

Yes, this function also has some assumptions built into it, just like for ozNextLine it’s enough to just realise that for this exercise.

That’s it for the zipper, now it’s possible to create the options:

options = ozFromListWithMod (optionSetRange 0) [Option (0, 0) ((show i) ++ " Foo") | i <- [0..99]]

The introduction of the zipper requires large changes to both getChoice and _getChoice. The changes are however very straight forward and in my opinion they make both functions easier to read and understand. I’ll simply copy in the definitions without any comments in the hope that thanks to using a zipper the code is self-explanatory It might be worth pointing out though that render is still passed a list of strings to render, so it requires no changes at this point.

getChoice vt opts = do
    (sx, sy) <- getSize vt
    _getChoice vt opts sx sy
 
 
_getChoice vt opts sx sy =
    let
        _converted_opts = lines $ show $ pretty opts
        _idx = ozIdx opts
        _calcTop winHeight listLength idx = max 0 ((min listLength ((max 0 (idx - winHeight `div` 2)) + winHeight)) - winHeight)
        _top = _calcTop sy (length _converted_opts) _idx
        _visible_opts = take sy (drop _top _converted_opts)
    in do
        update vt (render _visible_opts (_idx - _top) sx)
        k <- getEvent vt
        case k of
            EvKey KDown [] -> _getChoice vt (ozNextLine opts) sx sy
            EvKey KUp [] -> _getChoice vt (ozPreviousLine opts) sx sy
            EvKey KEsc [] -> shutdown vt >> return Nothing
            EvKey KEnter [] -> shutdown vt >> return (Just $ (_idx, ozCursor opts))
            EvResize nx ny -> _getChoice vt opts nx ny
            _ -> _getChoice vt opts sx sy

Yesterday I needed to do some tests involving tunneling of network connections. Rather than firing up the full client-server setup that I want to tunnel I thought I’d use someting simple to test with first. Instead of looking online for a simple server to use, or hack one up using netcat, or even hack one in Python I decided to hack one in Haskell:

module Main where
 
import Control.Monad
import System.Environment(getArgs)
import Network
import System.IO
 
main = withSocketsDo $ do
    [port_str] <- getArgs
    let port = fromIntegral (read port_str :: Int)
    serv_sock <- listenOn (PortNumber port)
    forever $ do
        (handle, host, port) <- accept serv_sock
        cmd <- hGetLine handle
        when (cmd == "Ping") $ hPutStr handle "Pong"
        hClose handle

I don’t know how many times I’ve gone looking for one of these but my search-fu is weak and I always give up, instead resorting to manual editing in Vim (no I hardly ever need the entire file to be pretty, only one or two tags that I’m interested in). Anyway, here’s a quick hack in Haskell, relying on xml for the heavy lifting:

#! /usr/bin/env runhaskell
 
module Main where
 
import Control.Monad
import System.Environment
import Text.XML.Light.Input
import Text.XML.Light.Output
 
main = do
    fn <- liftM (!! 0) $ getArgs
    xml_contents <- readFile fn
    let (Just doc) = parseXMLDoc xml_contents
    writeFile ("pretty-" ++ fn) (ppTopElement doc)