a3/code/Generics/GenPrint.icl

   1 implementation module GenPrint
   2
   3 import StdGeneric, StdEnv, StdMaybe
   4
   5 //-------------------------------------------------------------------------------------
   6
   7 :: *StringOutput = {so_str :: !*String, so_pos :: !Int}
   8
   9
  10 instance PrintOutput StringOutput where
  11         printOutput ch s=:{so_str, so_pos}
  12                 #! new_str = realloc_if_needed so_pos so_str
  13                 = {s & so_str = {new_str & [so_pos] = ch}, so_pos = inc so_pos}
  14         where
  15                 realloc_if_needed :: Int u:String -> v:String, [u <= v]
  16                 realloc_if_needed pos str
  17                         #! size_str = size str
  18                         | pos == size_str
  19                                 #! new_str = createArray ((size_str + 1) * 3 /2) '\0'
  20                                 #! (new_str, str) = fill 0 size_str new_str str
  21                                 = new_str
  22                         | otherwise
  23                                 = str
  24                 fill i n new_str str
  25                         | i == n
  26                                 = (new_str, str)
  27                         | otherwise
  28                                 #! (ch, str) = str![i]
  29                                 = fill (inc i) n {new_str & [i] = ch} str
  30
  31 instance PrintOutput File where
  32         printOutput x s
  33                 = fwritec x s
  34
  35
  36 //-------------------------------------------------------------------------------------
  37
  38
  39 ($) infixl 9
  40 ($) x y = y o x
  41
  42 (@) infix 8
  43 (@) x y = x y
  44
  45 mapSt f [] st = ([], st)
  46 mapSt f [x:xs] st
  47         # (y, st) = f x st
  48         # (ys, st) = mapSt f xs st
  49         = ([y:ys], st)
  50
  51 foldSt f []             = id
  52 foldSt f [x:xs]         = foldSt f xs o f x
  53
  54 //-------------------------------------------------------------------------------------
  55 :: PrintState s =
  56         { ps_output :: !s
  57         , ps_context :: !Context
  58         }
  59 :: Context
  60         = CtxNone                                                                               // initial env
  61         | CtxNullary                                                                    // nullary constructor
  62         | CtxRecord                                                                             // record constructor
  63         | CtxTuple                                                                              // tuple constructor
  64         | CtxNonfix                                                                             // normal nonfix constructor
  65         | CtxInfix                                                                              // infix constructor
  66                 String                                                                          // name
  67                 GenConsAssoc                                                            // constructor's associativity
  68                 Prio                                                                            // constructors priority
  69                 GenConsAssoc                                                            // left or right argument
  70 :: Prio :== Int
  71
  72 instance == GenConsAssoc where
  73         (==) GenConsAssocNone GenConsAssocNone = True
  74         (==) GenConsAssocLeft GenConsAssocLeft = True
  75         (==) GenConsAssocRight GenConsAssocRight = True
  76         (==) _ _ = False
  77
  78 mkContext :: GenericConsDescriptor -> Context
  79 mkContext {gcd_prio=GenConsNoPrio, gcd_fields, gcd_name, gcd_arity}
  80         | isEmpty gcd_fields
  81                 | gcd_arity == 0
  82                         = CtxNullary
  83                 | is_tuple gcd_name
  84                         = CtxTuple
  85                 | otherwise
  86                         = CtxNonfix
  87         | otherwise
  88                 = CtxRecord
  89 where
  90         is_tuple name
  91                 #! size_name = size name
  92                 = (size_name == 7 || size_name == 8)
  93                 && name.[0] == '_'
  94                 && name.[1] == 'T'
  95                 && name.[2] == 'u'
  96                 && name.[3] == 'p'
  97                 && name.[4] == 'l'
  98                 && name.[5] == 'e'
  99                 && isDigit name.[6]
 100                 && (size_name == 7 || isDigit name.[7])
 101
 102 mkContext {gcd_prio=GenConsPrio assoc prio, gcd_name}
 103         = CtxInfix gcd_name assoc prio GenConsAssocNone
 104
 105 needParenthesis :: Context Context -> Bool
 106 needParenthesis CtxNone outer_ctx               = abort "needParenthesis: this_ctx = CtxNone"
 107 needParenthesis this_ctx CtxNullary             = abort "needParenthesis: outer_ctx = CtxNullary"
 108 needParenthesis CtxNullary outer_ctx    = False
 109 needParenthesis CtxTuple outer_ctx              = True          // the tuple parenthesis
 110 needParenthesis CtxRecord outer_ctx     = False
 111 needParenthesis CtxNonfix CtxNone               = False
 112 needParenthesis CtxNonfix CtxTuple              = False
 113 needParenthesis CtxNonfix CtxRecord             = False
 114 needParenthesis CtxNonfix CtxNonfix             = True
 115 needParenthesis CtxNonfix (CtxInfix _ _ _ _) = False
 116 needParenthesis (CtxInfix _ _ _ _) CtxNone = False
 117 needParenthesis (CtxInfix _ _ _ _) CtxNullary = True
 118 needParenthesis (CtxInfix _ _ _ _) CtxTuple = False
 119 needParenthesis (CtxInfix _ _ _ _) CtxRecord = False
 120 needParenthesis (CtxInfix _ _ _ _) CtxNonfix = True // False // PK
 121 needParenthesis (CtxInfix _ this_assoc this_prio _) (CtxInfix _ outer_assoc outer_prio branch)
 122         =       outer_prio > this_prio
 123         ||  (outer_prio == this_prio && not (this_assoc == outer_assoc && this_assoc == branch))
 124
 125 //derive bimap PrintState
 126
 127 //-------------------------------------------------------------------------------------
 128
 129
 130 printChar :: Char (PrintState *s) -> (PrintState *s) | PrintOutput s
 131 printChar ch s=:{ps_output}
 132         # ps_output = printOutput ch ps_output
 133         = {s & ps_output = ps_output}
 134
 135 printCharLiteral '\\'   = printChar '\\' $ printChar '\\'
 136 printCharLiteral '\n'   = printChar '\\' $ printChar '\n'
 137 printCharLiteral '\t'   = printChar '\\' $ printChar '\t'
 138 printCharLiteral '\b'   = printChar '\\' $ printChar '\b'
 139 printCharLiteral '\''   = printChar '\\' $ printChar '\''
 140 printCharLiteral '\"'   = printChar '\\' $ printChar '\"'
 141 printCharLiteral '\0'   = printChar '\\' $ printChar '\0'
 142 printCharLiteral c              = printChar c
 143
 144 printString str
 145         #! size_str = size str
 146         = do_it 0 size_str str
 147 where
 148         do_it i n str
 149                 | i == n
 150                         = id
 151                         = printChar str.[i]
 152                         $ do_it (inc i) n str
 153
 154 printStringLiteral str
 155         #! size_str = size str
 156         = do_it 0 size_str str
 157 where
 158         do_it i n str
 159                 | i == n
 160                         = id
 161                         = printCharLiteral str.[i]
 162                         $ do_it (inc i) n str
 163
 164
 165 printList f xs ps=:{ps_context}
 166         =       { print_list f xs { ps & ps_context = CtxNone}
 167                 & ps_context = ps_context
 168                 }
 169 where
 170         print_list f [] = id
 171         print_list f [x] = f x
 172         print_list f [x:xs]
 173                 = f x
 174                 $ printString ", "
 175                 $ print_list f xs
 176
 177 //-------------------------------------------------------------------------------------
 178 generic gPrint a :: a (PrintState *s) -> (PrintState *s) | PrintOutput s
 179 gPrint{|Int|} x st
 180         = printString (toString x) st
 181 gPrint{|Real|} x st
 182         # str = toString x
 183         | all isDigit [c\\c<-:str] // add .0 if needed
 184                 = printString (str +++ ".0") st
 185         | str.[0] == '.'
 186                 = printString ("0" +++ str) st
 187         | otherwise
 188                 = printString str st
 189 gPrint{|Bool|} x st
 190         = printString (toString x) st
 191 gPrint{|Char|} x st
 192         = printChar '\'' $ printCharLiteral x $ printChar '\'' @ st
 193 gPrint{|String|} x st
 194         = printChar '"'
 195         $ printStringLiteral x
 196         $ printChar '"'
 197         @ st
 198 gPrint{|UNIT|} x st
 199         = st
 200
 201 gPrint{|EITHER|} fl fr (LEFT x) st = fl x st
 202 gPrint{|EITHER|} fl fr (RIGHT x) st = fr x st
 203
 204 gPrint{|PAIR|} fx fy (PAIR x y) st=:{ps_context = CtxNone}
 205         = abort "gOutput{|PAIR|}: CtxNone\n"
 206 gPrint{|PAIR|} fx fy (PAIR x y) st=:{ps_context = CtxNullary}
 207         = abort "gOutput{|PAIR|}: CtxNullary\n"
 208 gPrint{|PAIR|} fx fy (PAIR x y) st=:{ps_context = CtxTuple}
 209         = fx x $ printString ", " $ fy y @ st
 210 gPrint{|PAIR|} fx fy (PAIR x y) st=:{ps_context = CtxRecord}
 211         = fx x $ printString ", " $ fy y @ st
 212 gPrint{|PAIR|} fx fy (PAIR x y) st=:{ps_context = CtxNonfix}
 213         = fx x $ printChar ' ' $ fy y @ st
 214 gPrint{|PAIR|} fx fy (PAIR x y) st=:{ps_context = CtxInfix name assoc prio branch}
 215         # st = fx x {st & ps_context = CtxInfix name assoc prio GenConsAssocLeft}
 216         # st = printChar ' ' $ printStringLiteral name $ printChar ' ' @ st
 217         # st = fy y {st & ps_context = CtxInfix name assoc prio GenConsAssocRight}
 218         = {st & ps_context = CtxInfix name assoc prio branch}
 219
 220 gPrint{|CONS of d|} print_arg (CONS x) st=:{ps_context}
 221         #! ctx = mkContext d
 222         #! st = { st & ps_context = ctx }
 223         | needParenthesis ctx ps_context
 224                 =       { printChar '('
 225                         $ print print_arg ctx
 226                         $ printChar ')'
 227                         @ st
 228                         & ps_context = ps_context
 229                         }
 230         | otherwise
 231                 = { print print_arg ctx st & ps_context = ps_context }
 232 where
 233         print print_arg CtxNone
 234                 = abort "gOutput{|CONS|}: CtxNone\n"
 235         print print_arg CtxNullary
 236                 = printStringLiteral d.gcd_name
 237         print print_arg CtxTuple
 238                 = print_arg x
 239         print print_arg CtxRecord
 240                 = printString "{ "
 241                 $ foldSt printChar (tl [c\\c<-:d.gcd_name]) //printStringLiteral d.gcd_name
 242                 $ printString " | "
 243                 $ print_arg x
 244                 $ printString " }"
 245         print print_arg CtxNonfix
 246                 = printStringLiteral d.gcd_name
 247                 $ printChar ' '
 248                 $ print_arg x
 249         print print_arg (CtxInfix _ _ _ _)
 250                 = print_arg x
 251
 252 gPrint{|FIELD of d|} f (FIELD x) st
 253         = printStringLiteral d.gfd_name
 254         $ printString " = "
 255         $ f x
 256         @ st
 257 gPrint{|OBJECT|} f (OBJECT x) st
 258         = f x st
 259
 260 gPrint{|[]|} f xs st
 261         = printChar '['
 262         $ printList f xs
 263         $ printChar ']'
 264         @ st
 265
 266 gPrint{|{}|} f xs st
 267         = printChar '{'
 268         $ printList f [ x \\ x <-: xs]
 269         $ printChar '}'
 270         @ st
 271
 272 gPrint{|{!}|} f xs st
 273         = printChar '{'
 274         $ printList f [ x \\ x <-: xs]
 275         $ printChar '}'
 276         @ st
 277
 278 //derive gOutput (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
 279
 280 //-------------------------------------------------------------------------------------
 281 (<<-) infixl 0 :: (PrintState *s) a -> *(PrintState *s) | gPrint{|*|} a & PrintOutput s
 282 (<<-) s x = gPrint{|*|} x s
 283
 284 mkPrintState :: *s -> PrintState *s | PrintOutput s
 285 mkPrintState s =
 286         { ps_output = s
 287         , ps_context = CtxNone
 288         }
 289
 290 mkStringPrintState :: PrintState StringOutput
 291 mkStringPrintState = mkPrintState {so_pos = 0, so_str = createArray 16 '\0'}
 292
 293 openFilePrintState :: String *fs -> (Maybe (PrintState *File), *fs) | FileSystem fs
 294 openFilePrintState name fs
 295         # (ok, file, fs) = fopen name FWriteText fs
 296         | ok    = (Just (mkPrintState file), fs)
 297                         = (Nothing, fs)
 298
 299 printToString :: a -> String | gPrint{|*|} a
 300 printToString x
 301         # string_output = (mkStringPrintState <<- x).ps_output
 302         = string_output.so_str % (0,string_output.so_pos-1)
 303
 304 //-------------------------------------------------------------------------------------
 305
 306 //Start = 1