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
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
------------------------------------------------------------------
-- A tool to add all those type signatures, you didn't bother to 
-- write while developing the program. 
--
-- @author Bernd Brassel, with changes by Michael Hanus
-- @version April 2021
-- 
-- Possible extensions: Use type synonyms to reduce annotations
------------------------------------------------------------------

{-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-}

module AddTypes ( main, addTypeSignatures )
 where

import Control.Monad      ( when )
import Data.List
import System.Environment ( getArgs )

import AbstractCurry.Types
import AbstractCurry.Files
import AbstractCurry.Pretty
import Control.Search.AllValues  ( getOneValue )
import Control.Monad.Trans.State
import Language.Curry.StringClassifier
import System.CurryPath          ( runModuleAction )
import System.Process            ( exitWith, system )
import Text.Pretty


-- The tool is rather simple, it uses Curry's facilities for 
-- meta-programming to read the program in the form defined 
-- in the AbstractCurry module. 
-- The libraries for meta-programming provides commands to read
-- AbstractCurry programs typed and untyped.
-- By comparing the results of these two operations, we are able to
-- distinguish the inferred types from those given by the programmer.
-- 
-- addtypes makes use of the CurryStringClassifier, cf. function addTypes.


--- addtypes is supposed to get its argument, the file to add type signatures
--- to from the shell. 
main :: IO ()
main = do
  args <- getArgs
  case args of
    ["-h"]       -> printUsage
    ["--help"]   -> printUsage
    ["-?"]       -> printUsage
    ["-p",fname] -> runModuleAction (writeWithTypeSignatures False) fname
    [fname]      -> runModuleAction (writeWithTypeSignatures True)  fname
    _            -> printUsage >> exitWith 1

printUsage :: IO ()
printUsage = putStrLn $ unlines
  [ "A tool to add missing type signatures to top-level operations"
  , ""
  , "Usage: curry-addtypes [-p] <Curry module>"
  , ""
  , "-p : print new program source but do not replace source file"
  ]

--- The given file is read three times: a) typed, to get all the necessary 
--- type information b) untyped to find out, which of the types were 
--- specified by the user and c) as a simple string to which the signatures
--- are added.
--- If the first argument is `True`, addtypes will write a backup of the
--- source program to `<given filename>_ORG.curry` before replacing
--- the source program with the version with signatures,
--- otherwise the version with signatures is only printed.

writeWithTypeSignatures :: Bool -> String -> IO ()
writeWithTypeSignatures replace modname = do
   when replace $ do
     system $ "cp -p " ++ modname ++ ".curry " ++ modname ++ "_ORG.curry"
     return ()
   newprog <- addTypeSignatures modname
   if replace
     then do
       writeFile (modname ++ ".curry") newprog
       putStrLn $ "Signatures added.\nA backup of the original " ++
                  "file has been written to " ++ modname ++ "_ORG.curry"
     else putStrLn newprog

addTypeSignatures :: String -> IO String
addTypeSignatures modname = do
   typedProg   <- readCurry modname
   untypedProg <- readUntypedCurry modname
   progLines   <- readFile (modname ++ ".curry")
   -- enforce reading of complete source program before returning:
   mbprog <- getOneValue
               (unscan (addTypes (scan progLines)
                                 (getTypes typedProg untypedProg)))
   maybe (error "AddTypes: cannot add type signatures") return mbprog


--- retrieve the functions without type signature and their type

getTypes :: CurryProg -> CurryProg -> [(String,CQualTypeExpr)]
getTypes (CurryProg _ _ _ _ _ _ funcDecls1 _)
         (CurryProg _ _ _ _ _ _ funcDecls2 _) =
  getTypesFuncDecls funcDecls1 funcDecls2
 where
  getTypesFuncDecls [] [] = []
  getTypesFuncDecls (CFunc name _ _ t1 _:fs1) (CFunc _ _ _ t2 _:fs2)
    | isUntyped t2 = (snd name,t1) : getTypesFuncDecls fs1 fs2
    | otherwise    = getTypesFuncDecls fs1 fs2

--- addtypes implements a simple algorithm to decide where to add type 
--- information. Find the first line wich contains the function name 
--- on the left hand side and insert the type annotation before that line.
--- The problem with this algorithm is that it might get confused by 
--- comments. This is where the Curry string classifier comes in.
--- After using CurryStringClassifier.scan the function addTypes only 
--- has to process "Code" tokens and can be sure that there will be no
--- confusion with Comments, Strings or Chars within the program.

addTypes :: Tokens -> [(String,CQualTypeExpr)] -> Tokens
addTypes [] _ = []
addTypes (ModuleHead s:ts)   fts = ModuleHead s : (addTypes ts fts)
addTypes (SmallComment s:ts) fts = SmallComment s : (addTypes ts fts)
addTypes (BigComment s:ts)   fts = BigComment s : (addTypes ts fts)
addTypes (Text s:ts)         fts = Text s : (addTypes ts fts)
addTypes (Letter s:ts)       fts = Letter s : (addTypes ts fts)
addTypes (Code s:ts)         fts = Code newS : newTs
  where
    newS = addTypesCode s newFts fts
    newTs = if null newFts then ts else addTypes ts newFts
    newFts = unknown

--- Within a given  code segment insert all annotations for the contained
--- function and return the new code + the list of functions not yet 
--- inserted (via the logical variable newFts).

addTypesCode :: String -> [(String,CQualTypeExpr)] -> [(String,CQualTypeExpr)]
             -> String
