{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Nix.XML (toXML) where

import qualified Data.HashMap.Lazy             as M
import           Data.List
import           Data.Ord
import qualified Data.Text                     as Text
import           Nix.Atoms
import           Nix.Expr.Types
import           Nix.String
import           Nix.Value
import           Text.XML.Light

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
. (t
 -> (NValue t f m -> WithStringContextT Identity Element)
 -> WithStringContextT Identity Element)
-> (NValue' t f m (WithStringContextT Identity Element)
    -> WithStringContextT Identity Element)
-> NValue t f m
-> WithStringContextT Identity Element
forall t (f :: * -> *) (m :: * -> *) r.
MonadDataContext f m =>
(t -> (NValue t f m -> r) -> r)
-> (NValue' t f m r -> r) -> NValue t f m -> r
iterNValue (\_ _ -> 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 (m :: * -> *) a. Monad m => a -> m a
return (Element -> WithStringContextT Identity Element)
-> Element -> WithStringContextT Identity Element
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> Element
mkElem "string" "value" "<CYCLE>"

  pp :: Element -> Text
pp =
    ("<?xml version='1.0' encoding='utf-8'?>\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)
      (Text -> Text) -> (Element -> Text) -> Element -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n")
      (Text -> Text) -> (Element -> Text) -> Element -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack
      (String -> Text) -> (Element -> String) -> Element -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> String
ppElement
      (Element -> String) -> (Element -> Element) -> Element -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\e :: Element
e -> QName -> [Attr] -> [Content] -> Maybe Line -> Element
Element (String -> QName
unqual "expr") [] [Element -> Content
Elem Element
e] Maybe Line
forall a. Maybe a
Nothing)

  phi :: NValue' t f m (WithStringContext Element) -> WithStringContext Element
  phi :: NValue' t f m (WithStringContextT Identity Element)
-> WithStringContextT Identity Element
phi = \case
    NVConstant' a :: NAtom
a -> case NAtom
a of
      NURI   t :: Text
t -> Element -> WithStringContextT Identity Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> WithStringContextT Identity Element)
-> Element -> WithStringContextT Identity Element
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> Element
mkElem "string" "value" (Text -> String
Text.unpack Text
t)
      NInt   n :: Line
n -> Element -> WithStringContextT Identity Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> WithStringContextT Identity Element)
-> Element -> WithStringContextT Identity Element
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> Element
mkElem "int" "value" (Line -> String
forall a. Show a => a -> String
show Line
n)
      NFloat f :: Float
f -> Element -> WithStringContextT Identity Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> WithStringContextT Identity Element)
-> Element -> WithStringContextT Identity Element
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> Element
mkElem "float" "value" (Float -> String
forall a. Show a => a -> String
show Float
f)
      NBool  b :: Bool
b -> Element -> WithStringContextT Identity Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> WithStringContextT Identity Element)
-> Element -> WithStringContextT Identity Element
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> Element
mkElem "bool" "value" (if Bool
b then "true" else "false")
      NNull    -> Element -> WithStringContextT Identity Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> WithStringContextT Identity Element)
-> Element -> WithStringContextT Identity Element
forall a b. (a -> b) -> a -> b
$ QName -> [Attr] -> [Content] -> Maybe Line -> Element
Element (String -> QName
unqual "null") [] [] Maybe Line
forall a. Maybe a
Nothing

    NVStr' str :: NixString
str ->
      String -> String -> String -> Element
mkElem "string" "value" (String -> Element) -> (Text -> String) -> Text -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack (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' l :: [WithStringContextT Identity Element]
l -> [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
      WithStringContextT Identity [Element]
-> ([Element] -> WithStringContextT Identity Element)
-> WithStringContextT Identity Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \els :: [Element]
els -> Element -> WithStringContextT Identity Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> WithStringContextT Identity Element)
-> Element -> WithStringContextT Identity Element
forall a b. (a -> b) -> a -> b
$ QName -> [Attr] -> [Content] -> Maybe Line -> Element
Element (String -> QName
unqual "list") [] (Element -> Content
Elem (Element -> Content) -> [Element] -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Element]
els) Maybe Line
forall a. Maybe a
Nothing

    NVSet' s :: AttrSet (WithStringContextT Identity Element)
