Use Identity as the shape parameter for now.

semantic-ast/src/AST/SymbolMatching.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module AST.SymbolMatching
+  ( SymbolMatching (..),
+  )
+where
+
+import AST.Token
+import Data.Proxy
+import GHC.Generics
+import GHC.TypeLits
+import TreeSitter.Node (Node)
+
+class SymbolMatching (a :: * -> *) where
+  matchedSymbols :: Proxy a -> [Int]
+
+  -- | Provide error message describing the node symbol vs. the symbols this can match
+  showFailure :: Proxy a -> Node -> String
+
+instance SymbolMatching f => SymbolMatching (M1 i c f) where
+  matchedSymbols _ = matchedSymbols (Proxy @f)
+  showFailure _ = showFailure (Proxy @f)
+
+instance SymbolMatching f => SymbolMatching (Rec1 f) where
+  matchedSymbols _ = matchedSymbols (Proxy @f)
+  showFailure _ = showFailure (Proxy @f)
+
+instance (KnownNat n, KnownSymbol sym) => SymbolMatching (Token sym n) where
+  matchedSymbols _ = [fromIntegral (natVal (Proxy @n))]
+  showFailure _ _ = "expected " ++ symbolVal (Proxy @sym)
+
+instance (SymbolMatching f, SymbolMatching g) => SymbolMatching (f :+: g) where
+  matchedSymbols _ = matchedSymbols (Proxy @f) <> matchedSymbols (Proxy @g)
+  showFailure _ = sep <$> showFailure (Proxy @f) <*> showFailure (Proxy @g)
+
+instance SymbolMatching f => SymbolMatching (shape :.: f) where
+  matchedSymbols _ = matchedSymbols (Proxy @f)
+  showFailure _ = showFailure (Proxy @f)
+
+sep :: String -> String -> String
+sep a b = a ++ ". " ++ b

semantic-ast/src/AST/Unmarshal.hs

@@ -27,6 +27,7 @@ module AST.Unmarshal
 , GHasAnn(..)
 ) where
 
+import           AST.Token as TS
 import           Control.Algebra (send)
 import           Control.Carrier.Reader hiding (asks)
 import           Control.Exception
@@ -35,6 +36,7 @@ import           Data.ByteString (ByteString)
 import qualified Data.ByteString as B
 import           Data.Coerce
 import           Data.Foldable (toList)
+import           Data.Functor.Identity
 import qualified Data.IntMap as IntMap
 import           Data.List.NonEmpty (NonEmpty (..))
 import           Data.Proxy
@@ -55,7 +57,6 @@ import           TreeSitter.Cursor as TS
 import           TreeSitter.Language as TS
 import           TreeSitter.Node as TS
 import           TreeSitter.Parser as TS
