{-# LANGUAGE TemplateHaskellQuotes #-}

module Web.ArchLinux.Internal.KnownSPDXLoader (loadKnownSPDX) where

import Data.Aeson
import qualified Data.ByteString as BS
import Data.Map.Strict (Map, toList)
import GHC.Generics (Generic)
import Language.Haskell.TH
import System.Directory (getCurrentDirectory)
import System.FilePath ((</>))

-- | Load the KNOWN_SPDX.json file at compile time and generate data type 'License', and
-- functions 'parseLicense' and 'licenseId'. If the license string is not known, 'parseLicense'
-- will return 'Custom' with the original string, and 'licenseId' will return the original string
-- for 'Custom' licenses.
loadKnownSPDX :: DecsQ
loadKnownSPDX :: DecsQ
loadKnownSPDX = do
  ByteString
txt <- IO ByteString -> Q ByteString
forall a. IO a -> Q a
runIO (IO ByteString -> Q ByteString) -> IO ByteString -> Q ByteString
forall a b. (a -> b) -> a -> b
$ IO String
getCurrentDirectory IO String -> (String -> IO ByteString) -> IO ByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
dot -> String -> IO ByteString
BS.readFile (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String
dot String -> String -> String
</> String
"data" String -> String -> String
</> String
"KNOWN_SPDX.json"
  let (Map String String -> [(String, String)]
forall k a. Map k a -> [(k, a)]
toList -> [(String, String)]
src) = case forall a. FromJSON a => ByteString -> Maybe a
decodeStrict @(Map String String) ByteString
txt of
        Just Map String String
x -> Map String String
x
        Maybe (Map String String)
_ -> String -> Map String String
forall a. HasCallStack => String -> a
error String
"Failed to parse json"
  Dec
dec1 <- [(String, String)] -> DecQ
genData [(String, String)]
src
  Dec
dec2 <- [(String, String)] -> DecQ
genParse [(String, String)]
src
  Dec
dec3 <- [(String, String)] -> DecQ
genId [(String, String)]
src
  [Dec] -> DecsQ
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [Dec
dec1, Dec
dec2, Dec
dec3]

genData :: [(String, String)] -> DecQ
genData :: [(String, String)] -> DecQ
genData [(String, String)]
src = Q Cxt
-> Name
-> [Q (TyVarBndr BndrVis)]
-> Maybe (Q Kind)
-> [(Q Con, Maybe String, [Maybe String])]
-> [Q DerivClause]
-> Maybe String
-> DecQ
dataD_doc (Cxt -> Q Cxt
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []) (String -> Name
mkName String
"License") [] Maybe (Q Kind)
forall a. Maybe a
Nothing ((Q Con, Maybe String, [Maybe String])
forall {a} {a}. (Q Con, Maybe a, [a])
customCon (Q Con, Maybe String, [Maybe String])
-> [(Q Con, Maybe String, [Maybe String])]
-> [(Q Con, Maybe String, [Maybe String])]
forall a. a -> [a] -> [a]
: ((String, String) -> (Q Con, Maybe String, [Maybe String])
forall {m :: Type -> Type} {f :: Type -> Type} {a}.
(Quote m, Applicative f) =>
(String, String) -> (m Con, f String, [a])
genCon ((String, String) -> (Q Con, Maybe String, [Maybe String]))
-> [(String, String)] -> [(Q Con, Maybe String, [Maybe String])]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, String)]
src)) [Q DerivClause]
drv (String -> Maybe String
forall a. a -> Maybe a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure String
"SPDX License Identifiers included in @/usr/share/licenses/known_spdx_license_identifiers.txt@ of package <https://archlinux.org/packages/core/any/licenses/>.")
  where
    customCon :: (Q Con, Maybe a, [a])
customCon = (Name -> [Q BangType] -> Q Con
forall (m :: Type -> Type).
Quote m =>
Name -> [m BangType] -> m Con
normalC (String -> Name
mkName String
"Custom") [Q Bang -> Q Kind -> Q BangType
forall (m :: Type -> Type).
Quote m =>
m Bang -> m Kind -> m BangType
bangType (Q SourceUnpackedness -> Q SourceStrictness -> Q Bang
forall (m :: Type -> Type).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Bang
bang (SourceUnpackedness -> Q SourceUnpackedness
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure SourceUnpackedness
NoSourceUnpackedness) (SourceStrictness -> Q SourceStrictness
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure SourceStrictness
NoSourceStrictness)) [t|String|]], Maybe a
forall a. Maybe a
Nothing, [])
    genCon :: (String, String) -> (m Con, f String, [a])
