ImportExport.hs

{-# LANGUAGE CPP #-}

module HIndent.Ast.Name.ImportExport
  ( ImportExportName
  , mkImportExportName
  ) where

import qualified Data.ByteString.Builder as S
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Char (isLower, isUpper)
import HIndent.Ast.Name.Prefix
import HIndent.Ast.NodeComments
import HIndent.Ast.WithComments
import HIndent.Config
import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
import HIndent.Pretty
import HIndent.Pretty.Combinators
import HIndent.Pretty.NodeComments
import HIndent.Printer

data ImportExportName
  = Regular (WithComments PrefixName)
  | Pattern (WithComments PrefixName)
  | Type (WithComments PrefixName)

instance CommentExtraction ImportExportName where
  nodeComments Regular {} = NodeComments [] [] []
  nodeComments Pattern {} = NodeComments [] [] []
  nodeComments Type {} = NodeComments [] [] []

instance Pretty ImportExportName where
  pretty' (Regular name) = pretty name
  pretty' (Pattern name) = spaced [string "pattern", pretty name]
  pretty' (Type name) = string "type " >> pretty name

instance Eq ImportExportName where
  a == b = compare a b == EQ

instance Ord ImportExportName where
  compare a b = compareIdentifier (getNameString a) (getNameString b)

getNameString :: ImportExportName -> String
getNameString n =
  L.unpack $ S.toLazyByteString $ runPrinterStyle defaultConfig $ pretty' n

compareIdentifier :: String -> String -> Ordering
compareIdentifier as@(a:_) bs@(b:_) =
  case compareChar a b of
    EQ -> compareSameIdentifierType as bs
    x -> x
compareIdentifier "" "" = EQ
compareIdentifier "" _ = LT
compareIdentifier _ "" = GT

compareSameIdentifierType :: String -> String -> Ordering
compareSameIdentifierType "" "" = EQ
compareSameIdentifierType "" _ = LT
compareSameIdentifierType _ "" = GT
compareSameIdentifierType ('(':as) bs = compareSameIdentifierType as bs
compareSameIdentifierType (')':as) bs = compareSameIdentifierType as bs
compareSameIdentifierType as ('(':bs) = compareSameIdentifierType as bs
compareSameIdentifierType as (')':bs) = compareSameIdentifierType as bs
compareSameIdentifierType (a:as) (b:bs) =
  case compare a b of
    EQ -> compareSameIdentifierType as bs
    x -> x

compareChar :: Char -> Char -> Ordering
compareChar a b =
  case compare (charToLetterType a) (charToLetterType b) of
    EQ -> compare a b
    x -> x

charToLetterType :: Char -> LetterType
charToLetterType c
  | isLower c = Lower
  | isUpper c = Capital
  | otherwise = Symbol

data LetterType
  = Capital
  | Symbol
  | Lower
  deriving (Eq, Ord)
#if MIN_VERSION_ghc_lib_parser(9, 6, 1)
mkImportExportName :: GHC.IEWrappedName GHC.GhcPs -> ImportExportName
mkImportExportName (GHC.IEName _ name) =
  Regular $ fromGenLocated $ fmap mkPrefixName name
mkImportExportName (GHC.IEPattern _ name) =
  Pattern $ fromGenLocated $ fmap mkPrefixName name
mkImportExportName (GHC.IEType _ name) =
  Type $ fromGenLocated $ fmap mkPrefixName name
#if MIN_VERSION_ghc_lib_parser(9, 12, 1)
mkImportExportName GHC.IEDefault {} =
  error "IEDefault is not generated by parser"
#endif
#else
mkImportExportName :: GHC.IEWrappedName GHC.RdrName -> ImportExportName
mkImportExportName (GHC.IEName name) =
  Regular $ fromGenLocated $ fmap mkPrefixName name
mkImportExportName (GHC.IEPattern _ name) =
  Pattern $ fromGenLocated $ fmap mkPrefixName name
mkImportExportName (GHC.IEType _ name) =
  Type $ fromGenLocated $ fmap mkPrefixName name
#endif