{-| Helper module: export a schema as DOT (Graphviz-style graphs). Useful for
debugging and documenting a schema; not the primary API for database work through
@pg-schema@.

It is exposed as a small utility; it could be made non-public in a future release.
Avoid depending on it in compatibility-sensitive code unless you really need graph output.
-}
module PgSchema.Utils.GenDot where

import Data.Foldable as F
import Data.List as L
import Data.Map as M
import Data.Singletons
import Data.Text as T

import PgSchema.Schema


data DotOper
  = ExcludeToTab NameNS Text
  -- ^ Exclude relation to given table from DOT representation.

genDot :: forall sch. CSchema sch
  => Bool -- ^ Whether to use qualified names
  -> [DotOper] -- ^ Operations to exclude relations from DOT representation
  -> Text
genDot :: forall {k} (sch :: k). CSchema sch => Bool -> [DotOper] -> Text
genDot Bool
isQual [DotOper]
dos = [Text] -> Text
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold
  [ Text
"digraph G {\n"
  , Text
"  penwidth=2\n\n"
  , [Text] -> Text
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold [Text]
dbSchemas
  , Text
""
  , [Text] -> Text
T.unlines [Text]
relTxts
  , Text
"}\n"
  ]
  where
    tabs :: Demote [NameNSK]
tabs = forall (a :: [NameNSK]).
(SingKind [NameNSK], SingI a) =>
Demote [NameNSK]
forall {k} (a :: k). (SingKind k, SingI a) => Demote k
demote @(TTabs sch)
    tim :: Map NameNS TabInfo
tim = forall (sch :: k). CSchema sch => Map NameNS TabInfo
forall {k} (sch :: k). CSchema sch => Map NameNS TabInfo
tabInfoMap @sch
    rels :: [RelDef]
rels = (Map NameNS RelDef -> [RelDef]) -> [Map NameNS RelDef] -> [RelDef]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
L.concatMap Map NameNS RelDef -> [RelDef]
forall k a. Map k a -> [a]
elems ([Map NameNS RelDef] -> [RelDef])
-> (Map NameNS (Map NameNS RelDef) -> [Map NameNS RelDef])
-> Map NameNS (Map NameNS RelDef)
-> [RelDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map NameNS (Map NameNS RelDef) -> [Map NameNS RelDef]
forall k a. Map k a -> [a]
elems (Map NameNS (Map NameNS RelDef) -> [RelDef])
-> Map NameNS (Map NameNS RelDef) -> [RelDef]
forall a b. (a -> b) -> a -> b
$ TabInfo -> Map NameNS RelDef
tiFrom (TabInfo -> Map NameNS RelDef)
-> Map NameNS TabInfo -> Map NameNS (Map NameNS RelDef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map NameNS TabInfo
tim
    tabsByName :: Map Text [Text]
tabsByName = ([Text] -> [Text] -> [Text]) -> [(Text, [Text])] -> Map Text [Text]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
(<>)
      ([(Text, [Text])] -> Map Text [Text])
-> [(Text, [Text])] -> Map Text [Text]
forall a b. (a -> b) -> a -> b
$ ((,) (Text -> [Text] -> (Text, [Text]))
-> (NameNS -> Text) -> NameNS -> [Text] -> (Text, [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameNS -> Text
forall s. NameNS' s -> s
nnsName (NameNS -> [Text] -> (Text, [Text]))
-> (NameNS -> [Text]) -> NameNS -> (Text, [Text])
forall a b. (NameNS -> a -> b) -> (NameNS -> a) -> NameNS -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> [Text]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Text]) -> (NameNS -> Text) -> NameNS -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameNS -> Text
forall s. NameNS' s -> s
nnsNamespace) (NameNS -> (Text, [Text])) -> [NameNS] -> [(Text, [Text])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NameNS]
Demote [NameNSK]
tabs
    qName :: NameNS -> (Text, Bool)
qName NameNS
nns
      | Bool
isQual    = (Text, Bool)
q
      | Bool
otherwise = case Text -> Map Text [Text] -> Maybe [Text]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (NameNS -> Text
forall s. NameNS' s -> s
nnsName NameNS
nns) Map Text [Text]
tabsByName of
        Just [Text
_] -> (NameNS -> Text
forall s. NameNS' s -> s
nnsName NameNS
nns,Bool
False)
        Maybe [Text]
_        -> (Text, Bool)
q
      where
        q :: (Text, Bool)
q = (NameNS -> Text
qualName NameNS
nns,Bool
True)
    qNameQuo :: NameNS -> Text
qNameQuo NameNS
nns = case NameNS -> (Text, Bool)
qName NameNS
nns of
      (Text
x,Bool
False) -> Text
x
      (Text
x,Bool
True)  -> Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
    qName' :: NameNS -> Text
qName' NameNS
nns = case [Text]
exTo of
      [] -> Text
nns'
      [Text]
_  -> Text
nns' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [label=\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text, Bool) -> Text
forall a b. (a, b) -> a
fst (NameNS -> (Text, Bool)
qName NameNS
nns) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords [Text]
exTo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"]"
      where
        nns' :: Text
nns' = NameNS -> Text
qNameQuo NameNS
nns
        exTo :: [Text]
exTo = [Text
t | ExcludeToTab NameNS
x Text
t <- [DotOper]
dos, RelDef {[(Text, Text)]
NameNS
rdFrom :: NameNS
rdTo :: NameNS
rdCols :: [(Text, Text)]
rdCols :: forall s. RelDef' s -> [(s, s)]
rdTo :: forall s. RelDef' s -> NameNS' s
rdFrom :: forall s. RelDef' s -> NameNS' s
..} <- [RelDef]
rels
          , NameNS
rdTo NameNS -> NameNS -> Bool
forall a. Eq a => a -> a -> Bool
== NameNS
x, NameNS
rdFrom NameNS -> NameNS -> Bool
forall a. Eq a => a -> a -> Bool
== NameNS
nns]
    dbSchemas :: [Text]
dbSchemas = Text -> Text
dbSchema (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub (NameNS -> Text
forall s. NameNS' s -> s
nnsNamespace (NameNS -> Text) -> [NameNS] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NameNS]
Demote [NameNSK]
tabs)
    dbSchema :: Text -> Text
dbSchema Text
schName = [Text] -> Text
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold
      [ Text
"  subgraph cluster_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
schName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"{\n"
      , Text
"    label=\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
schName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"\n"
      , [Text] -> Text
T.unlines
        ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (NameNS -> Text) -> NameNS -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameNS -> Text
qName' (NameNS -> Text) -> [NameNS] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NameNS -> Bool) -> [NameNS] -> [NameNS]
forall a. (a -> Bool) -> [a] -> [a]
L.filter ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==Text
schName) (Text -> Bool) -> (NameNS -> Text) -> NameNS -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameNS -> Text
forall s. NameNS' s -> s
nnsNamespace) [NameNS]
Demote [NameNSK]
tabs
      , Text
"  }\n"
      ]
    relTxts :: [Text]
