{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Language.Haskell.Brittany.Internal.ToBriDoc.IE where

import qualified Data.List.Extra
import qualified Data.Text                     as Text
import           GHC                            ( GenLocated(L)
                                                , ModuleName
                                                , moduleNameString
                                                , unLoc
                                                )
import           GHC.Hs
import qualified GHC.OldList                   as List
import qualified Data.Data

import           Language.Haskell.Brittany.Internal.Components.BriDoc
import           Language.Haskell.Brittany.Internal.Prelude
import           Language.Haskell.Brittany.Internal.ToBriDocTools
import           Language.Haskell.Brittany.Internal.Types
import           Language.Haskell.Brittany.Internal.Utils



prepareName :: LIEWrappedName name -> LocatedN name
prepareName = ieLWrappedName

layoutIE :: Data.Data.Data ast => ast -> ToBriDoc IE
layoutIE commAst lie@(L _ ie) = docHandleComms lie $ case ie of
  IEVar      _ x -> layoutWrapped lie x
  IEThingAbs _ x -> layoutWrapped lie x
  IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
  IEThingWith epAnn x (IEWildcard _) _ -> do
    let posOpen = obtainAnnPos epAnn AnnOpenP
    let posClose = obtainAnnPos epAnn AnnCloseP
    let posDotDot = obtainAnnPos epAnn AnnDotdot
    docSeq 
      [ layoutWrapped lie x
      , docHandleComms posOpen $ docLitS "("
      , docHandleComms posDotDot $ docLitS ".."
      , docHandleComms posClose $ docLitS ")"
      ]
  IEThingWith epAnn x _ ns -> do
    let hasComments = or
          ( hasCommentsBetween commAst posOpen posClose
          : hasAnyCommentsBelow x
          : map hasAnyCommentsBelow ns
          )
    let sortedNs = List.sortOn wrappedNameToText ns
    runFilteredAlternative $ do
      addAlternativeCond (not hasComments)
        $  docSeq
        $  [layoutWrapped lie x, docHandleComms posOpen $ docLit $ Text.pack "("]
        ++ intersperse docCommaSep (map nameDoc sortedNs)
        ++ [docHandleComms posClose docParenR]
      addAlternative
        -- $ docWrapNodeRest lie
        $ docAddBaseY BrIndentRegular
        $ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs))
   where
    posOpen  = obtainAnnPos epAnn AnnOpenP
    posClose = obtainAnnPos epAnn AnnCloseP
    nameDoc =  docHandleListElemComms (docLit <=< lrdrNameToTextAnn . prepareName)
    layoutItem n = docSeq
      [ docCommaSep
      , -- TODO92 docWrapNode n $ 
        nameDoc n
      ]
    layoutItems FirstLastEmpty = docSetBaseY $ docLines
      [ docSeq
        [ docHandleComms posOpen docParenLSep
        , -- TODO92 docNodeAnnKW lie (Just AnnOpenP) 
          docEmpty
        ]
      , docHandleComms posClose docParenR
      ]
    layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines
      [ docSeq
        [ docHandleComms posOpen docParenLSep
        , -- TODO92 docNodeAnnKW lie (Just AnnOpenP) $ 
          nameDoc n
        ]
      , docHandleComms posClose docParenR
      ]
    layoutItems (FirstLast n1 nMs nN) =
      docSetBaseY
        $  docLines
        $  [ docSeq
               [ docHandleComms posOpen docParenLSep
               , -- TODO92 docWrapNode n1 $ 
                 nameDoc n1
               ]
           ]
        ++ map layoutItem nMs
        ++ [ docSeq
             [ docCommaSep
             , -- TODO92 docNodeAnnKW lie (Just AnnOpenP) $ 
               nameDoc nN
             ]
           , docHandleComms posClose docParenR
           ]
  IEModuleContents _ n -> docSeq
    [ docLit $ Text.pack "module"
    , docSeparator
    , docLit . Text.pack . moduleNameString $ unLoc n
    ]
  _ -> docEmpty
 where
  layoutWrapped _ = \case
    L _ (IEName n       ) -> docLit =<< lrdrNameToTextAnn n
    L _ (IEPattern loc n) -> do
      name <- lrdrNameToTextAnn n
      docHandleComms loc $ docLit $ Text.pack "pattern " <> name
    L _ (IEType loc n) -> do
      name <- lrdrNameToTextAnn n
      docHandleComms loc $ docLit $ Text.pack "type " <> name

-- Helper function to deal with Located lists of LIEs.
-- In particular this will also associate documentation
-- from the located list that actually belongs to the last IE.
-- It also adds docCommaSep to all but the first element
-- This configuration allows both vertical and horizontal
-- handling of the resulting list. Adding parens is
-- left to the caller since that is context sensitive
layoutAnnAndSepLLIEs
  :: (Data.Data.Data a, HasCallStack)
  => SortItemsFlag
  -> a
  -> [LIE GhcPs]
  -> ToBriDocM [ToBriDocM BriDocNumbered]
