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
------------------------------------------------------------------------------
-- Derivor for COOSy observation types
------------------------------------------------------------------------------

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

-- Derives observers to a given program file:
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
--deriveTypeVar (index,_) | index < 26 = [' ',chr $ 97+index]
--                        | otherwise = ' ':"t" ++ (show index)

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