-- | Patterns and replacements
--
-- NOTE: This module was developed to prepare for proper delegation (#39).
-- It is currently unusued.
{-# 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.Except
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 :: Pattern typ -> Replacement typ
identityReplacement = Pattern typ -> Replacement typ
forall typ. Pattern typ -> Replacement typ
go
  where
    go :: Pattern typ -> Replacement typ
    go :: Pattern typ -> Replacement typ
go (PatFileConst String
fn)  = String -> Replacement typ
forall a. String -> Replacement a
RepFileConst String
fn
    go (PatFileExt   String
e)   = String -> Replacement (String :- ())
forall a. String -> Replacement (String :- a)
RepFileExt   String
e
    go Pattern typ
PatFileAny         = Replacement typ
forall a. Replacement (String :- a)
RepFileAny
    go (PatDirConst  String
d Pattern typ
p) = String -> Replacement typ -> Replacement typ
forall a. String -> Replacement a -> Replacement a
RepDirConst  String
d (Pattern typ -> Replacement typ
forall typ. Pattern typ -> Replacement typ
go Pattern typ
p)
    go (PatDirAny      Pattern a
p) = Replacement a -> Replacement (String :- a)
forall a. Replacement a -> Replacement (String :- 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 :: String -> Pattern a -> Maybe a
matchPattern = [String] -> Pattern a -> Maybe a
forall a. [String] -> Pattern a -> Maybe a
go ([String] -> Pattern a -> Maybe a)
-> (String -> [String]) -> String -> Pattern a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitDirectories
  where
    go :: [String] -> Pattern a -> Maybe a
    go :: [String] -> Pattern a -> Maybe a
go []    Pattern a
_                    = Maybe a
forall a. Maybe a
Nothing
    go [String
f]   (PatFileConst String
f')    = do Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
f')
                                       () -> Maybe ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go [String
f]   (PatFileExt   String
e')    = do let (String
bn, Char
_:String
e) = String -> (String, String)
splitExtension String
f
                                       Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ String
e String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
e'
                                       (String :- ()) -> Maybe (String :- ())
forall (m :: * -> *) a. Monad m => a -> m a
return (String
bn String -> () -> String :- ()
forall h t. h -> t -> h :- t
:- ())
    go [String
_]   Pattern a
_                    = Maybe a
forall a. Maybe a
Nothing
    go (String
d:[String]
p) (PatDirConst  String
d' Pattern a
p') = do Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
d String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
d')
                                       [String] -> Pattern a -> Maybe a
forall a. [String] -> Pattern a -> Maybe a
go [String]
p Pattern a
p'
    go (String
d:[String]
p) (PatDirAny       Pattern a
p') = (String
d String -> a -> String :- a
forall h t. h -> t -> h :- t
:-) (a -> String :- a) -> Maybe a -> Maybe (String :- a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> Pattern a -> Maybe a
forall a. [String] -> Pattern a -> Maybe a
go [String]
p Pattern a
p'
    go (String
_:[String]
_) Pattern a
_                    = Maybe a
forall a. Maybe a
Nothing

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

matchDelegation :: Delegation -> String -> Maybe String
matchDelegation :: Delegation -> String -> Maybe String
matchDelegation (Delegation Pattern a
pat Replacement a
repl) String
str =
    Replacement a -> a -> String
forall a. Replacement a -> a -> String
constructReplacement Replacement a
repl (a -> String) -> Maybe a -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Pattern a -> Maybe a
forall a. String -> Pattern a -> Maybe a
matchPattern String
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 :: 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
forall a. a :=: a
Refl
  unify (PatTypeStr PatternType a
p) (PatTypeStr  PatternType a
p') = case PatternType a -> PatternType a -> Maybe (a :=: a)
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
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 :: Pattern typ -> TypeOf Pattern typ
typeOf (PatFileConst String
_)   = TypeOf Pattern typ
PatternType ()
PatTypeNil
  typeOf (PatFileExt   String
_)   = PatternType () -> PatternType (String :- ())
forall a. PatternType a -> PatternType (String :- a)
PatTypeStr PatternType ()
PatTypeNil
  typeOf (Pattern typ
PatFileAny    )   = PatternType () -> PatternType (String :- ())
forall a. PatternType a -> PatternType (String :- a)
PatTypeStr PatternType ()
PatTypeNil
  typeOf (PatDirConst  String
_ Pattern typ
p) = 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 (String :- a)
forall a. PatternType a -> PatternType (String :- a)
PatTypeStr (Pattern a -> TypeOf Pattern a
forall (f :: * -> *) typ. Typed f => f typ -> TypeOf f typ
typeOf Pattern a
p)

instance AsType Replacement where
  asType :: Replacement typ
-> TypeOf Replacement typ' -> Maybe (Replacement typ')
asType = Replacement typ
-> TypeOf Replacement 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 :: Replacement typ -> PatternType typ' -> Maybe (Replacement typ')
go (RepFileConst String
c)   PatternType typ'
_                = Replacement typ' -> Maybe (Replacement typ')
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
$ String -> Replacement typ'
forall a. String -> Replacement a
RepFileConst String
c
      go (RepFileExt   String
_)   PatternType typ'
PatTypeNil       = Maybe (Replacement typ')
forall a. Maybe a
Nothing
      go (RepFileExt   String
e)   (PatTypeStr PatternType a
_)   = Replacement (String :- a) -> Maybe (Replacement (String :- a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Replacement (String :- a) -> Maybe (Replacement (String :- a)))
-> Replacement (String :- a) -> Maybe (Replacement (String :- a))
forall a b. (a -> b) -> a -> b
$ String -> Replacement (String :- a)
forall a. String -> Replacement (String :- a)
RepFileExt String
e
      go Replacement typ
RepFileAny         PatternType typ'
PatTypeNil       = Maybe (Replacement typ')
forall a. Maybe a
Nothing
      go Replacement typ
RepFileAny         (PatTypeStr PatternType a
_)   = Replacement (String :- a) -> Maybe (Replacement (String :- a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Replacement (String :- a) -> Maybe (Replacement (String :- a)))
-> Replacement (String :- a) -> Maybe (Replacement (String :- a))
forall a b. (a -> b) -> a -> b
$ Replacement (String :- a)
forall a. Replacement (String :- a)
RepFileAny
      go (RepDirConst  String
c Replacement typ
p) PatternType typ'
tp               = String -> Replacement typ' -> Replacement typ'
forall a. String -> Replacement a -> Replacement a
RepDirConst String
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 (String :- a)
forall a. Replacement a -> Replacement (String :- a)
RepDirAny     (Replacement a -> Replacement (String :- a))
-> Maybe (Replacement a) -> Maybe (Replacement (String :- a))
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 :: Pattern typ -> String
prettyPattern (PatFileConst String
f)   = String
f
prettyPattern (PatFileExt   String
e)   = String
"*" String -> ShowS
<.> String
e
prettyPattern Pattern typ
PatFileAny         = String
"*"
prettyPattern (PatDirConst  String
d Pattern typ
p) = String
d   String -> ShowS
</> Pattern typ -> String
forall typ. Pattern typ -> String
prettyPattern Pattern typ
p
prettyPattern (PatDirAny      Pattern a
p) = String
"*" String -> ShowS
</> Pattern a -> String
forall typ. Pattern typ -> String
prettyPattern Pattern a
p

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

-- | Parse a pattern
parsePattern :: String -> Maybe (Some Pattern)
parsePattern :: String -> Maybe (Some Pattern)
parsePattern = [String] -> Maybe (Some Pattern)
go ([String] -> Maybe (Some Pattern))
-> (String -> [String]) -> String -> Maybe (Some Pattern)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitDirectories
  where
    go :: [String] -> Maybe (Some Pattern)
    go :: [String] -> Maybe (Some Pattern)
go []     = Maybe (Some Pattern)
forall a. Maybe a
Nothing
    go [String
"*"]  = Some Pattern -> Maybe (Some Pattern)
forall (m :: * -> *) a. Monad m => a -> m a
return (Some Pattern -> Maybe (Some Pattern))
-> (Pattern (String :- ()) -> Some Pattern)
-> Pattern (String :- ())
-> Maybe (Some Pattern)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern (String :- ()) -> Some Pattern
forall (f :: * -> *) a. f a -> Some f
Some (Pattern (String :- ()) -> Maybe (Some Pattern))
-> Pattern (String :- ()) -> Maybe (Some Pattern)
forall a b. (a -> b) -> a -> b
$ Pattern (String :- ())
PatFileAny
    go [String
p]    = if Char
'*' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
p
                  then Some Pattern -> Maybe (Some Pattern)
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
$ String -> Pattern ()
PatFileConst String
p
                  else case String -> (String, String)
splitExtension String
p of
                         (String
"*", Char
_:String
ext) -> Some Pattern -> Maybe (Some Pattern)
forall (m :: * -> *) a. Monad m => a -> m a
return (Some Pattern -> Maybe (Some Pattern))
-> (Pattern (String :- ()) -> Some Pattern)
-> Pattern (String :- ())
-> Maybe (Some Pattern)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern (String :- ()) -> Some Pattern
forall (f :: * -> *) a. f a -> Some f
Some (Pattern (String :- ()) -> Maybe (Some Pattern))
-> Pattern (String :- ()) -> Maybe (Some Pattern)
forall a b. (a -> b) -> a -> b
$ String -> Pattern (String :- ())
PatFileExt String
ext
                         (String, String)
_otherwise   -> Maybe (Some Pattern)
forall a. Maybe a
Nothing
    go (String
p:[String]
ps) = do Some Pattern a
p' <- [String] -> Maybe (Some Pattern)
go [String]
ps
                   if Char
'*' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
p
                     then Some Pattern -> Maybe (Some Pattern)
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
$ String -> Pattern a -> Pattern a
forall a. String -> Pattern a -> Pattern a
PatDirConst String
p Pattern a
p'
                     else case String
p of
                            String
"*"        -> Some Pattern -> Maybe (Some Pattern)
forall (m :: * -> *) a. Monad m => a -> m a
return (Some Pattern -> Maybe (Some Pattern))
-> (Pattern (String :- a) -> Some Pattern)
-> Pattern (String :- a)
-> Maybe (Some Pattern)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern (String :- a) -> Some Pattern
forall (f :: * -> *) a. f a -> Some f
Some (Pattern (String :- a) -> Maybe (Some Pattern))
-> Pattern (String :- a) -> Maybe (Some Pattern)
forall a b. (a -> b) -> a -> b
$ Pattern a -> Pattern (String :- a)
forall a. Pattern a -> Pattern (String :- a)
PatDirAny Pattern a
p'
                            String
_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 :: String -> Maybe (Some Replacement)
parseReplacement = (Some Pattern -> Some Replacement)
-> Maybe (Some Pattern) -> Maybe (Some Replacement)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Some Pattern -> Some Replacement
aux (Maybe (Some Pattern) -> Maybe (Some Replacement))
-> (String -> Maybe (Some Pattern))
-> String
-> Maybe (Some Replacement)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> 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 :: String -> String -> Either String Delegation
parseDelegation String
pat String
repl =
    case (String -> Maybe (Some Pattern)
parsePattern String
pat, String -> Maybe (Some Replacement)
parseReplacement String
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 (f :: * -> *) typ typ'.
AsType f =>
f typ -> TypeOf f typ' -> Maybe (f typ')
`asType` Pattern a -> TypeOf Pattern a
forall (f :: * -> *) typ. Typed f => f typ -> TypeOf f typ
typeOf Pattern a
pat' of
          Just Replacement a
repl'' -> Delegation -> Either String Delegation
forall a b. b -> Either a b
Right (Delegation -> Either String Delegation)
-> Delegation -> Either String 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     -> String -> Either String Delegation
forall a b. a -> Either a b
Left String
"Replacement does not match pattern type"
      (Maybe (Some Pattern), Maybe (Some Replacement))
_otherwise ->
        String -> Either String Delegation
forall a b. a -> Either a b
Left String
"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 :: String -> String -> Q Exp
qqd String
pat String
repl  =
    case String -> String -> Either String Delegation
parseDelegation String
pat String
repl of
      Left  String
err -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Invalid delegation: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err
      Right Delegation
del -> Delegation -> Q Exp
forall t. Lift t => t -> Q 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 = JSValue -> m JSValue
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
. String -> JSValue
JSString (String -> JSValue)
-> (Pattern typ -> String) -> Pattern typ -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern typ -> String
forall typ. Pattern typ -> String
prettyPattern
instance Monad m => ToJSON m (Replacement typ) where
  toJSON :: Replacement typ -> m JSValue
toJSON = JSValue -> m JSValue
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
. String -> JSValue
JSString (String -> JSValue)
-> (Replacement typ -> String) -> Replacement typ -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Replacement typ -> String
forall typ. Replacement typ -> String
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
    String
str <- JSValue -> m String
forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
enc
    case String -> Maybe (Some Pattern)
parsePattern String
str of
      Maybe (Some Pattern)
Nothing -> String -> Maybe String -> m (Some Pattern)
forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> Maybe String -> m a
expected String
"valid pattern" (String -> Maybe String
forall a. a -> Maybe a
Just String
str)
      Just Some Pattern
p  -> Some Pattern -> m (Some Pattern)
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
    String
str <- JSValue -> m String
forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
enc
    case String -> Maybe (Some Replacement)
parseReplacement String
str of
      Maybe (Some Replacement)
Nothing -> String -> Maybe String -> m (Some Replacement)
forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> Maybe String -> m a
expected String
"valid replacement" (String -> Maybe String
forall a. a -> Maybe a
Just String
str)
      Just Some Replacement
r  -> Some Replacement -> m (Some Replacement)
forall (m :: * -> *) a. Monad m => a -> m a
return Some Replacement
r

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

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

_ex2 :: Maybe String
_ex2 :: Maybe String
_ex2 = Delegation -> String -> Maybe String
matchDelegation Delegation
del String
"A/x/y/z.foo"
  where
    Right Delegation
del = String -> String -> Either String Delegation
parseDelegation String
"A/*/*/*.foo" String
"B/*/C/*/*.bar"

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