layoutAnnAndSepLLIEs shouldSort commAst lies = do
  let makeIENode ie = docSeq [docCommaSep, ie]
  let sortedLies =
        [ items
        | group <- Data.List.Extra.groupOn lieToText
          $ List.sortOn lieToText lies
        , items <- mergeGroup group
        ]
  let ieDocs = fmap (docHandleListElemComms (layoutIE commAst)) $ case shouldSort of
        ShouldSortItems   -> sortedLies
        KeepItemsUnsorted -> lies
  ieCommaDocs <- sequence $ case splitFirstLast ieDocs of
    FirstLastEmpty         -> []
    FirstLastSingleton ie  -> [ie]
    FirstLast ie1 ieMs ieN -> [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN]
  pure $ fmap pure ieCommaDocs -- returned shared nodes
 where
  mergeGroup :: [LIE GhcPs] -> [LIE GhcPs]
  mergeGroup []        = []
  mergeGroup items@[_] = items
  mergeGroup items     = if
    | all isProperIEThing items -> [List.foldl1' thingFolder items]
    | all isIEVar items         -> [List.foldl1' thingFolder items]
    | otherwise                 -> items
  -- proper means that if it is a ThingWith, it does not contain a wildcard
  -- (because I don't know what a wildcard means if it is not already a
  -- IEThingAll).
  isProperIEThing :: LIE GhcPs -> Bool
  isProperIEThing = \case
    L _ (IEThingAbs _ _wn) -> True
    L _ (IEThingAll _ _wn) -> True
    L _ (IEThingWith _ _wn NoIEWildcard _) -> True
    _ -> False
  isIEVar :: LIE GhcPs -> Bool
  isIEVar = \case
    L _ IEVar{} -> True
    _           -> False
  thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs
  thingFolder l1@(L _ IEVar{}     ) _                     = l1
  thingFolder l1@(L _ IEThingAll{}) _                     = l1
  thingFolder _                     l2@(L _ IEThingAll{}) = l2
  thingFolder l1                    (   L _ IEThingAbs{}) = l1
  thingFolder (L _ IEThingAbs{})    l2                    = l2
  thingFolder (L l (IEThingWith x wn _ items1)) (L _ (IEThingWith _ _ _ items2))
    = L l (IEThingWith x wn NoIEWildcard (items1 ++ items2))
  thingFolder _ _ =
    error "thingFolder should be exhaustive because we have a guard above"


-- Builds a complete layout for the given located
-- list of LIEs. The layout provides two alternatives:
-- (item, item, ..., item)
-- ( item
-- , item
-- ...
-- , item
-- )
-- If the llies contains comments the list will
-- always expand over multiple lines, even when empty:
-- () -- no comments
-- ( -- a comment
-- )
layoutLLIEs
  :: HasCallStack
  => Bool
  -> SortItemsFlag
  -> LocatedL [LIE GhcPs]
  -> ToBriDocM BriDocNumbered
layoutLLIEs enableSingleline shouldSort llies@(L epAnn lies) = do
  let posOpen  = obtainAnnPos epAnn AnnOpenP
  let posClose = obtainAnnPos epAnn AnnCloseP
  ieDs <- layoutAnnAndSepLLIEs shouldSort llies lies
  let hasComments = hasAnyCommentsBelow llies
  docOpen  <- shareDoc $ docHandleComms posOpen docParenL
  docClose <- shareDoc $ docHandleComms posClose docParenR
  docHandleComms llies $ runFilteredAlternative $ case ieDs of
    [] -> do
      addAlternativeCond (not hasComments) $ docLit $ Text.pack "()"
      addAlternativeCond hasComments $ docPar docOpen docClose
    (ieDsH : ieDsT) -> do
      addAlternativeCond (not hasComments && enableSingleline)
        $  docSeq
        $  [docOpen]
        ++ (docForceSingleline <$> ieDs)
        ++ [docClose]
      addAlternative
        $  docPar (docSetBaseY $ docSeq [docOpen, docSeparator, ieDsH])
        $  docLines
        $  ieDsT
        ++ [docClose]

-- | Returns a "fingerprint string", not a full text representation, nor even
-- a source code representation of this syntax node.
-- Used for sorting, not for printing the formatter's output source code.
wrappedNameToText :: LIEWrappedName RdrName -> Text
wrappedNameToText = \case
  L _ (IEName n        ) -> lrdrNameToText n
  L _ (IEPattern _loc n) -> lrdrNameToText n
  L _ (IEType    _loc n) -> lrdrNameToText n

-- | Returns a "fingerprint string", not a full text representation, nor even
-- a source code representation of this syntax node.
-- Used for sorting, not for printing the formatter's output source code.
lieToText :: LIE GhcPs -> Text
lieToText = \case
  L _ (IEVar      _ wn     ) -> wrappedNameToText wn
  L _ (IEThingAbs _ wn     ) -> wrappedNameToText wn
  L _ (IEThingAll _ wn     ) -> wrappedNameToText wn
  L _ (IEThingWith _ wn _ _) -> wrappedNameToText wn
  -- TODO: These _may_ appear in exports!
  -- Need to check, and either put them at the top (for module) or do some
  -- other clever thing.
  L _ (IEModuleContents _ n) -> moduleNameToText n
  L _ IEGroup{}              -> Text.pack "@IEGroup"
  L _ IEDoc{}                -> Text.pack "@IEDoc"
  L _ IEDocNamed{}           -> Text.pack "@IEDocNamed"
 where
  moduleNameToText :: LocatedA ModuleName -> Text
  moduleNameToText (L _ name) =
    Text.pack ("@IEModuleContents" ++ moduleNameString name)