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
|
module Coosy.Derive(derive,deriveFile) where
import AbstractCurry.Types
import AbstractCurry.Files
import AbstractCurry.Select(tconsArgsOfType)
import System(getProgName)
import Char(isSpace)
derive :: IO ()
derive = do
progname <- getProgName
putStr $ "Program where type observers should be added (default: "++progname++"): "
answer <- getLine
let fileName = if all isSpace answer
then progname
else answer
msg <- deriveFile fileName
putStrLn msg
deriveFile :: String -> IO String
deriveFile progfile = do
let progName = takeWhile (/='.') progfile
addOTypes progName
return $ "Observer functions have been added to '"++progName++"'.\n\n"++
"A backup of the original file has been written to:\n"++
progName++".curry.bak\n\n"++
"Don't forget to recompile the program and to reload it"++
" into your editor!"
addOTypes :: String -> IO ()
addOTypes fileName = do
progLines <- readFile (fileName++".curry")
writeFile (fileName++".curry.bak") progLines
writeFile (fileName++".curry")
(unlines (takeWhile (/=coosyComment) $ lines progLines))
prog <- readCurry fileName
appendFile (fileName++".curry")
("\n\n"++coosyComment++"\n\n"++deriveProg prog)
where
coosyComment = "--oTypes added by Coosy"
deriveProg :: CurryProg -> String
deriveProg (CurryProg _ _ _ _ _ typeDecls _ _) =
concatMap deriveTypeDecl typeDecls
deriveTypeDecl :: CTypeDecl -> String
deriveTypeDecl (CType (_,name) _ vs cs _) =
'o':name ++ " ::" ++ concatMap (\i->" Observer x"++show i++" ->") [1..arity]
++ " Observer "
++ brackets (arity>0) (name ++ derivePatArgs arity) ++"\n"++
concatMap (deriveCCons ('o':name) vs) cs ++"\n"
where arity = length vs
deriveTypeDecl (CTypeSyn (_,name) _ vs t)
= ('o':name) ++concatMap deriveTypeVar vs ++ "= "++deriveTypeExpr t++"\n"
deriveCCons :: String -> [CTVarIName] -> CConsDecl -> String
deriveCCons tname vs (CCons _ _ (_,cname) _ texps) =
tname ++deriveTypeVarPattern vs (usedVars texps) ++
' ':brackets (arity>0) (cname ++ derivePatArgs arity) ++
" = o" ++ show arity ++ concatMap deriveTypeExpr texps ++
' ':show cname ++ ' ':cname++derivePatArgs arity++"\n"
where arity = length texps
deriveTypeExpr :: CTypeExpr -> String
deriveTypeExpr (CTVar index) = deriveTypeVar index
deriveTypeExpr (CTCons tc) = deriveConsTypeExpr (tc,[])
deriveTypeExpr (CFuncType t1 t2) =
' ':'(':dropWhile (==' ') (deriveTypeExpr t1)++" ~>"++ deriveTypeExpr t2++")"
deriveTypeExpr t@(CTApply tc ta) =
maybe (error "Cannot derive type applications")
deriveConsTypeExpr
(tconsArgsOfType t)
deriveConsTypeExpr ((_,name),ts)
| name=="[]" = " (oList"++concatMap deriveTypeExpr ts++")"
| ti>0 = " ("++tupleOName ti++concatMap deriveTypeExpr ts++")"
| otherwise = ' ':brackets (not (null ts))
('o':name++concatMap deriveTypeExpr ts)
where ti = tupleIndex name
deriveTypeVar :: CTVarIName -> String
deriveTypeVar (_,tvarname) = ' ':tvarname
derivePatArgs :: Int -> String
derivePatArgs n = concatMap (\ i->' ':'x':show i) [1..n]
deriveTypeVarPattern :: [CTVarIName] -> [CTVarIName] -> String
deriveTypeVarPattern [] _ = ""
deriveTypeVarPattern (v:vs) used
= (if elem v used then (deriveTypeVar v) else " _") ++
deriveTypeVarPattern vs used
usedVars :: [CTypeExpr] -> [CTVarIName]
usedVars [] = []
usedVars (CTVar index:ts) = index:usedVars ts
usedVars (CTCons _ : ts) = usedVars ts
usedVars (CFuncType t1 t2:ts) = usedVars (t1:t2:ts)
usedVars (CTApply tc ta : ts) = usedVars (tc:ta:ts)
tupleIndex :: String -> Int
tupleIndex s = case s of
('(':s1) -> countComma 1 s1
_ -> 0
tupleOName :: Int -> String
tupleOName arity | arity==2 = "oPair"
| arity==3 = "oTriple"
| otherwise = 'o' : (show arity ++ "Tuple")
countComma :: Int -> String -> Int
countComma _ [] = 0
countComma n [c] = if c==')' then n else 0
countComma n (',':s1:s) = countComma (n+1) (s1:s)
brackets :: Bool -> String -> String
brackets b s = if b then '(':s++")" else s
|