{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}

module PureNix.Print (renderExpr) where

import Data.Foldable (toList)
import Data.List (intersperse)
import Data.Semigroup (mtimesDefault)
import Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as TB
import Lens.Micro.Platform
import PureNix.Expr hiding (string)
import PureNix.Identifiers
import PureNix.Prelude

newtype PrintContext = PrintContext {PrintContext -> Int
pcIndent :: Int}

newtype PrintState = PrintState {PrintState -> Builder
psBuilder :: Builder}

newtype Printer = Printer {Printer -> ReaderT PrintContext (State PrintState) ()
_unPrinter :: ReaderT PrintContext (State PrintState) ()}

runPrinter :: Printer -> LText
runPrinter :: Printer -> LText
runPrinter (Printer ReaderT PrintContext (State PrintState) ()
p) = Builder -> LText
TB.toLazyText (Builder -> LText) -> Builder -> LText
forall a b. (a -> b) -> a -> b
$ PrintState -> Builder
psBuilder (PrintState -> Builder) -> PrintState -> Builder
forall a b. (a -> b) -> a -> b
$ State PrintState () -> PrintState -> PrintState
forall s a. State s a -> s -> s
execState (ReaderT PrintContext (State PrintState) ()
-> PrintContext -> State PrintState ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT PrintContext (State PrintState) ()
p PrintContext
pc0) PrintState
ps0
  where
    pc0 :: PrintContext
pc0 = Int -> PrintContext
PrintContext Int
0
    ps0 :: PrintState
ps0 = Builder -> PrintState
PrintState Builder
forall a. Monoid a => a
mempty

instance Semigroup Printer where Printer ReaderT PrintContext (State PrintState) ()
a <> :: Printer -> Printer -> Printer
<> Printer ReaderT PrintContext (State PrintState) ()
b = ReaderT PrintContext (State PrintState) () -> Printer
Printer (ReaderT PrintContext (State PrintState) ()
a ReaderT PrintContext (State PrintState) ()
-> ReaderT PrintContext (State PrintState) ()
-> ReaderT PrintContext (State PrintState) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReaderT PrintContext (State PrintState) ()
b)

instance Monoid Printer where mempty :: Printer
mempty = ReaderT PrintContext (State PrintState) () -> Printer
Printer (() -> ReaderT PrintContext (State PrintState) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

instance IsString Printer where fromString :: String -> Printer
fromString = ReaderT PrintContext (State PrintState) () -> Printer
Printer (ReaderT PrintContext (State PrintState) () -> Printer)
-> (String -> ReaderT PrintContext (State PrintState) ())
-> String
-> Printer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ReaderT PrintContext (State PrintState) ()
emit (Builder -> ReaderT PrintContext (State PrintState) ())
-> (String -> Builder)
-> String
-> ReaderT PrintContext (State PrintState) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
forall a. IsString a => String -> a
fromString

delimit :: Style -> Char -> Char -> Printer -> Printer
delimit :: Style -> Char -> Char -> Printer -> Printer
delimit = (Char -> Char -> Printer -> Printer)
-> (Char -> Char -> Printer -> Printer)
-> Style
-> Char
-> Char
-> Printer
-> Printer
forall r. r -> r -> Style -> r
style Char -> Char -> Printer -> Printer
delimitSingle Char -> Char -> Printer -> Printer
delimitMulti
  where
    delimitSingle :: Char -> Char -> Printer -> Printer
    delimitSingle :: Char -> Char -> Printer -> Printer
delimitSingle Char
open Char
close Printer
body = [Printer] -> Printer
forall a. Monoid a => [a] -> a
mconcat [Char -> Printer
char Char
open, Printer
body, Char -> Printer
char Char
close]
    delimitMulti :: Char -> Char -> Printer -> Printer
    delimitMulti :: Char -> Char -> Printer -> Printer
delimitMulti Char
open Char
close Printer
body = [Printer] -> Printer
forall a. Monoid a => [a] -> a
mconcat [Printer
newline, Char -> Printer
char Char
open, Printer
space, Printer -> Printer
indent Printer
body, Printer
newline, Char -> Printer
char Char
close]

space :: Printer
space :: Printer
space = Char -> Printer
char Char
' '

indent :: Printer -> Printer
indent :: Printer -> Printer
indent (Printer ReaderT PrintContext (State PrintState) ()
p) = ReaderT PrintContext (State PrintState) () -> Printer
Printer (ReaderT PrintContext (State PrintState) () -> Printer)
-> ReaderT PrintContext (State PrintState) () -> Printer
forall a b. (a -> b) -> a -> b
$ (PrintContext -> PrintContext)
-> ReaderT PrintContext (State PrintState) ()
-> ReaderT PrintContext (State PrintState) ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\(PrintContext Int
n) -> Int -> PrintContext
PrintContext (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)) ReaderT PrintContext (State PrintState) ()
p

