{-# LANGUAGE ScopedTypeVariables #-}

module Nix.XML
  ( toXML )
where

import qualified Data.HashMap.Lazy             as M
import           Nix.Atoms
import           Nix.Expr.Types
import           Nix.String
import           Nix.Value
import           Text.XML.Light                 ( Element(Element)
                                                , Attr(Attr)
                                                , Content(Elem)
                                                , unqual
                                                , ppElement
                                                )

toXML :: forall t f m . MonadDataContext f m => NValue t f m -> NixString
toXML :: NValue t f m -> NixString
toXML = WithStringContextT Identity Text -> NixString
runWithStringContext (WithStringContextT Identity Text -> NixString)
-> (NValue t f m -> WithStringContextT Identity Text)
-> NValue t f m
-> NixString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Element -> Text)
-> WithStringContextT Identity Element
-> WithStringContextT Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Element -> Text
pp (WithStringContextT Identity Element
 -> WithStringContextT Identity Text)
-> (NValue t f m -> WithStringContextT Identity Element)
-> NValue t f m
-> WithStringContextT Identity Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithStringContextT Identity Element
-> (NValue' t f m (WithStringContextT Identity Element)
    -> WithStringContextT Identity Element)
-> NValue t f m
-> WithStringContextT Identity Element
forall (f :: * -> *) (m :: * -> *) r t.
MonadDataContext f m =>
r -> (NValue' t f m r -> r) -> Free (NValue' t f m) t -> r
iterNValueByDiscardWith WithStringContextT Identity Element
cyc NValue' t f m (WithStringContextT Identity Element)
-> WithStringContextT Identity Element
phi
 where
  cyc :: WithStringContextT Identity Element
cyc = Element -> WithStringContextT Identity Element
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Element -> WithStringContextT Identity Element)
-> Element -> WithStringContextT Identity Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
mkEVal String
"string" String
"<expr>"

  pp :: Element -> Text
pp Element
e =
    Text
heading
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText
        (Element -> String
ppElement (Element -> String) -> Element -> String
forall a b. (a -> b) -> a -> b
$
          String -> [Content] -> Element
mkE
            String
"expr"
            [Element -> Content
Elem Element
e]
        )
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
   where
    heading :: Text
heading = Text
"<?xml version='1.0' encoding='utf-8'?>\n"

  phi :: NValue' t f m (WithStringContext Element) -> WithStringContext Element
  phi :: NValue' t f m (WithStringContextT Identity Element)
-> WithStringContextT Identity Element
phi = \case
    NVConstant' NAtom
a ->
      Element -> WithStringContextT Identity Element
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Element -> WithStringContextT Identity Element)
-> Element -> WithStringContextT Identity Element
forall a b. (a -> b) -> a -> b
$
        case NAtom
a of
          NURI   Text
t -> String -> String -> Element
mkEVal String
"string" (String -> Element) -> String -> Element
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. ToString a => a -> String
toString Text
t
          NInt   Integer
n -> String -> String -> Element
mkEVal String
"int"    (String -> Element) -> String -> Element
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall b a. (Show a, IsString b) => a -> b
show Integer
n
          NFloat Float
f -> String -> String -> Element
mkEVal String
"float"  (String -> Element) -> String -> Element
forall a b. (a -> b) -> a -> b
$ Float -> String
forall b a. (Show a, IsString b) => a -> b
show Float
f
          NBool  Bool
b -> String -> String -> Element
mkEVal String
"bool"   (String -> Element) -> String -> Element
forall a b. (a -> b) -> a -> b
$ if Bool
b then String
"true" else String
"false"
          NAtom
NNull    -> String -> [Content] -> Element
mkE    String
"null"     [Content]
forall a. Monoid a => a
mempty

    NVStr' NixString
str ->
      String -> String -> Element
mkEVal String
"string" (String -> Element) -> (Text -> String) -> Text -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString (Text -> Element)
-> WithStringContextT Identity Text
-> WithStringContextT Identity Element
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NixString -> WithStringContextT Identity Text
forall (m :: * -> *).
Monad m =>
NixString -> WithStringContextT m Text
extractNixString NixString
str
    NVList' [WithStringContextT Identity Element]
l ->
      do
        [Element]
els <- [WithStringContextT Identity Element]
-> WithStringContextT Identity [Element]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [WithStringContextT Identity Element]
l
        pure $
          String -> [Content] -> Element
mkE
            String
"list"
            (Element -> Content
Elem (Element -> Content) -> [Element] -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Element]
els)

    NVSet' AttrSet (WithStringContextT Identity Element)
s AttrSet SourcePos
_ ->
      do
        HashMap Text Element
kvs <- AttrSet (WithStringContextT Identity Element)
-> WithStringContextT Identity (HashMap Text Element)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence AttrSet (WithStringContextT Identity Element)
s
        pure $
          String -> [Content] -> Element
mkE
            String
