    -- | Patterns and replacements
    --
    -- NOTE: This module was developed to prepare for proper delegation (#39).
    -- It is currently unused.
    {-# LANGUAGE DeriveLift #-}
    {-# LANGUAGE StandaloneDeriving #-}

    module Hackage.Security.TUF.Patterns (
        -- * Patterns and replacements
        FileName
      , Directory
      , Extension
      , BaseName
      , Pattern(..)
      , Replacement(..)
      , Delegation(..)
        -- ** Utility
      , identityReplacement
      , matchDelegation
        -- ** Parsing and quasi-quoting
      , parseDelegation
      , qqd
      ) where

    import Prelude
    import Control.Monad (guard)
    import Language.Haskell.TH (Q, Exp)
    import System.FilePath.Posix
    import qualified Language.Haskell.TH.Syntax as TH

    import Hackage.Security.JSON
    import Hackage.Security.Util.Some
    import Hackage.Security.Util.Stack
    import Hackage.Security.Util.TypedEmbedded

    {-------------------------------------------------------------------------------
      Patterns and replacements
    -------------------------------------------------------------------------------}

    type FileName  = String
    type Directory = String
    type Extension = String
    type BaseName  = String

    -- | Structured patterns over paths
    --
    -- The type argument indicates what kind of function we expect when the
    -- pattern matches. For example, we have the pattern @"*/*.txt"@:
    --
    -- > PathPatternDirAny (PathPatternFileExt ".txt")
    -- >   :: PathPattern (Directory :- BaseName :- ())
    --
    -- TODOs (see README.md):
    --
    -- * Update this to work with 'Path' rather than 'FilePath'/'String'
    -- * Add different kinds of wildcards
    -- * Add path roots
    --
    -- Currently this is a proof of concept more than anything else; the right
    -- structure is here, but it needs updating. However, until we add author
    -- signing (or out-of-tarball targets) we don't actually use this yet.
    --
    -- NOTE: Haddock lacks GADT support so constructors have only regular comments.
    data Pattern a where
        -- Match against a specific filename
        PatFileConst :: FileName -> Pattern ()

        -- Match against a filename with the given extension
        PatFileExt :: Extension -> Pattern (BaseName :- ())

        -- Match against any filename
        PatFileAny :: Pattern (FileName :- ())

        -- Match against a specific directory
        PatDirConst :: Directory -> Pattern a -> Pattern a

        -- Match against any directory
        PatDirAny :: Pattern a -> Pattern (Directory :- a)

    -- | Replacement patterns
    --
    -- These constructors match the ones in 'Pattern': wildcards must be used
    -- in the same order as they appear in the pattern, but they don't all have to
    -- be used (that's why the base constructors are polymorphic in the stack tail).
    data Replacement a where
        RepFileConst :: FileName -> Replacement a
        RepFileExt   :: Extension -> Replacement (BaseName :- a)
        RepFileAny   :: Replacement (FileName :- a)
        RepDirConst  :: Directory -> Replacement a -> Replacement a
        RepDirAny    :: Replacement a -> Replacement (Directory :- a)

    deriving instance Eq   (Pattern typ)
    deriving instance Show (Pattern typ)

    deriving instance Eq   (Replacement typ)
    deriving instance Show (Replacement typ)

    -- | The identity replacement replaces a matched pattern with itself
    identityReplacement :: Pattern typ -> Replacement typ
    identityReplacement :: forall typ. Pattern typ -> Replacement typ
    identityReplacement = Pattern typ -> Replacement typ
    forall typ. Pattern typ -> Replacement typ
    go
      where
        go :: Pattern typ -> Replacement typ
        go :: forall typ. Pattern typ -> Replacement typ
    go (PatFileConst BaseName
    fn)  = BaseName -> Replacement typ
    forall a. BaseName -> Replacement a
    RepFileConst BaseName
    fn
        go (PatFileExt   BaseName
    e)   = BaseName -> Replacement (BaseName :- ())
    forall a. BaseName -> Replacement (BaseName :- a)
    RepFileExt   BaseName
    e
        go Pattern typ
    PatFileAny         = Replacement typ
    Replacement (BaseName :- ())
    forall a. Replacement (BaseName :- a)
    RepFileAny
        go (PatDirConst  BaseName
    d Pattern typ
    p) = BaseName -> Replacement typ -> Replacement typ
    forall a. BaseName -> Replacement a -> Replacement a
    RepDirConst  BaseName
    d (Pattern typ -> Replacement typ
    forall typ. Pattern typ -> Replacement typ
    go Pattern typ
    p)
        go (PatDirAny      Pattern a
    p) = Replacement a -> Replacement (BaseName :- a)
    forall a. Replacement a -> Replacement (BaseName :- a)
    RepDirAny      (Pattern a -> Replacement a
    forall typ. Pattern typ -> Replacement typ
    go Pattern a
    p)

    -- | A delegation
    --
    -- A delegation is a pair of a pattern and a replacement.
    --
    -- See 'match' for an example.
    data Delegation = forall a. Delegation (Pattern a) (Replacement a)

    deriving instance Show Delegation

    {-------------------------------------------------------------------------------
      Matching
    -------------------------------------------------------------------------------}

    matchPattern :: String -> Pattern a -> Maybe a
    matchPattern :: forall a. BaseName -> Pattern a -> Maybe a
    matchPattern = [BaseName] -> Pattern a -> Maybe a
    forall a. [BaseName] -> Pattern a -> Maybe a
    go ([BaseName] -> Pattern a -> Maybe a)
    -> (BaseName -> [BaseName]) -> BaseName -> Pattern a -> Maybe a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . BaseName -> [BaseName]
    splitDirectories
      where
        go :: [String] -> Pattern a -> Maybe a
        go :: forall a. [BaseName] -> Pattern a -> Maybe a
    go []    Pattern a
    _                    = Maybe a
    forall a. Maybe a
    Nothing
        go [BaseName
    f]   (PatFileConst BaseName
    f')    = do Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (BaseName
    f BaseName -> BaseName -> Bool
    forall a. Eq a => a -> a -> Bool
    == BaseName
    f')
                                           a -> Maybe a
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
        go [BaseName
    f]   (PatFileExt   BaseName
    e')    = do let (BaseName
    bn, BaseName
    dotExt) = BaseName -> (BaseName, BaseName)
    splitExtension BaseName
    f
                                           Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (Bool -> Maybe ()) -> Bool -> Maybe ()
    forall a b. (a -> b) -> a -> b
    $ BaseName
    dotExt BaseName -> BaseName -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '.'Char -> ShowS
    forall a. a -> [a] -> [a]
    :BaseName
    e'
                                           a -> Maybe a
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (BaseName
    bn BaseName -> () -> BaseName :- ()
    forall h t. h -> t -> h :- t
    :- ())
        go [BaseName
    _]   Pattern a
    _                    = Maybe a
    forall a. Maybe a
    Nothing
        go (BaseName
    d:[BaseName]
    p) (PatDirConst  BaseName
    d' Pattern a
    p') = do Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (BaseName
    d BaseName -> BaseName -> Bool
    forall a. Eq a => a -> a -> Bool
    == BaseName
    d')
                                           [BaseName] -> Pattern a -> Maybe a
    forall a. [BaseName] -> Pattern a -> Maybe a
    go [BaseName]
    p Pattern a
    p'
        go (BaseName
    d:[BaseName]
    p) (PatDirAny       Pattern a
    p') = (BaseName
    d BaseName -> a -> BaseName :- a
    forall h t. h -> t -> h :- t
    :-) (a -> a) -> Maybe a -> Maybe a
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [BaseName] -> Pattern a -> Maybe a
    forall a. [BaseName] -> Pattern a -> Maybe a
    go [BaseName]
    p Pattern a
    p'
        go (BaseName
    _:[BaseName]
    _) Pattern a
    _                    = Maybe a
    forall a. Maybe a
    Nothing

    constructReplacement :: Replacement a -> a -> String
    constructReplacement :: forall a. Replacement a -> a -> BaseName
    constructReplacement = \Replacement a
    repl a
    a -> [BaseName] -> BaseName
    joinPath ([BaseName] -> BaseName) -> [BaseName] -> BaseName
    forall a b. (a -> b) -> a -> b
    $ Replacement a -> a -> [BaseName]
    forall a. Replacement a -> a -> [BaseName]
    go Replacement a
    repl a
    a
      where
        go :: Replacement a -> a -> [String]
        go :: forall a. Replacement a -> a -> [BaseName]
    go (RepFileConst BaseName
    c)   a
    _         = [BaseName
    c]
        go (RepFileExt   BaseName
    e)   (BaseName
    bn :- a
    _) = [BaseName
    bn BaseName -> ShowS
    <.> BaseName
    e]
        go Replacement a
    RepFileAny         (BaseName
    fn :- a
    _) = [BaseName
    fn]
        go (RepDirConst  BaseName
    d Replacement a
    p) a
    a         = BaseName
    d BaseName -> [BaseName] -> [BaseName]
    forall a. a -> [a] -> [a]
    : Replacement a -> a -> [BaseName]
    forall a. Replacement a -> a -> [BaseName]
    go Replacement a
    p a
    a
        go (RepDirAny      Replacement a
    p) (BaseName
    d  :- a
    a) = BaseName
    d BaseName -> [BaseName] -> [BaseName]
    forall a. a -> [a] -> [a]
    : Replacement a -> a -> [BaseName]
    forall a. Replacement a -> a -> [BaseName]
    go Replacement a
    p a
    a

    matchDelegation :: Delegation -> String -> Maybe String
    matchDelegation :: Delegation -> BaseName -> Maybe BaseName
    matchDelegation (Delegation Pattern a
    pat Replacement a
    repl) BaseName
    str =
        Replacement a -> a -> BaseName
    forall a. Replacement a -> a -> BaseName
    constructReplacement Replacement a
    repl (a -> BaseName) -> Maybe a -> Maybe BaseName
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> BaseName -> Pattern a -> Maybe a
    forall a. BaseName -> Pattern a -> Maybe a
    matchPattern BaseName
    str Pattern a
    pat

    {-------------------------------------------------------------------------------
      Typechecking patterns and replacements
    -------------------------------------------------------------------------------}

    -- | Types for pattern and replacements
    --
    -- We intentially are not very precise here, saying @String@ (instead of
    -- @FileName@, @BaseName@, or @Directory@, say) so that we can, for example,
    -- use a matched filename in a pattern as a directory in a replacement.
    data PatternType a where
      PatTypeNil :: PatternType ()
      PatTypeStr :: PatternType a -> PatternType (String :- a)

    instance Unify PatternType where
      unify :: forall typ typ'.
    PatternType typ -> PatternType typ' -> Maybe (typ :=: typ')
    unify PatternType typ
    PatTypeNil     PatternType typ'
    PatTypeNil       = (typ :=: typ') -> Maybe (typ :=: typ')
    forall a. a -> Maybe a
    Just typ :=: typ
    typ :=: typ'
    forall a. a :=: a
    Refl
      unify (PatTypeStr PatternType a
    p) (PatTypeStr  PatternType a
    p') = case PatternType a -> PatternType a -> Maybe (a :=: a)
    forall typ typ'.
    PatternType typ -> PatternType typ' -> Maybe (typ :=: typ')
    forall (f :: * -> *) typ typ'.
    Unify f =>
    f typ -> f typ' -> Maybe (typ :=: typ')
    unify PatternType a
    p PatternType a
    p' of
                                                Just a :=: a
    Refl -> (typ :=: typ') -> Maybe (typ :=: typ')
    forall a. a -> Maybe a
    Just typ :=: typ
    typ :=: typ'
    forall a. a :=: a
    Refl
                                                Maybe (a :=: a)
    Nothing   -> Maybe (typ :=: typ')
    forall a. Maybe a
    Nothing
      unify PatternType typ
    _              PatternType typ'
    _                = Maybe (typ :=: typ')
    forall a. Maybe a
    Nothing

    type instance TypeOf Pattern     = PatternType
    type instance TypeOf Replacement = PatternType

    instance Typed Pattern where
      typeOf :: forall typ. Pattern typ -> TypeOf Pattern typ
    typeOf (PatFileConst BaseName
    _)   = TypeOf Pattern typ
    PatternType ()
    PatTypeNil
      typeOf (PatFileExt   BaseName
    _)   = PatternType () -> PatternType (BaseName :- ())
    forall a. PatternType a -> PatternType (BaseName :- a)
    PatTypeStr PatternType ()
    PatTypeNil
      typeOf (Pattern typ
    PatFileAny    )   = PatternType () -> PatternType (BaseName :- ())
    forall a. PatternType a -> PatternType (BaseName :- a)
    PatTypeStr PatternType ()
    PatTypeNil
      typeOf (PatDirConst  BaseName
    _ Pattern typ
    p) = Pattern typ -> TypeOf Pattern typ
    forall typ. Pattern typ -> TypeOf Pattern typ
    forall (f :: * -> *) typ. Typed f => f typ -> TypeOf f typ
    typeOf Pattern typ
    p
      typeOf (PatDirAny      Pattern a
    p) = PatternType a -> PatternType (BaseName :- a)
    forall a. PatternType a -> PatternType (BaseName :- a)
    PatTypeStr (Pattern a -> TypeOf Pattern a
    forall typ. Pattern typ -> TypeOf Pattern typ
    forall (f :: * -> *) typ. Typed f => f typ -> TypeOf f typ
    typeOf Pattern a
    p)

    instance AsType Replacement where
      asType :: forall typ typ'.
    Replacement typ
    -> TypeOf Replacement typ' -> Maybe (Replacement typ')
    asType = Replacement typ
    -> TypeOf Replacement typ' -> Maybe (Replacement typ')
    Replacement typ -> PatternType typ' -> Maybe (Replacement typ')
    forall typ typ'.
    Replacement typ -> PatternType typ' -> Maybe (Replacement typ')
    go
        where
          go :: Replacement typ -> PatternType typ' -> Maybe (Replacement typ')
          go :: forall typ typ'.
    Replacement typ -> PatternType typ' -> Maybe (Replacement typ')
    go (RepFileConst BaseName
    c)   PatternType typ'
    _                = Replacement typ' -> Maybe (Replacement typ')
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Replacement typ' -> Maybe (Replacement typ'))
    -> Replacement typ' -> Maybe (Replacement typ')
    forall a b. (a -> b) -> a -> b
    $ BaseName -> Replacement typ'
    forall a. BaseName -> Replacement a
    RepFileConst BaseName
    c
          go (RepFileExt   BaseName
    _)   PatternType typ'
    PatTypeNil       = Maybe (Replacement typ')
    forall a. Maybe a
    Nothing
          go (RepFileExt   BaseName
    e)   (PatTypeStr PatternType a
    _)   = Replacement typ' -> Maybe (Replacement typ')
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Replacement typ' -> Maybe (Replacement typ'))
    -> Replacement typ' -> Maybe (Replacement typ')
    forall a b. (a -> b) -> a -> b
    $ BaseName -> Replacement (BaseName :- a)
    forall a. BaseName -> Replacement (BaseName :- a)
    RepFileExt BaseName
    e
          go Replacement typ
    RepFileAny         PatternType typ'
    PatTypeNil       = Maybe (Replacement typ')
    forall a. Maybe a
    Nothing
          go Replacement typ
    RepFileAny         (PatTypeStr PatternType a
    _)   = Replacement typ' -> Maybe (Replacement typ')
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Replacement typ' -> Maybe (Replacement typ'))
    -> Replacement typ' -> Maybe (Replacement typ')
    forall a b. (a -> b) -> a -> b
    $ Replacement typ'
    Replacement (BaseName :- a)
    forall a. Replacement (BaseName :- a)
    RepFileAny
          go (RepDirConst  BaseName
    c Replacement typ
    p) PatternType typ'
    tp               = BaseName -> Replacement typ' -> Replacement typ'
    forall a. BaseName -> Replacement a -> Replacement a
    RepDirConst BaseName
    c (Replacement typ' -> Replacement typ')
    -> Maybe (Replacement typ') -> Maybe (Replacement typ')
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Replacement typ -> PatternType typ' -> Maybe (Replacement typ')
    forall typ typ'.
    Replacement typ -> PatternType typ' -> Maybe (Replacement typ')
    go Replacement typ
    p PatternType typ'
    tp
          go (RepDirAny      Replacement a
    _) PatternType typ'
    PatTypeNil       = Maybe (Replacement typ')
    forall a. Maybe a
    Nothing
          go (RepDirAny      Replacement a
    p) (PatTypeStr PatternType a
    tp)  = Replacement a -> Replacement typ'
    Replacement a -> Replacement (BaseName :- a)
    forall a. Replacement a -> Replacement (BaseName :- a)
    RepDirAny     (Replacement a -> Replacement typ')
    -> Maybe (Replacement a) -> Maybe (Replacement typ')
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Replacement a -> PatternType a -> Maybe (Replacement a)
    forall typ typ'.
    Replacement typ -> PatternType typ' -> Maybe (Replacement typ')
    go Replacement a
    p PatternType a
    tp

    {-------------------------------------------------------------------------------
      Pretty-printing and parsing patterns and replacements
    -------------------------------------------------------------------------------}

    prettyPattern :: Pattern typ -> String
    prettyPattern :: forall typ. Pattern typ -> BaseName
    prettyPattern (PatFileConst BaseName
    f)   = BaseName
    f
    prettyPattern (PatFileExt   BaseName
    e)   = BaseName
    "*" BaseName -> ShowS
    <.> BaseName
    e
    prettyPattern Pattern typ
    PatFileAny         = BaseName
    "*"
    prettyPattern (PatDirConst  BaseName
    d Pattern typ
    p) = BaseName
    d   BaseName -> ShowS
    </> Pattern typ -> BaseName
    forall typ. Pattern typ -> BaseName
    prettyPattern Pattern typ
    p
    prettyPattern (PatDirAny      Pattern a
    p) = BaseName
    "*" BaseName -> ShowS
    </> Pattern a -> BaseName
    forall typ. Pattern typ -> BaseName
    prettyPattern Pattern a
    p

    prettyReplacement :: Replacement typ -> String
    prettyReplacement :: forall typ. Replacement typ -> BaseName
    prettyReplacement (RepFileConst BaseName
    f)   = BaseName
    f
    prettyReplacement (RepFileExt   BaseName
    e)   = BaseName
    "*" BaseName -> ShowS
    <.> BaseName
    e
    prettyReplacement Replacement typ
    RepFileAny         = BaseName
    "*"
    prettyReplacement (RepDirConst  BaseName
    d Replacement typ
    p) = BaseName
    d   BaseName -> ShowS
    </> Replacement typ -> BaseName
    forall typ. Replacement typ -> BaseName
    prettyReplacement Replacement typ
    p
    prettyReplacement (RepDirAny      Replacement a
    p) = BaseName
    "*" BaseName -> ShowS
    </> Replacement a -> BaseName
    forall typ. Replacement typ -> BaseName
    prettyReplacement Replacement a
    p

    -- | Parse a pattern
    parsePattern :: String -> Maybe (Some Pattern)
    parsePattern :: BaseName -> Maybe (Some Pattern)
    parsePattern = [BaseName] -> Maybe (Some Pattern)
    go ([BaseName] -> Maybe (Some Pattern))
    -> (BaseName -> [BaseName]) -> BaseName -> Maybe (Some Pattern)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . BaseName -> [BaseName]
    splitDirectories
      where
        go :: [String] -> Maybe (Some Pattern)
        go :: [BaseName] -> Maybe (Some Pattern)
    go []     = Maybe (Some Pattern)
    forall a. Maybe a
    Nothing
        go [BaseName
    "*"]  = Some Pattern -> Maybe (Some Pattern)
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Some Pattern -> Maybe (Some Pattern))
    -> (Pattern (BaseName :- ()) -> Some Pattern)
    -> Pattern (BaseName :- ())
    -> Maybe (Some Pattern)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Pattern (BaseName :- ()) -> Some Pattern
    forall (f :: * -> *) a. f a -> Some f
    Some (Pattern (BaseName :- ()) -> Maybe (Some Pattern))
    -> Pattern (BaseName :- ()) -> Maybe (Some Pattern)
    forall a b. (a -> b) -> a -> b
    $ Pattern (BaseName :- ())
    PatFileAny
        go [BaseName
    p]    = if Char
    '*' Char -> BaseName -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` BaseName
    p
                      then Some Pattern -> Maybe (Some Pattern)
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Some Pattern -> Maybe (Some Pattern))
    -> (Pattern () -> Some Pattern)
    -> Pattern ()
    -> Maybe (Some Pattern)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Pattern () -> Some Pattern
    forall (f :: * -> *) a. f a -> Some f
    Some (Pattern () -> Maybe (Some Pattern))
    -> Pattern () -> Maybe (Some Pattern)
    forall a b. (a -> b) -> a -> b
    $ BaseName -> Pattern ()
    PatFileConst BaseName
    p
                      else case BaseName -> (BaseName, BaseName)
    splitExtension BaseName
    p of
                             (BaseName
    "*", Char
    _:BaseName
    ext) -> Some Pattern -> Maybe (Some Pattern)
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Some Pattern -> Maybe (Some Pattern))
    -> (Pattern (BaseName :- ()) -> Some Pattern)
    -> Pattern (BaseName :- ())
    -> Maybe (Some Pattern)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Pattern (BaseName :- ()) -> Some Pattern
    forall (f :: * -> *) a. f a -> Some f
    Some (Pattern (BaseName :- ()) -> Maybe (Some Pattern))
    -> Pattern (BaseName :- ()) -> Maybe (Some Pattern)
    forall a b. (a -> b) -> a -> b
    $ BaseName -> Pattern (BaseName :- ())
    PatFileExt BaseName
    ext
                             (BaseName, BaseName)
    _otherwise   -> Maybe (Some Pattern)
    forall a. Maybe a
    Nothing
        go (BaseName
    p:[BaseName]
    ps) = do Some p' <- [BaseName] -> Maybe (Some Pattern)
    go [BaseName]
    ps
                       if '*' `notElem` p
                         then return . Some $ PatDirConst p p'
                         else case p of
                                BaseName
    "*"        -> Some Pattern -> Maybe (Some Pattern)
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Some Pattern -> Maybe (Some Pattern))
    -> (Pattern (BaseName :- a) -> Some Pattern)
    -> Pattern (BaseName :- a)
    -> Maybe (Some Pattern)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Pattern (BaseName :- a) -> Some Pattern
    forall (f :: * -> *) a. f a -> Some f
    Some (Pattern (BaseName :- a) -> Maybe (Some Pattern))
    -> Pattern (BaseName :- a) -> Maybe (Some Pattern)
    forall a b. (a -> b) -> a -> b
    $ Pattern a -> Pattern (BaseName :- a)
    forall a. Pattern a -> Pattern (BaseName :- a)
    PatDirAny Pattern a
    p'
                                BaseName
    _otherwise -> Maybe (Some Pattern)
    forall a. Maybe a
    Nothing

    -- | Parse a replacement
    --
    -- We cheat and use the parser for patterns and then translate using the
    -- identity replacement.
    parseReplacement :: String -> Maybe (Some Replacement)
    parseReplacement :: BaseName -> Maybe (Some Replacement)
    parseReplacement = (Some Pattern -> Some Replacement)
    -> Maybe (Some Pattern) -> Maybe (Some Replacement)
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Some Pattern -> Some Replacement
    aux (Maybe (Some Pattern) -> Maybe (Some Replacement))
    -> (BaseName -> Maybe (Some Pattern))
    -> BaseName
    -> Maybe (Some Replacement)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . BaseName -> Maybe (Some Pattern)
    parsePattern
      where
        aux :: Some Pattern -> Some Replacement
        aux :: Some Pattern -> Some Replacement
    aux (Some Pattern a
    pat) = Replacement a -> Some Replacement
    forall (f :: * -> *) a. f a -> Some f
    Some (Pattern a -> Replacement a
    forall typ. Pattern typ -> Replacement typ
    identityReplacement Pattern a
    pat)

    parseDelegation :: String -> String -> Either String Delegation
    parseDelegation :: BaseName -> BaseName -> Either BaseName Delegation
    parseDelegation BaseName
    pat BaseName
    repl =
        case (BaseName -> Maybe (Some Pattern)
    parsePattern BaseName
    pat, BaseName -> Maybe (Some Replacement)
    parseReplacement BaseName
    repl) of
          (Just (Some Pattern a
    pat'), Just (Some Replacement a
    repl')) ->
            case Replacement a
    repl' Replacement a -> TypeOf Replacement a -> Maybe (Replacement a)
    forall typ typ'.
    Replacement typ
    -> TypeOf Replacement typ' -> Maybe (Replacement typ')
    forall (f :: * -> *) typ typ'.
    AsType f =>
    f typ -> TypeOf f typ' -> Maybe (f typ')
    `asType` Pattern a -> TypeOf Pattern a
    forall typ. Pattern typ -> TypeOf Pattern typ
    forall (f :: * -> *) typ. Typed f => f typ -> TypeOf f typ
    typeOf Pattern a
    pat' of
              Just Replacement a
    repl'' -> Delegation -> Either BaseName Delegation
    forall a b. b -> Either a b
    Right (Delegation -> Either BaseName Delegation)
    -> Delegation -> Either BaseName Delegation
    forall a b. (a -> b) -> a -> b
    $ Pattern a -> Replacement a -> Delegation
    forall a. Pattern a -> Replacement a -> Delegation
    Delegation Pattern a
    pat' Replacement a
    repl''
              Maybe (Replacement a)
    Nothing     -> BaseName -> Either BaseName Delegation
    forall a b. a -> Either a b
    Left BaseName
    "Replacement does not match pattern type"
          (Maybe (Some Pattern), Maybe (Some Replacement))
    _otherwise ->
            BaseName -> Either BaseName Delegation
    forall a b. a -> Either a b
    Left BaseName
    "Cannot parse delegation"

    {-------------------------------------------------------------------------------
      Quasi-quotation

      We cannot (easily) use dataToExpQ because of the use of GADTs, so we manually
      give Lift instances.
    -------------------------------------------------------------------------------}

    -- | Quasi-quoter for delegations to make them easier to write in code
    --
    -- This allows to write delegations as
    --
    -- > $(qqd "targets/*/*/*.cabal" "targets/*/*/revisions.json")
    --
    -- (The alternative syntax which actually uses a quasi-quoter doesn't work very
    -- well because the '/*' bits confuse CPP: "unterminated comment")
    qqd :: String -> String -> Q Exp
    qqd :: BaseName -> BaseName -> Q Exp
    qqd BaseName
    pat BaseName
    repl  =
        case BaseName -> BaseName -> Either BaseName Delegation
    parseDelegation BaseName
    pat BaseName
    repl of
          Left  BaseName
    err -> BaseName -> Q Exp
    forall a. BaseName -> Q a
    forall (m :: * -> *) a. MonadFail m => BaseName -> m a
    fail (BaseName -> Q Exp) -> BaseName -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ BaseName
    "Invalid delegation: " BaseName -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ BaseName
    err
          Right Delegation
    del -> Delegation -> Q Exp
    forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
    forall (m :: * -> *). Quote m => Delegation -> m Exp
    TH.lift Delegation
    del

    deriving instance TH.Lift (Pattern a)
    deriving instance TH.Lift (Replacement a)
    deriving instance TH.Lift Delegation

    {-------------------------------------------------------------------------------
      JSON
    -------------------------------------------------------------------------------}

    instance Monad m => ToJSON m (Pattern typ) where
      toJSON :: Pattern typ -> m JSValue
    toJSON = JSValue -> m JSValue
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JSValue -> m JSValue)
    -> (Pattern typ -> JSValue) -> Pattern typ -> m JSValue
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . BaseName -> JSValue
    JSString (BaseName -> JSValue)
    -> (Pattern typ -> BaseName) -> Pattern typ -> JSValue
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Pattern typ -> BaseName
    forall typ. Pattern typ -> BaseName
    prettyPattern
    instance Monad m => ToJSON m (Replacement typ) where
      toJSON :: Replacement typ -> m JSValue
    toJSON = JSValue -> m JSValue
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (JSValue -> m JSValue)
    -> (Replacement typ -> JSValue) -> Replacement typ -> m JSValue
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . BaseName -> JSValue
    JSString (BaseName -> JSValue)
    -> (Replacement typ -> BaseName) -> Replacement typ -> JSValue
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Replacement typ -> BaseName
    forall typ. Replacement typ -> BaseName
    prettyReplacement

    instance Monad m => ToJSON m (Some Pattern) where
      toJSON :: Some Pattern -> m JSValue
    toJSON (Some Pattern a
    p) = Pattern a -> m JSValue
    forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
    toJSON Pattern a
    p
    instance Monad m => ToJSON m (Some Replacement) where
      toJSON :: Some Replacement -> m JSValue
    toJSON (Some Replacement a
    r) = Replacement a -> m JSValue
    forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
    toJSON Replacement a
    r

    instance ReportSchemaErrors m => FromJSON m (Some Pattern) where
      fromJSON :: JSValue -> m (Some Pattern)
    fromJSON JSValue
    enc = do
        str <- JSValue -> m BaseName
    forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
    fromJSON JSValue
    enc
        case parsePattern str of
          Maybe (Some Pattern)
    Nothing -> BaseName -> Maybe BaseName -> m (Some Pattern)
    forall a. BaseName -> Maybe BaseName -> m a
    forall (m :: * -> *) a.
    ReportSchemaErrors m =>
    BaseName -> Maybe BaseName -> m a
    expected BaseName
    "valid pattern" (BaseName -> Maybe BaseName
    forall a. a -> Maybe a
    Just BaseName
    str)
          Just Some Pattern
    p  -> Some Pattern -> m (Some Pattern)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Some Pattern
    p

    instance ReportSchemaErrors m => FromJSON m (Some Replacement) where
      fromJSON :: JSValue -> m (Some Replacement)
    fromJSON JSValue
    enc = do
        str <- JSValue -> m BaseName
    forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
    fromJSON JSValue
    enc
        case parseReplacement str of
          Maybe (Some Replacement)
    Nothing -> BaseName -> Maybe BaseName -> m (Some Replacement)
    forall a. BaseName -> Maybe BaseName -> m a
    forall (m :: * -> *) a.
    ReportSchemaErrors m =>
    BaseName -> Maybe BaseName -> m a
    expected BaseName
    "valid replacement" (BaseName -> Maybe BaseName
    forall a. a -> Maybe a
    Just BaseName
    str)
          Just Some Replacement
    r  -> Some Replacement -> m (Some Replacement)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Some Replacement
    r

    {-------------------------------------------------------------------------------
      Debugging: examples
    -------------------------------------------------------------------------------}

    _ex1 :: Maybe String
    _ex1 :: Maybe BaseName
    _ex1 = Delegation -> BaseName -> Maybe BaseName
    matchDelegation Delegation
    del BaseName
    "A/x/y/z.foo"
      where
        del :: Delegation
    del = Pattern (BaseName :- (BaseName :- (BaseName :- ())))
    -> Replacement (BaseName :- (BaseName :- (BaseName :- ())))
    -> Delegation
    forall a. Pattern a -> Replacement a -> Delegation
    Delegation
                ( BaseName
    -> Pattern (BaseName :- (BaseName :- (BaseName :- ())))
    -> Pattern (BaseName :- (BaseName :- (BaseName :- ())))
    forall a. BaseName -> Pattern a -> Pattern a
    PatDirConst BaseName
    "A"
                (Pattern (BaseName :- (BaseName :- (BaseName :- ())))
     -> Pattern (BaseName :- (BaseName :- (BaseName :- ()))))
    -> Pattern (BaseName :- (BaseName :- (BaseName :- ())))
    -> Pattern (BaseName :- (BaseName :- (BaseName :- ())))
    forall a b. (a -> b) -> a -> b
    $ Pattern (BaseName :- (BaseName :- ()))
    -> Pattern (BaseName :- (BaseName :- (BaseName :- ())))
    forall a. Pattern a -> Pattern (BaseName :- a)
    PatDirAny
                (Pattern (BaseName :- (BaseName :- ()))
     -> Pattern (BaseName :- (BaseName :- (BaseName :- ()))))
    -> Pattern (BaseName :- (BaseName :- ()))
    -> Pattern (BaseName :- (BaseName :- (BaseName :- ())))
    forall a b. (a -> b) -> a -> b
    $ Pattern (BaseName :- ()) -> Pattern (BaseName :- (BaseName :- ()))
    forall a. Pattern a -> Pattern (BaseName :- a)
    PatDirAny
                (Pattern (BaseName :- ())
     -> Pattern (BaseName :- (BaseName :- ())))
    -> Pattern (BaseName :- ())
    -> Pattern (BaseName :- (BaseName :- ()))
    forall a b. (a -> b) -> a -> b
    $ BaseName -> Pattern (BaseName :- ())
    PatFileExt BaseName
    "foo"
                )
                ( BaseName
    -> Replacement (BaseName :- (BaseName :- (BaseName :- ())))
    -> Replacement (BaseName :- (BaseName :- (BaseName :- ())))
    forall a. BaseName -> Replacement a -> Replacement a
    RepDirConst BaseName
    "B"
                (Replacement (BaseName :- (BaseName :- (BaseName :- ())))
     -> Replacement (BaseName :- (BaseName :- (BaseName :- ()))))
    -> Replacement (BaseName :- (BaseName :- (BaseName :- ())))
    -> Replacement (BaseName :- (BaseName :- (BaseName :- ())))
    forall a b. (a -> b) -> a -> b
    $ Replacement (BaseName :- (BaseName :- ()))
    -> Replacement (BaseName :- (BaseName :- (BaseName :- ())))
    forall a. Replacement a -> Replacement (BaseName :- a)
    RepDirAny
                (Replacement (BaseName :- (BaseName :- ()))
     -> Replacement (BaseName :- (BaseName :- (BaseName :- ()))))
    -> Replacement (BaseName :- (BaseName :- ()))
    -> Replacement (BaseName :- (BaseName :- (BaseName :- ())))
    forall a b. (a -> b) -> a -> b
    $ BaseName
    -> Replacement (BaseName :- (BaseName :- ()))
    -> Replacement (BaseName :- (BaseName :- ()))
    forall a. BaseName -> Replacement a -> Replacement a
    RepDirConst BaseName
    "C"
                (Replacement (BaseName :- (BaseName :- ()))
     -> Replacement (BaseName :- (BaseName :- ())))
    -> Replacement (BaseName :- (BaseName :- ()))
    -> Replacement (BaseName :- (BaseName :- ()))
    forall a b. (a -> b) -> a -> b
    $ Replacement (BaseName :- ())
    -> Replacement (BaseName :- (BaseName :- ()))
    forall a. Replacement a -> Replacement (BaseName :- a)
    RepDirAny
                (Replacement (BaseName :- ())
     -> Replacement (BaseName :- (BaseName :- ())))
    -> Replacement (BaseName :- ())
    -> Replacement (BaseName :- (BaseName :- ()))
    forall a b. (a -> b) -> a -> b
    $ BaseName -> Replacement (BaseName :- ())
    forall a. BaseName -> Replacement (BaseName :- a)
    RepFileExt BaseName
    "bar"
                )

    _ex2 :: Maybe String
    _ex2 :: Maybe BaseName
    _ex2 = (BaseName -> Maybe BaseName)
    -> (Delegation -> Maybe BaseName)
    -> Either BaseName Delegation
    -> Maybe BaseName
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either BaseName -> Maybe BaseName
    forall a. HasCallStack => a
    undefined (Delegation -> BaseName -> Maybe BaseName
    `matchDelegation` BaseName
    "A/x/y/z.foo")
      (BaseName -> BaseName -> Either BaseName Delegation
    parseDelegation BaseName
    "A/*/*/*.foo" BaseName
    "B/*/C/*/*.bar")

    _ex3 :: Either String Delegation
    _ex3 :: Either BaseName Delegation
    _ex3 = BaseName -> BaseName -> Either BaseName Delegation
    parseDelegation BaseName
    "foo" BaseName
    "*/bar"