{-# LANGUAGE DefaultSignatures, FlexibleContexts, FlexibleInstances, PolyKinds,
             ScopedTypeVariables, TypeApplications, TypeOperators #-}
module TreeSitter.Unmarshal
( parseByteString
, FieldName(..)
, Unmarshal(..)
, UnmarshalAnn(..)
, UnmarshalField(..)
, SymbolMatching(..)
, step
, push
, goto
, peekNode
, peekFieldName
, getFields
) where

import           Control.Applicative
import           Control.Carrier.Reader
import           Control.Carrier.Fail.Either
import           Control.Carrier.Lift
import           Control.Monad.IO.Class
import           Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.Map as Map
import qualified Data.Text as Text
import           Data.Text.Encoding
import           Foreign.C.String
import           Foreign.Marshal.Alloc
import           Foreign.Marshal.Utils
import           Foreign.Ptr
import           Foreign.Storable
import           GHC.Generics
import           GHC.TypeLits
import           TreeSitter.Cursor as TS
import           TreeSitter.Language as TS
import           TreeSitter.Node as TS
import           TreeSitter.Parser as TS
import           TreeSitter.Tree as TS
import           TreeSitter.Token as TS
import           Source.Loc
import           Source.Span
import           Data.Proxy
import           Prelude hiding (fail)
import           Data.Maybe (fromMaybe)
import           Data.List.NonEmpty (NonEmpty (..))

-- Parse source code and produce AST
parseByteString :: (Unmarshal t, UnmarshalAnn a) => Ptr TS.Language -> ByteString -> IO (Either String (t a))
parseByteString :: Ptr Language -> ByteString -> IO (Either String (t a))
parseByteString language :: Ptr Language
language bytestring :: ByteString
bytestring = Ptr Language
-> (Ptr Parser -> IO (Either String (t a)))
-> IO (Either String (t a))
forall a. Ptr Language -> (Ptr Parser -> IO a) -> IO a
withParser Ptr Language
language ((Ptr Parser -> IO (Either String (t a)))
 -> IO (Either String (t a)))
-> (Ptr Parser -> IO (Either String (t a)))
-> IO (Either String (t a))
forall a b. (a -> b) -> a -> b
$ \ parser :: Ptr Parser
parser -> Ptr Parser
-> ByteString
-> (Ptr Tree -> IO (Either String (t a)))
-> IO (Either String (t a))
forall a. Ptr Parser -> ByteString -> (Ptr Tree -> IO a) -> IO a
withParseTree Ptr Parser
parser ByteString
bytestring ((Ptr Tree -> IO (Either String (t a)))
 -> IO (Either String (t a)))
-> (Ptr Tree -> IO (Either String (t a)))
-> IO (Either String (t a))
forall a b. (a -> b) -> a -> b
$ \ treePtr :: Ptr Tree
treePtr ->
  if Ptr Tree
treePtr Ptr Tree -> Ptr Tree -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Tree
forall a. Ptr a
nullPtr then
    Either String (t a) -> IO (Either String (t a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Either String (t a)
forall a b. a -> Either a b
Left "error: didn't get a root node")
  else
    Ptr Tree
-> (Ptr Node -> IO (Either String (t a)))
-> IO (Either String (t a))
forall a. Ptr Tree -> (Ptr Node -> IO a) -> IO a
withRootNode Ptr Tree
treePtr ((Ptr Node -> IO (Either String (t a)))
 -> IO (Either String (t a)))
-> (Ptr Node -> IO (Either String (t a)))
-> IO (Either String (t a))
forall a b. (a -> b) -> a -> b
$ \ rootPtr :: Ptr Node
rootPtr ->
      Ptr TSNode
-> (Ptr Cursor -> IO (Either String (t a)))
-> IO (Either String (t a))
forall a. Ptr TSNode -> (Ptr Cursor -> IO a) -> IO a
withCursor (Ptr Node -> Ptr TSNode
forall a b. Ptr a -> Ptr b
castPtr Ptr Node
rootPtr) ((Ptr Cursor -> IO (Either String (t a)))
 -> IO (Either String (t a)))
-> (Ptr Cursor -> IO (Either String (t a)))
-> IO (Either String (t a))
forall a b. (a -> b) -> a -> b
$ \ cursor :: Ptr Cursor
cursor ->
        LiftC IO (Either String (t a)) -> IO (Either String (t a))
forall (m :: * -> *) a. LiftC m a -> m a
runM (FailC (LiftC IO) (t a) -> LiftC IO (Either String (t a))
forall (m :: * -> *) a. FailC m a -> m (Either String a)
runFail (Ptr Cursor
-> ReaderC (Ptr Cursor) (FailC (LiftC IO)) (t a)
-> FailC (LiftC IO) (t a)
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader Ptr Cursor
cursor (ByteString
-> ReaderC
     ByteString (ReaderC (Ptr Cursor) (FailC (LiftC IO))) (t a)
-> ReaderC (Ptr Cursor) (FailC (LiftC IO)) (t a)
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader ByteString
bytestring (ReaderC ByteString (ReaderC (Ptr Cursor) (FailC (LiftC IO))) Node
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Reader (Ptr Cursor)) sig m, MonadIO m) =>
m Node
peekNode ReaderC ByteString (ReaderC (Ptr Cursor) (FailC (LiftC IO))) Node
-> (Node
    -> ReaderC
         ByteString (ReaderC (Ptr Cursor) (FailC (LiftC IO))) (t a))
-> ReaderC
     ByteString (ReaderC (Ptr Cursor) (FailC (LiftC IO))) (t a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Node
-> ReaderC
     ByteString (ReaderC (Ptr Cursor) (FailC (LiftC IO))) (t a)
forall (t :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Unmarshal t, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m,
 UnmarshalAnn a) =>
Node -> m (t a)
unmarshalNode))))

-- | Unmarshalling is the process of iterating over tree-sitter’s parse trees using its tree cursor API and producing Haskell ASTs for the relevant nodes.
--
--   Datatypes which can be constructed from tree-sitter parse trees may use the default definition of 'unmarshalNode' providing that they have a suitable 'Generic1' instance.
class Unmarshal t where
  unmarshalNode
    :: ( Has (Reader ByteString) sig m
       , Has (Reader (Ptr Cursor)) sig m
       , MonadFail m
       , MonadIO m
       , UnmarshalAnn a
       )
    => Node
    -> m (t a)
  default unmarshalNode
    :: ( Generic1 t
       , GUnmarshal (Rep1 t)
       , Has (Reader ByteString) sig m
       , Has (Reader (Ptr Cursor)) sig m
       , MonadFail m
       , MonadIO m
       , UnmarshalAnn a
       )
    => Node
    -> m (t a)
  unmarshalNode x :: Node
x = do
    TSNode -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Reader (Ptr Cursor)) sig m, MonadIO m) =>
