{-# OPTIONS -fglasgow-exts #-}
{-# language OverloadedStrings #-}

module Autolib.Multilingual.Doc 

( Doc
, renderStyle, render, render_for
, renderStyleT, renderT, renderT_for
, putDoc, hPutDoc
, text, multitext
, text_
, vcat, hcat, cat, fsep, hsep, sep, vsep, empty
, nest, nest_noskip, indent, parens, brackets, braces
, char, int, integer, double, float
, (<+>), (<>), ($$), ($+$)
, (<+.>), (<.>)
, encloseSep, align
, punctuate, doubleQuotes
, skip, equals, comma, colon, semi
, group, line, softline, linebreak, softbreak
, fill, fillBreak
)


where

import Autolib.Multilingual
import Autolib.Multilingual.Doc.Style
-- but it's not exported, in order to not confuse clients

-- import qualified Text.PrettyPrint.HughesPJ as PP
-- import qualified Text.PrettyPrint.Leijen.Text as PP
import qualified Text.PrettyPrint.Dent as PP
import Data.String

import qualified Data.Text.Lazy as TL
import qualified Data.Text as T
import qualified Data.Text.Lazy.IO as TL
import System.IO (stdout)

import qualified Data.Map
import Data.Map ( Map )
import Data.List ( nub )
import Data.Monoid

----------------------------------------------------------------
-- Types


{-# deprecated renderStyle "use renderStyleT instead" #-}

renderStyle :: Style -> PP.Doc -> String
renderStyle :: Style -> Doc -> String
renderStyle Style
st Doc
doc = Text -> String
TL.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Style -> Doc -> Text
renderStyleT Style
st Doc
doc

renderStyleT :: Style -> PP.Doc -> TL.Text
renderStyleT :: Style -> Doc -> Text
renderStyleT Style
st Doc
doc = SimpleDoc -> Text
PP.displayT (SimpleDoc -> Text) -> SimpleDoc -> Text
forall a b. (a -> b) -> a -> b
$ case Style
st of
    Style
Compact -> Doc -> SimpleDoc
PP.renderCompact Doc
doc
    Style
Wide -> Doc -> SimpleDoc
PP.renderWide Doc
doc
    Style
Flat -> Doc -> SimpleDoc
PP.renderFlat Doc
doc
    Style
Pretty -> Double -> Integer -> Doc -> SimpleDoc
forall {p1} {p2}. p1 -> p2 -> Doc -> SimpleDoc
PP.renderPretty Double
0.4 Integer
80 Doc
doc 

type Doc = Autolib.Multilingual.Type PP.Doc

render :: Type Doc -> String
render = Language -> Type Doc -> String
render_for Language
DE
render_for :: Language -> Type Doc -> String
render_for Language
lang = Style -> Doc -> String
renderStyle Style
Pretty (Doc -> String) -> (Type Doc -> Doc) -> Type Doc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Language -> Type Doc -> Doc
forall a. Language -> Type a -> a
specialize Language
lang

renderT :: Type Doc -> Text
renderT = Language -> Type Doc -> Text
renderT_for Language
DE
renderT_for :: Language -> Type Doc -> Text
renderT_for Language
lang = Style -> Doc -> Text
renderStyleT Style
Pretty (Doc -> Text) -> (Type Doc -> Doc) -> Type Doc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Language -> Type Doc -> Doc
forall a. Language -> Type a -> a
specialize Language
lang

instance Show Doc where show :: Type Doc -> String
show = Type Doc -> String
render

putDocFor :: Language -> Type Doc -> IO ()
putDocFor Language
l = Language -> Handle -> Type Doc -> IO ()
hPutDocFor Language
l Handle
stdout
putDoc :: Type Doc -> IO ()
putDoc = Language -> Type Doc -> IO ()
putDocFor Language
DE

hPutDocFor :: Language -> Handle -> Type Doc -> IO ()
hPutDocFor Language
l Handle
h = Handle -> Text -> IO ()
TL.hPutStrLn Handle
h (Text -> IO ()) -> (Type Doc -> Text) -> Type Doc -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Language -> Type Doc -> Text
renderT_for Language
l
hPutDoc :: Handle -> Type Doc -> IO ()
hPutDoc = Language -> Handle -> Type Doc -> IO ()
hPutDocFor Language
DE

----------------------------------------------------------------
-- Accessors, Constructors

-- | for all languages
text :: String -> Doc
text :: String -> Type Doc
text = Doc -> Type Doc
forall {a}. a -> Type a
uniform (Doc -> Type Doc) -> (String -> Doc) -> String -> Type Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
forall a. IsString a => String -> a
fromString

-- | use several languages
multitext :: [(Language, String)] -> Doc
multitext :: [(Language, String)] -> Type Doc
multitext = [(Language, Doc)] -> Type Doc
forall a. [(Language, a)] -> Type a
Autolib.Multilingual.make 
          ([(Language, Doc)] -> Type Doc)
-> ([(Language, String)] -> [(Language, Doc)])
-> [(Language, String)]
-> Type Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Language, String) -> (Language, Doc))
-> [(Language, String)] -> [(Language, Doc)]
forall a b. (a -> b) -> [a] -> [b]
map ( \ ( Language
l, String
cs ) -> ( Language
l, String -> Doc
forall a. IsString a => String -> a
fromString String
cs ) )

text_ :: T.Text -> Doc
text_ :: Text -> Type Doc
text_ = Doc -> Type Doc
forall {a}. a -> Type a
uniform (Doc -> Type Doc) -> (Text -> Doc) -> Text -> Type Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc
PP.textStrict

multitext_ :: [(Language, T.Text)] -> Doc
multitext_ :: [(Language, Text)] -> Type Doc
multitext_ = [(Language, Doc)] -> Type Doc
forall a. [(Language, a)] -> Type a
Autolib.Multilingual.make 
          ([(Language, Doc)] -> Type Doc)
-> ([(Language, Text)] -> [(Language, Doc)])
-> [(Language, Text)]
-> Type Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Language, Text) -> (Language, Doc))
-> [(Language, Text)] -> [(Language, Doc)]
forall a b. (a -> b) -> [a] -> [b]
map ( \ ( Language
l, Text
cs ) -> ( Language
l, Text -> Doc
PP.textStrict Text
cs ) )



