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
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
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)
..} =
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
([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
, 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
, 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
]
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