Add short-ast target and change comment target

src/CompilerOpts.hs

@@ -175,7 +175,7 @@ verbosities = [ ( VerbQuiet , "0", "quiet" )
 -- |Type of the target file
 data TargetType
   = Tokens               -- ^ Source code tokens
-  | CommentTokens        -- ^ Source code comment tokens
+  | Comments             -- ^ Source code comments
   | Parsed               -- ^ Parsed source code
   | FlatCurry            -- ^ FlatCurry
   | TypedFlatCurry       -- ^ Typed FlatCurry
@@ -183,6 +183,7 @@ data TargetType
   | UntypedAbstractCurry -- ^ Untyped AbstractCurry
   | Html                 -- ^ HTML documentation
   | AST                  -- ^ Abstract-Syntax-Tree after checks
+  | ShortAST             -- ^ Abstract-Syntax-Tree with shortened decls
     deriving (Eq, Show)
 
 -- |Warnings flags
@@ -425,8 +426,8 @@ options =
   -- target types
   , targetOption Tokens               "tokens"
       "generate token stream"
-  , targetOption CommentTokens        "commentTokens"
-      "generate comment token stream"
+  , targetOption Comments             "comments"
+      "generate comments stream"
   , targetOption Parsed               "parse-only"
       "generate source representation"
   , targetOption FlatCurry            "flat"
@@ -441,6 +442,8 @@ options =
       "generate html documentation"
   , targetOption AST                  "ast"
       "generate abstract syntax tree"
+  , targetOption ShortAST                  "short-ast"
+      "generate shortened abstract syntax tree for documentation"
   , Option "F"  []
       (NoArg (onPrepOpts $ \ opts -> opts { ppPreprocess = True }))
       "use custom preprocessor"

src/CurryBuilder.hs

@@ -167,13 +167,14 @@ process opts idx m fn deps
   destFiles = [ gen fn | (t, gen) <- nameGens, t `elem` optTargetTypes opts]
   nameGens  =
     [ (Tokens              , tgtDir . tokensName       )
-    , (CommentTokens       , tgtDir . commentTokensName)
+    , (Comments            , tgtDir . commentsName)
     , (Parsed              , tgtDir . sourceRepName    )
     , (FlatCurry           , tgtDir . flatName         )
     , (TypedFlatCurry      , tgtDir . typedFlatName    )
     , (AbstractCurry       , tgtDir . acyName          )
     , (UntypedAbstractCurry, tgtDir . uacyName         )
     , (AST                 , tgtDir . astName          )
+    , (ShortAST            , tgtDir . shortASTName     )
     , (Html                , const (fromMaybe "." (optHtmlDir opts) </> htmlName m))
     ]
 

src/Modules.hs

@@ -43,6 +43,7 @@ import Curry.FlatCurry.InterfaceEquivalence (eqInterface)
 import Curry.Files.Filenames
 import Curry.Files.PathUtils
 import Curry.Syntax.InterfaceEquivalence
+import Curry.Syntax.Utils (shortenModuleAST)
 import Curry.Syntax.Lexer (Token(..), Category(..))
 
 import Base.Messages
@@ -65,7 +66,7 @@ import Generators
 import Html.CurryHtml (source2html)
 import Imports
 import Interfaces (loadInterfaces)
-import TokenStream (showTokenStream)
+import TokenStream (showTokenStream, showCommentTokenStream)
 import Transformations
 
 -- The function 'compileModule' is the main entry-point of this
@@ -87,11 +88,13 @@ import Transformations
 compileModule :: Options -> ModuleIdent -> FilePath -> CYIO ()
 compileModule opts m fn = do
   mdl <- loadAndCheckModule opts m fn
-  writeTokens        opts (fst mdl)
-  writeCommentTokens opts (fst mdl)
-  writeParsed opts mdl
-  writeHtml   opts (qual mdl)
-  writeAST    opts (fst mdl, fmap (const ()) (snd mdl))
+  writeTokens   opts (fst mdl)
+  writeComments opts (fst mdl)
+  writeParsed   opts mdl
+  writeHtml     opts (qual mdl)
+  let umdl = (fst mdl, fmap (const ()) (snd mdl))
+  writeAST      opts umdl
+  writeShortAST opts umdl
   mdl' <- expandExports opts mdl
   qmdl <- dumpWith opts CS.showModule CS.ppModule DumpQualified $ qual mdl'
   writeAbstractCurry opts qmdl
@@ -291,18 +294,14 @@ writeTokens opts env = when tokTarget $ liftIO $
   tokTarget  = Tokens `elem` optTargetTypes opts
   useSubDir  = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)
 
