{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
module Dhall.Tags
( generate
) where
import Control.Exception (handle, SomeException(..))
import Data.List (isSuffixOf)
import Data.Maybe (fromMaybe)
import Data.Semigroup (Semigroup(..))
import Dhall.Map (foldMapWithKey)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Dhall.Util (Input(..))
import Dhall.Core (Expr(..), Binding(..))
import Dhall.Src (Src(srcStart))
import Dhall.Parser (exprFromText)
import System.FilePath ((</>), takeFileName)
import Text.Megaparsec (sourceLine, sourceColumn, unPos)
import qualified Data.ByteString as BS (length)
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import qualified System.Directory as SD
data LineColumn = LC
{ lcLine :: Int
, lcColumn :: Int
} deriving (Eq, Ord, Show)
data LineOffset = LO
{ loLine :: Int
, loOffset :: Int
} deriving (Eq, Ord, Show)
newtype Tags = Tags (M.Map FilePath [(LineOffset, Tag)])
instance Semigroup Tags where
(Tags ts1) <> (Tags ts2) = Tags (M.unionWith (<>) ts1 ts2)
instance Monoid Tags where
mempty = Tags M.empty
mappend = (<>)
data Tag = Tag
{ tagPattern :: Text
, tagName :: Text
} deriving (Show)
type LineNumber = Int
type ByteOffset = Int
generate
:: Input
-> Maybe [Text]
-> Bool
-> IO Text
generate inp sxs followSyms = do
files <- inputToFiles followSyms (map T.unpack <$> sxs) inp
tags <- traverse (\f -> handle (\(SomeException _) -> return mempty)
(fileTags f <$> TIO.readFile f)) files
return (showTags . mconcat $ tags)
fileTags :: FilePath -> Text -> Tags
fileTags f t = Tags (M.singleton f
(initialMap <> getTagsFromText t))
where initialViTag = (LO 1 1, Tag "" (T.pack . takeFileName $ f))
initialEmacsTag = (LO 1 1, Tag "" ("/" <> (T.pack . takeFileName) f))
initialMap = [initialViTag, initialEmacsTag]
getTagsFromText :: Text -> [(LineOffset, Tag)]
getTagsFromText t = case exprFromText "" t of
Right expr -> fixPosAndDefinition t (getTagsFromExpr expr)
_ -> mempty
fixPosAndDefinition :: Text -> [(LineColumn, Text)] -> [(LineOffset, Tag)]
fixPosAndDefinition t = foldMap (\(LC ln c, term) ->
let (ln', offset, tPattern) = fromMaybe (fallbackInfoForText ln c)
(infoForText term ln)
in [(LO ln' offset, Tag tPattern term)])
where mls :: M.Map Int (Text, Int)
mls = M.fromList . fst . foldl processLine ([], 0) . zip [1..] $ T.lines t
processLine
:: ([(LineNumber, (Text, ByteOffset))], ByteOffset)
-> (LineNumber, Text)
-> ([(LineNumber, (Text, ByteOffset))], ByteOffset)
processLine (numberedLinesWithSizes, bytesBeforeLine) (n, line) =
((n, (line, bytesBeforeLine)): numberedLinesWithSizes, bytesBeforeNextLine)
where bytesBeforeNextLine = bytesBeforeLine + lengthInBytes line + 1
lineFromMap ln = fromMaybe ("", 0) (ln `M.lookup` mls)
lengthInBytes = BS.length . encodeUtf8
infoForText
:: Text
-> Int
-> Maybe (Int, Int, Text)
infoForText term ln
| ln <= 0 = Nothing
| T.null part2 = infoForText term (ln - 1)
| otherwise = Just (ln, lsl + 1 + lengthInBytes part1, part1 <> termAndNext)
where (l, lsl) = lineFromMap ln
(part1, part2) = T.breakOn term l
termAndNext = T.take (T.length term + 1) part2
fallbackInfoForText ln c = (ln, lsl + 1 + lengthInBytes pat, pat)
where (l, lsl) = lineFromMap ln
pat = T.take c l
getTagsFromExpr :: Expr Src a -> [(LineColumn, Text)]
getTagsFromExpr = go (LC 0 0) []
where go lpos mts = \case
(Let b e) -> go lpos (mts <> parseBinding lpos b) e
(Annot e1 e2) -> go lpos (go lpos mts e1) e2
(Record mr) -> mts <> tagsFromDhallMap lpos mr
(RecordLit mr) -> mts <> tagsFromDhallMap lpos mr
(Union mmr) -> mts <> tagsFromDhallMapMaybe lpos mmr
(Note s e) -> go (srcToLineColumn s) mts e
_ -> mts
tagsFromDhallMap lpos = foldMapWithKey (tagsFromDhallMapElement lpos)
tagsFromDhallMapMaybe lpos = foldMapWithKey (\k -> \case
Just e -> tagsFromDhallMapElement lpos k e
_ -> [(lpos, k)])
tagsFromDhallMapElement lpos k e = go pos [(pos, k)] e
where pos = firstPosFromExpr lpos e
parseBinding :: LineColumn -> Binding Src a -> [(LineColumn, Text)]
parseBinding lpos b = go p2 [(p0, variable b)] (value b)
where p0 = posFromBinding (bindingSrc0 b) lpos
p1 = posFromBinding (bindingSrc1 b) p0
p2 = posFromBinding (bindingSrc2 b) p1
posFromBinding src startPos = maybe startPos srcToLineColumn src
srcToLineColumn :: Src -> LineColumn
srcToLineColumn s = LC line column
where ssp = srcStart s
line = unPos . sourceLine $ ssp
column = unPos . sourceColumn $ ssp
firstPosFromExpr :: LineColumn -> Expr Src a -> LineColumn
firstPosFromExpr lpos = \case
(Note s _) -> srcToLineColumn s
_ -> lpos
showTags :: Tags -> Text
showTags (Tags ts) = T.concat . map (uncurry showFileTags) . M.toList $ ts
showFileTags :: FilePath -> [(LineOffset, Tag)] -> T.Text
showFileTags f ts = "\x0c\n" <> T.pack f <> "," <> (showInt . T.length) cs <> "\n" <> cs
where cs = T.concat . map (uncurry showPosTag) $ ts
showPosTag :: LineOffset -> Tag -> Text
showPosTag lo tag = def <>"\x7f" <> name <> "\x01" <> showInt line <>
"," <> showInt offset <> "\n"
where line = loLine lo
offset = loOffset lo
def = tagPattern tag
name = tagName tag
showInt :: Int -> Text
showInt = T.pack . show
inputToFiles
:: Bool
-> Maybe [String]
-> Input
-> IO [ FilePath ]
inputToFiles _ _ StandardInput = lines <$> getContents
inputToFiles followSyms suffixes (InputFile path) = go path
where go p = do
isD <- SD.doesDirectoryExist p
isSL <- isSymLink
if isD
then if isSL && not followSyms
then return []
else do
contents <- fmap (filter ((/=) '.' . head))
(SD.getDirectoryContents p)
concat <$> mapM (go . (</>) p) contents
else return [p | matchingSuffix || p == path]
where matchingSuffix = maybe True (any (`isSuffixOf` p)) suffixes
isSymLink =
#if MIN_VERSION_directory(1,3,0)
SD.pathIsSymbolicLink p
#elif MIN_VERSION_directory(1,2,6)
SD.isSymbolicLink pa
#else
return False
#endif