content: module Language.PureScript.Docs.Convert.Single
    ( convertSingleModule
    , convertComments
    ) where
  
  import Protolude hiding (moduleName)
  
  import Control.Category ((>>>))
  
  import Data.Text qualified as T
  
  import Language.PureScript.Docs.Types (ChildDeclaration(..), ChildDeclarationInfo(..), Declaration(..), DeclarationInfo(..), KindInfo(..), Module(..), Type', convertFundepsToStrings, isType, isTypeClass)
  
  import Language.PureScript.AST qualified as P
  import Language.PureScript.Comments qualified as P
  import Language.PureScript.Crash qualified as P
  import Language.PureScript.Names qualified as P
  import Language.PureScript.Roles qualified as P
  import Language.PureScript.Types qualified as P
  
  -- |
  -- Convert a single Module, but ignore re-exports; any re-exported types or
  -- values will not appear in the result.
  --
  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
  
  -- | Different declarations we can augment
  data AugmentType
    = AugmentClass
    -- ^ Augment documentation for a type class
    | AugmentType
    -- ^ Augment documentation for a type constructor
  
  -- | The data type for an intermediate stage which we go through during
  -- converting.
  --
  -- In the first pass, we take all top level declarations in the module, and
  -- collect other information which will later be used to augment the top level
  -- declarations. These two situation correspond to the Right and Left
  -- constructors, respectively.
  --
  -- In the second pass, we go over all of the Left values and augment the
  -- relevant declarations, leaving only the augmented Right values.
  --
  -- Note that in the Left case, we provide a [Text] as well as augment
  -- information. The [Text] value should be a list of titles of declarations
  -- that the augmentation should apply to. For example, for a type instance
  -- declaration, that would be any types or type classes mentioned in the
  -- instance. For a fixity declaration, it would be just the relevant operator's
  -- name.
  type IntermediateDeclaration
    = Either ([(Text, AugmentType)], DeclarationAugment) Declaration
  
  -- | Some data which will be used to augment a Declaration in the
  -- output.
  --
  -- The AugmentChild constructor allows us to move all children under their
  -- respective parents. It is only necessary for type instance declarations,
  -- since they appear at the top level in the AST, and since they might need to
  -- appear as children in two places (for example, if a data type defined in a
  -- module is an instance of a type class also defined in that module).
  --
  -- The AugmentKindSig constructor allows us to add a kind signature
  -- to its corresponding declaration. Comments for both declarations
  -- are also merged together.
  data DeclarationAugment
    = AugmentChild ChildDeclaration
    | AugmentKindSig KindSignatureInfo
    | AugmentRole (Maybe Text) [P.Role]
  
  data KindSignatureInfo = KindSignatureInfo
    { ksiComments :: Maybe Text
    , ksiKeyword :: P.KindSignatureFor
    , ksiKind :: Type'
    }
  
  -- | Augment top-level declarations; the second pass. See the comments under
  -- the type synonym IntermediateDeclaration for more information.
  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] }
    augmentWith (AugmentKindSig KindSignatureInfo{..}) d =
      d { declComments = mergeComments ksiComments $ declComments d
        , declKind = Just $ KindInfo { kiKeyword = ksiKeyword, kiKind = ksiKind }
        }
    augmentWith (AugmentRole comms roles) d =
      d { declComments = mergeComments (declComments d) comms
        , declInfo = insertRoles
        }
      where
        insertRoles = case declInfo d of
          DataDeclaration dataDeclType args [] ->
            DataDeclaration dataDeclType args roles
          DataDeclaration _ _ _ ->
            P.internalError "augmentWith: could not add a second role declaration to a data declaration"
  
          ExternDataDeclaration kind [] ->
            ExternDataDeclaration kind roles
          ExternDataDeclaration _ _ ->
            P.internalError "augmentWith: could not add a second role declaration to an FFI declaration"
  
          _ -> P.internalError "augmentWith: could not add role to declaration"
  
    mergeComments :: Maybe Text -> Maybe Text -> Maybe Text
    mergeComments Nothing bot = bot
    mergeComments top Nothing = top
    mergeComments (Just topComs) (Just bottomComs) =
      Just $ topComs <> "\n" <> bottomComs
  
  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.TypeSynonymDeclaration _ name _ _) = Just (P.runProperName name)
  getDeclarationTitle (P.TypeClassDeclaration _ name _ _ _ _) = Just (P.runProperName name)
  getDeclarationTitle (P.TypeInstanceDeclaration _ _ _ _ name _ _ _ _) = Just $ either (const "<anonymous>") P.showIdent name
  getDeclarationTitle (P.TypeFixityDeclaration _ _ _ op) = Just ("type " <> P.showOp op)
  getDeclarationTitle (P.ValueFixityDeclaration _ _ _ op) = Just (P.showOp op)
  getDeclarationTitle (P.KindDeclaration _ _ n _) = Just (P.runProperName n)
  getDeclarationTitle (P.RoleDeclaration P.RoleDeclarationData{..}) = Just (P.runProperName rdeclIdent)
  getDeclarationTitle _ = Nothing
  
  -- | Create a basic Declaration value.
  mkDeclaration :: P.SourceAnn -> Text -> DeclarationInfo -> Declaration
  mkDeclaration (ss, com) title info =
    Declaration { declTitle      = title
                , declComments   = convertComments com
                , declSourceSpan = Just ss -- TODO: make this non-optional when we next break the format
                , declChildren   = []
                , declInfo       = info
                , declKind       = Nothing -- kind sigs are added in augment pass
                }
  
  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 =
    -- If no explicit type declaration was provided, insert a wildcard, so that
    -- the actual type will be added during type checking.
    basicDeclaration sa title (ValueDeclaration (P.TypeWildcard () P.UnnamedWildcard))
  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.DataConstructorDeclaration -> ChildDeclaration
    convertCtor P.DataConstructorDeclaration{..} =
      let (sourceSpan, comments) = dataCtorAnn
      in ChildDeclaration (P.runProperName dataCtorName) (convertComments comments) (Just sourceSpan) (ChildDataConstructor (fmap (($> ()) . snd) dataCtorFields))
  convertDeclaration (P.ExternDataDeclaration sa _ kind') title =
    basicDeclaration sa title (ExternDataDeclaration (kind' $> ()) [])
  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 (P.KindDeclaration sa keyword _ kind) title =
    Just $ Left ([(title, AugmentType), (title, AugmentClass)], AugmentKindSig ksi)
    where
      comms = convertComments $ snd sa
      ksi = KindSignatureInfo { ksiComments = comms, ksiKeyword = keyword, ksiKind = kind $> () }
  convertDeclaration (P.RoleDeclaration P.RoleDeclarationData{..}) title =
    Just $ Left ([(title, AugmentType)], AugmentRole comms rdeclRoles)
    where
      comms = convertComments $ snd rdeclSourceAnn
  
  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)
  