char :: Char -> Printer
char :: Char -> Printer
char = ReaderT PrintContext (State PrintState) () -> Printer
Printer (ReaderT PrintContext (State PrintState) () -> Printer)
-> (Char -> ReaderT PrintContext (State PrintState) ())
-> Char
-> Printer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ReaderT PrintContext (State PrintState) ()
emit (Builder -> ReaderT PrintContext (State PrintState) ())
-> (Char -> Builder)
-> Char
-> ReaderT PrintContext (State PrintState) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Builder
TB.singleton

emit :: Builder -> ReaderT PrintContext (State PrintState) ()
emit :: Builder -> ReaderT PrintContext (State PrintState) ()
emit Builder
t = (PrintState -> PrintState)
-> ReaderT PrintContext (State PrintState) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\(PrintState Builder
s) -> Builder -> PrintState
PrintState (Builder -> PrintState) -> Builder -> PrintState
forall a b. (a -> b) -> a -> b
$ Builder
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
t)

text :: Text -> Printer
text :: Text -> Printer
text = ReaderT PrintContext (State PrintState) () -> Printer
Printer (ReaderT PrintContext (State PrintState) () -> Printer)
-> (Text -> ReaderT PrintContext (State PrintState) ())
-> Text
-> Printer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ReaderT PrintContext (State PrintState) ()
emit (Builder -> ReaderT PrintContext (State PrintState) ())
-> (Text -> Builder)
-> Text
-> ReaderT PrintContext (State PrintState) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
TB.fromText

string :: String -> Printer
string :: String -> Printer
string = ReaderT PrintContext (State PrintState) () -> Printer
Printer (ReaderT PrintContext (State PrintState) () -> Printer)
-> (String -> ReaderT PrintContext (State PrintState) ())
-> String
-> Printer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ReaderT PrintContext (State PrintState) ()
emit (Builder -> ReaderT PrintContext (State PrintState) ())
-> (String -> Builder)
-> String
-> ReaderT PrintContext (State PrintState) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
TB.fromString

newline :: Printer
newline :: Printer
newline = ReaderT PrintContext (State PrintState) () -> Printer
Printer (ReaderT PrintContext (State PrintState) () -> Printer)
-> ReaderT PrintContext (State PrintState) () -> Printer
forall a b. (a -> b) -> a -> b
$ do
  Int
i <- (PrintContext -> Int)
-> ReaderT PrintContext (State PrintState) Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrintContext -> Int
pcIndent
  Builder -> ReaderT PrintContext (State PrintState) ()
emit (Builder
"\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder -> Builder
forall b a. (Integral b, Monoid a) => b -> a -> a
mtimesDefault Int
i Builder
" ")

-- | Turn a Nix 'Expr' into an actual piece of text.
renderExpr :: Expr -> LText
renderExpr :: Expr -> LText
renderExpr = Printer -> LText
runPrinter (Printer -> LText) -> (Expr -> Printer) -> Expr -> LText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Printer (Printer, Style, Associativity, Precedence) Printer
-> (Printer, Style, Associativity, Precedence) -> Printer
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Printer (Printer, Style, Associativity, Precedence) Printer
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((Printer, Style, Associativity, Precedence) -> Printer)
-> (Expr -> (Printer, Style, Associativity, Precedence))
-> Expr
-> Printer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExprF (Printer, Style, Associativity, Precedence)
 -> (Printer, Style, Associativity, Precedence))
