Data attributes modified

Data attributes are now a printer/parser pair to accommedate the tutorial system, which is layer on top of the base game and so doesn't have access to the game state. Information about the game state will be encoded into data attributes and parsed by the tutorial system. DataAttribute tests added to ensure that the print/parse round trip returns the same values we statrted with. Typesafe tutorials deemed unworkable, will be moving forward with the new `GuideE` method of running tutorials.
MitchStevens · Jan 24, 2024 · 8e51a5d · 8e51a5d
1 parent ea031c2
commit 8e51a5d
Show file tree

Hide file tree

Showing 24 changed files with 382 additions and 187 deletions.
diff --git a/README.md b/README.md
@@ -1,5 +1,3 @@
-
-
 # Getting started
 - `npm install`
 - `npm run build-prod`
@@ -8,9 +6,4 @@
 # TODO
 - [ ] create more tutorials for early game levels
 - [ ] performance testing
-- [ ] HELP overlay
-
-
-## operations:
-    - visual: pay attention to this div!
-    - textual: interupt chat
+- [ ] HELP overlay
diff --git a/spago.dhall b/spago.dhall
@@ -46,6 +46,7 @@ to generate this file without the comments in this block.
   , "numbers"
   , "ordered-collections"
   , "partial"
+  , "parsing"
   , "prelude"
   , "profunctor"
   , "profunctor-lenses"
@@ -59,7 +60,6 @@ to generate this file without the comments in this block.
   , "transformers"
   , "tuples"
   , "typelevel"
-  , "typelevel-prelude"
   , "unfoldable"
   , "unsafe-coerce"
   , "web-dom"

diff --git a/src/Component/DataAttribute.purs b/src/Component/DataAttribute.purs
@@ -4,165 +4,250 @@ import Prelude
 
 import Capability.Progress (LevelProgress)
 import Capability.Progress as LevelProgress
+import Data.Array as A
+import Data.Either (hush)
 import Data.Int (fromString)
 import Data.Int as Int
-import Data.Maybe (Maybe(..))
-import Data.Newtype (unwrap, wrap)
+import Data.Maybe (Maybe(..), maybe)
+import Data.Newtype (class Newtype, unwrap, wrap)
 import Data.String (Pattern(..), split, stripPrefix, stripSuffix, toLower)
+import Data.String.CodeUnits (fromCharArray)
 import Effect (Effect)
+import Game.Capacity (Capacity(..))
 import Game.Direction (CardinalDirection)
 import Game.Direction as Direction
 import Game.Level.Completion (CompletionStatus(..), PortMismatch(..))
 import Game.Location (Location(..))
 import Game.Location as Location
 import Game.Piece (Piece(..), PieceId(..), pieceLookup)
-import Game.Port (PortType)
+import Game.Port (Port(..), PortType, createPort)
 import Game.Port as Port
 import Game.Rotation (Rotation(..))
 import Game.Signal (Signal(..))
 import Halogen.HTML (AttrName(..), IProp)
 import Halogen.HTML as HP
+import Parsing (Parser, fail, runParser)
+import Parsing.Combinators (choice, try)
+import Parsing.Combinators.Array (many1)
+import Parsing.String (char, rest, string)
+import Parsing.String.Basic (digit)
 import Web.DOM.Element (Element, getAttribute)
 import Web.DOM.ParentNode (QuerySelector(..))
 import Web.HTML.Common (AttrName(..))
 
-type DataAttributeBase r a =
+type DataAttribute a =
   { attrName :: AttrName
   , attrPrint :: a -> String
-  | r }
+  , attrParse :: Parser String a
+  }
 
-type DataAttribute a = DataAttributeBase () a
+dataAttribute :: forall a. AttrName -> (a -> String) -> (Parser String a) -> DataAttribute a
+dataAttribute = { attrName: _, attrPrint: _, attrParse: _ }
 
-type DataAttributeParser a = DataAttributeBase ( attrParse :: String -> Maybe a ) a
+wrapAttribute :: forall t a. Newtype t a => AttrName -> DataAttribute a -> DataAttribute t
+wrapAttribute attrName da =
+  { attrName
+  , attrPrint: unwrap >>> da.attrPrint
+  , attrParse: map wrap da.attrParse
+  }
 
