{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Data.RDF.Vocabulary.Generator.VocabularyGenerator
  ( genVocabulary,
  )
where

import Data.Char (isLower)
import Data.List (nub)
import qualified Data.Map as M
import Data.Maybe (maybeToList)
import Data.RDF
  ( AdjHashMap,
    Node (UNode),
    PrefixMappings (PrefixMappings),
    RDF,
    Rdf,
    TurtleParser (TurtleParser),
    parseFile,
    prefixMappings,
    subjectOf,
    triplesOf,
  )
import Data.Text (Text)
import qualified Data.Text as T
import Language.Haskell.TH

-- | Generates 'Node' values for concepts and properties, and
-- 'Namespace' values, for a given schema in the Haskell module in
-- which 'genVocabulary' is used.
--
-- Concepts in the schema are prepended with "_", the names of
-- properties are unchanged.
--
-- For example:
--
-- >>> $(genVocabulary "resources/shacl.ttl")
--
-- creates many 'Node' values including
--
-- @
--     _SPARQLConstraint  :: Node
--     annotationProperty :: Node
-- @
--
-- This is used to auto-generate all modules in Data.RDF.Vocabulary.* at
-- compile time with Template Haskell.
genVocabulary ::
  -- | the filepath of the file containing the schema in RDF Turtle format.
  String ->
  Q [Dec]
genVocabulary :: String -> Q [Dec]
genVocabulary String
file = RDF AdjHashMap -> [Dec]
forall a. Rdf a => RDF a -> [Dec]
vocabulary (RDF AdjHashMap -> [Dec]) -> Q (RDF AdjHashMap) -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (RDF AdjHashMap) -> Q (RDF AdjHashMap)
forall a. IO a -> Q a
runIO (String -> IO (RDF AdjHashMap)
loadGraph String
file)

loadGraph :: String -> IO (RDF AdjHashMap)
loadGraph :: String -> IO (RDF AdjHashMap)
loadGraph String
file =
  TurtleParser -> String -> IO (Either ParseFailure (RDF AdjHashMap))
forall p a.
(RdfParser p, Rdf a) =>
p -> String -> IO (Either ParseFailure (RDF a))
parseFile (Maybe BaseUrl -> Maybe Text -> TurtleParser
TurtleParser Maybe BaseUrl
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) String
file IO (Either ParseFailure (RDF AdjHashMap))
-> (Either ParseFailure (RDF AdjHashMap) -> IO (RDF AdjHashMap))
-> IO (RDF AdjHashMap)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either ParseFailure (RDF AdjHashMap)
result -> case Either ParseFailure (RDF AdjHashMap)
result of
    Left ParseFailure
err -> String -> IO (RDF AdjHashMap)
forall a. HasCallStack => String -> a
error (String -> IO (RDF AdjHashMap)) -> String -> IO (RDF AdjHashMap)
forall a b. (a -> b) -> a -> b
$ ParseFailure -> String
forall a. Show a => a -> String
show ParseFailure
err
    Right RDF AdjHashMap
rdfGraph -> RDF AdjHashMap -> IO (RDF AdjHashMap)
forall (m :: * -> *) a. Monad m => a -> m a
return RDF AdjHashMap
rdfGraph

vocabulary :: Rdf a => RDF a -> [Dec]
vocabulary :: RDF a -> [Dec]
vocabulary RDF a
graph =
  let nameDecls :: [(Name, Dec)]
nameDecls = do
        Node
subject <- [Node] -> [Node]
forall a. Eq a => [a] -> [a]
nub ([Node] -> [Node]) -> [Node] -> [Node]
forall a b. (a -> b) -> a -> b
$ Triple -> Node
subjectOf (Triple -> Node) -> [Triple] -> [Node]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RDF a -> [Triple]
forall rdfImpl. Rdf rdfImpl => RDF rdfImpl -> [Triple]
triplesOf RDF a
graph
        Text
iri <- Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (Maybe Text -> [Text]) -> Maybe Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Node -> Maybe Text
toIRI Node
subject
        Name
name <- Maybe Name -> [Name]
forall a. Maybe a -> [a]
maybeToList (Maybe Name -> [Name]) -> Maybe Name -> [Name]
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Name
iriToName Text
iri
        (Name, Dec) -> [(Name, Dec)]
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
name, Name -> Text -> Dec
declareIRI Name
name Text
iri)
      (PrefixMappings Map Text Text
prefixMappings') = RDF a -> PrefixMappings
forall rdfImpl. Rdf rdfImpl => RDF rdfImpl -> PrefixMappings
prefixMappings RDF a
graph
      namespaceDecls :: [Dec]
namespaceDecls = do
        (Text
prefix, Text
iri) <- Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
M.toList Map Text Text
prefixMappings'
        let name :: Name
name = String -> Name
mkName (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escape (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"NS"
        Dec -> [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> [Dec]) -> Dec -> [Dec]
forall a b. (a -> b) -> a -> b
$ Name -> Text -> Text -> Dec
declarePrefix Name
name Text
prefix Text
iri
      iriDecls :: [Dec]
iriDecls = (Name, Dec) -> Dec
forall a b. (a, b) -> b
snd ((Name, Dec) -> Dec) -> [(Name, Dec)] -> [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Dec)]
nameDecls
      irisDecl :: Dec
irisDecl = [Name] -> Dec
declareIRIs ([Name] -> Dec) -> [Name] -> Dec
forall a b. (a -> b) -> a -> b
$ (Name, Dec) -> Name
forall a b. (a, b) -> a
fst ((Name, Dec) -> Name) -> [(Name, Dec)] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Dec)]
nameDecls
   in Dec