-> Expr -> (Printer, Style, Associativity, Precedence)
forall r. (ExprF r -> r) -> Expr -> r
foldExpr ExprF (Printer, Style, Associativity, Precedence)
-> (Printer, Style, Associativity, Precedence)
render
  where
    render :: ExprF (Printer, Style, Associativity, Precedence) -> (Printer, Style, Associativity, Precedence)
    render :: ExprF (Printer, Style, Associativity, Precedence)
-> (Printer, Style, Associativity, Precedence)
render ExprF (Printer, Style, Associativity, Precedence)
expr = (Style -> ExprF Printer -> Printer
ppExpr Style
sty ExprF Printer
parenthesized, Style
sty, ExprF (Printer, Style, Associativity, Precedence) -> Associativity
forall a. ExprF a -> Associativity
exprAssoc ExprF (Printer, Style, Associativity, Precedence)
expr, ExprF (Printer, Style, Associativity, Precedence) -> Precedence
forall a. ExprF a -> Precedence
exprPrec ExprF (Printer, Style, Associativity, Precedence)
expr)
      where
        sty :: Style
sty = ExprF Style -> Style
exprStyle (Getting Style (Printer, Style, Associativity, Precedence) Style
-> (Printer, Style, Associativity, Precedence) -> Style
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Style (Printer, Style, Associativity, Precedence) Style
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((Printer, Style, Associativity, Precedence) -> Style)
-> ExprF (Printer, Style, Associativity, Precedence) -> ExprF Style
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExprF (Printer, Style, Associativity, Precedence)
expr)
        parenthesized :: ExprF Printer
parenthesized =
          ((Printer, Style, Associativity, Precedence) -> Associativity)
-> ((Printer, Style, Associativity, Precedence) -> Precedence)
-> ((Printer, Style, Associativity, Precedence) -> Printer)
-> ((Printer, Style, Associativity, Precedence) -> Printer)
-> ExprF (Printer, Style, Associativity, Precedence)
-> ExprF Printer
forall a b.
(a -> Associativity)
-> (a -> Precedence) -> (a -> b) -> (a -> b) -> ExprF a -> ExprF b
parenthesize
            (Getting
  Associativity
  (Printer, Style, Associativity, Precedence)
  Associativity
-> (Printer, Style, Associativity, Precedence) -> Associativity
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  Associativity
  (Printer, Style, Associativity, Precedence)
  Associativity
forall s t a b. Field3 s t a b => Lens s t a b
_3)
            (Getting
  Precedence (Printer, Style, Associativity, Precedence) Precedence
-> (Printer, Style, Associativity, Precedence) -> Precedence
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  Precedence (Printer, Style, Associativity, Precedence) Precedence
forall s t a b. Field4 s t a b => Lens s t a b
_4)
            (Getting Printer (Printer, Style, Associativity, Precedence) Printer
-> (Printer, Style, Associativity, Precedence) -> Printer
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Printer (Printer, Style, Associativity, Precedence) Printer
forall s t a b. Field1 s t a b => Lens s t a b
_1)
            (\(Printer, Style, Associativity, Precedence)
inner -> Style -> Char -> Char -> Printer -> Printer
delimit ((Printer, Style, Associativity, Precedence)
inner (Printer, Style, Associativity, Precedence)
-> Getting Style (Printer, Style, Associativity, Precedence) Style
-> Style
forall s a. s -> Getting a s a -> a
^. Getting Style (Printer, Style, Associativity, Precedence) Style
forall s t a b. Field2 s t a b => Lens s t a b
_2) Char
'(' Char
')' ((Printer, Style, Associativity, Precedence)
inner (Printer, Style, Associativity, Precedence)
-> Getting
     Printer (Printer, Style, Associativity, Precedence) Printer
-> Printer
forall s a. s -> Getting a s a -> a
^. Getting Printer (Printer, Style, Associativity, Precedence) Printer
forall s t a b. Field1 s t a b => Lens s t a b
_1))
            ExprF (Printer, Style, Associativity, Precedence)
expr

