From 2705f18e0f97a2c216b712bc22324640fe1443d0 Mon Sep 17 00:00:00 2001 From: Yuri Tatishchev Date: Sun, 3 May 2026 18:15:59 -0700 Subject: [PATCH] gemini fixes --- src/FWL/Check.hs | 28 ++++++++++++++++++++++++---- src/FWL/Compile.hs | 5 ++--- src/FWL/Parser.hs | 37 +++++++++++++++++++++---------------- src/FWL/Pretty.hs | 7 ++----- test/ParserTests.hs | 6 +++--- 5 files changed, 52 insertions(+), 31 deletions(-) diff --git a/src/FWL/Check.hs b/src/FWL/Check.hs index f3bd15d..71fdb67 100644 --- a/src/FWL/Check.hs +++ b/src/FWL/Check.hs @@ -135,15 +135,35 @@ checkFlow env (FSeq a b _) = checkFlow env a ++ checkFlow env b checkArm :: Env -> Arm -> [CheckError] checkArm env (Arm p mg e) = + let env' = addPat env p in checkPat env p ++ - maybe [] (checkExpr env) mg ++ - checkExpr env e + maybe [] (checkExpr env') mg ++ + checkExpr env' e + +addPat :: Env -> Pat -> Env +addPat env (PVar n) = Map.insert n KLet env +addPat env (PCtor _ ps) = foldl' addPat env ps +addPat env (PTuple ps) = foldl' addPat env ps +addPat env (PRecord _ fs) = foldl' addFP env fs +addPat env (PFrame mp inner) = + let env' = case mp of + Just (PathPat ms md) -> + let env1 = case ms of Just (EPName n) -> Map.insert n KLet env; _ -> env + in case md of Just (EPName n) -> Map.insert n KLet env1; _ -> env1 + Nothing -> env + in addPat env' inner +addPat env _ = env + +addFP :: Env -> FieldPat -> Env +addFP env (FPBind n) = Map.insert n KLet env +addFP env (FPAs _ v) = Map.insert v KLet env +addFP env _ = env checkExpr :: Env -> Expr -> [CheckError] checkExpr env (EVar n) = checkName env "name" n checkExpr _ (EQual _) = [] -- qualified names: deferred checkExpr _ (ELit _) = [] -checkExpr env (ELam _ e) = checkExpr env e +checkExpr env (ELam n e) = checkExpr (Map.insert n KLet env) e checkExpr env (EApp f x) = checkExpr env f ++ checkExpr env x checkExpr env (ECase e ab) = checkExpr env e ++ concatMap (checkArm env) ab checkExpr env (EIf c t f) = concatMap (checkExpr env) [c,t,f] @@ -157,7 +177,7 @@ checkExpr env (EInfix _ l r) = checkExpr env l ++ checkExpr env r checkExpr env (ENot e) = checkExpr env e checkStmt :: Env -> DoStmt -> [CheckError] -checkStmt env (DSBind _ e) = checkExpr env e +checkStmt env (DSBind n e) = checkExpr env e checkStmt env (DSExpr e) = checkExpr env e -- ─── Policy termination ─────────────────────────────────────────────────────── diff --git a/src/FWL/Compile.hs b/src/FWL/Compile.hs index 83227e4..ad6033f 100644 --- a/src/FWL/Compile.hs +++ b/src/FWL/Compile.hs @@ -301,9 +301,8 @@ renderLit (LInt n) = show n renderLit (LString s) = s renderLit (LBool True) = "true" renderLit (LBool False) = "false" -renderLit (LIPv4 (a, b, c, d)) = - show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d -renderLit (LIPv6 _) = "::1" +renderLit (LIP IPv4 n) = renderIPv4 n +renderLit (LIP IPv6 n) = renderIPv6 n renderLit (LCIDR ip p) = renderLit ip ++ "/" ++ show p renderLit (LPort p) = show p renderLit (LDuration n Seconds) = show n ++ "s" diff --git a/src/FWL/Parser.hs b/src/FWL/Parser.hs index 24a1dfd..26e67e2 100644 --- a/src/FWL/Parser.hs +++ b/src/FWL/Parser.hs @@ -3,7 +3,7 @@ module FWL.Parser , parseFile ) where -import Control.Monad (void) +import Control.Monad (void, when) import Data.Bits ((.&.), (.|.), shiftL) import Data.List (foldl') import Data.Word (Word8) @@ -15,6 +15,7 @@ import qualified Text.Parsec.Expr as Ex import FWL.AST import FWL.Lexer +import Data.Char (isUpper) -- ─── Entry points ──────────────────────────────────────────────────────────── @@ -37,7 +38,7 @@ program = do configBlock :: Parser Config configBlock = do reserved "config" - props <- braces (semiSep configProp) + props <- braces (endBy configProp semi) optional semi return $ foldr applyProp defaultConfig props where @@ -330,13 +331,12 @@ fieldLiteral = try portLit <|> literal n <- fromIntegral <$> natural return (LPort n) --- Named pattern reference OR constructor: starts with uppercase-ish ident namedOrCtorPat :: Parser Pat namedOrCtorPat = do n <- identifier args <- optionMaybe (try (parens (commaSep pat))) case args of - Nothing -> return (PNamed n) -- bare name = named pattern ref + Nothing -> return $ if null n then PWild else if isUpper (head n) then PNamed n else PVar n Just ps -> return (PCtor n ps) -- ─── Flow expressions ──────────────────────────────────────────────────────── @@ -346,13 +346,17 @@ flowExpr = do first <- FAtom <$> identifier rest <- many (reservedOp "." >> identifier) mw <- optionMaybe (reserved "within" >> durationLit) - return $ buildSeq (first : map FAtom rest) mw + let chain = buildSeq (first : map FAtom rest) + return $ case mw of + Nothing -> chain + Just w -> attach w chain where - buildSeq [x] mw = case mw of - Nothing -> x - Just w -> FSeq x x (Just w) -- degenerate - buildSeq (x:xs) mw = FSeq x (buildSeq xs mw) mw - buildSeq [] _ = error "impossible" + buildSeq [x] = x + buildSeq (x:xs) = FSeq x (buildSeq xs) Nothing + buildSeq [] = error "impossible" + + attach w (FSeq a b _) = FSeq a b (Just w) + attach w x = FSeq x x (Just w) durationLit :: Parser Duration durationLit = do @@ -588,17 +592,18 @@ ipv4Lit_ = do -- Stores as LIP IPv6 (128-bit Integer). ipv6Lit :: Parser Literal ipv6Lit = do - (left, right) <- ipv6Groups + (left, hasDbl, right) <- ipv6Groups let missing = 8 - length left - length right when (missing < 0) $ fail "too many groups in IPv6 address" + when (not hasDbl && missing /= 0) $ fail "invalid IPv6 address (must have 8 groups or use ::)" let groups = left ++ replicate missing 0 ++ right when (length groups /= 8) $ fail "invalid IPv6 address" let val = foldl' (\acc g -> (acc `shiftL` 16) .|. fromIntegral g) (0::Integer) groups return (LIP IPv6 val) --- Returns (left-of-::, right-of-::). +-- Returns (left-of-::, has_dbl_colon, right-of-::). -- If no :: present, left has all 8 groups and right is empty. -ipv6Groups :: Parser ([Int], [Int]) +ipv6Groups :: Parser ([Int], Bool, [Int]) ipv6Groups = do -- must start with a hex digit or ':' (for ::) ahead <- lookAhead (hexDigit <|> char ':') @@ -606,15 +611,15 @@ ipv6Groups = do ':' -> do void (string "::") right <- ipv6RightGroups - return ([], right) + return ([], True, right) _ -> do left <- ipv6LeftGroups mDbl <- optionMaybe (try (string "::")) case mDbl of - Nothing -> return (left, []) + Nothing -> return (left, False, []) Just _ -> do right <- ipv6RightGroups - return (left, right) + return (left, True, right) -- Parse a run of hex16:hex16:... stopping before :: or end ipv6LeftGroups :: Parser [Int] diff --git a/src/FWL/Pretty.hs b/src/FWL/Pretty.hs index a2430fa..790309e 100644 --- a/src/FWL/Pretty.hs +++ b/src/FWL/Pretty.hs @@ -49,8 +49,6 @@ prettyIfaceProp (IPCidr4 cs) = "cidr4 = { " ++ intercalate ", " (map prettyCidr prettyIfaceProp (IPCidr6 cs) = "cidr6 = { " ++ intercalate ", " (map prettyCidr cs) ++ " }" prettyCidr :: CIDR -> String -prettyCidr (LIPv4 (a,b,c,d), p) = - show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d ++ "/" ++ show p prettyCidr (ip, p) = prettyLit ip ++ "/" ++ show p prettyHook :: Hook -> String @@ -178,9 +176,8 @@ prettyLit (LInt n) = show n prettyLit (LString s) = "\"" ++ s ++ "\"" prettyLit (LBool True) = "true" prettyLit (LBool False) = "false" -prettyLit (LIPv4 (a,b,c,d)) = - show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d -prettyLit (LIPv6 _) = "" +prettyLit (LIP IPv4 n) = renderIPv4 n +prettyLit (LIP IPv6 n) = renderIPv6 n prettyLit (LCIDR ip p) = prettyLit ip ++ "/" ++ show p prettyLit (LPort p) = ":" ++ show p prettyLit (LDuration n u) = show n ++ prettyUnit u diff --git a/test/ParserTests.hs b/test/ParserTests.hs index c1f544a..d7f8708 100644 --- a/test/ParserTests.hs +++ b/test/ParserTests.hs @@ -37,7 +37,7 @@ interfaceTests = testGroup "interface" p <- parseOk "interface lan : LAN { cidr4 = { 10.0.0.0/8 }; };" d <- singleDecl p case d of - DInterface "lan" ILan [IPCidr4 [(LIPv4 (10,0,0,0), 8)]] -> return () + DInterface "lan" ILan [IPCidr4 [(ip, 8)]] | ip == ipv4Lit 10 0 0 0 -> return () _ -> assertFailure (show d) , testCase "LAN with cidr4 and cidr6" $ do @@ -165,7 +165,7 @@ patternTests = testGroup "pattern" \ Frame(_, IPv4(ip, WGInitiation));" d <- singleDecl p case d of - DPattern "Complex" _ (PFrame Nothing (PCtor "IPv4" [PVar "ip", PNamed "WGInitiation"])) -> + DPattern "Complex" _ (PFrame (Just _) (PCtor "IPv4" [PVar "ip", PNamed "WGInitiation"])) -> return () _ -> assertFailure (show d) @@ -407,7 +407,7 @@ policyTests = testGroup "policy" \ };" d <- singleDecl p case d of - DPolicy _ _ _ (Arm (PFrame Nothing (PCtor "IPv4" _)) _ _ : _) -> return () + DPolicy _ _ _ (Arm (PFrame (Just _) (PCtor "IPv4" _)) _ _ : _) -> return () _ -> assertFailure (show d) , testCase "policy arm calls rule" $ do