{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}

module Dhall.Syntax.Chunks
    ( Chunks(..)

      -- * Optics
    , chunkExprs

      -- * `Data.Text.Text` manipulation
    , toDoubleQuoted
    , longestSharedWhitespacePrefix
    , linesLiteral
    , unlinesLiteral
    ) where

import                Data.List.NonEmpty (NonEmpty (..))
import                Data.String        (IsString (..))
import                Data.Text          (Text)
import                Dhall.Src          (Src)
import {-# SOURCE #-} Dhall.Syntax.Expr  (Expr)
import                GHC.Generics       (Generic)

import qualified Data.Foldable
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Text

-- | The body of an interpolated @Text@ literal
data Chunks s a = Chunks [(Text, Expr s a)] Text
    deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s a x. Rep (Chunks s a) x -> Chunks s a
forall s a x. Chunks s a -> Rep (Chunks s a) x
$cto :: forall s a x. Rep (Chunks s a) x -> Chunks s a
$cfrom :: forall s a x. Chunks s a -> Rep (Chunks s a) x
Generic

instance IsString (Chunks s a) where
    fromString :: String -> Chunks s a
fromString String
str = forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] (forall a. IsString a => String -> a
fromString String
str)

instance Semigroup (Chunks s a) where
    Chunks [(Text, Expr s a)]
xysL Text
zL <> :: Chunks s a -> Chunks s a -> Chunks s a
<> Chunks         []    Text
zR =
        forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [(Text, Expr s a)]
xysL (Text
zL forall a. Semigroup a => a -> a -> a
<> Text
zR)
    Chunks [(Text, Expr s a)]
xysL Text
zL <> Chunks ((Text
x, Expr s a
y):[(Text, Expr s a)]
xysR) Text
zR =
        forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks ([(Text, Expr s a)]
xysL forall a. [a] -> [a] -> [a]
++ (Text
zL forall a. Semigroup a => a -> a -> a
<> Text
x, Expr s a
y)forall a. a -> [a] -> [a]
:[(Text, Expr s a)]
xysR) Text
zR

instance Monoid (Chunks s a) where
    mempty :: Chunks s a
mempty = forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] forall a. Monoid a => a
mempty

-- | A traversal over the immediate sub-expressions in 'Chunks'.
chunkExprs
  :: Applicative f
  => (Expr s a -> f (Expr t b))
  -> Chunks s a -> f (Chunks t b)
chunkExprs :: forall (f :: * -> *) s a t b.
Applicative f =>
(Expr s a -> f (Expr t b)) -> Chunks s a -> f (Chunks t b)
chunkExprs Expr s a -> f (Expr t b)
f (Chunks [(Text, Expr s a)]
chunks Text
final) =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks Text
final forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr s a -> f (Expr t b)
f) [(Text, Expr s a)]
chunks
{-# INLINABLE chunkExprs #-}

-- | Same as @Data.Text.splitOn@, except always returning a `NonEmpty` result
splitOn :: Text -> Text -> NonEmpty Text
splitOn :: Text -> Text -> NonEmpty Text
splitOn Text
needle Text
haystack =
    case Text -> Text -> [Text]
Data.Text.splitOn Text
needle Text
haystack of
        []     -> Text
"" forall a. a -> [a] -> NonEmpty a
:| []
        Text
t : [Text]
ts -> Text
t  forall a. a -> [a] -> NonEmpty a
:| [Text]
ts

-- | Split `Chunks` by lines
linesLiteral :: Chunks s a -> NonEmpty (Chunks s a)
linesLiteral :: forall s a. Chunks s a -> NonEmpty (Chunks s a)
linesLiteral (Chunks [] Text
suffix) =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks []) (Text -> Text -> NonEmpty Text
splitOn Text
"\n" Text
suffix)
linesLiteral (Chunks ((Text
prefix, Expr s a
interpolation) : [(Text, Expr s a)]
pairs₀) Text
suffix₀) =
    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        forall a. a -> NonEmpty a -> NonEmpty a
NonEmpty.cons
        (forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks ((Text
lastLine, Expr s a
interpolation) forall a. a -> [a] -> [a]
: [(Text, Expr s a)]
pairs₁) Text
suffix₁ forall a. a -> [a] -> NonEmpty a
:| [Chunks s a]
chunks)
        (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks []) [Text]
initLines)
  where
    splitLines :: NonEmpty Text
splitLines = Text -> Text -> NonEmpty Text
splitOn Text
"\n" Text
prefix

    initLines :: [Text]
initLines = forall a. NonEmpty a -> [a]
NonEmpty.init NonEmpty Text
splitLines
    lastLine :: Text
lastLine  = forall a. NonEmpty a -> a
NonEmpty.last NonEmpty Text
splitLines

    Chunks [(Text, Expr s a)]
pairs₁ Text
suffix₁ :| [Chunks s a]
chunks = forall s a. Chunks s a -> NonEmpty (Chunks s a)
linesLiteral (forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [(Text, Expr s a)]
pairs₀ Text
suffix₀)

