darcs - INblobs

1 {-|

2 Module : Functional.Language

3 Copyright : (c) Miguel VilaÃ§a 2007

5 Maintainer : jmvilaca@di.uminho.pt

6 Stability : experimental

7 Portability : portable

10 Small Functional Language

12 -}

13 module Functional.Language where

15 import Data.List

17 import Common

20 type Variable = String

22 data CallBy = Value | Name | Need deriving (Eq, Show)

24 data FuncLang = Var Variable -- 1 (precedences)

25 | Abst Variable FuncLang -- 7

26 | Appl FuncLang FuncLang -- 10

27 | TT -- 1

28 | FF -- 1

29 | IterBool FuncLang FuncLang FuncLang -- 5

30 | Zero -- 1

31 | Succ FuncLang -- 3

32 | IterNat Variable FuncLang FuncLang FuncLang -- 5

33 | Nil -- 1

34 | Cons FuncLang FuncLang -- 3

35 | IterList Variable Variable FuncLang FuncLang FuncLang -- 5

36 deriving (Eq)

38 -- | Default names and expressions for 'FuncLang' terms.

39 listLangConstructors :: [(String, FuncLang)]

40 listLangConstructors =

41 [ ("Abstraction" , Abst "x" (Var "t"))

42 , ("Application" , Appl (Var "t") (Var "u"))

43 , ("True" , TT)

44 , ("False" , FF)

45 , ("If then else" , IterBool (Var "V") (Var "F") (Var "b"))

46 , ("0" , Zero)

47 , ("successor" , Succ (Var "t"))

48 , ("Nat iterator" , IterNat "x" (Var "S") (Var "Z") (Var "t"))

49 , ("[]" , Nil)

50 , (":" , Cons (Var "H") (Var "T"))

51 , ("List iterator", IterList "x" "y" (Var "C") (Var "N") (Var "t"))

52 ]

54 instance Show FuncLang where

55 -- precedence 9 is a special one; means that it is inside an abstraction

56 showsPrec 9 (Abst v t) =

57 showChar ','

58 . showString v

59 . showsPrec 9 t

60 showsPrec 9 x = showChar ']' . showsPrec 0 x

61 showsPrec d (Abst v t) =

62 showParen (d > 7) $

63 showChar '['

64 . showString v

65 . showsPrec 9 t

66 -- elements of precedence 1; those never surrounded by parenthesis

67 showsPrec _ (Var x) = showString x

68 showsPrec _ TT = showString "tt"

69 showsPrec _ FF = showString "ff"

70 showsPrec _ Zero = showString "0"

71 showsPrec _ Nil = showString "nil"

72 -- elements of precedence 3

73 showsPrec _ (Succ n) =

74 showString "suc("

75 . showsPrec 0 n

76 . showChar ')'

77 showsPrec _ (Cons h t) =

78 showString "cons("

79 . showsPrec 0 h

80 . showChar ','

81 . showsPrec 0 t

82 . showChar ')'

83 -- elements of precedence 5

84 showsPrec _ (IterBool v f b) =

85 showString "iterbool("

86 . showsPrec 0 v

87 . showChar ','

88 . showsPrec 0 f

89 . showChar ','

90 . showsPrec 0 b

91 . showChar ')'

92 showsPrec _ (IterNat x s z n) =

93 showString "iternat("

94 . showsPrec 0 (Abst x s)

95 . showChar ','

96 . showsPrec 0 z

97 . showChar ','

98 . showsPrec 0 n

99 . showChar ')'

100 showsPrec _ (IterList h t c n l) =

101 showString "iterlist("

102 . showsPrec 0 (Abst h $ Abst t c)

103 . showChar ','

104 . showsPrec 0 n

105 . showChar ','

106 . showsPrec 0 l

107 . showChar ')'

108 -- elements of precedence 10

109 showsPrec d (Appl u v) =

110 showParen (d > 10) $

111 showsPrec 11 u

112 . showChar ' '

113 . showsPrec 11 v

114

115 -- | Show iter_TYPE symbols.

116 showAgent :: FuncLang -> String

117 showAgent t@(IterBool v f (Var "")) = show t

118 showAgent t@(IterNat x s z (Var "")) = show t

119 showAgent t@(IterList h r c n (Var "")) = show t

120 showAgent _ = error "unexpected functional term here"

121

122 cata :: (Variable -> r) -- ^ Var

123 -> (Variable -> r -> r) -- ^ Abstraction

124 -> (r -> r -> r) -- ^ Application

