-- | Pretty-print text (DTA) files with the HughesPJ library.
module Data.DTA.PrettyPrint (sToDTA) where

import qualified Data.ByteString.Char8     as B8
import           Data.Char                 (isAlphaNum)
import qualified Text.PrettyPrint.HughesPJ as PP

import           Data.DTA.Base

ppChunk :: Chunk -> PP.Doc
ppChunk :: Chunk -> Doc
ppChunk Chunk
c = case Chunk
c of
  Int Int32
i -> String -> Doc
PP.text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Int32 -> String
forall a. Show a => a -> String
show Int32
i
  Float Float
f -> String -> Doc
PP.text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Float -> String
forall a. Show a => a -> String
show Float
f
  Var ByteString
t -> [Doc] -> Doc
PP.hcat [Char -> Doc
PP.char Char
'$', ByteString -> Doc
ppText ByteString
t]
  Sym ByteString
t -> String -> Doc
PP.text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String -> String
ppSym (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> String
B8.unpack ByteString
t
  Chunk
Unhandled -> String -> Doc
PP.text String
"kDataUnhandled"
  IfDef ByteString
t -> [Doc] -> Doc
PP.hsep [String -> Doc
PP.text String
"#ifdef", ByteString -> Doc
ppText ByteString
t]
  Chunk
Else -> String -> Doc
PP.text String
"#else"
  Chunk
EndIf -> String -> Doc
PP.text String
"#endif"
  Parens Tree
tr -> Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Tree -> Doc
ppTree Tree
tr
  Braces Tree
tr -> Doc -> Doc
PP.braces (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Tree -> Doc
ppTree Tree
tr
  String ByteString
t -> String -> Doc
PP.text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String -> String
doubleQuotedString (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> String
B8.unpack ByteString
t
  Brackets Tree
tr -> Doc -> Doc
PP.brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Tree -> Doc
ppTree Tree
tr
  Define ByteString
t -> [Doc] -> Doc
PP.hsep [String -> Doc
PP.text String
"#define", ByteString -> Doc
ppText ByteString
t]
  Include ByteString
t -> [Doc] -> Doc
PP.hsep [String -> Doc
PP.text String
"#include", ByteString -> Doc
ppText ByteString
t]
  Merge ByteString
t -> [Doc] -> Doc
PP.hsep [String -> Doc
PP.text String
"#merge", ByteString -> Doc
ppText ByteString
t]
  IfNDef ByteString
t -> [Doc] -> Doc
PP.hsep [String -> Doc
PP.text String
"#ifndef", ByteString -> Doc
ppText ByteString
t]
  Chunk
Autorun -> String -> Doc
PP.text String
"#autorun"
  Undef ByteString
t -> [Doc] -> Doc
PP.hsep [String -> Doc
PP.text String
"#undef", ByteString -> Doc
ppText ByteString
t]
  where ppText :: ByteString -> Doc
ppText = String -> Doc
PP.text (String -> Doc) -> (ByteString -> String) -> ByteString -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B8.unpack

doubleQuotedString :: String -> String
doubleQuotedString :: String -> String
doubleQuotedString String
t = let
  f :: Char -> String
f Char
'"'  = String
"\\q"
  f Char
'\n' = String
"\\n"
  f Char
'\\' = String
"\\\\"
  f Char
ch   = [Char
ch]
  in String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
f String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""

-- | Automatically chooses between horizontal and vertical arrangements,
-- depending on what kind of chunks are in the tree.
ppTree :: Tree -> PP.Doc
ppTree :: Tree -> Doc
ppTree (Tree Word32
_ [Chunk]
chks)
  | (Chunk -> Bool) -> [Chunk] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Chunk -> Bool
simpleChunk [Chunk]
chks = [Doc] -> Doc
PP.hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Chunk -> Doc) -> [Chunk] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Chunk -> Doc
ppChunk [Chunk]
chks
  | Bool
otherwise            = [Doc] -> Doc
PP.vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Chunk -> Doc) -> [Chunk] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Chunk -> Doc
ppChunk [Chunk]
chks
  where simpleChunk :: Chunk -> Bool
simpleChunk Chunk
c = case Chunk
c of
          Int Int32
_     -> Bool
True
          Float Float
_   -> Bool
True
          Var ByteString
_     -> Bool
True
          Sym ByteString
_     -> Bool
True
          Chunk
Unhandled -> Bool
True
          Chunk
_         -> Bool
False

-- | Produces a raw symbol or single-quoted symbol literal.
ppSym :: String -> String
ppSym :: String -> String
ppSym String
s
  | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c String
"_/.-=#<>&!") String
s Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) = String
s
  | Bool
otherwise = let
    f :: Char -> String
f Char
'\'' = String
"\\q"
    f Char
'\n' = String
"\\n"
    f Char
'\\' = String
"\\\\"
    f Char
ch   = [Char
ch]
    in String
"'" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
f String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"'"

ppDTA :: DTA -> PP.Doc
ppDTA :: DTA -> Doc
ppDTA = [Doc] -> Doc
PP.vcat ([Doc] -> Doc) -> (DTA -> [Doc]) -> DTA -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chunk -> Doc) -> [Chunk] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Chunk -> Doc
ppChunk ([Chunk] -> [Doc]) -> (DTA -> [Chunk]) -> DTA -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree -> [Chunk]
treeChunks (Tree -> [Chunk]) -> (DTA -> Tree) -> DTA -> [Chunk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DTA -> Tree
topTree

sToDTA :: DTA -> String
sToDTA :: DTA -> String
sToDTA = Doc -> String
PP.render (Doc -> String) -> (DTA -> Doc) -> DTA -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DTA -> Doc
ppDTA