2018-04-07 21:02:50 +02:00
|
|
|
{-# LANGUAGE ConstraintKinds #-}
|
2018-11-16 21:16:17 +01:00
|
|
|
{-# LANGUAGE DefaultSignatures #-}
|
2018-04-07 21:02:50 +02:00
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
2018-04-24 11:14:27 +02:00
|
|
|
{-# LANGUAGE GADTs #-}
|
2018-04-07 21:02:50 +02:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
{-# LANGUAGE TypeFamilies #-}
|
2018-04-24 11:14:27 +02:00
|
|
|
{-# LANGUAGE TypeOperators #-}
|
2019-03-03 23:48:49 +01:00
|
|
|
{-# LANGUAGE ViewPatterns #-}
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-04-24 11:14:27 +02:00
|
|
|
module Nix.Render where
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-11-16 21:16:17 +01:00
|
|
|
import Prelude hiding (readFile)
|
|
|
|
|
|
|
|
import Control.Monad.Trans
|
2018-04-10 18:03:24 +02:00
|
|
|
import Data.ByteString (ByteString)
|
2018-11-16 21:16:17 +01:00
|
|
|
import qualified Data.ByteString as BS
|
2018-04-10 18:03:24 +02:00
|
|
|
import qualified Data.Set as Set
|
2019-03-03 23:48:49 +01:00
|
|
|
import qualified Data.Text as T
|
|
|
|
import qualified Data.Text.Encoding as T
|
2018-11-17 05:51:18 +01:00
|
|
|
import Data.Text.Prettyprint.Doc
|
2018-04-10 18:03:24 +02:00
|
|
|
import Data.Void
|
|
|
|
import Nix.Expr.Types.Annotated
|
2018-11-16 21:16:17 +01:00
|
|
|
import qualified System.Directory as S
|
2019-01-08 20:00:09 +01:00
|
|
|
import qualified System.Posix.Files as S
|
2018-05-07 21:06:56 +02:00
|
|
|
import Text.Megaparsec.Error
|
2019-01-08 20:00:09 +01:00
|
|
|
import Text.Megaparsec.Pos
|
2018-04-07 21:02:50 +02:00
|
|
|
|
|
|
|
class Monad m => MonadFile m where
|
|
|
|
readFile :: FilePath -> m ByteString
|
2018-11-16 21:16:17 +01:00
|
|
|
default readFile :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m ByteString
|
|
|
|
readFile = lift . readFile
|
|
|
|
listDirectory :: FilePath -> m [FilePath]
|
|
|
|
default listDirectory :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m [FilePath]
|
|
|
|
listDirectory = lift . listDirectory
|
|
|
|
getCurrentDirectory :: m FilePath
|
|
|
|
default getCurrentDirectory :: (MonadTrans t, MonadFile m', m ~ t m') => m FilePath
|
|
|
|
getCurrentDirectory = lift getCurrentDirectory
|
|
|
|
canonicalizePath :: FilePath -> m FilePath
|
|
|
|
default canonicalizePath :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m FilePath
|
|
|
|
canonicalizePath = lift . canonicalizePath
|
|
|
|
getHomeDirectory :: m FilePath
|
|
|
|
default getHomeDirectory :: (MonadTrans t, MonadFile m', m ~ t m') => m FilePath
|
|
|
|
getHomeDirectory = lift getHomeDirectory
|
|
|
|
doesPathExist :: FilePath -> m Bool
|
|
|
|
default doesPathExist :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m Bool
|
|
|
|
doesPathExist = lift . doesPathExist
|
|
|
|
doesFileExist :: FilePath -> m Bool
|
|
|
|
default doesFileExist :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m Bool
|
|
|
|
doesFileExist = lift . doesFileExist
|
|
|
|
doesDirectoryExist :: FilePath -> m Bool
|
|
|
|
default doesDirectoryExist :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m Bool
|
|
|
|
doesDirectoryExist = lift . doesDirectoryExist
|
|
|
|
getSymbolicLinkStatus :: FilePath -> m S.FileStatus
|
|
|
|
default getSymbolicLinkStatus :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m S.FileStatus
|
|
|
|
getSymbolicLinkStatus = lift . getSymbolicLinkStatus
|
|
|
|
|
|
|
|
instance MonadFile IO where
|
|
|
|
readFile = BS.readFile
|
|
|
|
listDirectory = S.listDirectory
|
|
|
|
getCurrentDirectory = S.getCurrentDirectory
|
|
|
|
canonicalizePath = S.canonicalizePath
|
|
|
|
getHomeDirectory = S.getHomeDirectory
|
|
|
|
doesPathExist = S.doesPathExist
|
|
|
|
doesFileExist = S.doesFileExist
|
|
|
|
doesDirectoryExist = S.doesDirectoryExist
|
|
|
|
getSymbolicLinkStatus = S.getSymbolicLinkStatus
|
2018-04-07 21:02:50 +02:00
|
|
|
|
2018-11-17 05:14:23 +01:00
|
|
|
posAndMsg :: SourcePos -> Doc a -> ParseError s Void
|
|
|
|
posAndMsg (SourcePos _ lineNo _) msg =
|
|
|
|
FancyError (unPos lineNo)
|
2018-04-21 07:36:40 +02:00
|
|
|
(Set.fromList [ErrorFail (show msg) :: ErrorFancy Void])
|
2018-04-18 02:25:59 +02:00
|
|
|
|
2019-03-03 23:48:49 +01:00
|
|
|
renderLocation :: MonadFile m => SrcSpan -> Doc a -> m (Doc a)
|
|
|
|
renderLocation (SrcSpan (SourcePos file begLine begCol)
|
2019-01-08 20:00:09 +01:00
|
|
|
(SourcePos file' endLine endCol)) msg
|
2019-03-03 23:48:49 +01:00
|
|
|
| file /= "<string>" && file == file' = do
|
|
|
|
exist <- doesFileExist file
|
|
|
|
if exist
|
|
|
|
then do
|
|
|
|
txt <- sourceContext file begLine begCol endLine endCol msg
|
|
|
|
return $ vsep
|
|
|
|
[ "In file " <> errorContext file begLine begCol endLine endCol <> ":"
|
|
|
|
, txt
|
|
|
|
]
|
|
|
|
else return msg
|
2019-01-08 20:00:09 +01:00
|
|
|
renderLocation (SrcSpan beg end) msg =
|
|
|
|
fail $ "Don't know how to render range from " ++ show beg ++ " to " ++ show end
|
|
|
|
++ " for error: " ++ show msg
|
|
|
|
|
|
|
|
errorContext :: FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a
|
|
|
|
errorContext path bl bc _el _ec =
|
|
|
|
pretty path <> ":" <> pretty (unPos bl) <> ":" <> pretty (unPos bc)
|
2019-03-03 23:48:49 +01:00
|
|
|
|
|
|
|
sourceContext :: MonadFile m => FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a -> m (Doc a)
|
2019-03-10 19:01:30 +01:00
|
|
|
sourceContext path (unPos -> begLine) (unPos -> _begCol)
|
|
|
|
(unPos -> endLine) (unPos -> _endCol) msg = do
|
2019-03-10 22:12:40 +01:00
|
|
|
let beg' = max 1 (min begLine (begLine - 3))
|
2019-03-10 19:01:30 +01:00
|
|
|
end' = max endLine (endLine + 3)
|
|
|
|
ls <- map pretty
|
|
|
|
. take (end' - beg')
|
|
|
|
. drop (pred beg')
|
2019-03-03 23:48:49 +01:00
|
|
|
. T.lines
|
|
|
|
. T.decodeUtf8
|
|
|
|
<$> readFile path
|
2019-03-10 19:01:30 +01:00
|
|
|
let nums = map (show . fst) $ zip [beg'..] ls
|
|
|
|
longest = maximum (map length nums)
|
|
|
|
nums' = flip map nums $ \n ->
|
|
|
|
replicate (longest - length n) ' ' ++ n
|
|
|
|
pad n | read n == begLine = "==> " ++ n
|
|
|
|
| otherwise = " " ++ n
|
|
|
|
ls' = zipWith (<+>) (map (pretty . pad) nums')
|
|
|
|
(zipWith (<+>) (repeat "| ") ls)
|
|
|
|
pure $ vsep $ ls' ++ [msg]
|