-dataAttribute :: forall a. AttrName -> (a -> String) -> DataAttribute a
-dataAttribute = { attrName: _, attrPrint: _ }
-
-dataAttributeParser :: forall a. AttrName -> (a -> String) -> (String -> Maybe a) -> DataAttributeParser a
-dataAttributeParser = { attrName: _, attrPrint: _, attrParse: _ }
-
-
-selector :: forall r a. DataAttributeBase r a -> a -> QuerySelector
+selector :: forall a. DataAttribute a -> a -> QuerySelector
 selector da a = QuerySelector ("["<> attr <>"='" <> da.attrPrint a <> "']")
   where AttrName attr = da.attrName
 
-attr :: forall r a p i. DataAttributeBase r a -> a -> IProp p i
+attr :: forall a p i. DataAttribute a -> a -> IProp p i
 attr da a = HP.attr da.attrName (da.attrPrint a)
 
-getAttr :: forall a. DataAttributeParser a -> Element -> Effect (Maybe a)
+getAttr :: forall a. DataAttribute a -> Element -> Effect (Maybe a)
 getAttr da element = do 
   let AttrName attr = da.attrName
   maybeAttrStr <- getAttribute attr element
-  pure $ maybeAttrStr >>= da.attrParse
+  pure $ maybeAttrStr >>= (\s -> hush (runParser s da.attrParse))
 
-print :: forall r a. DataAttributeBase r a -> a -> String
+print :: forall a. DataAttribute a -> a -> String
 print da a = da.attrPrint a
 
 
 -- DATA ATTRIBUTES
-pieceId :: DataAttributeParser PieceId
-pieceId = dataAttributeParser (AttrName  "data-piece-id") unwrap (Just <<< wrap)
+int :: DataAttribute Int
+int = dataAttribute (AttrName "int") show attrParse
+  where
+    attrParse = do
+      digitStr <- fromCharArray <<< A.fromFoldable <$> many1 digit
+      maybe (fail digitStr) pure (Int.fromString digitStr)
+
+boolean :: DataAttribute Boolean
+boolean = dataAttribute (AttrName "boolean") attrPrint attrParse
+  where
+    attrPrint = if _ then "true" else "false"
+    attrParse = choice
+      [ string "true"  $> true
+      , string "false" $> false
+      ]
+
+pieceId :: DataAttribute PieceId
+pieceId = dataAttribute (AttrName  "data-piece-id") unwrap (wrap <$> rest)
 
-location :: DataAttributeParser Location
-location = dataAttributeParser (AttrName "data-location") attrPrint attrParse
+location :: DataAttribute Location
+location = dataAttribute (AttrName "data-location") attrPrint attrParse
   where
     attrPrint (Location {x, y}) = "("<> show x <> ","<> show y <>")"
-
-    attrParse str = do
-      numbers <- pure str
-        >>= stripPrefix (Pattern "(") 
-        >>= stripSuffix (Pattern ")") 
-        <#> split (Pattern ",")
-      case numbers of
-        [x, y] -> Location.location <$> fromString x <*> fromString y
-        _ -> Nothing
+    attrParse = do
+      x <- char '(' *> int.attrParse <* char ','
+      y <- int.attrParse <* char ')'
+      pure (Location.location x y)
 
 
-availablePiece :: DataAttributeParser Piece
-availablePiece = dataAttributeParser (AttrName "data-available-piece") (\(Piece p) -> unwrap p.name) (Just <<< pieceLookup <<< PieceId)
+availablePiece :: DataAttribute PieceId
+availablePiece = dataAttribute (AttrName "data-available-piece") unwrap (PieceId <$> rest)
 
 chatUsername :: DataAttribute String
-chatUsername = dataAttribute (AttrName "data-username") identity
+chatUsername = dataAttribute (AttrName "data-username") identity rest
 
-progress :: DataAttributeParser LevelProgress
-progress = dataAttributeParser (AttrName "data-puzzle-progress") attrPrint attrParse
+progress :: DataAttribute LevelProgress
+progress = dataAttribute (AttrName "data-puzzle-progress") attrPrint attrParse
   where
     attrPrint = case _ of
       LevelProgress.Completed -> "completed"
       LevelProgress.Incomplete -> "incomplete"