-writeCommentTokens :: Options -> CompilerEnv -> CYIO ()
-writeCommentTokens opts env = when tokTarget $ liftIO $ (putStrLn "lol" >>
-  writeModule (useSubDir $ commentTokensName (filePath env))
-              (showTokenStream $ filter (isCommentTok . snd) (tokens env)))
+writeComments :: Options -> CompilerEnv -> CYIO ()
+writeComments opts env = when tokTarget $ liftIO $
+  writeModule (useSubDir $ commentsName (filePath env))
+              (showCommentTokenStream $ tokens env)
   where
-  tokTarget  = CommentTokens `elem` optTargetTypes opts
+  tokTarget  = Comments `elem` optTargetTypes opts
   useSubDir  = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)
 
--- | Check if Token is LineComment or NestedComment
-isCommentTok :: Token -> Bool
-isCommentTok (Token c _) = c == NestedComment || c == LineComment
-
 -- |Output the parsed 'Module' on request
 writeParsed :: Show a => Options -> CompEnv (CS.Module a) -> CYIO ()
 writeParsed opts (env, mdl) = when srcTarget $ liftIO $
@@ -395,6 +394,15 @@ writeAST opts (env, mdl) = when astTarget $ liftIO $
   useSubDir  = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)
 
 
+writeShortAST :: Options -> CompEnv (CS.Module ()) -> CYIO ()
+writeShortAST opts (env, mdl) = when astTarget $ liftIO $
+  writeModule (useSubDir $ shortASTName (filePath env))
+              (CS.showModule $ shortenModuleAST mdl)
+  where
+  astTarget  = ShortAST `elem` optTargetTypes opts
+  useSubDir  = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)
+
+
 type Dump = (DumpLevel, CompilerEnv, String)
 
 dumpWith :: MonadIO m

src/TokenStream.hs

@@ -9,7 +9,7 @@
     and spans of a Curry source module into a separate file.
 -}
 
-module TokenStream (showTokenStream) where
+module TokenStream (showTokenStream, showCommentTokenStream) where
 
 import Data.List             (intercalate)
 
@@ -21,20 +21,46 @@ import Curry.Syntax          (Token (..), Category (..), Attributes (..))
 -- The list is split into one tuple on each line to increase readability.
 showTokenStream :: [(Span, Token)] -> String
 showTokenStream [] = "[]\n"
-showTokenStream ts = "[ " ++ intercalate "\n, " (map showST filteredTs) ++ "\n]\n"
+showTokenStream ts =
+  "[ " ++ intercalate "\n, " (map showST filteredTs) ++ "\n]\n"
   where filteredTs     = filter (not . isVirtual) ts
+        showST (sp, t) = "(" ++ showSpanAsPair sp ++ ", " ++ showToken t ++ ")"
+
+-- |Show a list of 'Span' and 'Token' tuples filtered by CommentTokens.
+-- The list is split into one tuple on each line to increase readability.
+showCommentTokenStream :: [(Span, Token)] -> String
+showCommentTokenStream [] = "[]\n"
+showCommentTokenStream ts =
+  "[ " ++ intercalate "\n, " (map showST filteredTs) ++ "\n]\n"
+  where filteredTs     = filter isComment ts
         showST (sp, t) = "(" ++ showSpan sp ++ ", " ++ showToken t ++ ")"
 
 isVirtual :: (Span, Token) -> Bool
 isVirtual (_, Token cat _) = cat `elem` [EOF, VRightBrace, VSemicolon]
 
+isComment :: (Span, Token) -> Bool
+isComment (_, Token cat _) = cat `elem` [LineComment, NestedComment]
+
 -- show 'span' as "((startLine, startColumn), (endLine, endColumn))"
+showSpanAsPair :: Span -> String
+showSpanAsPair sp =
+  "(" ++ showPosAsPair (start sp) ++ ", " ++ showPos (end sp) ++ ")"
+
+-- show 'span' as "(Span startPos endPos)"
 showSpan :: Span -> String
-showSpan sp = "(" ++ showPos (start sp) ++ ", " ++ showPos (end sp) ++ ")"
+showSpan NoSpan = "NoSpan"
+showSpan Span { start = s, end = e } =
+   "(Span " ++ showPos s ++ " " ++ showPos e ++ ")"
 
--- show 'Position' as "(line, column)"
+-- show 'position' as "(Position line column)"
 showPos :: Position -> String
-showPos p = "(" ++ show (line p) ++ ", " ++ show (column p) ++ ")"
+showPos NoPos = "NoPos"
+showPos Position { line = l, column = c } =
+  "(Position " ++ show l++ " " ++ show c ++ ")"
+
+-- show 'Position' as "(line, column)"
+showPosAsPair :: Position -> String
+showPosAsPair p = "(" ++ show (line p) ++ ", " ++ show (column p) ++ ")"
 
 -- |Show tokens and their value if needed
 showToken :: Token -> String