Improved generation of HTML documentation

src/Frontend.hs

@@ -12,91 +12,71 @@
     This module provides an API for dealing with several kinds of Curry
     program representations.
 -}
+module Frontend (parse, fullParse) where
 
--- TODO: Should be updated/refactored
+import           Control.Monad.Writer
+import           Data.Maybe           (mapMaybe)
+import qualified Data.Map as Map      (empty)
 
-module Frontend (parse, fullParse, typingParse) where
-
-import Data.Maybe (mapMaybe)
-import qualified Data.Map as Map (empty)
-import Control.Monad.Writer
 
 import Curry.Base.MessageMonad
 import Curry.Files.Filenames
 import Curry.Files.PathUtils
 import Curry.Syntax (Module (..), parseModule)
 
-import Checks
-import CompilerEnv
-import CompilerOpts (Options (..), Verbosity (..), TargetType (..), defaultOptions)
+import Checks       (CheckResult (..))
+import CompilerOpts (Options (..), defaultOptions)
 import CurryBuilder (smake)
-import CurryDeps (Source (..), flattenDeps, moduleDeps)
-import Imports (importModules)
-import Interfaces (loadInterfaces)
-import Modules
+import CurryDeps    (Source (..), flattenDeps, moduleDeps)
+import Modules      (checkModule, checkModuleHeader, compileModule, loadModule)
 
 {- |Return the result of a syntactical analysis of the source program 'src'.
     The result is the syntax tree of the program (type 'Module'; see Module
     "CurrySyntax").
 -}
 parse :: FilePath -> String -> MsgMonad Module
-parse fn src = parseModule True fn src >>= genCurrySyntax fn
+parse fn src = parseModule True fn src >>= genCurrySyntax
+  where
+  genCurrySyntax mod1
+    | null hdrErrs = return mdl
+    | otherwise    = failWith $ show $ head hdrErrs
+    where (mdl, hdrErrs) = checkModuleHeader defaultOptions fn mod1
 
 {- |Return the syntax tree of the source program 'src' (type 'Module'; see
-    Module "CurrySyntax") after resolving the category (i.e. function,
-    constructor or variable) of an identifier. 'fullParse' always
-    searches for standard Curry libraries in the path defined in the
+    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 :: [FilePath] -> FilePath -> String -> IO (MsgMonad Module)
-fullParse paths fn src = genFullCurrySyntax checkModule paths fn $ parse fn src
-
-{- |Behaves like 'fullParse', but returns the syntax tree of the source
-    program 'src' (type 'Module'; see Module "CurrySyntax") after inferring
-    the types of identifiers.
--}
-typingParse :: [FilePath] -> FilePath -> String -> IO (MsgMonad Module)
-typingParse paths fn src = genFullCurrySyntax checkModule paths fn $ parse fn src
+fullParse :: Options -> FilePath -> String -> IO (MsgMonad Module)
+fullParse opts fn src = genFullCurrySyntax opts fn $ parse fn src
 
---
-genCurrySyntax :: FilePath -> Module -> MsgMonad Module
-genCurrySyntax fn mod1
-  | null hdrErrs = return mdl
-  | otherwise    = failWith $ show $ head hdrErrs
-  where (mdl, hdrErrs) = checkModuleHeader defaultOptions fn mod1
-
---
-genFullCurrySyntax ::
-  (Options -> CompilerEnv -> Module -> CheckResult (CompilerEnv, Module))
-  -> [FilePath] -> FilePath -> MsgMonad Module -> IO (MsgMonad Module)
-genFullCurrySyntax check paths fn m = runMsgIO m $ \mod1 -> do
-  errs <- makeInterfaces paths fn mod1
+genFullCurrySyntax :: Options -> FilePath -> MsgMonad Module -> IO (MsgMonad Module)
+genFullCurrySyntax opts fn m = runMsgIO m $ \mod1 -> do
+  errs <- makeInterfaces opts fn mod1
   if null errs
     then do
-      (iEnv, intfErrs) <- loadInterfaces paths mod1
-      unless (null intfErrs) $ failWith $ msgTxt $ head intfErrs
-      let env = importModules opts mod1 iEnv
-      case check opts env mod1 of
-        CheckSuccess (_, mod') -> return (return  mod')
+      loaded <- loadModule opts fn
+      case checkModule opts loaded of
         CheckFailed errs'      -> return $ failWith $ msgTxt $ head errs'
+        CheckSuccess (_, mod') -> return (return  mod')
     else return $ failWith $ head errs
-  where opts = mkOpts paths
 
 -- TODO: Resembles CurryBuilder
 
 -- Generates interface files for importes modules, if they don't exist or
 -- if they are not up-to-date.
-makeInterfaces ::  [FilePath] -> FilePath -> Module -> IO [String]
-makeInterfaces paths fn mdl = do
-  (deps1, errs) <- fmap flattenDeps $ moduleDeps (mkOpts paths) Map.empty fn mdl
+makeInterfaces :: Options -> FilePath -> Module -> IO [String]
+makeInterfaces opts fn mdl = do
+  (deps1, errs) <- fmap flattenDeps $ moduleDeps opts Map.empty fn mdl
   when (null errs) $ mapM_ (compile deps1 . snd) deps1
   return errs
   where
     compile deps' (Source file' mods) = smake
       [flatName file', flatIntName file']
       (file':mapMaybe (flatInterface deps') mods)
