hindent-6.3.0: src/HIndent/Ast/Name/RecordField.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}

module HIndent.Ast.Name.RecordField
  ( FieldName
  , mkFieldNameFromFieldOcc
  , mkFieldNameFromAmbiguousFieldOcc
  , mkFieldNameFromFieldLabelStrings
  , mkFieldNameFromLabels
  ) where

import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import qualified GHC.Data.FastString as GHC
import qualified GHC.Hs as GHC
import HIndent.Ast.Name.Prefix (PrefixName, fromString, mkPrefixName)
import HIndent.Ast.NodeComments (NodeComments(..))
import HIndent.Ast.WithComments (WithComments, flattenComments, fromGenLocated)
import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)
import HIndent.Pretty.Combinators (hDotSep)
import HIndent.Pretty.NodeComments
import qualified Language.Haskell.Syntax.Basic as GHC

newtype FieldName =
  FieldName (NonEmpty (WithComments PrefixName))

mkFieldNameFromLabels :: NonEmpty (WithComments PrefixName) -> FieldName
mkFieldNameFromLabels = FieldName

instance CommentExtraction FieldName where
  nodeComments FieldName {} = NodeComments [] [] []

instance Pretty FieldName where
  pretty' (FieldName labels) = hDotSep $ pretty <$> NonEmpty.toList labels

mkFieldNameFromFieldOcc :: GHC.FieldOcc GHC.GhcPs -> FieldName
#if MIN_VERSION_ghc_lib_parser(9, 4, 1)
mkFieldNameFromFieldOcc GHC.FieldOcc {..} =
  FieldName $ pure $ mkPrefixName <$> fromGenLocated foLabel
#else
mkFieldNameFromFieldOcc GHC.FieldOcc {..} =
  FieldName $ pure $ mkPrefixName <$> fromGenLocated rdrNameFieldOcc
#endif
#if MIN_VERSION_ghc_lib_parser(9, 12, 1)
mkFieldNameFromAmbiguousFieldOcc :: GHC.FieldOcc GHC.GhcPs -> FieldName
mkFieldNameFromAmbiguousFieldOcc = mkFieldNameFromFieldOcc
#else
mkFieldNameFromAmbiguousFieldOcc :: GHC.AmbiguousFieldOcc GHC.GhcPs -> FieldName
mkFieldNameFromAmbiguousFieldOcc (GHC.Unambiguous GHC.NoExtField name) =
  FieldName $ pure $ mkPrefixName <$> fromGenLocated name
mkFieldNameFromAmbiguousFieldOcc (GHC.Ambiguous GHC.NoExtField name) =
  FieldName $ pure $ mkPrefixName <$> fromGenLocated name
#endif
mkFieldNameFromFieldLabelStrings :: GHC.FieldLabelStrings GHC.GhcPs -> FieldName
mkFieldNameFromFieldLabelStrings (GHC.FieldLabelStrings labels) =
  maybe (error "FieldLabelStrings: expected non-empty label path") FieldName
    $ NonEmpty.nonEmpty
    $ fmap toSegment labels
  where
    toSegment =
      flattenComments
        . fmap
            (fmap (fromString . GHC.unpackFS . GHC.field_label)
               . fromGenLocated
               . GHC.dfoLabel)
        . fromGenLocated