module Nix.XML
  ( toXML )
where

import           Nix.Prelude
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) -> NValue t f m -> 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
$ Text -> Text -> Element
mkEVal Text
"string" Text
"<expr>"

  pp :: Element -> Text
  pp :: Element -> Text
pp Element
e =
    Text
heading
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString
        (Element -> String
ppElement (Element -> String) -> Element -> String
forall a b. (a -> b) -> a -> b
$
          Text -> [Content] -> Element
mkE
            Text
"expr"
            (OneItem [Content] -> [Content]
forall x. One x => OneItem x -> x
one (OneItem [Content] -> [Content]) -> OneItem [Content] -> [Content]
forall a b. (a -> b) -> a -> b
$ 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 -> Text -> Text -> Element
mkEVal Text
"string" Text
t
          NInt   Integer
n -> Text -> Text -> Element
mkEVal Text
"int"    (Text -> Element) -> Text -> Element
forall a b. (a -> b) -> a -> b
$ Integer -> Text
forall b a. (Show a, IsString b) => a -> b
show Integer
n
          NFloat Float
f -> Text -> Text -> Element
mkEVal Text
"float"  (Text -> Element) -> Text -> Element
forall a b. (a -> b) -> a -> b
$ Float -> Text
forall b a. (Show a, IsString b) => a -> b
show Float
f
          NBool  Bool
b -> Text -> Text -> Element
mkEVal Text
"bool"   (Text -> Element) -> Text -> Element
forall a b. (a -> b) -> a -> b
$ if Bool
b then Text
"true" else Text
"false"
          NAtom
NNull    -> Text -> [Content] -> Element
mkE    Text
"null"     [Content]
forall a. Monoid a => a
mempty

    NVStr' NixString
str ->
      Text -> Text -> Element
mkEVal Text
"string" (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 ->
      Text -> [Content] -> Element
mkE Text
"list" ([Content] -> Element)
-> ([Element] -> [Content]) -> [Element] -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Element -> Content) -> [Element] -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Element -> Content
Elem ([Element] -> Element)
-> WithStringContextT Identity [Element]
-> WithStringContextT Identity Element
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [WithStringContextT Identity Element]
-> WithStringContextT Identity [Element]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [WithStringContextT Identity Element]
l

    NVSet' PositionSet
_ AttrSet (WithStringContextT Identity Element)
s ->
      Text -> [Content] -> Element
mkE
        Text
"attrs"
        ([Content] -> Element)
-> (HashMap VarName Element -> [Content])
-> HashMap VarName Element
-> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((VarName, Element) -> Content)
-> [(VarName, Element)] -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            (VarName, Element) -> Content
mkElem'
            ([(VarName, Element)] -> [Content])
-> (HashMap VarName Element -> [(VarName, Element)])
-> HashMap VarName Element
-> [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((VarName, Element) -> VarName)
-> [(VarName, Element)] -> [(VarName, Element)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith (VarName, Element) -> VarName
forall a b. (a, b) -> a
fst ([(VarName, Element)] -> [(VarName, Element)])
-> (HashMap VarName Element -> [(VarName, Element)])
-> HashMap VarName Element
-> [(VarName, Element)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap VarName Element -> [(VarName, Element)]
forall k v. HashMap k v -> [(k, v)]
M.toList
        (HashMap VarName Element -> Element)
-> WithStringContextT Identity (HashMap VarName Element)
-> WithStringContextT Identity Element
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AttrSet (WithStringContextT Identity Element)
-> WithStringContextT Identity (HashMap VarName Element)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA AttrSet (WithStringContextT Identity Element)
s
     where
      mkElem' :: (VarName, Element) -> Content
      mkElem' :: (VarName, Element) -> Content
mkElem' (VarName
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")
            (OneItem [Attr] -> [Attr]
forall x. One x => OneItem x -> x
one (OneItem [Attr] -> [Attr]) -> OneItem [Attr] -> [Attr]
forall a b. (a -> b) -> a -> b
$ QName -> String -> Attr
Attr (String -> QName
unqual String
"name") (String -> Attr) -> String -> Attr
forall a b. (a -> b) -> a -> b
$ VarName -> String
forall a. ToString a => a -> String
toString VarName
k)
            (OneItem [Content] -> [Content]
forall x. One x => OneItem x -> x
one (OneItem [Content] -> [Content]) -> OneItem [Content] -> [Content]
forall a b. (a -> b) -> a -> b
$ Element -> Content
Elem Element
v)
            Maybe Integer
forall a. Maybe a
Nothing

    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
$
        Text -> [Content] -> Element
mkE
          Text
"function"
          (Params () -> [Content]
forall r. Params r -> [Content]
paramsXML Params ()
p)
    NVPath' Path
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
$ Text -> Text -> Element
mkEVal Text
"path" (Text -> Element) -> Text -> Element
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Path -> String
coerce Path
fp
    NVBuiltin' VarName
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
$ Text -> VarName -> Element
mkEName Text
"function" VarName
name

mkE :: Text -> [Content] -> Element
mkE :: Text -> [Content] -> Element
mkE (Text -> String
forall a. ToString a => a -> String
toString -> 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 :: Text -> Text -> Text -> Element
mkElem :: Text -> Text -> Text -> Element
mkElem (Text -> String
forall a. ToString a => a -> String
toString -> String
n) (Text -> String
forall a. ToString a => a -> String
toString -> String
a) (Text -> String
forall a. ToString a => a -> String
toString -> String
v) =
  QName -> [Attr] -> [Content] -> Maybe Integer -> Element
Element
    (String -> QName
unqual String
n)
    (OneItem [Attr] -> [Attr]
forall x. One x => OneItem x -> x
one (OneItem [Attr] -> [Attr]) -> OneItem [Attr] -> [Attr]
forall a b. (a -> b) -> a -> b
$ 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 :: Text -> Text -> Element
mkEVal :: Text -> Text -> Element
mkEVal = (Text -> Text -> Text -> Element
`mkElem` Text
"value")

mkEName :: Text -> VarName -> Element
mkEName :: Text -> VarName -> Element
mkEName Text
x (VarName -> Text
coerce -> Text
y) = (Text -> Text -> Text -> Element
`mkElem` Text
"name") Text
x Text
y

paramsXML :: Params r -> [Content]
paramsXML :: Params r -> [Content]
paramsXML (Param VarName
name) = OneItem [Content] -> [Content]
forall x. One x => OneItem x -> x
one (OneItem [Content] -> [Content]) -> OneItem [Content] -> [Content]
forall a b. (a -> b) -> a -> b
$ Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ Text -> VarName -> Element
mkEName Text
"varpat" VarName
name
paramsXML (ParamSet Maybe VarName
mname Variadic
variadic ParamSet r
pset) =
  OneItem [Content] -> [Content]
forall x. One x => OneItem x -> x
one (OneItem [Content] -> [Content]) -> OneItem [Content] -> [Content]
forall a b. (a -> b) -> a -> b
$ 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
pset) Maybe Integer
forall a. Maybe a
Nothing
 where
  battr :: [Attr]
battr =
    OneItem [Attr] -> [Attr]
forall x. One x => OneItem x -> x
one (QName -> String -> Attr
Attr (String -> QName
unqual String
"ellipsis") String
"1") [Attr] -> Bool -> [Attr]
forall a. Monoid a => a -> Bool -> a
`whenTrue` (Variadic
variadic Variadic -> Variadic -> Bool
forall a. Eq a => a -> a -> Bool
== Variadic
Variadic)
  nattr :: [Attr]
nattr =
    (Attr -> [Attr]
forall x. One x => OneItem x -> x
one (Attr -> [Attr]) -> (VarName -> Attr) -> VarName -> [Attr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> String -> Attr
Attr (String -> QName
unqual String
"name") (String -> Attr) -> (VarName -> String) -> VarName -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarName -> String
forall a. ToString a => a -> String
toString) (VarName -> [Attr]) -> Maybe VarName -> [Attr]
forall b a. Monoid b => (a -> b) -> Maybe a -> b
`whenJust` Maybe VarName
mname

paramSetXML :: ParamSet r -> [Content]
paramSetXML :: ParamSet r -> [Content]
paramSetXML = ((VarName, Maybe r) -> Content) -> ParamSet r -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Element -> Content
Elem (Element -> Content)
-> ((VarName, Maybe r) -> Element) -> (VarName, Maybe r) -> Content
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> VarName -> Element
mkEName Text
"attr" (VarName -> Element)
-> ((VarName, Maybe r) -> VarName) -> (VarName, Maybe r) -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VarName, Maybe r) -> VarName
forall a b. (a, b) -> a
fst)