Finally fix up that useless EnclosingObject class and do it all with …

…taggedobject

yaifl/run_no

@@ -1 +1 @@
-751
+752

yaifl/src/Yaifl.hs

@@ -39,7 +39,6 @@ import Yaifl.Model.Metadata
 import Yaifl.Model.Kinds.Direction
 import Yaifl.Model.Entity
 import Yaifl.Game.ObjectSpecifics
-import Yaifl.Game.Create.Object
 import Yaifl.Model.Kinds.Container
 import Yaifl.Model.Kinds.Door
 import Yaifl.Model.Kinds.Enclosing

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

@@ -4,7 +4,6 @@ module Yaifl.Game.Actions.Closing where
 import Yaifl.Model.Action
 import Yaifl.Prelude
 import Yaifl.Model.Actions.Args
-import Yaifl.Model.Action
 import Yaifl.Model.HasProperty
 import Yaifl.Model.Kinds.Openable
 import Yaifl.Model.Rules.Rulebook

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

@@ -140,7 +140,7 @@ examineContainers = Rule "examine containers rule" forPlayer' $ \a@Args{..} -> d
     -- if the noun is closed and the noun is opaque, make no decision;
     flip (maybe (return (Nothing, Nothing))) (getContainerMaybe =<< o) $ \cont -> do
       p <- getPlayer