s _ -> 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 WithStringContextT Identity (HashMap Text Element)
-> (HashMap Text Element -> WithStringContextT Identity Element)
-> WithStringContextT Identity Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \kvs :: HashMap Text Element
kvs -> Element -> WithStringContextT Identity Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> WithStringContextT Identity Element)
-> Element -> WithStringContextT Identity Element
forall a b. (a -> b) -> a -> b
$ QName -> [Attr] -> [Content] -> Maybe Line -> Element
Element
      (String -> QName
unqual "attrs")
      []
      (((Text, Element) -> Content) -> [(Text, Element)] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map
        (\(k :: Text
k, v :: Element
v) -> Element -> Content
Elem
          (QName -> [Attr] -> [Content] -> Maybe Line -> Element
Element (String -> QName
unqual "attr")
                   [QName -> String -> Attr
Attr (String -> QName
unqual "name") (Text -> String
Text.unpack Text
k)]
                   [Element -> Content
Elem Element
v]
                   Maybe Line
forall a. Maybe a
Nothing
          )
        )
        (((Text, Element) -> (Text, Element) -> Ordering)
-> [(Text, Element)] -> [(Text, Element)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Text, Element) -> Text)
-> (Text, Element) -> (Text, Element) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Text, Element) -> Text
forall a b. (a, b) -> a
fst) ([(Text, Element)] -> [(Text, Element)])
-> [(Text, Element)] -> [(Text, Element)]
forall a b. (a -> b) -> a -> b
$ HashMap Text Element -> [(Text, Element)]
forall k v. HashMap k v -> [(k, v)]
M.toList HashMap Text Element
kvs)
      )
      Maybe Line
forall a. Maybe a
Nothing

    NVClosure' p :: Params ()
p _ ->
      Element -> WithStringContextT Identity Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> WithStringContextT Identity Element)
-> Element -> WithStringContextT Identity Element
forall a b. (a -> b) -> a -> b
$ QName -> [Attr] -> [Content] -> Maybe Line -> Element
Element (String -> QName
unqual "function") [] (Params () -> [Content]
forall r. Params r -> [Content]
paramsXML Params ()
p) Maybe Line
forall a. Maybe a
Nothing
    NVPath' fp :: String
fp        -> Element -> WithStringContextT Identity Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> WithStringContextT Identity Element)
-> Element -> WithStringContextT Identity Element
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> Element
mkElem "path" "value" String
fp
    NVBuiltin' name :: String
name _ -> Element -> WithStringContextT Identity Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> WithStringContextT Identity Element)
-> Element -> WithStringContextT Identity Element
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> Element
mkElem "function" "name" String
name
    _                 -> String -> WithStringContextT Identity Element
forall a. HasCallStack => String -> a
error "Pattern synonyms mask coverage"

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

paramsXML :: Params r -> [Content]
paramsXML :: Params r -> [Content]
paramsXML (Param name :: Text
name) = [Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> Element
mkElem "varpat" "name" (Text -> String
Text.unpack Text
name)]
paramsXML (ParamSet s :: ParamSet r
s b :: Bool
b mname :: Maybe Text
mname) =
  [Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ QName -> [Attr] -> [Content] -> Maybe Line -> Element
Element (String -> QName
unqual "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 Line
forall a. Maybe a
Nothing]
 where
  battr :: [Attr]
battr = [ QName -> String -> Attr
Attr (String -> QName
unqual "ellipsis") "1" | Bool
b ]
  nattr :: [Attr]
nattr = [Attr] -> (Text -> [Attr]) -> Maybe Text -> [Attr]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Attr -> [Attr] -> [Attr]
forall a. a -> [a] -> [a]
: []) (Attr -> [Attr]) -> (Text -> Attr) -> Text -> [Attr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> String -> Attr
Attr (String -> QName
unqual "name") (String -> Attr) -> (Text -> String) -> Text -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack) Maybe Text
mname

paramSetXML :: ParamSet r -> [Content]
paramSetXML :: ParamSet r -> [Content]
paramSetXML = ((Text, Maybe r) -> Content) -> ParamSet r -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map (\(k :: Text
k, _) -> Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> Element
mkElem "attr" "name" (Text -> String
Text.unpack Text
k))