-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript.Hierarchy
-- Copyright   :  (c) Hardy Jones 2014
-- License     :  MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer  :  Hardy Jones <jones3.hardy@gmail.com>
-- Stability   :  experimental
-- Portability :
--
-- |
-- Generate Directed Graphs of PureScript TypeClasses
--
-----------------------------------------------------------------------------

module Language.PureScript.Hierarchy where

import Prelude
import Protolude (ordNub)

import Data.List (sort)
import Data.Text qualified as T
import Language.PureScript qualified as P

newtype SuperMap = SuperMap
  { SuperMap
-> Either
     (ProperName 'ClassName)
     (ProperName 'ClassName, ProperName 'ClassName)
_unSuperMap :: Either (P.ProperName 'P.ClassName) (P.ProperName 'P.ClassName, P.ProperName 'P.ClassName)
  }
  deriving SuperMap -> SuperMap -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SuperMap -> SuperMap -> Bool
$c/= :: SuperMap -> SuperMap -> Bool
== :: SuperMap -> SuperMap -> Bool
$c== :: SuperMap -> SuperMap -> Bool
Eq

instance Ord SuperMap where
  compare :: SuperMap -> SuperMap -> Ordering
compare (SuperMap Either
  (ProperName 'ClassName)
  (ProperName 'ClassName, ProperName 'ClassName)
s) (SuperMap Either
  (ProperName 'ClassName)
  (ProperName 'ClassName, ProperName 'ClassName)
s') = forall {c} {a}. Either c (a, c) -> c
getCls Either
  (ProperName 'ClassName)
  (ProperName 'ClassName, ProperName 'ClassName)
s forall a. Ord a => a -> a -> Ordering
`compare` forall {c} {a}. Either c (a, c) -> c
getCls Either
  (ProperName 'ClassName)
  (ProperName 'ClassName, ProperName 'ClassName)
s'
    where
      getCls :: Either c (a, c) -> c
getCls = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id forall a b. (a, b) -> b
snd

data Graph = Graph
  { Graph -> GraphName
graphName :: GraphName
  , Graph -> Digraph
digraph :: Digraph
  }
  deriving (Graph -> Graph -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Graph -> Graph -> Bool
$c/= :: Graph -> Graph -> Bool
== :: Graph -> Graph -> Bool
$c== :: Graph -> Graph -> Bool
Eq, Int -> Graph -> ShowS
[Graph] -> ShowS
Graph -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Graph] -> ShowS
$cshowList :: [Graph] -> ShowS
show :: Graph -> String
$cshow :: Graph -> String
showsPrec :: Int -> Graph -> ShowS
$cshowsPrec :: Int -> Graph -> ShowS
Show)

newtype GraphName = GraphName
  { GraphName -> Text
_unGraphName :: T.Text
  }
  deriving (GraphName -> GraphName -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GraphName -> GraphName -> Bool
$c/= :: GraphName -> GraphName -> Bool
== :: GraphName -> GraphName -> Bool
$c== :: GraphName -> GraphName -> Bool
Eq, Int -> GraphName -> ShowS
[GraphName] -> ShowS
GraphName -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GraphName] -> ShowS
$cshowList :: [GraphName] -> ShowS
show :: GraphName -> String
$cshow :: GraphName -> String
showsPrec :: Int -> GraphName -> ShowS
$cshowsPrec :: Int -> GraphName -> ShowS
Show)

newtype Digraph = Digraph
  { Digraph -> Text
_unDigraph :: T.Text
  }
  deriving (Digraph -> Digraph -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Digraph -> Digraph -> Bool
$c/= :: Digraph -> Digraph -> Bool
== :: Digraph -> Digraph -> Bool
$c== :: Digraph -> Digraph -> Bool
Eq, Int -> Digraph -> ShowS
[Digraph] -> ShowS
Digraph -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Digraph] -> ShowS
$cshowList :: [Digraph] -> ShowS
show :: Digraph -> String
$cshow :: Digraph -> String
showsPrec :: Int -> Digraph -> ShowS
$cshowsPrec :: Int -> Digraph -> ShowS
Show)

prettyPrint :: SuperMap -> T.Text
prettyPrint :: SuperMap -> Text
prettyPrint (SuperMap (Left ProperName 'ClassName
sub)) = Text
"  " forall a. Semigroup a => a -> a -> a
<> forall (a :: ProperNameType). ProperName a -> Text
P.runProperName ProperName 'ClassName
sub forall a. Semigroup a => a -> a -> a
<> Text
";"
prettyPrint (SuperMap (Right (ProperName 'ClassName
super, ProperName 'ClassName
sub))) =
  Text
"  " forall a. Semigroup a => a -> a -> a
<> forall (a :: ProperNameType). ProperName a -> Text
P.runProperName ProperName 'ClassName
super forall a. Semigroup a => a -> a -> a
<> Text
" -> " forall a. Semigroup a => a -> a -> a
<> forall (a :: ProperNameType). ProperName a -> Text
P.runProperName ProperName 'ClassName
sub forall a. Semigroup a => a -> a -> a
<> Text
";"

runModuleName :: P.ModuleName -> GraphName
runModuleName :: ModuleName -> GraphName
runModuleName (P.ModuleName Text
name) =
  Text -> GraphName
GraphName forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
T.replace Text
"." Text
"_" Text
name

typeClasses :: Functor f => f P.Module -> f (Maybe Graph)
typeClasses :: forall (f :: * -> *). Functor f => f Module -> f (Maybe Graph)
typeClasses =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Module -> Maybe Graph
typeClassGraph

typeClassGraph :: P.Module -> Maybe Graph
typeClassGraph :: Module -> Maybe Graph
typeClassGraph (P.Module SourceSpan
_ [Comment]
_ ModuleName
moduleName [Declaration]
decls Maybe [DeclarationRef]
_) =
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SuperMap]
supers then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (GraphName -> Digraph -> Graph
Graph GraphName
name Digraph
graph)
    where
      name :: GraphName
name = ModuleName -> GraphName
runModuleName ModuleName
moduleName
      supers :: [SuperMap]
supers = forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
ordNub forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [SuperMap]
superClasses [Declaration]
decls
      graph :: Digraph
graph = Text -> Digraph
Digraph forall a b. (a -> b) -> a -> b
$ GraphName -> Text
typeClassPrologue GraphName
name forall a. Semigroup a => a -> a -> a
<> [SuperMap] -> Text
typeClassBody [SuperMap]
supers forall a. Semigroup a => a -> a -> a
<> Text
typeClassEpilogue

typeClassPrologue :: GraphName -> T.Text
typeClassPrologue :: GraphName -> Text
typeClassPrologue (GraphName Text
name) = Text
"digraph " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" {\n"

typeClassBody :: [SuperMap] -> T.Text
typeClassBody :: [SuperMap] -> Text
typeClassBody [SuperMap]
supers = Text -> [Text] -> Text
T.intercalate Text
"\n" (SuperMap -> Text
prettyPrint forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SuperMap]
supers)

typeClassEpilogue :: T.Text
typeClassEpilogue :: Text
typeClassEpilogue = Text
"\n}"

superClasses :: P.Declaration -> [SuperMap]
superClasses :: Declaration -> [SuperMap]
superClasses (P.TypeClassDeclaration SourceAnn
_ ProperName 'ClassName
sub [(Text, Maybe SourceType)]
_ supers :: [SourceConstraint]
supers@(SourceConstraint
_:[SourceConstraint]
_) [FunctionalDependency]
_ [Declaration]
_) =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(P.Constraint SourceAnn
_ (P.Qualified QualifiedBy
_ ProperName 'ClassName
super) [SourceType]
_ [SourceType]
_ Maybe ConstraintData
_) -> Either
  (ProperName 'ClassName)
  (ProperName 'ClassName, ProperName 'ClassName)
-> SuperMap
SuperMap (forall a b. b -> Either a b
Right (ProperName 'ClassName
super, ProperName 'ClassName
sub))) [SourceConstraint]
supers
superClasses (P.TypeClassDeclaration SourceAnn
_ ProperName 'ClassName
sub [(Text, Maybe SourceType)]
_ [SourceConstraint]
_ [FunctionalDependency]
_ [Declaration]
_) = [Either
  (ProperName 'ClassName)
  (ProperName 'ClassName, ProperName 'ClassName)
-> SuperMap
SuperMap (forall a b. a -> Either a b
Left ProperName 'ClassName
sub)]
superClasses Declaration
_ = []