diff --git a/brat/Brat/Error.hs b/brat/Brat/Error.hs index f34dba14..efb1db66 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 Brat.Syntax.Port (PortName) import Data.List (intercalate) @@ -26,6 +28,28 @@ instance Show a => Show (LengthConstraintF a) where type LengthConstraint = LengthConstraintF Int +data BracketErrMsg + = EOFInBracket BracketType -- FC in enclosing `Err` should point to the open bracket + -- FC here is opening; closing FC in the enclosing `Err` + | OpenCloseMismatch (FC, BracketType) BracketType + | 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 @@ -83,6 +107,7 @@ data ErrorMsg -- The argument is the row of unused connectors | ThunkLeftOvers String | ThunkLeftUnders String + | BracketErr BracketErrMsg instance Show ErrorMsg where show (TypeErr x) = "Type error: " ++ x @@ -166,6 +191,7 @@ instance Show ErrorMsg where show UnreachableBranch = "Branch cannot be reached" show (ThunkLeftOvers overs) = "Expected function to address all inputs, but " ++ overs ++ " wasn't used" show (ThunkLeftUnders unders) = "Expected function to return additional values of type: " ++ unders + show (BracketErr msg) = show msg data Error = Err { fc :: Maybe FC diff --git a/brat/Brat/FC.hs b/brat/Brat/FC.hs index 958df5d1..669b9506 100644 --- a/brat/Brat/FC.hs +++ b/brat/Brat/FC.hs @@ -35,3 +35,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 _) = spanFC afc bfc diff --git a/brat/Brat/Lexer/Bracketed.hs b/brat/Brat/Lexer/Bracketed.hs new file mode 100644 index 00000000..d668c1ed --- /dev/null +++ b/brat/Brat/Lexer/Bracketed.hs @@ -0,0 +1,98 @@ +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 Data.List.NonEmpty (NonEmpty(..)) +import Data.Bifunctor (first) +import Text.Megaparsec (PosState(..), SourcePos(..), TraversableStream(..), VisualStream(..)) +import Text.Megaparsec.Pos (mkPos) + +data OpenClose = Open BracketType | Close BracketType + +openClose :: Tok -> Maybe OpenClose +openClose LParen = Just (Open Paren) +openClose LSquare = Just (Open Square) +openClose LBrace = Just (Open Brace) +openClose RParen = Just (Close Paren) +openClose RSquare = Just (Close Square) +openClose RBrace = Just (Close Brace) +openClose _ = Nothing + +-- Well bracketed tokens +data BToken + = Bracketed FC BracketType [BToken] + | FlatTok Token + deriving (Eq, Ord) + +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 + show (Bracketed _ b ts) = showOpen b ++ concatMap show ts ++ showClose b + +instance VisualStream [BToken] where + showTokens _ = concatMap show + tokensLength _ = sum . fmap btokLen + +instance TraversableStream [BToken] where + reachOffsetNoLine i pos = let fileName = sourceName (pstateSourcePos pos) + (Pos line col, rest) = skipChars (i - pstateOffset pos + 1) (pstateInput pos) + in pos + { pstateInput = rest + , pstateOffset = max (pstateOffset pos) i + , pstateSourcePos = SourcePos fileName (mkPos line) (mkPos col) + } + where + skipChars :: Int -> [BToken] -> (Pos, [BToken]) + skipChars 0 inp@(Bracketed fc _ _:_) = (start fc, inp) + skipChars 0 inp@(FlatTok t:_) = (start (fc t), inp) + skipChars i ((Bracketed fc b bts):rest) = + let Pos closeLine closeCol = end fc + closeFC = FC (Pos closeLine (closeCol - 1)) (Pos closeLine closeCol) + in skipChars (i - 1) (bts ++ [FlatTok (Token closeFC (closeTok b))] ++ rest) + skipChars i (FlatTok t:rest) + | i >= tokenLen t = skipChars (i - tokenLen t) rest + | otherwise = (start (fc t), FlatTok t:rest) + + closeTok Paren = RParen + closeTok Square = RSquare + closeTok Brace = RBrace + +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)) + +brackets :: [Token] -> Either Error [BToken] +brackets ts = helper ts >>= \case + (res, Nothing) -> pure res + (_, Just (b, t:|_)) -> Left $ unexpectedCloseErr (fc t, b) + where + -- Given a list of tokens, either + -- (success) return [BToken] consisting of the prefix of the input [Token] in which all opened brackets are closed, + -- and any remaining [Token] beginning with a closer that does not match any opener in the input + -- (either Nothing = no remaining tokens; or tokens with the BracketType that the first token closes) + -- (failure) return an error, if a bracket opened in the input, is either not closed (EOF) or does not match the closer + helper :: [Token] -> Either Error ([BToken], Maybe (BracketType, NonEmpty Token)) + helper [] = pure ([], Nothing) + helper (t:ts) = case openClose (_tok t) of + Just (Open b) -> let openFC = fc t in helper ts >>= \case + (_, Nothing) -> Left $ eofErr (fc t, b) + (within, Just (b', r :| rs)) -> + let closeFC = fc r + enclosingFC = spanFC openFC closeFC + in if b == b' + then first (Bracketed enclosingFC b within:) <$> helper rs + else Left $ openCloseMismatchErr (openFC, b) (closeFC, b') + Just (Close b) -> pure ([], Just (b, t :| ts)) -- return closer for caller + Nothing -> first (FlatTok t:) <$> helper ts diff --git a/brat/Brat/Lexer/Flat.hs b/brat/Brat/Lexer/Flat.hs index 1f41d5ba..e47d9db2 100644 --- a/brat/Brat/Lexer/Flat.hs +++ b/brat/Brat/Lexer/Flat.hs @@ -54,8 +54,8 @@ tok = try (char '(' $> LParen) <|> try (char ')' $> RParen) <|> try (char '{' $> LBrace) <|> try (char '}' $> RBrace) - <|> try (char '[' $> LBracket) - <|> try (char ']' $> RBracket) + <|> try (char '[' $> LSquare) + <|> try (char ']' $> RSquare) <|> try (Underscore <$ string "_") <|> try (Quoted <$> (char '"' *> printChar `manyTill` char '"')) <|> try (FloatLit <$> float) diff --git a/brat/Brat/Lexer/Token.hs b/brat/Brat/Lexer/Token.hs index d5f8842b..5765a546 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 @@ -21,8 +21,8 @@ data Tok | RParen | LBrace | RBrace - | LBracket - | RBracket + | LSquare + | RSquare | Semicolon | Into | Comma @@ -66,8 +66,8 @@ instance Show Tok where show RParen = ")" show LBrace = "{" show RBrace = "}" - show LBracket = "[" - show RBracket = "]" + show LSquare = "[" + show RSquare = "]" show Semicolon = ";" show Into = "|>" show Comma = "," @@ -102,7 +102,8 @@ 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' @@ -128,6 +129,8 @@ instance Show Keyword where tokLen :: Tok -> Int tokLen = length . show +tokenLen = tokLen . _tok + instance VisualStream [Token] where tokensLength _ = sum . fmap (\(Token _ t) -> tokLen t) showTokens _ = concatMap show diff --git a/brat/Brat/Parser.hs b/brat/Brat/Parser.hs index 494f193b..e6d9e7e9 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.QualName ( plain, QualName(..) ) @@ -15,17 +16,19 @@ import Brat.Syntax.Concrete import Brat.Syntax.Raw import Brat.Syntax.Simple 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.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.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, fromMaybe) import Data.Set (empty) import Prelude hiding (lex, round) import Text.Megaparsec hiding (Pos, Token, State, empty, match, ParseError, parse) @@ -34,112 +37,101 @@ 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 - thing <- p - end <- get - pure (WC (FC start end) thing) - -nextToken :: Parser Token -nextToken = lookAhead $ token Just empty - -token0 :: (Tok -> Maybe a) -> Parser a -token0 f = do - (fc, r) <- token (\(Token fc t) -> (fc,) <$> f t) empty - -- token matched condition f - put (end fc) - pure r +matchFC :: Tok -> Parser (WC ()) +matchFC tok = label (show tok) $ matchTok f + 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 -kmatch :: Keyword -> Parser () -kmatch = match . K - -matchString :: String -> Parser () -matchString s = ident $ \x -> if x == s then Just () else Nothing - -ident :: (String -> Maybe a) -> Parser a -ident f = label "identifier" $ token0 $ \case - Ident str -> f str +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 (WC ()) +kmatch = matchFC . K + +matchString :: String -> Parser (WC ()) +matchString s = label (show s) $ matchTok $ \case + Ident ident | ident == s -> Just () _ -> Nothing -hole :: Parser String -hole = label "hole" $ token0 $ \case +hole :: Parser (WC String) +hole = label "hole" $ matchTok $ \case Hole h -> Just h _ -> Nothing -simpleName :: Parser String -simpleName = token0 $ \case +simpleName :: Parser (WC String) +simpleName = matchTok $ \case Ident str -> Just str _ -> Nothing -qualName :: Parser QualName -qualName = ( "name") $ try qualifiedName <|> (PrefixName [] <$> simpleName) - where - qualifiedName :: Parser QualName - qualifiedName = ( "qualified name") . token0 $ \case - QualifiedId prefix str -> Just (PrefixName (toList prefix) str) - _ -> Nothing - - - -round :: Parser a -> Parser a -round p = label "(...)" $ match LParen *> p <* match RParen - -square :: Parser a -> Parser a -square p = label "[...]" $ match LBracket *> p <* match RBracket +qualName :: Parser (WC QualName) +qualName = label "qualified name" $ matchTok $ \case + QualifiedId prefix str -> Just (PrefixName (toList prefix) str) + Ident str -> Just (PrefixName [] str) + _ -> Nothing -curly :: Parser a -> Parser a -curly p = label "{...}" $ match LBrace *> p <* match RBrace +inBrackets :: BracketType -> Parser a -> Parser a +inBrackets b p = unWC <$> inBracketsFC b p -inLet :: Parser a -> Parser a -inLet p = label "let ... in" $ kmatch KLet *> p <* kmatch KIn +inBracketsFC :: BracketType -> Parser a -> Parser (WC a) +inBracketsFC b p = contents >>= \(outerFC, toks) -> either (customFailure . Custom . errorBundlePretty) (pure . WC outerFC) (parse (p <* eof) "" toks) + where + contents = flip token empty $ \case + Bracketed fc b' xs | b == b' -> Just (fc, xs) + _ -> Nothing -number :: Parser Int -number = label "nat" $ token0 $ \case +number :: Parser (WC Int) +number = label "nat" $ matchTok $ \case Number n -> Just n _ -> Nothing -float :: Parser Double -float = label "float" $ token0 $ \case +float :: Parser (WC Double) +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 String -string = token0 $ \case +string :: Parser (WC String) +string = matchTok $ \case Quoted txt -> Just txt _ -> Nothing -var :: Parser Flat -var = FVar <$> qualName +var :: Parser (WC Flat) +var = fmap FVar <$> qualName +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 -> - 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) -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 @@ -160,109 +152,149 @@ 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 <- 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)) 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, _, 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 Square ((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 - - binderComma :: Parser (Abstractor -> Abstractor -> Abstractor) - binderComma = match Comma $> (:||:) + portPull = port <* match PortColon -- 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) + <|> (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 @@ -270,72 +302,75 @@ 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) - where - ctype :: Parser RawCType - ctype = do - ins <- round $ rawIO (unWC <$> vtype) - match Arrow - outs <- rawIO (unWC <$> vtype) - pure (ins :-> outs) - - kernel :: Parser RawKType - kernel = do - ins <- round $ rawIO' (unWC <$> vtype) - match Lolly - outs <- rawIO' (unWC <$> vtype) - pure (ins :-> outs) +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 -vec :: Parser Flat -vec = (\(WC fc x) -> unWC $ vec2Cons (end fc) x) <$> withFC (square elems) +vec :: Parser (WC Flat) +vec = (\(WC fc x) -> WC fc (unWC (vec2Cons fc x))) <$> inBracketsFC Square 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 - -- 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 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 @@ -362,6 +397,24 @@ 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 <|> inBracketsFC Paren (unWC <$> expr) + where + simpleExpr :: Parser (WC Flat) + simpleExpr = fmap FHole <$> hole + <|> try (fmap FSimple <$> simpleTerm) + <|> try fanin + <|> try fanout + <|> vec + <|> cthunk + <|> fmap (const FPass) <$> matchFC DotDot + <|> var + <|> fmap (const FUnderscore) <$> matchFC Underscore + <|> fmap (const FIdentity) <$> matchFC Pipe + + {- Infix operator precedence table (See Brat.Syntax.Common.Precedence) (loosest to tightest binding): => @@ -378,12 +431,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" @@ -397,129 +450,145 @@ 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 + let juxtElems = case args of + [] -> rhs :| [] + (a:as) -> a :| (as ++ [rhs]) + pure (WC (spanFCOf lhs rhs) (FCon c (mkJuxt juxtElems))) + Nothing -> pure lhs - ofExpr :: Parser Flat + ofExpr :: Parser (WC Flat) ofExpr = do - lhs <- withFC (subExpr POf) + lhs <- subExpr POf optional (kmatch KOf) >>= \case - Nothing -> pure (unWC lhs) - Just () -> FOf lhs <$> withFC ofExpr + Nothing -> pure lhs + Just _ -> do + rhs <- ofExpr + pure (WC (spanFCOf lhs rhs) (lhs `FOf` rhs)) - 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 = 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 + WC (spanFCOf tm colon) . FAnnotation tm <$> rawIO + + letIn :: Parser (WC Flat) + letIn = label "let ... in" $ do + let_ <- kmatch 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)) + _ -> end (fcOf (snd (last otherClauses))) + 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 + divider tok f = fmap unWC . matchTok $ \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 = do - ports <- many (try (port <* match PortColon)) + ports <- many (try portPull) + let firstPortFC = fcOf . fst <$> uncons ports case ports of [] -> juxtRhsWithPull - _ -> FPull ports <$> withFC 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 <- withFC (subExpr PJuxtPull) - rest <- optional (match Comma *> withFC pullAndJuxt) + expr <- subExpr PJuxtPull + rest <- optional (match Comma *> pullAndJuxt) pure $ case rest of - Nothing -> unWC expr - Just rest -> FJuxt expr rest + Nothing -> expr + Just rest@(WC restFC _) -> WC (spanFC (fcOf expr) restFC) (FJuxt expr rest) - fanout = square (FFanOut <$ match Slash <* match Backslash) - fanin = square (FFanIn <$ match Backslash <* match Slash) +fanout = inBracketsFC Square (FFanOut <$ match Slash <* match Backslash) +fanin = inBracketsFC Square (FFanIn <$ match Backslash <* match Slash) - -- Expressions which don't contain juxtaposition or operators - atomExpr :: Parser Flat - atomExpr = simpleExpr <|> round expr - where - simpleExpr = FHole <$> hole - <|> try (FSimple <$> simpleTerm) - <|> try fanout - <|> try fanin - <|> vec - <|> cthunk - <|> try (match DotDot $> FPass) - <|> var - <|> match Underscore $> FUnderscore - <|> match Pipe $> FIdentity - - -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 @@ -532,17 +601,17 @@ 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) + (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 @@ -556,12 +625,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 - withFC expr + body@(WC fc _) <- expr + pure (WC fc (FNoLhs body)) class FCStream a where getFC :: Int -> PosState a -> FC @@ -580,10 +657,18 @@ instance FCStream [Token] where [] -> spToFC pstateSourcePos (Token fc _):_ -> fc +instance FCStream [BToken] where + getFC o PosState{..} = case drop (o - pstateOffset) pstateInput of + [] -> spToFC 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 @@ -599,19 +684,20 @@ parseFile fname contents = addSrcContext fname contents $ do clauses :: String -> Parser (NonEmpty (WC Abstractor, WC Flat)) clauses declName = label "clauses" (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 qualName + x <- qualName a <- alias Import x (not o) a <$> selection where @@ -623,7 +709,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 @@ -633,7 +719,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") <&> \_ -> ([] , [])) @@ -642,16 +728,16 @@ 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 (QualName, [(String, TypeKind)], RawVType) + aliasContents :: Parser (FC, QualName, [(String, TypeKind)], RawVType) aliasContents = do - match (K KType) - alias <- qualName - args <- option [] $ round (simpleName `sepBy` match Comma) + WC startFC () <- matchFC (K KType) + WC _ alias <- qualName + 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 @@ -663,21 +749,21 @@ 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 (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 <- 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 (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 @@ -685,9 +771,31 @@ pstmt = ((comment "comment") <&> \_ -> ([] , [])) , fnLoc = fc , fnLocality = Extern symbol } - where - nDecl = match TypeColon >> outputs - vDecl = (:[]) . Named "thunk" . Right <$> functionType + +declSignature :: Parser (WC [RawIO]) +declSignature = try nDecl <|> vDecl where + nDecl = match TypeColon >> rawIOWithSpanFC + 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/Brat/Syntax/Common.hs b/brat/Brat/Syntax/Common.hs index dacd8d1b..eb355607 100644 --- a/brat/Brat/Syntax/Common.hs +++ b/brat/Brat/Syntax/Common.hs @@ -110,8 +110,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 diff --git a/brat/Data/Bracket.hs b/brat/Data/Bracket.hs new file mode 100644 index 00000000..2b1ce93f --- /dev/null +++ b/brat/Data/Bracket.hs @@ -0,0 +1,13 @@ +module Data.Bracket where + +data BracketType = Paren | Square | Brace deriving (Eq, Ord) + +showOpen :: BracketType -> String +showOpen Paren = "(" +showOpen Square = "[" +showOpen Brace = "{" + +showClose :: BracketType -> String +showClose Paren = ")" +showClose Square = "]" +showClose Brace = "}" diff --git a/brat/brat.cabal b/brat/brat.cabal index 58a29efa..3265d13e 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, diff --git a/brat/test/golden/binding/cons.brat.golden b/brat/test/golden/binding/cons.brat.golden index 5742b0a3..150bf837 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 on line 7: badUncons(cons(stuff)) = stuff - ^^^^^^^^^^^^^ + ^^^^^^^^^^^ Unification error: Pattern doesn't match expected length for constructor args diff --git a/brat/test/golden/error/fanin-diff-types.brat.golden b/brat/test/golden/error/fanin-diff-types.brat.golden index f97d0b45..1e4f402f 100644 --- a/brat/test/golden/error/fanin-diff-types.brat.golden +++ b/brat/test/golden/error/fanin-diff-types.brat.golden @@ -1,6 +1,6 @@ Error in test/golden/error/fanin-diff-types.brat on line 2: f = { [\/] } - ^^^^^^^^ + ^^^^ Type mismatch when checking [\/] Expected: Qubit diff --git a/brat/test/golden/error/fanin-dynamic-length.brat.golden b/brat/test/golden/error/fanin-dynamic-length.brat.golden index 993c4357..0c4e0242 100644 --- a/brat/test/golden/error/fanin-dynamic-length.brat.golden +++ b/brat/test/golden/error/fanin-dynamic-length.brat.golden @@ -1,6 +1,6 @@ Error in test/golden/error/fanin-dynamic-length.brat on line 2: f(n) = { [\/] } - ^^^^^^^^ + ^^^^ Type error: Can't fanout a Vec with non-constant length: VPar Ex checking_check_defs_1_f_f.box_2_lambda_fake_source 0 diff --git a/brat/test/golden/error/fanin-list.brat.golden b/brat/test/golden/error/fanin-list.brat.golden index 6a8a2989..cf210abf 100644 --- a/brat/test/golden/error/fanin-list.brat.golden +++ b/brat/test/golden/error/fanin-list.brat.golden @@ -1,6 +1,6 @@ Error in test/golden/error/fanin-list.brat on line 2: f = { [\/] } - ^^^^^^^^ + ^^^^ Type error: Fanin ([\/]) only applies to Vec diff --git a/brat/test/golden/error/fanin-not-enough-overs.brat.golden b/brat/test/golden/error/fanin-not-enough-overs.brat.golden index 82d88b1c..0fa9c943 100644 --- a/brat/test/golden/error/fanin-not-enough-overs.brat.golden +++ b/brat/test/golden/error/fanin-not-enough-overs.brat.golden @@ -1,6 +1,6 @@ Error in test/golden/error/fanin-not-enough-overs.brat on line 2: f = { [\/] } - ^^^^^^^^ + ^^^^ Type error: Not enough inputs to make a vector of size 3 diff --git a/brat/test/golden/error/fanout-diff-types.brat.golden b/brat/test/golden/error/fanout-diff-types.brat.golden index 1f52499e..abde4a2f 100644 --- a/brat/test/golden/error/fanout-diff-types.brat.golden +++ b/brat/test/golden/error/fanout-diff-types.brat.golden @@ -1,6 +1,6 @@ Error in test/golden/error/fanout-diff-types.brat on line 2: f = { [/\] } - ^^^^^^^^ + ^^^^ Type mismatch when checking [/\] Expected: (b1 :: Bit) diff --git a/brat/test/golden/error/fanout-dynamic-length.brat.golden b/brat/test/golden/error/fanout-dynamic-length.brat.golden index 2d79c6e4..4c87893c 100644 --- a/brat/test/golden/error/fanout-dynamic-length.brat.golden +++ b/brat/test/golden/error/fanout-dynamic-length.brat.golden @@ -1,6 +1,6 @@ Error in test/golden/error/fanout-dynamic-length.brat on line 2: f(n) = { [/\] } - ^^^^^^^^ + ^^^^ Type error: Can't fanout a Vec with non-constant length: VPar Ex checking_check_defs_1_f_f.box_2_lambda_fake_source 0 diff --git a/brat/test/golden/error/fanout-list.brat.golden b/brat/test/golden/error/fanout-list.brat.golden index 8214f883..95895a9c 100644 --- a/brat/test/golden/error/fanout-list.brat.golden +++ b/brat/test/golden/error/fanout-list.brat.golden @@ -1,6 +1,6 @@ Error in test/golden/error/fanout-list.brat on line 2: f = { [/\] } - ^^^^^^^^ + ^^^^ Type error: Fanout ([/\]) only applies to Vec diff --git a/brat/test/golden/error/fanout-too-many-overs.brat.golden b/brat/test/golden/error/fanout-too-many-overs.brat.golden index bcf8c6b5..465ea12b 100644 --- a/brat/test/golden/error/fanout-too-many-overs.brat.golden +++ b/brat/test/golden/error/fanout-too-many-overs.brat.golden @@ -1,6 +1,6 @@ Error in test/golden/error/fanout-too-many-overs.brat on line 2: f = { [/\] } - ^^^^^^^^ + ^^^^ Type error: No unders but overs: (head :: Nat) for [/\] 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 9b17e59f..8a03a084 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 on line 2: -f = { [1,2] => true } - ^^^^^ +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 8acaa5c5..369fcaaf 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 on line 2: f(a, b) = [] - ^^^^^^ + ^^^^ Nothing to bind to: b diff --git a/brat/test/golden/error/toplevel-leftovers3.brat.golden b/brat/test/golden/error/toplevel-leftovers3.brat.golden index 23727f22..84290ebb 100644 --- a/brat/test/golden/error/toplevel-leftovers3.brat.golden +++ b/brat/test/golden/error/toplevel-leftovers3.brat.golden @@ -1,6 +1,6 @@ Error in test/golden/error/toplevel-leftovers3.brat on line 2: f(x) = x - ^^^ + ^ Type error: Inputs (b1 :: Bool) weren't used diff --git a/brat/test/golden/error/unmatched_bracket.brat.golden b/brat/test/golden/error/unmatched_bracket.brat.golden index f61aa5d2..ebc76650 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 on line 1: f(n, Vec([], n) -> Vec([], n) -- First bracket never closed - ^^ - - Parse error unexpected -> -expecting (...) or ) + ^ + File ended before this ( was closed diff --git a/brat/test/golden/error/vecpat.brat.golden b/brat/test/golden/error/vecpat.brat.golden index 34f98e75..335d7fd1 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 on line 3: 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 9009111f..ecb3ff7f 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 on line 3: 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 3eedcbce..e1ba8ab9 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 on line 3: 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 1938ca9a..9657dbbe 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 on line 2: 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 3734c119..2aea3dc3 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 on line 2: 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 050cdbab..2477d48f 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 on line 2: 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 b4297b53..ea70a16f 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 on line 2: deleteSnd = { q0, q1 => q0 } - ^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^ Type error: Variable(s) q1 haven't been used