Do a lot of fiddling to make stuff less depending on Eff es

src/Yaifl.hs

@@ -68,13 +68,13 @@ type PlainWorldModel = 'WorldModel ObjectSpecifics Direction () () ActivityColle
  -- toTextDir = toTextDir
 
 type HasStandardProperties s = (
-  WMHasProperty s Enclosing
-  , WMHasProperty s Container
-  , WMHasProperty s Enterable
-  , WMHasProperty s Openable
+  WMWithProperty s Enclosing
+  , WMWithProperty s Container
+  , WMWithProperty s Enterable
+  , WMWithProperty s Openable
   , HasLookingProperties s
   , WMStdDirections s
-  , WMHasProperty s DoorSpecifics
+  , WMWithProperty s DoorSpecifics
   , HasDirectionalTerms s
   , Pointed (WMObjSpecifics s)
   )

src/Yaifl/Actions/Going.hs

@@ -45,7 +45,7 @@ data GoingActionVariables wm = GoingActionVariables
   } deriving stock ( Generic )
 
 goingAction ::
-  (WMStdDirections wm, WMHasProperty wm DoorSpecifics, WMHasProperty wm Enclosing)
+  (WMStdDirections wm, WMWithProperty wm DoorSpecifics, WMWithProperty wm Enclosing)
   => WithPrintingNameOfSomething wm
   => Action wm (GoingActionVariables wm)
 goingAction = Action
@@ -69,7 +69,7 @@ describeRoomGoneInto = makeRule "describe room gone into rule" [] $ \a -> ifM
   (error "other actors cant report going yet")
 
 
