-- | This module provides types and functions for PostgreSQL's @ltree@ https://www.postgresql.org/docs/current/ltree.html
--
-- You will want to use a specific implementation, e.g. @postgresql-simple-ltree@.
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module Database.PostgreSQL.LTree
  ( LTree(..)
  , Label(unLabel)
  , map
  , fromList
  , toList
  , rootLabel
  , parentLabel
  , parent
  , numLabels
  , mkLabel
  , unsafeMkLabel
  , uuidToLabel
  , empty
  , null
  , singleton
  , snoc
  , render
  , unsafeUncheckedParse
  , parse
  , isImmediateParentOf
  , isImmediateChildOf
  , parseUUIDFromLabel
  , allLabelsUnique
  ) where

import Prelude hiding (map, null)

import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON))
import Data.Coerce (coerce)
import Data.Sequence (Seq((:<|), (:|>)), (|>))
import Data.Text (Text)
import Data.UUID (UUID)

import qualified Data.Attoparsec.Text as Atto
import qualified Data.Foldable as Foldable
import qualified Data.List as List
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.UUID as UUID

-- | Wrapper for Postgres' @ltree@ (label tree) type.
newtype LTree = LTree { LTree -> Seq Label
unLTree :: Seq Label }
  deriving newtype (Int -> LTree -> ShowS
[LTree] -> ShowS
LTree -> String
(Int -> LTree -> ShowS)
-> (LTree -> String) -> ([LTree] -> ShowS) -> Show LTree
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LTree] -> ShowS
$cshowList :: [LTree] -> ShowS
show :: LTree -> String
$cshow :: LTree -> String
showsPrec :: Int -> LTree -> ShowS
$cshowsPrec :: Int -> LTree -> ShowS
Show, LTree -> LTree -> Bool
(LTree -> LTree -> Bool) -> (LTree -> LTree -> Bool) -> Eq LTree
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LTree -> LTree -> Bool
$c/= :: LTree -> LTree -> Bool
== :: LTree -> LTree -> Bool
$c== :: LTree -> LTree -> Bool
Eq, Eq LTree
Eq LTree
-> (LTree -> LTree -> Ordering)
-> (LTree -> LTree -> Bool)
-> (LTree -> LTree -> Bool)
-> (LTree -> LTree -> Bool)
-> (LTree -> LTree -> Bool)
-> (LTree -> LTree -> LTree)
-> (LTree -> LTree -> LTree)
-> Ord LTree
LTree -> LTree -> Bool
LTree -> LTree -> Ordering
LTree -> LTree -> LTree
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
min :: LTree -> LTree -> LTree
$cmin :: LTree -> LTree -> LTree
max :: LTree -> LTree -> LTree
$cmax :: LTree -> LTree -> LTree
>= :: LTree -> LTree -> Bool
$c>= :: LTree -> LTree -> Bool
> :: LTree -> LTree -> Bool
$c> :: LTree -> LTree -> Bool
<= :: LTree -> LTree -> Bool
$c<= :: LTree -> LTree -> Bool
< :: LTree -> LTree -> Bool
$c< :: LTree -> LTree -> Bool
compare :: LTree -> LTree -> Ordering
$ccompare :: LTree -> LTree -> Ordering
$cp1Ord :: Eq LTree
Ord)

-- | Wrapper for a single label in an @ltree@.
-- The constructor IS NOT exported to ensure we only construct valid
-- labels. See 'mkLabel' for constructing a 'Label'.
newtype Label = Label { Label -> Text
unLabel :: Text }
  deriving newtype (Int -> Label -> ShowS
[Label] -> ShowS
Label -> String
(Int -> Label -> ShowS)
-> (Label -> String) -> ([Label] -> ShowS) -> Show Label
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Label] -> ShowS
$cshowList :: [Label] -> ShowS
show :: Label -> String
$cshow :: Label -> String
showsPrec :: Int -> Label -> ShowS
$cshowsPrec :: Int -> Label -> ShowS
Show, Label -> Label -> Bool
(Label -> Label -> Bool) -> (Label -> Label -> Bool) -> Eq Label
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Label -> Label -> Bool
$c/= :: Label -> Label -> Bool
== :: Label -> Label -> Bool
$c== :: Label -> Label -> Bool
Eq, Eq Label
Eq Label
-> (Label -> Label -> Ordering)
-> (Label -> Label -> Bool)
-> (Label -> Label -> Bool)
-> (Label -> Label -> Bool)
-> (Label -> Label -> Bool)
-> (Label -> Label -> Label)
-> (Label -> Label -> Label)
-> Ord Label
Label -> Label -> Bool
Label -> Label -> Ordering
Label -> Label -> Label
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
min :: Label -> Label -> Label
$cmin :: Label -> Label -> Label
max :: Label -> Label -> Label
$cmax :: Label -> Label -> Label
>= :: Label -> Label -> Bool
$c>= :: Label -> Label -> Bool
> :: Label -> Label -> Bool
$c> :: Label -> Label -> Bool
<= :: Label -> Label -> Bool
$c<= :: Label -> Label -> Bool
< :: Label -> Label -> Bool
$c< :: Label -> Label -> Bool
compare :: Label -> Label -> Ordering
$ccompare :: Label -> Label -> Ordering
$cp1Ord :: Eq Label
Ord)

