module Agda.Compiler.JS.Pretty where

import Data.Char ( isAsciiLower, isAsciiUpper, isDigit )
import Data.List ( intercalate )
import Data.String ( IsString (fromString) )
import Data.Semigroup ( Semigroup, (<>) )
import Data.Set ( Set, toList, singleton, insert, member )
import qualified Data.Set as Set
import Data.Map ( Map, toAscList, empty, null )
import qualified Data.Text as T

import Agda.Syntax.Common ( Nat )

import Agda.Utils.Hash
import Agda.Utils.List ( indexWithDefault )
import Agda.Utils.List1 ( List1, pattern (:|), (<|) )
import qualified Agda.Utils.List1 as List1

import Agda.Utils.Impossible

import Agda.Compiler.JS.Syntax hiding (exports)

-- Pretty-print a lambda-calculus expression as ECMAScript.

--- The indentation combinators of the pretty library does not fit C-like languages
--- like ECMAScript.
--- A simple pretty printer is implemented with a better `indent` and punctuation compaction.
---
--- More explanation:
---
--- I have struggled with different pretty printers, and at the end it was much easier
--- to implement and use this ~100 SLOC code pretty printer library.
--- It produces really better quality indentation than I could achieve with the
--  standard pretty printers.
--- This library code is only used in this module, and it is specialized to pretty
--- print JavaScript code for the Agda backend, so I think its best place is in this module.
data Doc
    = Doc String
    | Indent Int Doc
    | Group Doc
    | Beside Doc Doc
    | Above Doc Doc
    | Enclose Doc Doc Doc
    | Space
    | Empty

minifiedCodeLinesLength :: Int
minifiedCodeLinesLength :: Int
minifiedCodeLinesLength = Int
500

render :: Bool -> Doc -> String
render :: Bool -> Doc -> [Char]
render Bool
minify = forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [[Char]]
joinLines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> [Char] -> [Char]
mkIndent) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc -> [(Int, [Char])]
go Int
0
  where
    joinLines :: [String] -> [String]
    joinLines :: [[Char]] -> [[Char]]
joinLines = if Bool
minify then forall {a}. Int -> [[a]] -> [[a]] -> [[a]]
chunks Int
0 [] else forall a. a -> a
id
      where
        chunks :: Int -> [[a]] -> [[a]] -> [[a]]
chunks Int
len [[a]]
acc [] = [forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. [a] -> [a]
reverse [[a]]
acc)]
        chunks Int
len [[a]]
acc ([a]
s: [[a]]
ss)
            | Int
len forall a. Num a => a -> a -> a
+ Int
n forall a. Ord a => a -> a -> Bool
<= Int
minifiedCodeLinesLength = Int -> [[a]] -> [[a]] -> [[a]]
chunks (Int
len forall a. Num a => a -> a -> a
+ Int
n) ([a]
sforall a. a -> [a] -> [a]
: [[a]]
acc) [[a]]
ss
            | Bool
otherwise = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. [a] -> [a]
reverse [[a]]
acc)forall a. a -> [a] -> [a]
: Int -> [[a]] -> [[a]] -> [[a]]
chunks Int
n [[a]
s] [[a]]
ss
          where
            n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
s

    joinBy :: (a -> a -> [a]) -> [a] -> [a] -> [a]
joinBy a -> a -> [a]
f [a
x] (a
y: [a]
ys) = a -> a -> [a]
f a
x a
y forall a. [a] -> [a] -> [a]
++ [a]
ys
    joinBy a -> a -> [a]
f (a
x:[a]
xs) [a]
ys = a
xforall a. a -> [a] -> [a]
: (a -> a -> [a]) -> [a] -> [a] -> [a]
joinBy a -> a -> [a]
f [a]
xs [a]
ys
    joinBy a -> a -> [a]
f [a]
xs [a]
ys = [a]
xs forall a. [a] -> [a] -> [a]
++ [a]
ys

    mkIndent :: Int -> [Char] -> [Char]
mkIndent Int
n [Char]
s | Bool
minify = [Char]
s
    mkIndent Int
n [Char]
"" = [Char]
""
    mkIndent Int
