{-# LANGUAGE UndecidableInstances #-}
-- | A set of functions for matching on Nix expression trees and extracting the
-- values of sub-trees.
module Nix.Match
( match,
findMatches,
Matchable (..),
GMatchable (..),
WithHoles (..),
addHoles,
addHolesLoc,
isOptionalPath,
)
where
import Control.Category ((>>>))
import Control.Monad (void)
import Data.Data
import Data.Fix
import Data.Foldable
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe
import Data.Monoid hiding (All)
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Base (NonEmpty ((:|)))
import GHC.Generics
import Nix
-- | Like 'Fix' but each layer could instead be a 'Hole'
data WithHoles t v
= Hole !v
| Term !(t (WithHoles t v))
deriving instance (Typeable t, Data (t (WithHoles t v)), Data v) => Data (WithHoles t v)
-- | Match a tree with holes against a tree without holes, returning the values
-- of the holes if it matches.
--
-- 'NExprF' and 'NExprLocF' are both instances of 'Matchable'. 'NExprLocF' does
-- not require the annotations to match. Please see the 'Matchable' instance
-- documentation for 'NExprF' for more details.
--
-- >>> import Nix.TH
-- >>> match (addHoles [nix|{foo = x: ^foo; bar = ^bar;}|]) [nix|{foo = x: "hello"; bar = "world"; baz = "!";}|]
-- Just [("bar",Fix (NStr (DoubleQuoted [Plain "world"]))),("foo",Fix (NStr (DoubleQuoted [Plain "hello"])))]
match :: Matchable t => WithHoles t v -> Fix t -> Maybe [(v, Fix t)]
match = fmap (`appEndo` []) .: go
where
go = \case
Hole v -> \t -> Just (Endo ((v, t) :))
Term s -> \(Fix t) -> do
m <- zipMatchLeft s t
fmap fold . traverse (uncurry go) . toList $ m
-- | Find all the needles in a haystack, returning the matched expression as
-- well as their filled holes. Results are returned productively in preorder.
--
-- >>> import Nix.TH
-- >>> import Control.Arrow
-- >>> pretty = prettyNix *** (fmap @[] (fmap @((,) Text) prettyNix))
-- >>> pretty <$> findMatches (addHoles [nix|{x=^x;}|]) [nix|{x=1;a={x=2;};}|]
-- [({ x = 1; a = { x = 2; }; },[("x",1)]),({ x = 2; },[("x",2)])]
findMatches ::
Matchable t =>
-- | Needle
WithHoles t v ->
-- | Haystack
Fix t ->
[(Fix t, [(v, Fix t)])]
findMatches needle haystack =
[(s, r) | s <- fixUniverse haystack, Just r <- pure $ match needle s]
-- | Get every @f@ in a @Fix f@ in preorder.
fixUniverse :: Foldable f => Fix f -> [Fix f]
fixUniverse e = e : (fixUniverse =<< toList (unFix e))
-- | Make syntactic holes into 'Hole's
addHoles :: NExpr -> WithHoles NExprF VarName
addHoles =
unFix >>> \case
NSynHole n -> Hole n
e -> Term . fmap addHoles $ e
-- | Make syntactic holes into 'Hole's
addHolesLoc :: NExprLoc -> WithHoles NExprLocF VarName
addHolesLoc =
unFix >>> \case
Compose (AnnUnit _ (NSynHole n)) -> Hole n
e -> Term . fmap addHolesLoc $ e
----------------------------------------------------------------
-- Matchable
----------------------------------------------------------------
-- | Instances for this class can be derived for any type with a 'Generic1'
-- instance.
class Traversable t => Matchable t where
-- | Match one level of structure, returning the matched structure with sub
-- structures to match. Needle is the first argument, matchee is the second.
--
-- Unlike the @Unifiable@ class in the "unification-fd" package, this doesn't
-- have to be a commutative operation, the needle will always be the first
-- parameter and instances are free to treat if differently if appropriate.
zipMatchLeft :: t a -> t b -> Maybe (t (a, b))
default zipMatchLeft ::
(Generic1 t, GMatchable (Rep1 t)) =>
t a ->
t b ->
Maybe (t (a, b))
zipMatchLeft l r = to1 <$> gZipMatchLeft (from1 l) (from1 r)
-- | Match a composition of 'Matchable' things
zipMatchLeft2 ::
(Matchable f, Matchable t) => t (f a) -> t (f b) -> Maybe (t (f (a, b)))
zipMatchLeft2 a b = zipMatchLeft a b >>= traverse (uncurry zipMatchLeft)
----------------------------------------------------------------
-- Matchable instance for NExprF and NExprLocF
----------------------------------------------------------------
-- | There are a few special cases when matching expressions to make writing
-- matchers nicer:
--
-- - For attrsets and let bindings, the matching is done on the needle's keys
-- only. i.e. the matchee may have extra keys which are ignored.
--
-- - For attrsets and let bindings, bindings which have a LHS beginning with
-- @_@ are treated as optional. If they are not present then any holes on
-- their RHS will not be filled.
--
-- - Attrsets match ignoring recursiveness
--
-- - If a function in the needle has @_@ as its parameter, it matches
-- everything, so @_@ acts as a wildcard pattern.
instance Matchable NExprF where
zipMatchLeft (NSet _ bs1) (NSet _ bs2) = do
(bs1', bs2') <- unzip <$> reduceBindings bs1 bs2
to1
<$> gZipMatchLeft
(from1 (NSet NonRecursive bs1'))
(from1 (NSet NonRecursive bs2'))
zipMatchLeft (NLet bs1 e1) (NLet bs2 e2) = do
(bs1', bs2') <- unzip <$> reduceBindings bs1 bs2
to1 <$> gZipMatchLeft (from1 (NLet bs1' e1)) (from1 (NLet bs2' e2))
zipMatchLeft (NAbs (Param "_") e1) (NAbs _ e2) = do
pure $ NAbs (Param "_") (e1, e2)
zipMatchLeft l r = to1 <$> gZipMatchLeft (from1 l) (from1 r)
-- | Bindings are compared on top level structure only.
--
-- Doesn't filter bindings in the needle, as they must all be present
--
-- Bindings are returned according to their order in the needle.
--
-- Any optional (name begins with @_@) bindings may be removed from the needle.
--
-- Left hand sides are matched purely on the top level structure, this means
-- that "${a}" and "${b}" appear the same to this function, and it may not
-- match them up correctly.
reduceBindings :: [Binding q] -> [Binding r] -> Maybe [(Binding q, Binding r)]
reduceBindings needle matchee =
let -- A binding is optional if the lhs starts with a '_', return the same
-- binding but without the '_'
isOptional = \case
NamedVar p e l | Just p' <- isOptionalPath p -> Just (NamedVar p' e l)
_ -> Nothing
-- Get a representation of the left hand side which has an Eq instance
-- This will represent some things the samelike "${a}" and "${b}"
getLHS = \case
NamedVar p _ _ -> Left (fmap void p)
Inherit r ps _ -> Right (void r, ps)
in sequence
[ (n',) <$> m
| -- For each binding in the needle
n <- needle,
let opt = isOptional n
-- \| Use the optional demangled version if present
n' = fromMaybe n opt
lhs = getLHS n'
-- Find the first matching binding in the matchee
m = find ((lhs ==) . getLHS) matchee,
-- Skip this element if it is not present in the matchee and is optional in the needle
isNothing opt || isJust m
]
-- | Basically: does the path begin with an underscore, if so return it removed
-- without the underscore.
isOptionalPath :: NAttrPath r -> Maybe (NAttrPath r)
isOptionalPath = \case
StaticKey (VarName n) :| [] | Just ('_', t) <- T.uncons n -> Just (StaticKey (VarName t) :| [])
DynamicKey (Plain (DoubleQuoted [Plain n])) :| rs
| Just ('_', t) <- T.uncons n ->
Just
(DynamicKey (Plain (DoubleQuoted [Plain t])) :| rs)
_ -> Nothing
--
-- hnix types
--
instance Matchable NString
instance Matchable (Antiquoted Text)
-- | The matched pair uses the source location of the first argument
instance Matchable Binding where
zipMatchLeft (NamedVar p1 v1 _) (NamedVar p2 v2 l) = do
p <- zipMatchLeft2 p1 p2
pure (NamedVar p (v1, v2) l)
zipMatchLeft (Inherit x1 ys1 l) (Inherit x2 ys2 _)
| ys1 == ys2 = do
x <- zipMatchLeft x1 x2
pure (Inherit x ys1 l)
zipMatchLeft _ _ = Nothing
-- | No Generic1 instance
instance Matchable NKeyName where
zipMatchLeft (StaticKey k1) (StaticKey k2) | k1 == k2 = Just (StaticKey k1)
zipMatchLeft (DynamicKey EscapedNewline) (DynamicKey EscapedNewline) =
Just (DynamicKey EscapedNewline)
zipMatchLeft (DynamicKey (Plain k1)) (DynamicKey (Plain k2)) = do
k <- zipMatchLeft k1 k2
pure $ DynamicKey (Plain k)
zipMatchLeft (DynamicKey (Antiquoted k1)) (DynamicKey (Antiquoted k2)) =
pure $ DynamicKey (Antiquoted (k1, k2))
zipMatchLeft _ _ = Nothing
instance Matchable Params
-- | Doesn't require the annotations to match, returns the second annotation.
instance Matchable (AnnUnit ann) where
zipMatchLeft (AnnUnit _ a1) (AnnUnit ann2 a2) = Just $ AnnUnit ann2 (a1, a2)
--
-- base types
--
instance Matchable []
instance Matchable NonEmpty
instance Matchable Maybe
instance Eq a => Matchable ((,) a)
instance (Matchable f, Matchable g) => Matchable (Compose f g)
----------------------------------------------------------------
-- Generic Instance for Matchable
----------------------------------------------------------------
-- | A class used in the @default@ definition for 'zipMatchLeft'
class (Traversable t, Generic1 t) => GMatchable t where
gZipMatchLeft :: t a -> t b -> Maybe (t (a, b))
instance GMatchable t => GMatchable (M1 m i t) where
gZipMatchLeft (M1 l) (M1 r) = M1 <$> gZipMatchLeft l r
instance GMatchable U1 where
gZipMatchLeft _ _ = Just U1
instance Eq c => GMatchable (K1 m c) where
gZipMatchLeft (K1 l) (K1 r)
| l == r = Just (K1 l)
| otherwise = Nothing
instance GMatchable Par1 where
gZipMatchLeft (Par1 l) (Par1 r) = Just . Par1 $ (l, r)
instance Matchable x => GMatchable (Rec1 x) where
gZipMatchLeft (Rec1 l) (Rec1 r) = Rec1 <$> zipMatchLeft l r
instance (GMatchable l, GMatchable r) => GMatchable (l :+: r) where
gZipMatchLeft (L1 l) (L1 r) = L1 <$> gZipMatchLeft l r
gZipMatchLeft (R1 l) (R1 r) = R1 <$> gZipMatchLeft l r
gZipMatchLeft _ _ = Nothing
instance (GMatchable l, GMatchable r) => GMatchable (l :*: r) where
gZipMatchLeft (l1 :*: l2) (r1 :*: r2) =
(:*:) <$> gZipMatchLeft l1 r1 <*> gZipMatchLeft l2 r2
instance (Matchable a, GMatchable b) => GMatchable (a :.: b) where
gZipMatchLeft (Comp1 l) (Comp1 r) = do
x <- zipMatchLeft l r >>= traverse (uncurry gZipMatchLeft)
pure (Comp1 x)
----------------------------------------------------------------
-- Utils
----------------------------------------------------------------
(.:) :: (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c
(.:) = (.) . (.)