[WIP] Adding Position Annotation

.circleci/config.yml

@@ -67,7 +67,7 @@ jobs:
           #
           # Build with --coverage to ratchet our test coverage.
           name: Tests
-          command: STACK_YAML=stack-8.2.yaml stack test --skip-ghc-check --no-terminal --pedantic --coverage
+          command: STACK_YAML=stack-8.2.yaml stack test --skip-ghc-check --no-terminal --pedantic --coverage && ./scripts/patch_tix.sh
       - store_artifacts:
           path: /root/project/.stack-work/install/x86_64-linux/lts-10.4/8.2.2/hpc
       - run:

.gitignore

@@ -1 +1,3 @@
 .stack-work
+tmp/
+dist-newstyle/

scripts/hpc-ratchet

@@ -37,9 +37,9 @@ Each item represents the number of "things" we are OK with not being covered.
 COVERAGE_TOLERANCE = {
     ALTERNATIVES: 161,
     BOOLEANS: 8,
-    EXPRESSIONS: 1412,
+    EXPRESSIONS: 1395,
     LOCAL_DECLS: 13,
-    TOP_LEVEL_DECLS: 669,
+    TOP_LEVEL_DECLS: 666,
 }
 
 
@@ -48,7 +48,7 @@ def get_report_summary():
 
     Assumes that ``stack test --coverage`` has already been run.
     """
-    process = subprocess.Popen(["stack", "hpc", "report", "--all"], stderr=subprocess.PIPE)
+    process = subprocess.Popen(["stack", "hpc", "report", "tmp/all.tix"], stderr=subprocess.PIPE)
     stdout, stderr = process.communicate()
     return stderr
 
@@ -177,12 +177,12 @@ def format_entry(key, result, desired, actual):
 def main():
     report = parse_report_summary(get_report_summary())
     comparison = compare_coverage(report, COVERAGE_TOLERANCE)
-    all_same = True
+    more_missings = False
     for key, value in sorted(comparison.items()):
-        if value != 0:
-            all_same = False
+        if value < 0:
+            more_missings = True
         print format_entry(key, value, COVERAGE_TOLERANCE.get(key, 0), report[key])
-    sys.exit(0 if all_same else 2)
+    sys.exit(2 if more_missings else 0)
 
 
 if __name__ == '__main__':

scripts/patch_tix.sh

@@ -0,0 +1,10 @@
+#!/usr/bin/env bash
+
+HPC_DIR=$(stack path --dist-dir)/hpc
+GRAPHQL_API_MIX_ABSOLUTE_PATH=$(find $HPC_DIR -maxdepth 1 -name 'graphql-api-*')
+GRAPHQL_API_MIX_PATH=$(basename $GRAPHQL_API_MIX_ABSOLUTE_PATH)
+[[ -d tmp ]] || mkdir tmp
+
+sed s/GRAPHQL_API_MIX_PATH/$GRAPHQL_API_MIX_PATH/ ticks/graphql-api.txt > tmp/graphql-api.txt
+stack exec hpc -- overlay --hpcdir=$HPC_DIR --srcdir=. ./tmp/graphql-api.txt > tmp/graphql-api.tix
+stack exec hpc -- combine $(stack path --local-hpc-root)/combined/all/all.tix tmp/graphql-api.tix --union > tmp/all.tix

src/GraphQL/Internal/Syntax/AST.hs

@@ -1,7 +1,10 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
 {-# OPTIONS_HADDOCK not-home #-}
 
 -- | Description: The GraphQL AST
@@ -23,6 +26,7 @@ module GraphQL.Internal.Syntax.AST
   , FragmentDefinition(..)
   , TypeCondition
   , Value(..)
+  , Position(..)
   , StringValue(..)
   , ListValue(..)
   , ObjectValue(..)
@@ -51,39 +55,46 @@ module GraphQL.Internal.Syntax.AST
 import Protolude
 
 import Test.QuickCheck (Arbitrary(..), listOf, oneof)
-
 import GraphQL.Internal.Arbitrary (arbitraryText)
-import GraphQL.Internal.Name          
+import GraphQL.Internal.Name
   ( Name
   , HasName(..)
   )
-  
+
 -- * Documents
 
 -- | A 'QueryDocument' is something a user might send us.
 --
 -- https://facebook.github.io/graphql/#sec-Language.Query-Document
-newtype QueryDocument = QueryDocument { getDefinitions :: [Definition] } deriving (Eq,Show)
+data QueryDocument = QueryDocument {
+  getDefinitions :: [Definition]
+  , position :: PositionInfo
+  } deriving (Eq,Show)
 
-data Definition = DefinitionOperation OperationDefinition
-                | DefinitionFragment  FragmentDefinition
+-- | PositionInfo for a start position and an end position.
+--
+-- When the AST is constructed elsewhere(not by parsing), for encoding as an example,
+-- the PositionInfo shall be Nothing
+type PositionInfo = Maybe (Int, Int)
+data Definition = DefinitionOperation OperationDefinition PositionInfo
+                | DefinitionFragment  FragmentDefinition PositionInfo
                 deriving (Eq,Show)
 
 -- | A 'SchemaDocument' is a document that defines a GraphQL schema.
 --
 -- https://facebook.github.io/graphql/#sec-Type-System
-newtype SchemaDocument = SchemaDocument [TypeDefinition] deriving (Eq, Show)
+data SchemaDocument = SchemaDocument [TypeDefinition] PositionInfo deriving (Eq, Show)
 
 data OperationDefinition
-  = Query Node
-  | Mutation Node
-  | AnonymousQuery SelectionSet
+  = Query Node PositionInfo
+  | Mutation Node PositionInfo
+  | AnonymousQuery SelectionSet PositionInfo
   deriving (Eq,Show)
 
-data Node = Node (Maybe Name) [VariableDefinition] [Directive] SelectionSet
+data Node = Node (Maybe Name) [VariableDefinition] [Directive] SelectionSet PositionInfo
             deriving (Eq,Show)
 
-data VariableDefinition = VariableDefinition Variable GType (Maybe DefaultValue)
+data VariableDefinition = VariableDefinition Variable GType (Maybe DefaultValue) PositionInfo
                           deriving (Eq,Show)
 
 newtype Variable = Variable Name deriving (Eq, Ord, Show)
@@ -93,11 +104,13 @@ instance Arbitrary Variable where
 
 type SelectionSet = [Selection]
 
-data Selection = SelectionField Field
-               | SelectionFragmentSpread FragmentSpread
-               | SelectionInlineFragment InlineFragment
+data Selection = SelectionField Field PositionInfo
+               | SelectionFragmentSpread FragmentSpread PositionInfo
+               | SelectionInlineFragment InlineFragment PositionInfo
                  deriving (Eq,Show)
 
+-- Field, FragmentSpread and InlineFragment do not need PositionInfo
+-- because their Position is equal to its Selection parent
 data Field = Field (Maybe Alias) Name [Argument] [Directive] SelectionSet
              deriving (Eq,Show)
 
@@ -122,20 +135,42 @@ type TypeCondition = NamedType
 
 -- * Values
 
-data Value = ValueVariable Variable
-           | ValueInt Int32
+data Value  = ValueVariable Variable PositionInfo
+           | ValueInt Int32 PositionInfo
            -- GraphQL Float is double precison
-           | ValueFloat Double
-           | ValueBoolean Bool
-           | ValueString StringValue
-           | ValueEnum Name
-           | ValueList ListValue
-           | ValueObject ObjectValue
-           | ValueNull
+           | ValueFloat Double PositionInfo
+           | ValueBoolean Bool PositionInfo
+           | ValueString StringValue PositionInfo
+           | ValueEnum Name PositionInfo
+           | ValueList ListValue PositionInfo
+           | ValueObject ObjectValue PositionInfo
+           | ValueNull PositionInfo
            deriving (Eq, Show)
 
+class Position a where
+  setPos :: (PositionInfo -> PositionInfo) -> a -> a
+
+instance Position Value where
+  setPos f (ValueNull p) = ValueNull (f p)
+  setPos f (ValueVariable x p) = ValueVariable x (f p)
+  setPos f (ValueInt x p) = ValueInt x (f p)
+  setPos f (ValueFloat x p) = ValueFloat x (f p)
+  setPos f (ValueBoolean x p) = ValueBoolean x (f p)
+  setPos f (ValueString x p) = ValueString x (f p)
+  setPos f (ValueEnum x p) = ValueEnum x (f p)
+  setPos f (ValueList x p) = ValueList (setPos f x) (f p)
+  setPos f (ValueObject x p) = ValueObject (setPos f x) (f p)
+
+-- TODO: Use Rep
+instance Position ListValue where
+  setPos f (ListValue x) = ListValue (map (setPos f) x)
+instance Position ObjectValue where
+  setPos f (ObjectValue x) = ObjectValue (map (setPos f) x)
+instance Position ObjectField where
+  setPos f (ObjectField x v) = ObjectField x (setPos f v)
+
 instance Arbitrary Value where
-  arbitrary = oneof [ ValueVariable <$> arbitrary
+  arbitrary = oneof $ map (<*> pure Nothing) [ ValueVariable <$> arbitrary
                     , ValueInt <$> arbitrary
                     , ValueFloat <$> arbitrary
                     , ValueBoolean <$> arbitrary

src/GraphQL/Internal/Syntax/Encoder.hs

@@ -1,3 +1,4 @@
+{-# Language NamedFieldPuns #-}
 {-# OPTIONS_HADDOCK not-home #-}
 
 -- | Description: Turn GraphQL ASTs into text
@@ -18,27 +19,27 @@ import GraphQL.Internal.Name (unName)
 -- * Document
 
 queryDocument :: AST.QueryDocument -> Text
-queryDocument (AST.QueryDocument defs) = (`snoc` '\n') . mconcat $ definition <$> defs
+queryDocument AST.QueryDocument {getDefinitions = defs} = (`snoc` '\n') . mconcat $ definition <$> defs
 
 definition :: AST.Definition -> Text
-definition (AST.DefinitionOperation x) = operationDefinition x
-definition (AST.DefinitionFragment  x) = fragmentDefinition x
+definition (AST.DefinitionOperation x _) = operationDefinition x
+definition (AST.DefinitionFragment  x _) = fragmentDefinition x
 
 schemaDocument :: AST.SchemaDocument -> Text
-schemaDocument (AST.SchemaDocument defs) = (`snoc` '\n') . mconcat $ typeDefinition <$> defs
+schemaDocument (AST.SchemaDocument defs _) = (`snoc` '\n') . mconcat $ typeDefinition <$> defs
 
 operationDefinition :: AST.OperationDefinition -> Text
-operationDefinition (AST.Query    n) = "query "    <> node n
-operationDefinition (AST.Mutation n) = "mutation " <> node n
-operationDefinition (AST.AnonymousQuery ss) = selectionSet ss
+operationDefinition (AST.Query    n _) = "query "    <> node n
+operationDefinition (AST.Mutation n _) = "mutation " <> node n
+operationDefinition (AST.AnonymousQuery ss _) = selectionSet ss
 
 node :: AST.Node -> Text
-node (AST.Node (Just name) vds ds ss) =
+node (AST.Node (Just name) vds ds ss _) =
      unName name
   <> optempty variableDefinitions vds
   <> optempty directives ds
   <> selectionSet ss
-node (AST.Node Nothing vds ds ss) =
+node (AST.Node Nothing vds ds ss _) =
      optempty variableDefinitions vds
   <> optempty directives ds
   <> selectionSet ss
@@ -47,7 +48,7 @@ variableDefinitions :: [AST.VariableDefinition] -> Text
 variableDefinitions = parensCommas variableDefinition
 
 variableDefinition :: AST.VariableDefinition -> Text
-variableDefinition (AST.VariableDefinition var ty dv) =
+variableDefinition (AST.VariableDefinition var ty dv _) =
   variable var <> ":" <> type_ ty <> maybe mempty defaultValue dv
 
 defaultValue :: AST.DefaultValue -> Text
@@ -60,9 +61,9 @@ selectionSet :: AST.SelectionSet -> Text
 selectionSet = bracesCommas selection
 
 selection :: AST.Selection -> Text
-selection (AST.SelectionField          x) = field x
-selection (AST.SelectionInlineFragment x) = inlineFragment x
-selection (AST.SelectionFragmentSpread x) = fragmentSpread x
+selection (AST.SelectionField          x _) = field x
+selection (AST.SelectionInlineFragment x _) = inlineFragment x
+selection (AST.SelectionFragmentSpread x _) = fragmentSpread x
 
 field :: AST.Field -> Text
 field (AST.Field alias name args ds ss) =
@@ -102,17 +103,17 @@ fragmentDefinition (AST.FragmentDefinition name (AST.NamedType tc) ds ss) =
 -- * Values
 
 value :: AST.Value -> Text
-value (AST.ValueVariable x) = variable x
+value (AST.ValueVariable x _) = variable x
 -- TODO: This will be replaced with `decimal` Buidler
-value (AST.ValueInt      x) = pack $ show x
+value (AST.ValueInt      x _) = pack $ show x
 -- TODO: This will be replaced with `decimal` Buidler
-value (AST.ValueFloat    x) = pack $ show x
-value (AST.ValueBoolean  x) = booleanValue x
-value (AST.ValueString   x) = stringValue x
-value (AST.ValueEnum     x) = unName x
-value (AST.ValueList     x) = listValue x
-value (AST.ValueObject   x) = objectValue x
-value AST.ValueNull = "null"
+value (AST.ValueFloat    x _) = pack $ show x
+value (AST.ValueBoolean  x _) = booleanValue x
+value (AST.ValueString   x _) = stringValue x
+value (AST.ValueEnum     x _) = unName x
+value (AST.ValueList     x _) = listValue x
+value (AST.ValueObject   x _) = objectValue x
+value (AST.ValueNull       _) = "null"
 
 booleanValue :: Bool -> Text
 booleanValue True  = "true"