From bd86eb02e1a7dbd82bd31ea06623bb8b86e877ff Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Mon, 21 May 2018 17:31:43 -0400 Subject: [PATCH] braced block tests passing, layout block test is failing --- parser-typechecker/src/Unison/TermParser.hs | 36 +++++++------- .../tests/Unison/Test/TermParser.hs | 49 ++++++++++--------- yaks/parsec-layout/src/Text/Parsec/Layout.hs | 36 +++++++++----- 3 files changed, 69 insertions(+), 52 deletions(-) diff --git a/parser-typechecker/src/Unison/TermParser.hs b/parser-typechecker/src/Unison/TermParser.hs index a9ac34424..0b70b03a3 100644 --- a/parser-typechecker/src/Unison/TermParser.hs +++ b/parser-typechecker/src/Unison/TermParser.hs @@ -36,12 +36,12 @@ pTrace s = pt <|> return () trace (s++": " ++x) $ attempt $ char 'z' fail x --- traced s p = p -traced s p = do - pTrace s - a <- p <|> trace (s ++ " backtracked") (fail s) - let !x = trace (s ++ " succeeded") () - pure a +traced s p = p +--traced s p = do +-- pTrace s +-- a <- p <|> trace (s ++ " backtracked") (fail s) +-- let !x = trace (s ++ " succeeded") () +-- pure a {- Precedence of language constructs is identical to Haskell, except that all @@ -84,7 +84,7 @@ term4 = traced "apply-chain" $ f <$> some termLeaf f [] = error "'some' shouldn't produce an empty list" termLeaf :: Var v => TermP v -termLeaf = +termLeaf = traced "leaf" $ asum [hashLit, prefixTerm, text, number, tupleOrParenthesized term, blank, vector term, bracedBlock] ifthen :: Var v => TermP v @@ -114,7 +114,7 @@ text :: Ord v => Parser s (Term v) text = Term.text <$> text' number :: Ord v => Parser s (Term v) -number = traced "number" . token $ do +number = token $ do let digits = takeWhile1 "number" isDigit sign <- optional (char '+' <|> char '-') ds <- digits @@ -207,16 +207,16 @@ keywords = block' :: Var v => (forall a. Parser (S v) [a] -> Parser (S v) [a]) + -> Parser (S v) x -> TermP v -block' braced = go =<< braced statements +block' braced semi = go =<< braced (traced "statements" statements) where - statements = traced "statements" $ do + statements = do s <- statement o <- optional semi case o of Nothing -> pure [s] Just _ -> (s:) . join . toList <$> optional statements - semi = L.spaced L.semi statement = traced "statement" $ (Right <$> binding) <|> (Left <$> blockTerm) toBinding (Right (v, e)) = (v,e) toBinding (Left e) = (Var.named "_", e) @@ -230,10 +230,12 @@ block' braced = go =<< braced statements [] -> fail "empty block" block :: Var v => TermP v -block = traced "block" $ block' L.block +block = traced "block" $ bracedBlock <|> traced "unbraced-block" (block' L.vblock L.vsemi) bracedBlock :: Var v => TermP v -bracedBlock = traced "braced-block" $ block' (\body -> token (string "{") *> body <* token (string "}")) +bracedBlock = traced "braced-block" $ + block' (\body -> token (string "{") *> body <* token (string "}")) semi + where semi = L.spaced L.semi -- We disallow type annotations and lambdas, -- just function application and operators @@ -270,8 +272,8 @@ alias = do n = length params set (TypeParser.Aliases (s':s)) -bindings :: Var v => Parser (S v) [(v, Term v)] -bindings = do s0 <- get; L.laidout (many alias *> binding) <* set s0 where +-- bindings :: Var v => Parser (S v) [(v, Term v)] +-- bindings = do s0 <- get; L.laidout (many alias *> binding) <* set s0 where -moduleBindings :: Var v => Parser (S v) [(v, Term v)] -moduleBindings = root bindings +-- moduleBindings :: Var v => Parser (S v) [(v, Term v)] +-- moduleBindings = root bindings diff --git a/parser-typechecker/tests/Unison/Test/TermParser.hs b/parser-typechecker/tests/Unison/Test/TermParser.hs index 089fe2a31..f7f5d2811 100644 --- a/parser-typechecker/tests/Unison/Test/TermParser.hs +++ b/parser-typechecker/tests/Unison/Test/TermParser.hs @@ -7,28 +7,33 @@ import Unison.Symbol (Symbol) import Unison.Parsers (unsafeParseTerm) test = scope "termparser" . tests . map parses $ - [ -- "1" - --, "1.0" - --, "+1" - --, "-1" - --, "-1.0" - --, "4th" - --, "forty" - --, "forty two" - --, "\"forty two\"" - --, "{ one }" - --, "{ one ; two }" - --, "{ one ; two ; }" - --, "{ one ; two ; three }" - --, "{ one ; two ; 42 }" - --, "{ one ; two ; three; }" - --, "x + 1" - --, "{ x + 1 }" - --, "{ x + 1; }" - "{ y = x; 24 }" - -- , "{ y = x + 1; 24 }" - -- , "{ x = 42 ; y = x + 1 ; 24 }" - -- , "foo 42" + [ "1" + , "1.0" + , "+1" + , "-1" + , "-1.0" + , "4th" + , "forty" + , "forty two" + , "\"forty two\"" + , "{ one }" + , "{ one ; two }" + , "{ one ; two ; }" + , "{ one ; two ; three }" + , "{ one ; two ; 42 }" + , "{ one ; two ; three; }" + , "x + 1" + , "{ x + 1 }" + , "{ x + 1; }" + , "{ y = x; 24; }" + , "{ y = x + 1; 24 }" + , "{ x = 42 ; y = x + 1 ; 24 }" + , "{ x = \n" ++ + " z = 13 \n" ++ + " z + 1 \n" ++ + " 91.0 \n" ++ + "}" + , "foo 42" ] parses s = do diff --git a/yaks/parsec-layout/src/Text/Parsec/Layout.hs b/yaks/parsec-layout/src/Text/Parsec/Layout.hs index acb778ff6..f02f07ca6 100644 --- a/yaks/parsec-layout/src/Text/Parsec/Layout.hs +++ b/yaks/parsec-layout/src/Text/Parsec/Layout.hs @@ -13,8 +13,9 @@ module Text.Parsec.Layout ( block - , laidout + , vblock , semi + , vsemi , space , spaced , LayoutEnv @@ -196,7 +197,7 @@ virtual_lbrace = do when allow pushCurrentContext virtual_rbrace :: (HasLayoutEnv u, Stream s m Char) => ParsecT s u m () -virtual_rbrace = do +virtual_rbrace = try (void $ lookAhead semi) <|> do allow <- inLayout when allow $ eof <|> try (layoutSatisfies (VBrace ==) "outdent") @@ -207,6 +208,15 @@ space = do return " " "space" +vsemi :: (HasLayoutEnv u, Stream s m Char) => ParsecT s u m String +vsemi = do + try $ layoutSatisfies p + return ";" + "semicolon" + where + p VSemi = True + p _ = False + -- | Recognize a semicolon including a virtual semicolon in layout. semi :: (HasLayoutEnv u, Stream s m Char) => ParsecT s u m String semi = do @@ -214,9 +224,8 @@ semi = do return ";" "semicolon" where - p VSemi = True - p (Other ';') = True - p _ = False + p (Other ';') = True + p _ = False lbrace :: (HasLayoutEnv u, Stream s m Char) => ParsecT s u m String lbrace = do @@ -230,6 +239,15 @@ rbrace = do popContext "a right brace" return "}" +vblock :: (HasLayoutEnv u, Stream s m Char) => ParsecT s u m a -> ParsecT s u m a +vblock p = between (spaced virtual_lbrace) (spaced virtual_rbrace) p + where + -- NB: virtual_lbrace here doesn't use current column for offside calc, instead + -- uses 1 column greater than whatever column is at top of layout stack + virtual_lbrace = do + allow <- inLayout + when allow pushIncrementedContext + block :: (HasLayoutEnv u, Stream s m Char) => ParsecT s u m a -> ParsecT s u m a block p = braced p <|> vbraced p where braced s = between (try (spaced lbrace)) (spaced rbrace) s @@ -239,11 +257,3 @@ block p = braced p <|> vbraced p where virtual_lbrace = do allow <- inLayout when allow pushIncrementedContext - --- | Repeat a parser in layout, separated by (virtual) semicolons. -laidout :: (HasLayoutEnv u, Stream s m Char) => ParsecT s u m a -> ParsecT s u m [a] -laidout p = braced statements <|> vbraced statements where - braced s = between (try (spaced lbrace)) (spaced rbrace) s - vbraced s = between (spaced virtual_lbrace) (spaced virtual_rbrace) s - statements = p `sepBy` spaced semi -