-    attrParse = case _ of
-      "completed"  -> Just LevelProgress.Completed 
-      "incomplete" -> Just LevelProgress.Incomplete
-      _ -> Nothing
 
-direction :: DataAttributeParser CardinalDirection
-direction = dataAttributeParser (AttrName "data-direction") (show >>> toLower) attrParse
-  where
-    attrParse = case _ of
-      "up" -> Just Direction.Up
-      "right" -> Just Direction.Right
-      "down" -> Just Direction.Down
-      "left" -> Just Direction.Left
-      _ -> Nothing 
-
-rotation :: DataAttributeParser Rotation
-rotation = dataAttributeParser (AttrName "data-rotation") attrPrint attrParse
-  where
-    attrPrint (Rotation r) = show r
-    attrParse = map Rotation <<< Int.fromString
+    attrParse = choice
+      [ string "completed" $> LevelProgress.Completed 
+      , string "incomplete" $> LevelProgress.Incomplete
+      ]
 
-connected :: DataAttributeParser Boolean
-connected = dataAttributeParser (AttrName "data-connected") attrPrint attrParse
-  where
-    attrPrint = if _ then "connected" else "not-connected"
-    attrParse = case _ of
-      "connected" -> Just true
-      "not-connected" -> Just false
-      _ -> Nothing
-
-signal :: DataAttributeParser Signal
-signal = dataAttributeParser (AttrName "data-signal") attrPrint attrParse
+direction :: DataAttribute CardinalDirection
+direction = dataAttribute (AttrName "data-direction") (show >>> toLower) attrParse
   where
-    attrPrint (Signal s) = show s
-    attrParse = map Signal <<< Int.fromString
+    attrParse = choice
+      [ string "up"    $> Direction.Up
+      , string "right" $> Direction.Right
+      , string "down"  $> Direction.Down
+      , string "left"  $> Direction.Left
+      ]
+
+rotation :: DataAttribute Rotation
+rotation = wrapAttribute (AttrName "data-rotation") int
 
+isConnected :: DataAttribute Boolean
+isConnected = boolean { attrName = AttrName "data-is-connected" } 
 
-portType :: DataAttributeParser PortType
-portType = dataAttributeParser (AttrName "data-port-type") attrPrint attrParse
+signal :: DataAttribute Signal
+signal = wrapAttribute (AttrName "data-signal") int
+
+isDragging :: DataAttribute Boolean
+isDragging = boolean { attrName = AttrName "data-is-dragging" } 
+
+completionStatus :: DataAttribute CompletionStatus
+completionStatus = dataAttribute (AttrName "data-completion-status") attrPrint attrParse
+  where
+    attrPrint = case _ of
+      NotStarted -> "not-started"
+      FailedRestriction _ -> "failed-restriction"
+      NotEvaluable _ -> "not-evaluable"
+      PortMismatch _ -> "port-mismatch"
+      ReadyForTesting -> "ready-for-testing"
+      RunningTest _ -> "running-test"
+      FailedTestCase _ -> "failed-test-case"
+      Completed -> "completed"
+    attrParse = fail "no parser for completion status!"
+
+portType :: DataAttribute PortType
+portType = dataAttribute (AttrName "data-port-type") attrPrint attrParse
   where
     attrPrint = case _ of
       Port.Input -> "input"
       Port.Output -> "output"
-    attrParse = case _ of
-      "input" -> Just Port.Input
-      "output" -> Just Port.Output
-      _ -> Nothing
-
-
-isDragging :: DataAttributeParser Boolean
-isDragging = dataAttributeParser (AttrName "data-is-dragging") attrPrint attrParse
+    attrParse = choice
+      [ string "input"  $> Port.Input
+      , string "output" $> Port.Output
+      ]
+
+capacity :: DataAttribute Capacity
+capacity = dataAttribute (AttrName "data-capacity") attrPrint attrParse
   where