n [Char]
s = forall a. Int -> a -> [a]
replicate Int
n Char
' ' forall a. [a] -> [a] -> [a]
++ [Char]
s

    overlay :: (Int, [Char]) -> (Int, [Char]) -> [(Int, [Char])]
overlay (Int
i, [Char]
s) (Int
j, [Char]
s') | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
punctuation ([Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
s') Bool -> Bool -> Bool
&& Int
n forall a. Ord a => a -> a -> Bool
> Int
0 = [(Int
i, [Char]
s forall a. [a] -> [a] -> [a]
++ Int -> [Char] -> [Char]
mkIndent Int
n [Char]
s')]
      where n :: Int
n = Int
j forall a. Num a => a -> a -> a
- (Int
i forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s)
    overlay (Int
j, [Char]
s') (Int
i, [Char]
s) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
punctuation ([Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
s') Bool -> Bool -> Bool
&& Int
n forall a. Ord a => a -> a -> Bool
> Int
0 = [(Int
i, [Char]
s' forall a. [a] -> [a] -> [a]
++ Int -> [Char] -> [Char]
mkIndent Int
n [Char]
s)]
      where n :: Int
n = Int
j forall a. Num a => a -> a -> a
- (Int
i forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s)
    overlay (Int, [Char])
a (Int, [Char])
b = [(Int, [Char])
a, (Int, [Char])
b]

    punctuation :: Char -> Bool
punctuation = (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"(){}[];:, " :: String))

    go :: Int -> Doc -> [(Int, [Char])]
go Int
i Doc
Space = if Bool
minify then [] else [(Int
i, [Char]
" ")]
    go Int
i Doc
Empty = []
    go Int
i (Doc [Char]
s) = [(Int
i, [Char]
s)]
    go Int
i (Beside Doc
d Doc
d') = forall {a}. (a -> a -> [a]) -> [a] -> [a] -> [a]
joinBy (\(Int
i, [Char]
s) (Int
_, [Char]
s') -> [(Int
i, [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
s')]) (Int -> Doc -> [(Int, [Char])]
go Int
i Doc
d) (Int -> Doc -> [(Int, [Char])]
go Int
i Doc
d')
    go Int
i (Above Doc
d Doc
d') = forall {a}. (a -> a -> [a]) -> [a] -> [a] -> [a]
joinBy (Int, [Char]) -> (Int, [Char]) -> [(Int, [Char])]
overlay (Int -> Doc -> [(Int, [Char])]
go Int
i Doc
d) (Int -> Doc -> [(Int, [Char])]
go Int
i Doc
d')
    go Int
i (Indent Int
j Doc
d) = Int -> Doc -> [(Int, [Char])]
go (Int
iforall a. Num a => a -> a -> a
+Int
j) Doc
d
    go Int
i (Enclose Doc
open Doc
close Doc
d) = Int -> Doc -> [(Int, [Char])]
go Int
i forall a b. (a -> b) -> a -> b
$ Doc -> Doc
Group forall a b. (a -> b) -> a -> b
$ Doc -> Doc -> Doc
Above Doc
open forall a b. (a -> b) -> a -> b
$ Doc -> Doc -> Doc
Above Doc
d Doc
close
    go Int
i (Group Doc
d)
        | forall {a} {a}. [(a, [a])] -> Int
size [(Int, [Char])]
ss forall a. Ord a => a -> a -> Bool
< Int
40 = forall {a} {a}. [(a, [a])] -> [(a, [a])]
compact [(Int, [Char])]
ss
        | Bool
otherwise    = [(Int, [Char])]
ss
      where
        ss :: [(Int, [Char])]
ss = Int -> Doc -> [(Int, [Char])]
go Int
i Doc
d
        size :: [(a, [a])] -> Int
size = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
        compact :: [(a, [a])] -> [(a, [a])]
compact [] = []
        compact ((a
i, [a]
x): [(a, [a])]
xs) = [(a
i, [a]
x forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd [(a, [a])]
xs)]

instance IsString Doc where
    fromString :: [Char] -> Doc
fromString = [Char] -> Doc
Doc

instance Semigroup Doc where
    Doc
Empty <> :: Doc -> Doc -> Doc
<> Doc
d = Doc
d
    Doc
d <> Doc
Empty = Doc
d
    Doc
d <> Doc
d' = Doc -> Doc -> Doc
Beside Doc
d Doc
d'

instance Monoid Doc where
    mempty :: Doc
mempty = Doc
Empty
    mappend :: Doc -> Doc -> Doc
mappend = forall a. Semigroup a => a -> a -> a
(<>)

infixr 5 $+$
infixr 5 $++$
infixr 6 <+>  -- fixity has to match the one of Semigroup.(<>)

($+$) :: Doc -> Doc -> Doc
Doc
Empty $+$ :: Doc -> Doc -> Doc
$+$ Doc
d = Doc
d
Doc
d $+$ Doc
Empty = Doc
d
Doc
d $+$ Doc
d' = Doc -> Doc -> Doc
Above Doc
d Doc
d'

-- | Separate by blank line.

($++$) :: Doc -> Doc -> Doc
Doc
Empty $++$ :: Doc -> Doc -> Doc
$++$ Doc
d = Doc
d
Doc
d $++$ Doc
Empty = Doc
d
Doc
d $++$ Doc
d' = Doc
d Doc -> Doc -> Doc
`Above` Doc
"" Doc -> Doc -> Doc
`Above` Doc
d'

-- | Separate by space that will be removed by minify.
--
-- For non-removable space, use @d <> " " <> d'@.

(<+>) :: Doc -> Doc -> Doc
Doc
Empty <+> :: Doc -> Doc -> Doc
<+> Doc
d = Doc
d
Doc
d <+> Doc
Empty = Doc
d
Doc
d <+> Doc
d' = Doc
d Doc -> Doc -> Doc
`Beside` Doc
Space Doc -> Doc -> Doc
`Beside` Doc
d'

text :: String -> Doc
text :: [Char] -> Doc
text = [Char] -> Doc
Doc

group :: Doc -> Doc
group :: Doc -> Doc
group = Doc -> Doc
Group

indentBy :: Int -> Doc -> Doc
indentBy :: Int -> Doc -> Doc
indentBy Int
i Doc
Empty = Doc
Empty
indentBy Int
i (Indent Int
j Doc
d) = Int -> Doc -> Doc
Indent (Int
iforall a. Num a => a -> a -> a
+Int
j) Doc
d
indentBy Int
i Doc
d = Int -> Doc -> Doc
Indent Int
i Doc
d

enclose :: Doc -> Doc -> Doc -> Doc
enclose :: Doc -> Doc -> Doc -> Doc
enclose Doc
open Doc
close (Enclose Doc
o Doc
c Doc
d) = Doc -> Doc -> Doc -> Doc
Enclose (Doc
open forall a. Semigroup a => a -> a -> a
<> Doc
o) (Doc
c forall a. Semigroup a => a -> a -> a
<> Doc
close) Doc
d
enclose Doc
open Doc
close (Indent Int
_ (Enclose Doc
o Doc
c Doc
d)) = Doc -> Doc -> Doc -> Doc
Enclose (Doc
open forall a. Semigroup a => a -> a -> a
<> Doc
o) (Doc
c forall a. Semigroup a => a -> a -> a
<> Doc
close) Doc
d
enclose Doc
open Doc
close Doc
d = Doc -> Doc -> Doc -> Doc
Enclose Doc
open Doc
close Doc
d

----------------------------------------------------------------------------------------------

space :: Doc
space :: Doc
space = Doc
Space

indent :: Doc -> Doc
indent :: Doc -> Doc
indent = Int -> Doc -> Doc
indentBy Int
2

hcat :: [Doc] -> Doc
hcat :: [Doc] -> Doc
hcat = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Semigroup a => a -> a -> a
(<>) forall a. Monoid a => a
mempty

vcat :: [Doc] -> Doc
vcat :: [Doc] -> Doc
vcat = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Doc -> Doc -> Doc
($+$) forall a. Monoid a => a
mempty

-- | Concatenate vertically, separated by blank lines.

vsep :: [Doc] -> Doc
vsep :: [Doc] -> Doc
vsep = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Doc -> Doc -> Doc
($++$) forall a. Monoid a => a
mempty

punctuate :: Doc -> [Doc] -> Doc
punctuate :: Doc -> [Doc] -> Doc
punctuate Doc
_ []     = forall a. Monoid a => a
mempty
punctuate Doc
p (Doc
x:[Doc]
xs) = Doc -> Doc
indent forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
go Doc
x [Doc]
xs
                   where go :: Doc -> [Doc] -> [Doc]
go Doc
y []     = [Doc
y]
                         go Doc
y (Doc
z:[Doc]
zs) = (Doc
y forall a. Semigroup a => a -> a -> a
<> Doc
p) forall a. a -> [a] -> [a]
: Doc -> [Doc] -> [Doc]
go Doc
z [Doc]
zs

parens, brackets, braces :: Doc -> Doc
parens :: Doc -> Doc
parens   = Doc -> Doc -> Doc -> Doc
enclose Doc
"(" Doc
")"
brackets :: Doc -> Doc
brackets = Doc -> Doc -> Doc -> Doc
enclose Doc
"[" Doc
"]"
braces :: Doc -> Doc
braces   = Doc -> Doc -> Doc -> Doc
enclose Doc
"{" Doc
"}"

-- | Apply 'parens' to 'Doc' if boolean is true.
mparens :: Bool -> Doc -> Doc
mparens :: Bool -> Doc -> Doc
mparens Bool
True  Doc
d = Doc -> Doc
parens Doc
d
mparens Bool
False Doc
d = Doc
d

----------------------------------------------------------------------------------------------

unescape :: Char -> String
unescape :: Char -> [Char]
unescape Char
'"'      = [Char]
"\\\""
unescape Char
'\\'     = [Char]
"\\\\"
unescape Char
'\n'     = [Char]
"\\n"
unescape Char
'\r'     = [Char]
"\\r"
unescape Char
'\x2028' = [Char]
"\\u2028"
unescape Char
'\x2029' = [Char]
"\\u2029"
unescape Char
c        = [Char
c]

unescapes :: String -> Doc
unescapes :: [Char] -> Doc
unescapes [Char]
s = [Char] -> Doc
text forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> [Char]
unescape [Char]
s

-- pretty (n,b) i e pretty-prints e, under n levels of de Bruijn binding
--   if b is true then the output is minified

class Pretty a where
    pretty :: (Nat, Bool) -> a -> Doc

prettyShow :: Pretty a => Bool -> a -> String
prettyShow :: forall a. Pretty a => Bool -> a -> [Char]
prettyShow Bool
minify = Bool -> Doc -> [Char]
render Bool
minify forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int
0, Bool
minify)

instance Pretty a => Pretty (Maybe a) where
  pretty :: (Int, Bool) -> Maybe a -> Doc
pretty (Int, Bool)
n = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n)

instance (Pretty a, Pretty b) => Pretty (a,b) where
  pretty :: (Int, Bool) -> (a, b) -> Doc
pretty (Int, Bool)
n (a
x,b
y) = forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n a
x forall a. Semigroup a => a -> a -> a
<> Doc
":" Doc -> Doc -> Doc
<+> forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n b
y

-- Pretty-print collections

class Pretties a where
    pretties :: (Nat, Bool) -> a -> [Doc]

instance Pretty a => Pretties [a] where
  pretties :: (Int, Bool) -> [a] -> [Doc]
pretties (Int, Bool)
n = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n)

instance Pretty a => Pretties (List1 a) where
  pretties :: (Int, Bool) -> List1 a -> [Doc]
pretties (Int, Bool)
n = forall a. Pretties a => (Int, Bool) -> a -> [Doc]
pretties (Int, Bool)
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => l -> [Item l]
List1.toList

instance (Pretty a, Pretty b) => Pretties (Map a b) where
  pretties :: (Int, Bool) -> Map a b -> [Doc]
pretties (Int, Bool)
n = forall a. Pretties a => (Int, Bool) -> a -> [Doc]
pretties (Int, Bool)
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
toAscList

-- Pretty print identifiers

instance Pretty LocalId where
  pretty :: (Int, Bool) -> LocalId -> Doc
pretty (Int
n, Bool
_) (LocalId Int
x) = [Char] -> Doc
text forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> Int -> a
indexWithDefault forall a. HasCallStack => a
__IMPOSSIBLE__ [[Char]]
vars (Int
n forall a. Num a => a -> a -> a
- Int
x forall a. Num a => a -> a -> a
- Int
1)
    where
      vars :: [[Char]]
vars = ([Char]
""forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show [Integer
0..]) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Char]
s -> forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> [a] -> [a]
:[Char]
s) [Char
'a'..Char
'z']

instance Pretty GlobalId where
  pretty :: (Int, Bool) -> GlobalId -> Doc
pretty (Int, Bool)
n (GlobalId [[Char]]
m) = [Char] -> Doc
text forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
variableName forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"_" [[Char]]
m

instance Pretty MemberId where
  pretty :: (Int, Bool) -> MemberId -> Doc
pretty (Int, Bool)
_ (MemberId [Char]
s) = Doc
"\"" forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc
unescapes [Char]
s forall a. Semigroup a => a -> a -> a
<> Doc
"\""
  pretty (Int, Bool)
n (MemberIndex Int
i Comment
comment) = [Char] -> Doc
text (forall a. Show a => a -> [Char]
show Int
i) forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n Comment
comment

instance Pretty Comment where
  pretty :: (Int, Bool) -> Comment -> Doc
pretty (Int, Bool)
_ (Comment [Char]
"") = forall a. Monoid a => a
mempty
  pretty (Int
_, Bool
True) Comment
_ = forall a. Monoid a => a
mempty
  pretty (Int, Bool)
_ (Comment [Char]
s) = [Char] -> Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"/* " forall a. [a] -> [a] -> [a]
++ [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
" */"

-- Pretty print expressions

instance Pretty Exp where
  pretty :: (Int, Bool) -> Exp -> Doc
pretty (Int, Bool)
n (Exp
Self)            = Doc
"exports"
  pretty (Int, Bool)
n (Local LocalId
x)         = forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n LocalId
x
  pretty (Int, Bool)
n (Global GlobalId
m)        = forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n GlobalId
m
  pretty (Int, Bool)
n (Exp
Undefined)       = Doc
"undefined"
  pretty (Int, Bool)
n (Exp
Null)            = Doc
"null"
  pretty (Int, Bool)
n (String Text
s)        = Doc
"\"" forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc
unescapes (Text -> [Char]
T.unpack Text
s) forall a. Semigroup a => a -> a -> a
<> Doc
"\""
  pretty (Int, Bool)
n (Char Char
c)          = Doc
"\"" forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc
unescapes [Char
c] forall a. Semigroup a => a -> a -> a
<> Doc
"\""
  pretty (Int, Bool)
n (Integer Integer
x)       = Doc
"agdaRTS.primIntegerFromString(\"" forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc
text (forall a. Show a => a -> [Char]
show Integer
x) forall a. Semigroup a => a -> a -> a
<> Doc
"\")"
  pretty (Int, Bool)
n (Double Double
x)        = [Char] -> Doc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Double
x
  pretty (Int
n, Bool
min) (Lambda Int
x Exp
e) =
    Bool -> Doc -> Doc
mparens (Int
x forall a. Eq a => a -> a -> Bool
/= Int
1) (Doc -> [Doc] -> Doc
punctuate Doc
"," (forall a. Pretties a => (Int, Bool) -> a -> [Doc]
pretties (Int
nforall a. Num a => a -> a -> a
+Int
x, Bool
min) (forall a b. (a -> b) -> [a] -> [b]
map Int -> LocalId
LocalId [Int
xforall a. Num a => a -> a -> a
-Int
1, Int
xforall a. Num a => a -> a -> a
-Int
2 .. Int
0])))
    Doc -> Doc -> Doc
<+> Doc
"=>" Doc -> Doc -> Doc
<+> (Int, Bool) -> Exp -> Doc
block (Int
nforall a. Num a => a -> a -> a
+Int
x, Bool
min) Exp
e
  pretty (Int, Bool)
n (Object Map MemberId Exp
o)        = Doc -> Doc
braces forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> Doc
punctuate Doc
"," forall a b. (a -> b) -> a -> b
$ forall a. Pretties a => (Int, Bool) -> a -> [Doc]
pretties (Int, Bool)
n Map MemberId Exp
o
  pretty (Int, Bool)
n (Array [(Comment, Exp)]
es)        = Doc -> Doc
brackets forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> Doc
punctuate Doc
"," [forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n Comment
c forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n Exp
e | (Comment
c, Exp
e) <- [(Comment, Exp)]
es]
  pretty (Int, Bool)
n (Apply Exp
f [Exp]
es)      = forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n Exp
f forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (Doc -> [Doc] -> Doc
punctuate Doc
"," forall a b. (a -> b) -> a -> b
$ forall a. Pretties a => (Int, Bool) -> a -> [Doc]
pretties (Int, Bool)
n [Exp]
es)
  pretty (Int, Bool)
n (Lookup Exp
e MemberId
l)      = forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n Exp
e forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
brackets (forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n MemberId
l)
  pretty (Int, Bool)
n (If Exp
e Exp
f Exp
g)        = Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n Exp
e forall a. Semigroup a => a -> a -> a
<> Doc
"?" Doc -> Doc -> Doc
<+> forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n Exp
f forall a. Semigroup a => a -> a -> a
<> Doc
":" Doc -> Doc -> Doc
<+> forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n Exp
g
  pretty (Int, Bool)
n (PreOp [Char]
op Exp
e)      = Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
op forall a. Semigroup a => a -> a -> a
<> Doc
" " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n Exp
e
  pretty (Int, Bool)
n (BinOp Exp
e [Char]
op Exp
f)    = Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n Exp
e forall a. Semigroup a => a -> a -> a
<> Doc
" " forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc
text [Char]
op forall a. Semigroup a => a -> a -> a
<> Doc
" " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n Exp
f
  pretty (Int, Bool)
n (Const [Char]
c)         = [Char] -> Doc
text [Char]
c
  pretty (Int, Bool)
n (PlainJS [Char]
js)      = [Char] -> Doc
text [Char]
js

block :: (Nat, Bool) -> Exp -> Doc
block :: (Int, Bool) -> Exp -> Doc
block (Int, Bool)
n Exp
e = Bool -> Doc -> Doc
mparens (Exp -> Bool
doNest Exp
e) forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n Exp
e
  where
    doNest :: Exp -> Bool
doNest Object{} = Bool
True
    doNest Exp
_ = Bool
False

modname :: GlobalId -> Doc
modname :: GlobalId -> Doc
modname (GlobalId [[Char]]
ms) = [Char] -> Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"\"" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"." [[Char]]
ms forall a. [a] -> [a] -> [a]
++ [Char]
"\""

exports :: (Nat, Bool) -> Set JSQName -> [Export] -> Doc
exports :: (Int, Bool) -> Set JSQName -> [Export] -> Doc
exports (Int, Bool)
n Set JSQName
lss [] = Doc
Empty
exports (Int, Bool)
n Set JSQName
lss es0 :: [Export]
es0@(Export JSQName
ls Exp
e : [Export]
es)
  -- If the parent of @ls@ is already defined (or no parent exists), @ls@ can be defined
  | forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Ord a => a -> Set a -> Bool
`member` Set JSQName
lss) Maybe JSQName
parent =
      Doc
"exports" forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
hcat (forall a b. (a -> b) -> [a] -> [b]
map Doc -> Doc
brackets (forall a. Pretties a => (Int, Bool) -> a -> [Doc]
pretties (Int, Bool)
n JSQName
ls)) Doc -> Doc -> Doc
<+> Doc
"=" Doc -> Doc -> Doc
<+> Doc -> Doc
indent (forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n Exp
e) forall a. Semigroup a => a -> a -> a
<> Doc
";" Doc -> Doc -> Doc
$+$
      (Int, Bool) -> Set JSQName -> [Export] -> Doc
exports (Int, Bool)
n (forall a. Ord a => a -> Set a -> Set a
insert JSQName
ls Set JSQName
lss) [Export]
es
  -- If the parent is not yet defined, first define it as empty object, and then continue with @ls@.
  | Bool
otherwise =
      (Int, Bool) -> Set JSQName -> [Export] -> Doc
exports (Int, Bool)
n Set JSQName
lss forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Export]
es0 (\ JSQName
ls' -> JSQName -> Exp -> Export
Export JSQName
ls' (Map MemberId Exp -> Exp
Object forall a. Monoid a => a
mempty) forall a. a -> [a] -> [a]
: [Export]
es0) Maybe JSQName
parent
  where
  parent :: Maybe JSQName
parent = forall a. [a] -> Maybe (NonEmpty a)
List1.nonEmpty forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
List1.init JSQName
ls

instance Pretty [(GlobalId, Export)] where
  pretty :: (Int, Bool) -> [(GlobalId, Export)] -> Doc
pretty (Int, Bool)
n [(GlobalId, Export)]
es
    = [Doc] -> Doc
vcat [ forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n GlobalId
g forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
hcat (forall a b. (a -> b) -> [a] -> [b]
map Doc -> Doc
brackets (forall a. Pretties a => (Int, Bool) -> a -> [Doc]
pretties (Int, Bool)
n JSQName
ls)) Doc -> Doc -> Doc
<+> Doc
"=" Doc -> Doc -> Doc
<+> Doc -> Doc
indent (forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n Exp
e) forall a. Semigroup a => a -> a -> a
<> Doc
";"
           | (GlobalId
g, Export JSQName
ls Exp
e) <- [(GlobalId, Export)]
es ]

instance Pretty Module where
  pretty :: (Int, Bool) -> Module -> Doc
pretty (Int, Bool)
n (Module GlobalId
m [GlobalId]
is [Export]
es Maybe Exp
callMain) = [Doc] -> Doc
vsep
    [ Doc
importRTS
    , Doc
imports
    , (Int, Bool) -> Set JSQName -> [Export] -> Doc
exports (Int, Bool)
n forall a. Set a
Set.empty [Export]
es
    , forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n Maybe Exp
callMain
    ]
    Doc -> Doc -> Doc
$+$ Doc
"" -- Final newline
    where
      importRTS :: Doc
importRTS = Doc
"var agdaRTS" Doc -> Doc -> Doc
<+> Doc
"=" Doc -> Doc -> Doc
<+> Doc
"require(\"agda-rts\");"
      imports :: Doc
imports   = [Doc] -> Doc
vcat
        [ Doc
"var " forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
indent (forall a. Pretty a => (Int, Bool) -> a -> Doc
pretty (Int, Bool)
n GlobalId
e) Doc -> Doc -> Doc
<+> Doc
"=" Doc -> Doc -> Doc
<+> Doc
"require(" forall a. Semigroup a => a -> a -> a
<> GlobalId -> Doc
modname GlobalId
e forall a. Semigroup a => a -> a -> a
<> Doc
");"
        | GlobalId
e <- forall a. Set a -> [a]
toList (forall a. Globals a => a -> Set GlobalId
globals [Export]
es forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => [a] -> Set a
Set.fromList [GlobalId]
is)
        ]

variableName :: String -> String
variableName :: [Char] -> [Char]
variableName [Char]
s = if [Char] -> Bool
isValidJSIdent [Char]
s then [Char]
"z_" forall a. [a] -> [a] -> [a]
++ [Char]
s else [Char]
"h_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ([Char] -> Word64
hashString [Char]
s)

-- | Check if a string is a valid JS identifier. The check ignores keywords
-- as we prepend z_ to our identifiers. The check
-- is conservative and may not admit all valid JS identifiers.

isValidJSIdent :: String -> Bool
isValidJSIdent :: [Char] -> Bool
isValidJSIdent []     = Bool
False
isValidJSIdent (Char
c:[Char]
cs) = Char -> Bool
validFirst Char
c Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
validOther [Char]
cs
  where
  validFirst :: Char -> Bool
  validFirst :: Char -> Bool
validFirst Char
c = Char -> Bool
isAsciiUpper Char
c Bool -> Bool -> Bool
|| Char -> Bool
isAsciiLower Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'$'

  validOther :: Char -> Bool
  validOther :: Char -> Bool
validOther Char
c = Char -> Bool
validFirst Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c