{-# LANGUAGE LambdaCase #-}

-- |
-- Module      : Jikka.Core.Format
-- Description : converts the syntax trees of core language to strings. / core 言語の構文木を文字列に変換します。
-- Copyright   : (c) Kimiyuki Onaka, 2020
-- License     : Apache License 2.0
-- Maintainer  : kimiyuki95@gmail.com
-- Stability   : experimental
-- Portability : portable
--
-- TODO: add parens with considering precedences.
module Jikka.Core.Format
  ( run,
    formatBuiltinIsolated,
    formatBuiltin,
    formatType,
    formatExpr,
    formatProgram,
  )
where

import Data.Char (toLower)
import Data.List (intercalate)
import Data.Text (Text, pack)
import Jikka.Common.Format.AutoIndent
import Jikka.Core.Language.Expr
import Jikka.Core.Language.Util

paren :: String -> String
paren :: String -> String
paren String
s = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

formatType :: Type -> String
formatType :: Type -> String
formatType = \case
  VarTy (TypeName String
a) -> String
a
  Type
IntTy -> String
"int"
  Type
BoolTy -> String
"bool"
  ListTy Type
t -> Type -> String
formatType Type
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" list"
  TupleTy [Type]
ts -> case [Type]
ts of
    [Type
t] -> String -> String
paren (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Type -> String
formatType Type
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
","
    [Type]
_ -> String -> String
paren (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" * " ((Type -> String) -> [Type] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Type -> String
formatType [Type]
ts)
  t :: Type
t@(FunTy Type
_ Type
_) ->
    let ([Type]
ts, Type
ret) = Type -> ([Type], Type)
uncurryFunTy Type
t
     in String -> String
paren (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" -> " ((Type -> String) -> [Type] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Type -> String
formatType ([Type]
ts [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
ret]))
  DataStructureTy DataStructure
ds -> DataStructure -> String
formatDataStructure DataStructure
ds

formatDataStructure :: DataStructure -> String
formatDataStructure :: DataStructure -> String
formatDataStructure = \case
  DataStructure
ConvexHullTrick -> String
"convex-hull-trick"
  SegmentTree Semigroup'
semigrp -> String
"segment-tree<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Semigroup' -> String
formatSemigroup Semigroup'
semigrp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"

formatSemigroup :: Semigroup' -> String
formatSemigroup :: Semigroup' -> String
formatSemigroup = \case
  Semigroup'
SemigroupIntPlus -> String
"int.plus"
  Semigroup'
SemigroupIntMin -> String
"int.min"
  Semigroup'
SemigroupIntMax -> String
"int.max"

data Builtin'
  = Fun [Type] String
  | PrefixOp String
  | InfixOp [Type] String
  | At' Type
  | If' Type
  deriving (Builtin' -> Builtin' -> Bool
(Builtin' -> Builtin' -> Bool)
-> (Builtin' -> Builtin' -> Bool) -> Eq Builtin'
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Builtin' -> Builtin' -> Bool
$c/= :: Builtin' -> Builtin' -> Bool
== :: Builtin' -> Builtin' -> Bool
$c== :: Builtin' -> Builtin' -> Bool
Eq, Eq Builtin'
Eq Builtin'
-> (Builtin' -> Builtin' -> Ordering)
-> (Builtin' -> Builtin' -> Bool)
-> (Builtin' -> Builtin' -> Bool)
-> (Builtin' -> Builtin' -> Bool)
-> (Builtin' -> Builtin' -> Bool)
-> (Builtin' -> Builtin' -> Builtin')
-> (Builtin' -> Builtin' -> Builtin')
-> Ord Builtin'
Builtin' -> Builtin' -> Bool
Builtin' -> Builtin' -> Ordering
Builtin' -> Builtin' -> Builtin'
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 :: Builtin' -> Builtin' -> Builtin'
$cmin :: Builtin' -> Builtin' -> Builtin'
max :: Builtin' -> Builtin' -> Builtin'
$cmax :: Builtin' -> Builtin' -> Builtin'
>= :: Builtin' -> Builtin' -> Bool
$c>= :: Builtin' -> Builtin' -> Bool
> :: Builtin' -> Builtin' -> Bool
$c> :: Builtin' -> Builtin' -> Bool
<= :: Builtin' -> Builtin' -> Bool
$c<= :: Builtin' -> Builtin' -> Bool
< :: Builtin' -> Builtin' -> Bool
$c< :: Builtin' -> Builtin' -> Bool
compare :: Builtin' -> Builtin' -> Ordering
$ccompare :: Builtin' -> Builtin' -> Ordering
$cp1Ord :: Eq Builtin'
Ord, Int -> Builtin' -> String -> String
[Builtin'] -> String -> String
Builtin' -> String
(Int -> Builtin' -> String -> String)
-> (Builtin' -> String)
-> ([Builtin'] -> String -> String)
-> Show Builtin'
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Builtin'] -> String -> String
$cshowList :: [Builtin'] -> String -> String
show :: Builtin' -> String
$cshow :: Builtin' -> String
showsPrec :: Int -> Builtin' -> String -> String
$cshowsPrec :: Int -> Builtin' -> String -> String
Show, ReadPrec [Builtin']
ReadPrec Builtin'
Int -> ReadS Builtin'
ReadS [Builtin']
(Int -> ReadS Builtin')
-> ReadS [Builtin']
-> ReadPrec Builtin'
-> ReadPrec [Builtin']
-> Read Builtin'
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Builtin']
$creadListPrec :: ReadPrec [Builtin']
readPrec :: ReadPrec Builtin'
$creadPrec :: ReadPrec Builtin'
readList :: ReadS [Builtin']
$creadList :: ReadS [Builtin']
readsPrec :: Int -> ReadS Builtin'
$creadsPrec :: Int -> ReadS Builtin'
Read)

fun :: String -> Builtin'
fun :: String -> Builtin'
fun = [Type] -> String -> Builtin'
Fun []

infixOp :: String -> Builtin'
infixOp :: String -> Builtin'
infixOp = [Type] -> String -> Builtin'
InfixOp []

analyzeBuiltin :: Builtin -> Builtin'
analyzeBuiltin :: Builtin -> Builtin'
analyzeBuiltin = \case
  -- arithmetical functions
  Builtin
Negate -> String -> Builtin'
PrefixOp String
"negate"
  Builtin
Plus -> String -> Builtin'
infixOp String
"+"
  Builtin
Minus -> String -> Builtin'
infixOp String
"-"
  Builtin
Mult -> String -> Builtin'
infixOp String
"*"
  Builtin
FloorDiv -> String -> Builtin'
infixOp String
"/"
  Builtin
FloorMod -> String -> Builtin'
infixOp String
"%"
  Builtin
CeilDiv -> String -> Builtin'
fun String
"ceildiv"
  Builtin
CeilMod -> String -> Builtin'
fun String
"ceilmod"
  Builtin
Pow -> String -> Builtin'
infixOp String
"**"
  -- advanced arithmetical functions
  Builtin
Abs -> String -> Builtin'
fun String
"abs"
  Builtin
Gcd -> String -> Builtin'
fun String
"gcd"
  Builtin
Lcm -> String -> Builtin'
fun String
"lcm"
  Min2 Type
t -> [Type] -> String -> Builtin'
Fun [Type
t] String
"min"
  Max2 Type
t -> [Type] -> String -> Builtin'
Fun [Type
t] String
"max"
  -- logical functions
  Builtin
Not -> String -> Builtin'
PrefixOp String
"not"
  Builtin
And -> String -> Builtin'
infixOp String
"and"
  Builtin
Or -> String -> Builtin'
infixOp String
"or"
  Builtin
Implies -> String -> Builtin'
infixOp String
"implies"
  If Type
t -> Type -> Builtin'
If' Type
t
  -- bitwise functions
  Builtin
BitNot -> String -> Builtin'
PrefixOp String
"~"
  Builtin
BitAnd -> String -> Builtin'
infixOp String
"&"
  Builtin
BitOr -> String -> Builtin'
infixOp String
"|"
  Builtin
BitXor -> String -> Builtin'
infixOp String
"^"
  Builtin
BitLeftShift -> String -> Builtin'
infixOp String
"<<"
  Builtin
BitRightShift -> String -> Builtin'
infixOp String
">>"
  -- matrix functions
  MatAp Int
_ Int
_ -> String -> Builtin'
fun String
"matap"
  MatZero Int
_ -> String -> Builtin'
fun String
"matzero"
  MatOne Int
_ -> String -> Builtin'
fun String
"matone"
  MatAdd Int
_ Int
_ -> String -> Builtin'
fun String
"matadd"
  MatMul Int
_ Int
_ Int
_ -> String -> Builtin'
fun String
"matmul"
  MatPow Int
_ -> String -> Builtin'
fun String
"matpow"
  VecFloorMod Int
_ -> String -> Builtin'
fun String
"vecfloormod"
  MatFloorMod Int
_ Int
_ -> String -> Builtin'
fun String
"matfloormod"
  -- modular functions
  Builtin
ModNegate -> String -> Builtin'
fun String
"modnegate"
  Builtin
ModPlus -> String -> Builtin'
fun String
"modplus"
  Builtin
ModMinus -> String -> Builtin'
fun String
"modminus"
  Builtin
ModMult -> String -> Builtin'
fun String
"modmult"
  Builtin
ModInv -> String -> Builtin'
fun String
"modinv"
  Builtin
ModPow -> String -> Builtin'
fun String
"modpow"
  ModMatAp Int
_ Int
_ -> String -> Builtin'
fun String
"modmatap"
  ModMatAdd Int
_ Int
_ -> String -> Builtin'
fun String
"modmatadd"
  ModMatMul Int
_ Int
_ Int
_ -> String -> Builtin'
fun String
"modmatmul"
  ModMatPow Int
_ -> String -> Builtin'
fun String
"modmatpow"
  -- list functions
  Cons Type
t -> [Type] -> String -> Builtin'
Fun [Type
t] String
"cons"
  Snoc Type
t -> [Type] -> String -> Builtin'
Fun [Type
t] String
"snoc"
  Foldl Type
t1 Type
t2 -> [Type] -> String -> Builtin'
Fun [Type
t1, Type
t2] String
"foldl"
  Scanl Type
t1 Type
t2 -> [Type] -> String -> Builtin'
Fun [Type
t1, Type
t2] String
"scanl"
  Build Type
t -> [Type] -> String -> Builtin'
Fun [Type
t] String
"build"
  Iterate Type
t -> [Type] -> String -> Builtin'
Fun [Type
t] String
"iterate"
  Len Type
t -> [Type] -> String -> Builtin'
Fun [Type
t] String
"len"
  Map Type
t1 Type
t2 -> [Type] -> String -> Builtin'
Fun [Type
t1, Type
t2] String
"map"
  Filter Type
t -> [Type] -> String -> Builtin'
Fun [Type
t] String
"filter"
  At Type
t -> Type -> Builtin'
At' Type
t
  SetAt Type
t -> [Type] -> String -> Builtin'
Fun [Type
t] String
"setAt"
  Elem Type
t -> [Type] -> String -> Builtin'
Fun [Type
t] String
"elem"
  Builtin
Sum -> String -> Builtin'
fun String
"sum"
  Builtin
Product -> String -> Builtin'
fun String
"product"
  Builtin
ModSum -> String -> Builtin'
fun String
"modsum"
  Builtin
ModProduct -> String -> Builtin'
fun String
"modproduct"
  Min1 Type
t -> [Type] -> String -> Builtin'
Fun [Type
t] String
"min1"
  Max1 Type
t -> [Type] -> String -> Builtin'
Fun [Type
t] String
"max1"
  ArgMin Type
t -> [Type] -> String -> Builtin'
Fun [Type
t] String
"argmin"
  ArgMax Type
t -> [Type] -> String -> Builtin'
Fun [Type
t] String
"argmax"
  Builtin
All -> String -> Builtin'
fun String
"all"
  Builtin
Any -> String -> Builtin'
fun String
"any"
  Sorted Type
t -> [Type] -> String -> Builtin'
Fun [Type
t] String
"sort"
  Reversed Type
t -> [Type] -> String -> Builtin'
Fun [Type
t] String
"reverse"
  Builtin
Range1 -> String -> Builtin'
fun String
"range1"
  Builtin
Range2 -> String -> Builtin'
fun String
"range2"
  Builtin
Range3 -> String -> Builtin'
fun String
"range3"
  -- tuple functions
  Tuple [Type]
ts -> [Type] -> String -> Builtin'
Fun [Type]
ts String
"tuple"
  Proj [Type]
ts Int
n -> [Type] -> String -> Builtin'
Fun [Type]
ts (String
"proj" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)
  -- comparison
  LessThan Type
t -> [Type] -> String -> Builtin'
InfixOp [Type
t] String
"<"
  LessEqual Type
t -> [Type] -> String -> Builtin'
InfixOp [Type
t] String
"<="
  GreaterThan Type
t -> [Type] -> String -> Builtin'
InfixOp [Type
t] String
">"
  GreaterEqual Type
t -> [Type] -> String -> Builtin'
InfixOp [Type
t] String
">="
  Equal Type
t -> [Type] -> String -> Builtin'
InfixOp [Type
t] String
"=="
  NotEqual Type
t -> [Type] -> String -> Builtin'
InfixOp [Type
t] String
"!="
  -- combinational functions
  Builtin
Fact -> String -> Builtin'
fun String
"fact"
  Builtin
Choose -> String -> Builtin'
fun String
"choose"
  Builtin
Permute -> String -> Builtin'
fun String
"permute"
  Builtin
MultiChoose -> String -> Builtin'
fun String
"multichoose"
  -- data structures
  Builtin
ConvexHullTrickInit -> String -> Builtin'
fun String
"cht.init"
  Builtin
ConvexHullTrickGetMin -> String -> Builtin'
fun String
"cht.getmin"
  Builtin
ConvexHullTrickInsert -> String -> Builtin'
fun String
"cht.insert"
  SegmentTreeInitList Semigroup'
_ -> String -> Builtin'
fun String
"segtree.initlist"
  SegmentTreeGetRange Semigroup'
_ -> String -> Builtin'
fun String
"segtree.getrange"
  SegmentTreeSetPoint Semigroup'
_ -> String -> Builtin'
fun String
"segtree.setpoint"

formatTemplate :: [Type] -> String
formatTemplate :: [Type] -> String
formatTemplate = \case
  [] -> String
""
  [Type]
ts -> String
"<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Type -> String) -> [Type] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Type -> String
formatType [Type]
ts) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"

formatFunCall :: String -> [Expr] -> String
formatFunCall :: String -> [Expr] -> String
formatFunCall String
f = \case
  [] -> String
f
  [Expr]
args -> String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Expr -> String) -> [Expr] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> String
formatExpr' [Expr]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

formatBuiltinIsolated' :: Builtin' -> String
formatBuiltinIsolated' :: Builtin' -> String
formatBuiltinIsolated' = \case
  Fun [Type]
ts String
name -> String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Type] -> String
formatTemplate [Type]
ts
  PrefixOp String
op -> String -> String
paren String
op
  InfixOp [Type]
ts String
op -> String -> String
paren (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
op String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Type] -> String
formatTemplate [Type]
ts
  At' Type
t -> String -> String
paren (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"at" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Type] -> String
formatTemplate [Type
t]
  If' Type
t -> String -> String
paren (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"if-then-else" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Type] -> String
formatTemplate [Type
t]

formatBuiltinIsolated :: Builtin -> String
formatBuiltinIsolated :: Builtin -> String
formatBuiltinIsolated = Builtin' -> String
formatBuiltinIsolated' (Builtin' -> String) -> (Builtin -> Builtin') -> Builtin -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builtin -> Builtin'
analyzeBuiltin

formatBuiltin' :: Builtin' -> [Expr] -> String
formatBuiltin' :: Builtin' -> [Expr] -> String
formatBuiltin' Builtin'
builtin [Expr]
args = case (Builtin'
builtin, [Expr]
args) of
  (Fun [Type]
_ String
name, [Expr]
_) -> String -> [Expr] -> String
formatFunCall String
name [Expr]
args
  (PrefixOp String
op, Expr
e1 : [Expr]
args) -> String -> [Expr] -> String
formatFunCall (String -> String
paren (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
op String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
formatExpr' Expr
e1) [Expr]
args
  (InfixOp [Type]
_ String
op, Expr
e1 : Expr
e2 : [Expr]
args) -> String -> [Expr] -> String
formatFunCall (String -> String
paren (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Expr -> String
formatExpr' Expr
e1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
op String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
formatExpr' Expr
e2) [Expr]
args
  (At' Type
_, Expr
e1 : Expr
e2 : [Expr]
args) -> String -> [Expr] -> String
formatFunCall (String -> String
paren (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Expr -> String
formatExpr' Expr
e1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
formatExpr' Expr
e2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]") [Expr]
args
  (If' Type
_, Expr
e1 : Expr
e2 : Expr
e3 : [Expr]
args) -> String -> [Expr] -> String
formatFunCall (String -> String
paren (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"if" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
formatExpr' Expr
e1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" then " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
formatExpr' Expr
e2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" else " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
formatExpr' Expr
e3) [Expr]
args
  (Builtin', [Expr])
_ -> String -> [Expr] -> String
formatFunCall (Builtin' -> String
formatBuiltinIsolated' Builtin'
builtin) [Expr]
args

formatBuiltin :: Builtin -> [Expr] -> String
formatBuiltin :: Builtin -> [Expr] -> String
formatBuiltin = Builtin' -> [Expr] -> String
formatBuiltin' (Builtin' -> [Expr] -> String)
-> (Builtin -> Builtin') -> Builtin -> [Expr] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builtin -> Builtin'
analyzeBuiltin

formatLiteral :: Literal -> String
formatLiteral :: Literal -> String
formatLiteral = \case
  LitBuiltin Builtin
builtin -> Builtin -> String
formatBuiltinIsolated Builtin
builtin
  LitInt Integer
n -> Integer -> String
forall a. Show a => a -> String
show Integer
n
  LitBool Bool
p -> (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Bool -> String
forall a. Show a => a -> String
show Bool
p
  LitNil Type
t -> String
"nil" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Type] -> String
formatTemplate [Type
t]
  LitBottom Type
t String
_ -> String
"bottom" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Type] -> String
formatTemplate [Type
t]

formatFormalArgs :: [(VarName, Type)] -> String
formatFormalArgs :: [(VarName, Type)] -> String
formatFormalArgs [(VarName, Type)]
args = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((VarName, Type) -> String) -> [(VarName, Type)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(VarName
x, Type
t) -> String -> String
paren (VarName -> String
unVarName VarName
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
formatType Type
t)) [(VarName, Type)]
args

formatExpr' :: Expr -> String
formatExpr' :: Expr -> String
formatExpr' = \case
  Var VarName
x -> VarName -> String
unVarName VarName
x
  Lit Literal
lit -> Literal -> String
formatLiteral Literal
lit
  e :: Expr
e@(App Expr
_ Expr
_) ->
    let (Expr
f, [Expr]
args) = Expr -> (Expr, [Expr])
curryApp Expr
e
     in case Expr
f of
          Var VarName
x -> String -> [Expr] -> String
formatFunCall (VarName -> String
unVarName VarName
x) [Expr]
args
          Lit (LitBuiltin Builtin
builtin) -> Builtin -> [Expr] -> String
formatBuiltin Builtin
builtin [Expr]
args
          Expr
_ -> String -> [Expr] -> String
formatFunCall (Expr -> String
formatExpr' Expr
f) [Expr]
args
  e :: Expr
e@(Lam VarName
_ Type
_ Expr
_) ->
    let ([(VarName, Type)]
args, Expr
body) = Expr -> ([(VarName, Type)], Expr)
uncurryLam Expr
e
     in String -> String
paren (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"fun " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(VarName, Type)] -> String
formatFormalArgs [(VarName, Type)]
args String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ->\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
indent String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
formatExpr' Expr
body String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dedent String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
  Let VarName
x Type
t Expr
e1 Expr
e2 -> String
"let " String -> String -> String
forall a. [a] -> [a] -> [a]
++ VarName -> String
unVarName VarName
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
formatType Type
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" =\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
indent String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
formatExpr' Expr
e1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dedent String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nin " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
formatExpr' Expr
e2

formatExpr :: Expr -> String
formatExpr :: Expr -> String
formatExpr = [String] -> String
unwords ([String] -> String) -> (Expr -> [String]) -> Expr -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [String]
makeIndentFromMarkers Int
4 ([String] -> [String]) -> (Expr -> [String]) -> Expr -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [String]) -> (Expr -> String) -> Expr -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> String
formatExpr'

formatToplevelExpr :: ToplevelExpr -> [String]
formatToplevelExpr :: ToplevelExpr -> [String]
formatToplevelExpr = \case
  ResultExpr Expr
e -> String -> [String]
lines (Expr -> String
formatExpr' Expr
e)
  ToplevelLet VarName
x Type
t Expr
e ToplevelExpr
cont -> String -> Type -> Expr -> ToplevelExpr -> [String]
let' (VarName -> String
unVarName VarName
x) Type
t Expr
e ToplevelExpr
cont
  ToplevelLetRec VarName
f [(VarName, Type)]
args Type
ret Expr
e ToplevelExpr
cont -> String -> Type -> Expr -> ToplevelExpr -> [String]
let' (String
"rec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ VarName -> String
unVarName VarName
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(VarName, Type)] -> String
formatFormalArgs [(VarName, Type)]
args) Type
ret Expr
e ToplevelExpr
cont
  where
    let' :: String -> Type -> Expr -> ToplevelExpr -> [String]
let' String
s Type
t Expr
e ToplevelExpr
cont =
      [String
"let " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
formatType Type
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" =", String
indent]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
lines (Expr -> String
formatExpr' Expr
e)
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
dedent, String
"in"]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ToplevelExpr -> [String]
formatToplevelExpr ToplevelExpr
cont

formatProgram :: Program -> String
formatProgram :: ToplevelExpr -> String
formatProgram = [String] -> String
unlines ([String] -> String)
-> (ToplevelExpr -> [String]) -> ToplevelExpr -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [String]
makeIndentFromMarkers Int
4 ([String] -> [String])
-> (ToplevelExpr -> [String]) -> ToplevelExpr -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToplevelExpr -> [String]
formatToplevelExpr

run :: Applicative m => Program -> m Text
run :: ToplevelExpr -> m Text
run = Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> m Text)
-> (ToplevelExpr -> Text) -> ToplevelExpr -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Text)
-> (ToplevelExpr -> String) -> ToplevelExpr -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToplevelExpr -> String
formatProgram