module Language.PureScript.Docs.Convert
( convertModule
, collectBookmarks
) where
import Control.Monad
import Control.Category ((>>>))
import Data.Either
import Data.Maybe (mapMaybe, isNothing)
import Data.List (nub, isPrefixOf, isSuffixOf)
import qualified Language.PureScript as P
import Language.PureScript.Docs.Types
convertModule :: P.Module -> Module
convertModule m@(P.Module coms moduleName _ _) =
Module (show moduleName) comments (declarations m)
where
comments = convertComments coms
declarations =
P.exportedDeclarations
>>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d)
>>> augmentDeclarations
>>> map addDefaultFixity
type IntermediateDeclaration
= Either ([String], DeclarationAugment) Declaration
data DeclarationAugment
= AugmentChild ChildDeclaration
| AugmentFixity P.Fixity
augmentDeclarations :: [IntermediateDeclaration] -> [Declaration]
augmentDeclarations (partitionEithers -> (augments, toplevels)) =
foldl go toplevels augments
where
go ds (parentTitles, a) =
map (\d ->
if declTitle d `elem` parentTitles
then augmentWith a d
else d) ds
augmentWith a d =
case a of
AugmentChild child ->
d { declChildren = declChildren d ++ [child] }
AugmentFixity fixity ->
d { declFixity = Just fixity }
addDefaultFixity :: Declaration -> Declaration
addDefaultFixity decl@Declaration{..}
| isOp declTitle && isNothing declFixity =
decl { declFixity = Just defaultFixity }
| otherwise =
decl
where
isOp :: String -> Bool
isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str
defaultFixity = P.Fixity P.Infixl (1)
getDeclarationTitle :: P.Declaration -> Maybe String
getDeclarationTitle (P.TypeDeclaration name _) = Just (show name)
getDeclarationTitle (P.ExternDeclaration name _) = Just (show name)
getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (show name)
getDeclarationTitle (P.ExternDataDeclaration name _) = Just (show name)
getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (show name)
getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (show name)
getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (show name)
getDeclarationTitle (P.FixityDeclaration _ name) = Just ("(" ++ name ++ ")")
getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d
getDeclarationTitle _ = Nothing
mkDeclaration :: String -> DeclarationInfo -> Declaration
mkDeclaration title info =
Declaration { declTitle = title
, declComments = Nothing
, declSourceSpan = Nothing
, declChildren = []
, declFixity = Nothing
, declInfo = info
}
basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration
basicDeclaration title info = Just $ Right $ mkDeclaration title info
convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration
convertDeclaration (P.TypeDeclaration _ ty) title =
basicDeclaration title (ValueDeclaration ty)
convertDeclaration (P.ExternDeclaration _ ty) title =
basicDeclaration title (ValueDeclaration ty)
convertDeclaration (P.DataDeclaration dtype _ args ctors) title =
Just (Right (mkDeclaration title info) { declChildren = children })
where
info = DataDeclaration dtype args
children = map convertCtor ctors
convertCtor (ctor', tys) =
ChildDeclaration (show ctor') Nothing Nothing (ChildDataConstructor tys)
convertDeclaration (P.ExternDataDeclaration _ kind') title =
basicDeclaration title (ExternDataDeclaration kind')
convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =
basicDeclaration title (TypeSynonymDeclaration args ty)
convertDeclaration (P.TypeClassDeclaration _ args implies ds) title = do
Just (Right (mkDeclaration title info) { declChildren = children })
where
info = TypeClassDeclaration args implies
children = map convertClassMember ds
convertClassMember (P.PositionedDeclaration _ _ d) =
convertClassMember d
convertClassMember (P.TypeDeclaration ident' ty) =
ChildDeclaration (show ident') Nothing Nothing (ChildTypeClassMember ty)
convertClassMember _ =
error "Invalid argument to convertClassMember."
convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title = do
Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))
where
classNameString = unQual className
typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)
unQual x = let (P.Qualified _ y) = x in show y
extractProperNames (P.TypeConstructor n) = [unQual n]
extractProperNames (P.SaturatedTypeSynonym n _) = [unQual n]
extractProperNames _ = []
childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)
classApp = foldl P.TypeApp (P.TypeConstructor className) tys
convertDeclaration (P.FixityDeclaration fixity _) title =
Just (Left ([title], AugmentFixity fixity))
convertDeclaration (P.PositionedDeclaration srcSpan com d') title =
fmap (addComments . addSourceSpan) (convertDeclaration d' title)
where
addComments (Right d) =
Right (d { declComments = convertComments com })
addComments (Left augment) =
Left (withAugmentChild (\d -> d { cdeclComments = convertComments com })
augment)
addSourceSpan (Right d) =
Right (d { declSourceSpan = Just srcSpan })
addSourceSpan (Left augment) =
Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan })
augment)
withAugmentChild f (t, a) =
case a of
AugmentChild d -> (t, AugmentChild (f d))
_ -> (t, a)
convertDeclaration _ _ = Nothing
convertComments :: [P.Comment] -> Maybe String
convertComments cs = do
let raw = concatMap toLines cs
guard (all hasPipe raw && not (null raw))
return (go raw)
where
go = unlines . map stripPipes
toLines (P.LineComment s) = [s]
toLines (P.BlockComment s) = lines s
hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }
stripPipes = dropPipe . dropWhile (== ' ')
dropPipe ('|':' ':s) = s
dropPipe ('|':s) = s
dropPipe s = s
collectBookmarks :: InPackage P.Module -> [Bookmark]
collectBookmarks (Local m) = map Local (collectBookmarks' m)
collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)
collectBookmarks' :: P.Module -> [(P.ModuleName, String)]
collectBookmarks' m =
map (P.getModuleName m, )
(mapMaybe getDeclarationTitle
(P.exportedDeclarations m))