Skip to content

GitLab

Commit 61f6804a authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Removed support for FlatCurry XML files - fixes #1045

parent 98eaa471
Hide whitespace changes
Inline Side-by-side
curry-frontend.cabal
View file @ 61f6804a
......@@ -75,7 +75,6 @@ Executable cymake
, IL
, IL.Pretty
, IL.Type
, IL.XML
, Imports
, InterfaceEquivalence
, Interfaces
......
src/CompilerOpts.hs
View file @ 61f6804a
......@@ -145,7 +145,6 @@ data TargetType
= Parsed -- ^ Parsed source code
| FlatCurry -- ^ FlatCurry
| ExtendedFlatCurry -- ^ Extended FlatCurry
| FlatXml -- ^ FlatCurry as XML
| AbstractCurry -- ^ AbstractCurry
| UntypedAbstractCurry -- ^ Untyped AbstractCurry
deriving (Eq, Show)
......@@ -361,10 +360,6 @@ options =
(NoArg (onOpts $ \ opts -> opts { optTargetTypes =
nub $ ExtendedFlatCurry : optTargetTypes opts }))
"generate FlatCurry code with source references"
, Option "" ["xml"]
(NoArg (onOpts $ \ opts -> opts { optTargetTypes =
nub $ FlatXml : optTargetTypes opts }))
"generate flat xml code"
, Option "" ["acy"]
(NoArg (onOpts $ \ opts -> opts { optTargetTypes =
nub $ AbstractCurry : optTargetTypes opts }))
......
src/CurryBuilder.hs
View file @ 61f6804a
......@@ -158,7 +158,6 @@ process opts idx m fn deps
nameGens =
[ (FlatCurry , flatName )
, (ExtendedFlatCurry , extFlatName )
, (FlatXml , xmlName )
, (AbstractCurry , acyName )
, (UntypedAbstractCurry , uacyName )
, (Parsed , sourceRepName)
......
src/IL.hs
View file @ 61f6804a
{- |
Module : $Header$
Description : Intermediate language
Copyright : (c) 2011, Björn Peemöller
Copyright : (c) 2014, Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -9,14 +9,9 @@
Portability : portable
This module is a simple re-export of the definition of the AST of IL
and the pretty-printing/xml-printing functions.
and the pretty-printing of IL modules.
-}
module IL
( module IL.Type
, ppModule
, xmlModule
) where
module IL ( module IL.Type, ppModule ) where
import IL.Pretty (ppModule)
import IL.Type
import IL.XML (xmlModule)
src/IL/XML.lhs deleted 100644 → 0
View file @ 98eaa471
% $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 (xmlModule) where
> import Data.Maybe
> import Curry.Base.Ident
> import Curry.Base.Pretty
> import IL.Type
> import Base.Messages (internalError)
TODO: The following import should be avoided if possible as it makes
the program structure less clear.
> import qualified Curry.Syntax as CS
> -- identation level
> level::Int
> level = 3
> xmlModule :: [CS.IDecl] -> [CS.IDecl] -> Module -> Doc
> xmlModule intf infx m
> = text "<prog>" $$ nest level (xmlBody intf infx m) $$ text "</prog>"
> xmlBody :: [CS.IDecl] -> [CS.IDecl] -> Module -> Doc
> xmlBody intf infx (Module mname mimports decls) =
> xmlElement "module" xmlModuleDecl moduleDecl $$
> xmlElement "import" xmlImportDecl importDecl $$
> xmlElement "types" xmlTypeDecl typeDecl $$
> xmlElement "functions" xmlFunctionDecl funcDecl $$
> xmlElement "operators" xmlOperatorDecl operatorDecl $$
> xmlElement "translation" xmlTranslationDecl translationDecl
> where
> moduleDecl = [mname]
> importDecl = mimports
> (funcDecl,typeDecl) = splitDecls decls
> operatorDecl = infx
> translationDecl = foldl (qualIDeclId mname) [] intf
> xmlModuleDecl :: ModuleIdent -> Doc
> xmlModuleDecl = xmlModuleIdent
> xmlImportDecl :: ModuleIdent -> Doc
> xmlImportDecl mname = xmlElement "module" xmlModuleDecl [mname]
=========================================================================
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>"
> xmlTypeDecl _ = internalError "IL.XML.xmlTypeDecl: no data declaration"
> 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=\"") <> qname <> text "\" " <> arity
> arity = text "arity=\"" <> xmlInt n <> text "\""
> qname = 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
> qname = xmlQualIdent ident
> prefix = text "<tcons name=\"" <> qname <> 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) $$ xmlEndFunction
> where
> heading = xmlBeginFunction ident (length largs) fType
> xmlFunctionDecl (ExternalDecl ident _callConv internalName fType) =
> heading $$ external $$ xmlEndFunction
> where
> heading = xmlBeginFunction ident (xmlFunctionArity fType) fType
> external = text ("<external>"
> ++ xmlFormat internalName
> ++ "</external>")
> xmlFunctionDecl (DataDecl _ _ _) = internalError "IL.XML.xmlFunctionDecl: data declaration"
> 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 _ _) = 0
> xmlFunctionArity (TypeVariable _) = 0
> xmlFunctionArity (TypeArrow _ 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 expr@(Apply _ _) = xmlApply d expr (xmlAppArgs expr)
> 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
> xmlExpr d (Typed expr ty) = xmlTyped d expr ty
> 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 cname cType single =
> if single
> then prefix <> text " />"
> else prefix <> text ">"
> where
> prefix = text "<comb type=\""<>cType<>text "\" name=\""<>cname<>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 _ ((Function ident arity),lExp) =
> xmlApplyFunctor d ident arity lExp True
> xmlApply d _ ((Constructor ident arity),lExp) =
> xmlApplyFunctor d ident arity lExp False
> xmlApply d (Apply expr1 expr2) _ =
> (text "<apply>" $$ nest level e1 $$ nest level e2 $$ text "</apply>", d2)
> where
> (e1,d1) = xmlExpr d expr1
> (e2,d2) = xmlExpr d1 expr2
> xmlApply _ _ _ = internalError "IL.XML.xmlApply: no pattern match"
> 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
> | n /= arity = "PartCall"
> | isFunction = "FuncCall"
> | otherwise = "ConsCall"
> xmlCombApply :: [(Int,Ident)] -> Doc -> Doc -> Int ->
> [Expression] -> (Doc,[(Int,Ident)])
> xmlCombApply d cname cType 0 _ =
> (xmlCombHeading cname cType True,d)
> xmlCombApply d cname cType _ lArgs =
> (xmlCombHeading cname 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 _ (VariablePattern _) = internalError "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 expr =
> (text "<freevars>" $$ nest level v $$ nest level e $$ text "</freevars>",d2)
> where
> (v,d1) = xmlExprVar d ident
> (e,d2) = xmlExpr d1 expr
> xmlLet :: [(Int,Ident)] -> Binding -> Expression -> (Doc,[(Int,Ident)])
> xmlLet d binding expr =
> (text "<let>" $$ nest level b $$ nest level e $$ text "</let>", d2)
> where
> (b,d1) = xmlBinding d binding
> (e,d2) = xmlExpr d1 expr
> xmlBinding :: [(Int,Ident)] -> Binding -> (Doc,[(Int,Ident)])
> xmlBinding d (Binding ident expr) =
> (text "<binding>" $$ nest level v $$ nest level e $$ text "</binding>",d2)
> where
> (v,_) = xmlExprVar d ident
> (e,d2) = xmlExpr d expr
> xmlLetrec :: [(Int,Ident)] -> [Binding] -> Expression -> (Doc,[(Int,Ident)])
> xmlLetrec d lB expr =
> (text "<letrec>" $$ xmlLines id b $$ nest level e $$ text "</letrec>",d2)
> where
> (b,d1) = xmlMapDicc d xmlBinding lB
> (e,d2) = xmlExpr d1 expr
> xmlTyped :: [(Int,Ident)] -> Expression -> Type -> (Doc,[(Int,Ident)])
> xmlTyped d expr ty =
> (text "<typed>" $$ nest level e1 $$ nest level (xmlType ty) $$ text "</typed>", d1)
> where (e1 ,d1) = xmlExpr d expr
=========================================================================
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 n _ [] = text ("<" ++ n ++ " />")
> xmlElement n f lDecls = beginElement $$ xmlLines f lDecls $$ endElement
> where
> beginElement = text ("<"++n++">")
> endElement = text ("</"++n++">")
>
> 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 _ [] = -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,_):_) = 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>"
> 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 = text . xmlFormat .idName
> xmlInt :: Int -> Doc
> xmlInt = text . show
> xmlInteger :: Integer -> Doc
> xmlInteger = text . show
> xmlFloat :: Double -> Doc
> xmlFloat = text . show
> xmlQualIdent :: QualIdent -> Doc
> xmlQualIdent = text . xmlFormat . qualName
> xmlModuleIdent:: ModuleIdent -> Doc
> xmlModuleIdent = text . xmlFormat . moduleName
> xmlFormat :: String -> String
> xmlFormat [] = []
> xmlFormat ('>':xs) = "&gt;" ++ xmlFormat xs
> xmlFormat ('<':xs) = "&lt;" ++ xmlFormat xs
> xmlFormat ('&':xs) = "&amp;" ++ xmlFormat xs
> xmlFormat (x :xs) = x : (xmlFormat xs)
> 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>"
> xmlOperatorDecl _ = empty
> 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 _ qids (CS.ITypeDecl _ qid _ _)
> = qid:qids
> qualIDeclId _ qids (CS.IFunctionDecl _ qid _ _)
> = qid:qids
> qualIDeclId _ qids _ = qids
> qualConstrDeclId :: ModuleIdent -> [QualIdent] -> CS.ConstrDecl -> [QualIdent]
> qualConstrDeclId mid qids (CS.ConstrDecl _ _ ident _)
> = (qualifyWith mid ident):qids
> qualConstrDeclId mid qids (CS.ConOpDecl _ _ _ ident _)
> = (qualifyWith mid ident):qids
> qualNewConstrDeclId :: ModuleIdent -> [QualIdent] -> CS.NewConstrDecl
> -> [QualIdent]
> qualNewConstrDeclId mid qids (CS.NewConstrDecl _ _ ident _)
> = (qualifyWith mid ident):qids
\end{verbatim}
src/Modules.hs
View file @ 61f6804a
......@@ -61,14 +61,13 @@ import Transformations
-- The function 'compileModule' is the main entry-point of this
-- module for compiling a Curry source module. Depending on the command
-- line options, it will emit either FlatCurry code (standard or in XML
-- representation) or AbstractCurry code (typed, untyped or with type
-- signatures) for the module
-- line options, it will emit either FlatCurry code or AbstractCurry code
-- (typed, untyped or with type signatures) for the module.
-- Usually, the first step is to check the module.
-- Then the code is translated into the intermediate
-- language. If necessary, this phase will also update the module's
-- interface file. The resulting code then is written out (in
-- FlatCurry or XML format) to the corresponding file.
-- interface file. The resulting code then is written out
-- to the corresponding file.
-- The untyped AbstractCurry representation is written
-- out directly after parsing and simple checking the source file.
-- The typed AbstractCurry code is written out after checking the module.
......@@ -216,7 +215,7 @@ checkModule opts (env, mdl) = do
where
debugOpts = optDebugOpts opts
withTypeCheck = any (`elem` optTargetTypes opts)
[FlatCurry, ExtendedFlatCurry, FlatXml, AbstractCurry]
[FlatCurry, ExtendedFlatCurry, AbstractCurry]
-- ---------------------------------------------------------------------------
-- Translating a module
......@@ -266,8 +265,7 @@ writeOutput opts fn (env, modul) = do
let modSum = summarizeModule (tyConsEnv env2) intf qlfd
writeFlat opts fn env2 modSum il
where
withFlat = any (`elem` optTargetTypes opts)
[FlatCurry, FlatXml, ExtendedFlatCurry]
withFlat = any (`elem` optTargetTypes opts) [FlatCurry, ExtendedFlatCurry]
-- The functions \texttt{genFlat} and \texttt{genAbstract} generate
-- flat and abstract curry representations depending on the specified option.
......@@ -313,11 +311,9 @@ writeFlat opts fn env modSum il = do
when (extTarget || fcyTarget) $ do
writeFlatCurry opts fn env modSum il
writeFlatIntf opts fn env modSum il
when (xmlTarget) $ writeFlatXml opts fn modSum il
where
extTarget = ExtendedFlatCurry `elem` optTargetTypes opts
fcyTarget = FlatCurry `elem` optTargetTypes opts
xmlTarget = FlatXml `elem` optTargetTypes opts
-- |Export an 'IL.Module' into a FlatCurry file
writeFlatCurry :: Options -> FilePath -> CompilerEnv -> ModuleSummary
......@@ -332,13 +328,6 @@ writeFlatCurry opts fn env modSum il = do
useSubDir = optUseSubdir opts
(prog, msgs) = genFlatCurry opts modSum env il
-- |Export an 'IL.Module' into an XML file
writeFlatXml :: Options -> FilePath -> ModuleSummary -> IL.Module -> IO ()
writeFlatXml opts fn modSum il = writeModule useSubDir (xmlName fn) curryXml
where
useSubDir = optUseSubdir opts
curryXml = shows (IL.xmlModule (interface modSum) (infixDecls modSum) il) "\n"
writeFlatIntf :: Options -> FilePath -> CompilerEnv -> ModuleSummary
-> IL.Module -> IO ()
writeFlatIntf opts fn env modSum il
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment