Move WMWithProperty to a better location, properly handle match words

Author: PPKFS

yaifl/run_no

@@ -1 +1 @@
-808
+815

yaifl/src/Yaifl/Core/Action.hs

@@ -25,6 +25,9 @@ module Yaifl.Core.Action
   , withActionInterrupt'
 
   , oneTouchableThing
+
+  , getMatchingThing
+  , getMatching
   ) where
 
 import Yaifl.Prelude hiding (Reader)
@@ -44,6 +47,8 @@ import Yaifl.Core.Rules.RuleEffects
 import Yaifl.Core.Refreshable
 import Yaifl.Text.Say
 
+import Yaifl.Core.Query.Object
+
 type ParseArgumentEffects wm es = (WithMetadata es, NoMissingObjects wm es, RuleEffects wm es)
 
 data ParseArgumentResult wm v =
@@ -171,4 +176,17 @@ oneTouchableThing ::
   ArgsHaveMainObject (Args wm v) (Thing wm)
   => Args wm v
   -> [Thing wm]
-oneTouchableThing a = one $ view argsMainObject a
+oneTouchableThing a = one $ view argsMainObject a
+
+getMatchingThing :: RuleEffects wm es => Text -> UnverifiedArgs wm params -> Eff es (Maybe (Thing wm))
+getMatchingThing matchElement args = do
+  e <- getMatching matchElement args
+  case e of
+    Just (ObjectParameter o) -> getThingMaybe o
+    Just (ThingParameter t) -> return (Just t)
+    _ -> return Nothing
+
+getMatching :: Text -> UnverifiedArgs wm params -> Eff es (Maybe (NamedActionParameter wm))
+getMatching matchElement (UnverifiedArgs args) = do
+  let mbMatch = args ^? #variables % _2 % to (find ((== matchElement) . fst) ) % _Just % _2
+  return mbMatch

yaifl/src/Yaifl/Core/HasProperty.hs

@@ -10,9 +10,12 @@ Optics for accessing a property from the sum type of object specifics.
 module Yaifl.Core.HasProperty (
   -- * Has
     MayHaveProperty(..)
+  , HasProperty(..)
+  , WMWithProperty
   ) where
 
 import Yaifl.Prelude
+import Yaifl.Core.WorldModel
 
 -- | An `AffineTraversal` is an optic that focuses on 0-1 objects; it's a `Prism` without
 -- the condition that you can build it back up again..which works great for the possibility
@@ -36,4 +39,11 @@ instance MayHaveProperty a v => MayHaveProperty (Maybe a) v where
       Just y -> Right y)
     (\case
       Nothing -> const Nothing
-      Just a -> \v -> Just $ a & propertyAT .~ v)
+      Just a -> \v -> Just $ a & propertyAT .~ v)
+
+type WMWithProperty wm v = MayHaveProperty (WMObjSpecifics wm) v
+
+class HasProperty w o v where
+  propertyL :: w -> Lens' o v
+  default propertyL :: MayHaveProperty o v => w -> Lens' o v
+  propertyL _ = lens (fromMaybe (error "property witness was violated") . preview propertyAT) (flip (set propertyAT))

yaifl/src/Yaifl/Core/ObjectLike.hs

@@ -43,10 +43,10 @@ class HasID o => RoomLike wm o where
 instance (ObjectLike wm o) => ObjectLike wm (TaggedObject o tagEntity) where
   getObject = getObject . unTagObject
 
