-- | 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 Pattern a
p' <- [BaseName] -> Maybe (Some Pattern)
go [BaseName]
ps
                   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 a -> Some Pattern) -> Pattern a -> Maybe (Some Pattern)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern a -> Some Pattern
forall (f :: * -> *) a. f a -> Some f
Some (Pattern a -> Maybe (Some Pattern))
-> Pattern a -> Maybe (Some Pattern)
forall a b. (a -> b) -> a -> b
$ BaseName -> Pattern a -> Pattern a
forall a. BaseName -> Pattern a -> Pattern a
PatDirConst BaseName
p Pattern a
p'
                     else case BaseName
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
    BaseName
str <- JSValue -> m BaseName
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 -> 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
    BaseName
str <- JSValue -> m BaseName
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 -> 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"