module Language.Haskell.Modules.Util.SrcLoc
( HasSpanInfo(..)
, srcSpan
, srcLoc
, endLoc
, textEndLoc
, increaseSrcLoc
, textSpan
, srcPairText
, makeTree
, tests
) where
import Control.Monad.State (State, runState, get, put)
import Data.Default (def, Default)
import Data.List (groupBy, partition, sort)
import Data.Set (Set, toList)
import Data.Tree (Tree(Node), unfoldTree)
import qualified Language.Haskell.Exts.Annotated.Syntax as A (Decl(..), ExportSpec(..), ExportSpecList(..), ImportDecl(ImportDecl), ModuleHead(..), ModuleName(..), ModulePragma(..), WarningText(..))
import Language.Haskell.Exts.SrcLoc (SrcLoc(..), SrcSpan(..), SrcSpanInfo(..))
import Prelude hiding (rem)
import Test.HUnit (assertEqual, Test(TestCase, TestList))
lines' :: String -> [String]
lines' s =
bol (groupBy (\ a b -> a /= '\n' && b /= '\n') s)
where
bol ("\n" : xs) = "" : bol xs
bol (x : xs) = x : eol xs
bol [] = [""]
eol ("\n" : xs) = bol xs
eol (x : xs) = x : eol xs
eol [] = []
type ModuleHead = A.ModuleHead SrcSpanInfo
type ModulePragma = A.ModulePragma SrcSpanInfo
type ModuleName = A.ModuleName SrcSpanInfo
type WarningText = A.WarningText SrcSpanInfo
type ExportSpecList = A.ExportSpecList SrcSpanInfo
type ExportSpec = A.ExportSpec SrcSpanInfo
type ImportDecl = A.ImportDecl SrcSpanInfo
type Decl = A.Decl SrcSpanInfo
class HasSpanInfo a where
spanInfo :: a -> SrcSpanInfo
instance HasSpanInfo SrcSpan where
spanInfo x = SrcSpanInfo x []
instance HasSpanInfo a => HasSpanInfo (Tree a) where
spanInfo (Node x _) = spanInfo x
instance HasSpanInfo ModuleHead where
spanInfo (A.ModuleHead x _ _ _) = x
instance HasSpanInfo ModuleName where
spanInfo (A.ModuleName x _) = x
instance HasSpanInfo ModulePragma where
spanInfo (A.LanguagePragma x _) = x
spanInfo (A.OptionsPragma x _ _) = x
spanInfo (A.AnnModulePragma x _) = x
instance HasSpanInfo WarningText where
spanInfo (A.WarnText x _) = x
spanInfo (A.DeprText x _) = x
instance HasSpanInfo ExportSpecList where
spanInfo (A.ExportSpecList x _) = x
instance HasSpanInfo ExportSpec where
spanInfo (A.EVar x _) = x
spanInfo (A.EAbs x _) = x
spanInfo (A.EThingAll x _) = x
spanInfo (A.EThingWith x _ _) = x
spanInfo (A.EModuleContents x _) = x
instance HasSpanInfo ImportDecl where
spanInfo (A.ImportDecl x _ _ _ _ _ _) = x
instance HasSpanInfo Decl where
spanInfo (A.TypeDecl l _ _) = l
spanInfo (A.TypeFamDecl l _ _) = l
spanInfo (A.DataDecl l _ _ _ _ _) = l
spanInfo (A.GDataDecl l _ _ _ _ _ _) = l
spanInfo (A.DataFamDecl l _ _ _) = l
spanInfo (A.TypeInsDecl l _ _) = l
spanInfo (A.DataInsDecl l _ _ _ _) = l
spanInfo (A.GDataInsDecl l _ _ _ _ _) = l
spanInfo (A.ClassDecl l _ _ _ _) = l
spanInfo (A.InstDecl l _ _ _) = l
spanInfo (A.DerivDecl l _ _) = l
spanInfo (A.InfixDecl l _ _ _) = l
spanInfo (A.DefaultDecl l _) = l
spanInfo (A.SpliceDecl l _) = l
spanInfo (A.TypeSig l _ _) = l
spanInfo (A.FunBind l _) = l
spanInfo (A.PatBind l _ _ _ _) = l
spanInfo (A.ForImp l _ _ _ _ _) = l
spanInfo (A.ForExp l _ _ _ _) = l
spanInfo (A.RulePragmaDecl l _) = l
spanInfo (A.DeprPragmaDecl l _) = l
spanInfo (A.WarnPragmaDecl l _) = l
spanInfo (A.InlineSig l _ _ _) = l
spanInfo (A.InlineConlikeSig l _ _) = l
spanInfo (A.SpecSig l _ _) = l
spanInfo (A.SpecInlineSig l _ _ _ _) = l
spanInfo (A.InstSig l _ _) = l
spanInfo (A.AnnPragma l _) = l
instance HasSpanInfo SrcSpanInfo where
spanInfo = id
srcSpan :: HasSpanInfo x => x -> SrcSpan
srcSpan = srcInfoSpan . spanInfo
srcLoc :: HasSpanInfo x => x -> SrcLoc
srcLoc x = let (SrcSpan f b e _ _) = srcSpan x in SrcLoc f b e
endLoc :: HasSpanInfo x => x -> SrcLoc
endLoc x = let (SrcSpan f _ _ b e) = srcSpan x in SrcLoc f b e
textEndLoc :: String -> SrcLoc
textEndLoc text =
def {srcLine = length ls, srcColumn = length (last ls) + 1}
where ls = lines' text
increaseSrcLoc :: String -> SrcLoc -> SrcLoc
increaseSrcLoc "" l = l
increaseSrcLoc ('\n' : s) (SrcLoc f y _) = increaseSrcLoc s (SrcLoc f (y + 1) 1)
increaseSrcLoc (_ : s) (SrcLoc f y x) = increaseSrcLoc s (SrcLoc f y (x + 1))
tests :: Test
tests = TestList [test1, test2, test3, test4, test5]
test1 :: Test
test1 = TestCase (assertEqual "srcPairTextTail1" "hi\tjkl\n" (snd (srcPairText (SrcLoc "<unknown>.hs" 1 10) (SrcLoc "<unknown>.hs" 2 2) "abc\tdef\nghi\tjkl\n")))
test2 :: Test
test2 = TestCase (assertEqual "srcPairTextTail2" "kl\n" (snd (srcPairText (SrcLoc "<unknown>.hs" 1 10) (SrcLoc "<unknown>.hs" 2 9) "abc\tdef\nghi\tjkl\n")))
test3 :: Test
test3 = TestCase (assertEqual "srcPairTextHead1" "abc\tdef\ng" (fst (srcPairText (SrcLoc "<unknown>.hs" 1 10) (SrcLoc "<unknown>.hs" 2 2) "abc\tdef\nghi\tjkl\n")))
test4 :: Test
test4 = TestCase (assertEqual "srcPairTextHead21" "abc\tdef\nghi\tj" (fst (srcPairText (SrcLoc "<unknown>.hs" 1 10) (SrcLoc "<unknown>.hs" 2 9) "abc\tdef\nghi\tjkl\n")))
test5 :: Test
test5 = TestCase (assertEqual "srcPairTextTail3"
"{-# OPTIONS_GHC -fno-warn-orphans #-}\nmodule Debian.Repo.Orphans where\n\nimport Data.Text (Text)\nimport qualified Debian.Control.Text as T\n\nderiving instance Show (T.Field' Text)\nderiving instance Ord (T.Field' Text)\nderiving instance Show T.Paragraph\nderiving instance Ord T.Paragraph\n"
(snd
(srcPairText
(SrcLoc "<unknown>.hs" 1 77)
(SrcLoc "<unknown>.hs" 2 1)
"\n{-# OPTIONS_GHC -fno-warn-orphans #-}\nmodule Debian.Repo.Orphans where\n\nimport Data.Text (Text)\nimport qualified Debian.Control.Text as T\n\nderiving instance Show (T.Field' Text)\nderiving instance Ord (T.Field' Text)\nderiving instance Show T.Paragraph\nderiving instance Ord T.Paragraph\n")))
textSpan :: String -> SrcSpanInfo
textSpan s = let end = textEndLoc s in
SrcSpanInfo (def {srcSpanStartLine = 1, srcSpanStartColumn = 1, srcSpanEndLine = srcLine end, srcSpanEndColumn = srcColumn end}) []
srcPairText :: SrcLoc -> SrcLoc -> String -> (String, String)
srcPairText b0 e0 s0 =
fst $ runState f (b0, e0, "", s0)
where
f :: State (SrcLoc, SrcLoc, String, String) (String, String)
f = do (b, e, r, s) <- get
case (srcLine b < srcLine e, srcColumn b < srcColumn e) of
(True, _) ->
case span (/= '\n') s of
(r', '\n' : s') ->
put (b {srcLine = srcLine b + 1, srcColumn = 1}, e, r ++ r' ++ "\n", s') >> f
(_, "") ->
case s of
"" -> return (r, s)
('\t' : s') -> put (b {srcColumn = ((srcColumn b + 7) `div` 8) * 8}, e, r ++ "\t", s') >> f
(c : s') -> put (b {srcColumn = srcColumn b + 1}, e, r ++ [c], s') >> f
(_, True) ->
case s of
[] -> error $ "srcPairText: " ++ show (b0, e0, s0)
('\t' : s') -> put (b {srcColumn = ((srcColumn b + 7) `div` 8) * 8}, e, r ++ ['\t'], s') >> f
(c : s') -> put (b {srcColumn = srcColumn b + 1}, e, r ++ [c], s') >> f
_ ->
return (r, s)
instance Default SrcLoc where
def = SrcLoc "<unknown>.hs" 1 1
instance Default SrcSpanInfo where
def = SrcSpanInfo {srcInfoSpan = def, srcInfoPoints = def}
instance Default SrcSpan where
def = SrcSpan {srcSpanFilename = "<unknown>.hs", srcSpanStartLine = 1, srcSpanEndLine = 1, srcSpanStartColumn = 1, srcSpanEndColumn = 1}
makeTree :: (HasSpanInfo a, Show a, Eq a, Ord a) => Set a -> Tree a
makeTree s =
case findRoots (toList s) of
[] -> error "No roots"
[root] -> unfoldTree f root
roots -> error $ "Multiple roots: " ++ show roots
where
f x = (x, findChildren (toList s) x)
findRoots :: (HasSpanInfo a, Eq a, Ord a) => [a] -> [a]
findRoots [] = []
findRoots (x : xs) =
let (_children, other) = partition (\ y -> x `covers` y) xs
(ancestors, cousins) = partition (\ y -> x `coveredBy` y) other in
case ancestors of
[] -> x : findRoots cousins
_ -> findRoots (ancestors ++ cousins)
findChildren :: (HasSpanInfo a, Eq a, Ord a, Show a) => [a] -> a -> [a]
findChildren u x = findRoots children where children = sort (filter (\ y -> x `covers` y && x /= y) u)
covers :: (HasSpanInfo a, HasSpanInfo b) => a -> b -> Bool
covers a b = srcLoc a <= srcLoc b && endLoc b <= endLoc a
coveredBy :: (HasSpanInfo a, HasSpanInfo b) => a -> b -> Bool
coveredBy = flip covers