ref: 556338359d9b06258b738d98c36ce243d4cdce46
parent: 23004b0d63df15b92a5269d6e2709caeee63d25a
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Thu Oct 19 16:14:33 EDT 2023
Move pretty printing library
--- a/Makefile
+++ b/Makefile
@@ -11,7 +11,7 @@
GHCC=$(GHCB) $(GHCFLAGS)
GHC=ghc
# $(CURDIR) might not be quite right
-GHCE=$(GHC) $(EXTS) -package mtl -F -pgmF Tools/convertX.sh -outputdir $(OUTDIR)
+GHCE=$(GHC) $(EXTS) -package mtl -package pretty -F -pgmF Tools/convertX.sh -outputdir $(OUTDIR)
GCC=gcc
UPX=upx
ALLSRC=src/*/*.hs lib/*.hs lib/*/*.hs ghc/*.hs ghc/*/*.hs
@@ -76,9 +76,9 @@
$(GHCC) -c lib/Control/DeepSeq.hs
# $(GHCC) -c lib/Debug/Trace.hs
$(GHCC) -c lib/Control/Exception.hs
+ $(GHCC) -c lib/Text/PrettyPrint/HughesPJ.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
@@ -69,3 +69,4 @@
ghc-prim >= 0.5 && < 0.11,
mtl >= 2.0 && < 2.4,
time >= 1.1 && < 1.15
+ pretty >= 1.0 && < 1.2
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.0
-1082
-((A :0 _966) ((A :1 ((B _1012) _0)) ((A :2 (((S' _1012) _0) I)) ((A :3 _936) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _965) ((C _76) _5))) ((A :7 (((C' _6) (_983 _72)) ((_76 _981) _71))) ((A :8 ((B ((S _1012) _981)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_76 _191)) _10)) ((A :12 ((B (B (_74 _9))) (((C' B) ((B C) _10)) (B _10)))) ((A :13 ((B (B (_74 _9))) (((C' B) ((B C) _10)) (BK _10)))) ((A :14 ((B (_74 _9)) P)) ((A :15 ((B (B (_74 _9))) ((B ((C' C) _10)) (B P)))) ((A :16 _15) ((A :17 (((C' B) _12) (((C' B) _12) (B _14)))) ((A :18 ((B (_74 _9)) (B (P _894)))) ((A :19 ((B (_74 _9)) (BK (P _894)))) ((A :20 ((_74 _9) ((S P) I))) ((A :21 ((B (_74 _9)) ((C (S' P)) I))) ((A :22 ((B Y) ((B (B (P (_14 _116)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _117)))))) ((A :23 ((B Y) ((B (B (P (_14 _894)))) ((B (C' B)) (B _13))))) ((A :24 _3) ((A :25 (T (_14 _894))) ((A :26 (_22 _77)) ((A :27 (R _34)) ((A :28 (T _33)) ((A :29 ((P _34) _33)) ((A :30 _34) ((A :31 ((C ((C S') _29)) I)) ((A :32 ((C S) _29)) ((A :33 K) ((A :34 A) ((A :35 _941) ((A :36 _942) ((A :37 (((S' _28) (_933 #97)) ((C _933) #122))) ((A :38 (((S' _28) (_933 #65)) ((C _933) #90))) ((A :39 (((S' _27) _37) _38)) ((A :40 (((S' _28) (_933 #48)) ((C _933) #57))) ((A :41 (((S' _28) (_933 #32)) ((C _933) #126))) ((A :42 _930) ((A :43 _931) ((A :44 _933) ((A :45 _932) ((A :46 (((S' _27) ((C _42) #32)) (((S' _27) ((C _42) #9)) ((C _42) #10)))) ((A :47 ((S ((S (((S' _28) (_44 #65)) ((C _44) #90))) (_34 (((_892 "lib/Data/Char.hs") #3) #8)))) ((B _35) (((C' _83) (((C' _84) _36) (_36 #65))) (_36 #97))))) ((A :48 ((S ((S (((S' _28) (_44 #97)) ((C _44) #97))) (_34 (((_892 "lib/Data/Char.hs") #3) #8)))) ((B _35) (((C' _83) (((C' _84) _36) (_36 #97))) (_36 #65))))) ((A :49 _901) ((A :50 _902) ((A :51 _903) ((A :52 _904) ((A :53 (_50 %0.0)) ((A :54 _49) ((A :55 _50) ((A :56 _51) ((A :57 _52) ((A :58 _905) ((A :59 _906) ((A :60 _58) ((A :61 _59) ((A :62 _907) ((A :63 _908) ((A :64 _909) ((A :65 _910) ((A :66 _62) ((A :67 _63) ((A :68 _64) ((A :69 _65) ((A :70 _911) ((A :71 ((B BK) T)) ((A :72 (BK T)) ((A :73 P) ((A :74 I) ((A :75 (S _938)) ((A :76 B) ((A :77 I) ((A :78 K) ((A :79 C) ((A :80 _937) ((A :81 ((C ((C S') _191)) _192)) ((A :82 (((C' (S' (C' B))) B) I)) ((A :83 _895) ((A :84 _896) ((A :85 _897) ((A :86 _898) ((A :87 _899) ((A :88 _900) ((A :89 (_84 #0)) ((A :90 _918) ((A :91 _919) ((A :92 _920) ((A :93 _921) ((A :94 _922) ((A :95 _923) ((A :96 _90) ((A :97 (BK K)) ((A :98 ((B BK) ((B (B BK)) P))) ((A :99 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :100 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _27) (_93 #0))) (_90 #0)))) ((B (B ((C' P) (_88 #1)))) _83))) (C P))) _86)) _87)) ((A :101 _97) ((A :102 (((S' C) ((B (P _179)) (((C' (C' B)) (((C' C) _90) _179)) _180))) ((B ((C' (C' (C' C))) (((C' (C' (C' C))) (((C' (C' (C' (C' S')))) ((B (B (B (B C)))) ((B ((C' (C' (C' C))) ((B (B (B ((S' S') (_90 #0))))) ((B ((C' (C' C)) ((B (B ((S' S') (_90 #1)))) ((B ((C' C) ((B ((C' S') (_90 #2))) (C _102)))) (C _102))))) (C _102))))) (C _102)))) (T K))) (T A)))) ((C _100) #4)))) ((A :103 (_109 _78)) ((A :104 ((_124 (_81 _103)) _101)) ((A :105 ((C (((C' B) ((P _116) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _106)))) (((S' (C' (C' B))) ((B (B (B _106))) (((S' (C' B)) ((B (B _106)) (((C' B) ((B _122) (T #0))) _105))) (((C' B) ((B _122) (T #1))) _105)))) (((C' B) ((B _122) (T #2))) _105)))) (((C' B) ((B _122) (T #3))) _105)))) ((B T) ((B (B P)) ((C' _83) (_85 #4)))))) ((A :106 ((S S) ((B BK) ((B BK) (((S' S) T) ((B BK) ((B BK) ((C (((S' C') S) ((B (B (B (S B)))) ((B (B (B (B (B BK))))) ((B ((S' (C' B)) ((B B') B'))) ((B (B (B (B (B (S B)))))) ((B (B (B (B (B (B (B BK))))))) (((C' B) (B' (B' ((B (C' (C' (C' C)))) ((B ((C' B) (B' ((B C) _92)))) ((B ((C' B) _117)) _106)))))) ((B ((C' B) _117)) (C _106)))))))))) (((_892 "lib/Data/IntMap.hs") #3) #8))))))))) ((A :107 ((_76 (_122 _191)) _105)) ((A :108 (((C' C) (((C' C) (C _102)) (_3 "Data.IntMap.!"))) I)) ((A :109 ((B (C' Y)) (((C' (C' (S' (S' C
\ No newline at end of file
+1084
+((A :0 _907) ((A :1 ((B _953) _0)) ((A :2 (((S' _953) _0) I)) ((A :3 _877) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _906) ((C _76) _5))) ((A :7 (((C' _6) (_924 _72)) ((_76 _922) _71))) ((A :8 ((B ((S _953) _922)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_76 _191)) _10)) ((A :12 ((B (B (_74 _9))) (((C' B) ((B C) _10)) (B _10)))) ((A :13 ((B (B (_74 _9))) (((C' B) ((B C) _10)) (BK _10)))) ((A :14 ((B (_74 _9)) P)) ((A :15 ((B (B (_74 _9))) ((B ((C' C) _10)) (B P)))) ((A :16 _15) ((A :17 (((C' B) _12) (((C' B) _12) (B _14)))) ((A :18 ((B (_74 _9)) (B (P _835)))) ((A :19 ((B (_74 _9)) (BK (P _835)))) ((A :20 ((_74 _9) ((S P) I))) ((A :21 ((B (_74 _9)) ((C (S' P)) I))) ((A :22 ((B Y) ((B (B (P (_14 _116)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _117)))))) ((A :23 ((B Y) ((B (B (P (_14 _835)))) ((B (C' B)) (B _13))))) ((A :24 _3) ((A :25 (T (_14 _835))) ((A :26 (_22 _77)) ((A :27 (R _34)) ((A :28 (T _33)) ((A :29 ((P _34) _33)) ((A :30 _34) ((A :31 ((C ((C S') _29)) I)) ((A :32 ((C S) _29)) ((A :33 K) ((A :34 A) ((A :35 _882) ((A :36 _883) ((A :37 (((S' _28) (_874 #97)) ((C _874) #122))) ((A :38 (((S' _28) (_874 #65)) ((C _874) #90))) ((A :39 (((S' _27) _37) _38)) ((A :40 (((S' _28) (_874 #48)) ((C _874) #57))) ((A :41 (((S' _28) (_874 #32)) ((C _874) #126))) ((A :42 _871) ((A :43 _872) ((A :44 _874) ((A :45 _873) ((A :46 (((S' _27) ((C _42) #32)) (((S' _27) ((C _42) #9)) ((C _42) #10)))) ((A :47 ((S ((S (((S' _28) (_44 #65)) ((C _44) #90))) (_34 (((_833 "lib/Data/Char.hs") #3) #8)))) ((B _35) (((C' _83) (((C' _84) _36) (_36 #65))) (_36 #97))))) ((A :48 ((S ((S (((S' _28) (_44 #97)) ((C _44) #97))) (_34 (((_833 "lib/Data/Char.hs") #3) #8)))) ((B _35) (((C' _83) (((C' _84) _36) (_36 #97))) (_36 #65))))) ((A :49 _842) ((A :50 _843) ((A :51 _844) ((A :52 _845) ((A :53 (_50 %0.0)) ((A :54 _49) ((A :55 _50) ((A :56 _51) ((A :57 _52) ((A :58 _846) ((A :59 _847) ((A :60 _58) ((A :61 _59) ((A :62 _848) ((A :63 _849) ((A :64 _850) ((A :65 _851) ((A :66 _62) ((A :67 _63) ((A :68 _64) ((A :69 _65) ((A :70 _852) ((A :71 ((B BK) T)) ((A :72 (BK T)) ((A :73 P) ((A :74 I) ((A :75 (S _879)) ((A :76 B) ((A :77 I) ((A :78 K) ((A :79 C) ((A :80 _878) ((A :81 ((C ((C S') _191)) _192)) ((A :82 (((C' (S' (C' B))) B) I)) ((A :83 _836) ((A :84 _837) ((A :85 _838) ((A :86 _839) ((A :87 _840) ((A :88 _841) ((A :89 (_84 #0)) ((A :90 _859) ((A :91 _860) ((A :92 _861) ((A :93 _862) ((A :94 _863) ((A :95 _864) ((A :96 _90) ((A :97 (BK K)) ((A :98 ((B BK) ((B (B BK)) P))) ((A :99 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :100 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _27) (_93 #0))) (_90 #0)))) ((B (B ((C' P) (_88 #1)))) _83))) (C P))) _86)) _87)) ((A :101 _97) ((A :102 (((S' C) ((B (P _179)) (((C' (C' B)) (((C' C) _90) _179)) _180))) ((B ((C' (C' (C' C))) (((C' (C' (C' C))) (((C' (C' (C' (C' S')))) ((B (B (B (B C)))) ((B ((C' (C' (C' C))) ((B (B (B ((S' S') (_90 #0))))) ((B ((C' (C' C)) ((B (B ((S' S') (_90 #1)))) ((B ((C' C) ((B ((C' S') (_90 #2))) (C _102)))) (C _102))))) (C _102))))) (C _102)))) (T K))) (T A)))) ((C _100) #4)))) ((A :103 (_109 _78)) ((A :104 ((_124 (_81 _103)) _101)) ((A :105 ((C (((C' B) ((P _116) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _106)))) (((S' (C' (C' B))) ((B (B (B _106))) (((S' (C' B)) ((B (B _106)) (((C' B) ((B _122) (T #0))) _105))) (((C' B) ((B _122) (T #1))) _105)))) (((C' B) ((B _122) (T #2))) _105)))) (((C' B) ((B _122) (T #3))) _105)))) ((B T) ((B (B P)) ((C' _83) (_85 #4)))))) ((A :106 ((S S) ((B BK) ((B BK) (((S' S) T) ((B BK) ((B BK) ((C (((S' C') S) ((B (B (B (S B)))) ((B (B (B (B (B BK))))) ((B ((S' (C' B)) ((B B') B'))) ((B (B (B (B (B (S B)))))) ((B (B (B (B (B (B (B BK))))))) (((C' B) (B' (B' ((B (C' (C' (C' C)))) ((B ((C' B) (B' ((B C) _92)))) ((B ((C' B) _117)) _106)))))) ((B ((C' B) _117)) (C _106)))))))))) (((_833 "lib/Data/IntMap.hs") #3) #8))))))))) ((A :107 ((_76 (_122 _191)) _105)) ((A :108 (((C' C) (((C' C) (C _102)) (_3 "Data.IntMap.!"))) I)) ((A :109 ((B (C' Y)) (((C' (C' (S' (S' C)))
\ No newline at end of file
--- /dev/null
+++ b/lib/Text/PrettyPrint/HughesPJ.hs
@@ -1,0 +1,368 @@
+-- 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(
+ Doc,
+ text, empty,
+ (<>), (<+>), ($$), ($+$),
+ hcat, hsep,
+ vcat,
+ sep, cat,
+ nest, hang,
+ punctuate,
+ parens, brackets, braces,
+ maybeParens,
+ Style,
+ render, renderStyle,
+ ) where
+import Prelude
+
+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
+
+hsep :: [Doc] -> Doc
+hsep = snd . reduceHoriz . foldr (\p q -> Beside p True q) empty
+
+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/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -23,7 +23,8 @@
Constr(..), ConstrField,
ConTyInfo,
Con(..), conIdent, conArity, eqCon, getSLocCon,
- tupleConstr, untupleConstr, isTupleConstr,
+ tupleConstr, getTupleConstr,
+ mkTupleSel,
subst,
allVarsExpr, allVarsBind,
getSLocExpr, setSLocExpr,
@@ -35,11 +36,11 @@
import Data.Maybe
import MicroHs.Ident
import qualified Data.Double as D
+import Text.PrettyPrint.HughesPJ
--Ximport Compat
--Ximport GHC.Stack
--Ximport Control.DeepSeq
--Yimport Primitives(NFData(..))
-import MicroHs.Pretty
type IdentModule = Ident
@@ -216,11 +217,17 @@
tupleConstr :: SLoc -> Int -> Ident
tupleConstr loc n = mkIdentSLoc loc (replicate (n - 1) ',')
-untupleConstr :: Ident -> Int
-untupleConstr i = length (unIdent i) + 1
+-- Check if it is a suple constructor
+getTupleConstr :: Ident -> Maybe Int
+getTupleConstr i =
+ case unIdent i of
+ ',':xs -> Just (length xs + 2) -- "," is 2-tuple
+ _ -> Nothing
-isTupleConstr :: Int -> Ident -> Bool
-isTupleConstr n i = eqChar (head (unIdent i)) ',' && untupleConstr i == n
+-- Create a tuple selector, component i (0 based) of n
+mkTupleSel :: Int -> Int -> Expr
+mkTupleSel i n = ELam [ETuple [ EVar $ if k == i then x else dummyIdent | k <- [0 .. n - 1] ]] (EVar x)
+ where x = mkIdent "$x"
---------------------------------
--- a/src/MicroHs/Ident.hs
+++ b/src/MicroHs/Ident.hs
@@ -19,9 +19,9 @@
--Ximport Control.DeepSeq
--Yimport Primitives(NFData(..))
import Data.Char
+import Text.PrettyPrint.HughesPJ
--Ximport Compat
--Ximport GHC.Stack
-import MicroHs.Pretty
type Line = Int
type Col = Int
--- a/src/MicroHs/Pretty.hs
+++ /dev/null
@@ -1,370 +1,0 @@
--- 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
-
-hsep :: [Doc] -> Doc
-hsep = snd . reduceHoriz . foldr (\p q -> Beside p True q) empty
-
-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"
--
⑨