PatternSynonym.hs

{-# LANGUAGE RecordWildCards #-}

module HIndent.Ast.Declaration.PatternSynonym
  ( PatternSynonym
  , mkPatternSynonym
  ) where

import HIndent.Applicative
import HIndent.Ast.MatchGroup (MatchGroup, mkExprMatchGroup)
import HIndent.Ast.Name.Infix
import HIndent.Ast.Name.Prefix
import HIndent.Ast.Name.RecordField (FieldName, mkFieldNameFromFieldOcc)
import HIndent.Ast.Pattern
import HIndent.Ast.WithComments
import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
import {-# SOURCE #-} HIndent.Pretty
import HIndent.Pretty.Combinators
import HIndent.Pretty.NodeComments

data Parameters
  = Prefix
      { args :: [WithComments PrefixName]
      }
  | Infix
      { leftArg :: WithComments PrefixName
      , rightArg :: WithComments PrefixName
      }
  | Record
      { fields :: [WithComments FieldName]
      }

data PatternSynonym = PatternSynonym
  { name :: GHC.LIdP GHC.GhcPs
  , parameters :: WithComments Parameters
  , isImplicitBidirectional :: Bool
  , explicitMatches :: Maybe MatchGroup
  , definition :: WithComments PatInsidePatDecl
  }

instance CommentExtraction Parameters where
  nodeComments Prefix {} = emptyNodeComments
  nodeComments Infix {} = emptyNodeComments
  nodeComments Record {} = emptyNodeComments

instance CommentExtraction PatternSynonym where
  nodeComments PatternSynonym {} = emptyNodeComments

instance Pretty Parameters where
  pretty' Prefix {..} = spaced $ fmap pretty args
  pretty' Infix {..} = spaced [pretty leftArg, pretty rightArg]
  pretty' Record {..} = hFields $ fmap pretty fields

instance Pretty PatternSynonym where
  pretty' PatternSynonym {..} = do
    string "pattern "
    case getNode parameters of
      Infix {..} ->
        spaced [pretty leftArg, pretty $ fmap mkInfixName name, pretty rightArg]
      Prefix {args = []} -> pretty $ fmap mkPrefixName name
      _ -> spaced [pretty $ fmap mkPrefixName name, pretty parameters]
    let arrow =
          if isImplicitBidirectional
            then "="
            else "<-"
    spacePrefixed [string arrow, pretty definition]
    whenJust explicitMatches $ \matches -> do
      newline
      indentedBlock $ string "where " |=> pretty matches

mkParameters :: GHC.HsPatSynDetails GHC.GhcPs -> Parameters
mkParameters (GHC.PrefixCon _ args) =
  Prefix {args = map (fromGenLocated . fmap mkPrefixName) args}
mkParameters (GHC.InfixCon l r) =
  Infix
    { leftArg = fromGenLocated $ fmap mkPrefixName l
    , rightArg = fromGenLocated $ fmap mkPrefixName r
    }
mkParameters (GHC.RecCon fields) =
  Record
    { fields =
        map
          (mkWithComments . mkFieldNameFromFieldOcc . GHC.recordPatSynField)
          fields
    }

mkPatternSynonym :: GHC.PatSynBind GHC.GhcPs GHC.GhcPs -> PatternSynonym
mkPatternSynonym GHC.PSB {..} = PatternSynonym {..}
  where
    name = psb_id
    parameters = mkWithComments $ mkParameters psb_args
    (isImplicitBidirectional, explicitMatches) =
      case psb_dir of
        GHC.Unidirectional -> (False, Nothing)
        GHC.ImplicitBidirectional -> (True, Nothing)
        GHC.ExplicitBidirectional matches ->
          (False, Just $ mkExprMatchGroup matches)
    definition = mkPatInsidePatDecl <$> fromGenLocated psb_def