module Language.Haskell.TokenUtils.GHC.Layout (
nullSrcSpan
, mkToken
, gs2f,f2gs
, gs2ss,ss2gs
, insertForestLineInSrcSpan
, showSrcSpan
, showSrcSpanF
, newNameTok
, GhcPosToken
) where
import qualified Bag as GHC
import qualified DynFlags as GHC
import qualified FastString as GHC
import qualified ForeignCall as GHC
import qualified GHC as GHC
import qualified GHC.Paths as GHC
import qualified Lexer as GHC
import qualified Name as GHC
import qualified NameSet as GHC
import qualified Outputable as GHC
import qualified RdrName as GHC
import qualified SrcLoc as GHC
import qualified StringBuffer as GHC
import qualified UniqSet as GHC
import qualified Unique as GHC
import qualified Var as GHC
import qualified GHC.SYB.Utils as SYB
import qualified Data.Generics as SYB
import Control.Exception
import Data.Generics hiding (GT)
import Data.List
import Data.Monoid
import Data.Tree
import System.IO.Unsafe
import Language.Haskell.TokenUtils.DualTree
import Language.Haskell.TokenUtils.Layout
import Language.Haskell.TokenUtils.TokenUtils
import Language.Haskell.TokenUtils.Types
import Language.Haskell.TokenUtils.Utils
import qualified Data.Tree.Zipper as Z
import Debug.Trace
instance GHC.Outputable (Line GhcPosToken) where
ppr (Line r c o s f str) = GHC.parens $ GHC.text "Line" GHC.<+> GHC.ppr r
GHC.<+> GHC.ppr c GHC.<+> GHC.ppr o
GHC.<+> GHC.ppr s GHC.<+> GHC.ppr f
GHC.<+> GHC.text ("\"" ++ (GHC.showRichTokenStream str) ++ "\"")
instance GHC.Outputable Source where
ppr SOriginal = GHC.text "SOriginal"
ppr SAdded = GHC.text "SAdded"
ppr SWasAdded = GHC.text "SWasAdded"
instance GHC.Outputable LineOpt where
ppr ONone = GHC.text "ONone"
ppr OGroup = GHC.text "OGroup"
instance GHC.Outputable (LayoutTree GhcPosToken) where
ppr (Node e sub) = GHC.hang (GHC.text "Node") 2
(GHC.vcat [GHC.ppr e,GHC.ppr sub])
instance GHC.Outputable (Entry GhcPosToken) where
ppr (Entry ffs l toks) = GHC.text "Entry" GHC.<+> GHC.ppr ffs
GHC.<+> GHC.ppr l
GHC.<+> GHC.text (show toks)
ppr (Deleted ffs ro pos) = GHC.text "Deleted" GHC.<+> GHC.ppr ffs
GHC.<+> GHC.ppr ro
GHC.<+> GHC.ppr pos
instance GHC.Outputable ForestLine where
ppr (ForestLine lc sel v l) = GHC.parens $ GHC.text "ForestLine"
GHC.<+> GHC.ppr lc GHC.<+> GHC.int sel
GHC.<+> GHC.int v GHC.<+> GHC.int l
instance GHC.Outputable Layout where
ppr (Above bo pos1 pos2 eo) = GHC.text "Above"
GHC.<+> GHC.ppr bo
GHC.<+> GHC.ppr pos1
GHC.<+> GHC.ppr pos2
GHC.<+> GHC.ppr eo
ppr NoChange = GHC.text "NoChange"
instance GHC.Outputable GHC.Token where
ppr t = GHC.text (show t)
instance GHC.Outputable EndOffset where
ppr None = GHC.text "None"
ppr (SameLine co) = GHC.text "SameLine"
GHC.<+> GHC.ppr co
ppr (FromAlignCol pos) = GHC.text "FromAlignCol"
GHC.<+> GHC.ppr pos
initTokenLayout :: GHC.ParsedSource -> [GhcPosToken] -> LayoutTree GhcPosToken
initTokenLayout parsed toks = (allocTokens parsed toks)
ghcAllocTokens :: GHC.ParsedSource-> [GhcPosToken] -> LayoutTree GhcPosToken
ghcAllocTokens (GHC.L _l (GHC.HsModule maybeName maybeExports imports decls _warns _haddocks)) toks = r
where
(nameLayout,toks1) =
case maybeName of
Nothing -> ([],toks)
Just (GHC.L ln _modName) -> ((makeLeafFromToks s1) ++ [makeLeaf (g2s ln) NoChange modNameToks],toks')
where
(s1,modNameToks,toks') = splitToksIncComments (ghcSpanStartEnd ln) toks
(exportLayout,toks2) =
case maybeExports of
Nothing -> ([],toks1)
Just exps -> ((makeLeafFromToks s2) ++ (makeLeafFromToks expToks),toks2')
where
(s2,expToks,toks2') = splitToksForList exps toks1
(importLayout,toks3) =
case imports of
[] -> ([],toks2)
is -> ((makeLeafFromToks s3) ++ (makeLeafFromToks impToks),toks3')
where
(s3,impToks,toks3') = splitToksForList is toks2
(declLayout,toks4) =
case decls of
[] -> ([],toks3)
is -> ((makeLeafFromToks s4) ++ allocDecls is declToks ++ (makeLeafFromToks toks4'),[])
where
(s4,declToks,toks4') = splitToksForList is toks3
r' = makeGroup (strip $ nameLayout ++ exportLayout ++ importLayout ++ declLayout ++ (makeLeafFromToks toks4))
r = addEndOffsets r' toks
type GhcPosToken = (GHC.Located GHC.Token, String)
allocDecls :: [GHC.LHsDecl GHC.RdrName] -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocDecls decls toks = r
where
(declLayout,tailToks) = foldl' doOne ([],toks) decls
r = strip $ declLayout ++ (makeLeafFromToks tailToks)
doOne :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])
doOne acc d@(GHC.L _ (GHC.TyClD _)) = allocTyClD acc d
doOne acc d@(GHC.L _ (GHC.InstD _)) = allocInstD acc d
doOne acc d@(GHC.L _ (GHC.DerivD _)) = allocDerivD acc d
doOne acc d@(GHC.L _ (GHC.ValD _)) = allocValD acc d
doOne acc d@(GHC.L _ (GHC.SigD _)) = allocSigD acc d
doOne acc d@(GHC.L _ (GHC.DefD _)) = allocDefD acc d
doOne acc d@(GHC.L _ (GHC.ForD _)) = allocForD acc d
doOne acc d@(GHC.L _ (GHC.WarningD _)) = allocWarningD acc d
doOne acc d@(GHC.L _ (GHC.AnnD _)) = allocAnnD acc d
doOne acc d@(GHC.L _ (GHC.RuleD _)) = allocRuleD acc d
doOne acc d@(GHC.L _ (GHC.VectD _)) = allocVectD acc d
doOne acc d@(GHC.L _ (GHC.SpliceD _)) = allocSpliceD acc d
doOne acc d@(GHC.L _ (GHC.DocD _)) = allocDocD acc d
doOne acc d@(GHC.L _ (GHC.QuasiQuoteD _)) = allocQuasiQuoteD acc d
allocTyClD :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName
-> ([LayoutTree GhcPosToken],[GhcPosToken])
allocTyClD (acc,toks) (GHC.L l (GHC.TyClD d)) = (r,toks')
where
(s1,clToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
declLayout = allocLTyClDecl (GHC.L l d) clToks
r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) ++ declLayout)]
allocTyClD _ x = error $ "allocTyClD:unexpected value:" ++ showGhc x
allocInstD :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName
-> ([LayoutTree GhcPosToken],[GhcPosToken])
allocInstD (acc,toks) (GHC.L l (GHC.InstD inst)) = (r,toks')
where
(s1,instToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
instLayout = allocInstDecl (GHC.L l inst) instToks
r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) ++ [makeGroup instLayout] )]
allocInstD _ x = error $ "allocInstD:unexpected value:" ++ showGhc x
allocDerivD :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])
allocDerivD (acc,toks) (GHC.L l (GHC.DerivD (GHC.DerivDecl typ))) = (r,toks')
where
(s1,bindToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
typLayout = allocType typ bindToks
r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) ++ [makeGroup typLayout] )]
allocDerivD _ x = error $ "allocDerivD:unexpected value:" ++ showGhc x
allocValD :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName
-> ([LayoutTree GhcPosToken],[GhcPosToken])
allocValD (acc,toks) (GHC.L l (GHC.ValD bind)) = (r,toks')
where
(s1,bindToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
bindLayout = allocBind (GHC.L l bind) bindToks
r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) ++ [makeGroup bindLayout] )]
allocValD _ x = error $ "allocValD:unexpected value:" ++ showGhc x
allocSigD :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName
-> ([LayoutTree GhcPosToken],[GhcPosToken])
allocSigD (acc,toks) (GHC.L l (GHC.SigD sig)) = (r,toks')
where
(s1,sigToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
sigLayout = allocSig (GHC.L l sig) sigToks
r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1)
++ sigLayout)]
allocSigD _ x = error $ "allocSigD:unexpected value:" ++ showGhc x
allocDefD :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])
allocDefD (acc,toks) (GHC.L l (GHC.DefD (GHC.DefaultDecl typs))) = (r,toks')
where
(s1,typsToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
typsLayout = allocList typs typsToks allocType
r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1)
++ typsLayout)]
allocDefD _ x = error $ "allocDefD:unexpected value:" ++ showGhc x
allocForD :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])
allocForD (acc,toks) (GHC.L l (GHC.ForD (GHC.ForeignImport (GHC.L ln _) typ@(GHC.L lt _) _coer _imp))) = (r,toks')
where
(s1,declToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,nameToks,toks1) = splitToksIncComments (ghcSpanStartEnd ln) declToks
(s3,typToks,toks2) = splitToksIncComments (ghcSpanStartEnd lt) toks1
nameLayout = [makeLeaf (g2s ln) NoChange nameToks]
typLayout = allocType typ typToks
r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1)
++ (makeLeafFromToks s2) ++ nameLayout
++ (makeLeafFromToks s3) ++ typLayout
++ (makeLeafFromToks toks2))]
allocForD (acc,toks) (GHC.L l (GHC.ForD (GHC.ForeignExport (GHC.L ln _) typ@(GHC.L lt _) _coer _imp))) = (r,toks')
where
(s1,declToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,nameToks,toks1) = splitToksIncComments (ghcSpanStartEnd ln) declToks
(s3,typToks,toks2) = splitToksIncComments (ghcSpanStartEnd lt) toks1
nameLayout = [makeLeaf (g2s ln) NoChange nameToks]
typLayout = allocType typ typToks
r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1)
++ (makeLeafFromToks s2) ++ nameLayout
++ (makeLeafFromToks s3) ++ typLayout
++ (makeLeafFromToks toks2))]
allocForD _ x = error $ "allocForD:unexpected value:" ++ showGhc x
allocWarningD :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])
allocWarningD (acc,toks) (GHC.L _l (GHC.WarningD _)) = (acc,toks)
allocWarningD _ x = error $ "allocWarningD:unexpected value:" ++ showGhc x
allocAnnD :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])
allocAnnD (acc,toks) (GHC.L _l (GHC.AnnD _)) = (acc,toks)
allocAnnD _ x = error $ "allocAnnD:unexpected value:" ++ showGhc x
allocRuleD :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])
allocRuleD (acc,toks) (GHC.L _l (GHC.RuleD _)) = (acc,toks)
allocRuleD _ x = error $ "allocRuleD:unexpected value:" ++ showGhc x
allocVectD :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])
allocVectD (acc,toks) (GHC.L _l (GHC.VectD _)) = (acc,toks)
allocVectD _ x = error $ "allocVectD:unexpected value:" ++ showGhc x
allocSpliceD :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])
allocSpliceD (acc,toks) (GHC.L l (GHC.SpliceD (GHC.SpliceDecl ex _))) = (r,toks')
where
(s1,exprToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
exprLayout = allocExpr ex exprToks
r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1)
++ exprLayout)]
allocSpliceD _ x = error $ "allocSpliceD:unexpected value:" ++ showGhc x
allocDocD :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])
allocDocD _ x = error $ "allocDocD:unexpected value:" ++ showGhc x
allocQuasiQuoteD :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])
allocQuasiQuoteD (acc,toks) (GHC.L l (GHC.QuasiQuoteD (GHC.HsQuasiQuote _n _ss _))) = (r,toks')
where
(s1,qqToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
qqLayout = makeLeafFromToks qqToks
r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1)
++ qqLayout)]
allocQuasiQuoteD _ x = error $ "allocQuasiQuoteD:unexpected value:" ++ showGhc x
allocLTyClDecl :: GHC.LTyClDecl GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocLTyClDecl (GHC.L l (GHC.ForeignType ln _)) toks = r
where
(s1,clToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
lnToks = allocLocated ln clToks
r = [makeGroup (strip $ (makeLeafFromToks s1) ++ lnToks ++ (makeLeafFromToks toks'))]
allocLTyClDecl (GHC.L l (GHC.TyFamily _f n@(GHC.L ln _) vars _mk)) toks = r
where
(s1,clToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,nToks,varsToks) = splitToksIncComments (ghcSpanStartEnd ln) toks'
nLayout = allocLocated n nToks
#if __GLASGOW_HASKELL__ > 704
(varsLayout,s3) = allocTyVarBndrs vars varsToks
#else
varsLayout = allocList vars varsToks allocTyVarBndr
s3 = []
#endif
r = [makeGroup (strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks clToks)
++ (makeLeafFromToks s2) ++ nLayout ++ varsLayout
++ (makeLeafFromToks s3)
++ (makeLeafFromToks toks'))
]
#if __GLASGOW_HASKELL__ > 704
allocLTyClDecl (GHC.L l (GHC.TyDecl (GHC.L ln _) vars def _fvs)) toks = r
where
(s1,clToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,nToks,toks'') = splitToksIncComments (ghcSpanStartEnd ln) clToks
(varsLayout,toks3) = allocTyVarBndrs vars toks''
(typeLayout,toks4) = allocHsTyDefn def toks3
r = [makeGroup (strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)
++ (makeLeafFromToks nToks) ++ varsLayout ++ typeLayout
++ (makeLeafFromToks toks4)
++ (makeLeafFromToks toks'))]
#else
allocLTyClDecl (GHC.L l (GHC.TyData _ (GHC.L lc ctx) (GHC.L ln _) vars mpats mkind cons mderivs)) toks = r
where
(s1,clToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s15,ctxToks,toks'a) = splitToksIncComments (ghcSpanStartEnd lc) clToks
(s2,nToks,toks'') = splitToksIncComments (ghcSpanStartEnd ln) toks'a
(s21,vToks,toks3) = splitToksForList vars toks''
ctxLayout = allocHsContext ctx ctxToks
varsLayout = allocList vars vToks allocTyVarBndr
(patsLayout,toks4) = case mpats of
Nothing -> ([],toks3)
Just pats -> ([makeGroup (strip $ (makeLeafFromToks s3) ++ (allocList pats patsToks allocType))],toks4')
where (s3,patsToks,toks4') = splitToksForList pats toks3
(kindLayout,toks5) = case mkind of
Nothing -> ([],toks4)
Just k@(GHC.L lk _k) -> (kLayout,toks5')
where
(s4,kToks,toks5') = splitToksIncComments (ghcSpanStartEnd lk) toks4
kLayout = [makeGroup (strip $ (makeLeafFromToks s4) ++ allocHsKind k kToks)]
(s5,consToks,toks6) = splitToksForList cons toks5
consLayout = [makeGroup (strip $ (makeLeafFromToks s5) ++ (allocList cons consToks allocConDecl))]
(derivsLayout,toks7) = case mderivs of
Nothing -> ([],toks6)
Just derivs -> (dLayout,toks7')
where
(s6,dToks,toks7') = splitToksForList derivs toks6
dLayout = [makeGroup (strip $ (makeLeafFromToks s6) ++ (allocList derivs dToks allocType))]
r = [makeGroup (strip $ (makeLeafFromToks s1)
++ (makeLeafFromToks s15)
++ ctxLayout
++ (makeLeafFromToks s2)
++ (makeLeafFromToks nToks)
++ (makeLeafFromToks s21)
++ varsLayout ++ patsLayout
++ kindLayout
++ consLayout ++ derivsLayout
++ (makeLeafFromToks toks7)
++ (makeLeafFromToks toks')
)]
#endif
#if __GLASGOW_HASKELL__ > 704
allocLTyClDecl (GHC.L l (GHC.ClassDecl (GHC.L lc ctx) n@(GHC.L ln _) vars fds sigs meths ats atdefs docs _fvs)) toks = r
#else
allocLTyClDecl (GHC.L l (GHC.ClassDecl (GHC.L lc ctx) n@(GHC.L ln _) vars fds sigs meths ats atdefs docs )) toks = r
#endif
where
(s1,clToks, toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,ctxToks, toks1) = splitToksIncComments (ghcSpanStartEnd lc) clToks
(s3,nToks, toks2) = splitToksIncComments (ghcSpanStartEnd ln) toks1
#if __GLASGOW_HASKELL__ > 704
(varsLayout, toks3) = allocTyVarBndrs vars toks2
#else
varsLayout = allocList vars toks2 allocTyVarBndr
toks3 = []
#endif
(s5,fdToks, toks4) = splitToksForList fds toks3
ctxLayout = allocHsContext ctx ctxToks
nLayout = allocLocated n nToks
fdsLayout = makeLeafFromToks fdToks
bindList = GHC.bagToList meths
sigMix = makeMixedListEntry sigs (shim allocSig)
methsMix = makeMixedListEntry bindList (shim allocBind)
atsMix = makeMixedListEntry ats (shim allocLTyClDecl)
#if __GLASGOW_HASKELL__ > 704
atsdefsMix = makeMixedListEntry atdefs (shim allocLFamInstDecl)
#else
atsdefsMix = makeMixedListEntry atdefs (shim allocLTyClDecl)
#endif
docsMix = makeMixedListEntry docs (shim allocLocated)
bindsLayout = allocMixedList (sigMix++methsMix++atsMix++atsdefsMix++docsMix) toks4
r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)
++ ctxLayout ++ (makeLeafFromToks s3)
++ nLayout ++ varsLayout ++ (makeLeafFromToks s5)
++ fdsLayout ++ bindsLayout
++ (makeLeafFromToks toks')
]
#if __GLASGOW_HASKELL__ > 704
#else
allocLTyClDecl (GHC.L l (GHC.TySynonym n@(GHC.L ln _) vars mpats synrhs@(GHC.L lr _))) toks = r
where
(s1,clToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,nToks,toks2) = splitToksIncComments (ghcSpanStartEnd ln) clToks
(s25,vToks,toks3) = splitToksForList vars toks2
(patsLayout,toks4) = case mpats of
Nothing -> ([],toks3)
Just pats -> ([makeGroup (strip $ (makeLeafFromToks s3) ++ (allocList pats patsToks allocType))],toks4')
where (s3,patsToks,toks4') = splitToksForList pats toks3
(s4,rToks,toks5) = splitToksIncComments (ghcSpanStartEnd lr) toks4
varsLayout = allocList vars vToks allocTyVarBndr
synrhsLayout = allocType synrhs rToks
r = [makeGroup (strip $ (makeLeafFromToks s1)
++ (makeLeafFromToks s2)
++ (makeLeafFromToks nToks)
++ (makeLeafFromToks s25)
++ varsLayout ++ patsLayout
++ (makeLeafFromToks s4)
++ synrhsLayout
++ (makeLeafFromToks toks5)
++ (makeLeafFromToks toks')
)]
#endif
allocMatches :: [GHC.LMatch GHC.RdrName] -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocMatches matches toksIn = allocList matches toksIn doOne
where
doOne :: GHC.LMatch GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
doOne (GHC.L lm (GHC.Match pats mtyp grhs@(GHC.GRHSs rhs _))) toks = r
where
(sb,matchToks,sa) = splitToksIncComments (ghcSpanStartEnd lm) toks
(s2,patsToks,toks2) = splitToksForList pats matchToks
(mtypLayout,toks') = case mtyp of
Nothing -> ([],toks2)
Just (typ@(GHC.L l _)) -> (typeLayout,toks'')
where
(t1,typToks,toks'') = splitToksIncComments (ghcSpanStartEnd l) toks2
typeLayout = strip $ (makeLeafFromToks t1) ++ allocType typ typToks
(s3,rhsToks,bindsToks) = splitToksForList rhs toks'
patLayout = case (strip $ allocList pats patsToks allocPat) of
[] -> []
ps -> [makeGroup ps]
grhsLayout = allocGRHSs grhs (rhsToks++bindsToks)
matchLayout = [makeGroup $ strip $ (makeLeafFromToks s2)
++ patLayout
++ mtypLayout
++ (makeLeafFromToks s3)
++ grhsLayout
]
r = (strip $ (makeLeafFromToks sb)
++ matchLayout
++ (makeLeafFromToks sa))
allocGRHSs :: GHC.GRHSs GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocGRHSs (GHC.GRHSs rhs localBinds) toks = r
where
(s1,rhsToks,bindsToks) = splitToksForList rhs toks
rhsLayout = allocList rhs rhsToks allocRhs
localBindsLayout = allocLocalBinds localBinds bindsToks
r = (strip $ (makeLeafFromToks s1) ++ rhsLayout ++ localBindsLayout)
allocPat :: GHC.LPat GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocPat (GHC.L _ _) toks = makeLeafFromToks toks
allocRhs :: GHC.LGRHS GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocRhs (GHC.L l (GHC.GRHS stmts expr)) toksIn = r
where
(sb,toksRhs,sa) = splitToksIncComments (ghcSpanStartEnd l) toksIn
(s1,stmtsToks,toks') = splitToksForList stmts toksRhs
stmtsLayout = allocList stmts stmtsToks allocStmt
exprLayout = allocExpr expr toks'
exprMainLayout = [makeGroup $ strip $ (makeLeafFromToks s1) ++ stmtsLayout ++ exprLayout]
r = strip $ (makeLeafFromToks sb) ++ exprMainLayout ++ (makeLeafFromToks sa)
allocStmt :: GHC.LStmt GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocStmt (GHC.L _ (GHC.LastStmt expr _)) toks = allocExpr expr toks
allocStmt (GHC.L _ (GHC.BindStmt pat@(GHC.L lp _) expr _ _)) toks = r
where
(s1,patToks,toks') = splitToksIncComments (ghcSpanStartEnd lp) toks
patLayout = allocPat pat patToks
exprLayout = allocExpr expr toks'
r = strip $ (makeLeafFromToks s1) ++ patLayout ++ exprLayout
allocStmt (GHC.L _ (GHC.ExprStmt expr _ _ _)) toks = allocExpr expr toks
allocStmt (GHC.L _ (GHC.LetStmt binds)) toks = allocLocalBinds binds toks
#if __GLASGOW_HASKELL__ > 704
allocStmt (GHC.L l (GHC.ParStmt blocks _ _)) toks = r
where
(s1,blocksToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(blocksLayout,toks2) = foldl' allocParStmtBlock ([],blocksToks) blocks
r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ blocksLayout
++ (makeLeafFromToks toks2)
++ (makeLeafFromToks toks')]
#else
allocStmt (GHC.L l (GHC.ParStmt blocks _ _ _)) toks = r
where
(s1,blocksToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(blocksLayout,toks2) = foldl' allocParStmtBlock ([],blocksToks) blocks
r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ blocksLayout
++ (makeLeafFromToks toks2)
++ (makeLeafFromToks toks')]
allocParStmtBlock :: ([LayoutTree GhcPosToken],[GhcPosToken])
-> ([GHC.LStmt GHC.RdrName],[GHC.RdrName]) -> ([LayoutTree GhcPosToken],[GhcPosToken])
allocParStmtBlock (acc,toks) (stmts,ns) = (r1,toks')
where
(s1,stmtToks,toks') = splitToksForList stmts toks
stmtLayout = allocList stmts stmtToks allocStmt
r1 = [makeGroup $ strip $ (makeLeafFromToks s1)
++ stmtLayout]
#endif
allocStmt (GHC.L l (GHC.TransStmt _ stmts _ using@(GHC.L lu _) mby _ _ _ )) toks = r
where
(sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
(s1,stmtsToks,toks1) = splitToksForList stmts toksExpr
(s2,usingToks,toks2) = splitToksIncComments (ghcSpanStartEnd lu) toks1
(byLayout,toks3) = case mby of
Nothing -> ([],toks2)
Just e -> (byL,toks3')
where
byL = allocExpr e toks2
toks3' = []
stmtsLayout = allocList stmts stmtsToks allocStmt
usingLayout = allocExpr using usingToks
r = [makeGroup $ strip $ (makeLeafFromToks sb)
++ (makeLeafFromToks s1) ++ stmtsLayout
++ (makeLeafFromToks s2) ++ usingLayout
++ byLayout
++ (makeLeafFromToks toks3)
++ (makeLeafFromToks sa)
]
allocStmt (GHC.L l (GHC.RecStmt stmts _ _ _ _ _ _ _ _)) toks = r
where
(sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
(s1,stmtsToks,toks1) = splitToksForList stmts toksExpr
stmtsLayout = allocList stmts stmtsToks allocStmt
r = [makeGroup $ strip $ (makeLeafFromToks sb)
++ (makeLeafFromToks s1) ++ stmtsLayout
++ (makeLeafFromToks toks1)
++ (makeLeafFromToks sa)
]
#if __GLASGOW_HASKELL__ > 704
allocParStmtBlock :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> GHC.ParStmtBlock GHC.RdrName GHC.RdrName -> ([LayoutTree GhcPosToken],[GhcPosToken])
allocParStmtBlock (acc,toks) (GHC.ParStmtBlock stmts _ns _) = (acc ++ r,toks')
where
(s1,stmtToks,toks') = splitToksForList stmts toks
stmtLayout = allocList stmts stmtToks allocStmt
r = [makeGroup $ strip $ (makeLeafFromToks s1)
++ stmtLayout]
#endif
allocExpr :: GHC.LHsExpr GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocExpr (GHC.L l (GHC.HsVar _)) toks = [makeLeaf (g2s l) NoChange toks]
allocExpr (GHC.L l (GHC.HsLit _)) toks = [makeLeaf (g2s l) NoChange toks]
allocExpr (GHC.L l (GHC.HsOverLit _)) toks = [makeLeaf (g2s l) NoChange toks]
allocExpr (GHC.L _ (GHC.HsLam (GHC.MatchGroup matches _))) toks
= allocMatches matches toks
#if __GLASGOW_HASKELL__ > 704
allocExpr (GHC.L _ (GHC.HsLamCase _ (GHC.MatchGroup matches _))) toks
= allocMatches matches toks
#endif
allocExpr (GHC.L l (GHC.HsApp e1@(GHC.L l1 _) e2)) toks = r
where
(sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
(s1,e1Toks,e2Toks) = splitToksIncComments (ghcSpanStartEnd l1) toksExpr
e1Layout = allocExpr e1 e1Toks
e2Layout = allocExpr e2 e2Toks
exprLayout = [makeGroup $ strip $ (makeLeafFromToks s1) ++ e1Layout ++ e2Layout]
r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)
allocExpr (GHC.L l (GHC.OpApp e1@(GHC.L l1 _) e2@(GHC.L l2 _) _ e3)) toks = r
where
(sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
(s1,e1Toks,toks1) = splitToksIncComments (ghcSpanStartEnd l1) toksExpr
(s2,e2Toks,e3Toks) = splitToksIncComments (ghcSpanStartEnd l2) toks1
e1Layout = allocExpr e1 e1Toks
e2Layout = allocExpr e2 e2Toks
e3Layout = allocExpr e3 e3Toks
exprLayout = [makeGroup $ strip $ (makeLeafFromToks s1)
++ e1Layout ++ (makeLeafFromToks s2)
++ e2Layout ++ e3Layout]
r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)
allocExpr (GHC.L l (GHC.NegApp expr _)) toks = r
where
(sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
exprLayout = [makeGroup $ allocExpr expr toksExpr]
r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)
allocExpr (GHC.L l (GHC.HsPar expr)) toks = r
where
(sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
exprLayout = [makeGroup $ allocExpr expr toksExpr]
r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)
allocExpr (GHC.L l (GHC.SectionL e1@(GHC.L l1 _) e2)) toks = r
where
(sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
(s1,e1Toks,e2Toks) = splitToksIncComments (ghcSpanStartEnd l1) toksExpr
e1Layout = allocExpr e1 e1Toks
e2Layout = allocExpr e2 e2Toks
exprLayout = [makeGroup $ strip $ (makeLeafFromToks s1) ++ e1Layout ++ e2Layout]
r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)
allocExpr (GHC.L l (GHC.SectionR e1@(GHC.L l1 _) e2)) toks = r
where
(sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
(s1,e1Toks,e2Toks) = splitToksIncComments (ghcSpanStartEnd l1) toksExpr
e1Layout = allocExpr e1 e1Toks
e2Layout = allocExpr e2 e2Toks
exprLayout = [makeGroup $ strip $ (makeLeafFromToks s1) ++ e1Layout ++ e2Layout]
r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)
allocExpr (GHC.L l (GHC.ExplicitTuple tupArgs _)) toks = r
where
(sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
(s1,tupToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toksExpr
tupLayout = allocTupArgList tupArgs tupToks
exprLayout = [makeGroup $ strip $ (makeLeafFromToks s1) ++ tupLayout
++ (makeLeafFromToks toks')]
r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)
allocExpr (GHC.L l (GHC.HsCase expr@(GHC.L le _) (GHC.MatchGroup matches _))) toks = r
where
(sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
(s1,exprToks,toks1) = splitToksIncComments (ghcSpanStartEnd le) toksExpr
(s2,matchToks,toks2) = splitToksForList matches toks1
exprLayout = allocExpr expr exprToks
firstMatchTok = ghead "allocLocalBinds" $ dropWhile isWhiteSpaceOrIgnored matchToks
p1 = (ghcTokenRow firstMatchTok,ghcTokenCol firstMatchTok)
(ro,co) = case (filter isOf s2) of
[] -> (0,0)
(x:_) -> (ghcTokenRow firstMatchTok ghcTokenRow x,
ghcTokenCol firstMatchTok (ghcTokenCol x + tokenLen x))
(rt,ct) = calcLastTokenPos matchToks
so = makeOffset ro (co 1)
matchesLayout = [placeAbove so p1 (rt,ct) (allocMatches matches matchToks)]
exprMainLayout = [makeGroup $ strip $ (makeLeafFromToks s1) ++ exprLayout
++ (makeLeafFromToks s2) ++ matchesLayout ++ (makeLeafFromToks toks2)]
r = strip $ (makeLeafFromToks sb) ++ exprMainLayout ++ (makeLeafFromToks sa)
allocExpr (GHC.L l (GHC.HsIf _ e1@(GHC.L l1 _) e2@(GHC.L l2 _) e3)) toks = r
where
(sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
(s1,e1Toks,toks1) = splitToksIncComments (ghcSpanStartEnd l1) toksExpr
(s2,e2Toks,e3Toks) = splitToksIncComments (ghcSpanStartEnd l2) toks1
e1Layout = allocExpr e1 e1Toks
e2Layout = allocExpr e2 e2Toks
e3Layout = allocExpr e3 e3Toks
exprLayout = [makeGroup $ strip $ (makeLeafFromToks s1)
++ e1Layout ++ (makeLeafFromToks s2)
++ e2Layout ++ e3Layout]
r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)
#if __GLASGOW_HASKELL__ > 704
allocExpr (GHC.L l (GHC.HsMultiIf _ rhs)) toks = r
where
(sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
exprLayout = [makeGroup $ allocList rhs toksExpr allocRhs]
r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)
#endif
allocExpr (GHC.L l (GHC.HsLet localBinds expr@(GHC.L le _))) toks = r
where
(sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
(bindToks,exprToks,toks') = splitToksIncComments (ghcSpanStartEnd le) toksExpr
bindLayout = allocLocalBinds localBinds bindToks
exprLayout = allocExpr expr exprToks
exprMainLayout = [makeGroup $ strip $ bindLayout ++ [makeGroup exprLayout] ++ (makeLeafFromToks toks')]
r = strip $ (makeLeafFromToks sb) ++ exprMainLayout ++ (makeLeafFromToks sa)
allocExpr e@(GHC.L _ (GHC.HsDo GHC.ListComp _ _)) toks = allocExprListComp e toks
allocExpr e@(GHC.L _ (GHC.HsDo GHC.MonadComp _ _)) toks = allocExprListComp e toks
allocExpr e@(GHC.L _ (GHC.HsDo GHC.PArrComp _ _)) toks = allocExprListComp e toks
allocExpr e@(GHC.L _ (GHC.HsDo GHC.DoExpr _ _)) toks = allocDoExpr e toks
allocExpr e@(GHC.L _ (GHC.HsDo GHC.GhciStmt _ _)) toks = allocDoExpr e toks
allocExpr e@(GHC.L _ (GHC.HsDo GHC.MDoExpr _ _)) toks = allocDoExpr e toks
allocExpr e@(GHC.L _ (GHC.HsDo GHC.ArrowExpr _ _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0 e)
allocExpr e@(GHC.L _ (GHC.HsDo (GHC.PatGuard _) _ _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0 e)
allocExpr e@(GHC.L _ (GHC.HsDo (GHC.ParStmtCtxt _) _ _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0 e)
allocExpr e@(GHC.L _ (GHC.HsDo (GHC.TransStmtCtxt _) _ _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0 e)
allocExpr (GHC.L l (GHC.ExplicitList _ exprs)) toks = r
where
(sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
exprLayout = [makeGroup $ allocList exprs toksExpr allocExpr]
r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)
allocExpr (GHC.L l (GHC.ExplicitPArr _ exprs)) toks = r
where
(sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
exprLayout = [makeGroup $ allocList exprs toksExpr allocExpr]
r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)
allocExpr (GHC.L l (GHC.RecordCon (GHC.L ln _) _ binds)) toks = r
where
(sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
(s1,nameToks,fieldsToks) = splitToksIncComments (ghcSpanStartEnd ln) toksExpr
nameLayout = [makeLeaf (g2s ln) NoChange nameToks]
(bindsLayout,toks3) = allocHsRecordBinds binds fieldsToks
exprLayout = [makeGroup $ strip $ (makeLeafFromToks s1)
++ nameLayout ++ bindsLayout
++ (makeLeafFromToks toks3)]
r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)
allocExpr (GHC.L l (GHC.RecordUpd expr@(GHC.L le _) binds _cons _ptctypes1 _ptctypes2)) toks = r
where
(sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
(s1,toksE,toks2) = splitToksIncComments (ghcSpanStartEnd le) toksExpr
(bindsLayout,toks3) = allocHsRecordBinds binds toks2
exprLayout = allocExpr expr toksE
recLayout = [makeGroup $ strip $ (makeLeafFromToks s1) ++ exprLayout
++ bindsLayout ++ (makeLeafFromToks toks3)]
r = strip $ (makeLeafFromToks sb) ++ recLayout ++ (makeLeafFromToks sa)
allocExpr (GHC.L l (GHC.ArithSeq _ info)) toks = r
where
(sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
exprLayout = [makeGroup $ allocArithSeqInfo info toksExpr]
r = strip $ (makeLeafFromToks sb) ++ exprLayout ++ (makeLeafFromToks sa)
allocExpr (GHC.L l (GHC.ExprWithTySig (GHC.L le expr) (GHC.L lt typ))) toks = r
where
(sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
(s1,toksE,toks2) = splitToksIncComments (ghcSpanStartEnd le) toksExpr
(s2,toksType,toks3) = splitToksIncComments (ghcSpanStartEnd lt) toks2
exprLayout = allocExpr (GHC.L le expr) toksE
typeLayout = allocType (GHC.L lt typ) toksType
layout = [makeGroup $ strip $ (makeLeafFromToks s1) ++ exprLayout
++ (makeLeafFromToks s2) ++ typeLayout
++ (makeLeafFromToks toks3)]
r = strip $ (makeLeafFromToks sb) ++ layout ++ (makeLeafFromToks sa)
allocExpr (GHC.L _ (GHC.HsIPVar _)) toks = makeLeafFromToks toks
allocExpr e@(GHC.L _ (GHC.PArrSeq _ _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0 e)
allocExpr (GHC.L _ (GHC.HsSCC _ ex)) toks = allocExpr ex toks
allocExpr (GHC.L _ (GHC.HsCoreAnn _ ex)) toks = allocExpr ex toks
allocExpr (GHC.L l (GHC.HsBracket bracket)) toks = r
where
(sb,toksBrack,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
layoutBrack = case bracket of
GHC.ExpBr ex -> allocExpr ex toksBrack
GHC.PatBr p -> allocPat p toksBrack
GHC.DecBrL decs -> allocDecls decs toksBrack
GHC.DecBrG g -> error $ "allocExpr.DecBrG undefined for " ++ (SYB.showData SYB.Parser 0 g)
GHC.TypBr typ -> allocType typ toksBrack
GHC.VarBr _ _ -> makeLeafFromToks toksBrack
r = [makeGroup $ strip $ (makeLeafFromToks sb)
++ layoutBrack
++ (makeLeafFromToks sa)]
allocExpr e@(GHC.L _ (GHC.ExprWithTySigOut _ _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0 e)
allocExpr e@(GHC.L _ (GHC.HsBracketOut _ _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0 e)
allocExpr (GHC.L _l (GHC.HsSpliceE (GHC.HsSplice _ expr))) toks = allocExpr expr toks
allocExpr e@(GHC.L _ (GHC.HsQuasiQuoteE _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0 e)
allocExpr (GHC.L l (GHC.HsProc p@(GHC.L lp _) cmd@(GHC.L lc _))) toks = r
where
(sb,toksBrack,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
(s1,toksPat,toks1) = splitToksIncComments (ghcSpanStartEnd lp) toksBrack
(s2,toksCmd,toks2) = splitToksIncComments (ghcSpanStartEnd lc) toks1
layoutPat = allocPat p toksPat
layoutCmd = allocCmdTop cmd toksCmd
r = [makeGroup $ strip $ (makeLeafFromToks sb)
++ (makeLeafFromToks s1)
++ layoutPat
++ (makeLeafFromToks s2)
++ layoutCmd
++ (makeLeafFromToks toks2)
++ (makeLeafFromToks sa)]
allocExpr (GHC.L l (GHC.HsArrApp e1@(GHC.L l1 _) e2@(GHC.L l2 _) _ _ _)) toks = r
where
(sb,toksApp,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
(s1,toksE1,toks1) = splitToksIncComments (ghcSpanStartEnd l1) toksApp
(s2,toksE2,toks2) = splitToksIncComments (ghcSpanStartEnd l2) toks1
layoutE1 = allocExpr e1 toksE1
layoutE2 = allocExpr e2 toksE2
r = [makeGroup $ strip $ (makeLeafFromToks sb)
++ (makeLeafFromToks s1)
++ layoutE1
++ (makeLeafFromToks s2)
++ layoutE2
++ (makeLeafFromToks toks2)
++ (makeLeafFromToks sa)]
allocExpr (GHC.L l (GHC.HsArrForm e@(GHC.L le _) _ cmds)) toks = r
where
(sb,toksApp,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
(s1,toksExpr,toks1) = splitToksIncComments (ghcSpanStartEnd le) toksApp
(s2,toksCmd,toks2) = splitToksForList cmds toks1
layoutExpr = allocExpr e toksExpr
layoutCmds = allocList cmds toksCmd allocCmdTop
r = [makeGroup $ strip $ (makeLeafFromToks sb)
++ (makeLeafFromToks s1)
++ layoutExpr
++ (makeLeafFromToks s2)
++ layoutCmds
++ (makeLeafFromToks toks2)
++ (makeLeafFromToks sa)]
allocExpr (GHC.L _ (GHC.HsTick _ e)) toks = allocExpr e toks
allocExpr (GHC.L _ (GHC.HsBinTick _ _ e)) toks = allocExpr e toks
allocExpr (GHC.L _ (GHC.HsTickPragma _ e)) toks = allocExpr e toks
allocExpr (GHC.L l (GHC.EWildPat)) toks = r
where
(sb,toksPat,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
r = [makeGroup $ strip $ (makeLeafFromToks sb)
++ (makeLeafFromToks toksPat)
++ (makeLeafFromToks sa)]
allocExpr (GHC.L l (GHC.EAsPat (GHC.L ln _) e@(GHC.L le _))) toks = r
where
(sb,toksPat,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
(s1,toksN,toks1) = splitToksIncComments (ghcSpanStartEnd ln) toksPat
(s2,toksE,toks2) = splitToksIncComments (ghcSpanStartEnd le) toks1
layoutN = makeLeafFromToks toksN
layoutExpr = allocExpr e toksE
r = [makeGroup $ strip $ (makeLeafFromToks sb)
++ (makeLeafFromToks s1)
++ layoutN
++ (makeLeafFromToks s2)
++ layoutExpr
++ (makeLeafFromToks toks2)
++ (makeLeafFromToks sa)]
allocExpr (GHC.L l (GHC.EViewPat e1@(GHC.L l1 _) e2@(GHC.L l2 _))) toks = r
where
(sb,toksPat,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
(s1,toksE1,toks1) = splitToksIncComments (ghcSpanStartEnd l1) toksPat
(s2,toksE2,toks2) = splitToksIncComments (ghcSpanStartEnd l2) toks1
layoutE1 = allocExpr e1 toksE1
layoutE2 = allocExpr e2 toksE2
r = [makeGroup $ strip $ (makeLeafFromToks sb)
++ (makeLeafFromToks s1)
++ layoutE1
++ (makeLeafFromToks s2)
++ layoutE2
++ (makeLeafFromToks toks2)
++ (makeLeafFromToks sa)]
allocExpr (GHC.L _ (GHC.ELazyPat e)) toks = allocExpr e toks
allocExpr (GHC.L _ (GHC.HsType typ)) toks = allocType typ toks
allocExpr e@(GHC.L _ (GHC.HsWrap _ _)) toks = allocExpr e toks
allocDoExpr :: GHC.LHsExpr GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocDoExpr _e@(GHC.L l (GHC.HsDo _ stmts _)) toks = r
where
(s1,toksBinds',toks1) = splitToksIncComments (ghcSpanStartEnd l) toks
(before,including) = break isDo toksBinds'
doToks = before ++ [ghead ("allocExpr:" ++ (show toksBinds') ++ (SYB.showData SYB.Renamer 0 _e)) including]
toksBinds = gtail ("allocExpr.HsDo" ++ show (l,before,including,toks)) including
bindsLayout' = allocList stmts toksBinds allocStmt
firstBindTok = ghead "allocLocalBinds" $ dropWhile isWhiteSpaceOrIgnored toksBinds
p1 = (ghcTokenRow firstBindTok,ghcTokenCol firstBindTok)
(ro,co) = case (filter isDo doToks) of
[] -> (0,0)
(x:_) -> (ghcTokenRow firstBindTok ghcTokenRow x,
ghcTokenCol firstBindTok (ghcTokenCol x + tokenLen x))
(rt,ct) = calcLastTokenPos toksBinds
so = makeOffset ro (co 1)
bindsLayout = case bindsLayout' of
[] -> []
bs -> [placeAbove so p1 (rt,ct) bs]
r = strip $ (makeLeafFromToks (s1++doToks) ++ bindsLayout ++ makeLeafFromToks toks1)
allocDoExpr e _
= error $ "Layout.allocDoExpr should not have been called with " ++ showGhc e
allocExprListComp :: GHC.LHsExpr GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocExprListComp _e@(GHC.L l (GHC.HsDo _ stmts _)) toks = r
where
(s1,toksBinds,toks1) = splitToksIncComments (ghcSpanStartEnd l) toks
bindsLayout = allocList stmts toksBinds allocStmt
r = strip $ ((makeLeafFromToks s1) ++ bindsLayout ++ makeLeafFromToks toks1)
allocExprListComp e _
= error $ "Layout.allocExprListComp should not have been called with " ++ showGhc e
allocCmdTop :: GHC.LHsCmdTop GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocCmdTop (GHC.L l (GHC.HsCmdTop cmd _ _ _)) toks = r
where
(sb,toksCmd,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
layoutExpr = allocExpr cmd toksCmd
r = [makeGroup $ strip $ (makeLeafFromToks sb)
++ layoutExpr
++ (makeLeafFromToks sa)]
allocHsRecordBinds :: GHC.HsRecordBinds GHC.RdrName -> [GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken])
allocHsRecordBinds (GHC.HsRecFields flds _dot) toks = (r,toks')
where
(r,toks') = foldl doOne ([],toks) flds
doOne (r1,toks1) fld = (r1',toks1')
where
(r2,toks1') = allocHsRecField fld toks1
r1' = r1 ++ r2
allocHsRecField ::
GHC.HsRecField GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> [GhcPosToken]
-> ([LayoutTree GhcPosToken],[GhcPosToken])
allocHsRecField (GHC.HsRecField (GHC.L ln _) expr@(GHC.L le _) _) toks = (r,toks')
where
(s1,toksN,toks1) = splitToksIncComments (ghcSpanStartEnd ln) toks
(s2,toksE,toks2) = splitToksIncComments (ghcSpanStartEnd le) toks1
nLayout = makeLeafFromToks toksN
exprLayout = allocExpr expr toksE
toks' = toks2
r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ nLayout
++ (makeLeafFromToks s2) ++ exprLayout]
allocLocalBinds :: GHC.HsLocalBinds GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocLocalBinds GHC.EmptyLocalBinds toks = strip $ makeLeafFromToks toks
allocLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) toks = r
where
bindList = GHC.bagToList binds
startBind = startPosForList bindList
startSig = startPosForList sigs
start = if startSig < startBind then startSig else startBind
endBind = endPosForList bindList
endSig = endPosForList sigs
end = if endSig > endBind then endSig else endBind
(s1,toksBinds,toks1) = splitToksIncComments (start,end) toks
(s1p,s1r) = break isWhereOrLet s1
(w,s1a) = break (not.isWhereOrLet) s1r
whereLayout = makeLeafFromToks s1p ++ makeLeafFromToks w ++ makeLeafFromToks s1a
firstBindTok = ghead "allocLocalBinds" $ dropWhile isWhiteSpaceOrIgnored toksBinds
p1 = (ghcTokenRow firstBindTok,ghcTokenCol firstBindTok)
(ro,co) = case (filter isWhereOrLet s1) of
[] -> (0,0)
(x:_) -> (ghcTokenRow firstBindTok ghcTokenRow x,
ghcTokenCol firstBindTok (ghcTokenCol x + tokenLen x))
(rt,ct) = calcLastTokenPos toksBinds
bindsLayout' = allocInterleavedLists bindList sigs (toksBinds) allocBind allocSig
so = makeOffset ro (co 1)
bindsLayout = case bindsLayout' of
[] -> []
bs -> [placeAbove so p1 (rt,ct) bs]
r = strip $ whereLayout ++ bindsLayout ++ (makeLeafFromToks toks1)
allocLocalBinds (GHC.HsValBinds (GHC.ValBindsOut _ _)) _
= error "allocLocalBinds (GHC.HsValBinds (GHC.ValBindsOut..)) should not be required"
allocLocalBinds (GHC.HsIPBinds (GHC.IPBinds bs _)) toks = r
where
bindsLayout = allocList bs toks allocLocated
r = strip $ bindsLayout
startPosForList :: [GHC.Located a] -> SimpPos
startPosForList xs = start
where
(start,_) = case xs of
[] -> ((100000,0),(0,0))
((GHC.L ls _):_) -> ghcSpanStartEnd ls
endPosForList :: [GHC.Located a] -> SimpPos
endPosForList xs = end
where
(_,end) = case xs of
[] -> ((0,0),(0,0))
ls -> ghcSpanStartEnd $ GHC.getLoc $ last ls
allocBind :: GHC.LHsBind GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocBind (GHC.L l (GHC.FunBind (GHC.L ln _) _ (GHC.MatchGroup matches _) _ _ _)) toks = r
where
(nameLayout,toks1) = ((makeLeafFromToks s1)++[makeLeaf (g2s ln) NoChange nameToks],toks')
where
(s1,nameToks,toks') = splitToksIncComments (ghcSpanStartEnd ln) toks
(matchesLayout,toks2) = ((makeLeafFromToks s2) ++ allocMatches matches matchToks,toks2')
where
(s2,matchToks,toks2') = splitToksForList matches toks1
r = strip $ [mkGroup (g2s l) NoChange (strip $ nameLayout ++ matchesLayout)] ++ (makeLeafFromToks toks2)
allocBind (GHC.L l (GHC.PatBind lhs@(GHC.L ll _) grhs@(GHC.GRHSs rhs _) _ _ _)) toks = r
where
(s1,bindToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,lhsToks,toks1) = splitToksIncComments (ghcSpanStartEnd ll) bindToks
(s3,rhsToks,bindsToks) = splitToksForList rhs toks1
lhsLayout = allocPat lhs lhsToks
grhsLayout = allocGRHSs grhs (rhsToks ++ bindsToks)
r = [makeGroup $ (strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)
++ lhsLayout ++ (makeLeafFromToks s3) ++ grhsLayout
++ (makeLeafFromToks toks')) ]
allocBind (GHC.L l (GHC.VarBind _n rhs@(GHC.L lr _) _)) toks = r
where
(sb,toksBind,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
(s1,exprToks,toks2) = splitToksIncComments (ghcSpanStartEnd lr) toksBind
exprLayout = allocExpr rhs exprToks
r = [makeGroup $ (strip $ (makeLeafFromToks sb)
++ (makeLeafFromToks s1)
++ exprLayout
++ (makeLeafFromToks toks2)
++ (makeLeafFromToks sa)
)
]
allocBind (GHC.L l (GHC.AbsBinds _tvs _vars _exps _ev binds)) toks = r
where
bindsList = GHC.bagToList binds
(sb,toksBind,sa) = splitToksIncComments (ghcSpanStartEnd l) toks
(s1,bindsToks,toks2) = splitToksForList bindsList toksBind
bindsLayout = allocList bindsList bindsToks allocBind
r = [makeGroup $ (strip $ (makeLeafFromToks sb)
++ (makeLeafFromToks s1)
++ bindsLayout
++ (makeLeafFromToks toks2)
++ (makeLeafFromToks sa)
)
]
allocSig :: GHC.LSig GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocSig (GHC.L l (GHC.TypeSig names t@(GHC.L lt _))) toks = r
where
(s1,bindToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,nameToks,toks'') = splitToksForList names bindToks
(s3,typeToks,s4) = splitToksIncComments (ghcSpanStartEnd lt) toks''
nameLayout = allocList names nameToks allocLocated
typeLayout = allocType t typeToks
nsub = ghead "allocSig.1" nameLayout
tsub = ghead "allocSig.2" typeLayout
(_,ne) = treeStartEnd nsub
(tb,_) = treeStartEnd tsub
gap = (ne,tb)
gapLayout = [Node (Entry gap NoChange []) (makeLeafFromToks s3)]
r = [makeGroup (strip $ (makeLeafFromToks s1)
++ (makeLeafFromToks s2)
++ nameLayout ++ gapLayout ++ typeLayout
++ (makeLeafFromToks s4) ++ (makeLeafFromToks toks'))]
allocSig (GHC.L l (GHC.GenericSig names t@(GHC.L lt _))) toks = r
where
(s1,bindToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,nameToks,toks'') = splitToksForList names bindToks
(s3,typeToks,s4) = splitToksIncComments (ghcSpanStartEnd lt) toks''
nameLayout = allocList names nameToks allocLocated
typeLayout = allocType t typeToks
r = [makeGroup (strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)
++ nameLayout ++ (makeLeafFromToks s3) ++typeLayout
++ (makeLeafFromToks s4) ++ (makeLeafFromToks toks') )]
allocSig (GHC.L l (GHC.IdSig _i)) toks = r
where
(s1,nameToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
r = [makeGroup $ (strip $ (makeLeafFromToks s1) ++ [makeLeaf (g2s l) NoChange nameToks])
++ (makeLeafFromToks toks') ]
allocSig (GHC.L l (GHC.FixSig (GHC.FixitySig n@(GHC.L ln _) _fix))) toks = r
where
(s1,fToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,nToks,fixToks) = splitToksIncComments (ghcSpanStartEnd ln) fToks
r = [makeGroup $ (strip $ (makeLeafFromToks s1) ++ (allocLocated n nToks)
++ (makeLeafFromToks s2) ++ (makeLeafFromToks fixToks))
++ (makeLeafFromToks toks') ]
allocSig (GHC.L l (GHC.InlineSig n@(GHC.L ln _) _ip)) toks = r
where
(s1,sigToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,nToks,ipToks) = splitToksIncComments (ghcSpanStartEnd ln) sigToks
r = [makeGroup $ (strip $ (makeLeafFromToks s1) ++ (allocLocated n nToks)
++ (makeLeafFromToks s2) ++ (makeLeafFromToks ipToks))
++ (makeLeafFromToks toks') ]
allocSig (GHC.L l (GHC.SpecSig n@(GHC.L ln _) t@(GHC.L lt _) _ip)) toks = r
where
(s1,sigToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,nToks,toks'') = splitToksIncComments (ghcSpanStartEnd ln) sigToks
(s3,tToks,ipToks) = splitToksIncComments (ghcSpanStartEnd lt) toks''
nameLayout = allocLocated n nToks
typeLayout = allocType t tToks
ipLayout = makeLeafFromToks ipToks
r = [makeGroup $ (strip $ (makeLeafFromToks s1) ++ nameLayout ++ (makeLeafFromToks s2)
++ typeLayout ++ (makeLeafFromToks s3) ++ ipLayout
++ (makeLeafFromToks toks')) ]
allocSig (GHC.L l (GHC.SpecInstSig t)) toks = r
where
(s1,sigToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
r = [makeGroup $ (strip $ (makeLeafFromToks s1) ++ allocType t sigToks
++ (makeLeafFromToks toks')) ]
allocArithSeqInfo :: GHC.ArithSeqInfo GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocArithSeqInfo (GHC.From e) toks = allocExpr e toks
allocArithSeqInfo (GHC.FromThen e1@(GHC.L l _) e2) toksIn = r
where
(s1,e1Toks,e2Toks) = splitToksIncComments (ghcSpanStartEnd l) toksIn
e1Layout = allocExpr e1 e1Toks
e2Layout = allocExpr e2 e2Toks
r = strip $ (makeLeafFromToks s1) ++ e1Layout ++ e2Layout
allocArithSeqInfo (GHC.FromTo e1@(GHC.L l _) e2) toksIn = r
where
(s1,e1Toks,e2Toks) = splitToksIncComments (ghcSpanStartEnd l) toksIn
e1Layout = allocExpr e1 e1Toks
e2Layout = allocExpr e2 e2Toks
r = strip $ (makeLeafFromToks s1) ++ e1Layout ++ e2Layout
allocArithSeqInfo (GHC.FromThenTo e1@(GHC.L l1 _) e2@(GHC.L l2 _) e3) toksIn = r
where
(s1,e1Toks,toks) = splitToksIncComments (ghcSpanStartEnd l1) toksIn
(s2,e2Toks,e3Toks) = splitToksIncComments (ghcSpanStartEnd l2) toks
e1Layout = allocExpr e1 e1Toks
e2Layout = allocExpr e2 e2Toks
e3Layout = allocExpr e3 e3Toks
r = strip $ (makeLeafFromToks s1) ++ e1Layout ++ e2Layout ++ (makeLeafFromToks s2) ++ e3Layout
allocType :: GHC.LHsType GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocType (GHC.L l (GHC.HsForAllTy _ef vars (GHC.L lc ctx) typ) ) toks = r
where
(s1,exprToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
#if __GLASGOW_HASKELL__ > 704
(varsLayout,toks2) = allocTyVarBndrs vars exprToks
#else
(s1',tp,toks2) = splitToksForList vars exprToks
varsLayout = strip $ (makeLeafFromToks s1') ++ allocList vars tp allocTyVarBndr
#endif
(s2,ctxToks,toks3) = splitToksIncComments (ghcSpanStartEnd lc) toks2
ctxLayout = allocHsContext ctx ctxToks
typLayout = allocType typ toks3
r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ varsLayout
++ (makeLeafFromToks s2) ++ ctxLayout
++ typLayout ++ (makeLeafFromToks toks')]
allocType n@(GHC.L _l (GHC.HsTyVar _) ) toks = allocLocated n toks
allocType (GHC.L l (GHC.HsAppTy t1@(GHC.L l1 _) t2@(GHC.L _ _)) ) toks = r
where
(s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,t1Toks,t2Toks) = splitToksIncComments (ghcSpanStartEnd l1) typeToks
t1Layout = allocType t1 t1Toks
t2Layout = allocType t2 t2Toks
r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)
++ t1Layout ++ t2Layout ++ (makeLeafFromToks toks')]
allocType (GHC.L l (GHC.HsFunTy t1@(GHC.L l1 _) t2@(GHC.L _ _)) ) toks = r
where
(s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,t1Toks,t2Toks) = splitToksIncComments (ghcSpanStartEnd l1) typeToks
t1Layout = allocType t1 t1Toks
t2Layout = allocType t2 t2Toks
r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)
++ t1Layout ++ t2Layout ++ (makeLeafFromToks toks')]
allocType (GHC.L l (GHC.HsListTy t1@(GHC.L l1 _)) ) toks = r
where
(s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,t1Toks,toks2) = splitToksIncComments (ghcSpanStartEnd l1) typeToks
t1Layout = allocType t1 t1Toks
r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)
++ t1Layout ++ (makeLeafFromToks toks2) ++ (makeLeafFromToks toks')]
allocType (GHC.L l (GHC.HsPArrTy t1@(GHC.L l1 _)) ) toks = r
where
(s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,t1Toks,toks2) = splitToksIncComments (ghcSpanStartEnd l1) typeToks
t1Layout = allocType t1 t1Toks
r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)
++ t1Layout ++ (makeLeafFromToks toks2) ++ (makeLeafFromToks toks')]
allocType (GHC.L l (GHC.HsTupleTy _sort types)) toks = r
where
(s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
typesLayout = allocList types typeToks allocType
r = [makeGroup $ strip $ (makeLeafFromToks s1)
++ typesLayout ++ (makeLeafFromToks toks')]
allocType (GHC.L l (GHC.HsOpTy t1@(GHC.L l1 _) _op t2@(GHC.L l2 _))) toks = r
where
(s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,t1Toks,toks2) = splitToksIncComments (ghcSpanStartEnd l1) toks1
(s4,t2Toks,toks4) = splitToksIncComments (ghcSpanStartEnd l2) toks2
t1Layout = allocType t1 t1Toks
t2Layout = allocType t2 t2Toks
r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)
++ t1Layout
++ (makeLeafFromToks s4)
++ t2Layout ++ (makeLeafFromToks toks4)
++ (makeLeafFromToks toks')]
allocType n@(GHC.L _l (GHC.HsParTy _) ) toks = allocLocated n toks
allocType (GHC.L l (GHC.HsIParamTy _ typ@(GHC.L lt _)) ) toks = r
where
(s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,typToks,toks2) = splitToksIncComments (ghcSpanStartEnd lt) toks1
typLayout = allocType typ typToks
r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)
++ typLayout ++ (makeLeafFromToks toks2)
++ (makeLeafFromToks toks')]
allocType (GHC.L l (GHC.HsEqTy t1@(GHC.L l1 _) t2@(GHC.L l2 _))) toks = r
where
(s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,t1Toks,toks2) = splitToksIncComments (ghcSpanStartEnd l1) toks1
(s3,t2Toks,toks3) = splitToksIncComments (ghcSpanStartEnd l2) toks2
t1Layout = allocType t1 t1Toks
t2Layout = allocType t2 t2Toks
r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)
++ t1Layout ++ (makeLeafFromToks s3)
++ t2Layout ++ (makeLeafFromToks toks3)
++ (makeLeafFromToks toks')]
allocType (GHC.L l (GHC.HsKindSig t1@(GHC.L l1 _) t2@(GHC.L l2 _))) toks = r
where
(s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,t1Toks,toks2) = splitToksIncComments (ghcSpanStartEnd l1) toks1
(s3,t2Toks,toks3) = splitToksIncComments (ghcSpanStartEnd l2) toks2
t1Layout = allocType t1 t1Toks
t2Layout = allocType t2 t2Toks
r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)
++ t1Layout ++ (makeLeafFromToks s3)
++ t2Layout ++ (makeLeafFromToks toks3)
++ (makeLeafFromToks toks')]
allocType (GHC.L l (GHC.HsQuasiQuoteTy (GHC.HsQuasiQuote _n _lq _)) ) toks = r
where
(s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
quoteLayout = makeLeafFromToks toks1
r = [makeGroup $ strip $ (makeLeafFromToks s1)
++ quoteLayout
++ (makeLeafFromToks toks') ]
allocType (GHC.L l (GHC.HsSpliceTy (GHC.HsSplice _n e@(GHC.L le _)) _fv _k) ) toks = r
where
(s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,eToks,toks2) = splitToksIncComments (ghcSpanStartEnd le) toks1
eLayout = allocExpr e eToks
r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)
++ eLayout ++ (makeLeafFromToks toks2)
++ (makeLeafFromToks toks') ]
allocType (GHC.L l (GHC.HsDocTy t1@(GHC.L l1 _) t2@(GHC.L l2 _))) toks = r
where
(s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,t1Toks,toks2) = splitToksIncComments (ghcSpanStartEnd l1) toks1
(s3,t2Toks,toks3) = splitToksIncComments (ghcSpanStartEnd l2) toks2
t1Layout = allocType t1 t1Toks
t2Layout = allocLocated t2 t2Toks
r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)
++ t1Layout ++ (makeLeafFromToks s3)
++ t2Layout ++ (makeLeafFromToks toks3)
++ (makeLeafFromToks toks')]
allocType (GHC.L l (GHC.HsBangTy _ t1@(GHC.L l1 _)) ) toks = r
where
(s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,t1Toks,toks2) = splitToksIncComments (ghcSpanStartEnd l1) typeToks
t1Layout = allocType t1 t1Toks
r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)
++ t1Layout ++ (makeLeafFromToks toks2) ++ (makeLeafFromToks toks')]
allocType (GHC.L l (GHC.HsRecTy decls) ) toks = r
where
(s1,typeToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(declsLayout,toks1) = allocConDeclFieldList decls typeToks
r = [makeGroup $ strip $ (makeLeafFromToks s1)
++ declsLayout
++ (makeLeafFromToks toks1)
++ (makeLeafFromToks toks') ]
allocType n@(GHC.L _l (GHC.HsCoreTy _) ) toks = allocLocated n toks
allocType (GHC.L _l (GHC.HsExplicitListTy _ ts) ) toks = allocList ts toks allocType
allocType (GHC.L _l (GHC.HsExplicitTupleTy _ ts) ) toks = allocList ts toks allocType
#if __GLASGOW_HASKELL__ > 704
allocType n@(GHC.L _l (GHC.HsTyLit _) ) toks = allocLocated n toks
#endif
allocType (GHC.L l (GHC.HsWrapTy _ typ) ) toks = allocType (GHC.L l typ) toks
allocInstDecl :: GHC.LInstDecl GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
#if __GLASGOW_HASKELL__ > 704
allocInstDecl (GHC.L l (GHC.ClsInstD polyTy@(GHC.L lt _) binds sigs famInsts)) toks = r
where
(s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,polytToks,toks2) = splitToksIncComments (ghcSpanStartEnd lt) toks1
polytLayout = allocType polyTy polytToks
bindList = GHC.bagToList binds
bindMix = makeMixedListEntry bindList (shim allocBind)
sigMix = makeMixedListEntry sigs (shim allocSig)
famMix = makeMixedListEntry famInsts (shim allocLFamInstDecl)
bindsLayout' = allocMixedList (bindMix++sigMix++famMix) toks2
r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)
++ polytLayout ++ bindsLayout'
++ (makeLeafFromToks toks')
allocInstDecl (GHC.L l (GHC.FamInstD decl)) toks = r
where
(s1,toks1,s2) = splitToksIncComments (ghcSpanStartEnd l) toks
declLayout = allocLFamInstDecl (GHC.L l decl) toks1
r = strip $(makeLeafFromToks s1) ++ declLayout ++ (makeLeafFromToks s2)
#else
allocInstDecl (GHC.L l (GHC.InstDecl (GHC.L ln _) binds sigs tycldecls)) toks = r
where
(s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
bindList = GHC.bagToList binds
bindMix = makeMixedListEntry bindList (shim allocBind)
sigMix = makeMixedListEntry sigs (shim allocSig)
famMix = makeMixedListEntry tycldecls (shim allocLTyClDecl)
bindsLayout' = allocMixedList (bindMix++sigMix++famMix) toks1
r = strip $ (makeLeafFromToks s1)
++ bindsLayout'
++ (makeLeafFromToks toks')
#endif
#if __GLASGOW_HASKELL__ > 704
allocLFamInstDecl :: GHC.LFamInstDecl GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocLFamInstDecl (GHC.L l (GHC.FamInstDecl n@(GHC.L ln _) (GHC.HsWB typs _ _) defn _fvs)) toks = r
where
(s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,nToks,toks2) = splitToksIncComments (ghcSpanStartEnd ln) toks1
(s3,typsToks,defnToks) = splitToksForList typs toks2
nLayout = allocLocated n nToks
patsLayout = allocList typs typsToks allocType
(defnLayout,s4) = allocHsTyDefn defn defnToks
r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)
++ nLayout ++ (makeLeafFromToks s3)
++ patsLayout ++ defnLayout
++ (makeLeafFromToks s4)
++ (makeLeafFromToks toks')
#endif
allocTupArgList :: [GHC.HsTupArg GHC.RdrName] -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocTupArgList tas toksIn = r
where
go :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> [GHC.HsTupArg GHC.RdrName] -> ([LayoutTree GhcPosToken],[GhcPosToken])
go (acc,toks) [] = (acc,toks)
go (acc,toks) ((GHC.Missing _):ts') = go (acc,toks) ts'
go (acc,toks) ((GHC.Present expr@(GHC.L l _)):ts') = go (acc++exprLayout,toks') ts'
where
(s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
eLayout = allocExpr expr toks1
exprLayout = strip $ (makeLeafFromToks s1) ++ eLayout
(lay,toksOut) = go ([],toksIn) tas
r = strip $ lay ++ (makeLeafFromToks toksOut)
allocLocated :: GHC.Located b -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocLocated (GHC.L l _) toks = r
where
(s1,toks1,s2) = splitToksIncComments (ghcSpanStartEnd l) toks
r = strip $ (makeLeafFromToks s1) ++ [makeLeaf (g2s l) NoChange toks1] ++ (makeLeafFromToks s2)
#if __GLASGOW_HASKELL__ > 704
allocTyVarBndrs :: GHC.LHsTyVarBndrs GHC.RdrName -> [GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken])
allocTyVarBndrs (GHC.HsQTvs _kvs tvs) toks = (r,s1)
where
(kvsToks,tyvarToks,s1) = splitToksForList tvs toks
tyvarLayout = allocList tvs tyvarToks allocTyVarBndr
r = (strip $ (makeLeafFromToks kvsToks) ++ tyvarLayout)
#else
#endif
allocTyVarBndr :: GHC.LHsTyVarBndr GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
#if __GLASGOW_HASKELL__ > 704
allocTyVarBndr n@(GHC.L l (GHC.UserTyVar _ )) toks = r
#else
allocTyVarBndr n@(GHC.L l (GHC.UserTyVar _ _)) toks = r
#endif
where
(s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
nLayout = allocLocated n toks1
r = strip $ (makeLeafFromToks s1) ++ nLayout
++ (makeLeafFromToks toks')
#if __GLASGOW_HASKELL__ > 704
allocTyVarBndr (GHC.L l (GHC.KindedTyVar _n k@(GHC.L lk _) )) toks = r
#else
allocTyVarBndr (GHC.L l (GHC.KindedTyVar _n k@(GHC.L lk _) _)) toks = r
#endif
where
(s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(nToks,kToks,toks2) = splitToksIncComments (ghcSpanStartEnd lk) toks1
nLayout = makeLeafFromToks nToks
kindLayout = allocType k kToks
r = strip $ (makeLeafFromToks s1) ++ nLayout
++ kindLayout ++ (makeLeafFromToks toks2)
++ (makeLeafFromToks toks')
#if __GLASGOW_HASKELL__ > 704
allocHsTyDefn :: GHC.HsTyDefn GHC.RdrName -> [GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken])
allocHsTyDefn (GHC.TySynonym typ@(GHC.L l _)) toks = (r,toks')
where
(s1,typToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
typeLayout = allocType typ typToks
r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ typeLayout]
allocHsTyDefn (GHC.TyData _ (GHC.L lc ctx) mc mk cons mderivs) toks = (r,toks')
where
(s1,ctxToks,toks2) = splitToksIncComments (ghcSpanStartEnd lc) toks
ctxLayout = allocHsContext ctx ctxToks
(mcLayout,toks3) = case mc of
Nothing -> ([],toks2)
Just ct -> (rc,toks2')
where
ctLayout = allocCType ct toks2
toks2' = toks2
rc = strip $ ctLayout
(mkLayout,toks4) = case mk of
Nothing -> ([],toks3)
Just k@(GHC.L lk _) -> (rk,toks3')
where
(sk,kToks,toks3') = splitToksIncComments (ghcSpanStartEnd lk) toks3
kindLayout = allocHsKind k kToks
rk = strip $ (makeLeafFromToks sk) ++ kindLayout
(s2,consToks,toks5) = splitToksForList cons toks4
consLayout = allocList cons consToks allocConDecl
(mderivsLayout,toks6) = case mderivs of
Nothing -> ([],toks5)
Just ds -> (rd,toksd)
where
(sd,derivToks,toksd) = splitToksForList ds toks5
derivLayout = allocList ds derivToks allocType
rd = strip $ (makeLeafFromToks sd) ++ derivLayout
toks' = toks6
r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ ctxLayout ++ mcLayout ++ mkLayout
++ (makeLeafFromToks s2) ++ consLayout ++ mderivsLayout]
#endif
allocConDecl :: GHC.LConDecl GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocConDecl (GHC.L l (GHC.ConDecl n@(GHC.L ln _) _expl qvars (GHC.L lc ctx) details res mdoc _)) toks = r
where
(s1,conDeclToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
(s2,nameToks,toks2) = splitToksIncComments (ghcSpanStartEnd ln) conDeclToks
nameLayout = allocLocated n nameToks
#if __GLASGOW_HASKELL__ > 704
(qvarsLayout,toks3) = allocTyVarBndrs qvars toks2
#else
qvarsLayout = allocList qvars toks2 allocTyVarBndr
toks3 = []
#endif
(s3,ctxToks,toks4) = splitToksIncComments (ghcSpanStartEnd lc) toks3
ctxLayout = allocHsContext ctx ctxToks
(detailsLayout,toks5) = allocHsConDeclDetails details toks4
(resLayout,toks6) = case res of
GHC.ResTyH98 -> ([],toks5)
GHC.ResTyGADT (ty@(GHC.L lt _)) -> (rt,toks6')
where
(st,tyToks,toks6') = splitToksIncComments (ghcSpanStartEnd lt) toks5
tyLayout = allocType ty tyToks
rt = strip $ (makeLeafFromToks st) ++ tyLayout
(docLayout,toks7) = case mdoc of
Nothing -> ([],toks6)
Just ds@(GHC.L ld _) -> (rd,toks7')
where
(sd,dsToks,toks7') = splitToksIncComments (ghcSpanStartEnd ld) toks6
dsLayout = allocLocated ds dsToks
rd = strip (makeLeafFromToks sd) ++ dsLayout
r = strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)
++ nameLayout ++ qvarsLayout ++ (makeLeafFromToks s3)
++ ctxLayout ++ detailsLayout ++ resLayout
++ docLayout ++ (makeLeafFromToks toks7)
++ (makeLeafFromToks toks')
allocHsConDeclDetails :: GHC.HsConDeclDetails GHC.RdrName -> [GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken])
allocHsConDeclDetails (GHC.PrefixCon ds) toks = (r,toks')
where
(s1,dsToks,toks') = splitToksForList ds toks
dsLayout = allocList ds dsToks allocLBangType
r = strip $ (makeLeafFromToks s1) ++ dsLayout
allocHsConDeclDetails (GHC.RecCon conDecls) toks = allocConDeclFieldList conDecls toks
allocHsConDeclDetails (GHC.InfixCon bt1@(GHC.L lb1 _) bt2@(GHC.L lb2 _)) toks = (r,toks')
where
(s1,bt1Toks,toks2) = splitToksIncComments (ghcSpanStartEnd lb1) toks
(s2,bt2Toks,toks') = splitToksIncComments (ghcSpanStartEnd lb2) toks2
bt1Layout = allocType bt1 bt1Toks
bt2Layout = allocType bt2 bt2Toks
r = strip $ (makeLeafFromToks s1) ++ bt1Layout
++ (makeLeafFromToks s2) ++ bt2Layout
allocConDeclFieldList :: [GHC.ConDeclField GHC.RdrName] -> [GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken])
allocConDeclFieldList conDecls toks = (r,toks')
where
(r,toks') = foldl' doOne ([],toks) conDecls
doOne (acc,toksOne) cdf = (r1,toks2)
where
(lay,toks2) = allocConDeclField cdf toksOne
r1 = acc ++ lay
allocConDeclField :: GHC.ConDeclField GHC.RdrName -> [GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken])
allocConDeclField (GHC.ConDeclField n@(GHC.L ln _) typ@(GHC.L lb _) mdoc) toks = (r,toks')
where
(s1,nToks,toks1) = splitToksIncComments (ghcSpanStartEnd ln) toks
nLayout = allocLocated n nToks
(s2,btToks,toks2) = splitToksIncComments (ghcSpanStartEnd lb) toks1
btLayout = allocLBangType typ btToks
(mdocLayout,toks') = case mdoc of
Nothing -> ([],toks2)
Just ldoc@(GHC.L ld _) -> (rd,toks2')
where
(sd,docToks,toks2') = splitToksIncComments (ghcSpanStartEnd ld) toks2
rdLayout = allocLocated ldoc docToks
rd = strip $ (makeLeafFromToks sd) ++ rdLayout
r = strip $ (makeLeafFromToks s1) ++ nLayout ++ (makeLeafFromToks s2)
++ btLayout ++ mdocLayout
allocLBangType :: GHC.LBangType GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocLBangType bt toks = allocType bt toks
allocHsKind :: GHC.LHsKind GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocHsKind = error "allocHsKind undefined"
#if __GLASGOW_HASKELL__ > 704
allocCType :: GHC.CType -> [GhcPosToken] -> [LayoutTree GhcPosToken]
#endif
allocCType = error "allocCType undefined"
allocHsContext :: GHC.HsContext GHC.RdrName -> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocHsContext ts toks = r
where
r = allocList ts toks allocType
allocInterleavedLists :: [GHC.Located a] -> [GHC.Located b] -> [GhcPosToken]
-> (GHC.Located a -> [GhcPosToken] -> [LayoutTree GhcPosToken])
-> (GHC.Located b -> [GhcPosToken] -> [LayoutTree GhcPosToken])
-> [LayoutTree GhcPosToken]
allocInterleavedLists axs bxs toksIn allocFuncA allocFuncB = r
where
go (acc,ts) [] [] = (acc,ts)
go (acc,ts) (a:as) [] = go (acc ++ aa,ts') as []
where
(aa,ts') = allocA a ts
go (acc,ts) [] (b:bs) = go (acc ++ bb,ts') [] bs
where
(bb,ts') = allocB b ts
go (acc,ts) (a:as) (b:bs) = if GHC.getLoc a < GHC.getLoc b
then go (acc ++ aa,tsa') as (b:bs)
else go (acc ++ bb,tsb') (a:as) bs
where
(aa,tsa') = allocA a ts
(bb,tsb') = allocB b ts
allocA x@(GHC.L l _) toks = (r',toks')
where
(s1,funcToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
funcLayout = allocFuncA x funcToks
r' = strip $ (makeLeafFromToks s1) ++ [makeGroup (strip funcLayout)]
allocB x@(GHC.L l _) toks = (r',toks')
where
(s1,funcToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
funcLayout = allocFuncB x funcToks
r' = strip $ (makeLeafFromToks s1) ++ [makeGroup (strip funcLayout)]
(layout,s2) = go ([],toksIn) axs bxs
r = strip $ layout ++ (makeLeafFromToks s2)
shim ::
(GHC.Located a -> [GhcPosToken] -> [LayoutTree GhcPosToken])
-> (GHC.Located a -> [GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken]))
shim f = f'
where
f' x@(GHC.L l _) toks = (r,toks')
where
(s1,toks1,toks') = splitToksIncComments (ghcSpanStartEnd l) toks
r = strip $ (makeLeafFromToks s1) ++ f x toks1
makeMixedListEntry ::
[GHC.Located a]
-> (GHC.Located a -> [GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken]))
-> [(SimpPos,([GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken])))]
makeMixedListEntry xs f = map (\x@(GHC.L l _) -> (fst $ ghcSpanStartEnd l,f x)) xs
allocMixedList ::
[(SimpPos,([GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken])))]
-> [GhcPosToken] -> [LayoutTree GhcPosToken]
allocMixedList xs toksIn = r
where
xs' = sortBy (\(p1,_) (p2,_) -> compare p1 p2) xs
(layout,toksFin) = foldl' doOne ([],toksIn) xs'
doOne :: ([LayoutTree GhcPosToken],[GhcPosToken]) -> (SimpPos,([GhcPosToken] -> ([LayoutTree GhcPosToken],[GhcPosToken])))
-> ([LayoutTree GhcPosToken],[GhcPosToken])
doOne (acc,toks) (_,f) = (acc++lay,toks')
where
(lay,toks') = f toks
r = strip $ layout ++ (makeLeafFromToks toksFin)
getGhcLoc :: GHC.SrcSpan -> (Int, Int)
getGhcLoc (GHC.RealSrcSpan ss) = (GHC.srcSpanStartLine ss, GHC.srcSpanStartCol ss)
getGhcLoc (GHC.UnhelpfulSpan _) = (1,1)
getGhcLocEnd :: GHC.SrcSpan -> (Int, Int)
getGhcLocEnd (GHC.RealSrcSpan ss) = (GHC.srcSpanEndLine ss, GHC.srcSpanEndCol ss)
getGhcLocEnd (GHC.UnhelpfulSpan _) = (1,1)
getLocatedStart :: GHC.GenLocated GHC.SrcSpan t -> (Int, Int)
getLocatedStart (GHC.L l _) = getGhcLoc l
getLocatedEnd :: GHC.GenLocated GHC.SrcSpan t -> (Int, Int)
getLocatedEnd (GHC.L l _) = getGhcLocEnd l
ghcSpanStartEnd :: GHC.SrcSpan -> ((Int, Int), (Int, Int))
ghcSpanStartEnd sspan = (getGhcLoc sspan,getGhcLocEnd sspan)
ghcTokenCol :: GhcPosToken -> Int
ghcTokenCol (GHC.L l _,_) = c where (_,c) = getGhcLoc l
ghcTokenColEnd :: GhcPosToken -> Int
ghcTokenColEnd (GHC.L l _,_) = c where (_,c) = getGhcLocEnd l
ghcTokenRow :: GhcPosToken -> Int
ghcTokenRow (GHC.L l _,_) = r where (r,_) = getGhcLoc l
tokenPosEnd :: (GHC.GenLocated GHC.SrcSpan t1, t) -> SimpPos
tokenPosEnd (GHC.L l _,_) = getGhcLocEnd l
tokenSrcSpan :: (GHC.Located t1, t) -> GHC.SrcSpan
tokenSrcSpan (GHC.L l _,_) = l
showGhc :: (GHC.Outputable a) => a -> String
#if __GLASGOW_HASKELL__ > 704
showGhc x = GHC.showSDoc GHC.tracingDynFlags $ GHC.ppr x
#else
showGhc x = GHC.showSDoc $ GHC.ppr x
#endif
ghcIsEmpty :: GhcPosToken -> Bool
ghcIsEmpty ((GHC.L _ (GHC.ITsemi)), "") = True
ghcIsEmpty ((GHC.L _ (GHC.ITvocurly)), "") = True
ghcIsEmpty ((GHC.L _ _), "") = True
ghcIsEmpty _ = False
mkToken::GHC.Token -> SimpPos -> String -> GhcPosToken
mkToken t (row,col) c = ((GHC.L l t),c)
where
filename = (GHC.mkFastString "f")
l = GHC.mkSrcSpan (GHC.mkSrcLoc filename row col) (GHC.mkSrcLoc filename row (col + (length c) ))
ghcZeroToken :: GhcPosToken
ghcZeroToken = mkToken GHC.ITsemi (0,0) ""
nullSrcSpan :: GHC.SrcSpan
nullSrcSpan = GHC.UnhelpfulSpan $ GHC.mkFastString "HaRe nullSrcSpan"
g2s :: GHC.SrcSpan -> SimpSpan
g2s ss = ((GHC.srcSpanStartLine ss',GHC.srcSpanStartCol ss'),
(GHC.srcSpanEndLine ss', GHC.srcSpanEndCol ss'))
where ss' = case ss of
GHC.RealSrcSpan sp -> sp
GHC.UnhelpfulSpan str -> error $ "g2 got UnhelpfulSpan" ++ (GHC.unpackFS str)
s2g :: SimpSpan -> GHC.SrcSpan
s2g ((sr,sc),(er,ec)) = sp
where
filename = (GHC.mkFastString "f")
sp = GHC.mkSrcSpan (GHC.mkSrcLoc filename sr sc) (GHC.mkSrcLoc filename er ec)
instance Allocatable GHC.ParsedSource GhcPosToken where
allocTokens = ghcAllocTokens
instance (IsToken (GHC.Located GHC.Token, String)) where
tokenLen = ghcTokenLen
isComment = ghcIsComment
isEmpty = ghcIsEmpty
mkZeroToken = ghcZeroToken
isDo = ghcIsDo
isElse = ghcIsElse
isIn = ghcIsIn
isLet = ghcIsLet
isOf = ghcIsOf
isThen = ghcIsThen
isWhere = ghcIsWhere
tokenToString (_,s) = s
showTokenStream = GHC.showRichTokenStream
lexStringToTokens = ghcLexStringToTokens
markToken = ghcMarkToken
isMarked = ghcIsMarked
instance (HasLoc (GHC.Located a)) where
getLoc (GHC.L l _) = start where ( start,_end) = g2s l
getLocEnd (GHC.L l _) = end where (_start, end) = g2s l
putSpan (GHC.L l v) ns = GHC.L (putSpan l ns) v
instance HasLoc GHC.SrcSpan where
getLoc = getGhcLoc
getLocEnd = getGhcLocEnd
putSpan _ss ns = s2g ns
instance (HasLoc (GHC.Located GHC.Token, String)) where
getLoc (lt,_) = getLoc lt
getLocEnd (lt,_) = getLocEnd lt
putSpan (lt,s) ns = (ghcPutSpan lt ns,s)
showToks toks = show $ map (\(t@(GHC.L _ tok),s) ->
((getLocatedStart t, getLocatedEnd t),tok,s)) toks
instance Show (GHC.GenLocated GHC.SrcSpan GHC.Token) where
show t@(GHC.L _l tok) = show ((getLocatedStart t, getLocatedEnd t),tok)
tokenFileMark :: GHC.FastString
tokenFileMark = GHC.mkFastString "HaRe"
ghcMarkToken :: GhcPosToken -> GhcPosToken
ghcMarkToken tok = tok'
where
(GHC.L l t,s) = tok
tok' = (GHC.L (GHC.RealSrcSpan l') t,s)
l' = case l of
GHC.RealSrcSpan ss ->
GHC.mkRealSrcSpan
(GHC.mkRealSrcLoc tokenFileMark (GHC.srcSpanStartLine ss) (GHC.srcSpanStartCol ss))
(GHC.mkRealSrcLoc tokenFileMark (GHC.srcSpanEndLine ss) (GHC.srcSpanEndCol ss))
_ -> error $ "markToken: expecting a real SrcSpan, got"
ghcIsMarked :: GhcPosToken -> Bool
ghcIsMarked (GHC.L l _,_) =
case l of
GHC.RealSrcSpan ss -> GHC.srcSpanFile ss == tokenFileMark
_ -> False
ghcGetSpan :: GhcPosToken -> SimpSpan
ghcGetSpan (GHC.L l _,_) = g2s l
ghcPutSpan :: (GHC.Located a) -> SimpSpan -> (GHC.Located a)
ghcPutSpan (GHC.L _l x) s = (GHC.L l' x)
where
l' = s2g s
ghcIsWhere :: GhcPosToken -> Bool
ghcIsWhere ((GHC.L _ t),_s) = case t of
GHC.ITwhere -> True
_ -> False
ghcIsLet :: GhcPosToken -> Bool
ghcIsLet ((GHC.L _ t),_s) = case t of
GHC.ITlet -> True
_ -> False
ghcIsElse :: GhcPosToken -> Bool
ghcIsElse ((GHC.L _ t),_s) = case t of
GHC.ITelse -> True
_ -> False
ghcIsThen :: GhcPosToken -> Bool
ghcIsThen ((GHC.L _ t),_s) = case t of
GHC.ITthen -> True
_ -> False
ghcIsOf :: GhcPosToken -> Bool
ghcIsOf ((GHC.L _ t),_s) = case t of
GHC.ITof -> True
_ -> False
ghcIsDo :: GhcPosToken -> Bool
ghcIsDo ((GHC.L _ t),_s) = case t of
GHC.ITdo -> True
_ -> False
ghcIsIn :: GhcPosToken -> Bool
ghcIsIn ((GHC.L _ t),_s) = case t of
GHC.ITin -> True
_ -> False
ghcIsComment :: GhcPosToken -> Bool
ghcIsComment ((GHC.L _ (GHC.ITdocCommentNext _)),_s) = True
ghcIsComment ((GHC.L _ (GHC.ITdocCommentPrev _)),_s) = True
ghcIsComment ((GHC.L _ (GHC.ITdocCommentNamed _)),_s) = True
ghcIsComment ((GHC.L _ (GHC.ITdocSection _ _)),_s) = True
ghcIsComment ((GHC.L _ (GHC.ITdocOptions _)),_s) = True
ghcIsComment ((GHC.L _ (GHC.ITdocOptionsOld _)),_s) = True
ghcIsComment ((GHC.L _ (GHC.ITlineComment _)),_s) = True
ghcIsComment ((GHC.L _ (GHC.ITblockComment _)),_s) = True
ghcIsComment ((GHC.L _ _),_s) = False
ghcTokenLen :: (t, [a]) -> Int
ghcTokenLen (_,s) = length s
gs2f :: GHC.SrcSpan -> ForestSpan
gs2f = ghcSrcSpanToForestSpan
f2gs :: ForestSpan -> GHC.SrcSpan
f2gs = forestSpanToGhcSrcSpan
gs2ss :: GHC.SrcSpan -> SimpSpan
gs2ss ss = ((getGhcLoc ss),(getGhcLocEnd ss))
ss2gs :: SimpSpan -> GHC.SrcSpan
ss2gs ((sr,sc),(er,ec)) = GHC.mkSrcSpan locStart locEnd
where
fname = GHC.mkFastString "foo"
locStart = GHC.mkSrcLoc fname sr sc
locEnd = GHC.mkSrcLoc fname er ec
ghcSrcSpanToForestSpan :: GHC.SrcSpan -> ForestSpan
ghcSrcSpanToForestSpan sspan = ((ghcLineToForestLine startRow,startCol),(ghcLineToForestLine endRow,endCol))
where
(startRow,startCol) = getGhcLoc sspan
(endRow,endCol) = getGhcLocEnd sspan
forestSpanToGhcSrcSpan :: ForestSpan -> GHC.SrcSpan
forestSpanToGhcSrcSpan ((fls,sc),(fle,ec)) = sspan
where
lineStart = forestLineToGhcLine fls
lineEnd = forestLineToGhcLine fle
locStart = GHC.mkSrcLoc (GHC.mkFastString "foo") lineStart sc
locEnd = GHC.mkSrcLoc (GHC.mkFastString "foo") lineEnd ec
sspan = GHC.mkSrcSpan locStart locEnd
insertForestLineInSrcSpan :: ForestLine -> GHC.SrcSpan -> GHC.SrcSpan
insertForestLineInSrcSpan fl@(ForestLine ch tr v _l) (GHC.RealSrcSpan ss) = ss'
where
lineStart = forestLineToGhcLine fl
(_,(ForestLine _ _ _ le,_)) = ghcSrcSpanToForestSpan (GHC.RealSrcSpan ss)
lineEnd = forestLineToGhcLine (ForestLine ch tr v le)
locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineStart (GHC.srcSpanStartCol ss)
locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) lineEnd (GHC.srcSpanEndCol ss)
ss' = GHC.mkSrcSpan locStart locEnd
insertForestLineInSrcSpan _ _ss = error $ "insertForestLineInSrcSpan: expecting a RealSrcSpan, got:"
showSrcSpan :: GHC.SrcSpan -> String
showSrcSpan sspan = show (getGhcLoc sspan, (r,c))
where
(r,c) = getGhcLocEnd sspan
showSrcSpanF :: GHC.SrcSpan -> String
showSrcSpanF sspan = show (((chs,trs,vs,ls),cs),((che,tre,ve,le),ce))
where
((ForestLine chs trs vs ls,cs),(ForestLine che tre ve le,ce)) = ghcSrcSpanToForestSpan sspan
newNameTok :: Bool -> GHC.SrcSpan -> GHC.Name -> GhcPosToken
newNameTok useQual l newName =
((GHC.L l' (GHC.ITvarid (GHC.mkFastString newNameStr))),newNameStr)
where
newNameStr = if useQual then (showGhc newName)
else (GHC.occNameString $ GHC.getOccName newName)
l' = case l of
GHC.RealSrcSpan ss ->
let
((ForestLine _ _ _ startRow,startCol),_) = ghcSrcSpanToForestSpan l
locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) startRow startCol
locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) startRow (length newNameStr + startCol)
in
GHC.mkSrcSpan locStart locEnd
_ -> l
ghcAllocTokens' :: GHC.ParsedSource-> [GhcPosToken] -> LayoutTree GhcPosToken
ghcAllocTokens' parsed toks = r
where
parsed' = sanitize parsed
ss = allocTokensSrcSpans parsed'
ss1 = (ghead "ghcAllocTokens" ss)
ss2 = addEndOffsets ss1 toks
ss3 = decorate ss2 toks
ss4 = addLayout parsed ss3
r = error $ "foo=" ++ drawTreeWithToks ss4
allocTokensSrcSpans :: Data a => a -> [LayoutTree GhcPosToken]
allocTokensSrcSpans modu = r
where
start :: [LayoutTree (GhcPosToken)] -> [LayoutTree (GhcPosToken)]
start old = old
r = synthesizelStaged SYB.Parser [] [] redf (start `mkQ` bb
) modu
bb :: GHC.SrcSpan -> [LayoutTree GhcPosToken] -> [LayoutTree GhcPosToken]
bb ss@(GHC.RealSrcSpan _) vv = [Node (Entry (gs2f ss) NoChange []) vv]
bb ss vv = vv
mergeSubs as bs = as ++ bs
redf :: [LayoutTree GhcPosToken] -> [LayoutTree GhcPosToken] -> [LayoutTree GhcPosToken]
redf [] b = b
redf a [] = a
redf [a@(Node e1@(Entry s1 l1 []) sub1)] [b@(Node _e2@(Entry s2 l2 []) sub2)]
=
let
(as,ae) = treeStartEnd a
(bs,be) = treeStartEnd b
ss = combineSpans s1 s2
ret =
case (compare as bs,compare ae be) of
(EQ,EQ) -> [Node (Entry s1 (l1 <> l2) []) (sub1 ++ sub2)]
(LT,EQ) -> [Node (Entry ss (l1 <> l2) []) (mergeSubs sub1 [b])]
(GT,EQ) -> [Node (Entry ss (l1 <> l2) []) (mergeSubs sub2 [a])]
(EQ,GT) -> [Node (Entry ss (l1 <> l2) []) (mergeSubs [b] sub1)]
(EQ,LT) -> [Node (Entry ss (l1 <> l2) []) (mergeSubs [a] sub2)]
(_,_) -> if ae <= bs
then [Node e [a,b]]
else if be <= as
then [Node e [b,a]]
else
[Node e1 (sub1++[b])]
where
e = Entry ss NoChange []
(Node (Entry _ _lr []) _) = head ret
in
ret
redf new old = error $ "bar2.redf:" ++ show (new,old)
synthesizel :: s -> (s -> t -> s) -> GenericQ (s -> t) -> GenericQ t
synthesizel z o f x = f x (foldl o z (gmapQ (synthesizel z o f) x))
synthesizelStaged :: SYB.Stage -> t -> s -> (s -> t -> s) -> GenericQ (s -> t) -> GenericQ t
synthesizelStaged stage zt z o f x
| checkItemStage stage x = zt
| otherwise = f x (foldl' o z (gmapQ ((synthesizelStaged stage zt) z o f) x))
checkItemStage :: (Typeable a, Data a) => SYB.Stage -> a -> Bool
checkItemStage stage x = (checkItemStage1 stage x)
#if __GLASGOW_HASKELL__ > 704
|| (checkItemStage2 stage x)
#endif
checkItemStage1 :: (Typeable a) => SYB.Stage -> a -> Bool
checkItemStage1 stage x = (const False `SYB.extQ` postTcType `SYB.extQ` fixity `SYB.extQ` nameSet) x
where nameSet = const (stage `elem` [SYB.Parser,SYB.TypeChecker]) :: GHC.NameSet -> Bool
postTcType = const (stage < SYB.TypeChecker ) :: GHC.PostTcType -> Bool
fixity = const (stage < SYB.Renamer ) :: GHC.Fixity -> Bool
#if __GLASGOW_HASKELL__ > 704
checkItemStage2 :: Data a => SYB.Stage -> a -> Bool
checkItemStage2 stage x = (const False `SYB.ext1Q` hsWithBndrs) x
where
hsWithBndrs = const (stage < SYB.Renamer) :: GHC.HsWithBndrs a -> Bool
#endif
instance Monoid Layout where
mempty = NoChange
mappend NoChange NoChange = NoChange
mappend NoChange x = x
mappend x NoChange = x
mappend (Above bo1 ps1 pe1 eo1) (Above bo2 ps2 pe2 eo2)
= (Above bo ps pe eo)
where
(bo,ps) = if ps1 <= ps2 then (bo1,ps1)
else (bo2,ps2)
(eo,pe) = if pe1 >= pe2 then (eo1,pe1)
else (eo2,pe2)
sanitize :: (Typeable a,Data a) => a -> a
sanitize t = r
where
r = everywhereStaged SYB.Parser (SYB.mkT cmdTopR `SYB.extT` cmdTopN
#if __GLASGOW_HASKELL__ > 704
`SYB.extT` parStmt
#endif
) t
cmdTopN :: GHC.HsCmdTop GHC.Name -> GHC.HsCmdTop GHC.Name
cmdTopN (GHC.HsCmdTop cmd ts typ _) = (GHC.HsCmdTop cmd ts typ [])
cmdTopR :: GHC.HsCmdTop GHC.RdrName -> GHC.HsCmdTop GHC.RdrName
cmdTopR (GHC.HsCmdTop cmd ts typ _) = (GHC.HsCmdTop cmd ts typ [])
#if __GLASGOW_HASKELL__ > 704
parStmt :: GHC.ParStmtBlock GHC.RdrName GHC.RdrName -> GHC.ParStmtBlock GHC.RdrName GHC.RdrName
parStmt (GHC.ParStmtBlock stmts _ typ) = (GHC.ParStmtBlock stmts [] typ)
#endif
everywhereStaged :: SYB.Stage -> (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhereStaged stage f x
| checkItemStage stage x = x
| otherwise = (f . gmapT (everywhereStaged stage f)) x
everywhereStaged' :: SYB.Stage -> (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhereStaged' stage f x
| checkItemStage stage x = x
| otherwise = (gmapT (everywhereStaged stage f) . f) x
everythingStaged :: SYB.Stage -> (r -> r -> r) -> r -> SYB.GenericQ r -> SYB.GenericQ r
everythingStaged stage k z f x
| checkItemStage stage x = z
| otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x)
addLayout :: GHC.ParsedSource -> LayoutTree GhcPosToken -> LayoutTree GhcPosToken
addLayout parsed tree = r
where
ztree = Z.fromTree tree
[r] = everythingStaged SYB.Parser combine [tree] ([] `SYB.mkQ` lgrhs
`SYB.extQ` lmatch
) parsed
combine :: [LayoutTree GhcPosToken] -> [LayoutTree GhcPosToken] -> [LayoutTree GhcPosToken]
combine [] rs = rs
combine ls [] = ls
combine [l] [rt] = trace ("addLayout.combine1:" ++ show (rootLabel l,rootLabel rt)) [rt]
combine ls rs = trace ("addLayout.combine2:" ++ show (ls,rs)) []
lgrhs :: GHC.Located (GHC.GRHSs GHC.RdrName) -> [LayoutTree GhcPosToken]
lgrhs (GHC.L l (GHC.GRHSs rhs (GHC.HsValBinds binds))) = tt
where
z = openZipperToSpan (gs2f l) ztree
tt = trace ("lgrhs:z=" ++ show (Z.label z)) undefined
lgrhs _ = []
lmatch :: GHC.LMatch GHC.RdrName -> [LayoutTree GhcPosToken]
lmatch (GHC.L l (GHC.Match pats mtyp (GHC.GRHSs rhs (GHC.HsValBinds binds)) )) = tt
where
z = openZipperToSpan (gs2f l) ztree
tt = trace ("lmatch:z=" ++ drawTreeWithToks (Z.tree z)) undefined
lmatch _ = []
ghcLexStringToTokens :: SimpSpan -> String -> [GhcPosToken]
ghcLexStringToTokens startLoc str = r
where
rsl = case ss2gs startLoc of
GHC.RealSrcSpan x -> GHC.realSrcSpanStart x
_ -> undefined
r = unsafePerformIO $ lexStringToRichTokens rsl str
lexStringToRichTokens :: GHC.RealSrcLoc -> String -> IO [GhcPosToken]
lexStringToRichTokens startLoc str = do
#if __GLASGOW_HASKELL__ > 704
GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $ do
#else
GHC.defaultErrorHandler GHC.defaultLogAction $ do
#endif
GHC.runGhc (Just GHC.libdir) $ do
dflags <- GHC.getSessionDynFlags
let dflags' = foldl GHC.xopt_set dflags
[GHC.Opt_Cpp, GHC.Opt_ImplicitPrelude, GHC.Opt_MagicHash]
_ <- GHC.setSessionDynFlags dflags'
let res = GHC.lexTokenStream (GHC.stringToStringBuffer str) startLoc dflags'
case res of
GHC.POk _ toks -> return $ GHC.addSourceToTokens startLoc (GHC.stringToStringBuffer str) toks
GHC.PFailed _srcSpan _msg -> error $ "lexStringToRichTokens:"