-- | Flatten several `Chunks` back into a single `Chunks` by inserting newlines
unlinesLiteral :: NonEmpty (Chunks s a) -> Chunks s a
unlinesLiteral :: forall s a. NonEmpty (Chunks s a) -> Chunks s a
unlinesLiteral NonEmpty (Chunks s a)
chunks =
    forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
Data.Foldable.fold (forall a. a -> NonEmpty a -> NonEmpty a
NonEmpty.intersperse Chunks s a
"\n" NonEmpty (Chunks s a)
chunks)

-- | Returns `True` if the `Chunks` represents a blank line
emptyLine :: Chunks s a -> Bool
emptyLine :: forall s a. Chunks s a -> Bool
emptyLine (Chunks [] Text
""  ) = Bool
True
emptyLine (Chunks [] Text
"\r") = Bool
True  -- So that `\r\n` is treated as a blank line
emptyLine  Chunks s a
_               = Bool
False

-- | Return the leading whitespace for a `Chunks` literal
leadingSpaces :: Chunks s a -> Text
leadingSpaces :: forall s a. Chunks s a -> Text
leadingSpaces Chunks s a
chunks = (Char -> Bool) -> Text -> Text
Data.Text.takeWhile Char -> Bool
isSpace Text
firstText
  where
    isSpace :: Char -> Bool
isSpace Char
c = Char
c forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\t'

    firstText :: Text
firstText =
        case Chunks s a
chunks of
            Chunks                []  Text
suffix -> Text
suffix
            Chunks ((Text
prefix, Expr s a
_) : [(Text, Expr s a)]
_ ) Text
_      -> Text
prefix

{-| Compute the longest shared whitespace prefix for the purposes of stripping
    leading indentation
-}
longestSharedWhitespacePrefix :: NonEmpty (Chunks s a) -> Text
longestSharedWhitespacePrefix :: forall s a. NonEmpty (Chunks s a) -> Text
longestSharedWhitespacePrefix NonEmpty (Chunks s a)
literals =
    case forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall s a. Chunks s a -> Text
leadingSpaces [Chunks s a]
filteredLines of
        Text
l : [Text]
ls -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Data.Foldable.foldl' Text -> Text -> Text
sharedPrefix Text
l [Text]
ls
        []     -> Text
""
  where
    sharedPrefix :: Text -> Text -> Text
sharedPrefix Text
ab Text
ac =
        case Text -> Text -> Maybe (Text, Text, Text)
Data.Text.commonPrefixes Text
ab Text
ac of
            Just (Text
a, Text
_b, Text
_c) -> Text
a
            Maybe (Text, Text, Text)
Nothing          -> Text
""

    -- The standard specifies to filter out blank lines for all lines *except*
    -- for the last line
    filteredLines :: [Chunks s a]
filteredLines = [Chunks s a]
newInit forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Applicative f => a -> f a
pure Chunks s a
oldLast
      where
        oldInit :: [Chunks s a]
oldInit = forall a. NonEmpty a -> [a]
NonEmpty.init NonEmpty (Chunks s a)
literals

        oldLast :: Chunks s a
oldLast = forall a. NonEmpty a -> a
NonEmpty.last NonEmpty (Chunks s a)
literals

        newInit :: [Chunks s a]
newInit = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. Chunks s a -> Bool
emptyLine) [Chunks s a]
oldInit

-- | Drop the first @n@ characters for a `Chunks` literal
dropLiteral :: Int -> Chunks s a -> Chunks s a
dropLiteral :: forall s a. Int -> Chunks s a -> Chunks s a
dropLiteral Int
n (Chunks [] Text
suffix) =
    forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks [] (Int -> Text -> Text
Data.Text.drop Int
n Text
suffix)
dropLiteral Int
n (Chunks ((Text
prefix, Expr s a
interpolation) : [(Text, Expr s a)]
rest) Text
suffix) =
    forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Chunks ((Int -> Text -> Text
Data.Text.drop Int
n Text
prefix, Expr s a
interpolation) forall a. a -> [a] -> [a]
: [(Text, Expr s a)]
rest) Text
suffix

{-| Convert a single-quoted `Chunks` literal to the equivalent double-quoted
    `Chunks` literal
-}
toDoubleQuoted :: Chunks Src a -> Chunks Src a
toDoubleQuoted :: forall a. Chunks Src a -> Chunks Src a
toDoubleQuoted Chunks Src a
literal =
    forall s a. NonEmpty (Chunks s a) -> Chunks s a
unlinesLiteral (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall s a. Int -> Chunks s a -> Chunks s a
dropLiteral Int
indent) NonEmpty (Chunks Src a)
literals)
  where
    literals :: NonEmpty (Chunks Src a)
literals = forall s a. Chunks s a -> NonEmpty (Chunks s a)
linesLiteral Chunks Src a
literal

    longestSharedPrefix :: Text
longestSharedPrefix = forall s a. NonEmpty (Chunks s a) -> Text
longestSharedWhitespacePrefix NonEmpty (Chunks Src a)
literals

    indent :: Int
indent = Text -> Int
Data.Text.length Text
longestSharedPrefix