"attrs"
            ((\ (Text
k, Element
v) ->
                Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$
                  QName -> [Attr] -> [Content] -> Maybe Integer -> Element
Element
                    (String -> QName
unqual String
"attr")
                    [QName -> String -> Attr
Attr (String -> QName
unqual String
"name") (Text -> String
forall a. ToString a => a -> String
toString Text
k)]
                    [Element -> Content
Elem Element
v]
                    Maybe Integer
forall a. Maybe a
Nothing
              ) ((Text, Element) -> Content) -> [(Text, Element)] -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                ((Text, Element) -> Text) -> [(Text, Element)] -> [(Text, Element)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith (Text, Element) -> Text
forall a b. (a, b) -> a
fst (HashMap Text Element -> [(Text, Element)]
forall k v. HashMap k v -> [(k, v)]
M.toList HashMap Text Element
kvs)
            )

    NVClosure' Params ()
p NValue t f m -> m (WithStringContextT Identity Element)
_ ->
      Element -> WithStringContextT Identity Element
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Element -> WithStringContextT Identity Element)
-> Element -> WithStringContextT Identity Element
forall a b. (a -> b) -> a -> b
$
        String -> [Content] -> Element
mkE
          String
"function"
          (Params () -> [Content]
forall r. Params r -> [Content]
paramsXML Params ()
p)
    NVPath' String
fp        -> Element -> WithStringContextT Identity Element
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Element -> WithStringContextT Identity Element)
-> Element -> WithStringContextT Identity Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
mkEVal String
"path" String
fp
    NVBuiltin' Text
name NValue t f m -> m (WithStringContextT Identity Element)
_ -> Element -> WithStringContextT Identity Element
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Element -> WithStringContextT Identity Element)
-> Element -> WithStringContextT Identity Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
mkEName String
"function" (String -> Element) -> String -> Element
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. ToString a => a -> String
toString Text
name

mkE :: String -> [Content] -> Element
mkE :: String -> [Content] -> Element
mkE String
n [Content]
c =
  QName -> [Attr] -> [Content] -> Maybe Integer -> Element
Element
    (String -> QName
unqual String
n)
    [Attr]
forall a. Monoid a => a
mempty
    [Content]
c
    Maybe Integer
forall a. Maybe a
Nothing

mkElem :: String -> String -> String -> Element
mkElem :: String -> String -> String -> Element
mkElem String
n String
a String
v =
  QName -> [Attr] -> [Content] -> Maybe Integer -> Element
Element
    (String -> QName
unqual String
n)
    [QName -> String -> Attr
Attr (String -> QName
unqual String
a) String
v]
    [Content]
forall a. Monoid a => a
mempty
    Maybe Integer
forall a. Maybe a
Nothing

mkEVal :: String -> String -> Element
mkEVal :: String -> String -> Element
mkEVal = (String -> String -> String -> Element
`mkElem` String
"value")

mkEName :: String -> String -> Element
mkEName :: String -> String -> Element
mkEName = (String -> String -> String -> Element
`mkElem` String
"name")

paramsXML :: Params r -> [Content]
paramsXML :: Params r -> [Content]
paramsXML (Param Text
name) = [Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
mkEName String
"varpat" (Text -> String
forall a. ToString a => a -> String
toString Text
name)]
paramsXML (ParamSet ParamSet r
s Bool
b Maybe Text
mname) =
  [Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ QName -> [Attr] -> [Content] -> Maybe Integer -> Element
Element (String -> QName
unqual String
"attrspat") ([Attr]
battr [Attr] -> [Attr] -> [Attr]
forall a. Semigroup a => a -> a -> a
<> [Attr]
nattr) (ParamSet r -> [Content]
forall r. ParamSet r -> [Content]
paramSetXML ParamSet r
s) Maybe Integer
forall a. Maybe a
Nothing]
 where
  battr :: [Attr]
battr = [ QName -> String -> Attr
Attr (String -> QName
unqual String
"ellipsis") String
"1" | Bool
b ]
  nattr :: [Attr]
nattr =
    [Attr] -> (Text -> [Attr]) -> Maybe Text -> [Attr]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      [Attr]
forall a. Monoid a => a
mempty
      ((Attr -> [Attr] -> [Attr]
forall a. a -> [a] -> [a]
: [Attr]
forall a. Monoid a => a
mempty) (Attr -> [Attr]) -> (Text -> Attr) -> Text -> [Attr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> String -> Attr
Attr (String -> QName
unqual String
"name") (String -> Attr) -> (Text -> String) -> Text -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString)
      Maybe Text
mname

paramSetXML :: ParamSet r -> [Content]
paramSetXML :: ParamSet r -> [Content]
paramSetXML = ((Text, Maybe r) -> Content) -> ParamSet r -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Text
k, Maybe r
_) -> Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
mkEName String
"attr" (Text -> String
forall a. ToString a => a -> String
toString Text
k))