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

module CPM.Diff.CurryComments
  ( readComments
  , SourceLine
  , getFuncComment
  ) where

import Char
import List (isSuffixOf)

-- This is adapted from the currydoc source code.

--- Reads the pragma comments from a Curry program.
--- The first component of the result
--- is the comment for the module definition. The second component is a map
--- from different source line types to pragma comments on that source line.
readComments :: String -> IO (String, [(SourceLine, String)])
readComments filename = do
  prog <- readFile filename
  return (groupLines . filter (/= OtherLine) . map classifyLine . lines $ prog)

data SourceLine = PragmaCmt String
                | ModDef
                | DataDef String
                | FuncDef String
                | OtherLine
 deriving Eq

classifyLine :: String -> SourceLine
classifyLine line
  | take 3 line == "{-#" = PragmaCmt (drop 3 line) -- #-}
  | take 7 line == "module " = ModDef
  | take 7 line == "import " = ModDef
  | otherwise = if null id1
                  then OtherLine
                  else if id1 == "data" || id1 == "type" || id1 == "newtype"
                        then DataDef (getDatatypeName line)
                        else if "'default" `isSuffixOf` id1
                              then OtherLine
                              else FuncDef id1
   where
    id1 = getFirstId line
    getDatatypeName = takeWhile isIdChar . dropWhile (== ' ') . dropWhile isIdChar

getFirstId :: String -> String
getFirstId [] = ""
getFirstId (c:cs)
  | isAlpha c = takeWhile isIdChar (c:cs)
  | c == '('  = let bracketId = takeWhile (/= ')') cs
                 in if all (`elem` infixIDs) bracketId
                    then bracketId
                    else ""
  | otherwise = ""

isIdChar :: Char -> Bool
isIdChar c = isAlphaNum c || c == '_' || c == '\''

infixIDs :: String
infixIDs =  "~!@#$%^&*+-=<>?./|\\:"

groupLines :: [SourceLine] -> (String, [(SourceLine, String)])
groupLines sls =
  let (modCmts, progCmts) = break (== ModDef) sls
   in if progCmts == []
      then ("", groupProgLines sls)
      else (concatMap getComment modCmts,
            groupProgLines (filter (/= ModDef) (tail progCmts)))
 where
  getComment src = case src of
    PragmaCmt cmt -> cmt ++ "\n"
    _             -> ""

groupProgLines :: [SourceLine] -> [(SourceLine, String)]
groupProgLines [] = []
groupProgLines (PragmaCmt cmt : sls) = groupComment cmt sls
groupProgLines (FuncDef f     : sls) = (FuncDef f, "") : skipFuncDefs f sls
groupProgLines (DataDef d     : sls) = (DataDef d, "") : skipDataDefs d sls
groupProgLines (ModDef        : sls) = groupProgLines sls
groupProgLines (OtherLine     : sls) = groupProgLines sls

groupComment :: String -> [SourceLine] -> [(SourceLine, String)]
groupComment _ [] = []
groupComment cmt (PragmaCmt cmt1 : sls) = groupComment (cmt ++ "\n" ++ cmt1) sls
groupComment cmt (FuncDef f      : sls) = (FuncDef f, cmt) : skipFuncDefs f sls
groupComment cmt (DataDef d      : sls) = (DataDef d, cmt) : skipDataDefs d sls
groupComment cmt (ModDef         : sls) = groupComment cmt sls
groupComment cmt (OtherLine      : sls) = groupComment cmt sls

skipFuncDefs :: String -> [SourceLine] -> [(SourceLine, String)]
skipFuncDefs _ [] = []
skipFuncDefs _ (PragmaCmt cmt : sls) = groupProgLines (PragmaCmt cmt : sls)
skipFuncDefs _ (DataDef d     : sls) = groupProgLines (DataDef d   : sls)
skipFuncDefs f (FuncDef f1    : sls) =
  if f == f1 then skipFuncDefs f sls
             else groupProgLines (FuncDef f1 : sls)
skipFuncDefs f (ModDef        : sls) = skipFuncDefs f sls
skipFuncDefs f (OtherLine     : sls) = skipFuncDefs f sls

skipDataDefs :: String -> [SourceLine] -> [(SourceLine, String)]
skipDataDefs _ [] = []
skipDataDefs _ (PragmaCmt cmt : sls) = groupProgLines (PragmaCmt cmt : sls)
skipDataDefs _ (FuncDef f     : sls) = groupProgLines (FuncDef f   : sls)
skipDataDefs d (DataDef d1    : sls) =
  if d == d1 then skipDataDefs d sls
             else groupProgLines (DataDef d1 : sls)
skipDataDefs d (ModDef        : sls) = skipDataDefs d sls
skipDataDefs d (OtherLine     : sls) = skipDataDefs d sls

--- Get the pragma comments for a function from a map from source lines
--- to comments.
getFuncComment :: String -> [(SourceLine, String)] -> String
getFuncComment _ [] = ""
getFuncComment fname ((def, cmt):fdcmts) = case def of
  FuncDef f -> if fname == f then cmt else getFuncComment fname fdcmts
  _         -> getFuncComment fname fdcmts