-- | Produce a new 'LTree' by applying the supplied function to each 'Label'.
map :: (Label -> Label) -> LTree -> LTree
map :: (Label -> Label) -> LTree -> LTree
map Label -> Label
f = Seq Label -> LTree
LTree (Seq Label -> LTree) -> (LTree -> Seq Label) -> LTree -> LTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Label -> Label) -> Seq Label -> Seq Label
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Label -> Label
f (Seq Label -> Seq Label)
-> (LTree -> Seq Label) -> LTree -> Seq Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LTree -> Seq Label
unLTree

-- | Convert a list to an 'LTree'.
fromList :: [Label] -> LTree
fromList :: [Label] -> LTree
fromList = Seq Label -> LTree
LTree (Seq Label -> LTree) -> ([Label] -> Seq Label) -> [Label] -> LTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Label] -> Seq Label
forall a. [a] -> Seq a
Seq.fromList

-- | Convert an 'LTree' to a list.
toList :: LTree -> [Label]
toList :: LTree -> [Label]
toList = Seq Label -> [Label]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList (Seq Label -> [Label]) -> (LTree -> Seq Label) -> LTree -> [Label]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LTree -> Seq Label
unLTree

-- | Get the first 'Label' from an 'LTree' if one exists.
rootLabel :: LTree -> Maybe Label
rootLabel :: LTree -> Maybe Label
rootLabel (LTree (Label
x :<| Seq Label
_)) = Label -> Maybe Label
forall a. a -> Maybe a
Just Label
x
rootLabel LTree
_ = Maybe Label
forall a. Maybe a
Nothing

