{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TemplateHaskell #-}
-- | A more strongly typed alternative to 'Nix.Match'
module Nix.Match.Typed
  ( matchNix
  , matchNixLoc
  , TypedMatcher(..)
  , TypedMatch(..)
  , get
  , getOptional
  , matchTyped
  , findMatchesTyped
  ) where

import           Control.Category               ( (>>>) )
import           Data.Coerce                    ( coerce )
import           Data.Data
import           Data.Fix
import           Data.Generics.Aliases
import           Data.Kind                      ( Constraint )
import           Data.Maybe
import qualified Data.Text                     as T
import           Data.Type.Equality             ( type (==) )
import           GHC.TypeLits                   ( ErrorMessage(..)
                                                , KnownSymbol
                                                , Symbol
                                                , TypeError
                                                , symbolVal
                                                )
import           Language.Haskell.TH            ( Exp(AppE, VarE)
                                                , ExpQ
                                                , Pat(..)
                                                , PatQ
                                                , Q
                                                , TyLit(StrTyLit)
                                                , Type(..)
                                                , appTypeE
                                                , litT
                                                , mkName
                                                , newName
                                                , strTyLit
                                                , tupE
                                                , tupP
                                                , varE
                                                , varP
                                                )
import           Language.Haskell.TH.Lib        ( appE
                                                , conE
                                                )
import           Language.Haskell.TH.Quote      ( QuasiQuoter(..) )
import           Language.Haskell.TH.Syntax     ( dataToExpQ
                                                , liftString
                                                )
import           Nix                     hiding ( TypeError )
import           Nix.Match
import           Nix.TH

----------------------------------------------------------------
-- Typed matching
----------------------------------------------------------------

-- | A QuasiQuoter for safely generating 'TypedMatcher's from nix source
--
-- The expression has the type @'TypedMatcher' opts reqs 'NExprF'@ where @opts@
-- and @reqs@ are the optional and required holes from the source expression.
--
-- The pattern, if matched, will bring into scope variables named according to
-- the holes present in the expression. These will have type 'NExpr' if they
-- are required, and @Maybe 'NExpr'@ if they are optional.
--
-- This requires ViewPatterns, TypeApplications and DataKinds
--
-- >>> case [nix|{a="hello";}|] of [matchNix|{a=^a;}|] -> a
-- Fix (NStr (DoubleQuoted [Plain "hello"]))
--
-- >>> :t [matchNix|{a = ^a; b = {c = ^c; _d = ^d;};}|]
-- [matchNix|{a = ^a; b = {c = ^c; _d = ^d;};}|] :: TypedMatcher '["d"] '["a", "c"] NExprF
--
-- >>> [matchNix|let a = ^a; _b = ^b; in x|] = undefined
-- >>> :t (a, b)
-- (a, b) :: (Fix NExprF, Maybe (Fix NExprF))
matchNix :: QuasiQuoter
matchNix :: QuasiQuoter
matchNix = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter { quoteExp :: String -> Q Exp
quoteExp  = String -> Q Exp
typedMatcherExp
                       , quotePat :: String -> Q Pat
quotePat  = String -> Q Pat
typedMatcherPat
                       , quoteDec :: String -> Q [Dec]
quoteDec  = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"No dec quoter for typedMatcher"
                       , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"No type quoter for typedMatcher"
                       }

-- | A QuasiQuoter for safely generating 'TypedMatcher's from nix source along
-- with source location annotations
--
-- The expression has the type @'TypedMatcher' opts reqs 'NExprLocF'@ where
-- @opts@ and @reqs@ are the optional and required holes from the source
-- expression.
--
-- This requires ViewPatterns, TypeApplications and DataKinds
--
-- The pattern, if matched, will bring into scope variables named according to
-- the holes present in the expression. These will have type 'NExprLoc' if they
-- are required, and @Maybe 'NExprLoc'@ if they are optional.
matchNixLoc :: QuasiQuoter
matchNixLoc :: QuasiQuoter
matchNixLoc = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp  = String -> Q Exp
typedMatcherLocExp
  , quotePat :: String -> Q Pat
quotePat  = String -> Q Pat
typedMatcherLocPat
  , quoteDec :: String -> Q [Dec]
quoteDec  = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"No dec quoter for typedMatcherLoc"
  , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"No type quoter for typedMatcherLoc"
  }