-import           AST.Token as TS
 import           TreeSitter.Tree as TS
 
 asks :: Has (Reader r) sig m => (r -> r') -> m r'
@@ -152,6 +153,11 @@ class SymbolMatching t => Unmarshal t where
 instance (Unmarshal f, Unmarshal g) => Unmarshal (f :+: g) where
   matchers = fmap (fmap (hoist L1)) matchers <> fmap (fmap (hoist R1)) matchers
 
+instance (Applicative shape, Unmarshal f) => Unmarshal (shape :.: f) where
+  matchers = let base = matchers @f in fmap (fmap promote) base
+    where
+      promote (Match f) = Match (fmap (fmap (Comp1 . pure)) f)
+
 instance Unmarshal t => Unmarshal (Rec1 t) where
   matchers = coerce (matchers @t)
 
@@ -218,6 +224,10 @@ instance UnmarshalField Maybe where
   unmarshalField _ _ [x] = Just <$> unmarshalNode x
   unmarshalField d f _   = liftIO . throwIO . UnmarshalError $ "type '" <> d <> "' expected zero or one nodes in field '" <> f <> "' but got multiple"
 
+instance UnmarshalField Identity where
+  unmarshalField _ _ [x] = Identity <$> unmarshalNode x
+  unmarshalField d f _   = liftIO . throwIO . UnmarshalError $ "type '" <> d <> "' expected zero or one nodes in field '" <> f <> "' but got multiple"
+
 instance UnmarshalField [] where
   unmarshalField d f (x:xs) = do
     head' <- unmarshalNode x
@@ -254,6 +264,10 @@ instance (SymbolMatching f, SymbolMatching g) => SymbolMatching (f :+: g) where
   matchedSymbols _ = matchedSymbols (Proxy @f) <> matchedSymbols (Proxy @g)
   showFailure _ = sep <$> showFailure (Proxy @f) <*> showFailure (Proxy @g)
 
+instance SymbolMatching f => SymbolMatching (shape :.: f) where
+  matchedSymbols _ = matchedSymbols (Proxy @f)
+  showFailure _ = showFailure (Proxy @f)
+
 sep :: String -> String -> String
 sep a b = a ++ ". " ++ b
 
@@ -309,6 +323,9 @@ instance (Datatype d, GUnmarshalData f) => GUnmarshal (M1 D d f) where
     go :: (Node -> MatchM (f a)) -> Node -> MatchM (M1 i c f a)
     go = coerce
 
+instance (GUnmarshal f, Applicative shape) => GUnmarshal (shape :.: f) where
+  gunmarshalNode = fmap (Comp1 . pure) . gunmarshalNode @f
+
 class GUnmarshalData f where
   gunmarshalNode'
     :: UnmarshalAnn a
@@ -402,4 +419,4 @@ instance (GHasAnn a l, GHasAnn a r) => GHasAnn a (l :+: r) where
   gann (R1 r) = gann r
 
 instance {-# OVERLAPPABLE #-} HasField "ann" (t a) a => GHasAnn a t where
-  gann = getField @"ann"
+  gann = getField @"ann"

semantic-json/src/Language/JSON.hs

@@ -4,17 +4,18 @@ module Language.JSON
 , TreeSitter.JSON.tree_sitter_json
 ) where
 
+import qualified AST.Unmarshal as TS
+import           Data.Functor.Identity
 import           Data.Proxy
 import qualified Language.JSON.AST as JSON
 import qualified Tags.Tagging.Precise as Tags
 import qualified TreeSitter.JSON (tree_sitter_json)
-import qualified AST.Unmarshal as TS
 
-newtype Term a = Term { getTerm :: JSON.Document a }
+newtype Term a = Term { getTerm :: JSON.Document Identity a }
 
 instance TS.SymbolMatching Term where
-  matchedSymbols _ = TS.matchedSymbols (Proxy :: Proxy JSON.Document)
-  showFailure _ = TS.showFailure (Proxy :: Proxy JSON.Document)
+  matchedSymbols _ = TS.matchedSymbols (Proxy :: Proxy (JSON.Document Identity))
+  showFailure _ = TS.showFailure (Proxy :: Proxy (JSON.Document Identity))
 
 instance TS.Unmarshal Term where
   matchers = fmap (fmap (TS.hoist Term)) TS.matchers

semantic-json/test/Test.hs

@@ -1,16 +1,18 @@
-{-# LANGUAGE DisambiguateRecordFields, OverloadedStrings, TypeApplications #-}
+{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
 module Main (main) where
 
-import qualified System.Path as Path
-import           Test.Tasty
-import           TreeSitter.JSON
-import qualified TreeSitter.JSON.AST as JSON
 import           AST.TestHelpers
 import           AST.Unmarshal
+import           Data.Functor.Identity
 import qualified Language.JSON.AST as JSON
 import           Language.JSON.Grammar
 import qualified System.Path as Path
+import qualified System.Path as Path
 import           Test.Tasty
+import           Test.Tasty
+import           TreeSitter.JSON
 
 main :: IO ()
 main
@@ -18,7 +20,7 @@ main
   >>= readCorpusFiles'
   >>= traverse (testCorpus parse)
   >>= defaultMain . tests
-  where parse = parseByteString @JSON.Document @() tree_sitter_json
+  where parse = parseByteString @(JSON.Document Identity) @() tree_sitter_json
 
 tests :: [TestTree] -> TestTree
 tests = testGroup "tree-sitter-json corpus tests"