Allow a name and multiple pixel letters per type

Fixes #33

Author: Sjoerd Visscher

src/InferType.purs

@@ -14,6 +14,7 @@ import Data.Map (Map)
 import Data.Maybe (Maybe(..), maybe)
 import Data.Newtype (alaF)
 import Data.String (trim, split, joinWith)
+import Data.String.CodeUnits (singleton, toCharArray)
 import Data.String.Pattern (Pattern(..))
 import Data.String.Regex (regex, match)
 import Data.String.Regex.Flags (noFlags)
@@ -74,7 +75,7 @@ inferType ctx tm = { term, bounds, matches: matches <> typeToMatches, errors }
                 replaceInferredType bounds $
                   (acc <> step <> empty { bounds = bounds, matches = [Matched matches] })
                     { type = Ty (a <#> replaceBoxed bounds) (c <#> replaceBoxed bounds) }
-  tmWithDecl = tm # traverse (\{ bid, box } -> Map.lookup bid ctx # maybe (Left $ "Undeclared name: " <> show bid) \decl -> Right { bid, box, decl })
+  tmWithDecl = tm # traverse (\{ bid, box } -> Map.lookup bid ctx # maybe (Left $ "Undeclared name: " <> show bid) \decl -> Right { bid, box, decl: decl.type })
   fatTerm = tmWithDecl # either (const (Fix (Ann empty TUnit))) (reannotateFix alg)
   typeToMatches = case (getAnn fatTerm).type of Ty l r -> [Unmatched Valid Input l, Unmatched Valid Output r]
   { bounds, matches, errors } = getAnn fatTerm
@@ -145,7 +146,7 @@ getSubTerm' _ _ mkTerm = mkTerm []
 
 
 defaultEnv :: Context String String
-defaultEnv = Map.fromFoldable
+defaultEnv = Map.fromFoldable $ map (\(name /\ ty) -> name /\ { name, type: ty })
   [ " " /\ Perm []
   , "-" /\ Perm [1]
   , "=" /\ Perm [1, 2]
@@ -167,22 +168,28 @@ parseContext = spl "\n" >>> alaF App foldMap toEntry
   where
     spl :: String -> String -> Array String
     spl p = trim >>> split (Pattern p) >>> map trim
+    parseName :: String -> { name :: String, bids :: Array String }
+    parseName nameBid = case nameBid # spl "@" of
+      [name, bids] -> { name, bids: toCharArray bids <#> singleton }
+      _ -> { name: nameBid, bids: toCharArray nameBid <#> singleton }
     toEntry :: String -> Either String (Context String String)
     toEntry line = case spl ":" line of
-      [name, typ] -> case typ # spl "->" <#> (spl " " >>> filter (_ /= "")) of
-        [left, right] -> pure $ Map.singleton name (Gen $ Ty left right)
-        _ -> do
-          permRe <- regex "^\\[(.*)\\]$" noFlags
-          case match permRe typ # map toArray of
-            Just [_, Just perm] ->
-              pure $ Map.singleton name (Perm $ perm # (spl " " >>> filter (_ /= "") >>> map (readInt 10 >>> floor)))
-            _ -> do
-              spiderRe <- regex "^(\\d+)(o|\\.)(\\d+)$" noFlags
-              case match spiderRe typ # map toArray of
-                Just [_, Just ls, Just cs, Just rs] -> pure $ Map.singleton name (Spider
-                  (if cs == "." then Black else White)
-                  (readInt 10 ls # floor)
-                  (readInt 10 rs # floor)
-                )
-                _ -> Left $ "Invalid type: " <> typ
+      [nameBid, typ] -> let { name, bids } = parseName nameBid in
+        (\ty -> foldMap (\bid -> Map.singleton bid { name, type: ty }) bids) <$>
+        case typ # spl "->" <#> (spl " " >>> filter (_ /= "")) of
+          [left, right] -> pure $ Gen $ Ty left right
+          _ -> do
+            permRe <- regex "^\\[(.*)\\]$" noFlags
+            case match permRe typ # map toArray of
+              Just [_, Just perm] ->
+                pure (Perm $ perm # (spl " " >>> filter (_ /= "") >>> map (readInt 10 >>> floor)))
+              _ -> do
+                spiderRe <- regex "^(\\d+)(o|\\.)(\\d+)$" noFlags
+                case match spiderRe typ # map toArray of
+                  Just [_, Just ls, Just cs, Just rs] -> pure (Spider
+                    (if cs == "." then Black else White)
+                    (readInt 10 ls # floor)
+                    (readInt 10 rs # floor)
+                  )
+                  _ -> Left $ "Invalid type: " <> typ
       _ -> Left $ "Invalid signature: " <> line

src/Model.purs

@@ -138,7 +138,7 @@ isGen :: ∀ bv. TypeDecl bv -> Boolean
 isGen (Gen _) = true
 isGen _ = false
 
-type Context bv bid = Map bid (TypeDecl bv)
+type Context bv bid = Map bid { name :: String, type :: TypeDecl bv }
 
 
 data Var bv

src/View/Bricks.purs

@@ -116,45 +116,45 @@ render { input: { bricks: { width, height, boxes }, matches, context, selectedBo
     ] ]
   ]
 
-renderBrick :: ∀ m. InputOutput String -> Maybe (TypeDecl String) -> Brick String
+renderBrick :: ∀ m. InputOutput String -> Maybe { name :: String, type :: TypeDecl String } -> Brick String
   -> { className :: String, content :: Array (H.ComponentHTML Action () m) }
-renderBrick io (Just (Gen _)) b@{ box } =
+renderBrick io (Just { name, type: Gen _ }) b@{ box } =
   { className: "box"
   , content:
-      renderBox b
+      renderBox name box
       <> maybe [] (foldMap (renderLines genLineSettings Input b)) (lookup (box /\ Input) io)
       <> maybe [] (foldMap (renderLines genLineSettings Output b)) (lookup (box /\ Output) io)
   }
-renderBrick io (Just (Perm perm)) b = { className: "wires", content: renderPerm io b perm }
-renderBrick io (Just (Spider c _ _)) b@{ box } =
+renderBrick io (Just { type: Perm perm }) b = { className: "wires", content: renderPerm io b perm }
+renderBrick io (Just { type: Spider c _ _ }) b@{ box } =
   { className: "wires"
   , content:
       maybe [] (foldMap (renderLines spiderLineSettings Input b)) (lookup (box /\ Input) io) <>
       maybe [] (foldMap (renderLines spiderLineSettings Output b)) (lookup (box /\ Output) io) <>
       renderNode b c
   }
-renderBrick io (Just Cup) b@{ box } =
+renderBrick io (Just { type: Cup }) b@{ box } =
   { className: "wires"
   , content:
       maybe [] (foldMap (renderLines cupcapLineSettings Input b)) (lookup (box /\ Input) io) <>
       maybe [] (foldMap (renderLines cupcapLineSettings Output b)) (lookup (box /\ Output) io)
   }
-renderBrick io (Just Cap) b@{ box } =
+renderBrick io (Just { type: Cap }) b@{ box } =
   { className: "wires"
   , content:
       maybe [] (foldMap (renderLines cupcapLineSettings Input b)) (lookup (box /\ Input) io) <>
       maybe [] (foldMap (renderLines cupcapLineSettings Output b)) (lookup (box /\ Output) io)
   }
 renderBrick _ Nothing _ = { className: "box", content: [] }
 
-renderBox :: ∀ m. Brick String -> Array (H.ComponentHTML Action () m)
-renderBox { bid, box: { topLeft: { x: xl, y: yt }, bottomRight: { x: xr, y: yb } } } =
+renderBox :: ∀ m. String -> Box -> Array (H.ComponentHTML Action () m)
+renderBox name { topLeft: { x: xl, y: yt }, bottomRight: { x: xr, y: yb } } =
   [ S.rect [ S.x (mx - 0.18), S.y (my - 0.25), S.width 0.36, S.height 0.5, svgClasses [ ClassName "inner-box" ] ]
   , S.text
     [ S.x mx, S.y (my + 0.12)
     , S.attr (AttrName "text-anchor") "middle"
     , svgClasses [ ClassName "inner-box-text" ]
-    ] [ text bid ]
+    ] [ text name, sub_ [ text "1" ] ]
   ]
   where
     mx = (toNumber xl + toNumber xr) / 2.0