{-# language UndecidableInstances #-}
{-# language CPP #-}
{-# language ConstraintKinds #-}
{-# language DefaultSignatures #-}
{-# language GADTs #-}
{-# language TypeFamilies #-}
{-# language TypeOperators #-}
{-# language MultiWayIf #-}
module Nix.Render where
import Nix.Prelude
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.PosixCompat.Files as S
import Text.Megaparsec.Error
import Text.Megaparsec.Pos
import qualified Data.Text as Text
class (MonadFail m, MonadIO m) => MonadFile m where
readFile :: Path -> m Text
default readFile :: (MonadTrans t, MonadIO m', MonadFile m', m ~ t m') => Path -> m Text
readFile = IO Text -> m Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> (Path -> IO Text) -> Path -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> IO Text
Nix.Prelude.readFile
listDirectory :: Path -> m [Path]
default listDirectory :: (MonadTrans t, MonadFile m', m ~ t m') => Path -> m [Path]
listDirectory = m' [Path] -> t m' [Path]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' [Path] -> t m' [Path])
-> (Path -> m' [Path]) -> Path -> t m' [Path]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> m' [Path]
forall (m :: * -> *). MonadFile m => Path -> m [Path]
listDirectory
getCurrentDirectory :: m Path
default getCurrentDirectory :: (MonadTrans t, MonadFile m', m ~ t m') => m Path
getCurrentDirectory = m' Path -> t m' Path
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m' Path
forall (m :: * -> *). MonadFile m => m Path
getCurrentDirectory
canonicalizePath :: Path -> m Path
default canonicalizePath :: (MonadTrans t, MonadFile m', m ~ t m') => Path -> m Path
canonicalizePath = m' Path -> t m' Path
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m' Path -> t m' Path) -> (Path -> m' Path) -> Path -> t m' Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> m' Path
forall (m :: * -> *). MonadFile m => Path -> m Path
canonicalizePath
getHomeDirectory :: m Path
default getHomeDirectory :: (MonadTrans t, MonadFile m', m ~ t m') => m Path
getHomeDirectory = m' Path -> t m' Path
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m' Path
forall (m :: * -> *). MonadFile m => m Path
getHomeDirectory
doesPathExist :: Path -> m Bool
default doesPathExist :: (MonadTrans t, MonadFile m', m ~ t m') => Path -> 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) -> (Path -> m' Bool) -> Path -> t m' Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> m' Bool
forall (m :: * -> *). MonadFile m => Path -> m Bool
doesPathExist
doesFileExist :: Path -> m Bool
default doesFileExist :: (MonadTrans t, MonadFile m', m ~ t m') => Path -> 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) -> (Path -> m' Bool) -> Path -> t m' Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> m' Bool
forall (m :: * -> *). MonadFile m => Path -> m Bool
doesFileExist
doesDirectoryExist :: Path -> m Bool
default doesDirectoryExist :: (MonadTrans t, MonadFile m', m ~ t m') => Path -> 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) -> (Path -> m' Bool) -> Path -> t m' Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> m' Bool
forall (m :: * -> *). MonadFile m => Path -> m Bool
doesDirectoryExist
getSymbolicLinkStatus :: Path -> m S.FileStatus
default getSymbolicLinkStatus :: (MonadTrans t, MonadFile m', m ~ t m') => Path -> 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)
-> (Path -> m' FileStatus) -> Path -> t m' FileStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> m' FileStatus
forall (m :: * -> *). MonadFile m => Path -> m FileStatus
getSymbolicLinkStatus
instance MonadFile IO where
readFile :: Path -> IO Text
readFile = Path -> IO Text
Nix.Prelude.readFile
listDirectory :: Path -> IO [Path]
listDirectory = (FilePath -> IO [FilePath]) -> Path -> IO [Path]
coerce FilePath -> IO [FilePath]
S.listDirectory
getCurrentDirectory :: IO Path
getCurrentDirectory = IO FilePath -> IO Path
coerce IO FilePath
S.getCurrentDirectory
canonicalizePath :: Path -> IO Path
canonicalizePath = (FilePath -> IO FilePath) -> Path -> IO Path
coerce FilePath -> IO FilePath
S.canonicalizePath
getHomeDirectory :: IO Path
getHomeDirectory = IO FilePath -> IO Path
coerce IO FilePath
S.getHomeDirectory
doesPathExist :: Path -> IO Bool
doesPathExist = (FilePath -> IO Bool) -> Path -> IO Bool
coerce FilePath -> IO Bool
S.doesPathExist
doesFileExist :: Path -> IO Bool
doesFileExist = (FilePath -> IO Bool) -> Path -> IO Bool
coerce FilePath -> IO Bool
S.doesFileExist
doesDirectoryExist :: Path -> IO Bool
doesDirectoryExist = (FilePath -> IO Bool) -> Path -> IO Bool
coerce FilePath -> IO Bool
S.doesDirectoryExist
getSymbolicLinkStatus :: Path -> IO FileStatus
getSymbolicLinkStatus = (FilePath -> IO FileStatus) -> Path -> IO FileStatus
coerce FilePath -> IO FileStatus
S.getSymbolicLinkStatus
instance (MonadFix1T t m, MonadIO (Fix1T 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 ([ErrorFancy Void] -> Set (ErrorFancy Void))
-> [ErrorFancy Void] -> Set (ErrorFancy Void)
forall a b. (a -> b) -> a -> b
$ OneItem [ErrorFancy Void] -> [ErrorFancy Void]
forall x. One x => OneItem x -> x
one (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 -> Path
coerce -> Path
file) Pos
begLine Pos
begCol) (SourcePos (FilePath -> Path
coerce -> Path
file') Pos
endLine Pos
endCol)) Doc a
msg
| Path
file Path -> Path -> Bool
forall a. Eq a => a -> a -> Bool
== Path
file' Bool -> Bool -> Bool
&& Path
file Path -> Path -> Bool
forall a. Eq a => a -> a -> Bool
== Path
"<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)
| Path
file Path -> Path -> Bool
forall a. Eq a => a -> a -> Bool
/= Path
"<string>" Bool -> Bool -> Bool
&& Path
file Path -> Path -> Bool
forall a. Eq a => a -> a -> Bool
== Path
file' =
m (Doc a) -> m (Doc a) -> Bool -> m (Doc a)
forall a. a -> a -> Bool -> a
bool
(Doc a -> m (Doc a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc a
msg)
(do
Doc a
txt <- Path -> Pos -> Pos -> Pos -> Pos -> Doc a -> m (Doc a)
forall (m :: * -> *) a.
MonadFile m =>
Path -> Pos -> Pos -> Pos -> Pos -> Doc a -> m (Doc a)
sourceContext Path
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
<> Path -> Pos -> Pos -> Pos -> Pos -> Doc a
forall a. Path -> Pos -> Pos -> Pos -> Pos -> Doc a
errorContext Path
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
]
)
(Bool -> m (Doc a)) -> m Bool -> m (Doc a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Path -> m Bool
forall (m :: * -> *). MonadFile m => Path -> m Bool
doesFileExist Path
file
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 :: Path -> Pos -> Pos -> Pos -> Pos -> Doc a
errorContext :: Path -> Pos -> Pos -> Pos -> Pos -> Doc a
errorContext (Coercible Path FilePath => Path -> FilePath
coerce @Path @FilePath -> 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 => Path -> Pos -> Pos -> Pos -> Pos -> Doc a -> m (Doc a)
sourceContext :: Path -> Pos -> Pos -> Pos -> Pos -> Doc a -> m (Doc a)
sourceContext Path
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]) -> (Text -> [Text]) -> Text -> [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]) -> (Text -> [Text]) -> Text -> [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]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
forall t. IsText t "lines" => t -> [t]
lines
(Text -> [Doc a]) -> m Text -> m [Doc a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path -> m Text
forall (m :: * -> *). MonadFile m => Path -> m Text
Nix.Render.readFile Path
path
let
longest :: Int
longest = Text -> Int
Text.length (Text -> Int) -> Text -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ 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 -> Text
pad :: Int -> Text
pad Int
n =
let
ns :: Text
ns :: Text
ns = Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
n
nsp :: Text
nsp = Int -> Text -> Text
Text.replicate (Int
longest Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
Text.length Text
ns) Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
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 -> Text
"==> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nsp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" | "
| 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 -> Text
" > " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nsp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" | "
| Bool
otherwise -> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nsp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" | "
composeLine :: Int -> Doc a -> [Doc a]
composeLine Int
n Doc a
l =
OneItem [Doc a] -> [Doc a]
forall x. One x => OneItem x -> x
one (Text -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Text
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. Semigroup a => a -> a -> a
<> [Doc a] -> Bool -> [Doc a]
forall a. Monoid a => a -> Bool -> a
whenTrue
(OneItem [Doc a] -> [Doc a]
forall x. One x => OneItem x -> x
one (OneItem [Doc a] -> [Doc a]) -> OneItem [Doc a] -> [Doc a]
forall a b. (a -> b) -> a -> b
$
Text -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc a) -> Text -> Doc a
forall a b. (a -> b) -> a -> b
$
Int -> Text -> Text
Text.replicate (Text -> Int
Text.length (Int -> Text
pad Int
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) Text
" "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"|"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.replicate (Int
_begCol Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
" "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.replicate (Int
_endCol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
_begCol) Text
"^"
)
(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 :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([[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. Semigroup a => a -> a -> a
<> OneItem [Doc a] -> [Doc a]
forall x. One x => OneItem x -> x
one (Int -> Doc a -> Doc a
forall ann. Int -> Doc ann -> Doc ann
indent (Text -> Int
Text.length (Text -> Int) -> Text -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Text
pad Int
begLine) Doc a
msg)