TSNode -> m ()
goto (Node -> TSNode
nodeTSNode Node
x)
    Rep1 t a -> t a
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 (Rep1 t a -> t a) -> m (Rep1 t a) -> m (t a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> m (Rep1 t a)
forall (f :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(GUnmarshal f, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m,
 UnmarshalAnn a) =>
Node -> m (f a)
gunmarshalNode Node
x

instance (Unmarshal f, Unmarshal g, SymbolMatching f, SymbolMatching g) => Unmarshal (f :+: g) where
  unmarshalNode :: Node -> m ((:+:) f g a)
unmarshalNode node :: Node
node = do
    let lhsSymbolMatch :: Bool
lhsSymbolMatch = Proxy f -> Node -> Bool
forall (a :: * -> *). SymbolMatching a => Proxy a -> Node -> Bool
symbolMatch (Proxy f
forall k (t :: k). Proxy t
Proxy @f) Node
node
        rhsSymbolMatch :: Bool
rhsSymbolMatch = Proxy g -> Node -> Bool
forall (a :: * -> *). SymbolMatching a => Proxy a -> Node -> Bool
symbolMatch (Proxy g
forall k (t :: k). Proxy t
Proxy @g) Node
node
    if Bool
lhsSymbolMatch then
      f a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f a -> (:+:) f g a) -> m (f a) -> m ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> m (f a)
forall (t :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Unmarshal t, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m,
 UnmarshalAnn a) =>
Node -> m (t a)
unmarshalNode @f Node
node
    else if Bool
rhsSymbolMatch then
      g a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g a -> (:+:) f g a) -> m (g a) -> m ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> m (g a)
forall (t :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Unmarshal t, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m,
 UnmarshalAnn a) =>
Node -> m (t a)
unmarshalNode @g Node
node
    else
      String -> m ((:+:) f g a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ((:+:) f g a)) -> String -> m ((:+:) f g a)
forall a b. (a -> b) -> a -> b
$ Proxy (f :+: g) -> Node -> String
forall (a :: * -> *). SymbolMatching a => Proxy a -> Node -> String
showFailure (Proxy (f :+: g)
forall k (t :: k). Proxy t
Proxy @(f :+: g)) Node
node

instance Unmarshal t => Unmarshal (Rec1 t) where
  unmarshalNode :: Node -> m (Rec1 t a)
