{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Unique Identifier used across Drasil.
module Drasil.Database.UID (
    UID
  , HasUID(uid)
  , mkUid, nsUid, (+++), (+++.), (+++!)
  , showUID
) where

import Data.Aeson
import Data.Aeson.Types
import Data.List (intercalate)
import Data.Text (pack)
import GHC.Generics

import Control.Lens (Getter, makeLenses, (^.), view, over)

-- | The most basic item: having a unique identifier key, a 'UID'.
class HasUID c where
  -- | The /unique/ id of the chunk (for internal Drasil use only).
  uid :: Getter c UID

-- | A @UID@ is a 'unique identifier' for things that we will put into our
-- database of information. We use a newtype wrapper to make sure we are only
-- using 'UID's where desired.
data UID = UID { UID -> [[Char]]
_namespace :: [String], UID -> [Char]
_baseName :: String }
  deriving (UID -> UID -> Bool
(UID -> UID -> Bool) -> (UID -> UID -> Bool) -> Eq UID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UID -> UID -> Bool
== :: UID -> UID -> Bool
$c/= :: UID -> UID -> Bool
/= :: UID -> UID -> Bool
Eq, Eq UID
Eq UID =>
(UID -> UID -> Ordering)
-> (UID -> UID -> Bool)
-> (UID -> UID -> Bool)
-> (UID -> UID -> Bool)
-> (UID -> UID -> Bool)
-> (UID -> UID -> UID)
-> (UID -> UID -> UID)
-> Ord UID
UID -> UID -> Bool
UID -> UID -> Ordering
UID -> UID -> UID
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: UID -> UID -> Ordering
compare :: UID -> UID -> Ordering
$c< :: UID -> UID -> Bool
< :: UID -> UID -> Bool
$c<= :: UID -> UID -> Bool
<= :: UID -> UID -> Bool
$c> :: UID -> UID -> Bool
> :: UID -> UID -> Bool
$c>= :: UID -> UID -> Bool
>= :: UID -> UID -> Bool
$cmax :: UID -> UID -> UID
max :: UID -> UID -> UID
$cmin :: UID -> UID -> UID
min :: UID -> UID -> UID
Ord, (forall x. UID -> Rep UID x)
-> (forall x. Rep UID x -> UID) -> Generic UID
forall x. Rep UID x -> UID
forall x. UID -> Rep UID x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. UID -> Rep UID x
from :: forall x. UID -> Rep UID x
$cto :: forall x. Rep UID x -> UID
to :: forall x. Rep UID x -> UID
Generic)

makeLenses ''UID

instance ToJSON UID where
  toJSON :: UID -> Value
toJSON = [Char] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Char] -> Value) -> (UID -> [Char]) -> UID -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UID -> [Char]
forall a. Show a => a -> [Char]
show

instance ToJSONKey UID where
  toJSONKey :: ToJSONKeyFunction UID
toJSONKey = (UID -> Text) -> ToJSONKeyFunction UID
forall a. (a -> Text) -> ToJSONKeyFunction a
toJSONKeyText ([Char] -> Text
pack ([Char] -> Text) -> (UID -> [Char]) -> UID -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UID -> [Char]
forall a. Show a => a -> [Char]
show)

instance Show UID where
  show :: UID -> [Char]
