{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}

module Nix.Render where

import           Prelude                 hiding ( readFile )

import           Control.Monad.Fail             ( MonadFail )
import           Control.Monad.Trans
import           Data.ByteString                ( ByteString )
import qualified Data.ByteString               as BS
import qualified Data.Set                      as Set
import qualified Data.Text                     as T
import qualified Data.Text.Encoding            as T
import           Data.Text.Prettyprint.Doc
import           Data.Void
import           Nix.Expr.Types.Annotated
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

posAndMsg :: SourcePos -> Doc a -> ParseError s Void
posAndMsg :: SourcePos -> Doc a -> ParseError s Void
posAndMsg (SourcePos _ lineNo :: Pos
lineNo _) msg :: 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 a. Show a => a -> FilePath
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 file :: FilePath
file begLine :: Pos
begLine begCol :: Pos
begCol) (SourcePos file' :: FilePath
file' endLine :: Pos
endLine endCol :: Pos
endCol)) msg :: Doc a
msg
  | FilePath
file FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= "<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
        Doc a -> m (Doc a)
forall (m :: * -> *) a. Monad m => a -> m a
return
          (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
              [ "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
txt
              ]
      else Doc a -> m (Doc a)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc a
msg
renderLocation (SrcSpan beg :: SourcePos
beg end :: SourcePos
end) msg :: 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
$  "Don't know how to render range from "
    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SourcePos -> FilePath
forall a. Show a => a -> FilePath
show SourcePos
beg
    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " to "
    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SourcePos -> FilePath
forall a. Show a => a -> FilePath
show SourcePos
end
    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " for error: "
    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Doc a -> FilePath
forall a. Show a => a -> FilePath
show Doc a
msg

errorContext :: FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a
errorContext :: FilePath -> Pos -> Pos -> Pos -> Pos -> Doc a
errorContext path :: FilePath
path bl :: Pos
bl bc :: Pos
bc _el :: Pos
_el _ec :: 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
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
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 path :: FilePath
path (Pos -> Int
unPos -> Int
begLine) (Pos -> Int
unPos -> Int
_begCol) (Pos -> Int
unPos -> Int
endLine) (Pos -> Int
unPos -> Int
_endCol) msg :: Doc a
msg
  = do
    let beg' :: Int
beg' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 1 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
begLine (Int
begLine Int -> Int -> Int
forall a. Num a => a -> a -> a
- 3))
        end' :: Int
end' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
endLine (Int
endLine Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 3)
    [Doc a]
ls <-
      (Text -> Doc a) -> [Text] -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map 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]
T.lines
      (Text -> [Text]) -> (ByteString -> Text) -> ByteString -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.   ByteString -> Text
T.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. (a -> b) -> [a] -> [b]
map (Int -> FilePath
forall a. Show a => a -> FilePath
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, Doc a)] -> [FilePath]) -> [(Int, Doc a)] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Doc a] -> [(Int, Doc a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
beg' ..] [Doc a]
ls
      longest :: Int
longest = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((FilePath -> Int) -> [FilePath] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
nums)
      nums' :: [FilePath]
nums'   = ((FilePath -> FilePath) -> [FilePath] -> [FilePath])
-> [FilePath] -> (FilePath -> FilePath) -> [FilePath]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map [FilePath]
nums ((FilePath -> FilePath) -> [FilePath])
-> (FilePath -> FilePath) -> [FilePath]
forall a b. (a -> b) -> a -> b
$ \n :: 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) ' ' FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
n
      pad :: FilePath -> FilePath
pad n :: 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
forall a. [a] -> [a] -> [a]
++ FilePath
n
            | Bool
otherwise         = "    " FilePath -> FilePath -> FilePath
forall 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 -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
(<+>)
                    ((FilePath -> Doc a) -> [FilePath] -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map (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]
nums')
                    ((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 -> Doc a -> Doc a
forall ann. Doc ann -> Doc ann -> Doc ann
(<+>) (Doc a -> [Doc a]
forall a. a -> [a]
repeat "| ") [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]
++ [Doc a
msg]