unmarshalNode = (t a -> Rec1 t a) -> m (t a) -> m (Rec1 t a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t a -> Rec1 t a
forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 (m (t a) -> m (Rec1 t a))
-> (Node -> m (t a)) -> Node -> m (Rec1 t a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> m (t a)
forall (t :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Unmarshal t, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m,
 UnmarshalAnn a) =>
Node -> m (t a)
unmarshalNode

instance Unmarshal (Token sym n) where
  unmarshalNode :: Node -> m (Token sym n a)
unmarshalNode = (a -> Token sym n a) -> m a -> m (Token sym n a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Token sym n a
forall (symName :: Symbol) (symVal :: Nat) a.
a -> Token symName symVal a
Token (m a -> m (Token sym n a))
-> (Node -> m a) -> Node -> m (Token sym n a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> m a
forall a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(UnmarshalAnn a, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m) =>
Node -> m a
unmarshalAnn


-- | Unmarshal an annotation field.
--
--   Leaf nodes have 'Text.Text' fields, and leaves, anonymous leaves, and products all have parametric annotation fields. All of these fields are unmarshalled using the metadata of the node, e.g. its start/end bytes, without reference to any child nodes it may contain.
class UnmarshalAnn a where
  unmarshalAnn
    :: ( Has (Reader ByteString) sig m
       , Has (Reader (Ptr Cursor)) sig m
       , MonadFail m
       , MonadIO m
       )
    => Node
    -> m a

instance UnmarshalAnn () where
  unmarshalAnn :: Node -> m ()
unmarshalAnn _ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance UnmarshalAnn Text.Text where
  unmarshalAnn :: Node -> m Text
unmarshalAnn node :: Node
node = do
    Range
range <- Node -> m Range
forall a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(UnmarshalAnn a, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m) =>
Node -> m a
unmarshalAnn Node
node
    ByteString
bytestring <- m ByteString
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
m r
ask
    Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Text
decodeUtf8 (Range -> ByteString -> ByteString
slice Range
range ByteString
bytestring))

-- | Instance for pairs of annotations
instance (UnmarshalAnn a, UnmarshalAnn b) => UnmarshalAnn (a,b) where
  unmarshalAnn :: Node -> m (a, b)
unmarshalAnn node :: Node
node = (,)
    (a -> b -> (a, b)) -> m a -> m (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> m a
forall a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(UnmarshalAnn a, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m) =>
Node -> m a
unmarshalAnn @a Node
node
    m (b -> (a, b)) -> m b -> m (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> m b
forall a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(UnmarshalAnn a, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m) =>
Node -> m a
unmarshalAnn @b Node
node

instance UnmarshalAnn Loc where
  unmarshalAnn :: Node -> m Loc
unmarshalAnn node :: Node
node = Range -> Span -> Loc
Loc
    (Range -> Span -> Loc) -> m Range -> m (Span -> Loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> m Range
forall a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(UnmarshalAnn a, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m) =>
Node -> m a
unmarshalAnn @Range Node
node
    m (Span -> Loc) -> m Span -> m Loc
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> m Span
forall a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(UnmarshalAnn a, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m) =>
Node -> m a
unmarshalAnn @Span  Node
node

instance UnmarshalAnn Range where
  unmarshalAnn :: Node -> m Range
unmarshalAnn node :: Node
node = do
    let start :: Int
start = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Node -> Word32
nodeStartByte Node
node)
        end :: Int
end   = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Node -> Word32
nodeEndByte Node
node)
    Range -> m Range
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Range
Range Int
start Int
end)

instance UnmarshalAnn Span where
  unmarshalAnn :: Node -> m Span
unmarshalAnn node :: Node
node = do
    let spanStart :: Pos
spanStart = TSPoint -> Pos
pointToPos (Node -> TSPoint
nodeStartPoint Node
node)
        spanEnd :: Pos
spanEnd   = TSPoint -> Pos
pointToPos (Node -> TSPoint
nodeEndPoint Node
node)
    Span -> m Span
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pos -> Pos -> Span
Span Pos
spanStart Pos
spanEnd)

pointToPos :: TSPoint -> Pos
pointToPos :: TSPoint -> Pos
pointToPos (TSPoint line :: Word32
line column :: Word32
column) = Int -> Int -> Pos
Pos (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
line) (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
column)


-- | Optional/repeated fields occurring in product datatypes are wrapped in type constructors, e.g. 'Maybe', '[]', or 'NonEmpty', and thus can unmarshal zero or more nodes for the same field name.
class UnmarshalField t where
  unmarshalField
    :: ( Has (Reader ByteString) sig m
       , Has (Reader (Ptr Cursor)) sig m
       , MonadFail m
       , MonadIO m
       , Unmarshal f
       , UnmarshalAnn a
       )
    => [Node]
    -> m (t (f a))

instance UnmarshalField Maybe where
  unmarshalField :: [Node] -> m (Maybe (f a))
unmarshalField []  = Maybe (f a) -> m (Maybe (f a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (f a)
forall a. Maybe a
Nothing
  unmarshalField [x :: Node
x] = f a -> Maybe (f a)
forall a. a -> Maybe a
Just (f a -> Maybe (f a)) -> m (f a) -> m (Maybe (f a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> m (f a)
forall (t :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Unmarshal t, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m,
 UnmarshalAnn a) =>
Node -> m (t a)
unmarshalNode Node
x
  unmarshalField _   = String -> m (Maybe (f a))
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "expected a node of type (Maybe a) but got multiple"

instance UnmarshalField [] where
  unmarshalField :: [Node] -> m [f a]
unmarshalField (x :: Node
x:xs :: [Node]
xs) = do
    f a
head' <- Node -> m (f a)
forall (t :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Unmarshal t, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m,
 UnmarshalAnn a) =>
Node -> m (t a)
unmarshalNode Node
x
    [f a]
tail' <- [Node] -> m [f a]
forall (t :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *)
       (f :: * -> *) a.
(UnmarshalField t, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m,
 Unmarshal f, UnmarshalAnn a) =>
[Node] -> m (t (f a))
unmarshalField [Node]
xs
    [f a] -> m [f a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([f a] -> m [f a]) -> [f a] -> m [f a]
forall a b. (a -> b) -> a -> b
$ f a
head' f a -> [f a] -> [f a]
forall a. a -> [a] -> [a]
: [f a]
tail'
  unmarshalField [] = [f a] -> m [f a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

instance UnmarshalField NonEmpty where
  unmarshalField :: [Node] -> m (NonEmpty (f a))
unmarshalField (x :: Node
x:xs :: [Node]
xs) = do
    f a
head' <- Node -> m (f a)
forall (t :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Unmarshal t, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m,
 UnmarshalAnn a) =>
Node -> m (t a)
unmarshalNode Node
x
    [f a]
tail' <- [Node] -> m [f a]
forall (t :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *)
       (f :: * -> *) a.
(UnmarshalField t, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m,
 Unmarshal f, UnmarshalAnn a) =>
[Node] -> m (t (f a))
unmarshalField [Node]
xs
    NonEmpty (f a) -> m (NonEmpty (f a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty (f a) -> m (NonEmpty (f a)))
-> NonEmpty (f a) -> m (NonEmpty (f a))
forall a b. (a -> b) -> a -> b
$ f a
head' f a -> [f a] -> NonEmpty (f a)
forall a. a -> [a] -> NonEmpty a
:| [f a]
tail'
  unmarshalField [] = String -> m (NonEmpty (f a))
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "expected a node of type (NonEmpty a) but got an empty list"


class SymbolMatching (a :: * -> *) where
  symbolMatch :: Proxy a -> Node -> Bool

  -- | 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
  symbolMatch :: Proxy (M1 i c f) -> Node -> Bool
symbolMatch _ = Proxy f -> Node -> Bool
forall (a :: * -> *). SymbolMatching a => Proxy a -> Node -> Bool
symbolMatch (Proxy f
forall k (t :: k). Proxy t
Proxy @f)
  showFailure :: Proxy (M1 i c f) -> Node -> String
showFailure _ = Proxy f -> Node -> String
forall (a :: * -> *). SymbolMatching a => Proxy a -> Node -> String
showFailure (Proxy f
forall k (t :: k). Proxy t
Proxy @f)

instance SymbolMatching f => SymbolMatching (Rec1 f) where
  symbolMatch :: Proxy (Rec1 f) -> Node -> Bool
symbolMatch _ = Proxy f -> Node -> Bool
forall (a :: * -> *). SymbolMatching a => Proxy a -> Node -> Bool
symbolMatch (Proxy f
forall k (t :: k). Proxy t
Proxy @f)
  showFailure :: Proxy (Rec1 f) -> Node -> String
showFailure _ = Proxy f -> Node -> String
forall (a :: * -> *). SymbolMatching a => Proxy a -> Node -> String
showFailure (Proxy f
forall k (t :: k). Proxy t
Proxy @f)

instance (KnownNat n, KnownSymbol sym) => SymbolMatching (Token sym n) where
  symbolMatch :: Proxy (Token sym n) -> Node -> Bool
symbolMatch _ node :: Node
node = Node -> TSSymbol
nodeSymbol Node
node TSSymbol -> TSSymbol -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> TSSymbol
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy @n))
  showFailure :: Proxy (Token sym n) -> Node -> String
showFailure _ _ = "expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Proxy sym -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy sym
forall k (t :: k). Proxy t
Proxy @sym)

instance (SymbolMatching f, SymbolMatching g) => SymbolMatching (f :+: g) where
  symbolMatch :: Proxy (f :+: g) -> Node -> Bool
symbolMatch _ = Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool) -> (Node -> Bool) -> Node -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy f -> Node -> Bool
forall (a :: * -> *). SymbolMatching a => Proxy a -> Node -> Bool
symbolMatch (Proxy f
forall k (t :: k). Proxy t
Proxy @f) (Node -> Bool -> Bool) -> (Node -> Bool) -> Node -> Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Proxy g -> Node -> Bool
forall (a :: * -> *). SymbolMatching a => Proxy a -> Node -> Bool
symbolMatch (Proxy g
forall k (t :: k). Proxy t
Proxy @g)
  showFailure :: Proxy (f :+: g) -> Node -> String
showFailure _ = String -> String -> String
sep (String -> String -> String)
-> (Node -> String) -> Node -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy f -> Node -> String
forall (a :: * -> *). SymbolMatching a => Proxy a -> Node -> String
showFailure (Proxy f
forall k (t :: k). Proxy t
Proxy @f) (Node -> String -> String) -> (Node -> String) -> Node -> String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Proxy g -> Node -> String
forall (a :: * -> *). SymbolMatching a => Proxy a -> Node -> String
showFailure (Proxy g
forall k (t :: k). Proxy t
Proxy @g)

sep :: String -> String -> String
sep :: String -> String -> String
sep a :: String
a b :: String
b = String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ ". " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b

-- | Advance the cursor to the next sibling of the current node.
step :: (Has (Reader (Ptr Cursor)) sig m, MonadIO m) => m Bool
step :: m Bool
step = m (Ptr Cursor)
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
m r
ask m (Ptr Cursor) -> (Ptr Cursor -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool)
-> (Ptr Cursor -> IO Bool) -> Ptr Cursor -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Cursor -> IO Bool
ts_tree_cursor_goto_next_sibling

-- | Run an action over the children of the current node.
push :: (Has (Reader (Ptr Cursor)) sig m, MonadIO m) => m a -> m (Maybe a)
push :: m a -> m (Maybe a)
push m :: m a
m = do
  Bool
hasChildren <- m (Ptr Cursor)
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
m r
ask m (Ptr Cursor) -> (Ptr Cursor -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool)
-> (Ptr Cursor -> IO Bool) -> Ptr Cursor -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Cursor -> IO Bool
ts_tree_cursor_goto_first_child
  if Bool
hasChildren then do
    a
a <- m a
m
    a -> Maybe a
forall a. a -> Maybe a
Just a
a Maybe a -> m Bool -> m (Maybe a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (m (Ptr Cursor)
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
m r
ask m (Ptr Cursor) -> (Ptr Cursor -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool)
-> (Ptr Cursor -> IO Bool) -> Ptr Cursor -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Cursor -> IO Bool
ts_tree_cursor_goto_parent)
  else
    Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

-- | Move the cursor to point at the passed 'TSNode'.
goto :: (Has (Reader (Ptr Cursor)) sig m, MonadIO m) => TSNode -> m ()
goto :: TSNode -> m ()
goto node :: TSNode
node = do
  Ptr Cursor
cursor <- m (Ptr Cursor)
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
m r
ask
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TSNode -> (Ptr TSNode -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with TSNode
node (Ptr Cursor -> Ptr TSNode -> IO ()
ts_tree_cursor_reset_p Ptr Cursor
cursor))

-- | Return the 'Node' that the cursor is pointing at.
peekNode :: (Has (Reader (Ptr Cursor)) sig m, MonadIO m) => m Node
peekNode :: m Node
peekNode = do
  Ptr Cursor
cursor <- m (Ptr Cursor)
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
m r
ask
  IO Node -> m Node
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Node -> m Node) -> IO Node -> m Node
forall a b. (a -> b) -> a -> b
$ (Ptr TSNode -> IO Node) -> IO Node
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr TSNode -> IO Node) -> IO Node)
-> (Ptr TSNode -> IO Node) -> IO Node
forall a b. (a -> b) -> a -> b
$ \ tsNodePtr :: Ptr TSNode
tsNodePtr -> do
    Bool
_ <- Ptr Cursor -> Ptr TSNode -> IO Bool
ts_tree_cursor_current_node_p Ptr Cursor
cursor Ptr TSNode
tsNodePtr
    (Ptr Node -> IO Node) -> IO Node
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Node -> IO Node) -> IO Node)
-> (Ptr Node -> IO Node) -> IO Node
forall a b. (a -> b) -> a -> b
$ \ nodePtr :: Ptr Node
nodePtr -> do
      Ptr TSNode -> Ptr Node -> IO ()
ts_node_poke_p Ptr TSNode
tsNodePtr Ptr Node
nodePtr
      Ptr Node -> IO Node
forall a. Storable a => Ptr a -> IO a
peek Ptr Node
nodePtr

-- | Return the field name (if any) for the node that the cursor is pointing at (if any), or 'Nothing' otherwise.
peekFieldName :: (Has (Reader (Ptr Cursor)) sig m, MonadIO m) => m (Maybe FieldName)
peekFieldName :: m (Maybe FieldName)
peekFieldName = do
  Ptr Cursor
cursor <- m (Ptr Cursor)
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
m r
ask
  CString
fieldName <- IO CString -> m CString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CString -> m CString) -> IO CString -> m CString
forall a b. (a -> b) -> a -> b
$ Ptr Cursor -> IO CString
ts_tree_cursor_current_field_name Ptr Cursor
cursor
  if CString
