Skip to content

Commit 40e7108

Browse files
sfultongsfultong
committed
breaking early ASTs out into high and lam term fragments
1 parent 1a73da4 commit 40e7108

7 files changed

Lines changed: 633 additions & 264 deletions

File tree

‎src/PrettyPrint.hs‎

Lines changed: 82 additions & 67 deletions
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,7 @@ import Telomare (AbortableF (..), BasicExprF (..), CompiledExpr,
1313
Term3F (..), UnprocessedParsedTerm (..),
1414
UnprocessedParsedTermF (..), b2i, convertAbortMessage, forget,
1515
indentWithChildren', indentWithOneChild',
16-
indentWithTwoChildren', locatedNameText, pattern BasicEE)
16+
indentWithTwoChildren', locatedNameText, pattern BasicEE, HighTermF (..), BasicExprF (..), LamTermF(..))
1717

1818
import qualified Control.Comonad.Trans.Cofree as CofreeT (CofreeF (..))
1919
import qualified Control.Monad.State as State
@@ -43,22 +43,31 @@ indentation :: Int -> String
4343
indentation 0 = []
4444
indentation n = ' ' : ' ' : indentation (n - 1)
4545

46-
instance (Show l, Show v) => PrettyPrintable1 (ParserTermF l v) where
46+
instance (Show l, Show v) => PrettyPrintable1 (LamTermF l v) where
4747
showP1 = \case
48-
ParserTermB x -> showP1 x
49-
TVarF v -> pure $ show v
50-
TAppF c i -> indentWithTwoChildren' "($)" (showP c) (showP i)
51-
TCheckF cf i -> indentWithTwoChildren' ":" (showP cf) (showP i)
52-
TITEF i t e -> indentWithChildren' "ITE" $ showP <$> [i,t,e]
53-
TLeftF x -> indentWithOneChild' "L" $ showP x
54-
TRightF x -> indentWithOneChild' "R" $ showP x
55-
TTraceF x -> indentWithOneChild' "T" $ showP x
56-
THashF x -> indentWithOneChild' "#" $ showP x
57-
TChurchF n -> pure $ "$" <> show n
48+
VarF v -> pure $ show v
49+
AppF c i -> indentWithTwoChildren' "($)" (showP c) (showP i)
50+
LamF l x -> indentWithOneChild' ("\\" <> show l) $ showP x
51+
52+
instance PrettyPrintable1 HighTermF where
53+
showP1 = \case
54+
CheckF cf i -> indentWithTwoChildren' ":" (showP cf) (showP i)
55+
ITEF i t e -> indentWithChildren' "ITE" $ showP <$> [i,t,e]
56+
HLeftF x -> indentWithOneChild' "L" $ showP x
57+
HRightF x -> indentWithOneChild' "R" $ showP x
58+
HTraceF x -> indentWithOneChild' "T" $ showP x
59+
HashF x -> indentWithOneChild' "#" $ showP x
60+
ChurchF n -> pure $ "$" <> show n
61+
{-
5862
TLamF (Open v) x -> indentWithOneChild' ("\\" <> show v) $ showP x
5963
TLamF (Closed v) x -> indentWithOneChild' ("[\\" <> show v) $ showP x
6064
TLamF (LetBinding c v) x -> indentWithOneChild' ("{\\(" <> show c <> ") " <> show v) $ showP x
61-
TLimitedRecursionF t r b -> indentWithChildren' "TRB" $ showP <$> [t,r,b]
65+
-}
66+
RecursionF t r b -> indentWithChildren' "TRB" $ showP <$> [t,r,b]
67+
68+
instance (Show l, Show v) => PrettyPrintable1 (ParserTermF l v) where
69+
showP1 = \case
70+
ParserTermB x -> showP1 x
6271
TUnsizedRepeaterF -> pure "*"
6372

6473
indentSansFirstLine :: Int -> String -> String
@@ -115,37 +124,40 @@ instance Show MultiLineShowUPT where
115124
ind = indentSansFirstLine 2
116125
-- alg :: Base UnprocessedParsedTerm String -> String
117126
alg = \case
118-
IntUPF i -> "IntUP " <> show i
119-
VarUPF str -> "VarUP " <> str
120-
StringUPF str -> "StringUP " <> show str
121-
PairUPF x y -> "PairUP\n" <>
122-
" " <> ind x <> "\n" <>
123-
" " <> ind y
124-
(ITEUPF x y z) -> "ITEUP\n" <>
125-
" " <> ind x <> "\n" <>
126-
" " <> ind y <> "\n" <>
127-
" " <> ind z
128-
(AppUPF x y) -> "AppUP\n" <>
129-
" " <> ind x <> "\n" <>
130-
" " <> ind y
131-
(LamUPF str y) -> "LamUP " <> locatedNameText str <> "\n" <>
132-
" " <> ind y
133-
(ChurchUPF x) -> "ChurchUP " <> show x
134-
(LeftUPF x) -> "LeftUP\n" <>
135-
" " <> ind x
136-
(RightUPF x) -> "RightUP\n" <>
127+
UnprocessedParsedTermB x -> case x of
128+
PairSF x y -> "PairUP\n" <>
129+
" " <> ind x <> "\n" <>
130+
" " <> ind y
131+
UnprocessedParsedTermH x -> case x of
132+
(ITEF x y z) -> "ITEUP\n" <>
133+
" " <> ind x <> "\n" <>
134+
" " <> ind y <> "\n" <>
135+
" " <> ind z
136+
(ChurchF x) -> "ChurchUP " <> show x
137+
(HLeftF x) -> "LeftUP\n" <>
137138
" " <> ind x
138-
(TraceUPF x) -> "TraceUP\n" <>
139+
(HRightF x) -> "RightUP\n" <>
140+
" " <> ind x
141+
(HTraceF x) -> "TraceUP\n" <>
142+
" " <> ind x
143+
(RecursionF x y z) -> "UnsizedRecursionUP\n" <>
144+
" " <> ind x <> "\n" <>
145+
" " <> ind y <> "\n" <>
146+
" " <> ind z
147+
(HashF x) -> "HashUP\n" <>
139148
" " <> ind x
140-
(UnsizedRecursionUPF x y z) -> "UnsizedRecursionUP\n" <>
141-
" " <> ind x <> "\n" <>
142-
" " <> ind y <> "\n" <>
143-
" " <> ind z
144-
(HashUPF x) -> "HashUP\n" <>
145-
" " <> ind x
146-
(CheckUPF x y) -> "CheckUP\n" <>
147-
" " <> ind x <> "\n" <>
148-
" " <> ind y
149+
(CheckF x y) -> "CheckUP\n" <>
150+
" " <> ind x <> "\n" <>
151+
" " <> ind y
152+
UnprocessedParsedTermL x -> case x of
153+
VarF str -> "VarUP " <> str
154+
(AppF x y) -> "AppUP\n" <>
155+
" " <> ind x <> "\n" <>
156+
" " <> ind y
157+
(LamF str y) -> "LamUP " <> locatedNameText str <> "\n" <>
158+
" " <> ind y
159+
IntUPF i -> "IntUP " <> show i
160+
StringUPF str -> "StringUP " <> show str
149161
(ListUPF []) -> "ListUP []"
150162
(ListUPF [x]) -> "ListUP [" <> x <> "]"
151163
(ListUPF ls) -> "ListUP\n" <>
@@ -170,17 +182,36 @@ instance Show PrettyUPT where
170182
show (PrettyUPT (UnprocessedParsedTerm upt)) = cata alg upt where
171183
-- alg :: Base UnprocessedParsedTerm String -> String
172184
alg = \case
185+
UnprocessedParsedTermB x -> case x of
186+
PairSF x y -> if length (lines (x <> y)) > 1
187+
then "( " <> indentSansFirstLine 2 x <> "\n" <>
188+
", " <> indentSansFirstLine 2 y <> "\n" <>
189+
")"
190+
else "(" <> x <> ", " <> y <>")"
191+
UnprocessedParsedTermL x -> case x of
192+
VarF str -> str
193+
(AppF x y) -> (if (length . words $ x) == 1 then x else "(" <> x <> ")") <> " " <>
194+
if (length . words $ y) == 1 then y else "(" <> y <> ")"
195+
(LamF str y) -> "\\ " <> locatedNameText str <> " -> " <> indentSansFirstLine (6 + length (locatedNameText str)) y
196+
UnprocessedParsedTermH x -> case x of
197+
(ITEF x y z) -> "if " <> indentSansFirstLine 3 x <> "\n" <>
198+
" then " <> indentSansFirstLine 7 y <> "\n" <>
199+
" else " <> indentSansFirstLine 7 z
200+
(ChurchF x) -> "$" <> show x
201+
(HLeftF x) -> "left (" <> indentSansFirstLine 6 x <> ")"
202+
(HRightF x) -> "right (" <> indentSansFirstLine 7 x <> ")"
203+
(HTraceF x) -> "trace (" <> indentSansFirstLine 7 x <> ")"
204+
(RecursionF x y z) -> "{ " <> indentSansFirstLine 2 x <>
205+
", " <> indentSansFirstLine 2 y <>
206+
", " <> indentSansFirstLine 2 z <>
207+
"}"
208+
(HashF x) -> "# " <> indentSansFirstLine 2 x
209+
(CheckF x y) -> if length (lines (x <> y)) > 1
210+
then "(" <> indentSansFirstLine 2 y <> " : " <> "\n" <>
211+
" " <> indentSansFirstLine 4 y <> ")"
212+
else "(" <> y <> " : " <> x <> ")"
173213
IntUPF i -> show i
174-
VarUPF str -> str
175214
StringUPF str -> show str
176-
PairUPF x y -> if length (lines (x <> y)) > 1
177-
then "( " <> indentSansFirstLine 2 x <> "\n" <>
178-
", " <> indentSansFirstLine 2 y <> "\n" <>
179-
")"
180-
else "(" <> x <> ", " <> y <>")"
181-
(ITEUPF x y z) -> "if " <> indentSansFirstLine 3 x <> "\n" <>
182-
" then " <> indentSansFirstLine 7 y <> "\n" <>
183-
" else " <> indentSansFirstLine 7 z
184215
(LetUPF ls x) ->
185216
"let " <> indentSansFirstLine 4 (unlines (assignList <$> ls)) <> "\n" <>
186217
"in " <> indentSansFirstLine 3 x
@@ -195,25 +226,9 @@ instance Show PrettyUPT where
195226
removeFirstComma = \case
196227
(',':str) -> str
197228
_ -> error "removeFirstComma: input does not start with a comma"
198-
(AppUPF x y) -> (if (length . words $ x) == 1 then x else "(" <> x <> ")") <> " " <>
199-
if (length . words $ y) == 1 then y else "(" <> y <> ")"
200-
(LamUPF str y) -> "\\ " <> locatedNameText str <> " -> " <> indentSansFirstLine (6 + length (locatedNameText str)) y
201-
(ChurchUPF x) -> "$" <> show x
202-
(LeftUPF x) -> "left (" <> indentSansFirstLine 6 x <> ")"
203-
(RightUPF x) -> "right (" <> indentSansFirstLine 7 x <> ")"
204-
(TraceUPF x) -> "trace (" <> indentSansFirstLine 7 x <> ")"
205-
(UnsizedRecursionUPF x y z) -> "{ " <> indentSansFirstLine 2 x <>
206-
", " <> indentSansFirstLine 2 y <>
207-
", " <> indentSansFirstLine 2 z <>
208-
"}"
209-
(HashUPF x) -> "# " <> indentSansFirstLine 2 x
210229
(CaseUPF x ls) -> "case " <> x <> " of\n" <>
211230
" " <> indentSansFirstLine 2 (unlines ((\(p, r) -> indentSansFirstLine 2 (prettyPrintPattern (show . PrettyUPT) p <> " -> " <> r))
212231
<$> ls))
213-
(CheckUPF x y) -> if length (lines (x <> y)) > 1
214-
then "(" <> indentSansFirstLine 2 y <> " : " <> "\n" <>
215-
" " <> indentSansFirstLine 4 y <> ")"
216-
else "(" <> y <> " : " <> x <> ")"
217232

218233
instance PrettyPrintable LocTag where
219234
showP = const $ pure ""

0 commit comments

Comments
 (0)