A (partial) re-implementation of the `memo` application available at http://getmemo.org. Excuse to learn about applicative parser combinators. Work in progress.

Main.hs

{-# LANGUAGE DeriveFunctor #-}

module Main where

import Data.Char (toUpper)
import Prelude hiding (map, take, takeWhile, print, filter)
import Pipes
import Pipes.Prelude (map, fromHandle, toHandle, stdoutLn, filter, take, fold)
import Pipes.Lift
import System.Directory (getHomeDirectory, doesFileExist)
import System.IO hiding (print)
import Control.Monad.IO.Class
import Data.List hiding (take, map, filter)
import Control.Applicative hiding (many)
import Data.Char
import Control.Monad (forever, unless)
import Control.Monad.Trans.State.Strict
import System.Environment (getArgs)
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IM
import Data.Time.Calendar
import Data.Time.Clock

{- |
 - Data we work with: Memos, MemoFlags, and Dates
 -}

data MemoFlag = Undone | Done | Postponed
    deriving (Eq, Ord)

instance Show MemoFlag where
    show (Postponed) = "P"
    show (Undone)    = "U"
    show (Done)      = "D"

data Date = Date { _year :: Int, _month :: Int, _day :: Int }
    deriving (Ord, Eq)

instance Show Date where
    show (Date yr mt dy) = (show yr) ++ "-" ++ (show' mt) ++ "-" ++ (show' dy)
        where show' x | x < 10 = "0" ++ (show x)
                      | otherwise = show x

data Memo = Memo
    { mId          :: Int
    , mFlag        :: MemoFlag
    , mDateCreated :: Date
    , mText        :: String
    } deriving (Eq)

instance Show Memo where
    show (Memo mId mFlag mDate mText) =
        (show mId) ++ "\t" ++
        (show mFlag) ++ "\t" ++
        (show mDate) ++ "\t" ++
        mText

dateToday :: IO Date
dateToday = do
    (yr, mt, dy) <- getCurrentTime >>= return . toGregorian . utctDay
    return $ Date (fromIntegral yr) mt (dy - 1)

{- |
 - This is a relatively naïve applicative parser combinator library, and the
 - (primary) raison d'être for this exercise.
 -
 - Where this code is interesting or novel it is adapted from this paper:
 -
 -     http://www.cs.uu.nl/research/techreps/repo/CS-2008/2008-044.pdf
 -}

newtype Parser s t = P { runParser :: ([s] -> [(t, [s])]) }
    deriving Functor

instance Applicative (Parser s) where
    pure x = P $ \inp -> [(x, inp)]
    (P p1) <*> (P p2) = P $
        \inp -> [ (v1 v2, ss2) | (v1, ss1) <- p1 inp
                               , (v2, ss2) <- p2 ss1 ]

instance Alternative (Parser s) where
    empty = P $ \_ -> []
    (P p1) <|> (P p2) = P $ \inp -> p1 inp ++ p2 inp

char :: Char -> Parser Char Char
char c = P $ \inp ->
    case inp of
        (s:ss) -> if s == c then [(s, ss)] else []
        _      -> []

digit :: Parser Char Int
digit = P $ \inp ->
    case inp of
        s:ss -> if isDigit s
                    then let s' = read [s]
                         in if s' >= 0 && s' <= 9
                                then
                                      [(s', ss)]
                                else []
                    else []
        _ -> []

number :: Parser Char Int
number = foldl (\a b -> a * 10 + b) 0 <$> many digit

anyChar = P $ \inp -> case inp of
                      (s:ss) -> [(s, ss)]
                      _      -> []

opt :: Alternative f => f a -> a -> f a
p `opt` v = p <|> pure v

many :: Alternative f => f a -> f [a]
many p = (:) <$> p <*> many p `opt` []

many1 :: Alternative f => f a -> f [a]
many1 p = (:) <$> p <*> many p

{- |
 - Using the combinators above we can define parsers for our data structures.
 -}

parseFlag :: Parser Char MemoFlag
parseFlag = P $ \inp -> case inp of
                        'U':ss -> [(Undone, ss)]
                        'D':ss -> [(Done,   ss)]
                        'P':ss -> [(Postponed, ss)]

parseDate :: Parser Char Date
parseDate = Date <$> number <* char '-' <*> number <* char '-' <*> number

parseMemo :: Parser Char Memo
parseMemo = Memo <$> number <* char '\t'
                 <*> parseFlag <* char '\t'
                 <*> parseDate <* char '\t'
                 <*> many anyChar

{- |
 - Application-specific utilities
 -
 - The real logic of the application. Defined below are mainly processing
 - pipelines to get memos out of the memo file; to filter the memos according
 - to user commands; and get them back into the file.
 -}

-- | Determine if the user has a `~/.memo` file
locateMemoFile :: IO (Maybe FilePath)
locateMemoFile = do
    userHome <- getHomeDirectory
    let memoPath = userHome ++ "/.memo"
    memoFileFound <- doesFileExist memoPath
    if memoFileFound then return (Just memoPath) else return Nothing

-- | Stream memos from the memo file
readMemos :: Handle -> Producer Memo IO ()
readMemos hndl = fromHandle hndl >-> map (runParser parseMemo)
                    >-> map head >-> map fst

-- | Stream memos into a file with the given Handle
writeMemos :: Handle -> Consumer Memo IO ()
writeMemos hndl = map show >-> toHandle hndl

-- | Consumes memos, writing them to the terminal
displayMemo :: Consumer Memo IO ()
displayMemo = do
    memo <- await
    lift . putStrLn . show $ memo
    return ()

-- | Makes our sink run as long as there is input
displayMemos :: Consumer Memo IO ()
displayMemos = forever displayMemo

-- | Accepts a memo-transforming pipe and a sink, and runs the pipeline.
filterMemos :: FilePath -> Pipe Memo a IO () -> Consumer a IO () -> IO ()
filterMemos fp pipe sink = do
    hndl <- openFile fp ReadMode
    runEffect $ readMemos hndl >-> pipe >-> sink
    hClose hndl

-- | It is often the case that we wish to filter out "postponed" memos
excludePostponed :: Pipe Memo Memo IO ()
excludePostponed = filter (\m -> mFlag m /= Postponed)

-- | Convenience function, first excluding postponed memos before using `take`
listNMemos :: Int -> Pipe Memo Memo IO ()
listNMemos howMany = excludePostponed >-> take howMany

-- | *Only* show postponed memos
showPostponed :: Pipe Memo Memo IO ()
showPostponed = filter (\m -> mFlag m == Postponed)

-- | This needs love. Intention: search for memos containing the given
-- substring.
findInMemos :: Monad m => String -> Pipe Memo Memo m ()
findInMemos needle = loop where
    loop = do
        haystack <- await
        let txt = words $ mText haystack
        let res = elemIndex needle txt
        case res of
            Just _  -> yield haystack >> loop
            Nothing -> loop

-- | Utility to read a file into an IntMap
readIntoMap :: FilePath -> IO (IntMap Memo)
readIntoMap fp = do
    hndl <- openFile fp ReadMode
    theMap <- fold (\mp m -> IM.insert (mId m) m mp)
                 IM.empty id $ readMemos hndl
    hClose hndl
    return theMap

-- | Utility to stream memos from an IntMap
streamFromMap :: Monad m => IntMap a -> Producer a m ()
streamFromMap mp = each (IM.toList mp) >-> map snd

-- | Read in memos from the file, determine what the next ID should be, and
-- then insert the appropriate memo.
addMemo :: FilePath -> String -> IO ()
addMemo fp txt = do
    mp <- readIntoMap fp
    theDate <- dateToday
    let nextId = (head . reverse . IM.keys $ mp) + 1
    let m = Memo nextId Undone theDate txt
    let mp' = IM.insert nextId m mp
    hndl <- openFile fp WriteMode
    -- NB `WriteMode` means the existing file will be overwritten
    runEffect $ streamFromMap mp' >-> excludePostponed >-> writeMemos hndl
    hClose hndl

-- | Filter out the memo with the specified id. Meant to be piped into a file
-- sink.
rmMemo :: FilePath -> Int -> IO ()
rmMemo fp theId = do
    mp <- readIntoMap fp
    hOut <- openFile fp WriteMode
    runEffect $ streamFromMap mp
            >-> filter (\m -> mId m /= theId)
            >-> writeMemos hOut
    hClose hOut

-- | A nice poorly-engineered god function to dispatch pipelines based on
-- command line arguments.
doMemo :: FilePath -> [String] -> IO ()
doMemo fp args =
    case length args of
        0 -> filterMemos fp excludePostponed displayMemos
        1 -> case (args !! 0) of
                 "-P" -> filterMemos fp showPostponed displayMemos
                 "-p" -> putStrLn fp
                 _    -> invalidSyntax
        2 -> case (args !! 0) of
                 "-l" -> filterMemos fp (listNMemos (read (args !! 1)))
                            displayMemos
                 "-f" -> filterMemos fp (findInMemos (args !! 1)) displayMemos
                 "-a" -> addMemo fp (args !! 1)
                 "-d" -> rmMemo fp (read (args !! 1))
                 _    -> invalidSyntax
        _ -> invalidSyntax

-- | Let the user know something very useful
invalidSyntax :: IO ()
invalidSyntax = putStrLn "Invalid syntax"

main :: IO ()
main = do
    args <- getArgs
    found <- locateMemoFile
    -- TODO create the file instead of failing
    case found of
        Just fp -> doMemo fp args
        Nothing -> putStrLn "No memos"
    return ()

Makefile

OPTS = -no-user-package-db -package-db .cabal-sandbox/*-packages.conf.d

all: memo-hs

memo-hs:
	ghc $(OPTS) --make Main.lhs -o memo-hs

clean:
	rm memo-hs
	rm *.{hi,o}

memo-hs.cabal

-- Initial memo-hs.cabal generated by cabal init.  For further 
-- documentation, see http://haskell.org/cabal/users-guide/

-- The name of the package.
name:                memo-hs

-- The package version.  See the Haskell package versioning policy (PVP) 
-- for standards guiding when and how versions should be incremented.
-- http://www.haskell.org/haskellwiki/Package_versioning_policy
-- PVP summary:      +-+------- breaking API changes
--                   | | +----- non-breaking API additions
--                   | | | +--- code changes with no API change
version:             0.1.0.0

-- A short (one-line) description of the package.
synopsis:            Re-implementation of the `memo` CLI note taking utility

-- A longer description of the package.
-- description:         

-- URL for the project homepage or repository.
homepage:            http://niltag.net/memo-hs

-- The license under which the package is released.
license:             GPL-3

-- The file containing the license text.
license-file:        LICENSE

-- The package author(s).
author:              Gatlin Johnson

-- An email address to which users can send suggestions, bug reports, and 
-- patches.
maintainer:          gatlin@niltag.net

-- A copyright notice.
-- copyright:           

category:            Text

build-type:          Simple

-- Extra files to be distributed with the package, such as examples or a 
-- README.
-- extra-source-files:  

-- Constraint on the version of Cabal needed to build this package.
cabal-version:       >=1.10


executable memo-hs
  -- .hs or .lhs file containing the Main module.
  main-is:             Main.hs
  
  -- Modules included in this executable, other than Main.
  -- other-modules:       
  
  -- LANGUAGE extensions used by modules in this package.
  other-extensions:  DeriveFunctor
  
  -- Other library packages from which modules are imported.
  build-depends:       base >=4.7 && <4.8,
                       pipes >= 4.1.4,
                       directory >= 1.2.1.0,
                       transformers >= 0.4.2.0,
                       containers >= 0.5.6.2,
                       time == 1.4.2
  
  -- Directories containing source files.
  -- hs-source-dirs:      
  
  -- Base language which the package is written in.
  default-language:    Haskell2010