module Language.Haskell.TokenUtils.Types
(
Entry(..)
, TokenCache(..)
, TreeId(..)
, mainTid
, ForestSpan
, ForestPos
, ForestLine(..)
, RowOffset
, ColOffset
, Row
, Col
, SimpPos
, Layout(..)
, EndOffset(..)
, Located(..)
, Span(..)
, nullSpan
, TokenLayout
, LayoutTree
, forestSpanFromEntry
, putForestSpanInEntry
, forestSpanToSimpPos
, forestSpanVersionSet
, treeStartEnd
, groupTokensByLine
, tokenRow
, tokenCol
, tokenColEnd
, tokenPos
, tokenPosEnd
, increaseSrcSpan
, srcPosToSimpPos
, addOffsetToToks
, ghcLineToForestLine
, forestLineToGhcLine
, IsToken(..)
, notWhiteSpace
, isWhiteSpaceOrIgnored
, isIgnored
, isIgnoredNonComment
, isWhereOrLet
, showFriendlyToks
, HasLoc(..)
, Allocatable(..)
) where
import Control.Exception
import Data.Bits
import Data.List
import Data.Tree
import qualified Data.Map as Map
data Entry a =
Entry !ForestSpan
!Layout
![a]
| Deleted !ForestSpan
!RowOffset
!SimpPos
deriving (Show)
instance (IsToken a) => Eq (Entry a) where
(Entry fs1 lay1 toks1) == (Entry fs2 lay2 toks2)
= fs1 == fs2 && lay1 == lay2
&& (show toks1) == (show toks2)
(Deleted fs1 pg1 lay1) == (Deleted fs2 pg2 lay2)
= fs1 == fs2 && pg1 == pg2 && lay1 == lay2
(==) _ _ = False
instance HasLoc (Entry a) where
getLoc (Entry fs _ _) = getLoc fs
getLoc (Deleted fs _ _) = getLoc fs
getLocEnd (Entry fs _ _) = getLocEnd fs
getLocEnd (Deleted fs _ _) = getLocEnd fs
type RowOffset = Int
type ColOffset = Int
type Row = Int
type Col = Int
type SimpPos = (Int,Int)
data Layout = Above EndOffset (Row,Col) (Row,Col) EndOffset
| NoChange
deriving (Show,Eq)
data EndOffset = None
| SameLine ColOffset
| FromAlignCol (RowOffset, ColOffset)
deriving (Show,Eq)
data ForestLine = ForestLine
{ flSpanLengthChanged :: !Bool
, flTreeSelector :: !Int
, flInsertVersion :: !Int
, flLine :: !Int
}
instance Eq ForestLine where
(ForestLine _ s1 v1 l1) == (ForestLine _ s2 v2 l2) = s1 == s2 && v1 == v2 && l1 == l2
instance Show ForestLine where
show s = "(ForestLine " ++ (show $ flSpanLengthChanged s)
++ " " ++ (show $ flTreeSelector s)
++ " " ++ (show $ flInsertVersion s)
++ " " ++ (show $ flLine s)
++ ")"
instance Ord ForestLine where
compare (ForestLine _sc1 _ v1 l1) (ForestLine _sc2 _ v2 l2) =
if (l1 == l2)
then compare v1 v2
else compare l1 l2
type ForestPos = (ForestLine,Int)
type ForestSpan = (ForestPos,ForestPos)
instance HasLoc ForestSpan where
getLoc fs = fst (forestSpanToSimpPos fs)
getLocEnd fs = snd (forestSpanToSimpPos fs)
data TreeId = TId !Int deriving (Eq,Ord,Show)
mainTid :: TreeId
mainTid = TId 0
data TokenCache a = TK
{ tkCache :: !(Map.Map TreeId (Tree (Entry a)))
, tkLastTreeId :: !TreeId
}
class Allocatable b a where
allocTokens :: b -> [a] -> LayoutTree a
class (Show a) => IsToken a where
getSpan :: a -> Span
putSpan :: a -> Span -> a
tokenLen :: a -> Int
isComment :: a -> Bool
isEmpty :: a -> Bool
isDo :: a -> Bool
isElse :: a -> Bool
isIn :: a -> Bool
isLet :: a -> Bool
isOf :: a -> Bool
isThen :: a -> Bool
isWhere :: a -> Bool
tokenToString :: a -> String
showTokenStream :: [a] -> String
isWhiteSpace :: (IsToken a) => a -> Bool
isWhiteSpace tok = isComment tok || isEmpty tok
notWhiteSpace :: (IsToken a) => a -> Bool
notWhiteSpace tok = not (isWhiteSpace tok)
isWhiteSpaceOrIgnored :: (IsToken a) => a -> Bool
isWhiteSpaceOrIgnored tok = isWhiteSpace tok || isIgnored tok
isIgnored :: (IsToken a) => a -> Bool
isIgnored tok = isThen tok || isElse tok || isIn tok || isDo tok
isIgnoredNonComment :: (IsToken a) => a -> Bool
isIgnoredNonComment tok = isThen tok || isElse tok || isWhiteSpace tok
isWhereOrLet :: (IsToken a) => a -> Bool
isWhereOrLet t = isWhere t || isLet t
showFriendlyToks :: IsToken a => [a] -> String
showFriendlyToks toks = reverse $ dropWhile (=='\n')
$ reverse $ dropWhile (=='\n') $ showTokenStream toks
class HasLoc a where
getLoc :: a -> SimpPos
getLocEnd :: a -> SimpPos
data Located e = L Span e
deriving Show
data Span = Span (Row,Col) (Row,Col)
deriving (Show,Eq,Ord)
nullSpan :: Span
nullSpan = Span (0,0) (0,0)
data TokenLayout a = TL (Tree (Entry a))
type LayoutTree a = Tree (Entry a)
instance (IsToken t) => Ord (LayoutTree t) where
compare (Node a _) (Node b _) = compare (forestSpanFromEntry a) (forestSpanFromEntry b)
forestSpanFromEntry :: Entry a -> ForestSpan
forestSpanFromEntry (Entry ss _ _) = ss
forestSpanFromEntry (Deleted ss _ _) = ss
putForestSpanInEntry :: Entry a -> ForestSpan -> Entry a
putForestSpanInEntry (Entry _ss lay toks) ssnew = (Entry ssnew lay toks)
putForestSpanInEntry (Deleted _ss pg eg) ssnew = (Deleted ssnew pg eg)
forestSpanToSimpPos :: ForestSpan -> (SimpPos,SimpPos)
forestSpanToSimpPos ((ForestLine _ _ _ sr,sc),(ForestLine _ _ _ er,ec)) = ((sr,sc),(er,ec))
forestSpanVersionSet :: ForestSpan -> Bool
forestSpanVersionSet ((ForestLine _ _ sv _,_),(ForestLine _ _ ev _,_)) = sv /= 0 || ev /= 0
treeStartEnd :: Tree (Entry a) -> ForestSpan
treeStartEnd (Node (Entry sspan _ _) _) = sspan
treeStartEnd (Node (Deleted sspan _ _) _) = sspan
groupTokensByLine :: (IsToken a) => [a] -> [[a]]
groupTokensByLine xs = groupBy toksOnSameLine xs
toksOnSameLine :: (IsToken a) => a -> a -> Bool
toksOnSameLine t1 t2 = tokenRow t1 == tokenRow t2
tokenRow :: (IsToken a) => a -> Int
tokenRow tok = r
where (Span (r,_) _) = getSpan tok
tokenCol :: (IsToken a) => a -> Int
tokenCol tok = c
where (Span (_,c) _) = getSpan tok
tokenColEnd :: (IsToken a) => a -> Int
tokenColEnd tok = c
where (Span _ (_,c)) = getSpan tok
tokenPos :: IsToken a => a -> SimpPos
tokenPos tok = startPos
where (Span startPos _) = getSpan tok
tokenPosEnd :: IsToken a => a -> SimpPos
tokenPosEnd tok = endPos
where (Span _ endPos) = getSpan tok
srcPosToSimpPos :: (Int,Int) -> (Int,Int)
srcPosToSimpPos (sr,c) = (l,c)
where
(ForestLine _ _ _ l) = ghcLineToForestLine sr
forestLineMask,forestVersionMask,forestTreeMask,forestLenChangedMask :: Int
forestLineMask = 0xfffff
forestVersionMask = 0x1f00000
forestTreeMask = 0x3e000000
forestLenChangedMask = 0x40000000
forestVersionShift :: Int
forestVersionShift = 20
forestTreeShift :: Int
forestTreeShift = 25
ghcLineToForestLine :: Int -> ForestLine
ghcLineToForestLine l = ForestLine ch tr v l'
where
l' = l .&. forestLineMask
v = shiftR (l .&. forestVersionMask) forestVersionShift
tr = shiftR (l .&. forestTreeMask) forestTreeShift
ch = (l .&. forestLenChangedMask) /= 0
forestLineToGhcLine :: ForestLine -> Int
forestLineToGhcLine fl = (if (flSpanLengthChanged fl) then forestLenChangedMask else 0)
+ (shiftL (flTreeSelector fl) forestTreeShift)
+ (shiftL (flInsertVersion fl) forestVersionShift)
+ (flLine fl)
addOffsetToToks :: (IsToken a) => SimpPos -> [a] -> [a]
addOffsetToToks (r,c) toks = map (\t -> increaseSrcSpan (r,c) t) toks
increaseSrcSpan :: (IsToken a) => SimpPos -> a -> a
increaseSrcSpan (lineAmount,colAmount) posToken
= putSpan posToken newL
where
newL = Span (startLine + lineAmount, startCol + colAmount)
(endLine + lineAmount, endCol + colAmount)
(Span (startLine, startCol) (endLine,endCol)) = getSpan posToken