{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StrictData #-}

-- | Parsing, pretty-printing and rendering of SPDX license templates
module Distribution.SPDX.Template
  ( Parser,
    License (..),
    Piece (..),
    SubstitutionError (..),
    license,
    prettyLicense,
    render,
    unsafeRender,
  )
where

import Data.Functor
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.String.Interpolate
import Data.Text (Text, pack)
import qualified Data.Text as T
import Data.Void
import GHC.Generics
import Text.Megaparsec
  ( MonadParsec (eof, notFollowedBy, takeWhileP, try),
    Parsec,
    anySingle,
    chunk,
    many,
    single,
    some,
    (<|>),
  )
import Text.Regex.TDFA ((=~))

type Parser = Parsec Void Text

data SubstitutionError = RegexNoMatch
  { SubstitutionError -> Text
name :: {-# UNPACK #-} Text,
    SubstitutionError -> Text
original :: {-# UNPACK #-} Text,
    SubstitutionError -> Text
match :: {-# UNPACK #-} Text,
    SubstitutionError -> Text
target :: {-# UNPACK #-} Text
  }
  deriving (SubstitutionError -> SubstitutionError -> Bool
(SubstitutionError -> SubstitutionError -> Bool)
-> (SubstitutionError -> SubstitutionError -> Bool)
-> Eq SubstitutionError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SubstitutionError -> SubstitutionError -> Bool
$c/= :: SubstitutionError -> SubstitutionError -> Bool
== :: SubstitutionError -> SubstitutionError -> Bool
$c== :: SubstitutionError -> SubstitutionError -> Bool
Eq, (forall x. SubstitutionError -> Rep SubstitutionError x)
-> (forall x. Rep SubstitutionError x -> SubstitutionError)
-> Generic SubstitutionError
forall x. Rep SubstitutionError x -> SubstitutionError
forall x. SubstitutionError -> Rep SubstitutionError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SubstitutionError x -> SubstitutionError
$cfrom :: forall x. SubstitutionError -> Rep SubstitutionError x
Generic)

instance Show SubstitutionError where
  show :: SubstitutionError -> String
show RegexNoMatch {Text
target :: Text
match :: Text
original :: Text
name :: Text
$sel:target:RegexNoMatch :: SubstitutionError -> Text
$sel:match:RegexNoMatch :: SubstitutionError -> Text
$sel:original:RegexNoMatch :: SubstitutionError -> Text
$sel:name:RegexNoMatch :: SubstitutionError -> Text
..} =
    [i|the substitution target "#{target}" does not match the regex "#{match}" required by the var "#{name}"|]

newtype License = License [Piece]
  deriving (Int -> License -> ShowS
[License] -> ShowS
License -> String
(Int -> License -> ShowS)
-> (License -> String) -> ([License] -> ShowS) -> Show License
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [License] -> ShowS
$cshowList :: [License] -> ShowS
show :: License -> String
$cshow :: License -> String
showsPrec :: Int -> License -> ShowS
$cshowsPrec :: Int -> License -> ShowS
Show, License -> License -> Bool
(License -> License -> Bool)
-> (License -> License -> Bool) -> Eq License
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: License -> License -> Bool
$c/= :: License -> License -> Bool
== :: License -> License -> Bool
$c== :: License -> License -> Bool
Eq, (forall x. License -> Rep License x)
-> (forall x. Rep License x -> License) -> Generic License
forall x. Rep License x -> License
forall x. License -> Rep License x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep License x -> License
$cfrom :: forall x. License -> Rep License x
Generic)

data Piece
  = Substansive {-# UNPACK #-} Text
  | Optional [Piece]
  | Var
      { Piece -> Text
name :: {-# UNPACK #-} Text,
        -- | The original content
        Piece -> Text
original :: {-# UNPACK #-} Text,
        -- | A POSIX ERE that any new value must match
        Piece -> Text
match :: {-# UNPACK #-} Text
      }
  deriving (Int -> Piece -> ShowS
[Piece] -> ShowS
Piece -> String
(Int -> Piece -> ShowS)
-> (Piece -> String) -> ([Piece] -> ShowS) -> Show Piece
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Piece] -> ShowS
$cshowList :: [Piece] -> ShowS
show :: Piece -> String
$cshow :: Piece -> String
showsPrec :: Int -> Piece -> ShowS
$cshowsPrec :: Int -> Piece -> ShowS
Show, Piece -> Piece -> Bool
(Piece -> Piece -> Bool) -> (Piece -> Piece -> Bool) -> Eq Piece
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Piece -> Piece -> Bool
$c/= :: Piece -> Piece -> Bool
== :: Piece -> Piece -> Bool
$c== :: Piece -> Piece -> Bool
Eq, (forall x. Piece -> Rep Piece x)
-> (forall x. Rep Piece x -> Piece) -> Generic Piece
forall x. Rep Piece x -> Piece
forall x. Piece -> Rep Piece x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Piece x -> Piece
$cfrom :: forall x. Piece -> Rep Piece x
Generic)

prettyPiece :: Piece -> Text
prettyPiece :: Piece -> Text
prettyPiece (Substansive Text
s) = Text
s
prettyPiece (Optional [Piece]
o) = [i|<<beginOptional>>#{foldMap prettyPiece o}<<endOptional>>|]
prettyPiece Var {Text
match :: Text
original :: Text
name :: Text
$sel:match:Substansive :: Piece -> Text
$sel:original:Substansive :: Piece -> Text
$sel:name:Substansive :: Piece -> Text
..} = [i|<<var;name="#{name}";original="#{original}";match="#{match}">>|]

-- | Pretty-print a license template
prettyLicense :: License -> Text
prettyLicense :: License -> Text
prettyLicense (License [Piece]
ps) = (Piece -> Text) -> [Piece] -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Piece -> Text
prettyPiece [Piece]
ps

bra :: Parser ()
bra :: Parser ()
bra = Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"<<" ParsecT Void Text Identity Text -> () -> Parser ()
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ()

ket :: Parser ()
ket :: Parser ()
ket = Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
">>" ParsecT Void Text Identity Text -> () -> Parser ()
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ()

bracket :: Parser a -> Parser a
bracket :: Parser a -> Parser a
bracket Parser a
p = Parser ()
bra Parser () -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p Parser a -> Parser () -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
ket

semi :: Parser ()
semi :: Parser ()
semi = Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token Text
';' ParsecT Void Text Identity Char -> () -> Parser ()
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ()

quote :: Parser a -> Parser a
quote :: Parser a -> Parser a
quote Parser a
p = Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token Text
'"' ParsecT Void Text Identity Char -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p Parser a -> ParsecT Void Text Identity Char -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token Text
'"'

eq :: Parser ()
eq :: Parser ()
eq = Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
Token Text
'=' ParsecT Void Text Identity Char -> () -> Parser ()
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ()

field :: Text -> Parser Text
field :: Text -> ParsecT Void Text Identity Text
field Text
fieldName = do
  Text
_ <- Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Text
Tokens Text
fieldName
  Parser ()
eq
  ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a. Parser a -> Parser a
quote (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"')

beginOptional :: Parser ()
beginOptional :: Parser ()
beginOptional = Parser () -> Parser ()
forall a. Parser a -> Parser a
bracket (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"beginOptional" ParsecT Void Text Identity Text -> () -> Parser ()
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ()

endOptional :: Parser ()
endOptional :: Parser ()
endOptional = Parser () -> Parser ()
forall a. Parser a -> Parser a
bracket (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"endOptional" ParsecT Void Text Identity Text -> () -> Parser ()
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ()

substansive :: Parser Piece
substansive :: Parser Piece
substansive = do
  String
l <- ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (ParsecT Void Text Identity Char
 -> ParsecT Void Text Identity String)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall a b. (a -> b) -> a -> b
$ do
    Parser Piece -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy Parser Piece
var
    Parser () -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy Parser ()
beginOptional
    Parser () -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy Parser ()
endOptional
    ParsecT Void Text Identity Char
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle
  Piece -> Parser Piece
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Piece -> Parser Piece) -> Piece -> Parser Piece
forall a b. (a -> b) -> a -> b
$ Text -> Piece
Substansive (Text -> Piece) -> Text -> Piece
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
l

optional :: Parser Piece
optional :: Parser Piece
optional = do
  Parser ()
beginOptional
  [Piece]
l <- Parser Piece -> ParsecT Void Text Identity [Piece]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser Piece
piece
  Parser ()
endOptional
  Piece -> Parser Piece
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Piece -> Parser Piece) -> Piece -> Parser Piece
forall a b. (a -> b) -> a -> b
$ [Piece] -> Piece
Optional [Piece]
l

var :: Parser Piece
var :: Parser Piece
var = Parser Piece -> Parser Piece
forall a. Parser a -> Parser a
bracket (Parser Piece -> Parser Piece) -> Parser Piece -> Parser Piece
forall a b. (a -> b) -> a -> b
$ do
  Text
_ <- Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"var"
  Parser ()
semi
  Text
name <- Text -> ParsecT Void Text Identity Text
field Text
"name"
  Parser ()
semi
  Text
original <- Text -> ParsecT Void Text Identity Text
field Text
"original"
  Parser ()
semi
  Text
match <- Text -> ParsecT Void Text Identity Text
field Text
"match"
  Piece -> Parser Piece
forall (f :: * -> *) a. Applicative f => a -> f a
pure Var :: Text -> Text -> Text -> Piece
Var {Text
match :: Text
original :: Text
name :: Text
$sel:match:Substansive :: Text
$sel:original:Substansive :: Text
$sel:name:Substansive :: Text
..}

piece :: Parser Piece
piece :: Parser Piece
piece = Parser Piece -> Parser Piece
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser Piece
var Parser Piece -> Parser Piece -> Parser Piece
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Piece -> Parser Piece
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser Piece
optional Parser Piece -> Parser Piece -> Parser Piece
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Piece -> Parser Piece
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser Piece
substansive

-- | License parser
license :: Parser License
license :: Parser License
license = do
  [Piece]
pieces <- Parser Piece -> ParsecT Void Text Identity [Piece]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser Piece
piece
  Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
  License -> Parser License
forall (f :: * -> *) a. Applicative f => a -> f a
pure (License -> Parser License) -> License -> Parser License
forall a b. (a -> b) -> a -> b
$ [Piece] -> License
License [Piece]
pieces

substitute :: Map Text Text -> Piece -> Either SubstitutionError Text
substitute :: Map Text Text -> Piece -> Either SubstitutionError Text
substitute Map Text Text
_ (Substansive Text
s) = Text -> Either SubstitutionError Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
s
substitute Map Text Text
ctx (Optional [Piece]
ps) = Map Text Text -> [Piece] -> Either SubstitutionError Text
substitute' Map Text Text
ctx [Piece]
ps
substitute Map Text Text
ctx Var {Text
match :: Text
original :: Text
name :: Text
$sel:match:Substansive :: Piece -> Text
$sel:original:Substansive :: Piece -> Text
$sel:name:Substansive :: Piece -> Text
..} =
  let mTarget :: Maybe Text
mTarget = Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
name Map Text Text
ctx
   in Either SubstitutionError Text
-> (Text -> Either SubstitutionError Text)
-> Maybe Text
-> Either SubstitutionError Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (Text -> Either SubstitutionError Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
original)
        ( \Text
target ->
            if Text
target Text -> Text -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ Text
match
              then Text -> Either SubstitutionError Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
target
              else SubstitutionError -> Either SubstitutionError Text
forall a b. a -> Either a b
Left (SubstitutionError -> Either SubstitutionError Text)
-> SubstitutionError -> Either SubstitutionError Text
forall a b. (a -> b) -> a -> b
$ RegexNoMatch :: Text -> Text -> Text -> Text -> SubstitutionError
RegexNoMatch {Text
target :: Text
match :: Text
original :: Text
name :: Text
$sel:target:RegexNoMatch :: Text
$sel:match:RegexNoMatch :: Text
$sel:original:RegexNoMatch :: Text
$sel:name:RegexNoMatch :: Text
..}
        )
        Maybe Text
mTarget

substitute' :: Map Text Text -> [Piece] -> Either SubstitutionError Text
substitute' :: Map Text Text -> [Piece] -> Either SubstitutionError Text
substitute' Map Text Text
ctx [Piece]
ps = [Text] -> Text
T.concat ([Text] -> Text)
-> Either SubstitutionError [Text] -> Either SubstitutionError Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Piece -> Either SubstitutionError Text)
-> [Piece] -> Either SubstitutionError [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Map Text Text -> Piece -> Either SubstitutionError Text
substitute Map Text Text
ctx) [Piece]
ps

unsafeSubstitute :: Map Text Text -> Piece -> Text
unsafeSubstitute :: Map Text Text -> Piece -> Text
unsafeSubstitute Map Text Text
_ (Substansive Text
s) = Text
s
unsafeSubstitute Map Text Text
ctx (Optional [Piece]
ps) = Map Text Text -> [Piece] -> Text
unsafeSubstitute' Map Text Text
ctx [Piece]
ps
unsafeSubstitute Map Text Text
ctx Var {Text
match :: Text
original :: Text
name :: Text
$sel:match:Substansive :: Piece -> Text
$sel:original:Substansive :: Piece -> Text
$sel:name:Substansive :: Piece -> Text
..} = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
original (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
name Map Text Text
ctx

unsafeSubstitute' :: Map Text Text -> [Piece] -> Text
unsafeSubstitute' :: Map Text Text -> [Piece] -> Text
unsafeSubstitute' Map Text Text
ctx [Piece]
ps = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Piece -> Text) -> [Piece] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Map Text Text -> Piece -> Text
unsafeSubstitute Map Text Text
ctx) [Piece]
ps

-- | Render a license from a context, if a var is not in the context, the original value will be used
render :: Map Text Text -> License -> Either SubstitutionError Text
render :: Map Text Text -> License -> Either SubstitutionError Text
render Map Text Text
ctx (License [Piece]
ps) = [Text] -> Text
T.concat ([Text] -> Text)
-> Either SubstitutionError [Text] -> Either SubstitutionError Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Piece -> Either SubstitutionError Text)
-> [Piece] -> Either SubstitutionError [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Map Text Text -> Piece -> Either SubstitutionError Text
substitute Map Text Text
ctx) [Piece]
ps

-- | Render a license without checking whether the texts match the regexes
unsafeRender :: Map Text Text -> License -> Text
unsafeRender :: Map Text Text -> License -> Text
unsafeRender Map Text Text
ctx (License [Piece]
ps) = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Piece -> Text) -> [Piece] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Map Text Text -> Piece -> Text
unsafeSubstitute Map Text Text
ctx) [Piece]
ps