align entities to factions

1 files changed, 20 insertions, 4 deletions

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