Commit 420dfd1c authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Integerated Token and HTML generation into main compilation chain

parent 637f3efd
......@@ -15,7 +15,8 @@ module CompilerEnv where
import qualified Data.Map as Map (Map, keys, toList)
import Curry.Base.Ident (ModuleIdent)
import Curry.Base.Ident (ModuleIdent)
import Curry.Base.Position (Position)
import Curry.Base.Pretty
import Curry.Syntax
......@@ -33,20 +34,24 @@ type CompEnv a = (CompilerEnv, a)
-- compiled. The information is updated during the different stages of
-- compilation.
data CompilerEnv = CompilerEnv
{ moduleIdent :: ModuleIdent -- ^ identifier of the module
, extensions :: [KnownExtension] -- ^ enabled language extensions
, interfaceEnv :: InterfaceEnv -- ^ declarations of imported interfaces
, aliasEnv :: AliasEnv -- ^ aliases for imported modules
, tyConsEnv :: TCEnv -- ^ type constructors
, valueEnv :: ValueEnv -- ^ functions and data constructors
, opPrecEnv :: OpPrecEnv -- ^ operator precedences
{ moduleIdent :: ModuleIdent -- ^ identifier of the module
, filePath :: FilePath -- ^ 'FilePath' of compilation target
, extensions :: [KnownExtension] -- ^ enabled language extensions
, tokens :: [(Position, Token)] -- ^ token list of module
, interfaceEnv :: InterfaceEnv -- ^ declarations of imported interfaces
, aliasEnv :: AliasEnv -- ^ aliases for imported modules
, tyConsEnv :: TCEnv -- ^ type constructors
, valueEnv :: ValueEnv -- ^ functions and data constructors
, opPrecEnv :: OpPrecEnv -- ^ operator precedences
}
-- |Initial 'CompilerEnv'
initCompilerEnv :: ModuleIdent -> CompilerEnv
initCompilerEnv mid = CompilerEnv
{ moduleIdent = mid
, filePath = []
, extensions = []
, tokens = []
, interfaceEnv = initInterfaceEnv
, aliasEnv = initAliasEnv
, tyConsEnv = initTCEnv
......@@ -58,6 +63,7 @@ initCompilerEnv mid = CompilerEnv
showCompilerEnv :: CompilerEnv -> String
showCompilerEnv env = show $ vcat
[ header "Module Identifier " $ textS $ moduleIdent env
, header "FilePath" $ text $ filePath env
, header "Language Extensions" $ text $ show $ extensions env
, header "Interfaces " $ hcat $ punctuate comma $ map textS
$ Map.keys $ interfaceEnv env
......
......@@ -3,7 +3,7 @@
Description : Compiler options
Copyright : (c) 2005 Martin Engelke
2007 Sebastian Fischer
2011 - 2014 Björn Peemöller
2011 - 2016 Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -125,8 +125,6 @@ data CymakeMode
= ModeHelp -- ^ Show help information and exit
| ModeVersion -- ^ Show version and exit
| ModeNumericVersion -- ^ Show numeric version, suitable for later processing
| ModeHtml -- ^ Create HTML documentation
| ModeToken -- ^ Create stream of positions and token
| ModeMake -- ^ Compile with dependencies
deriving (Eq, Show)
......@@ -144,11 +142,13 @@ verbosities = [ ( VerbQuiet , "0", "quiet" )
-- |Type of the target file
data TargetType
= Parsed -- ^ Parsed source code
= Tokens -- ^ Source code tokens
| Parsed -- ^ Parsed source code
| FlatCurry -- ^ FlatCurry
| ExtendedFlatCurry -- ^ Extended FlatCurry
| AbstractCurry -- ^ AbstractCurry
| UntypedAbstractCurry -- ^ Untyped AbstractCurry
| Html -- ^ HTML documentation
deriving (Eq, Show)
-- |Warnings flags
......@@ -351,32 +351,20 @@ options =
addFlag WarnOverlapping (wnWarnFlags opts) }))
"do not print warnings for overlapping rules"
-- target types
, Option "" ["html"]
(NoArg (onOpts $ \ opts -> opts { optMode = ModeHtml }))
"generate html code and exit"
, Option "" ["tokens"]
(NoArg (onOpts $ \ opts -> opts { optMode = ModeToken }))
"generate token stream and exit"
, Option "" ["parse-only"]
(NoArg (onOpts $ \ opts -> opts { optTargetTypes =
nub $ Parsed : optTargetTypes opts }))
, targetOption Tokens "tokens"
"generate token stream"
, targetOption Parsed "parse-only"
"generate source representation"
, Option "" ["flat"]
(NoArg (onOpts $ \ opts -> opts { optTargetTypes =
nub $ FlatCurry : optTargetTypes opts }))
, targetOption FlatCurry "flat"
"generate FlatCurry code"
, Option "" ["extended-flat"]
(NoArg (onOpts $ \ opts -> opts { optTargetTypes =
nub $ ExtendedFlatCurry : optTargetTypes opts }))
, targetOption ExtendedFlatCurry "extended-flat"
"generate FlatCurry code with source references"
, Option "" ["acy"]
(NoArg (onOpts $ \ opts -> opts { optTargetTypes =
nub $ AbstractCurry : optTargetTypes opts }))
"generate (type infered) AbstractCurry code"
, Option "" ["uacy"]
(NoArg (onOpts $ \ opts -> opts { optTargetTypes =
nub $ UntypedAbstractCurry : optTargetTypes opts }))
"generate untyped AbstractCurry code"
, targetOption AbstractCurry "acy"
"generate typed AbstractCurry"
, targetOption UntypedAbstractCurry "uacy"
"generate untyped AbstractCurry"
, targetOption Html "html"
"generate html documentation"
, Option "F" []
(NoArg (onPrepOpts $ \ opts -> opts { ppPreprocess = True }))
"use custom preprocessor"
......@@ -398,6 +386,11 @@ options =
, mkOptDescr onDebugOpts "d" [] "opt" "debug option" debugDescriptions
]
targetOption :: TargetType -> String -> String -> OptDescr (OptErr -> OptErr)
targetOption ty flag desc
= Option "" [flag] (NoArg (onOpts $ \ opts -> opts { optTargetTypes =
nub $ ty : optTargetTypes opts })) desc
verbDescriptions :: OptErrTable Options
verbDescriptions = map toDescr verbosities
where
......@@ -463,9 +456,8 @@ parseOpts = updateOpts defaultOptions
-- |Check options and files and return a list of error messages
checkOpts :: Options -> [String] -> [String]
checkOpts opts _
| isJust (optHtmlDir opts) && (optMode opts) /= ModeHtml
= ["The option '--htmldir' is only valid for HTML generation mode"]
| otherwise = []
= [ "The option '--htmldir' is only valid for HTML generation mode"
| isJust (optHtmlDir opts) && Html `notElem` optTargetTypes opts ]
-- |Print the usage information of the command line tool.
usage :: String -> String
......
......@@ -17,8 +17,8 @@ module CurryBuilder (buildCurry, findCurry) where
import Control.Monad (foldM, liftM)
import Data.Char (isSpace)
import Data.Maybe (catMaybes, mapMaybe)
import System.FilePath (normalise)
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import System.FilePath ((</>), normalise)
import Curry.Base.Ident
import Curry.Base.Monad
......@@ -153,18 +153,19 @@ process opts idx m fn deps
skip = status opts $ compMessage idx "Skipping" m (fn, head destFiles)
compile = do
status opts $ compMessage idx "Compiling" m (fn, head destFiles)
compileModule opts fn
compileModule opts m fn
tgtDir = addCurrySubdirModule (optUseSubdir opts) m
destFiles = [ tgtDir (gen fn)
| (tgt, gen) <- nameGens, tgt `elem` optTargetTypes opts]
destFiles = [ gen fn | (t, gen) <- nameGens, t `elem` optTargetTypes opts]
nameGens =
[ (FlatCurry , flatName )
, (ExtendedFlatCurry , extFlatName )
, (AbstractCurry , acyName )
, (UntypedAbstractCurry , uacyName )
, (Parsed , sourceRepName)
[ (Tokens , tgtDir . tokensName )
, (Parsed , tgtDir . sourceRepName)
, (FlatCurry , tgtDir . flatName )
, (ExtendedFlatCurry , tgtDir . extFlatName )
, (AbstractCurry , tgtDir . acyName )
, (UntypedAbstractCurry , tgtDir . uacyName )
, (Html , const (fromMaybe "." (optHtmlDir opts) </> htmlName m))
]
-- |Create a status message like
......
......@@ -23,18 +23,16 @@ import System.FilePath ((</>))
import Curry.Base.Ident ( ModuleIdent (..), Ident (..), QualIdent (..)
, unqualify, moduleName)
import Curry.Base.Monad (CYIO, liftCYM, failMessages)
import Curry.Base.Monad (CYIO, failMessages)
import Curry.Base.Position (Position)
import Curry.Base.Pretty ((<+>), text, vcat)
import Curry.Files.PathUtils (readModule)
import Curry.Syntax (Module (..), lexSource)
import Curry.Files.Filenames (htmlName)
import Curry.Syntax (Module (..), Token)
import Html.SyntaxColoring
import Base.Messages (message)
import CompilerOpts (Options (..), WarnOpts (..))
import CurryBuilder (buildCurry, findCurry)
import Modules (loadAndCheckModule)
import Transformations (qual)
import CompilerOpts (Options (..))
import Paths_curry_frontend (getDataFileName)
-- |'FilePath' of the CSS style file to be added to the documentation.
......@@ -42,14 +40,13 @@ cssFile :: FilePath
cssFile = "currysource.css"
-- |Translate source file into HTML file with syntaxcoloring
source2html :: Options -> String -> CYIO ()
source2html opts s = do
srcFile <- findCurry opts s
(mid, doc) <- docModule opts srcFile
let outDir = fromMaybe "." $ optHtmlDir opts
outFile = outDir </> htmlFile mid
liftIO $ writeFile outFile doc
source2html :: Options -> ModuleIdent -> [(Position, Token)] -> Module -> CYIO ()
source2html opts mid toks mdl = do
liftIO $ writeFile (outDir </> htmlName mid) doc
updateCSSFile outDir
where
doc = program2html mid (genProgram mdl toks)
outDir = fromMaybe "." (optHtmlDir opts)
-- |Update the CSS file
updateCSSFile :: FilePath -> CYIO ()
......@@ -65,33 +62,6 @@ updateCSSFile dir = do
, text "File" <+> text ("`" ++ f ++ "'") <+> text "does not exist"
]
-- |Create the documentation for the module
docModule :: Options -> String -> CYIO (ModuleIdent, String)
docModule opts f = do
mbModule <- liftIO $ readModule f
case mbModule of
Nothing -> failMessages [message $ text $ "Missing file: " ++ f]
Just src -> do
toks <- liftCYM $ lexSource f src
typed@(Module _ m _ _ _) <- fullParse opts f src
return (m, program2html m $ genProgram typed toks)
-- |Return the syntax tree of the source program 'src' (type 'Module'; see
-- Module "CurrySyntax").after inferring the types of identifiers.
-- 'fullParse' always searches for standard Curry libraries in the path
-- defined in the
-- environment variable "PAKCSLIBPATH". Additional search paths can
-- be defined using the argument 'paths'.
fullParse :: Options -> FilePath -> String -> CYIO Module
fullParse opts fn _ = do
buildCurry (opts { optTargetTypes = []}) fn
(env, mdl) <- loadAndCheckModule opts' fn
return (snd $ qual (env, mdl))
where
opts' = opts { optWarnOpts = (optWarnOpts opts) { wnWarn = False }
, optTargetTypes = []
}
-- generates htmlcode with syntax highlighting
-- @param modulname
-- @param a program
......@@ -164,7 +134,7 @@ code2class (StringCode _) = "string"
code2class (CharCode _) = "char"
addModuleLink :: ModuleIdent -> ModuleIdent -> String -> String
addModuleLink m m' str
addModuleLink m m' str
= "<a href=\"" ++ makeRelativePath m m' ++ "\">" ++ str ++ "</a>"
addEntityLink :: ModuleIdent -> String -> QualIdent -> String
......@@ -177,10 +147,7 @@ addEntityLink m str qid =
makeRelativePath :: ModuleIdent -> ModuleIdent -> String
makeRelativePath cur new | cur == new = ""
| otherwise = htmlFile new
htmlFile :: ModuleIdent -> String
htmlFile m = moduleName m ++ "_curry.html"
| otherwise = htmlName new
isCall :: Code -> Bool
isCall (TypeCons TypeExport _ _) = True
......
......@@ -56,9 +56,11 @@ import CompilerEnv
import CompilerOpts
import Exports
import Generators
import Html.CurryHtml (source2html)
import Imports
import Interfaces (loadInterfaces)
import ModuleSummary
import TokenStream (showTokenStream)
import Transformations
-- The function 'compileModule' is the main entry-point of this
......@@ -77,26 +79,41 @@ import Transformations
-- The compiler automatically loads the prelude when compiling any
-- module, except for the prelude itself, by adding an appropriate import
-- declaration to the module.
compileModule :: Options -> FilePath -> CYIO ()
compileModule opts fn = do
(env, mdl) <- loadAndCheckModule opts fn
liftIO $ writeOutput opts fn (env, mdl)
compileModule :: Options -> ModuleIdent -> FilePath -> CYIO ()
compileModule opts m fn = do
mdl <- loadAndCheckModule opts m fn
writeTokens opts (fst mdl)
writeParsed opts mdl
writeHtml opts (qual mdl)
mdl' <- expandExports opts mdl
qmdl <- dumpWith opts CS.showModule CS.ppModule DumpQualified $ qual mdl'
writeAbstractCurry opts qmdl
-- generate interface file
let intf = uncurry exportInterface qmdl
writeInterface opts (fst mdl') intf
when withFlat $ do
(env2, il) <- transModule opts qmdl
-- generate target code
let modSum = summarizeModule (tyConsEnv env2) intf (snd qmdl)
writeFlat opts env2 modSum il
where
withFlat = any (`elem` optTargetTypes opts) [FlatCurry, ExtendedFlatCurry]
loadAndCheckModule :: Options -> FilePath -> CYIO (CompEnv CS.Module)
loadAndCheckModule opts fn = do
(env, mdl) <- loadModule opts fn >>= checkModule opts
warnMessages $ warnCheck opts env mdl
return (env, mdl)
loadAndCheckModule :: Options -> ModuleIdent -> FilePath
-> CYIO (CompEnv CS.Module)
loadAndCheckModule opts m fn = do
ce <- loadModule opts m fn >>= checkModule opts
warnMessages $ uncurry (warnCheck opts) ce
return ce
-- ---------------------------------------------------------------------------
-- Loading a module
-- ---------------------------------------------------------------------------
loadModule :: Options -> FilePath -> CYIO (CompEnv CS.Module)
loadModule opts fn = do
parsed <- parseModule opts fn
-- check module header
mdl <- checkModuleHeader opts fn parsed
loadModule :: Options -> ModuleIdent -> FilePath -> CYIO (CompEnv CS.Module)
loadModule opts m fn = do
-- parse and check module header
(toks, mdl) <- parseModule opts m fn
-- load the imported interfaces into an InterfaceEnv
let paths = map (addCurrySubdir (optUseSubdir opts))
("." : optImportPaths opts)
......@@ -105,17 +122,21 @@ loadModule opts fn = do
is <- importSyntaxCheck iEnv mdl
-- add information of imported modules
cEnv <- importModules mdl iEnv is
return (cEnv, mdl)
return (cEnv { filePath = fn, tokens = toks }, mdl)
parseModule :: Options -> FilePath -> CYIO CS.Module
parseModule opts fn = do
parseModule :: Options -> ModuleIdent -> FilePath
-> CYIO ([(Position, CS.Token)], CS.Module)
parseModule opts m fn = do
mbSrc <- liftIO $ readModule fn
case mbSrc of
Nothing -> failMessages [message $ text $ "Missing file: " ++ fn]
Just src -> do
ul <- liftCYM $ CS.unlit fn src
prepd <- preprocess (optPrepOpts opts) fn ul
liftCYM $ CS.parseModule fn prepd
ul <- liftCYM $ CS.unlit fn src
posToks <- liftCYM $ CS.lexSource fn ul
prepd <- preprocess (optPrepOpts opts) fn ul
ast <- liftCYM $ CS.parseModule fn prepd
checked <- checkModuleHeader opts m fn ast
return (posToks, checked)
preprocess :: PrepOpts -> FilePath -> String -> CYIO String
preprocess opts fn src
......@@ -143,26 +164,22 @@ withTempFile act = do
removeFile fn
return res
checkModuleHeader :: Monad m => Options -> FilePath -> CS.Module
checkModuleHeader :: Monad m => Options -> ModuleIdent -> FilePath -> CS.Module
-> CYT m CS.Module
checkModuleHeader opts fn = checkModuleId fn
. importPrelude opts
. CS.patchModuleId fn
checkModuleHeader opts m fn = checkModuleId m
. importPrelude opts
. CS.patchModuleId fn
-- |Check whether the 'ModuleIdent' and the 'FilePath' fit together
checkModuleId :: Monad m => FilePath -> CS.Module
-> CYT m CS.Module
checkModuleId fn m@(CS.Module _ mid _ _ _)
| last (midQualifiers mid) == takeBaseName fn
= ok m
| otherwise
= failMessages [errModuleFileMismatch mid]
checkModuleId :: Monad m => ModuleIdent -> CS.Module -> CYT m CS.Module
checkModuleId mid m@(CS.Module _ mid' _ _ _)
| mid == mid' = ok m
| otherwise = failMessages [errModuleFileMismatch mid']
-- An implicit import of the prelude is added to the declarations of
-- every module, except for the prelude itself, or when the import is disabled
-- by a compiler option. If no explicit import for the prelude is present,
-- the prelude is imported unqualified, otherwise a qualified import is added.
importPrelude :: Options -> CS.Module -> CS.Module
importPrelude opts m@(CS.Module ps mid es is ds)
-- the Prelude itself
......@@ -218,7 +235,7 @@ checkModule opts mdl = do
-- Translating a module
-- ---------------------------------------------------------------------------
transModule :: Options -> CompEnv CS.Module -> IO (CompEnv IL.Module)
transModule :: Options -> CompEnv CS.Module -> CYIO (CompEnv IL.Module)
transModule opts mdl = do
desugared <- dumpCS DumpDesugared $ desugar mdl
simplified <- dumpCS DumpSimplified $ simplify desugared
......@@ -234,23 +251,6 @@ transModule opts mdl = do
-- Writing output
-- ---------------------------------------------------------------------------
writeOutput :: Options -> FilePath -> CompEnv CS.Module -> IO ()
writeOutput opts fn mdl@(_, modul) = do
writeParsed opts fn modul
mdl' <- expandExports opts mdl
qmdl <- dumpWith opts CS.showModule CS.ppModule DumpQualified $ qual mdl'
writeAbstractCurry opts fn qmdl
-- generate interface file
let intf = uncurry exportInterface qmdl
writeInterface opts fn intf
when withFlat $ do
(env2, il) <- transModule opts qmdl
-- generate target code
let modSum = summarizeModule (tyConsEnv env2) intf (snd qmdl)
writeFlat opts fn env2 modSum il
where
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.
-- If the interface of a modified Curry module did not change, the
......@@ -258,27 +258,40 @@ writeOutput opts fn mdl@(_, modul) = do
-- (depending on the compiler flag "force") and other modules importing this
-- module won't be dependent on it any longer.
writeTokens :: Options -> CompilerEnv -> CYIO ()
writeTokens opts env = when tokTarget $ liftIO $
writeModule (useSubDir $ tokensName (filePath env))
(showTokenStream (tokens env))
where
tokTarget = Tokens `elem` optTargetTypes opts
useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)
-- |Output the parsed 'Module' on request
writeParsed :: Options -> FilePath -> CS.Module -> IO ()
writeParsed opts fn modul@(CS.Module _ m _ _ _) = when srcTarget $
writeModule (useSubDir $ sourceRepName fn) source
writeParsed :: Options -> CompEnv CS.Module -> CYIO ()
writeParsed opts (env, mdl) = when srcTarget $ liftIO $
writeModule (useSubDir $ sourceRepName (filePath env)) (CS.showModule mdl)
where
srcTarget = Parsed `elem` optTargetTypes opts
useSubDir = addCurrySubdirModule (optUseSubdir opts) m
source = CS.showModule modul
useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)
writeHtml :: Options -> CompEnv CS.Module -> CYIO ()
writeHtml opts (env, mdl) = when htmlTarget $
source2html opts (moduleIdent env) (tokens env) mdl
where htmlTarget = Html `elem` optTargetTypes opts
writeInterface :: Options -> FilePath -> CS.Interface -> IO ()
writeInterface opts fn intf@(CS.Interface m _ _)
writeInterface :: Options -> CompilerEnv -> CS.Interface -> CYIO ()
writeInterface opts env intf@(CS.Interface m _ _)
| optForce opts = outputInterface
| otherwise = do
equal <- C.catch (matchInterface interfaceFile intf) ignoreIOException
equal <- liftIO $ C.catch (matchInterface interfaceFile intf)
ignoreIOException
unless equal outputInterface
where
ignoreIOException :: C.IOException -> IO Bool
ignoreIOException _ = return False
interfaceFile = interfName fn
outputInterface = writeModule
interfaceFile = interfName (filePath env)
outputInterface = liftIO $ writeModule
(addCurrySubdirModule (optUseSubdir opts) m interfaceFile)
(show $ CS.ppInterface intf)
......@@ -290,52 +303,53 @@ matchInterface ifn i = do
Left _ -> hClose hdl >> return False
Right i' -> return (i `intfEquiv` fixInterface i')
writeFlat :: Options -> FilePath -> CompilerEnv -> ModuleSummary -> IL.Module
-> IO ()
writeFlat opts fn env modSum il = do
writeFlat :: Options -> CompilerEnv -> ModuleSummary -> IL.Module -> CYIO ()
writeFlat opts env modSum il = do
when (extTarget || fcyTarget) $ do
writeFlatCurry opts fn env modSum il
writeFlatIntf opts fn env modSum il
writeFlatCurry opts env modSum il
writeFlatIntf opts env modSum il
where
extTarget = ExtendedFlatCurry `elem` optTargetTypes opts
fcyTarget = FlatCurry `elem` optTargetTypes opts
-- |Export an 'IL.Module' into a FlatCurry file
writeFlatCurry :: Options -> FilePath -> CompilerEnv -> ModuleSummary
-> IL.Module -> IO ()
writeFlatCurry opts fn env modSum il = do
writeFlatCurry :: Options -> CompilerEnv -> ModuleSummary -> IL.Module -> CYIO ()
writeFlatCurry opts env modSum il = do
(_, fc) <- dumpWith opts show EF.ppProg DumpFlatCurry (env, prog)
when extTarget $ EF.writeExtendedFlat (useSubDir $ extFlatName fn) fc
when fcyTarget $ EF.writeFlatCurry (useSubDir $ flatName fn) fc
when extTarget $ liftIO
$ EF.writeExtendedFlat (useSubDir $ extFlatName (filePath env)) fc
when fcyTarget $ liftIO
$ EF.writeFlatCurry (useSubDir $ flatName (filePath env)) fc
where
extTarget = ExtendedFlatCurry `elem` optTargetTypes opts
fcyTarget = FlatCurry `elem` optTargetTypes opts
useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)
prog = genFlatCurry modSum env il
writeFlatIntf :: Options -> FilePath -> CompilerEnv -> ModuleSummary
-> IL.Module -> IO ()
writeFlatIntf opts fn env modSum il
writeFlatIntf :: Options -> CompilerEnv -> ModuleSummary -> IL.Module -> CYIO ()
writeFlatIntf opts env modSum il
| not (optInterface opts) = return ()
| optForce opts = outputInterface
| otherwise = do
mfint <- EF.readFlatInterface targetFile
mfint <- liftIO $ EF.readFlatInterface targetFile
let oldInterface = fromMaybe emptyIntf mfint
when (mfint == mfint) $ return () -- necessary to close file -- TODO
unless (oldInterface `eqInterface` intf) $ outputInterface
where
targetFile = flatIntName fn
targetFile = flatIntName (filePath env)
emptyIntf = EF.Prog "" [] [] [] []
intf = genFlatInterface modSum env il
useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)
outputInterface = EF.writeFlatCurry (useSubDir targetFile) intf
writeAbstractCurry :: Options -> FilePath -> CompEnv CS.Module -> IO ()
writeAbstractCurry opts fname (env, modul) = do
when acyTarget $ AC.writeCurry (useSubDir $ acyName fname)
$ genTypedAbstractCurry env modul
when uacyTarget $ AC.writeCurry (useSubDir $ uacyName fname)
$ genUntypedAbstractCurry env modul
outputInterface = liftIO $ EF.writeFlatCurry (useSubDir targetFile) intf
writeAbstractCurry :: Options -> CompEnv CS.Module -> CYIO ()
writeAbstractCurry opts (env, mdl) = do
when acyTarget $ liftIO
$ AC.writeCurry (useSubDir $ acyName (filePath env))
$ genTypedAbstractCurry env mdl
when uacyTarget $ liftIO
$ AC.writeCurry (useSubDir $ uacyName (filePath env))
$ genUntypedAbstractCurry env mdl
where
acyTarget = AbstractCurry `elem` optTargetTypes opts
uacyTarget = UntypedAbstractCurry `elem` optTargetTypes opts
......
......@@ -9,47 +9,12 @@
and positions of a Curry source module into a separate file.
-}
module TokenStream (source2token) where
module TokenStream (showTokenStream) where
import Control.Monad.Writer (liftIO)
import Data.List (intercalate)
import System.FilePath (replaceExtension)
import Curry.Base.Ident (ModuleIdent)
import Curry.Base.Monad (CYIO, liftCYM, failMessages)
import Curry.Base.Position (Position (..))
import Curry.Base.Pretty (text)
import Curry.Files.Filenames (addCurrySubdirModule)
import Curry.Files.PathUtils (readModule)
import Curry.Syntax ( Module (..)
, Token (..), Category (..), Attributes (..)
, lexSource, parseHeader, patchModuleId
)
import Base.Messages (message)
import CompilerOpts (Options (..))
import CurryBuilder (findCurry)
-- |Write list of positions and tokens into a file.
-- TODO: To get the name of the module its header is getting parsed.
-- This should be improved because there shouldn't be done any
-- parsing when extracting only the TokenStream.
source2token :: Options -> String -> CYIO ()
source2token opts s = do
srcFile <- findCurry opts s
mModule <- liftIO (readModule srcFile)
case mModule of
Nothing -> failMessages [message $ text $ "Missing file: " ++ srcFile]
Just src -> do