content: -- | Data types and functions for representing a simplified form of PureScript
  -- code, intended for use in e.g. HTML documentation.
  
  module Language.PureScript.Docs.RenderedCode.Types
   ( RenderedCodeElement(..)
   , ContainingModule(..)
   , asContainingModule
   , maybeToContainingModule
   , fromQualified
   , Namespace(..)
   , Link(..)
   , FixityAlias
   , RenderedCode
   , outputWith
   , sp
   , syntax
   , keyword
   , keywordForall
   , keywordData
   , keywordType
   , keywordClass
   , keywordWhere
   , keywordFixity
   , keywordAs
   , ident
   , dataCtor
   , typeCtor
   , typeOp
   , typeVar
   , roleAnn
   , alias
   , aliasName
   ) where
  
  import Prelude
  import GHC.Generics (Generic)
  
  import Control.DeepSeq (NFData)
  import Control.Monad.Error.Class (MonadError(..))
  
  import Data.Aeson.BetterErrors (Parse, nth, withText, withValue, toAesonParser, perhaps, asText)
  import Data.Aeson qualified as A
  import Data.Text (Text)
  import Data.Text qualified as T
  import Data.ByteString.Lazy qualified as BS
  import Data.Text.Encoding qualified as TE
  
  import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, OpName(..), OpNameType(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), moduleNameFromString, runIdent, runModuleName)
  import Language.PureScript.AST (Associativity(..))
  
  -- | Given a list of actions, attempt them all, returning the first success.
  -- If all the actions fail, 'tryAll' returns the first argument.
  tryAll :: MonadError e m => m a -> [m a] -> m a
  tryAll = foldr $ \x y -> catchError x (const y)
  
  firstEq :: Text -> Parse Text a -> Parse Text a
  firstEq str p = nth 0 (withText (eq str)) *> p
    where
    eq s s' = if s == s' then Right () else Left ""
  
  -- |
  -- Try the given parsers in sequence. If all fail, fail with the given message,
  -- and include the JSON in the error.
  --
  tryParse :: Text -> [Parse Text a] -> Parse Text a
  tryParse msg =
    tryAll (withValue (Left . (fullMsg <>) . showJSON))
  
    where
    fullMsg = "Invalid " <> msg <> ": "
  
    showJSON :: A.Value -> Text
    showJSON = TE.decodeUtf8 . BS.toStrict . A.encode
  
  -- |
  -- This type is isomorphic to 'Maybe' 'ModuleName'. It makes code a bit
  -- easier to read, as the meaning is more explicit.
  --
  data ContainingModule
    = ThisModule
    | OtherModule ModuleName
    deriving (Show, Eq, Ord)
  
  instance A.ToJSON ContainingModule where
    toJSON = A.toJSON . go
      where
      go = \case
        ThisModule -> ["ThisModule"]
        OtherModule mn -> ["OtherModule", runModuleName mn]
  
  instance A.FromJSON ContainingModule where
    parseJSON = toAesonParser id asContainingModule
  
  asContainingModule :: Parse Text ContainingModule
  asContainingModule =
    tryParse "containing module" $
      current ++ backwardsCompat
    where
    current =
      [ firstEq "ThisModule" (pure ThisModule)
      , firstEq "OtherModule" (OtherModule <$> nth 1 asModuleName)
      ]
  
    -- For JSON produced by compilers up to 0.10.5.
    backwardsCompat =
      [ maybeToContainingModule <$> perhaps asModuleName
      ]
  
    asModuleName = moduleNameFromString <$> asText
  
  -- |
  -- Convert a 'Maybe' 'ModuleName' to a 'ContainingModule', using the obvious
  -- isomorphism.
  --
  maybeToContainingModule :: Maybe ModuleName -> ContainingModule
  maybeToContainingModule Nothing = ThisModule
  maybeToContainingModule (Just mn) = OtherModule mn
  
  fromQualified :: Qualified a -> (ContainingModule, a)
  fromQualified (Qualified (ByModuleName mn) x) = (OtherModule mn, x)
  fromQualified (Qualified _ x) = (ThisModule, x)
  
  data Link
    = NoLink
    | Link ContainingModule
    deriving (Show, Eq, Ord)
  
  instance A.ToJSON Link where
    toJSON = \case
      NoLink -> A.toJSON ["NoLink" :: Text]
      Link mn -> A.toJSON ["Link", A.toJSON mn]
  
  asLink :: Parse Text Link
  asLink =
    tryParse "link"
      [ firstEq "NoLink" (pure NoLink)
      , firstEq "Link" (Link <$> nth 1 asContainingModule)
      ]
  
  instance A.FromJSON Link where
    parseJSON = toAesonParser id asLink
  
  data Namespace
    = ValueLevel
    | TypeLevel
    deriving (Show, Eq, Ord, Generic)
  
  instance NFData Namespace
  
  instance A.ToJSON Namespace where
    toJSON = A.toJSON . show
  
  asNamespace :: Parse Text Namespace
  asNamespace =
    tryParse "namespace"
      [ withText $ \case
          "ValueLevel" -> Right ValueLevel
          "TypeLevel" -> Right TypeLevel
          _ -> Left ""
      ]
  
  instance A.FromJSON Namespace where
    parseJSON = toAesonParser id asNamespace
  
  -- |
  -- A single element in a rendered code fragment. The intention is to support
  -- multiple output formats. For example, plain text, or highlighted HTML.
  --
  data RenderedCodeElement
    = Syntax Text
    | Keyword Text
    | Space
    -- | Any symbol which you might or might not want to link to, in any
    -- namespace (value, type, or kind). Note that this is not related to the
    -- kind called Symbol for type-level strings.
    | Symbol Namespace Text Link
    | Role Text
    deriving (Show, Eq, Ord)
  
  instance A.ToJSON RenderedCodeElement where
    toJSON (Syntax str) =
      A.toJSON ["syntax", str]
    toJSON (Keyword str) =
      A.toJSON ["keyword", str]
    toJSON Space =
      A.toJSON ["space" :: Text]
    toJSON (Symbol ns str link) =
      A.toJSON ["symbol", A.toJSON ns, A.toJSON str, A.toJSON link]
    toJSON (Role role) =
      A.toJSON ["role", role]
  
  -- |
  -- A type representing a highly simplified version of PureScript code, intended
  -- for use in output formats like plain text or HTML.
  --
  newtype RenderedCode
    = RC { unRC :: [RenderedCodeElement] }
    deriving (Show, Eq, Ord, Semigroup, Monoid)
  
  instance A.ToJSON RenderedCode where
    toJSON (RC elems) = A.toJSON elems
  
  -- |
  -- This function allows conversion of a 'RenderedCode' value into a value of
  -- some other type (for example, plain text, or HTML). The first argument
  -- is a function specifying how each individual 'RenderedCodeElement' should be
  -- rendered.
  --
  outputWith :: Monoid a => (RenderedCodeElement -> a) -> RenderedCode -> a
  outputWith f = foldMap f . unRC
  
  -- |
  -- A 'RenderedCode' fragment representing a space.
  --
  sp :: RenderedCode
  sp = RC [Space]
  
  -- possible TODO: instead of this function, export RenderedCode values for
  -- each syntax element, eg syntaxArr (== syntax "->"), syntaxLBrace,
  -- syntaxRBrace, etc.
  syntax :: Text -> RenderedCode
  syntax x = RC [Syntax x]
  
  keyword :: Text -> RenderedCode
  keyword kw = RC [Keyword kw]
  
  keywordForall :: RenderedCode
  keywordForall = keyword "forall"
  
  keywordData :: RenderedCode
  keywordData = keyword "data"
  
  keywordType :: RenderedCode
  keywordType = keyword "type"
  
  keywordClass :: RenderedCode
  keywordClass = keyword "class"
  
  keywordWhere :: RenderedCode
  keywordWhere = keyword "where"
  
  keywordFixity :: Associativity -> RenderedCode
  keywordFixity Infixl = keyword "infixl"
  keywordFixity Infixr = keyword "infixr"
  keywordFixity Infix = keyword "infix"
  
  keywordAs :: RenderedCode
  keywordAs = keyword "as"
  
  ident :: Qualified Ident -> RenderedCode
  ident (fromQualified -> (mn, name)) =
    RC [Symbol ValueLevel (runIdent name) (Link mn)]
  
  dataCtor :: Qualified (ProperName 'ConstructorName) -> RenderedCode
  dataCtor (fromQualified -> (mn, name)) =
    RC [Symbol ValueLevel (runProperName name) (Link mn)]
  
  typeCtor :: Qualified (ProperName 'TypeName) -> RenderedCode
  typeCtor (fromQualified -> (mn, name)) =
    RC [Symbol TypeLevel (runProperName name) (Link mn)]
  
  typeOp :: Qualified (OpName 'TypeOpName) -> RenderedCode
  typeOp (fromQualified -> (mn, name)) =
    RC [Symbol TypeLevel (runOpName name) (Link mn)]
  
  typeVar :: Text -> RenderedCode
  typeVar x = RC [Symbol TypeLevel x NoLink]
  
  roleAnn :: Maybe Text -> RenderedCode
  roleAnn = RC . maybe [] renderRole
    where
    renderRole = \case
      "nominal" -> [Role "nominal"]
      "phantom" -> [Role "phantom"]
      _ -> []
  
  type FixityAlias = Qualified (Either (ProperName 'TypeName) (Either Ident (ProperName 'ConstructorName)))
  
  alias :: FixityAlias -> RenderedCode
  alias for =
    prefix <> RC [Symbol ns name (Link mn)]
    where
    (ns, name, mn) = unpackFixityAlias for
    prefix = case ns of
      TypeLevel ->
        keywordType <> sp
      _ ->
        mempty
  
  aliasName :: FixityAlias -> Text -> RenderedCode
  aliasName for name' =
    let
      (ns, _, _) = unpackFixityAlias for
      unParen = T.tail . T.init
      name = unParen name'
    in
      case ns of
        ValueLevel ->
          ident (Qualified ByNullSourcePos (Ident name))
        TypeLevel ->
          typeCtor (Qualified ByNullSourcePos (ProperName name))
  
  -- | Converts a FixityAlias into a different representation which is more
  -- useful to other functions in this module.
  unpackFixityAlias :: FixityAlias -> (Namespace, Text, ContainingModule)
  unpackFixityAlias (fromQualified -> (mn, x)) =
    case x of
      -- We add some seemingly superfluous type signatures here just to be extra
      -- sure we are not mixing up our namespaces.
      Left (n :: ProperName 'TypeName) ->
        (TypeLevel, runProperName n, mn)
      Right (Left n) ->
        (ValueLevel, runIdent n, mn)
      Right (Right (n :: ProperName 'ConstructorName)) ->
        (ValueLevel, runProperName n, mn)
  