-- | Expressions can be printed in two styles; single-line or multi-line.
data Style = Single | Multi deriving (Style -> Style -> Bool
(Style -> Style -> Bool) -> (Style -> Style -> Bool) -> Eq Style
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Style -> Style -> Bool
$c/= :: Style -> Style -> Bool
== :: Style -> Style -> Bool
$c== :: Style -> Style -> Bool
Eq, Eq Style
Eq Style
-> (Style -> Style -> Ordering)
-> (Style -> Style -> Bool)
-> (Style -> Style -> Bool)
-> (Style -> Style -> Bool)
-> (Style -> Style -> Bool)
-> (Style -> Style -> Style)
-> (Style -> Style -> Style)
-> Ord Style
Style -> Style -> Bool
Style -> Style -> Ordering
Style -> Style -> Style
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Style -> Style -> Style
$cmin :: Style -> Style -> Style
max :: Style -> Style -> Style
$cmax :: Style -> Style -> Style
>= :: Style -> Style -> Bool
$c>= :: Style -> Style -> Bool
> :: Style -> Style -> Bool
$c> :: Style -> Style -> Bool
<= :: Style -> Style -> Bool
$c<= :: Style -> Style -> Bool
< :: Style -> Style -> Bool
$c< :: Style -> Style -> Bool
compare :: Style -> Style -> Ordering
$ccompare :: Style -> Style -> Ordering
$cp1Ord :: Eq Style
Ord)

style :: r -> r -> Style -> r
style :: r -> r -> Style -> r
style r
a r
_ Style
Single = r
a
style r
_ r
b Style
Multi = r
b

exprStyle :: ExprF Style -> Style
exprStyle :: ExprF Style -> Style
exprStyle (Attrs [Var]
_ [] []) = Style
Single
exprStyle (Attrs [] [(Style
sty, [Key]
_)] []) = Style
sty
exprStyle (Attrs [] [] [(Key
_, Style
sty)]) = Style
sty
exprStyle Attrs {} = Style
Multi
exprStyle Let {} = Style
Multi
exprStyle ExprF Style
v = Style -> Style -> Bool -> Style
forall a. a -> a -> Bool -> a
bool Style
Single Style
Multi (Bool -> Style) -> Bool -> Style
forall a b. (a -> b) -> a -> b
$ Style -> ExprF Style -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Style
Multi ExprF Style
v

newtype Precedence = Precedence Int deriving newtype (Integer -> Precedence
Precedence -> Precedence
Precedence -> Precedence -> Precedence
(Precedence -> Precedence -> Precedence)
-> (Precedence -> Precedence -> Precedence)
-> (Precedence -> Precedence -> Precedence)
-> (Precedence -> Precedence)
-> (Precedence -> Precedence)
-> (Precedence -> Precedence)
-> (Integer -> Precedence)
-> Num Precedence
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Precedence
$cfromInteger :: Integer -> Precedence
signum :: Precedence -> Precedence
$csignum :: Precedence -> Precedence
abs :: Precedence -> Precedence
$cabs :: Precedence -> Precedence
negate :: Precedence -> Precedence
$cnegate :: Precedence -> Precedence
* :: Precedence -> Precedence -> Precedence
$c* :: Precedence -> Precedence -> Precedence
- :: Precedence -> Precedence -> Precedence
$c- :: Precedence -> Precedence -> Precedence
+ :: Precedence -> Precedence -> Precedence
$c+ :: Precedence -> Precedence -> Precedence
Num, Precedence -> Precedence -> Bool
(Precedence -> Precedence -> Bool)
-> (Precedence -> Precedence -> Bool) -> Eq Precedence
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Precedence -> Precedence -> Bool
$c/= :: Precedence -> Precedence -> Bool
== :: Precedence -> Precedence -> Bool
$c== :: Precedence -> Precedence -> Bool
Eq, Eq Precedence
Eq Precedence
-> (Precedence -> Precedence -> Ordering)
-> (Precedence -> Precedence -> Bool)
-> (Precedence -> Precedence -> Bool)
-> (Precedence -> Precedence -> Bool)
-> (Precedence -> Precedence -> Bool)
-> (Precedence -> Precedence -> Precedence)
-> (Precedence -> Precedence -> Precedence)
-> Ord Precedence
Precedence -> Precedence -> Bool
Precedence -> Precedence -> Ordering
Precedence -> Precedence -> Precedence
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Precedence -> Precedence -> Precedence
$cmin :: Precedence -> Precedence -> Precedence
max :: Precedence -> Precedence -> Precedence
$cmax :: Precedence -> Precedence -> Precedence
>= :: Precedence -> Precedence -> Bool
$c>= :: Precedence -> Precedence -> Bool
> :: Precedence -> Precedence -> Bool
$c> :: Precedence -> Precedence -> Bool
<= :: Precedence -> Precedence -> Bool
$c<= :: Precedence -> Precedence -> Bool
< :: Precedence -> Precedence -> Bool
$c< :: Precedence -> Precedence -> Bool
compare :: Precedence -> Precedence -> Ordering
$ccompare :: Precedence -> Precedence -> Ordering
$cp1Ord :: Eq Precedence
Ord)