-      playerInObject <- enclosingContains (tag (cont ^. #enclosing) obj) p
+      playerInObject <- enclosingContains (tagEntity (cont ^. #enclosing) obj) p
       if isOpaqueClosedContainer cont then return (Nothing, Nothing) else do
         -- if something described which is not scenery is in the noun and something which
         -- is not the player is in the noun and the noun is not falsely-unoccupied:

yaifl/src/Yaifl/Game/Actions/GettingOff.hs

@@ -9,12 +9,10 @@ import Yaifl.Text.Say
 import Yaifl.Model.Kinds.Thing ( thingContainedBy )
 import Yaifl.Model.HasProperty
 import Yaifl.Model.Kinds.Enclosing
-import Yaifl.Model.Kinds.Container
-import Yaifl.Model.Tag
+import Yaifl.Model.Tag ( getTaggedObject, tagObject )
 import Yaifl.Model.Kinds.Supporter
 import Yaifl.Game.Move (move)
 import Yaifl.Model.Query
-import Yaifl.Model.Entity
 import Yaifl.Model.Metadata
 import Yaifl.Text.AdaptiveNarrative
 import Yaifl.Text.Verb (Tense(..))
@@ -23,7 +21,7 @@ data GettingOffResponses wm
 
 type GettingOffAction wm = Action wm () ('TakesOneOf 'TakesThingParameter 'TakesNoParameter) (SupporterThing wm)
 
-gettingOffAction :: forall wm. (WithPrintingNameOfSomething wm, WMWithProperty wm Enclosing, WMWithProperty wm Container, WMWithProperty wm Supporter) => GettingOffAction wm
+gettingOffAction :: forall wm. (WithPrintingNameOfSomething wm, WMWithProperty wm Enclosing, WMWithProperty wm Supporter) => GettingOffAction wm
 gettingOffAction = (makeAction "getting off")
   { name = "getting off"
   , understandAs = ["get off", "get up"]
@@ -67,7 +65,7 @@ standardGettingOff ::
 standardGettingOff = makeRule "standard getting off rule" [] $ \Args{source=s, variables=v} -> do
   let supporterHolder = thingContainedBy (getTaggedObject v)
   e' <- getEnclosingObject supporterHolder
-  move s (tagObject @_ @EnclosingTag (snd e') (fst e'))
+  move s e'
   rulePass
 
 reportGettingOff ::

yaifl/src/Yaifl/Game/Actions/Going.hs

@@ -149,13 +149,13 @@ goingActionSet (UnverifiedArgs Args{..}) = do
     -- if the noun is a door, let the target be the noun;
     -- now the door gone through is the target;
     -- now the target is the other side of the target from the room gone from;
-    Just (Right door) -> pure $ (\ds -> getConnectionViaDoor (tag ds (getID door)) roomGoneFrom) =<< getDoorMaybe door
+    Just (Right door) -> pure $ (\ds -> getConnectionViaDoor (tagEntity ds (getID door)) roomGoneFrom) =<< getDoorMaybe door
     Nothing -> do
       mbThrough <- getMatchingThing "through"
       pure $ do
             door <- mbThrough
             ds <- getDoorMaybe door
-            getConnectionViaDoor (tag ds (getID door)) roomGoneFrom
+            getConnectionViaDoor (tagEntity ds (getID door)) roomGoneFrom
   case mbTargetAndConn of
     Nothing -> flip (cantGoThatWay source) roomGoneFrom =<< getMatchingThing "through"
     Just (target, conn) -> do
@@ -269,20 +269,19 @@ inTheRegion r = Precondition (lookupRegion r >>= \(Right o) -> pure $ "in the re
 -}
 throughTheDoor ::
   forall d wm.
-  TaggedAs d DoorTag
+  HasID d
   => d
   -> Precondition wm (Args wm (GoingActionVariables wm))
-throughTheDoor d = Precondition (pure "through a specific door") $ \v -> pure $ (getID <$> doorGoneThrough (variables v)) == Just (getID $ toTag @d @DoorTag d)
+throughTheDoor d = Precondition (pure "through a specific door") $ \v -> pure $ (getID <$> doorGoneThrough (variables v)) == Just (getID d)
 
 throughTheClosedDoor ::
   forall d wm.
-  TaggedAs d DoorTag
-  => WMWithProperty wm Openability
+  WMWithProperty wm Openability
   => ThingLike wm d
   => d
   -> Precondition wm (Args wm (GoingActionVariables wm))
 throughTheClosedDoor d = Precondition (pure "through a specific closed door") $ \v -> do
   o <- getThing d
   pure $
     isClosed o &&
-    (getID <$> doorGoneThrough (variables v)) == Just (getID $ toTag @d @DoorTag d)
+    (getID <$> doorGoneThrough (variables v)) == Just (getID d)

yaifl/src/Yaifl/Game/Actions/Looking/Visibility.hs

@@ -18,11 +18,9 @@ import Yaifl.Model.HasProperty
 import Yaifl.Model.Query
 import Yaifl.Model.Kinds.Supporter
 import Yaifl.Model.WorldModel
-import Yaifl.Model.Actions.Args
 import qualified Data.EnumSet as DES
 import Yaifl.Model.Kinds.AnyObject
 import Yaifl.Model.Metadata
-import Yaifl.Text.Say
 
 -- | An easier way to describe the requirements to look.
 type HasLookingProperties wm =

yaifl/src/Yaifl/Game/Create/Object.hs

@@ -95,7 +95,7 @@ addObject updWorld n d ty isT specifics details mbLocation =
             Just loc -> do
               encLoc <- getObject loc
               asThingOrRoom
-                (void . move @_ @_ @(EnclosingThing wm) t . tagObject @EnclosingEntity @EnclosingTag loc)
+                (void . move @(EnclosingThing wm) @_ @_ t . tagObject @EnclosingEntity @EnclosingTag loc)
                 (void . move t)
                 encLoc
         )
@@ -116,7 +116,7 @@ addThingInternal ::
 addThingInternal name ia desc objtype specifics details mbLoc = do
   t <- Thing <$> addObject (setThing . Thing) name desc objtype
         True specifics (fromMaybe (blankThingData ia) details) mbLoc
-  pure (tagThing t)
+  pure (tagThingEntity t)
 
 addThing ::
   forall wm es.

yaifl/src/Yaifl/Game/Create/RoomConnection.hs

@@ -48,7 +48,6 @@ import Yaifl.Model.Rules (RuleEffects)
 import Yaifl.Prelude hiding (Down)
 import Yaifl.Model.Kinds.Supporter (SupporterEntity)
 import Yaifl.Game.Move (move)
-import Yaifl.Model.Tag
 import Yaifl.Model.Kinds.Enclosing
 
 getAllConnections ::
@@ -275,6 +274,5 @@ isNowOn ::
   -> Eff es ()
 isNowOn t e = do
   t' <- getThing t
-  e' <- getEnclosingObject (coerceTag e)
-  let e'' = TaggedObject (coerceTag @_ @EnclosingTag e, fst e')
-  void $ move t' e''
+  e' <- getEnclosingObject e
+  void $ move t' e'

yaifl/src/Yaifl/Game/Create/Rule.hs

@@ -18,10 +18,8 @@ import Yaifl.Prelude
 import Yaifl.Model.Action ( Action, WorldActions )
 import Yaifl.Game.Actions.Collection (ActionCollection)
 import Yaifl.Model.Kinds.Object
-import Yaifl.Model.Entity
 import Yaifl.Model.ObjectLike
 import Yaifl.Model.Query
-import Yaifl.Model.Tag
 import Yaifl.Model.Actions.Args
 import Yaifl.Model.Rules.Rulebook
 import Yaifl.Model.Rules.RuleEffects
@@ -112,8 +110,8 @@ theObject' o = Precondition
   }
 
 whenIn ::
-  TaggedAs e EnclosingTag
-  => ObjectLike wm e
+  ObjectLike wm e
+  => IsEnclosing e
   => e
   -> Precondition wm (Args wm v)
 whenIn e = Precondition
@@ -122,12 +120,12 @@ whenIn e = Precondition
       pure $ "when in the location " <> display (e' ^. #name)
   , checkPrecondition = \args -> do
       hierarchy <- getContainingHierarchy (args ^. #source)
-      pure $ elem (toTag e) hierarchy
+      pure $ elem (getEnclosingEntity e) hierarchy
   }
 
 whenPlayerIsIn ::
-  TaggedAs e EnclosingTag
-  => ObjectLike wm e
+  ObjectLike wm e
+  => IsEnclosing e
   => e
   -> Precondition wm a
 whenPlayerIsIn e = Precondition
@@ -136,7 +134,7 @@ whenPlayerIsIn e = Precondition
       pure $ "when in the location " <> display (e' ^. #name)
   , checkPrecondition = const $ do
       hierarchy <- getPlayer' >>= getContainingHierarchy
-      pure $ elem (toTag e) hierarchy
+      pure $ elem (getEnclosingEntity e) hierarchy
   }
 
 aKindOf ::

yaifl/src/Yaifl/Game/Move.hs

@@ -21,12 +21,13 @@ import qualified Data.EnumSet as ES
 import Yaifl.Model.Kinds.AnyObject
 
 move ::
+  forall l wm es.
   Breadcrumbs :> es
   => State Metadata :> es
   => ObjectQuery wm es
   => Display (WMText wm)
   => WMWithProperty wm Enclosing
-  => EnclosingObject l
+  => IsEnclosingObject l
   => ObjectLike wm l
   => Thing wm
   -> l
@@ -35,16 +36,17 @@ move objectToMove oLoc = failHorriblyIfMissing moveBlock
   where
     moveBlock = withSpan' "move" "" $ do
       objectToMove' <- refreshThing objectToMove
-      let loc :: Enclosing = oLoc ^. enclosingL
+      let loc :: Enclosing = getEnclosing oLoc
       let (c :: EnclosingEntity) = thingContainedBy objectToMove'
       c' <- getObject c
       oLoc' <- getObject oLoc
-      let (oldLocEnc :: Enclosing) = getEnclosing c c'
+      let (taggedEnc :: TaggedAnyEnclosing wm) = tagObject c c'
+      let (oldLocEnc :: Enclosing) = getEnclosing taggedEnc
       addTag "object to move" (display $ objectToMove')
       addTag "current location" (display $ c')
       addTag "new location" (display $ oLoc')
       modifySpan (\s -> s { _spanName = display (objectToMove' ^. #name) })
-      let (movedObj, oldLocation, newLocation) = moveObjects (tag oldLocEnc (getID oLoc')) objectToMove' oldLocEnc loc
+      let (movedObj, oldLocation, newLocation) = moveObjects (tagEntity oldLocEnc (getID oLoc')) objectToMove' oldLocEnc loc
       setThing movedObj
       setEnclosing c' oldLocation
       setEnclosing oLoc' newLocation
@@ -54,9 +56,9 @@ move objectToMove oLoc = failHorriblyIfMissing moveBlock
 moveObjects :: EnclosingEntity -> Thing wm -> Enclosing -> Enclosing -> (Thing wm, Enclosing, Enclosing)
 moveObjects newId t oldLoc newLocEncl = let (newLoc', t') = nowContains newId newLocEncl t in (t', oldLoc `noLongerContains` t, newLoc')
 noLongerContains :: Enclosing -> Thing wm -> Enclosing
-noLongerContains cont obj = cont & (#contents %~ ES.delete (tagThing obj))
+noLongerContains cont obj = cont & (#contents %~ ES.delete (tagThingEntity obj))
 nowContains :: EnclosingEntity -> Enclosing -> Thing wm -> (Enclosing, Thing wm)
-nowContains contId cont obj = (cont & (#contents %~ ES.insert (tagThing obj)), obj & (#objectData % #containedBy .~ contId))
+nowContains contId cont obj = (cont & (#contents %~ ES.insert (tagThingEntity obj)), obj & (#objectData % #containedBy .~ contId))
 
 updateToContain ::
   NoMissingObjects wm es
@@ -66,4 +68,4 @@ updateToContain ::
   -> Thing wm
   -> Eff es ()
 updateToContain cont enc obj = do
-  setEnclosing cont (enc & (#contents %~ ES.insert (tagThing obj)))
+  setEnclosing cont (enc & (#contents %~ ES.insert (tagThingEntity obj)))

yaifl/src/Yaifl/Game/ObjectSpecifics.hs

@@ -148,9 +148,9 @@ addDoor n (arg #front -> f) (arg #back -> b) ia des (argDef #described Described
       -- A door is always fixed in place.
       -- A door is never pushable between rooms.
   updateMultiLocatedObject d
-  let tagged = tag @Door @DoorTag ds d
+  let tagged = tagEntity @Door @DoorTag ds d
   addDoorToConnection tagged f b
-  pure (tag ds d)
+  pure (tagEntity ds d)
 
 addBackdrop ::
   forall wm es.
@@ -194,9 +194,9 @@ updateMultiLocatedObject tl = do
   case getMultiLocatedMaybe t of
     Nothing -> noteError (const ()) "the object had no multilocated component"
     Just ml -> mapM_ (\x -> do
-      obj <- getObject x
-      let enc = getEnclosing x obj
-      updateToContain obj enc t) (S.toList $ ml ^. #locations)
+      obj <- getEnclosingObject x
+      let enc = getEnclosing obj
+      updateToContain (getTaggedObject obj) enc t) (S.toList $ ml ^. #locations)
 
 addDevice ::
   forall wm es.
@@ -247,7 +247,7 @@ addContainer n ia d
         ! paramF #portable p
         ! paramF #modify m
         ! done
-    pure $ tag @Container @ContainerTag cs c
+    pure $ tagEntity @Container @ContainerTag cs c
 
 addSupporter ::
   forall wm es.
@@ -272,7 +272,7 @@ addSupporter n ia d
         ! paramF #location l
         ! paramF #modify m
         ! done
-    pure $ tag @_ @SupporterTag sup c
+    pure $ tagEntity @_ @SupporterTag sup c
 
 addPerson ::
   forall wm es.

yaifl/src/Yaifl/Game/Parser.hs

@@ -292,10 +292,10 @@ tryFindingObject t = failHorriblyIfMissing $ do
           (const $ return $ (obj, enc))
           obj
 
-  (playerLocObj, domainEnc) <- getUppermostDomain =<< getEnclosingObject (thingContainedBy pl)
+  (playerLocObj, domainEnc) <- (\t -> getUppermostDomain (getTaggedObject t, getEnclosing t)) =<< getEnclosingObject (thingContainedBy pl)
   -- okay, if we bother doing a proper scanning loop it'll go here
   -- but for now, we just want to consider anything recursively present. that'll do.
-  allItems <- getAllObjectsInEnclosing IncludeScenery IncludeDoors (tag domainEnc playerLocObj)
+  allItems <- getAllObjectsInEnclosing IncludeScenery IncludeDoors (tagEntity domainEnc playerLocObj)
   findObjectsFrom t allItems True
 
 

yaifl/src/Yaifl/Model/Actions/Args.hs

@@ -26,7 +26,6 @@ module Yaifl.Model.Actions.Args
 
 import Yaifl.Prelude hiding (show)
 
-import Yaifl.Model.ObjectLike
 import Yaifl.Model.Kinds.Object
 import Yaifl.Model.WorldModel
 import Yaifl.Model.Effects
@@ -157,7 +156,7 @@ instance Display (Args wm v) where
 instance {-# OVERLAPPING #-} Refreshable wm v => Refreshable wm (Args wm v) where
   refresh av = do
     v <- refresh (variables av)
-    o <- getThing (tagThing $ source av)
+    o <- refresh $ source av
     return $ av { source = o, variables = v }
 
 -- | Before 'Args' are parsed, the variable is just a command string

yaifl/src/Yaifl/Model/Entity.hs

@@ -47,17 +47,17 @@ instance HasID Entity where
 instance Display Entity where
   displayBuilder i = "(ID: " <> show i <> ")"
 
--- | An entity tagged with a phantom @tag@ for keeping some semblance of type safety
+-- | An entity tagged with a phantom @tagEntity@ for keeping some semblance of type safety
 -- when indirectly storing references to other objects. The tagging mechanisms are in
 -- @Yaifl.Model.Objects.Tag@.
-newtype TaggedEntity tag = TaggedEntity { unTag :: Entity }
+newtype TaggedEntity tagEntity = TaggedEntity { unTag :: Entity }
   deriving stock (Show, Generic)
   deriving newtype (Eq, Num, Read, Bounded, Hashable, Enum, Ord, Real, Integral)
 
 -- | Tag an entity without a witness.
 unsafeTagEntity ::
-  Entity -- ^ Entity to tag
-  -> TaggedEntity tag
+  Entity -- ^ Entity to tagEntity
+  -> TaggedEntity tagEntity
 unsafeTagEntity = TaggedEntity
 
 instance HasID (TaggedEntity t) where

yaifl/src/Yaifl/Model/Kinds/AnyObject.hs

@@ -58,15 +58,7 @@ instance CanBeAny wm (AnyObject wm) where
   toAny = id
   fromAny = Just
 
-instance CanBeAny wm (TaggedObject (Thing wm) ThingTag) where
-  toAny = toAny . snd . unTagObject
-  fromAny o = (\t -> TaggedObject (tag t (getID t), t)) <$> fromAny o
-
-instance CanBeAny wm (TaggedObject (Room wm) RoomTag) where
-  toAny = toAny . snd . unTagObject
-  fromAny o = (\t -> TaggedObject (tag t (getID t), t)) <$> fromAny o
-
 instance IsObject (AnyObject wm) where
   isThing = isJust . fromAny @wm @(Thing wm)
 
-type TaggedAnyEnclosing wm = TaggedObject (AnyObject wm) EnclosingTag
+type TaggedAnyEnclosing wm = TaggedObject (AnyObject wm) EnclosingTag

yaifl/src/Yaifl/Model/Kinds/Container.hs

@@ -39,7 +39,7 @@ import Yaifl.Model.HasProperty ( WMWithProperty )
 import Yaifl.Model.Kinds.AnyObject
 import Yaifl.Model.Kinds.Enclosing
 import Yaifl.Model.Kinds.Openable
-import Yaifl.Model.Query ( defaultPropertySetter, defaultPropertyGetter, modifyProperty, ObjectLike (..) )
+import Yaifl.Model.Query ( defaultPropertySetter, defaultPropertyGetter, modifyProperty, ObjectLike (..), IsEnclosing )
 import Yaifl.Model.TH ( makeSpecificsWithout )
 import Yaifl.Model.Tag
 import Yaifl.Model.Kinds.Object
@@ -167,11 +167,4 @@ instance Taggable ContainerEntity EnclosingTag
 instance Taggable Container EnclosingTag
 instance Taggable Container ContainerTag
 
-instance TaggedAs (TaggedContainer wm) ContainerTag where
-  toTag = fst . unTagObject
-
-instance TaggedAs (TaggedContainer wm) EnclosingTag where
-  toTag = coerceTag . fst . unTagObject
-
-instance TaggedAs (TaggedEntity ContainerTag) EnclosingTag where
-  toTag = coerceTag
+instance IsEnclosing ContainerEntity