-instance (RoomLike wm o) => RoomLike wm (TaggedObject o tagEntity) where
+instance {-# OVERLAPPABLE #-} (RoomLike wm o) => RoomLike wm (TaggedObject o tagEntity) where
   getRoom = getRoom . snd . unTagObject
 
-instance (ThingLike wm o) => ThingLike wm (TaggedObject o tagEntity) where
+instance {-# OVERLAPPABLE #-} (ThingLike wm o) => ThingLike wm (TaggedObject o tagEntity) where
   getThing = getThing . snd . unTagObject
 
 instance ObjectLike wm (Thing wm) where
@@ -74,10 +74,10 @@ instance ObjectLike wm (TaggedEntity anyTag) where
   getObject e = getObject (unTag e)
 
 instance ThingLike wm DoorEntity where
-  getThing = getThing . coerceTag @_ @ThingTag
+  getThing = getThing . coerceTag @ThingTag
 
 instance ThingLike wm PersonEntity where
-  getThing = getThing . coerceTag @_ @ThingTag
+  getThing = getThing . coerceTag @ThingTag
 
 instance ObjectLike wm Entity where
   getObject e = if isThing (getID e)
@@ -87,6 +87,12 @@ instance ObjectLike wm Entity where
 instance ObjectLike wm o => ObjectLike wm (TaggedEntity e, o) where
   getObject = getObject . snd
 
+instance ThingLike wm (TaggedObject (Thing wm) o) where
+  getThing = pure . snd . unTagObject
+
+instance RoomLike wm (TaggedObject (Room wm) o) where
+  getRoom = pure . snd . unTagObject
+
 objectIsKind ::
   NoMissingObjects wm es
   => ObjectLike wm o

yaifl/src/Yaifl/Core/Query/Enclosing.hs

@@ -30,9 +30,9 @@ import Yaifl.Core.Kinds.Thing
 import Yaifl.Core.ObjectLike
 import Yaifl.Core.Query.Property
 import Yaifl.Core.Tag
-import Yaifl.Core.WorldModel
 import Yaifl.Core.Query.Object
 import qualified Data.EnumSet as ES
+import Yaifl.Core.HasProperty
 
 data IncludeScenery = IncludeScenery | ExcludeScenery
 data IncludeDoors = IncludeDoors | ExcludeDoors

yaifl/src/Yaifl/Core/Tag.hs

@@ -82,6 +82,7 @@ instance Taggable (TaggedEntity PersonTag) ThingTag
 -- | If we can tagEntity a `TaggedEntity a` as a @b@, we can just coerce the entity
 -- rather than passing it twice.
 coerceTag ::
+  forall b a.
   Taggable (TaggedEntity a) b
   => TaggedEntity a
   -> TaggedEntity b

yaifl/src/Yaifl/Core/WorldModel.hs

@@ -28,11 +28,9 @@ module Yaifl.Core.WorldModel (
   , WMOrd
   , WMEq
 
-  , WMWithProperty
   ) where
 
 import Yaifl.Prelude
-import Yaifl.Core.HasProperty
 
 -- | All the various type parameters wrapped into a single type.
 -- This allows us to tie the knot in some weird way - we need some way to refer
@@ -102,7 +100,4 @@ type WMRead wm = WMConstr Read wm
 -- | Constraint that object specifics, values, and directions are Ordable.
 type WMOrd wm = WMConstr Ord wm
 -- | Constraint that object specifics, values, and directions are Eqable.
-type WMEq wm = WMConstr Eq wm
-
--- | A helper to define that a world model @wm@ has a Property.
-type WMWithProperty wm v = MayHaveProperty (WMObjSpecifics wm) v
+type WMEq wm = WMConstr Eq wm

yaifl/src/Yaifl/Std/Actions/Closing.hs

@@ -7,6 +7,7 @@ import Yaifl.Std.Actions.Imports
 import Yaifl.Std.Kinds.Openable
 import Yaifl.Core.Metadata
 import Yaifl.Core.Kinds.Thing
+import Yaifl.Core.HasProperty
 
 data ClosingResponses wm =
     CloseReportA

yaifl/src/Yaifl/Std/Actions/Entering.hs

@@ -24,6 +24,7 @@ import Yaifl.Core.Kinds.Object
 import Yaifl.Core.Query.Enclosing
 import Yaifl.Core.Rules.RuleEffects
 import Yaifl.Std.Kinds.Door
+import Yaifl.Core.HasProperty
 
 data EnteringResponses wm =
     EnterAlreadyEnteredA
@@ -63,7 +64,7 @@ enteringAction = (makeAction "entering")
       case mbCont of
         Nothing ->
           case mbDoor of
-            Just door -> return $ ConversionTo "go" [ThingParameter (fst variables)]
+            Just _door -> return $ ConversionTo "go" [ThingParameter (fst variables)]
             Nothing -> return $ FailedParse "That's not enterable."
         Just x -> return $ SuccessfulParse (tagObject x (fst variables))
   , beforeRules = makeActionRulebook "before entering rulebook" []

yaifl/src/Yaifl/Std/Actions/Examining.hs

@@ -19,6 +19,7 @@ import Yaifl.Core.ObjectLike
 import qualified Data.EnumSet as ES
 import Yaifl.Core.Kinds.Object
 import Yaifl.Std.Kinds.Person
+import Yaifl.Core.HasProperty
 
 data ExaminingResponses =
   ExamineDirectionA