Text/ParserCombinators/Parsec/examples/Mondrian/SimpleMondrianPrinter.hs

   1 {-
   2 Copyright(C) 1999 Erik Meijer and Arjan van Yzendoorn
   3 -}
   4 module SimpleMondrianPrinter where
   5
   6 import Mondrian
   7 import Pretty
   8 import Utils
   9
  10 mondrianIndent :: Int
  11 mondrianIndent = 2
  12
  13 compilationUnit :: CompilationUnit -> Doc
  14 compilationUnit = \m ->
  15   case m of
  16     { Package n ds -> package m (name n) (decls ds)
  17     }
  18
  19 package = \(Package n' ds') -> \n -> \ds ->
  20   case null ds' of
  21     { True -> text "package" <+> n <+> row ds
  22     ; False -> text "package" <+> n <-> nest (-mondrianIndent) (column ds)
  23     }
  24
  25 decls = \ds -> [ decl d | d <- ds ]
  26
  27 decl = \d ->
  28   case d of
  29     { ImportDecl ns -> importDecl d (name ns)
  30     ; ClassDecl n xs ds -> classDecl d (name n) (extends xs) (decls ds)
  31     ; SigDecl n t -> sigDecl (name n) (expr t)
  32     ; VarDecl v (Lambda ns e) -> varDecl d (name v) (lambdas ns) (expr e)
  33     ; VarDecl v e -> decl (VarDecl v (Lambda [] e))
  34     }
  35
  36 extends = \xs ->
  37   case xs of
  38     { [] -> empty
  39     ; [x] -> text "extends" <+> name x <+> empty
  40     ; xs -> text "multiple inheritance not supported" <+> row [name x | x <- xs]
  41     }
  42
  43 classDecl = \(ClassDecl n' xs' ds') -> \n -> \xs -> \ds ->
  44   case ds' of
  45     { [] -> text "class" <+> n <+> xs
  46     ; otherwise -> text "class" <+> n <+> xs <-> column ds
  47     }
  48
  49 sigDecl = \n -> \t -> n <+> text "::" <+> t
  50
  51 importDecl = \d -> \n -> text "import" <+> n
  52
  53 varDecl = \(VarDecl v' (Lambda ns' e')) -> \v -> \ns -> \e ->
  54   if isSimpleExpr e'
  55   then v <+> text "=" <+> ns <|> e
  56   else v <+> text "=" <+> ns <-> nest mondrianIndent e
  57
  58 names = \ns -> horizontal (text " ") [ name n | n <- ns ]
  59
  60 name = \ns -> horizontal (text ".") [text n | n <- ns]
  61
  62 lambdas = \ns ->
  63   case ns of
  64     { []   -> empty
  65     ; [n]  -> text "\\" <|> name n <+> text "->" <+> empty
  66     ; n:ns -> text "\\" <|> name n <+> text "->" <+> lambdas ns
  67     }
  68
  69 expr = \e ->
  70   case e of
  71     { Lit l -> lit l
  72     ; Var n -> name n
  73     ; App f a -> application (expr f) (expr a)
  74     ; Lambda ns b -> lambdaExpr e (lambdas ns) (expr b)
  75     ; New n ds -> newExpr e (name n) (decls ds)
  76     ; Case e1 as -> caseExpr e (expr e1) (arms as)
  77     ; Let ds e1 -> letExpr e (decls ds) (expr e1)
  78     ; Chain e1 oes -> chain e1 oes
  79     }
  80
  81 application = \f -> \a -> text "(" <|> f <+> a <|> text ")"
  82
  83 newExpr = \(New n' ds') -> \n -> \ds ->
  84   case ds' of
  85     { [] -> text "new" <+> n
  86     ; otherwise ->
  87         if isSimpleDecls ds'
  88         then text "new" <+> n <+> row ds
  89         else text "new" <+> n <-> column ds
  90     }
  91
  92 lambdaExpr = \(Lambda ns' e') -> \ns -> \e ->
  93   if isSimpleExpr e'
  94   then ns <|> e
  95   else ns <-> nest mondrianIndent e
  96
  97 caseExpr :: Expr -> Doc -> [Doc] -> Doc
  98 caseExpr = \(Case e' as') -> \e -> \as ->
  99   case (isSimpleExpr e', isSimpleArms as') of
 100     { (True, True) -> text "case" <+> e <+> text "of" <+> row as
 101     ; (True, False)-> text "case" <+> e <+> text "of" <-> column as
 102     ; (False, True) -> text "case" <-> nest mondrianIndent e <-> text "of" <+> row as
 103     ; (False, False) -> text "case" <-> nest mondrianIndent e <-> text "of" <-> column as
 104     }
 105
 106 letExpr = \(Let ds' e') -> \ds -> \e ->
 107   case (length ds' == 1 && isSimpleDecls ds', isSimpleExpr e') of
 108     { (True, True) -> text "let" <+> row ds <+> text "in" <+> e
 109     ; (True, False) -> text "let" <+> row ds <-> text "in" <-> nest mondrianIndent e
 110     ; (False, True) -> text "let" <-> column ds <-> text "in" <+> e
 111     ; (False, False) -> text "let" <-> column ds <-> text "in" <-> nest mondrianIndent e
 112     }
 113
 114 arms = \as -> [ arm (p,e) (pattern p) (expr e) | (p,e) <- as ]
 115
 116 arm = \(p',e') -> \p -> \e ->
 117   if isSimplePattern p' && isSimpleExpr e'
 118   then p <+> text "->" <+> e
 119   else p <+> text "->" <-> nest mondrianIndent e
 120
 121 -- This is a dirty hack!
 122
 123 chain = \e -> \oes ->
 124   case oes of
 125     { []        -> bracket e
 126     ; ([""],f):oes -> if (isSimpleExpr f)
 127                    then (bracket e) <+> chain f oes
 128                    else (bracket e) <-> nest 2 (chain f oes)
 129     ; (o,f):oes -> if (isSimpleExpr f)
 130                    then (bracket e) <+> name o <+> chain f oes
 131                    else (bracket e) <-> name o <+> chain f oes
 132     }
 133
 134 pattern = \p ->
 135   case p of
 136     { Pattern n ds ->
 137         case ds of
 138           { [] -> name n
 139           ; otherwise -> name n <+> row (decls ds)
 140           }
 141     ; Default -> text "default"
 142     }
 143
 144 lit = \l ->
 145   case l of
 146     { IntLit i    -> text (show i)
 147     ; CharLit c   -> text (show c)
 148     ; StringLit s -> text (show s)
 149     }
 150
 151 bracket = \e ->
 152   case e of
 153     { Lit l -> expr e
 154     ; Var n -> expr e
 155     ; e     -> par (expr e)
 156     }
 157
 158 par = \e -> text "(" <|> e <|> text ")"
 159
 160 column = \ds -> nest mondrianIndent (block (text "{ ", text ";" <+> empty, text "}") ds)
 161
 162 row = \ds -> text "{" <|> horizontal (text ";" <+> empty) ds <|> text "}"