fieldName CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
nullPtr then
    Maybe FieldName -> m (Maybe FieldName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FieldName
forall a. Maybe a
Nothing
  else
    FieldName -> Maybe FieldName
forall a. a -> Maybe a
Just (FieldName -> Maybe FieldName)
-> (String -> FieldName) -> String -> Maybe FieldName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FieldName
FieldName (String -> FieldName) -> (String -> String) -> String -> FieldName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toHaskellCamelCaseIdentifier (String -> Maybe FieldName) -> m String -> m (Maybe FieldName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CString -> IO String
peekCString CString
fieldName)


type Fields = Map.Map FieldName [Node]

-- | Return the fields remaining in the current branch, represented as 'Map.Map' of 'FieldName's to their corresponding 'Node's.
getFields :: (Has (Reader (Ptr Cursor)) sig m, MonadIO m) => m Fields
getFields :: m Fields
getFields = Fields -> m Fields
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Algebra sig m, Member (Reader (Ptr Cursor)) sig, MonadIO m) =>
Fields -> m Fields
go Fields
forall k a. Map k a
Map.empty
  where go :: Fields -> m Fields
go fs :: Fields
fs = do
          Node
node <- m Node
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Reader (Ptr Cursor)) sig m, MonadIO m) =>
m Node
peekNode
          Maybe FieldName
