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

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

import qualified Data.Foldable as Foldable
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
import GHC (GenLocated(L), ol_val)
import GHC.Hs
import qualified GHC.OldList as List
import GHC.Types.Basic
import Language.Haskell.Brittany.Internal.ToBriDocTools
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Components.BriDoc



-- | layouts patterns (inside function bindings, case alternatives, let
-- bindings or do notation). E.g. for input
--        > case computation of
--        >   (warnings, Success a b) -> ..
-- This part  ^^^^^^^^^^^^^^^^^^^^^^^ of the syntax tree is layouted by
-- 'layoutPat'. Similarly for
-- > func abc True 0 = []
--        ^^^^^^^^^^ this part
-- We will use `case .. of` as the imagined prefix to the examples used in
-- the different cases below.
layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered)
layoutPat lpat@(L _ pat) = docHandleComms lpat $ case pat of
  WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_"
    -- _ -> expr
  VarPat _ n -> fmap Seq.singleton $ docLit $ lrdrNameToText n
    -- abc -> expr
  LitPat _ lit -> do
    layouters <- mAsk
    fmap Seq.singleton $ allocateNode $ layout_lit layouters lit
    -- 0 -> expr
  ParPat _ inner -> do
    -- (nestedpat) -> expr
    left <- docLit $ Text.pack "("
    right <- docLit $ Text.pack ")"
    innerDocs <- colsWrapPat =<< layoutPat inner
    return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right
    -- return $ (left Seq.<| innerDocs) Seq.|> right
    -- case Seq.viewl innerDocs of
    --   Seq.EmptyL -> fmap return $ docLit $ Text.pack "()" -- this should never occur..
    --   x1 Seq.:< rest -> case Seq.viewr rest of
    --     Seq.EmptyR ->
    --       fmap return $ docSeq
    --       [ docLit $ Text.pack "("
    --       , return x1
    --       , docLit $ Text.pack ")"
    --       ]
    --     middle Seq.:> xN -> do
    --       x1' <- docSeq [docLit $ Text.pack "(", return x1]
    --       xN' <- docSeq [return xN, docLit $ Text.pack ")"]
    --       return $ (x1' Seq.<| middle) Seq.|> xN'
  ConPat _ lname (PrefixCon _tyargs args) -> do -- TODO92 is it safe to ignore tyargs??
    -- Abc a b c -> expr
    nameDoc <- lrdrNameToTextAnn lname
    argDocs <- layoutPat `mapM` args
    if null argDocs
      then return <$> docLit nameDoc
      else do
        x1 <- appSep (docLit nameDoc)
        xR <- fmap Seq.fromList $ sequence $ spacifyDocs $ fmap
          colsWrapPat
          argDocs
        return $ x1 Seq.<| xR
  ConPat _ lname (InfixCon left right) -> do
    -- a :< b -> expr
    nameDoc <- lrdrNameToTextAnn lname
    leftDoc <- appSep . colsWrapPat =<< layoutPat left
    rightDoc <- colsWrapPat =<< layoutPat right
    middle <- appSep $ docLit nameDoc
    return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc
  ConPat _ lname (RecCon (HsRecFields [] Nothing)) -> do
    -- Abc{} -> expr
    let t = lrdrNameToText lname
    fmap Seq.singleton $ docLit $ t <> Text.pack "{}"
  ConPat _ lname (RecCon (HsRecFields fs@(_ : _) Nothing)) -> do
    -- Abc { a = locA, b = locB, c = locC } -> expr1
    -- Abc { a, b, c } -> expr2
    let t = lrdrNameToText lname
    fds <- fs `forM` \(L _ (HsRecField _ (L _ fieldOcc) fPat pun)) -> do
      let FieldOcc _ lnameF = fieldOcc
      fExpDoc <- if pun
        then return Nothing
        else fmap Just $ shareDoc $ layoutPat fPat
      return (lrdrNameToText lnameF, fExpDoc)
    Seq.singleton <$> docSeq
      [ appSep $ docLit t
      , appSep $ docLit $ Text.pack "{"
      , docSeq $ List.intersperse docCommaSep $ fds <&> \case
        (fieldName, Just fieldDoc) -> docSeq
          [ appSep $ docLit fieldName
          , appSep $ docLit $ Text.pack "="
          , fieldDoc >>= colsWrapPat
          ]
        (fieldName, Nothing) -> docLit fieldName
      , docSeparator
      , docLit $ Text.pack "}"
      ]
  ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do
    -- Abc { .. } -> expr
    let t = lrdrNameToText lname
    Seq.singleton <$> docSeq [appSep $ docLit t, docLit $ Text.pack "{..}"]
  ConPat _ lname (RecCon (HsRecFields fs@(_ : _) (Just (L _ dotdoti))))
    | dotdoti == length fs -> do
    -- Abc { a = locA, .. }
      let t = lrdrNameToText lname
      fds <- fs `forM` \(L _ (HsRecField _ (L _ fieldOcc) fPat pun)) -> do
        let FieldOcc _ lnameF = fieldOcc
        fExpDoc <- if pun
          then return Nothing
          else Just <$> shareDoc (layoutPat fPat)
        return (lrdrNameToText lnameF, fExpDoc)
      Seq.singleton <$> docSeq
        [ appSep $ docLit t
        , appSep $ docLit $ Text.pack "{"
        , docSeq $ fds >>= \case
          (fieldName, Just fieldDoc) ->
            [ appSep $ docLit fieldName
            , appSep $ docLit $ Text.pack "="
            , fieldDoc >>= colsWrapPat
            , docCommaSep
            ]
          (fieldName, Nothing) -> [docLit fieldName, docCommaSep]
        , docLit $ Text.pack "..}"
        ]
  TuplePat _ args boxity -> do
    -- (nestedpat1, nestedpat2, nestedpat3) -> expr
    -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr
    case boxity of
      Boxed -> wrapPatListy args "()" docParenL docParenR
      Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep
  AsPat _ asName asPat -> do
    -- bind@nestedpat -> expr
    wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@")
  SigPat _ pat1 (HsPS _ ty1) -> do
    -- i :: Int -> expr
    patDocs <- layoutPat pat1
    tyDoc <- shareDoc $ callLayouter2 layout_type False ty1
    case Seq.viewr patDocs of
      Seq.EmptyR -> error "cannot happen ljoiuxoasdcoviuasd"
      xR Seq.:> xN -> do
        xN' <- -- at the moment, we don't support splitting patterns into
               -- multiple lines. but we cannot enforce pasting everything
               -- into one line either, because the type signature will ignore
               -- this if we overflow sufficiently.
               -- In order to prevent syntactically invalid results in such
               -- cases, we need the AddBaseY here.
               -- This can all change when patterns get multiline support.
               docAddBaseY BrIndentRegular $ docSeq
          [ appSep $ return xN
          , appSep $ docLit $ Text.pack "::"
          , docForceSingleline tyDoc
          ]
        return $ xR Seq.|> xN'
  ListPat _ elems ->
    -- [] -> expr1
    -- [nestedpat1, nestedpat2, nestedpat3] -> expr2
    wrapPatListy elems "[]" docBracketL docBracketR
  BangPat _ pat1 -> do
    -- !nestedpat -> expr
    wrapPatPrepend pat1 (docLit $ Text.pack "!")
  LazyPat _ pat1 -> do
    -- ~nestedpat -> expr
    wrapPatPrepend pat1 (docLit $ Text.pack "~")
  NPat _ _llit@(L _ ol) mNegative _ -> do
    -- -13 -> expr
    -- TODO92 we had `docWrapNode llit` below, but I don't think that is
    --        necessary/possible any longer..
    layouters <- mAsk
    litDoc <- allocateNode $ layout_overLit layouters $ GHC.ol_val ol
    negDoc <- docLit $ Text.pack "-"
    pure $ case mNegative of
      Just{} -> Seq.fromList [negDoc, litDoc]
      Nothing -> Seq.singleton litDoc
  ViewPat epAnn pat1 pat2 -> do
    pat1Doc <- docHandleComms epAnn $ callLayouter layout_expr pat1
    let arrowLoc = obtainAnnPos epAnn AnnRarrow
    pat1DocC <- appSep $ pure pat1Doc
    pat2Docs <- layoutPat pat2
    arrowDoc <- docHandleComms arrowLoc $ appSep $ docLitS "->"
    pure $ pat1DocC Seq.<| arrowDoc Seq.<| pat2Docs
  
  _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat

colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered
colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList

wrapPatPrepend
  :: LPat GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM (Seq BriDocNumbered)
wrapPatPrepend pat prepElem = do
  patDocs <- layoutPat pat
  case Seq.viewl patDocs of
    Seq.EmptyL -> return Seq.empty
    x1 Seq.:< xR -> do
      x1' <- docSeq [prepElem, return x1]
      return $ x1' Seq.<| xR

wrapPatListy
  :: [LPat GhcPs]
  -> String
  -> ToBriDocM BriDocNumbered
  -> ToBriDocM BriDocNumbered
  -> ToBriDocM (Seq BriDocNumbered)
wrapPatListy elems both start end = do
  elemDocs <- Seq.fromList elems `forM` (layoutPat >=> colsWrapPat)
  case Seq.viewl elemDocs of
    Seq.EmptyL -> fmap Seq.singleton $ docLit $ Text.pack both
    x1 Seq.:< rest -> do
      sDoc <- start
      eDoc <- end
      rest' <- rest `forM` \bd -> docSeq [docCommaSep, return bd]
      return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc