1 -- functions and operators 2 3 4 module Syntax 5 6 ( CType(..) 7 , Exp(..) 8 9 10 11 , appId, appArgs, appids 12 , isApp, isAppId, unAppId 13 14 15 , pr 16 17 , substExp 18 19 , cType, cArgs, isColl 20 21 ) 22 23 where 24 25 -- import List 26 import Maybes 27 28 import Ids 29 30 import Pretty -- syslib ghc 31 import PrettyClass 32 33 import Options -- to find out about print format 34 35 import FiniteMap 36 37 ----------------------------------------------------------------------- 38 39 data CType = CSet | CList | CTuple 40 deriving (Eq, Ord, Show) 41 42 data Exp 43 = App Id [Exp] -- function (identifier) application 44 | Coll CType [Exp] 45 46 deriving (Eq, Ord) 47 48 isApp (App _ _) = True; isApp _ = False 49 isColl (Coll _ _) = True; isColl _ = False 50 51 cType (Coll ct _) = ct 52 cArgs (Coll _ ca) = ca 53 54 appId (App id args) = id 55 appArgs (App id args) = args 56 57 isAppId (App id []) = True; isAppId _ = False 58 unAppId (App id []) = id; unAppId _ = error "unAppId" 59 60 appids (App id xs) = id : concat (map appids xs) 61 appids (Coll _ xs) = concat (map appids xs) 62 63 ------------------------------------------------------------------ 64 65 66 67 substExp :: Exp -> Exp -> Exp -> Exp 68 69 substExp a val x | a == x = val 70 substExp a val (App id xs) = App id ( map (substExp a val) xs ) 71 substExp a val (Coll t xs) = Coll t ( map (substExp a val) xs ) 72 73 74 ---------------------------------------------- 75 76 paren opts f p = if f then alParens opts p else p 77 brack opts f p = if f then alBrackets opts p else p 78 curls opts f p = if f then alBraces opts p else p 79 80 lgroup :: Pretty -> Pretty 81 lgroup p = ppBesides [ppStr "{", p, ppStr "}"] 82 83 instance Show Exp where showsPrec p = emitascii 84 85 -- todo: something more distinctive 86 pr opts = pp opts 87 88 instance PrettyClass Exp where 89 90 ppp opts p (Coll tc args) = (case tc of 91 CSet -> curls ; CList -> brack; CTuple -> paren) 92 opts True (ppCommas (map (pp opts) args)) 93 94 95 ppp opts p (App f args) = 96 if null args 97 then ppfn opts f 98 99 else case idform f of 100 Active _ _ -> caseopts opts "code" 101 [ ("latex", activate opts p f args) 102 , ("plain", passivate opts p f args) 103 ] 104 Passive _ -> passivate opts p f args 105 106 activate :: Opts -> Int -> Id -> [ Exp ] -> Pretty 107 activate opts p f args = 108 let Active n cs = idform f 109 110 fs :: FiniteMap Int Pretty 111 fs = if length args /= n 112 then error ("active form used with wrong number of args, " 113 ++ show f ++ show args) 114 else listToFM (zip [1..n] 115 [lgroup (ppp opts 0 arg) | arg <- args]) 116 -- note: individual args are formatted with 117 -- surrounding precedence level 0 118 119 atoi :: Char -> Int 120 atoi c = fromEnum c - fromEnum '0' 121 122 farg :: Int -> Pretty 123 farg i = lookupWithDefaultFM fs 124 (error ("arg no " ++ show i ++ " missing")) i 125 126 eat :: String -> Pretty 127 eat "" = ppNil 128 eat ('#' : c : cs) = farg (atoi c) `ppBeside` eat cs 129 eat (c : cs) = ppChar c `ppBeside` eat cs 130 131 in eat cs 132 133 134 135 passivate :: Opts -> Int -> Id -> [ Exp ] -> Pretty 136 passivate opts p f args = 137 if iduse f == Fn 138 then paren opts (p == 100) 139 (ppfn opts f `ppSep2` 140 ppNest tabstop (ppSepp 141 [ ppp opts 100 arg | arg <- args ]) 142 ) 143 else case args of 144 [x, y] -> props opts p f x y 145 _ -> error "in ppp: op needs exactly 2 args" 146 147 148 props opts p f x y = 149 case idprec f of 150 Nothing -> paren opts (0 < p) -- todo: 100 more abstract 151 (ppp opts 100 x `ppSep2` ppNest tabstop 152 (ppop opts f `ppSep2` (ppp opts 100 y))) 153 Just q -> 154 let qx = q + offset Lft f x 155 qy = q + offset Rght f y 156 in paren opts (q < p) 157 (ppp opts qx x `ppSep2` ppNest tabstop 158 (ppop opts f `ppSep2` (ppp opts qy y) )) 159 160 161 offset dir f (App id args) = 162 if idlook id == Fn then 0 -- harmless 163 else if idprec id == Nothing then 0 -- will get parens anyway 164 else if the (idprec id) /= the (idprec f) then 0 -- precs are distinct 165 else if id /= f then 1 -- same precs, different ops: need parens 166 else if idbind f == dir then 0 -- i am assoc, need no parens 167 else 1 -- i am not assoc, need paren 168 169 170 {- 171 ppp LaTeX p (App f args) = 172 let ff = idform f 173 fargs = [ lgroup (pp LaTeX arg) | arg <- args ] 174 175 expand "" = ppStr "" 176 expand ('#' : c : cs) = 177 let n = fromEnum c - fromEnum '0' 178 in (fargs !! (n - 1)) `ppBeside` (expand cs) 179 expand (c : cs) = ppChar c `ppBeside` expand cs 180 181 in expand ff 182 183 -} 184 185 {- 186 ppp st _ (Let x b) = 187 ppSep [ ppStr "let", ppNest 4 (pp st b) 188 , ppStr "in", ppNest 4 (pp st x) ] 189 -} 190 191 {- 192 ppp Ascii p (Con x y) = paren Ascii (conprec < p) 193 -- for debugging, show constructors: 194 -- (ppSep [ ppp Ascii conprec x, ppStr "^", ppp Ascii (conprec + 1) y ]) 195 (ppSep [ ppp Ascii conprec x, ppp Ascii (conprec + 1) y ]) 196 197 ppp LaTeX p (Con x y) = paren LaTeX (conprec < p) 198 (ppBesides [ ppStr "\\con" 199 -- make precedences in constructor args very low 200 -- in order to avoid parentheses that are visually unnecessary 201 , lgroup (ppp LaTeX 0 x) 202 , lgroup (ppp LaTeX 0 y) 203 ]) 204 -} 205 206 {- 207 ppp st p (Bpp op (arg : args)) = 208 let q = opprec op 209 in paren st (q < p) 210 211 -- todo: check whether to hide application 212 -- todo: do precedences correctly 213 214 ( ppp st q arg `ppSep2` 215 ppNest tabstop 216 (ppSepp [ ppp st q op `ppSep2` ppp st (q+1) arg 217 | arg <- args ] )) 218 -}