{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Hpack.Render.Dsl (
-- * AST
  Element (..)
, Value (..)

-- * Render
, RenderSettings (..)
, CommaStyle (..)
, defaultRenderSettings
, Alignment (..)
, Nesting
, render

-- * Utils
, sortFieldsBy

#ifdef TEST
, Lines (..)
, renderValue
, addSortKey
#endif
) where

import           Imports

data Value =
    Literal String
  | CommaSeparatedList [String]
  | LineSeparatedList [String]
  | WordList [String]
  deriving (Value -> Value -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c== :: Value -> Value -> Bool
Eq, Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show)

data Element = Stanza String [Element] | Group Element Element | Field String Value | Verbatim String
  deriving (Element -> Element -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Element -> Element -> Bool
$c/= :: Element -> Element -> Bool
== :: Element -> Element -> Bool
$c== :: Element -> Element -> Bool
Eq, Int -> Element -> ShowS
[Element] -> ShowS
Element -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Element] -> ShowS
$cshowList :: [Element] -> ShowS
show :: Element -> String
$cshow :: Element -> String
showsPrec :: Int -> Element -> ShowS
$cshowsPrec :: Int -> Element -> ShowS
Show)

data Lines = SingleLine String | MultipleLines [String]
  deriving (Lines -> Lines -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Lines -> Lines -> Bool
$c/= :: Lines -> Lines -> Bool
== :: Lines -> Lines -> Bool
$c== :: Lines -> Lines -> Bool
Eq, Int -> Lines -> ShowS
[Lines] -> ShowS
Lines -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Lines] -> ShowS
$cshowList :: [Lines] -> ShowS
show :: Lines -> String
$cshow :: Lines -> String
showsPrec :: Int -> Lines -> ShowS
$cshowsPrec :: Int -> Lines -> ShowS
Show)

data CommaStyle = LeadingCommas | TrailingCommas
  deriving (CommaStyle -> CommaStyle -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CommaStyle -> CommaStyle -> Bool
$c/= :: CommaStyle -> CommaStyle -> Bool
== :: CommaStyle -> CommaStyle -> Bool
$c== :: CommaStyle -> CommaStyle -> Bool
Eq, Int -> CommaStyle -> ShowS
[CommaStyle] -> ShowS
CommaStyle -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CommaStyle] -> ShowS
$cshowList :: [CommaStyle] -> ShowS
show :: CommaStyle -> String
$cshow :: CommaStyle -> String
showsPrec :: Int -> CommaStyle -> ShowS
$cshowsPrec :: Int -> CommaStyle -> ShowS
Show)

newtype Nesting = Nesting Int
  deriving (Nesting -> Nesting -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Nesting -> Nesting -> Bool
$c/= :: Nesting -> Nesting -> Bool
== :: Nesting -> Nesting -> Bool
$c== :: Nesting -> Nesting -> Bool
Eq, Int -> Nesting -> ShowS
[Nesting] -> ShowS
Nesting -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Nesting] -> ShowS
$cshowList :: [Nesting] -> ShowS
show :: Nesting -> String
$cshow :: Nesting -> String
showsPrec :: Int -> Nesting -> ShowS
$cshowsPrec :: Int -> Nesting -> ShowS
Show, Integer -> Nesting
Nesting -> Nesting
Nesting -> Nesting -> Nesting
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Nesting
$cfromInteger :: Integer -> Nesting
signum :: Nesting -> Nesting
$csignum :: Nesting -> Nesting
abs :: Nesting -> Nesting
$cabs :: Nesting -> Nesting
negate :: Nesting -> Nesting
$cnegate :: Nesting -> Nesting
* :: Nesting -> Nesting -> Nesting
$c* :: Nesting -> Nesting -> Nesting
- :: Nesting -> Nesting -> Nesting
$c- :: Nesting -> Nesting -> Nesting
+ :: Nesting -> Nesting -> Nesting
$c+ :: Nesting -> Nesting -> Nesting
Num, Int -> Nesting
Nesting -> Int
Nesting -> [Nesting]
Nesting -> Nesting
Nesting -> Nesting -> [Nesting]
Nesting -> Nesting -> Nesting -> [Nesting]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Nesting -> Nesting -> Nesting -> [Nesting]
$cenumFromThenTo :: Nesting -> Nesting -> Nesting -> [Nesting]
enumFromTo :: Nesting -> Nesting -> [Nesting]
$cenumFromTo :: Nesting -> Nesting -> [Nesting]
enumFromThen :: Nesting -> Nesting -> [Nesting]
$cenumFromThen :: Nesting -> Nesting -> [Nesting]
enumFrom :: Nesting -> [Nesting]
$cenumFrom :: Nesting -> [Nesting]
fromEnum :: Nesting -> Int
$cfromEnum :: Nesting -> Int
toEnum :: Int -> Nesting
$ctoEnum :: Int -> Nesting
pred :: Nesting -> Nesting
$cpred :: Nesting -> Nesting
succ :: Nesting -> Nesting
$csucc :: Nesting -> Nesting
Enum)

