hranker 0.1 → 0.1.1
raw patch · 5 files changed
+251/−1 lines, 5 files
Files
- Hranker/CommandLine.hs +38/−0
- Hranker/Commands.hs +128/−0
- Hranker/Rank.hs +30/−0
- Hranker/State.hs +53/−0
- hranker.cabal +2/−1
+ Hranker/CommandLine.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Hranker.CommandLine (clMain, oneRound) where++import Hranker.Commands (allCommands, cmdFn, Command, findCmd, printInverseMapping, pushAt)+import Hranker.State (AnnotatedItem(..), MyState(..), OutputState)++import Data.List.NonEmpty (listToNonEmpty)+import System.Console.HCL (execReq, prompt, reqCont, reqFail, reqIO, reqIterate, reqResp, Request, reqUntil)++import Control.Monad (liftM)+import Data.Maybe (fromJust, isJust)++-- | Perform one "round" of the user interaction (i.e. asking for and executing one command)+oneRound :: forall a. (Show a, Eq a, Ord a) => OutputState a -> Request (OutputState a)+oneRound prevOS = do+ -- Immediately quit if the unranked list is empty+ u <- maybe (printInverseMapping prevOS >> reqFail) return . listToNonEmpty $ unranked prevOS+ -- Convert the previous OutputState into an InputState+ let inS = prevOS { unranked = u }+ -- Show the current state+ reqIO . putStrLn $ show inS+ -- Ask for a command until a valid one is entered+ c <- reqUntil (return . isJust . (findCmd :: Char -> Maybe (Command a)))+ . prompt (show (allCommands :: [Command a]) ++ "> ") . liftM head $ reqResp `reqCont` return "!" -- bogus command+ -- Execute the selected command+ cmdFn ((fromJust $ findCmd c) :: Command a) inS++notEnough :: IO a+notEnough = fail "At least one item to rank must be provided"++-- | Run the program, given the items to rank+clMain :: (Show a, Eq a, Ord a) => [a] -> IO ()+clMain xs = do+ putStrLn "WARNING 1: This program does not have any save or export feature. You have to manually read and transfer the results."+ putStrLn "WARNING 2: If there are no more items to rank, the program immediately outputs a mapping from items to ranks, and then quits."+ putStrLn "Your scrollback buffer must be large enough."+ putStrLn ""+ execReq . reqIterate oneRound . pushAt id . MyState [] =<< maybe notEnough return (listToNonEmpty $ map (`AnnotatedItem` "") xs)
+ Hranker/Commands.hs view
@@ -0,0 +1,128 @@+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
+ Hranker/Rank.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances #-}+module Hranker.Rank+( highestRank+, indexToRank+, Rank+, rankToIndex+) where++import Control.Arrow (first)++newtype Rank = Rank { getRank :: Int } deriving (Enum, Eq, Ord)++instance Read Rank where+ -- Although this may look complicated, all it does is delegates to Read for Int and then converts the result+ readsPrec i = fmap (first Rank) . readsPrec i++instance Show Rank where+ show = show . getRank++-- | The highest possible rank. Ranks count upwards from this rank.+highestRank :: Rank+highestRank = Rank 1++-- | Convert a rank to a zero-based position in the list+rankToIndex :: Rank -> Int+rankToIndex r = getRank r - getRank highestRank++-- | Inverse function of rankToIndex+indexToRank :: Int -> Rank+indexToRank = Rank . (+ getRank highestRank)
+ Hranker/State.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances #-}+module Hranker.State +( AnnotatedItem(..)+, idS+, InputState+, MyState(..)+, OutputState+, validRank+) where++import Hranker.Rank (highestRank, Rank, rankToIndex)++import Data.List.NonEmpty (length', NonEmpty(..), nonEmptyToList)++-- | A possibly-annotated item to be ranked. Empty annotations are treated as no annotation.+data (Show a, Eq a, Ord a) => AnnotatedItem a+ = AnnotatedItem { item :: a+ , annotation :: String+ } deriving (Eq, Ord)++instance (Show a, Eq a, Ord a) => Show (AnnotatedItem a) where+ show (AnnotatedItem { annotation = "", item = i}) = show i+ show (AnnotatedItem { annotation = a , item = i}) = show i ++ " (" ++ a ++ ")"++-- | Program state+data (Show a, Eq a, Ord a) => MyState c a+ = MyState { ranked :: [[AnnotatedItem a]]+ , unranked :: c (AnnotatedItem a)+ }++-- | Input state of a command+type InputState = MyState NonEmpty++-- | Output state of a command+type OutputState = MyState []++-- | Turn an InputState into an OutputState+idS :: (Show a, Eq a, Ord a) => InputState a -> OutputState a+idS s = s { unranked = nonEmptyToList $ unranked s }++instance (Show a, Eq a, Ord a) => Show (InputState a) where+ show s = unlines $ "Rank:\tItem(s):" : zipWith showRank [highestRank..] (ranked s)+ ++ [ ""+ , show (length' $ unranked s) ++ " unranked items, starting with: " ++ show (neHead $ unranked s)+ ]++-- | (Show a, Eq a, Ord a) particular rank, given the rank number and the AnnotatedItems at that rank+showRank :: (Show a, Eq a, Ord a) => Rank -> [AnnotatedItem a] -> String+showRank rank ais = show rank ++ '\t' : show ais++-- | Is the given rank currently listed?+validRank :: (Show a, Eq a, Ord a) => MyState c a -> Rank -> Bool+validRank s r = rankToIndex r < length (ranked s) && r >= highestRank
hranker.cabal view
@@ -1,5 +1,5 @@ name: hranker-version: 0.1+version: 0.1.1 Cabal-Version: >= 1.6 synopsis: Basic utility for ranking a list of items description: A CLI utility for helping the user to rank a list of items in order.@@ -18,4 +18,5 @@ Executable hranker build-Depends: base, HCL >= 1.4, HCL < 1.5, NonEmpty >= 0.1, NonEmpty < 0.2 main-is: Hranker.hs+ other-modules: Hranker.Rank, Hranker.CommandLine, Hranker.State, Hranker.Commands ghc-options: -Wall -fno-warn-type-defaults