-- | A matcher with the names of the required and optional holes encoded at the
-- type level.
newtype TypedMatcher (opts :: [Symbol]) (reqs :: [Symbol]) t
  = TypedMatcher {TypedMatcher opts reqs t -> WithHoles t Text
unTypedMatcher :: WithHoles t T.Text}

-- | The results of matching with a 'TypedMatcher'. The values in the required
-- list are guaranteed to be present. The values in the optional list may be
-- present. Use 'get' and 'getOptional' to extract them safely.
newtype TypedMatch (opts :: [Symbol]) (reqs :: [Symbol]) a
  = TypedMatch [(T.Text, a)]

-- | Extract a required key from a match
get
  :: forall x opts reqs a
   . (Elem "Required" x reqs, KnownSymbol x)
  => TypedMatch opts reqs a
  -> a
get :: TypedMatch opts reqs a -> a
get (TypedMatch [(Text, a)]
ms) =
  a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (String -> a
forall a. HasCallStack => String -> a
error String
"Required key not present in TypedMatch")
    (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> Text
T.pack (Proxy x -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy x
forall k (t :: k). Proxy t
Proxy @x))) [(Text, a)]
ms

-- | Maybe extract an optional key from a match
getOptional
  :: forall x opts reqs a
   . (Elem "Optional" x opts, KnownSymbol x)
  => TypedMatch opts reqs a
  -> Maybe a
getOptional :: TypedMatch opts reqs a -> Maybe a
getOptional (TypedMatch [(Text, a)]
ms) = Text -> [(Text, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> Text
T.pack (Proxy x -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy x
forall k (t :: k). Proxy t
Proxy @x))) [(Text, a)]
ms

-- | A typed version of 'match'
matchTyped
  :: Matchable t
  => TypedMatcher opts reqs t
  -> Fix t
  -> Maybe (TypedMatch opts reqs (Fix t))
matchTyped :: TypedMatcher opts reqs t
-> Fix t -> Maybe (TypedMatch opts reqs (Fix t))
matchTyped = (WithHoles t Text -> Fix t -> Maybe [(Text, Fix t)])
-> TypedMatcher opts reqs t
-> Fix t
-> Maybe (TypedMatch opts reqs (Fix t))
coerce WithHoles t Text -> Fix t -> Maybe [(Text, Fix t)]
forall (t :: * -> *) v.
Matchable t =>
WithHoles t v -> Fix t -> Maybe [(v, Fix t)]
match

-- | A typed version of 'findMatches'
findMatchesTyped
  :: Matchable t
  => TypedMatcher opts reqs t
  -> Fix t
  -> [(Fix t, TypedMatch opts reqs (Fix t))]
findMatchesTyped :: TypedMatcher opts reqs t
-> Fix t -> [(Fix t, TypedMatch opts reqs (Fix t))]
findMatchesTyped = (WithHoles t Text -> Fix t -> [(Fix t, [(Text, Fix t)])])
-> TypedMatcher opts reqs t
-> Fix t
-> [(Fix t, TypedMatch opts reqs (Fix t))]
coerce WithHoles t Text -> Fix t -> [(Fix t, [(Text, Fix t)])]
forall (t :: * -> *) v.
Matchable t =>
WithHoles t v -> Fix t -> [(Fix t, [(v, Fix t)])]
findMatches

typedMatcherExp :: String -> ExpQ
typedMatcherExp :: String -> Q Exp
typedMatcherExp =
  ((([Text], [Text]), Exp) -> Exp)
