HsLexMerge.hs

module HsLexMerge where
import HsLexerPos(Pos(..),startPos,nextPos,nextPos1)
import HsTokens
--import OpTypes(eqBy)
import List(groupBy)
import Unlit(CommentClass(..))

mergeLex ([],ts) = ts -- for efficiency when tokens are not from a literal file
mergeLex (litcmnts,ts) =
    rejoin .
    addSpace startPos .
    merge (groupLit (addPos litcmnts)) .
    concatMap split .
    filter notSpace 
    $ ts
  where
    addPos = zipWith pos [1..]
       where pos l s = (Pos 0 l 1,s) -- dummy character position

    notSpace (t,_) = t/=Whitespace

    split (t,(Pos n y x,s)) =
	[(t,(Pos n y' x',l))|((y',x'),l)<-zip ps (lines s),l/=""]
      where ps = zip [y..] (x:repeat 1)

    rejoin [] = []
    rejoin (t@(tt,(p@Pos{char=n},s)):ts) =
      case rejoin ts of
        t'@(tt',(Pos{char=n'},s')):ts' | n>0 && tt==tt' && n'==n -> (tt,(p,s++s')):ts'
	ts' -> t:ts'

    groupLit = map join . groupBy bothLitCmnt
      where
        bothLitCmnt (_,(LitCmnt,_)) (_,(LitCmnt,_)) = True
	bothLitCmnt _ _ = False

        join ((p,(LitCmnt,s)):cs) = (p,(LitCmnt,unlines (s:map (snd.snd) cs)))
        join [l] = l

    litc (p,(cc,c)) = (conv cc,(p,c))
      where
        conv LitCmnt = LiterateComment
	conv _       = Whitespace

    merge [] ts = ts
    merge cmnts [] = map litc cmnts

    merge cs0@(c@(pc,sc):cs) ts0@(t@(tt,(pt,s)):ts) =
	if pc<=pt
	then litc c:merge cs ts0
	else --if pt'<=pc then
	       t:merge cs0 ts
	     --else error "literate comment inside token not handled yet"
        -- TODO: handle tokens containing literate comments
{-
      where
        pc' = nextPos pc sc
	pt' = nextPos pt s

        overlap1 pc sc pt s =
           case compare pc pt of
             LT -> litc (pc,sc1):overlap pt sc2 s
	       where (sc1,sc2) = split pc pt sc
             GT -> (t,(pt,s1)):overlap pc sc s2
	       where (s1,s2) = split pt pc s
	     EQ -> overlap pc sc s

        split pc pt (c:cs) | pc<pt = apFst (c:) (split (nextPos1 pc c) pt cs)
        split _ _ s = ("",s)

        overlap pc (c:cs) (' ':s) =
-}

    addSpace p0 [] = []
    addSpace p0 (t@(_,(p,s)):ts) =
       (if p0<p
        then ((Whitespace,(p0,space p0 p)):)
        else id) $ t:addSpace (nextPos p s) ts

    space (Pos _ y0 x0) (Pos _ y x) = vspace y0 x0 y x
    vspace y0 x0 y x =
      if y0<y
      then '\n':vspace (y0+1) 1 y x
      else replicate (x-x0) ' '