module Language.PureScript.Docs.AsMarkdown
  ( Docs
  , runDocs
  , moduleAsMarkdown
  , codeToString
  ) where

import Prelude

import Control.Monad (unless, zipWithM_)
import Control.Monad.Writer (Writer, tell, execWriter)

import Data.Foldable (for_)
import Data.List (partition)
import Data.Text (Text)
import qualified Data.Text as T

import Language.PureScript.Docs.RenderedCode
import Language.PureScript.Docs.Types
import qualified Language.PureScript as P
import qualified Language.PureScript.Docs.Render as Render

moduleAsMarkdown :: Module -> Docs
moduleAsMarkdown :: Module -> Docs
moduleAsMarkdown Module{[(InPackage ModuleName, [Declaration])]
[Declaration]
Maybe Text
ModuleName
modReExports :: Module -> [(InPackage ModuleName, [Declaration])]
modDeclarations :: Module -> [Declaration]
modComments :: Module -> Maybe Text
modName :: Module -> ModuleName
modReExports :: [(InPackage ModuleName, [Declaration])]
modDeclarations :: [Declaration]
modComments :: Maybe Text
modName :: ModuleName
..} = do
  Int -> Text -> Docs
headerLevel Int
2 forall a b. (a -> b) -> a -> b
$ Text
"Module " forall a. Semigroup a => a -> a -> a
<> ModuleName -> Text
P.runModuleName ModuleName
modName
  Docs
spacer
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Text
modComments Text -> Docs
tell'
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Declaration -> Docs
declAsMarkdown [Declaration]
modDeclarations
  Docs
spacer
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(InPackage ModuleName, [Declaration])]
modReExports forall a b. (a -> b) -> a -> b
$ \(InPackage ModuleName
mn', [Declaration]
decls) -> do
    let mn :: ModuleName
mn = forall a. InPackage a -> a
ignorePackage InPackage ModuleName
mn'
    Int -> Text -> Docs
headerLevel Int
3 forall a b. (a -> b) -> a -> b
$ Text
"Re-exported from " forall a. Semigroup a => a -> a -> a
<> ModuleName -> Text
P.runModuleName ModuleName
mn forall a. Semigroup a => a -> a -> a
<> Text
":"
    Docs
spacer
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Declaration -> Docs
declAsMarkdown [Declaration]
decls

declAsMarkdown :: Declaration -> Docs
declAsMarkdown :: Declaration -> Docs
declAsMarkdown decl :: Declaration
decl@Declaration{[ChildDeclaration]
Maybe Text
Maybe SourceSpan
Maybe KindInfo
Text
DeclarationInfo
declKind :: Declaration -> Maybe KindInfo
declInfo :: Declaration -> DeclarationInfo
declChildren :: Declaration -> [ChildDeclaration]
declSourceSpan :: Declaration -> Maybe SourceSpan
declComments :: Declaration -> Maybe Text
declTitle :: Declaration -> Text
declKind :: Maybe KindInfo
declInfo :: DeclarationInfo
declChildren :: [ChildDeclaration]
declSourceSpan :: Maybe SourceSpan
declComments :: Maybe Text
declTitle :: Text
..} = do
  Int -> Text -> Docs
headerLevel Int
4 (Text -> Text
ticks Text
declTitle)
  Docs
spacer

  let ([ChildDeclaration]
instances, [ChildDeclaration]
children) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (ChildDeclarationInfo -> Bool
isChildInstance forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChildDeclaration -> ChildDeclarationInfo
cdeclInfo) [ChildDeclaration]
declChildren
  Docs -> Docs
fencedBlock forall a b. (a -> b) -> a -> b
$ do
    Text -> Docs
tell' (RenderedCode -> Text
codeToString forall a b. (a -> b) -> a -> b
$ Declaration -> RenderedCode
Render.renderDeclaration Declaration
decl)
    forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (\First
f ChildDeclaration
c -> Text -> Docs
tell' (First -> ChildDeclaration -> Text
childToString First
f ChildDeclaration
c)) (First
First forall a. a -> [a] -> [a]
: forall a. a -> [a]
repeat First
NotFirst) [ChildDeclaration]
children
  Docs
spacer

  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Text
declComments Text -> Docs
tell'

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ChildDeclaration]
instances) forall a b. (a -> b) -> a -> b
$ do
    Int -> Text -> Docs
headerLevel Int
5 Text
"Instances"
    Docs -> Docs
fencedBlock forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> Docs
tell' forall b c a. (b -> c) -> (a -> b) -> a -> c
. First -> ChildDeclaration -> Text
childToString First
NotFirst) [ChildDeclaration]
instances
    Docs
spacer

  where
  isChildInstance :: ChildDeclarationInfo -> Bool