fieldName <- m (Maybe FieldName)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Reader (Ptr Cursor)) sig m, MonadIO m) =>
m (Maybe FieldName)
peekFieldName
          Bool
keepGoing <- m Bool
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Reader (Ptr Cursor)) sig m, MonadIO m) =>
m Bool
step
          let fs' :: Fields
fs' = case Maybe FieldName
fieldName of
                Just fieldName' :: FieldName
fieldName' -> ([Node] -> [Node] -> [Node])
-> FieldName -> [Node] -> Fields -> Fields
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (([Node] -> [Node] -> [Node]) -> [Node] -> [Node] -> [Node]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Node] -> [Node] -> [Node]
forall a. [a] -> [a] -> [a]
(++)) FieldName
fieldName' [Node
node] Fields
fs
                -- NB: We currently skip “extra” nodes (i.e. ones occurring in the @extras@ rule), pending a fix to https://github.com/tree-sitter/haskell-tree-sitter/issues/99
                _ -> if Node -> CBool
nodeIsNamed Node
node CBool -> CBool -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 Bool -> Bool -> Bool
&& Node -> CBool
nodeIsExtra Node
node CBool -> CBool -> Bool
forall a. Eq a => a -> a -> Bool
== 0
                  then ([Node] -> [Node] -> [Node])
