From dd872404d97b8a0735ae7a2f47eff38d28b9311c Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Thu, 27 Jun 2024 10:49:33 +0100 Subject: [PATCH 01/12] refactor: Add bracketing; kill withFC --- brat/Brat/Error.hs | 24 ++ brat/Brat/FC.hs | 6 + brat/Brat/Lexer/Bracketed.hs | 78 ++++++ brat/Brat/Parser.hs | 522 +++++++++++++++++++++-------------- brat/Data/Bracket.hs | 13 + brat/brat.cabal | 4 +- 6 files changed, 445 insertions(+), 202 deletions(-) create mode 100644 brat/Brat/Lexer/Bracketed.hs create mode 100644 brat/Data/Bracket.hs diff --git a/brat/Brat/Error.hs b/brat/Brat/Error.hs index 869c5002..aefb26a6 100644 --- a/brat/Brat/Error.hs +++ b/brat/Brat/Error.hs @@ -1,5 +1,6 @@ module Brat.Error (ParseError(..) ,LengthConstraintF(..), LengthConstraint + ,BracketErrMsg(..) ,ErrorMsg(..) ,Error(..), showError ,SrcErr(..) @@ -9,6 +10,7 @@ module Brat.Error (ParseError(..) ) where import Brat.FC +import Data.Bracket import Data.List (intercalate) import System.Exit @@ -25,6 +27,27 @@ instance Show a => Show (LengthConstraintF a) where type LengthConstraint = LengthConstraintF Int +data BracketErrMsg + = EOFInBracket BracketType -- FC points to the open bracket + | OpenCloseMismatch (FC, BracketType) BracketType -- Closer FC is in the `Err` fc + | UnexpectedClose BracketType + +instance Show BracketErrMsg where + show (EOFInBracket b) = "File ended before this " ++ showOpen b ++ " was closed" + show (OpenCloseMismatch (openFC, bOpen) bClose) = unwords ["This" + ,showClose bClose + ,"doesn't match the" + ,showOpen bOpen + ,"at" + ,show openFC + ] + show (UnexpectedClose b) = unwords ["There is no" + ,showOpen b + ,"for this" + ,showClose b + ,"to close" + ] + data ErrorMsg = TypeErr String -- Term, Expected type, Actual type @@ -80,6 +103,7 @@ data ErrorMsg | WrongModeForType String -- TODO: Add file context here | CompilingHoles [String] + | BracketErr BracketErrMsg instance Show ErrorMsg where show (TypeErr x) = "Type error: " ++ x diff --git a/brat/Brat/FC.hs b/brat/Brat/FC.hs index ab50a96f..a58940c3 100644 --- a/brat/Brat/FC.hs +++ b/brat/Brat/FC.hs @@ -31,3 +31,9 @@ fcOf (WC fc _) = fc -- TODO: Remove this dummyFC :: a -> WC a dummyFC = WC (FC (Pos 0 0) (Pos 0 0)) + +spanFC :: FC -> FC -> FC +spanFC afc bfc = FC (start afc) (end bfc) + +spanFCOf :: WC a -> WC b -> FC +spanFCOf (WC afc _) (WC bfc _) = FC (start afc) (end bfc) diff --git a/brat/Brat/Lexer/Bracketed.hs b/brat/Brat/Lexer/Bracketed.hs new file mode 100644 index 00000000..b23cfa6c --- /dev/null +++ b/brat/Brat/Lexer/Bracketed.hs @@ -0,0 +1,78 @@ +module Brat.Lexer.Bracketed (BToken(..), brackets) where + +import Data.Bracket +import Brat.Error (BracketErrMsg(..), Error(Err), ErrorMsg(..)) +import Brat.FC +import Brat.Lexer.Token +import Bwd + +import Text.Megaparsec (VisualStream(..)) + +opener :: Tok -> Maybe BracketType +opener LParen = Just Paren +opener LBracket = Just Bracket +opener LBrace = Just Brace +opener _ = Nothing + +closer :: Tok -> Maybe BracketType +closer RParen = Just Paren +closer RBracket = Just Bracket +closer RBrace = Just Brace +closer _ = Nothing + +-- Well bracketed tokens +data BToken + = Bracketed FC BracketType [BToken] + | FlatTok Token + deriving (Eq, Ord) + +tokLen :: BToken -> Int +tokLen (FlatTok tok) = length (show tok) +tokLen (Bracketed _ _ bs) = sum (tokLen <$> bs) + 2 + +instance Show BToken where + show (FlatTok t) = show t + show (Bracketed _ b ts) = showOpen b ++ show ts ++ showClose b + +instance VisualStream [BToken] where + showTokens _ ts = concatMap show ts + tokensLength _ = sum . fmap tokLen + +eofErr :: FC -> BracketType -> Error +eofErr fc b = Err (Just fc) (BracketErr (EOFInBracket b)) + +openCloseMismatchErr :: (FC, BracketType) -> (FC, BracketType) -> Error +openCloseMismatchErr open (fcClose, bClose) + = Err (Just fcClose) (BracketErr (OpenCloseMismatch open bClose)) + +unexpectedCloseErr :: FC -> BracketType -> Error +unexpectedCloseErr fc b = Err (Just fc) (BracketErr (UnexpectedClose b)) + +within :: (FC, BracketType) -> Bwd BToken -> [Token] -> Either Error (FC, Bwd BToken, [Token]) +within (openFC, b) _ [] = Left $ eofErr openFC b +within ctx@(openFC, b) acc (t:ts) + | Just b' <- closer (_tok t) = if b' == b + then pure (fc t, acc, ts) + else Left $ openCloseMismatchErr ctx (fc t, b') + | Just b' <- opener (_tok t) = do + (closeFC, xs, ts) <- within (fc t, b') B0 ts + let fc = bracketFC openFC closeFC + within ctx (acc :< Bracketed fc b' (xs <>> [])) ts + | otherwise = within ctx (acc :< FlatTok t) ts + +bracketFC openFC closeFC = FC (start openFC) (end closeFC) + +brackets :: [Token] -> Either Error [BToken] +brackets ts = bracketsWorker B0 ts >>= \case + (tokz, []) -> pure (tokz <>> []) + _ -> error "Incomplete bracket parse" -- Shouldn't happen + where + bracketsWorker :: Bwd BToken -> [Token] -> Either Error (Bwd BToken, [Token]) + bracketsWorker acc [] = pure (acc, []) + bracketsWorker acc (t:ts) + | Just b <- opener (_tok t) = do + (closeFC, xs, ts) <- within (fc t, b) B0 ts + let enclosingFC = bracketFC (fc t) closeFC + bracketsWorker (acc :< Bracketed enclosingFC b (xs <>> [])) ts + | Just b <- closer (_tok t) = Left $ unexpectedCloseErr (fc t) b + | otherwise = bracketsWorker (acc :< FlatTok t) ts diff --git a/brat/Brat/Parser.hs b/brat/Brat/Parser.hs index f75ac70b..050b3900 100644 --- a/brat/Brat/Parser.hs +++ b/brat/Brat/Parser.hs @@ -4,6 +4,7 @@ import Brat.Constructors.Patterns import Brat.Error import Brat.FC import Brat.Lexer (lex) +import Brat.Lexer.Bracketed (BToken(..), brackets) import Brat.Lexer.Token (Keyword(..), Token(..), Tok(..)) import qualified Brat.Lexer.Token as Lexer import Brat.Syntax.Abstractor @@ -15,16 +16,18 @@ import Brat.Syntax.Raw import Brat.Syntax.Simple import Brat.UserName ( plain, UserName(..) ) import Brat.Elaborator +import Data.Bracket import Util ((**^)) import Control.Monad (void) import Control.Monad.State (State, evalState, runState, get, put) import Data.Bifunctor +import Data.Either.HT (maybeRight) +import Data.Foldable (msum) +import Data.Functor (($>), (<&>)) import Data.List (intercalate) import Data.List.HT (chop, viewR) import Data.List.NonEmpty (toList, NonEmpty(..), nonEmpty) -import Data.Foldable (msum) -import Data.Functor (($>), (<&>)) import Data.Maybe (fromJust, maybeToList, fromMaybe) import Data.Set (empty) import Prelude hiding (lex, round) @@ -34,83 +37,112 @@ import qualified Text.Megaparsec as M (parse) newtype CustomError = Custom String deriving (Eq, Ord) -- the State is the (FC) Position of the last token *consumed* -type Parser a = ParsecT CustomError [Token] (State Pos) a +type Parser a = ParsecT CustomError [BToken] (State Pos) a -parse :: Parser a -> String -> [Token] -> Either (ParseErrorBundle [Token] CustomError) a +parse :: Parser a -> String -> [BToken] -> Either (ParseErrorBundle [BToken] CustomError) a parse p s tks = evalState (runParserT p s tks) (Pos 0 0) instance ShowErrorComponent CustomError where showErrorComponent (Custom s) = s - +{- withFC :: Parser a -> Parser (WC a) withFC p = do - (Token (FC start _) _) <- nextToken + fc <- nextToken <&> \case + Bracketed fc _ _ -> fc + FlatTok (Token fc _) -> fc thing <- p end <- get - pure (WC (FC start end) thing) + pure (WC (FC (start fc) end) thing) +-} +withFC :: Parser a -> Parser (WC a) +withFC p = undefined -nextToken :: Parser Token +nextToken :: Parser BToken nextToken = lookAhead $ token Just empty +matchTokFC :: (Tok -> Maybe a) -> Parser (WC a) +matchTokFC f = token (matchTok f) empty + token0 :: (Tok -> Maybe a) -> Parser a token0 f = do - (fc, r) <- token (\(Token fc t) -> (fc,) <$> f t) empty + WC fc r <- token (matchTok f) empty -- token matched condition f put (end fc) pure r +matchFC :: Tok -> Parser (WC ()) +matchFC tok = label (show tok) $ token (matchTok f) empty + where + f :: Tok -> Maybe () + f t | t == tok = Just () + | otherwise = Nothing + match :: Tok -> Parser () -match tok = label (show tok) $ token0 $ \t -> if t == tok then Just () else Nothing +match = fmap unWC . matchFC + +matchTok :: (Tok -> Maybe a) -> BToken -> Maybe (WC a) +matchTok f (FlatTok (Token fc t)) = (WC fc) <$> f t +-- Returns the FC at the beginning of the token +matchTok f (Bracketed _ Paren [t]) = matchTok f t +matchTok _ _ = Nothing + +kmatchFC :: Keyword -> Parser (WC ()) +kmatchFC = matchFC . K kmatch :: Keyword -> Parser () kmatch = match . K -matchString :: String -> Parser () -matchString s = ident $ \x -> if x == s then Just () else Nothing +matchString :: String -> Parser (WC ()) +matchString s = label (show s) $ matchTokFC $ \case + Ident ident | ident == s -> Just () + _ -> Nothing + ident :: (String -> Maybe a) -> Parser a ident f = label "identifier" $ token0 $ \case Ident str -> f str _ -> Nothing -hole :: Parser String -hole = label "hole" $ token0 $ \case +hole :: Parser (WC String) +hole = label "hole" $ matchTokFC $ \case Hole h -> Just h _ -> Nothing -simpleName :: Parser String -simpleName = token0 $ \case +simpleName :: Parser (WC String) +simpleName = matchTokFC $ \case Ident str -> Just str _ -> Nothing -qualifiedName :: Parser UserName -qualifiedName = ( "qualified name") . token0 $ \case +qualifiedName :: Parser (WC UserName) +qualifiedName = label "qualified name" $ matchTokFC $ \case QualifiedId prefix str -> Just (PrefixName (toList prefix) str) _ -> Nothing -userName :: Parser UserName -userName = ( "name") $ try qualifiedName <|> (PrefixName [] <$> simpleName) - -round :: Parser a -> Parser a -round p = label "(...)" $ match LParen *> p <* match RParen +userName :: Parser (WC UserName) +userName = ( "name") $ try qualifiedName <|> (fmap (PrefixName []) <$> simpleName) -square :: Parser a -> Parser a -square p = label "[...]" $ match LBracket *> p <* match RBracket +inBrackets :: BracketType -> Parser a -> Parser a +inBrackets b p = unWC <$> inBracketsFC b p -curly :: Parser a -> Parser a -curly p = label "{...}" $ match LBrace *> p <* match RBrace +inBracketsFC :: BracketType -> Parser a -> Parser (WC a) +inBracketsFC b p = label lbl $ flip token empty $ \case + Bracketed fc b' xs | b == b' -> (WC fc) <$> maybeRight (parse p "" xs) + _ -> Nothing + where + lbl = showOpen b ++ "..." ++ showClose b -inLet :: Parser a -> Parser a -inLet p = label "let ... in" $ kmatch KLet *> p <* kmatch KIn +-- f :: Parser a -> BToken -> Maybe (WC a) +-- f p (Bracketed fc b' xs) | b == b' = (WC fc) <$> parseMaybe p xs +-- f _ _ = Nothing -number :: Parser Int -number = label "nat" $ token0 $ \case +number :: Parser (WC Int) +number = label "nat" $ matchTokFC $ \case Number n -> Just n _ -> Nothing -float :: Parser Double -float = label "float" $ token0 $ \case +float :: Parser (WC Double) +float = label "float" $ matchTokFC $ \case FloatLit x -> Just x _ -> Nothing @@ -119,21 +151,21 @@ comment = label "Comment" $ token0 $ \case Comment _ -> Just () _ -> Nothing -string :: Parser String -string = token0 $ \case +string :: Parser (WC String) +string = matchTokFC $ \case Quoted txt -> Just txt _ -> Nothing -var :: Parser Flat -var = FVar <$> userName +var :: Parser (WC Flat) +var = fmap FVar <$> userName +port :: Parser (WC String) port = simpleName comma :: Parser (WC Flat -> WC Flat -> WC Flat) comma = token0 $ \case Comma -> Just $ \a b -> - let fc = FC (start (fcOf a)) (end (fcOf b)) - in WC fc (FJuxt a b) + WC (spanFCOf a b) (FJuxt a b) _ -> Nothing arith :: ArithOp -> Parser (WC Flat -> WC Flat -> WC Flat) @@ -158,109 +190,151 @@ chainl1 px pf = px >>= rest Just (f, y) -> rest (f x y) Nothing -> pure x -abstractor :: Parser Abstractor +abstractor :: Parser (WC Abstractor) abstractor = do ps <- many (try portPull) - xs <- binding `chainl1` try binderComma - pure $ if null ps then xs else APull ps xs + abs <- binders + pure $ if null ps + then abs + else let fc = spanFCOf (head ps) abs in WC fc (APull (unWC <$> ps) (unWC abs)) where - binding :: Parser Abstractor - binding = (try (APat <$> bigPat) <|> round abstractor) - vecPat = square (binding `sepBy` (match Comma)) >>= list2Cons + -- Minus port pulling + binders = try (joinBinders <$> ((:|) <$> binding <*> (many (match Comma *> binding)))) + where + joinBinders xs = let (abs, startFC, endFC) = joinBindersAux xs in WC (spanFC startFC endFC) abs + + joinBindersAux (WC fc x :| []) = (x, fc, fc) + joinBindersAux (WC fc x :| (y:ys)) = let (abs, startFC, endFC) = joinBindersAux (y :| ys) in + (x :||: abs, fc, endFC) + + binding :: Parser (WC Abstractor) + binding = try (fmap APat <$> bigPat) <|> inBrackets Paren abstractor + + vecPat :: Parser (WC Pattern) + vecPat = do + WC fc elems <- inBracketsFC Bracket ((unWC <$> binding) `sepBy` (match Comma)) + WC fc <$> list2Cons elems list2Cons :: [Abstractor] -> Parser Pattern list2Cons [] = pure PNil list2Cons (APat x:xs) = PCons x <$> (list2Cons xs) list2Cons _ = customFailure (Custom "Internal error list2Cons") - portPull = simpleName <* match PortColon + portPull = port <* match PortColon - binderComma :: Parser (Abstractor -> Abstractor -> Abstractor) binderComma = match Comma $> (:||:) -- For simplicity, we can say for now that all of our infix vector patterns have -- the same precedence and associate to the right - bigPat :: Parser Pattern + bigPat :: Parser (WC Pattern) bigPat = do - lhs <- weePat + WC lfc lhs <- weePat rest <- optional $ PCons lhs <$ match Cons <|> PSnoc lhs <$ match Snoc <|> PConcatEqEven lhs <$ match ConcatEqEven - <|> PConcatEqOdd lhs <$ match ConcatEqOddL <*> weePat <* match ConcatEqOddR + <|> PConcatEqOdd lhs <$ match ConcatEqOddL <*> (unWC <$> weePat) <* match ConcatEqOddR <|> PRiffle lhs <$ match Riffle case rest of - Just f -> f <$> bigPat - Nothing -> pure lhs + Just f -> do + WC rfc rhs <- bigPat + pure $ WC (spanFC lfc rfc) (f rhs) + Nothing -> pure (WC lfc lhs) - weePat :: Parser Pattern + weePat :: Parser (WC Pattern) weePat = try vecPat - <|> (match Underscore $> DontCare) - <|> try (Lit <$> simpleTerm) - <|> try constructorsWithArgs + <|> (fmap (const DontCare) <$> matchFC Underscore) + <|> try (fmap Lit <$> simpleTerm) + <|> try (constructorsWithArgs) <|> try nullaryConstructors - <|> (Bind <$> simpleName) - <|> (round bigPat) + <|> (fmap Bind <$> simpleName) + <|> (inBrackets Paren bigPat) where - constructor :: Parser Abstractor -> String -> Parser Pattern - constructor pabs c = do - matchString c - PCon (plain c) <$> pabs + nullaryConstructor c = do + WC fc () <- matchString c + pure $ WC fc (PCon (plain c) AEmpty) - nullaryConstructors = msum (try . constructor (pure AEmpty) <$> ["zero", "nil", "none", "true", "false"]) + nullaryConstructors = msum (try . nullaryConstructor <$> ["zero", "nil", "none", "true", "false"]) - constructorsWithArgs = msum (try . constructor (round abstractor) <$> ["succ", "doub", "cons", "some"]) + constructorWithArgs :: String -> Parser (WC Pattern) + constructorWithArgs c = do + str <- matchString c + abs <- inBracketsFC Paren (unWC <$> abstractor) + pure $ WC (spanFCOf str abs) (PCon (plain c) (unWC abs)) -simpleTerm :: Parser SimpleTerm -simpleTerm = - (Text <$> string "string") - <|> try (Float . negate <$> (match Minus *> float) "float") - <|> try (Float <$> float "float") - <|> (Num . negate <$> (match Minus *> number) "nat") - <|> (Num <$> number "nat") + constructorsWithArgs = msum (try . constructorWithArgs <$> ["succ", "doub", "cons", "some"]) -outputs :: Parser [RawIO] -outputs = rawIO (unWC <$> vtype) +simpleTerm :: Parser (WC SimpleTerm) +simpleTerm = + (fmap Text <$> string "string") + <|> try (maybeNegative Float float "float") + <|> maybeNegative Num number "nat" -typekind :: Parser TypeKind -typekind = try (match Hash $> Nat) <|> kindHelper Lexer.Dollar Syntax.Dollar <|> kindHelper Asterisk Star where - kindHelper tok c = do - match tok - margs <- optional (round row) - pure $ c (concat $ maybeToList margs) - - row = (`sepBy` match Comma) $ do - p <- port + maybeNegative :: Num a => (a -> SimpleTerm) -> Parser (WC a) + -> Parser (WC SimpleTerm) + maybeNegative f p = do + minusFC <- fmap fcOf <$> optional (matchFC Minus) + WC nFC n <- p + pure $ case minusFC of + Nothing -> WC nFC (f n) + Just minusFC -> WC (spanFC minusFC nFC) (f (negate n)) + +typekind :: Parser (WC TypeKind) +typekind = try (fmap (const Nat) <$> matchFC Hash) <|> kindHelper Lexer.Dollar Syntax.Dollar <|> kindHelper Asterisk Star + where + kindHelper tok con = do + WC conFC () <- matchFC tok + margs <- optional (inBracketsFC Paren row) + let (fc, args) = maybe + (conFC, []) + (\(WC argsFC args) -> (FC (start conFC) (end argsFC), args)) + margs + pure $ WC fc (con args) + + + row :: Parser [(PortName, TypeKind)] + row = (`sepBy` match Comma) $ do + p <- unWC <$> port match TypeColon - (p,) <$> typekind + ((p,) . unWC) <$> typekind vtype :: Parser (WC (Raw Chk Noun)) vtype = cnoun (expr' PApp) -- Parse a row of type and kind parameters -- N.B. kinds must be named -rawIO :: Parser ty -> Parser (TypeRow (KindOr ty)) -rawIO tyP = rowElem `sepBy` void (try comma) +-- TODO: Update definitions so we can retain the FC info, instead of forgetting it +rawIOFC :: Parser (TypeRow (WC (KindOr RawVType))) +rawIOFC = rowElem `sepBy` void (try comma) where - rowElem = try (round rowElem') <|> rowElem' + rowElem :: Parser (TypeRowElem (WC (KindOr RawVType))) + rowElem = try (inBrackets Paren rowElem') <|> rowElem' - rowElem' = try namedKind <|> try namedType <|> (Anon . Right <$> tyP) + rowElem' :: Parser (TypeRowElem (WC (KindOr RawVType))) + rowElem' = try namedKind <|> try namedType <|> ((\(WC tyFC ty) -> Anon (WC tyFC (Right ty))) <$> vtype) + namedType :: Parser (TypeRowElem (WC (KindOr RawVType))) namedType = do - p <- port + WC pFC p <- port match TypeColon - Named p . Right <$> tyP + WC tyFC ty <- vtype + pure (Named p (WC (spanFC pFC tyFC) (Right ty))) + namedKind :: Parser (TypeRowElem (WC (KindOr ty))) namedKind = do - p <- port + WC pFC p <- port match TypeColon - Named p . Left <$> typekind + WC kFC k <- typekind + pure (Named p (WC (spanFC pFC kFC) (Left k))) + +rawIO :: Parser [RawIO] +rawIO = fmap (fmap unWC) <$> rawIOFC rawIO' :: Parser ty -> Parser (TypeRow ty) rawIO' tyP = rowElem `sepBy` void (try comma) where - rowElem = try (round rowElem') <|> rowElem' + rowElem = try (inBrackets Paren rowElem') <|> rowElem' -- Look out if we can find ::. If not, backtrack and just do tyP. -- For example, if we get an invalid primitive type (e.g. `Int` in @@ -268,33 +342,44 @@ rawIO' tyP = rowElem `sepBy` void (try comma) -- error message from tyP instead of complaining about a missing :: -- (since the invalid type can be parsed as a port name) rowElem' = optional (try $ port <* match TypeColon) >>= \case - Just p -> Named p <$> tyP + Just (WC _ p) -> Named p <$> tyP Nothing -> Anon <$> tyP -functionType :: Parser RawVType -functionType = try (RFn <$> ctype) <|> (RKernel <$> kernel) +spanningFC :: TypeRow (WC ty) -> Parser (WC (TypeRow ty)) +spanningFC [] = customFailure (Custom "Internal: RawIO shouldn't be empty") +spanningFC [x] = pure (WC (fcOf $ forgetPortName x) [unWC <$> x]) +spanningFC (x:xs) = pure (WC (spanFC (fcOf $ forgetPortName x) (fcOf . forgetPortName $ last xs)) (fmap unWC <$> (x:xs))) + +rawIOWithSpanFC :: Parser (WC [RawIO]) +rawIOWithSpanFC = spanningFC =<< rawIOFC + +functionType :: Parser (WC RawVType) +functionType = try (fmap RFn <$> ctype) <|> (fmap RKernel <$> kernel) where - ctype :: Parser RawCType + ctype :: Parser (WC RawCType) ctype = do - ins <- round $ rawIO (unWC <$> vtype) + WC startFC ins <- inBracketsFC Paren $ rawIO match Arrow - outs <- rawIO (unWC <$> vtype) - pure (ins :-> outs) + WC endFC outs <- rawIOWithSpanFC + pure (WC (spanFC startFC endFC) (ins :-> outs)) - kernel :: Parser RawKType + kernel :: Parser (WC RawKType) kernel = do - ins <- round $ rawIO' (unWC <$> vtype) + WC startFC ins <- inBracketsFC Paren $ rawIO' (unWC <$> vtype) match Lolly - outs <- rawIO' (unWC <$> vtype) - pure (ins :-> outs) + WC endFC outs <- spanningFC =<< rawIO' vtype + pure (WC (spanFC startFC endFC) (ins :-> outs)) -vec :: Parser Flat -vec = (\(WC fc x) -> unWC $ vec2Cons (end fc) x) <$> withFC (square elems) +vec :: Parser (WC Flat) +vec = (\(WC fc x) -> vec2Cons (end fc) x) <$> (inBracketsFC Bracket elems) where elems = (element `chainl1` (try vecComma)) <|> pure [] vecComma = match Comma $> (++) - element = (:[]) <$> withFC (expr' (succ PJuxtPull)) + + element :: Parser [WC Flat] + element = (:[]) <$> (expr' (succ PJuxtPull)) + mkNil fc = FCon (plain "nil") (WC fc FEmpty) vec2Cons :: Pos -> [WC Flat] -> WC Flat @@ -306,34 +391,39 @@ vec = (\(WC fc x) -> unWC $ vec2Cons (end fc) x) <$> withFC (square elems) WC fc $ FCon (plain "cons") (WC fc (FJuxt x (vec2Cons end xs))) -cthunk :: Parser Flat +cthunk :: Parser (WC Flat) cthunk = try bratFn <|> try kernel <|> thunk where - bratFn = curly $ do - ss <- rawIO (unWC <$> vtype) + bratFn = inBracketsFC Brace $ do + ss <- rawIO match Arrow - ts <- rawIO (unWC <$> vtype) + ts <- rawIO pure $ FFn (ss :-> ts) - kernel = curly $ do + kernel = inBracketsFC Brace $ do ss <- rawIO' (unWC <$> vtype) match Lolly ts <- rawIO' (unWC <$> vtype) pure $ FKernel (ss :-> ts) + -- Explicit lambda or brace section - thunk = FThunk <$> withFC (curly braceSection) + thunk :: Parser (WC Flat) + thunk = do + WC bracesFC th <- inBracketsFC Brace braceSection + pure (WC bracesFC (FThunk th)) + braceSection :: Parser (WC Flat) braceSection = do - e <- withFC expr + e <- expr -- Replace underscores with invented variable names '1, '2, '3 ... -- which are illegal for the user to use as variables case runState (replaceU e) 0 of - (e', 0) -> pure (unWC e') + (e', 0) -> pure e' -- If we don't have a `=>` at the start of a kernel, it could (and should) -- be a verb, not the RHS of a no-arg lambda - (e', n) -> let abs = braceSectionAbstractor [0..n-1] in - pure $ FLambda (((WC (fcOf e) abs), e') :| []) -- TODO: Which FC to use for the abstracor? + (e', n) -> let abs = braceSectionAbstractor [0..n-1] + in pure $ WC (fcOf e) $ FLambda (((WC (fcOf e) abs), e') :| []) replaceU :: WC Flat -> State Int (WC Flat) replaceU (WC fc x) = WC fc <$> replaceU' x @@ -360,6 +450,21 @@ cthunk = try bratFn <|> try kernel <|> thunk (\x -> APat (Bind ('\'': show x))) <$> ns +-- Expressions that can occur inside juxtapositions and vectors (i.e. everything with a higher +-- precedence than juxtaposition). Precedence table (loosest to tightest binding): +atomExpr :: Parser (WC Flat) +atomExpr = simpleExpr <|> inBrackets Paren expr + where + simpleExpr :: Parser (WC Flat) + simpleExpr = fmap FHole <$> hole + <|> try (fmap FSimple <$> simpleTerm) + <|> vec + <|> cthunk + <|> fmap (const FPass) <$> matchFC DotDot + <|> var + <|> fmap (const FUnderscore) <$> matchFC Underscore + + {- Infix operator precedence table (See Brat.Syntax.Common.Precedence) (loosest to tightest binding): => @@ -375,12 +480,12 @@ cthunk = try bratFn <|> try kernel <|> thunk -} expr = expr' minBound -expr' :: Precedence -> Parser Flat +expr' :: Precedence -> Parser (WC Flat) expr' p = choice $ (try . getParser <$> enumFrom p) ++ [atomExpr] where - getParser :: Precedence -> Parser Flat + getParser :: Precedence -> Parser (WC Flat) getParser = \case - PLetIn -> letin "let ... in" + PLetIn -> letIn "let ... in" PLambda -> lambda "lambda" PInto -> (emptyInto <|> into) "into" PComp -> composition "composition" @@ -393,116 +498,122 @@ expr' p = choice $ (try . getParser <$> enumFrom p) ++ [atomExpr] PApp -> application "application" -- Take the precedence level and return a parser for everything with a higher precedence - subExpr :: Precedence -> Parser Flat + subExpr :: Precedence -> Parser (WC Flat) subExpr PApp = atomExpr subExpr p = choice $ (try . getParser <$> enumFrom (succ p)) ++ [atomExpr] -- Top level parser, looks for vector constructors with `atomExpr'`s as their -- elements. - vectorBuild :: Parser Flat + vectorBuild :: Parser (WC Flat) vectorBuild = do - lhs <- withFC (subExpr PVecPat) + lhs <- subExpr PVecPat rest <- optional $ (CCons, [lhs]) <$ match Cons <|> (CSnoc, [lhs]) <$ match Snoc <|> (CConcatEqEven, [lhs]) <$ match ConcatEqEven - <|> (CConcatEqOdd,) . ([lhs] ++) . (:[]) <$ match ConcatEqOddL <*> withFC (subExpr (succ PVecPat)) <* match ConcatEqOddR - <|> (CRiffle, [lhs]) <$ match Riffle + <|> (CConcatEqOdd,) . ([lhs] ++) . (:[]) <$ match ConcatEqOddL <*> subExpr (succ PVecPat) <* match ConcatEqOddR + <|> (CRiffle, [lhs]) <$ matchFC Riffle case rest of Just (c, args) -> do - rhs <- withFC vectorBuild - pure (FCon c (mkJuxt (args ++ [rhs]))) - Nothing -> pure (unWC lhs) + rhs <- vectorBuild + pure (WC (spanFCOf lhs rhs) (FCon c (mkJuxt (args ++ [rhs])))) + Nothing -> pure lhs + where + matchConstructor lhs = matchFC Cons + mkJuxt :: [WC Flat] -> WC Flat mkJuxt [x] = x mkJuxt (x:xs) = let rest = mkJuxt xs in WC (FC (start (fcOf x)) (end (fcOf rest))) (FJuxt x rest) - application = withFC atomExpr >>= applied + application :: Parser (WC Flat) + application = atomExpr >>= applied where - applied :: WC Flat -> Parser Flat + applied :: WC Flat -> Parser (WC Flat) applied f = do - first <- withFC (round $ expr <|> pure FEmpty) - let one = FApp f first - let combinedFC = FC (start (fcOf f)) (end (fcOf first)) - optional (applied $ WC combinedFC one) <&> fromMaybe one + first <- inBracketsFC Paren $ (unWC <$> expr) <|> pure FEmpty + let one = WC (spanFCOf f first) (FApp f first) + optional (applied $ one) <&> fromMaybe one + + binary :: [ArithOp] -> Precedence -> Parser (WC Flat) + binary ops lvl = subExpr lvl `chainl1` choice (try . arith <$> ops) - binary ops lvl = unWC <$> withFC (subExpr lvl) `chainl1` choice (try . arith <$> ops) addSub = binary [Add, Sub] PAddSub mulDiv = binary [Mul, Div] PMulDiv pow = binary [Pow] PPow - annotation = FAnnotation <$> withFC (subExpr PAnn) <* match TypeColon <*> rawIO (unWC <$> vtype) - - letin = do - (lhs,rhs) <- inLet $ do - abs <- withFC abstractor + annotation :: Parser (WC Flat) + annotation = do + tm <- subExpr PAnn + colon <- matchFC TypeColon + tys <- rawIO + pure $ WC (spanFCOf tm colon) (FAnnotation tm tys) + + letIn :: Parser (WC Flat) + letIn = label "let ... in" $ do + let_ <- kmatchFC KLet + (lhs, rhs) <- letInBinding + kmatch KIn + body <- expr + pure (WC (spanFCOf let_ body) (FLetIn lhs rhs body)) + where + letInBinding = do + abs <- abstractor match Equal - thing <- withFC expr + thing <- expr pure (abs, thing) - body <- withFC expr - pure $ FLetIn lhs rhs body -- Sequence of `abstractor => expr` separated by `|` + lambda :: Parser (WC Flat) lambda = do firstClause <- lambdaClause otherClauses <- many (match Pipe >> lambdaClause) - pure (FLambda (firstClause :| otherClauses)) + let endPos = case otherClauses of + [] -> end (fcOf (snd firstClause)) + let fc = FC (start (fcOf (fst firstClause))) endPos + pure (WC fc (FLambda (firstClause :| otherClauses))) -- A single `abstractor => expr` + lambdaClause :: Parser (WC Abstractor, WC Flat) lambdaClause = do - abs <- withFC (try abstractor <|> pure AEmpty) - match FatArrow - body <- withFC expr + mabs <- (try (Right <$> abstractor) <|> pure (Left AEmpty)) + WC arrowFC () <- matchFC FatArrow + let abs = either (WC arrowFC) id mabs + body <- expr pure (abs, body) + emptyInto :: Parser (WC Flat) emptyInto = do -- It's tricky to come up with an FC for empty syntax - WC lhs () <- withFC $ match Into - rhs <- withFC (subExpr (pred PInto)) - pure $ FInto (WC lhs FEmpty) rhs + WC lhs () <- matchFC Into + rhs <- subExpr (pred PInto) + pure $ WC (spanFC lhs (fcOf rhs)) $ FInto (WC lhs FEmpty) rhs - into = unWC <$> withFC (subExpr PInto) `chainl1` (divider Into FInto) + into :: Parser (WC Flat) + into = subExpr PInto `chainl1` (divider Into FInto) - composition = unWC <$> withFC (subExpr PComp) `chainl1` (divider Semicolon FCompose) + composition :: Parser (WC Flat) + composition = subExpr PComp `chainl1` divider Semicolon FCompose divider :: Tok -> (WC Flat -> WC Flat -> Flat) -> Parser (WC Flat -> WC Flat -> WC Flat) divider tok f = token0 $ \case t | t == tok -> Just $ \a b -> - let fc = FC (start (fcOf a)) (end (fcOf b)) - in WC fc (f a b) + WC (spanFCOf a b) (f a b) _ -> Nothing + pullAndJuxt = pull <|> juxt - pullAndJuxt = do - ports <- many (try (port <* match PortColon)) - case ports of - [] -> juxtRhsWithPull - _ -> FPull ports <$> withFC juxtRhsWithPull - where - -- Juxtaposition here includes port pulling, since they have the same precedence - juxtRhsWithPull = do - expr <- withFC (subExpr PJuxtPull) - rest <- optional (match Comma *> withFC pullAndJuxt) - pure $ case rest of - Nothing -> unWC expr - Just rest -> FJuxt expr rest - - -- Expressions which don't contain juxtaposition or operators - atomExpr :: Parser Flat - atomExpr = simpleExpr <|> round expr - where - simpleExpr = FHole <$> hole - <|> try (FSimple <$> simpleTerm) - <|> vec - <|> cthunk - <|> try (match DotDot $> FPass) - <|> var - <|> match Underscore $> FUnderscore + pull :: Parser (WC Flat) + pull = do + ports <- some (try (port <* match PortColon)) + body <- subExpr PJuxtPull + pure $ WC (spanFCOf (head ports) body) (FPull (unWC <$> ports) body) + juxt :: Parser (WC Flat) + juxt = (try pull <|> subExpr PJuxtPull) `chainl1` try comma -cnoun :: Parser Flat -> Parser (WC (Raw 'Chk 'Noun)) +cnoun :: Parser (WC Flat) -> Parser (WC (Raw 'Chk 'Noun)) cnoun pe = do - e <- withFC pe + e <- pe case elaborate e of Left err -> fail (showError err) Right (SomeRaw r) -> case do @@ -517,9 +628,9 @@ cnoun pe = do decl :: Parser FDecl decl = do (WC fc (nm, ty, body)) <- withFC (do - nm <- simpleName - ty <- try (functionType <&> \ty -> [Named "thunk" (Right ty)]) - <|> (match TypeColon >> outputs) + WC _ nm <- simpleName + ty <- try (functionType <&> \(WC _ ty) -> [Named "thunk" (Right ty)]) + <|> (match TypeColon >> rawIO) let allow_clauses = case ty of [Named _ (Right t)] -> is_fun_ty t [Anon (Right t)] -> is_fun_ty t @@ -545,7 +656,7 @@ decl = do label (nm ++ "(...) = ...") $ matchString nm match Equal - withFC expr + expr class FCStream a where getFC :: Int -> PosState a -> FC @@ -564,10 +675,18 @@ instance FCStream [Token] where [] -> sp_to_fc pstateSourcePos (Token fc _):_ -> fc +instance FCStream [BToken] where + getFC o PosState{..} = case drop (o - pstateOffset) pstateInput of + [] -> sp_to_fc pstateSourcePos + (Bracketed fc _ _):_ -> fc + (FlatTok (Token fc _)):_ -> fc + + parseFile :: String -> String -> Either SrcErr ([Import], FEnv) parseFile fname contents = addSrcContext fname contents $ do toks <- first (wrapParseErr LexErr) (M.parse lex fname contents) - first (wrapParseErr ParseErr) (parse pfile fname toks) + btoks <- brackets toks + first (wrapParseErr ParseErr) (parse pfile fname btoks) where wrapParseErr :: (VisualStream t, FCStream t, ShowErrorComponent e) => (ParseError -> ErrorMsg) -> ParseErrorBundle t e -> Error @@ -585,19 +704,20 @@ clauses declName = label "clauses" $ fmap (fromJust . nonEmpty) $ some (try branch) where + branch :: Parser (WC Abstractor, WC Flat) branch = do label (declName ++ "(...) = ...") $ matchString declName - lhs <- withFC $ round (abstractor "binder") + lhs <- inBrackets Paren (abstractor "binder") match Equal - rhs <- withFC expr + rhs <- expr pure (lhs,rhs) pimport :: Parser Import pimport = do o <- open kmatch KImport - x <- withFC userName + x <- userName a <- alias s <- selection pure (Import x (not o) a s) @@ -610,7 +730,7 @@ pimport = do alias :: Parser (Maybe (WC String)) alias = optional (matchString "as") >>= \case Nothing -> pure Nothing - Just _ -> Just <$> withFC (ident Just) + Just _ -> Just <$> simpleName selection :: Parser ImportSelection selection = optional (try $ matchString "hiding") >>= \case @@ -620,7 +740,7 @@ pimport = do Just ss -> pure (ImportPartial ss) list :: Parser [WC String] - list = round $ ((:[]) <$> withFC (ident Just)) `chainl1` try (match Comma $> (++)) + list = inBrackets Paren $ ((:[]) <$> simpleName) `chainl1` try (match Comma $> (++)) pstmt :: Parser FEnv pstmt = ((comment "comment") <&> \_ -> ([] , [])) @@ -635,10 +755,10 @@ pstmt = ((comment "comment") <&> \_ -> ([] , [])) aliasContents :: Parser (UserName, [(String, TypeKind)], RawVType) aliasContents = do match (K KType) - alias <- userName - args <- option [] $ round $ (simpleName `sepBy` (match Comma)) + WC _ alias <- userName + args <- option [] $ inBrackets Paren $ ((unWC <$> simpleName) `sepBy` (match Comma)) {- future stuff - args <- option [] $ round $ (`sepBy` (match Comma)) $ do + args <- option [] $ inBrackets Paren $ (`sepBy` (match Comma)) $ do port <- port match TypeColon (port,) <$> typekind @@ -653,18 +773,18 @@ pstmt = ((comment "comment") <&> \_ -> ([] , [])) pure (alias, (,Star []) <$> args, unWC ty) extDecl :: Parser FDecl - extDecl = do (WC fc (fnName, ty, symbol)) <- withFC $ do - match (K KExt) - symbol <- string - fnName <- simpleName - ty <- try nDecl <|> vDecl + extDecl = do (fc, fnName, ty, symbol) <- do + WC startFC () <- matchFC (K KExt) + symbol <- unWC <$> string + fnName <- unWC <$> simpleName + WC tyFC ty <- try nDecl <|> vDecl -- When external ops are used, we expect it to be in the form: -- extension.op for the hugr extension used and the op name let bits = chop (=='.') symbol (ext, op) <- case viewR bits of Just (ext, op) -> pure (intercalate "." ext, op) Nothing -> fail $ "Malformed op name: " ++ symbol - pure (fnName, ty, (ext, op)) + pure (spanFC startFC tyFC, fnName, ty, (ext, op)) pure FuncDecl { fnName = fnName , fnSig = ty @@ -673,8 +793,8 @@ pstmt = ((comment "comment") <&> \_ -> ([] , [])) , fnLocality = Extern symbol } where - nDecl = match TypeColon >> outputs - vDecl = (:[]) . Named "thunk" . Right <$> functionType + nDecl = match TypeColon >> rawIOWithSpanFC + vDecl = functionType <&> fmap (\ty -> [Named "thunk" (Right ty)]) pfile :: Parser ([Import], FEnv) pfile = do diff --git a/brat/Data/Bracket.hs b/brat/Data/Bracket.hs new file mode 100644 index 00000000..48d3efb3 --- /dev/null +++ b/brat/Data/Bracket.hs @@ -0,0 +1,13 @@ +module Data.Bracket where + +data BracketType = Paren | Bracket | Brace deriving (Eq, Ord) + +showOpen :: BracketType -> String +showOpen Paren = "(" +showOpen Bracket = "[" +showOpen Brace = "{" + +showClose :: BracketType -> String +showClose Paren = ")" +showClose Bracket = "]" +showClose Brace = "}" diff --git a/brat/brat.cabal b/brat/brat.cabal index 001c2bde..111a8d70 100644 --- a/brat/brat.cabal +++ b/brat/brat.cabal @@ -56,7 +56,9 @@ common warning-flags library import: haskell, warning-flags default-language: GHC2021 - other-modules: Brat.Lexer.Flat, + other-modules: Data.Bracket, + Brat.Lexer.Bracketed, + Brat.Lexer.Flat, Brat.Lexer.Token exposed-modules: Brat.Checker.Quantity, From 1ad6d601be3f03e4538712c926c8740f81d3ca0a Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Tue, 1 Oct 2024 14:26:53 +0100 Subject: [PATCH 02/12] kill withFC --- brat/Brat/Error.hs | 2 + brat/Brat/Lexer/Bracketed.hs | 11 ++- brat/Brat/Lexer/Token.hs | 2 +- brat/Brat/Parser.hs | 83 ++++++++++--------- brat/brat.cabal | 8 +- brat/test/golden/binding/cons.brat.golden | 4 +- brat/test/golden/error/badvec.brat.golden | 4 +- brat/test/golden/error/kbadvec.brat.golden | 4 +- brat/test/golden/error/kbadvec4.brat | 2 +- brat/test/golden/error/kbadvec4.brat.golden | 6 +- brat/test/golden/error/noovers.brat.golden | 4 +- brat/test/golden/error/vecpat.brat.golden | 4 +- brat/test/golden/error/vecpat2.brat.golden | 4 +- brat/test/golden/error/vecpat3.brat.golden | 4 +- brat/test/golden/kernel/copy.brat.golden | 4 +- brat/test/golden/kernel/delete.brat.golden | 4 +- brat/test/golden/kernel/deleteFst.brat.golden | 4 +- brat/test/golden/kernel/deleteSnd.brat.golden | 4 +- 18 files changed, 81 insertions(+), 77 deletions(-) diff --git a/brat/Brat/Error.hs b/brat/Brat/Error.hs index aefb26a6..42226347 100644 --- a/brat/Brat/Error.hs +++ b/brat/Brat/Error.hs @@ -188,6 +188,8 @@ instance Show ErrorMsg where show (CompilingHoles hs) = unlines ("Can't compile file with remaining holes": indent hs) where indent = fmap (" " ++) + show (BracketErr msg) = show msg + data Error = Err { fc :: Maybe FC , msg :: ErrorMsg diff --git a/brat/Brat/Lexer/Bracketed.hs b/brat/Brat/Lexer/Bracketed.hs index b23cfa6c..dce3f7aa 100644 --- a/brat/Brat/Lexer/Bracketed.hs +++ b/brat/Brat/Lexer/Bracketed.hs @@ -50,18 +50,17 @@ unexpectedCloseErr fc b = Err (Just fc) (BracketErr (UnexpectedClose b)) within :: (FC, BracketType) -> Bwd BToken -> [Token] -> Either Error (FC, Bwd BToken, [Token]) within (openFC, b) _ [] = Left $ eofErr openFC b -within ctx@(openFC, b) acc (t:ts) +within ctx@(_, b) acc (t:ts) | Just b' <- closer (_tok t) = if b' == b then pure (fc t, acc, ts) else Left $ openCloseMismatchErr ctx (fc t, b') | Just b' <- opener (_tok t) = do - (closeFC, xs, ts) <- within (fc t, b') B0 ts - let fc = bracketFC openFC closeFC + let innerOpenFC = fc t + (innerCloseFC, xs, ts) <- within (innerOpenFC, b') B0 ts + let fc = spanFC innerOpenFC innerCloseFC within ctx (acc :< Bracketed fc b' (xs <>> [])) ts | otherwise = within ctx (acc :< FlatTok t) ts -bracketFC openFC closeFC = FC (start openFC) (end closeFC) - brackets :: [Token] -> Either Error [BToken] brackets ts = bracketsWorker B0 ts >>= \case (tokz, []) -> pure (tokz <>> []) @@ -72,7 +71,7 @@ brackets ts = bracketsWorker B0 ts >>= \case bracketsWorker acc (t:ts) | Just b <- opener (_tok t) = do (closeFC, xs, ts) <- within (fc t, b) B0 ts - let enclosingFC = bracketFC (fc t) closeFC + let enclosingFC = spanFC (fc t) closeFC bracketsWorker (acc :< Bracketed enclosingFC b (xs <>> [])) ts | Just b <- closer (_tok t) = Left $ unexpectedCloseErr (fc t) b | otherwise = bracketsWorker (acc :< FlatTok t) ts diff --git a/brat/Brat/Lexer/Token.hs b/brat/Brat/Lexer/Token.hs index 95acff34..58ac81fc 100644 --- a/brat/Brat/Lexer/Token.hs +++ b/brat/Brat/Lexer/Token.hs @@ -100,7 +100,7 @@ instance Eq Token where (Token fc t) == (Token fc' t') = t == t' && fc == fc' instance Show Token where - show (Token _ t) = (show t) ++ " " + show (Token _ t) = show t instance Ord Token where compare (Token (FC st nd) _) (Token (FC st' nd') _) = if st == st' then compare nd nd' diff --git a/brat/Brat/Parser.hs b/brat/Brat/Parser.hs index 050b3900..aee60c1e 100644 --- a/brat/Brat/Parser.hs +++ b/brat/Brat/Parser.hs @@ -25,9 +25,10 @@ import Data.Bifunctor import Data.Either.HT (maybeRight) import Data.Foldable (msum) import Data.Functor (($>), (<&>)) -import Data.List (intercalate) +import Data.List (intercalate, uncons) import Data.List.HT (chop, viewR) import Data.List.NonEmpty (toList, NonEmpty(..), nonEmpty) +import qualified Data.List.NonEmpty as NE import Data.Maybe (fromJust, maybeToList, fromMaybe) import Data.Set (empty) import Prelude hiding (lex, round) @@ -45,19 +46,6 @@ parse p s tks = evalState (runParserT p s tks) (Pos 0 0) instance ShowErrorComponent CustomError where showErrorComponent (Custom s) = s -{- -withFC :: Parser a -> Parser (WC a) -withFC p = do - fc <- nextToken <&> \case - Bracketed fc _ _ -> fc - FlatTok (Token fc _) -> fc - thing <- p - end <- get - pure (WC (FC (start fc) end) thing) --} -withFC :: Parser a -> Parser (WC a) -withFC p = undefined - nextToken :: Parser BToken nextToken = lookAhead $ token Just empty @@ -192,7 +180,7 @@ chainl1 px pf = px >>= rest abstractor :: Parser (WC Abstractor) abstractor = do ps <- many (try portPull) - abs <- binders + abs <- try (inBrackets Paren binders) <|> binders pure $ if null ps then abs else let fc = spanFCOf (head ps) abs in WC fc (APull (unWC <$> ps) (unWC abs)) @@ -372,7 +360,7 @@ functionType = try (fmap RFn <$> ctype) <|> (fmap RKernel <$> kernel) vec :: Parser (WC Flat) -vec = (\(WC fc x) -> vec2Cons (end fc) x) <$> (inBracketsFC Bracket elems) +vec = (\(WC fc x) -> vec2Cons fc x) <$> (inBracketsFC Bracket elems) where elems = (element `chainl1` (try vecComma)) <|> pure [] vecComma = match Comma $> (++) @@ -382,13 +370,18 @@ vec = (\(WC fc x) -> vec2Cons (end fc) x) <$> (inBracketsFC Bracket elems) mkNil fc = FCon (plain "nil") (WC fc FEmpty) - vec2Cons :: Pos -> [WC Flat] -> WC Flat - -- The nil element gets as FC the closing ']' of the [li,te,ral] - vec2Cons end [] = let fc = FC end{col=(col end)-1} end in WC fc (mkNil fc) + vec2Cons :: FC -> [WC Flat] -> WC Flat + -- The nil element gets the FC of the `[]` expression. + -- N.B. this is also true in non-nil lists: the `nil` terminator of the list + -- `[1,2,3]` gets the file context of `[1,2,3]` + vec2Cons outerFC [] = WC outerFC (mkNil outerFC) + vec2Cons outerFC [x] = WC (fcOf x) $ FCon (plain "cons") (WC (fcOf x) (FJuxt x (WC outerFC (mkNil outerFC)))) -- We give each cell of the list an FC which starts with the FC -- of its head element and ends at the end of the list (the closing ']') - vec2Cons end (x:xs) = let fc = FC (start $ fcOf x) end in - WC fc $ FCon (plain "cons") (WC fc (FJuxt x (vec2Cons end xs))) + vec2Cons outerFC (x:xs) = let endFC = fcOf (last xs) + fc = spanFC (fcOf x) endFC + in WC fc $ + FCon (plain "cons") (WC fc (FJuxt x (vec2Cons outerFC xs))) cthunk :: Parser (WC Flat) @@ -627,17 +620,17 @@ cnoun pe = do decl :: Parser FDecl decl = do - (WC fc (nm, ty, body)) <- withFC (do - WC _ nm <- simpleName - ty <- try (functionType <&> \(WC _ ty) -> [Named "thunk" (Right ty)]) - <|> (match TypeColon >> rawIO) + (fc, nm, ty, body) <- do + WC startFC nm <- simpleName + WC _ ty <- declSignature let allow_clauses = case ty of [Named _ (Right t)] -> is_fun_ty t [Anon (Right t)] -> is_fun_ty t _ -> False - body <- if allow_clauses then (FClauses <$> clauses nm) <|> (FNoLhs <$> nbody nm) - else FNoLhs <$> nbody nm - pure (nm, ty, body)) + WC endFC body <- if allow_clauses + then declClauses nm <|> declNounBody nm + else declNounBody nm + pure (spanFC startFC endFC, nm, ty, body) pure $ FuncDecl { fnName = nm , fnLoc = fc @@ -651,12 +644,20 @@ decl = do is_fun_ty (RKernel _) = True is_fun_ty _ = False - nbody :: String -> Parser (WC Flat) - nbody nm = do + declClauses :: String -> Parser (WC FBody) + declClauses nm = do + cs <- clauses nm + let startFC = fcOf . fst $ NE.head cs + let endFC = fcOf . snd $ NE.last cs + pure (WC (spanFC startFC endFC) (FClauses cs)) + + declNounBody :: String -> Parser (WC FBody) + declNounBody nm = do label (nm ++ "(...) = ...") $ matchString nm match Equal - expr + body@(WC fc _) <- expr + pure (WC fc (FNoLhs body)) class FCStream a where getFC :: Int -> PosState a -> FC @@ -749,12 +750,12 @@ pstmt = ((comment "comment") <&> \_ -> ([] , [])) <|> ((decl "declaration") <&> \x -> ([x], [])) where alias :: Parser RawAlias - alias = withFC aliasContents <&> - \(WC fc (name, args, ty)) -> (TypeAlias fc name args ty) + alias = aliasContents <&> + \(fc, name, args, ty) -> (TypeAlias fc name args ty) - aliasContents :: Parser (UserName, [(String, TypeKind)], RawVType) + aliasContents :: Parser (FC, UserName, [(String, TypeKind)], RawVType) aliasContents = do - match (K KType) + WC startFC () <- matchFC (K KType) WC _ alias <- userName args <- option [] $ inBrackets Paren $ ((unWC <$> simpleName) `sepBy` (match Comma)) {- future stuff @@ -770,14 +771,14 @@ pstmt = ((comment "comment") <&> \_ -> ([] , [])) -- users to specify the kinds of variables in type aliases, like: -- type X(a :: *, b :: #, c :: *(x :: *, y :: #)) = ... -- See KARL-325 - pure (alias, (,Star []) <$> args, unWC ty) + pure (spanFC startFC (fcOf ty), alias, (,Star []) <$> args, unWC ty) extDecl :: Parser FDecl extDecl = do (fc, fnName, ty, symbol) <- do WC startFC () <- matchFC (K KExt) symbol <- unWC <$> string fnName <- unWC <$> simpleName - WC tyFC ty <- try nDecl <|> vDecl + WC tyFC ty <- declSignature -- When external ops are used, we expect it to be in the form: -- extension.op for the hugr extension used and the op name let bits = chop (=='.') symbol @@ -792,9 +793,11 @@ pstmt = ((comment "comment") <&> \_ -> ([] , [])) , fnLoc = fc , fnLocality = Extern symbol } - where - nDecl = match TypeColon >> rawIOWithSpanFC - vDecl = functionType <&> fmap (\ty -> [Named "thunk" (Right ty)]) + +declSignature :: Parser (WC [RawIO]) +declSignature = try nDecl <|> vDecl where + nDecl = match TypeColon >> rawIOWithSpanFC + vDecl = functionType <&> fmap (\ty -> [Named "thunk" (Right ty)]) pfile :: Parser ([Import], FEnv) pfile = do diff --git a/brat/brat.cabal b/brat/brat.cabal index 111a8d70..35abe821 100644 --- a/brat/brat.cabal +++ b/brat/brat.cabal @@ -44,11 +44,11 @@ common warning-flags -Wno-unused-do-bind -Wno-missing-signatures -Wno-noncanonical-monoid-instances - -Werror=unused-imports - -Werror=unused-matches +-- -Werror=unused-imports +-- -Werror=unused-matches -Werror=missing-methods - -Werror=unused-top-binds - -Werror=unused-local-binds +-- -Werror=unused-top-binds +-- -Werror=unused-local-binds -Werror=redundant-constraints -Werror=orphans -Werror=overlapping-patterns diff --git a/brat/test/golden/binding/cons.brat.golden b/brat/test/golden/binding/cons.brat.golden index 760511cd..fbbcbdd2 100644 --- a/brat/test/golden/binding/cons.brat.golden +++ b/brat/test/golden/binding/cons.brat.golden @@ -1,6 +1,6 @@ -Error in test/golden/binding/cons.brat@FC {start = Pos {line = 7, col = 10}, end = Pos {line = 7, col = 23}}: +Error in test/golden/binding/cons.brat@FC {start = Pos {line = 7, col = 11}, end = Pos {line = 7, col = 22}}: badUncons(cons(stuff)) = stuff - ^^^^^^^^^^^^^ + ^^^^^^^^^^^ Unification error: Pattern doesn't match expected length for constructor args diff --git a/brat/test/golden/error/badvec.brat.golden b/brat/test/golden/error/badvec.brat.golden index 9098c931..b9c83d8c 100644 --- a/brat/test/golden/error/badvec.brat.golden +++ b/brat/test/golden/error/badvec.brat.golden @@ -1,6 +1,6 @@ -Error in test/golden/error/badvec.brat@FC {start = Pos {line = 2, col = 6}, end = Pos {line = 2, col = 9}}: +Error in test/golden/error/badvec.brat@FC {start = Pos {line = 2, col = 7}, end = Pos {line = 2, col = 8}}: v3 = [1] - ^^^ + ^ Expected vector of length 3 from the type: Vec(Int, 3) diff --git a/brat/test/golden/error/kbadvec.brat.golden b/brat/test/golden/error/kbadvec.brat.golden index c14904dd..9568bb93 100644 --- a/brat/test/golden/error/kbadvec.brat.golden +++ b/brat/test/golden/error/kbadvec.brat.golden @@ -1,6 +1,6 @@ -Error in test/golden/error/kbadvec.brat@FC {start = Pos {line = 2, col = 17}, end = Pos {line = 2, col = 20}}: +Error in test/golden/error/kbadvec.brat@FC {start = Pos {line = 2, col = 18}, end = Pos {line = 2, col = 19}}: triple = { b => [b] } - ^^^ + ^ Expected vector of length 3 from the type: Vec(Bit, 3) diff --git a/brat/test/golden/error/kbadvec4.brat b/brat/test/golden/error/kbadvec4.brat index 6079c080..7b1ebc8c 100644 --- a/brat/test/golden/error/kbadvec4.brat +++ b/brat/test/golden/error/kbadvec4.brat @@ -1,2 +1,2 @@ f :: { Vec(Bool, 3) -> Bool } -f = { [1,2] => true } +f = { [1, 2] => true } diff --git a/brat/test/golden/error/kbadvec4.brat.golden b/brat/test/golden/error/kbadvec4.brat.golden index 8d2c78b8..49775657 100644 --- a/brat/test/golden/error/kbadvec4.brat.golden +++ b/brat/test/golden/error/kbadvec4.brat.golden @@ -1,6 +1,6 @@ -Error in test/golden/error/kbadvec4.brat@FC {start = Pos {line = 2, col = 7}, end = Pos {line = 2, col = 12}}: -f = { [1,2] => true } - ^^^^^ +Error in test/golden/error/kbadvec4.brat@FC {start = Pos {line = 2, col = 7}, end = Pos {line = 2, col = 13}}: +f = { [1, 2] => true } + ^^^^^^ Type error: Expected something of type `Bool` but got `1` diff --git a/brat/test/golden/error/noovers.brat.golden b/brat/test/golden/error/noovers.brat.golden index d0100d4e..3953da25 100644 --- a/brat/test/golden/error/noovers.brat.golden +++ b/brat/test/golden/error/noovers.brat.golden @@ -1,6 +1,6 @@ -Error in test/golden/error/noovers.brat@FC {start = Pos {line = 2, col = 2}, end = Pos {line = 2, col = 8}}: +Error in test/golden/error/noovers.brat@FC {start = Pos {line = 2, col = 3}, end = Pos {line = 2, col = 7}}: f(a, b) = [] - ^^^^^^ + ^^^^ Nothing to bind to: b diff --git a/brat/test/golden/error/vecpat.brat.golden b/brat/test/golden/error/vecpat.brat.golden index 0d9e24a2..f7ac009d 100644 --- a/brat/test/golden/error/vecpat.brat.golden +++ b/brat/test/golden/error/vecpat.brat.golden @@ -1,6 +1,6 @@ -Error in test/golden/error/vecpat.brat@FC {start = Pos {line = 3, col = 5}, end = Pos {line = 3, col = 10}}: +Error in test/golden/error/vecpat.brat@FC {start = Pos {line = 3, col = 6}, end = Pos {line = 3, col = 9}}: fst3(nil) = none - ^^^^^ + ^^^ Unification error: Couldn't force 3 to be 0 diff --git a/brat/test/golden/error/vecpat2.brat.golden b/brat/test/golden/error/vecpat2.brat.golden index 7fc56984..9a3af11d 100644 --- a/brat/test/golden/error/vecpat2.brat.golden +++ b/brat/test/golden/error/vecpat2.brat.golden @@ -1,6 +1,6 @@ -Error in test/golden/error/vecpat2.brat@FC {start = Pos {line = 3, col = 5}, end = Pos {line = 3, col = 14}}: +Error in test/golden/error/vecpat2.brat@FC {start = Pos {line = 3, col = 6}, end = Pos {line = 3, col = 13}}: fst3(some(x)) = none - ^^^^^^^^^ + ^^^^^^^ "some" is not a valid constructor for type Vec diff --git a/brat/test/golden/error/vecpat3.brat.golden b/brat/test/golden/error/vecpat3.brat.golden index 53b3521f..6dc52bfb 100644 --- a/brat/test/golden/error/vecpat3.brat.golden +++ b/brat/test/golden/error/vecpat3.brat.golden @@ -1,6 +1,6 @@ -Error in test/golden/error/vecpat3.brat@FC {start = Pos {line = 3, col = 5}, end = Pos {line = 3, col = 12}}: +Error in test/golden/error/vecpat3.brat@FC {start = Pos {line = 3, col = 6}, end = Pos {line = 3, col = 11}}: fst3([a,b]) = none - ^^^^^^^ + ^^^^^ Unification error: Couldn't force 1 to be 0 diff --git a/brat/test/golden/kernel/copy.brat.golden b/brat/test/golden/kernel/copy.brat.golden index b53a285b..2f61f2bc 100644 --- a/brat/test/golden/kernel/copy.brat.golden +++ b/brat/test/golden/kernel/copy.brat.golden @@ -1,6 +1,6 @@ -Error in test/golden/kernel/copy.brat@FC {start = Pos {line = 2, col = 8}, end = Pos {line = 2, col = 21}}: +Error in test/golden/kernel/copy.brat@FC {start = Pos {line = 2, col = 10}, end = Pos {line = 2, col = 19}}: copy = { q => q, q } - ^^^^^^^^^^^^^ + ^^^^^^^^^ Type error: q has already been used diff --git a/brat/test/golden/kernel/delete.brat.golden b/brat/test/golden/kernel/delete.brat.golden index a9ae4a5a..d14867a1 100644 --- a/brat/test/golden/kernel/delete.brat.golden +++ b/brat/test/golden/kernel/delete.brat.golden @@ -1,6 +1,6 @@ -Error in test/golden/kernel/delete.brat@FC {start = Pos {line = 2, col = 13}, end = Pos {line = 2, col = 29}}: +Error in test/golden/kernel/delete.brat@FC {start = Pos {line = 2, col = 15}, end = Pos {line = 2, col = 27}}: deleteFst = { q0, q1 => q1 } - ^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^ Type error: Variable(s) q0 haven't been used diff --git a/brat/test/golden/kernel/deleteFst.brat.golden b/brat/test/golden/kernel/deleteFst.brat.golden index a9dcf31a..c4dcc771 100644 --- a/brat/test/golden/kernel/deleteFst.brat.golden +++ b/brat/test/golden/kernel/deleteFst.brat.golden @@ -1,6 +1,6 @@ -Error in test/golden/kernel/deleteFst.brat@FC {start = Pos {line = 2, col = 13}, end = Pos {line = 2, col = 29}}: +Error in test/golden/kernel/deleteFst.brat@FC {start = Pos {line = 2, col = 15}, end = Pos {line = 2, col = 27}}: deleteFst = { q0, q1 => q1 } - ^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^ Type error: Variable(s) q0 haven't been used diff --git a/brat/test/golden/kernel/deleteSnd.brat.golden b/brat/test/golden/kernel/deleteSnd.brat.golden index 7dbea77e..35f9aa4b 100644 --- a/brat/test/golden/kernel/deleteSnd.brat.golden +++ b/brat/test/golden/kernel/deleteSnd.brat.golden @@ -1,6 +1,6 @@ -Error in test/golden/kernel/deleteSnd.brat@FC {start = Pos {line = 2, col = 13}, end = Pos {line = 2, col = 29}}: +Error in test/golden/kernel/deleteSnd.brat@FC {start = Pos {line = 2, col = 15}, end = Pos {line = 2, col = 27}}: deleteSnd = { q0, q1 => q0 } - ^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^ Type error: Variable(s) q1 haven't been used From a5b4df9ebb52439660ebd73ffb41f7ac3f6af41c Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Tue, 1 Oct 2024 17:18:29 +0100 Subject: [PATCH 03/12] Revert pullAndJuxt changes --- brat/Brat/Parser.hs | 30 ++++++++++++++++++++---------- 1 file changed, 20 insertions(+), 10 deletions(-) diff --git a/brat/Brat/Parser.hs b/brat/Brat/Parser.hs index aee60c1e..f38d7ae8 100644 --- a/brat/Brat/Parser.hs +++ b/brat/Brat/Parser.hs @@ -593,16 +593,26 @@ expr' p = choice $ (try . getParser <$> enumFrom p) ++ [atomExpr] WC (spanFCOf a b) (f a b) _ -> Nothing - pullAndJuxt = pull <|> juxt - - pull :: Parser (WC Flat) - pull = do - ports <- some (try (port <* match PortColon)) - body <- subExpr PJuxtPull - pure $ WC (spanFCOf (head ports) body) (FPull (unWC <$> ports) body) - - juxt :: Parser (WC Flat) - juxt = (try pull <|> subExpr PJuxtPull) `chainl1` try comma + pullAndJuxt = do + ports <- many (try portPull) + let firstPortFC = fcOf . fst <$> uncons ports + case ports of + [] -> juxtRhsWithPull + _ -> (\juxt@(WC juxtFC _) -> WC (maybe juxtFC (\fc -> spanFC fc juxtFC) firstPortFC) (FPull (unWC <$> ports) juxt)) <$> juxtRhsWithPull + where + portPull :: Parser (WC String) + portPull = do + WC portFC portName <- port + WC colonFC _ <- matchFC PortColon + pure (WC (spanFC portFC colonFC) portName) + + -- Juxtaposition here includes port pulling, since they have the same precedence + juxtRhsWithPull = do + expr <- subExpr PJuxtPull + rest <- optional (match Comma *> pullAndJuxt) + pure $ case rest of + Nothing -> expr + Just rest@(WC restFC _) -> WC (spanFC (fcOf expr) restFC) (FJuxt expr rest) cnoun :: Parser (WC Flat) -> Parser (WC (Raw 'Chk 'Noun)) cnoun pe = do From 39d101b84bdd74c16488906944c7ee6be52f7b91 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Tue, 1 Oct 2024 17:41:22 +0100 Subject: [PATCH 04/12] Drive-by: Update kind printing and remove Row kind --- brat/Brat/Syntax/Common.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/brat/Brat/Syntax/Common.hs b/brat/Brat/Syntax/Common.hs index 2b08edb1..6d8265e5 100644 --- a/brat/Brat/Syntax/Common.hs +++ b/brat/Brat/Syntax/Common.hs @@ -109,8 +109,16 @@ instance Eq ty => Eq (TypeRowElem ty) where Named _ ty == Anon ty' = ty == ty' Anon ty == Anon ty' = ty == ty' -data TypeKind = TypeFor Mode [(PortName, TypeKind)] | Nat | Row - deriving (Eq, Show) +data TypeKind = TypeFor Mode [(PortName, TypeKind)] | Nat + deriving Eq + +instance Show TypeKind where + show (TypeFor m args) = let argsStr = if null args then "" else ("(" ++ intercalate ", " (show <$> args) ++ ")") + kindStr = case m of + Brat -> "*" + Kernel -> "$" + in kindStr ++ argsStr + show Nat = "#" pattern Star, Dollar :: [(PortName, TypeKind)] -> TypeKind pattern Star ks = TypeFor Brat ks From 81b49bc2cf0a2f798cd85f8f5a2fbe4b722576d0 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Tue, 1 Oct 2024 17:41:48 +0100 Subject: [PATCH 05/12] test: Add extra let binding tests --- brat/examples/let.brat | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/brat/examples/let.brat b/brat/examples/let.brat index 69a6b400..b927a87c 100644 --- a/brat/examples/let.brat +++ b/brat/examples/let.brat @@ -32,3 +32,13 @@ nums' = let xs = map(inc, [0,2,3]) in xs nums'' :: List(Int) nums'' = let i2 = {inc; inc} in map(i2, xs) + +dyad :: Int, Bool +dyad = 42, true + +bind2 :: Bool +bind2 = let i, b = dyad in b + +-- It shouldn't matter if we put brackets in the binding sites +bind2' :: Bool +bind2' = let (i, b) = dyad in b From a4c47dcea19770238b21b87aff1a65353e03a286 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Tue, 1 Oct 2024 17:42:13 +0100 Subject: [PATCH 06/12] Update golden tests --- brat/test/Test/Checking.hs | 1 + brat/test/Test/Parsing.hs | 1 - brat/test/golden/error/badvec4.brat.golden | 4 ++-- brat/test/golden/error/unmatched_bracket.brat.golden | 8 +++----- 4 files changed, 6 insertions(+), 8 deletions(-) diff --git a/brat/test/Test/Checking.hs b/brat/test/Test/Checking.hs index ce348e4c..3a219375 100644 --- a/brat/test/Test/Checking.hs +++ b/brat/test/Test/Checking.hs @@ -16,6 +16,7 @@ import Test.Tasty.Silver import Test.Tasty.ExpectedFailure expectedCheckingFails = map ("examples" ) ["nested-abstractors.brat" + ,"karlheinz.brat" ,"karlheinz_alias.brat" ,"hea.brat" ] diff --git a/brat/test/Test/Parsing.hs b/brat/test/Test/Parsing.hs index fec759ce..f2093192 100644 --- a/brat/test/Test/Parsing.hs +++ b/brat/test/Test/Parsing.hs @@ -18,7 +18,6 @@ testParse file = testCase (show file) $ do Right _ -> return () -- OK expectedParsingFails = map ("examples" ) [ - "karlheinz.brat", "thin.brat"] expectFailForPaths :: [FilePath] -> (FilePath -> TestTree) -> FilePath -> TestTree diff --git a/brat/test/golden/error/badvec4.brat.golden b/brat/test/golden/error/badvec4.brat.golden index 53262957..425777b4 100644 --- a/brat/test/golden/error/badvec4.brat.golden +++ b/brat/test/golden/error/badvec4.brat.golden @@ -1,6 +1,6 @@ -Error in test/golden/error/badvec4.brat@FC {start = Pos {line = 2, col = 6}, end = Pos {line = 2, col = 11}}: +Error in test/golden/error/badvec4.brat@FC {start = Pos {line = 2, col = 7}, end = Pos {line = 2, col = 10}}: v3 = [1,2] - ^^^^^ + ^^^ Expected vector of length 3 from the type: Vec(Int, 3) diff --git a/brat/test/golden/error/unmatched_bracket.brat.golden b/brat/test/golden/error/unmatched_bracket.brat.golden index 427aac74..6afb5a16 100644 --- a/brat/test/golden/error/unmatched_bracket.brat.golden +++ b/brat/test/golden/error/unmatched_bracket.brat.golden @@ -1,8 +1,6 @@ -Error in test/golden/error/unmatched_bracket.brat@FC {start = Pos {line = 1, col = 17}, end = Pos {line = 1, col = 19}}: +Error in test/golden/error/unmatched_bracket.brat@FC {start = Pos {line = 1, col = 2}, end = Pos {line = 1, col = 3}}: f(n, Vec([], n) -> Vec([], n) -- First bracket never closed - ^^ - - Parse error unexpected -> -expecting (...) or ) + ^ + File ended before this ( was closed From 93e43c6c7b5b97d14c702f7eae536f115afc53e1 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Tue, 1 Oct 2024 17:52:09 +0100 Subject: [PATCH 07/12] Fix warnings --- brat/Brat/Parser.hs | 29 ++++++++++------------------- brat/brat.cabal | 8 ++++---- 2 files changed, 14 insertions(+), 23 deletions(-) diff --git a/brat/Brat/Parser.hs b/brat/Brat/Parser.hs index f38d7ae8..b0bcf60d 100644 --- a/brat/Brat/Parser.hs +++ b/brat/Brat/Parser.hs @@ -29,7 +29,7 @@ import Data.List (intercalate, uncons) import Data.List.HT (chop, viewR) import Data.List.NonEmpty (toList, NonEmpty(..), nonEmpty) import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromJust, maybeToList, fromMaybe) +import Data.Maybe (fromJust, fromMaybe) import Data.Set (empty) import Prelude hiding (lex, round) import Text.Megaparsec hiding (Pos, Token, State, empty, match, ParseError, parse) @@ -46,9 +46,6 @@ parse p s tks = evalState (runParserT p s tks) (Pos 0 0) instance ShowErrorComponent CustomError where showErrorComponent (Custom s) = s -nextToken :: Parser BToken -nextToken = lookAhead $ token Just empty - matchTokFC :: (Tok -> Maybe a) -> Parser (WC a) matchTokFC f = token (matchTok f) empty @@ -86,12 +83,6 @@ matchString s = label (show s) $ matchTokFC $ \case Ident ident | ident == s -> Just () _ -> Nothing - -ident :: (String -> Maybe a) -> Parser a -ident f = label "identifier" $ token0 $ \case - Ident str -> f str - _ -> Nothing - hole :: Parser (WC String) hole = label "hole" $ matchTokFC $ \case Hole h -> Just h @@ -191,7 +182,7 @@ abstractor = do ps <- many (try portPull) joinBinders xs = let (abs, startFC, endFC) = joinBindersAux xs in WC (spanFC startFC endFC) abs joinBindersAux (WC fc x :| []) = (x, fc, fc) - joinBindersAux (WC fc x :| (y:ys)) = let (abs, startFC, endFC) = joinBindersAux (y :| ys) in + joinBindersAux (WC fc x :| (y:ys)) = let (abs, _, endFC) = joinBindersAux (y :| ys) in (x :||: abs, fc, endFC) binding :: Parser (WC Abstractor) @@ -209,8 +200,6 @@ abstractor = do ps <- many (try portPull) portPull = port <* match PortColon - binderComma = match Comma $> (:||:) - -- For simplicity, we can say for now that all of our infix vector patterns have -- the same precedence and associate to the right bigPat :: Parser (WC Pattern) @@ -509,14 +498,15 @@ expr' p = choice $ (try . getParser <$> enumFrom p) ++ [atomExpr] case rest of Just (c, args) -> do rhs <- vectorBuild - pure (WC (spanFCOf lhs rhs) (FCon c (mkJuxt (args ++ [rhs])))) + let juxtElems = case args of + [] -> rhs :| [] + (a:as) -> a :| (as ++ [rhs]) + pure (WC (spanFCOf lhs rhs) (FCon c (mkJuxt juxtElems))) Nothing -> pure lhs - where - matchConstructor lhs = matchFC Cons - mkJuxt :: [WC Flat] -> WC Flat - mkJuxt [x] = x - mkJuxt (x:xs) = let rest = mkJuxt xs in WC (FC (start (fcOf x)) (end (fcOf rest))) (FJuxt x rest) + mkJuxt :: NonEmpty (WC Flat) -> WC Flat + mkJuxt (x :| []) = x + mkJuxt (x :| (y:ys)) = let rest = mkJuxt (y:|ys) in WC (FC (start (fcOf x)) (end (fcOf rest))) (FJuxt x rest) application :: Parser (WC Flat) application = atomExpr >>= applied @@ -562,6 +552,7 @@ expr' p = choice $ (try . getParser <$> enumFrom p) ++ [atomExpr] otherClauses <- many (match Pipe >> lambdaClause) let endPos = case otherClauses of [] -> end (fcOf (snd firstClause)) + _ -> end (fcOf (snd (last otherClauses))) let fc = FC (start (fcOf (fst firstClause))) endPos pure (WC fc (FLambda (firstClause :| otherClauses))) diff --git a/brat/brat.cabal b/brat/brat.cabal index 35abe821..111a8d70 100644 --- a/brat/brat.cabal +++ b/brat/brat.cabal @@ -44,11 +44,11 @@ common warning-flags -Wno-unused-do-bind -Wno-missing-signatures -Wno-noncanonical-monoid-instances --- -Werror=unused-imports --- -Werror=unused-matches + -Werror=unused-imports + -Werror=unused-matches -Werror=missing-methods --- -Werror=unused-top-binds --- -Werror=unused-local-binds + -Werror=unused-top-binds + -Werror=unused-local-binds -Werror=redundant-constraints -Werror=orphans -Werror=overlapping-patterns From 48612d475ba480366d43fd579a7d3d203dfe34c1 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Tue, 1 Oct 2024 18:12:47 +0100 Subject: [PATCH 08/12] Wee cleanup --- brat/Brat/Parser.hs | 58 +++++++++++++++++++-------------------------- 1 file changed, 24 insertions(+), 34 deletions(-) diff --git a/brat/Brat/Parser.hs b/brat/Brat/Parser.hs index b0bcf60d..9da70dcb 100644 --- a/brat/Brat/Parser.hs +++ b/brat/Brat/Parser.hs @@ -46,18 +46,8 @@ parse p s tks = evalState (runParserT p s tks) (Pos 0 0) instance ShowErrorComponent CustomError where showErrorComponent (Custom s) = s -matchTokFC :: (Tok -> Maybe a) -> Parser (WC a) -matchTokFC f = token (matchTok f) empty - -token0 :: (Tok -> Maybe a) -> Parser a -token0 f = do - WC fc r <- token (matchTok f) empty - -- token matched condition f - put (end fc) - pure r - matchFC :: Tok -> Parser (WC ()) -matchFC tok = label (show tok) $ token (matchTok f) empty +matchFC tok = label (show tok) $ matchTok f where f :: Tok -> Maybe () f t | t == tok = Just () @@ -66,35 +56,35 @@ matchFC tok = label (show tok) $ token (matchTok f) empty match :: Tok -> Parser () match = fmap unWC . matchFC -matchTok :: (Tok -> Maybe a) -> BToken -> Maybe (WC a) -matchTok f (FlatTok (Token fc t)) = (WC fc) <$> f t --- Returns the FC at the beginning of the token -matchTok f (Bracketed _ Paren [t]) = matchTok f t -matchTok _ _ = Nothing - -kmatchFC :: Keyword -> Parser (WC ()) -kmatchFC = matchFC . K +matchTok :: (Tok -> Maybe a) -> Parser (WC a) +matchTok f = token (matcher f) empty + where + matcher :: (Tok -> Maybe a) -> BToken -> Maybe (WC a) + matcher f (FlatTok (Token fc t)) = (WC fc) <$> f t + -- Returns the FC at the beginning of the token + matcher f (Bracketed _ Paren [t]) = matcher f t + matcher _ _ = Nothing -kmatch :: Keyword -> Parser () -kmatch = match . K +kmatch :: Keyword -> Parser (WC ()) +kmatch = matchFC . K matchString :: String -> Parser (WC ()) -matchString s = label (show s) $ matchTokFC $ \case +matchString s = label (show s) $ matchTok $ \case Ident ident | ident == s -> Just () _ -> Nothing hole :: Parser (WC String) -hole = label "hole" $ matchTokFC $ \case +hole = label "hole" $ matchTok $ \case Hole h -> Just h _ -> Nothing simpleName :: Parser (WC String) -simpleName = matchTokFC $ \case +simpleName = matchTok $ \case Ident str -> Just str _ -> Nothing qualifiedName :: Parser (WC UserName) -qualifiedName = label "qualified name" $ matchTokFC $ \case +qualifiedName = label "qualified name" $ matchTok $ \case QualifiedId prefix str -> Just (PrefixName (toList prefix) str) _ -> Nothing @@ -116,22 +106,22 @@ inBracketsFC b p = label lbl $ flip token empty $ \case -- f _ _ = Nothing number :: Parser (WC Int) -number = label "nat" $ matchTokFC $ \case +number = label "nat" $ matchTok $ \case Number n -> Just n _ -> Nothing float :: Parser (WC Double) -float = label "float" $ matchTokFC $ \case +float = label "float" $ matchTok $ \case FloatLit x -> Just x _ -> Nothing -comment :: Parser () -comment = label "Comment" $ token0 $ \case +comment :: Parser (WC ()) +comment = label "Comment" $ matchTok $ \case Comment _ -> Just () _ -> Nothing string :: Parser (WC String) -string = matchTokFC $ \case +string = matchTok $ \case Quoted txt -> Just txt _ -> Nothing @@ -142,13 +132,13 @@ port :: Parser (WC String) port = simpleName comma :: Parser (WC Flat -> WC Flat -> WC Flat) -comma = token0 $ \case +comma = fmap unWC . matchTok $ \case Comma -> Just $ \a b -> WC (spanFCOf a b) (FJuxt a b) _ -> Nothing arith :: ArithOp -> Parser (WC Flat -> WC Flat -> WC Flat) -arith op = token0 $ \tok -> case (op, tok) of +arith op = fmap unWC . matchTok $ \tok -> case (op, tok) of (Add, Plus) -> Just make (Sub, Minus) -> Just make (Mul, Asterisk) -> Just make @@ -533,7 +523,7 @@ expr' p = choice $ (try . getParser <$> enumFrom p) ++ [atomExpr] letIn :: Parser (WC Flat) letIn = label "let ... in" $ do - let_ <- kmatchFC KLet + let_ <- kmatch KLet (lhs, rhs) <- letInBinding kmatch KIn body <- expr @@ -579,7 +569,7 @@ expr' p = choice $ (try . getParser <$> enumFrom p) ++ [atomExpr] composition = subExpr PComp `chainl1` divider Semicolon FCompose divider :: Tok -> (WC Flat -> WC Flat -> Flat) -> Parser (WC Flat -> WC Flat -> WC Flat) - divider tok f = token0 $ \case + divider tok f = fmap unWC . matchTok $ \case t | t == tok -> Just $ \a b -> WC (spanFCOf a b) (f a b) _ -> Nothing From e4842a6fbd64c1c49cdbb34762f4c7b14aba4145 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 2 Oct 2024 14:05:55 +0100 Subject: [PATCH 09/12] drive-by: Fix karlheinz list application --- brat/examples/karlheinz.brat | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brat/examples/karlheinz.brat b/brat/examples/karlheinz.brat index e43814c8..f4a9fbf1 100644 --- a/brat/examples/karlheinz.brat +++ b/brat/examples/karlheinz.brat @@ -89,7 +89,7 @@ answer = energy(results) evaluate(obs :: Observable ,q :: Quantity ,a :: Ansatz - ,rs :: List Real + ,rs :: List(Real) ) -> Real evaluate = ?eval From 3c2be6f4d000d73db897e81b0dca05a7fb9fecb3 Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 2 Oct 2024 14:06:45 +0100 Subject: [PATCH 10/12] fix: Don't allow trailing tokens when parsing between brackets --- brat/Brat/Parser.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/brat/Brat/Parser.hs b/brat/Brat/Parser.hs index 9da70dcb..39ed1172 100644 --- a/brat/Brat/Parser.hs +++ b/brat/Brat/Parser.hs @@ -96,7 +96,7 @@ inBrackets b p = unWC <$> inBracketsFC b p inBracketsFC :: BracketType -> Parser a -> Parser (WC a) inBracketsFC b p = label lbl $ flip token empty $ \case - Bracketed fc b' xs | b == b' -> (WC fc) <$> maybeRight (parse p "" xs) + Bracketed fc b' xs | b == b' -> (WC fc) <$> maybeRight (parse (p <* eof) "" xs) _ -> Nothing where lbl = showOpen b ++ "..." ++ showClose b From 4e9ac06b29cf933a34cb12a16e8cf5c089caf99a Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 6 Nov 2024 11:24:32 +0000 Subject: [PATCH 11/12] Propogate errors from parsers when going under brackets --- brat/Brat/Lexer/Bracketed.hs | 34 ++++++++++-- brat/Brat/Lexer/Token.hs | 4 +- brat/Brat/Parser.hs | 55 +++++++++---------- .../golden/error/multilambda-id2.brat.golden | 6 +- .../golden/error/multilambda-id3.brat.golden | 6 +- brat/test/golden/error/vectorise1.brat.golden | 2 +- 6 files changed, 63 insertions(+), 44 deletions(-) diff --git a/brat/Brat/Lexer/Bracketed.hs b/brat/Brat/Lexer/Bracketed.hs index dce3f7aa..2a972165 100644 --- a/brat/Brat/Lexer/Bracketed.hs +++ b/brat/Brat/Lexer/Bracketed.hs @@ -6,7 +6,8 @@ import Brat.FC import Brat.Lexer.Token import Bwd -import Text.Megaparsec (VisualStream(..)) +import Text.Megaparsec (PosState(..), SourcePos(..), TraversableStream(..), VisualStream(..)) +import Text.Megaparsec.Pos (mkPos) opener :: Tok -> Maybe BracketType opener LParen = Just Paren @@ -26,9 +27,9 @@ data BToken | FlatTok Token deriving (Eq, Ord) -tokLen :: BToken -> Int -tokLen (FlatTok tok) = length (show tok) -tokLen (Bracketed _ _ bs) = sum (tokLen <$> bs) + 2 +btokLen :: BToken -> Int +btokLen (FlatTok tok) = length (show tok) +btokLen (Bracketed _ _ bs) = sum (btokLen <$> bs) + 2 instance Show BToken where show (FlatTok t) = show t @@ -36,7 +37,30 @@ instance Show BToken where instance VisualStream [BToken] where showTokens _ ts = concatMap show ts - tokensLength _ = sum . fmap tokLen + tokensLength _ = sum . fmap btokLen + +instance TraversableStream [BToken] where + reachOffsetNoLine i pos = let fileName = sourceName (pstateSourcePos pos) + (Pos line col, rest) = worker (i - pstateOffset pos + 1) (pstateInput pos) + in pos + { pstateInput = rest + , pstateOffset = max (pstateOffset pos) i + , pstateSourcePos = SourcePos fileName (mkPos line) (mkPos col) + } + where + worker :: Int -> [BToken] -> (Pos, [BToken]) + worker 0 inp@(Bracketed fc _ _:_) = (start fc, inp) + worker 0 inp@(FlatTok t:_) = (start (fc t), inp) + worker i ((Bracketed fc b bts):rest) = let Pos closeLine closeCol = end fc + closeFC = FC (Pos closeLine (closeCol - 1)) (Pos closeLine closeCol) + in worker (i - 1) (bts ++ [FlatTok (Token closeFC (closeTok b))] ++ rest) + worker i (FlatTok t:rest) + | i >= tokenLen t = worker (i - tokenLen t) rest + | otherwise = (start (fc t), FlatTok t:rest) + + closeTok Paren = RParen + closeTok Bracket = RBracket + closeTok Brace = RBrace eofErr :: FC -> BracketType -> Error eofErr fc b = Err (Just fc) (BracketErr (EOFInBracket b)) diff --git a/brat/Brat/Lexer/Token.hs b/brat/Brat/Lexer/Token.hs index 1cf9eff6..114d5aae 100644 --- a/brat/Brat/Lexer/Token.hs +++ b/brat/Brat/Lexer/Token.hs @@ -1,4 +1,4 @@ -module Brat.Lexer.Token (Tok(..), Token(..), Keyword(..)) where +module Brat.Lexer.Token (Tok(..), Token(..), Keyword(..), tokenLen) where import Brat.FC @@ -128,6 +128,8 @@ instance Show Keyword where tokLen :: Tok -> Int tokLen = length . show +tokenLen = tokLen . _tok + instance VisualStream [Token] where showTokens _ ts = concatMap show ts tokensLength _ = sum . fmap (\(Token _ t) -> tokLen t) diff --git a/brat/Brat/Parser.hs b/brat/Brat/Parser.hs index 0a2071c2..c24f5b2d 100644 --- a/brat/Brat/Parser.hs +++ b/brat/Brat/Parser.hs @@ -22,7 +22,6 @@ import Util ((**^)) import Control.Monad (void) import Control.Monad.State (State, evalState, runState, get, put) import Data.Bifunctor -import Data.Either.HT (maybeRight) import Data.Foldable (msum) import Data.Functor (($>), (<&>)) import Data.List (intercalate, uncons) @@ -95,15 +94,11 @@ inBrackets :: BracketType -> Parser a -> Parser a inBrackets b p = unWC <$> inBracketsFC b p inBracketsFC :: BracketType -> Parser a -> Parser (WC a) -inBracketsFC b p = label lbl $ flip token empty $ \case - Bracketed fc b' xs | b == b' -> (WC fc) <$> maybeRight (parse (p <* eof) "" xs) - _ -> Nothing +inBracketsFC b p = contents >>= \(outerFC, toks) -> either (customFailure . Custom . errorBundlePretty) (pure . WC outerFC) (parse (p <* eof) "" toks) where - lbl = showOpen b ++ "..." ++ showClose b - --- f :: Parser a -> BToken -> Maybe (WC a) --- f p (Bracketed fc b' xs) | b == b' = (WC fc) <$> parseMaybe p xs --- f _ _ = Nothing + contents = flip token empty $ \case + Bracketed fc b' xs | b == b' -> Just (fc, xs) + _ -> Nothing number :: Parser (WC Int) number = label "nat" $ matchTok $ \case @@ -320,24 +315,6 @@ spanningFC (x:xs) = pure (WC (spanFC (fcOf $ forgetPortName x) (fcOf . forgetPor rawIOWithSpanFC :: Parser (WC [RawIO]) rawIOWithSpanFC = spanningFC =<< rawIOFC -functionType :: Parser (WC RawVType) -functionType = try (fmap RFn <$> ctype) <|> (fmap RKernel <$> kernel) - where - ctype :: Parser (WC RawCType) - ctype = do - WC startFC ins <- inBracketsFC Paren $ rawIO - match Arrow - WC endFC outs <- rawIOWithSpanFC - pure (WC (spanFC startFC endFC) (ins :-> outs)) - - kernel :: Parser (WC RawKType) - kernel = do - WC startFC ins <- inBracketsFC Paren $ rawIO' (unWC <$> vtype) - match Lolly - WC endFC outs <- spanningFC =<< rawIO' vtype - pure (WC (spanFC startFC endFC) (ins :-> outs)) - - vec :: Parser (WC Flat) vec = (\(WC fc x) -> vec2Cons fc x) <$> (inBracketsFC Bracket elems) where @@ -425,7 +402,7 @@ cthunk = try bratFn <|> try kernel <|> thunk -- Expressions that can occur inside juxtapositions and vectors (i.e. everything with a higher -- precedence than juxtaposition). Precedence table (loosest to tightest binding): atomExpr :: Parser (WC Flat) -atomExpr = simpleExpr <|> inBrackets Paren expr +atomExpr = simpleExpr <|> inBracketsFC Paren (unWC <$> expr) where simpleExpr :: Parser (WC Flat) simpleExpr = fmap FHole <$> hole @@ -805,7 +782,27 @@ pstmt = ((comment "comment") <&> \_ -> ([] , [])) declSignature :: Parser (WC [RawIO]) declSignature = try nDecl <|> vDecl where nDecl = match TypeColon >> rawIOWithSpanFC - vDecl = functionType <&> fmap (\ty -> [Named "thunk" (Right ty)]) + vDecl = functionSignature <&> fmap (\ty -> [Named "thunk" (Right ty)]) + + functionSignature :: Parser (WC RawVType) + functionSignature = try (fmap RFn <$> ctype) <|> (fmap RKernel <$> kernel) + where + ctype :: Parser (WC RawCType) + ctype = do + WC startFC ins <- inBracketsFC Paren $ rawIO + match Arrow + WC endFC outs <- rawIOWithSpanFC + pure (WC (spanFC startFC endFC) (ins :-> outs)) + + kernel :: Parser (WC RawKType) + kernel = do + WC startFC ins <- inBracketsFC Paren $ rawIO' (unWC <$> vtype) + match Lolly + WC endFC outs <- spanningFC =<< rawIO' vtype + pure (WC (spanFC startFC endFC) (ins :-> outs)) + + + pfile :: Parser ([Import], FEnv) pfile = do diff --git a/brat/test/golden/error/multilambda-id2.brat.golden b/brat/test/golden/error/multilambda-id2.brat.golden index bf1eef3e..ead31661 100644 --- a/brat/test/golden/error/multilambda-id2.brat.golden +++ b/brat/test/golden/error/multilambda-id2.brat.golden @@ -1,8 +1,6 @@ Error in test/golden/error/multilambda-id2.brat on line 2: g = { 0 => ||succ(n) => | } - ^^^^^^^^^^^^^^^^^^^^^^^ - - Parse error unexpected {[0,=>,|,|,succ,([n]),=>,|]} -expecting (...), .., [...], _, addition or subtraction, application, composition, hole, into, juxtaposition, lambda, let ... in, multiplication or division, name, nat, power, type annotation, vector pattern, vectorisation, or {...} + ^ + Elab error "Noun required at this position" diff --git a/brat/test/golden/error/multilambda-id3.brat.golden b/brat/test/golden/error/multilambda-id3.brat.golden index 27dd24aa..e97e87e5 100644 --- a/brat/test/golden/error/multilambda-id3.brat.golden +++ b/brat/test/golden/error/multilambda-id3.brat.golden @@ -1,8 +1,6 @@ Error in test/golden/error/multilambda-id3.brat on line 2: f = { true => |;||false =>|;|;|} - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - - Parse error unexpected {[true,=>,|,;,|,|,false,=>,|,;,|,;,|]} -expecting (...), .., [...], _, addition or subtraction, application, composition, hole, into, juxtaposition, lambda, let ... in, multiplication or division, name, nat, power, type annotation, vector pattern, vectorisation, or {...} + ^^^ + Elab error "Noun required at this position" diff --git a/brat/test/golden/error/vectorise1.brat.golden b/brat/test/golden/error/vectorise1.brat.golden index d3c33bd1..570e060c 100644 --- a/brat/test/golden/error/vectorise1.brat.golden +++ b/brat/test/golden/error/vectorise1.brat.golden @@ -1,6 +1,6 @@ Error in test/golden/error/vectorise1.brat on line 2: bad1(n) = (n of (1, 2.0)), (n of 3) - ^^^^^^ + ^^^^^^^^ Type error: Got: Vector of length VPar Ex checking_check_defs_1_bad1_bad1.box_2_lambda_fake_source 0 Expected: empty row From 06f671e930ace412872ff458ba87306a6122db3b Mon Sep 17 00:00:00 2001 From: Craig Roy Date: Wed, 6 Nov 2024 11:30:50 +0000 Subject: [PATCH 12/12] Fix vector FCs --- brat/Brat/Parser.hs | 2 +- brat/test/golden/error/badvec.brat.golden | 2 +- brat/test/golden/error/badvec4.brat.golden | 2 +- brat/test/golden/error/kbadvec.brat.golden | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/brat/Brat/Parser.hs b/brat/Brat/Parser.hs index c24f5b2d..f25eb91f 100644 --- a/brat/Brat/Parser.hs +++ b/brat/Brat/Parser.hs @@ -316,7 +316,7 @@ rawIOWithSpanFC :: Parser (WC [RawIO]) rawIOWithSpanFC = spanningFC =<< rawIOFC vec :: Parser (WC Flat) -vec = (\(WC fc x) -> vec2Cons fc x) <$> (inBracketsFC Bracket elems) +vec = (\(WC fc x) -> WC fc (unWC (vec2Cons fc x))) <$> (inBracketsFC Bracket elems) where elems = (element `chainl1` (try vecComma)) <|> pure [] vecComma = match Comma $> (++) diff --git a/brat/test/golden/error/badvec.brat.golden b/brat/test/golden/error/badvec.brat.golden index 5eaf0102..35e9fc33 100644 --- a/brat/test/golden/error/badvec.brat.golden +++ b/brat/test/golden/error/badvec.brat.golden @@ -1,6 +1,6 @@ Error in test/golden/error/badvec.brat on line 2: v3 = [1] - ^ + ^^^ Expected vector of length 3 from the type: Vec(Int, 3) diff --git a/brat/test/golden/error/badvec4.brat.golden b/brat/test/golden/error/badvec4.brat.golden index 8396b27f..7fe59dfd 100644 --- a/brat/test/golden/error/badvec4.brat.golden +++ b/brat/test/golden/error/badvec4.brat.golden @@ -1,6 +1,6 @@ Error in test/golden/error/badvec4.brat on line 2: v3 = [1,2] - ^^^ + ^^^^^ Expected vector of length 3 from the type: Vec(Int, 3) diff --git a/brat/test/golden/error/kbadvec.brat.golden b/brat/test/golden/error/kbadvec.brat.golden index 6bbb94e4..07a9e553 100644 --- a/brat/test/golden/error/kbadvec.brat.golden +++ b/brat/test/golden/error/kbadvec.brat.golden @@ -1,6 +1,6 @@ Error in test/golden/error/kbadvec.brat on line 2: triple = { b => [b] } - ^ + ^^^ Expected vector of length 3 from the type: Vec(Bit, 3)