{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

-- | 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
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
    { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
typedMatcherExp,
      quotePat :: String -> Q Pat
quotePat = String -> Q Pat
typedMatcherPat,
      quoteDec :: String -> Q [Dec]
quoteDec = forall a. HasCallStack => String -> a
error String
"No dec quoter for typedMatcher",
      quoteType :: String -> Q Type
quoteType = 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
    { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
typedMatcherLocExp,
      quotePat :: String -> Q Pat
quotePat = String -> Q Pat
typedMatcherLocPat,
      quoteDec :: String -> Q [Dec]
quoteDec = forall a. HasCallStack => String -> a
error String
"No dec quoter for typedMatcherLoc",
      quoteType :: String -> Q Type
quoteType = 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 {forall (opts :: [Symbol]) (reqs :: [Symbol]) (t :: * -> *).
TypedMatcher opts reqs t -> WithHoles t VarName
unTypedMatcher :: WithHoles t VarName}

-- | 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 :: forall (x :: Symbol) (opts :: [Symbol]) (reqs :: [Symbol]) a.
(Elem "Required" x reqs, KnownSymbol x) =>
TypedMatch opts reqs a -> a
get (TypedMatch [(Text, a)]
ms) =
  forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"Required key not present in TypedMatch") forall a b. (a -> b) -> a -> b
$
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> Text
T.pack (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (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 :: forall (x :: Symbol) (opts :: [Symbol]) (reqs :: [Symbol]) a.
(Elem "Optional" x opts, KnownSymbol x) =>
TypedMatch opts reqs a -> Maybe a
getOptional (TypedMatch [(Text, a)]
ms) = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> Text
T.pack (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (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 :: forall (t :: * -> *) (opts :: [Symbol]) (reqs :: [Symbol]).
Matchable t =>
TypedMatcher opts reqs t
-> Fix t -> Maybe (TypedMatch opts reqs (Fix t))
matchTyped = coerce :: forall a b. Coercible a b => a -> b
coerce 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 :: forall (t :: * -> *) (opts :: [Symbol]) (reqs :: [Symbol]).
Matchable t =>
TypedMatcher opts reqs t
-> Fix t -> [(Fix t, TypedMatch opts reqs (Fix t))]
findMatchesTyped = coerce :: forall a b. Coercible a b => a -> b
coerce forall (t :: * -> *) v.
Matchable t =>
WithHoles t v -> Fix t -> [(Fix t, [(v, Fix t)])]
findMatches

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

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

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

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

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

unVarName :: VarName -> T.Text
unVarName :: VarName -> Text
unVarName (VarName Text
x) = Text
x

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

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

-- | Make a list of promoted strings
symbolList :: [VarName] -> Type
symbolList :: [VarName] -> Type
symbolList =
  forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
    (\(VarName 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 -> ([VarName], [VarName])
collectHoles :: NExpr -> ([VarName], [VarName])
collectHoles =
  forall (f :: * -> *). Fix f -> f (Fix f)
unFix forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
    NSynHole VarName
n -> ([], [VarName
n])
    NSet Recursivity
_ [Binding NExpr]
bs -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall r a. (r -> ([a], [a])) -> Binding r -> ([a], [a])
bindingHoles NExpr -> ([VarName], [VarName])
collectHoles) [Binding NExpr]
bs
    NLet [Binding NExpr]
bs NExpr
e -> NExpr -> ([VarName], [VarName])
collectHoles NExpr
e forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall r a. (r -> ([a], [a])) -> Binding r -> ([a], [a])
bindingHoles NExpr -> ([VarName], [VarName])
collectHoles) [Binding NExpr]
bs
    NExprF NExpr
e -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap NExpr -> ([VarName], [VarName])
collectHoles NExprF NExpr
e

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

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