-    attrPrint = if _ then "true" else "false"
-    attrParse = case _ of
-      "true" -> Just true
-      "false" -> Just false
-      _ -> Nothing
+    attrPrint = case _ of
+      OneBit -> "1"
+      TwoBit -> "2"
+      FourBit -> "4"
+      EightBit -> "8"
+    attrParse = choice
+      [ char '1' $> OneBit
+      , char '2' $> TwoBit
+      , char '4' $> FourBit
+      , char '8' $> EightBit
+      ]
+
+port :: DataAttribute Port
+port = dataAttribute (AttrName "data-port") attrPrint attrParse
+  where
+    attrPrint (Port p) = portType.attrPrint p.portType <> "-" <> capacity.attrPrint p.capacity
+    attrParse = do
+      portType' <- portType.attrParse <* char '-'
+      capacity' <- capacity.attrParse
+      pure (createPort portType' capacity')
 
-completionStatus :: DataAttribute CompletionStatus
-completionStatus = dataAttribute (AttrName "data-completion-status") $ case _ of
-  NotStarted -> "not-started"
-  FailedRestriction _ -> "failed-restriction"
-  NotEvaluable _ -> "not-evaluable"
-  PortMismatch _ -> "port-mismatch"
-  ReadyForTesting -> "ready-for-testing"
-  RunningTest _ -> "running-test"
-  FailedTestCase _ -> "failed-test-case"
-  Completed -> "completed"
-
-portMismatch :: DataAttribute (Maybe PortMismatch)
-portMismatch = dataAttribute (AttrName "data-port-mismatch") $ case _ of
-  Just (PortExpected _)      -> "port-expected"
-  Just (NoPortExpected _)    -> "no-port-expected"
-  Just (IncorrectPortType _) -> "incorrect-port-type"
-  Just (IncorrectCapacity _) -> "incorrect-capacity"
-  Nothing                    -> "no-mismatch"
+
+-- very complex, take care when modifying!
+portMismatch :: DataAttribute PortMismatch
+portMismatch = dataAttribute (AttrName "data-port-mismatch") attrPrint attrParse
+  where
+    attrPrint = case _  of
+      PortExpected r -> A.intercalate "-"
+        [ port.attrPrint r.expected
+        , "port-expected-at"
+        , direction.attrPrint r.direction
+        ]
+      NoPortExpected r -> A.intercalate "-"
+        [ "no"
+        , port.attrPrint r.received
+        , "port-expected-at"
+        , direction.attrPrint r.direction
+        ]
+      IncorrectPortType r -> A.intercalate "-"
+        [ "expected"
+        , port.attrPrint (createPort r.expected r.capacity)
+        , "at"
+        , direction.attrPrint r.direction
+        , "but-port-type-was"
+        , portType.attrPrint r.received
+        ]
+      IncorrectCapacity r -> A.intercalate "-"
+        [ "expected"
+        , port.attrPrint (createPort r.portType r.expected)
+        , "at"
+        , direction.attrPrint r.direction
+        , "but-capacity-was"
+        , capacity.attrPrint r.received ]
+    attrParse = choice $ map try
+      [ do
+          expected <- port.attrParse
+          _ <- string "-port-expected-at-"
+          direction <- direction.attrParse
+          pure (PortExpected { direction, expected })
+      , do
+          _ <- string "no-"
+          received <- port.attrParse
+          _ <- string "-port-expected-at-"
+          direction <- direction.attrParse
+          pure (NoPortExpected { received, direction })
+      , do
+          _ <- string "expected-"
+          Port p <- port.attrParse
+          _ <- string "-at-"
+          direction <- direction.attrParse
+          _ <- string "-but-port-type-was-"
+          received <- portType.attrParse
+          pure (IncorrectPortType {direction, capacity: p.capacity, received, expected: p.portType} )
+      , do
+          _ <- string "expected-"
+          Port p <- port.attrParse
+          _ <- string "-at-"
+          direction <- direction.attrParse
+          _ <- string "-but-capacity-was-"
+          received <- capacity.attrParse
+          pure (IncorrectCapacity {direction, portType: p.portType, received, expected: p.capacity} )
+      ]
+
+
+--no-PORT-port-expected-at-DIR