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
|
module Coosy.Derive ( derive, deriveFile )
where
import Control.Monad ( unless, when )
import Data.Char ( isSpace )
import Data.List ( intercalate )
import System.Environment ( getProgName )
import AbstractCurry.Types
import AbstractCurry.Files
import AbstractCurry.Select ( tconsArgsOfType )
import System.CurryPath ( runModuleActionQuiet, stripCurrySuffix )
import System.Process ( sleep )
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 = stripCurrySuffix progfile
runModuleActionQuiet addOTypes progName
return $ unlines
[ "Observer functions have been added to:", progName, ""
, "A backup of the original file has been written to:"
, progName ++ ".curry.bak", ""
, "Don't forget to recompile the program and to reload it into your editor!"
]
addOTypes :: String -> IO ()
addOTypes fileName = do
let curryfile = fileName ++ ".curry"
progtext <- readFile curryfile
writeFile (curryfile ++ ".bak") progtext
when (coosyComment `elem` lines progtext) $ do
writeFile curryfile
(unlines (takeWhile (/= coosyComment) $ lines progtext))
sleep 1
prog <- readCurry fileName
appendFile curryfile ("\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 ++ " ::" ++ datactxt
++ 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
datactxt | arity == 0 = ""
| otherwise = brackets (arity>0)
(intercalate ", "
(map (\i -> "Data x" ++ show i)
[1 .. arity])) ++ " =>"
deriveTypeDecl (CTypeSyn (_,name) _ vs t) =
('o':name) ++ concatMap deriveTypeVar vs ++ "= " ++ deriveTypeExpr t ++ "\n"
deriveTypeDecl (CNewType _ _ _ _ _) = error "Cannot handle type synonyms"
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
deriveCCons _ _ (CRecord _ _ _) = error "Cannot handle record constructors"
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 _ _) =
maybe (error "Cannot derive type applications")
deriveConsTypeExpr
(tconsArgsOfType t)
deriveConsTypeExpr :: ((a,String), [AbstractCurry.Types.CTypeExpr]) -> String
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
|