newtype Alignment = Alignment Int
  deriving (Alignment -> Alignment -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Alignment -> Alignment -> Bool
$c/= :: Alignment -> Alignment -> Bool
== :: Alignment -> Alignment -> Bool
$c== :: Alignment -> Alignment -> Bool
Eq, Int -> Alignment -> ShowS
[Alignment] -> ShowS
Alignment -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Alignment] -> ShowS
$cshowList :: [Alignment] -> ShowS
show :: Alignment -> String
$cshow :: Alignment -> String
showsPrec :: Int -> Alignment -> ShowS
$cshowsPrec :: Int -> Alignment -> ShowS
Show, Integer -> Alignment
Alignment -> Alignment
Alignment -> Alignment -> Alignment
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Alignment
$cfromInteger :: Integer -> Alignment
signum :: Alignment -> Alignment
$csignum :: Alignment -> Alignment
abs :: Alignment -> Alignment
$cabs :: Alignment -> Alignment
negate :: Alignment -> Alignment
$cnegate :: Alignment -> Alignment
* :: Alignment -> Alignment -> Alignment
$c* :: Alignment -> Alignment -> Alignment
- :: Alignment -> Alignment -> Alignment
$c- :: Alignment -> Alignment -> Alignment
+ :: Alignment -> Alignment -> Alignment
$c+ :: Alignment -> Alignment -> Alignment
Num)

data RenderSettings = RenderSettings {
  RenderSettings -> Int
renderSettingsIndentation :: Int
, RenderSettings -> Alignment
renderSettingsFieldAlignment :: Alignment
, RenderSettings -> CommaStyle
renderSettingsCommaStyle :: CommaStyle
} deriving (RenderSettings -> RenderSettings -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RenderSettings -> RenderSettings -> Bool
$c/= :: RenderSettings -> RenderSettings -> Bool
== :: RenderSettings -> RenderSettings -> Bool
$c== :: RenderSettings -> RenderSettings -> Bool
Eq, Int -> RenderSettings -> ShowS
[RenderSettings] -> ShowS
RenderSettings -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RenderSettings] -> ShowS
$cshowList :: [RenderSettings] -> ShowS
show :: RenderSettings -> String
$cshow :: RenderSettings -> String
showsPrec :: Int -> RenderSettings -> ShowS
$cshowsPrec :: Int -> RenderSettings -> ShowS
Show)

defaultRenderSettings :: RenderSettings
defaultRenderSettings :: RenderSettings
defaultRenderSettings = Int -> Alignment -> CommaStyle -> RenderSettings
RenderSettings Int
2 Alignment
0 CommaStyle
LeadingCommas

render :: RenderSettings -> Nesting -> Element -> [String]
render :: RenderSettings -> Nesting -> Element -> [String]
render RenderSettings
settings Nesting
nesting (Stanza String
name [Element]
elements) = RenderSettings -> Nesting -> ShowS
indent RenderSettings
settings Nesting
nesting String
name forall a. a -> [a] -> [a]
: RenderSettings -> Nesting -> [Element] -> [String]
renderElements RenderSettings
settings (forall a. Enum a => a -> a
succ Nesting
nesting) [Element]
elements
render RenderSettings
settings Nesting
nesting (Group Element
a Element
b) = RenderSettings -> Nesting -> Element -> [String]
render RenderSettings
settings Nesting
nesting Element
a forall a. [a] -> [a] -> [a]
++ RenderSettings -> Nesting -> Element -> [String]
render RenderSettings
settings Nesting
nesting Element
b
render RenderSettings
settings Nesting
nesting (Field String
name Value
value) = RenderSettings -> Nesting -> String -> Value -> [String]
renderField RenderSettings
settings Nesting
nesting String
name Value
value
render RenderSettings
settings Nesting
nesting (Verbatim String
str) = forall a b. (a -> b) -> [a] -> [b]
map (RenderSettings -> Nesting -> ShowS
indent RenderSettings
settings Nesting
nesting) (String -> [String]
lines String
str)

