hranker-0.1.1: Hranker/Commands.hs

module Hranker.Commands 
( allCommands
, Command(..)
, findCmd
, printInverseMapping
, pushAt
) where

import Hranker.Rank (highestRank, indexToRank, Rank, rankToIndex)
import Hranker.State (AnnotatedItem(..), idS, InputState, MyState(..), OutputState, validRank)

import Data.List.NonEmpty (NonEmpty(..), nonEmptyToList)
import System.Console.HCL (prompt, reqCont, reqFail, reqIO, reqRead, reqResp, reqUntil, Request)

import Control.Applicative ((<*>))
import Control.Monad (liftM)
import Data.List (find, sort)

-- | A command which the user can invoke
data (Show a, Eq a, Ord a) => Command a
    = Command { cmdName :: String
              , cmdFn   :: InputState a -> Request (OutputState a)
              }

instance (Show a, Eq a, Ord a) => Show (Command a) where
    show (Command { cmdName = n }) = '(' : head n : ')' : tail n

-- | Request a rank for the given operation
reqRank :: (Show a, Eq a, Ord a) => Bool -> String -> InputState a -> Request Rank
reqRank blankAllowed action s
    | not blankAllowed && (null . tail $ ranked s) = return highestRank  -- because that's the only possible rank
    | otherwise = reqUntil (return . validRank s)
                . prompt (action ++ " item(s) at which rank" ++ if blankAllowed then " (blank for next unranked)? " else "? ")
                $ reqRead reqResp

-- | Request a rank for the given operation, and then turn it into a list index
reqIndex :: (Show a, Eq a, Ord a) => Bool -> String -> InputState a -> Request Int
reqIndex = ((liftM rankToIndex .) .) . reqRank

-- | Removes the user's choice of item(s) and puts them back in the unranked list
removeCmd :: (Show a, Eq a, Ord a) => InputState a -> Request (OutputState a)
removeCmd s = do
    i <- reqIndex False "Remove" s
    let r = ranked s
        (h:t) = drop i r
    return $ MyState { ranked   = take i r ++ t
                     , unranked = h ++ nonEmptyToList (unranked s)
                     }

-- | Applies a function to only the head of a list (if any)
mapHead :: (a -> a) -> [a] -> [a]
mapHead _ []     = []
mapHead f (x:xs) = (f x : xs)

-- | Add the user's annotation to all items at a rank - replacing the annotations that were already there, if any
annotateCmd :: (Show a, Eq a, Ord a) => InputState a -> Request (OutputState a)
annotateCmd s@(MyState { ranked = r, unranked = u}) = do
    i <- reqIndex True "Annotate" s `reqCont` (return (-1))
    a <- prompt ("New annotation> ") . reqCont reqResp $ return ""
    return $ if i < 0
             then (idS s) { unranked = (neHead u) { annotation = a } : neTail u }
                  else (idS s) { ranked = take i r ++ mapHead (map (\ai -> ai { annotation = a })) (drop i r) }

-- | Given a function which takes the lowest rank and yields the rank to insert at, inserts the next item there
pushAt :: (Show a, Eq a, Ord a) => (Rank -> Rank) -> InputState a -> OutputState a
pushAt f (MyState { ranked = r, unranked = u })
    = MyState { ranked = take i r ++ [neHead u] : drop i r
              , unranked = neTail u
              }
    where i = rankToIndex . f . indexToRank $ length r - 1

tieCmd :: (Show a, Eq a, Ord a) => InputState a -> Request (OutputState a)
tieCmd s@(MyState { ranked = r, unranked = u }) = do
    i <- reqIndex False "Tie with" s
    return $ MyState { ranked = take i r ++ mapHead (neHead u:) (drop i r)
                     , unranked = neTail u
                     }

insertCmd :: (Show a, Eq a, Ord a) => InputState a -> Request (OutputState a)
insertCmd s = do
    r <- reqRank False "Insert" s
    return $ pushAt (const r) s

inverseMapping :: (Show a, Eq a, Ord a) => [[AnnotatedItem a]] -> String
inverseMapping = unlines . ("Item:\tRank:" :) . map showInv . sort . concat . zipWith (map . flip (,)) [highestRank..]
    where
        showInv (ai, r) = show ai ++ '\t' : show r

passThruM :: (Monad m, Show a, Eq a, Ord a) => (InputState a -> m b) -> InputState a -> m (OutputState a)
passThruM f = ((>>) . f) <*> return . idS

printInverseMapping :: (Show a, Eq a, Ord a) => MyState c a -> Request ()
printInverseMapping = reqIO . putStrLn . inverseMapping . ranked

inverseMappingCmd :: (Show a, Eq a, Ord a) => InputState a -> Request (OutputState a)
inverseMappingCmd = passThruM printInverseMapping

-- | A list of all the commands the user can choose between
allCommands :: (Show a, Eq a, Ord a) => [Command a]
allCommands = Command { cmdName = "quit"
                      , cmdFn = const reqFail
                      } : map (\c -> c { cmdFn = \s -> cmdFn c s `reqCont` return (idS s) })
                              [ Command { cmdName = "remove"
                                        , cmdFn   = removeCmd
                                        }
                              , Command { cmdName = "annotate"
                                        , cmdFn   = annotateCmd
                                        }
                              , Command { cmdName = "best"
                                        , cmdFn   = return . pushAt (const highestRank)
                                        }
                              , Command { cmdName = "worst"
                                        , cmdFn   = return . pushAt succ
                                        }
                              , Command { cmdName = "tie"
                                        , cmdFn   = tieCmd
                                        }
                              , Command { cmdName = "insert"
                                        , cmdFn   = insertCmd
                                        }
                              , Command { cmdName = "mapping"
                                        , cmdFn   = inverseMappingCmd
                                        }
                              ]

-- | Which command a given character represents - or Nothing if it doesn't represent any valid command
findCmd :: (Show a, Eq a, Ord a) => Char -> Maybe (Command a)
findCmd c = find ((c ==) . head . cmdName) allCommands