Use names i/o bids in generated JSON and Haskell

Author: Sjoerd Visscher

src/InferType.purs

@@ -75,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: decl.type })
+  tmWithDecl = tm # traverse (\{ bid, box } -> Map.lookup bid ctx # maybe (Left $ "Undeclared name: " <> show bid) \decl -> Right { bid, box, decl: decl.type, name: decl.name })
   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

src/Model.purs

@@ -162,7 +162,7 @@ derive instance eqValidity :: Eq Validity
 
 data Matches a = Matched (Array (Validity /\ a /\ a)) | Unmatched Validity Side (Array a)
 
-type TypedTerm bv bid = Fix (Ann (Ty String) TermF) { bid :: bid, box :: Box, decl :: TypeDecl bv }
+type TypedTerm bv bid = Fix (Ann (Ty String) TermF) { bid :: bid, box :: Box, decl :: TypeDecl bv, name :: String }
 
 
 class FlipDir bv where

src/Output/Haskell.purs

@@ -17,14 +17,14 @@ import Model
 
 
 haskellCode :: String -> TypedTerm String String -> String
-haskellCode name tm = case haskellCode' tm of
+haskellCode fnName tm = case haskellCode' tm of
   { i, o, code } -> typeDecl <> args <> indent ("\n" <> arr (tuple $ foldMap singleton i) (showNested i) `comp` code `comp` arr (showNested o) (tuple $ foldMap singleton o))
   where
-    gens = tm # foldMap \{ decl, bid } -> case decl of
-      Gen ty -> Map.singleton bid ty
+    gens = tm # foldMap \{ decl, name } -> case decl of
+      Gen ty -> Map.singleton name ty
       otherwise -> Map.empty
-    args = if length gens > 0 then name <> " " <> toLower (intercalate " " $ Map.keys gens) <> " = " else ""
-    typeDecl = name <>
+    args = if length gens > 0 then fnName <> " " <> toLower (intercalate " " $ Map.keys gens) <> " = " else ""
+    typeDecl = fnName <>
       "\n  :: Arrow arr" <>
       "\n  => " <> intercalate "\n  -> " (showTy <$> Map.values gens) <>
       "\n  -> " <> showTy (getAnn tm) <>
@@ -39,7 +39,7 @@ haskellEmpty = { i: liftF [], o: liftF [], code: "returnA" }
 haskellCode' :: TypedTerm String String -> HaskellCode
 haskellCode' = foldFix \(Ann _ f) -> alg f where
   alg TUnit = haskellEmpty
-  alg (TBox { bid, decl }) = case decl of
+  alg (TBox { name, decl }) = case decl of
     Perm perm -> perm # foldMapWithIndex (\i p -> ["a" <> show i] /\ ["a" <> show (p - 1)]) #
       \(i /\ o) -> { i: liftF i, o: liftF o, code: arr (tuple i) (tuple o) }
     Spider _ l r -> { i: liftF i, o: liftF o, code: arr (tuple i) out }
@@ -52,7 +52,7 @@ haskellCode' = foldFix \(Ann _ f) -> alg f where
     Gen (Ty i o) ->
       { i: liftF $ foldMapWithIndex (\j n -> [toLower n <> show j]) i
       , o: liftF $ foldMapWithIndex (\j n -> [toLower n <> show j]) o
-      , code: toLower bid }
+      , code: name }
     Cup -> { i: liftF [], o: liftF ["a0", "a1"], code: "cup" }
     Cap -> { i: liftF ["a0", "a1"], o: liftF [], code: "cap" }
   alg (TC ts) = ts # unsnoc # maybe haskellEmpty (\{ init, last } -> foldr compose last init) # mapCode braced

src/Output/JSON.purs

@@ -14,34 +14,34 @@ json = foldFix alg >>> stringify where
   alg (Ann _ TUnit) = encodeJson { type: "unit" }
   alg (Ann _ (TC terms)) = encodeJson { type: "compose", terms }
   alg (Ann _ (TT terms)) = encodeJson { type: "tensor", terms }
-  alg (Ann (Ty l r) (TBox { bid, decl: Gen _ })) = encodeJson
+  alg (Ann (Ty l r) (TBox { name, decl: Gen _ })) = encodeJson
     { type: "generator"
-    , name: bid
+    , name
     , inputTypes: l
     , outputTypes: r }
-  alg (Ann (Ty l _) (TBox { bid, decl: Perm p }))
+  alg (Ann (Ty l _) (TBox { name, decl: Perm p }))
     | take (length p) [1,2,3,4,5,6,7,8,9] == p = encodeJson
       { type: "identity"
-      , name: bid
+      , name
       , typeParams: l }
     | otherwise = encodeJson
       { type: "permutation"
-      , name: bid
+      , name
       , permutation: p
       , typeParams: l }
-  alg (Ann (Ty l r) (TBox { bid, decl: Spider c ni no })) = encodeJson
+  alg (Ann (Ty l r) (TBox { name, decl: Spider c ni no })) = encodeJson
     { type: "spider"
-    , name: bid
+    , name
     , inputs: ni
     , outputs: no
     , color: show c
     , typeParam: l <> r # head
     }
-  alg (Ann (Ty l r) (TBox { bid, decl: Cup })) = encodeJson
+  alg (Ann (Ty l r) (TBox { name, decl: Cup })) = encodeJson
     { type: "cup"
-    , name: bid
+    , name
     , typeParam: l <> r # head }
-  alg (Ann (Ty l r) (TBox { bid, decl: Cap })) = encodeJson
+  alg (Ann (Ty l r) (TBox { name, decl: Cap })) = encodeJson
     { type: "cap"
-    , name: bid
+    , name
     , typeParam: l <> r # head }