genCon (String
from, String
to) = (Name -> [m BangType] -> m Con
forall (m :: Type -> Type).
Quote m =>
Name -> [m BangType] -> m Con
normalC (String -> Name
mkName String
to) [], String -> f String
forall a. a -> f a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (String -> f String) -> String -> f String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"@", String
from, String
"@"], [])
    drv :: [Q DerivClause]
drv = [Maybe DerivStrategy -> [Q Kind] -> Q DerivClause
forall (m :: Type -> Type).
Quote m =>
Maybe DerivStrategy -> [m Kind] -> m DerivClause
derivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure DerivStrategy
StockStrategy) [[t|Show|], [t|Eq|], [t|Ord|], [t|Generic|]]]

genParse :: [(String, String)] -> DecQ
genParse :: [(String, String)] -> DecQ
genParse [(String, String)]
src = Name -> [Q Clause] -> Maybe String -> [Maybe String] -> DecQ
funD_doc (String -> Name
mkName String
"parseLicense") (((String, String) -> Q Clause
forall {m :: Type -> Type}. Quote m => (String, String) -> m Clause
genClause ((String, String) -> Q Clause) -> [(String, String)] -> [Q Clause]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, String)]
src) [Q Clause] -> [Q Clause] -> [Q Clause]
forall a. Semigroup a => a -> a -> a
<> [Q Clause
custom]) (String -> Maybe String
forall a. a -> Maybe a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure String
"Parse a SPDX license identifier. If the identifier is not known, return 'Custom' with the original string.") []
  where
    custom :: Q Clause
custom = [Q Pat] -> Q Body -> [DecQ] -> Q Clause
forall (m :: Type -> Type).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"s")] (Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB [|Custom s|]) []
    genClause :: (String, String) -> m Clause
genClause (String
from, String
to) = [m Pat] -> m Body -> [m Dec] -> m Clause
forall (m :: Type -> Type).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Lit -> m Pat
forall (m :: Type -> Type). Quote m => Lit -> m Pat
litP (String -> Lit
StringL String
from)] (m Exp -> m Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB (m Exp -> m Body) -> m Exp -> m Body
forall a b. (a -> b) -> a -> b
$ Name -> m Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
conE (String -> Name
mkName String
to)) []

genId :: [(String, String)] -> DecQ
genId :: [(String, String)] -> DecQ
genId [(String, String)]
src = Name -> [Q Clause] -> Maybe String -> [Maybe String] -> DecQ
funD_doc (String -> Name
mkName String
"licenseId") (((String, String) -> Q Clause
forall {m :: Type -> Type}. Quote m => (String, String) -> m Clause
genClause ((String, String) -> Q Clause) -> [(String, String)] -> [Q Clause]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, String)]
src) [Q Clause] -> [Q Clause] -> [Q Clause]
forall a. Semigroup a => a -> a -> a
<> [Q Clause
custom]) (String -> Maybe String
forall a. a -> Maybe a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure String
"Get the SPDX license identifier. If the license is 'Custom', return the original string.") []
  where
    custom :: Q Clause
custom = [Q Pat] -> Q Body -> [DecQ] -> Q Clause
forall (m :: Type -> Type).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> [Q Pat] -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> [m Pat] -> m Pat
conP (String -> Name
mkName String
"Custom") [Name -> Q Pat
forall (m :: Type -> Type). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"s")]] (Q Exp -> Q Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB [|s|]) []
    genClause :: (String, String) -> m Clause
genClause (String
from, String
to) = [m Pat] -> m Body -> [m Dec] -> m Clause
forall (m :: Type -> Type).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> [m Pat] -> m Pat
forall (m :: Type -> Type). Quote m => Name -> [m Pat] -> m Pat
conP (String -> Name
mkName String
to) []] (m Exp -> m Body
forall (m :: Type -> Type). Quote m => m Exp -> m Body
normalB (m Exp -> m Body) -> m Exp -> m Body
forall a b. (a -> b) -> a -> b
$ Lit -> m Exp
forall (m :: Type -> Type). Quote m => Lit -> m Exp
litE (String -> Lit
StringL String
from)) []