From 36ddcc8ddb16e23af22db64214b44668880eb406 Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Tue, 25 Jan 2022 04:18:16 +0300
Subject: [PATCH 01/35] Initial: relax constraints till cabal is satisfied
---
brittany.cabal | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/brittany.cabal b/brittany.cabal
index ad87944..00eb0cd 100644
--- a/brittany.cabal
+++ b/brittany.cabal
@@ -39,9 +39,9 @@ flag pedantic
common library
build-depends:
, aeson ^>= 2.0.1
- , base ^>= 4.15.0
+ , base >= 4.15.0 && < 4.17
, butcher ^>= 1.3.3
- , bytestring ^>= 0.10.12
+ , bytestring >= 0.10.12
, cmdargs ^>= 0.10.21
, containers ^>= 0.6.4
, czipwith ^>= 1.0.1
@@ -50,10 +50,10 @@ common library
, directory ^>= 1.3.6
, extra ^>= 1.7.10
, filepath ^>= 1.4.2
- , ghc ^>= 9.0.1
- , ghc-boot ^>= 9.0.1
- , ghc-boot-th ^>= 9.0.1
- , ghc-exactprint ^>= 0.6.4
+ , ghc ^>= 9.2.1
+ , ghc-boot ^>= 9.2.1
+ , ghc-boot-th ^>= 9.2.1
+ , ghc-exactprint >= 0.6.4
, monad-memo ^>= 0.5.3
, mtl ^>= 2.2.2
, multistate ^>= 0.8.0
--
2.30.2
From f84d5f335698f8c15dbace8dcce524d267b4e1eb Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Tue, 25 Jan 2022 04:36:59 +0300
Subject: [PATCH 02/35] Roughly wrangle most of GHC.Settings moving to
GHC.Platform
---
.../Haskell/Brittany/Internal/ParseModule.hs | 346 +++++++++---------
1 file changed, 174 insertions(+), 172 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs
index 03f83a5..22611f9 100644
--- a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs
@@ -13,6 +13,8 @@ import qualified GHC.Driver.Session
import qualified GHC.Parser.Header
import qualified GHC.Platform
import qualified GHC.Settings
+import qualified GHC.Platform as PlatformSettings
+import qualified GHC.Settings as PlatformSettings
import qualified GHC.Types.SrcLoc
import qualified GHC.Utils.Error
import qualified GHC.Utils.Fingerprint
@@ -118,137 +120,137 @@ initialLlvmConfig = GHC.Driver.Session.LlvmConfig
, GHC.Driver.Session.llvmTargets = []
}
-initialPlatformConstants :: GHC.Settings.PlatformConstants
-initialPlatformConstants = GHC.Settings.PlatformConstants
- { GHC.Settings.pc_AP_STACK_SPLIM = 0
- , GHC.Settings.pc_BITMAP_BITS_SHIFT = 0
- , GHC.Settings.pc_BLOCK_SIZE = 0
- , GHC.Settings.pc_BLOCKS_PER_MBLOCK = 0
- , GHC.Settings.pc_CINT_SIZE = 0
- , GHC.Settings.pc_CLONG_LONG_SIZE = 0
- , GHC.Settings.pc_CLONG_SIZE = 0
- , GHC.Settings.pc_CONTROL_GROUP_CONST_291 = 0
- , GHC.Settings.pc_DYNAMIC_BY_DEFAULT = False
- , GHC.Settings.pc_ILDV_CREATE_MASK = 0
- , GHC.Settings.pc_ILDV_STATE_CREATE = 0
- , GHC.Settings.pc_ILDV_STATE_USE = 0
- , GHC.Settings.pc_LDV_SHIFT = 0
- , GHC.Settings.pc_MAX_CHARLIKE = 0
- , GHC.Settings.pc_MAX_Double_REG = 0
- , GHC.Settings.pc_MAX_Float_REG = 0
- , GHC.Settings.pc_MAX_INTLIKE = 0
- , GHC.Settings.pc_MAX_Long_REG = 0
- , GHC.Settings.pc_MAX_Real_Double_REG = 0
- , GHC.Settings.pc_MAX_Real_Float_REG = 0
- , GHC.Settings.pc_MAX_Real_Long_REG = 0
- , GHC.Settings.pc_MAX_Real_Vanilla_REG = 0
- , GHC.Settings.pc_MAX_Real_XMM_REG = 0
- , GHC.Settings.pc_MAX_SPEC_AP_SIZE = 0
- , GHC.Settings.pc_MAX_SPEC_SELECTEE_SIZE = 0
- , GHC.Settings.pc_MAX_Vanilla_REG = 0
- , GHC.Settings.pc_MAX_XMM_REG = 0
- , GHC.Settings.pc_MIN_CHARLIKE = 0
- , GHC.Settings.pc_MIN_INTLIKE = 0
- , GHC.Settings.pc_MIN_PAYLOAD_SIZE = 0
- , GHC.Settings.pc_MUT_ARR_PTRS_CARD_BITS = 0
- , GHC.Settings.pc_OFFSET_bdescr_blocks = 0
- , GHC.Settings.pc_OFFSET_bdescr_flags = 0
- , GHC.Settings.pc_OFFSET_bdescr_free = 0
- , GHC.Settings.pc_OFFSET_bdescr_start = 0
- , GHC.Settings.pc_OFFSET_Capability_r = 0
- , GHC.Settings.pc_OFFSET_CostCentreStack_mem_alloc = 0
- , GHC.Settings.pc_OFFSET_CostCentreStack_scc_count = 0
- , GHC.Settings.pc_OFFSET_StgArrBytes_bytes = 0
- , GHC.Settings.pc_OFFSET_stgEagerBlackholeInfo = 0
- , GHC.Settings.pc_OFFSET_StgEntCounter_allocd = 0
- , GHC.Settings.pc_OFFSET_StgEntCounter_allocs = 0
- , GHC.Settings.pc_OFFSET_StgEntCounter_entry_count = 0
- , GHC.Settings.pc_OFFSET_StgEntCounter_link = 0
- , GHC.Settings.pc_OFFSET_StgEntCounter_registeredp = 0
- , GHC.Settings.pc_OFFSET_StgFunInfoExtraFwd_arity = 0
- , GHC.Settings.pc_OFFSET_StgFunInfoExtraRev_arity = 0
- , GHC.Settings.pc_OFFSET_stgGCEnter1 = 0
- , GHC.Settings.pc_OFFSET_stgGCFun = 0
- , GHC.Settings.pc_OFFSET_StgHeader_ccs = 0
- , GHC.Settings.pc_OFFSET_StgHeader_ldvw = 0
- , GHC.Settings.pc_OFFSET_StgMutArrPtrs_ptrs = 0
- , GHC.Settings.pc_OFFSET_StgMutArrPtrs_size = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rCCCS = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rCurrentNursery = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rCurrentTSO = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rD1 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rD2 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rD3 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rD4 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rD5 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rD6 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rF1 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rF2 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rF3 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rF4 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rF5 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rF6 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rHp = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rHpAlloc = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rHpLim = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rL1 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rR1 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rR10 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rR2 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rR3 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rR4 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rR5 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rR6 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rR7 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rR8 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rR9 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rSp = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rSpLim = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rXMM1 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rXMM2 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rXMM3 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rXMM4 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rXMM5 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rXMM6 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rYMM1 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rYMM2 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rYMM3 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rYMM4 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rYMM5 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rYMM6 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rZMM1 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rZMM2 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rZMM3 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rZMM4 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rZMM5 = 0
- , GHC.Settings.pc_OFFSET_StgRegTable_rZMM6 = 0
- , GHC.Settings.pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0
- , GHC.Settings.pc_OFFSET_StgStack_sp = 0
- , GHC.Settings.pc_OFFSET_StgStack_stack = 0
- , GHC.Settings.pc_OFFSET_StgTSO_alloc_limit = 0
- , GHC.Settings.pc_OFFSET_StgTSO_cccs = 0
- , GHC.Settings.pc_OFFSET_StgTSO_stackobj = 0
- , GHC.Settings.pc_OFFSET_StgUpdateFrame_updatee = 0
- , GHC.Settings.pc_PROF_HDR_SIZE = 0
- , GHC.Settings.pc_REP_CostCentreStack_mem_alloc = 0
- , GHC.Settings.pc_REP_CostCentreStack_scc_count = 0
- , GHC.Settings.pc_REP_StgEntCounter_allocd = 0
- , GHC.Settings.pc_REP_StgEntCounter_allocs = 0
- , GHC.Settings.pc_REP_StgFunInfoExtraFwd_arity = 0
- , GHC.Settings.pc_REP_StgFunInfoExtraRev_arity = 0
- , GHC.Settings.pc_RESERVED_C_STACK_BYTES = 0
- , GHC.Settings.pc_RESERVED_STACK_WORDS = 0
- , GHC.Settings.pc_SIZEOF_CostCentreStack = 0
- , GHC.Settings.pc_SIZEOF_StgArrBytes_NoHdr = 0
- , GHC.Settings.pc_SIZEOF_StgFunInfoExtraRev = 0
- , GHC.Settings.pc_SIZEOF_StgMutArrPtrs_NoHdr = 0
- , GHC.Settings.pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 0
- , GHC.Settings.pc_SIZEOF_StgSMPThunkHeader = 0
- , GHC.Settings.pc_SIZEOF_StgUpdateFrame_NoHdr = 0
- , GHC.Settings.pc_STD_HDR_SIZE = 0
- , GHC.Settings.pc_TAG_BITS = 0
- , GHC.Settings.pc_TICKY_BIN_COUNT = 0
- , GHC.Settings.pc_WORD_SIZE = 0
+initialPlatformConstants :: PlatformSettings.PlatformConstants
+initialPlatformConstants = PlatformSettings.PlatformConstants
+ { PlatformSettings.pc_AP_STACK_SPLIM = 0
+ , PlatformSettings.pc_BITMAP_BITS_SHIFT = 0
+ , PlatformSettings.pc_BLOCK_SIZE = 0
+ , PlatformSettings.pc_BLOCKS_PER_MBLOCK = 0
+ , PlatformSettings.pc_CINT_SIZE = 0
+ , PlatformSettings.pc_CLONG_LONG_SIZE = 0
+ , PlatformSettings.pc_CLONG_SIZE = 0
+ , PlatformSettings.pc_CONTROL_GROUP_CONST_291 = 0
+ , PlatformSettings.pc_DYNAMIC_BY_DEFAULT = False
+ , PlatformSettings.pc_ILDV_CREATE_MASK = 0
+ , PlatformSettings.pc_ILDV_STATE_CREATE = 0
+ , PlatformSettings.pc_ILDV_STATE_USE = 0
+ , PlatformSettings.pc_LDV_SHIFT = 0
+ , PlatformSettings.pc_MAX_CHARLIKE = 0
+ , PlatformSettings.pc_MAX_Double_REG = 0
+ , PlatformSettings.pc_MAX_Float_REG = 0
+ , PlatformSettings.pc_MAX_INTLIKE = 0
+ , PlatformSettings.pc_MAX_Long_REG = 0
+ , PlatformSettings.pc_MAX_Real_Double_REG = 0
+ , PlatformSettings.pc_MAX_Real_Float_REG = 0
+ , PlatformSettings.pc_MAX_Real_Long_REG = 0
+ , PlatformSettings.pc_MAX_Real_Vanilla_REG = 0
+ , PlatformSettings.pc_MAX_Real_XMM_REG = 0
+ , PlatformSettings.pc_MAX_SPEC_AP_SIZE = 0
+ , PlatformSettings.pc_MAX_SPEC_SELECTEE_SIZE = 0
+ , PlatformSettings.pc_MAX_Vanilla_REG = 0
+ , PlatformSettings.pc_MAX_XMM_REG = 0
+ , PlatformSettings.pc_MIN_CHARLIKE = 0
+ , PlatformSettings.pc_MIN_INTLIKE = 0
+ , PlatformSettings.pc_MIN_PAYLOAD_SIZE = 0
+ , PlatformSettings.pc_MUT_ARR_PTRS_CARD_BITS = 0
+ , PlatformSettings.pc_OFFSET_bdescr_blocks = 0
+ , PlatformSettings.pc_OFFSET_bdescr_flags = 0
+ , PlatformSettings.pc_OFFSET_bdescr_free = 0
+ , PlatformSettings.pc_OFFSET_bdescr_start = 0
+ , PlatformSettings.pc_OFFSET_Capability_r = 0
+ , PlatformSettings.pc_OFFSET_CostCentreStack_mem_alloc = 0
+ , PlatformSettings.pc_OFFSET_CostCentreStack_scc_count = 0
+ , PlatformSettings.pc_OFFSET_StgArrBytes_bytes = 0
+ , PlatformSettings.pc_OFFSET_stgEagerBlackholeInfo = 0
+ , PlatformSettings.pc_OFFSET_StgEntCounter_allocd = 0
+ , PlatformSettings.pc_OFFSET_StgEntCounter_allocs = 0
+ , PlatformSettings.pc_OFFSET_StgEntCounter_entry_count = 0
+ , PlatformSettings.pc_OFFSET_StgEntCounter_link = 0
+ , PlatformSettings.pc_OFFSET_StgEntCounter_registeredp = 0
+ , PlatformSettings.pc_OFFSET_StgFunInfoExtraFwd_arity = 0
+ , PlatformSettings.pc_OFFSET_StgFunInfoExtraRev_arity = 0
+ , PlatformSettings.pc_OFFSET_stgGCEnter1 = 0
+ , PlatformSettings.pc_OFFSET_stgGCFun = 0
+ , PlatformSettings.pc_OFFSET_StgHeader_ccs = 0
+ , PlatformSettings.pc_OFFSET_StgHeader_ldvw = 0
+ , PlatformSettings.pc_OFFSET_StgMutArrPtrs_ptrs = 0
+ , PlatformSettings.pc_OFFSET_StgMutArrPtrs_size = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rCCCS = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rCurrentNursery = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rCurrentTSO = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rD1 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rD2 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rD3 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rD4 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rD5 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rD6 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rF1 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rF2 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rF3 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rF4 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rF5 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rF6 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rHp = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rHpAlloc = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rHpLim = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rL1 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rR1 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rR10 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rR2 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rR3 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rR4 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rR5 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rR6 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rR7 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rR8 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rR9 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rSp = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rSpLim = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rXMM1 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rXMM2 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rXMM3 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rXMM4 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rXMM5 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rXMM6 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rYMM1 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rYMM2 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rYMM3 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rYMM4 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rYMM5 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rYMM6 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rZMM1 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rZMM2 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rZMM3 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rZMM4 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rZMM5 = 0
+ , PlatformSettings.pc_OFFSET_StgRegTable_rZMM6 = 0
+ , PlatformSettings.pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0
+ , PlatformSettings.pc_OFFSET_StgStack_sp = 0
+ , PlatformSettings.pc_OFFSET_StgStack_stack = 0
+ , PlatformSettings.pc_OFFSET_StgTSO_alloc_limit = 0
+ , PlatformSettings.pc_OFFSET_StgTSO_cccs = 0
+ , PlatformSettings.pc_OFFSET_StgTSO_stackobj = 0
+ , PlatformSettings.pc_OFFSET_StgUpdateFrame_updatee = 0
+ , PlatformSettings.pc_PROF_HDR_SIZE = 0
+ , PlatformSettings.pc_REP_CostCentreStack_mem_alloc = 0
+ , PlatformSettings.pc_REP_CostCentreStack_scc_count = 0
+ , PlatformSettings.pc_REP_StgEntCounter_allocd = 0
+ , PlatformSettings.pc_REP_StgEntCounter_allocs = 0
+ , PlatformSettings.pc_REP_StgFunInfoExtraFwd_arity = 0
+ , PlatformSettings.pc_REP_StgFunInfoExtraRev_arity = 0
+ , PlatformSettings.pc_RESERVED_C_STACK_BYTES = 0
+ , PlatformSettings.pc_RESERVED_STACK_WORDS = 0
+ , PlatformSettings.pc_SIZEOF_CostCentreStack = 0
+ , PlatformSettings.pc_SIZEOF_StgArrBytes_NoHdr = 0
+ , PlatformSettings.pc_SIZEOF_StgFunInfoExtraRev = 0
+ , PlatformSettings.pc_SIZEOF_StgMutArrPtrs_NoHdr = 0
+ , PlatformSettings.pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 0
+ , PlatformSettings.pc_SIZEOF_StgSMPThunkHeader = 0
+ , PlatformSettings.pc_SIZEOF_StgUpdateFrame_NoHdr = 0
+ , PlatformSettings.pc_STD_HDR_SIZE = 0
+ , PlatformSettings.pc_TAG_BITS = 0
+ , PlatformSettings.pc_TICKY_BIN_COUNT = 0
+ , PlatformSettings.pc_WORD_SIZE = 0
}
initialPlatformMini :: GHC.Settings.PlatformMini
@@ -271,46 +273,46 @@ initialTargetPlatform = GHC.Settings.Platform
, GHC.Settings.platformWordSize = GHC.Platform.PW8
}
-initialToolSettings :: GHC.Settings.ToolSettings
-initialToolSettings = GHC.Settings.ToolSettings
- { GHC.Settings.toolSettings_ccSupportsNoPie = False
- , GHC.Settings.toolSettings_extraGccViaCFlags = []
- , GHC.Settings.toolSettings_ldIsGnuLd = False
- , GHC.Settings.toolSettings_ldSupportsBuildId = False
- , GHC.Settings.toolSettings_ldSupportsCompactUnwind = False
- , GHC.Settings.toolSettings_ldSupportsFilelist = False
- , GHC.Settings.toolSettings_opt_a = []
- , GHC.Settings.toolSettings_opt_c = []
- , GHC.Settings.toolSettings_opt_cxx = []
- , GHC.Settings.toolSettings_opt_F = []
- , GHC.Settings.toolSettings_opt_i = []
- , GHC.Settings.toolSettings_opt_l = []
- , GHC.Settings.toolSettings_opt_L = []
- , GHC.Settings.toolSettings_opt_lc = []
- , GHC.Settings.toolSettings_opt_lcc = []
- , GHC.Settings.toolSettings_opt_lm = []
- , GHC.Settings.toolSettings_opt_lo = []
- , GHC.Settings.toolSettings_opt_P = []
- , GHC.Settings.toolSettings_opt_P_fingerprint =
+initialToolSettings :: PlatformSettings.ToolSettings
+initialToolSettings = PlatformSettings.ToolSettings
+ { PlatformSettings.toolSettings_ccSupportsNoPie = False
+ , PlatformSettings.toolSettings_extraGccViaCFlags = []
+ , PlatformSettings.toolSettings_ldIsGnuLd = False
+ , PlatformSettings.toolSettings_ldSupportsBuildId = False
+ , PlatformSettings.toolSettings_ldSupportsCompactUnwind = False
+ , PlatformSettings.toolSettings_ldSupportsFilelist = False
+ , PlatformSettings.toolSettings_opt_a = []
+ , PlatformSettings.toolSettings_opt_c = []
+ , PlatformSettings.toolSettings_opt_cxx = []
+ , PlatformSettings.toolSettings_opt_F = []
+ , PlatformSettings.toolSettings_opt_i = []
+ , PlatformSettings.toolSettings_opt_l = []
+ , PlatformSettings.toolSettings_opt_L = []
+ , PlatformSettings.toolSettings_opt_lc = []
+ , PlatformSettings.toolSettings_opt_lcc = []
+ , PlatformSettings.toolSettings_opt_lm = []
+ , PlatformSettings.toolSettings_opt_lo = []
+ , PlatformSettings.toolSettings_opt_P = []
+ , PlatformSettings.toolSettings_opt_P_fingerprint =
GHC.Utils.Fingerprint.fingerprint0
- , GHC.Settings.toolSettings_opt_windres = []
- , GHC.Settings.toolSettings_pgm_a = ("", [])
- , GHC.Settings.toolSettings_pgm_ar = ""
- , GHC.Settings.toolSettings_pgm_c = ""
- , GHC.Settings.toolSettings_pgm_dll = ("", [])
- , GHC.Settings.toolSettings_pgm_F = ""
- , GHC.Settings.toolSettings_pgm_i = ""
- , GHC.Settings.toolSettings_pgm_install_name_tool = ""
- , GHC.Settings.toolSettings_pgm_l = ("", [])
- , GHC.Settings.toolSettings_pgm_L = ""
- , GHC.Settings.toolSettings_pgm_lc = ("", [])
- , GHC.Settings.toolSettings_pgm_lcc = ("", [])
- , GHC.Settings.toolSettings_pgm_libtool = ""
- , GHC.Settings.toolSettings_pgm_lm = ("", [])
- , GHC.Settings.toolSettings_pgm_lo = ("", [])
- , GHC.Settings.toolSettings_pgm_otool = ""
- , GHC.Settings.toolSettings_pgm_P = ("", [])
- , GHC.Settings.toolSettings_pgm_ranlib = ""
- , GHC.Settings.toolSettings_pgm_T = ""
- , GHC.Settings.toolSettings_pgm_windres = ""
+ , PlatformSettings.toolSettings_opt_windres = []
+ , PlatformSettings.toolSettings_pgm_a = ("", [])
+ , PlatformSettings.toolSettings_pgm_ar = ""
+ , PlatformSettings.toolSettings_pgm_c = ""
+ , PlatformSettings.toolSettings_pgm_dll = ("", [])
+ , PlatformSettings.toolSettings_pgm_F = ""
+ , PlatformSettings.toolSettings_pgm_i = ""
+ , PlatformSettings.toolSettings_pgm_install_name_tool = ""
+ , PlatformSettings.toolSettings_pgm_l = ("", [])
+ , PlatformSettings.toolSettings_pgm_L = ""
+ , PlatformSettings.toolSettings_pgm_lc = ("", [])
+ , PlatformSettings.toolSettings_pgm_lcc = ("", [])
+ , PlatformSettings.toolSettings_pgm_libtool = ""
+ , PlatformSettings.toolSettings_pgm_lm = ("", [])
+ , PlatformSettings.toolSettings_pgm_lo = ("", [])
+ , PlatformSettings.toolSettings_pgm_otool = ""
+ , PlatformSettings.toolSettings_pgm_P = ("", [])
+ , PlatformSettings.toolSettings_pgm_ranlib = ""
+ , PlatformSettings.toolSettings_pgm_T = ""
+ , PlatformSettings.toolSettings_pgm_windres = ""
}
--
2.30.2
From 97edab50e8a3486feb5cb5bdba1fb9043a626c27 Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Tue, 25 Jan 2022 19:38:02 +0300
Subject: [PATCH 03/35] Fix PlatformMini ~> ArchOS
---
.../Haskell/Brittany/Internal/ParseModule.hs | 13 +++++++++++++
1 file changed, 13 insertions(+)
diff --git a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs
index 22611f9..6ef2bcd 100644
--- a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-implicit-prelude #-}
module Language.Haskell.Brittany.Internal.ParseModule where
@@ -253,11 +254,19 @@ initialPlatformConstants = PlatformSettings.PlatformConstants
, PlatformSettings.pc_WORD_SIZE = 0
}
+#if MIN_VERSION_ghc(9,2,1)
+initialPlatformArchOS :: GHC.Platform.ArchOS
+initialPlatformArchOS = GHC.Platform.ArchOS
+ { GHC.Platform.archOS_arch = GHC.Platform.ArchX86_64
+ , GHC.Platform.archOS_OS = GHC.Platform.OSLinux
+ }
+#else
initialPlatformMini :: GHC.Settings.PlatformMini
initialPlatformMini = GHC.Settings.PlatformMini
{ GHC.Settings.platformMini_arch = GHC.Platform.ArchX86_64
, GHC.Settings.platformMini_os = GHC.Platform.OSLinux
}
+#endif
initialTargetPlatform :: GHC.Settings.Platform
initialTargetPlatform = GHC.Settings.Platform
@@ -267,7 +276,11 @@ initialTargetPlatform = GHC.Settings.Platform
, GHC.Settings.platformHasSubsectionsViaSymbols = False
, GHC.Settings.platformIsCrossCompiling = False
, GHC.Settings.platformLeadingUnderscore = False
+#if MIN_VERSION_ghc(9,2,1)
+ , GHC.Settings.platformArchOS = initialPlatformArchOS
+#else
, GHC.Settings.platformMini = initialPlatformMini
+#endif
, GHC.Settings.platformTablesNextToCode = False
, GHC.Settings.platformUnregisterised = False
, GHC.Settings.platformWordSize = GHC.Platform.PW8
--
2.30.2
From 128e19be2b98f499aa0558b4e1ae4a83e51f270e Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Tue, 25 Jan 2022 19:41:26 +0300
Subject: [PATCH 04/35] Conditionalize PlatformSettings; revert overzealous
migration of toolSettings
---
.../Haskell/Brittany/Internal/ParseModule.hs | 85 ++++++++++---------
1 file changed, 44 insertions(+), 41 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs
index 6ef2bcd..fc7195f 100644
--- a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs
@@ -14,8 +14,11 @@ import qualified GHC.Driver.Session
import qualified GHC.Parser.Header
import qualified GHC.Platform
import qualified GHC.Settings
+#if MIN_VERSION_ghc(9,2,1)
import qualified GHC.Platform as PlatformSettings
+#else
import qualified GHC.Settings as PlatformSettings
+#endif
import qualified GHC.Types.SrcLoc
import qualified GHC.Utils.Error
import qualified GHC.Utils.Fingerprint
@@ -286,46 +289,46 @@ initialTargetPlatform = GHC.Settings.Platform
, GHC.Settings.platformWordSize = GHC.Platform.PW8
}
-initialToolSettings :: PlatformSettings.ToolSettings
-initialToolSettings = PlatformSettings.ToolSettings
- { PlatformSettings.toolSettings_ccSupportsNoPie = False
- , PlatformSettings.toolSettings_extraGccViaCFlags = []
- , PlatformSettings.toolSettings_ldIsGnuLd = False
- , PlatformSettings.toolSettings_ldSupportsBuildId = False
- , PlatformSettings.toolSettings_ldSupportsCompactUnwind = False
- , PlatformSettings.toolSettings_ldSupportsFilelist = False
- , PlatformSettings.toolSettings_opt_a = []
- , PlatformSettings.toolSettings_opt_c = []
- , PlatformSettings.toolSettings_opt_cxx = []
- , PlatformSettings.toolSettings_opt_F = []
- , PlatformSettings.toolSettings_opt_i = []
- , PlatformSettings.toolSettings_opt_l = []
- , PlatformSettings.toolSettings_opt_L = []
- , PlatformSettings.toolSettings_opt_lc = []
- , PlatformSettings.toolSettings_opt_lcc = []
- , PlatformSettings.toolSettings_opt_lm = []
- , PlatformSettings.toolSettings_opt_lo = []
- , PlatformSettings.toolSettings_opt_P = []
- , PlatformSettings.toolSettings_opt_P_fingerprint =
+initialToolSettings :: GHC.Settings.ToolSettings
+initialToolSettings = GHC.Settings.ToolSettings
+ { GHC.Settings.toolSettings_ccSupportsNoPie = False
+ , GHC.Settings.toolSettings_extraGccViaCFlags = []
+ , GHC.Settings.toolSettings_ldIsGnuLd = False
+ , GHC.Settings.toolSettings_ldSupportsBuildId = False
+ , GHC.Settings.toolSettings_ldSupportsCompactUnwind = False
+ , GHC.Settings.toolSettings_ldSupportsFilelist = False
+ , GHC.Settings.toolSettings_opt_a = []
+ , GHC.Settings.toolSettings_opt_c = []
+ , GHC.Settings.toolSettings_opt_cxx = []
+ , GHC.Settings.toolSettings_opt_F = []
+ , GHC.Settings.toolSettings_opt_i = []
+ , GHC.Settings.toolSettings_opt_l = []
+ , GHC.Settings.toolSettings_opt_L = []
+ , GHC.Settings.toolSettings_opt_lc = []
+ , GHC.Settings.toolSettings_opt_lcc = []
+ , GHC.Settings.toolSettings_opt_lm = []
+ , GHC.Settings.toolSettings_opt_lo = []
+ , GHC.Settings.toolSettings_opt_P = []
+ , GHC.Settings.toolSettings_opt_P_fingerprint =
GHC.Utils.Fingerprint.fingerprint0
- , PlatformSettings.toolSettings_opt_windres = []
- , PlatformSettings.toolSettings_pgm_a = ("", [])
- , PlatformSettings.toolSettings_pgm_ar = ""
- , PlatformSettings.toolSettings_pgm_c = ""
- , PlatformSettings.toolSettings_pgm_dll = ("", [])
- , PlatformSettings.toolSettings_pgm_F = ""
- , PlatformSettings.toolSettings_pgm_i = ""
- , PlatformSettings.toolSettings_pgm_install_name_tool = ""
- , PlatformSettings.toolSettings_pgm_l = ("", [])
- , PlatformSettings.toolSettings_pgm_L = ""
- , PlatformSettings.toolSettings_pgm_lc = ("", [])
- , PlatformSettings.toolSettings_pgm_lcc = ("", [])
- , PlatformSettings.toolSettings_pgm_libtool = ""
- , PlatformSettings.toolSettings_pgm_lm = ("", [])
- , PlatformSettings.toolSettings_pgm_lo = ("", [])
- , PlatformSettings.toolSettings_pgm_otool = ""
- , PlatformSettings.toolSettings_pgm_P = ("", [])
- , PlatformSettings.toolSettings_pgm_ranlib = ""
- , PlatformSettings.toolSettings_pgm_T = ""
- , PlatformSettings.toolSettings_pgm_windres = ""
+ , GHC.Settings.toolSettings_opt_windres = []
+ , GHC.Settings.toolSettings_pgm_a = ("", [])
+ , GHC.Settings.toolSettings_pgm_ar = ""
+ , GHC.Settings.toolSettings_pgm_c = ""
+ , GHC.Settings.toolSettings_pgm_dll = ("", [])
+ , GHC.Settings.toolSettings_pgm_F = ""
+ , GHC.Settings.toolSettings_pgm_i = ""
+ , GHC.Settings.toolSettings_pgm_install_name_tool = ""
+ , GHC.Settings.toolSettings_pgm_l = ("", [])
+ , GHC.Settings.toolSettings_pgm_L = ""
+ , GHC.Settings.toolSettings_pgm_lc = ("", [])
+ , GHC.Settings.toolSettings_pgm_lcc = ("", [])
+ , GHC.Settings.toolSettings_pgm_libtool = ""
+ , GHC.Settings.toolSettings_pgm_lm = ("", [])
+ , GHC.Settings.toolSettings_pgm_lo = ("", [])
+ , GHC.Settings.toolSettings_pgm_otool = ""
+ , GHC.Settings.toolSettings_pgm_P = ("", [])
+ , GHC.Settings.toolSettings_pgm_ranlib = ""
+ , GHC.Settings.toolSettings_pgm_T = ""
+ , GHC.Settings.toolSettings_pgm_windres = ""
}
--
2.30.2
From dde016f5fe09405e969bc5f1be7f105cb2ccac0f Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Tue, 25 Jan 2022 19:51:27 +0300
Subject: [PATCH 05/35] Fix other ghc-9.2.1 field and type migrations in
ParseModule
---
.../Haskell/Brittany/Internal/ParseModule.hs | 18 +++++++++++++++---
1 file changed, 15 insertions(+), 3 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs
index fc7195f..cca412d 100644
--- a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs
@@ -15,6 +15,7 @@ import qualified GHC.Parser.Header
import qualified GHC.Platform
import qualified GHC.Settings
#if MIN_VERSION_ghc(9,2,1)
+import qualified GHC.Types.SafeHaskell
import qualified GHC.Platform as PlatformSettings
#else
import qualified GHC.Settings as PlatformSettings
@@ -42,7 +43,12 @@ parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do
-- Neither passing in @"-XUnsafe"@ as a command line argument nor having
-- @{-# LANGUAGE Unsafe #-}@ in the source file seem to help.
initialDynFlags
- { GHC.Driver.Session.safeHaskell = GHC.Driver.Session.Sf_Unsafe
+ { GHC.Driver.Session.safeHaskell =
+#if MIN_VERSION_ghc(9,2,1)
+ GHC.Types.SafeHaskell.Sf_Unsafe
+#else
+ GHC.Driver.Session.Sf_Unsafe
+#endif
}
GHC.Driver.Session.Opt_KeepRawTokenStream
(dynFlags2, leftovers1, _) <-
@@ -85,7 +91,9 @@ initialSettings = GHC.Driver.Session.Settings
, GHC.Driver.Session.sTargetPlatform = initialTargetPlatform
, GHC.Driver.Session.sToolSettings = initialToolSettings
, GHC.Driver.Session.sPlatformMisc = initialPlatformMisc
+#if !MIN_VERSION_ghc(9,2,1)
, GHC.Driver.Session.sPlatformConstants = initialPlatformConstants
+#endif
, GHC.Driver.Session.sRawSettings = []
}
@@ -107,10 +115,12 @@ initialGhcNameVersion = GHC.Driver.Session.GhcNameVersion
initialPlatformMisc :: GHC.Driver.Session.PlatformMisc
initialPlatformMisc = GHC.Driver.Session.PlatformMisc
- { GHC.Driver.Session.platformMisc_ghcDebugged = False
- , GHC.Driver.Session.platformMisc_ghcRTSWays = ""
+ { GHC.Driver.Session.platformMisc_ghcRTSWays = ""
, GHC.Driver.Session.platformMisc_ghcRtsWithLibdw = False
+#if !MIN_VERSION_ghc(9,2,1)
, GHC.Driver.Session.platformMisc_ghcThreaded = False
+ , GHC.Driver.Session.platformMisc_ghcDebugged = False
+#endif
, GHC.Driver.Session.platformMisc_ghcWithInterpreter = False
, GHC.Driver.Session.platformMisc_ghcWithSMP = False
, GHC.Driver.Session.platformMisc_libFFI = False
@@ -134,7 +144,9 @@ initialPlatformConstants = PlatformSettings.PlatformConstants
, PlatformSettings.pc_CLONG_LONG_SIZE = 0
, PlatformSettings.pc_CLONG_SIZE = 0
, PlatformSettings.pc_CONTROL_GROUP_CONST_291 = 0
+#if !MIN_VERSION_ghc(9,2,1)
, PlatformSettings.pc_DYNAMIC_BY_DEFAULT = False
+#endif
, PlatformSettings.pc_ILDV_CREATE_MASK = 0
, PlatformSettings.pc_ILDV_STATE_CREATE = 0
, PlatformSettings.pc_ILDV_STATE_USE = 0
--
2.30.2
From 2fd0b861dd54730e1510ba4ec111cf1a88e13ede Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Tue, 25 Jan 2022 19:58:15 +0300
Subject: [PATCH 06/35] Finish ParseModule
---
.../Language/Haskell/Brittany/Internal/ParseModule.hs | 9 +++++++++
1 file changed, 9 insertions(+)
diff --git a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs
index cca412d..fe37a9a 100644
--- a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs
@@ -34,7 +34,11 @@ parseModule
-> FilePath
-> (GHC.Driver.Session.DynFlags -> io (Either String a))
-> String
+#if MIN_VERSION_ghc(9,2,1)
+ -> io (Either String (GHC.ParsedSource, a))
+#else
-> io (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
+#endif
parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do
let
dynFlags1 = GHC.Driver.Session.gopt_set
@@ -68,7 +72,11 @@ parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do
ExactPrint.parseModuleFromStringInternal dynFlags3 filePath string
case parseResult of
Left errorMessages -> handleErrorMessages errorMessages
+#if MIN_VERSION_ghc(9,2,1)
+ Right parsedSource -> pure (parsedSource, dynFlagsResult)
+#else
Right (anns, parsedSource) -> pure (anns, parsedSource, dynFlagsResult)
+#endif
handleLeftovers
:: Monad m => [GHC.Types.SrcLoc.Located String] -> Except.ExceptT String m ()
@@ -293,6 +301,7 @@ initialTargetPlatform = GHC.Settings.Platform
, GHC.Settings.platformLeadingUnderscore = False
#if MIN_VERSION_ghc(9,2,1)
, GHC.Settings.platformArchOS = initialPlatformArchOS
+ , GHC.Settings.platform_constants = Just initialPlatformConstants
#else
, GHC.Settings.platformMini = initialPlatformMini
#endif
--
2.30.2
From af2781b672e54e1ee9294781df14367242a4e276 Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Tue, 25 Jan 2022 20:16:38 +0300
Subject: [PATCH 07/35] Make build-depends constraints shippable
---
brittany.cabal | 10 +++++-----
1 file changed, 5 insertions(+), 5 deletions(-)
diff --git a/brittany.cabal b/brittany.cabal
index 00eb0cd..21a95ca 100644
--- a/brittany.cabal
+++ b/brittany.cabal
@@ -41,7 +41,7 @@ common library
, aeson ^>= 2.0.1
, base >= 4.15.0 && < 4.17
, butcher ^>= 1.3.3
- , bytestring >= 0.10.12
+ , bytestring >= 0.10.12 && < 0.12
, cmdargs ^>= 0.10.21
, containers ^>= 0.6.4
, czipwith ^>= 1.0.1
@@ -50,10 +50,10 @@ common library
, directory ^>= 1.3.6
, extra ^>= 1.7.10
, filepath ^>= 1.4.2
- , ghc ^>= 9.2.1
- , ghc-boot ^>= 9.2.1
- , ghc-boot-th ^>= 9.2.1
- , ghc-exactprint >= 0.6.4
+ , ghc >= 9.0.1 && < 9.4
+ , ghc-boot >= 9.0.1 && < 9.4
+ , ghc-boot-th >= 9.0.1 && < 9.4
+ , ghc-exactprint >= 0.6.4 && < 2
, monad-memo ^>= 0.5.3
, mtl ^>= 2.2.2
, multistate ^>= 0.8.0
--
2.30.2
From 00461993062162f44f20010f2138626016ce91ad Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Fri, 28 Jan 2022 21:02:41 +0300
Subject: [PATCH 08/35] Drop ghc-9.0 support (relegated to a branch)
---
brittany.cabal | 12 +-
.../Haskell/Brittany/Internal/ParseModule.hs | 304 ++++++++----------
2 files changed, 137 insertions(+), 179 deletions(-)
diff --git a/brittany.cabal b/brittany.cabal
index 21a95ca..35bf75d 100644
--- a/brittany.cabal
+++ b/brittany.cabal
@@ -39,9 +39,9 @@ flag pedantic
common library
build-depends:
, aeson ^>= 2.0.1
- , base >= 4.15.0 && < 4.17
+ , base ^>= 4.16.0
, butcher ^>= 1.3.3
- , bytestring >= 0.10.12 && < 0.12
+ , bytestring ^>= 0.11
, cmdargs ^>= 0.10.21
, containers ^>= 0.6.4
, czipwith ^>= 1.0.1
@@ -50,10 +50,10 @@ common library
, directory ^>= 1.3.6
, extra ^>= 1.7.10
, filepath ^>= 1.4.2
- , ghc >= 9.0.1 && < 9.4
- , ghc-boot >= 9.0.1 && < 9.4
- , ghc-boot-th >= 9.0.1 && < 9.4
- , ghc-exactprint >= 0.6.4 && < 2
+ , ghc ^>= 9.2.1
+ , ghc-boot ^>= 9.2.1
+ , ghc-boot-th ^>= 9.2.1
+ , ghc-exactprint ^>= 1.4
, monad-memo ^>= 0.5.3
, mtl ^>= 2.2.2
, multistate ^>= 0.8.0
diff --git a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs
index fe37a9a..22dc596 100644
--- a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-implicit-prelude #-}
module Language.Haskell.Brittany.Internal.ParseModule where
@@ -14,17 +13,11 @@ import qualified GHC.Driver.Session
import qualified GHC.Parser.Header
import qualified GHC.Platform
import qualified GHC.Settings
-#if MIN_VERSION_ghc(9,2,1)
import qualified GHC.Types.SafeHaskell
-import qualified GHC.Platform as PlatformSettings
-#else
-import qualified GHC.Settings as PlatformSettings
-#endif
import qualified GHC.Types.SrcLoc
import qualified GHC.Utils.Error
import qualified GHC.Utils.Fingerprint
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint
-import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
-- | Parses a Haskell module. Although this nominally requires IO, it is
-- morally pure. It should have no observable effects.
@@ -34,11 +27,7 @@ parseModule
-> FilePath
-> (GHC.Driver.Session.DynFlags -> io (Either String a))
-> String
-#if MIN_VERSION_ghc(9,2,1)
-> io (Either String (GHC.ParsedSource, a))
-#else
- -> io (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
-#endif
parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do
let
dynFlags1 = GHC.Driver.Session.gopt_set
@@ -47,12 +36,7 @@ parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do
-- Neither passing in @"-XUnsafe"@ as a command line argument nor having
-- @{-# LANGUAGE Unsafe #-}@ in the source file seem to help.
initialDynFlags
- { GHC.Driver.Session.safeHaskell =
-#if MIN_VERSION_ghc(9,2,1)
- GHC.Types.SafeHaskell.Sf_Unsafe
-#else
- GHC.Driver.Session.Sf_Unsafe
-#endif
+ { GHC.Driver.Session.safeHaskell = GHC.Types.SafeHaskell.Sf_Unsafe
}
GHC.Driver.Session.Opt_KeepRawTokenStream
(dynFlags2, leftovers1, _) <-
@@ -72,11 +56,7 @@ parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do
ExactPrint.parseModuleFromStringInternal dynFlags3 filePath string
case parseResult of
Left errorMessages -> handleErrorMessages errorMessages
-#if MIN_VERSION_ghc(9,2,1)
Right parsedSource -> pure (parsedSource, dynFlagsResult)
-#else
- Right (anns, parsedSource) -> pure (anns, parsedSource, dynFlagsResult)
-#endif
handleLeftovers
:: Monad m => [GHC.Types.SrcLoc.Located String] -> Except.ExceptT String m ()
@@ -99,9 +79,6 @@ initialSettings = GHC.Driver.Session.Settings
, GHC.Driver.Session.sTargetPlatform = initialTargetPlatform
, GHC.Driver.Session.sToolSettings = initialToolSettings
, GHC.Driver.Session.sPlatformMisc = initialPlatformMisc
-#if !MIN_VERSION_ghc(9,2,1)
- , GHC.Driver.Session.sPlatformConstants = initialPlatformConstants
-#endif
, GHC.Driver.Session.sRawSettings = []
}
@@ -125,10 +102,6 @@ initialPlatformMisc :: GHC.Driver.Session.PlatformMisc
initialPlatformMisc = GHC.Driver.Session.PlatformMisc
{ GHC.Driver.Session.platformMisc_ghcRTSWays = ""
, GHC.Driver.Session.platformMisc_ghcRtsWithLibdw = False
-#if !MIN_VERSION_ghc(9,2,1)
- , GHC.Driver.Session.platformMisc_ghcThreaded = False
- , GHC.Driver.Session.platformMisc_ghcDebugged = False
-#endif
, GHC.Driver.Session.platformMisc_ghcWithInterpreter = False
, GHC.Driver.Session.platformMisc_ghcWithSMP = False
, GHC.Driver.Session.platformMisc_libFFI = False
@@ -142,154 +115,143 @@ initialLlvmConfig = GHC.Driver.Session.LlvmConfig
, GHC.Driver.Session.llvmTargets = []
}
-initialPlatformConstants :: PlatformSettings.PlatformConstants
-initialPlatformConstants = PlatformSettings.PlatformConstants
- { PlatformSettings.pc_AP_STACK_SPLIM = 0
- , PlatformSettings.pc_BITMAP_BITS_SHIFT = 0
- , PlatformSettings.pc_BLOCK_SIZE = 0
- , PlatformSettings.pc_BLOCKS_PER_MBLOCK = 0
- , PlatformSettings.pc_CINT_SIZE = 0
- , PlatformSettings.pc_CLONG_LONG_SIZE = 0
- , PlatformSettings.pc_CLONG_SIZE = 0
- , PlatformSettings.pc_CONTROL_GROUP_CONST_291 = 0
-#if !MIN_VERSION_ghc(9,2,1)
- , PlatformSettings.pc_DYNAMIC_BY_DEFAULT = False
-#endif
- , PlatformSettings.pc_ILDV_CREATE_MASK = 0
- , PlatformSettings.pc_ILDV_STATE_CREATE = 0
- , PlatformSettings.pc_ILDV_STATE_USE = 0
- , PlatformSettings.pc_LDV_SHIFT = 0
- , PlatformSettings.pc_MAX_CHARLIKE = 0
- , PlatformSettings.pc_MAX_Double_REG = 0
- , PlatformSettings.pc_MAX_Float_REG = 0
- , PlatformSettings.pc_MAX_INTLIKE = 0
- , PlatformSettings.pc_MAX_Long_REG = 0
- , PlatformSettings.pc_MAX_Real_Double_REG = 0
- , PlatformSettings.pc_MAX_Real_Float_REG = 0
- , PlatformSettings.pc_MAX_Real_Long_REG = 0
- , PlatformSettings.pc_MAX_Real_Vanilla_REG = 0
- , PlatformSettings.pc_MAX_Real_XMM_REG = 0
- , PlatformSettings.pc_MAX_SPEC_AP_SIZE = 0
- , PlatformSettings.pc_MAX_SPEC_SELECTEE_SIZE = 0
- , PlatformSettings.pc_MAX_Vanilla_REG = 0
- , PlatformSettings.pc_MAX_XMM_REG = 0
- , PlatformSettings.pc_MIN_CHARLIKE = 0
- , PlatformSettings.pc_MIN_INTLIKE = 0
- , PlatformSettings.pc_MIN_PAYLOAD_SIZE = 0
- , PlatformSettings.pc_MUT_ARR_PTRS_CARD_BITS = 0
- , PlatformSettings.pc_OFFSET_bdescr_blocks = 0
- , PlatformSettings.pc_OFFSET_bdescr_flags = 0
- , PlatformSettings.pc_OFFSET_bdescr_free = 0
- , PlatformSettings.pc_OFFSET_bdescr_start = 0
- , PlatformSettings.pc_OFFSET_Capability_r = 0
- , PlatformSettings.pc_OFFSET_CostCentreStack_mem_alloc = 0
- , PlatformSettings.pc_OFFSET_CostCentreStack_scc_count = 0
- , PlatformSettings.pc_OFFSET_StgArrBytes_bytes = 0
- , PlatformSettings.pc_OFFSET_stgEagerBlackholeInfo = 0
- , PlatformSettings.pc_OFFSET_StgEntCounter_allocd = 0
- , PlatformSettings.pc_OFFSET_StgEntCounter_allocs = 0
- , PlatformSettings.pc_OFFSET_StgEntCounter_entry_count = 0
- , PlatformSettings.pc_OFFSET_StgEntCounter_link = 0
- , PlatformSettings.pc_OFFSET_StgEntCounter_registeredp = 0
- , PlatformSettings.pc_OFFSET_StgFunInfoExtraFwd_arity = 0
- , PlatformSettings.pc_OFFSET_StgFunInfoExtraRev_arity = 0
- , PlatformSettings.pc_OFFSET_stgGCEnter1 = 0
- , PlatformSettings.pc_OFFSET_stgGCFun = 0
- , PlatformSettings.pc_OFFSET_StgHeader_ccs = 0
- , PlatformSettings.pc_OFFSET_StgHeader_ldvw = 0
- , PlatformSettings.pc_OFFSET_StgMutArrPtrs_ptrs = 0
- , PlatformSettings.pc_OFFSET_StgMutArrPtrs_size = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rCCCS = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rCurrentNursery = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rCurrentTSO = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rD1 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rD2 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rD3 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rD4 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rD5 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rD6 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rF1 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rF2 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rF3 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rF4 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rF5 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rF6 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rHp = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rHpAlloc = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rHpLim = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rL1 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rR1 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rR10 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rR2 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rR3 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rR4 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rR5 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rR6 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rR7 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rR8 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rR9 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rSp = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rSpLim = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rXMM1 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rXMM2 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rXMM3 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rXMM4 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rXMM5 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rXMM6 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rYMM1 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rYMM2 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rYMM3 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rYMM4 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rYMM5 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rYMM6 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rZMM1 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rZMM2 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rZMM3 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rZMM4 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rZMM5 = 0
- , PlatformSettings.pc_OFFSET_StgRegTable_rZMM6 = 0
- , PlatformSettings.pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0
- , PlatformSettings.pc_OFFSET_StgStack_sp = 0
- , PlatformSettings.pc_OFFSET_StgStack_stack = 0
- , PlatformSettings.pc_OFFSET_StgTSO_alloc_limit = 0
- , PlatformSettings.pc_OFFSET_StgTSO_cccs = 0
- , PlatformSettings.pc_OFFSET_StgTSO_stackobj = 0
- , PlatformSettings.pc_OFFSET_StgUpdateFrame_updatee = 0
- , PlatformSettings.pc_PROF_HDR_SIZE = 0
- , PlatformSettings.pc_REP_CostCentreStack_mem_alloc = 0
- , PlatformSettings.pc_REP_CostCentreStack_scc_count = 0
- , PlatformSettings.pc_REP_StgEntCounter_allocd = 0
- , PlatformSettings.pc_REP_StgEntCounter_allocs = 0
- , PlatformSettings.pc_REP_StgFunInfoExtraFwd_arity = 0
- , PlatformSettings.pc_REP_StgFunInfoExtraRev_arity = 0
- , PlatformSettings.pc_RESERVED_C_STACK_BYTES = 0
- , PlatformSettings.pc_RESERVED_STACK_WORDS = 0
- , PlatformSettings.pc_SIZEOF_CostCentreStack = 0
- , PlatformSettings.pc_SIZEOF_StgArrBytes_NoHdr = 0
- , PlatformSettings.pc_SIZEOF_StgFunInfoExtraRev = 0
- , PlatformSettings.pc_SIZEOF_StgMutArrPtrs_NoHdr = 0
- , PlatformSettings.pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 0
- , PlatformSettings.pc_SIZEOF_StgSMPThunkHeader = 0
- , PlatformSettings.pc_SIZEOF_StgUpdateFrame_NoHdr = 0
- , PlatformSettings.pc_STD_HDR_SIZE = 0
- , PlatformSettings.pc_TAG_BITS = 0
- , PlatformSettings.pc_TICKY_BIN_COUNT = 0
- , PlatformSettings.pc_WORD_SIZE = 0
+initialPlatformConstants :: GHC.Platform.PlatformConstants
+initialPlatformConstants = GHC.Platform.PlatformConstants
+ { GHC.Platform.pc_AP_STACK_SPLIM = 0
+ , GHC.Platform.pc_BITMAP_BITS_SHIFT = 0
+ , GHC.Platform.pc_BLOCK_SIZE = 0
+ , GHC.Platform.pc_BLOCKS_PER_MBLOCK = 0
+ , GHC.Platform.pc_CINT_SIZE = 0
+ , GHC.Platform.pc_CLONG_LONG_SIZE = 0
+ , GHC.Platform.pc_CLONG_SIZE = 0
+ , GHC.Platform.pc_CONTROL_GROUP_CONST_291 = 0
+ , GHC.Platform.pc_ILDV_CREATE_MASK = 0
+ , GHC.Platform.pc_ILDV_STATE_CREATE = 0
+ , GHC.Platform.pc_ILDV_STATE_USE = 0
+ , GHC.Platform.pc_LDV_SHIFT = 0
+ , GHC.Platform.pc_MAX_CHARLIKE = 0
+ , GHC.Platform.pc_MAX_Double_REG = 0
+ , GHC.Platform.pc_MAX_Float_REG = 0
+ , GHC.Platform.pc_MAX_INTLIKE = 0
+ , GHC.Platform.pc_MAX_Long_REG = 0
+ , GHC.Platform.pc_MAX_Real_Double_REG = 0
+ , GHC.Platform.pc_MAX_Real_Float_REG = 0
+ , GHC.Platform.pc_MAX_Real_Long_REG = 0
+ , GHC.Platform.pc_MAX_Real_Vanilla_REG = 0
+ , GHC.Platform.pc_MAX_Real_XMM_REG = 0
+ , GHC.Platform.pc_MAX_SPEC_AP_SIZE = 0
+ , GHC.Platform.pc_MAX_SPEC_SELECTEE_SIZE = 0
+ , GHC.Platform.pc_MAX_Vanilla_REG = 0
+ , GHC.Platform.pc_MAX_XMM_REG = 0
+ , GHC.Platform.pc_MIN_CHARLIKE = 0
+ , GHC.Platform.pc_MIN_INTLIKE = 0
+ , GHC.Platform.pc_MIN_PAYLOAD_SIZE = 0
+ , GHC.Platform.pc_MUT_ARR_PTRS_CARD_BITS = 0
+ , GHC.Platform.pc_OFFSET_bdescr_blocks = 0
+ , GHC.Platform.pc_OFFSET_bdescr_flags = 0
+ , GHC.Platform.pc_OFFSET_bdescr_free = 0
+ , GHC.Platform.pc_OFFSET_bdescr_start = 0
+ , GHC.Platform.pc_OFFSET_Capability_r = 0
+ , GHC.Platform.pc_OFFSET_CostCentreStack_mem_alloc = 0
+ , GHC.Platform.pc_OFFSET_CostCentreStack_scc_count = 0
+ , GHC.Platform.pc_OFFSET_StgArrBytes_bytes = 0
+ , GHC.Platform.pc_OFFSET_stgEagerBlackholeInfo = 0
+ , GHC.Platform.pc_OFFSET_StgEntCounter_allocd = 0
+ , GHC.Platform.pc_OFFSET_StgEntCounter_allocs = 0
+ , GHC.Platform.pc_OFFSET_StgEntCounter_entry_count = 0
+ , GHC.Platform.pc_OFFSET_StgEntCounter_link = 0
+ , GHC.Platform.pc_OFFSET_StgEntCounter_registeredp = 0
+ , GHC.Platform.pc_OFFSET_StgFunInfoExtraFwd_arity = 0
+ , GHC.Platform.pc_OFFSET_StgFunInfoExtraRev_arity = 0
+ , GHC.Platform.pc_OFFSET_stgGCEnter1 = 0
+ , GHC.Platform.pc_OFFSET_stgGCFun = 0
+ , GHC.Platform.pc_OFFSET_StgHeader_ccs = 0
+ , GHC.Platform.pc_OFFSET_StgHeader_ldvw = 0
+ , GHC.Platform.pc_OFFSET_StgMutArrPtrs_ptrs = 0
+ , GHC.Platform.pc_OFFSET_StgMutArrPtrs_size = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rCCCS = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rCurrentNursery = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rCurrentTSO = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rD1 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rD2 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rD3 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rD4 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rD5 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rD6 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rF1 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rF2 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rF3 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rF4 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rF5 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rF6 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rHp = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rHpAlloc = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rHpLim = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rL1 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rR1 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rR10 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rR2 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rR3 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rR4 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rR5 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rR6 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rR7 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rR8 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rR9 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rSp = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rSpLim = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rXMM1 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rXMM2 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rXMM3 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rXMM4 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rXMM5 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rXMM6 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rYMM1 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rYMM2 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rYMM3 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rYMM4 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rYMM5 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rYMM6 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rZMM1 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rZMM2 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rZMM3 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rZMM4 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rZMM5 = 0
+ , GHC.Platform.pc_OFFSET_StgRegTable_rZMM6 = 0
+ , GHC.Platform.pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0
+ , GHC.Platform.pc_OFFSET_StgStack_sp = 0
+ , GHC.Platform.pc_OFFSET_StgStack_stack = 0
+ , GHC.Platform.pc_OFFSET_StgTSO_alloc_limit = 0
+ , GHC.Platform.pc_OFFSET_StgTSO_cccs = 0
+ , GHC.Platform.pc_OFFSET_StgTSO_stackobj = 0
+ , GHC.Platform.pc_OFFSET_StgUpdateFrame_updatee = 0
+ , GHC.Platform.pc_PROF_HDR_SIZE = 0
+ , GHC.Platform.pc_REP_CostCentreStack_mem_alloc = 0
+ , GHC.Platform.pc_REP_CostCentreStack_scc_count = 0
+ , GHC.Platform.pc_REP_StgEntCounter_allocd = 0
+ , GHC.Platform.pc_REP_StgEntCounter_allocs = 0
+ , GHC.Platform.pc_REP_StgFunInfoExtraFwd_arity = 0
+ , GHC.Platform.pc_REP_StgFunInfoExtraRev_arity = 0
+ , GHC.Platform.pc_RESERVED_C_STACK_BYTES = 0
+ , GHC.Platform.pc_RESERVED_STACK_WORDS = 0
+ , GHC.Platform.pc_SIZEOF_CostCentreStack = 0
+ , GHC.Platform.pc_SIZEOF_StgArrBytes_NoHdr = 0
+ , GHC.Platform.pc_SIZEOF_StgFunInfoExtraRev = 0
+ , GHC.Platform.pc_SIZEOF_StgMutArrPtrs_NoHdr = 0
+ , GHC.Platform.pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 0
+ , GHC.Platform.pc_SIZEOF_StgSMPThunkHeader = 0
+ , GHC.Platform.pc_SIZEOF_StgUpdateFrame_NoHdr = 0
+ , GHC.Platform.pc_STD_HDR_SIZE = 0
+ , GHC.Platform.pc_TAG_BITS = 0
+ , GHC.Platform.pc_TICKY_BIN_COUNT = 0
+ , GHC.Platform.pc_WORD_SIZE = 0
}
-#if MIN_VERSION_ghc(9,2,1)
initialPlatformArchOS :: GHC.Platform.ArchOS
initialPlatformArchOS = GHC.Platform.ArchOS
{ GHC.Platform.archOS_arch = GHC.Platform.ArchX86_64
, GHC.Platform.archOS_OS = GHC.Platform.OSLinux
}
-#else
-initialPlatformMini :: GHC.Settings.PlatformMini
-initialPlatformMini = GHC.Settings.PlatformMini
- { GHC.Settings.platformMini_arch = GHC.Platform.ArchX86_64
- , GHC.Settings.platformMini_os = GHC.Platform.OSLinux
- }
-#endif
initialTargetPlatform :: GHC.Settings.Platform
initialTargetPlatform = GHC.Settings.Platform
@@ -299,12 +261,8 @@ initialTargetPlatform = GHC.Settings.Platform
, GHC.Settings.platformHasSubsectionsViaSymbols = False
, GHC.Settings.platformIsCrossCompiling = False
, GHC.Settings.platformLeadingUnderscore = False
-#if MIN_VERSION_ghc(9,2,1)
, GHC.Settings.platformArchOS = initialPlatformArchOS
, GHC.Settings.platform_constants = Just initialPlatformConstants
-#else
- , GHC.Settings.platformMini = initialPlatformMini
-#endif
, GHC.Settings.platformTablesNextToCode = False
, GHC.Settings.platformUnregisterised = False
, GHC.Settings.platformWordSize = GHC.Platform.PW8
--
2.30.2
From 3d12add3d86fe7b05b73696d3e18d5f1a58bc0a5 Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Fri, 28 Jan 2022 21:51:13 +0300
Subject: [PATCH 09/35] (try commenting out)
(run into Brittany.Internal.Types, & commenting that _probably_ won't work)
---
.../Haskell/Brittany/Internal/ExactPrintUtils.hs | 15 +++++++++------
.../Haskell/Brittany/Internal/LayouterBasics.hs | 2 +-
2 files changed, 10 insertions(+), 7 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
index 63d6b53..4635bac 100644
--- a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
@@ -37,7 +37,7 @@ parseModule
:: [String]
-> System.IO.FilePath
-> (GHC.DynFlags -> IO (Either String a))
- -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
+ -> IO (Either String (GHC.ParsedSource, a))
parseModule args fp dynCheck = do
str <- System.IO.readFile fp
parseModuleFromString args fp dynCheck str
@@ -47,10 +47,10 @@ parseModuleFromString
-> System.IO.FilePath
-> (GHC.DynFlags -> IO (Either String a))
-> String
- -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
+ -> IO (Either String (GHC.ParsedSource, a))
parseModuleFromString = ParseModule.parseModule
-
+{-
commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform ()
commentAnnFixTransformGlob ast = do
let
@@ -115,7 +115,7 @@ commentAnnFixTransformGlob ast = do
, ExactPrint.annsDP = assocs'
}
ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns
-
+-}
-- TODO: this is unused by now, but it contains one detail that
-- commentAnnFixTransformGlob does not include: Moving of comments for
@@ -181,6 +181,8 @@ commentAnnFixTransformGlob ast = do
-- ExactPrint.modifyAnnsT moveComments
+{--
+
-- | split a set of annotations in a module into a map from top-level module
-- elements to the relevant annotations. Avoids quadratic behaviour a trivial
-- implementation would have.
@@ -229,7 +231,8 @@ foldedAnnKeys ast = SYB.everything
ast
where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ()))
-
+-}
+{-
withTransformedAnns
:: Data ast
=> ast
@@ -248,7 +251,7 @@ withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
((), (annsBalanced, _), _) =
ExactPrint.runTransform anns (commentAnnFixTransformGlob ast)
in annsBalanced
-
+-}
warnExtractorCompat :: GHC.Warn -> String
warnExtractorCompat (GHC.Warn _ (L _ s)) = s
diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
index 136468e..afc3af2 100644
--- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
@@ -31,7 +31,7 @@ import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
-import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
+-- import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
--
2.30.2
From 73ef14cea527df72eac1bb3d6d99cb69e75f34b1 Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Fri, 28 Jan 2022 22:42:18 +0300
Subject: [PATCH 10/35] Make Internal.Types fake-compile
---
.../Language/Haskell/Brittany/Internal/Types.hs | 16 +++++++++-------
1 file changed, 9 insertions(+), 7 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs
index 6a2c8af..3198f86 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Types.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Types.hs
@@ -22,29 +22,31 @@ import GHC (AnnKeywordId, GenLocated, Located, SrcSpan)
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
-import Language.Haskell.GHC.ExactPrint (AnnKey)
+-- import Language.Haskell.GHC.ExactPrint (AnnKey)
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
-import Language.Haskell.GHC.ExactPrint.Types (Anns)
+-- import Language.Haskell.GHC.ExactPrint.Types (Anns)
import qualified Safe
+type Anns = ()
+type AnnKey = ()
data PerItemConfig = PerItemConfig
{ _icd_perBinding :: Map String (CConfig Maybe)
- , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Maybe)
+ , _icd_perKey :: Map AnnKey (CConfig Maybe)
}
deriving Data.Data.Data
type PPM = MultiRWSS.MultiRWS
- '[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns]
+ '[Map AnnKey Anns, PerItemConfig, Config, Anns]
'[Text.Builder.Builder, [BrittanyError], Seq String]
'[]
type PPMLocal = MultiRWSS.MultiRWS
- '[Config, ExactPrint.Anns]
+ '[Config, Anns]
'[Text.Builder.Builder, [BrittanyError], Seq String]
'[]
-newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String)
+newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map AnnKey String)
data LayoutState = LayoutState
{ _lstate_baseYs :: [Int]
@@ -131,7 +133,7 @@ instance Show LayoutState where
-- -- when creating zero-indentation
-- -- multi-line list literals.
-- , _lsettings_importColumn :: Int
--- , _lsettings_initialAnns :: ExactPrint.Anns
+-- , _lsettings_initialAnns :: Anns
-- }
data BrittanyError
--
2.30.2
From 9ee501753e53fa0c5e51e4f951f7172a2b442c92 Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Sun, 30 Jan 2022 15:25:45 +0300
Subject: [PATCH 11/35] Hack away Utils
---
.../Haskell/Brittany/Internal/Utils.hs | 24 +++++++++++--------
1 file changed, 14 insertions(+), 10 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/Utils.hs b/source/library/Language/Haskell/Brittany/Internal/Utils.hs
index b62028f..5de87df 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Utils.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Utils.hs
@@ -17,9 +17,10 @@ import qualified Data.Sequence as Seq
import DataTreePrint
import qualified GHC.Data.FastString as GHC
import qualified GHC.Driver.Session as GHC
-import qualified GHC.Hs.Extension as HsExtension
+import qualified GHC.Driver.Ppr as GHC
import qualified GHC.OldList as List
import GHC.Types.Name.Occurrence as OccName (occNameString)
+import qualified GHC.Parser.Annotation as GHC
import qualified GHC.Types.SrcLoc as GHC
import qualified GHC.Utils.Outputable as GHC
import Language.Haskell.Brittany.Internal.Config.Types
@@ -28,6 +29,7 @@ import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
+import qualified Language.Haskell.Syntax.Extension as HsExtension
import qualified Text.PrettyPrint as PP
@@ -40,10 +42,10 @@ parDocW = PP.fsep . fmap PP.text . List.words . List.unwords
showSDoc_ :: GHC.SDoc -> String
-showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags
+showSDoc_ = GHC.showSDoc undefined -- GHC.unsafeGlobalDynFlags
showOutputable :: (GHC.Outputable a) => a -> String
-showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags
+showOutputable = GHC.showPpr undefined -- GHC.unsafeGlobalDynFlags
fromMaybeIdentity :: Identity a -> Maybe a -> Identity a
fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y
@@ -72,8 +74,10 @@ instance Show ShowIsId where
data A x = A ShowIsId x
deriving Data
-customLayouterF :: ExactPrint.Types.Anns -> LayouterF
-customLayouterF anns layoutF =
+type EPAnns = ()
+
+customLayouterF :: LayouterF
+customLayouterF layoutF =
DataToLayouter
$ f
`extQ` showIsId
@@ -104,12 +108,12 @@ customLayouterF anns layoutF =
$ "{"
++ showOutputable ss
++ "}"
- located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter
+ located :: (Data b, Data ann) => GHC.GenLocated ann b -> NodeLayouter
located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a
where
annStr = case cast ss of
- Just (s :: GHC.SrcSpan) ->
- ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns)
+ Just (s :: GHC.SrcLoc) ->
+ ShowIsId $ "printing anns on 9.2.1: not implemented" ++ undefined
Nothing -> ShowIsId "nnnnnnnn"
customLayouterNoAnnsF :: LayouterF
@@ -226,9 +230,9 @@ briDocToDoc = astToDoc . removeAnnotations
briDocToDocWithAnns :: BriDoc -> PP.Doc
briDocToDocWithAnns = astToDoc
-annsDoc :: ExactPrint.Types.Anns -> PP.Doc
+annsDoc :: EPAnns -> PP.Doc
annsDoc =
- printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)
+ printTreeWithCustom 100 customLayouterNoAnnsF
breakEither :: (a -> Either b c) -> [a] -> ([b], [c])
breakEither _ [] = ([], [])
--
2.30.2
From e46e459e87da1c147069c31d9b66d2da67a8e431 Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Sun, 30 Jan 2022 15:25:55 +0300
Subject: [PATCH 12/35] Hack away BackendUtils
---
.../Haskell/Brittany/Internal/BackendUtils.hs | 164 +++++++++---------
1 file changed, 82 insertions(+), 82 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs
index 310ea56..920e3a5 100644
--- a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs
@@ -17,7 +17,7 @@ import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
-import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
+-- import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
@@ -338,23 +338,23 @@ layoutAddSepSpace = do
-- TODO: when refactoring is complete, the other version of this method
-- can probably be removed.
-moveToExactAnn
- :: ( MonadMultiWriter Text.Builder.Builder m
- , MonadMultiState LayoutState m
- , MonadMultiReader (Map AnnKey Annotation) m
- )
- => AnnKey
- -> m ()
-moveToExactAnn annKey = do
- traceLocal ("moveToExactAnn", annKey)
- anns <- mAsk
- case Map.lookup annKey anns of
- Nothing -> return ()
- Just ann -> do
- -- curY <- mGet <&> _lstate_curY
- let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann
- -- mModify $ \state -> state { _lstate_addNewline = Just x }
- moveToY y
+-- moveToExactAnn
+-- :: ( MonadMultiWriter Text.Builder.Builder m
+-- , MonadMultiState LayoutState m
+-- -- , MonadMultiReader (Map AnnKey Annotation) m
+-- )
+-- => AnnKey
+-- -> m ()
+-- moveToExactAnn annKey = do
+-- traceLocal ("moveToExactAnn", annKey)
+-- anns <- mAsk
+-- case Map.lookup annKey anns of
+-- Nothing -> return ()
+-- Just ann -> do
+-- -- curY <- mGet <&> _lstate_curY
+-- let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann
+-- -- mModify $ \state -> state { _lstate_addNewline = Just x }
+-- moveToY y
moveToY :: MonadMultiState LayoutState m => Int -> m ()
moveToY y = mModify $ \state ->
@@ -379,77 +379,77 @@ moveToY y = mModify $ \state ->
-- then x-1
-- else x
-ppmMoveToExactLoc
- :: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m ()
-ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do
- replicateM_ x $ mTell $ Text.Builder.fromString "\n"
- replicateM_ y $ mTell $ Text.Builder.fromString " "
+-- ppmMoveToExactLoc
+-- :: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m ()
+-- ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do
+-- replicateM_ x $ mTell $ Text.Builder.fromString "\n"
+-- replicateM_ y $ mTell $ Text.Builder.fromString " "
-- TODO: update and use, or clean up. Currently dead code.
-layoutWritePriorComments
- :: ( Data.Data.Data ast
- , MonadMultiWriter Text.Builder.Builder m
- , MonadMultiState LayoutState m
- )
- => Located ast
- -> m ()
-layoutWritePriorComments ast = do
- mAnn <- do
- state <- mGet
- let key = ExactPrint.mkAnnKey ast
- let anns = _lstate_comments state
- let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns
- mSet $ state
- { _lstate_comments = Map.adjust
- (\ann -> ann { ExactPrint.annPriorComments = [] })
- key
- anns
- }
- return mAnn
- case mAnn of
- Nothing -> return ()
- Just priors -> do
- unless (null priors) $ layoutSetCommentCol
- priors `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
- do
- replicateM_ x layoutWriteNewline
- layoutWriteAppendSpaces y
- layoutWriteAppendMultiline $ Text.lines $ Text.pack comment
+-- layoutWritePriorComments
+-- :: ( Data.Data.Data ast
+-- , MonadMultiWriter Text.Builder.Builder m
+-- , MonadMultiState LayoutState m
+-- )
+-- => Located ast
+-- -> m ()
+-- layoutWritePriorComments ast = do
+-- mAnn <- do
+-- state <- mGet
+-- let key = ExactPrint.mkAnnKey ast
+-- let anns = _lstate_comments state
+-- let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns
+-- mSet $ state
+-- { _lstate_comments = Map.adjust
+-- (\ann -> ann { ExactPrint.annPriorComments = [] })
+-- key
+-- anns
+-- }
+-- return mAnn
+-- case mAnn of
+-- Nothing -> return ()
+-- Just priors -> do
+-- unless (null priors) $ layoutSetCommentCol
+-- priors `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
+-- do
+-- replicateM_ x layoutWriteNewline
+-- layoutWriteAppendSpaces y
+-- layoutWriteAppendMultiline $ Text.lines $ Text.pack comment
-- TODO: update and use, or clean up. Currently dead code.
-- this currently only extracs from the `annsDP` field of Annotations.
-- per documentation, this seems sufficient, as the
-- "..`annFollowingComments` are only added by AST transformations ..".
-layoutWritePostComments
- :: ( Data.Data.Data ast
- , MonadMultiWriter Text.Builder.Builder m
- , MonadMultiState LayoutState m
- )
- => Located ast
- -> m ()
-layoutWritePostComments ast = do
- mAnn <- do
- state <- mGet
- let key = ExactPrint.mkAnnKey ast
- let anns = _lstate_comments state
- let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns
- mSet $ state
- { _lstate_comments = Map.adjust
- (\ann -> ann { ExactPrint.annFollowingComments = [] })
- key
- anns
- }
- return mAnn
- case mAnn of
- Nothing -> return ()
- Just posts -> do
- unless (null posts) $ layoutSetCommentCol
- posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
- do
- replicateM_ x layoutWriteNewline
- layoutWriteAppend $ Text.pack $ replicate y ' '
- mModify $ \s -> s { _lstate_addSepSpace = Nothing }
- layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment
+-- layoutWritePostComments
+-- :: ( Data.Data.Data ast
+-- , MonadMultiWriter Text.Builder.Builder m
+-- , MonadMultiState LayoutState m
+-- )
+-- => Located ast
+-- -> m ()
+-- layoutWritePostComments ast = do
+-- mAnn <- do
+-- state <- mGet
+-- let key = ExactPrint.mkAnnKey ast
+-- let anns = _lstate_comments state
+-- let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns
+-- mSet $ state
+-- { _lstate_comments = Map.adjust
+-- (\ann -> ann { ExactPrint.annFollowingComments = [] })
+-- key
+-- anns
+-- }
+-- return mAnn
+-- case mAnn of
+-- Nothing -> return ()
+-- Just posts -> do
+-- unless (null posts) $ layoutSetCommentCol
+-- posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
+-- do
+-- replicateM_ x layoutWriteNewline
+-- layoutWriteAppend $ Text.pack $ replicate y ' '
+-- mModify $ \s -> s { _lstate_addSepSpace = Nothing }
+-- layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment
layoutIndentRestorePostComment
:: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m)
--
2.30.2
From 494a0ba09a24698b3ca9d82480c0049213f2e2cd Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Sun, 30 Jan 2022 15:53:19 +0300
Subject: [PATCH 13/35] Hack away LayouterBasics (ouch)
---
.../Brittany/Internal/LayouterBasics.hs | 206 +++++++++++-------
1 file changed, 123 insertions(+), 83 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
index afc3af2..6bc1dd7 100644
--- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
@@ -34,21 +34,23 @@ import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
-- import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
-import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
+-- import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
processDefault
- :: ( ExactPrint.Annotate.Annotate ast
- , MonadMultiWriter Text.Builder.Builder m
- , MonadMultiReader ExactPrint.Types.Anns m
+ :: (
+ -- ExactPrint.Annotate.Annotate ast
+ ExactPrint.ExactPrint ast
+ , MonadMultiWriter Text.Builder.Builder m
+ -- , MonadMultiReader ExactPrint.Types.Anns m
)
=> Located ast
-> m ()
processDefault x = do
- anns <- mAsk
- let str = ExactPrint.exactPrint x anns
+ -- anns <- mAsk
+ let str = ExactPrint.exactPrint x {-anns-}
-- this hack is here so our print-empty-module trick does not add
-- a newline at the start if there actually is no module header / imports
-- / anything.
@@ -63,16 +65,18 @@ processDefault x = do
-- not handled by brittany yet). Useful when starting implementing new
-- syntactic constructs when children are not handled yet.
briDocByExact
- :: (ExactPrint.Annotate.Annotate ast)
+ ::
+ -- (ExactPrint.Annotate.Annotate ast)
+ Data ast
=> Located ast
-> ToBriDocM BriDocNumbered
briDocByExact ast = do
- anns <- mAsk
+ -- anns <- mAsk
traceIfDumpConf
"ast"
_dconf_dump_ast_unknown
- (printTreeWithCustom 100 (customLayouterF anns) ast)
- docExt ast anns True
+ (printTreeWithCustom 100 (customLayouterF {-anns-}) ast)
+ docExt ast {-anns-} True
-- | Use ExactPrint's output for this node.
-- Consider that for multi-line input, the indentation of the code produced
@@ -80,38 +84,44 @@ briDocByExact ast = do
-- of its surroundings as layouted by brittany. But there are safe uses of
-- this, e.g. for any top-level declarations.
briDocByExactNoComment
- :: (ExactPrint.Annotate.Annotate ast)
+ ::
+ -- (ExactPrint.Annotate.Annotate ast)
+ Data ast
=> Located ast
-> ToBriDocM BriDocNumbered
briDocByExactNoComment ast = do
- anns <- mAsk
+ -- anns <- mAsk
traceIfDumpConf
"ast"
_dconf_dump_ast_unknown
- (printTreeWithCustom 100 (customLayouterF anns) ast)
- docExt ast anns False
+ (printTreeWithCustom 100 (customLayouterF {-anns-}) ast)
+ docExt ast {-anns-} False
-- | Use ExactPrint's output for this node, presuming that this output does
-- not contain any newlines. If this property is not met, the semantics
-- depend on the @econf_AllowRiskyExactPrintUse@ config flag.
briDocByExactInlineOnly
- :: (ExactPrint.Annotate.Annotate ast)
+ ::
+ -- (ExactPrint.Annotate.Annotate ast)
+ (Data ast, ExactPrint.ExactPrint ast)
=> String
-> Located ast
-> ToBriDocM BriDocNumbered
briDocByExactInlineOnly infoStr ast = do
- anns <- mAsk
+ -- anns <- mAsk
traceIfDumpConf
"ast"
_dconf_dump_ast_unknown
- (printTreeWithCustom 100 (customLayouterF anns) ast)
- let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns
+ (printTreeWithCustom 100 (customLayouterF {-anns-}) ast)
+ let exactPrinted = Text.pack $ ExactPrint.exactPrint ast {-anns-}
fallbackMode <-
mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack
let
exactPrintNode t = allocateNode $ BDFExternal
- (ExactPrint.Types.mkAnnKey ast)
- (foldedAnnKeys ast)
+ -- ({-ExactPrint.Types.mkAnnKey-} undefined ast)
+ undefined
+ -- (foldedAnnKeys ast)
+ undefined
False
t
let
@@ -138,37 +148,47 @@ lrdrNameToText :: GenLocated l RdrName -> Text
lrdrNameToText (L _ n) = rdrNameToText n
lrdrNameToTextAnnGen
- :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
+ :: (MonadMultiReader Config m
+ -- , MonadMultiReader (Map AnnKey Annotation) m
+ )
=> (Text -> Text)
-> Located RdrName
-> m Text
lrdrNameToTextAnnGen f ast@(L _ n) = do
- anns <- mAsk
+ -- anns <- mAsk
let t = f $ rdrNameToText n
let
- hasUni x (ExactPrint.Types.G y, _) = x == y
+ -- hasUni x (ExactPrint.Types.G y, _) = x == y
hasUni _ _ = False
-- TODO: in general: we should _always_ process all annotaiton stuff here.
-- whatever we don't probably should have had some effect on the
-- output. in such cases, resorting to byExact is probably the safe
-- choice.
- return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of
+ return $ case {-Map.lookup ({-ExactPrint.Types.mkAnnKey-} undefined ast) anns-} undefined of
Nothing -> t
- Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of
+ Just {-(ExactPrint.Types.Ann _ _ _ aks _ _)-} _ -> case n of
Exact{} | t == Text.pack "()" -> t
_ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`"
_ | any (hasUni AnnCommaTuple) aks -> t
_ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")"
_ | otherwise -> t
+ where
+ aks :: [a]
+ aks = undefined
+
lrdrNameToTextAnn
- :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
+ :: (MonadMultiReader Config m
+ -- , MonadMultiReader (Map AnnKey Annotation) m
+ )
=> Located RdrName
-> m Text
lrdrNameToTextAnn = lrdrNameToTextAnnGen id
lrdrNameToTextAnnTypeEqualityIsSpecial
- :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
+ :: (MonadMultiReader Config m
+ -- , MonadMultiReader (Map AnnKey Annotation) m
+ )
=> Located RdrName
-> m Text
lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
@@ -186,7 +206,7 @@ lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick
:: ( Data ast
, MonadMultiReader Config m
- , MonadMultiReader (Map AnnKey Annotation) m
+ -- , MonadMultiReader (Map AnnKey Annotation) m
)
=> Located ast
-> Located RdrName
@@ -205,28 +225,30 @@ askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk
extractAllComments
- :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]
+ :: Annotation -> [(Comment, DeltaPos)]
extractAllComments ann =
- ExactPrint.annPriorComments ann ++ extractRestComments ann
+ undefined
+ -- ExactPrint.annPriorComments ann ++ extractRestComments ann
extractRestComments
- :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]
+ :: Annotation -> [(Comment, DeltaPos)]
extractRestComments ann =
- ExactPrint.annFollowingComments ann
- ++ (ExactPrint.annsDP ann >>= \case
- (ExactPrint.AnnComment com, dp) -> [(com, dp)]
- _ -> []
- )
+ undefined
+ -- ExactPrint.annFollowingComments ann
+ -- ++ (ExactPrint.annsDP ann >>= \case
+ -- (ExactPrint.AnnComment com, dp) -> [(com, dp)]
+ -- _ -> []
+ -- )
-filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns
-filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)
+-- filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns
+-- filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)
-- | True if there are any comments that are
-- a) connected to any node below (in AST sense) the given node AND
-- b) after (in source code order) the node.
hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool
hasAnyCommentsBelow ast@(L l _) =
- List.any (\(c, _) -> ExactPrint.commentIdentifier c > ExactPrint.Utils.rs l)
+ List.any (\(c, _) -> {-ExactPrint.commentIdentifier-} undefined c > ExactPrint.Utils.rs l)
<$> astConnectedComments ast
hasCommentsBetween
@@ -236,18 +258,18 @@ hasCommentsBetween
-> AnnKeywordId
-> ToBriDocM Bool
hasCommentsBetween ast leftKey rightKey = do
- mAnn <- astAnn ast
+ mAnn <- {-astAnn-} undefined ast
let
go1 [] = False
- go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest
+ -- go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest
go1 (_ : rest) = go1 rest
go2 [] = False
- go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True
- go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False
+ -- go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True
+ -- go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False
go2 (_ : rest) = go2 rest
case mAnn of
Nothing -> pure False
- Just ann -> pure $ go1 $ ExactPrint.annsDP ann
+ Just ann -> pure $ go1 $ undefined ann
-- | True if there are any comments that are connected to any node below (in AST
-- sense) the given node
@@ -258,7 +280,7 @@ hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast
-- sense) the given node
hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool
hasAnyRegularCommentsConnected ast =
- any isRegularComment <$> astConnectedComments ast
+ any {-isRegularComment-} undefined <$> astConnectedComments ast
-- | Regular comments are comments that are actually "source code comments",
-- i.e. things that start with "--" or "{-". In contrast to comment-annotations
@@ -269,51 +291,66 @@ hasAnyRegularCommentsConnected ast =
-- I believe that most of the time we branch on the existence of comments, we
-- only care about "regular" comments. We simply did not need the distinction
-- because "irregular" comments are not that common outside of type/data decls.
-isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool
-isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst
+-- isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool
+-- isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst
+
+type DeltaPos = ()
+type Comment = ()
astConnectedComments
:: Data ast
=> GHC.Located ast
- -> ToBriDocM [(ExactPrint.Types.Comment, ExactPrint.Types.DeltaPos)]
+ -> ToBriDocM [(Comment, DeltaPos)]
astConnectedComments ast = do
- anns <- filterAnns ast <$> mAsk
- pure $ extractAllComments =<< Map.elems anns
+ undefined
+ -- anns <- filterAnns ast <$> mAsk
+ -- pure $ extractAllComments =<< Map.elems anns
hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool
-hasAnyCommentsPrior ast = astAnn ast <&> \case
+hasAnyCommentsPrior ast = {-astAnn-} undefined ast <&> \case
Nothing -> False
- Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors
+ Just _ {-(ExactPrint.Types.Ann _ priors _ _ _ _)-} -> not $ null priors
+ where priors = [undefined]
hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool
-hasAnyRegularCommentsRest ast = astAnn ast <&> \case
+hasAnyRegularCommentsRest ast = {-astAnn-} undefined ast <&> \case
Nothing -> False
- Just ann -> any isRegularComment (extractRestComments ann)
+ Just ann -> undefined -- any isRegularComment (extractRestComments ann)
hasAnnKeywordComment
:: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool
-hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case
+hasAnnKeywordComment ast annKeyword = {-astAnn-} undefined ast <&> \case
Nothing -> False
- Just ann -> any hasK (extractAllComments ann)
- where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst
+ Just ann -> any hasK ({-extractAllComments-} thing ann)
+ where
+ hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst
+ thing ann = [undefined]
hasAnnKeyword
- :: (Data a, MonadMultiReader (Map AnnKey Annotation) m)
+ :: (Data a
+ -- , MonadMultiReader (Map AnnKey Annotation) m
+ , Functor m
+ )
=> Located a
-> AnnKeywordId
-> m Bool
-hasAnnKeyword ast annKeyword = astAnn ast <&> \case
+hasAnnKeyword ast annKeyword = {-astAnn-} astAnn' ast <&> \case
Nothing -> False
- Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks
+ Just {-(ExactPrint.Types.Ann _ _ _ aks _ _)-} undefined -> any hasK aks
where
- hasK (ExactPrint.Types.G x, _) = x == annKeyword
+ -- hasK (ExactPrint.Types.G x, _) = x == annKeyword
hasK _ = False
+ aks = [undefined]
+ -- astAnn' :: Functor f => Located a -> f (Maybe b)
+ astAnn' = undefined
-astAnn
- :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m)
- => GHC.Located ast
- -> m (Maybe Annotation)
-astAnn ast = Map.lookup (ExactPrint.Types.mkAnnKey ast) <$> mAsk
+type Annotation = ()
+
+-- astAnn
+-- :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m)
+-- => GHC.Located ast
+-- -> m (Maybe Annotation)
+-- astAnn ast = {-Map.lookup ({-ExactPrint.Types.mkAnnKey-} undefined ast)-} undefined <$> mAsk
-- new BriDoc stuff
@@ -338,7 +375,7 @@ allocNodeIndex = do
-- docExt :: (ExactPrint.Annotate.Annotate ast, MonadMultiState NodeAllocIndex m)
-- => Located ast -> ExactPrint.Types.Anns -> Bool -> m BriDocNumbered
-- docExt x anns shouldAddComment = allocateNode $ BDFExternal
--- (ExactPrint.Types.mkAnnKey x)
+-- ({-ExactPrint.Types.mkAnnKey-} undefined x)
-- (foldedAnnKeys x)
-- shouldAddComment
-- (Text.pack $ ExactPrint.exactPrint x anns)
@@ -393,7 +430,7 @@ allocNodeIndex = do
-- -> m BriDocNumbered
-- docPostComment ast bdm = do
-- bd <- bdm
--- allocateNode $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd
+-- allocateNode $ BDFAnnotationPost ({-ExactPrint.Types.mkAnnKey-} undefined ast) bd
--
-- docWrapNode :: ( Data.Data.Data ast, MonadMultiState NodeAllocIndex m)
-- => Located ast
@@ -405,9 +442,9 @@ allocNodeIndex = do
-- i2 <- allocNodeIndex
-- return
-- $ (,) i1
--- $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
+-- $ BDFAnnotationPrior ({-ExactPrint.Types.mkAnnKey-} undefined ast)
-- $ (,) i2
--- $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast)
+-- $ BDFAnnotationPost ({-ExactPrint.Types.mkAnnKey-} undefined ast)
-- $ bd
--
-- docPar :: MonadMultiState NodeAllocIndex m
@@ -438,16 +475,19 @@ docLitS :: String -> ToBriDocM BriDocNumbered
docLitS s = allocateNode $ BDFLit $ Text.pack s
docExt
- :: (ExactPrint.Annotate.Annotate ast)
- => Located ast
- -> ExactPrint.Types.Anns
+ ::
+ -- (ExactPrint.Annotate.Annotate ast)
+ Located ast
+ -- -> ExactPrint.Types.Anns
-> Bool
-> ToBriDocM BriDocNumbered
-docExt x anns shouldAddComment = allocateNode $ BDFExternal
- (ExactPrint.Types.mkAnnKey x)
- (foldedAnnKeys x)
+docExt x shouldAddComment = allocateNode $ BDFExternal
+ -- ({-ExactPrint.Types.mkAnnKey-} undefined x)
+ undefined
+ -- (foldedAnnKeys x)
+ undefined
shouldAddComment
- (Text.pack $ ExactPrint.exactPrint x anns)
+ (Text.pack $ {-ExactPrint.exactPrint x anns-} undefined)
docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
docAlt l = allocateNode . BDFAlt =<< sequence l
@@ -585,7 +625,7 @@ docNodeAnnKW
-> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
docNodeAnnKW ast kw bdm =
- docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm
+ docAnnotationKW ({-{-ExactPrint.Types.mkAnnKey-} undefined-} undefined ast) kw bdm
docNodeMoveToKWDP
:: Data.Data.Data ast
@@ -595,7 +635,7 @@ docNodeMoveToKWDP
-> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
docNodeMoveToKWDP ast kw shouldRestoreIndent bdm =
- docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw shouldRestoreIndent bdm
+ docMoveToKWDP ({-{-ExactPrint.Types.mkAnnKey-} undefined-} undefined ast) kw shouldRestoreIndent bdm
class DocWrapable a where
docWrapNode :: ( Data.Data.Data ast)
@@ -618,18 +658,18 @@ instance DocWrapable (ToBriDocM BriDocNumbered) where
i2 <- allocNodeIndex
return
$ (,) i1
- $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
+ $ BDFAnnotationPrior ({-ExactPrint.Types.mkAnnKey-} undefined ast)
$ (,) i2
- $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast)
+ $ BDFAnnotationRest ({-ExactPrint.Types.mkAnnKey-} undefined ast)
$ bd
docWrapNodePrior ast bdm = do
bd <- bdm
i1 <- allocNodeIndex
- return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd
+ return $ (,) i1 $ BDFAnnotationPrior ({-ExactPrint.Types.mkAnnKey-} undefined ast) $ bd
docWrapNodeRest ast bdm = do
bd <- bdm
i2 <- allocNodeIndex
- return $ (,) i2 $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd
+ return $ (,) i2 $ BDFAnnotationRest ({-ExactPrint.Types.mkAnnKey-} undefined ast) $ bd
instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where
docWrapNode ast bdms = case bdms of
--
2.30.2
From 2535f82d82363576853ad3cc8350ab14486b0527 Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Sun, 30 Jan 2022 16:02:59 +0300
Subject: [PATCH 14/35] Hack away Backend
---
.../Haskell/Brittany/Internal/Backend.hs | 154 +++++++++---------
.../Haskell/Brittany/Internal/Types.hs | 2 +-
2 files changed, 80 insertions(+), 76 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/Backend.hs b/source/library/Language/Haskell/Brittany/Internal/Backend.hs
index 55a3c97..1a1e741 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Backend.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Backend.hs
@@ -66,7 +66,7 @@ data ColBuildState = ColBuildState
type LayoutConstraints m
= ( MonadMultiReader Config m
- , MonadMultiReader ExactPrint.Types.Anns m
+ -- , MonadMultiReader ExactPrint.Types.Anns m
, MonadMultiWriter Text.Builder.Builder m
, MonadMultiWriter (Seq String) m
, MonadMultiState LayoutState m
@@ -138,12 +138,12 @@ layoutBriDocM = \case
let
tlines = Text.lines $ t <> Text.pack "\n"
tlineCount = length tlines
- anns :: ExactPrint.Anns <- mAsk
+ -- anns <- mAsk
when shouldAddComment $ do
layoutWriteAppend
$ Text.pack
$ "{-"
- ++ show (annKey, Map.lookup annKey anns)
+ ++ show (annKey, Map.lookup annKey {-anns-} undefined :: Maybe String)
++ "-}"
zip [1 ..] tlines `forM_` \(i, l) -> do
layoutWriteAppend $ l
@@ -152,7 +152,7 @@ layoutBriDocM = \case
state <- mGet
let filterF k _ = not $ k `Set.member` subKeys
mSet $ state
- { _lstate_comments = Map.filterWithKey filterF $ _lstate_comments state
+ { _lstate_comments = undefined -- Map.filterWithKey filterF $ _lstate_comments state
}
BDPlain t -> do
layoutWriteAppend t
@@ -162,12 +162,12 @@ layoutBriDocM = \case
let
moveToExactLocationAction = case _lstate_curYOrAddNewline state of
Left{} -> pure ()
- Right{} -> moveToExactAnn annKey
+ Right{} -> undefined -- moveToExactAnn annKey
mAnn <- do
- let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m
+ let mAnn = {-ExactPrint.annPriorComments-} undefined <$> Map.lookup annKey m
mSet $ state
{ _lstate_comments = Map.adjust
- (\ann -> ann { ExactPrint.annPriorComments = [] })
+ (\ann -> ann {- ExactPrint.annPriorComments = [] -})
annKey
m
}
@@ -177,20 +177,20 @@ layoutBriDocM = \case
Just [] -> moveToExactLocationAction
Just priors -> do
-- layoutResetSepSpace
- priors
- `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
- when (comment /= "(" && comment /= ")") $ do
- let commentLines = Text.lines $ Text.pack $ comment
- case comment of
- ('#' : _) ->
- layoutMoveToCommentPos y (-999) (length commentLines)
- -- ^ evil hack for CPP
- _ -> layoutMoveToCommentPos y x (length commentLines)
- -- fixedX <- fixMoveToLineByIsNewline x
- -- replicateM_ fixedX layoutWriteNewline
- -- layoutMoveToIndentCol y
- layoutWriteAppendMultiline commentLines
- -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
+ -- priors
+ -- `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
+ -- when (comment /= "(" && comment /= ")") $ do
+ -- let commentLines = Text.lines $ Text.pack $ comment
+ -- case comment of
+ -- ('#' : _) ->
+ -- layoutMoveToCommentPos y (-999) (length commentLines)
+ -- -- ^ evil hack for CPP
+ -- _ -> layoutMoveToCommentPos y x (length commentLines)
+ -- -- fixedX <- fixMoveToLineByIsNewline x
+ -- -- replicateM_ fixedX layoutWriteNewline
+ -- -- layoutMoveToIndentCol y
+ -- layoutWriteAppendMultiline commentLines
+ -- -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
moveToExactLocationAction
layoutBriDocM bd
BDAnnotationKW annKey keyword bd -> do
@@ -198,22 +198,22 @@ layoutBriDocM = \case
mComments <- do
state <- mGet
let m = _lstate_comments state
- let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
+ let mAnn = {-ExactPrint.annsDP-} undefined <$> Map.lookup annKey m
let
mToSpan = case mAnn of
Just anns | Maybe.isNothing keyword -> Just anns
- Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 ->
- Just annR
+ -- Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 ->
+ -- Just annR
_ -> Nothing
case mToSpan of
Just anns -> do
let
(comments, rest) = flip spanMaybe anns $ \case
- (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp)
+ -- (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp)
_ -> Nothing
mSet $ state
{ _lstate_comments = Map.adjust
- (\ann -> ann { ExactPrint.annsDP = rest })
+ (\ann -> ann {- ExactPrint.annsDP = rest -})
annKey
m
}
@@ -221,21 +221,22 @@ layoutBriDocM = \case
_ -> return Nothing
case mComments of
Nothing -> pure ()
- Just comments -> do
- comments
- `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
- when (comment /= "(" && comment /= ")") $ do
- let commentLines = Text.lines $ Text.pack $ comment
- -- evil hack for CPP:
- case comment of
- ('#' : _) ->
- layoutMoveToCommentPos y (-999) (length commentLines)
- _ -> layoutMoveToCommentPos y x (length commentLines)
- -- fixedX <- fixMoveToLineByIsNewline x
- -- replicateM_ fixedX layoutWriteNewline
- -- layoutMoveToIndentCol y
- layoutWriteAppendMultiline commentLines
- -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
+ Just comments -> undefined
+ -- do
+ -- comments
+ -- `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
+ -- when (comment /= "(" && comment /= ")") $ do
+ -- let commentLines = Text.lines $ Text.pack $ comment
+ -- -- evil hack for CPP:
+ -- case comment of
+ -- ('#' : _) ->
+ -- layoutMoveToCommentPos y (-999) (length commentLines)
+ -- _ -> layoutMoveToCommentPos y x (length commentLines)
+ -- -- fixedX <- fixMoveToLineByIsNewline x
+ -- -- replicateM_ fixedX layoutWriteNewline
+ -- -- layoutMoveToIndentCol y
+ -- layoutWriteAppendMultiline commentLines
+ -- -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
BDAnnotationRest annKey bd -> do
layoutBriDocM bd
annMay <- do
@@ -247,7 +248,7 @@ layoutBriDocM = \case
semiCount = length
[ ()
| Just ann <- [annMay]
- , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann
+ -- , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann
]
shouldAddSemicolonNewlines <-
mAsk
@@ -257,12 +258,12 @@ layoutBriDocM = \case
mModify $ \state -> state
{ _lstate_comments = Map.adjust
(\ann -> ann
- { ExactPrint.annFollowingComments = []
- , ExactPrint.annPriorComments = []
- , ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case
- (ExactPrint.Types.AnnComment{}, _) -> False
- _ -> True
- }
+ -- { ExactPrint.annFollowingComments = []
+ -- , ExactPrint.annPriorComments = []
+ -- , ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case
+ -- (ExactPrint.Types.AnnComment{}, _) -> False
+ -- _ -> True
+ -- }
)
annKey
(_lstate_comments state)
@@ -271,41 +272,44 @@ layoutBriDocM = \case
Nothing -> do
when shouldAddSemicolonNewlines $ do
[1 .. semiCount] `forM_` const layoutWriteNewline
- Just comments -> do
- comments
- `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
- when (comment /= "(" && comment /= ")") $ do
- let commentLines = Text.lines $ Text.pack comment
- case comment of
- ('#' : _) -> layoutMoveToCommentPos y (-999) 1
- -- ^ evil hack for CPP
- ")" -> pure ()
- -- ^ fixes the formatting of parens
- -- on the lhs of type alias defs
- _ -> layoutMoveToCommentPos y x (length commentLines)
- -- fixedX <- fixMoveToLineByIsNewline x
- -- replicateM_ fixedX layoutWriteNewline
- -- layoutMoveToIndentCol y
- layoutWriteAppendMultiline commentLines
- -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
+ Just comments -> undefined
+ -- do
+ -- comments
+ -- `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
+ -- when (comment /= "(" && comment /= ")") $ do
+ -- let commentLines = Text.lines $ Text.pack comment
+ -- case comment of
+ -- ('#' : _) -> layoutMoveToCommentPos y (-999) 1
+ -- -- ^ evil hack for CPP
+ -- ")" -> pure ()
+ -- -- ^ fixes the formatting of parens
+ -- -- on the lhs of type alias defs
+ -- _ -> layoutMoveToCommentPos y x (length commentLines)
+ -- -- fixedX <- fixMoveToLineByIsNewline x
+ -- -- replicateM_ fixedX layoutWriteNewline
+ -- -- layoutMoveToIndentCol y
+ -- layoutWriteAppendMultiline commentLines
+ -- -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do
mDP <- do
state <- mGet
let m = _lstate_comments state
- let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
+ -- let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
let
- relevant =
- [ dp
- | Just ann <- [mAnn]
- , (ExactPrint.Types.G kw1, dp) <- ann
- , keyword == kw1
- ]
+ relevant = undefined
+ -- [ dp
+ -- | Just ann <- [mAnn]
+ -- -- , (ExactPrint.Types.G kw1, dp) <- ann
+
+ -- , keyword == kw1
+ -- ]
-- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant]
case relevant of
[] -> pure Nothing
- (ExactPrint.Types.DP (y, x) : _) -> do
- mSet state { _lstate_commentNewlines = 0 }
- pure $ Just (y - _lstate_commentNewlines state, x)
+ _ -> pure undefined
+ -- (ExactPrint.Types.DP (y, x) : _) -> do
+ -- mSet state { _lstate_commentNewlines = 0 }
+ -- pure $ Just (y - _lstate_commentNewlines state, x)
case mDP of
Nothing -> pure ()
Just (y, x) ->
diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs
index 3198f86..c2ace35 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Types.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Types.hs
@@ -27,7 +27,7 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
-- import Language.Haskell.GHC.ExactPrint.Types (Anns)
import qualified Safe
-type Anns = ()
+type Anns = Map AnnKey ()
type AnnKey = ()
data PerItemConfig = PerItemConfig
--
2.30.2
From ee48d4a2f521ba8f396171bdaaa5d97227db27fa Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Sun, 30 Jan 2022 16:30:02 +0300
Subject: [PATCH 15/35] A little movement in Type
---
.../Haskell/Brittany/Internal/Layouters/Type.hs | 11 +++++------
1 file changed, 5 insertions(+), 6 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs
index 1662ffb..f89e11b 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs
@@ -8,6 +8,7 @@ import GHC (AnnKeywordId(..), GenLocated(L))
import GHC.Hs
import qualified GHC.OldList as List
import GHC.Types.Basic
+import qualified GHC.Types.SourceText
import GHC.Utils.Outputable (ftext, showSDocUnsafe)
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Prelude
@@ -291,8 +292,6 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
]
HsTupleTy _ tupleSort typs -> case tupleSort of
HsUnboxedTuple -> unboxed
- HsBoxedTuple -> simple
- HsConstraintTuple -> simple
HsBoxedOrConstraintTuple -> simple
where
unboxed = if null typs
@@ -573,11 +572,11 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsExplicitTupleTy{} -> -- TODO
briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype
HsTyLit _ lit -> case lit of
- HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext
- HsNumTy NoSourceText _ ->
+ HsNumTy (GHC.Types.SourceText.SourceText srctext) _ -> docLit $ Text.pack srctext
+ HsNumTy GHC.Types.SourceText.NoSourceText _ ->
error "overLitValBriDoc: literal with no SourceText"
- HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext
- HsStrTy NoSourceText _ ->
+ HsStrTy (GHC.Types.SourceText.SourceText srctext) _ -> docLit $ Text.pack srctext
+ HsStrTy GHC.Types.SourceText.NoSourceText _ ->
error "overLitValBriDoc: literal with no SourceText"
HsWildCardTy _ -> docLit $ Text.pack "_"
HsSumTy{} -> -- TODO
--
2.30.2
From 422f93db20db4cd1cb2a2c8bbe7bdddf8171b079 Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Sun, 30 Jan 2022 16:31:17 +0300
Subject: [PATCH 16/35] Upgrade ToBriDoc itself + in Type
---
.../Language/Haskell/Brittany/Internal/Layouters/Type.hs | 2 +-
source/library/Language/Haskell/Brittany/Internal/Types.hs | 4 ++--
2 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs
index f89e11b..b680984 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs
@@ -19,7 +19,7 @@ import Language.Haskell.Brittany.Internal.Utils
-layoutType :: ToBriDoc HsType
+layoutType :: ToBriDoc ann HsType
layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible"
HsTyVar _ promoted name -> do
diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs
index c2ace35..822fd84 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Types.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Types.hs
@@ -18,7 +18,7 @@ import Data.Generics.Uniplate.Direct as Uniplate
import qualified Data.Kind as Kind
import qualified Data.Strict.Maybe as Strict
import qualified Data.Text.Lazy.Builder as Text.Builder
-import GHC (AnnKeywordId, GenLocated, Located, SrcSpan)
+import GHC (AnnKeywordId, GenLocated, Located, LocatedAn, SrcSpan)
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
@@ -220,7 +220,7 @@ type ToBriDocM = MultiRWSS.MultiRWS
'[[BrittanyError], Seq String] -- writer
'[NodeAllocIndex] -- state
-type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered
+type ToBriDoc an (sym :: Kind.Type -> Kind.Type) = LocatedAn an (sym GhcPs) -> ToBriDocM BriDocNumbered
type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered
type ToBriDocC sym c = Located sym -> ToBriDocM c
--
2.30.2
From b575d4a574f9ad012b47b9865d248b9fe8112679 Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Sun, 30 Jan 2022 21:49:35 +0300
Subject: [PATCH 17/35] Upgrade strategyLeftRight + smth else
---
.../Brittany/Internal/LayouterBasics.hs | 8 ++++----
.../Brittany/Internal/Layouters/DataDecl.hs | 20 +++++++++++--------
2 files changed, 16 insertions(+), 12 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
index 6bc1dd7..4fc70b0 100644
--- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
@@ -17,7 +17,7 @@ import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as Text.Builder
import DataTreePrint
-import GHC (GenLocated(L), Located, moduleName, moduleNameString)
+import GHC (GenLocated(L), Located, LocatedAn, moduleName, moduleNameString)
import qualified GHC.OldList as List
import GHC.Parser.Annotation (AnnKeywordId(..))
import GHC.Types.Name (getOccString)
@@ -639,15 +639,15 @@ docNodeMoveToKWDP ast kw shouldRestoreIndent bdm =
class DocWrapable a where
docWrapNode :: ( Data.Data.Data ast)
- => Located ast
+ => LocatedAn an ast
-> a
-> a
docWrapNodePrior :: ( Data.Data.Data ast)
- => Located ast
+ => LocatedAn an ast
-> a
-> a
docWrapNodeRest :: ( Data.Data.Data ast)
- => Located ast
+ => LocatedAn an ast
-> a
-> a
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
index 37f648e..3cecab9 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
@@ -275,29 +275,33 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of
$ List.intersperse docCommaSep
$ ts
<&> \case
- HsIB _ t -> layoutType t
+ _ -> undefined
+ -- HsIB _ t -> layoutType t
, whenMoreThan1Type ")"
, rhsStrategy
]
where
+ strategyLeftRight
+ :: GenLocated (SrcAnn ann) (DerivStrategy GhcPs)
+ -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)
strategyLeftRight = \case
- (L _ StockStrategy) -> (docLitS " stock", docEmpty)
- (L _ AnyclassStrategy) -> (docLitS " anyclass", docEmpty)
- (L _ NewtypeStrategy) -> (docLitS " newtype", docEmpty)
+ (L _ (StockStrategy _)) -> (docLitS " stock", docEmpty)
+ (L _ (AnyclassStrategy _)) -> (docLitS " anyclass", docEmpty)
+ (L _ (NewtypeStrategy _)) -> (docLitS " newtype", docEmpty)
lVia@(L _ (ViaStrategy viaTypes)) ->
( docEmpty
, case viaTypes of
- HsIB _ext t ->
- docSeq [docWrapNode lVia $ docLitS " via", docSeparator, layoutType t]
+ XViaStrategyPs _epann (L _span (HsSig _sig _bndrs t)) ->
+ docSeq [docWrapNode lVia $ docLitS " via", docSeparator, layoutType t]
)
docDeriving :: ToBriDocM BriDocNumbered
docDeriving = docLitS "deriving"
createDetailsDoc
- :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered)
+ :: Text -> HsConDeclH98Details GhcPs -> (ToBriDocM BriDocNumbered)
createDetailsDoc consNameStr details = case details of
- PrefixCon args -> do
+ PrefixCon _ args -> do
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
let
singleLine = docSeq
--
2.30.2
From d1e940ebb12bea63a71591fbf092aa7eadcc30ad Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Sun, 30 Jan 2022 22:02:15 +0300
Subject: [PATCH 18/35] ()
---
.../Language/Haskell/Brittany/Internal/LayouterBasics.hs | 8 ++++----
.../Haskell/Brittany/Internal/Layouters/DataDecl.hs | 2 +-
2 files changed, 5 insertions(+), 5 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
index 4fc70b0..0dd6de0 100644
--- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
@@ -620,7 +620,7 @@ docTick = docLit $ Text.pack "'"
docNodeAnnKW
:: Data.Data.Data ast
- => Located ast
+ => LocatedAn an ast
-> Maybe AnnKeywordId
-> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
@@ -639,15 +639,15 @@ docNodeMoveToKWDP ast kw shouldRestoreIndent bdm =
class DocWrapable a where
docWrapNode :: ( Data.Data.Data ast)
- => LocatedAn an ast
+ => Located ast
-> a
-> a
docWrapNodePrior :: ( Data.Data.Data ast)
- => LocatedAn an ast
+ => Located ast
-> a
-> a
docWrapNodeRest :: ( Data.Data.Data ast)
- => LocatedAn an ast
+ => Located ast
-> a
-> a
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
index 3cecab9..c3df7e8 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
@@ -282,7 +282,7 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of
]
where
strategyLeftRight
- :: GenLocated (SrcAnn ann) (DerivStrategy GhcPs)
+ :: Located (DerivStrategy GhcPs)
-> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)
strategyLeftRight = \case
(L _ (StockStrategy _)) -> (docLitS " stock", docEmpty)
--
2.30.2
From b4066c5141439bb901d5cc1738b91a2bead605e1 Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Sun, 30 Jan 2022 22:04:52 +0300
Subject: [PATCH 19/35] Upgrade lardrNameToTextAnnGen to LocatedAn
---
.../Language/Haskell/Brittany/Internal/LayouterBasics.hs | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
index 0dd6de0..1694eb3 100644
--- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
@@ -152,7 +152,7 @@ lrdrNameToTextAnnGen
-- , MonadMultiReader (Map AnnKey Annotation) m
)
=> (Text -> Text)
- -> Located RdrName
+ -> LocatedAn an RdrName
-> m Text
lrdrNameToTextAnnGen f ast@(L _ n) = do
-- anns <- mAsk
@@ -181,7 +181,7 @@ lrdrNameToTextAnn
:: (MonadMultiReader Config m
-- , MonadMultiReader (Map AnnKey Annotation) m
)
- => Located RdrName
+ => LocatedAn an RdrName
-> m Text
lrdrNameToTextAnn = lrdrNameToTextAnnGen id
@@ -189,7 +189,7 @@ lrdrNameToTextAnnTypeEqualityIsSpecial
:: (MonadMultiReader Config m
-- , MonadMultiReader (Map AnnKey Annotation) m
)
- => Located RdrName
+ => LocatedAn an RdrName
-> m Text
lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
let
@@ -209,7 +209,7 @@ lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick
-- , MonadMultiReader (Map AnnKey Annotation) m
)
=> Located ast
- -> Located RdrName
+ -> LocatedAn an RdrName
-> m Text
lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do
hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote
--
2.30.2
From ed5bf856a9bcbf7428f5942b1b6a4e1d8ba7649a Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Sun, 30 Jan 2022 22:44:54 +0300
Subject: [PATCH 20/35] Type-fixing layoutDataDecl
---
.../Brittany/Internal/LayouterBasics.hs | 16 ++---
.../Brittany/Internal/Layouters/DataDecl.hs | 63 ++++++++++---------
2 files changed, 40 insertions(+), 39 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
index 1694eb3..ca32220 100644
--- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
@@ -67,8 +67,8 @@ processDefault x = do
briDocByExact
::
-- (ExactPrint.Annotate.Annotate ast)
- Data ast
- => Located ast
+ (Data ast, Data an)
+ => LocatedAn an ast
-> ToBriDocM BriDocNumbered
briDocByExact ast = do
-- anns <- mAsk
@@ -86,8 +86,8 @@ briDocByExact ast = do
briDocByExactNoComment
::
-- (ExactPrint.Annotate.Annotate ast)
- Data ast
- => Located ast
+ (Data ast, Data an)
+ => LocatedAn an ast
-> ToBriDocM BriDocNumbered
briDocByExactNoComment ast = do
-- anns <- mAsk
@@ -477,7 +477,7 @@ docLitS s = allocateNode $ BDFLit $ Text.pack s
docExt
::
-- (ExactPrint.Annotate.Annotate ast)
- Located ast
+ LocatedAn an ast
-- -> ExactPrint.Types.Anns
-> Bool
-> ToBriDocM BriDocNumbered
@@ -639,15 +639,15 @@ docNodeMoveToKWDP ast kw shouldRestoreIndent bdm =
class DocWrapable a where
docWrapNode :: ( Data.Data.Data ast)
- => Located ast
+ => LocatedAn an ast
-> a
-> a
docWrapNodePrior :: ( Data.Data.Data ast)
- => Located ast
+ => LocatedAn an ast
-> a
-> a
docWrapNodeRest :: ( Data.Data.Data ast)
- => Located ast
+ => LocatedAn an ast
-> a
-> a
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
index c3df7e8..500444f 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
@@ -20,16 +20,16 @@ import Language.Haskell.Brittany.Internal.Types
layoutDataDecl
- :: Located (TyClDecl GhcPs)
- -> Located RdrName
+ :: LocatedAn an1 (TyClDecl GhcPs)
+ -> LocatedAn an2 RdrName
-> LHsQTyVars GhcPs
-> HsDataDefn GhcPs
-> ToBriDocM BriDocNumbered
layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- newtype MyType a b = MyType ..
- HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs ->
+ HsDataDefn _ext NewType _ctxt _ctype Nothing [cons] mDerivs ->
case cons of
- (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc))
+ (L _ (ConDeclH98 _ext consName False _qvars (Just (L _ [])) details _conDoc))
-> docWrapNode ltycl $ do
nameStr <- lrdrNameToTextAnn name
consNameStr <- lrdrNameToTextAnn consName
@@ -54,9 +54,9 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- data MyData a b
-- (zero constructors)
- HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs ->
+ HsDataDefn _ext DataType mLhsContext _ctype Nothing [] mDerivs ->
docWrapNode ltycl $ do
- lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
+ lhsContextDoc <- docSharedWrapper createContextDoc mLhsContext
nameStr <- lrdrNameToTextAnn name
tyVarLine <- return <$> createBndrDoc bndrs
createDerivingPar mDerivs $ docSeq
@@ -68,11 +68,11 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- data MyData = MyData ..
-- data MyData = MyData { .. }
- HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs ->
+ HsDataDefn _ext DataType mLhsContext _ctype Nothing [cons] mDerivs ->
case cons of
- (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc))
+ (L _ (ConDeclH98 _ext consName _hasExt qvars mRhsContext details _conDoc))
-> docWrapNode ltycl $ do
- lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
+ lhsContextDoc <- docSharedWrapper createContextDoc mLhsContext
nameStr <- lrdrNameToTextAnn name
consNameStr <- lrdrNameToTextAnn consName
tyVarLine <- return <$> createBndrDoc bndrs
@@ -81,7 +81,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
Just x -> Just . pure <$> x
rhsContextDocMay <- case mRhsContext of
Nothing -> pure Nothing
- Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt
+ Just lctxt -> Just . pure <$> createContextDoc (Just lctxt)
rhsDoc <- return <$> createDetailsDoc consNameStr details
consDoc <-
fmap pure
@@ -200,28 +200,29 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
_ -> briDocByExactNoComment ltycl
-createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered
-createContextDoc [] = docEmpty
-createContextDoc [t] =
- docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator]
-createContextDoc (t1 : tR) = do
- t1Doc <- docSharedWrapper layoutType t1
- tRDocs <- tR `forM` docSharedWrapper layoutType
- docAlt
- [ docSeq
- [ docLitS "("
- , docForceSingleline $ docSeq $ List.intersperse
- docCommaSep
- (t1Doc : tRDocs)
- , docLitS ") =>"
- , docSeparator
+createContextDoc :: Maybe (LHsContext GhcPs) -> ToBriDocM BriDocNumbered
+createContextDoc Nothing = docEmpty
+createContextDoc (Just (L _ lhsContext)) = case lhsContext of
+ [] -> docEmpty
+ [t] -> docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator]
+ (t1 : tR) -> do
+ t1Doc <- docSharedWrapper layoutType t1
+ tRDocs <- tR `forM` docSharedWrapper layoutType
+ docAlt
+ [ docSeq
+ [ docLitS "("
+ , docForceSingleline $ docSeq $ List.intersperse
+ docCommaSep
+ (t1Doc : tRDocs)
+ , docLitS ") =>"
+ , docSeparator
+ ]
+ , docLines $ join
+ [ [docSeq [docLitS "(", docSeparator, t1Doc]]
+ , tRDocs <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc]
+ , [docLitS ") =>", docSeparator]
+ ]
]
- , docLines $ join
- [ [docSeq [docLitS "(", docSeparator, t1Doc]]
- , tRDocs <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc]
- , [docLitS ") =>", docSeparator]
- ]
- ]
createBndrDoc :: [LHsTyVarBndr flag GhcPs] -> ToBriDocM BriDocNumbered
createBndrDoc bs = do
--
2.30.2
From 648d4a0459c109864fc551ce523bf8011bbc4e05 Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Sun, 30 Jan 2022 23:08:37 +0300
Subject: [PATCH 21/35] Typefix DataDecl (??)
---
.../Brittany/Internal/Layouters/DataDecl.hs | 32 +++++++++----------
1 file changed, 16 insertions(+), 16 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
index 500444f..d986b07 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
@@ -20,7 +20,8 @@ import Language.Haskell.Brittany.Internal.Types
layoutDataDecl
- :: LocatedAn an1 (TyClDecl GhcPs)
+ :: Data.Data.Data an1
+ => LocatedAn an1 (TyClDecl GhcPs)
-> LocatedAn an2 RdrName
-> LHsQTyVars GhcPs
-> HsDataDefn GhcPs
@@ -247,20 +248,20 @@ createBndrDoc bs = do
createDerivingPar
:: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
createDerivingPar derivs mainDoc = do
- case derivs of
- (L _ []) -> mainDoc
- (L _ types) ->
- docPar mainDoc
- $ docEnsureIndent BrIndentRegular
- $ docLines
- $ docWrapNode derivs
- $ derivingClauseDoc
- <$> types
+ docPar mainDoc
+ $ docEnsureIndent BrIndentRegular
+ $ docLines
+ $ docWrapNode (noLocA derivs)
+ $ derivingClauseDoc
+ <$> derivs
derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered
derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of
- (L _ []) -> docSeq []
- (L _ ts) ->
+ (L _ (DctSingle _ t)) -> derivingClauseDoc' [t]
+ (L _ (DctMulti _ ts)) -> derivingClauseDoc' ts
+ where
+ derivingClauseDoc' [] = docSeq []
+ derivingClauseDoc' ts =
let
tsLength = length ts
whenMoreThan1Type val = if tsLength > 1 then docLitS val else docLitS ""
@@ -281,7 +282,6 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of
, whenMoreThan1Type ")"
, rhsStrategy
]
- where
strategyLeftRight
:: Located (DerivStrategy GhcPs)
-> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)
@@ -293,7 +293,7 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of
( docEmpty
, case viaTypes of
XViaStrategyPs _epann (L _span (HsSig _sig _bndrs t)) ->
- docSeq [docWrapNode lVia $ docLitS " via", docSeparator, layoutType t]
+ docSeq [docWrapNode (reLocA lVia) $ docLitS " via", docSeparator, layoutType t]
)
docDeriving :: ToBriDocM BriDocNumbered
@@ -426,9 +426,9 @@ createForallDoc lhsTyVarBndrs =
createNamesAndTypeDoc
:: Data.Data.Data ast
- => Located ast
+ => LocatedAn an1 ast
-> [GenLocated t (FieldOcc GhcPs)]
- -> Located (HsType GhcPs)
+ -> LocatedAn an2 (HsType GhcPs)
-> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)
createNamesAndTypeDoc lField names t =
( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq
--
2.30.2
From 05bcc7571a6945915b093ec5b32f50de9a118c58 Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Sun, 30 Jan 2022 23:17:51 +0300
Subject: [PATCH 22/35] Upgrade IE to LocatedAn
---
.../Brittany/Internal/LayouterBasics.hs | 12 ++++----
.../Brittany/Internal/Layouters/Expr.hs-boot | 2 +-
.../Haskell/Brittany/Internal/Layouters/IE.hs | 29 +++++++++----------
3 files changed, 21 insertions(+), 22 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
index ca32220..e24d26c 100644
--- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
@@ -246,14 +246,14 @@ extractRestComments ann =
-- | True if there are any comments that are
-- a) connected to any node below (in AST sense) the given node AND
-- b) after (in source code order) the node.
-hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool
+hasAnyCommentsBelow :: Data ast => GHC.LocatedAn an ast -> ToBriDocM Bool
hasAnyCommentsBelow ast@(L l _) =
- List.any (\(c, _) -> {-ExactPrint.commentIdentifier-} undefined c > ExactPrint.Utils.rs l)
+ List.any (\(c, _) -> {-ExactPrint.commentIdentifier c > ExactPrint.Utils.rs l-} undefined)
<$> astConnectedComments ast
hasCommentsBetween
:: Data ast
- => GHC.Located ast
+ => GHC.LocatedAn an ast
-> AnnKeywordId
-> AnnKeywordId
-> ToBriDocM Bool
@@ -273,12 +273,12 @@ hasCommentsBetween ast leftKey rightKey = do
-- | True if there are any comments that are connected to any node below (in AST
-- sense) the given node
-hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool
+hasAnyCommentsConnected :: Data ast => GHC.LocatedAn an ast -> ToBriDocM Bool
hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast
-- | True if there are any regular comments connected to any node below (in AST
-- sense) the given node
-hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool
+hasAnyRegularCommentsConnected :: Data ast => GHC.LocatedAn an ast -> ToBriDocM Bool
hasAnyRegularCommentsConnected ast =
any {-isRegularComment-} undefined <$> astConnectedComments ast
@@ -299,7 +299,7 @@ type Comment = ()
astConnectedComments
:: Data ast
- => GHC.Located ast
+ => GHC.LocatedAn an ast
-> ToBriDocM [(Comment, DeltaPos)]
astConnectedComments ast = do
undefined
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot
index 4f913c3..93f9286 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot
@@ -7,7 +7,7 @@ import Language.Haskell.Brittany.Internal.Types
-layoutExpr :: ToBriDoc HsExpr
+layoutExpr :: ToBriDoc an HsExpr
-- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs
index 8684842..cee3d87 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs
@@ -23,17 +23,17 @@ import Language.Haskell.Brittany.Internal.Utils
-prepareName :: LIEWrappedName name -> Located name
+prepareName :: LIEWrappedName name -> LocatedN name
prepareName = ieLWrappedName
-layoutIE :: ToBriDoc IE
+layoutIE :: ToBriDoc an IE
layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
IEVar _ x -> layoutWrapped lie x
IEThingAbs _ x -> layoutWrapped lie x
IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
- IEThingWith _ x (IEWildcard _) _ _ ->
+ IEThingWith _ x (IEWildcard _) _ ->
docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
- IEThingWith _ x _ ns _ -> do
+ IEThingWith _ x _ ns -> do
hasComments <- orM
(hasCommentsBetween lie AnnOpenP AnnCloseP
: hasAnyCommentsBelow x
@@ -78,10 +78,10 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
where
layoutWrapped _ = \case
L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n
- L _ (IEPattern n) -> do
+ L _ (IEPattern _ n) -> do
name <- lrdrNameToTextAnn n
docLit $ Text.pack "pattern " <> name
- L _ (IEType n) -> do
+ L _ (IEType _ n) -> do
name <- lrdrNameToTextAnn n
docLit $ Text.pack "type " <> name
@@ -95,7 +95,7 @@ data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted
-- left to the caller since that is context sensitive
layoutAnnAndSepLLIEs
:: SortItemsFlag
- -> Located [LIE GhcPs]
+ -> LocatedAn an [LIE GhcPs]
-> ToBriDocM [ToBriDocM BriDocNumbered]
layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
let makeIENode ie = docSeq [docCommaSep, ie]
@@ -131,7 +131,7 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
isProperIEThing = \case
L _ (IEThingAbs _ _wn) -> True
L _ (IEThingAll _ _wn) -> True
- L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True
+ L _ (IEThingWith _ _wn NoIEWildcard _) -> True
_ -> False
isIEVar :: LIE GhcPs -> Bool
isIEVar = \case
@@ -143,7 +143,7 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
thingFolder _ l2@(L _ IEThingAll{}) = l2
thingFolder l1 (L _ IEThingAbs{}) = l1
thingFolder (L _ IEThingAbs{}) l2 = l2
- thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2))
+ thingFolder (L l (IEThingWith x wn _ consItems1)) (L _ (IEThingWith _ _ _ consItems2))
= L
l
(IEThingWith
@@ -151,7 +151,6 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
wn
NoIEWildcard
(consItems1 ++ consItems2)
- (fieldLbls1 ++ fieldLbls2)
)
thingFolder _ _ =
error "thingFolder should be exhaustive because we have a guard above"
@@ -171,7 +170,7 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
-- ( -- a comment
-- )
layoutLLIEs
- :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered
+ :: Bool -> SortItemsFlag -> LocatedAn an [LIE GhcPs] -> ToBriDocM BriDocNumbered
layoutLLIEs enableSingleline shouldSort llies = do
ieDs <- layoutAnnAndSepLLIEs shouldSort llies
hasComments <- hasAnyCommentsBelow llies
@@ -199,8 +198,8 @@ layoutLLIEs enableSingleline shouldSort llies = do
wrappedNameToText :: LIEWrappedName RdrName -> Text
wrappedNameToText = \case
L _ (IEName n) -> lrdrNameToText n
- L _ (IEPattern n) -> lrdrNameToText n
- L _ (IEType n) -> lrdrNameToText n
+ L _ (IEPattern _ n) -> lrdrNameToText n
+ L _ (IEType _ n) -> lrdrNameToText n
-- | Returns a "fingerprint string", not a full text representation, nor even
-- a source code representation of this syntax node.
@@ -210,7 +209,7 @@ lieToText = \case
L _ (IEVar _ wn) -> wrappedNameToText wn
L _ (IEThingAbs _ wn) -> wrappedNameToText wn
L _ (IEThingAll _ wn) -> wrappedNameToText wn
- L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn
+ L _ (IEThingWith _ wn _ _) -> wrappedNameToText wn
-- TODO: These _may_ appear in exports!
-- Need to check, and either put them at the top (for module) or do some
-- other clever thing.
@@ -219,6 +218,6 @@ lieToText = \case
L _ IEDoc{} -> Text.pack "@IEDoc"
L _ IEDocNamed{} -> Text.pack "@IEDocNamed"
where
- moduleNameToText :: Located ModuleName -> Text
+ moduleNameToText :: LocatedAn an ModuleName -> Text
moduleNameToText (L _ name) =
Text.pack ("@IEModuleContents" ++ moduleNameString name)
--
2.30.2
From a0157b6cfcf62e2a08a7ff0569d4b3b58b7bf506 Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Sun, 30 Jan 2022 23:21:52 +0300
Subject: [PATCH 23/35] Fix Import
---
.../Haskell/Brittany/Internal/Layouters/Import.hs | 11 ++++++-----
1 file changed, 6 insertions(+), 5 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs
index fc17cde..b8424ff 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs
@@ -7,6 +7,7 @@ import qualified Data.Text as Text
import GHC (GenLocated(L), Located, moduleNameString, unLoc)
import GHC.Hs
import GHC.Types.Basic
+import qualified GHC.Types.SourceText
import GHC.Unit.Types (IsBootInterface(..))
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
@@ -17,13 +18,13 @@ import Language.Haskell.Brittany.Internal.Types
-prepPkg :: SourceText -> String
+prepPkg :: GHC.Types.SourceText.SourceText -> String
prepPkg rawN = case rawN of
- SourceText n -> n
+ GHC.Types.SourceText.SourceText n -> n
-- This would be odd to encounter and the
-- result will most certainly be wrong
- NoSourceText -> ""
-prepModName :: Located e -> e
+ GHC.Types.SourceText.NoSourceText -> ""
+prepModName :: LocatedAn an e -> e
prepModName = unLoc
layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered
@@ -36,7 +37,7 @@ layoutImport importD = case importD of
let
compact = indentPolicy /= IndentPolicyFree
modNameT = Text.pack $ moduleNameString modName
- pkgNameT = Text.pack . prepPkg . sl_st <$> pkg
+ pkgNameT = Text.pack . prepPkg . GHC.Types.SourceText.sl_st <$> pkg
masT = Text.pack . moduleNameString . prepModName <$> mas
hiding = maybe False fst mllies
minQLength = length "import qualified "
--
2.30.2
From 1fa45be586e2546c8575bddc2fa0fcb74ab7afa7 Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Sun, 30 Jan 2022 23:32:34 +0300
Subject: [PATCH 24/35] Pull all fake types to a single module
---
.../Language/Haskell/Brittany/Internal/EPCompat.hs | 13 +++++++++++++
.../Haskell/Brittany/Internal/LayouterBasics.hs | 7 +------
.../Haskell/Brittany/Internal/Layouters/Module.hs | 3 ++-
.../Language/Haskell/Brittany/Internal/Types.hs | 3 +--
.../Language/Haskell/Brittany/Internal/Utils.hs | 3 +--
5 files changed, 18 insertions(+), 11 deletions(-)
create mode 100644 source/library/Language/Haskell/Brittany/Internal/EPCompat.hs
diff --git a/source/library/Language/Haskell/Brittany/Internal/EPCompat.hs b/source/library/Language/Haskell/Brittany/Internal/EPCompat.hs
new file mode 100644
index 0000000..16d753d
--- /dev/null
+++ b/source/library/Language/Haskell/Brittany/Internal/EPCompat.hs
@@ -0,0 +1,13 @@
+module Language.Haskell.Brittany.Internal.EPCompat where
+
+import Data.Map (Map)
+
+type DeltaPos = ()
+type Comment = ()
+
+type Annotation = ()
+
+type Anns = Map AnnKey ()
+type AnnKey = ()
+
+type EPAnns = ()
diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
index e24d26c..cd8899a 100644
--- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
@@ -37,7 +37,7 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
-- import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
-
+import Language.Haskell.Brittany.Internal.EPCompat
processDefault
:: (
@@ -294,9 +294,6 @@ hasAnyRegularCommentsConnected ast =
-- isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool
-- isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst
-type DeltaPos = ()
-type Comment = ()
-
astConnectedComments
:: Data ast
=> GHC.LocatedAn an ast
@@ -344,8 +341,6 @@ hasAnnKeyword ast annKeyword = {-astAnn-} astAnn' ast <&> \case
-- astAnn' :: Functor f => Located a -> f (Maybe b)
astAnn' = undefined
-type Annotation = ()
-
-- astAnn
-- :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m)
-- => GHC.Located ast
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs
index 8de45d7..7109a38 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs
@@ -18,8 +18,9 @@ import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.GHC.ExactPrint as ExactPrint
import Language.Haskell.GHC.ExactPrint.Types
- (DeltaPos(..), commentContents, deltaRow)
+ (commentContents)
+import Language.Haskell.Brittany.Internal.EPCompat (Annotation)
layoutModule :: ToBriDoc' HsModule
diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs
index 822fd84..0e0c27d 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Types.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Types.hs
@@ -27,8 +27,7 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
-- import Language.Haskell.GHC.ExactPrint.Types (Anns)
import qualified Safe
-type Anns = Map AnnKey ()
-type AnnKey = ()
+import Language.Haskell.Brittany.Internal.EPCompat
data PerItemConfig = PerItemConfig
{ _icd_perBinding :: Map String (CConfig Maybe)
diff --git a/source/library/Language/Haskell/Brittany/Internal/Utils.hs b/source/library/Language/Haskell/Brittany/Internal/Utils.hs
index 5de87df..154461d 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Utils.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Utils.hs
@@ -32,6 +32,7 @@ import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
import qualified Language.Haskell.Syntax.Extension as HsExtension
import qualified Text.PrettyPrint as PP
+import Language.Haskell.Brittany.Internal.EPCompat
parDoc :: String -> PP.Doc
@@ -74,8 +75,6 @@ instance Show ShowIsId where
data A x = A ShowIsId x
deriving Data
-type EPAnns = ()
-
customLayouterF :: LayouterF
customLayouterF layoutF =
DataToLayouter
--
2.30.2
From 4b4629289a5c2d34fbb1a7d2b518b4deba714914 Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Sun, 30 Jan 2022 23:39:37 +0300
Subject: [PATCH 25/35] Upgrade/hack Module
---
.../Brittany/Internal/LayouterBasics.hs | 2 +-
.../Brittany/Internal/Layouters/Module.hs | 35 ++++++++++---------
.../Haskell/Brittany/Internal/Types.hs | 2 +-
3 files changed, 21 insertions(+), 18 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
index cd8899a..0fe12c1 100644
--- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
@@ -624,7 +624,7 @@ docNodeAnnKW ast kw bdm =
docNodeMoveToKWDP
:: Data.Data.Data ast
- => Located ast
+ => LocatedAn an ast
-> AnnKeywordId
-> Bool
-> ToBriDocM BriDocNumbered
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs
index 7109a38..4b0e602 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs
@@ -23,16 +23,16 @@ import Language.Haskell.GHC.ExactPrint.Types
import Language.Haskell.Brittany.Internal.EPCompat (Annotation)
-layoutModule :: ToBriDoc' HsModule
+layoutModule :: ToBriDoc' an HsModule
layoutModule lmod@(L _ mod') = case mod' of
-- Implicit module Main
- HsModule _ Nothing _ imports _ _ _ -> do
+ HsModule _ _ Nothing _ imports _ _ _ -> do
commentedImports <- transformToCommentedImport imports
-- groupify commentedImports `forM_` tellDebugMessShow
docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports)
-- sortedImports <- sortImports imports
-- docLines $ [layoutImport y i | (y, i) <- sortedImports]
- HsModule _ (Just n) les imports _ _ _ -> do
+ HsModule _ _ (Just n) les imports _ _ _ -> do
commentedImports <- transformToCommentedImport imports
-- groupify commentedImports `forM_` tellDebugMessShow
-- sortedImports <- sortImports imports
@@ -100,11 +100,12 @@ transformToCommentedImport
:: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport]
transformToCommentedImport is = do
nodeWithAnnotations <- is `forM` \i@(L _ rawImport) -> do
- annotionMay <- astAnn i
+ annotionMay <- undefined -- astAnn i
pure (annotionMay, rawImport)
let
- convertComment (c, DP (y, x)) =
- replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))]
+ convertComment (c, _ {-DP (y, x)-}) =
+ undefined
+ -- replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))]
accumF
:: [(Comment, DeltaPos)]
-> (Maybe Annotation, ImportDecl GhcPs)
@@ -121,21 +122,22 @@ transformToCommentedImport is = do
)
Just ann ->
let
- blanksBeforeImportDecl = deltaRow (annEntryDelta ann) - 1
+ blanksBeforeImportDecl = undefined -- deltaRow (annEntryDelta ann) - 1
(newAccumulator, priorComments') =
- List.span ((== 0) . deltaRow . snd) (annPriorComments ann)
+ List.span ((== 0) . {-deltaRow-} undefined . snd) ({-annPriorComments-} undefined ann)
go
:: [(Comment, DeltaPos)]
-> [(Comment, DeltaPos)]
-> ([CommentedImport], [(Comment, DeltaPos)], Int)
go acc [] = ([], acc, 0)
- go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1)
- go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs
- go acc ((c1, DP (y, x)) : xs) =
- ( (convertComment =<< xs) ++ replicate (y - 1) EmptyLine
- , (c1, DP (1, x)) : acc
- , 0
- )
+ go acc _ = undefined
+ -- go acc [c1@(_, {DP (y, _)})] = ([], c1 : acc, y - 1)
+ -- go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs
+ -- go acc ((c1, DP (y, x)) : xs) =
+ -- ( (convertComment =<< xs) ++ replicate (y - 1) EmptyLine
+ -- , (c1, DP (1, x)) : acc
+ -- , 0
+ -- )
(convertedIndependentComments, beforeComments, initialBlanks) =
if blanksBeforeImportDecl /= 0
then (convertComment =<< priorComments', [], 0)
@@ -195,4 +197,5 @@ commentedImportsToDoc = \case
ImportStatement r -> docSeq
(layoutImport (importStatement r) : map commentToDoc (commentsAfter r))
where
- commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c)
+ commentToDoc (c, _ {-DP (_y, x)-}) = undefined
+ -- docLitS (replicate x ' ' ++ commentContents c)
diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs
index 0e0c27d..f930100 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Types.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Types.hs
@@ -220,7 +220,7 @@ type ToBriDocM = MultiRWSS.MultiRWS
'[NodeAllocIndex] -- state
type ToBriDoc an (sym :: Kind.Type -> Kind.Type) = LocatedAn an (sym GhcPs) -> ToBriDocM BriDocNumbered
-type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered
+type ToBriDoc' an sym = LocatedAn an sym -> ToBriDocM BriDocNumbered
type ToBriDocC sym c = Located sym -> ToBriDocM c
data DocMultiLine
--
2.30.2
From c201bdda160b11a990862018a6fdc117574e9468 Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Sun, 30 Jan 2022 23:45:23 +0300
Subject: [PATCH 26/35] Upgrade/hack Pattern
---
.../Language/Haskell/Brittany/Internal/LayouterBasics.hs | 6 +++---
.../Haskell/Brittany/Internal/Layouters/Pattern.hs | 8 ++++----
.../library/Language/Haskell/Brittany/Internal/Types.hs | 2 +-
3 files changed, 8 insertions(+), 8 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
index 0fe12c1..4f28e06 100644
--- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
@@ -103,9 +103,9 @@ briDocByExactNoComment ast = do
briDocByExactInlineOnly
::
-- (ExactPrint.Annotate.Annotate ast)
- (Data ast, ExactPrint.ExactPrint ast)
+ (Data ast, ExactPrint.ExactPrint (LocatedAn an ast), Data an)
=> String
- -> Located ast
+ -> LocatedAn an ast
-> ToBriDocM BriDocNumbered
briDocByExactInlineOnly infoStr ast = do
-- anns <- mAsk
@@ -781,7 +781,7 @@ docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd
unknownNodeError
:: Data.Data.Data ast
=> String
- -> GenLocated GHC.SrcSpan ast
+ -> LocatedAn an ast
-> ToBriDocM BriDocNumbered
unknownNodeError infoStr ast = do
mTell [ErrorUnknownNode infoStr ast]
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
index 773d993..8e36274 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
@@ -57,7 +57,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
-- x1' <- docSeq [docLit $ Text.pack "(", return x1]
-- xN' <- docSeq [return xN, docLit $ Text.pack ")"]
-- return $ (x1' Seq.<| middle) Seq.|> xN'
- ConPat _ lname (PrefixCon args) -> do
+ ConPat _ lname (PrefixCon _tyargs args) -> do
-- Abc a b c -> expr
nameDoc <- lrdrNameToTextAnn lname
argDocs <- layoutPat `mapM` args
@@ -84,7 +84,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
-- Abc { a = locA, b = locB, c = locC } -> expr1
-- Abc { a, b, c } -> expr2
let t = lrdrNameToText lname
- fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do
+ fds <- fs `forM` \(L _ (HsRecField _ (L _ fieldOcc) fPat pun)) -> do
let FieldOcc _ lnameF = fieldOcc
fExpDoc <- if pun
then return Nothing
@@ -111,7 +111,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
| dotdoti == length fs -> do
-- Abc { a = locA, .. }
let t = lrdrNameToText lname
- fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do
+ fds <- fs `forM` \(L _ (HsRecField _ (L _ fieldOcc) fPat pun)) -> do
let FieldOcc _ lnameF = fieldOcc
fExpDoc <- if pun
then return Nothing
@@ -171,7 +171,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
wrapPatPrepend pat1 (docLit $ Text.pack "~")
NPat _ llit@(L _ ol) mNegative _ -> do
-- -13 -> expr
- litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol
+ litDoc <- docWrapNode (reLocA llit) $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol
negDoc <- docLit $ Text.pack "-"
pure $ case mNegative of
Just{} -> Seq.fromList [negDoc, litDoc]
diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs
index f930100..3919eba 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Types.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Types.hs
@@ -145,7 +145,7 @@ data BrittanyError
-- output and second the corresponding, ill-formed input.
| LayoutWarning String
-- ^ some warning
- | forall ast . Data.Data.Data ast => ErrorUnknownNode String (GenLocated SrcSpan ast)
+ | forall ast an. Data.Data.Data ast => ErrorUnknownNode String (LocatedAn an ast)
-- ^ internal error: pretty-printing is not implemented for type of node
-- in the syntax-tree
| ErrorOutputCheck
--
2.30.2
From 75d03534e78483a00974aabb4f60aa4f33b4c17c Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Mon, 31 Jan 2022 00:43:27 +0300
Subject: [PATCH 27/35] Typefixing/hacking Decl (partial)
---
.../Brittany/Internal/ExactPrintUtils.hs | 147 +++++++++---------
.../Brittany/Internal/Layouters/Decl.hs | 54 +++----
.../Brittany/Internal/Layouters/Stmt.hs-boot | 2 +-
.../Haskell/Brittany/Internal/Types.hs | 2 +-
4 files changed, 103 insertions(+), 102 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
index 4635bac..6c4fefc 100644
--- a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
@@ -31,7 +31,7 @@ import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified System.IO
-
+import Language.Haskell.Brittany.Internal.EPCompat
parseModule
:: [String]
@@ -50,72 +50,73 @@ parseModuleFromString
-> IO (Either String (GHC.ParsedSource, a))
parseModuleFromString = ParseModule.parseModule
-{-
+
commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform ()
-commentAnnFixTransformGlob ast = do
- let
- extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
- extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $
- const Seq.empty
- `SYB.ext1Q` (\l@(L span _) ->
- Seq.singleton (span, ExactPrint.mkAnnKey l)
- )
- let nodes = SYB.everything (<>) extract ast
- let
- annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
- annsMap = Map.fromListWith
- (const id)
- [ (GHC.realSrcSpanEnd span, annKey)
- | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes
- ]
- nodes `forM_` (snd .> processComs annsMap)
- where
- processComs annsMap annKey1 = do
- mAnn <- State.Class.gets fst <&> Map.lookup annKey1
- mAnn `forM_` \ann1 -> do
- let
- priors = ExactPrint.annPriorComments ann1
- follows = ExactPrint.annFollowingComments ann1
- assocs = ExactPrint.annsDP ann1
- let
- processCom
- :: (ExactPrint.Comment, ExactPrint.DeltaPos)
- -> ExactPrint.TransformT Identity Bool
- processCom comPair@(com, _) =
- case GHC.realSrcSpanStart $ ExactPrint.commentIdentifier com of
- comLoc -> case Map.lookupLE comLoc annsMap of
- Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of
- (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->
- move $> False
- (x, y) | x == y -> move $> False
- _ -> return True
- where
- ExactPrint.AnnKey annKeyLoc1 con1 = annKey1
- ExactPrint.AnnKey annKeyLoc2 con2 = annKey2
- loc1 = GHC.realSrcSpanStart annKeyLoc1
- loc2 = GHC.realSrcSpanStart annKeyLoc2
- move = ExactPrint.modifyAnnsT $ \anns ->
- let
- ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns
- ann2' = ann2
- { ExactPrint.annFollowingComments =
- ExactPrint.annFollowingComments ann2 ++ [comPair]
- }
- in Map.insert annKey2 ann2' anns
- _ -> return True -- retain comment at current node.
- priors' <- filterM processCom priors
- follows' <- filterM processCom follows
- assocs' <- flip filterM assocs $ \case
- (ExactPrint.AnnComment com, dp) -> processCom (com, dp)
- _ -> return True
- let
- ann1' = ann1
- { ExactPrint.annPriorComments = priors'
- , ExactPrint.annFollowingComments = follows'
- , ExactPrint.annsDP = assocs'
- }
- ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns
--}
+commentAnnFixTransformGlob ast = undefined
+-- do
+-- let
+-- extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
+-- extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $
+-- const Seq.empty
+-- `SYB.ext1Q` (\l@(L span _) ->
+-- Seq.singleton (span, ExactPrint.mkAnnKey l)
+-- )
+-- let nodes = SYB.everything (<>) extract ast
+-- let
+-- annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
+-- annsMap = Map.fromListWith
+-- (const id)
+-- [ (GHC.realSrcSpanEnd span, annKey)
+-- | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes
+-- ]
+-- nodes `forM_` (snd .> processComs annsMap)
+-- where
+-- processComs annsMap annKey1 = do
+-- mAnn <- State.Class.gets fst <&> Map.lookup annKey1
+-- mAnn `forM_` \ann1 -> do
+-- let
+-- priors = ExactPrint.annPriorComments ann1
+-- follows = ExactPrint.annFollowingComments ann1
+-- assocs = ExactPrint.annsDP ann1
+-- let
+-- processCom
+-- :: (ExactPrint.Comment, ExactPrint.DeltaPos)
+-- -> ExactPrint.TransformT Identity Bool
+-- processCom comPair@(com, _) =
+-- case GHC.realSrcSpanStart $ ExactPrint.commentIdentifier com of
+-- comLoc -> case Map.lookupLE comLoc annsMap of
+-- Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of
+-- (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->
+-- move $> False
+-- (x, y) | x == y -> move $> False
+-- _ -> return True
+-- where
+-- ExactPrint.AnnKey annKeyLoc1 con1 = annKey1
+-- ExactPrint.AnnKey annKeyLoc2 con2 = annKey2
+-- loc1 = GHC.realSrcSpanStart annKeyLoc1
+-- loc2 = GHC.realSrcSpanStart annKeyLoc2
+-- move = ExactPrint.modifyAnnsT $ \anns ->
+-- let
+-- ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns
+-- ann2' = ann2
+-- { ExactPrint.annFollowingComments =
+-- ExactPrint.annFollowingComments ann2 ++ [comPair]
+-- }
+-- in Map.insert annKey2 ann2' anns
+-- _ -> return True -- retain comment at current node.
+-- priors' <- filterM processCom priors
+-- follows' <- filterM processCom follows
+-- assocs' <- flip filterM assocs $ \case
+-- (ExactPrint.AnnComment com, dp) -> processCom (com, dp)
+-- _ -> return True
+-- let
+-- ann1' = ann1
+-- { ExactPrint.annPriorComments = priors'
+-- , ExactPrint.annFollowingComments = follows'
+-- , ExactPrint.annsDP = assocs'
+-- }
+-- ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns
+
-- TODO: this is unused by now, but it contains one detail that
-- commentAnnFixTransformGlob does not include: Moving of comments for
@@ -232,12 +233,12 @@ foldedAnnKeys ast = SYB.everything
where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ()))
-}
-{-
+
withTransformedAnns
:: Data ast
=> ast
- -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a
- -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a
+ -> MultiRWSS.MultiRWS '[Config , Anns] w s a
+ -> MultiRWSS.MultiRWS '[Config , Anns] w s a
withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
readers@(conf :+: anns :+: HNil) -> do
-- TODO: implement `local` for MultiReader/MultiRWS
@@ -248,10 +249,10 @@ withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
where
f anns =
let
- ((), (annsBalanced, _), _) =
- ExactPrint.runTransform anns (commentAnnFixTransformGlob ast)
- in annsBalanced
--}
+ ((), _, _) =
+ ExactPrint.runTransform (commentAnnFixTransformGlob ast)
+ in anns
+
warnExtractorCompat :: GHC.Warn -> String
warnExtractorCompat (GHC.Warn _ (L _ s)) = s
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
index 9e22b6e..2b759dd 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
@@ -19,9 +19,9 @@ import GHC.Types.Basic
( Activation(..)
, InlinePragma(..)
, InlineSpec(..)
- , LexicalFixity(..)
, RuleMatchInfo(..)
)
+import GHC.Types.Fixity (LexicalFixity(..))
import GHC.Types.SrcLoc (Located, SrcSpan, getLoc, unLoc)
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.ExactPrintUtils
@@ -35,12 +35,12 @@ import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
-import Language.Haskell.GHC.ExactPrint.Types (mkAnnKey)
+-- import Language.Haskell.GHC.ExactPrint.Types (mkAnnKey)
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint
+import Language.Haskell.Brittany.Internal.EPCompat
-
-layoutDecl :: ToBriDoc HsDecl
+layoutDecl :: ToBriDoc an HsDecl
layoutDecl d@(L loc decl) = case decl of
SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig)
ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case
@@ -57,9 +57,9 @@ layoutDecl d@(L loc decl) = case decl of
-- Sig
--------------------------------------------------------------------------------
-layoutSig :: ToBriDoc Sig
+layoutSig :: ToBriDoc an Sig
layoutSig lsig@(L _loc sig) = case sig of
- TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ
+ TypeSig _ names (HsWC _ (L _ typ)) -> layoutNamesAndType Nothing names typ
InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) ->
docWrapNode lsig $ do
nameStr <- lrdrNameToTextAnn name
@@ -80,8 +80,8 @@ layoutSig lsig@(L _loc sig) = case sig of
$ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr)
<> nameStr
<> Text.pack " #-}"
- ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ
- PatSynSig _ names (HsIB _ typ) ->
+ ClassOpSig _ False names (L _ typ) -> layoutNamesAndType Nothing names typ
+ PatSynSig _ names (L _ typ) ->
layoutNamesAndType (Just "pattern") names typ
_ -> briDocByExactNoComment lsig -- TODO
where
@@ -121,12 +121,12 @@ layoutSig lsig@(L _loc sig) = case sig of
specStringCompat
:: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String
specStringCompat ast = \case
- NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> ""
+ NoUserInlinePrag -> mTell [ErrorUnknownNode "NoUserInline" ast] $> ""
Inline -> pure "INLINE "
Inlinable -> pure "INLINABLE "
NoInline -> pure "NOINLINE "
-layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs))
+layoutGuardLStmt :: ToBriDoc' an (Stmt GhcPs (LHsExpr GhcPs))
layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
BodyStmt _ body _ _ -> layoutExpr body
BindStmt _ lPat expr -> do
@@ -145,7 +145,7 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
--------------------------------------------------------------------------------
layoutBind
- :: ToBriDocC (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered)
+ :: ToBriDocC an (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered)
layoutBind lbind@(L _ bind) = case bind of
FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do
idStr <- lrdrNameToTextAnn fId
@@ -173,7 +173,7 @@ layoutBind lbind@(L _ bind) = case bind of
PatSynBind _ (PSB _ patID lpat rpat dir) -> do
fmap Right $ docWrapNode lbind $ layoutPatSynBind patID lpat dir rpat
_ -> Right <$> unknownNodeError "" lbind
-layoutIPBind :: ToBriDoc IPBind
+layoutIPBind :: ToBriDoc an IPBind
layoutIPBind lipbind@(L _ bind) = case bind of
IPBind _ (Right _) _ -> error "brittany internal error: IPBind Right"
IPBind _ (Left (L _ (HsIPName name))) expr -> do
@@ -198,7 +198,7 @@ bindOrSigtoSrcSpan (BagBind (L l _)) = l
bindOrSigtoSrcSpan (BagSig (L l _)) = l
layoutLocalBinds
- :: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered])
+ :: ToBriDocC an (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered])
layoutLocalBinds lbinds@(L _ binds) = case binds of
-- HsValBinds (ValBindsIn lhsBindsLR []) ->
-- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering
@@ -307,7 +307,7 @@ layoutPatternBindFinal
-> BriDocNumbered
-> Maybe BriDocNumbered
-> [([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)]
- -> Maybe (ExactPrint.AnnKey, [BriDocNumbered])
+ -> Maybe (AnnKey, [BriDocNumbered])
-- ^ AnnKey for the node that contains the AnnWhere position annotation
-> Bool
-> ToBriDocM BriDocNumbered
@@ -663,10 +663,10 @@ layoutPatSynBind name patSynDetails patDir rpat = do
-- | Helper method for the left hand side of a pattern synonym
layoutLPatSyn
- :: Located (IdP GhcPs)
+ :: LocatedAn an (IdP GhcPs)
-> HsPatSynDetails (Located (IdP GhcPs))
-> ToBriDocM BriDocNumbered
-layoutLPatSyn name (PrefixCon vars) = do
+layoutLPatSyn name (PrefixCon _ vars) = do
docName <- lrdrNameToTextAnn name
names <- mapM lrdrNameToTextAnn vars
docSeq . fmap appSep $ docLit docName : (docLit <$> names)
@@ -699,7 +699,7 @@ layoutPatSynWhere hs = case hs of
-- TyClDecl
--------------------------------------------------------------------------------
-layoutTyCl :: ToBriDoc TyClDecl
+layoutTyCl :: ToBriDoc an TyClDecl
layoutTyCl ltycl@(L _loc tycl) = case tycl of
SynDecl _ name vars fixity typ -> do
let
@@ -720,7 +720,7 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of
layoutSynDecl
:: Bool
-> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered)
- -> Located (IdP GhcPs)
+ -> LocatedAn an (IdP GhcPs)
-> [LHsTyVarBndr () GhcPs]
-> LHsType GhcPs
-> ToBriDocM BriDocNumbered
@@ -756,7 +756,7 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do
hasComments <- hasAnyCommentsConnected typ
layoutLhsAndType hasComments sharedLhs "=" typeDoc
-layoutTyVarBndr :: Bool -> ToBriDoc (HsTyVarBndr ())
+layoutTyVarBndr :: Bool -> ToBriDoc an (HsTyVarBndr ())
layoutTyVarBndr needsSep lbndr@(L _ bndr) = do
docWrapNodePrior lbndr $ case bndr of
UserTyVar _ _ name -> do
@@ -783,12 +783,12 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do
layoutTyFamInstDecl
:: Data.Data.Data a
=> Bool
- -> Located a
+ -> LocatedAn an a
-> TyFamInstDecl GhcPs
-> ToBriDocM BriDocNumbered
layoutTyFamInstDecl inClass outerNode tfid = do
let
- FamEqn _ name bndrsMay pats _fixity typ = hsib_body $ tfid_eqn tfid
+ FamEqn _ name bndrsMay pats _fixity typ = L_body $ tfid_eqn tfid
-- bndrsMay isJust e.g. with
-- type instance forall a . MyType (Maybe a) = Either () a
innerNode = outerNode
@@ -842,7 +842,7 @@ layoutHsTyPats pats = pats <&> \case
-- Layout signatures and bindings using the corresponding layouters from the
-- top-level. Layout the instance head, type family instances, and data family
-- instances using ExactPrint.
-layoutClsInst :: ToBriDoc ClsInstDecl
+layoutClsInst :: ToBriDoc an ClsInstDecl
layoutClsInst lcid@(L _ cid) = docLines
[ layoutInstanceHead
, docEnsureIndent BrIndentRegular
@@ -880,10 +880,10 @@ layoutClsInst lcid@(L _ cid) = docLines
. List.sortOn (ExactPrint.rs . getLoc)
=<< sequence l
- layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered)
+ layoutAndLocateSig :: ToBriDocC an (Sig GhcPs) (Located BriDocNumbered)
layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig
- layoutAndLocateBind :: ToBriDocC (HsBind GhcPs) (Located BriDocNumbered)
+ layoutAndLocateBind :: ToBriDocC an (HsBind GhcPs) (Located BriDocNumbered)
layoutAndLocateBind lbind@(L loc _) =
L loc <$> (joinBinds =<< layoutBind lbind)
@@ -894,17 +894,17 @@ layoutClsInst lcid@(L _ cid) = docLines
Right n -> return n
layoutAndLocateTyFamInsts
- :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered)
+ :: ToBriDocC an (TyFamInstDecl GhcPs) (Located BriDocNumbered)
layoutAndLocateTyFamInsts ltfid@(L loc tfid) =
L loc <$> layoutTyFamInstDecl True ltfid tfid
layoutAndLocateDataFamInsts
- :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered)
+ :: ToBriDocC an (DataFamInstDecl GhcPs) (Located BriDocNumbered)
layoutAndLocateDataFamInsts ldfid@(L loc _) =
L loc <$> layoutDataFamInstDecl ldfid
-- | Send to ExactPrint then remove unecessary whitespace
- layoutDataFamInstDecl :: ToBriDoc DataFamInstDecl
+ layoutDataFamInstDecl :: ToBriDoc an DataFamInstDecl
layoutDataFamInstDecl ldfid =
fmap stripWhitespace <$> briDocByExactNoComment ldfid
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot
index 6cfd5c8..319e4ce 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot
@@ -7,4 +7,4 @@ import Language.Haskell.Brittany.Internal.Types
-layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
+layoutStmt :: ToBriDoc' an (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs
index 3919eba..9480332 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Types.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Types.hs
@@ -221,7 +221,7 @@ type ToBriDocM = MultiRWSS.MultiRWS
type ToBriDoc an (sym :: Kind.Type -> Kind.Type) = LocatedAn an (sym GhcPs) -> ToBriDocM BriDocNumbered
type ToBriDoc' an sym = LocatedAn an sym -> ToBriDocM BriDocNumbered
-type ToBriDocC sym c = Located sym -> ToBriDocM c
+type ToBriDocC an sym c = LocatedAn an sym -> ToBriDocM c
data DocMultiLine
= MultiLineNo
--
2.30.2
From e6a38550a0229e50eddd76cdea18f261af9a4c9e Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Mon, 31 Jan 2022 02:22:11 +0300
Subject: [PATCH 28/35] Hack/fix Decl (partial)
---
.../Brittany/Internal/Layouters/Decl.hs | 27 ++++++++++---------
1 file changed, 14 insertions(+), 13 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
index 2b759dd..07a5f24 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
@@ -40,7 +40,7 @@ import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint
import Language.Haskell.Brittany.Internal.EPCompat
-layoutDecl :: ToBriDoc an HsDecl
+layoutDecl :: ToBriDoc AnnListItem HsDecl
layoutDecl d@(L loc decl) = case decl of
SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig)
ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case
@@ -57,9 +57,9 @@ layoutDecl d@(L loc decl) = case decl of
-- Sig
--------------------------------------------------------------------------------
-layoutSig :: ToBriDoc an Sig
+layoutSig :: ToBriDoc AnnListItem Sig
layoutSig lsig@(L _loc sig) = case sig of
- TypeSig _ names (HsWC _ (L _ typ)) -> layoutNamesAndType Nothing names typ
+ TypeSig _ names (HsWC _ (L _ (HsSig _ _ typ))) -> layoutNamesAndType Nothing names typ
InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) ->
docWrapNode lsig $ do
nameStr <- lrdrNameToTextAnn name
@@ -80,8 +80,8 @@ layoutSig lsig@(L _loc sig) = case sig of
$ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr)
<> nameStr
<> Text.pack " #-}"
- ClassOpSig _ False names (L _ typ) -> layoutNamesAndType Nothing names typ
- PatSynSig _ names (L _ typ) ->
+ ClassOpSig _ False names (L _ (HsSig _ _ typ)) -> layoutNamesAndType Nothing names typ
+ PatSynSig _ names (L _ (HsSig _ _ typ)) ->
layoutNamesAndType (Just "pattern") names typ
_ -> briDocByExactNoComment lsig -- TODO
where
@@ -160,7 +160,7 @@ layoutBind lbind@(L _ bind) = case bind of
patDocs <- colsWrapPat =<< layoutPat pat
clauseDocs <- layoutGrhs `mapM` grhss
mWhereDocs <- layoutLocalBinds whereBinds
- let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey?
+ let mWhereArg = mWhereDocs <&> (,) (undefined lbind) -- TODO: is this the right AnnKey?
binderDoc <- docLit $ Text.pack "="
hasComments <- hasAnyCommentsBelow lbind
fmap Right $ docWrapNode lbind $ layoutPatternBindFinal
@@ -198,8 +198,9 @@ bindOrSigtoSrcSpan (BagBind (L l _)) = l
bindOrSigtoSrcSpan (BagSig (L l _)) = l
layoutLocalBinds
- :: ToBriDocC an (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered])
-layoutLocalBinds lbinds@(L _ binds) = case binds of
+ :: HsLocalBindsLR GhcPs GhcPs -> ToBriDocM (Maybe [BriDocNumbered])
+ -- :: ToBriDocC an (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered])
+layoutLocalBinds binds = case binds of
-- HsValBinds (ValBindsIn lhsBindsLR []) ->
-- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering
-- x@(HsValBinds (ValBindsIn{})) ->
@@ -210,7 +211,7 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of
[ BagBind b | b <- Data.Foldable.toList bindlrs ]
++ [ BagSig s | s <- sigs ]
ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered
- docs <- docWrapNode lbinds $ join <$> ordered `forM` \case
+ docs <- docWrapNode (noLocA binds) $ join <$> ordered `forM` \case
BagBind b -> either id return <$> layoutBind b
BagSig s -> return <$> layoutSig s
return $ Just $ docs
@@ -610,8 +611,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
-- | Layout a pattern synonym binding
layoutPatSynBind
- :: Located (IdP GhcPs)
- -> HsPatSynDetails (Located (IdP GhcPs))
+ :: LIdP GhcPs
+ -> HsPatSynDetails GhcPs
-> HsPatSynDir GhcPs
-> LPat GhcPs
-> ToBriDocM BriDocNumbered
@@ -663,8 +664,8 @@ layoutPatSynBind name patSynDetails patDir rpat = do
-- | Helper method for the left hand side of a pattern synonym
layoutLPatSyn
- :: LocatedAn an (IdP GhcPs)
- -> HsPatSynDetails (Located (IdP GhcPs))
+ :: LIdP GhcPs
+ -> HsPatSynDetails GhcPs
-> ToBriDocM BriDocNumbered
layoutLPatSyn name (PrefixCon _ vars) = do
docName <- lrdrNameToTextAnn name
--
2.30.2
From 0fca61a8e3d31d058a10a73ac690331ca54f60dc Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Mon, 31 Jan 2022 03:07:53 +0300
Subject: [PATCH 29/35] Finish Decl
---
.../Brittany/Internal/LayouterBasics.hs | 8 ++---
.../Brittany/Internal/Layouters/Decl.hs | 36 +++++++++----------
2 files changed, 22 insertions(+), 22 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
index 4f28e06..d2b2ff5 100644
--- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
@@ -208,7 +208,7 @@ lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick
, MonadMultiReader Config m
-- , MonadMultiReader (Map AnnKey Annotation) m
)
- => Located ast
+ => LocatedAn an ast
-> LocatedAn an RdrName
-> m Text
lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do
@@ -309,13 +309,13 @@ hasAnyCommentsPrior ast = {-astAnn-} undefined ast <&> \case
Just _ {-(ExactPrint.Types.Ann _ priors _ _ _ _)-} -> not $ null priors
where priors = [undefined]
-hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool
+hasAnyRegularCommentsRest :: Data ast => GHC.LocatedAn an ast -> ToBriDocM Bool
hasAnyRegularCommentsRest ast = {-astAnn-} undefined ast <&> \case
Nothing -> False
Just ann -> undefined -- any isRegularComment (extractRestComments ann)
hasAnnKeywordComment
- :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool
+ :: Data ast => GHC.LocatedAn an ast -> AnnKeywordId -> ToBriDocM Bool
hasAnnKeywordComment ast annKeyword = {-astAnn-} undefined ast <&> \case
Nothing -> False
Just ann -> any hasK ({-extractAllComments-} thing ann)
@@ -328,7 +328,7 @@ hasAnnKeyword
-- , MonadMultiReader (Map AnnKey Annotation) m
, Functor m
)
- => Located a
+ => LocatedAn an a
-> AnnKeywordId
-> m Bool
hasAnnKeyword ast annKeyword = {-astAnn-} astAnn' ast <&> \case
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
index 07a5f24..6401c8d 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
@@ -193,7 +193,7 @@ layoutIPBind lipbind@(L _ bind) = case bind of
data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs)
| BagSig (LSig GhcPs)
-bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan
+bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpanAnnA
bindOrSigtoSrcSpan (BagBind (L l _)) = l
bindOrSigtoSrcSpan (BagSig (L l _)) = l
@@ -210,7 +210,7 @@ layoutLocalBinds binds = case binds of
unordered =
[ BagBind b | b <- Data.Foldable.toList bindlrs ]
++ [ BagSig s | s <- sigs ]
- ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered
+ ordered = List.sortOn (la2r . bindOrSigtoSrcSpan) unordered
docs <- docWrapNode (noLocA binds) $ join <$> ordered `forM` \case
BagBind b -> either id return <$> layoutBind b
BagSig s -> return <$> layoutSig s
@@ -226,7 +226,7 @@ layoutGrhs
:: LGRHS GhcPs (LHsExpr GhcPs)
-> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)
layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do
- guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards
+ guardDocs <- docWrapNode (reLocA lgrhs) $ layoutStmt `mapM` guards
bodyDoc <- layoutExpr body
return (guardDocs, bodyDoc, body)
@@ -275,7 +275,7 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do
$ (List.intersperse docSeparator $ docForceSingleline <$> ps)
clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss
mWhereDocs <- layoutLocalBinds whereBinds
- let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch)
+ let mWhereArg = mWhereDocs <&> (,) ({-mkAnnKey-} undefined lmatch)
let alignmentToken = if null pats then Nothing else funId
hasComments <- hasAnyCommentsBelow lmatch
layoutPatternBindFinal
@@ -678,7 +678,7 @@ layoutLPatSyn name (InfixCon left right) = do
docSeq . fmap (appSep . docLit) $ [leftDoc, docName, rightDoc]
layoutLPatSyn name (RecCon recArgs) = do
docName <- lrdrNameToTextAnn name
- args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs
+ args <- mapM (lrdrNameToTextAnn . rdrNameFieldOcc . recordPatSynField) recArgs
docSeq
. fmap docLit
$ [docName, Text.pack " { "]
@@ -700,7 +700,7 @@ layoutPatSynWhere hs = case hs of
-- TyClDecl
--------------------------------------------------------------------------------
-layoutTyCl :: ToBriDoc an TyClDecl
+layoutTyCl :: Data.Data.Data an => ToBriDoc an TyClDecl
layoutTyCl ltycl@(L _loc tycl) = case tycl of
SynDecl _ name vars fixity typ -> do
let
@@ -721,7 +721,7 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of
layoutSynDecl
:: Bool
-> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered)
- -> LocatedAn an (IdP GhcPs)
+ -> LIdP GhcPs
-> [LHsTyVarBndr () GhcPs]
-> LHsType GhcPs
-> ToBriDocM BriDocNumbered
@@ -789,8 +789,8 @@ layoutTyFamInstDecl
-> ToBriDocM BriDocNumbered
layoutTyFamInstDecl inClass outerNode tfid = do
let
- FamEqn _ name bndrsMay pats _fixity typ = L_body $ tfid_eqn tfid
- -- bndrsMay isJust e.g. with
+ FamEqn _ name bndrs pats _fixity typ = tfid_eqn tfid
+ -- bndrs isJust e.g. with
-- type instance forall a . MyType (Maybe a) = Either () a
innerNode = outerNode
docWrapNodePrior outerNode $ do
@@ -811,7 +811,7 @@ layoutTyFamInstDecl inClass outerNode tfid = do
docWrapNode innerNode
. docSeq
$ [appSep instanceDoc]
- ++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ]
+ ++ [ makeForallDoc foralls | HsOuterExplicit _ foralls <- [bndrs] ]
++ [ docParenL | needsParens ]
++ [appSep $ docWrapNode name $ docLit nameStr]
++ intersperse docSeparator (layoutHsTyPats pats)
@@ -843,7 +843,7 @@ layoutHsTyPats pats = pats <&> \case
-- Layout signatures and bindings using the corresponding layouters from the
-- top-level. Layout the instance head, type family instances, and data family
-- instances using ExactPrint.
-layoutClsInst :: ToBriDoc an ClsInstDecl
+layoutClsInst :: Data.Data.Data an => ToBriDoc an ClsInstDecl
layoutClsInst lcid@(L _ cid) = docLines
[ layoutInstanceHead
, docEnsureIndent BrIndentRegular
@@ -873,18 +873,18 @@ layoutClsInst lcid@(L _ cid) = docLines
-- | Like 'docLines', but sorts the lines based on location
docSortedLines
- :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered
+ :: [ToBriDocM (LocatedAn an BriDocNumbered)] -> ToBriDocM BriDocNumbered
docSortedLines l =
allocateNode
. BDFLines
. fmap unLoc
- . List.sortOn (ExactPrint.rs . getLoc)
+ . List.sortOn (realSrcSpan . getLocA)
=<< sequence l
- layoutAndLocateSig :: ToBriDocC an (Sig GhcPs) (Located BriDocNumbered)
+ layoutAndLocateSig :: ToBriDocC AnnListItem (Sig GhcPs) (LocatedA BriDocNumbered)
layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig
- layoutAndLocateBind :: ToBriDocC an (HsBind GhcPs) (Located BriDocNumbered)
+ layoutAndLocateBind :: ToBriDocC an (HsBind GhcPs) (LocatedAn an BriDocNumbered)
layoutAndLocateBind lbind@(L loc _) =
L loc <$> (joinBinds =<< layoutBind lbind)
@@ -895,17 +895,17 @@ layoutClsInst lcid@(L _ cid) = docLines
Right n -> return n
layoutAndLocateTyFamInsts
- :: ToBriDocC an (TyFamInstDecl GhcPs) (Located BriDocNumbered)
+ :: ToBriDocC an (TyFamInstDecl GhcPs) (LocatedAn an BriDocNumbered)
layoutAndLocateTyFamInsts ltfid@(L loc tfid) =
L loc <$> layoutTyFamInstDecl True ltfid tfid
layoutAndLocateDataFamInsts
- :: ToBriDocC an (DataFamInstDecl GhcPs) (Located BriDocNumbered)
+ :: Data.Data.Data an => ToBriDocC an (DataFamInstDecl GhcPs) (LocatedAn an BriDocNumbered)
layoutAndLocateDataFamInsts ldfid@(L loc _) =
L loc <$> layoutDataFamInstDecl ldfid
-- | Send to ExactPrint then remove unecessary whitespace
- layoutDataFamInstDecl :: ToBriDoc an DataFamInstDecl
+ layoutDataFamInstDecl :: Data.Data.Data an => ToBriDoc an DataFamInstDecl
layoutDataFamInstDecl ldfid =
fmap stripWhitespace <$> briDocByExactNoComment ldfid
--
2.30.2
From 03ba1f3a3d31d434d5008e50b2a6413e0f0c514e Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Mon, 31 Jan 2022 03:12:00 +0300
Subject: [PATCH 30/35] (Poink Stmt)
---
.../Language/Haskell/Brittany/Internal/Layouters/Stmt.hs | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs
index 5ef19c7..4dc0383 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs
@@ -19,7 +19,7 @@ import Language.Haskell.Brittany.Internal.Types
-layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
+layoutStmt :: ToBriDoc' an (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
layoutStmt lstmt@(L _ stmt) = do
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
indentAmount :: Int <-
--
2.30.2
From 800500f7cea6b1d9340e5fd566b8f02b0a01ad0a Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Sat, 12 Feb 2022 16:11:22 +0300
Subject: [PATCH 31/35] Hack on Layouters.Type
---
.../Brittany/Internal/Layouters/Type.hs | 20 ++++++++++---------
1 file changed, 11 insertions(+), 9 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs
index b680984..a384078 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs
@@ -1,10 +1,11 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ViewPatterns #-}
module Language.Haskell.Brittany.Internal.Layouters.Type where
import qualified Data.Text as Text
-import GHC (AnnKeywordId(..), GenLocated(L))
+import GHC (GenLocated(L))
import GHC.Hs
import qualified GHC.OldList as List
import GHC.Types.Basic
@@ -18,8 +19,8 @@ import Language.Haskell.Brittany.Internal.Utils
(FirstLastView(..), splitFirstLast)
-
-layoutType :: ToBriDoc ann HsType
+--- XXX: maybe push `Anno (sym GhcPs)` into ToBriDoc definition in place of a typevar
+layoutType :: ToBriDoc AnnListItem HsType
layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible"
HsTyVar _ promoted name -> do
@@ -27,7 +28,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
case promoted of
IsPromoted -> docSeq [docSeparator, docTick, docWrapNode name $ docLit t]
NotPromoted -> docWrapNode name $ docLit t
- HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do
+ HsForAllTy _ hsf (L _ (HsQualTy _ (fromMaybeContext -> cntxts) typ2)) -> do
let bndrs = getBinders hsf
typeDoc <- docSharedWrapper layoutType typ2
tyVarDocs <- layoutTyVarBndrs bndrs
@@ -160,7 +161,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
]
)
]
- HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do
+ HsQualTy _ (fromMaybe (noLocA []) -> lcntxts@(L _ cntxts)) typ1 -> do
typeDoc <- docSharedWrapper layoutType typ1
cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
let
@@ -578,6 +579,9 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsStrTy (GHC.Types.SourceText.SourceText srctext) _ -> docLit $ Text.pack srctext
HsStrTy GHC.Types.SourceText.NoSourceText _ ->
error "overLitValBriDoc: literal with no SourceText"
+ HsCharTy (GHC.Types.SourceText.SourceText srctext) _ -> docLit $ Text.pack srctext
+ HsCharTy GHC.Types.SourceText.NoSourceText _ ->
+ error "overLitValBriDoc: literal with no SourceText"
HsWildCardTy _ -> docLit $ Text.pack "_"
HsSumTy{} -> -- TODO
briDocByExactInlineOnly "HsSumTy{}" ltype
@@ -621,14 +625,12 @@ processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case
, docLit $ Text.pack ")"
]
-getBinders :: HsForAllTelescope pass -> [LHsTyVarBndr () pass]
+getBinders :: HsForAllTelescope (GhcPass pass) -> [LHsTyVarBndr () (GhcPass pass)]
getBinders x = case x of
HsForAllVis _ b -> b
HsForAllInvis _ b -> fmap withoutSpecificity b
- XHsForAllTelescope _ -> []
-withoutSpecificity :: LHsTyVarBndr flag pass -> LHsTyVarBndr () pass
+withoutSpecificity :: LHsTyVarBndr flag (GhcPass pass) -> LHsTyVarBndr () (GhcPass pass)
withoutSpecificity = fmap $ \case
UserTyVar a _ c -> UserTyVar a () c
KindedTyVar a _ c d -> KindedTyVar a () c d
- XTyVarBndr a -> XTyVarBndr a
--
2.30.2
From ea58f8d46fc0a0c0a45f81492cc3a2ea9592c91a Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Sat, 12 Feb 2022 16:22:37 +0300
Subject: [PATCH 32/35] (Fix DadaDecl)
---
.../Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
index d986b07..e946cd1 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
@@ -428,7 +428,7 @@ createNamesAndTypeDoc
:: Data.Data.Data ast
=> LocatedAn an1 ast
-> [GenLocated t (FieldOcc GhcPs)]
- -> LocatedAn an2 (HsType GhcPs)
+ -> LocatedAn AnnListItem (HsType GhcPs)
-> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)
createNamesAndTypeDoc lField names t =
( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq
--
2.30.2
From 6210024d2450ecd2522583246cb3fbabc6e8cd7d Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Sat, 12 Feb 2022 16:49:55 +0300
Subject: [PATCH 33/35] Fix Stmt
---
.../Language/Haskell/Brittany/Internal/Layouters/Stmt.hs | 4 ++--
.../Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot | 2 +-
2 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs
index 4dc0383..7ce5aed 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs
@@ -19,7 +19,7 @@ import Language.Haskell.Brittany.Internal.Types
-layoutStmt :: ToBriDoc' an (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
+layoutStmt :: ToBriDoc' AnnListItem (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
layoutStmt lstmt@(L _ stmt) = do
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
indentAmount :: Int <-
@@ -94,7 +94,7 @@ layoutStmt lstmt@(L _ stmt) = do
$ docPar
(docLit $ Text.pack "let")
(docSetBaseAndIndent $ docLines $ return <$> bindDocs)
- RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do
+ RecStmt _ (L _ stmts) _ _ _ _ _ -> runFilteredAlternative $ do
-- rec stmt1
-- stmt2
-- stmt3
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot
index 319e4ce..0eb826b 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot
@@ -7,4 +7,4 @@ import Language.Haskell.Brittany.Internal.Types
-layoutStmt :: ToBriDoc' an (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
+layoutStmt :: ToBriDoc' AnnListItem (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
--
2.30.2
From 16a89cdfeb8289d62f7558fca8e7188abd6b208d Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Sat, 12 Feb 2022 17:44:54 +0300
Subject: [PATCH 34/35] Fix Expr
---
.../Brittany/Internal/Layouters/Expr.hs | 62 +++++++++++--------
.../Brittany/Internal/Layouters/Expr.hs-boot | 4 +-
2 files changed, 38 insertions(+), 28 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
index 138a748..8808b10 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
@@ -8,12 +8,13 @@ import qualified Data.Data
import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
-import GHC (AnnKeywordId(..), GenLocated(L), RdrName(..), SrcSpan)
+import GHC (GenLocated(L), RdrName(..))
import qualified GHC.Data.FastString as FastString
import GHC.Hs
import qualified GHC.OldList as List
import GHC.Types.Basic
import GHC.Types.Name
+import GHC.Types.SourceText
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.Decl
@@ -27,7 +28,7 @@ import Language.Haskell.Brittany.Internal.Utils
-layoutExpr :: ToBriDoc HsExpr
+layoutExpr :: ToBriDoc AnnListItem HsExpr
layoutExpr lexpr@(L _ expr) = do
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
let allowFreeIndent = indentPolicy == IndentPolicyFree
@@ -38,7 +39,7 @@ layoutExpr lexpr@(L _ expr) = do
HsRecFld{} -> do
-- TODO
briDocByExactInlineOnly "HsRecFld" lexpr
- HsOverLabel _ext _reboundFromLabel name ->
+ HsOverLabel _ext name ->
let label = FastString.unpackFS name in docLit . Text.pack $ '#' : label
HsIPVar _ext (HsIPName name) ->
let label = FastString.unpackFS name in docLit . Text.pack $ '?' : label
@@ -49,7 +50,7 @@ layoutExpr lexpr@(L _ expr) = do
HsLam _ (MG _ (L _ [lmatch@(L _ match)]) _)
| pats <- m_pats match
, GRHSs _ [lgrhs] llocals <- m_grhss match
- , L _ EmptyLocalBinds{} <- llocals
+ , EmptyLocalBinds{} <- llocals
, L _ (GRHS _ [] body) <- lgrhs
-> do
patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) ->
@@ -86,7 +87,7 @@ layoutExpr lexpr@(L _ expr) = do
[ docLit $ Text.pack "\\"
, docWrapNode lmatch $ docForceSingleline funcPatternPartLine
, appSep $ docLit $ Text.pack "->"
- , docWrapNode lgrhs $ docForceSingleline bodyDoc
+ , docWrapNode (reLocA lgrhs) $ docForceSingleline bodyDoc
]
-- double line
, docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
@@ -97,13 +98,13 @@ layoutExpr lexpr@(L _ expr) = do
, docLit $ Text.pack "->"
]
)
- (docWrapNode lgrhs $ docForceSingleline bodyDoc)
+ (docWrapNode (reLocA lgrhs) $ docForceSingleline bodyDoc)
-- wrapped par spacing
, docSetParSpacing $ docSeq
[ docLit $ Text.pack "\\"
, docWrapNode lmatch $ docForceSingleline funcPatternPartLine
, appSep $ docLit $ Text.pack "->"
- , docWrapNode lgrhs $ docForceParSpacing bodyDoc
+ , docWrapNode (reLocA lgrhs) $ docForceParSpacing bodyDoc
]
-- conservative
, docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar
@@ -114,7 +115,7 @@ layoutExpr lexpr@(L _ expr) = do
, docLit $ Text.pack "->"
]
)
- (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc)
+ (docWrapNode (reLocA lgrhs) $ docNonBottomSpacing bodyDoc)
]
HsLam{} -> unknownNodeError "HsLam too complex" lexpr
HsLamCase _ (MG _ (L _ []) _) -> do
@@ -378,14 +379,14 @@ layoutExpr lexpr@(L _ expr) = do
ExplicitTuple _ args boxity -> do
let
argExprs = args <&> \arg -> case arg of
- (L _ (Present _ e)) -> (arg, Just e)
- (L _ (Missing NoExtField)) -> (arg, Nothing)
+ (Present _ e) -> (arg, Just e)
+ (Missing _) -> (arg, Nothing)
argDocs <- forM argExprs $ docSharedWrapper $ \(arg, exprM) ->
- docWrapNode arg $ maybe docEmpty layoutExpr exprM
+ docWrapNode (noLocA arg) $ maybe docEmpty layoutExpr exprM
hasComments <-
orM
(hasCommentsBetween lexpr AnnOpenP AnnCloseP
- : map hasAnyCommentsBelow args
+ : map (hasAnyCommentsBelow . noLocA) args
)
let
(openLit, closeLit) = case boxity of
@@ -758,7 +759,7 @@ layoutExpr lexpr@(L _ expr) = do
_ -> do
-- TODO
unknownNodeError "HsDo{} unknown stmtCtx" lexpr
- ExplicitList _ _ elems@(_ : _) -> do
+ ExplicitList _ elems@(_ : _) -> do
elemDocs <- elems `forM` docSharedWrapper layoutExpr
hasComments <- hasAnyCommentsBelow lexpr
case splitFirstLast elemDocs of
@@ -800,12 +801,12 @@ layoutExpr lexpr@(L _ expr) = do
[docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN]
end = docLit $ Text.pack "]"
in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]
- ExplicitList _ _ [] -> docLit $ Text.pack "[]"
+ ExplicitList _ [] -> docLit $ Text.pack "[]"
RecordCon _ lname fields -> case fields of
HsRecFields fs Nothing -> do
let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname
rFs <-
- fs `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do
+ fs `forM` \lfield@(L _ (HsRecField _ (L _ fieldOcc) rFExpr pun)) -> do
let FieldOcc _ lnameF = fieldOcc
rFExpDoc <- if pun
then return Nothing
@@ -818,7 +819,7 @@ layoutExpr lexpr@(L _ expr) = do
HsRecFields fs@(_ : _) (Just (L _ dotdoti)) | dotdoti == length fs -> do
let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname
fieldDocs <-
- fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do
+ fs `forM` \fieldl@(L _ (HsRecField _ (L _ fieldOcc) fExpr pun)) -> do
let FieldOcc _ lnameF = fieldOcc
fExpDoc <- if pun
then return Nothing
@@ -826,10 +827,10 @@ layoutExpr lexpr@(L _ expr) = do
return (fieldl, lrdrNameToText lnameF, fExpDoc)
recordExpression True indentPolicy lexpr nameDoc fieldDocs
_ -> unknownNodeError "RecordCon with puns" lexpr
- RecordUpd _ rExpr fields -> do
+ RecordUpd _ rExpr (Left fields) -> do
rExprDoc <- docSharedWrapper layoutExpr rExpr
rFs <-
- fields `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do
+ fields `forM` \lfield@(L _ (HsRecField _ (L _ ambName) rFExpr pun)) -> do
rFExpDoc <- if pun
then return Nothing
else Just <$> docSharedWrapper layoutExpr rFExpr
@@ -837,7 +838,11 @@ layoutExpr lexpr@(L _ expr) = do
Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc)
Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc)
recordExpression False indentPolicy lexpr rExprDoc rFs
- ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do
+ RecordUpd _ _rExpr (Right _projections) -> do
+ -- TODO
+ briDocByExactInlineOnly "RecordUpd _ _ (Right _projections)" lexpr
+
+ ExprWithTySig _ exp1 (HsWC _ (L _ (HsSig _ _ typ1))) -> do
expDoc <- docSharedWrapper layoutExpr exp1
typDoc <- docSharedWrapper layoutType typ1
docSeq [appSep expDoc, appSep $ docLit $ Text.pack "::", typDoc]
@@ -925,14 +930,21 @@ layoutExpr lexpr@(L _ expr) = do
HsPragE{} -> do
-- TODO
briDocByExactInlineOnly "HsPragE{}" lexpr
+ HsGetField{} -> do
+ -- TODO
+ briDocByExactInlineOnly "HsGetField{}" lexpr
+ HsProjection{} -> do
+ -- TODO
+ briDocByExactInlineOnly "HsProjection{}" lexpr
+
recordExpression
:: (Data.Data.Data lExpr, Data.Data.Data name)
=> Bool
-> IndentPolicy
- -> GenLocated SrcSpan lExpr
+ -> LocatedAn an1 lExpr
-> ToBriDocM BriDocNumbered
- -> [ ( GenLocated SrcSpan name
+ -> [ ( LocatedAn an2 name
, Text
, Maybe (ToBriDocM BriDocNumbered)
)
@@ -1073,14 +1085,14 @@ litBriDoc = \case
HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
- HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t
- HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t
- HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t
+ HsRat _ (FL (SourceText t) _ _ _ _) _type -> BDFLit $ Text.pack t
+ HsFloatPrim _ (FL (SourceText t) _ _ _ _) -> BDFLit $ Text.pack t
+ HsDoublePrim _ (FL (SourceText t) _ _ _ _) -> BDFLit $ Text.pack t
_ -> error "litBriDoc: literal with no SourceText"
overLitValBriDoc :: OverLitVal -> BriDocFInt
overLitValBriDoc = \case
HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t
- HsFractional (FL (SourceText t) _ _) -> BDFLit $ Text.pack t
+ HsFractional (FL (SourceText t) _ _ _ _) -> BDFLit $ Text.pack t
HsIsString (SourceText t) _ -> BDFLit $ Text.pack t
_ -> error "overLitValBriDoc: literal with no SourceText"
diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot
index 93f9286..0ffc39e 100644
--- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot
+++ b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot
@@ -7,9 +7,7 @@ import Language.Haskell.Brittany.Internal.Types
-layoutExpr :: ToBriDoc an HsExpr
-
--- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
+layoutExpr :: ToBriDoc AnnListItem HsExpr
litBriDoc :: HsLit GhcPs -> BriDocFInt
--
2.30.2
From a3ae082f296d9bfd4197de54165f52ec0fe1add1 Mon Sep 17 00:00:00 2001
From: mrkun <mrgutkun@gmail.com>
Date: Mon, 14 Feb 2022 16:28:01 +0300
Subject: [PATCH 35/35] Hack on Internal (incomplete)
---
.../Language/Haskell/Brittany/Internal.hs | 142 +++++++++---------
.../Haskell/Brittany/Internal/EPCompat.hs | 2 +-
.../Brittany/Internal/ExactPrintUtils.hs | 25 ++-
3 files changed, 86 insertions(+), 83 deletions(-)
diff --git a/source/library/Language/Haskell/Brittany/Internal.hs b/source/library/Language/Haskell/Brittany/Internal.hs
index 06cbb63..04985d0 100644
--- a/source/library/Language/Haskell/Brittany/Internal.hs
+++ b/source/library/Language/Haskell/Brittany/Internal.hs
@@ -57,7 +57,7 @@ import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified UI.Butcher.Monadic as Butcher
-
+import Language.Haskell.Brittany.Internal.EPCompat as ExactPrint
data InlineConfigTarget
= InlineConfigTargetModule
@@ -73,16 +73,17 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
let
commentLiness =
[ ( k
- , [ x
- | (ExactPrint.Comment x _ _, _) <-
- (ExactPrint.annPriorComments ann
- ++ ExactPrint.annFollowingComments ann
- )
- ]
- ++ [ x
- | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <-
- ExactPrint.annsDP ann
- ]
+ , []
+ -- , [ x
+ -- | (ExactPrint.Comment x _ _, _) <-
+ -- (ExactPrint.annPriorComments ann
+ -- ++ ExactPrint.annFollowingComments ann
+ -- )
+ -- ]
+ -- ++ [ x
+ -- | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <-
+ -- ExactPrint.annsDP ann
+ -- ]
)
| (k, ann) <- Map.toList anns
]
@@ -218,11 +219,12 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap
-getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) =
+getTopLevelDeclNameMap (L _ (HsModule _ _ _name _exports _ decls _ _)) =
TopLevelDeclNameMap $ Map.fromList
- [ (ExactPrint.mkAnnKey decl, name)
- | decl <- decls
- , (name : _) <- [getDeclBindingNames decl]
+ [
+ -- (ExactPrint.mkAnnKey decl, name)
+ -- | decl <- decls
+ -- , (name : _) <- [getDeclBindingNames decl]
]
@@ -245,7 +247,7 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do
let config_pp = config & _conf_preprocessor
let cppMode = config_pp & _ppconf_CPPMode & confUnpack
let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack
- (anns, parsedSource, hasCPP) <- do
+ ({-anns,-} parsedSource, hasCPP) <- do
let
hackF s =
if "#include" `isPrefixOf` s then "-- BRITANY_INCLUDE_HACK " ++ s else s
@@ -270,7 +272,7 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do
Right x -> pure x
(inlineConf, perItemConf) <-
either (throwE . (: []) . uncurry ErrorMacroConfig) pure
- $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)
+ $ extractCommentConfigs {-anns-} undefined (getTopLevelDeclNameMap parsedSource)
let moduleConfig = cZipWith fromOptionIdentity config inlineConf
let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack
if disableFormatting
@@ -285,9 +287,9 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do
& _econf_omit_output_valid_check
& confUnpack
(ews, outRaw) <- if hasCPP || omitCheck
- then return $ pPrintModule moduleConfig perItemConf anns parsedSource
+ then return $ pPrintModule moduleConfig perItemConf {-anns-} undefined parsedSource
else lift
- $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource
+ $ pPrintModuleAndCheck moduleConfig perItemConf {-anns-} undefined parsedSource
let
hackF s = fromMaybe s
$ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
@@ -341,7 +343,7 @@ pPrintModule conf inlineConf anns parsedModule =
$ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns)
$ do
traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations
- $ annsDoc anns
+ $ annsDoc {-anns-} undefined
ppModule parsedModule
tracer = if Seq.null debugStrings
then id
@@ -389,9 +391,9 @@ parsePrintModuleTests conf filename input = do
inputStr
case parseResult of
Left err -> return $ Left err
- Right (anns, parsedModule, _) -> runExceptT $ do
+ Right ({-anns,-} parsedModule, _) -> runExceptT $ do
(inlineConf, perItemConf) <-
- case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of
+ case extractCommentConfigs {-anns-} undefined (getTopLevelDeclNameMap parsedModule) of
Left err -> throwE $ "error in inline config: " ++ show err
Right x -> pure x
let moduleConf = cZipWith fromOptionIdentity conf inlineConf
@@ -402,9 +404,9 @@ parsePrintModuleTests conf filename input = do
.> _econf_omit_output_valid_check
.> confUnpack
(errs, ltext) <- if omitCheck
- then return $ pPrintModule moduleConf perItemConf anns parsedModule
+ then return $ pPrintModule moduleConf perItemConf {-anns-} undefined parsedModule
else lift
- $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule
+ $ pPrintModuleAndCheck moduleConf perItemConf {-anns-} undefined parsedModule
if null errs
then pure $ TextL.toStrict $ ltext
else
@@ -460,18 +462,18 @@ toLocal conf anns m = do
pure x
ppModule :: GenLocated SrcSpan HsModule -> PPM ()
-ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
+ppModule lmod@(L _loc _m@(HsModule _ _ _name _exports _ decls _ _)) = do
defaultAnns <- do
anns <- mAsk
- let annKey = ExactPrint.mkAnnKey lmod
+ let annKey = undefined -- ExactPrint.mkAnnKey lmod
let annMap = Map.findWithDefault Map.empty annKey anns
- let isEof = (== ExactPrint.AnnEofPos)
- let overAnnsDP f a = a { ExactPrint.annsDP = f $ ExactPrint.annsDP a }
- pure $ fmap (overAnnsDP . filter $ isEof . fst) annMap
+ -- let isEof = (== ExactPrint.AnnEofPos)
+ -- let overAnnsDP f a = a { ExactPrint.annsDP = f $ ExactPrint.annsDP a }
+ pure $ undefined {- fmap (overAnnsDP . filter $ isEof . fst) -} annMap
post <- ppPreamble lmod
decls `forM_` \decl -> do
- let declAnnKey = ExactPrint.mkAnnKey decl
+ let declAnnKey = undefined --ExactPrint.mkAnnKey decl
let declBindingNames = getDeclBindingNames decl
inlineConf <- mAsk
let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf
@@ -484,7 +486,7 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
traceIfDumpConf
"bridoc annotations filtered/transformed"
_dconf_dump_annotations
- $ annsDoc filteredAnns
+ $ annsDoc {-filteredAnns-} undefined
config <- mAsk
@@ -505,27 +507,27 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
else briDocMToPPM $ briDocByExactNoComment decl
layoutBriDoc bd
- let
- finalComments = filter
- (fst .> \case
- ExactPrint.AnnComment{} -> True
- _ -> False
- )
- post
+ -- let
+ -- finalComments = filter
+ -- (fst .> \case
+ -- -- ExactPrint.AnnComment{} -> True
+ -- _ -> False
+ -- )
+ -- post
post `forM_` \case
- (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do
- ppmMoveToExactLoc l
- mTell $ Text.Builder.fromString cmStr
- (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) ->
- let
- folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of
- ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm ->
- ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span
- , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span
- )
- _ -> (acc + y, x)
- (cmY, cmX) = foldl' folder (0, 0) finalComments
- in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX)
+ -- (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do
+ -- ppmMoveToExactLoc l
+ -- mTell $ Text.Builder.fromString cmStr
+ -- (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) ->
+ -- let
+ -- folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of
+ -- ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm ->
+ -- ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span
+ -- , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span
+ -- )
+ -- _ -> (acc + y, x)
+ -- (cmY, cmX) = foldl' folder (0, 0) finalComments
+ -- in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX)
_ -> return ()
getDeclBindingNames :: LHsDecl GhcPs -> [String]
@@ -539,10 +541,10 @@ getDeclBindingNames (L _ decl) = case decl of
-- This includes the imports
ppPreamble
:: GenLocated SrcSpan HsModule
- -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)]
+ -> PPM [{- (ExactPrint.KeywordId, ExactPrint.DeltaPos)-} ((), ())]
ppPreamble lmod@(L loc m@HsModule{}) = do
filteredAnns <- mAsk <&> \annMap ->
- Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap
+ Map.findWithDefault Map.empty ({-ExactPrint.mkAnnKey-} undefined lmod) annMap
-- Since ghc-exactprint adds annotations following (implicit)
-- modules to both HsModule and the elements in the module
-- this can cause duplication of comments. So strip
@@ -555,14 +557,14 @@ ppPreamble lmod@(L loc m@HsModule{}) = do
let
(filteredAnns', post) =
- case Map.lookup (ExactPrint.mkAnnKey lmod) filteredAnns of
+ case Map.lookup ({-ExactPrint.mkAnnKey-} undefined lmod) filteredAnns of
Nothing -> (filteredAnns, [])
Just mAnn ->
let
- modAnnsDp = ExactPrint.annsDP mAnn
- isWhere (ExactPrint.G AnnWhere) = True
+ modAnnsDp = undefined -- ExactPrint.annsDP mAnn
+ -- isWhere (ExactPrint.G AnnWhere) = True
isWhere _ = False
- isEof (ExactPrint.AnnEofPos) = True
+ -- isEof (ExactPrint.AnnEofPos) = True
isEof _ = False
whereInd = List.findIndex (isWhere . fst) modAnnsDp
eofInd = List.findIndex (isEof . fst) modAnnsDp
@@ -571,9 +573,9 @@ ppPreamble lmod@(L loc m@HsModule{}) = do
(Just i, Nothing) -> List.splitAt (i + 1) modAnnsDp
(Nothing, Just _i) -> ([], modAnnsDp)
(Just i, Just j) -> List.splitAt (min (i + 1) j) modAnnsDp
- mAnn' = mAnn { ExactPrint.annsDP = pre }
+ mAnn' = mAnn -- { ExactPrint.annsDP = pre }
filteredAnns'' =
- Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns
+ Map.insert ({-ExactPrint.mkAnnKey-} undefined lmod) mAnn' filteredAnns
in (filteredAnns'', post')
traceIfDumpConf
"bridoc annotations filtered/transformed"
@@ -582,7 +584,7 @@ ppPreamble lmod@(L loc m@HsModule{}) = do
if shouldReformatPreamble
then toLocal config filteredAnns' $ withTransformedAnns lmod $ do
- briDoc <- briDocMToPPM $ layoutModule lmod
+ briDoc <- briDocMToPPM $ layoutModule (reLocA lmod)
layoutBriDoc briDoc
else
let emptyModule = L loc m { hsmodDecls = [] }
@@ -667,16 +669,18 @@ layoutBriDoc briDoc = do
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
let
+ remainingComments :: [((), ())]
remainingComments =
- [ c
- | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList
- (_lstate_comments state')
- -- With the new import layouter, we manually process comments
- -- without relying on the backend to consume the comments out of
- -- the state/map. So they will end up here, and we need to ignore
- -- them.
- , ExactPrint.unConName con /= "ImportDecl"
- , c <- extractAllComments elemAnns
+ [
+ -- c
+ -- | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList
+ -- (_lstate_comments state')
+ -- -- With the new import layouter, we manually process comments
+ -- -- without relying on the backend to consume the comments out of
+ -- -- the state/map. So they will end up here, and we need to ignore
+ -- -- them.
+ -- , ExactPrint.unConName con /= "ImportDecl"
+ -- , c <- extractAllComments elemAnns
]
remainingComments
`forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell)
diff --git a/source/library/Language/Haskell/Brittany/Internal/EPCompat.hs b/source/library/Language/Haskell/Brittany/Internal/EPCompat.hs
index 16d753d..850fce1 100644
--- a/source/library/Language/Haskell/Brittany/Internal/EPCompat.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/EPCompat.hs
@@ -10,4 +10,4 @@ type Annotation = ()
type Anns = Map AnnKey ()
type AnnKey = ()
-type EPAnns = ()
+type EPAnns = Map AnnKey ()
diff --git a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
index 6c4fefc..1f89422 100644
--- a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
@@ -182,29 +182,29 @@ commentAnnFixTransformGlob ast = undefined
-- ExactPrint.modifyAnnsT moveComments
-{--
-- | split a set of annotations in a module into a map from top-level module
-- elements to the relevant annotations. Avoids quadratic behaviour a trivial
-- implementation would have.
extractToplevelAnns
:: Located HsModule
- -> ExactPrint.Anns
- -> Map ExactPrint.AnnKey ExactPrint.Anns
+ -> Anns
+ -> Map AnnKey Anns
extractToplevelAnns lmod anns = output
where
- (L _ (HsModule _ _ _ _ ldecls _ _)) = lmod
- declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey
+ (L _ (HsModule _ _ _ _ _ ldecls _ _)) = lmod
+ declMap1 :: Map AnnKey AnnKey
declMap1 = Map.unions $ ldecls <&> \ldecl ->
- Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl)
- declMap2 :: Map ExactPrint.AnnKey ExactPrint.AnnKey
+ Map.fromSet (const ({-ExactPrint.mkAnnKey-} undefined ldecl)) (foldedAnnKeys ldecl)
+ declMap2 :: Map AnnKey AnnKey
declMap2 =
Map.fromList
- $ [ (captured, declMap1 Map.! k)
- | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns
+ $ [
+ -- (captured, declMap1 Map.! k)
+ -- | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns
]
declMap = declMap1 `Map.union` declMap2
- modKey = ExactPrint.mkAnnKey lmod
+ modKey = {-ExactPrint.mkAnnKey-} undefined lmod
output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns
groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a)
@@ -215,13 +215,13 @@ groupMap f = Map.foldlWithKey'
insert k a Nothing = Just (Map.singleton k a)
insert k a (Just m) = Just (Map.insert k a m)
-foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey
+foldedAnnKeys :: Data.Data.Data ast => ast -> Set AnnKey
foldedAnnKeys ast = SYB.everything
Set.union
(\x -> maybe
Set.empty
Set.singleton
- [ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x
+ [ SYB.gmapQi 1 ({-ExactPrint.mkAnnKey-} undefined . L l) x
| locTyCon == SYB.typeRepTyCon (SYB.typeOf x)
, l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x
]
@@ -232,7 +232,6 @@ foldedAnnKeys ast = SYB.everything
ast
where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ()))
--}
withTransformedAnns
:: Data ast
--
2.30.2