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
_ = []