relTxts = RelDef -> Text
rel (RelDef -> Text) -> [RelDef] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RelDef -> Bool) -> [RelDef] -> [RelDef]
forall a. (a -> Bool) -> [a] -> [a]
L.filter RelDef -> Bool
notExcluded [RelDef]
rels
      where
        notExcluded :: RelDef -> Bool
notExcluded RelDef{[(Text, Text)]
NameNS
rdCols :: forall s. RelDef' s -> [(s, s)]
rdTo :: forall s. RelDef' s -> NameNS' s
rdFrom :: forall s. RelDef' s -> NameNS' s
rdFrom :: NameNS
rdTo :: NameNS
rdCols :: [(Text, Text)]
..} = [()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [()|ExcludeToTab NameNS
x Text
_ <- [DotOper]
dos, NameNS
rdTo NameNS -> NameNS -> Bool
forall a. Eq a => a -> a -> Bool
==NameNS
x]
    rel :: RelDef -> Text
rel RelDef {[(Text, Text)]
NameNS
rdCols :: forall s. RelDef' s -> [(s, s)]
rdTo :: forall s. RelDef' s -> NameNS' s
rdFrom :: forall s. RelDef' s -> NameNS' s
rdFrom :: NameNS
rdTo :: NameNS
rdCols :: [(Text, Text)]
..} = Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NameNS -> Text
qNameQuo NameNS
rdFrom Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"->" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NameNS -> Text
qNameQuo NameNS
rdTo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
clr
      where
        clr :: Text
clr = case Maybe (Map Text FldDef)
mbTabFlds Maybe (Map Text FldDef)
-> (Map Text FldDef -> Maybe Bool) -> Maybe Bool
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Map Text FldDef -> Maybe Bool
isNullableRef of
          Just Bool
True -> Text
"[color=\"green\"]"
          Maybe Bool
_         -> Text
""
          where
            mbTabFlds :: Maybe (Map Text FldDef)
mbTabFlds = TabInfo -> Map Text FldDef
tiFlds (TabInfo -> Map Text FldDef)
-> Maybe TabInfo -> Maybe (Map Text FldDef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameNS -> Map NameNS TabInfo -> Maybe TabInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup NameNS
rdFrom Map NameNS TabInfo
tim
            isNullableRef :: Map Text FldDef -> Maybe Bool
isNullableRef Map Text FldDef
tabFlds = (FldDef -> Bool) -> [FldDef] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
L.any FldDef -> Bool
forall s. FldDef' s -> Bool
fdNullable
              ([FldDef] -> Bool) -> Maybe [FldDef] -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Text, Text) -> Maybe FldDef) -> [(Text, Text)] -> Maybe [FldDef]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Text -> Map Text FldDef -> Maybe FldDef
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map Text FldDef
tabFlds) (Text -> Maybe FldDef)
-> ((Text, Text) -> Text) -> (Text, Text) -> Maybe FldDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> a
fst) [(Text, Text)]
rdCols