isChildInstance (ChildInstance [Constraint']
_ Type'
_) = Bool
True
  isChildInstance ChildDeclarationInfo
_ = Bool
False

codeToString :: RenderedCode -> Text
codeToString :: RenderedCode -> Text
codeToString = forall a.
Monoid a =>
(RenderedCodeElement -> a) -> RenderedCode -> a
outputWith RenderedCodeElement -> Text
elemAsMarkdown
  where
  elemAsMarkdown :: RenderedCodeElement -> Text
elemAsMarkdown (Syntax Text
x)     = Text
x
  elemAsMarkdown (Keyword Text
x)    = Text
x
  elemAsMarkdown RenderedCodeElement
Space          = Text
" "
  elemAsMarkdown (Symbol Namespace
_ Text
x Link
_) = Text
x

  -- roles aren't rendered in markdown
  elemAsMarkdown (Role Text
_) = Text
""

-- fixityAsMarkdown :: P.Fixity -> Docs
-- fixityAsMarkdown (P.Fixity associativity precedence) =
--   tell' $ concat [ "_"
--                  , associativityStr
--                  , " / precedence "
--                  , show precedence
--                  , "_"
--                  ]
--   where
--   associativityStr = case associativity of
--     P.Infixl -> "left-associative"
--     P.Infixr -> "right-associative"
--     P.Infix  -> "non-associative"

childToString :: First -> ChildDeclaration -> Text
childToString :: First -> ChildDeclaration -> Text
childToString First
f decl :: ChildDeclaration
decl@ChildDeclaration{Maybe Text
Maybe SourceSpan
Text
ChildDeclarationInfo
cdeclSourceSpan :: ChildDeclaration -> Maybe SourceSpan
cdeclComments :: ChildDeclaration -> Maybe Text
cdeclTitle :: ChildDeclaration -> Text
cdeclInfo :: ChildDeclarationInfo
cdeclSourceSpan :: Maybe SourceSpan
cdeclComments :: Maybe Text
cdeclTitle :: Text
cdeclInfo :: ChildDeclaration -> ChildDeclarationInfo
..} =
  case ChildDeclarationInfo
cdeclInfo of
    ChildDataConstructor [Type']
_ ->
      let c :: Text
c = if First
f forall a. Eq a => a -> a -> Bool
== First
First then Text
"=" else Text
"|"
      in  Text
"  " forall a. Semigroup a => a -> a -> a
<> Text
c forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
str
    ChildTypeClassMember Type'
_ ->
      Text
"  " forall a. Semigroup a => a -> a -> a
<> Text
str
    ChildInstance [Constraint']
_ Type'
_ ->
      Text
str
  where
  str :: Text
str = RenderedCode -> Text
codeToString forall a b. (a -> b) -> a -> b
$ ChildDeclaration -> RenderedCode
Render.renderChildDeclaration ChildDeclaration
decl

data First
  = First
  | NotFirst
  deriving (Int -> First -> ShowS
[First] -> ShowS
First -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [First] -> ShowS
$cshowList :: [First] -> ShowS
show :: First -> String
$cshow :: First -> String
showsPrec :: Int -> First -> ShowS
$cshowsPrec :: Int -> First -> ShowS
Show, First -> First -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: First -> First -> Bool
$c/= :: First -> First -> Bool
== :: First -> First -> Bool
$c== :: First -> First -> Bool
Eq, Eq First
First -> First -> Bool
First -> First -> Ordering
First -> First -> First
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: First -> First -> First
$cmin :: First -> First -> First
max :: First -> First -> First
$cmax :: First -> First -> First
>= :: First -> First -> Bool
$c>= :: First -> First -> Bool
> :: First -> First -> Bool
$c> :: First -> First -> Bool
<= :: First -> First -> Bool
$c<= :: First -> First -> Bool
< :: First -> First -> Bool
$c< :: First -> First -> Bool
compare :: First -> First -> Ordering
$ccompare :: First -> First -> Ordering
Ord)

type Docs = Writer [Text] ()

runDocs :: Docs -> Text
runDocs :: Docs -> Text
runDocs = [Text] -> Text
T.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w a. Writer w a -> w
execWriter

tell' :: Text -> Docs
tell' :: Text -> Docs
tell' = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[])

spacer :: Docs
spacer :: Docs
spacer = Text -> Docs
tell' Text
""

headerLevel :: Int -> Text -> Docs
headerLevel :: Int -> Text -> Docs
headerLevel Int
level Text
hdr = Text -> Docs
tell' (Int -> Text -> Text
T.replicate Int
level Text
"#" forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
hdr)

fencedBlock :: Docs -> Docs
fencedBlock :: Docs -> Docs
fencedBlock Docs
inner = do
  Text -> Docs
tell' Text
"``` purescript"
  Docs
inner
  Text -> Docs
tell' Text
"```"

ticks :: Text -> Text
ticks :: Text -> Text
ticks = (Text
"`" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<> Text
"`")