addTypesCode code [] [] = code
addTypesCode code newFts ((f,t):fts)
  | null code = (newFts=:=((f,t):fts)) &> []
  | otherwise
  = case lhs of
      [] -> head remainder
          : addTypesCode (tail remainder) newFts ((f,t):fts)
      ' ':_ -> line ++ addTypesCode remainder newFts ((f,t):fts)
      _ -> if defines f lhs
             then showWidth 78 (ppSig $ normalize t) ++ "\n" ++
                  line ++ addTypesCode remainder newFts fts
             else line ++ addTypesCode remainder newFts ((f,t):fts)

  where
    (line,remainder) = break (=='\n') code
    (lhs,_) = break (=='=') line
    printf = if all (flip elem infixIDs) f then '(':f++")" else f

    ppSig texp = nest 2 $
                   sep [ text printf
                       , align $ doubleColon <+>
                         ppCQualTypeExpr defaultOptions texp]


--- test for functions not typed by the programmer

isUntyped :: CQualTypeExpr -> Bool
isUntyped typeexpr =
  case typeexpr of
    CQualType (CContext []) (CTCons (mod,name))
      -> name == "untyped" && mod == "Prelude"
    _ -> False

------------------------------------------------------------------------------
-- Normalization of type variables in type expressions by enumerating
-- them starting from `(1,"a")` and type variables with singleton
-- occurrences are replaced by `(0,"_")`.

-- The state used during normalization consists of a current number
-- for enumerating type variables, a mapping from old variables
-- to new numbers (which will be expanded during the transformation),
-- and the list of all occurrences of type varables (which will be
-- used to check for single occurrences).
data NormInfo = NormInfo { currNr   :: Int
                         , varMap   :: [(Int,Int)]
                         , allTVars :: [CTVarIName]
                         }

-- The initial normalization state.
initNormInfo :: CQualTypeExpr -> NormInfo
initNormInfo qt = NormInfo 0 [] (allTVarsOfQualType qt)
 where
  allTVarsOfQualType (CQualType (CContext ctxt) t) =
    concatMap (concatMap allTVarsTExp . snd) ctxt ++ allTVarsTExp t

  allTVarsTExp (CTVar tv)        = [tv]
  allTVarsTExp (CTCons _)        = []
  allTVarsTExp (CFuncType t1 t2) = allTVarsTExp t1 ++ allTVarsTExp t2
  allTVarsTExp (CTApply t1 t2)   = allTVarsTExp t1 ++ allTVarsTExp t2


-- The type of our actual state monad contains the normalization state.
type TransNorm a = State NormInfo a

-- Auxiliary operation: get a new variable index for a given variable index.
-- Either return the existing index or create a fresh one and update
-- the state.
getVarIndex :: Int -> TransNorm Int
getVarIndex v = do
  ti <- get
  maybe (do let freshnr = currNr ti + 1
            put ti { currNr = freshnr, varMap = (v,freshnr) : varMap ti }
            return freshnr )
        return
        (lookup v (varMap ti))

--- Normalize type expression by rename type variables left-to-right
--- beginning with 0.
normalize :: CQualTypeExpr ->  CQualTypeExpr
normalize qte = evalState (normalizeT qte) (initNormInfo qte)

normalizeT :: CQualTypeExpr -> TransNorm CQualTypeExpr
normalizeT (CQualType (CContext ctxt) t) = do
  ctxt' <- normCtxt ctxt
  t'    <- normTExp t
  return (CQualType (CContext ctxt') t')

normCtxt :: [CConstraint] -> TransNorm [CConstraint]
normCtxt [] = return []
normCtxt ((qf,ts) : ctxt) = do
  ts'   <- mapM normTExp ts
  ctxt' <- normCtxt ctxt
  return ((qf,ts') : ctxt')

normTExp :: CTypeExpr -> TransNorm CTypeExpr
normTExp (CTVar tv@(i,_)) = do
  ti <- get
  if length (filter (==tv) (allTVars ti)) <= 1
    then return (CTVar (0,"_"))
    else do ni <- getVarIndex i
            return (toTVar ni)
normTExp (CTCons n) = return (CTCons n)
normTExp (CFuncType t1 t2) = do
  t1' <- normTExp t1
  t2' <- normTExp t2
  return (CFuncType t1' t2')
normTExp (CTApply t1 t2) = do
  t1' <- normTExp t1
  t2' <- normTExp t2
  return (CTApply t1' t2')

--- Name type variables with a,b,c ... z, t0, t1, ...:
toTVar :: Int -> CTypeExpr
toTVar n | n < 27    = CTVar (n, [chr (96+n)])
         | otherwise = CTVar (n, "t" ++ show (n-27))

------------------------------------------------------------------------------
-- Auxiliaries:

--- a left hand side defines a function named f, if it starts leftmost,
--- and contains f 
defines :: String -> String -> Bool
defines f lhs
  | null ts = False
  | head lhs == ' ' = False
  | otherwise = elem f ts
  where
    ts = symbols lhs

--- delimiters between terms on left hand sides
delimiters :: String
delimiters = " ([{,}])"

--- these characters form infix operator names
infixIDs :: String
infixIDs =  "~!@#$%^&*+-=<>?./|\\:"

--- divide a left hand side to a list of symbols contained
--- e.g. symbols "f x [y,z]" = ["f","x","y","z"]
symbols :: String -> [String]
symbols lhs = syms [] lhs
  where
    maybeSym t = if null t then [] else [t]
    syms s [] = maybeSym s
    syms s (x:xs)
      | elem x delimiters
      = maybeSym s ++ syms [] (dropWhile (flip elem delimiters) xs)
      | otherwise
      = syms (s ++ [x]) xs

------------------------------------------------------------------------------