data Associativity = AssocLeft | AssocRight | AssocNone | Associative
  deriving (Associativity -> Associativity -> Bool
(Associativity -> Associativity -> Bool)
-> (Associativity -> Associativity -> Bool) -> Eq Associativity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Associativity -> Associativity -> Bool
$c/= :: Associativity -> Associativity -> Bool
== :: Associativity -> Associativity -> Bool
$c== :: Associativity -> Associativity -> Bool
Eq, Int -> Associativity -> ShowS
[Associativity] -> ShowS
Associativity -> String
(Int -> Associativity -> ShowS)
-> (Associativity -> String)
-> ([Associativity] -> ShowS)
-> Show Associativity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Associativity] -> ShowS
$cshowList :: [Associativity] -> ShowS
show :: Associativity -> String
$cshow :: Associativity -> String
showsPrec :: Int -> Associativity -> ShowS
$cshowsPrec :: Int -> Associativity -> ShowS
Show)

exprAssoc :: ExprF a -> Associativity
exprAssoc :: ExprF a -> Associativity
exprAssoc Sel {} = Associativity
AssocLeft
exprAssoc App {} = Associativity
AssocLeft
exprAssoc (Bin Op
op a
_ a
_) = Op -> Associativity
opAssoc Op
op
  where
    opAssoc :: Op -> Associativity
opAssoc Op
Equals = Associativity
AssocNone
    opAssoc Op
Update = Associativity
Associative
    opAssoc Op
And = Associativity
Associative
exprAssoc ExprF a
_ = Associativity
AssocNone

-- | Expression precedence.
-- See: https://nixos.org/manual/nix/stable/#sec-language-operators
-- Operators listed in the above table have a precedence of (15 - <listed precedence>)
exprPrec :: ExprF a -> Precedence
exprPrec :: ExprF a -> Precedence
exprPrec Var {} = Precedence
15
exprPrec Int {} = Precedence
15
exprPrec Double {} = Precedence
15
exprPrec String {} = Precedence
15
exprPrec Attrs {} = Precedence
15
exprPrec List {} = Precedence
15
exprPrec Path {} = Precedence
15
exprPrec Sel {} = Precedence
14
exprPrec App {} = Precedence
13
exprPrec Not {} = Precedence
8
exprPrec (Bin Op
op a
_ a
_) = Op -> Precedence
opPrec Op
op
  where
    opPrec :: Op -> Precedence
    opPrec :: Op -> Precedence
opPrec Op
Update = Precedence
6
    opPrec Op
Equals = Precedence
4
    opPrec Op
And = Precedence
3
exprPrec Cond {} = Precedence
0
exprPrec Lam {} = Precedence
0
exprPrec Let {} = Precedence
0

-- | Define whether a subexpression needs to be parenthesized, based on its associativity and precedence.
parenthesize :: forall a b. (a -> Associativity) -> (a -> Precedence) -> (a -> b) -> (a -> b) -> ExprF a -> ExprF b
parenthesize :: (a -> Associativity)
-> (a -> Precedence) -> (a -> b) -> (a -> b) -> ExprF a -> ExprF b
parenthesize a -> Associativity
assoc a -> Precedence
prec a -> b
no a -> b
yes = ExprF a -> ExprF b
go
  where
    below :: Precedence -> a -> b
    below :: Precedence -> a -> b
