1 module Ids 2 3 ( Id(..) 4 , Form(..) 5 6 , Kind(..) 7 , Bind(..) 8 9 , changeprec 10 , setarity 11 , setform 12 13 , idname 14 , idform 15 16 , idarity -- returns Int 17 , maybe_idarity -- returns Maybe Int 18 19 , idlook 20 , iduse 21 , idprec 22 , idbind 23 24 , findid 25 26 , mkid 27 , mknat 28 29 , userfun 30 , uservar 31 , usercon 32 33 34 , ppfn, ppop 35 36 , IdTable 37 38 , inIts 39 , emptyIT 40 , lookupIT 41 , addToIT 42 , plusIT 43 44 ) 45 46 where 47 48 -- import Trace 49 50 import Maybes 51 52 import Char (isDigit) 53 54 import FiniteMap 55 import Pretty 56 import PrettyClass 57 58 import Lex (updown) 59 60 import Options 61 62 data Kind = Fn | Op 63 deriving (Eq, Show) 64 65 data Bind = Lft | Rght | Nn -- associativity 66 deriving (Eq, Show) 67 68 data Form 69 = Passive String -- is just expanded 70 | Active Int String -- arguments get plugged in 71 72 data Id = Id 73 String -- name (that is typed in) 74 Form -- latex expansion (may contain #1, #2 ...) 75 -- for expansions of arguments 76 (Maybe Int) -- arity 77 Kind -- looks like Fn or Op 78 Kind -- used as Fn or Op 79 (Maybe Int) -- precedence 80 Bind -- Associativity 81 82 -- won't need this much, except for debugging 83 instance Show Id where showsPrec p id = showString (idname id) 84 85 86 instance Eq Id where 87 x == y = idname x == idname y -- disregarding all other fields 88 89 instance Ord Id where 90 x <= y = idname x <= idname y -- disregarding all other fields 91 92 ---------------------------------------------- 93 94 95 ppfn opts id = caseopts opts "code" 96 [ ("plain", case idlook id of 97 Fn -> ppStr ( idname id ) 98 Op -> ppStr ("(" ++ idname id ++ ")") ) 99 100 , ("latex", 101 let f = case idform id of 102 Active _ _ -> idname id -- shouldn't happen 103 Passive form -> form 104 in case idlook id of 105 Fn -> ppStr ( f ) 106 Op -> ppStr ("(" ++ f ++ ")") ) 107 ] 108 109 ppop opts id = caseopts opts "code" 110 [ ("plain", case idlook id of 111 Fn -> ppStr ("`" ++ idname id ++ "`") 112 Op -> if idname id == getopt opts "apply" && onoff opts "implicit" 113 then ppNil 114 else ppStr (idname id) 115 ) 116 , ("latex", 117 let f = case idform id of 118 Active _ _ -> idname id -- shouldn't happen 119 Passive form -> form 120 in case idlook id of 121 122 123 -- Fn -> ppStr ("`" ++ f ++ "`") 124 -- TODO: something more clever here 125 Fn -> ppStr ( f ) 126 127 128 Op -> ppStr ( f ) ) 129 ] 130 131 ----------------------------------------------- 132 133 134 -- todo: use records here ? 135 idname (Id name form arity look use prec bind) = name 136 idform (Id name form arity look use prec bind) = form 137 maybe_idarity (Id name form arity look use prec bind) = arity 138 idlook (Id name form arity look use prec bind) = look 139 iduse (Id name form arity look use prec bind) = use 140 idprec (Id name form arity look use prec bind) = prec 141 idbind (Id name form arity look use prec bind) = bind 142 143 idarity id = case maybe_idarity id of 144 Just n -> n 145 Nothing -> error ("no arity for " ++ show id) 146 147 mkid :: String -> Form -> Maybe Int -> Kind -> Kind -> Maybe Int -> Bind 148 -> Id 149 mkid name form arity look use prec bind = 150 Id name form arity look use prec bind 151 152 mknat :: Int -> Id 153 mknat n = mkid (show n) (Passive (show n)) 154 (Just 0) Fn Fn Nothing Nn 155 156 userfun :: Int -> String -> Id 157 userfun n name = mkid name (Passive (pform "\\mathrm" name)) 158 (Just n) Fn Fn Nothing Nn 159 160 uservar :: String -> Id 161 uservar name = mkid name (Passive (pform "\\mathit" name)) 162 (Just 0) Fn Fn Nothing Nn 163 164 usercon :: Int -> String -> Id 165 usercon n name = mkid name (Passive (pform "\\mathbf" name)) 166 (Just n) Fn Fn Nothing Nn 167 168 -------------------------------------------------- 169 170 data IdTable = IT (FiniteMap String Id) deriving Show 171 172 emptyIT = IT (emptyFM) 173 174 lookupIT (IT fm) = lookupFM fm 175 176 addToIT (IT fm) name id = 177 IT (addToFM_C (error "addToIt") fm name id) 178 179 plusIT (IT fm1) (IT fm2) = 180 IT (plusFM_C (error "Ids.plusIT: IdTables not disjoint") fm1 fm2) 181 182 inIts :: [Id] -> IdTable 183 inIts ids = IT (listToFM [ (idname id, id) | id <- ids ]) 184 185 ------------------------------------------------- 186 187 188 189 pform style name | isDigit (head name) = name 190 191 pform style name | length name == 1 = 192 if style == "\\mathit" 193 then name -- one letter ids are mathit automatically 194 else style ++ "{" ++ name ++ "}" 195 196 pform style name = 197 let (as, bs) = span (not . updown) name 198 (cs, ds) = span ( updown) bs 199 in style ++ "{" ++ as ++ "}" 200 ++ case bs of 201 [] -> "" 202 _ -> case ds of 203 [] -> cs -- hopefully these are primes '''' 204 -- otherwise, just "_" or "^" (we hope) 205 _ -> cs ++ "{" ++ pform style ds ++ "}" 206 207 ----------------------------------------------------------- 208 209 findid :: String -> Kind -> Kind -> IdTable -> (Id, IdTable) 210 findid name look use it = 211 case lookupIT it name of 212 Just id -> (id, it) 213 Nothing -> 214 let id = mkid name 215 (case look of -- tex form 216 Fn -> Passive (pform "\\mathit" name) 217 Op -> Passive ("\\verb;" ++ name ++ ";") 218 ) 219 (case use of -- arity 220 Fn -> Nothing 221 Op -> Just 2 222 ) 223 look 224 use 225 Nothing -- precedence 226 Nn -- associativity 227 in 228 -- trace ("\nmaking " ++ show id) $ 229 (id, addToIT it name id) 230 231 changeprec :: IdTable -> String -> Int -> Bind -> (Id, IdTable) 232 changeprec it @ (IT fm) name level bind = 233 let id' = lookupFM fm name 234 in if exists id' && not (exists (idprec (the id'))) 235 then 236 let id'' = mkid 237 (idname (the id')) (idform (the id')) 238 (maybe_idarity (the id')) 239 (idlook (the id')) (iduse (the id')) 240 (Just level) 241 bind 242 in (id'', IT (addToFM fm name id'')) 243 244 else error ("cannot change precedence of: " ++ name) 245 246 setarity :: IdTable -> String -> Int -> (Id, IdTable) 247 -- does nothing if arity is already set 248 -- (will complain elsewhere if does not agree and implicit_apply is off) 249 setarity it @ (IT fm) name ar = 250 let id' = lookupFM fm name 251 in if exists id' 252 then 253 if exists (maybe_idarity (the id')) 254 then (the id', it) -- needs no change 255 else 256 let id'' = mkid 257 (idname (the id')) (idform (the id')) 258 (Just ar) 259 (idlook (the id')) (iduse (the id')) 260 (idprec (the id')) (idbind (the id')) 261 in (id'', IT (addToFM fm (name) id'')) 262 263 else error ("setarity: id doesn't exist: " ++ name) 264 265 266 setform :: IdTable -> String -> Form -> (Id, IdTable) 267 -- does never complain 268 setform it @ (IT fm) name cs = 269 let id' = lookupFM fm name 270 in if exists id' 271 then 272 let id'' = mkid 273 (idname (the id')) cs 274 (maybe_idarity (the id')) 275 (idlook (the id')) (iduse (the id')) 276 (idprec (the id')) (idbind (the id')) 277 in (id'', IT (addToFM fm (name) id'')) 278 279 else error ("setform: id doesn't exist: " ++ name) 280 281 282 283