gen: Use a propagator network to solve deriving constraints

Using Data.Map.Map to sort gen outputs caused the ordering of certain
fields inside the containers to change, breaking (at least)
`amazonka-emr-containers`. The generator tries to calculate the set of
derivable typeclasses through a `Ptr`, and takes a guess instead of
looking up the actual pointed-to type.

This commit uses a small propagator network to perform
constraint-satisfaction, and uses that to calculate the set of classes
each new type should derive. Because the `typeOf` operation is no
longer local, we have to pass the `TType` evidence through all the
different stages of the generator.

It is broken in several ways:

1. Lenses are generated with the wrong name for the containing
   structure (e.g., `FooRequest` instead of `Foo`).

2. Response structures now have a `Read` instance when they probably
   shouldn't.

3. The actual bug is not fixed - even if the two points above were
   addressed, mutually-recursive structures involving `Ptr` are still
   generating incorrect deriving clauses.

I give up. This needs to be redone properly without fixpoints and
cofree comonadic trees - it was a defensible idea when the inclusion
graph of shape definitions was a DAG, but that has not been true for a
very long time.

WORKSPACE

@@ -349,6 +349,7 @@ stack_snapshot(
         "http-client",
         "http-conduit",
         "http-types",
+        "indexed-traversable",
         "ini",
         "json",  # keep
         "lens",  # keep

gen/BUILD.bazel

@@ -75,6 +75,7 @@ haskell_library(
         "@stackage//:free",
         "@stackage//:hashable",
         "@stackage//:haskell-src-exts",
+        "@stackage//:indexed-traversable",
         "@stackage//:lens",
         "@stackage//:mtl",
         "@stackage//:pandoc",

gen/src/Gen/AST.hs

@@ -5,8 +5,8 @@ import qualified Control.Lens as Lens
 import qualified Control.Monad.Except as Except
 import Control.Monad.State.Strict (execState, modify)
 import qualified Control.Monad.State.Strict as State
-import qualified Data.Map.Strict as Map
 import qualified Data.HashSet as HashSet
+import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import qualified Data.Text as Text
 import Gen.AST.Cofree
@@ -22,7 +22,7 @@ import Gen.Types
 rewrite ::
   Versions ->
   Config ->
-  Service Maybe (RefF ()) (ShapeF ()) (Waiter Id) ->
+  Service Maybe (RefF ()) (ShapeF () ()) (Waiter Id) ->
   Either String Library
 rewrite _versions' _config' s' = do
   rewrittenService <- rewriteService _config' (ignore _config' (deprecate s'))
@@ -40,15 +40,15 @@ rewrite _versions' _config' s' = do
           Nothing -> []
           Just (_ :< shape) -> case shape of
             Ptr {} -> [] -- A top-level lookup should never be a Ptr
-            Struct StructF {_members} -> _members ^.. traverse . importedTypes
-            List ListF {_listItem} -> _listItem ^.. importedTypes
-            Map MapF {_mapKey, _mapValue} -> [_mapKey, _mapValue] ^.. traverse . importedTypes
+            Struct _ StructF {_members} -> _members ^.. traverse . refAnn . importedTypes
+            List _ ListF {_listItem} -> _listItem ^.. refAnn . importedTypes
+            Map _ MapF {_mapKey, _mapValue} -> [_mapKey, _mapValue] ^.. traverse . refAnn . importedTypes
             Enum {} -> []
             Lit {} -> []
 
-      -- A 'Lens.Fold' over any type names that 't' will have to import.
-      importedTypes :: TypeOf t => Lens.Fold t Text
-      importedTypes = Lens.to (typeNames . typeOf) . traverse
+      -- A 'Lens.Fold' over any type names that the shape will have to import.
+      importedTypes :: Lens.Fold (Shape a) Text
+      importedTypes = Lens.to (typeNames . shapeTType) . traverse
         where
           typeNames = \case
             TType t _ -> [t]
@@ -82,7 +82,7 @@ ignore c srv =
 
 rewriteService ::
   Config ->
-  Service Maybe (RefF ()) (ShapeF ()) (Waiter Id) ->
+  Service Maybe (RefF ()) (ShapeF () ()) (Waiter Id) ->
   Either String (Service Identity (RefF ()) (Shape Related) (Waiter Id))
 rewriteService cfg s = do
   -- Determine which direction (input, output, or both) shapes are used.
@@ -137,9 +137,9 @@ type MemoR = StateT (Map Id Relation, HashSet (Id, Direction, Id)) (Either Strin
 -- /Note:/ This currently doesn't operate over the free AST, since it's also
 -- used by 'setDefaults'.
 relations ::
-  Show a =>
+  (Show ttype, Show a) =>
   Map Id (Operation Maybe (RefF b) c) ->
-  Map Id (ShapeF a) ->
+  Map Id (ShapeF ttype a) ->
   Either String (Map Id Relation)
 relations os ss = fst <$> State.execStateT (traverse go os) (mempty, mempty)
   where
@@ -158,7 +158,7 @@ relations os ss = fst <$> State.execStateT (traverse go os) (mempty, mempty)
         s <- lift (safe n)
         shape n d s
 
-    shape :: Id -> Direction -> ShapeF a -> MemoR ()
+    shape :: Id -> Direction -> ShapeF ttype a -> MemoR ()
     shape p d =
       mapM_ (count (Just p) d . Just . Lens.view refShape)
         . Lens.toListOf references
@@ -189,17 +189,17 @@ solve ::
   Config ->
   t (Shape Prefixed) ->
   t (Shape Solved)
-solve cfg ss = State.evalState (go ss) (replaced typeOf cfg)
+solve cfg ss = State.evalState (go ss) replacements
   where
-    go = traverse (annotate Solved id (pure . typeOf))
+    go = traverse (annotate Solved id (pure . shapeTType))
 
-    replaced :: (Replace -> a) -> Config -> Map Id a
-    replaced f =
+    replacements :: Map Id TType
+    replacements =
       Map.fromList
-        . map (_replaceName &&& f)
+        . map (_replaceName &&& replaceTType)
         . Map.elems
         . vMapMaybe _replacedBy
-        . _typeOverrides
+        $ _typeOverrides cfg
 
 type MemoS a = StateT (Map Id a) (Either String)
 

gen/src/Gen/AST/Cofree.hs

@@ -68,41 +68,42 @@ runMemoE = flip State.evalStateT mempty
 -- nested structure definitions, but mutually-recursive shape
 -- references are broken by returning 'Ptr's as loop breakers.
 --
--- We never return a 'Ptr' in the first layer of the 'HashMap''s
+-- We never return a 'Ptr' in the first layer of the 'Map''s
 -- values.
 elaborate ::
-  forall a.
-  Show a =>
-  Map Id (ShapeF a) ->
+  Map Id (ShapeF () ()) ->
   Either String (Map Id (Shape Id))
-elaborate m = runMemoE $ Map.traverseWithKey (shape mempty) m
+elaborate shapeMap = runMemoE $ Map.traverseWithKey (addShape mempty) shapeMap
   where
-    shape :: Set Id -> Id -> ShapeF a -> MemoE (Shape Id)
-    shape seen n s
-      | n `elem` seen = pure $! n :< Ptr (s ^. info) (pointerTo n s)
-      | otherwise = do
-        ms <- State.gets (Map.lookup n)
-        case ms of
-          Just x -> pure x
-          Nothing -> do
-            x <- (n :<) <$> Lens.traverseOf references (ref (Set.insert n seen)) s
-            State.modify' (Map.insert n x)
-            pure x
+    addShape :: Set Id -> Id -> ShapeF () () -> MemoE (Shape Id)
+    addShape seen n shapeF
+      | n `elem` seen =
+          pure $! n :< Ptr (shapeF ^. info) (typeOf derives shapeMap n)
+      | otherwise =
+          State.gets (Map.lookup n) >>= \case
+            Just shape -> pure shape
+            Nothing -> do
+              let shapeF' = addTType (typeOf derives shapeMap n) shapeF
+              shape <- (n :<) <$> Lens.traverseOf references (ref (Set.insert n seen)) shapeF'
+              State.modify' (Map.insert n shape)
+              pure shape
 
-    ref :: Set Id -> RefF a -> MemoE (RefF (Shape Id))
+    ref :: Set Id -> RefF () -> MemoE (RefF (Shape Id))
     ref seen r = do
       let n = r ^. refShape
-      s <- findShape n >>= shape seen n
+      s <- findShape n >>= addShape seen n
       pure $ r & refAnn .~ s
 
-    findShape :: Id -> MemoE (ShapeF a)
-    findShape n = case Map.lookup n m of
+    findShape :: Id -> MemoE (ShapeF () ())
+    findShape n = case Map.lookup n shapeMap of
       Nothing ->
         Except.throwError $
           unwords
             [ "Missing shape ",
               Text.unpack (memberId n),
               ", possible matches: ",
-              partial n m
+              partial n shapeMap
             ]
       Just s -> pure s
+
+    derives = shapeDerives shapeMap