-> Q (([Text], [Text]), Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Text], [Text]), Exp) -> Exp
forall a b. (a, b) -> b
snd (Q (([Text], [Text]), Exp) -> Q Exp)
-> (String -> Q (([Text], [Text]), Exp)) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Result NExpr)
-> (NExpr -> ([Text], [Text]))
-> (NExpr -> WithHoles NExprF Text)
-> (NExpr -> NExpr)
-> String
-> Q (([Text], [Text]), Exp)
forall a t.
Data a =>
(Text -> Result t)
-> (t -> ([Text], [Text]))
-> (t -> a)
-> (t -> NExpr)
-> String
-> Q (([Text], [Text]), Exp)
typedMatcherGen Text -> Result NExpr
parseNixText NExpr -> ([Text], [Text])
collectHoles NExpr -> WithHoles NExprF Text
addHoles NExpr -> NExpr
forall a. a -> a
id

typedMatcherLocExp :: String -> ExpQ
typedMatcherLocExp :: String -> Q Exp
typedMatcherLocExp =
  ((([Text], [Text]), Exp) -> Exp)
-> Q (([Text], [Text]), Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Text], [Text]), Exp) -> Exp
forall a b. (a, b) -> b
snd
    (Q (([Text], [Text]), Exp) -> Q Exp)
-> (String -> Q (([Text], [Text]), Exp)) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Result NExprLoc)
-> (NExprLoc -> ([Text], [Text]))
-> (NExprLoc -> WithHoles NExprLocF Text)
-> (NExprLoc -> NExpr)
-> String
-> Q (([Text], [Text]), Exp)
forall a t.
Data a =>
(Text -> Result t)
-> (t -> ([Text], [Text]))
-> (t -> a)
-> (t -> NExpr)
-> String
-> Q (([Text], [Text]), Exp)
typedMatcherGen Text -> Result NExprLoc
parseNixTextLoc
                      NExprLoc -> ([Text], [Text])
collectHolesLoc
                      NExprLoc -> WithHoles NExprLocF Text
addHolesLoc
                      NExprLoc -> NExpr
forall (f :: * -> *) ann. Functor f => Fix (AnnF ann f) -> Fix f
stripAnnotation

typedMatcherPat :: String -> PatQ
typedMatcherPat :: String -> Q Pat
typedMatcherPat = (Text -> Result NExpr)
-> (NExpr -> ([Text], [Text]))
-> (NExpr -> WithHoles NExprF Text)
-> (NExpr -> NExpr)
-> String
-> Q Pat
forall a t.
Data a =>
(Text -> Result t)
-> (t -> ([Text], [Text]))
-> (t -> a)
-> (t -> NExpr)
-> String
-> Q Pat
typedMatcherPatGen Text -> Result NExpr
parseNixText NExpr -> ([Text], [Text])
collectHoles NExpr -> WithHoles NExprF Text
addHoles NExpr -> NExpr
forall a. a -> a
id

typedMatcherLocPat :: String -> PatQ
typedMatcherLocPat :: String -> Q Pat
typedMatcherLocPat =
  (Text -> Result NExprLoc)
-> (NExprLoc -> ([Text], [Text]))
-> (NExprLoc -> WithHoles NExprLocF Text)
-> (NExprLoc -> NExpr)
-> String
-> Q Pat
forall a t.
Data a =>
(Text -> Result t)
-> (t -> ([Text], [Text]))
-> (t -> a)
-> (t -> NExpr)
-> String
-> Q Pat
typedMatcherPatGen Text -> Result NExprLoc
parseNixTextLoc NExprLoc -> ([Text], [Text])
collectHolesLoc NExprLoc -> WithHoles NExprLocF Text
addHolesLoc NExprLoc -> NExpr
forall (f :: * -> *) ann. Functor f => Fix (AnnF ann f) -> Fix f
stripAnnotation

