{-# 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)
        -- XXX: Consider inserting the message here when it is small enough.
        -- ATM some messages are so huge that they take prevalence over the source listing.
        -- ++ [ indent (length $ pad n) msg | n == 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)