-- | put side by side, and @align@ the right argument
<+> :: Type Doc -> Type Doc -> Type Doc
(<+>) = (Doc -> Doc -> Doc) -> Type Doc -> Type Doc -> Type Doc
forall a. (a -> a -> a) -> Type a -> Type a -> Type a
fold_binary ( \ Doc
l Doc
r -> Doc
l Doc -> Doc -> Doc
PP.<+> ( {- PP.align -} Doc
r) )

instance Semigroup Doc where
  <> :: Type Doc -> Type Doc -> Type Doc
(<>) = (Doc -> Doc -> Doc) -> Type Doc -> Type Doc -> Type Doc
forall a. (a -> a -> a) -> Type a -> Type a -> Type a
fold_binary ( \ Doc
l Doc
r -> Doc
l Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>  ( {- PP.align -} Doc
r) )
  
instance Monoid Doc where
  mempty :: Type Doc
mempty = Type Doc
empty
  mappend :: Type Doc -> Type Doc -> Type Doc
mappend = Type Doc -> Type Doc -> Type Doc
forall a. Semigroup a => a -> a -> a
(<>)

-- | put side by side, without alignment (you don't want to use this, mostly)
(<+.>) :: Doc -> Doc -> Doc
<+.> :: Type Doc -> Type Doc -> Type Doc
(<+.>) = (Doc -> Doc -> Doc) -> Type Doc -> Type Doc -> Type Doc
forall a. (a -> a -> a) -> Type a -> Type a -> Type a
fold_binary Doc -> Doc -> Doc
(PP.<+>)
(<.>) :: Doc -> Doc -> Doc
<.> :: Type Doc -> Type Doc -> Type Doc
(<.>) = (Doc -> Doc -> Doc) -> Type Doc -> Type Doc -> Type Doc
forall a. (a -> a -> a) -> Type a -> Type a -> Type a
fold_binary Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
(<>)


$$ :: Type Doc -> Type Doc -> Type Doc
($$) = (Doc -> Doc -> Doc) -> Type Doc -> Type Doc -> Type Doc
forall a. (a -> a -> a) -> Type a -> Type a -> Type a
fold_binary Doc -> Doc -> Doc
(PP.<$$>)
$+$ :: Type Doc -> Type Doc -> Type Doc
($+$) = (Doc -> Doc -> Doc) -> Type Doc -> Type Doc -> Type Doc
forall a. (a -> a -> a) -> Type a -> Type a -> Type a
fold_binary Doc -> Doc -> Doc
(PP.<//>)

vcat :: [Type Doc] -> Type Doc
vcat = ([Doc] -> Doc) -> [Type Doc] -> Type Doc
forall a b. ([a] -> b) -> [Type a] -> Type b
fold_list ( [Doc] -> Doc
PP.vcat  )
hcat :: [Type Doc] -> Type Doc
hcat = ([Doc] -> Doc) -> [Type Doc] -> Type Doc
forall a b. ([a] -> b) -> [Type a] -> Type b
fold_list ( [Doc] -> Doc
PP.hcat  )
cat :: [Type Doc] -> Type Doc
cat  = ([Doc] -> Doc) -> [Type Doc] -> Type Doc
forall a b. ([a] -> b) -> [Type a] -> Type b
fold_list ( [Doc] -> Doc
PP.cat   )

group :: Type Doc -> Type Doc
group = (Doc -> Doc) -> Type Doc -> Type Doc
forall a b. (a -> b) -> Type a -> Type b
fold_unary Doc -> Doc
PP.group
-- group = id

fsep :: [Type Doc] -> Type Doc
fsep = ([Doc] -> Doc) -> [Type Doc] -> Type Doc
forall a b. ([a] -> b) -> [Type a] -> Type b
fold_list ( [Doc] -> Doc
PP.fillSep )
-- http://stackoverflow.com/a/23656188/2868481
{-
fsep xs = case xs of
    [] -> fold_nullary PP.empty
    _  -> fold_list ( foldl1 (\x y -> x PP.<> (PP.group $ PP.line PP.<> y) ) ) xs
-}

hsep :: [Type Doc] -> Type Doc
hsep = ([Doc] -> Doc) -> [Type Doc] -> Type Doc
forall a b. ([a] -> b) -> [Type a] -> Type b
fold_list ( [Doc] -> Doc
PP.hsep )
vsep :: [Type Doc] -> Type Doc
vsep  = ([Doc] -> Doc) -> [Type Doc] -> Type Doc
forall a b. ([a] -> b) -> [Type a] -> Type b
fold_list ( [Doc] -> Doc
PP.vsep )
sep :: [Type Doc] -> Type Doc
sep  = ([Doc] -> Doc) -> [Type Doc] -> Type Doc
forall a b. ([a] -> b) -> [Type a] -> Type b
fold_list ( [Doc] -> Doc
PP.sep )

nest_noskip :: a -> Type Doc -> Type Doc
nest_noskip a
d = (Doc -> Doc) -> Type Doc -> Type Doc
forall a b. (a -> b) -> Type a -> Type b
fold_unary ( a -> Doc -> Doc
forall {a}. Integral a => a -> Doc -> Doc
PP.nest a
d )
nest :: a -> Type Doc -> Type Doc
nest a
d = (Doc -> Doc) -> Type Doc -> Type Doc
forall a b. (a -> b) -> Type a -> Type b
fold_unary (a -> Doc -> Doc
forall {a}. Integral a => a -> Doc -> Doc
PP.nest a
d (Doc -> Doc) -> (Doc -> Doc) -> Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc
PP.skip Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>))
indent :: Integer -> Type Doc -> Type Doc
indent Integer
d = (Doc -> Doc) -> Type Doc -> Type Doc
forall a b. (a -> b) -> Type a -> Type b
fold_unary ( Integer -> Doc -> Doc
PP.indent Integer
d )
parens :: Type Doc -> Type Doc
parens = (Doc -> Doc) -> Type Doc -> Type Doc
forall a b. (a -> b) -> Type a -> Type b
fold_unary Doc -> Doc
PP.parens
brackets :: Type Doc -> Type Doc
brackets = (Doc -> Doc) -> Type Doc -> Type Doc
forall a b. (a -> b) -> Type a -> Type b
fold_unary Doc -> Doc
PP.brackets
braces :: Type Doc -> Type Doc
braces = (Doc -> Doc) -> Type Doc -> Type Doc
forall a b. (a -> b) -> Type a -> Type b
fold_unary Doc -> Doc
PP.braces
doubleQuotes :: Type Doc -> Type Doc
doubleQuotes = (Doc -> Doc) -> Type Doc -> Type Doc
forall a b. (a -> b) -> Type a -> Type b
fold_unary Doc -> Doc
PP.dquotes

punctuate :: t -> [t] -> [t]
punctuate t
x [] = []
punctuate t
x [t
y] = [t
y]
punctuate t
x (t
y : [t]
ys) = t
y t -> t -> t
forall a. Semigroup a => a -> a -> a
<> t
x t -> [t] -> [t]
forall a. a -> [a] -> [a]
: t -> [t] -> [t]
punctuate t
x [t]
ys

align :: Type b -> Type b
align = (b -> b) -> Type b -> Type b
forall a b. (a -> b) -> Type a -> Type b
fold_unary ( b -> b
forall {a}. a -> a
PP.align )

encloseSep :: Type ([b] -> a)
-> Type ([b] -> a) -> Type ([b] -> a) -> [Type b] -> Type a
encloseSep Type ([b] -> a)
left Type ([b] -> a)
right Type ([b] -> a)
sep [Type b]
docs = [(Language, a)] -> Type a
forall a. [(Language, a)] -> Type a
make ([(Language, a)] -> Type a) -> [(Language, a)] -> Type a
forall a b. (a -> b) -> a -> b
$ do 
    l <- [ Language
forall a. Bounded a => a
minBound .. Language
forall a. Bounded a => a
maxBound ]
    return ( l
           , PP.encloseSep (specialize l left)(specialize l right)(specialize l sep)
                              (map (specialize l) docs) 
           )

skip :: Type Doc
skip = Doc -> Type Doc
forall {a}. a -> Type a
uniform Doc
PP.skip
comma :: Type Doc
comma = Doc -> Type Doc
forall {a}. a -> Type a
uniform Doc
PP.comma
colon :: Type Doc
colon = Doc -> Type Doc
forall {a}. a -> Type a
uniform Doc
PP.colon
semi :: Type Doc
semi = Doc -> Type Doc
forall {a}. a -> Type a
uniform Doc
PP.semi
equals :: Type Doc
equals = Doc -> Type Doc
forall {a}. a -> Type a
uniform Doc
PP.equals
char :: Char -> Type a
char Char
c = a -> Type a
forall {a}. a -> Type a
uniform ( Char -> a
forall {a}. IsString a => Char -> a
PP.char Char
c )

line :: Type Doc
line = Doc -> Type Doc
forall {a}. a -> Type a
uniform Doc
PP.line
softline :: Type Doc
softline = Doc -> Type Doc
forall {a}. a -> Type a
uniform Doc
PP.softline
linebreak :: Type Doc
linebreak = Doc -> Type Doc
forall {a}. a -> Type a
uniform Doc
PP.linebreak
softbreak :: Type Doc
softbreak = Doc -> Type Doc
forall {a}. a -> Type a
uniform Doc
PP.softbreak

fill :: Type (p -> a -> a)
fill = (p -> a -> a) -> Type (p -> a -> a)
forall {a}. a -> Type a
uniform p -> a -> a
forall {p} {a}. p -> a -> a
PP.fill
fillBreak :: Int -> Doc -> Doc
fillBreak :: Int -> Type Doc -> Type Doc
fillBreak Int
i = (Doc -> Doc) -> Type Doc -> Type Doc
forall a b. (a -> b) -> Type a -> Type b
fold_unary (Int -> Doc -> Doc
forall {p} {a}. p -> a -> a
PP.fillBreak Int
i)

int :: Int -> Type Doc
int = Doc -> Type Doc
forall {a}. a -> Type a
uniform (Doc -> Type Doc) -> (Int -> Doc) -> Int -> Type Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc
PP.int
integer :: Integer -> Type Doc
integer = Doc -> Type Doc
forall {a}. a -> Type a
uniform (Doc -> Type Doc) -> (Integer -> Doc) -> Integer -> Type Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Doc
PP.integer
float :: Float -> Type Doc
float = Doc -> Type Doc
forall {a}. a -> Type a
uniform (Doc -> Type Doc) -> (Float -> Doc) -> Float -> Type Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Doc
PP.float
double :: Double -> Type Doc
double = Doc -> Type Doc
forall {a}. a -> Type a
uniform (Doc -> Type Doc) -> (Double -> Doc) -> Double -> Type Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Doc
PP.double

empty :: Type Doc
empty = Doc -> Type Doc
forall {a}. a -> Type a
uniform Doc
PP.empty