renderElements :: RenderSettings -> Nesting -> [Element] -> [String]
renderElements :: RenderSettings -> Nesting -> [Element] -> [String]
renderElements RenderSettings
settings Nesting
nesting = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (RenderSettings -> Nesting -> Element -> [String]
render RenderSettings
settings Nesting
nesting)

renderField :: RenderSettings -> Nesting -> String -> Value -> [String]
renderField :: RenderSettings -> Nesting -> String -> Value -> [String]
renderField settings :: RenderSettings
settings@RenderSettings{Int
Alignment
CommaStyle
renderSettingsCommaStyle :: CommaStyle
renderSettingsFieldAlignment :: Alignment
renderSettingsIndentation :: Int
renderSettingsCommaStyle :: RenderSettings -> CommaStyle
renderSettingsFieldAlignment :: RenderSettings -> Alignment
renderSettingsIndentation :: RenderSettings -> Int
..} Nesting
nesting String
name Value
value = case RenderSettings -> Value -> Lines
renderValue RenderSettings
settings Value
value of
  SingleLine String
"" -> []
  SingleLine String
x -> [RenderSettings -> Nesting -> ShowS
indent RenderSettings
settings Nesting
nesting (String
name forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
padding forall a. [a] -> [a] -> [a]
++ String
x)]
  MultipleLines [] -> []
  MultipleLines [String]
xs -> (RenderSettings -> Nesting -> ShowS
indent RenderSettings
settings Nesting
nesting String
name forall a. [a] -> [a] -> [a]
++ String
":") forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (RenderSettings -> Nesting -> ShowS
indent RenderSettings
settings forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> a
succ Nesting
nesting) [String]
xs
  where
    Alignment Int
fieldAlignment = Alignment
renderSettingsFieldAlignment
    padding :: String
padding = forall a. Int -> a -> [a]
replicate (Int
fieldAlignment forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name forall a. Num a => a -> a -> a
- Int
2) Char
' '

renderValue :: RenderSettings -> Value -> Lines
renderValue :: RenderSettings -> Value -> Lines
renderValue RenderSettings{Int
Alignment
CommaStyle
renderSettingsCommaStyle :: CommaStyle
renderSettingsFieldAlignment :: Alignment
renderSettingsIndentation :: Int
renderSettingsCommaStyle :: RenderSettings -> CommaStyle
renderSettingsFieldAlignment :: RenderSettings -> Alignment
renderSettingsIndentation :: RenderSettings -> Int
..} Value
v = case Value
v of
  Literal String
s -> String -> Lines
SingleLine String
s
  WordList [String]
ws -> String -> Lines
SingleLine forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String]
ws
  LineSeparatedList [String]
xs -> CommaStyle -> [String] -> Lines
renderLineSeparatedList CommaStyle
renderSettingsCommaStyle [String]
xs
  CommaSeparatedList [String]
xs -> CommaStyle -> [String] -> Lines
renderCommaSeparatedList CommaStyle
renderSettingsCommaStyle [String]
xs

renderLineSeparatedList :: CommaStyle -> [String] -> Lines
renderLineSeparatedList :: CommaStyle -> [String] -> Lines
renderLineSeparatedList CommaStyle
style = [String] -> Lines
MultipleLines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (String
padding forall a. [a] -> [a] -> [a]
++)
  where
    padding :: String
padding = case CommaStyle
style of
      CommaStyle
LeadingCommas -> String
"  "
      CommaStyle
TrailingCommas -> String
""

renderCommaSeparatedList :: CommaStyle -> [String] -> Lines
renderCommaSeparatedList :: CommaStyle -> [String] -> Lines
renderCommaSeparatedList CommaStyle
style = [String] -> Lines
MultipleLines forall b c a. (b -> c) -> (a -> b) -> a -> c
. case CommaStyle
style of
  CommaStyle