-      (compileModule (mkOpts paths) file')
+      (compileModule opts file')
       (return ())
     compile _ _ = return ()
 
@@ -104,11 +84,3 @@ makeInterfaces paths fn mdl = do
       Just (Source f  _) -> Just $ flatIntName $ dropExtension f
       Just (Interface f) -> Just $ flatIntName $ dropExtension f
       _                  -> Nothing
-
-mkOpts :: [FilePath] -> Options
-mkOpts paths = defaultOptions
-  { optImportPaths = paths
-  , optVerbosity   = VerbQuiet
-  , optWarn        = False
-  , optTargetTypes = [AbstractCurry]
-  }

src/Html/CurryHtml.hs

@@ -24,8 +24,9 @@ import Curry.Syntax (lexFile)
 
 import Html.SyntaxColoring
 
-import CompilerOpts (Options(..))
-import Frontend (parse, typingParse, fullParse)
+import Base.Messages (abortWith)
+import CompilerOpts (Options(..), TargetType (..))
+import Frontend (parse, fullParse)
 
 
 --- translate source file into HTML file with syntaxcoloring
@@ -41,7 +42,7 @@ source2html opts sourcefilename = do
                  else outputfilename
       modulname = takeFileName sourceprogname
   fullfname <- lookupCurryFile imports sourcefilename
-  program <- filename2program imports (fromMaybe sourcefilename fullfname)
+  program <- filename2program opts (fromMaybe sourcefilename fullfname)
   (if null outputfilename then writeModule True output'
                           else writeFile   output')
       (program2html modulname program)
@@ -49,14 +50,17 @@ source2html opts sourcefilename = do
 --- @param importpaths
 --- @param filename
 --- @return program
-filename2program :: [String] -> String -> IO Program
-filename2program paths filename = do
-  (Just cont) <- readModule filename
-  typingParseRes <- catchError $ typingParse paths filename cont
-  fullParseRes <- catchError $ fullParse paths filename cont
-  parseRes <- catchError $ return (parse filename cont)
-  lexRes <- catchError $ return (lexFile filename cont)
-  return $ genProgram cont [typingParseRes, fullParseRes, parseRes] lexRes
+filename2program :: Options -> String -> IO Program
+filename2program opts filename = do
+  mbModule <- readModule filename
+  case mbModule of
+    Nothing   -> abortWith ["Missing file: " ++ filename]
+    Just cont -> do
+      typingParseRes <- catchError $ fullParse opts filename cont
+      fullParseRes <- catchError $ fullParse (opts { optTargetTypes = [UntypedAbstractCurry]}) filename cont
+      parseRes <- catchError $ return (parse filename cont)
+      lexRes <- catchError $ return (lexFile filename cont)
+      return $ genProgram cont [typingParseRes, fullParseRes, parseRes] lexRes
 
 
 --- this function intercepts errors and converts it to Messages

src/Modules.hs

@@ -15,7 +15,7 @@
 -}
 
 module Modules
-  ( compileModule, loadModule, checkModuleHeader, checkModule
+  ( compileModule, loadModule, checkModuleHeader, checkModule, writeOutput
   ) where
 
 import Control.Monad (unless, when)
@@ -73,26 +73,30 @@ import Transformations
 compileModule :: Options -> FilePath -> IO ()
 compileModule opts fn = do
   loaded <- loadModule opts fn
-  case uncurry (checkModule opts) loaded of
+  case checkModule opts loaded of
     CheckFailed errs -> abortWith $ map show errs
-    CheckSuccess (env, modul) -> do
-      showWarnings opts $ uncurry warnCheck loaded
-      writeParsed        opts fn     modul
-      writeAbstractCurry opts fn env modul
-      when withFlat $ do
-        -- checkModule checks types, and then transModule introduces new
-        -- functions (by lambda lifting in 'desugar'). Consequence: The
-        -- types of the newly introduced functions are not inferred (hsi)
-        let (env2, il, dumps) = transModule opts env modul
-        -- dump intermediate results
-        mapM_ (doDump opts) dumps
-        -- generate target code
-        let intf = exportInterface env2 modul
-        let modSum = summarizeModule (tyConsEnv env2) intf modul
-        writeFlat opts fn env2 modSum il
-      where
-      withFlat = any (`elem` optTargetTypes opts)
-                 [FlatCurry, FlatXml, ExtendedFlatCurry]
+    CheckSuccess res -> do
+      showWarnings opts $ uncurry warnCheck res
+      writeOutput opts fn res
+
+writeOutput :: Options -> FilePath -> (CompilerEnv, CS.Module) -> IO ()
+writeOutput opts fn (env, modul) = do
+  writeParsed        opts fn     modul
+  writeAbstractCurry opts fn env modul
+  when withFlat $ do
+    -- checkModule checks types, and then transModule introduces new
+    -- functions (by lambda lifting in 'desugar'). Consequence: The
+    -- types of the newly introduced functions are not inferred (hsi)
+    let (env2, il, dumps) = transModule opts env modul
+    -- dump intermediate results
+    mapM_ (doDump opts) dumps
+    -- generate target code
+    let intf = exportInterface env2 modul
+    let modSum = summarizeModule (tyConsEnv env2) intf modul
+    writeFlat opts fn env2 modSum il
+  where
+  withFlat = any (`elem` optTargetTypes opts)
+              [FlatCurry, FlatXml, ExtendedFlatCurry]
 
 -- ---------------------------------------------------------------------------
 -- Loading a module
@@ -119,7 +123,7 @@ loadModule opts fn = do
 
 checkModuleHeader :: Options -> FilePath -> CS.Module -> (CS.Module, [Message])
 checkModuleHeader opts fn = checkModuleId fn
-                          . importPrelude opts
+                          . importPrelude opts fn
                           . CS.patchModuleId fn
 
 -- |Check whether the 'ModuleIdent' and the 'FilePath' fit together
@@ -135,8 +139,8 @@ checkModuleId fn m@(CS.Module mid _ _ _)
 -- 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 mid es is ds)
+importPrelude :: Options -> FilePath -> CS.Module -> CS.Module
+importPrelude opts fn m@(CS.Module mid es is ds)
     -- the Prelude itself
   | mid == preludeMIdent          = m
     -- disabled by compiler option
@@ -147,7 +151,7 @@ importPrelude opts m@(CS.Module mid es is ds)
   | otherwise                     = CS.Module mid es (preludeImp : is) ds
   where
   noImpPrelude = NoImplicitPrelude `elem` optExtensions opts
-  preludeImp   = CS.ImportDecl NoPos preludeMIdent
+  preludeImp   = CS.ImportDecl (first fn) preludeMIdent
                   False   -- qualified?
                   Nothing -- no alias
                   Nothing -- no selection of types, functions, etc.
@@ -161,18 +165,19 @@ importPrelude opts m@(CS.Module mid es is ds)
 -- TODO (2012-01-05, bjp): The export specification check for untyped
 --   AbstractCurry is deactivated as it requires the value information
 --   collected by the type checker.
-checkModule :: Options -> CompilerEnv -> CS.Module
+checkModule :: Options -> (CompilerEnv, CS.Module)
             -> CheckResult (CompilerEnv, CS.Module)
-checkModule opts env mdl = kindCheck env mdl -- should be only syntax checking ?
-                       >>= uncurry (syntaxCheck opts)
-                       >>= uncurry precCheck
-                       >>= (if withTypeCheck
-                              then \x -> uncurry typeCheck x >>= uncurry exportCheck
-                              else return)
-                       >>= return . (uncurry (qual opts))
+checkModule opts (env, mdl)
+  =   kindCheck env mdl -- should be only syntax checking ?
+  >>= uncurry (syntaxCheck opts)
+  >>= uncurry precCheck
+  >>= (if withTypeCheck
+        then \x -> uncurry typeCheck x >>= uncurry exportCheck
+        else return)
+  >>= return . (uncurry (qual opts))
   where
-  withTypeCheck  = any (`elem` optTargetTypes opts)
-                       [FlatCurry, ExtendedFlatCurry, FlatXml, AbstractCurry]
+  withTypeCheck = any (`elem` optTargetTypes opts)
+                      [FlatCurry, ExtendedFlatCurry, FlatXml, AbstractCurry]
 
 -- ---------------------------------------------------------------------------
 -- Translating a module