-> FieldName -> [Node] -> Fields -> Fields
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (([Node] -> [Node] -> [Node]) -> [Node] -> [Node] -> [Node]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Node] -> [Node] -> [Node]
forall a. [a] -> [a] -> [a]
(++)) (String -> FieldName
FieldName "extraChildren") [Node
node] Fields
fs
                  else Fields
fs
          if Bool
keepGoing then Fields -> m Fields
go Fields
fs'
          else Fields -> m Fields
forall (f :: * -> *) a. Applicative f => a -> f a
pure Fields
fs'

lookupField :: FieldName -> Fields -> [Node]
lookupField :: FieldName -> Fields -> [Node]
lookupField k :: FieldName
k = [Node] -> Maybe [Node] -> [Node]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Node] -> [Node])
-> (Fields -> Maybe [Node]) -> Fields -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Fields -> Maybe [Node]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
k


-- | Return a 'ByteString' that contains a slice of the given 'ByteString'.
slice :: Range -> ByteString -> ByteString
slice :: Range -> ByteString -> ByteString
slice (Range start :: Int
start end :: Int
end) = ByteString -> ByteString
take (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
drop
  where drop :: ByteString -> ByteString
drop = Int -> ByteString -> ByteString
B.drop Int
start
        take :: ByteString -> ByteString
take = Int -> ByteString -> ByteString
B.take (Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start)


newtype FieldName = FieldName { FieldName -> String
getFieldName :: String }
  deriving (FieldName -> FieldName -> Bool
(FieldName -> FieldName -> Bool)
-> (FieldName -> FieldName -> Bool) -> Eq FieldName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FieldName -> FieldName -> Bool
$c/= :: FieldName -> FieldName -> Bool
== :: FieldName -> FieldName -> Bool
$c== :: FieldName -> FieldName -> Bool
Eq, Eq FieldName
Eq FieldName =>
(FieldName -> FieldName -> Ordering)
-> (FieldName -> FieldName -> Bool)
-> (FieldName -> FieldName -> Bool)
-> (FieldName -> FieldName -> Bool)
-> (FieldName -> FieldName -> Bool)
-> (FieldName -> FieldName -> FieldName)
-> (FieldName -> FieldName -> FieldName)
-> Ord FieldName
FieldName -> FieldName -> Bool
FieldName -> FieldName -> Ordering
FieldName -> FieldName -> FieldName
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FieldName -> FieldName -> FieldName
$cmin :: FieldName -> FieldName -> FieldName
max :: FieldName -> FieldName -> FieldName
$cmax :: FieldName -> FieldName -> FieldName
>= :: FieldName -> FieldName -> Bool
$c>= :: FieldName -> FieldName -> Bool
> :: FieldName -> FieldName -> Bool
$c> :: FieldName -> FieldName -> Bool
<= :: FieldName -> FieldName -> Bool
$c<= :: FieldName -> FieldName -> Bool
< :: FieldName -> FieldName -> Bool
$c< :: FieldName -> FieldName -> Bool
compare :: FieldName -> FieldName -> Ordering
$ccompare :: FieldName -> FieldName -> Ordering
$cp1Ord :: Eq FieldName
Ord, Int -> FieldName -> String -> String
[FieldName] -> String -> String
FieldName -> String
(Int -> FieldName -> String -> String)
-> (FieldName -> String)
-> ([FieldName] -> String -> String)
-> Show FieldName
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [FieldName] -> String -> String
$cshowList :: [FieldName] -> String -> String
show :: FieldName -> String
$cshow :: FieldName -> String
showsPrec :: Int -> FieldName -> String -> String
$cshowsPrec :: Int -> FieldName -> String -> String
Show)


-- | Generic construction of ASTs from a 'Map.Map' of named fields.
--
--   Product types (specifically, record types) are constructed by looking up the node for each corresponding field name in the map, moving the cursor to it, and then invoking 'unmarshalNode' to construct the value for that field. Leaf types are constructed as a special case of product types.
--
--   Sum types are constructed by attempting to unmarshal each constructor nondeterministically. This should instead use the current node’s symbol to select the corresponding constructor deterministically.
class GUnmarshal f where
  gunmarshalNode
    :: ( Has (Reader ByteString) sig m
       , Has (Reader (Ptr Cursor)) sig m
       , MonadFail m
       , MonadIO m
       , UnmarshalAnn a
       )
    => Node
    -> m (f a)

instance GUnmarshal f => GUnmarshal (M1 i c f) where
  gunmarshalNode :: Node -> m (M1 i c f a)
gunmarshalNode node :: Node
node = f a -> M1 i c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 i c f a) -> m (f a) -> m (M1 i c f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> m (f a)
forall (f :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(GUnmarshal f, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m,
 UnmarshalAnn a) =>
Node -> m (f a)
gunmarshalNode Node
node

-- For anonymous leaf nodes:
instance GUnmarshal U1 where
  gunmarshalNode :: Node -> m (U1 a)
gunmarshalNode _ = U1 a -> m (U1 a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1


-- For unary products:
instance UnmarshalAnn k => GUnmarshal (K1 c k) where
  gunmarshalNode :: Node -> m (K1 c k a)
gunmarshalNode node :: Node
node = k -> K1 c k a
forall k i c (p :: k). c -> K1 i c p
K1 (k -> K1 c k a) -> m k -> m (K1 c k a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> m k
forall a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(UnmarshalAnn a, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m) =>
Node -> m a
unmarshalAnn Node
node

-- For anonymous leaf nodes
instance GUnmarshal Par1 where
  gunmarshalNode :: Node -> m (Par1 a)
gunmarshalNode node :: Node
node = a -> Par1 a
forall p. p -> Par1 p
Par1 (a -> Par1 a) -> m a -> m (Par1 a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> m a
forall a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(UnmarshalAnn a, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m) =>
Node -> m a
unmarshalAnn Node
node

instance Unmarshal t => GUnmarshal (Rec1 t) where
  gunmarshalNode :: Node -> m (Rec1 t a)
gunmarshalNode node :: Node
node = t a -> Rec1 t a
forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 (t a -> Rec1 t a) -> m (t a) -> m (Rec1 t a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> m (t a)
forall (t :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Unmarshal t, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m,
 UnmarshalAnn a) =>
Node -> m (t a)
unmarshalNode Node
node

-- For product datatypes:
instance (GUnmarshalProduct f, GUnmarshalProduct g) => GUnmarshal (f :*: g) where
  gunmarshalNode :: Node -> m ((:*:) f g a)
gunmarshalNode node :: Node
node = m Fields -> m (Maybe Fields)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (Reader (Ptr Cursor)) sig m, MonadIO m) =>
m a -> m (Maybe a)
push m Fields
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Reader (Ptr Cursor)) sig m, MonadIO m) =>
m Fields
getFields m (Maybe Fields)
-> (Maybe Fields -> m ((:*:) f g a)) -> m ((:*:) f g a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Node -> Fields -> m ((:*:) f g a)
forall (f :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(GUnmarshalProduct f, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m,
 UnmarshalAnn a) =>
Node -> Fields -> m (f a)
gunmarshalProductNode @(f :*: g) Node
node (Fields -> m ((:*:) f g a))
-> (Maybe Fields -> Fields) -> Maybe Fields -> m ((:*:) f g a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fields -> Maybe Fields -> Fields
forall a. a -> Maybe a -> a
fromMaybe Fields
forall k a. Map k a
Map.empty

-- For sum datatypes:
instance (GUnmarshal f, GUnmarshal g, SymbolMatching f, SymbolMatching g) => GUnmarshal (f :+: g) where
  gunmarshalNode :: Node -> m ((:+:) f g a)
gunmarshalNode node :: Node
node = do
    let lhsSymbolMatch :: Bool
lhsSymbolMatch = Proxy f -> Node -> Bool
forall (a :: * -> *). SymbolMatching a => Proxy a -> Node -> Bool
symbolMatch (Proxy f
forall k (t :: k). Proxy t
Proxy @f) Node
node
        rhsSymbolMatch :: Bool
rhsSymbolMatch = Proxy g -> Node -> Bool
forall (a :: * -> *). SymbolMatching a => Proxy a -> Node -> Bool
symbolMatch (Proxy g
forall k (t :: k). Proxy t
Proxy @g) Node
node
    if Bool
lhsSymbolMatch then
      f a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f a -> (:+:) f g a) -> m (f a) -> m ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> m (f a)
forall (f :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(GUnmarshal f, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m,
 UnmarshalAnn a) =>
Node -> m (f a)
gunmarshalNode @f Node
node
    else if Bool
rhsSymbolMatch then
      g a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g a -> (:+:) f g a) -> m (g a) -> m ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> m (g a)
forall (f :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(GUnmarshal f, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m,
 UnmarshalAnn a) =>
Node -> m (f a)
gunmarshalNode @g Node
node
    else
      String -> m ((:+:) f g a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ((:+:) f g a)) -> String -> m ((:+:) f g a)
forall a b. (a -> b) -> a -> b
$ Proxy f -> Node -> String
forall (a :: * -> *). SymbolMatching a => Proxy a -> Node -> String
showFailure (Proxy f
forall k (t :: k). Proxy t
Proxy @f) Node
node String -> String -> String
`sep` Proxy g -> Node -> String
forall (a :: * -> *). SymbolMatching a => Proxy a -> Node -> String
showFailure (Proxy g
forall k (t :: k). Proxy t
Proxy @g) Node
node


-- | Generically unmarshal products
class GUnmarshalProduct f where
  gunmarshalProductNode
    :: ( Has (Reader ByteString) sig m
       , Has (Reader (Ptr Cursor)) sig m
       , MonadFail m
       , MonadIO m
       , UnmarshalAnn a
       )
    => Node
    -> Fields
    -> m (f a)

-- Product structure
instance (GUnmarshalProduct f, GUnmarshalProduct g) => GUnmarshalProduct (f :*: g) where
  gunmarshalProductNode :: Node -> Fields -> m ((:*:) f g a)
gunmarshalProductNode node :: Node
node fields :: Fields
fields = f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:)
    (f a -> g a -> (:*:) f g a) -> m (f a) -> m (g a -> (:*:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> Fields -> m (f a)
forall (f :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(GUnmarshalProduct f, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m,
 UnmarshalAnn a) =>
Node -> Fields -> m (f a)
gunmarshalProductNode @f Node
node Fields
fields
    m (g a -> (:*:) f g a) -> m (g a) -> m ((:*:) f g a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Fields -> m (g a)
forall (f :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(GUnmarshalProduct f, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m,
 UnmarshalAnn a) =>
Node -> Fields -> m (f a)
gunmarshalProductNode @g Node
node Fields
fields

-- Contents of product types (ie., the leaves of the product tree)
instance UnmarshalAnn k => GUnmarshalProduct (M1 S c (K1 i k)) where
  gunmarshalProductNode :: Node -> Fields -> m (M1 S c (K1 i k) a)
gunmarshalProductNode node :: Node
node _ = K1 i k a -> M1 S c (K1 i k) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 i k a -> M1 S c (K1 i k) a)
-> (k -> K1 i k a) -> k -> M1 S c (K1 i k) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> K1 i k a
forall k i c (p :: k). c -> K1 i c p
K1 (k -> M1 S c (K1 i k) a) -> m k -> m (M1 S c (K1 i k) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> m k
forall a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(UnmarshalAnn a, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m) =>
Node -> m a
unmarshalAnn Node
node

instance GUnmarshalProduct (M1 S c Par1) where
  gunmarshalProductNode :: Node -> Fields -> m (M1 S c Par1 a)
gunmarshalProductNode node :: Node
node _ = Par1 a -> M1 S c Par1 a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Par1 a -> M1 S c Par1 a) -> (a -> Par1 a) -> a -> M1 S c Par1 a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Par1 a
forall p. p -> Par1 p
Par1 (a -> M1 S c Par1 a) -> m a -> m (M1 S c Par1 a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> m a
forall a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(UnmarshalAnn a, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m) =>
Node -> m a
unmarshalAnn Node
node

instance (UnmarshalField f, Unmarshal g, Selector c) => GUnmarshalProduct (M1 S c (f :.: g)) where
  gunmarshalProductNode :: Node -> Fields -> m (M1 S c (f :.: g) a)
gunmarshalProductNode _ fields :: Fields
fields =
    (:.:) f g a -> M1 S c (f :.: g) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 ((:.:) f g a -> M1 S c (f :.: g) a)
-> (f (g a) -> (:.:) f g a) -> f (g a) -> M1 S c (f :.: g) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (g a) -> (:.:) f g a
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (f (g a) -> M1 S c (f :.: g) a)
-> m (f (g a)) -> m (M1 S c (f :.: g) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Node] -> m (f (g a))
forall (t :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *)
       (f :: * -> *) a.
(UnmarshalField t, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m,
 Unmarshal f, UnmarshalAnn a) =>
[Node] -> m (t (f a))
unmarshalField (FieldName -> Fields -> [Node]
lookupField (String -> FieldName
FieldName (Any c Any Any -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName @c Any c Any Any
forall a. HasCallStack => a
undefined)) Fields
fields)

instance (Unmarshal t, Selector c) => GUnmarshalProduct (M1 S c (Rec1 t)) where
  gunmarshalProductNode :: Node -> Fields -> m (M1 S c (Rec1 t) a)
gunmarshalProductNode _ fields :: Fields
fields =
    case FieldName -> Fields -> [Node]
lookupField (String -> FieldName
FieldName (Any c Any Any -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName @c Any c Any Any
forall a. HasCallStack => a
undefined)) Fields
fields of
      []  -> String -> m (M1 S c (Rec1 t) a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (M1 S c (Rec1 t) a))
-> String -> m (M1 S c (Rec1 t) a)
forall a b. (a -> b) -> a -> b
$ "expected a node " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Any c Any Any -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName @c Any c Any Any
forall a. HasCallStack => a
undefined String -> String -> String
forall a. Semigroup a => a -> a -> a
<> " but didn't get one"
      [x :: Node
x] -> Rec1 t a -> M1 S c (Rec1 t) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Rec1 t a -> M1 S c (Rec1 t) a)
-> (t a -> Rec1 t a) -> t a -> M1 S c (Rec1 t) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t a -> Rec1 t a
forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 (t a -> M1 S c (Rec1 t) a) -> m (t a) -> m (M1 S c (Rec1 t) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> m (t a)
forall (t :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Unmarshal t, Has (Reader ByteString) sig m,
 Has (Reader (Ptr Cursor)) sig m, MonadFail m, MonadIO m,
 UnmarshalAnn a) =>
Node -> m (t a)
unmarshalNode Node
x
      _   -> String -> m (M1 S c (Rec1 t) a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "expected a node but got multiple"