{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module TreeSitter.Unmarshal
( parseByteString
, UnmarshalState(..)
, UnmarshalError(..)
, FieldName(..)
, Unmarshal(..)
, UnmarshalAnn(..)
, UnmarshalField(..)
, SymbolMatching(..)
, Match(..)
, hoist
, lookupSymbol
, unmarshalNode
, GHasAnn(..)
) where

import           Control.Algebra (send)
import           Control.Carrier.Reader hiding (asks)
import           Control.Exception
import           Control.Monad.IO.Class
import           Data.ByteString (ByteString)
import qualified Data.ByteString as B
import           Data.Coerce
import           Data.Foldable (toList)
import qualified Data.IntMap as IntMap
import           Data.List.NonEmpty (NonEmpty (..))
import           Data.Proxy
import qualified Data.Text as Text
import           Data.Text.Encoding
import           Data.Text.Encoding.Error (lenientDecode)
import           Foreign.C.String
import           Foreign.Marshal.Array
import           Foreign.Marshal.Utils
import           Foreign.Ptr
import           Foreign.Storable
import           GHC.Generics
import           GHC.Records
import           GHC.TypeLits
import           Source.Loc
import           Source.Span
import           TreeSitter.Cursor as TS
import           TreeSitter.Language as TS
import           TreeSitter.Node as TS
import           TreeSitter.Parser as TS
import           TreeSitter.Token as TS
import           TreeSitter.Tree as TS

asks :: Has (Reader r) sig m => (r -> r') -> m r'
asks :: (r -> r') -> m r'
asks f :: r -> r'
f = Reader r m r' -> m r'
forall (eff :: (* -> *) -> * -> *) (sig :: (* -> *) -> * -> *)
       (m :: * -> *) a.
(Member eff sig, Algebra sig m) =>
eff m a -> m a
send ((r -> m r') -> Reader r m r'
forall r (m :: * -> *) k. (r -> m k) -> Reader r m k
Ask (r' -> m r'
forall (f :: * -> *) a. Applicative f => a -> f a
pure (r' -> m r') -> (r -> r') -> r -> m r'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> r'
f))
{-# INLINE asks #-}

-- 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 ->
        (t a -> Either String (t a)
forall a b. b -> Either a b
Right (t a -> Either String (t a))
-> IO (t a) -> IO (Either String (t a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnmarshalState -> ReaderC UnmarshalState IO (t a) -> IO (t a)
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader (ByteString -> Ptr Cursor -> UnmarshalState
UnmarshalState ByteString
bytestring Ptr Cursor
cursor) (IO Node -> ReaderC UnmarshalState IO Node
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Node -> IO Node
forall a. Storable a => Ptr a -> IO a
peek Ptr Node
rootPtr) ReaderC UnmarshalState IO Node
-> (Node -> ReaderC UnmarshalState IO (t a))
-> ReaderC UnmarshalState IO (t a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Node -> ReaderC UnmarshalState IO (t a)
forall (t :: * -> *) a.
(UnmarshalAnn a, Unmarshal t) =>
Node -> MatchM (t a)
unmarshalNode))
          IO (Either String (t a))
-> (UnmarshalError -> IO (Either String (t a)))
-> IO (Either String (t a))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (Either String (t a) -> IO (Either String (t a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (t a) -> IO (Either String (t a)))
-> (UnmarshalError -> Either String (t a))
-> UnmarshalError
-> IO (Either String (t a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String (t a)
forall a b. a -> Either a b
Left (String -> Either String (t a))
-> (UnmarshalError -> String)
-> UnmarshalError
-> Either String (t a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnmarshalError -> String
getUnmarshalError)

newtype UnmarshalError = UnmarshalError { UnmarshalError -> String
getUnmarshalError :: String }
  deriving (Int -> UnmarshalError -> ShowS
[UnmarshalError] -> ShowS
UnmarshalError -> String
(Int -> UnmarshalError -> ShowS)
-> (UnmarshalError -> String)
-> ([UnmarshalError] -> ShowS)
-> Show UnmarshalError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnmarshalError] -> ShowS
$cshowList :: [UnmarshalError] -> ShowS
show :: UnmarshalError -> String
$cshow :: UnmarshalError -> String
showsPrec :: Int -> UnmarshalError -> ShowS
$cshowsPrec :: Int -> UnmarshalError -> ShowS
Show)

instance Exception UnmarshalError

data UnmarshalState = UnmarshalState
  { UnmarshalState -> ByteString
source :: {-# UNPACK #-} !ByteString
  , UnmarshalState -> Ptr Cursor
cursor :: {-# UNPACK #-} !(Ptr Cursor)
  }

type MatchM = ReaderC UnmarshalState IO

newtype Match t = Match
  { Match t -> forall a. UnmarshalAnn a => Node -> MatchM (t a)
runMatch :: forall a . UnmarshalAnn a => Node -> MatchM (t a)
  }

-- | A church-encoded binary tree with constant-time 'singleton', 'mempty', '<>', and 'fmap', and linear-time 'foldMap'.
newtype B a = B (forall r . (r -> r -> r) -> (a -> r) -> r -> r)

instance Functor B where
  fmap :: (a -> b) -> B a -> B b
fmap f :: a -> b
f (B run :: forall r. (r -> r -> r) -> (a -> r) -> r -> r
run) = (forall r. (r -> r -> r) -> (b -> r) -> r -> r) -> B b
forall a. (forall r. (r -> r -> r) -> (a -> r) -> r -> r) -> B a
B (\ fork :: r -> r -> r
fork leaf :: b -> r
leaf -> (r -> r -> r) -> (a -> r) -> r -> r
forall r. (r -> r -> r) -> (a -> r) -> r -> r
run r -> r -> r
fork (b -> r
leaf (b -> r) -> (a -> b) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))
  {-# INLINE fmap #-}
  a :: a
a <$ :: a -> B b -> B a
<$ B run :: forall r. (r -> r -> r) -> (b -> r) -> r -> r
run = (forall r. (r -> r -> r) -> (a -> r) -> r -> r) -> B a
forall a. (forall r. (r -> r -> r) -> (a -> r) -> r -> r) -> B a
B (\ fork :: r -> r -> r
fork leaf :: a -> r
leaf -> (r -> r -> r) -> (b -> r) -> r -> r
forall r. (r -> r -> r) -> (b -> r) -> r -> r
run r -> r -> r
fork (a -> r
leaf (a -> r) -> (b -> a) -> b -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> a
forall a b. a -> b -> a
const a
a))
  {-# INLINE (<$) #-}

instance Semigroup (B a) where
  B l :: forall r. (r -> r -> r) -> (a -> r) -> r -> r
l <> :: B a -> B a -> B a
<> B r :: forall r. (r -> r -> r) -> (a -> r) -> r -> r
r = (forall r. (r -> r -> r) -> (a -> r) -> r -> r) -> B a
forall a. (forall r. (r -> r -> r) -> (a -> r) -> r -> r) -> B a
B (\ fork :: r -> r -> r
fork leaf :: a -> r
leaf nil :: r
nil -> r -> r -> r
fork ((r -> r -> r) -> (a -> r) -> r -> r
forall r. (r -> r -> r) -> (a -> r) -> r -> r
l r -> r -> r
fork a -> r
leaf r
nil) ((r -> r -> r) -> (a -> r) -> r -> r
forall r. (r -> r -> r) -> (a -> r) -> r -> r
r r -> r -> r
fork a -> r
leaf r
nil))
  {-# INLINE (<>) #-}

instance Monoid (B a) where
  mempty :: B a
mempty = (forall r. (r -> r -> r) -> (a -> r) -> r -> r) -> B a
forall a. (forall r. (r -> r -> r) -> (a -> r) -> r -> r) -> B a
B (\ _ _ nil :: r
nil -> r
nil)
  {-# INLINE mempty #-}

instance Foldable B where
  foldMap :: (a -> m) -> B a -> m
foldMap f :: a -> m
f (B run :: forall r. (r -> r -> r) -> (a -> r) -> r -> r
run) = (m -> m -> m) -> (a -> m) -> m -> m
forall r. (r -> r -> r) -> (a -> r) -> r -> r
run m -> m -> m
forall a. Semigroup a => a -> a -> a
(<>) a -> m
f m
forall a. Monoid a => a
mempty
  {-# INLINE foldMap #-}

singleton :: a -> B a
singleton :: a -> B a
singleton a :: a
a = (forall r. (r -> r -> r) -> (a -> r) -> r -> r) -> B a
forall a. (forall r. (r -> r -> r) -> (a -> r) -> r -> r) -> B a
B (\ _ leaf :: a -> r
leaf _ -> a -> r
leaf a
a)
{-# INLINE singleton #-}

hoist :: (forall x . t x -> t' x) -> Match t -> Match t'
hoist :: (forall x. t x -> t' x) -> Match t -> Match t'
hoist f :: forall x. t x -> t' x
f (Match run :: forall a. UnmarshalAnn a => Node -> MatchM (t a)
run) = (forall a. UnmarshalAnn a => Node -> MatchM (t' a)) -> Match t'
forall (t :: * -> *).
(forall a. UnmarshalAnn a => Node -> MatchM (t a)) -> Match t
Match ((t a -> t' a)
-> ReaderC UnmarshalState IO (t a)
-> ReaderC UnmarshalState IO (t' a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t a -> t' a
forall x. t x -> t' x
f (ReaderC UnmarshalState IO (t a)
 -> ReaderC UnmarshalState IO (t' a))
-> (Node -> ReaderC UnmarshalState IO (t a))
-> Node
-> ReaderC UnmarshalState IO (t' a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> ReaderC UnmarshalState IO (t a)
forall a. UnmarshalAnn a => Node -> MatchM (t a)
run)
{-# INLINE hoist #-}

lookupSymbol :: TSSymbol -> IntMap.IntMap a -> Maybe a
lookupSymbol :: TSSymbol -> IntMap a -> Maybe a
lookupSymbol sym :: TSSymbol
sym map :: IntMap a
map = Int -> IntMap a -> Maybe a
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (TSSymbol -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral TSSymbol
sym) IntMap a
map
{-# INLINE lookupSymbol #-}

-- | Unmarshal a node
unmarshalNode :: forall t a .
                 ( UnmarshalAnn a
                 , Unmarshal t
                 )
  => Node
  -> MatchM (t a)
unmarshalNode :: Node -> MatchM (t a)
unmarshalNode node :: Node
node = case TSSymbol -> IntMap (Match t) -> Maybe (Match t)
forall a. TSSymbol -> IntMap a -> Maybe a
lookupSymbol (Node -> TSSymbol
nodeSymbol Node
node) IntMap (Match t)
forall (t :: * -> *). Unmarshal t => IntMap (Match t)
matchers' of
  Just t :: Match t
t  -> Match t -> Node -> MatchM (t a)
forall (t :: * -> *).
Match t -> forall a. UnmarshalAnn a => Node -> MatchM (t a)
runMatch Match t
t Node
node
  Nothing -> IO (t a) -> MatchM (t a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (t a) -> MatchM (t a))
-> (String -> IO (t a)) -> String -> MatchM (t a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnmarshalError -> IO (t a)
forall e a. Exception e => e -> IO a
throwIO (UnmarshalError -> IO (t a))
-> (String -> UnmarshalError) -> String -> IO (t a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> UnmarshalError
UnmarshalError (String -> MatchM (t a)) -> String -> MatchM (t a)
forall a b. (a -> b) -> a -> b
$ Proxy t -> Node -> String
forall (a :: * -> *). SymbolMatching a => Proxy a -> Node -> String
showFailure (Proxy t
forall k (t :: k). Proxy t
Proxy @t) Node
node
{-# INLINE 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 'matchers' providing that they have a suitable 'Generic1' instance.
class SymbolMatching t => Unmarshal t where
  matchers' :: IntMap.IntMap (Match t)
  matchers' = [(Int, Match t)] -> IntMap (Match t)
forall a. [(Int, a)] -> IntMap a
IntMap.fromList (B (Int, Match t) -> [(Int, Match t)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList B (Int, Match t)
forall (t :: * -> *). Unmarshal t => B (Int, Match t)
matchers)

  matchers :: B (Int, Match t)
  default matchers :: (Generic1 t, GUnmarshal (Rep1 t)) => B (Int, Match t)
  matchers = (Int -> B (Int, Match t)) -> [Int] -> B (Int, Match t)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Int, Match t) -> B (Int, Match t)
forall a. a -> B a
singleton ((Int, Match t) -> B (Int, Match t))
-> (Int -> (Int, Match t)) -> Int -> B (Int, Match t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, Match t
match)) (Proxy t -> [Int]
forall (a :: * -> *). SymbolMatching a => Proxy a -> [Int]
matchedSymbols (Proxy t
forall k (t :: k). Proxy t
Proxy @t))
    where match :: Match t
match = (forall a. UnmarshalAnn a => Node -> MatchM (t a)) -> Match t
forall (t :: * -> *).
(forall a. UnmarshalAnn a => Node -> MatchM (t a)) -> Match t
Match ((forall a. UnmarshalAnn a => Node -> MatchM (t a)) -> Match t)
-> (forall a. UnmarshalAnn a => Node -> MatchM (t a)) -> Match t
forall a b. (a -> b) -> a -> b
$ \ node :: Node
node -> do
            Ptr Cursor
cursor <- (UnmarshalState -> Ptr Cursor)
-> ReaderC UnmarshalState IO (Ptr Cursor)
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *) r'.
Has (Reader r) sig m =>
(r -> r') -> m r'
asks UnmarshalState -> Ptr Cursor
cursor
            Ptr Cursor -> TSNode -> MatchM ()
goto Ptr Cursor
cursor (Node -> TSNode
nodeTSNode Node
node)
            (Rep1 t a -> t a)
-> ReaderC UnmarshalState IO (Rep1 t a)
-> ReaderC UnmarshalState IO (t a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep1 t a -> t a
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 (Node -> ReaderC UnmarshalState IO (Rep1 t a)
forall (f :: * -> *) a.
(GUnmarshal f, UnmarshalAnn a) =>
Node -> MatchM (f a)
gunmarshalNode Node
node)

instance (Unmarshal f, Unmarshal g) => Unmarshal (f :+: g) where
  matchers :: B (Int, Match (f :+: g))
matchers = ((Int, Match f) -> (Int, Match (f :+: g)))
-> B (Int, Match f) -> B (Int, Match (f :+: g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Match f -> Match (f :+: g))
-> (Int, Match f) -> (Int, Match (f :+: g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall x. f x -> (:+:) f g x) -> Match f -> Match (f :+: g)
forall (t :: * -> *) (t' :: * -> *).
(forall x. t x -> t' x) -> Match t -> Match t'
hoist forall x. f x -> (:+:) f g x
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1)) B (Int, Match f)
forall (t :: * -> *). Unmarshal t => B (Int, Match t)
matchers B (Int, Match (f :+: g))
-> B (Int, Match (f :+: g)) -> B (Int, Match (f :+: g))
forall a. Semigroup a => a -> a -> a
<> ((Int, Match g) -> (Int, Match (f :+: g)))
-> B (Int, Match g) -> B (Int, Match (f :+: g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Match g -> Match (f :+: g))
-> (Int, Match g) -> (Int, Match (f :+: g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall x. g x -> (:+:) f g x) -> Match g -> Match (f :+: g)
forall (t :: * -> *) (t' :: * -> *).
(forall x. t x -> t' x) -> Match t -> Match t'
hoist forall x. g x -> (:+:) f g x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1)) B (Int, Match g)
forall (t :: * -> *). Unmarshal t => B (Int, Match t)
matchers

instance Unmarshal t => Unmarshal (Rec1 t) where
  matchers :: B (Int, Match (Rec1 t))
matchers = B (Int, Match t) -> B (Int, Match (Rec1 t))
forall a b. Coercible a b => a -> b
coerce (Unmarshal t => B (Int, Match t)
forall (t :: * -> *). Unmarshal t => B (Int, Match t)
matchers @t)

instance (KnownNat n, KnownSymbol sym) => Unmarshal (Token sym n) where
  matchers :: B (Int, Match (Token sym n))
matchers = (Int, Match (Token sym n)) -> B (Int, Match (Token sym n))
forall a. a -> B a
singleton (Integer -> Int
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)), (forall a. UnmarshalAnn a => Node -> MatchM (Token sym n a))
-> Match (Token sym n)
forall (t :: * -> *).
(forall a. UnmarshalAnn a => Node -> MatchM (t a)) -> Match t
Match ((a -> Token sym n a)
-> ReaderC UnmarshalState IO a
-> ReaderC UnmarshalState IO (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 (ReaderC UnmarshalState IO a
 -> ReaderC UnmarshalState IO (Token sym n a))
-> (Node -> ReaderC UnmarshalState IO a)
-> Node
-> ReaderC UnmarshalState IO (Token sym n a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> ReaderC UnmarshalState IO a
forall a. UnmarshalAnn a => Node -> MatchM 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
    :: Node
    -> MatchM a

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

instance UnmarshalAnn Text.Text where
  unmarshalAnn :: Node -> MatchM Text
unmarshalAnn node :: Node
node = do
    Range
range <- Node -> MatchM Range
forall a. UnmarshalAnn a => Node -> MatchM a
unmarshalAnn Node
node
    (UnmarshalState -> Text) -> MatchM Text
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *) r'.
Has (Reader r) sig m =>
(r -> r') -> m r'
asks (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text)
-> (UnmarshalState -> ByteString) -> UnmarshalState -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> ByteString -> ByteString
slice Range
range (ByteString -> ByteString)
-> (UnmarshalState -> ByteString) -> UnmarshalState -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnmarshalState -> ByteString
source)

-- | Instance for pairs of annotations
instance (UnmarshalAnn a, UnmarshalAnn b) => UnmarshalAnn (a,b) where
  unmarshalAnn :: Node -> MatchM (a, b)
unmarshalAnn node :: Node
node = (,)
    (a -> b -> (a, b))
-> ReaderC UnmarshalState IO a
-> ReaderC UnmarshalState IO (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> ReaderC UnmarshalState IO a
forall a. UnmarshalAnn a => Node -> MatchM a
unmarshalAnn @a Node
node
    ReaderC UnmarshalState IO (b -> (a, b))
-> ReaderC UnmarshalState IO b -> MatchM (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> ReaderC UnmarshalState IO b
forall a. UnmarshalAnn a => Node -> MatchM a
unmarshalAnn @b Node
node

instance UnmarshalAnn Loc where
  unmarshalAnn :: Node -> MatchM Loc
unmarshalAnn node :: Node
node = Range -> Span -> Loc
Loc
    (Range -> Span -> Loc)
-> MatchM Range -> ReaderC UnmarshalState IO (Span -> Loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> MatchM Range
forall a. UnmarshalAnn a => Node -> MatchM a
unmarshalAnn @Range Node
node
    ReaderC UnmarshalState IO (Span -> Loc)
-> ReaderC UnmarshalState IO Span -> MatchM Loc
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> ReaderC UnmarshalState IO Span
forall a. UnmarshalAnn a => Node -> MatchM a
unmarshalAnn @Span  Node
node

instance UnmarshalAnn Range where
  unmarshalAnn :: Node -> MatchM 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 -> MatchM Range
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Range
Range Int
start Int
end)

instance UnmarshalAnn Span where
  unmarshalAnn :: Node -> ReaderC UnmarshalState IO 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 -> ReaderC UnmarshalState IO 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
    :: ( Unmarshal f
       , UnmarshalAnn a
       )
    => String -- ^ datatype name
    -> String -- ^ field name
    -> [Node] -- ^ nodes
    -> MatchM (t (f a))

instance UnmarshalField Maybe where
  unmarshalField :: String -> String -> [Node] -> MatchM (Maybe (f a))
unmarshalField _ _ []  = Maybe (f a) -> MatchM (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))
-> ReaderC UnmarshalState IO (f a) -> MatchM (Maybe (f a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> ReaderC UnmarshalState IO (f a)
forall (t :: * -> *) a.
(UnmarshalAnn a, Unmarshal t) =>
Node -> MatchM (t a)
unmarshalNode Node
x
  unmarshalField d :: String
d f :: String
f _   = IO (Maybe (f a)) -> MatchM (Maybe (f a))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (f a)) -> MatchM (Maybe (f a)))
-> (String -> IO (Maybe (f a))) -> String -> MatchM (Maybe (f a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnmarshalError -> IO (Maybe (f a))
forall e a. Exception e => e -> IO a
throwIO (UnmarshalError -> IO (Maybe (f a)))
-> (String -> UnmarshalError) -> String -> IO (Maybe (f a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> UnmarshalError
UnmarshalError (String -> MatchM (Maybe (f a))) -> String -> MatchM (Maybe (f a))
forall a b. (a -> b) -> a -> b
$ "type '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
d String -> ShowS
forall a. Semigroup a => a -> a -> a
<> "' expected zero or one nodes in field '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
f String -> ShowS
forall a. Semigroup a => a -> a -> a
<> "' but got multiple"

instance UnmarshalField [] where
  unmarshalField :: String -> String -> [Node] -> MatchM [f a]
unmarshalField d :: String
d f :: String
f (x :: Node
x:xs :: [Node]
xs) = do
    f a
head' <- Node -> MatchM (f a)
forall (t :: * -> *) a.
(UnmarshalAnn a, Unmarshal t) =>
Node -> MatchM (t a)
unmarshalNode Node
x
    [f a]
tail' <- String -> String -> [Node] -> MatchM [f a]
forall (t :: * -> *) (f :: * -> *) a.
(UnmarshalField t, Unmarshal f, UnmarshalAnn a) =>
String -> String -> [Node] -> MatchM (t (f a))
unmarshalField String
d String
f [Node]
xs
    [f a] -> MatchM [f a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([f a] -> MatchM [f a]) -> [f a] -> MatchM [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] -> MatchM [f a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

instance UnmarshalField NonEmpty where
  unmarshalField :: String -> String -> [Node] -> MatchM (NonEmpty (f a))
unmarshalField d :: String
d f :: String
f (x :: Node
x:xs :: [Node]
xs) = do
    f a
head' <- Node -> MatchM (f a)
forall (t :: * -> *) a.
(UnmarshalAnn a, Unmarshal t) =>
Node -> MatchM (t a)
unmarshalNode Node
x
    [f a]
tail' <- String -> String -> [Node] -> MatchM [f a]
forall (t :: * -> *) (f :: * -> *) a.
(UnmarshalField t, Unmarshal f, UnmarshalAnn a) =>
String -> String -> [Node] -> MatchM (t (f a))
unmarshalField String
d String
f [Node]
xs
    NonEmpty (f a) -> MatchM (NonEmpty (f a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty (f a) -> MatchM (NonEmpty (f a)))
-> NonEmpty (f a) -> MatchM (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 d :: String
d f :: String
f [] = IO (NonEmpty (f a)) -> MatchM (NonEmpty (f a))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (NonEmpty (f a)) -> MatchM (NonEmpty (f a)))
-> (String -> IO (NonEmpty (f a)))
-> String
-> MatchM (NonEmpty (f a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnmarshalError -> IO (NonEmpty (f a))
forall e a. Exception e => e -> IO a
throwIO (UnmarshalError -> IO (NonEmpty (f a)))
-> (String -> UnmarshalError) -> String -> IO (NonEmpty (f a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> UnmarshalError
UnmarshalError (String -> MatchM (NonEmpty (f a)))
-> String -> MatchM (NonEmpty (f a))
forall a b. (a -> b) -> a -> b
$ "type '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
d String -> ShowS
forall a. Semigroup a => a -> a -> a
<> "' expected one or more nodes in field '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
f String -> ShowS
forall a. Semigroup a => a -> a -> a
<> "' but got zero"

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 :: Proxy (M1 i c f) -> [Int]
matchedSymbols _ = Proxy f -> [Int]
forall (a :: * -> *). SymbolMatching a => Proxy a -> [Int]
matchedSymbols (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
  matchedSymbols :: Proxy (Rec1 f) -> [Int]
matchedSymbols _ = Proxy f -> [Int]
forall (a :: * -> *). SymbolMatching a => Proxy a -> [Int]
matchedSymbols (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
  matchedSymbols :: Proxy (Token sym n) -> [Int]
matchedSymbols _ = [Integer -> Int
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 -> ShowS
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
  matchedSymbols :: Proxy (f :+: g) -> [Int]
matchedSymbols _ = Proxy f -> [Int]
forall (a :: * -> *). SymbolMatching a => Proxy a -> [Int]
matchedSymbols (Proxy f
forall k (t :: k). Proxy t
Proxy @f) [Int] -> [Int] -> [Int]
forall a. Semigroup a => a -> a -> a
<> Proxy g -> [Int]
forall (a :: * -> *). SymbolMatching a => Proxy a -> [Int]
matchedSymbols (Proxy g
forall k (t :: k). Proxy t
Proxy @g)
  showFailure :: Proxy (f :+: g) -> Node -> String
showFailure _ = String -> ShowS
sep (String -> ShowS) -> (Node -> String) -> Node -> ShowS
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 -> ShowS) -> (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 -> ShowS
sep a :: String
a b :: String
b = String
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ ". " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
b

-- | Move the cursor to point at the passed 'TSNode'.
goto :: Ptr Cursor -> TSNode -> MatchM ()
goto :: Ptr Cursor -> TSNode -> MatchM ()
goto cursor :: Ptr Cursor
cursor node :: TSNode
node = IO () -> MatchM ()
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))


type Fields = [(FieldName, Node)]

-- | Return the fields remaining in the current branch, represented as 'Map.Map' of 'FieldName's to their corresponding 'Node's.
getFields :: Ptr Cursor -> Node -> MatchM Fields
getFields :: Ptr Cursor -> Node -> MatchM Fields
getFields cursor :: Ptr Cursor
cursor node :: Node
node
  | Int
maxCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = Fields -> MatchM Fields
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  | Bool
otherwise     = do
    [Node]
nodes <- IO [Node] -> ReaderC UnmarshalState IO [Node]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Node] -> ReaderC UnmarshalState IO [Node])
-> ((Ptr Node -> IO [Node]) -> IO [Node])
-> (Ptr Node -> IO [Node])
-> ReaderC UnmarshalState IO [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (Ptr Node -> IO [Node]) -> IO [Node]
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
maxCount ((Ptr Node -> IO [Node]) -> ReaderC UnmarshalState IO [Node])
-> (Ptr Node -> IO [Node]) -> ReaderC UnmarshalState IO [Node]
forall a b. (a -> b) -> a -> b
$ \ ptr :: Ptr Node
ptr -> do
      Word32
actualCount <- Ptr Cursor -> Ptr Node -> IO Word32
ts_tree_cursor_copy_child_nodes Ptr Cursor
cursor Ptr Node
ptr
      Int -> Ptr Node -> IO [Node]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
actualCount) Ptr Node
ptr
    (Node -> ReaderC UnmarshalState IO (FieldName, Node))
-> [Node] -> MatchM Fields
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\ node :: Node
node -> (, Node
node) (FieldName -> (FieldName, Node))
-> ReaderC UnmarshalState IO FieldName
-> ReaderC UnmarshalState IO (FieldName, Node)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> ReaderC UnmarshalState IO FieldName
forall (f :: * -> *). MonadIO f => Node -> f FieldName
getFieldName Node
node) [Node]
nodes
  where
  maxCount :: Int
maxCount = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Node -> Word32
nodeChildCount Node
node)
  getFieldName :: Node -> f FieldName
getFieldName node :: Node
node
    | Node -> CString
nodeFieldName Node
node CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
nullPtr = FieldName -> f FieldName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> FieldName
FieldName "extraChildren")
    | Bool
otherwise                     = String -> FieldName
FieldName (String -> FieldName) -> ShowS -> String -> FieldName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
toHaskellCamelCaseIdentifier (String -> FieldName) -> f String -> f FieldName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String -> f String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CString -> IO String
peekCString (Node -> CString
nodeFieldName Node
node))

lookupField :: FieldName -> Fields -> [Node]
lookupField :: FieldName -> Fields -> [Node]
lookupField k :: FieldName
k = ((FieldName, Node) -> Node) -> Fields -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map (FieldName, Node) -> Node
forall a b. (a, b) -> b
snd (Fields -> [Node]) -> (Fields -> Fields) -> Fields -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FieldName, Node) -> Bool) -> Fields -> Fields
forall a. (a -> Bool) -> [a] -> [a]
filter ((FieldName -> FieldName -> Bool
forall a. Eq a => a -> a -> Bool
== FieldName
k) (FieldName -> Bool)
-> ((FieldName, Node) -> FieldName) -> (FieldName, Node) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldName, Node) -> FieldName
forall a b. (a, b) -> a
fst)


-- | 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 -> ShowS
[FieldName] -> ShowS
FieldName -> String
(Int -> FieldName -> ShowS)
-> (FieldName -> String)
-> ([FieldName] -> ShowS)
-> Show FieldName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FieldName] -> ShowS
$cshowList :: [FieldName] -> ShowS
show :: FieldName -> String
$cshow :: FieldName -> String
showsPrec :: Int -> FieldName -> ShowS
$cshowsPrec :: Int -> FieldName -> ShowS
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 using the current node’s symbol to select the corresponding constructor deterministically.
class GUnmarshal f where
  gunmarshalNode
    :: UnmarshalAnn a
    => Node
    -> MatchM (f a)

instance (Datatype d, GUnmarshalData f) => GUnmarshal (M1 D d f) where
  gunmarshalNode :: Node -> MatchM (M1 D d f a)
gunmarshalNode = (Node -> MatchM (f a)) -> Node -> MatchM (M1 D d f a)
forall a i (c :: Meta).
(Node -> MatchM (f a)) -> Node -> MatchM (M1 i c f a)
go (String -> Node -> MatchM (f a)
forall (f :: * -> *) a.
(GUnmarshalData f, UnmarshalAnn a) =>
String -> Node -> MatchM (f a)
gunmarshalNode' (Any d Any Any -> String
forall k (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
datatypeName @d Any d Any Any
forall a. HasCallStack => a
undefined)) where
    go :: (Node -> MatchM (f a)) -> Node -> MatchM (M1 i c f a)
    go :: (Node -> MatchM (f a)) -> Node -> MatchM (M1 i c f a)
go = (Node -> MatchM (f a)) -> Node -> MatchM (M1 i c f a)
forall a b. Coercible a b => a -> b
coerce

class GUnmarshalData f where
  gunmarshalNode'
    :: UnmarshalAnn a
    => String
    -> Node
    -> MatchM (f a)

instance GUnmarshalData f => GUnmarshalData (M1 i c f) where
  gunmarshalNode' :: String -> Node -> MatchM (M1 i c f a)
gunmarshalNode' = (String -> Node -> MatchM (f a))
-> String -> Node -> MatchM (M1 i c f a)
forall a.
(String -> Node -> MatchM (f a))
-> String -> Node -> MatchM (M1 i c f a)
go String -> Node -> MatchM (f a)
forall (f :: * -> *) a.
(GUnmarshalData f, UnmarshalAnn a) =>
String -> Node -> MatchM (f a)
gunmarshalNode' where
    go :: (String -> Node -> MatchM (f a)) -> String -> Node -> MatchM (M1 i c f a)
    go :: (String -> Node -> MatchM (f a))
-> String -> Node -> MatchM (M1 i c f a)
go = (String -> Node -> MatchM (f a))
-> String -> Node -> MatchM (M1 i c f a)
forall a b. Coercible a b => a -> b
coerce

-- For anonymous leaf nodes:
instance GUnmarshalData U1 where
  gunmarshalNode' :: String -> Node -> MatchM (U1 a)
gunmarshalNode' _ _ = U1 a -> MatchM (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 => GUnmarshalData (K1 c k) where
  gunmarshalNode' :: String -> Node -> MatchM (K1 c k a)
gunmarshalNode' _ = (Node -> MatchM k) -> Node -> MatchM (K1 c k a)
forall a. (Node -> MatchM k) -> Node -> MatchM (K1 c k a)
go Node -> MatchM k
forall a. UnmarshalAnn a => Node -> MatchM a
unmarshalAnn where
    go :: (Node -> MatchM k) -> Node -> MatchM (K1 c k a)
    go :: (Node -> MatchM k) -> Node -> MatchM (K1 c k a)
go = (Node -> MatchM k) -> Node -> MatchM (K1 c k a)
forall a b. Coercible a b => a -> b
coerce

-- For anonymous leaf nodes
instance GUnmarshalData Par1 where
  gunmarshalNode' :: String -> Node -> MatchM (Par1 a)
gunmarshalNode' _ = (Node -> MatchM a) -> Node -> MatchM (Par1 a)
forall a. (Node -> MatchM a) -> Node -> MatchM (Par1 a)
go Node -> MatchM a
forall a. UnmarshalAnn a => Node -> MatchM a
unmarshalAnn where
    go :: (Node -> MatchM a) -> Node -> MatchM (Par1 a)
    go :: (Node -> MatchM a) -> Node -> MatchM (Par1 a)
go = (Node -> MatchM a) -> Node -> MatchM (Par1 a)
forall a b. Coercible a b => a -> b
coerce

instance Unmarshal t => GUnmarshalData (Rec1 t) where
  gunmarshalNode' :: String -> Node -> MatchM (Rec1 t a)
gunmarshalNode' _ = (Node -> MatchM (t a)) -> Node -> MatchM (Rec1 t a)
forall a. (Node -> MatchM (t a)) -> Node -> MatchM (Rec1 t a)
go Node -> MatchM (t a)
forall (t :: * -> *) a.
(UnmarshalAnn a, Unmarshal t) =>
Node -> MatchM (t a)
unmarshalNode where
    go :: (Node -> MatchM (t a)) -> Node -> MatchM (Rec1 t a)
    go :: (Node -> MatchM (t a)) -> Node -> MatchM (Rec1 t a)
go = (Node -> MatchM (t a)) -> Node -> MatchM (Rec1 t a)
forall a b. Coercible a b => a -> b
coerce

-- For product datatypes:
instance (GUnmarshalProduct f, GUnmarshalProduct g) => GUnmarshalData (f :*: g) where
  gunmarshalNode' :: String -> Node -> MatchM ((:*:) f g a)
gunmarshalNode' datatypeName :: String
datatypeName node :: Node
node = (UnmarshalState -> Ptr Cursor)
-> ReaderC UnmarshalState IO (Ptr Cursor)
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *) r'.
Has (Reader r) sig m =>
(r -> r') -> m r'
asks UnmarshalState -> Ptr Cursor
cursor ReaderC UnmarshalState IO (Ptr Cursor)
-> (Ptr Cursor -> MatchM Fields) -> MatchM Fields
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Ptr Cursor -> Node -> MatchM Fields)
-> Node -> Ptr Cursor -> MatchM Fields
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr Cursor -> Node -> MatchM Fields
getFields Node
node MatchM Fields
-> (Fields -> MatchM ((:*:) f g a)) -> MatchM ((:*:) f g a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Node -> Fields -> MatchM ((:*:) f g a)
forall (f :: * -> *) a.
(GUnmarshalProduct f, UnmarshalAnn a) =>
String -> Node -> Fields -> MatchM (f a)
gunmarshalProductNode @(f :*: g) String
datatypeName Node
node


-- | Generically unmarshal products
class GUnmarshalProduct f where
  gunmarshalProductNode
    :: UnmarshalAnn a
    => String
    -> Node
    -> Fields
    -> MatchM (f a)

-- Product structure
instance (GUnmarshalProduct f, GUnmarshalProduct g) => GUnmarshalProduct (f :*: g) where
  gunmarshalProductNode :: String -> Node -> Fields -> MatchM ((:*:) f g a)
gunmarshalProductNode datatypeName :: String
datatypeName 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)
-> ReaderC UnmarshalState IO (f a)
-> ReaderC UnmarshalState IO (g a -> (:*:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Node -> Fields -> ReaderC UnmarshalState IO (f a)
forall (f :: * -> *) a.
(GUnmarshalProduct f, UnmarshalAnn a) =>
String -> Node -> Fields -> MatchM (f a)
gunmarshalProductNode @f String
datatypeName Node
node Fields
fields
    ReaderC UnmarshalState IO (g a -> (:*:) f g a)
-> ReaderC UnmarshalState IO (g a) -> MatchM ((:*:) f g a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Node -> Fields -> ReaderC UnmarshalState IO (g a)
forall (f :: * -> *) a.
(GUnmarshalProduct f, UnmarshalAnn a) =>
String -> Node -> Fields -> MatchM (f a)
gunmarshalProductNode @g String
datatypeName 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 :: String -> Node -> Fields -> MatchM (M1 S c (K1 i k) a)
gunmarshalProductNode _ node :: Node
node _ = (Node -> MatchM k) -> Node -> MatchM (M1 S c (K1 i k) a)
forall a. (Node -> MatchM k) -> Node -> MatchM (M1 S c (K1 i k) a)
go Node -> MatchM k
forall a. UnmarshalAnn a => Node -> MatchM a
unmarshalAnn Node
node where
    go :: (Node -> MatchM k) -> Node -> MatchM (M1 S c (K1 i k) a)
    go :: (Node -> MatchM k) -> Node -> MatchM (M1 S c (K1 i k) a)
go = (Node -> MatchM k) -> Node -> MatchM (M1 S c (K1 i k) a)
forall a b. Coercible a b => a -> b
coerce

instance GUnmarshalProduct (M1 S c Par1) where
  gunmarshalProductNode :: String -> Node -> Fields -> MatchM (M1 S c Par1 a)
gunmarshalProductNode _ node :: Node
node _ = (Node -> MatchM a) -> Node -> MatchM (M1 S c Par1 a)
forall a. (Node -> MatchM a) -> Node -> MatchM (M1 S c Par1 a)
go Node -> MatchM a
forall a. UnmarshalAnn a => Node -> MatchM a
unmarshalAnn Node
node where
    go :: (Node -> MatchM a) -> Node -> MatchM (M1 S c Par1 a)
    go :: (Node -> MatchM a) -> Node -> MatchM (M1 S c Par1 a)
go = (Node -> MatchM a) -> Node -> MatchM (M1 S c Par1 a)
forall a b. Coercible a b => a -> b
coerce

instance (UnmarshalField f, Unmarshal g, Selector c) => GUnmarshalProduct (M1 S c (f :.: g)) where
  gunmarshalProductNode :: String -> Node -> Fields -> MatchM (M1 S c (f :.: g) a)
gunmarshalProductNode datatypeName :: String
datatypeName _ = (Fields -> MatchM (f (g a)))
-> Fields -> MatchM (M1 S c (f :.: g) a)
forall a.
(Fields -> MatchM (f (g a)))
-> Fields -> MatchM (M1 S c (f :.: g) a)
go (String -> String -> [Node] -> MatchM (f (g a))
forall (t :: * -> *) (f :: * -> *) a.
(UnmarshalField t, Unmarshal f, UnmarshalAnn a) =>
String -> String -> [Node] -> MatchM (t (f a))
unmarshalField String
datatypeName String
fieldName ([Node] -> MatchM (f (g a)))
-> (Fields -> [Node]) -> Fields -> MatchM (f (g a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Fields -> [Node]
lookupField (String -> FieldName
FieldName String
fieldName)) where
    go :: (Fields -> MatchM (f (g a))) -> Fields -> MatchM (M1 S c (f :.: g) a)
    go :: (Fields -> MatchM (f (g a)))
-> Fields -> MatchM (M1 S c (f :.: g) a)
go = (Fields -> MatchM (f (g a)))
-> Fields -> MatchM (M1 S c (f :.: g) a)
forall a b. Coercible a b => a -> b
coerce
    fieldName :: String
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

instance (Unmarshal t, Selector c) => GUnmarshalProduct (M1 S c (Rec1 t)) where
  gunmarshalProductNode :: String -> Node -> Fields -> MatchM (M1 S c (Rec1 t) a)
gunmarshalProductNode datatypeName :: String
datatypeName _ fields :: Fields
fields =
    case FieldName -> Fields -> [Node]
lookupField (String -> FieldName
FieldName String
fieldName) Fields
fields of
      []  -> IO (M1 S c (Rec1 t) a) -> MatchM (M1 S c (Rec1 t) a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (M1 S c (Rec1 t) a) -> MatchM (M1 S c (Rec1 t) a))
-> (String -> IO (M1 S c (Rec1 t) a))
-> String
-> MatchM (M1 S c (Rec1 t) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnmarshalError -> IO (M1 S c (Rec1 t) a)
forall e a. Exception e => e -> IO a
throwIO (UnmarshalError -> IO (M1 S c (Rec1 t) a))
-> (String -> UnmarshalError) -> String -> IO (M1 S c (Rec1 t) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> UnmarshalError
UnmarshalError (String -> MatchM (M1 S c (Rec1 t) a))
-> String -> MatchM (M1 S c (Rec1 t) a)
forall a b. (a -> b) -> a -> b
$ "type '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
datatypeName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> "' expected a node '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
fieldName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> "' but didn't get one"
      [x :: Node
x] -> (Node -> MatchM (t a)) -> Node -> MatchM (M1 S c (Rec1 t) a)
forall a.
(Node -> MatchM (t a)) -> Node -> MatchM (M1 S c (Rec1 t) a)
go Node -> MatchM (t a)
forall (t :: * -> *) a.
(UnmarshalAnn a, Unmarshal t) =>
Node -> MatchM (t a)
unmarshalNode Node
x where
        go :: (Node -> MatchM (t a)) -> Node -> MatchM (M1 S c (Rec1 t) a)
        go :: (Node -> MatchM (t a)) -> Node -> MatchM (M1 S c (Rec1 t) a)
go = (Node -> MatchM (t a)) -> Node -> MatchM (M1 S c (Rec1 t) a)
forall a b. Coercible a b => a -> b
coerce
      _   -> IO (M1 S c (Rec1 t) a) -> MatchM (M1 S c (Rec1 t) a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (M1 S c (Rec1 t) a) -> MatchM (M1 S c (Rec1 t) a))
-> (String -> IO (M1 S c (Rec1 t) a))
-> String
-> MatchM (M1 S c (Rec1 t) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnmarshalError -> IO (M1 S c (Rec1 t) a)
forall e a. Exception e => e -> IO a
throwIO (UnmarshalError -> IO (M1 S c (Rec1 t) a))
-> (String -> UnmarshalError) -> String -> IO (M1 S c (Rec1 t) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> UnmarshalError
UnmarshalError (String -> MatchM (M1 S c (Rec1 t) a))
-> String -> MatchM (M1 S c (Rec1 t) a)
forall a b. (a -> b) -> a -> b
$ "type '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
datatypeName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> "' expected a node but got multiple"
    where
    fieldName :: String
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


class GHasAnn a t where
  gann :: t a -> a

instance GHasAnn a f => GHasAnn a (M1 i c f) where
  gann :: M1 i c f a -> a
gann = f a -> a
forall a (t :: * -> *). GHasAnn a t => t a -> a
gann (f a -> a) -> (M1 i c f a -> f a) -> M1 i c f a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 i c f a -> f a
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

instance (GHasAnn a l, GHasAnn a r) => GHasAnn a (l :+: r) where
  gann :: (:+:) l r a -> a
gann (L1 l :: l a
l) = l a -> a
forall a (t :: * -> *). GHasAnn a t => t a -> a
gann l a
l
  gann (R1 r :: r a
r) = r a -> a
forall a (t :: * -> *). GHasAnn a t => t a -> a
gann r a
r

instance {-# OVERLAPPABLE #-} HasField "ann" (t a) a => GHasAnn a t where
  gann :: t a -> a
gann = forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "ann" r a => r -> a
getField @"ann"