-carryOutGoingRules :: WMHasProperty wm Enclosing => ActionRulebook wm (GoingActionVariables wm)
+carryOutGoingRules :: WMWithProperty wm Enclosing => ActionRulebook wm (GoingActionVariables wm)
 carryOutGoingRules = makeActionRulebook "carry out going rulebook"
   [ movePlayerAndVehicle
   , moveFloatingObjects
@@ -82,7 +82,7 @@ checkLightInNewLocation = notImplementedRule "check light in new location rule"
 moveFloatingObjects :: Rule wm (Args wm (GoingActionVariables wm)) Bool
 moveFloatingObjects = notImplementedRule "move floating objects rule"
 
-movePlayerAndVehicle :: WMHasProperty wm Enclosing => Rule wm (Args wm (GoingActionVariables wm)) Bool
+movePlayerAndVehicle :: WMWithProperty wm Enclosing => Rule wm (Args wm (GoingActionVariables wm)) Bool
 movePlayerAndVehicle = makeRule "move player and vehicle rule" [] $ \a@Args{variables=v} -> do
   moveSuccessful <- case vehicleGoneBy v of
     Nothing -> move (source a) (roomGoneTo v)
@@ -91,7 +91,7 @@ movePlayerAndVehicle = makeRule "move player and vehicle rule" [] $ \a@Args{vari
 
 goingActionSet ::
   forall wm es.
-  (ParseArgumentEffects wm es, WMStdDirections wm, WMHasProperty wm DoorSpecifics)
+  (ParseArgumentEffects wm es, WMStdDirections wm, WMWithProperty wm DoorSpecifics)
   => WithPrintingNameOfSomething wm
   => UnverifiedArgs wm
   -> Eff es (ArgumentParseResult (GoingActionVariables wm))
@@ -124,8 +124,9 @@ goingActionSet (UnverifiedArgs Args{..}) = do
     NoParameter -> do
       mbThrough <- getMatchingThing "through"
       -- TODO: this should be a door or complain
-      mbDoor <- join <$> traverse getDoorSpecificsMaybe mbThrough
-      pure $ backSide <$> mbDoor
+      --mbDoor <- join <$> traverse getDoorSpecificsMaybe mbThrough
+      --pure $ backSide <$> mbDoor
+      error "aaaaa door"
     ConstantParameter t -> error $ "got a " <> t
   mbRoomGoneTo <- join <$> traverse getRoomMaybe target
   addAnnotation $ "target was " <> show target

src/Yaifl/Actions/Looking/Visibility.hs

@@ -6,7 +6,6 @@ import Solitude
 
 import Breadcrumbs ( addAnnotation )
 import Yaifl.Activities.Activity (WithPrintingNameOfADarkRoom, WithPrintingDescriptionOfADarkRoom)
-import Yaifl.Model.Entity
 import Yaifl.Model.Object
 import Yaifl.Model.Objects.Query
 import Yaifl.Model.Objects.RoomData
@@ -28,7 +27,7 @@ import Yaifl.Model.Objects.ObjectLike
 
 -- | An easier way to describe the 3 requirements to look.
 type HasLookingProperties wm =
-  (WMHasProperty wm Enclosing, WMHasProperty wm Enterable, WMHasProperty wm Container
+  (WMWithProperty wm Enclosing, WMWithProperty wm Enterable, WMWithProperty wm Container
   , Display (WMSayable wm)
   , IsString (WMSayable wm)
   , WithPrintingNameOfADarkRoom wm
@@ -78,13 +77,10 @@ getVisibilityLevels e = do
 findVisibilityHolder ::
   NoMissingObjects wm es
   => HasLookingProperties wm
-  => CanBeAny wm o
-  => ObjectLike wm o
-  => o
+  => AnyObject wm
   -> Eff es (AnyObject wm)
-findVisibilityHolder e' = do
-  obj <- getObject e'
-  mCont <- getContainerMaybe e'
+findVisibilityHolder obj = do
+  let mCont = getContainerMaybe obj
   let n = obj ^. #name
   case (tagObject obj, isOpaqueClosedContainer <$?> mCont) of
     -- a nonopaque or open container thing
@@ -94,8 +90,7 @@ findVisibilityHolder e' = do
     _ -> do
       addAnnotation $ "The visibility holder of " <> display n <> " is itself"
       --return it
-      return (toAny e')
-
+      return obj
 
 -- Inform Designer's Manual, Page 146
 -- we recalculate the light of the immediate holder of an object
@@ -106,23 +101,21 @@ findVisibilityHolder e' = do
 recalculateLightOfParent ::
   NoMissingObjects wm es
   => HasLookingProperties wm
-  => ObjectLike wm o
+  => CanBeAny wm o
   => o
   -> Eff es Int
-recalculateLightOfParent e = do
-  (parent :: Maybe EnclosingEntity) <- view (#objectData % #containedBy) <$$> getThingMaybe e
-  case parent of
-    --it's a room.
-    Nothing -> return 0
-    Just p -> do
-      ol <- offersLight p
-      if
-        ol
-      then
-        (1+) <$> recalculateLightOfParent p
-      else
-        return 0
-
+recalculateLightOfParent = asThingOrRoom
+  (\t -> do
+    parent <- getObject (t ^. #objectData % #containedBy)
+    ol <- offersLight parent
+    if
+      ol
+    then
+      (1+) <$> recalculateLightOfParent parent
+    else
+      return 0
+  )
+  (const $ return 0) . toAny
 
 -- | An object offers light if:
 -- - it is a lit thing (lit thing or lighted room)
@@ -132,17 +125,16 @@ recalculateLightOfParent e = do
 offersLight ::
   NoMissingObjects wm es
   => HasLookingProperties wm
-  => ObjectLike wm o
-  => o
+  => AnyObject wm
   -> Eff es Bool
-offersLight e = do
-  let parentOffersLight o = offersLight (o ^. #objectData % #containedBy)
+offersLight obj = do
+  let parentOffersLight o = getObject (o ^. #objectData % #containedBy) >>= offersLight
       seeThruWithParent = maybe (return False) (\o' -> isSeeThrough o' &&^ parentOffersLight o')
-  o <- getThingMaybe e
+  t <- getThingMaybe obj
 
-  objectItselfHasLight e -- it is a lit thing (lit thing or lighted room)
-    ||^ seeThruWithParent o -- - it is see-through and its parent offers light
-    ||^ containsLitObj e -- - it contains a thing that has light
+  pure (objectItselfHasLight obj) -- it is a lit thing (lit thing or lighted room)
+    ||^ seeThruWithParent t -- - it is see-through thing and its parent offers light
+    ||^ containsLitObj obj -- - it contains a thing that has light
 
 -- | an object is see through if...
 isSeeThrough ::
@@ -151,7 +143,9 @@ isSeeThrough ::
   => Thing wm
   -> Eff es Bool
 isSeeThrough e = do
-  (c, en, s) <- (,,) <$> getContainerMaybe e <*> getEnterableMaybe e <*> isSupporter e
+  let c = getContainerMaybe e
+      en = getEnterableMaybe e
+  s <- isSupporter e
   isContainer <- isType e "container"
   let isOpenContainer = fmap _containerOpenable c == Just Open && isContainer
       isTransparent = fmap _containerOpacity c == Just Transparent
@@ -164,24 +158,21 @@ isSeeThrough e = do
 containsLitObj ::
   NoMissingObjects wm es
   => HasLookingProperties wm
-  => ObjectLike wm o
-  => o -- ^ the object
+  => AnyObject wm -- ^ the object
   -> Eff es Bool
-containsLitObj e = do
-  enc <- getEnclosing e
-  enc & maybe (return False) (\encs -> anyM hasLight (DES.elems $ contents encs))
+containsLitObj obj = do
+  let enc = getEnclosingMaybe obj
+  enc & maybe (return False) (\encs -> anyM (getObject >=> hasLight) (DES.elems $ contents encs))
 
 {- | (4) An object itself has light if:
   (a) it's a room with the lighted property,
   (b) it's a thing with the lit property.
   If you want to include transitive light, you want `hasLight`.
 -}
 objectItselfHasLight ::
-  NoMissingObjects wm es
-  => ObjectLike wm o
-  => o -- ^ the object
-  -> Eff es Bool
-objectItselfHasLight e = asThingOrRoom e
+  AnyObject wm -- ^ the object
+  -> Bool
+objectItselfHasLight = asThingOrRoom
   ((Lit ==) . view (#objectData % #lit))
   ((Lighted ==) . view (#objectData % #darkness))
 
@@ -195,11 +186,10 @@ objectItselfHasLight e = asThingOrRoom e
 hasLight ::
   NoMissingObjects wm es
   => HasLookingProperties wm
-  => ObjectLike wm o
-  => o
+  => AnyObject wm
   -> Eff es Bool
-hasLight e = do
-  ts <- getThingMaybe e
-  objectItselfHasLight e
+hasLight obj = do
+  ts <- getThingMaybe obj
+  pure (objectItselfHasLight obj)
     ||^ (maybe (return False) isSeeThrough ts
-      &&^ containsLitObj e)
+      &&^ containsLitObj obj)

src/Yaifl/Activities/ChoosingNotableLocaleObjects.hs

@@ -10,8 +10,8 @@ import Yaifl.Model.Entity ( Store(..), HasID(..) )
 import Yaifl.Model.Object( Object(..), AnyObject )
 import Yaifl.Model.Objects.Query ( getObject )
 import Yaifl.Model.Properties.Enclosing ( Enclosing(..) )
-import Yaifl.Model.Properties.Has ( WMHasProperty )
-import Yaifl.Model.Properties.Query ( getEnclosing )
+import Yaifl.Model.Properties.Has ( WMWithProperty )
+import Yaifl.Model.Properties.Query ( getEnclosingMaybe )
 import Yaifl.Rules.Rule (makeRule)
 import qualified Data.EnumMap as DEM
 import qualified Data.EnumSet as DES
@@ -21,11 +21,11 @@ import Yaifl.Actions.Looking.Locale
 
 type WithChoosingNotableLocaleObjects wm = (WithActivity "choosingNotableLocaleObjects" wm (AnyObject wm) (LocalePriorities wm))
 choosingNotableLocaleObjectsImpl ::
-  WMHasProperty wm Enclosing
+  WMWithProperty wm Enclosing
   => Activity wm (AnyObject wm) (LocalePriorities wm)
 choosingNotableLocaleObjectsImpl = makeActivity "Choosing notable locale objects" [makeRule "" []
   (\v -> do
-    e' <- getEnclosing v
+    let e' = getEnclosingMaybe v
     case e' of
       Nothing -> (do
         addAnnotation $ "Tried to choose notable locale objects from " <> display (v ^. #name) <> " which doesn't enclose."

src/Yaifl/Activities/PrintingTheLocaleDescription.hs

@@ -193,9 +193,9 @@ alsoSee = Rule "You can also see" [] (\v ->
       -- has a common parent and therefore we are listing the contents
       -- of something. this will happen unless the author
       -- manually adds some notable object that isn't present in the room
-      allHolders <- sequence $ DEM.foldl' (\xs li -> flip cons xs $ asThingOrRoom (localeObject li)
-          (\t -> Just $ t ^. #objectData % #containedBy)
-          (const Nothing)) [] lp
+      let allHolders = DEM.foldl' (\xs li -> flip cons xs $ asThingOrRoom
+            (\t -> Just $ t ^. #objectData % #containedBy)
+            (const Nothing) (localeObject li)) [] lp
       case allHolders of
         -- no items
         [] -> error "impossible - no items found?"

src/Yaifl/Model/Object.hs

@@ -15,6 +15,7 @@ is an object. Namely, there's no need for e.g. directions to be objects.
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE FunctionalDependencies #-}
 
 module Yaifl.Model.Object (
   -- * Objects
@@ -129,8 +130,6 @@ newtype Room wm = Room (Object wm (RoomData wm) (WMObjSpecifics wm))
 newtype AnyObject wm = AnyObject (Object wm (Either ThingData (RoomData wm)) (WMObjSpecifics wm))
   deriving newtype (Eq, Ord, Generic)
 
-
-
 instance HasField x (Object wm ThingData (WMObjSpecifics wm)) a  => HasField x (Thing wm) a where
   getField (Thing o) = getField @x o
 
@@ -166,6 +165,7 @@ instance HasID (Room wm) where
 
 makeFieldLabelsNoPrefix ''Object
 
+instance Taggable (Room wm) EnclosingTag
 instance Taggable (Room wm) RoomTag
 instance Taggable (Thing wm) ThingTag
 
@@ -200,7 +200,7 @@ _Thing :: Prism' (AnyObject wm) (Thing wm)
 _Thing = prism' (AnyObject . first Left . coerce) (fmap Thing . bitraverse leftToMaybe Just . (\(AnyObject a) -> a))
 
 -- | A slightly more descriptive prism for objects specifically.
-class CanBeAny wm o where
+class CanBeAny wm o | o -> wm where
   toAny :: o -> AnyObject wm
   fromAny :: AnyObject wm -> Maybe o
 

src/Yaifl/Model/ObjectSpecifics.hs

@@ -9,20 +9,20 @@ module Yaifl.Model.ObjectSpecifics
 
 import Solitude
 
-import Yaifl.Metadata (previousRoom, ObjectType(..))
+import Yaifl.Metadata ( ObjectType(..) )
 import Yaifl.Model.Object
 import Yaifl.Model.Objects.Create
 import Yaifl.Model.Objects.ThingData
 import Yaifl.Model.Properties.Enclosing ( Enclosing )
-import Yaifl.Model.Properties.Has ( HasProperty(..), WMHasProperty )
+import Yaifl.Model.Properties.Has ( MayHaveProperty(..), WMWithProperty )
 import Yaifl.Model.WorldModel ( WMObjSpecifics, WorldModel(..), WMSayable, WMDirection )
 import Yaifl.Model.Properties.Container
 import Yaifl.Model.Properties.Door
 import Yaifl.Model.Properties.Openable ( Openable )
 import Yaifl.Model.Objects.Effects
-import Yaifl.Model.Objects.RoomData
 import Yaifl.Model.Entity
 import Yaifl.Model.Objects.RoomConnections
+import Yaifl.Model.Direction (WMStdDirections)
 
 data ObjectSpecifics =
   NoSpecifics
@@ -43,20 +43,20 @@ class WMHasObjSpecifics (wm :: WorldModel) where
 instance WMHasObjSpecifics ('WorldModel ObjectSpecifics a b c ac r se) where
   inj _ = id
 
-instance HasProperty ObjectSpecifics Enclosing where
-  propertyL = _EnclosingSpecifics `thenATraverse` (_ContainerSpecifics % containerEnclosing)
+instance MayHaveProperty ObjectSpecifics Enclosing where
+  propertyAT = _EnclosingSpecifics `thenATraverse` (_ContainerSpecifics % containerEnclosing)
 
-instance HasProperty ObjectSpecifics Container where
-  propertyL = castOptic _ContainerSpecifics
+instance MayHaveProperty ObjectSpecifics Container where
+  propertyAT = castOptic _ContainerSpecifics
 
-instance HasProperty ObjectSpecifics Enterable where
-  propertyL = _ContainerSpecifics % containerEnterable
+instance MayHaveProperty ObjectSpecifics Enterable where
+  propertyAT = _ContainerSpecifics % containerEnterable
 
-instance HasProperty ObjectSpecifics Openable where
-  propertyL = _OpenableSpecifics `thenATraverse` (_ContainerSpecifics % containerOpenable)
+instance MayHaveProperty ObjectSpecifics Openable where
+  propertyAT = _OpenableSpecifics `thenATraverse` (_ContainerSpecifics % containerOpenable)
 
-instance HasProperty ObjectSpecifics DoorSpecifics where
-  propertyL = castOptic _DoorSpecifics
+instance MayHaveProperty ObjectSpecifics DoorSpecifics where
+  propertyAT = castOptic _DoorSpecifics
 
 localST ::
   State st :> es
@@ -75,21 +75,22 @@ localST f l = do
 -- it isn't portable on creation, and then the check will be whenever we modify an object
 -- make sure that it isn't breaking an invariant.
 addDoor ::
-  forall wm es. WMHasObjSpecifics wm
-  => WMHasProperty wm Enclosing
+  forall wm es.
+  WMHasObjSpecifics wm
+  => WMWithProperty wm Enclosing
+  => WMStdDirections wm
+  => NoMissingObjects wm es
   => AddObjects wm es
   => WMSayable wm -- ^ name
   -> Maybe (WMSayable wm) -- ^ description
-  -> Room wm
-  -> WMDirection wm
-  -> Room wm
-  -> WMDirection wm
+  -> (Room wm, WMDirection wm)
+  -> (Room wm, WMDirection wm)
   -> Maybe ThingData -- ^ Optional details; if 'Nothing' then the default is used.
   -> Eff es (Thing wm)
-addDoor n mbDes fr frDir ba baDir mbD = do
-  let ds = blankDoorSpecifics (tagRoom fr) (tagRoom ba)
+addDoor n mbDes f b mbD = do
+  let ds = blankDoorSpecifics (tagRoom (fst f)) (tagRoom (fst b))
   d <- addThingInternal n (fromMaybe "" mbDes) (ObjectType "door")
       (Just $ inj (Proxy @wm) $ DoorSpecifics ds)
       (Just $ (\x -> x & #portable .~ FixedInPlace & #pushableBetweenRooms .~ False) $ fromMaybe blankThingData mbD)
-  addDoorToConnection (tag ds d) fr ba
+  addDoorToConnection (tag @DoorSpecifics @DoorTag ds d) f b
   pure d