below Precedence
p a
a = if a -> Precedence
prec a
a Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
< Precedence
p then a -> b
yes a
a else a -> b
no a
a
    bin :: (forall c. c -> c -> ExprF c) -> a -> a -> ExprF b
    bin :: (forall c. c -> c -> ExprF c) -> a -> a -> ExprF b
bin forall c. c -> c -> ExprF c
op a
l a
r = b -> b -> ExprF b
forall c. c -> c -> ExprF c
op (a -> Associativity -> b
f a
l Associativity
AssocLeft) (a -> Associativity -> b
f a
r Associativity
AssocRight)
      where
        f :: a -> Associativity -> b
f a
x Associativity
a = case Precedence -> Precedence -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> Precedence
prec a
x) (ExprF () -> Precedence
forall a. ExprF a -> Precedence
exprPrec (ExprF () -> Precedence) -> ExprF () -> Precedence
forall a b. (a -> b) -> a -> b
$ () -> () -> ExprF ()
forall c. c -> c -> ExprF c
op () ()) of
          Ordering
GT -> a -> b
no a
x
          Ordering
EQ | a -> Associativity
assoc a
x Associativity -> [Associativity] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Associativity
a, Associativity
Associative] -> a -> b
no a
x
          Ordering
_ -> a -> b
yes a
x
    go :: ExprF a -> ExprF b
    go :: ExprF a -> ExprF b
