1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
|
--------------------------------------------------------------------------------
-- | There are a number of steps that sort items: 'Imports' and 'ModuleHeader',
-- and maybe more in the future. This module provides consistent sorting
-- utilities.
{-# LANGUAGE LambdaCase #-}
module Language.Haskell.Stylish.Ordering
( compareImports
, compareLIE
, compareWrappedName
, compareOutputableCI
) where
--------------------------------------------------------------------------------
import Data.Char (isUpper, toLower)
import Data.Function (on)
import Data.Ord (comparing)
import GHC.Hs
import qualified GHC.Hs as GHC
import GHC.Types.SrcLoc (unLoc)
import GHC.Utils.Outputable (Outputable)
import qualified GHC.Utils.Outputable as GHC
import Language.Haskell.Stylish.GHC (showOutputable)
--------------------------------------------------------------------------------
-- | Compare imports for sorting. Cannot easily be a lawful instance due to
-- case insensitivity.
compareImports
:: GHC.ImportDecl GHC.GhcPs -> GHC.ImportDecl GHC.GhcPs -> Ordering
compareImports i0 i1 =
ideclName i0 `compareOutputableCI` ideclName i1 <>
showOutputable (ideclPkgQual i0) `compare`
showOutputable (ideclPkgQual i1) <>
compareOutputableCI i0 i1
--------------------------------------------------------------------------------
-- | NOTE: Can we get rid off this by adding a properly sorting newtype around
-- 'RdrName'?
compareLIE :: LIE GhcPs -> LIE GhcPs -> Ordering
compareLIE = comparing $ ieKey . unLoc
where
-- | The implementation is a bit hacky to get proper sorting for input specs:
-- constructors first, followed by functions, and then operators.
ieKey :: IE GhcPs -> (Int, String)
ieKey = \case
IEVar _ n -> nameKey n
IEThingAbs _ n -> nameKey n
IEThingAll _ n -> nameKey n
IEThingWith _ n _ _ -> nameKey n
IEModuleContents _ n -> nameKey n
_ -> (2, "")
--------------------------------------------------------------------------------
compareWrappedName :: IEWrappedName GhcPs -> IEWrappedName GhcPs -> Ordering
compareWrappedName = comparing nameKey
--------------------------------------------------------------------------------
nameKey :: Outputable name => name -> (Int, String)
nameKey n = case showOutputable n of
o@('(' : _) -> (2, o)
o@(o0 : _) | isUpper o0 -> (0, o)
o -> (1, o)
--------------------------------------------------------------------------------
compareOutputableCI :: GHC.Outputable a => a -> a -> Ordering
compareOutputableCI = compare `on` (map toLower . showOutputable)
|
