{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE MultiWayIf #-}
module Nix.Render where
import Prelude hiding ( readFile )
import qualified Data.ByteString as BS
import qualified Data.Set as Set
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
begLine Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3
end' :: Int
end' = 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
longest :: Int
longest = FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (FilePath -> Int) -> FilePath -> Int
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
forall b a. (Show a, IsString b) => a -> b
show @String (Int
beg' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ([Doc a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Doc a]
ls) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
pad :: Int -> FilePath
pad Int
n =
let
ns :: FilePath
ns = Int -> FilePath
forall b a. (Show a, IsString b) => a -> b
show Int
n
nsp :: FilePath
nsp = 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
ns) Char
' ' FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
ns
in
if
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
begLine Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
endLine -> FilePath
"==> " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
nsp FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" | "
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
begLine Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
endLine -> FilePath
" > " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
nsp FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" | "
| Bool
otherwise -> FilePath
" " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
nsp FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" | "
composeLine :: Int -> Doc a -> [Doc a]
composeLine Int
n Doc a
l =
[FilePath -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> FilePath
pad Int
n) Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
l]
[Doc a] -> [Doc a] -> [Doc a]
forall a. [a] -> [a] -> [a]
++ [ FilePath -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty
(FilePath -> Doc a) -> FilePath -> Doc a
forall a b. (a -> b) -> a -> b
$ Int -> Char -> FilePath
forall a. Int -> a -> [a]
replicate (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Int -> FilePath
pad Int
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) Char
' '
FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"| "
FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> FilePath
forall a. Int -> a -> [a]
replicate (Int
_begCol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char
' '
FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> FilePath
forall a. Int -> a -> [a]
replicate (Int
_endCol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
_begCol) Char
'^'
| Int
begLine Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
endLine Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
endLine ]
ls' :: [Doc a]
ls' = [[Doc a]] -> [Doc a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Doc a]] -> [Doc a]) -> [[Doc a]] -> [Doc a]
forall a b. (a -> b) -> a -> b
$ (Int -> Doc a -> [Doc a]) -> [Int] -> [Doc a] -> [[Doc a]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Doc a -> [Doc a]
composeLine [Int
beg' ..] [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. [a] -> [a] -> [a]
++ [ Int -> Doc a -> Doc a
forall ann. Int -> Doc ann -> Doc ann
indent (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (FilePath -> Int) -> FilePath -> Int
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
pad Int
begLine) Doc a
msg ]