{-# 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 )

-- Please reduce Unsafe
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]