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

module Coosy.Derive ( derive, deriveFile )
 where

import Control.Monad        ( 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     ( 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

-- Derives observers to a given program file:
deriveFile :: String -> IO String
deriveFile progfile = do
  let progName = stripCurrySuffix progfile
  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
  progtext <- readFile (fileName ++ ".curry")
  writeFile (fileName ++ ".curry.bak") progtext
  when (coosyComment `elem` lines progtext) $ do
    writeFile (fileName ++ ".curry")
              (unlines (takeWhile (/=coosyComment) $ lines progtext))
    sleep 1 -- wait for file to be written (has caused problems...)
  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 ++ " ::" ++ 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
--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