1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
{- |
    Module      :  $Header$
    Description :  Main module

    Command line tool for checking programming style of Curry files.
-}





module CASC ( main ) where

import Directory    ( doesDirectoryExist, getDirectoryContents )
import FilePath
import IO           ( hPutStrLn, hIsTerminalDevice, stdout, stderr )
import List         ( (\\), intercalate, last, isSuffixOf )
import Maybe        ( isJust )
import ReadShowTerm ( readUnqualifiedTerm, readQTermFile )
import System       ( exitWith, getProgName, system )

import System.Console.ANSI.Codes ( blue, green, red, yellow )
import System.CurryPath    ( lookupModuleSourceInLoadPath, stripCurrySuffix
                           , inCurrySubdir )
import System.FrontendExec ( FrontendTarget(..), callFrontendWithParams
                           , defaultParams, setQuiet, addTarget )

import AST.AddSpans            ( apModule )
import AST.SpanAST             ( Module )
import AST.SortSplit           ( sortSplitModule )
import AutoCorr.AutoCorrPosAST ( correctModule )
import Check.CheckPosAST       ( checkModule )
import Check.LineLength        ( checkLine )
import Config.ReadConfig
import Config.Types            ( Check (CLineLength) )
import Opts
import AST.RemoveSpans         ( rsModule )
import Utils

-- |Get options from command line and pass them to main function `casc`
main :: IO ()
main = getCheckOpts >>= casc "casc"

-------------------------------------------------------------------------------
--- Main function of tool casc. Checks Mode and takes appropriate actions.
--- @param prog  - name of program
--- @param opts  - options which have been read in from command line
--- @param files - files or directories which are to be processed
--- @param errs  - errors that happend while reading  args from command line

casc :: String -> (Options, [String], [String]) -> IO ()
casc prog (opts, files, errs)
  | mode == ModeHelp    = printUsage prog
  | mode == ModeVersion = printVersion
  | null files          = badUsage prog ["no input files"]
  | mode == ModeCheck   = do fL <- mapIO (subFiles (optRecursive opts)) files
                             isTerminal <- hIsTerminalDevice stdout
                             checkAll (concat fL) (verb, col isTerminal)
  | not $ null errs     = badUsage prog errs
  | otherwise           = error "casc: no option"
  where
    mode = optMode      opts
    verb = optVerbosity opts
    col isterm = case optColor opts of
                   ColOn   -> True
                   ColOff  -> False
                   ColAuto -> isterm

    subFiles :: Bool -> String -> IO [String]
    subFiles rec f = do
      isdir <- doesDirectoryExist f
      if isdir
        then if rec
               then do
                 fs <- dirFiles f
                 submods <- mapIO (subFiles rec) fs >>= return . concat
                 return (map (intercalate "." . splitDirectories) submods)
               else curryFiles f
        else do
          let fs = stripCurrySuffix f
          mbsrc <- lookupModuleSourceInLoadPath fs
          if isJust mbsrc
            then return [fs]
            else error $
                   "Curry program or directory `" ++ f ++ "' does not exist."

type CallOpts = (Verbosity, Bool)

-------------------------------------------------------------------------------
--- Initiate checking procedure.
--- @param files - all files from invocation of `casc`
--- @param verb  - option: verbosity - if "quiet", don't print status

checkAll :: [String] -> CallOpts -> IO()
checkAll []          _    = putStrLn "No programs found, nothing to be done."
checkAll files@(_:_) (verb, col) = do

  let c = red "C" ++ yellow "A" ++ green "S" ++ blue "C"
  if col
    then wStatus verb
                $ "\nWelcome to " ++ c
               ++ ", the " ++ red "C" ++ "urry "
               ++ yellow "A" ++ "utomatic "
               ++ green "S" ++ "tyle "
               ++ blue "C" ++ "hecker.\n\n"
               ++ "The following modules will be checked:\n"
               ++ intercalate " " files ++ "\n"
    else wStatus verb
                  $ "\nWelcome to CASC, the Curry Automatic Style Checker.\n\n"
                 ++ "The following modules will be checked:\n"
                 ++ intercalate ", " files ++ "\n"

  -- Pass programs along to checkOne, but only if there are features to check
  when (not $ null checkList) $ mapIO_  (checkOne (verb, col)) files

-------------------------------------------------------------------------------
--- Execute checking procedure for one file.
--- @param file - the file to be checked
--- @param verb - option: verbosity - if "quiet", don't print status

checkOne :: CallOpts -> String -> IO ()
checkOne (verb, col) file = do
  wStatusLn verb $ "\nProcessing program `" ++ file ++ "'..."
  let progname = stripCurrySuffix file
  mbsrc <- lookupModuleSourceInLoadPath progname
  case mbsrc of
    Nothing            -> error $ "Source file not found!"
    Just (dir,srcfile) ->
      catch (checkOneSourceFile (verb, col) progname dir srcfile)
            (\err -> hPutStrLn stderr $ "Internal error: " ++ showError err)

