module Language.PureScript.Docs.Convert.Single
( convertSingleModule
, convertComments
) where
import Protolude hiding (moduleName)
import Control.Category ((>>>))
import Data.Functor (($>))
import qualified Data.Text as T
import Language.PureScript.Docs.Types
import qualified Language.PureScript.AST as P
import qualified Language.PureScript.Comments as P
import qualified Language.PureScript.Crash as P
import qualified Language.PureScript.Names as P
import qualified Language.PureScript.Types as P
convertSingleModule :: P.Module -> Module
convertSingleModule m@(P.Module _ coms moduleName _ _) =
Module moduleName comments (declarations m) []
where
comments = convertComments coms
declarations =
P.exportedDeclarations
>>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d)
>>> augmentDeclarations
data AugmentType
= AugmentClass
| AugmentType
type IntermediateDeclaration
= Either ([(Text, AugmentType)], DeclarationAugment) Declaration
data DeclarationAugment
= AugmentChild ChildDeclaration
augmentDeclarations :: [IntermediateDeclaration] -> [Declaration]
augmentDeclarations (partitionEithers -> (augments, toplevels)) =
foldl' go toplevels augments
where
go ds (parentTitles, a) =
map (\d ->
if any (matches d) parentTitles
then augmentWith a d
else d) ds
matches d (name, AugmentType) = isType d && declTitle d == name
matches d (name, AugmentClass) = isTypeClass d && declTitle d == name
augmentWith (AugmentChild child) d =
d { declChildren = declChildren d ++ [child] }
getDeclarationTitle :: P.Declaration -> Maybe Text
getDeclarationTitle (P.ValueDeclaration vd) = Just (P.showIdent (P.valdeclIdent vd))
getDeclarationTitle (P.ExternDeclaration _ name _) = Just (P.showIdent name)
getDeclarationTitle (P.DataDeclaration _ _ name _ _) = Just (P.runProperName name)
getDeclarationTitle (P.ExternDataDeclaration _ name _) = Just (P.runProperName name)
getDeclarationTitle (P.ExternKindDeclaration _ name) = Just (P.runProperName name)
getDeclarationTitle (P.TypeSynonymDeclaration _ name _ _) = Just (P.runProperName name)
getDeclarationTitle (P.TypeClassDeclaration _ name _ _ _ _) = Just (P.runProperName name)
getDeclarationTitle (P.TypeInstanceDeclaration _ _ _ name _ _ _ _) = Just (P.showIdent name)
getDeclarationTitle (P.TypeFixityDeclaration _ _ _ op) = Just ("type " <> P.showOp op)
getDeclarationTitle (P.ValueFixityDeclaration _ _ _ op) = Just (P.showOp op)
getDeclarationTitle _ = Nothing
mkDeclaration :: P.SourceAnn -> Text -> DeclarationInfo -> Declaration
mkDeclaration (ss, com) title info =
Declaration { declTitle = title
, declComments = convertComments com
, declSourceSpan = Just ss
, declChildren = []
, declInfo = info
}
basicDeclaration :: P.SourceAnn -> Text -> DeclarationInfo -> Maybe IntermediateDeclaration
basicDeclaration sa title = Just . Right . mkDeclaration sa title
convertDeclaration :: P.Declaration -> Text -> Maybe IntermediateDeclaration
convertDeclaration (P.ValueDecl sa _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)]) title =
basicDeclaration sa title (ValueDeclaration (ty $> ()))
convertDeclaration (P.ValueDecl sa _ _ _ _) title =
basicDeclaration sa title (ValueDeclaration (P.TypeWildcard () Nothing))
convertDeclaration (P.ExternDeclaration sa _ ty) title =
basicDeclaration sa title (ValueDeclaration (ty $> ()))
convertDeclaration (P.DataDeclaration sa dtype _ args ctors) title =
Just (Right (mkDeclaration sa title info) { declChildren = children })
where
info = DataDeclaration dtype (fmap (fmap (fmap ($> ()))) args)
children = map convertCtor ctors
convertCtor :: (P.ProperName 'P.ConstructorName, [(P.Ident, P.SourceType)]) -> ChildDeclaration
convertCtor (ctor', tys) =
ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor (fmap (($> ()) . snd) tys))
convertDeclaration (P.ExternDataDeclaration sa _ kind') title =
basicDeclaration sa title (ExternDataDeclaration (kind' $> ()))
convertDeclaration (P.ExternKindDeclaration sa _) title =
basicDeclaration sa title ExternKindDeclaration
convertDeclaration (P.TypeSynonymDeclaration sa _ args ty) title =
basicDeclaration sa title (TypeSynonymDeclaration (fmap (fmap (fmap ($> ()))) args) (ty $> ()))
convertDeclaration (P.TypeClassDeclaration sa _ args implies fundeps ds) title =
Just (Right (mkDeclaration sa title info) { declChildren = children })
where
args' = fmap (fmap (fmap ($> ()))) args
info = TypeClassDeclaration args' (fmap ($> ()) implies) (convertFundepsToStrings args' fundeps)
children = map convertClassMember ds
convertClassMember (P.TypeDeclaration (P.TypeDeclarationData (ss, com) ident' ty)) =
ChildDeclaration (P.showIdent ident') (convertComments com) (Just ss) (ChildTypeClassMember (ty $> ()))
convertClassMember _ =
P.internalError "convertDeclaration: Invalid argument to convertClassMember."
convertDeclaration (P.TypeInstanceDeclaration (ss, com) _ _ _ constraints className tys _) title =
Just (Left ((classNameString, AugmentClass) : map (, AugmentType) typeNameStrings, AugmentChild childDecl))
where
classNameString = unQual className
typeNameStrings = ordNub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)
unQual x = let (P.Qualified _ y) = x in P.runProperName y
extractProperNames (P.TypeConstructor _ n) = [unQual n]
extractProperNames _ = []
childDecl = ChildDeclaration title (convertComments com) (Just ss) (ChildInstance (fmap ($> ()) constraints) (classApp $> ()))
classApp = foldl' P.srcTypeApp (P.srcTypeConstructor (fmap P.coerceProperName className)) tys
convertDeclaration (P.ValueFixityDeclaration sa fixity (P.Qualified mn alias) _) title =
Just . Right $ mkDeclaration sa title (AliasDeclaration fixity (P.Qualified mn (Right alias)))
convertDeclaration (P.TypeFixityDeclaration sa fixity (P.Qualified mn alias) _) title =
Just . Right $ mkDeclaration sa title (AliasDeclaration fixity (P.Qualified mn (Left alias)))
convertDeclaration _ _ = Nothing
convertComments :: [P.Comment] -> Maybe Text
convertComments cs = do
let raw = concatMap toLines cs
let docs = mapMaybe stripPipe raw
guard (not (null docs))
pure (T.unlines docs)
where
toLines (P.LineComment s) = [s]
toLines (P.BlockComment s) = T.lines s
stripPipe =
T.dropWhile (== ' ')
>>> T.stripPrefix "|"
>>> fmap (dropPrefix " ")
dropPrefix prefix str =
fromMaybe str (T.stripPrefix prefix str)