Haskell program with TCL gui to append to YAML files.

YamlAppend.hs

import System.IO
import System.Environment
import System.Process
import System.Exit
import Data.Maybe
import Control.Applicative

import HTk.Toplevel.HTk
import Data.Yaml

import System.Directory
import qualified Data.Vector as V
import qualified Data.HashMap.Strict as M
import Data.List
import Control.Monad.Instances

import qualified Data.Text as T
import qualified Data.ByteString.Char8 as B

data Doc = Doc String String [String] deriving (Read, Show)

usage = "Usage: ./YamlAppend doc_spec.data doc_name"

metaDoc fname name = do
  docs <- read <$> readFile fname
  -- get the doc spec for the doc_name
  let (Just d) = find (\(Doc x _ _) -> x == name) docs
  return d

isMatch :: String -> Value -> Bool
isMatch term (Object s) = any (isMatch term) (M.elems s)
-- TODO: don't be case sensitive
isMatch term (String s) = isInfixOf term (T.unpack s)
isMatch _ _ = False

main = do
  args <- getArgs
  if (length args == 2) then do
    -- missing specified doc_name
    docs <- read <$> readFile (args !! 0)
    -- hPutStrLn stderr usage
    hPutStrLn stderr "Possible docs:"
    mapM_ (\(Doc x _ _) -> hPutStrLn stderr ("- " ++ x)) docs
    exitFailure

  else if (length args == 4 || length args == 5) then do
    if (args !! 0 == "edit") then do
      -- normal usage
      (Doc _ fn opts) <- metaDoc (args !! 1) (args !! 3)
      let pth = args !! 2
      mkEditor (pth ++ fn) opts

    else if (args !! 0 == "search") then do
      (Doc _ fn opts) <- metaDoc (args !! 1) (args !! 3)
      let pth = args !! 2
      (Just d) <- decodeFile (pth ++ fn) :: IO (Maybe Array)
      B.putStrLn $ encode $ V.filter (isMatch (args !! 4)) d

    else do
      hPutStrLn stderr "Invalid option: Must be edit or search"
      exitFailure
  else do
    hPutStrLn stderr usage
    exitFailure

-- Editor
saveDoc :: FilePath -> [String] -> [String] -> IO ()
saveDoc f keys vals = do
  h <- openFile f AppendMode
  let pairs = zip keys vals
  putHeader h $ head pairs
  mapM_ (\x -> putRow h x) (tail (zip keys vals))
  hClose h

putHeader :: Handle -> (String, String) -> IO ()
putHeader h v = hPutStrLn h $ "- " ++ fst v ++ ": " ++ snd v

putRow :: Handle -> (String, String) -> IO ()
putRow h v = hPutStrLn h $ "  " ++ fst v ++ ": " ++ snd v

mkFrame main name = do
  f <- newFrame main []
  l <- newLabel f [text name, width 10, justify JustLeft]
  e <- (newEntry f [value "", width 20]) :: IO (Entry String)
  pack f []
  pack l [PadX 10, Side AtLeft]
  pack e [PadX 10, Side AtRight]
  return e

mkEditor :: String -> [String] -> IO ()
mkEditor name keys = do
    valid <- doesFileExist name
    if valid then
      -- open editor
      editor name keys
    else do
      -- File doens't exist, exit
      hPutStrLn stderr $ "Error: Unable to open file " ++ name
      exitFailure

editor :: FilePath -> [String] -> IO ()
editor fname keys = do
  main <- initHTk [text "YAML Editor", size (300, 120)]
  l <- newLabel main [text ("Editing: " ++ fname)]
  pack l []

  fields <- mapM (mkFrame main) keys

  (entered, _) <- bind (last fields) [WishEvent [] (KeyPress (Just (KeySym "Return")))]

  _ <- spawnEvent (forever
    (entered >>> do
                    txts <- mapM (getValue) fields
                    saveDoc fname keys txts
                    mapM_ (# value "") fields
                    setFocus (head fields) >> done))
  finishHTk


-- Test Data
docs = [ Doc "links" "links/linksdb.yaml" ["id", "description", "title", "url"]
       , Doc "tools" "links/tools.yaml" ["name", "description", "url"]
       ]

test = mkEditor "test.txt" ["name", "url"]