{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
module Nix.Render where
import Prelude hiding ( readFile )
import Relude.Unsafe ( read )
import qualified Data.ByteString as BS
import qualified Data.Set as Set
import Data.List ( maximum )
import Nix.Utils.Fix1 ( Fix1T
, MonadFix1T )
import Nix.Expr.Types.Annotated
import Prettyprinter
import qualified System.Directory as S
import qualified System.Posix.Files as S
import Text.Megaparsec.Error
import Text.Megaparsec.Pos
class MonadFail m => MonadFile m where
readFile :: FilePath -> m ByteString
default readFile :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m ByteString
readFile = m' ByteString -> t m' ByteString
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' ByteString -> t m' ByteString)
-> (FilePath -> m' ByteString) -> FilePath -> t m' ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> m' ByteString
forall (m :: * -> *). MonadFile m => FilePath -> m ByteString
readFile
listDirectory :: FilePath -> m [FilePath]
default listDirectory :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m [FilePath]
listDirectory = m' [FilePath] -> t m' [FilePath]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' [FilePath] -> t m' [FilePath])
-> (FilePath -> m' [FilePath]) -> FilePath -> t m' [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> m' [FilePath]
forall (m :: * -> *). MonadFile m => FilePath -> m [FilePath]
listDirectory
getCurrentDirectory :: m FilePath
default getCurrentDirectory :: (MonadTrans t, MonadFile m', m ~ t m') => m FilePath
getCurrentDirectory = m' FilePath -> t m' FilePath
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m' FilePath
forall (m :: * -> *). MonadFile m => m FilePath
getCurrentDirectory
canonicalizePath :: FilePath -> m FilePath
default canonicalizePath :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m FilePath
canonicalizePath = m' FilePath -> t m' FilePath
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' FilePath -> t m' FilePath)
-> (FilePath -> m' FilePath) -> FilePath -> t m' FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> m' FilePath
forall (m :: * -> *). MonadFile m => FilePath -> m FilePath
canonicalizePath
getHomeDirectory :: m FilePath
default getHomeDirectory :: (MonadTrans t, MonadFile m', m ~ t m') => m FilePath
getHomeDirectory = m' FilePath -> t m' FilePath
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m' FilePath
forall (m :: * -> *). MonadFile m => m FilePath
getHomeDirectory
doesPathExist :: FilePath -> m Bool
default doesPathExist :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m Bool
doesPathExist = m' Bool -> t m' Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' Bool -> t m' Bool)
-> (FilePath -> m' Bool) -> FilePath -> t m' Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> m' Bool
forall (m :: * -> *). MonadFile m => FilePath -> m Bool
doesPathExist
doesFileExist :: FilePath -> m Bool
default doesFileExist :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m Bool
doesFileExist = m' Bool -> t m' Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' Bool -> t m' Bool)
-> (FilePath -> m' Bool) -> FilePath -> t m' Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> m' Bool
forall (m :: * -> *). MonadFile m => FilePath -> m Bool
doesFileExist
doesDirectoryExist :: FilePath -> m Bool
default doesDirectoryExist :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m Bool
doesDirectoryExist = m' Bool -> t m' Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' Bool -> t m' Bool)
-> (FilePath -> m' Bool) -> FilePath -> t m' Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> m' Bool
forall (m :: * -> *). MonadFile m => FilePath -> m Bool
doesDirectoryExist
getSymbolicLinkStatus :: FilePath -> m S.FileStatus
default getSymbolicLinkStatus :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m S.FileStatus
getSymbolicLinkStatus = m' FileStatus -> t m' FileStatus
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' FileStatus -> t m' FileStatus)
-> (FilePath -> m' FileStatus) -> FilePath -> t m' FileStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> m' FileStatus
forall (m :: * -> *). MonadFile m => FilePath -> m FileStatus
getSymbolicLinkStatus
instance MonadFile IO where
readFile :: FilePath -> IO ByteString
readFile = FilePath -> IO ByteString
BS.readFile
listDirectory :: FilePath -> IO [FilePath]
listDirectory = FilePath -> IO [FilePath]
S.listDirectory
getCurrentDirectory :: IO FilePath
getCurrentDirectory = IO FilePath
S.getCurrentDirectory
canonicalizePath :: FilePath -> IO FilePath
canonicalizePath = FilePath -> IO FilePath
S.canonicalizePath
getHomeDirectory :: IO FilePath
getHomeDirectory = IO FilePath
S.getHomeDirectory
doesPathExist :: FilePath -> IO Bool
doesPathExist = FilePath -> IO Bool
S.doesPathExist
doesFileExist :: FilePath -> IO Bool
doesFileExist = FilePath -> IO Bool
S.doesFileExist
doesDirectoryExist :: FilePath -> IO Bool
doesDirectoryExist = FilePath -> IO Bool
S.doesDirectoryExist
getSymbolicLinkStatus :: FilePath -> IO FileStatus
getSymbolicLinkStatus = FilePath -> IO FileStatus
S.getSymbolicLinkStatus
instance (MonadFix1T t m, MonadFail (Fix1T t m), MonadFile m) => MonadFile (Fix1T t m)
posAndMsg :: SourcePos -> Doc a -> ParseError s Void
posAndMsg :: SourcePos -> Doc a -> ParseError s Void
posAndMsg (SourcePos FilePath
_ Pos
lineNo Pos
_) Doc a
msg =
Int -> Set (ErrorFancy Void) -> ParseError s Void
forall s e. Int -> Set (ErrorFancy e) -> ParseError s e
FancyError
(Pos -> Int
unPos Pos
lineNo)
([ErrorFancy Void] -> Set (ErrorFancy Void)
forall a. Ord a => [a] -> Set a
Set.fromList [FilePath -> ErrorFancy Void
forall e. FilePath -> ErrorFancy e
ErrorFail (Doc a -> FilePath
forall b a. (Show a, IsString b) => a -> b
show Doc a
msg) :: ErrorFancy Void])
renderLocation :: MonadFile m => SrcSpan -> Doc a -> m (Doc a)
renderLocation :: SrcSpan -> Doc a -> m (Doc a)
renderLocation (SrcSpan (SourcePos FilePath
file Pos
begLine Pos
begCol) (SourcePos FilePath
file' Pos
endLine Pos
endCol)) Doc a
msg
| FilePath
file FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
file' Bool -> Bool -> Bool
&& FilePath
file FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"<string>" Bool -> Bool -> Bool
&& Pos
begLine Pos -> Pos -> Bool
forall a. Eq a => a -> a -> Bool
== Pos
endLine
= Doc a -> m (Doc a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc a -> m (Doc a)) -> Doc a -> m (Doc a)
forall a b. (a -> b) -> a -> b
$ Doc a
"In raw input string at position " Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Int -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty (Pos -> Int
unPos Pos
begCol)
| FilePath
file FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
"<string>" Bool -> Bool -> Bool
&& FilePath
file FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
file'
= do
Bool
exist <- FilePath -> m Bool
forall (m :: * -> *). MonadFile m => FilePath -> m Bool
doesFileExist FilePath
file
if Bool
exist
then do
Doc a
txt <- FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a -> m (Doc a)
forall (m :: * -> *) a.
MonadFile m =>
FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a -> m (Doc a)
sourceContext FilePath
file Pos
begLine Pos
begCol Pos
endLine Pos
endCol Doc a
msg
pure $
[Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
vsep
[ Doc a
"In file " Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a
forall a. FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a
errorContext FilePath
file Pos
begLine Pos
begCol Pos
endLine Pos
endCol Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
":"
, Doc a
txt
]
else Doc a -> m (Doc a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc a
msg
renderLocation (SrcSpan SourcePos
beg SourcePos
end) Doc a
msg = FilePath -> m (Doc a)
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> m (Doc a)) -> FilePath -> m (Doc a)
forall a b. (a -> b) -> a -> b
$ FilePath
"Don't know how to render range from " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> SourcePos -> FilePath
forall b a. (Show a, IsString b) => a -> b
show SourcePos
beg FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>FilePath
" to " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> SourcePos -> FilePath
forall b a. (Show a, IsString b) => a -> b
show SourcePos
end FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>FilePath
" for fail: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Doc a -> FilePath
forall b a. (Show a, IsString b) => a -> b
show Doc a
msg
errorContext :: FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a
errorContext :: FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a
errorContext FilePath
path Pos
bl Pos
bc Pos
_el Pos
_ec =
FilePath -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty FilePath
path Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
":" Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Int -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty (Pos -> Int
unPos Pos
bl) Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
":" Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Int -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty (Pos -> Int
unPos Pos
bc)
sourceContext
:: MonadFile m => FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a -> m (Doc a)
sourceContext :: FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a -> m (Doc a)
sourceContext FilePath
path (Pos -> Int
unPos -> Int
begLine) (Pos -> Int
unPos -> Int
_begCol) (Pos -> Int
unPos -> Int
endLine) (Pos -> Int
unPos -> Int
_endCol) Doc a
msg
= do
let beg' :: Int
beg' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
begLine (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
begLine Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3
end' :: Int
end' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
endLine (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
endLine Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3
[Doc a]
ls <-
(Text -> Doc a) -> [Text] -> [Doc a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty
([Text] -> [Doc a])
-> (ByteString -> [Text]) -> ByteString -> [Doc a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take (Int
end' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
beg')
([Text] -> [Text])
-> (ByteString -> [Text]) -> ByteString -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop (Int -> Int
forall a. Enum a => a -> a
pred Int
beg')
([Text] -> [Text])
-> (ByteString -> [Text]) -> ByteString -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
forall t. IsText t "lines" => t -> [t]
lines
(Text -> [Text]) -> (ByteString -> Text) -> ByteString -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8
(ByteString -> [Doc a]) -> m ByteString -> m [Doc a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> m ByteString
forall (m :: * -> *). MonadFile m => FilePath -> m ByteString
readFile FilePath
path
let
nums :: [FilePath]
nums = (Int -> Doc a -> FilePath) -> [Int] -> [Doc a] -> [FilePath]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (((Int, Doc a) -> FilePath) -> Int -> Doc a -> FilePath
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (Int -> FilePath
forall b a. (Show a, IsString b) => a -> b
show (Int -> FilePath)
-> ((Int, Doc a) -> Int) -> (Int, Doc a) -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Doc a) -> Int
forall a b. (a, b) -> a
fst)) [Int
beg' ..] [Doc a]
ls
longest :: Int
longest = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (FilePath -> Int) -> [FilePath] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
nums
nums' :: [FilePath]
nums' = (\FilePath
n -> Int -> Char -> FilePath
forall a. Int -> a -> [a]
replicate (Int
longest Int -> Int -> Int
forall a. Num a => a -> a -> a
- FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
n) Char
' ' FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
n) (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
nums
pad :: FilePath -> FilePath
pad FilePath
n | FilePath -> Int
forall a. Read a => FilePath -> a
read FilePath
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
begLine = FilePath
"==> " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
n
| Bool
otherwise = FilePath
" " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
n
ls' :: [Doc a]
ls' =
(Doc a -> Doc a -> Doc a) -> [Doc a] -> [Doc a] -> [Doc a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
(\ Doc a
a Doc a
b -> Doc a
a Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
forall ann. Doc ann
space Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
b)
(FilePath -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty (FilePath -> Doc a) -> (FilePath -> FilePath) -> FilePath -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
pad (FilePath -> Doc a) -> [FilePath] -> [Doc a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
nums')
((Doc a
"| " Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<>) (Doc a -> Doc a) -> [Doc a] -> [Doc a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Doc a]
ls)
Doc a -> m (Doc a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc a -> m (Doc a)) -> Doc a -> m (Doc a)
forall a b. (a -> b) -> a -> b
$ [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
vsep ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall a b. (a -> b) -> a -> b
$ [Doc a]
ls' [Doc a] -> [Doc a] -> [Doc a]
forall a. Semigroup a => a -> a -> a
<> [Doc a
msg]