typedMatcherPatGen
  :: Data a
  => (T.Text -> Result t)
  -> (t -> ([T.Text], [T.Text]))
  -> (t -> a)
  -> (t -> NExpr)
  -> String
  -> Q Pat
typedMatcherPatGen :: (Text -> Result t)
-> (t -> ([Text], [Text]))
-> (t -> a)
-> (t -> NExpr)
-> String
-> Q Pat
typedMatcherPatGen Text -> Result t
parseNix t -> ([Text], [Text])
collect t -> a
add t -> NExpr
strip String
s = do
  (([Text]
opt, [Text]
req), Exp
matcher) <- (Text -> Result t)
-> (t -> ([Text], [Text]))
-> (t -> a)
-> (t -> NExpr)
-> String
-> Q (([Text], [Text]), Exp)
forall a t.
Data a =>
(Text -> Result t)
-> (t -> ([Text], [Text]))
-> (t -> a)
-> (t -> NExpr)
-> String
-> Q (([Text], [Text]), Exp)
typedMatcherGen Text -> Result t
parseNix t -> ([Text], [Text])
collect t -> a
add t -> NExpr
strip String
s
  -- e' <- [|fmap (\x -> $()) . matchTyped $(pure matcher)|]
  Name
x                     <- String -> Q Name
newName String
"x"
  let pat :: Q Pat
pat        = [Q Pat] -> Q Pat
tupP (Name -> Q Pat
varP (Name -> Q Pat) -> (Text -> Name) -> Text -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Q Pat) -> [Text] -> [Q Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Text]
req [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
opt))
      textSymbol :: Text -> Q Type
textSymbol = TyLitQ -> Q Type
litT (TyLitQ -> Q Type) -> (Text -> TyLitQ) -> Text -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TyLitQ
strTyLit (String -> TyLitQ) -> (Text -> String) -> Text -> TyLitQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
      getters :: Q Exp
getters    = [Q Exp] -> Q Exp
tupE
        (  ((\Q Type
r -> [|get @($r) $(varE x)|]) (Q Type -> Q Exp) -> (Text -> Q Type) -> Text -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Q Type
textSymbol (Text -> Q Exp) -> [Text] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
req)
        [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. Semigroup a => a -> a -> a
<> ((\Q Type
o -> [|getOptional @($o) $(varE x)|]) (Q Type -> Q Exp) -> (Text -> Q Type) -> Text -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Q Type
textSymbol (Text -> Q Exp) -> [Text] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
opt)
        )
  [p|(fmap (\ $(varP x) -> $getters) . matchTyped $(pure matcher) -> Just $pat)|]

typedMatcherGen
  :: Data a
  => (T.Text -> Result t)
  -> (t -> ([T.Text], [T.Text]))
  -> (t -> a)
  -> (t -> NExpr)
  -> String
  -> Q (([T.Text], [T.Text]), Exp)
typedMatcherGen :: (Text -> Result t)
-> (t -> ([Text], [Text]))
-> (t -> a)
-> (t -> NExpr)
-> String
-> Q (([Text], [Text]), Exp)
typedMatcherGen Text -> Result t
parseNix t -> ([Text], [Text])
collect t -> a
add t -> NExpr
strip String
s = do
  t
expr <- case Text -> Result t
parseNix (String -> Text
T.pack String
s) of
    Left Doc Void
err -> String -> Q t
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q t) -> String -> Q t
forall a b. (a -> b) -> a -> b
$ Doc Void -> String
forall a. Show a => a -> String
show Doc Void
err
    Right t
e  -> t -> Q t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
e
  let ([Text]
opt, [Text]
req) = t -> ([Text], [Text])
collect t
expr
      optT :: Type
optT       = [Text] -> Type
symbolList [Text]
opt
      reqT :: Type
reqT       = [Text] -> Type
symbolList [Text]
req
      holed :: a
