align entities to factions

2 files changed, 26 insertions, 5 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 639673c..903da05 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -46,6 +46,7 @@ main = do
                                     , cmd "factions" listFactions "List all inhabited factions"
                                     , cmd "members" listFaction "List all members of a faction"
                                     , cmd "entities" listEntities "List all entities"
+                                    , cmd "align" alignEntity "Align an entity to a faction creating it, if necessary"
                                     ]
                   }
   void $ runShell description haskelineBackend (def :: GameState)
@@ -68,10 +69,14 @@ stateOutline st
       return . colsAllG top $ [show (seqVal' ^. seqVal)] : map factionColumn [0..(length factions - 1)]
 
 listFaction :: Completable Faction -> Sh GameState ()
-listFaction (Completable (flip (set faction') def -> qFaction)) = use gEntities >>= mapM_ (shellPutStrLn <=< toName) . Map.keys . Map.filter ((==) qFaction . view eFaction)
+listFaction = withArg $ \qFaction -> use gEntities >>= mapM_ (shellPutStrLn <=< toName) . Map.keys . Map.filter ((==) qFaction . view eFaction)
 
 listFactions :: Sh GameState ()
 listFactions = use inhabitedFactions >>= mapM_ (shellPutStrLn . view faction')
 
 listEntities :: Sh GameState ()
 listEntities = use (gEntities . to Map.keys) >>= mapM_ (shellPutStrLn <=< toName)
+
+alignEntity :: Completable EntityIdentifier -> Completable Faction -> Sh GameState ()
+alignEntity ident' nFaction' = flip withArg nFaction' $ \nFaction -> flip withArg ident' $ \ident -> do
+  gEntities %= Map.adjust (set eFaction nFaction) ident
diff --git a/src/Sequence/Utils.hs b/src/Sequence/Utils.hs
index 7d28b83..aa92081 100644
--- a/src/Sequence/Utils.hs
+++ b/src/Sequence/Utils.hs
@@ -1,7 +1,7 @@
-{-# LANGUAGE ViewPatterns, FlexibleContexts, MultiParamTypeClasses #-}
+{-# LANGUAGE ViewPatterns, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-}
 
 module Sequence.Utils
-  ( toName, fromName
+  ( withArg, toName, fromName
   ) where
 
 import Sequence.Types
@@ -22,11 +22,21 @@ import qualified Data.Map.Strict as Map
 import Data.Function
 import Data.Default
 import Data.Maybe
-import Text.Read
+import Text.Read (readMaybe)
 
 import Data.List
 
 import System.Console.Shell
+import System.Console.Shell.ShellMonad
+
+
+class Argument a st | a -> st where
+  arg :: String -> Sh st (Maybe a)
+
+withArg :: Argument a st => (a -> Sh st ()) -> (Completable a -> Sh st ())
+withArg f (Completable str) = arg str >>= \a -> case a of
+  Nothing -> shellPutErrLn $ "Could not parse ‘" ++ str ++ "’"
+  Just a  -> f a
 
 unaligned = view faction' def
   
@@ -34,13 +44,19 @@ toName :: MonadState GameState m => EntityIdentifier -> m String
 toName id = fromMaybe (show $ id ^. entityId) . fmap (CI.original . view entityName) . Bimap.lookup id <$> use gEntityNames
 
 fromName :: MonadState GameState m => String -> m (Maybe EntityIdentifier)
-fromName (readMaybe -> n@(Just _)) = return $ EntityIdentifier <$> n
+fromName (readMaybe -> (Just (EntityIdentifier -> n))) = (n <$) . guard . Map.member n <$> use gEntities
 fromName (EntityName . CI.mk -> name) = Bimap.lookupR name <$> use gEntityNames
 
 instance Completion EntityIdentifier GameState where
   completableLabel _ = "<entity>"
   complete _ st prefix = return . filter ((isPrefixOf `on` CI.foldCase) prefix) . map ((evalState ?? st) . toName) . Map.keys $ st ^. gEntities
 
+instance Argument EntityIdentifier GameState where
+  arg = fromName
+
 instance Completion Faction GameState where
   completableLabel _ = "<faction>"
   complete _ st prefix = return . filter ((isPrefixOf `on` CI.foldCase) prefix) . nub . sort $ unaligned : map (view faction') (st ^. inhabitedFactions)
+
+instance Argument Faction GameState where
+  arg = return . Just . flip (set faction') def