% $Id: ILxml.lhs,v 1.0 2001/06/19 12:19:18 rafa Exp $
%
% $Log: ILxml.lhs,v $
%
% Revision 1.1 2001/06/19 12:19:18 rafa
% Pretty printer in XML for the intermediate language added.
%
%
% Modified by Martin Engelke (men@informatik.uni-kiel.de)
%
\nwfilename{ILxml.lhs}
\section{A pretty printer in XML for the intermediate language}
This module implements just another pretty printer, this time in XML and for
the intermediate language. It was mainly adapted from the Curry pretty
printer (see sect.~\ref{sec:CurryPP}), which in turn is based on Simon
Marlow's pretty printer for Haskell. The format of the output intends to be
similar to that of Flat-Curry XML representation.
\begin{verbatim}
> module IL.XML(module IL.XML) where
> import Data.Maybe
> import Curry.Base.Ident
> import qualified Curry.Syntax as CS
> import IL.Type
> import CurryEnv
> import PrettyCombinators
> -- identation level
> level::Int
> level = 3
> xmlModule :: CurryEnv -> Module -> Doc
> xmlModule cEnv m = text "<prog>" $$ nest level (xmlBody cEnv m)
> $$ text "</prog>"
> xmlBody :: CurryEnv -> Module -> Doc
> xmlBody cEnv (Module name imports decls) =
> xmlElement "module" xmlModuleDecl moduleDecl $$
> xmlElement "import" xmlImportDecl importDecl $$
> xmlElement "types" xmlTypeDecl typeDecl $$
> xmlElement "functions" xmlFunctionDecl functionDecl $$
> xmlElement "operators" xmlOperatorDecl operatorDecl $$
> xmlElement "translation" xmlTranslationDecl translationDecl
> where
> moduleDecl = [name]
> importDecl = imports
> operatorDecl = infixDecls cEnv
> translationDecl = foldl (qualIDeclId (moduleId cEnv))
> []
> (interface cEnv)
> (functionDecl,typeDecl) = splitDecls decls
> -- =========================================================================
> xmlModuleDecl :: ModuleIdent -> Doc
> xmlModuleDecl name = xmlModuleIdent name
> -- =========================================================================
> xmlImportDecl :: ModuleIdent -> Doc
> xmlImportDecl name = xmlElement "module" xmlModuleDecl [name]
> -- =========================================================================
> -- T Y P E S
> -- =========================================================================
> xmlTypeDecl :: Decl -> Doc
> xmlTypeDecl (DataDecl tc arity cs) =
> beginType $$
> nest level (xmlTypeParams arity) $$
> xmlLines xmlConstructor cs $$
> endType
> where
> beginType = text "<type name=\"" <> (xmlQualIdent tc) <> text "\">"
> endType = text "</type>"
> xmlTypeParams :: Int -> Doc
> xmlTypeParams n = xmlElement "params" xmlTypeVar [0..(n-1)]
> xmlConstructor :: ConstrDecl [Type] -> Doc
> xmlConstructor (ConstrDecl ident []) = xmlConstructorBegin ident 0
> xmlConstructor (ConstrDecl ident l) =
> xmlConstructorBegin ident (length l) $$
> xmlLines xmlType l $$
> xmlConstructorEnd
> where
> xmlConstructorEnd = text "</cons>"
> xmlConstructorBegin :: QualIdent -> Int -> Doc
> xmlConstructorBegin ident n = xmlHeadingWithArity "cons" ident n (n==0)
> xmlHeadingWithArity :: String -> QualIdent -> Int -> Bool -> Doc
> xmlHeadingWithArity tagName ident n single =
> if single
> then prefix<>text "/>"
> else prefix<> text ">"
> where
> prefix = text ("<"++tagName++" name=\"") <> name <> text "\" " <> arity
> arity = text "arity=\"" <> xmlInt n <> text "\""
> name = xmlQualIdent ident
> xmlType :: Type -> Doc
> xmlType (TypeConstructor ident []) = xmlTypeConsBegin ident True
> xmlType (TypeConstructor ident l) = xmlTypeConsBegin ident False $$
> xmlLines xmlType l $$
> xmlTypeConsEnd
> where
> xmlTypeConsEnd = text "</tcons>"
> xmlType (TypeVariable n) = xmlTypeVar n
> xmlType (TypeArrow a b) = xmlTypeFun a b
> xmlTypeConsBegin :: QualIdent -> Bool -> Doc
> xmlTypeConsBegin ident single =
> if single
> then prefix <> text "/>"
> else prefix <> text ">"
> where
> name = xmlQualIdent ident
> prefix = text "<tcons name=\"" <> name <> text "\""
> xmlTypeVar :: Int -> Doc
> xmlTypeVar n = text "<tvar>"<> xmlInt n <> text "</tvar>"
> xmlTypeFun :: Type -> Type -> Doc
> xmlTypeFun a b = xmlElement "functype" xmlType [a,b]
> -- =========================================================================
> -- F U N C T I O N S
> -- =========================================================================
> xmlFunctionDecl :: Decl -> Doc
> xmlFunctionDecl (NewtypeDecl tc arity (ConstrDecl ident ty)) =
> xmlFunctionDecl (FunctionDecl ident [arg] ftype (Variable arg))
> where
> arg = mkIdent "_1"
> ftype = TypeArrow ty (TypeConstructor tc (map TypeVariable [0..arity-1]))
> xmlFunctionDecl (FunctionDecl ident largs fType expr) =
> heading $$ nest level (xmlRule largs expr) $$ end
> where
> heading = xmlBeginFunction ident (length largs) fType
> end = text "</func>"
> xmlFunctionDecl (ExternalDecl ident callConv internalName fType) =
> heading $$ external $$ end
> where
> heading = xmlBeginFunction ident (xmlFunctionArity fType) fType
> external = text ("<external>"
> ++ xmlFormat internalName
> ++ "</external>")
> end = text "</func>"
> xmlBeginFunction :: QualIdent -> Int -> Type -> Doc
> xmlBeginFunction ident n fType =
> heading $$ typeDecls
> where
> heading = xmlHeadingWithArity "func" ident n False
> typeDecls = nest level (xmlType fType)
> xmlEndFunction :: Doc
> xmlEndFunction = text "</func>"
> xmlFunctionArity :: Type -> Int
> xmlFunctionArity (TypeConstructor ident l) = 0
> xmlFunctionArity (TypeVariable n) = 0
> xmlFunctionArity (TypeArrow a b) = 1 + (xmlFunctionArity b)
> xmlRule :: [Ident] -> Expression -> Doc
> xmlRule lArgs e = text "<rule>" $$
> nest level (xmlLhs lArgs) $$
> nest level (xmlRhs lArgs e) $$
> text "</rule>"
> xmlLhs :: [Ident] -> Doc
> xmlLhs l = xmlElement "lhs" xmlVar [0..((length l)-1)]
> xmlRhs :: [Ident] -> Expression -> Doc
> xmlRhs l e = text "<rhs>" $$ nest level rhs $$ text "</rhs>"
> where
> varDicc = xmlBuildDicc l
> (rhs, _) = xmlExpr varDicc e
> -- =========================================================================
> -- =========================================================================
> -- E X P R E S S I O N S
> -- =========================================================================
> xmlExpr :: [(Int,Ident)] -> Expression -> (Doc,[(Int,Ident)])
> xmlExpr d (Literal lit) = (xmlLiteral (xmlLit lit),d)
> xmlExpr d (Variable ident) = xmlExprVar d ident
> xmlExpr d (Function ident arity) = (xmlSingleApp ident arity True,d)
> xmlExpr d (Constructor ident arity) = (xmlSingleApp ident arity False,d)
> xmlExpr d exp@(Apply e1 e2) = xmlApply d exp (xmlAppArgs exp)
> xmlExpr d (Case _ eval expr alt) = xmlCase d eval expr alt
> xmlExpr d (Or expr1 expr2) = xmlOr d expr1 expr2
> xmlExpr d (Exist ident expr) = xmlFree d ident expr
> xmlExpr d (Let binding expr) = xmlLet d binding expr
> xmlExpr d (Letrec lBinding expr) = xmlLetrec d lBinding expr
> --error "Recursive let bindings not supported in FlatCurry"
> -- =========================================================================
> xmlSingleApp :: QualIdent -> Int -> Bool -> Doc
> xmlSingleApp ident arity isFunction =
> if arity>0
> then xmlCombHeading identDoc (text "PartCall") True
> else xmlCombHeading identDoc (text totalApp) True
> where
> identDoc = xmlQualIdent ident
> totalApp = if isFunction then "FuncCall" else "ConsCall"
> xmlCombHeading :: Doc -> Doc -> Bool -> Doc
> xmlCombHeading name cType single =
> if single
> then prefix <> text " />"
> else prefix <> text ">"
> where
> prefix = text "<comb type=\""<>cType<>text "\" name=\""<>name<>text "\""
> -- =========================================================================
> xmlExprVar :: [(Int,Ident)] -> Ident -> (Doc,[(Int,Ident)])
> xmlExprVar d ident =
> if isNew
> then (xmlVar newVar, (newVar,ident):d)
> else (xmlVar var, d)
> where
> var = xmlLookUp ident d
> isNew = var == -1
> newVar = xmlNewVar d
> -- =========================================================================
> xmlApply :: [(Int,Ident)] -> Expression -> (Expression,[Expression]) ->
> (Doc,[(Int,Ident)])
> xmlApply d exp ((Function ident arity),lExp) =
> xmlApplyFunctor d ident arity lExp True
> xmlApply d exp ((Constructor ident arity),lExp) =
> xmlApplyFunctor d ident arity lExp False
> xmlApply d (Apply expr1 expr2) e' =
> (text "<apply>" $$ nest level e1 $$ nest level e2 $$ text "</apply>", d2)
> where
> (e1,d1) = xmlExpr d expr1
> (e2,d2) = xmlExpr d1 expr2
> xmlApplyFunctor ::[(Int,Ident)] -> QualIdent -> Int -> [Expression] ->
> Bool -> (Doc,[(Int,Ident)])
> xmlApplyFunctor d ident arity lArgs isFunction =
> xmlCombApply d (xmlQualIdent ident) (text cTypeS) n lArgs
> where
> n = length (lArgs)
> cTypeS = if n==arity
> then if isFunction
> then "FuncCall"
> else "ConsCall"
> else "PartCall"
> xmlCombApply :: [(Int,Ident)] -> Doc -> Doc -> Int ->
> [Expression] -> (Doc,[(Int,Ident)])
> xmlCombApply d name cType 0 lArgs =
> (xmlCombHeading name cType True,d)
> xmlCombApply d name cType n lArgs =
> (xmlCombHeading name cType False $$ xmlLines id lDocs$$ text "</comb>", d1)
> where
> (lDocs,d1) = xmlMapDicc d xmlExpr lArgs
> xmlAppArgs :: Expression -> (Expression,[Expression])
> xmlAppArgs (Apply e1 e2) = (e,lArgs++[e2])
> where
> (e,lArgs) = (xmlAppArgs e1)
> xmlAppArgs e = (e,[])
> -- =========================================================================
> -- =========================================================================
> xmlCase :: [(Int,Ident)] -> Eval -> Expression -> [Alt] -> (Doc,[(Int,Ident)])
> xmlCase d eval expr lAlt =
> (heading $$ nest level e1 $$ xmlLines id lDocs$$ end,d2)
> where
> sEval = if eval==Rigid then "\"Rigid\"" else "\"Flex\""
> heading = text "<case type=" <> text sEval <> text ">"
> end = text "</case>"
> (e1,_) = xmlExpr d expr
> (lDocs,d2) = xmlMapDicc d xmlBranch lAlt
> xmlOr :: [(Int,Ident)] -> Expression -> Expression -> (Doc,[(Int,Ident)])
> xmlOr d expr1 expr2 =
> (text "<or>" $$ nest level e1 $$ nest level e2 $$ text "</or>",d2)
> where
> (e1,d1) = xmlExpr d expr1
> (e2,d2) = xmlExpr d1 expr2
> xmlBranch :: [(Int,Ident)] -> Alt -> (Doc,[(Int,Ident)])
> xmlBranch d (Alt pattern expr) =
> (text "<branch>" $$ nest level e1 $$ nest level e2 $$ text "</branch>",d2)
> where
> (e1,d1) = xmlPattern d pattern
> (e2,d2) = xmlExpr d1 expr
> xmlPattern :: [(Int,Ident)] -> ConstrTerm -> (Doc,[(Int,Ident)])
> xmlPattern d (LiteralPattern lit) = (xmlLitPattern (xmlLit lit),d)
> xmlPattern d (ConstructorPattern ident lArgs) = xmlConsPattern d ident lArgs
> xmlPattern d (VariablePattern _) = error "Variable patterns not allowed in Flat Curry"
> xmlConsPattern :: [(Int,Ident)] -> QualIdent -> [Ident] -> (Doc,[(Int,Ident)])
> xmlConsPattern d ident lArgs =
> (heading $$ xmlLines id lDocs $$ end,d2)
> where
> heading = text "<pattern name=\""<> (xmlQualIdent ident) <>
> text "\"" <> endh
> endh = if (length lArgs)>0 then text ">" else text "/>"
> end = if (length lArgs)>0 then text "</pattern>" else empty
> (lDocs,d2) = xmlMapDicc d xmlExprVar lArgs
> -- =========================================================================
> xmlFree :: [(Int,Ident)] -> Ident -> Expression -> (Doc,[(Int,Ident)])
> xmlFree d ident exp =
> (text "<freevars>" $$ nest level v $$ nest level e $$ text "</freevars>",d2)
> where
> (v,d1) = xmlExprVar d ident
> (e,d2) = xmlExpr d1 exp
> -- =========================================================================
> xmlLet :: [(Int,Ident)] -> Binding -> Expression -> (Doc,[(Int,Ident)])
> xmlLet d binding exp =
> (text "<let>" $$ nest level b $$ nest level e $$ text "</let>", d2)
> where
> (b,d1) = xmlBinding d binding
> (e,d2) = xmlExpr d1 exp
> xmlBinding :: [(Int,Ident)] -> Binding -> (Doc,[(Int,Ident)])
> xmlBinding d (Binding ident exp) =
> (text "<binding>" $$ nest level v $$ nest level e $$ text "</binding>",d2)
> where
> (v,_) = xmlExprVar d ident
> (e,d2) = xmlExpr d exp
> -- =========================================================================
> xmlLetrec :: [(Int,Ident)] -> [Binding] -> Expression -> (Doc,[(Int,Ident)])
> xmlLetrec d lB exp =
> (text "<letrec>" $$ xmlLines id b $$ nest level e $$ text "</letrec>",d2)
> where
> (b,d1) = xmlMapDicc d xmlBinding lB
> (e,d2) = xmlExpr d1 exp
> -- =========================================================================
> -- =========================================================================
> -- A U X I L I A R Y F U N C T I O N S
> -- =========================================================================
> splitDecls :: [Decl] -> ([Decl],[Decl])
> splitDecls [] = ([],[])
> splitDecls (x:xs) = case x of
> DataDecl _ _ _ -> (functionDecl,x:typeDecl)
> NewtypeDecl _ _ _ -> (x:functionDecl,typeDecl)
> FunctionDecl _ _ _ _ -> (x:functionDecl,typeDecl)
> ExternalDecl _ _ _ _ -> (x:functionDecl,typeDecl)
> where
> (functionDecl,typeDecl) = splitDecls xs
> xmlElement :: Eq a => String -> (a -> Doc) -> [a] -> Doc
> xmlElement name f [] = text ("<"++name++" />")
> xmlElement name f lDecls = beginElement $$ xmlLines f lDecls $$ endElement
> where
> beginElement = text ("<"++name++">")
> endElement = text ("</"++name++">")
>
> xmlLines :: (a -> Doc) -> [a] -> Doc
> xmlLines f = (nest level).vcat.(map f)
> xmlMapDicc::[(Int,Ident)] -> ([(Int,Ident)] -> a -> (Doc,[(Int,Ident)])) ->
> [a] -> ([Doc],[(Int,Ident)])
> xmlMapDicc d f lArgs = foldl newArg ([],d) lArgs
> where
> newArg (l,d) e = (l++[v'],d')
> where (v',d') = f d e
>
> -- The dictionary identifies var names with integers
> -- it will be ordered starting at the greatest integer
> xmlBuildDicc :: [Ident] -> [(Int,Ident)]
> xmlBuildDicc l = reverse (zip [0..((length l)-1)] l)
> -- looks for a ident in the dictorionary. If it appears returns its
> -- associated value. Otherwise, -1 is returned
> xmlLookUp :: Ident -> [(Int,Ident)] -> Int
> xmlLookUp ident [] = -1
> xmlLookUp ident ((n,name):xs) = if ident==name
> then n
> else xmlLookUp ident xs
> -- generates a integer corresponding to a new var
> xmlNewVar :: [(Int,Ident)] -> Int
> xmlNewVar [] = 0
> xmlNewVar ((n,ident):xs) = n+1
> xmlVar :: Int -> Doc
> xmlVar n = text "<var>" <> xmlInt n <> text "</var>"
> xmlLiteral :: Doc -> Doc
> xmlLiteral d = text "<lit>" $$ nest level d $$ text "</lit>"
> xmlLitPattern :: Doc -> Doc
> xmlLitPattern d = text "<lpattern>" $$ nest level d $$ text "</lpattern>"
> xmlLit :: Literal -> Doc
> xmlLit (Char _ c) = text "<charc>" <> xmlInt (fromEnum c) <> text "</charc>"
> xmlLit (Int _ n) = text "<intc>" <> xmlInteger n <> text "</intc>"
> xmlLit (Float _ n) = text "<floatc>" <> xmlFloat n <> text "</floatc>"
> xmlOperatorDecl :: CS.IDecl -> Doc
> xmlOperatorDecl (CS.IInfixDecl _ fixity prec qident) =
> text "<op fixity=\"" <> xmlFixity fixity
> <> text "\" prec=\"" <> xmlInteger prec <> text "\">"
> <> xmlIdent (unqualify qident)
> <> text "</op>"
> xmlFixity :: CS.Infix -> Doc
> xmlFixity CS.InfixL = text "InfixlOp"
> xmlFixity CS.InfixR = text "InfixrOp"
> xmlFixity CS.Infix = text "InfixOp"
> xmlTranslationDecl :: QualIdent -> Doc
> xmlTranslationDecl expId =
> text "<trans>"
> $$ nest level ( text "<name>" <> xmlIdent (unqualify expId) <> text "</name>"
> $$ text "<intname>" <> xmlQualIdent expId <> text "</intname>")
> $$ text "</trans>"
> xmlIdent :: Ident -> Doc
> xmlIdent ident = text (xmlFormat (name ident))
> xmlInt :: Int -> Doc
> xmlInt n = text (show n)
> xmlInteger :: Integer -> Doc
> xmlInteger n = text (show n)
> xmlFloat :: Double -> Doc
> xmlFloat n = text (show n)
> xmlQualIdent :: QualIdent -> Doc
> xmlQualIdent ident = text (xmlFormat (qualName ident))
> xmlModuleIdent:: ModuleIdent -> Doc
> xmlModuleIdent name = text (xmlFormat (moduleName name))
> xmlFormat :: String -> String
> xmlFormat [] = []
> xmlFormat ('>':xs) = ">"++xmlFormat xs
> xmlFormat ('<':xs) = "<"++xmlFormat xs
> xmlFormat ('&':xs) = "&"++xmlFormat xs
> xmlFormat (x:xs) = x:(xmlFormat xs)
> -- =========================================================================
> qualIDeclId :: ModuleIdent -> [QualIdent] -> CS.IDecl -> [QualIdent]
> qualIDeclId mid qids (CS.IDataDecl _ qid _ mcdecls)
> = foldl (qualConstrDeclId mid) (qid:qids) (catMaybes mcdecls)
> qualIDeclId mid qids (CS.INewtypeDecl _ qid _ ncdecl)
> = qualNewConstrDeclId mid (qid:qids) ncdecl
> qualIDeclId mid qids (CS.ITypeDecl _ qid _ _)
> = qid:qids
> qualIDeclId mid qids (CS.IFunctionDecl _ qid _ _)
> = qid:qids
> qualIDeclId mid qids _ = qids
> qualConstrDeclId :: ModuleIdent -> [QualIdent] -> CS.ConstrDecl
> -> [QualIdent]
> qualConstrDeclId mid qids (CS.ConstrDecl _ _ id _)
> = (qualifyWith mid id):qids
> qualConstrDeclId mid qids (CS.ConOpDecl _ _ _ id _)
> = (qualifyWith mid id):qids
> qualNewConstrDeclId :: ModuleIdent -> [QualIdent] -> CS.NewConstrDecl
> -> [QualIdent]
> qualNewConstrDeclId mid qids (CS.NewConstrDecl _ _ id _)
> = (qualifyWith mid id):qids
\end{verbatim}