module Language.PureScript.Interactive.Printer where

import Prelude

import Data.List (intersperse)
import Data.Map qualified as M
import Data.Maybe (mapMaybe)
import Data.Text qualified as T
import Data.Text (Text)
import Language.PureScript qualified as P
import Text.PrettyPrint.Boxes qualified as Box

-- TODO (Christoph): Text version of boxes
textT :: Text -> Box.Box
textT :: Text -> Box
textT = String -> Box
Box.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

-- Printers

-- |
-- Pretty print a module's signatures
--
printModuleSignatures :: P.ModuleName -> P.Environment -> String
printModuleSignatures :: ModuleName -> Environment -> String
printModuleSignatures ModuleName
moduleName P.Environment{Map
  (Qualified (ProperName 'TypeName))
  ([(Text, Maybe SourceType)], SourceType)
Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
Map
  (Qualified (ProperName 'ConstructorName))
  (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
Map (Qualified (ProperName 'ClassName)) TypeClassData
Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
typeClasses :: Environment
-> Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClassDictionaries :: Environment
-> Map
     QualifiedBy
     (Map
        (Qualified (ProperName 'ClassName))
        (Map (Qualified Ident) (NonEmpty NamedDict)))
typeSynonyms :: Environment
-> Map
     (Qualified (ProperName 'TypeName))
     ([(Text, Maybe SourceType)], SourceType)
dataConstructors :: Environment
-> Map
     (Qualified (ProperName 'ConstructorName))
     (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
types :: Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
names :: Environment
-> Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
typeClasses :: Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClassDictionaries :: Map
  QualifiedBy
  (Map
     (Qualified (ProperName 'ClassName))
     (Map (Qualified Ident) (NonEmpty NamedDict)))
typeSynonyms :: Map
  (Qualified (ProperName 'TypeName))
  ([(Text, Maybe SourceType)], SourceType)
dataConstructors :: Map
  (Qualified (ProperName 'ConstructorName))
  (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
types :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
names :: Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
..} =
    -- get relevant components of a module from environment
    let moduleNamesIdent :: [Qualified Ident]
moduleNamesIdent = forall a b. Map (Qualified a) b -> [Qualified a]
byModuleName Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names
        moduleTypeClasses :: [Qualified (ProperName 'ClassName)]
moduleTypeClasses = forall a b. Map (Qualified a) b -> [Qualified a]
byModuleName Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses
        moduleTypes :: [Qualified (ProperName 'TypeName)]
moduleTypes = forall a b. Map (Qualified a) b -> [Qualified a]
byModuleName Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types

        byModuleName :: M.Map (P.Qualified a) b -> [P.Qualified a]
        byModuleName :: forall a b. Map (Qualified a) b -> [Qualified a]
byModuleName = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ModuleName
moduleName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Qualified a -> Maybe ModuleName
P.getQual) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [k]
M.keys

  in
    -- print each component
    ([String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map String -> String
trimEnd forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. Box -> String
Box.render forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.vsep Int
1 Alignment
Box.left)
      [ forall {f :: * -> *} {a}. Foldable f => (a -> f Box) -> a -> Box
printModule's (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Qualified (ProperName 'ClassName), Maybe TypeClassData)
-> Maybe Box
showTypeClass forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (Qualified (ProperName 'ClassName)) TypeClassData
-> Qualified (ProperName 'ClassName)
-> (Qualified (ProperName 'ClassName), Maybe TypeClassData)
findTypeClass Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses)) [Qualified (ProperName 'ClassName)]
moduleTypeClasses -- typeClasses
      , forall {f :: * -> *} {a}. Foldable f => (a -> f Box) -> a -> Box
printModule's (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Map (Qualified (ProperName 'ClassName)) TypeClassData
-> Map
     (Qualified (ProperName 'ConstructorName))
     (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
-> Map
     (Qualified (ProperName 'TypeName))
     ([(Text, Maybe SourceType)], SourceType)
-> (Qualified (ProperName 'TypeName), Maybe (SourceType, TypeKind))
-> Maybe Box
showType Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClasses Map
  (Qualified (ProperName 'ConstructorName))
  (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
dataConstructors Map
  (Qualified (ProperName 'TypeName))
  ([(Text, Maybe SourceType)], SourceType)
typeSynonyms forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
-> Qualified (ProperName 'TypeName)
-> (Qualified (ProperName 'TypeName), Maybe (SourceType, TypeKind))
findType Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
types)) [Qualified (ProperName 'TypeName)]
moduleTypes -- types
      , forall {f :: * -> *} {a}. Foldable f => (a -> f Box) -> a -> Box
printModule's (forall a b. (a -> b) -> [a] -> [b]
map ((Ident, Maybe (SourceType, NameKind, NameVisibility)) -> Box
showNameType forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
-> Qualified Ident
-> (Ident, Maybe (SourceType, NameKind, NameVisibility))
findNameType Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
names)) [Qualified Ident]
moduleNamesIdent -- functions
      ]

  where printModule's :: (a -> f Box) -> a -> Box
printModule's a -> f Box
showF = forall (f :: * -> *).
Foldable f =>
Int -> Alignment -> f Box -> Box
Box.vsep Int
1 Alignment
Box.left forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f Box
showF

        findNameType :: M.Map (P.Qualified P.Ident) (P.SourceType, P.NameKind, P.NameVisibility)
                     -> P.Qualified P.Ident
                     -> (P.Ident, Maybe (P.SourceType, P.NameKind, P.NameVisibility))
        findNameType :: Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
-> Qualified Ident
-> (Ident, Maybe (SourceType, NameKind, NameVisibility))
findNameType Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
envNames Qualified Ident
m = (forall a. Qualified a -> a
P.disqualify Qualified Ident
m, forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified Ident
m Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
envNames)

        showNameType :: (P.Ident, Maybe (P.SourceType, P.NameKind, P.NameVisibility)) -> Box.Box
        showNameType :: (Ident, Maybe (SourceType, NameKind, NameVisibility)) -> Box
showNameType (Ident
mIdent, Just (SourceType
mType, NameKind
_, NameVisibility
_)) = Text -> Box
textT (Ident -> Text
P.showIdent Ident
mIdent forall a. Semigroup a => a -> a -> a
<> Text
" :: ") Box -> Box -> Box
Box.<> forall a. Int -> Type a -> Box
P.typeAsBox forall a. Bounded a => a
maxBound SourceType
mType
        showNameType (Ident, Maybe (SourceType, NameKind, NameVisibility))
_ = forall a. HasCallStack => String -> a
P.internalError String
"The impossible happened in printModuleSignatures."

        findTypeClass
          :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) P.TypeClassData
          -> P.Qualified (P.ProperName 'P.ClassName)
          -> (P.Qualified (P.ProperName 'P.ClassName), Maybe P.TypeClassData)
        findTypeClass :: Map (Qualified (ProperName 'ClassName)) TypeClassData
-> Qualified (ProperName 'ClassName)
-> (Qualified (ProperName 'ClassName), Maybe TypeClassData)
findTypeClass Map (Qualified (ProperName 'ClassName)) TypeClassData
envTypeClasses Qualified (ProperName 'ClassName)
name = (Qualified (ProperName 'ClassName)
name, forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified (ProperName 'ClassName)
name Map (Qualified (ProperName 'ClassName)) TypeClassData
envTypeClasses)

        showTypeClass
          :: (P.Qualified (P.ProperName 'P.ClassName), Maybe P.TypeClassData)
          -> Maybe Box.Box
        showTypeClass :: (Qualified (ProperName 'ClassName), Maybe TypeClassData)
-> Maybe Box
showTypeClass (Qualified (ProperName 'ClassName)
_, Maybe TypeClassData
Nothing) = forall a. Maybe a
Nothing
        showTypeClass (P.Qualified QualifiedBy
_ ProperName 'ClassName
name, Just P.TypeClassData{Bool
[(Text, Maybe SourceType)]
[(Ident, SourceType)]
[SourceConstraint]
[FunctionalDependency]
Set Int
Set (Set Int)
typeClassIsEmpty :: TypeClassData -> Bool
typeClassCoveringSets :: TypeClassData -> Set (Set Int)
typeClassDeterminedArguments :: TypeClassData -> Set Int
typeClassDependencies :: TypeClassData -> [FunctionalDependency]
typeClassSuperclasses :: TypeClassData -> [SourceConstraint]
typeClassMembers :: TypeClassData -> [(Ident, SourceType)]
typeClassArguments :: TypeClassData -> [(Text, Maybe SourceType)]
typeClassIsEmpty :: Bool
typeClassCoveringSets :: Set (Set Int)
typeClassDeterminedArguments :: Set Int
typeClassDependencies :: [FunctionalDependency]
typeClassSuperclasses :: [SourceConstraint]
typeClassMembers :: [(Ident, SourceType)]
typeClassArguments :: [(Text, Maybe SourceType)]
..}) =
            let constraints :: Box
constraints =
                    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SourceConstraint]
typeClassSuperclasses
                    then String -> Box
Box.text String
""
                    else String -> Box
Box.text String
"("
                         Box -> Box -> Box
Box.<> forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.hcat Alignment
Box.left (forall a. a -> [a] -> [a]
intersperse (String -> Box
Box.text String
", ") forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(P.Constraint SourceAnn
_ (P.Qualified QualifiedBy
_ ProperName 'ClassName
pn) [SourceType]
_ [SourceType]
lt Maybe ConstraintData
_) -> Text -> Box
textT (forall (a :: ProperNameType). ProperName a -> Text
P.runProperName ProperName 'ClassName
pn) Box -> Box -> Box
Box.<+> forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.hcat Alignment
Box.left (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> Type a -> Box
P.typeAtomAsBox forall a. Bounded a => a
maxBound) [SourceType]
lt)) [SourceConstraint]
typeClassSuperclasses)
                         Box -> Box -> Box
Box.<> String -> Box
Box.text String
") <= "
                className :: Box
className =
                    Text -> Box
textT (forall (a :: ProperNameType). ProperName a -> Text
P.runProperName ProperName 'ClassName
name)
                    Box -> Box -> Box
Box.<> Text -> Box
textT (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Text
" " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Text, Maybe SourceType)]
typeClassArguments)
                classBody :: Box
classBody =
                    forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.top (forall a b. (a -> b) -> [a] -> [b]
map (\(Ident
i, SourceType
t) -> Text -> Box
textT (Ident -> Text
P.showIdent Ident
i forall a. Semigroup a => a -> a -> a
<> Text
" ::") Box -> Box -> Box
Box.<+> forall a. Int -> Type a -> Box
P.typeAsBox forall a. Bounded a => a
maxBound SourceType
t) [(Ident, SourceType)]
typeClassMembers)

            in
              forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                (String -> Box
Box.text String
"class "
                Box -> Box -> Box
Box.<> Box
constraints
                Box -> Box -> Box
Box.<> Box
className
                Box -> Box -> Box
Box.<+> if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Ident, SourceType)]
typeClassMembers then String -> Box
Box.text String
"" else String -> Box
Box.text String
"where")
                Box -> Box -> Box
Box.// Int -> Box -> Box
Box.moveRight Int
2 Box
classBody


        findType
          :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.SourceType, P.TypeKind)
          -> P.Qualified (P.ProperName 'P.TypeName)
          -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.SourceType, P.TypeKind))
        findType :: Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
-> Qualified (ProperName 'TypeName)
-> (Qualified (ProperName 'TypeName), Maybe (SourceType, TypeKind))
findType Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
envTypes Qualified (ProperName 'TypeName)
name = (Qualified (ProperName 'TypeName)
name, forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified (ProperName 'TypeName)
name Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
envTypes)

        showType
          :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) P.TypeClassData
          -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident])
          -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(Text, Maybe P.SourceType)], P.SourceType)
          -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.SourceType, P.TypeKind))
          -> Maybe Box.Box
        showType :: Map (Qualified (ProperName 'ClassName)) TypeClassData
-> Map
     (Qualified (ProperName 'ConstructorName))
     (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
-> Map
     (Qualified (ProperName 'TypeName))
     ([(Text, Maybe SourceType)], SourceType)
-> (Qualified (ProperName 'TypeName), Maybe (SourceType, TypeKind))
-> Maybe Box
showType Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClassesEnv Map
  (Qualified (ProperName 'ConstructorName))
  (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
dataConstructorsEnv Map
  (Qualified (ProperName 'TypeName))
  ([(Text, Maybe SourceType)], SourceType)
typeSynonymsEnv (n :: Qualified (ProperName 'TypeName)
n@(P.Qualified QualifiedBy
modul ProperName 'TypeName
name), Maybe (SourceType, TypeKind)
typ) =
          case (Maybe (SourceType, TypeKind)
typ, forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Qualified (ProperName 'TypeName)
n Map
  (Qualified (ProperName 'TypeName))
  ([(Text, Maybe SourceType)], SourceType)
typeSynonymsEnv) of
            (Just (SourceType
_, TypeKind
P.TypeSynonym), Just ([(Text, Maybe SourceType)]
typevars, SourceType
dtType)) ->
                if forall k a. Ord k => k -> Map k a -> Bool
M.member (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
P.coerceProperName Qualified (ProperName 'TypeName)
n) Map (Qualified (ProperName 'ClassName)) TypeClassData
typeClassesEnv
                then
                  forall a. Maybe a
Nothing
                else
                  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                    Text -> Box
textT (Text
"type " forall a. Semigroup a => a -> a -> a
<> forall (a :: ProperNameType). ProperName a -> Text
P.runProperName ProperName 'TypeName
name forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Text
" " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Text, Maybe SourceType)]
typevars)
                    Box -> Box -> Box
Box.// Int -> Box -> Box
Box.moveRight Int
2 (String -> Box
Box.text String
"=" Box -> Box -> Box
Box.<+> forall a. Int -> Type a -> Box
P.typeAsBox forall a. Bounded a => a
maxBound SourceType
dtType)

            (Just (SourceType
_, P.DataType DataDeclType
_ [(Text, Maybe SourceType, Role)]
typevars [(ProperName 'ConstructorName, [SourceType])]
pt), Maybe ([(Text, Maybe SourceType)], SourceType)
_) ->
              let prefix :: Text
prefix =
                    case [(ProperName 'ConstructorName, [SourceType])]
pt of
                      [(ProperName 'ConstructorName
dtProperName,[SourceType]
_)] ->
                        case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall a. QualifiedBy -> a -> Qualified a
P.Qualified QualifiedBy
modul ProperName 'ConstructorName
dtProperName) Map
  (Qualified (ProperName 'ConstructorName))
  (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
dataConstructorsEnv of
                          Just (DataDeclType
dataDeclType, ProperName 'TypeName
_, SourceType
_, [Ident]
_) -> DataDeclType -> Text
P.showDataDeclType DataDeclType
dataDeclType
                          Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
_ -> Text
"data"
                      [(ProperName 'ConstructorName, [SourceType])]
_ -> Text
"data"

              in
                forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Box
textT (Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall (a :: ProperNameType). ProperName a -> Text
P.runProperName ProperName 'TypeName
name forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Text
" " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(Text
v, Maybe SourceType
_, Role
_) -> Text
v)) [(Text, Maybe SourceType, Role)]
typevars) Box -> Box -> Box
Box.// forall {a :: ProperNameType} {a}. [(ProperName a, [Type a])] -> Box
printCons [(ProperName 'ConstructorName, [SourceType])]
pt

            (Maybe (SourceType, TypeKind),
 Maybe ([(Text, Maybe SourceType)], SourceType))
_ ->
              forall a. Maybe a
Nothing

          where printCons :: [(ProperName a, [Type a])] -> Box
printCons [(ProperName a, [Type a])]
pt =
                    Int -> Box -> Box
Box.moveRight Int
2 forall a b. (a -> b) -> a -> b
$
                    forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.left forall a b. (a -> b) -> a -> b
$
                    forall {a} {a}. (a -> a) -> (a -> a) -> [a] -> [a]
mapFirstRest (String -> Box
Box.text String
"=" Box -> Box -> Box
Box.<+>) (String -> Box
Box.text String
"|" Box -> Box -> Box
Box.<+>) forall a b. (a -> b) -> a -> b
$
                    forall a b. (a -> b) -> [a] -> [b]
map (\(ProperName a
cons,[Type a]
idents) -> Text -> Box
textT (forall (a :: ProperNameType). ProperName a -> Text
P.runProperName ProperName a
cons) Box -> Box -> Box
Box.<> forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.hcat Alignment
Box.left (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Type a -> Box
prettyPrintType [Type a]
idents)) [(ProperName a, [Type a])]
pt

                prettyPrintType :: Type a -> Box
prettyPrintType Type a
t = String -> Box
Box.text String
" " Box -> Box -> Box
Box.<> forall a. Int -> Type a -> Box
P.typeAtomAsBox forall a. Bounded a => a
maxBound Type a
t

                mapFirstRest :: (a -> a) -> (a -> a) -> [a] -> [a]
mapFirstRest a -> a
_ a -> a
_ [] = []
                mapFirstRest a -> a
f a -> a
g (a
x:[a]
xs) = a -> a
f a
x forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map a -> a
g [a]
xs

        trimEnd :: String -> String
trimEnd = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
' ') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse