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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -Wno-missing-fields #-}
-- | Utility functions for working with the GHC AST
module Language.Haskell.Stylish.GHC
( dropAfterLocated
, dropBeforeLocated
, dropBeforeAndAfter
-- * Unsafe getters
, unsafeGetRealSrcSpan
, getEndLineUnsafe
, getStartLineUnsafe
-- * Standard settings
, baseDynFlags
-- * Positions
, unLocated
-- * Outputable operators
, showOutputable
, compareOutputable
) where
--------------------------------------------------------------------------------
import Data.Function (on)
--------------------------------------------------------------------------------
import DynFlags (Settings (..), defaultDynFlags)
import qualified DynFlags as GHC
import FileSettings (FileSettings (..))
import GHC.Fingerprint (fingerprint0)
import GHC.Platform
import GHC.Version (cProjectVersion)
import GhcNameVersion (GhcNameVersion (..))
import qualified Outputable as GHC
import PlatformConstants (PlatformConstants (..))
import SrcLoc (GenLocated (..), Located, RealLocated,
RealSrcSpan, SrcSpan (..), srcSpanEndLine,
srcSpanStartLine)
import ToolSettings (ToolSettings (..))
unsafeGetRealSrcSpan :: Located a -> RealSrcSpan
unsafeGetRealSrcSpan = \case
(L (RealSrcSpan s) _) -> s
_ -> error "could not get source code location"
getStartLineUnsafe :: Located a -> Int
getStartLineUnsafe = srcSpanStartLine . unsafeGetRealSrcSpan
getEndLineUnsafe :: Located a -> Int
getEndLineUnsafe = srcSpanEndLine . unsafeGetRealSrcSpan
dropAfterLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b]
dropAfterLocated loc xs = case loc of
Just (L (RealSrcSpan rloc) _) ->
filter (\(L x _) -> srcSpanEndLine rloc >= srcSpanStartLine x) xs
_ -> xs
dropBeforeLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b]
dropBeforeLocated loc xs = case loc of
Just (L (RealSrcSpan rloc) _) ->
filter (\(L x _) -> srcSpanStartLine rloc <= srcSpanEndLine x) xs
_ -> xs
dropBeforeAndAfter :: Located a -> [RealLocated b] -> [RealLocated b]
dropBeforeAndAfter loc = dropBeforeLocated (Just loc) . dropAfterLocated (Just loc)
baseDynFlags :: GHC.DynFlags
baseDynFlags = defaultDynFlags fakeSettings llvmConfig
where
fakeSettings = GHC.Settings
{ sGhcNameVersion = GhcNameVersion "stylish-haskell" cProjectVersion
, sFileSettings = FileSettings {}
, sToolSettings = ToolSettings
{ toolSettings_opt_P_fingerprint = fingerprint0,
toolSettings_pgm_F = ""
}
, sPlatformConstants = PlatformConstants
{ pc_DYNAMIC_BY_DEFAULT = False
, pc_WORD_SIZE = 8
}
, sTargetPlatform = Platform
{ platformMini = PlatformMini
{ platformMini_arch = ArchUnknown
, platformMini_os = OSUnknown
}
, platformWordSize = PW8
, platformUnregisterised = True
, platformHasIdentDirective = False
, platformHasSubsectionsViaSymbols = False
, platformIsCrossCompiling = False
}
, sPlatformMisc = PlatformMisc {}
, sRawSettings = []
}
llvmConfig = GHC.LlvmConfig [] []
unLocated :: Located a -> a
unLocated (L _ a) = a
showOutputable :: GHC.Outputable a => a -> String
showOutputable = GHC.showPpr baseDynFlags
compareOutputable :: GHC.Outputable a => a -> a -> Ordering
compareOutputable = compare `on` showOutputable
|