125 -> r -- ^ True

126 -> r -- ^ False

127 -> (r -> r -> r -> r) -- ^ IterBool

128 -> r -- ^ Zero

129 -> (r -> r) -- ^ Succ

130 -> (Variable -> r -> r -> r -> r) -- ^ IterNat

131 -> r -- ^ Nil

132 -> (r -> r -> r) -- ^ Cons

133 -> (Variable -> Variable -> r -> r -> r -> r) -- ^ IterList

134 -> FuncLang -- ^ term

135 -> r -- ^ result

136 cata fVar fAbst fAppl fTT fFF fIB fZ fS fIN fN fC fIL = cata'

137 where cata' term =

138 case term of

139 Var var -> fVar var

140 Abst var t -> fAbst var (cata' t)

141 Appl t1 t2 -> fAppl (cata' t1) (cata' t2)

142 TT -> fTT

143 FF -> fFF

144 IterBool t1 t2 t3 -> fIB (cata' t1) (cata' t2) (cata' t3)

145 Zero -> fZ

146 Succ t -> fS (cata' t)

147 IterNat var t1 t2 t3 -> fIN var (cata' t1) (cata' t2) (cata' t3)

148 Nil -> fN

149 Cons t1 t2 -> fC (cata' t1) (cata' t2)

150 IterList var1 var2 t1 t2 t3 -> fIL var1 var2 (cata' t1) (cata' t2) (cata' t3)

151

152 -- | Dummy variable

153 eVar = Var ""

154

155 -- | Collect all the symbols in a term.

156 -- The possible symbols are:

157 -- * @ IterBool t1 t2 (Var \"\") @

158 -- * @ IterNat v t1 t2 (Var \"\") @

159 -- * @ IterList v1 v2 t1 t2 (Var \"\") @

160 listIteratorSymbols,listSymbs :: FuncLang -> [FuncLang]

161 listIteratorSymbols = listSymbs

162

163 listSymbs term =

164 case term of

165 Var _var -> []

166 Abst _var t -> listSymbs t

167 Appl t1 t2 -> (listSymbs t1) `join` (listSymbs t2)

168 TT -> []

169 FF -> []

170 IterBool t1 t2 t3 -> [IterBool t1 t2 eVar] `join` (listSymbs t1) `join` (listSymbs t2) `join` (listSymbs t3)

171 Zero -> []

172 Succ t -> listSymbs t

173 IterNat var t1 t2 t3 -> [IterNat var t1 t2 eVar] `join` (listSymbs t1) `join` (listSymbs t2) `join` (listSymbs t3)

174 Nil -> []

175 Cons t1 t2 -> (listSymbs t1) `join` (listSymbs t2)

176 IterList var1 var2 t1 t2 t3 -> [IterList var1 var2 t1 t2 eVar] `join` (listSymbs t1) `join` (listSymbs t2) `join` (listSymbs t3)

177 where join = union

178

179 -- | Give some sequential names to symbols.

180 giveNames :: [FuncLang] -> [(FuncLang, String)]

181 giveNames = snd . mapAccumL f 1

182 where f acc x = (acc+1,(x,"Iter_" ++ show acc))

183

184

185 -- | List the free variables of a term; the result is a set.

186 freeVars :: FuncLang -> [String]

187 freeVars = cata singleton delete union [] [] fIB [] id fIN [] union fIL

188 where

189 fIB r1 r2 r3 = r1 `union` r2 `union` r3

190 fIN v r1 r2 r3 = (delete v r1) `union` r2 `union` r3

191 fIL x y r1 r2 r3 = ( r1\\[x,y] ) `union` r2 `union` r3

192

193 -- | Special lookup function for iterators with an equality.

194 lookupIterName :: FuncLang -> [(FuncLang, String)] -> Maybe String

195 lookupIterName term [] = Nothing

196 lookupIterName term ((term2,str):xs) | term `equal` term2 = Just str

197 | otherwise = lookupIterName term xs

198 where

199 equal :: FuncLang -> FuncLang -> Bool

200 equal (IterBool v1 f1 _) (IterBool v2 f2 _) = v1==v2 && f1==f2

201 equal (IterNat x1 s1 z1 _) (IterNat x2 s2 z2 _) = x1==x2 && s1==s2 && z1==z2

202 equal (IterList x1 y1 c1 n1 _) (IterList x2 y2 c2 n2 _) = x1==x2 && y1==y2 && c1==c2 && n1==n2

203 equal _ _ = False

204