X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Text%2FParserCombinators%2FParsec%2Fexamples%2FMondrian%2FSimpleMondrianPrinter.hs;fp=Text%2FParserCombinators%2FParsec%2Fexamples%2FMondrian%2FSimpleMondrianPrinter.hs;h=b3c6f8692581bb72e78a5ecea3eb01d68f41f3d2;hb=792c0b584d78fdab6834553b79f9b5d445ae80e6;hp=0000000000000000000000000000000000000000;hpb=c7b9b8a5aa78b28aa2f9a35b22a2f1416a6f2938;p=ghc-base.git

diff --git a/Text/ParserCombinators/Parsec/examples/Mondrian/SimpleMondrianPrinter.hs b/Text/ParserCombinators/Parsec/examples/Mondrian/SimpleMondrianPrinter.hs
new file mode 100644
index 0000000..b3c6f86
--- /dev/null
+++ b/Text/ParserCombinators/Parsec/examples/Mondrian/SimpleMondrianPrinter.hs
@@ -0,0 +1,162 @@
+{-
+Copyright(C) 1999 Erik Meijer and Arjan van Yzendoorn
+-}
+module SimpleMondrianPrinter where
+
+import Mondrian
+import Pretty
+import Utils
+
+mondrianIndent :: Int
+mondrianIndent = 2
+
+compilationUnit :: CompilationUnit -> Doc
+compilationUnit = \m ->
+  case m of 
+    { Package n ds -> package m (name n) (decls ds) 
+    }
+
+package = \(Package n' ds') -> \n -> \ds -> 
+  case null ds' of
+    { True -> text "package" <+> n <+> row ds
+    ; False -> text "package" <+> n <-> nest (-mondrianIndent) (column ds)
+    }
+
+decls = \ds -> [ decl d | d <- ds ]
+
+decl = \d ->
+  case d of
+    { ImportDecl ns -> importDecl d (name ns)
+    ; ClassDecl n xs ds -> classDecl d (name n) (extends xs) (decls ds)
+    ; SigDecl n t -> sigDecl (name n) (expr t)
+    ; VarDecl v (Lambda ns e) -> varDecl d (name v) (lambdas ns) (expr e)
+    ; VarDecl v e -> decl (VarDecl v (Lambda [] e))
+    }
+
+extends = \xs ->
+  case xs of 
+    { [] -> empty
+    ; [x] -> text "extends" <+> name x <+> empty
+    ; xs -> text "multiple inheritance not supported" <+> row [name x | x <- xs]
+    } 
+    
+classDecl = \(ClassDecl n' xs' ds') -> \n -> \xs -> \ds -> 
+  case ds' of
+    { [] -> text "class" <+> n <+> xs
+    ; otherwise -> text "class" <+> n <+> xs <-> column ds
+    }
+
+sigDecl = \n -> \t -> n <+> text "::" <+> t
+    
+importDecl = \d -> \n -> text "import" <+> n
+
+varDecl = \(VarDecl v' (Lambda ns' e')) -> \v -> \ns -> \e ->
+  if isSimpleExpr e'
+  then v <+> text "=" <+> ns <|> e
+  else v <+> text "=" <+> ns <-> nest mondrianIndent e
+
+names = \ns -> horizontal (text " ") [ name n | n <- ns ]       
+                 
+name = \ns -> horizontal (text ".") [text n | n <- ns]
+  
+lambdas = \ns ->
+  case ns of 
+    { []   -> empty
+    ; [n]  -> text "\\" <|> name n <+> text "->" <+> empty
+    ; n:ns -> text "\\" <|> name n <+> text "->" <+> lambdas ns
+    }
+
+expr = \e ->
+  case e of
+    { Lit l -> lit l
+    ; Var n -> name n
+    ; App f a -> application (expr f) (expr a)
+    ; Lambda ns b -> lambdaExpr e (lambdas ns) (expr b)
+    ; New n ds -> newExpr e (name n) (decls ds)
+    ; Case e1 as -> caseExpr e (expr e1) (arms as)
+    ; Let ds e1 -> letExpr e (decls ds) (expr e1)                                            
+    ; Chain e1 oes -> chain e1 oes
+    }
+   
+application = \f -> \a -> text "(" <|> f <+> a <|> text ")"
+
+newExpr = \(New n' ds') -> \n -> \ds ->
+  case ds' of
+    { [] -> text "new" <+> n
+    ; otherwise -> 
+        if isSimpleDecls ds'
+        then text "new" <+> n <+> row ds
+        else text "new" <+> n <-> column ds
+    }
+    
+lambdaExpr = \(Lambda ns' e') -> \ns -> \e ->
+  if isSimpleExpr e'
+  then ns <|> e
+  else ns <-> nest mondrianIndent e
+
+caseExpr :: Expr -> Doc -> [Doc] -> Doc
+caseExpr = \(Case e' as') -> \e -> \as ->
+  case (isSimpleExpr e', isSimpleArms as') of
+    { (True, True) -> text "case" <+> e <+> text "of" <+> row as
+    ; (True, False)-> text "case" <+> e <+> text "of" <-> column as
+    ; (False, True) -> text "case" <-> nest mondrianIndent e <-> text "of" <+> row as
+    ; (False, False) -> text "case" <-> nest mondrianIndent e <-> text "of" <-> column as
+    }
+  
+letExpr = \(Let ds' e') -> \ds -> \e ->
+  case (length ds' == 1 && isSimpleDecls ds', isSimpleExpr e') of
+    { (True, True) -> text "let" <+> row ds <+> text "in" <+> e
+    ; (True, False) -> text "let" <+> row ds <-> text "in" <-> nest mondrianIndent e
+    ; (False, True) -> text "let" <-> column ds <-> text "in" <+> e
+    ; (False, False) -> text "let" <-> column ds <-> text "in" <-> nest mondrianIndent e
+    }
+
+arms = \as -> [ arm (p,e) (pattern p) (expr e) | (p,e) <- as ]
+  
+arm = \(p',e') -> \p -> \e ->
+  if isSimplePattern p' && isSimpleExpr e'
+  then p <+> text "->" <+> e
+  else p <+> text "->" <-> nest mondrianIndent e
+    
+-- This is a dirty hack!
+
+chain = \e -> \oes ->
+  case oes of
+    { []        -> bracket e
+    ; ([""],f):oes -> if (isSimpleExpr f)
+                   then (bracket e) <+> chain f oes
+                   else (bracket e) <-> nest 2 (chain f oes)
+    ; (o,f):oes -> if (isSimpleExpr f)
+                   then (bracket e) <+> name o <+> chain f oes
+                   else (bracket e) <-> name o <+> chain f oes           
+    }
+
+pattern = \p ->
+  case p of
+    { Pattern n ds -> 
+        case ds of
+          { [] -> name n
+          ; otherwise -> name n <+> row (decls ds)
+          }
+    ; Default -> text "default"
+    }
+    
+lit = \l ->
+  case l of
+    { IntLit i    -> text (show i)
+    ; CharLit c   -> text (show c)
+    ; StringLit s -> text (show s)
+    }
+
+bracket = \e ->
+  case e of
+    { Lit l -> expr e
+    ; Var n -> expr e
+    ; e     -> par (expr e)
+    }
+
+par = \e -> text "(" <|> e <|> text ")"
+
+column = \ds -> nest mondrianIndent (block (text "{ ", text ";" <+> empty, text "}") ds)
+
+row = \ds -> text "{" <|> horizontal (text ";" <+> empty) ds <|> text "}"
\ No newline at end of file