refactor(tests): Remove use of unsafeCoerce

PR-URL: hasura/graphql-engine-mono#5682 GitOrigin-RevId: 78ac1482977f427148e7675e45ff9c515db02b68
hasura · Sep 7, 2022 · 8bc34e1 · 8bc34e1
1 parent bf91655
commit 8bc34e1
Show file tree

Hide file tree

Showing 2 changed files with 61 additions and 22 deletions.
diff --git a/server/src-lib/Hasura/GraphQL/Execute/Inline.hs b/server/src-lib/Hasura/GraphQL/Execute/Inline.hs
@@ -34,7 +34,12 @@
 -- performed by "Hasura.GraphQL.Execute.Resolve", but for fragment definitions
 -- rather than variables.
 module Hasura.GraphQL.Execute.Inline
-  ( inlineSelectionSet,
+  ( InlineMT,
+    InlineM,
+    inlineSelectionSet,
+    inlineField,
+    runInlineMT,
+    runInlineM,
   )
 where
 
@@ -74,6 +79,34 @@ type MonadInline m =
     MonadState InlineState m
   )
 
+type InlineMT m a = MonadError QErr m => (StateT InlineState (ReaderT InlineEnv m)) a
+
+type InlineM a = InlineMT (Except QErr) a
+
+{-# INLINE runInlineMT #-}
+runInlineMT ::
+  forall m a.
+  (MonadError QErr m) =>
+  HashMap Name FragmentDefinition ->
+  InlineMT m a ->
+  m a
+runInlineMT uniqueFragmentDefinitions =
+  flip
+    runReaderT
+    InlineEnv
+      { _ieFragmentDefinitions = uniqueFragmentDefinitions,
+        _ieFragmentStack = []
+      }
+    . flip evalStateT InlineState {_isFragmentCache = mempty}
+
+{-# INLINE runInlineM #-}
+runInlineM ::
+  forall a.
+  HashMap Name FragmentDefinition ->
+  InlineM a ->
+  Either QErr a
+runInlineM fragments = runExcept . runInlineMT fragments
+
 -- | Inlines all fragment spreads in a 'SelectionSet'; see the module
 -- documentation for "Hasura.GraphQL.Execute.Inline" for details.
 inlineSelectionSet ::
@@ -106,6 +139,8 @@ inlineSelectionSet fragmentDefinitions selectionSet = do
                 Set.toList $
                   Set.difference definedFragmentNames usedFragmentNames
           )
+  -- The below code is a manual inlining of 'runInlineMT', as appearently the
+  -- inlining optimization does not trigger, even with the INLINE pragma.
   traverse inlineSelection selectionSet
     & flip evalStateT InlineState {_isFragmentCache = mempty}
     & flip
@@ -128,18 +163,21 @@ inlineSelection ::
   MonadInline m =>
   Selection FragmentSpread Name ->
   m (Selection NoFragments Name)
-inlineSelection (SelectionField field@Field {_fSelectionSet}) =
-  withPathK "selectionSet" $
-    withPathK (unName $ _fName field) $ do
-      selectionSet <- traverse inlineSelection _fSelectionSet
-      pure $! SelectionField field {_fSelectionSet = selectionSet}
+inlineSelection (SelectionField field) =
+  withPathK "selectionSet" $ SelectionField <$> inlineField field
 inlineSelection (SelectionFragmentSpread spread) =
   withPathK "selectionSet" $
     SelectionInlineFragment <$> inlineFragmentSpread spread
 inlineSelection (SelectionInlineFragment fragment@InlineFragment {_ifSelectionSet}) = do
   selectionSet <- traverse inlineSelection _ifSelectionSet
   pure $! SelectionInlineFragment fragment {_ifSelectionSet = selectionSet}
 
+{-# INLINE inlineField #-}
+inlineField :: MonadInline m => Field FragmentSpread Name -> m (Field NoFragments Name)
+inlineField field@(Field {_fSelectionSet}) = withPathK (unName $ _fName field) $ do
+  selectionSet <- traverse inlineSelection _fSelectionSet
+  pure $! field {_fSelectionSet = selectionSet}
+
 inlineFragmentSpread ::
   MonadInline m =>
   FragmentSpread Name ->

diff --git a/server/src-test/Test/Parser/Field.hs b/server/src-test/Test/Parser/Field.hs
@@ -1,20 +1,20 @@
 -- | QuasiQuoter for parsing GraphQL fields in tests. See 'field' for details.
 module Test.Parser.Field (field) where
 
+import Control.Monad.Trans.Except
 import Data.Attoparsec.Text qualified as Parser
 import Data.Text qualified as T
+import Hasura.Base.Error (showQErr)
+import Hasura.GraphQL.Execute.Inline (inlineField, runInlineM)
 import Hasura.GraphQL.Parser.Variable
 import Hasura.Prelude
 import Language.GraphQL.Draft.Parser qualified as GraphQL
 import Language.GraphQL.Draft.Syntax qualified as GraphQL
 import Language.Haskell.TH.Lib (ExpQ)
 import Language.Haskell.TH.Quote
 import Language.Haskell.TH.Syntax qualified as TH
-import Unsafe.Coerce (unsafeCoerce)
 
--- | Warning: we are currently using unsafe coercions to convert the field. This
--- seems to work for now, but beware.
---
+-- | Quasi-Quoter for GraphQL fields.
 -- Example usage:
 -- > [GQL.field|
 -- >    update_artist(
@@ -27,21 +27,22 @@ import Unsafe.Coerce (unsafeCoerce)
 field :: QuasiQuoter
 field =
   QuasiQuoter
-    { quoteExp = evalFieldGQL,
+    { quoteExp = fieldExp,
       quotePat = \_ -> fail "invalid",
       quoteType = \_ -> fail "invalid",
       quoteDec = \_ -> fail "invalid"
     }
-
-evalFieldGQL :: String -> ExpQ
-evalFieldGQL = either fail TH.lift . go
   where
-    -- Note: @skipSpace@ is used here to allow trailing whitespace in the QQ.
-    go :: String -> Either String (GraphQL.Field GraphQL.NoFragments Variable)
-    go =
-      fmap fixField
-        . Parser.parseOnly (Parser.skipSpace *> GraphQL.field @GraphQL.Name)
-        . T.pack
+    fieldExp :: String -> ExpQ
+    fieldExp input = do
+      either fail TH.lift $
+        runExcept $ do
+          parsed <- hoistEither $ Parser.parseOnly (Parser.skipSpace *> GraphQL.field @GraphQL.Name) . T.pack $ input
+          fixField parsed
 
-fixField :: GraphQL.Field GraphQL.FragmentSpread GraphQL.Name -> GraphQL.Field GraphQL.NoFragments Variable
-fixField = unsafeCoerce
+    -- A parsed field can contain both fragments and variables.
+    -- We support neither yet.
+    fixField :: GraphQL.Field GraphQL.FragmentSpread GraphQL.Name -> Except String (GraphQL.Field GraphQL.NoFragments Variable)
+    fixField f = do
+      x <- except $ mapLeft (T.unpack . showQErr) $ runInlineM mempty . inlineField $ f
+      traverse (throwE . ("Variables are not supported in tests yet: " ++) . show) x