LeadingCommas -> forall a b. (a -> b) -> [a] -> [b]
map (Bool, String) -> String
renderLeadingComma forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip (Bool
True forall a. a -> [a] -> [a]
: forall a. a -> [a]
repeat Bool
False)
  CommaStyle
TrailingCommas -> forall a b. (a -> b) -> [a] -> [b]
map (Bool, String) -> String
renderTrailingComma forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip (Bool
True forall a. a -> [a] -> [a]
: forall a. a -> [a]
repeat Bool
False) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
  where
    renderLeadingComma :: (Bool, String) -> String
    renderLeadingComma :: (Bool, String) -> String
renderLeadingComma (Bool
isFirst, String
x)
      | Bool
isFirst   = String
"  " forall a. [a] -> [a] -> [a]
++ String
x
      | Bool
otherwise = String
", " forall a. [a] -> [a] -> [a]
++ String
x

    renderTrailingComma :: (Bool, String) -> String
    renderTrailingComma :: (Bool, String) -> String
renderTrailingComma (Bool
isLast, String
x)
      | Bool
isLast    = String
x
      | Bool
otherwise = String
x forall a. [a] -> [a] -> [a]
++ String
","

instance IsString Value where
  fromString :: String -> Value
fromString = String -> Value
Literal

indent :: RenderSettings -> Nesting -> String -> String
indent :: RenderSettings -> Nesting -> ShowS
indent RenderSettings{Int
Alignment
CommaStyle
renderSettingsCommaStyle :: CommaStyle
renderSettingsFieldAlignment :: Alignment
renderSettingsIndentation :: Int
renderSettingsCommaStyle :: RenderSettings -> CommaStyle
renderSettingsFieldAlignment :: RenderSettings -> Alignment
renderSettingsIndentation :: RenderSettings -> Int
..} (Nesting Int
nesting) String
s = forall a. Int -> a -> [a]
replicate (Int
nesting forall a. Num a => a -> a -> a
* Int
renderSettingsIndentation) Char
' ' forall a. [a] -> [a] -> [a]
++ String
s

sortFieldsBy :: [String] -> [Element] -> [Element]
sortFieldsBy :: [String] -> [Element] -> [Element]
sortFieldsBy [String]
existingFieldOrder =
    forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. (a, b) -> a
fst
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [(Maybe Int, a)] -> [((Int, Int), a)]
addSortKey
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\Element
a -> (Element -> Maybe Int
existingIndex Element
a, Element
a))
  where
    existingIndex :: Element -> Maybe Int
    existingIndex :: Element -> Maybe Int
existingIndex (Field String
name Value
_) = String
name forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` [String]
existingFieldOrder
    existingIndex Element
_ = forall a. Maybe a
Nothing

addSortKey :: [(Maybe Int, a)] -> [((Int, Int), a)]
addSortKey :: forall a. [(Maybe Int, a)] -> [((Int, Int), a)]
addSortKey = forall a. Int -> [(Int, (Maybe Int, a))] -> [((Int, Int), a)]
go (-Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..]
  where
    go :: Int -> [(Int, (Maybe Int, a))] -> [((Int, Int), a)]
    go :: forall a. Int -> [(Int, (Maybe Int, a))] -> [((Int, Int), a)]
go Int
n [(Int, (Maybe Int, a))]
xs = case [(Int, (Maybe Int, a))]
xs of
      [] -> []
      (Int
x, (Just Int
y, a
a)) : [(Int, (Maybe Int, a))]
ys -> ((Int
y, Int
x), a
a) forall a. a -> [a] -> [a]
: forall a. Int -> [(Int, (Maybe Int, a))] -> [((Int, Int), a)]
go Int
y [(Int, (Maybe Int, a))]
ys
      (Int
x, (Maybe Int
Nothing, a
a)) : [(Int, (Maybe Int, a))]
ys -> ((Int
n, Int
x), a
a) forall a. a -> [a] -> [a]
: forall a. Int -> [(Int, (Maybe Int, a))] -> [((Int, Int), a)]
go Int
n [(Int, (Maybe Int, a))]
ys