file parser can pass tests, ...

- in `type Foo a = Bar`, `type` now opens the layout block instead of `=`
- fix effect declaration parser, was expecting `:` to open a layout block
- fix lexer mishandling `}`
- fill in empty pretty print case
- distinguish root from rootFile parser
- add debugLex'' which takes a [Token Lexeme]

parser-typechecker/src/Unison/FileParser.hs

@@ -1,8 +1,9 @@
-{-# Language OverloadedStrings, TupleSections, ScopedTypeVariables #-}
+{-# Language BangPatterns, OverloadedStrings, TupleSections, ScopedTypeVariables #-}
 
 module Unison.FileParser where
 
 import           Control.Applicative
+import           Control.Monad (void)
 import           Control.Monad.Reader (local)
 import           Data.Either (partitionEithers)
 import           Data.List (foldl')
@@ -24,10 +25,15 @@ import Unison.Reference (Reference)
 
 file :: Var v => [(v, Reference)] -> [(v, Reference)] -> P v (UnisonFile v Ann)
 file builtinTerms builtinTypes = do
+  traceRemainingTokens "file before parsing declarations"
+  _ <- openBlock
   (dataDecls, effectDecls) <- declarations
   let env = environmentFor builtinTerms builtinTypes dataDecls effectDecls
   local (`Map.union` UF.constructorLookup env) $ do
-    term <- TermParser.topBlock
+    traceRemainingTokens "file"
+    term <- TermParser.block' "top-level block"
+              (void <$> peekAny) -- we actually opened before the declarations
+              closeBlock
     pure $ UnisonFile (UF.datas env) (UF.effects env) (UF.resolveTerm env term)
 
 declarations :: Var v => P v
@@ -45,10 +51,10 @@ declarations = do
 
 dataDeclaration :: forall v . Var v => P v (v, DataDeclaration' v Ann)
 dataDeclaration = do
-  start <- reserved "type"
+  start <- openBlockWith "type"
   (name, typeArgs) <- (,) <$> prefixVar <*> many prefixVar
   let typeArgVs = L.payload <$> typeArgs
-  eq <- openBlockWith "="
+  eq <- reserved "="
   let
       -- go gives the type of the constructor, given the types of
       -- the constructor arguments, e.g. Cons becomes forall a . a -> List a -> List a
@@ -90,5 +96,5 @@ effectDeclaration = do
   where
     constructor :: Var v => P v (Ann, v, AnnotatedType v Ann)
     constructor = explodeToken <$>
-      prefixVar <* openBlockWith ":" <*> TypeParser.computationType <* closeBlock
+      prefixVar <* reserved ":" <*> TypeParser.computationType
       where explodeToken v t = (ann v, L.payload v, t)

parser-typechecker/src/Unison/Lexer.hs

@@ -71,7 +71,7 @@ instance ShowToken (Token Lexeme) where
       pretty (Numeric n) = n
       pretty (Hash h) = show h
       pretty (Err e) = show e
-      pretty _ = ""
+      pretty t = show t
       pad (Pos line1 col1) (Pos line2 col2) =
         if line1 == line2
         then replicate (col2 - col1) ' '
@@ -99,6 +99,11 @@ top :: Layout -> Column
 top []    = 1
 top ((_,h):_) = h
 
+-- todo: make Layout a NonEmpty
+topBlockName :: Layout -> Maybe BlockName
+topBlockName [] = Nothing
+topBlockName ((name,_):_) = Just name
+
 pop :: [a] -> [a]
 pop = drop 1
 
@@ -176,11 +181,18 @@ lexer scope rem =
     go :: Layout -> Pos -> [Char] -> [Token Lexeme]
     go l pos rem = case rem of
       [] -> popLayout0 l pos []
-      -- delimiters - `:`, `@`, `|`, `=`, and `->`
+      -- we wanted `->` to be able to introduce a layout block
+      -- if the top block name on the layout stack is an `of`
+      -- but the effectBind pattern contains an `->`, and we
+      -- didn't want an `->` within an effectBind to introduce a block.
+      -- case blah of {State.get -> k} -> <layout block>
       '{' : rem ->
         Token (Open "{") pos (inc pos) : pushLayout "{" l (inc pos) rem
       '}' : rem ->
-        Token (Close) pos (inc pos) : pushLayout "{" l (inc pos) rem
+        Token Close pos (inc pos)
+          : Token (Reserved "}") pos (inc pos)
+          : goWhitespace (drop 1 l) (inc pos) rem
+      -- delimiters - `:`, `@`, `|`, `=`, and `->`
       ch : rem | Set.member ch delimiters ->
         Token (Reserved [ch]) pos (inc pos) : goWhitespace l (inc pos) rem
       ':' : c : rem | isSpace c || isAlphaNum c ->
@@ -191,16 +203,21 @@ lexer scope rem =
         Token (Reserved "_") pos (inc pos) : goWhitespace l (inc pos) rem
       '|' : c : rem | isSpace c || isAlphaNum c ->
         Token (Reserved "|") pos (inc pos) : goWhitespace l (inc pos) (c:rem)
-      '=' : c : rem | isSpace c || isAlphaNum c ->
-        Token (Open "=") pos (inc pos) : pushLayout "=" l (inc pos) (c:rem)
+      '=' : (rem @ (c : _)) | isSpace c || isAlphaNum c ->
+        let end = inc pos
+        in case topBlockName l of
+          -- '=' does not open a layout block if within a type declaration
+          Just "type" -> Token (Reserved "=") pos end : goWhitespace l end rem
+          Just _      -> Token (Open "=") pos end : pushLayout "=" l end rem
+          _ -> error "looks like we called topBlockName on an empty layout stack"
       '-' : '>' : (rem @ (c : _))
         | isSpace c || isAlphaNum c || Set.member c delimiters ->
           let end = incBy "->" pos
-          in case l of
-              ("of", _) : _ -> -- `->` opens a block when pattern-matching only
+          in case topBlockName l of
+              Just "of" -> -- `->` opens a block when pattern-matching only
                 Token (Open "->") pos end : pushLayout "->" l end rem
-              _ -> Token (Reserved "->") pos end : goWhitespace l end rem
-
+              Just _ -> Token (Reserved "->") pos end : goWhitespace l end rem
+              _ -> error "looks like we called topBlockName on an empty layout stack"
       -- string literals and backticked identifiers
       '"' : rem -> span' (/= '"') rem $ \(lit, rem) ->
         if rem == [] then
@@ -221,6 +238,9 @@ lexer scope rem =
       (matchKeyword -> Just (kw,rem)) ->
         let end = incBy kw pos in
               case kw of
+                kw@"type" ->
+                  Token (Open kw) pos end
+                    : goWhitespace ((kw, column $ inc pos) : l) end rem
                 kw | Set.member kw layoutKeywords ->
                        Token (Open kw) pos end : pushLayout kw l end rem
                    | otherwise -> Token (Reserved kw) pos end : goWhitespace l end rem
@@ -381,6 +401,19 @@ ex =
        , "  s = 0\n"
        , "  s + 2\n" ]
 
+debugLex'' :: [Token Lexeme] -> String
+debugLex'' lexemes =
+  unlines . W.execWriter . flip S.evalStateT [] . traverse_ f . map payload $ lexemes
+  where
+    f :: Lexeme -> S.StateT String (W.Writer [String]) ()
+    f x = do
+      pad <- S.get
+      S.lift . W.tell $ [pad ++ show x]
+      case x of
+        Open _ -> S.modify (++ "  ")
+        Close -> S.modify (drop 2)
+        _ -> pure ()
+
 debugLex :: String -> String -> IO ()
 debugLex scope = flip S.evalStateT [] . traverse_ f . map payload . lexer scope
   where
@@ -394,16 +427,7 @@ debugLex scope = flip S.evalStateT [] . traverse_ f . map payload . lexer scope
         _ -> pure ()
 
 debugLex' :: String -> String
-debugLex' = unlines . W.execWriter . flip S.evalStateT [] . traverse_ f . map payload . lexer "debugLex"
-  where
-    f :: Lexeme -> S.StateT String (W.Writer [String]) ()
-    f x = do
-      pad <- S.get
-      S.lift . W.tell $ [pad ++ show x]
-      case x of
-        Open _ -> S.modify (++ "  ")
-        Close -> S.modify (drop 2)
-        _ -> pure ()
+debugLex' =  debugLex'' . lexer "debugLex"
 
 span' :: (a -> Bool) -> [a] -> (([a],[a]) -> r) -> r
 span' f a k = k (span f a)

parser-typechecker/src/Unison/Parser.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE BangPatterns, RankNTypes #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -11,6 +11,7 @@ import           Data.Bifunctor (bimap)
 import           Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.Map as Map
 import           Data.Maybe
+import Debug.Trace
 import qualified Data.Set as Set
 import           Data.Text (Text)
 import qualified Data.Text as Text
@@ -139,6 +140,16 @@ instance Annotated a => Annotated (PatternP a) where
 instance (Annotated a, Annotated b) => Annotated (MatchCase a b) where
   ann (MatchCase p _ b) = ann p <> ann b
 
+label :: (Var v, Show a) => String -> P v a -> P v a
+label = P.label
+-- label = P.dbg
+
+traceRemainingTokens :: Var v => String -> P v ()
+traceRemainingTokens label = do
+  remainingTokens <- lookAhead $ many anyToken
+  let _ = trace ("REMAINDER " ++ label ++ ":\n" ++ L.debugLex'' remainingTokens) ()
+  pure ()
+
 mkAnn :: (Annotated a, Annotated b) => a -> b -> Ann
 mkAnn x y = ann x <> ann y
 
@@ -153,11 +164,21 @@ tok f (L.Token a start end) = f (Ann start end) a
 peekAny :: Var v => P v (L.Token L.Lexeme)
 peekAny = P.lookAhead P.anyChar
 
+lookAhead :: Var v => P v a -> P v a
+lookAhead = P.lookAhead
+
+anyToken :: Var v => P v (L.Token L.Lexeme)
+anyToken = P.anyChar
+
 proxy :: Proxy Input
 proxy = Proxy
 
 root :: Var v => P v a -> P v a
-root p = openBlock *> p <* closeBlock <* P.eof
+root p = (openBlock *> p) <* closeBlock <* P.eof
+
+-- |
+rootFile :: Var v => P v a -> P v a
+rootFile p = p <* P.eof
 
 run' :: P v a -> String -> String -> PEnv -> Either (Err v) a
 run' p s name = runParserT p name (Input $ L.lexer name s) -- todo: L.reorder
@@ -215,7 +236,7 @@ backticks = queryToken getBackticks
 
 -- Parse a reserved word
 reserved :: Var v => String -> P v (L.Token String)
-reserved w = P.label w $ queryToken getReserved
+reserved w = label w $ queryToken getReserved
   where getReserved (L.Reserved w') | w == w' = Just w
         getReserved _ = Nothing
 
@@ -231,9 +252,9 @@ sepBy1 :: Var v => P v a -> P v b -> P v [b]
 sepBy1 sep pb = P.sepBy1 pb sep
 
 prefixVar :: Var v => P v (L.Token v)
-prefixVar = fmap (Var.named . Text.pack) <$> P.label "symbol" prefixOp
+prefixVar = fmap (Var.named . Text.pack) <$> label "symbol" prefixOp
   where
-    prefixOp = wordyId <|> P.label "prefix-operator" (P.try (reserved "(" *> symbolyId) <* reserved ")")
+    prefixOp = wordyId <|> label "prefix-operator" (P.try (reserved "(" *> symbolyId) <* reserved ")")
 
 infixVar :: Var v => P v (L.Token v)
 infixVar =

parser-typechecker/src/Unison/Parsers.hs

@@ -30,7 +30,7 @@ parseType s = Parser.run (Parser.root TypeParser.valueType) s
 
 parseFile :: Var v => FilePath -> String -> PEnv -> Either (Parser.Err v) (UnisonFile v Ann)
 parseFile filename s = Parser.run'
-  (Parser.root $ FileParser.file Builtin.builtinTerms Builtin.builtinTypes) s filename
+  (Parser.rootFile $ FileParser.file Builtin.builtinTerms Builtin.builtinTypes) s filename
 
 unsafeParseTerm :: Var v => String -> PEnv -> AnnotatedTerm v Ann
 unsafeParseTerm s = fmap (unsafeGetRightFrom s) . parseTerm $ s

parser-typechecker/src/Unison/TermParser.hs

@@ -9,8 +9,9 @@
 module Unison.TermParser where
 
 import           Control.Applicative
-import           Control.Monad (guard, join, when, void)
+import           Control.Monad (guard, join, when)
 import           Control.Monad.Reader (ask)
+-- import           Debug.Trace
 import           Data.Char (isUpper)
 import           Data.Foldable (asum)
 import           Data.Int (Int64)
@@ -153,20 +154,20 @@ parsePattern = constructor <|> leaf
       Nothing -> customFailure $ UnknownDataConstructor t
 
 lam :: Var v => TermP v -> TermP v
-lam p = P.label "lambda" $ mkLam <$> P.try (some prefixVar <* reserved "->") <*> p
+lam p = label "lambda" $ mkLam <$> P.try (some prefixVar <* reserved "->") <*> p
   where
     mkLam vs b = Term.lam' (ann (head vs) <> ann b) (map L.payload vs) b
 
 letBlock, handle, ifthen, and, or, infixApp :: Var v => TermP v
-letBlock = P.label "let" $ block "let"
+letBlock = label "let" $ block "let"
 
-handle = P.label "handle" $ do
+handle = label "handle" $ do
   t <- reserved "handle"
   handler <- term
   b <- block "in"
   pure $ Term.handle (ann t <> ann b) handler b
 
-ifthen = P.label "if" $ do
+ifthen = label "if" $ do
   c <- block "if"
   t <- block "then"
   f <- block "else"
@@ -199,10 +200,10 @@ termLeaf =
   asum [hashLit, prefixTerm, text, number, boolean,
         tupleOrParenthesizedTerm, blank, vector term]
 
-and = P.label "and" $ f <$> reserved "and" <*> termLeaf <*> termLeaf
+and = label "and" $ f <$> reserved "and" <*> termLeaf <*> termLeaf
   where f kw x y = Term.and (ann kw <> ann y) x y
 
-or = P.label "or" $ f <$> reserved "or" <*> termLeaf <*> termLeaf
+or = label "or" $ f <$> reserved "or" <*> termLeaf <*> termLeaf
   where f kw x y = Term.or (ann kw <> ann y) x y
 
 var :: Var v => L.Token v -> AnnotatedTerm v Ann
@@ -214,10 +215,11 @@ term4 = f <$> some termLeaf
     f (func:args) = Term.apps func ((\a -> (ann func <> ann a, a)) <$> args)
     f [] = error "'some' shouldn't produce an empty list"
 
-infixApp = chainl1 term4 (f <$> fmap var infixVar)
-  where
-    f op lhs rhs =
-      Term.apps op [(ann lhs, lhs), (ann rhs, rhs)]
+infixApp = label "infixApp" $
+  chainl1 term4 (f <$> fmap var infixVar)
+    where
+      f op lhs rhs =
+        Term.apps op [(ann lhs, lhs), (ann rhs, rhs)]
 
 typedecl :: Var v => P v (L.Token v, AnnotatedType v Ann)
 typedecl =
@@ -226,7 +228,7 @@ typedecl =
       <* semi
 
 binding :: forall v. Var v => P v ((Ann, v), AnnotatedTerm v Ann)
-binding = P.label "binding" $ do
+binding = label "binding" $ do
   typ <- optional typedecl
   let infixLhs = do
         (arg1, op) <- P.try ((,) <$> prefixVar <*> infixVar)
@@ -264,10 +266,6 @@ customFailure = P.customFailure
 block :: forall v. Var v => String -> TermP v
 block s = block' s (openBlockWith s) closeBlock
 
--- | if there's no open for us, there won't be a close either
-topBlock :: forall v. Var v => TermP v
-topBlock = block' "top-level block" (void <$> peekAny) (pure ())
-
 block' :: forall v b. Var v => String -> P v (L.Token ()) -> P v b -> TermP v
 block' s openBlock closeBlock = do
     open <- openBlock
@@ -275,7 +273,8 @@ block' s openBlock closeBlock = do
     _ <- closeBlock
     go open statements
   where
-    statement = (Right <$> binding) <|> (Left <$> blockTerm)
+    statement = traceRemainingTokens "statement" *>
+                ((Right <$> binding) <|> (Left <$> blockTerm))
     toBinding (Right ((a, v), e)) = ((a, v), e)
     toBinding (Left e) = ((ann e, Var.named "_"), e)
     go :: L.Token () -> [Either (AnnotatedTerm v Ann) ((Ann, v), AnnotatedTerm v Ann)] -> P v (AnnotatedTerm v Ann)
@@ -310,7 +309,7 @@ number' i u f = fmap go numeric
       | otherwise = u (read <$> num)
 
 tupleOrParenthesizedTerm :: Var v => TermP v
-tupleOrParenthesizedTerm = P.label "tuple" $ tupleOrParenthesized term unit pair
+tupleOrParenthesizedTerm = label "tuple" $ tupleOrParenthesized term unit pair
   where
     pair t1 t2 =
       Term.app (ann t1 <> ann t2)

parser-typechecker/src/Unison/TypeParser.hs

@@ -46,8 +46,9 @@ type2 = app valueTypeLeaf
 -- ex : {State Text, IO} (Sequence Int64)
 effect :: Var v => TypeP v
 effect = do
-  open <- reserved "{"
+  open <- openBlockWith "{"
   es <- sepBy (reserved ",") valueType
+  _ <- closeBlock
   _ <- reserved "}"
   t <- valueTypeLeaf
   pure (Type.effect (Ann (L.start open) (end $ ann t)) es t)

parser-typechecker/tests/Unison/Test/FileParser.hs

@@ -60,7 +60,7 @@ module Unison.Test.FileParser where
       p :: UnisonFile Symbol Ann
       !p = unsafeGetRightFrom s $
              Unison.Parser.run
-               (Parser.root $
+               (Parser.rootFile $
                  file Builtin.builtinTerms Builtin.builtinTypes)
                  s
                  builtins

parser-typechecker/tests/Unison/Test/TermParser.hs

@@ -127,6 +127,11 @@ test1 = scope "termparser" . tests . map parses $
     "  s + 2\n"
    , "and x y"
    , "or x y"
+   , [r|--let r1
+   let r1 : UInt64
+       r1 = case Optional.Some 3 of
+         x -> 1
+       42 |]
    , [r|let
         increment = (+_UInt64) 1
 

parser-typechecker/tests/Unison/Test/Typechecker.hs

@@ -83,6 +83,11 @@ test = scope "typechecker" . tests $
              |r1 = case Optional.Some 3 of
              |  x -> 1
              |() |]
+  , checks [r|--r0
+             |r1 : UInt64
+             |r1 = case Optional.Some 3 of
+             |  x -> 1
+             |42|]
   , checks [r|--r2
              |type Optional a = None | Some a
              |r2 : UInt64