show UID
u = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
":" ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ UID
u UID -> Getting [[Char]] UID [[Char]] -> [[Char]]
forall s a. s -> Getting a s a -> a
^. Getting [[Char]] UID [[Char]]
Lens' UID [[Char]]
namespace [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [UID
u UID -> Getting [Char] UID [Char] -> [Char]
forall s a. s -> Getting a s a -> a
^. Getting [Char] UID [Char]
Lens' UID [Char]
baseName]

-- | Smart constructor for 'UID's from raw 'String's.
-- The raw string must not contain a colon (':'), as they are reserved
-- for displaying namespaced 'UID's (see 'nsUid').
mkUid :: String -> UID
mkUid :: [Char] -> UID
mkUid [Char]
s = if Char
':' Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
s
  then [Char] -> UID
forall a. HasCallStack => [Char] -> a
error ([Char] -> UID) -> [Char] -> UID
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid uid '" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
s [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"'. UIDs must not have colons."
  else UID { _namespace :: [[Char]]
_namespace = [], _baseName :: [Char]
_baseName = [Char]
s }

-- | Nest a 'UID' under a namespace.
nsUid :: String -> UID -> UID
nsUid :: [Char] -> UID -> UID
nsUid [Char]
ns = ASetter UID UID [[Char]] [[Char]]
-> ([[Char]] -> [[Char]]) -> UID -> UID
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter UID UID [[Char]] [[Char]]
Lens' UID [[Char]]
namespace ([[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
ns])

-- | Append a suffix to a thing with a 'UID' and get the resulting 'UID'.
(+++) :: HasUID a => a -> String -> UID
+++ :: forall a. HasUID a => a -> [Char] -> UID
(+++) a
a = UID -> [Char] -> UID
(+++.) (a
a a -> Getting UID a UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID a UID
forall c. HasUID c => Getter c UID
Getter a UID
uid)

-- | Append a suffix to a 'UID'.
(+++.) :: UID -> String -> UID
UID
a +++. :: UID -> [Char] -> UID
+++. [Char]
suff
  | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
suff       = [Char] -> UID
forall a. HasCallStack => [Char] -> a
error ([Char] -> UID) -> [Char] -> UID
forall a b. (a -> b) -> a -> b
$ [Char]
"Suffix must be non-zero length for UID " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> UID -> [Char]
forall a. Show a => a -> [Char]
show UID
a
  | Bool
otherwise       = ASetter UID UID [Char] [Char] -> ShowS -> UID -> UID
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter UID UID [Char] [Char]
Lens' UID [Char]
baseName ([Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
suff) UID
a

-- | Merge the 'UID's of two chunks through simple concatenation.
(+++!) :: (HasUID a, HasUID b) => a -> b -> UID
a
a +++! :: forall a b. (HasUID a, HasUID b) => a -> b -> UID
+++! b
b
  | UID
s UID -> Getting [[Char]] UID [[Char]] -> [[Char]]
forall s a. s -> Getting a s a -> a
^. Getting [[Char]] UID [[Char]]
Lens' UID [[Char]]
namespace [[Char]] -> [[Char]] -> Bool
forall a. Eq a => a -> a -> Bool
/= UID
t UID -> Getting [[Char]] UID [[Char]] -> [[Char]]
forall s a. s -> Getting a s a -> a
^. Getting [[Char]] UID [[Char]]
Lens' UID [[Char]]
namespace = [Char] -> UID
forall a. HasCallStack => [Char] -> a
error ([Char] -> UID) -> [Char] -> UID
forall a b. (a -> b) -> a -> b
$ UID -> [Char]
forall a. Show a => a -> [Char]
show UID
s [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" and " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> UID -> [Char]
forall a. Show a => a -> [Char]
show UID
t [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" are not in the same namespace"
  | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (UID
s UID -> Getting [Char] UID [Char] -> [Char]
forall s a. s -> Getting a s a -> a
^. Getting [Char] UID [Char]
Lens' UID [Char]
baseName) Bool -> Bool -> Bool
|| [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (UID
t UID -> Getting [Char] UID [Char] -> [Char]
forall s a. s -> Getting a s a -> a
^. Getting [Char] UID [Char]
Lens' UID [Char]
baseName) = [Char] -> UID
forall a. HasCallStack => [Char] -> a
error ([Char] -> UID) -> [Char] -> UID
forall a b. (a -> b) -> a -> b
$ UID -> [Char]
forall a. Show a => a -> [Char]
show UID
s [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" and " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> UID -> [Char]
forall a. Show a => a -> [Char]
show UID
t [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" UIDs must be non-zero length"
  | Bool
otherwise = UID
s UID -> [Char] -> UID
+++. (UID
t UID -> Getting [Char] UID [Char] -> [Char]
forall s a. s -> Getting a s a -> a
^. Getting [Char] UID [Char]
Lens' UID [Char]
baseName)
  where
    s :: UID
s = a
a a -> Getting UID a UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID a UID
forall c. HasUID c => Getter c UID
Getter a UID
uid
    t :: UID
t = b
b b -> Getting UID b UID -> UID
forall s a. s -> Getting a s a -> a
^. Getting UID b UID
forall c. HasUID c => Getter c UID
Getter b UID
uid

-- | Get something's 'UID' as a 'String'.
showUID :: HasUID a => a -> String
showUID :: forall a. HasUID a => a -> [Char]
showUID = UID -> [Char]
forall a. Show a => a -> [Char]
show (UID -> [Char]) -> (a -> UID) -> a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting UID a UID -> a -> UID
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting UID a UID
forall c. HasUID c => Getter c UID
Getter a UID
uid