-- | Get the second-to-last 'Label' in an 'LTree'.
parentLabel :: LTree -> Maybe Label
parentLabel :: LTree -> Maybe Label
parentLabel (LTree Seq Label
x) = Int -> Seq Label -> Maybe Label
forall a. Int -> Seq a -> Maybe a
Seq.lookup (Seq Label -> Int
forall a. Seq a -> Int
Seq.length Seq Label
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Seq Label
x

-- | Get the parent path of an 'LTree'.
parent :: LTree -> Maybe LTree
parent :: LTree -> Maybe LTree
parent (LTree (Seq Label
xs :|> Label
_)) = LTree -> Maybe LTree
forall a. a -> Maybe a
Just (LTree -> Maybe LTree) -> LTree -> Maybe LTree
forall a b. (a -> b) -> a -> b
$ Seq Label -> LTree
LTree Seq Label
xs
parent LTree
_ = Maybe LTree
forall a. Maybe a
Nothing

-- | Get the length of an 'LTree'.
numLabels :: LTree -> Int
numLabels :: LTree -> Int
numLabels (LTree Seq Label
x) = Seq Label -> Int
forall a. Seq a -> Int
Seq.length Seq Label
x

-- | Safely construct a 'Label' from 'Text'. If the supplied 'Text'
-- contains characters unsupported by @ltree@. On failure, returns 'Left'
-- with an error message.
mkLabel :: Text -> Either String Label
mkLabel :: Text -> Either String Label
mkLabel Text
t =
  if Text -> Bool
Text.null Text
t then
    String -> Either String Label
forall a b. a -> Either a b
Left String
"ltree label must be non-empty"
  else if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null String
invalidChars then
    Label -> Either String Label
forall a b. b -> Either a b
Right (Label -> Either String Label) -> Label -> Either String Label
forall a b. (a -> b) -> a -> b
$ Text -> Label
Label Text
t
  else
    String -> Either String Label
forall a b. a -> Either a b
Left (String -> Either String Label) -> String -> Either String Label
forall a b. (a -> b) -> a -> b
$ String
"Invalid ltree label chars found: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a. Show a => a -> String
show String
invalidChars
  where
  invalidChars :: String
invalidChars = ShowS
forall a. Eq a => [a] -> [a]
List.nub ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
Text.filter (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isValidLabelChar) Text
t

-- | Same as 'mkLabel' except throws an error for an invalid 'Text' input.
unsafeMkLabel :: Text -> Label
unsafeMkLabel :: Text -> Label
unsafeMkLabel = (String -> Label)
-> (Label -> Label) -> Either String Label -> Label
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Label
forall a. HasCallStack => String -> a
error Label -> Label
forall a. a -> a
id (Either String Label -> Label)
-> (Text -> Either String Label) -> Text -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String Label
mkLabel

-- | A 'UUID' can always be converted into a 'Label' without error by
-- dropping the hyphens. The resulting 'Label' will only contain
-- numbers and lower-case alpha characters.
uuidToLabel :: UUID -> Label
uuidToLabel :: UUID -> Label
uuidToLabel = Text -> Label
Label (Text -> Label) -> (UUID -> Text) -> UUID -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
Text.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') (Text -> Text) -> (UUID -> Text) -> UUID -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> Text
UUID.toText

-- | Predicate for which characters are supported by @ltree@.
isValidLabelChar :: Char -> Bool
isValidLabelChar :: Char -> Bool
isValidLabelChar = (Char -> Set Char -> Bool) -> Set Char -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> Set Char -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Set Char
valid
  where
  valid :: Set Char
valid = [Set Char] -> Set Char
forall a. Monoid a => [a] -> a
mconcat
    [ Char -> Set Char
forall a. a -> Set a
Set.singleton Char
'_'
    , String -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList [Char
'0'..Char
'9']
    , String -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList [Char
'A'..Char
'Z']
    , String -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList [Char
'a'..Char
'z']
    ]

-- | An empty 'LTree'.
empty :: LTree
empty :: LTree
empty = Seq Label -> LTree
LTree Seq Label
forall a. Monoid a => a
mempty

-- | Test whether an 'LTree' is empty.
null :: LTree -> Bool
null :: LTree -> Bool
null = Seq Label -> Bool
forall a. Seq a -> Bool
Seq.null (Seq Label -> Bool) -> (LTree -> Seq Label) -> LTree -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LTree -> Seq Label
unLTree

-- | Construct an 'LTree' from a single 'Label'.
singleton :: Label -> LTree
singleton :: Label -> LTree
singleton = Seq Label -> LTree
LTree (Seq Label -> LTree) -> (Label -> Seq Label) -> Label -> LTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> Seq Label
forall a. a -> Seq a
Seq.singleton

-- | Append a single 'Label' to the end of an 'LTree'; should be O(1)
-- since it's delegating to 'Data.Sequence.|>'
snoc :: LTree -> Label -> LTree
snoc :: LTree -> Label -> LTree
snoc (LTree Seq Label
xs) Label
x = Seq Label -> LTree
LTree (Seq Label
xs Seq Label -> Label -> Seq Label
forall a. Seq a -> a -> Seq a
|> Label
x)

-- | Render an @ltree@ as it would appear in the database.
render :: LTree -> Text
render :: LTree -> Text
render = Text -> [Text] -> Text
Text.intercalate Text
"." ([Text] -> Text) -> (LTree -> [Text]) -> LTree -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Label] -> [Text]
coerce ([Label] -> [Text]) -> (LTree -> [Label]) -> LTree -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LTree -> [Label]
toList

-- | Unsafely parse an 'LTree' from 'Text' assuming each 'Label'
-- is valid. Use this only if you sure the input is a valid 'LTree';
-- e.g. it was fetched from a field the database of type @ltree@.
unsafeUncheckedParse :: Text -> LTree
unsafeUncheckedParse :: Text -> LTree
unsafeUncheckedParse = [Label] -> LTree
fromList ([Label] -> LTree) -> (Text -> [Label]) -> Text -> LTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Label]
coerce ([Text] -> [Label]) -> (Text -> [Text]) -> Text -> [Label]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
Text.splitOn Text
"."

-- | Parse an 'LTree' from 'Text'. If any 'Label' present is invalid,
-- returns 'Left'.
parse :: Text -> Either String LTree
parse :: Text -> Either String LTree
parse = ([Label] -> LTree) -> Either String [Label] -> Either String LTree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Label] -> LTree
fromList (Either String [Label] -> Either String LTree)
-> (Text -> Either String [Label]) -> Text -> Either String LTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Either String Label) -> [Text] -> Either String [Label]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> Either String Label
mkLabel ([Text] -> Either String [Label])
-> (Text -> [Text]) -> Text -> Either String [Label]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
Text.splitOn Text
"."