irisDecl Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
namespaceDecls [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
iriDecls

toIRI :: Node -> Maybe Text
toIRI :: Node -> Maybe Text
toIRI (UNode Text
iri) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
iri
toIRI Node
_ = Maybe Text
forall a. Maybe a
Nothing

packFun :: Exp
packFun :: Exp
packFun = Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Data.Text.pack"

unodeFun :: Exp
unodeFun :: Exp
unodeFun = Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Data.RDF.Types.unode"

mkPrefixedNSFun :: Exp
mkPrefixedNSFun :: Exp
mkPrefixedNSFun = Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Data.RDF.Namespace.mkPrefixedNS"

declareIRI :: Name -> Text -> Dec
declareIRI :: Name -> Text -> Dec
declareIRI Name
name Text
iri =
  let iriLiteral :: Exp
iriLiteral = Lit -> Exp
LitE (Lit -> Exp) -> (String -> Lit) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL (String -> Exp) -> String -> Exp
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
iri
      unodeLiteral :: Exp
unodeLiteral = Exp -> Exp -> Exp
AppE Exp
unodeFun (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
packFun Exp
iriLiteral
   in Name -> [Clause] -> Dec
FunD Name
name [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
unodeLiteral) []]

declareIRIs :: [Name] -> Dec
declareIRIs :: [Name] -> Dec
declareIRIs [Name]
names =
  let iriList :: Exp
iriList = [Exp] -> Exp
ListE (Name -> Exp
VarE (Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
names)
   in Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"iris") [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
iriList) []]

-- namespace = mkPrefixedNS "ogit" "http://www.purl.org/ogit/"
declarePrefix :: Name -> Text -> Text -> Dec
declarePrefix :: Name -> Text -> Text -> Dec
declarePrefix Name
name Text
prefix Text
iri =
  let prefixLiteral :: Exp
prefixLiteral = Exp -> Exp -> Exp
AppE Exp
packFun (Exp -> Exp) -> (Text -> Exp) -> Text -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Exp
LitE (Lit -> Exp) -> (Text -> Lit) -> Text -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL (String -> Lit) -> (Text -> String) -> Text -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Exp) -> Text -> Exp
forall a b. (a -> b) -> a -> b
$ Text
prefix
      iriLiteral :: Exp
iriLiteral = Exp -> Exp -> Exp
AppE Exp
packFun (Exp -> Exp) -> (Text -> Exp) -> Text -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Exp
LitE (Lit -> Exp) -> (Text -> Lit) -> Text -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL (String -> Lit) -> (Text -> String) -> Text -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Exp) -> Text -> Exp
forall a b. (a -> b) -> a -> b
$ Text
iri
      namespace :: Exp
namespace = Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE Exp
mkPrefixedNSFun Exp
prefixLiteral) Exp
iriLiteral
   in Name -> [Clause] -> Dec
FunD Name
name [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
namespace) []]

iriToName :: Text -> Maybe Name
iriToName :: Text -> Maybe Name
iriToName Text
iri = String -> Name
mkName (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escape (Text -> Name) -> Maybe Text -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Text] -> Maybe Text
forall a. [a] -> Maybe a
lastMay ([Text] -> Maybe Text) -> (Text -> [Text]) -> Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
separators)) Text
iri
  where
    separators :: String
separators = [Char
'/', Char
'#']
    lastMay :: [a] -> Maybe a
    lastMay :: [a] -> Maybe a
lastMay [] = Maybe a
forall a. Maybe a
Nothing
    lastMay [a]
xs = a -> Maybe a
forall a. a -> Maybe a
Just ([a] -> a
forall a. [a] -> a
last [a]
xs)

escape :: Text -> Text
escape :: Text -> Text
escape Text
name = Text -> Text
escapeKeywords (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> Text -> Text
T.map Char -> Char
escapeOperators Text
name
  where
    escapeOperators :: Char -> Char
escapeOperators Char
c | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
operators = Char
escapeChar
    escapeOperators Char
c = Char
c
    escapeKeywords :: Text -> Text
escapeKeywords Text
name' | Bool -> Bool
not (Char -> Bool
isLower (Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Char
T.head Text
name') = Char
escapeChar Char -> Text -> Text
`T.cons` Text
name'
    escapeKeywords Text
name' | Text
name' Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
keywords = Char
escapeChar Char -> Text -> Text
`T.cons` Text
name'
    escapeKeywords Text
name' = Text
name'
    operators :: String
operators = [Char
'!', Char
'#', Char
'$', Char
'%', Char
'&', Char
'*', Char
'+', Char
'.', Char
'/', Char
'<', Char
'=', Char
'>', Char
'?', Char
'@', Char
'\\', Char
'^', Char
'|', Char
'-', Char
'~']
    keywords :: [Text]
keywords =
      [ Text
"as",
        Text
"case",
        Text
"of",
        Text
"class",
        Text
"data",
        Text
"data family",
        Text
"data instance",
        Text
"default",
        Text
"deriving",
        Text
"deriving instance",
        Text
"do",
        Text
"forall",
        Text
"foreign",
        Text
"hiding",
        Text
"if",
        Text
"then",
        Text
"else",
        Text
"import",
        Text
"infix",
        Text
"infixl",
        Text
"infixr",
        Text
"instance",
        Text
"let",
        Text
"in",
        Text
"mdo",
        Text
"module",
        Text
"newtype",
        Text
"proc",
        Text
"qualified",
        Text
"rec",
        Text
"type",
        Text
"type family",
        Text
"type instance",
        Text
"where"
      ]
    escapeChar :: Char
escapeChar = Char
'_'