ref: 0c81744b3f3e130857b7d7adb3430fa65bf47212
parent: 524ce369835cf8cd07ead5e749676a5d6fc591a1
parent: ebb73b7a83d202294f6cec93634bde578942cecc
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Thu Oct 19 10:46:57 EDT 2023
Merge branch 'master' into class
--- a/Makefile
+++ b/Makefile
@@ -78,6 +78,7 @@
$(GHCC) -c lib/Control/Exception.hs
$(GHCC) -c src/System/Console/SimpleReadline.hs
$(GHCC) -c src/Text/ParserComb.hs
+ $(GHCC) -c src/MicroHs/Pretty.hs
$(GHCC) -c src/MicroHs/Ident.hs
$(GHCC) -c src/MicroHs/Expr.hs
$(GHCC) -c src/MicroHs/Graph.hs
--- a/MicroHs.cabal
+++ b/MicroHs.cabal
@@ -48,6 +48,7 @@
MicroHs.Ident
MicroHs.Lex
MicroHs.Parse
+ MicroHs.Pretty
MicroHs.StateIO
MicroHs.IdentMap
MicroHs.Interactive
--- a/TODO
+++ b/TODO
@@ -8,7 +8,6 @@
- Use filename as the cache lookup key and SHA for validation
* make the runtime system catch ^C and stop execution
* use pointer stack during GC instead of recursion.
-* add pretty printing library
* whith dictionaries we need two optimizations to get rid of them
- case d of (d1,d2) -> ... (d1,d2) ...
transforms to
--- a/lib/Data/Function.hs
+++ b/lib/Data/Function.hs
@@ -8,6 +8,10 @@
($) :: forall a b . (a -> b) -> a -> b
($) f x = f x
+infixr 0 $!
+($!) :: forall a b . (a -> b) -> a -> b
+($!) f x = x `primSeq` f x
+
infixr 9 .
(.) :: forall a b c . (b -> c) -> (a -> b) -> (a -> c)
(.) f g x = f (g x)
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -31,8 +31,7 @@
errorMessage,
Assoc(..), eqAssoc, Fixity
) where
-import Prelude --Xhiding (Monad(..), Applicative(..), MonadFail(..), Functor(..), (<$>), showString, showChar, showList)
-import Data.List
+import Prelude --Xhiding (Monad(..), Applicative(..), MonadFail(..), Functor(..), (<$>), showString, showChar, showList, (<>))
import Data.Maybe
import MicroHs.Ident
import qualified Data.Double as D
@@ -40,6 +39,7 @@
--Ximport GHC.Stack
--Ximport Control.DeepSeq
--Yimport Primitives(NFData(..))
+import MicroHs.Pretty
type IdentModule = Ident
@@ -353,165 +353,3 @@
----------------
-{--showEModule :: EModule -> String
-showEModule am =
- case am of
- EModule i es ds -> "module " ++ i ++ "(\n" ++
- unlines (intersperse "," (map showExportItem es)) ++
- "\n) where\n" ++
- showEDefs ds
-
-showExportItem :: ExportItem -> String
-showExportItem ae =
- case ae of
- ExpModule i -> "module " ++ i
- ExpTypeCon i -> i ++ "(..)"
- ExpType i -> i
- ExpValue i -> i
--}
-
-showImportItem :: ImportItem -> String
-showImportItem ae =
- case ae of
- ImpTypeCon i -> showIdent i ++ "(..)"
- ImpType i -> showIdent i
- ImpValue i -> showIdent i
-
-showEDef :: EDef -> String
-showEDef def =
- case def of
- Data lhs cs -> "data " ++ showLHS lhs ++ " = " ++ intercalate " | " (map showConstr cs)
- Newtype lhs c -> "newtype " ++ showLHS lhs ++ " = " ++ showConstr c
- Type lhs t -> "type " ++ showLHS lhs ++ " = " ++ showEType t
- Fcn i eqns -> unlines (map (\ (Eqn ps alts) -> showIdent i ++ " " ++ unwords (map showEPat ps) ++ showAlts "=" alts) eqns)
- Sign i t -> showIdent i ++ " :: " ++ showEType t
- Import (ImportSpec q m mm mis) -> "import " ++ (if q then "qualified " else "") ++ showIdent m ++ maybe "" ((" as " ++) . unIdent) mm ++- case mis of
- Nothing -> ""
- Just (h, is) -> (if h then " hiding" else "") ++ "(" ++ intercalate ", " (map showImportItem is) ++ ")"- ForImp ie i t -> "foreign import ccall " ++ showString ie ++ " " ++ showIdent i ++ " :: " ++ showEType t
- Infix (a, p) is -> "infix" ++ f a ++ " " ++ showInt p ++ " " ++ intercalate ", " (map showIdent is)
- where f AssocLeft = "l"; f AssocRight = "r"; f AssocNone = ""
- Class sup lhs bs -> "class " ++ ctx sup ++ showLHS lhs ++ showWhere bs
- Instance vs ct ty bs -> "instance " ++ showForall vs ++ ctx ct ++ showEType ty ++ showWhere bs
- where ctx [] = ""
- ctx ts = showEType (ETuple ts) ++ " => "
-
-showConstr :: Constr -> String
-showConstr (Constr c (Left ts)) = unwords (showIdent c : map showEType ts)
-showConstr (Constr c (Right fs)) = unwords (showIdent c : "{" : map f fs ++ ["}"])- where f (i, t) = showIdent i ++ " :: " ++ showEType t ++ ","
-
-showLHS :: LHS -> String
-showLHS lhs =
- case lhs of
- (f, vs) -> unwords (showIdent f : map showIdKind vs)
-
-showIdKind :: IdKind -> String
-showIdKind (IdKind i k) = "(" ++ showIdent i ++ "::" ++ showEKind k ++ ")"-
-showEDefs :: [EDef] -> String
-showEDefs ds = unlines (map showEDef ds)
-
-showAlts :: String -> EAlts -> String
-showAlts sep (EAlts alts bs) = showAltsL sep alts ++ showWhere bs
-
-showWhere :: [EBind] -> String
-showWhere [] = ""
-showWhere bs = " where\n" ++ unlines (map showEBind bs)
-
-showAltsL :: String -> [EAlt] -> String
-showAltsL sep [([], e)] = " " ++ sep ++ " " ++ showExpr e
-showAltsL sep alts = unlines (map (showAlt sep) alts)
-
-showAlt :: String -> EAlt -> String
-showAlt sep (ss, e) = " | " ++ concat (intersperse ", " (map showEStmt ss)) ++ " " ++ sep ++ " " ++ showExpr e
-
-showExpr :: Expr -> String
-showExpr ae =
- case ae of
- EVar v -> showIdent v
- EApp _ _ -> showApp [] ae
- EOper e ies -> showExpr (foldl (\ e1 (i, e2) -> EApp (EApp (EVar i) e1) e2) e ies)
- ELam ps e -> "(\\" ++ unwords (map showExpr ps) ++ " -> " ++ showExpr e ++ ")"
- ELit _ i -> showLit i
- ECase e as -> "case " ++ showExpr e ++ " of {\n" ++ unlines (map showCaseArm as) ++ "}"- ELet bs e -> "let\n" ++ unlines (map showEBind bs) ++ "in " ++ showExpr e
- ETuple es -> "(" ++ intercalate "," (map showExpr es) ++ ")"- EListish (LList es) -> showList showExpr es
- EDo mn ss -> maybe "do" (\ n -> showIdent n ++ ".do\n") mn ++ unlines (map showEStmt ss)
- ESectL e i -> "(" ++ showExpr e ++ " " ++ showIdent i ++ ")"- ESectR i e -> "(" ++ showIdent i ++ " " ++ showExpr e ++ ")"- EIf e1 e2 e3 -> "if " ++ showExpr e1 ++ " then " ++ showExpr e2 ++ " else " ++ showExpr e3
- EListish l -> showListish l
- ESign e t -> showExpr e ++ " :: " ++ showEType t
- EAt i e -> showIdent i ++ "@" ++ showExpr e
- EUVar i -> "a" ++ showInt i
- ECon c -> showCon c
- EForall iks e -> showForall iks ++ showEType e
- where
- showApp as (EApp f a) = showApp (a:as) f
- showApp as (EVar i) | eqString op "->", [a, b] <- as = "(" ++ showExpr a ++ " -> " ++ showExpr b ++ ")"- | eqString op "=>", [a, b] <- as = showExpr a ++ " => " ++ showExpr b
- | eqChar (head op) ',' = showExpr (ETuple as)
- | eqString op "[]", length as == 1 = showExpr (EListish (LList as))
- where op = unQualString (unIdent i)
- showApp as f = "(" ++ unwords (map showExpr (f:as)) ++ ")"-
-showForall :: [IdKind] -> String
-showForall [] = ""
-showForall iks = "forall " ++ unwords (map showIdKind iks) ++ " . "
-
-showListish :: Listish -> String
-showListish _ = "<<Listish>>"
-
-showCon :: Con -> String
-showCon (ConData _ s) = showIdent s
-showCon (ConNew s) = showIdent s
-showCon (ConLit l) = showLit l
-
--- Literals are tagged the way they appear in the combinator file:
--- # Int
--- % Double
--- ' Char (not in file)
--- " String
--- ^ FFI function
--- primitive
-showLit :: Lit -> String
-showLit l =
- case l of
- LInt i -> '#' : showInt i
- LDouble d -> '%' : D.showDouble d
- LChar c -> showChar c
- LStr s -> showString s
- LPrim s -> s
- LForImp s -> '^' : s
-
-showEStmt :: EStmt -> String
-showEStmt as =
- case as of
- SBind p e -> showEPat p ++ " <- " ++ showExpr e
- SThen e -> showExpr e
- SLet bs -> "let\n" ++ unlines (map showEBind bs)
-
-showEBind :: EBind -> String
-showEBind ab =
- case ab of
- BFcn i eqns -> showEDef (Fcn i eqns)
- BPat p e -> showEPat p ++ " = " ++ showExpr e
- BSign i t -> showIdent i ++ " :: " ++ showEType t
-
-showCaseArm :: ECaseArm -> String
-showCaseArm arm =
- case arm of
- (p, alts) -> showEPat p ++ showAlts "->" alts
-
-showEPat :: EPat -> String
-showEPat = showExpr
-
-showEType :: EType -> String
-showEType = showExpr
-
-showEKind :: EKind -> String
-showEKind = showEType
--- a/src/MicroHs/Ident.hs
+++ b/src/MicroHs/Ident.hs
@@ -4,6 +4,7 @@
Line, Col, Loc,
Ident(..),
mkIdent, mkIdentLoc, unIdent, eqIdent, leIdent, qualIdent, showIdent, getSLocIdent, setSLocIdent,
+ ppIdent,
mkIdentSLoc,
isLower_, isIdentChar, isOperChar, isConIdent,
dummyIdent, isDummyIdent,
@@ -20,6 +21,7 @@
import Data.Char
--Ximport Compat
--Ximport GHC.Stack
+import MicroHs.Pretty
type Line = Int
type Col = Int
@@ -59,6 +61,9 @@
showIdent :: Ident -> String
showIdent (Ident _ i) = i
+
+ppIdent :: Ident -> Doc
+ppIdent (Ident _ i) = text i
eqIdent :: Ident -> Ident -> Bool
eqIdent (Ident _ i) (Ident _ j) = eqString i j
--- /dev/null
+++ b/src/MicroHs/Pretty.hs
@@ -1,0 +1,372 @@
+-- Based on the pretty-printer outlined in the paper
+-- 'The Design of a Pretty-printing Library' by
+-- John Hughes in Advanced Functional Programming, 1995.
+-- With inspiration and code from the from the Hackage package pretty.
+--module Text.PrettyPrint.HughesPJ(
+module MicroHs.Pretty(
+ Doc,
+ text, empty,
+ (<>), (<+>), ($$), ($+$),
+ hcat, hsep,
+ vcat,
+ sep, cat,
+ nest, hang,
+ punctuate,
+ parens, brackets, braces,
+ maybeParens,
+ Style,
+ render, renderStyle,
+ ) where
+import Prelude --X hiding((<>))
+--Ximport Compat
+
+infixl 6 <>, <+>
+infixl 5 $$, $+$
+
+data Doc
+ = Empty -- ^ An empty span, see 'empty'.
+ | NilAbove Doc -- ^ @text "" $$ x@.
+ | TextBeside String Doc -- ^ @text s <> x@.
+ | Nest Int Doc -- ^ @nest k x@.
+ | Union Doc Doc -- ^ @ul `union` ur@.
+ | NoDoc -- ^ The empty set of documents.
+ | Beside Doc Bool Doc -- ^ True <=> space between.
+ | Above Doc Bool Doc -- ^ True <=> never overlap.
+
+type RDoc = Doc
+
+text :: String -> Doc
+text s = TextBeside s Empty
+
+empty :: Doc
+empty = Empty
+
+reduceDoc :: Doc -> RDoc
+reduceDoc (Beside p g q) = beside p g (reduceDoc q)
+reduceDoc (Above p g q) = above p g (reduceDoc q)
+reduceDoc p = p
+
+hcat :: [Doc] -> Doc
+hcat = snd . reduceHoriz . foldr (\p q -> Beside p False q) empty
+
+-- | List version of '<+>'.
+hsep :: [Doc] -> Doc
+hsep = snd . reduceHoriz . foldr (\p q -> Beside p True q) empty
+
+-- | List version of '$$'.
+vcat :: [Doc] -> Doc
+vcat = snd . reduceVert . foldr (\p q -> Above p False q) empty
+
+nest :: Int -> Doc -> Doc
+nest k p = mkNest k (reduceDoc p)
+
+-- | @hang d1 n d2 = sep [d1, nest n d2]@
+hang :: Doc -> Int -> Doc -> Doc
+hang d1 n d2 = sep [d1, nest n d2]
+
+punctuate :: Doc -> [Doc] -> [Doc]
+punctuate _ [] = []
+punctuate p (x:xs) = go x xs
+ where go y [] = [y]
+ go y (z:zs) = (y <> p) : go z zs
+
+maybeParens :: Bool -> Doc -> Doc
+maybeParens False = id
+maybeParens True = parens
+
+parens :: Doc -> Doc
+parens p = text "(" <> p <> text ")"+braces :: Doc -> Doc
+braces p = text "{" <> p <> text "}"+brackets :: Doc -> Doc
+brackets p = text "[" <> p <> text "]"
+
+-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
+mkNest :: Int -> Doc -> Doc
+mkNest k _ | k `seq` False = undefined
+mkNest k (Nest k1 p) = mkNest (k + k1) p
+mkNest _ NoDoc = NoDoc
+mkNest _ Empty = Empty
+mkNest 0 p = p
+mkNest k p = nest_ k p
+
+-- mkUnion checks for an empty document
+mkUnion :: Doc -> Doc -> Doc
+mkUnion Empty _ = Empty
+mkUnion p q = p `union_` q
+
+data IsEmpty = IsEmpty | NotEmpty
+
+reduceHoriz :: Doc -> (IsEmpty, Doc)
+reduceHoriz (Beside p g q) = eliminateEmpty Beside (snd (reduceHoriz p)) g (reduceHoriz q)
+reduceHoriz doc = (NotEmpty, doc)
+
+reduceVert :: Doc -> (IsEmpty, Doc)
+reduceVert (Above p g q) = eliminateEmpty Above (snd (reduceVert p)) g (reduceVert q)
+reduceVert doc = (NotEmpty, doc)
+
+eliminateEmpty ::
+ (Doc -> Bool -> Doc -> Doc) ->
+ Doc -> Bool -> (IsEmpty, Doc) -> (IsEmpty, Doc)
+eliminateEmpty _ Empty _ q = q
+eliminateEmpty cons p g q =
+ (NotEmpty,
+ case q of
+ (NotEmpty, q') -> cons p g q'
+ (IsEmpty, _) -> p
+ )
+
+nilAbove_ :: RDoc -> RDoc
+nilAbove_ = NilAbove
+
+-- | Arg of a TextBeside is always an RDoc.
+textBeside_ :: String -> RDoc -> RDoc
+textBeside_ = TextBeside
+
+nest_ :: Int -> RDoc -> RDoc
+nest_ = Nest
+
+union_ :: RDoc -> RDoc -> RDoc
+union_ = Union
+
+($$) :: Doc -> Doc -> Doc
+p $$ q = above_ p False q
+
+-- | Above, with no overlapping.
+-- '$+$' is associative, with identity 'empty'.
+($+$) :: Doc -> Doc -> Doc
+p $+$ q = above_ p True q
+
+above_ :: Doc -> Bool -> Doc -> Doc
+above_ p _ Empty = p
+above_ Empty _ q = q
+above_ p g q = Above p g q
+
+above :: Doc -> Bool -> RDoc -> RDoc
+above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
+above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q)
+above p g q = aboveNest p g 0 (reduceDoc q)
+
+-- Specfication: aboveNest p g k q = p $g$ (nest k q)
+aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc
+aboveNest _ _ k _ | k `seq` False = undefined
+aboveNest NoDoc _ _ _ = NoDoc
+aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
+ aboveNest p2 g k q
+
+aboveNest Empty _ k q = mkNest k q
+aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q)
+ -- p can't be Empty, so no need for mkNest
+
+aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
+aboveNest (TextBeside s p) g k q = TextBeside s rest
+ where
+ k1 = k - length s
+ rest = case p of
+ Empty -> nilAboveNest g k1 q
+ _ -> aboveNest p g k1 q
+
+aboveNest (Above _ _ _) _ _ _ = error "aboveNest Above"
+aboveNest (Beside _ _ _) _ _ _ = error "aboveNest Beside"
+
+-- Specification: text s <> nilaboveNest g k q
+-- = text s <> (text "" $g$ nest k q)
+nilAboveNest :: Bool -> Int -> RDoc -> RDoc
+nilAboveNest _ k _ | k `seq` False = undefined
+nilAboveNest _ _ Empty = Empty
+ -- Here's why the "text s <>" is in the spec!
+nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
+nilAboveNest g k q | not g && k > 0 -- No newline if no overlap
+ = textBeside_ (replicate k ' ') q
+ | otherwise -- Put them really above
+ = nilAbove_ (mkNest k q)
+
+(<>) :: Doc -> Doc -> Doc
+p <> q = beside_ p False q
+
+-- | Beside, separated by space, unless one of the arguments is 'empty'.
+-- '<+>' is associative, with identity 'empty'.
+(<+>) :: Doc -> Doc -> Doc
+p <+> q = beside_ p True q
+
+beside_ :: Doc -> Bool -> Doc -> Doc
+beside_ p _ Empty = p
+beside_ Empty _ q = q
+beside_ p g q = Beside p g q
+
+-- Specification: beside g p q = p <g> q
+beside :: Doc -> Bool -> RDoc -> RDoc
+beside NoDoc _ _ = NoDoc
+beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q
+beside Empty _ q = q
+beside (Nest k p) g q = nest_ k $! beside p g q
+beside p@(Beside p1 g1 q1) g2 q2
+ | eqBool g1 g2 = beside p1 g1 $! beside q1 g2 q2
+ | otherwise = beside (reduceDoc p) g2 q2
+beside p@(Above _ _ _) g q = let { d = reduceDoc p } in beside d g q+beside (NilAbove p) g q = nilAbove_ $! beside p g q
+beside (TextBeside t p) g q = TextBeside t rest
+ where
+ rest = case p of
+ Empty -> nilBeside g q
+ _ -> beside p g q
+
+-- Specification: text "" <> nilBeside g p
+-- = text "" <g> p
+nilBeside :: Bool -> RDoc -> RDoc
+nilBeside _ Empty = Empty -- Hence the text "" in the spec
+nilBeside g (Nest _ p) = nilBeside g p
+nilBeside g p | g = textBeside_ " " p
+ | otherwise = p
+
+sep :: [Doc] -> Doc
+sep = sepX True -- Separate with spaces
+
+-- | Either 'hcat' or 'vcat'.
+cat :: [Doc] -> Doc
+cat = sepX False -- Don't
+
+sepX :: Bool -> [Doc] -> Doc
+sepX _ [] = empty
+sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
+
+
+-- Specification: sep1 g k ys = sep (x : map (nest k) ys)
+-- = oneLiner (x <g> nest k (hsep ys))
+-- `union` x $$ nest k (vcat ys)
+sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
+sep1 _ _ k _ | k `seq` False = undefined
+sep1 _ NoDoc _ _ = NoDoc
+sep1 g (p `Union` q) k ys = sep1 g p k ys `union_`
+ aboveNest q False k (reduceDoc (vcat ys))
+
+sep1 g Empty k ys = mkNest k (sepX g ys)
+sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys)
+
+sep1 _ (NilAbove p) k ys = nilAbove_
+ (aboveNest p False k (reduceDoc (vcat ys)))
+sep1 g (TextBeside s p) k ys = textBeside_ s (sepNB g p (k - length s) ys)
+sep1 _ (Above _ _ _) _ _ = error "sep1 Above"
+sep1 _ (Beside _ _ _) _ _ = error "sep1 Beside"
+
+sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc
+sepNB g (Nest _ p) k ys
+ = sepNB g p k ys
+sepNB g Empty k ys
+ = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion`
+ nilAboveNest False k (reduceDoc (vcat ys))
+ where
+ rest | g = hsep ys
+ | otherwise = hcat ys
+sepNB g p k ys
+ = sep1 g p k ys
+
+oneLiner :: Doc -> Doc
+oneLiner NoDoc = NoDoc
+oneLiner Empty = Empty
+oneLiner (NilAbove _) = NoDoc
+oneLiner (TextBeside s p) = textBeside_ s (oneLiner p)
+oneLiner (Nest k p) = nest_ k (oneLiner p)
+oneLiner (p `Union` _) = oneLiner p
+oneLiner (Above _ _ _) = error "oneLiner Above"
+oneLiner (Beside _ _ _) = error "oneLiner Beside"
+
+-- ---------------------------------------------------------------------------
+-- Rendering
+
+-- | A rendering style. Allows us to specify constraints to choose among the
+-- many different rendering options.
+data Style = Style Int Rat
+lineLength :: Style -> Int
+lineLength (Style l _) = l
+ribbonsPerLine :: Style -> Rat
+ribbonsPerLine (Style _ r) = r
+
+type Rat = (Int, Int)
+
+style :: Style
+style = Style 100 (3, 2)
+
+-- | Render the @Doc@ to a String using the default @Style@ (see 'style').
+render :: Doc -> String
+render = renderStyle style
+
+-- | Render the @Doc@ to a String using the given @Style@.
+renderStyle :: Style -> Doc -> String
+renderStyle s = fullRender (lineLength s) (ribbonsPerLine s) ""
+
+-- | The general rendering interface. Please refer to the @Style@ and @Mode@
+-- types for a description of rendering mode, line length and ribbons.
+fullRender :: Int -- ^ Line length.
+ -> Rat -- ^ Ribbons per line.
+ -> String -- ^ What to do at the end.
+ -> Doc -- ^ The document.
+ -> String -- ^ Result.
+fullRender lineLen (num, den) rest doc
+ = display lineLen ribbonLen rest doc'
+ where
+ doc' = best bestLineLen ribbonLen (reduceDoc doc)
+
+ ribbonLen = (lineLen * den) `quot` num
+ bestLineLen = lineLen
+
+display :: Int -> Int -> String -> Doc -> String
+display _page_width _ribbon_width end doc
+ = let lay :: Int -> Doc -> String
+ lay k (Nest k1 p) = lay (k + k1) p
+ lay _ Empty = end
+ lay k (NilAbove p) = "\n" ++ lay k p
+ lay k (TextBeside s p) = lay1 k s p
+ lay _ _ = error "display lay"
+
+ lay1 k s p = let r = k + length s
+ in replicate k ' ' ++ (s ++ lay2 r p)
+
+ lay2 :: Int -> Doc -> String
+ lay2 k (NilAbove p) = "\n" ++ lay k p
+ lay2 k (TextBeside s p) = s ++ lay2 (k + length s) p
+ lay2 k (Nest _ p) = lay2 k p
+ lay2 _ Empty = end
+ lay2 _ _ = error "display lay2"
+ in lay 0 doc
+
+best :: Int -- Line length.
+ -> Int -- Ribbon length.
+ -> RDoc
+ -> RDoc -- No unions in here!.
+best w0 r = get w0
+ where
+ get _ Empty = Empty
+ get _ NoDoc = NoDoc
+ get w (NilAbove p) = nilAbove_ (get w p)
+ get w (TextBeside s p) = textBeside_ s (get1 w (length s) p)
+ get w (Nest k p) = nest_ k (get (w - k) p)
+ get w (p `Union` q) = nicest w r (get w p) (get w q)
+ get _ _ = error "best get"
+
+ get1 _ _ Empty = Empty
+ get1 _ _ NoDoc = NoDoc
+ get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p)
+ get1 w sl (TextBeside s p) = textBeside_ s (get1 w (sl + length s) p)
+ get1 w sl (Nest _ p) = get1 w sl p
+ get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
+ (get1 w sl q)
+ get1 _ _ _ = error "best get1"
+
+nicest :: Int -> Int -> Doc -> Doc -> Doc
+nicest w r = nicest1 w r 0
+
+nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc
+nicest1 w r sl p q | fits (minWR - sl) p = p
+ | otherwise = q
+ where minWR = if w < r then w else r
+
+fits :: Int -- Space available
+ -> Doc
+ -> Bool -- True if *first line* of Doc fits in space available
+fits n _ | n < 0 = False
+fits _ NoDoc = False
+fits _ Empty = True
+fits _ (NilAbove _) = True
+fits n (TextBeside s p) = fits (n - length s) p
+fits _ _ = error "fits"
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -1674,7 +1674,7 @@
showTModule :: forall a . (a -> String) -> TModule a -> String
showTModule sh amdl =
case amdl of
- TModule mn _ _ _ _ a -> "Tmodule " ++ showIdent mn ++ "\n" ++ sh a
+ TModule mn _ _ _ _ a -> "Tmodule " ++ showIdent mn ++ "\n" ++ sh a ++ "\n"
{-showValueTable :: ValueTable -> String
--
⑨