-- | Test whether the first 'LTree' is an immediate parent of the second;
-- e.g. @a.b@ is an immediate parent of @a.b.c@
isImmediateParentOf :: LTree -> LTree -> Bool
isImmediateParentOf :: LTree -> LTree -> Bool
isImmediateParentOf (LTree Seq Label
xs) (LTree (Seq Label
ys :|> Label
_)) | Seq Label
xs Seq Label -> Seq Label -> Bool
forall a. Eq a => a -> a -> Bool
== Seq Label
ys = Bool
True
isImmediateParentOf LTree
_ LTree
_ = Bool
False

-- | Test whether the first 'LTree' is an immediate child of the second;
-- e.g. @a.b.c@ is an immediate child of @a.b@
isImmediateChildOf :: LTree -> LTree -> Bool
isImmediateChildOf :: LTree -> LTree -> Bool
isImmediateChildOf = (LTree -> LTree -> Bool) -> LTree -> LTree -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip LTree -> LTree -> Bool
isImmediateParentOf

-- | Attempt to parse a 'UUID' from a 'Label'.
parseUUIDFromLabel :: Label -> Either String UUID
parseUUIDFromLabel :: Label -> Either String UUID
parseUUIDFromLabel (Label Text
t) =
  Parser UUID -> Text -> Either String UUID
forall a. Parser a -> Text -> Either String a
Atto.parseOnly Parser UUID
p Text
t
  where
  p :: Parser UUID
p = do
    Text
a <- Int -> Parser Text
Atto.take Int
8
    Text
b <- Int -> Parser Text
Atto.take Int
4
    Text
c <- Int -> Parser Text
Atto.take Int
4
    Text
d <- Int -> Parser Text
Atto.take Int
4
    Text
e <- Int -> Parser Text
Atto.take Int
12
    Parser Text ()
forall t. Chunk t => Parser t ()
Atto.endOfInput
    Parser UUID -> (UUID -> Parser UUID) -> Maybe UUID -> Parser UUID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (String -> Parser UUID
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Label is not a valid UUID")
      UUID -> Parser UUID
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Text -> Maybe UUID
UUID.fromText (Text -> Maybe UUID) -> Text -> Maybe UUID
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
Text.intercalate Text
"-" [Text
a, Text
b, Text
c, Text
d, Text
e])

-- | Test whether all labels in the 'LTree' are unique.
allLabelsUnique :: LTree -> Bool
allLabelsUnique :: LTree -> Bool
allLabelsUnique (LTree Seq Label
xs) = Seq Label -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq Label
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Set Label -> Int
forall a. Set a -> Int
Set.size (Set Label -> Int) -> (Seq Label -> Set Label) -> Seq Label -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Label] -> Set Label
forall a. Ord a => [a] -> Set a
Set.fromList ([Label] -> Set Label)
-> (Seq Label -> [Label]) -> Seq Label -> Set Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Label -> [Label]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList (Seq Label -> Int) -> Seq Label -> Int
forall a b. (a -> b) -> a -> b
$ Seq Label
xs)

instance FromJSON Label where
  parseJSON :: Value -> Parser Label
parseJSON Value
v = do
    Text
text <- Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
    (String -> Parser Label)
-> (Label -> Parser Label) -> Either String Label -> Parser Label
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser Label
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Label -> Parser Label
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Label -> Parser Label)
-> Either String Label -> Parser Label
forall a b. (a -> b) -> a -> b
$ Text -> Either String Label
mkLabel Text
text

instance ToJSON Label where
  toJSON :: Label -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (Label -> Text) -> Label -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> Text
unLabel

instance FromJSON LTree where
  parseJSON :: Value -> Parser LTree
parseJSON Value
v = do
    Text
text <- Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
    (String -> Parser LTree)
-> (LTree -> Parser LTree) -> Either String LTree -> Parser LTree
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser LTree
forall (m :: * -> *) a. MonadFail m => String -> m a
fail LTree -> Parser LTree
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String LTree -> Parser LTree)
-> Either String LTree -> Parser LTree
forall a b. (a -> b) -> a -> b
$ Text -> Either String LTree
parse Text
text

instance ToJSON LTree where
  toJSON :: LTree -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (LTree -> Text) -> LTree -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LTree -> Text
render