go (Attrs [Var]
ih [(a, [Key])]
ihf [(Key, a)]
f) = [Var] -> [(b, [Key])] -> [(Key, b)] -> ExprF b
forall f. [Var] -> [(f, [Key])] -> [(Key, f)] -> ExprF f
Attrs [Var]
ih ([(a, [Key])]
ihf [(a, [Key])] -> ([(a, [Key])] -> [(b, [Key])]) -> [(b, [Key])]
forall a b. a -> (a -> b) -> b
& ((a, [Key]) -> Identity (b, [Key]))
-> [(a, [Key])] -> Identity [(b, [Key])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((a, [Key]) -> Identity (b, [Key]))
 -> [(a, [Key])] -> Identity [(b, [Key])])
-> ((a -> Identity b) -> (a, [Key]) -> Identity (b, [Key]))
-> (a -> Identity b)
-> [(a, [Key])]
-> Identity [(b, [Key])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Identity b) -> (a, [Key]) -> Identity (b, [Key])
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((a -> Identity b) -> [(a, [Key])] -> Identity [(b, [Key])])
-> (a -> b) -> [(a, [Key])] -> [(b, [Key])]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ a -> b
yes) ([(Key, a)]
f [(Key, a)] -> ([(Key, a)] -> [(Key, b)]) -> [(Key, b)]
forall a b. a -> (a -> b) -> b
& ((Key, a) -> Identity (Key, b))
-> [(Key, a)] -> Identity [(Key, b)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((Key, a) -> Identity (Key, b))
 -> [(Key, a)] -> Identity [(Key, b)])
-> ((a -> Identity b) -> (Key, a) -> Identity (Key, b))
-> (a -> Identity b)
-> [(Key, a)]
-> Identity [(Key, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Identity b) -> (Key, a) -> Identity (Key, b)
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((a -> Identity b) -> [(Key, a)] -> Identity [(Key, b)])
-> (a -> b) -> [(Key, a)] -> [(Key, b)]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ a -> b
no)
    go (Let NonEmpty (Var, a)
binds a
body) = NonEmpty (Var, b) -> b -> ExprF b
forall f. NonEmpty (Var, f) -> f -> ExprF f
Let (NonEmpty (Var, a)
binds NonEmpty (Var, a)
-> (NonEmpty (Var, a) -> NonEmpty (Var, b)) -> NonEmpty (Var, b)
forall a b. a -> (a -> b) -> b
& ((Var, a) -> Identity (Var, b))
-> NonEmpty (Var, a) -> Identity (NonEmpty (Var, b))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((Var, a) -> Identity (Var, b))
 -> NonEmpty (Var, a) -> Identity (NonEmpty (Var, b)))
-> ((a -> Identity b) -> (Var, a) -> Identity (Var, b))
-> (a -> Identity b)
-> NonEmpty (Var, a)
-> Identity (NonEmpty (Var, b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Identity b) -> (Var, a) -> Identity (Var, b)
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((a -> Identity b)
 -> NonEmpty (Var, a) -> Identity (NonEmpty (Var, b)))
-> (a -> b) -> NonEmpty (Var, a) -> NonEmpty (Var, b)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ a -> b
no) (a
body a -> (a -> b) -> b
forall a b. a -> (a -> b) -> b
& a -> b
no)
    go (List [a]
elems) = [b] -> ExprF b
forall f. [f] -> ExprF f
List (Precedence -> a -> b
below Precedence
14 (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
elems)
    go (App a
f a
x) = (forall c. c -> c -> ExprF c) -> a -> a -> ExprF b
bin forall c. c -> c -> ExprF c
App a
f a
x
    go (Bin Op
op a
l a
r) = (forall c. c -> c -> ExprF c) -> a -> a -> ExprF b
bin (Op -> c -> c -> ExprF c
forall f. Op -> f -> f -> ExprF f
Bin Op
op) a
l a
r
    go ExprF a
e = (a -> b) -> ExprF a -> ExprF b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Precedence -> a -> b
below (ExprF a -> Precedence
forall a. ExprF a -> Precedence
exprPrec ExprF a
e)) ExprF a
e

sepBy :: Foldable t => Printer -> t Printer -> Printer
sepBy :: Printer -> t Printer -> Printer
sepBy Printer
sep t Printer
ps = [Printer] -> Printer
forall a. Monoid a => [a] -> a
mconcat ([Printer] -> Printer) -> [Printer] -> Printer
forall a b. (a -> b) -> a -> b
$ Printer -> [Printer] -> [Printer]
forall a. a -> [a] -> [a]
intersperse Printer
sep (t Printer -> [Printer]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t Printer
ps)

binding :: (k -> Printer) -> (k, Printer) -> Printer
binding :: (k -> Printer) -> (k, Printer) -> Printer
binding k -> Printer
f (k
v, Printer
body) = k -> Printer
f k
v Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
" = " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer -> Printer
indent Printer
body Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
";"

binder :: Var -> Printer
binder :: Var -> Printer
binder = Text -> Printer
text (Text -> Printer) -> (Var -> Text) -> Var -> Printer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Text
unVar

key :: Key -> Printer
key :: Key -> Printer
key = Text -> Printer
text (Text -> Printer) -> (Key -> Text) -> Key -> Printer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
unKey

ppExpr :: Style -> ExprF Printer -> Printer
ppExpr :: Style -> ExprF Printer -> Printer
ppExpr Style
_ (Var Var
v) = Var -> Printer
binder Var
v
ppExpr Style
_ (Lam Var
arg Printer
body) = Text -> Printer
text (Var -> Text
unVar Var
arg) Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
": " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
body
ppExpr Style
_ (App Printer
f Printer
x) = Printer
f Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
space Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
x
ppExpr Style
_ (Attrs [] [] []) = Printer
"{ }"
ppExpr Style
sty (Attrs [Var]
ih [(Printer, [Key])]
ihf [(Key, Printer)]
b) = Style -> Char -> Char -> Printer -> Printer
delimit Style
sty Char
'{' Char
'}' (Printer -> Printer) -> Printer -> Printer
forall a b. (a -> b) -> a -> b
$ Printer -> [Printer] -> Printer
forall (t :: * -> *). Foldable t => Printer -> t Printer -> Printer
sepBy Printer
newline ([Printer] -> Printer) -> [Printer] -> Printer
forall a b. (a -> b) -> a -> b
$ [Printer]
inherits [Printer] -> [Printer] -> [Printer]
forall a. Semigroup a => a -> a -> a
<> [Printer]
inheritFroms [Printer] -> [Printer] -> [Printer]
forall a. Semigroup a => a -> a -> a
<> [Printer]
binds
  where
    inherits :: [Printer]
inherits = [Printer -> [Printer] -> Printer
forall (t :: * -> *). Foldable t => Printer -> t Printer -> Printer
sepBy Printer
space (Printer
"inherit" Printer -> [Printer] -> [Printer]
forall a. a -> [a] -> [a]
: (Var -> Printer
binder (Var -> Printer) -> [Var] -> [Printer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var]
ih)) Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
";" | Bool -> Bool
not ([Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
ih)]
    inheritFroms :: [Printer]
inheritFroms = (\(Printer
from, [Key]
idents) -> Printer -> [Printer] -> Printer
forall (t :: * -> *). Foldable t => Printer -> t Printer -> Printer
sepBy Printer
space (Printer
"inherit" Printer -> [Printer] -> [Printer]
forall a. a -> [a] -> [a]
: Printer
from Printer -> [Printer] -> [Printer]
forall a. a -> [a] -> [a]
: (Key -> Printer
key (Key -> Printer) -> [Key] -> [Printer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Key]
idents)) Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
";") ((Printer, [Key]) -> Printer) -> [(Printer, [Key])] -> [Printer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Printer, [Key])]
ihf
    binds :: [Printer]
binds = (Key -> Printer) -> (Key, Printer) -> Printer
forall k. (k -> Printer) -> (k, Printer) -> Printer
binding Key -> Printer
key ((Key, Printer) -> Printer) -> [(Key, Printer)] -> [Printer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Key, Printer)]
b
ppExpr Style
_ (List []) = Printer
"[]"
ppExpr Style
sty (List [Printer]
l) = Style -> Char -> Char -> Printer -> Printer
delimit Style
sty Char
'[' Char
']' (Printer -> Printer) -> Printer -> Printer
forall a b. (a -> b) -> a -> b
$ Printer -> [Printer] -> Printer
forall (t :: * -> *). Foldable t => Printer -> t Printer -> Printer
sepBy Printer
newline [Printer]
l
ppExpr Style
_ (Sel Printer
a Key
b) = Printer
a Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
"." Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Key -> Printer
key Key
b
ppExpr Style
_ (Path Text
t) = Text -> Printer
text Text
t
ppExpr Style
_ (String Text
str) = Char -> Printer
char Char
'"' Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Text -> Printer
text Text
str Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Char -> Printer
char Char
'"'
ppExpr Style
_ (Int Integer
n) = String -> Printer
string (Integer -> String
forall a. Show a => a -> String
show Integer
n)
ppExpr Style
_ (Double Double
x) = String -> Printer
string (Double -> String
forall a. Show a => a -> String
show Double
x)
ppExpr Style
Single (Cond Printer
c Printer
t Printer
f) = Printer -> [Printer] -> Printer
forall (t :: * -> *). Foldable t => Printer -> t Printer -> Printer
sepBy Printer
space [Printer
"if", Printer
c, Printer
"then", Printer
t, Printer
"else", Printer
f]
ppExpr Style
Multi (Cond Printer
c Printer
t Printer
f) = Printer
newline Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
"if " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
c Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer -> Printer
indent (Printer
newline Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
"then " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer -> Printer
indent Printer
t Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
"else " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer -> Printer
indent Printer
f)
ppExpr Style
_ (Not Printer
e) = Printer
"!" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
e
ppExpr Style
_ (Let NonEmpty (Var, Printer)
binds Printer
body) =
  [Printer] -> Printer
forall a. Monoid a => [a] -> a
mconcat
    [ Printer
newline,
      Printer
"let",
      Printer -> Printer
indent (Printer -> Printer) -> Printer -> Printer
forall a b. (a -> b) -> a -> b
$ Printer
newline Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer -> NonEmpty Printer -> Printer
forall (t :: * -> *). Foldable t => Printer -> t Printer -> Printer
sepBy Printer
newline ((Var -> Printer) -> (Var, Printer) -> Printer
forall k. (k -> Printer) -> (k, Printer) -> Printer
binding Var -> Printer
binder ((Var, Printer) -> Printer)
-> NonEmpty (Var, Printer) -> NonEmpty Printer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Var, Printer)
binds),
      Printer
newline,
      Printer
"in",
      Printer -> Printer
indent (Printer -> Printer) -> Printer -> Printer
forall a b. (a -> b) -> a -> b
$ Printer
newline Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
body
    ]
ppExpr Style
_ (Bin Op
Update Printer
l Printer
r) = Printer
l Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
" // " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
r
ppExpr Style
_ (Bin Op
Equals Printer
l Printer
r) = Printer
l Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
" == " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
r
ppExpr Style
_ (Bin Op
And Printer
l Printer
r) = Printer
l Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
" && " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
r