holed      = t -> a
add t
expr
      exprExp :: Q Exp
exprExp    = (forall b. Data b => b -> Maybe (Q Exp)) -> a -> Q Exp
forall a.
Data a =>
(forall b. Data b => b -> Maybe (Q Exp)) -> a -> Q Exp
dataToExpQ
        (      Maybe (Q Exp) -> b -> Maybe (Q Exp)
forall a b. a -> b -> a
const Maybe (Q Exp)
forall a. Maybe a
Nothing
        (b -> Maybe (Q Exp))
-> (NExprLoc -> Maybe (Q Exp)) -> b -> Maybe (Q Exp)
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` Set Text -> NExprLoc -> Maybe (Q Exp)
metaExp (NExpr -> Set Text
freeVars (t -> NExpr
strip t
expr))
        (b -> Maybe (Q Exp))
-> (Text -> Maybe (Q Exp)) -> b -> Maybe (Q Exp)
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Q Exp -> Maybe (Q Exp))
-> (Text -> Q Exp) -> Text -> Maybe (Q Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Q Exp
liftText)
        )
        a
holed
  Exp
e <-
    Name -> Q Exp
conE 'TypedMatcher Q Exp -> Q Type -> Q Exp
`appTypeE` Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
optT Q Exp -> Q Type -> Q Exp
`appTypeE` Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
reqT Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
exprExp
  (([Text], [Text]), Exp) -> Q (([Text], [Text]), Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([Text]
opt, [Text]
req), Exp
e)

liftText :: T.Text -> Q Exp
liftText :: Text -> Q Exp
liftText Text
txt = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'T.pack) (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Exp
liftString (Text -> String
T.unpack Text
txt)

-- | Make a list of promoted strings
symbolList :: [T.Text] -> Type
symbolList :: [Text] -> Type
symbolList = (Text -> Type -> Type) -> Type -> [Text] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
  (\Text
n -> (Type
PromotedConsT Type -> Type -> Type
`AppT` TyLit -> Type
LitT (String -> TyLit
StrTyLit (Text -> String
T.unpack Text
n)) Type -> Type -> Type
`AppT`))
  Type
PromotedNilT

-- | Collect optional and required holes
collectHoles :: NExpr -> ([T.Text], [T.Text])
collectHoles :: NExpr -> ([Text], [Text])
collectHoles = NExpr -> NExprF NExpr
forall (f :: * -> *). Fix f -> f (Fix f)
unFix (NExpr -> NExprF NExpr)
-> (NExprF NExpr -> ([Text], [Text])) -> NExpr -> ([Text], [Text])
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
  NSynHole Text
n -> ([], [Text
n])
  NSet NRecordType
_  [Binding NExpr]
bs -> (Binding NExpr -> ([Text], [Text]))
-> [Binding NExpr] -> ([Text], [Text])
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((NExpr -> ([Text], [Text])) -> Binding NExpr -> ([Text], [Text])
forall r a. (r -> ([a], [a])) -> Binding r -> ([a], [a])
bindingHoles NExpr -> ([Text], [Text])
collectHoles) [Binding NExpr]
bs
  NLet [Binding NExpr]
bs NExpr
e  -> NExpr -> ([Text], [Text])
collectHoles NExpr
e ([Text], [Text]) -> ([Text], [Text]) -> ([Text], [Text])
forall a. Semigroup a => a -> a -> a
<> (Binding NExpr -> ([Text], [Text]))
-> [Binding NExpr] -> ([Text], [Text])
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((NExpr -> ([Text], [Text])) -> Binding NExpr -> ([Text], [Text])
forall r a. (r -> ([a], [a])) -> Binding r -> ([a], [a])
bindingHoles NExpr -> ([Text], [Text])
collectHoles) [Binding NExpr]
bs
  NExprF NExpr
e          -> (NExpr -> ([Text], [Text])) -> NExprF NExpr -> ([Text], [Text])
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap NExpr -> ([Text], [Text])
collectHoles NExprF NExpr
e

-- | Collect optional and required holes
collectHolesLoc :: NExprLoc -> ([T.Text], [T.Text])
collectHolesLoc :: NExprLoc -> ([Text], [Text])
collectHolesLoc = NExprLoc -> NExprLocF NExprLoc
forall (f :: * -> *). Fix f -> f (Fix f)
unFix (NExprLoc -> NExprLocF NExprLoc)
-> (NExprLocF NExprLoc -> ([Text], [Text]))
-> NExprLoc
-> ([Text], [Text])
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
  Compose (Ann SrcSpan
_ (NSynHole Text
n)) -> ([], [Text
n])
  Compose (Ann SrcSpan
_ (NSet NRecordType
_ [Binding NExprLoc]
bs )) -> (Binding NExprLoc -> ([Text], [Text]))
-> [Binding NExprLoc] -> ([Text], [Text])
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((NExprLoc -> ([Text], [Text]))
-> Binding NExprLoc -> ([Text], [Text])
forall r a. (r -> ([a], [a])) -> Binding r -> ([a], [a])
bindingHoles NExprLoc -> ([Text], [Text])
collectHolesLoc) [Binding NExprLoc]
bs
  Compose (Ann SrcSpan
_ (NLet [Binding NExprLoc]
bs NExprLoc
e)) ->
    NExprLoc -> ([Text], [Text])
collectHolesLoc NExprLoc
e ([Text], [Text]) -> ([Text], [Text]) -> ([Text], [Text])
forall a. Semigroup a => a -> a -> a
<> (Binding NExprLoc -> ([Text], [Text]))
-> [Binding NExprLoc] -> ([Text], [Text])
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((NExprLoc -> ([Text], [Text]))
-> Binding NExprLoc -> ([Text], [Text])
forall r a. (r -> ([a], [a])) -> Binding r -> ([a], [a])
bindingHoles NExprLoc -> ([Text], [Text])
collectHolesLoc) [Binding NExprLoc]
bs
  NExprLocF NExprLoc
e -> (NExprLoc -> ([Text], [Text]))
-> NExprLocF NExprLoc -> ([Text], [Text])
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap NExprLoc -> ([Text], [Text])
collectHolesLoc NExprLocF NExprLoc
e

-- | Find the optional and required holees in a binding
bindingHoles :: (r -> ([a], [a])) -> Binding r -> ([a], [a])
bindingHoles :: (r -> ([a], [a])) -> Binding r -> ([a], [a])
bindingHoles r -> ([a], [a])
f = \case
  b :: Binding r
b@(NamedVar NAttrPath r
p r
_ SourcePos
_) | Maybe (NAttrPath r) -> Bool
forall a. Maybe a -> Bool
isJust (NAttrPath r -> Maybe (NAttrPath r)
forall r. NAttrPath r -> Maybe (NAttrPath r)
isOptionalPath NAttrPath r
p) ->
    let ([a]
opt, [a]
req) = (r -> ([a], [a])) -> Binding r -> ([a], [a])
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap r -> ([a], [a])
f Binding r
b in ([a]
opt [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a]
req, [])
  Binding r
b -> (r -> ([a], [a])) -> Binding r -> ([a], [a])
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap r -> ([a], [a])
f Binding r
b

----------------------------------------------------------------
-- Helpers
----------------------------------------------------------------

type family Bool' (f :: k) (t :: k) (x :: Bool) :: k where
  Bool' f _ 'False = f
  Bool' _ t 'True = t

type family Elem n x ys :: Constraint where
  Elem n x '[] = TypeError ('Text n ':<>: 'Text " key \"" ':<>: 'Text x ':<>: 'Text "\" not found in TypedMatch")
  Elem n x (y:ys) = Bool' (Elem n x ys) (() :: Constraint) (x == y)