{-# LANGUAGE CPP #-}
module IL.Pretty (ppModule) where
#if __GLASGOW_HASKELL__ >= 804
import Prelude hiding ((<>))
#endif
import Curry.Base.Ident
import Curry.Base.Pretty
import IL.Type
dataIndent :: Int
dataIndent :: Int
dataIndent = 2
bodyIndent :: Int
bodyIndent :: Int
bodyIndent = 2
exprIndent :: Int
exprIndent :: Int
exprIndent = 2
caseIndent :: Int
caseIndent :: Int
caseIndent = 2
altIndent :: Int
altIndent :: Int
altIndent = 2
orIndent :: Int
orIndent :: Int
orIndent = 2
ppModule :: Module -> Doc
ppModule :: Module -> Doc
ppModule (Module m :: ModuleIdent
m is :: [ModuleIdent]
is ds :: [Decl]
ds) = [Doc] -> Doc
sepByBlankLine
[ModuleIdent -> Doc
ppHeader ModuleIdent
m, [Doc] -> Doc
vcat ((ModuleIdent -> Doc) -> [ModuleIdent] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ModuleIdent -> Doc
ppImport [ModuleIdent]
is), [Doc] -> Doc
sepByBlankLine ((Decl -> Doc) -> [Decl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Decl -> Doc
ppDecl [Decl]
ds)]
ppHeader :: ModuleIdent -> Doc
m :: ModuleIdent
m = String -> Doc
text "module" Doc -> Doc -> Doc
<+> String -> Doc
text (ModuleIdent -> String
moduleName ModuleIdent
m) Doc -> Doc -> Doc
<+> String -> Doc
text "where"
ppImport :: ModuleIdent -> Doc
ppImport :: ModuleIdent -> Doc
ppImport m :: ModuleIdent
m = String -> Doc
text "import" Doc -> Doc -> Doc
<+> String -> Doc
text (ModuleIdent -> String
moduleName ModuleIdent
m)
ppDecl :: Decl -> Doc
ppDecl :: Decl -> Doc
ppDecl (DataDecl tc :: QualIdent
tc n :: Int
n cs :: [ConstrDecl]
cs) = [Doc] -> Doc
sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
String -> Doc
text "data" Doc -> Doc -> Doc
<+> QualIdent -> Int -> Doc
ppTypeLhs QualIdent
tc Int
n Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:
(Doc -> Doc) -> [Doc] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Doc -> Doc
nest Int
dataIndent)
((Doc -> Doc -> Doc) -> [Doc] -> [Doc] -> [Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Doc -> Doc -> Doc
(<+>) (Doc
equals Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: Doc -> [Doc]
forall a. a -> [a]
repeat (Char -> Doc
char '|')) ((ConstrDecl -> Doc) -> [ConstrDecl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ConstrDecl -> Doc
ppConstr [ConstrDecl]
cs))
ppDecl (ExternalDataDecl tc :: QualIdent
tc n :: Int
n) =
String -> Doc
text "external data" Doc -> Doc -> Doc
<+> QualIdent -> Int -> Doc
ppTypeLhs QualIdent
tc Int
n
ppDecl (FunctionDecl f :: QualIdent
f vs :: [(Type, Ident)]
vs ty :: Type
ty e :: Expression
e) = QualIdent -> Type -> Doc
ppTypeSig QualIdent
f Type
ty Doc -> Doc -> Doc
$$ [Doc] -> Doc
sep
[ QualIdent -> Doc
ppQIdent QualIdent
f Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (((Type, Ident) -> Doc) -> [(Type, Ident)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Ident -> Doc
ppIdent (Ident -> Doc) -> ((Type, Ident) -> Ident) -> (Type, Ident) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type, Ident) -> Ident
forall a b. (a, b) -> b
snd) [(Type, Ident)]
vs) Doc -> Doc -> Doc
<+> Doc
equals
, Int -> Doc -> Doc
nest Int
bodyIndent (Int -> Expression -> Doc
ppExpr 0 Expression
e)]
ppDecl (ExternalDecl f :: QualIdent
f ty :: Type
ty) = String -> Doc
text "external" Doc -> Doc -> Doc
<+> QualIdent -> Type -> Doc
ppTypeSig QualIdent
f Type
ty
ppTypeLhs :: QualIdent -> Int -> Doc
ppTypeLhs :: QualIdent -> Int -> Doc
ppTypeLhs tc :: QualIdent
tc n :: Int
n = QualIdent -> Doc
ppQIdent QualIdent
tc Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
n [String]
typeVars))
ppConstr :: ConstrDecl -> Doc
ppConstr :: ConstrDecl -> Doc
ppConstr (ConstrDecl c :: QualIdent
c tys :: [Type]
tys) = QualIdent -> Doc
ppQIdent QualIdent
c Doc -> Doc -> Doc
<+> [Doc] -> Doc
fsep ((Type -> Doc) -> [Type] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Type -> Doc
ppType 2) [Type]
tys)
ppTypeSig :: QualIdent -> Type -> Doc
ppTypeSig :: QualIdent -> Type -> Doc
ppTypeSig f :: QualIdent
f ty :: Type
ty = QualIdent -> Doc
ppQIdent QualIdent
f Doc -> Doc -> Doc
<+> String -> Doc
text "::" Doc -> Doc -> Doc
<+> Int -> Type -> Doc
ppType 0 Type
ty
ppType :: Int -> Type -> Doc
ppType :: Int -> Type -> Doc
ppType p :: Int
p (TypeConstructor tc :: QualIdent
tc tys :: [Type]
tys)
| QualIdent -> Bool
isQTupleId QualIdent
tc = Doc -> Doc
parens
([Doc] -> Doc
fsep (Doc -> [Doc] -> [Doc]
punctuate Doc
comma ((Type -> Doc) -> [Type] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Type -> Doc
ppType 0) [Type]
tys)))
| QualIdent
tc QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
qListId Bool -> Bool -> Bool
&& [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 = Doc -> Doc
brackets (Int -> Type -> Doc
ppType 0 ([Type] -> Type
forall a. [a] -> a
head [Type]
tys))
| Bool
otherwise = Bool -> Doc -> Doc
parenIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1 Bool -> Bool -> Bool
&& Bool -> Bool
not ([Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
tys))
(QualIdent -> Doc
ppQIdent QualIdent
tc Doc -> Doc -> Doc
<+> [Doc] -> Doc
fsep ((Type -> Doc) -> [Type] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Type -> Doc
ppType 2) [Type]
tys))
ppType _ (TypeVariable n :: Int
n) = Int -> Doc
ppTypeVar Int
n
ppType p :: Int
p (TypeArrow ty1 :: Type
ty1 ty2 :: Type
ty2) = Bool -> Doc -> Doc
parenIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0)
([Doc] -> Doc
fsep (Type -> [Doc]
ppArrow (Type -> Type -> Type
TypeArrow Type
ty1 Type
ty2)))
where
ppArrow :: Type -> [Doc]
ppArrow (TypeArrow ty1' :: Type
ty1' ty2' :: Type
ty2') = Int -> Type -> Doc
ppType 1 Type
ty1' Doc -> Doc -> Doc
<+> String -> Doc
text "->" Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: Type -> [Doc]
ppArrow Type
ty2'
ppArrow ty :: Type
ty = [Int -> Type -> Doc
ppType 0 Type
ty]
ppType p :: Int
p (TypeForall ns :: [Int]
ns ty :: Type
ty)
| [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
ns = Int -> Type -> Doc
ppType Int
p Type
ty
| Bool
otherwise = Bool -> Doc -> Doc
parenIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Int] -> Doc
ppQuantifiedTypeVars [Int]
ns Doc -> Doc -> Doc
<+> Int -> Type -> Doc
ppType 0 Type
ty
ppTypeVar :: Int -> Doc
ppTypeVar :: Int -> Doc
ppTypeVar n :: Int
n
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 = String -> Doc
text ([String]
typeVars [String] -> Int -> String
forall a. [a] -> Int -> a
!! Int
n)
| Bool
otherwise = String -> Doc
text ('_'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show (-Int
n))
ppQuantifiedTypeVars :: [Int] -> Doc
ppQuantifiedTypeVars :: [Int] -> Doc
ppQuantifiedTypeVars ns :: [Int]
ns
| [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
ns = Doc
empty
| Bool
otherwise = String -> Doc
text "forall" Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((Int -> Doc) -> [Int] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Doc
ppTypeVar [Int]
ns) Doc -> Doc -> Doc
<+> Char -> Doc
char '.'
ppBinding :: Binding -> Doc
ppBinding :: Binding -> Doc
ppBinding (Binding v :: Ident
v expr :: Expression
expr) = [Doc] -> Doc
sep
[Ident -> Doc
ppIdent Ident
v Doc -> Doc -> Doc
<+> Doc
equals, Int -> Doc -> Doc
nest Int
bodyIndent (Int -> Expression -> Doc
ppExpr 0 Expression
expr)]
ppAlt :: Alt -> Doc
ppAlt :: Alt -> Doc
ppAlt (Alt pat :: ConstrTerm
pat expr :: Expression
expr) = [Doc] -> Doc
sep
[ConstrTerm -> Doc
ppConstrTerm ConstrTerm
pat Doc -> Doc -> Doc
<+> String -> Doc
text "->", Int -> Doc -> Doc
nest Int
altIndent (Int -> Expression -> Doc
ppExpr 0 Expression
expr)]
ppLiteral :: Literal -> Doc
ppLiteral :: Literal -> Doc
ppLiteral (Char c :: Char
c) = String -> Doc
text (Char -> String
forall a. Show a => a -> String
show Char
c)
ppLiteral (Int i :: Integer
i) = Integer -> Doc
integer Integer
i
ppLiteral (Float f :: Double
f) = Double -> Doc
double Double
f
ppConstrTerm :: ConstrTerm -> Doc
ppConstrTerm :: ConstrTerm -> Doc
ppConstrTerm (LiteralPattern _ l :: Literal
l) = Literal -> Doc
ppLiteral Literal
l
ppConstrTerm (ConstructorPattern _ c :: QualIdent
c [(_, v1 :: Ident
v1), (_, v2 :: Ident
v2)])
| QualIdent -> Bool
isQInfixOp QualIdent
c = Ident -> Doc
ppIdent Ident
v1 Doc -> Doc -> Doc
<+> QualIdent -> Doc
ppQInfixOp QualIdent
c Doc -> Doc -> Doc
<+> Ident -> Doc
ppIdent Ident
v2
ppConstrTerm (ConstructorPattern _ c :: QualIdent
c vs :: [(Type, Ident)]
vs)
| QualIdent -> Bool
isQTupleId QualIdent
c = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
fsep (Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ ((Type, Ident) -> Doc) -> [(Type, Ident)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Ident -> Doc
ppIdent (Ident -> Doc) -> ((Type, Ident) -> Ident) -> (Type, Ident) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type, Ident) -> Ident
forall a b. (a, b) -> b
snd) [(Type, Ident)]
vs)
| Bool
otherwise = QualIdent -> Doc
ppQIdent QualIdent
c Doc -> Doc -> Doc
<+> [Doc] -> Doc
fsep (((Type, Ident) -> Doc) -> [(Type, Ident)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Ident -> Doc
ppIdent (Ident -> Doc) -> ((Type, Ident) -> Ident) -> (Type, Ident) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type, Ident) -> Ident
forall a b. (a, b) -> b
snd) [(Type, Ident)]
vs)
ppConstrTerm (VariablePattern _ v :: Ident
v) = Ident -> Doc
ppIdent Ident
v
ppExpr :: Int -> Expression -> Doc
ppExpr :: Int -> Expression -> Doc
ppExpr _ (Literal _ l :: Literal
l) = Literal -> Doc
ppLiteral Literal
l
ppExpr _ (Variable _ v :: Ident
v) = Ident -> Doc
ppIdent Ident
v
ppExpr _ (Function _ f :: QualIdent
f _) = QualIdent -> Doc
ppQIdent QualIdent
f
ppExpr _ (Constructor _ c :: QualIdent
c _) = QualIdent -> Doc
ppQIdent QualIdent
c
ppExpr p :: Int
p (Apply (Apply (Function _ f :: QualIdent
f _) e1 :: Expression
e1) e2 :: Expression
e2)
| QualIdent -> Bool
isQInfixOp QualIdent
f = Int -> Expression -> QualIdent -> Expression -> Doc
ppInfixApp Int
p Expression
e1 QualIdent
f Expression
e2
ppExpr p :: Int
p (Apply (Apply (Constructor _ c :: QualIdent
c _) e1 :: Expression
e1) e2 :: Expression
e2)
| QualIdent -> Bool
isQInfixOp QualIdent
c = Int -> Expression -> QualIdent -> Expression -> Doc
ppInfixApp Int
p Expression
e1 QualIdent
c Expression
e2
ppExpr p :: Int
p (Apply e1 :: Expression
e1 e2 :: Expression
e2) = Bool -> Doc -> Doc
parenIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 2) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep
[Int -> Expression -> Doc
ppExpr 2 Expression
e1, Int -> Doc -> Doc
nest Int
exprIndent (Int -> Expression -> Doc
ppExpr 3 Expression
e2)]
ppExpr p :: Int
p (Case ev :: Eval
ev e :: Expression
e alts :: [Alt]
alts) = Bool -> Doc -> Doc
parenIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
String -> Doc
text "case" Doc -> Doc -> Doc
<+> Eval -> Doc
ppEval Eval
ev Doc -> Doc -> Doc
<+> Int -> Expression -> Doc
ppExpr 0 Expression
e Doc -> Doc -> Doc
<+> String -> Doc
text "of"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
caseIndent ([Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Alt -> Doc) -> [Alt] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Alt -> Doc
ppAlt [Alt]
alts)
where ppEval :: Eval -> Doc
ppEval Rigid = String -> Doc
text "rigid"
ppEval Flex = String -> Doc
text "flex"
ppExpr p :: Int
p (Or e1 :: Expression
e1 e2 :: Expression
e2) = Bool -> Doc -> Doc
parenIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep
[Int -> Doc -> Doc
nest Int
orIndent (Int -> Expression -> Doc
ppExpr 0 Expression
e1), Char -> Doc
char '|', Int -> Doc -> Doc
nest Int
orIndent (Int -> Expression -> Doc
ppExpr 0 Expression
e2)]
ppExpr p :: Int
p (Exist v :: Ident
v _ e :: Expression
e) = Bool -> Doc -> Doc
parenIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep
[String -> Doc
text "let" Doc -> Doc -> Doc
<+> Ident -> Doc
ppIdent Ident
v Doc -> Doc -> Doc
<+> String -> Doc
text "free" Doc -> Doc -> Doc
<+> String -> Doc
text "in", Int -> Expression -> Doc
ppExpr 0 Expression
e]
ppExpr p :: Int
p (Let b :: Binding
b e :: Expression
e) = Bool -> Doc -> Doc
parenIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep
[String -> Doc
text "let" Doc -> Doc -> Doc
<+> Binding -> Doc
ppBinding Binding
b Doc -> Doc -> Doc
<+> String -> Doc
text "in",Int -> Expression -> Doc
ppExpr 0 Expression
e]
ppExpr p :: Int
p (Letrec bs :: [Binding]
bs e :: Expression
e) = Bool -> Doc -> Doc
parenIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep
[String -> Doc
text "letrec" Doc -> Doc -> Doc
<+> [Doc] -> Doc
vcat ((Binding -> Doc) -> [Binding] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Binding -> Doc
ppBinding [Binding]
bs) Doc -> Doc -> Doc
<+> String -> Doc
text "in", Int -> Expression -> Doc
ppExpr 0 Expression
e]
ppExpr p :: Int
p (Typed e :: Expression
e ty :: Type
ty) = Bool -> Doc -> Doc
parenIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep
[Int -> Expression -> Doc
ppExpr 0 Expression
e, String -> Doc
text "::", Int -> Type -> Doc
ppType 0 Type
ty]
ppInfixApp :: Int -> Expression -> QualIdent -> Expression -> Doc
ppInfixApp :: Int -> Expression -> QualIdent -> Expression -> Doc
ppInfixApp p :: Int
p e1 :: Expression
e1 op :: QualIdent
op e2 :: Expression
e2 = Bool -> Doc -> Doc
parenIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep
[Int -> Expression -> Doc
ppExpr 2 Expression
e1 Doc -> Doc -> Doc
<+> QualIdent -> Doc
ppQInfixOp QualIdent
op, Int -> Doc -> Doc
nest Int
exprIndent (Int -> Expression -> Doc
ppExpr 2 Expression
e2)]
ppIdent :: Ident -> Doc
ppIdent :: Ident -> Doc
ppIdent ident :: Ident
ident
| Ident -> Bool
isInfixOp Ident
ident = Doc -> Doc
parens (Ident -> Doc
ppName Ident
ident)
| Bool
otherwise = Ident -> Doc
ppName Ident
ident
ppQIdent :: QualIdent -> Doc
ppQIdent :: QualIdent -> Doc
ppQIdent ident :: QualIdent
ident
| QualIdent -> Bool
isQInfixOp QualIdent
ident = Doc -> Doc
parens (QualIdent -> Doc
ppQual QualIdent
ident)
| Bool
otherwise = QualIdent -> Doc
ppQual QualIdent
ident
ppQInfixOp :: QualIdent -> Doc
ppQInfixOp :: QualIdent -> Doc
ppQInfixOp op :: QualIdent
op
| QualIdent -> Bool
isQInfixOp QualIdent
op = QualIdent -> Doc
ppQual QualIdent
op
| Bool
otherwise = Char -> Doc
char '`' Doc -> Doc -> Doc
<> QualIdent -> Doc
ppQual QualIdent
op Doc -> Doc -> Doc
<> Char -> Doc
char '`'
ppName :: Ident -> Doc
ppName :: Ident -> Doc
ppName x :: Ident
x = String -> Doc
text (Ident -> String
idName Ident
x)
ppQual :: QualIdent -> Doc
ppQual :: QualIdent -> Doc
ppQual x :: QualIdent
x = String -> Doc
text (QualIdent -> String
qualName QualIdent
x)
typeVars :: [String]
typeVars :: [String]
typeVars = [Char -> Int -> String
mkTypeVar Char
c Int
i | Int
i <- [0 .. ], Char
c <- ['a' .. 'z']] where
mkTypeVar :: Char -> Int -> String
mkTypeVar :: Char -> Int -> String
mkTypeVar c :: Char
c i :: Int
i = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then [] else Int -> String
forall a. Show a => a -> String
show Int
i