-- | Patterns and replacements
--
-- NOTE: This module was developed to prepare for proper delegation (#39).
-- It is currently unused.
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE StandaloneDeriving #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif
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 MyPrelude
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 = forall typ. Pattern typ -> Replacement typ
go
  where
    go :: Pattern typ -> Replacement typ
    go :: forall typ. Pattern typ -> Replacement typ
go (PatFileConst BaseName
fn)  = forall a. BaseName -> Replacement a
RepFileConst BaseName
fn
    go (PatFileExt   BaseName
e)   = forall a. BaseName -> Replacement (BaseName :- a)
RepFileExt   BaseName
e
    go Pattern typ
PatFileAny         = forall a. Replacement (BaseName :- a)
RepFileAny
    go (PatDirConst  BaseName
d Pattern typ
p) = forall a. BaseName -> Replacement a -> Replacement a
RepDirConst  BaseName
d (forall typ. Pattern typ -> Replacement typ
go Pattern typ
p)
    go (PatDirAny      Pattern a
p) = forall a. Replacement a -> Replacement (BaseName :- a)
RepDirAny      (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 = forall a. [BaseName] -> Pattern a -> Maybe a
go 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
_                    = forall a. Maybe a
Nothing
    go [BaseName
f]   (PatFileConst BaseName
f')    = do forall (f :: * -> *). Alternative f => Bool -> f ()
guard (BaseName
f forall a. Eq a => a -> a -> Bool
== BaseName
f')
                                       forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go [BaseName
f]   (PatFileExt   BaseName
e')    = do let (BaseName
bn, Char
_:BaseName
e) = BaseName -> (BaseName, BaseName)
splitExtension BaseName
f
                                       forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ BaseName
e forall a. Eq a => a -> a -> Bool
== BaseName
e'
                                       forall (m :: * -> *) a. Monad m => a -> m a
return (BaseName
bn forall h t. h -> t -> h :- t
:- ())
    go [BaseName
_]   Pattern a
_                    = forall a. Maybe a
Nothing
    go (BaseName
d:[BaseName]
p) (PatDirConst  BaseName
d' Pattern a
p') = do forall (f :: * -> *). Alternative f => Bool -> f ()
guard (BaseName
d forall a. Eq a => a -> a -> Bool
== BaseName
d')
                                       forall a. [BaseName] -> Pattern a -> Maybe a
go [BaseName]
p Pattern a
p'
    go (BaseName
d:[BaseName]
p) (PatDirAny       Pattern a
p') = (BaseName
d forall h t. h -> t -> h :- t
:-) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [BaseName] -> Pattern a -> Maybe a
go [BaseName]
p Pattern a
p'
    go (BaseName
_:[BaseName]
_) Pattern 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 forall a b. (a -> b) -> a -> b
$ 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 forall a. a -> [a] -> [a]
: forall a. Replacement a -> a -> [BaseName]
go Replacement a
p a
a
    go (RepDirAny      Replacement a
p) (BaseName
d  :- a
a) = BaseName
d forall a. a -> [a] -> [a]
: 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 =
    forall a. Replacement a -> a -> BaseName
constructReplacement Replacement a
repl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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       = forall a. a -> Maybe a
Just forall a. a :=: a
Refl
  unify (PatTypeStr PatternType a
p) (PatTypeStr  PatternType a
p') = case 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 -> forall a. a -> Maybe a
Just forall a. a :=: a
Refl
                                            Maybe (a :=: a)
Nothing   -> forall a. Maybe a
Nothing
  unify PatternType typ
_              PatternType 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
_)   = PatternType ()
PatTypeNil
  typeOf (PatFileExt   BaseName
_)   = forall a. PatternType a -> PatternType (BaseName :- a)
PatTypeStr PatternType ()
PatTypeNil
  typeOf (Pattern typ
PatFileAny    )   = forall a. PatternType a -> PatternType (BaseName :- a)
PatTypeStr PatternType ()
PatTypeNil
  typeOf (PatDirConst  BaseName
_ Pattern typ
p) = forall (f :: * -> *) typ. Typed f => f typ -> TypeOf f typ
typeOf Pattern typ
p
  typeOf (PatDirAny      Pattern a
p) = forall a. PatternType a -> PatternType (BaseName :- a)
PatTypeStr (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 = 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'
_                = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. BaseName -> Replacement a
RepFileConst BaseName
c
      go (RepFileExt   BaseName
_)   PatternType typ'
PatTypeNil       = forall a. Maybe a
Nothing
      go (RepFileExt   BaseName
e)   (PatTypeStr PatternType a
_)   = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. BaseName -> Replacement (BaseName :- a)
RepFileExt BaseName
e
      go Replacement typ
RepFileAny         PatternType typ'
PatTypeNil       = forall a. Maybe a
Nothing
      go Replacement typ
RepFileAny         (PatTypeStr PatternType a
_)   = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Replacement (BaseName :- a)
RepFileAny
      go (RepDirConst  BaseName
c Replacement typ
p) PatternType typ'
tp               = forall a. BaseName -> Replacement a -> Replacement a
RepDirConst BaseName
c forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall typ typ'.
Replacement typ -> PatternType typ' -> Maybe (Replacement typ')
go Replacement typ
p PatternType typ'
tp
      go (RepDirAny      Replacement a
_) PatternType typ'
PatTypeNil       = forall a. Maybe a
Nothing
      go (RepDirAny      Replacement a
p) (PatTypeStr PatternType a
tp)  = forall a. Replacement a -> Replacement (BaseName :- a)
RepDirAny     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
</> forall typ. Pattern typ -> BaseName
prettyPattern Pattern typ
p
prettyPattern (PatDirAny      Pattern a
p) = BaseName
"*" BaseName -> ShowS
</> 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
</> forall typ. Replacement typ -> BaseName
prettyReplacement Replacement typ
p
prettyReplacement (RepDirAny      Replacement a
p) = BaseName
"*" BaseName -> ShowS
</> 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 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 []     = forall a. Maybe a
Nothing
    go [BaseName
"*"]  = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. f a -> Some f
Some forall a b. (a -> b) -> a -> b
$ Pattern (BaseName :- ())
PatFileAny
    go [BaseName
p]    = if Char
'*' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` BaseName
p
                  then forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. f a -> Some f
Some 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) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. f a -> Some f
Some forall a b. (a -> b) -> a -> b
$ BaseName -> Pattern (BaseName :- ())
PatFileExt BaseName
ext
                         (BaseName, BaseName)
_otherwise   -> forall a. Maybe a
Nothing
    go (BaseName
p:[BaseName]
ps) = do Some Pattern a
p' <- [BaseName] -> Maybe (Some Pattern)
go [BaseName]
ps
                   if Char
'*' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` BaseName
p
                     then forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. f a -> Some f
Some forall a b. (a -> b) -> a -> b
$ forall a. BaseName -> Pattern a -> Pattern a
PatDirConst BaseName
p Pattern a
p'
                     else case BaseName
p of
                            BaseName
"*"        -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. f a -> Some f
Some forall a b. (a -> b) -> a -> b
$ forall a. Pattern a -> Pattern (BaseName :- a)
PatDirAny Pattern a
p'
                            BaseName
_otherwise -> 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Some Pattern -> Some Replacement
aux 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) = forall (f :: * -> *) a. f a -> Some f
Some (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' forall (f :: * -> *) typ typ'.
AsType f =>
f typ -> TypeOf f typ' -> Maybe (f typ')
`asType` forall (f :: * -> *) typ. Typed f => f typ -> TypeOf f typ
typeOf Pattern a
pat' of
          Just Replacement a
repl'' -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Pattern a -> Replacement a -> Delegation
Delegation Pattern a
pat' Replacement a
repl''
          Maybe (Replacement a)
Nothing     -> forall a b. a -> Either a b
Left BaseName
"Replacement does not match pattern type"
      (Maybe (Some Pattern), Maybe (Some Replacement))
_otherwise ->
        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 -> forall (m :: * -> *) a. MonadFail m => BaseName -> m a
fail forall a b. (a -> b) -> a -> b
$ BaseName
"Invalid delegation: " forall a. [a] -> [a] -> [a]
++ BaseName
err
      Right Delegation
del -> forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
TH.lift Delegation
del

#if __GLASGOW_HASKELL__ >= 800
deriving instance TH.Lift (Pattern a)
deriving instance TH.Lift (Replacement a)
deriving instance TH.Lift Delegation
#else
instance TH.Lift (Pattern a) where
  lift (PatFileConst fn)  = [| PatFileConst fn  |]
  lift (PatFileExt   e)   = [| PatFileExt   e   |]
  lift PatFileAny         = [| PatFileAny       |]
  lift (PatDirConst  d p) = [| PatDirConst  d p |]
  lift (PatDirAny      p) = [| PatDirAny      p |]

instance TH.Lift (Replacement a) where
  lift (RepFileConst fn)  = [| RepFileConst fn  |]
  lift (RepFileExt   e )  = [| RepFileExt   e   |]
  lift RepFileAny         = [| RepFileAny       |]
  lift (RepDirConst  d r) = [| RepDirConst  d r |]
  lift (RepDirAny      r) = [| RepDirAny      r |]

instance TH.Lift Delegation where
  lift (Delegation pat repl) = [| Delegation pat repl |]
#endif

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

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

instance Monad m => ToJSON m (Some Pattern) where
  toJSON :: Some Pattern -> m JSValue
toJSON (Some Pattern a
p) = 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) = 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
    BaseName
str <- forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
enc
    case BaseName -> Maybe (Some Pattern)
parsePattern BaseName
str of
      Maybe (Some Pattern)
Nothing -> forall (m :: * -> *) a.
ReportSchemaErrors m =>
BaseName -> Maybe BaseName -> m a
expected BaseName
"valid pattern" (forall a. a -> Maybe a
Just BaseName
str)
      Just Some Pattern
p  -> 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
    BaseName
str <- forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
enc
    case BaseName -> Maybe (Some Replacement)
parseReplacement BaseName
str of
      Maybe (Some Replacement)
Nothing -> forall (m :: * -> *) a.
ReportSchemaErrors m =>
BaseName -> Maybe BaseName -> m a
expected BaseName
"valid replacement" (forall a. a -> Maybe a
Just BaseName
str)
      Just Some Replacement
r  -> 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 = forall a. Pattern a -> Replacement a -> Delegation
Delegation
            ( forall a. BaseName -> Pattern a -> Pattern a
PatDirConst BaseName
"A"
            forall a b. (a -> b) -> a -> b
$ forall a. Pattern a -> Pattern (BaseName :- a)
PatDirAny
            forall a b. (a -> b) -> a -> b
$ forall a. Pattern a -> Pattern (BaseName :- a)
PatDirAny
            forall a b. (a -> b) -> a -> b
$ BaseName -> Pattern (BaseName :- ())
PatFileExt BaseName
"foo"
            )
            ( forall a. BaseName -> Replacement a -> Replacement a
RepDirConst BaseName
"B"
            forall a b. (a -> b) -> a -> b
$ forall a. Replacement a -> Replacement (BaseName :- a)
RepDirAny
            forall a b. (a -> b) -> a -> b
$ forall a. BaseName -> Replacement a -> Replacement a
RepDirConst BaseName
"C"
            forall a b. (a -> b) -> a -> b
$ forall a. Replacement a -> Replacement (BaseName :- a)
RepDirAny
            forall a b. (a -> b) -> a -> b
$ forall a. BaseName -> Replacement (BaseName :- a)
RepFileExt BaseName
"bar"
            )

_ex2 :: Maybe String
_ex2 :: Maybe BaseName
_ex2 = Delegation -> BaseName -> Maybe BaseName
matchDelegation Delegation
del BaseName
"A/x/y/z.foo"
  where
    Right Delegation
del = 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"