checkOneSourceFile :: CallOpts -> String -> String -> String -> IO ()
checkOneSourceFile (verb, col) progname dir srcfile = do

  -- Invoke front end
  let options = addTarget TOKS (setQuiet True defaultParams)
  callFrontendWithParams CY options progname

  -- Retrieve token stream
  let tokenFile = inCurrySubdir (dir </> takeFileName progname) <.> "tokens"
  toks <- liftIO filterTS (readQTermFile tokenFile)
  wDebug verb $ "Tokens: " ++ show toks

  -- Retrieve abstract syntax tree in an order synchronous with tokenstream
  let astFile = inCurrySubdir (dir </> takeFileName progname) <.> "cy"
  astStr <- readFile astFile
  let ast = sortSplitModule $ readUnqualifiedTerm ["Prelude", "AST.AST"] astStr
  wDebug verb $ "AST: " ++ show ast

  -- Extend AST with positions
  wStatus verb "Extending abstract syntax tree... "
  let posAST = either error id $ fst $ apModule ast toks

  wDebug verb $ "Extended AST: " ++ show posAST

  -- Retrieve source file
  src <- readFile srcfile

  -- Check whether structures in active checks are valid
  wStatusLn verb "Checking... "
  let msgs         = checkModule posAST
                     ++ condMsg (shallCheck CLineLength) (checkLine src)
      msgsNotEmpty = (not $ null msgs)
  when (not $ null msgs) $ do
    when (verb == VerbQuiet) $ putStrLn $ "Program: " ++ progname
    putStrLn $ prettyMsg col msgs
  wStatusLn verb "Done."

  -- Initiate autocorrection if parameter in config file is set to "yes"
  let corrNotEmpty = (not $ null corrList)
      shallCorr    = (autoCorr == "yes" || autoCorr == "y")
      corrActive   = corrNotEmpty && msgsNotEmpty && shallCorr
  when corrActive $ correctOne (progname <.> "curry") posAST verb

-- |Autocorrection for one file.
-- |Overwrite .curry/file.cy with corrected AST.
-- |Later, the .curry file itself should be overwritten by the exaxtly
-- |pretty printed corrected PosAST.
correctOne :: String -> Module -> Verbosity -> IO ()
correctOne file posAST verb =
  do let corrOut   = ".curry" </> replaceExtension file ".cy"
         corrAst   = correctModule posAST
         rpAst     = rsModule corrAst
     when (verb == VerbDebug)
          (putStrLn $ "Corrected PosAST: " ++ show corrAst)
     when (verb == VerbDebug)
          (putStrLn $ "With removed positions: " ++ show rpAst)
     writeFile corrOut $ show rpAst
     when (verb == VerbStatus)
          (putStrLn $ "Corrections have been applied to AST file, " ++
                      "but source file still unchanged.")

-- |Take a path. If it ends with a ".curry"-file, drop the file name.
pathName :: String -> String
pathName d = if (takeExtension d == ".curry")
               then dropFileName d
               else d

-- |Get list of .curry files in a given directory.
curryFiles :: String -> IO [String]
curryFiles dirpath = dirFiles dirpath >>= return . filter (isSuffixOf ".curry")

-- |Get list of directory contents and combine each file name to a path
-- |while filtering unneeded entries
dirFiles :: String -> IO [String]
dirFiles dirpath = do
  dcont <- getDirectoryContents dirpath >>= return . (\\ [".", "..", ".curry"])
  cont <- mapIO (\f -> curryOrDir f >>= \b -> return $ if b then [f] else [])
                dcont >>= return . concat
  return $ if dirpath == "." then cont else map (combine dirpath) cont
 where
   curryOrDir f = if ".curry" `isSuffixOf` f
                    then return True
                    else doesDirectoryExist (combine dirpath f)

-- |Print usage message
help :: IO ()
help = do
  putStr "Usage: " >> getProgName >>= putStr >> putStrLn " COMMAND [OPTIONS]"
  putStrLn "  Curry Style Checker"
  putStrLn ""
  putStrLn "Commands:"
  putStrLn "  help"
  exitWith 0

-- |Print the usage information of the command line tool
printUsage :: String -> IO ()
printUsage prog = putStrLn $ cascTitle ++ "\n\n" ++ usage prog

-- |Print the program version
printVersion :: IO ()
printVersion = putStrLn $ "This is " ++ cascTitle

-- |Show a greeting of CASC
cascTitle :: String
cascTitle = "CASC (Curry Automatic Style Checker), version " ++ cascVersion

-- |Number of current casc version
cascVersion :: String
cascVersion = "1.0 of 29/08/2016"

-- |Print errors and abort execution on bad parameters
badUsage :: String -> [String] -> IO ()
badUsage prog errs = do
  putStrsLn $ map (\ err -> prog ++ ": " ++ err) errs
  error $ "Try 'curry style --help' for more information"