v1 perplexed

.gitignore

@@ -0,0 +1 @@
+dist-newstyle

app/Main.hs

@@ -0,0 +1,57 @@
+module Main where
+
+import System.Environment (getArgs)
+import System.Exit (exitFailure, exitSuccess)
+import System.IO (hPutStrLn, stderr)
+
+import FWL.Parser  (parseFile)
+import FWL.Pretty  (prettyProgram)
+import FWL.Check   (checkProgram)
+import FWL.Compile (compileToJson, compileProgram)
+
+main :: IO ()
+main = do
+  args <- getArgs
+  case args of
+    ["check",  fp] -> runCheck fp
+    ["compile", fp] -> runCompile fp
+    ["pretty",  fp] -> runPretty fp
+    _ -> do
+      putStrLn "Usage: fwlc <command> <file.fwl>"
+      putStrLn "  check   <file>   -- parse and static-check"
+      putStrLn "  compile <file>   -- emit nftables JSON to stdout"
+      putStrLn "  pretty  <file>   -- parse and re-print"
+      exitFailure
+
+runCheck :: FilePath -> IO ()
+runCheck fp = do
+  result <- parseFile fp
+  case result of
+    Left err -> hPutStrLn stderr ("Parse error:\n" ++ show err) >> exitFailure
+    Right prog -> do
+      let errs = checkProgram prog
+      if null errs
+        then putStrLn "OK" >> exitSuccess
+        else do
+          mapM_ (hPutStrLn stderr . show) errs
+          exitFailure
+
+runCompile :: FilePath -> IO ()
+runCompile fp = do
+  result <- parseFile fp
+  case result of
+    Left err -> hPutStrLn stderr ("Parse error:\n" ++ show err) >> exitFailure
+    Right prog -> do
+      let errs = checkProgram prog
+      if null errs
+        then putStrLn (compileToJson prog)
+        else do
+          mapM_ (hPutStrLn stderr . ("Check error: " ++) . show) errs
+          exitFailure
+
+runPretty :: FilePath -> IO ()
+runPretty fp = do
+  result <- parseFile fp
+  case result of
+    Left err -> hPutStrLn stderr ("Parse error:\n" ++ show err) >> exitFailure
+    Right prog -> putStr (prettyProgram prog)

cabal.project

@@ -0,0 +1 @@
+packages: .

fwl.cabal

@@ -0,0 +1,38 @@
+cabal-version:      3.0
+name:               fwl
+version:            0.1.0.0
+synopsis:           Firewall Language — MVP
+build-type:         Simple
+
+common shared
+  ghc-options:      -Wall
+  default-language: Haskell2010
+
+library
+  import:           shared
+  hs-source-dirs:   src
+  exposed-modules:
+      FWL.AST
+    , FWL.Lexer
+    , FWL.Parser
+    , FWL.Pretty
+    , FWL.Check
+    , FWL.Compile
+  build-depends:
+      base        >= 4.14
+    , parsec      >= 3.1
+    , aeson       >= 2.0
+    , aeson-pretty >= 0.8
+    , text        >= 1.2
+    , containers  >= 0.6
+    , mtl         >= 2.2
+    , prettyprinter >= 1.7
+    , bytestring  >= 0.11
+    , word8       >= 0.1
+
+executable fwlc
+  import:           shared
+  main-is:          Main.hs
+  hs-source-dirs:   app
+  build-depends:
+      base, fwl, text, aeson-pretty, bytestring

src/FWL/AST.hs

@@ -0,0 +1,160 @@
+module FWL.AST where
+
+import Data.Word (Word8, Word16)
+
+type Name = String
+
+-- ─── Program ────────────────────────────────────────────────────────────────
+
+data Program = Program
+  { progConfig :: Config
+  , progDecls  :: [Decl]
+  } deriving (Show)
+
+data Config = Config
+  { configTable :: String   -- default "fwl"
+  } deriving (Show)
+
+defaultConfig :: Config
+defaultConfig = Config { configTable = "fwl" }
+
+-- ─── Declarations ───────────────────────────────────────────────────────────
+
+data Decl
+  = DInterface  Name IfaceKind [IfaceProp]
+  | DZone       Name [Name]
+  | DImport     Name Type FilePath
+  | DLet        Name Type Expr
+  | DPattern    Name Type Pat
+  | DFlow       Name FlowExpr
+  | DRule       Name Type Expr          -- body must be ELam
+  | DPolicy     Name Type PolicyMeta ArmBlock
+  deriving (Show)
+
+data PolicyMeta = PolicyMeta
+  { pmHook     :: Hook
+  , pmTable    :: TableName
+  , pmPriority :: Priority
+  } deriving (Show)
+
+data Hook      = HInput | HForward | HOutput | HPrerouting | HPostrouting
+  deriving (Show, Eq)
+data TableName = TFilter | TNAT
+  deriving (Show, Eq)
+data Priority  = PFilter | PDstNat | PSrcNat | PMangle | PInt Int
+  deriving (Show, Eq)
+
+data IfaceKind = IWan | ILan | IWireGuard | IUser Name
+  deriving (Show)
+
+data IfaceProp
+  = IPDynamic
+  | IPCidr4 [CIDR]
+  | IPCidr6 [CIDR]
+  deriving (Show)
+
+-- ─── Patterns ───────────────────────────────────────────────────────────────
+
+data Pat
+  = PWild
+  | PVar  Name
+  | PNamed Name                          -- first-class named pattern ref
+  | PCtor  Name [Pat]                    -- IPv4(ip, ...), TCP(tcp, ...)
+  | PRecord Name [FieldPat]              -- udp { length = 156 }
+  | PTuple [Pat]
+  | PFrame (Maybe PathPat) Pat           -- Frame(path?, inner)
+  | PBytes [ByteElem]
+  deriving (Show)
+
+data FieldPat
+  = FPEq   Name Literal                  -- field = literal
+  | FPBind Name                          -- bind field to same-named var
+  | FPAs   Name Name                     -- field as var
+  deriving (Show)
+
+data PathPat  = PathPat (Maybe EndpointPat) (Maybe EndpointPat)
+  deriving (Show)
+
+data EndpointPat
+  = EPWild
+  | EPName   Name
+  | EPMember Name Name                   -- iif `in` zone
+  deriving (Show)
+
+data ByteElem
+  = BEHex  Word8
+  | BEWild                               -- _   (one byte)
+  | BEWildStar                           -- _*  (zero or more)
+  deriving (Show)
+
+-- ─── Flow ───────────────────────────────────────────────────────────────────
+
+data FlowExpr
+  = FAtom Name
+  | FSeq  FlowExpr FlowExpr (Maybe Duration)
+  deriving (Show)
+
+type Duration = (Int, TimeUnit)
+data TimeUnit = Seconds | Millis | Minutes | Hours
+  deriving (Show)
+
+-- ─── Types ──────────────────────────────────────────────────────────────────
+
+data Type
+  = TName   Name [Type]
+  | TTuple  [Type]
+  | TFun    Type Type
+  | TEffect [Name] Type
+  deriving (Show)
+
+-- ─── Expressions ────────────────────────────────────────────────────────────
+
+data Expr
+  = EVar    Name
+  | EQual   [Name]                       -- qualified name, e.g. Log.emit
+  | ELit    Literal
+  | ELam    Name Expr
+  | EApp    Expr Expr
+  | ECase   Expr ArmBlock
+  | EIf     Expr Expr Expr
+  | EDo     [DoStmt]
+  | ELet    Name Expr Expr
+  | ETuple  [Expr]
+  | ESet    [Expr]
+  | EMap    [(Expr, Expr)]
+  | EPerform [Name] [Expr]               -- perform QualName(args)
+  | EInfix  InfixOp Expr Expr
+  | ENot    Expr
+  deriving (Show)
+
+data InfixOp
+  = OpAnd | OpOr
+  | OpEq | OpNeq | OpLt | OpLte | OpGt | OpGte
+  | OpIn                                 -- `in` / `∈`
+  | OpConcat                             -- ++
+  | OpThen                               -- >>
+  | OpBind                               -- >>=
+  deriving (Show, Eq)
+
+data DoStmt
+  = DSBind Name Expr
+  | DSExpr Expr
+  deriving (Show)
+
+type ArmBlock = [Arm]
+data Arm = Arm Pat (Maybe Expr) Expr     -- pattern, guard?, body
+  deriving (Show)
+
+-- ─── Literals ───────────────────────────────────────────────────────────────
+
+data Literal
+  = LInt      Int
+  | LString   String
+  | LBool     Bool
+  | LIPv4     (Word8,Word8,Word8,Word8)
+  | LIPv6     [Word16]
+  | LCIDR     Literal Int
+  | LPort     Int
+  | LDuration Int TimeUnit
+  | LHex      Word8
+  deriving (Show, Eq)

src/FWL/Check.hs

@@ -0,0 +1,207 @@
+{- | Static checks for MVP:
+     1. Undefined name detection (interfaces, zones, patterns, rules/policies)
+     2. Policy arm termination: last arm of a policy must not be Continue
+     3. Named pattern cycle detection
+     4. CIDR exhaustiveness stub (warns but does not error for MVP)
+-}
+module FWL.Check
+  ( checkProgram
+  , CheckError(..)
+  ) where
+
+import Data.List (foldl', nub)
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+
+import FWL.AST
+
+data CheckError
+  = UndefinedName    String String   -- kind, name
+  | PolicyNoContinue String          -- policy name
+  | PatternCycle     [String]        -- cycle path
+  | DuplicateDecl    String String   -- kind, name
+  deriving (Show, Eq)
+
+type Env = Map.Map String DeclKind
+data DeclKind = KInterface | KZone | KLet | KPattern | KFlow | KRule | KPolicy
+  deriving (Show, Eq)
+
+checkProgram :: Program -> [CheckError]
+checkProgram (Program _ decls) =
+  dupErrs ++ nameErrs ++ policyErrs ++ cycleErrs
+  where
+    env        = buildEnv decls
+    dupErrs    = findDups decls
+    nameErrs   = concatMap (checkDecl env) decls
+    policyErrs = concatMap checkPolicyTermination decls
+    cycleErrs  = checkPatternCycles decls
+
+-- ─── Environment ─────────────────────────────────────────────────────────────
+
+buildEnv :: [Decl] -> Env
+buildEnv = foldl' addDecl Map.empty
+  where
+    addDecl m (DInterface n _ _) = Map.insert n KInterface m
+    addDecl m (DZone n _)        = Map.insert n KZone m
+    addDecl m (DLet n _ _)       = Map.insert n KLet m
+    addDecl m (DPattern n _ _)   = Map.insert n KPattern m
+    addDecl m (DFlow n _)        = Map.insert n KFlow m
+    addDecl m (DRule n _ _)      = Map.insert n KRule m
+    addDecl m (DPolicy n _ _ _)  = Map.insert n KPolicy m
+    addDecl m _                  = m
+
+findDups :: [Decl] -> [CheckError]
+findDups decls = go [] Set.empty decls
+  where
+    go acc _ []     = acc
+    go acc seen (d:ds) =
+      let n = declName d in
+      if Set.member n seen
+        then go (DuplicateDecl (declKindStr d) n : acc) seen ds
+        else go acc (Set.insert n seen) ds
+
+declName :: Decl -> String
+declName (DInterface n _ _) = n
+declName (DZone n _)        = n
+declName (DImport n _ _)    = n
+declName (DLet n _ _)       = n
+declName (DPattern n _ _)   = n
+declName (DFlow n _)        = n
+declName (DRule n _ _)      = n
+declName (DPolicy n _ _ _)  = n
+
+declKindStr :: Decl -> String
+declKindStr (DInterface _ _ _) = "interface"
+declKindStr (DZone _ _)        = "zone"
+declKindStr (DImport _ _ _)    = "import"
+declKindStr (DLet _ _ _)       = "let"
+declKindStr (DPattern _ _ _)   = "pattern"
+declKindStr (DFlow _ _)        = "flow"
+declKindStr (DRule _ _ _)      = "rule"
+declKindStr (DPolicy _ _ _ _)  = "policy"
+
+-- ─── Name resolution ─────────────────────────────────────────────────────────
+
+checkDecl :: Env -> Decl -> [CheckError]
+checkDecl env (DZone _ ns)       = concatMap (checkName env "interface or zone") ns
+checkDecl env (DPattern _ _ p)   = checkPat env p
+checkDecl env (DFlow _ fe)       = checkFlow env fe
+checkDecl env (DRule _ _ e)      = checkExpr env e
+checkDecl env (DPolicy _ _ _ ab) = concatMap (checkArm env) ab
+checkDecl env (DLet _ _ e)       = checkExpr env e
+checkDecl _   _                  = []
+
+checkName :: Env -> String -> String -> [CheckError]
+checkName env kind n
+  | Map.member n env          = []
+  | isBuiltin n               = []
+  | otherwise                 = [UndefinedName kind n]
+
+isBuiltin :: String -> Bool
+isBuiltin n = n `elem`
+  [ "ct", "iif", "oif", "lo", "wan", "lan"
+  , "tcp", "udp", "ip", "ip6", "eth"
+  , "Established", "Related", "DNAT"
+  , "Allow", "Drop", "Continue", "Masquerade"
+  , "Matched", "Unmatched"
+  , "true", "false"
+  ]
+
+checkPat :: Env -> Pat -> [CheckError]
+checkPat _   PWild            = []
+checkPat _   (PVar _)         = []
+checkPat env (PNamed n)       = checkName env "pattern" n
+checkPat env (PCtor _ ps)     = concatMap (checkPat env) ps
+checkPat env (PRecord _ fs)   = concatMap (checkFP env) fs
+checkPat env (PTuple ps)      = concatMap (checkPat env) ps
+checkPat env (PFrame mp inner)= maybe [] (checkPath env) mp ++ checkPat env inner
+checkPat _   (PBytes _)       = []
+
+checkFP :: Env -> FieldPat -> [CheckError]
+checkFP _ _ = []   -- field names checked by type-checker later
+
+checkPath :: Env -> PathPat -> [CheckError]
+checkPath env (PathPat ms md) =
+  maybe [] (checkEP env) ms ++ maybe [] (checkEP env) md
+
+checkEP :: Env -> EndpointPat -> [CheckError]
+checkEP _   EPWild           = []
+checkEP env (EPName n)       = checkName env "interface or zone" n
+checkEP env (EPMember _ z)   = checkName env "zone" z
+
+checkFlow :: Env -> FlowExpr -> [CheckError]
+checkFlow env (FAtom n)      = checkName env "pattern" n
+checkFlow env (FSeq a b _)   = checkFlow env a ++ checkFlow env b
+
+checkArm :: Env -> Arm -> [CheckError]
+checkArm env (Arm p mg e) =
+  checkPat env p ++
+  maybe [] (checkExpr env) mg ++
+  checkExpr env e
+
+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 (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]
+checkExpr env (EDo ss)         = concatMap (checkStmt env) ss
+checkExpr env (ELet _ e1 e2)   = checkExpr env e1 ++ checkExpr env e2
+checkExpr env (ETuple es)      = concatMap (checkExpr env) es
+checkExpr env (ESet es)        = concatMap (checkExpr env) es
+checkExpr env (EMap ms)        = concatMap (\(k,v) -> checkExpr env k ++ checkExpr env v) ms
+checkExpr env (EPerform _ as_) = concatMap (checkExpr env) as_
+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 (DSExpr e)   = checkExpr env e
+
+-- ─── Policy termination ───────────────────────────────────────────────────────
+
+-- The last arm of a policy block must not unconditionally return Continue.
+checkPolicyTermination :: Decl -> [CheckError]
+checkPolicyTermination (DPolicy n _ _ arms)
+  | null arms              = [PolicyNoContinue n]
+  | isContinue (last arms) = [PolicyNoContinue n]
+  | otherwise              = []
+  where
+    isContinue (Arm PWild Nothing (EVar "Continue")) = True
+    isContinue _                                     = False
+checkPolicyTermination _ = []
+
+-- ─── Pattern cycle detection ─────────────────────────────────────────────────
+
+checkPatternCycles :: [Decl] -> [CheckError]
+checkPatternCycles decls =
+  [ PatternCycle c
+  | c <- findCycles graph
+  ]
+  where
+    patDecls = [(n, p) | DPattern n _ p <- decls]
+    graph    = Map.fromList [(n, nub (refsInPat p)) | (n,p) <- patDecls]
+    allPats  = Set.fromList (map fst patDecls)
+
+    refsInPat :: Pat -> [String]
+    refsInPat (PNamed r)     = [r | Set.member r allPats]
+    refsInPat (PCtor _ ps)   = concatMap refsInPat ps
+    refsInPat (PTuple ps)    = concatMap refsInPat ps
+    refsInPat (PFrame _ p)   = refsInPat p
+    refsInPat _              = []
+
+findCycles :: Map.Map String [String] -> [[String]]
+findCycles graph = go Set.empty Set.empty [] (Map.keys graph)
+  where
+    go _       _      _    []     = []
+    go visited onPath path (n:ns)
+      | Set.member n visited = go visited onPath path ns
+      | Set.member n onPath  = [path]
+      | otherwise =
+          let onPath' = Set.insert n onPath
+              path'   = path ++ [n]
+              deps    = Map.findWithDefault [] n graph
+              cycles  = go visited onPath' path' deps
+          in cycles ++ go (Set.insert n visited) onPath path ns

src/FWL/Compile.hs

@@ -0,0 +1,316 @@
+{- | Compile a checked FWL program to nftables JSON using Aeson.
+     All policies (Filter and NAT) go into one table named by Config.
+     Layer stripping: Frame patterns that omit Ether compile identically
+     to those that include it — the compiler inserts protocol matches
+     from whatever constructor the user wrote.
+-}
+module FWL.Compile
+  ( compileProgram
+  , compileToJson
+  ) where
+
+import Data.List (intercalate)
+import Data.Maybe (mapMaybe)
+import qualified Data.Map.Strict as Map
+import qualified Data.Aeson as A
+import Data.Aeson ((.=), Value(..), object, toJSON)
+import qualified Data.Aeson.Key as K
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Aeson.Encode.Pretty as Pretty
+
+import FWL.AST
+
+-- ─── Entry points ────────────────────────────────────────────────────────────
+
+-- | Compile an FWL program and render to pretty-printed JSON bytes.
+compileToJson :: Program -> BL.ByteString
+compileToJson = Pretty.encodePretty . programToValue
+
+-- | Compile an FWL program to an Aeson Value (the nftables JSON schema).
+programToValue :: Program -> Value
+programToValue prog@(Program cfg decls) =
+  object [ "nftables" .= toJSON (metainfo : tableObj : chainObjs ++ mapObjs ++ ruleObjs) ]
+  where
+    env       = buildEnv decls
+    tbl       = configTable cfg
+
+    metainfo  = object [ "metainfo" .= object [ "json_schema_version" .= (1 :: Int) ] ]
+    tableObj  = object [ "table"    .= tableValue tbl ]
+
+    policies  = [ (n, pm, ab) | DPolicy n _ pm ab <- decls ]
+    chainObjs = map (\(n, pm, _)  -> chainDeclValue tbl n pm) policies
+    ruleObjs  = concatMap (\(n, _, ab) -> concatMap (armToRuleValues env tbl n) ab) policies
+
+    letDecls  = [ (n, t, e) | DLet n t e <- decls ]
+    mapObjs   = mapMaybe (\(n, _, e) -> letToMapValue tbl n e) letDecls
+
+-- ─── Table / Chain declarations ──────────────────────────────────────────────
+
+tableValue :: String -> Value
+tableValue tbl = object
+  [ "family" .= ("inet" :: String)
+  , "name"   .= tbl
+  ]
+
+chainDeclValue :: String -> Name -> PolicyMeta -> Value
+chainDeclValue tbl n pm = object
+  [ "chain" .= object
+      [ "family"   .= ("inet" :: String)
+      , "table"    .= tbl
+      , "name"     .= n
+      , "type"     .= chainTypeStr (pmTable pm)
+      , "hook"     .= hookStr (pmHook pm)
+      , "prio"     .= priorityStr (pmPriority pm)
+      , "policy"   .= defaultPolicyStr (pmHook pm)
+      ]
+  ]
+
+chainTypeStr :: TableName -> String
+chainTypeStr TFilter = "filter"
+chainTypeStr TNAT    = "nat"
+
+hookStr :: Hook -> String
+hookStr HInput       = "input"
+hookStr HForward     = "forward"
+hookStr HOutput      = "output"
+hookStr HPrerouting  = "prerouting"
+hookStr HPostrouting = "postrouting"
+
+priorityStr :: Priority -> String
+priorityStr PFilter  = "filter"
+priorityStr PDstNat  = "dstnat"
+priorityStr PSrcNat  = "srcnat"
+priorityStr PMangle  = "mangle"
+priorityStr (PInt n) = show n
+
+-- Input and Forward hooks default to drop; everything else to accept.
+defaultPolicyStr :: Hook -> String
+defaultPolicyStr HInput   = "drop"
+defaultPolicyStr HForward = "drop"
+defaultPolicyStr _        = "accept"
+
+-- ─── Arm → Rule objects ──────────────────────────────────────────────────────
+
+-- Each policy arm becomes zero or more nftables rule objects.
+-- An arm whose action is Continue compiles to zero rules.
+armToRuleValues :: CompileEnv -> String -> Name -> Arm -> [Value]
+armToRuleValues env tbl chain (Arm p mg body) =
+  case compileAction env body of
+    Nothing      -> []   -- Continue: emit nothing
+    Just verdict ->
+      let patExprs   = compilePat env p
+          guardExprs = maybe [] (compileGuard env) mg
+          allExprs   = patExprs ++ guardExprs ++ [verdict]
+      in  [ object
+              [ "rule" .= object
+                  [ "family" .= ("inet" :: String)
+                  , "table"  .= tbl
+                  , "chain"  .= chain
+                  , "expr"   .= toJSON allExprs
+                  ]
+              ]
+          ]
+
+-- ─── Pattern → [Value] ───────────────────────────────────────────────────────
+
+type CompileEnv = Map.Map String Decl
+
+buildEnv :: [Decl] -> CompileEnv
+buildEnv = foldr (\d m -> Map.insert (declNameOf d) d m) Map.empty
+  where
+    declNameOf (DInterface n _ _) = n
+    declNameOf (DZone n _)        = n
+    declNameOf (DPattern n _ _)   = n
+    declNameOf (DFlow n _)        = n
+    declNameOf (DRule n _ _)      = n
+    declNameOf (DPolicy n _ _ _)  = n
+    declNameOf (DLet n _ _)       = n
+    declNameOf (DImport n _ _)    = n
+
+compilePat :: CompileEnv -> Pat -> [Value]
+compilePat _   PWild             = []
+compilePat _   (PVar _)          = []
+compilePat env (PNamed n)        = expandNamedPat env n
+compilePat env (PFrame mp inner) =
+  maybe [] (compilePathPat env) mp ++ compilePat env inner
+compilePat env (PCtor n ps)      = compileCtorPat env n ps
+compilePat _   (PRecord n fs)    = compileRecordPat n fs
+compilePat env (PTuple ps)       = concatMap (compilePat env) ps
+compilePat _   (PBytes _)        = []   -- handled by flow/ct mark (future)
+
+-- Named patterns are inlined at compile time.
+expandNamedPat :: CompileEnv -> Name -> [Value]
+expandNamedPat env n =
+  case Map.lookup n env of
+    Just (DPattern _ _ p) -> compilePat env p
+    _                     -> []
+
+-- Layer stripping: Ether is transparent; IPv4/IPv6/TCP/UDP/ICMPv6 each emit
+-- the appropriate protocol-selector match then recurse into their children.
+-- Omitting Ether produces identical output.
+compileCtorPat :: CompileEnv -> String -> [Pat] -> [Value]
+compileCtorPat env ctor ps = case ctor of
+  "Ether"  -> children                           -- transparent layer
+  "IPv4"   -> matchMeta "nfproto" "ipv4"   : children
+  "IPv6"   -> matchMeta "nfproto" "ipv6"   : children
+  "TCP"    -> matchPayload "th" "protocol" "tcp"   : children
+  "UDP"    -> matchPayload "th" "protocol" "udp"   : children
+  "ICMPv6" -> matchPayload "ip6" "nexthdr" "ipv6-icmp" : children
+  "ICMP"   -> matchPayload "ip"  "protocol" "icmp" : children
+  _        -> children
+  where
+    children = concatMap (compilePat env) ps
+
+-- Record patterns emit field equality matches, e.g. tcp { dport = :22 }.
+compileRecordPat :: String -> [FieldPat] -> [Value]
+compileRecordPat proto = mapMaybe go
+  where
+    go (FPEq field lit) = Just (matchPayload proto field (renderLit lit))
+    go _                = Nothing
+
+-- Path patterns (iif/oif).
+compilePathPat :: CompileEnv -> PathPat -> [Value]
+compilePathPat _ (PathPat ms md) =
+  maybe [] (compileEndpoint "iifname") ms ++
+  maybe [] (compileEndpoint "oifname") md
+
+compileEndpoint :: String -> EndpointPat -> [Value]
+compileEndpoint _   EPWild          = []
+compileEndpoint dir (EPName n)      = [matchMeta dir n]
+compileEndpoint dir (EPMember _ z)  = [matchInSet (metaVal dir) [z]]
+  -- zone membership: for MVP we emit the zone name as a set element.
+  -- A later pass would expand zones to their member interface names.
+
+-- ─── Guard → [Value] ─────────────────────────────────────────────────────────
+
+compileGuard :: CompileEnv -> Expr -> [Value]
+compileGuard env (EInfix OpAnd l r)   = compileGuard env l ++ compileGuard env r
+compileGuard _   (EInfix OpIn  l r)   = [compileInExpr l r]
+compileGuard _   (EInfix OpEq  l r)   = [matchExpr "==" (exprVal l) (exprVal r)]
+compileGuard _   (EInfix OpNeq l r)   = [matchExpr "!=" (exprVal l) (exprVal r)]
+compileGuard _   _                    = []
+
+compileInExpr :: Expr -> Expr -> Value
+-- ct.state in { Established, Related }
+compileInExpr (EQual ["ct","state"])  (ESet vs) = ctMatch "state"  vs
+compileInExpr (EQual ["ct","status"]) (ESet vs) = ctMatch "status" vs
+-- generic set membership
+compileInExpr l (ESet vs) = matchExpr "in" (exprVal l) (setVal (map exprToStr vs))
+compileInExpr l r         = matchExpr "==" (exprVal l) (exprVal r)
+
+ctMatch :: String -> [Expr] -> Value
+ctMatch key vs = matchExpr "in"
+  (object ["ct" .= object ["key" .= key]])
+  (setVal (map exprToStr vs))
+
+-- ─── Action → Maybe Value (Nothing = Continue = no rule) ─────────────────────
+
+compileAction :: CompileEnv -> Expr -> Maybe Value
+compileAction _   (EVar "Allow")      = Just (object ["accept"     .= Null])
+compileAction _   (EVar "Drop")       = Just (object ["drop"       .= Null])
+compileAction _   (EVar "Continue")   = Nothing
+compileAction _   (EVar "Masquerade") = Just (object ["masquerade" .= Null])
+compileAction _   (EApp (EVar "DNAT") arg) =
+  Just $ object ["dnat" .= object ["addr" .= exprToStr arg]]
+compileAction _   (EApp (EVar "DNATMap") arg) =
+  Just $ object ["dnat" .= object ["addr" .= object
+    ["map" .= object ["key" .= object ["concat" .= Array mempty]
+                     ,"data" .= exprToStr arg]]]]
+-- Rule invocation → jump
+compileAction env (EApp (EVar rn) _) =
+  case Map.lookup rn env of
+    Just (DRule _ _ _) -> Just $ object ["jump" .= object ["target" .= rn]]
+    _                  -> Just (object ["accept" .= Null])
+compileAction _ _ = Just (object ["accept" .= Null])
+
+-- ─── Let → Map object ────────────────────────────────────────────────────────
+
+letToMapValue :: String -> Name -> Expr -> Maybe Value
+letToMapValue tbl n (EMap entries) = Just $ object
+  [ "map" .= object
+      [ "family"   .= ("inet" :: String)
+      , "table"    .= tbl
+      , "name"     .= n
+      , "type"     .= ("inetproto . inetservice" :: String)
+      , "map"      .= ("ipv4_addr . inetservice" :: String)
+      , "elem"     .= toJSON (map renderMapElem entries)
+      ]
+  ]
+letToMapValue _ _ _ = Nothing
+
+renderMapElem :: (Expr, Expr) -> Value
+renderMapElem (k, v) = toJSON
+  [ object ["concat" .= toJSON [exprToStr k]]
+  , exprToStr v
+  ]
+
+-- ─── Aeson building blocks ───────────────────────────────────────────────────
+
+-- { "match": { "op": op, "left": left, "right": right } }
+matchExpr :: String -> Value -> Value -> Value
+matchExpr op l r = object
+  [ "match" .= object
+      [ "op"    .= op
+      , "left"  .= l
+      , "right" .= r
+      ]
+  ]
+
+matchMeta :: String -> String -> Value
+matchMeta key val = matchExpr "==" (metaVal key) (A.String (strText val))
+
+matchPayload :: String -> String -> String -> Value
+matchPayload proto field val =
+  matchExpr "==" (payloadVal proto field) (A.String (strText val))
+
+matchInSet :: Value -> [String] -> Value
+matchInSet lhs vals =
+  matchExpr "in" lhs (setVal vals)
+
+metaVal :: String -> Value
+metaVal key = object ["meta" .= object ["key" .= key]]
+
+payloadVal :: String -> String -> Value
+payloadVal proto field =
+  object ["payload" .= object ["protocol" .= proto, "field" .= field]]
+
+setVal :: [String] -> Value
+setVal vs = object ["set" .= toJSON vs]
+
+-- ─── Expression → Value helpers ──────────────────────────────────────────────
+
+exprVal :: Expr -> Value
+exprVal (EQual [p, f])          = payloadVal p f
+exprVal (EQual ["ct", k])       = object ["ct" .= object ["key" .= k]]
+exprVal (EVar n)                = metaVal n
+exprVal (ELit l)                = A.String (strText (renderLit l))
+exprVal (ESet vs)               = setVal (map exprToStr vs)
+exprVal e                       = A.String (strText (exprToStr e))
+
+exprToStr :: Expr -> String
+exprToStr (EVar n)    = n
+exprToStr (ELit l)    = renderLit l
+exprToStr (EQual ns)  = intercalate "." ns
+exprToStr (ETuple es) = intercalate " . " (map exprToStr es)
+exprToStr _           = "_"
+
+strText :: String -> A.Text
+strText = \s -> read (show s)   -- simple String→Text without extra dep
+
+renderLit :: Literal -> String
+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 (LCIDR ip p)          = renderLit ip ++ "/" ++ show p
+renderLit (LPort p)             = show p
+renderLit (LDuration n Seconds) = show n
+renderLit (LDuration n _)       = show n
+renderLit (LHex b)              = show b
+
+-- Data.Aeson.Key helper (aeson >= 2.0 uses Key, not Text, for object keys)
+(.=) :: A.ToJSON v => String -> v -> A.Pair
+k .= v = (K.fromString k, toJSON v)

src/FWL/Lexer.hs

@@ -0,0 +1,100 @@
+module FWL.Lexer where
+
+import Text.Parsec
+import Text.Parsec.String (Parser)
+import qualified Text.Parsec.Token as Tok
+import Text.Parsec.Language (emptyDef)
+
+-- ─── Language definition ─────────────────────────────────────────────────────
+
+fwlDef :: Tok.LanguageDef ()
+fwlDef = emptyDef
+  { Tok.commentLine     = "--"
+  , Tok.commentStart    = "{-"
+  , Tok.commentEnd      = "-}"
+  , Tok.identStart      = letter <|> char '_'
+  , Tok.identLetter     = alphaNum <|> char '_'
+  , Tok.reservedNames   =
+      [ "config", "table"
+      , "interface", "zone", "import", "from"
+      , "let", "in", "pattern", "flow", "rule", "policy", "on"
+      , "case", "of", "if", "then", "else", "do", "perform"
+      , "within", "as", "dynamic", "cidr4", "cidr6"
+      , "hook", "priority"
+      , "WAN", "LAN", "WireGuard"
+      , "Input", "Forward", "Output", "Prerouting", "Postrouting"
+      , "Filter", "NAT", "Mangle", "DstNat", "SrcNat"
+      , "Allow", "Drop", "Continue", "Masquerade", "DNAT", "DNATMap"
+      , "Log", "Info", "Warn", "Error"
+      , "Matched", "Unmatched"
+      , "Frame", "FlowPattern"
+      , "true", "false"
+      ]
+  , Tok.reservedOpNames =
+      [ "->", "<-", "=>", "::", ":", "=", ".", ".."
+      , "\\", "|", ","
+      , "&&", "||", "!", "=="  , "!=", "<", "<=", ">", ">="
+      , "++", ">>", ">>="
+      , "∈"
+      ]
+  , Tok.caseSensitive   = True
+  }
+
+lexer :: Tok.TokenParser ()
+lexer = Tok.makeTokenParser fwlDef
+
+-- ─── Token helpers ───────────────────────────────────────────────────────────
+
+identifier  :: Parser String
+identifier  = Tok.identifier lexer
+
+reserved    :: String -> Parser ()
+reserved    = Tok.reserved lexer
+
+reservedOp  :: String -> Parser ()
+reservedOp  = Tok.reservedOp lexer
+
+symbol      :: String -> Parser String
+symbol      = Tok.symbol lexer
+
+parens      :: Parser a -> Parser a
+parens      = Tok.parens lexer
+
+braces      :: Parser a -> Parser a
+braces      = Tok.braces lexer
+
+angles      :: Parser a -> Parser a
+angles      = Tok.angles lexer
+
+brackets    :: Parser a -> Parser a
+brackets    = Tok.brackets lexer
+
+semi        :: Parser String
+semi        = Tok.semi lexer
+
+comma       :: Parser String
+comma       = Tok.comma lexer
+
+colon       :: Parser String
+colon       = Tok.colon lexer
+
+dot         :: Parser String
+dot         = Tok.dot lexer
+
+whiteSpace  :: Parser ()
+whiteSpace  = Tok.whiteSpace lexer
+
+stringLit   :: Parser String
+stringLit   = Tok.stringLiteral lexer
+
+natural     :: Parser Integer
+natural     = Tok.natural lexer
+
+commaSep    :: Parser a -> Parser [a]
+commaSep    = Tok.commaSep lexer
+
+commaSep1   :: Parser a -> Parser [a]
+commaSep1   = Tok.commaSep1 lexer
+
+semiSep     :: Parser a -> Parser [a]
+semiSep     = Tok.semiSep lexer

src/FWL/Parser.hs

@@ -0,0 +1,553 @@
+module FWL.Parser
+  ( parseProgram
+  , parseFile
+  ) where
+
+import Control.Monad (void)
+import Data.Word (Word8)
+import Numeric (readHex)
+import Text.Parsec
+import Text.Parsec.String (Parser)
+import qualified Text.Parsec.Expr as Ex
+
+import FWL.AST
+import FWL.Lexer
+
+-- ─── Entry points ────────────────────────────────────────────────────────────
+
+parseProgram :: String -> String -> Either ParseError Program
+parseProgram src input = parse program src input
+
+parseFile :: FilePath -> IO (Either ParseError Program)
+parseFile fp = parseProgram fp <$> readFile fp
+
+-- ─── Top-level ───────────────────────────────────────────────────────────────
+
+program :: Parser Program
+program = do
+  whiteSpace
+  cfg  <- option defaultConfig configBlock
+  ds   <- many decl
+  eof
+  return (Program cfg ds)
+
+configBlock :: Parser Config
+configBlock = do
+  reserved "config"
+  props <- braces (semiSep configProp)
+  optional semi
+  return $ foldr applyProp defaultConfig props
+  where
+    applyProp ("table", v) c = c { configTable = v }
+    applyProp _            c = c
+
+configProp :: Parser (String, String)
+configProp = do
+  reserved "table"
+  reservedOp "="
+  v <- stringLit
+  return ("table", v)
+
+-- ─── Declarations ────────────────────────────────────────────────────────────
+
+decl :: Parser Decl
+decl =  interfaceDecl
+    <|> zoneDecl
+    <|> importDecl
+    <|> letDecl
+    <|> patternDecl
+    <|> flowDecl
+    <|> ruleDecl
+    <|> policyDecl
+
+interfaceDecl :: Parser Decl
+interfaceDecl = do
+  reserved "interface"
+  n  <- identifier
+  reservedOp ":"
+  k  <- ifaceKind
+  ps <- braces (semiSep ifaceProp)
+  semi
+  return (DInterface n k ps)
+
+ifaceKind :: Parser IfaceKind
+ifaceKind =  (reserved "WAN"       >> return IWan)
+         <|> (reserved "LAN"       >> return ILan)
+         <|> (reserved "WireGuard" >> return IWireGuard)
+         <|> (IUser <$> identifier)
+
+ifaceProp :: Parser IfaceProp
+ifaceProp =  (reserved "dynamic" >> return IPDynamic)
+         <|> (reserved "cidr4" >> reservedOp "=" >> IPCidr4 <$> cidrSet)
+         <|> (reserved "cidr6" >> reservedOp "=" >> IPCidr6 <$> cidrSet)
+
+cidrSet :: Parser [CIDR]
+cidrSet = braces (commaSep1 cidrLit)
+
+zoneDecl :: Parser Decl
+zoneDecl = do
+  reserved "zone"
+  n  <- identifier
+  reservedOp "="
+  ns <- braces (commaSep1 identifier)
+  semi
+  return (DZone n ns)
+
+importDecl :: Parser Decl
+importDecl = do
+  reserved "import"
+  n <- identifier
+  reservedOp ":"
+  t <- typeP
+  reserved "from"
+  s <- stringLit
+  semi
+  return (DImport n t s)
+
+letDecl :: Parser Decl
+letDecl = do
+  reserved "let"
+  n <- identifier
+  reservedOp ":"
+  t <- typeP
+  reservedOp "="
+  e <- expr
+  semi
+  return (DLet n t e)
+
+patternDecl :: Parser Decl
+patternDecl = do
+  reserved "pattern"
+  n <- identifier
+  reservedOp ":"
+  t <- typeP
+  reservedOp "="
+  p <- pat
+  semi
+  return (DPattern n t p)
+
+flowDecl :: Parser Decl
+flowDecl = do
+  reserved "flow"
+  n <- identifier
+  reservedOp ":"
+  reserved "FlowPattern"
+  reservedOp "="
+  f <- flowExpr
+  semi
+  return (DFlow n f)
+
+ruleDecl :: Parser Decl
+ruleDecl = do
+  reserved "rule"
+  n <- identifier
+  reservedOp ":"
+  t <- typeP
+  reservedOp "="
+  e <- expr
+  semi
+  return (DRule n t e)
+
+policyDecl :: Parser Decl
+policyDecl = do
+  reserved "policy"
+  n  <- identifier
+  reservedOp ":"
+  t  <- typeP
+  reserved "on"
+  pm <- braces policyMeta
+  reservedOp "="
+  ab <- armBlock
+  semi
+  return (DPolicy n t pm ab)
+
+policyMeta :: Parser PolicyMeta
+policyMeta = do
+  props <- commaSep1 metaProp
+  let h  = foldr (\p a -> case p of Left  v -> v; _ -> a) HInput  props
+      tb = foldr (\p a -> case p of Right (Left  v) -> v; _ -> a) TFilter props
+      pr = foldr (\p a -> case p of Right (Right v) -> v; _ -> a) PFilter props
+  return (PolicyMeta h tb pr)
+
+metaProp :: Parser (Either Hook (Either TableName Priority))
+metaProp
+  =  (reserved "hook"     >> reservedOp "=" >> fmap (Left)             hookP)
+ <|> (reserved "table"    >> reservedOp "=" >> fmap (Right . Left)     tableNameP)
+ <|> (reserved "priority" >> reservedOp "=" >> fmap (Right . Right)    priorityP)
+
+hookP :: Parser Hook
+hookP =  (reserved "Input"       >> return HInput)
+     <|> (reserved "Forward"     >> return HForward)
+     <|> (reserved "Output"      >> return HOutput)
+     <|> (reserved "Prerouting"  >> return HPrerouting)
+     <|> (reserved "Postrouting" >> return HPostrouting)
+
+tableNameP :: Parser TableName
+tableNameP =  (reserved "Filter" >> return TFilter)
+          <|> (reserved "NAT"    >> return TNAT)
+
+priorityP :: Parser Priority
+priorityP =  (reserved "Filter" >> return PFilter)
+         <|> (reserved "DstNat" >> return PDstNat)
+         <|> (reserved "SrcNat" >> return PSrcNat)
+         <|> (reserved "Mangle" >> return PMangle)
+         <|> (PInt . fromIntegral <$> natural)
+
+-- ─── Arm blocks ──────────────────────────────────────────────────────────────
+
+armBlock :: Parser ArmBlock
+armBlock = braces (many arm)
+
+arm :: Parser Arm
+arm = do
+  symbol "|"
+  p  <- pat
+  g  <- optionMaybe (reserved "if" >> expr)
+  reservedOp "->"
+  e  <- expr
+  semi
+  return (Arm p g e)
+
+-- ─── Patterns ────────────────────────────────────────────────────────────────
+
+pat :: Parser Pat
+pat =  wildcardPat
+   <|> framePat
+   <|> try tuplePat
+   <|> bytesPat
+   <|> try recordPat
+   <|> try namedOrCtorPat
+
+wildcardPat :: Parser Pat
+wildcardPat = symbol "_" >> return PWild
+
+-- Frame(...) — optional path then inner pattern
+-- Layer stripping: if the inner pattern is not Ether/IPv4/IPv6/etc the
+-- type-checker will peel outer layers automatically. Parser just stores
+-- whatever the user wrote.
+framePat :: Parser Pat
+framePat = do
+  reserved "Frame"
+  (mp, inner) <- parens frameArgs
+  return (PFrame mp inner)
+
+frameArgs :: Parser (Maybe PathPat, Pat)
+frameArgs = try withPath <|> withoutPath
+  where
+    withPath = do
+      pp <- pathPat
+      comma
+      inner <- pat
+      return (Just pp, inner)
+    withoutPath = do
+      inner <- pat
+      return (Nothing, inner)
+
+pathPat :: Parser PathPat
+pathPat = do
+  src <- optionMaybe (try endpointPat)
+  dst <- optionMaybe (try (reservedOp "->" >> endpointPat))
+  case (src, dst) of
+    (Nothing, Nothing) -> fail "empty path pattern"
+    _                  -> return (PathPat src dst)
+
+endpointPat :: Parser EndpointPat
+endpointPat
+  =  (symbol "_" >> return EPWild)
+ <|> try (do n <- identifier
+             memberOp
+             z <- identifier
+             return (EPMember n z))
+ <|> (EPName <$> identifier)
+
+memberOp :: Parser ()
+memberOp = (reservedOp "∈" <|> reserved "in") >> return ()
+
+tuplePat :: Parser Pat
+tuplePat = do
+  ps <- parens (commaSep2 pat)
+  return (PTuple ps)
+
+commaSep2 :: Parser a -> Parser [a]
+commaSep2 p = do
+  x  <- p
+  comma
+  xs <- commaSep1 p
+  return (x:xs)
+
+bytesPat :: Parser Pat
+bytesPat = brackets (PBytes <$> many byteElem)
+
+byteElem :: Parser ByteElem
+byteElem
+  =  try (symbol "_*" >> return BEWildStar)
+ <|> try (symbol "_"  >> return BEWild)
+ <|> (BEHex <$> hexByte)
+
+hexByte :: Parser Word8
+hexByte = do
+  void (string "0x")
+  h1 <- hexDigit
+  h2 <- hexDigit
+  whiteSpace
+  let [(v,"")] = readHex [h1,h2]
+  return (fromIntegral v)
+
+-- Record pattern: ident { fields }
+recordPat :: Parser Pat
+recordPat = do
+  n  <- identifier
+  fs <- braces (commaSep fieldPat)
+  return (PRecord n fs)
+
+fieldPat :: Parser FieldPat
+fieldPat = do
+  n <- identifier
+  try (reservedOp "=" >> FPEq n <$> literal)
+    <|> try (reserved "as" >> FPAs n <$> identifier)
+    <|> return (FPBind 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
+    Just ps -> return (PCtor  n ps)
+
+-- ─── Flow expressions ────────────────────────────────────────────────────────
+
+flowExpr :: Parser FlowExpr
+flowExpr = do
+  first <- FAtom <$> identifier
+  rest  <- many (reservedOp "." >> identifier)
+  mw    <- optionMaybe (reserved "within" >> durationLit)
+  return $ buildSeq (first : map FAtom rest) mw
+  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"
+
+durationLit :: Parser Duration
+durationLit = do
+  n <- fromIntegral <$> natural
+  u <-  (char 's' >> return Seconds)
+    <|> (string "ms" >> return Millis)
+    <|> (char 'm' >> return Minutes)
+    <|> (char 'h' >> return Hours)
+  whiteSpace
+  return (n, u)
+
+-- ─── Types ───────────────────────────────────────────────────────────────────
+
+typeP :: Parser Type
+typeP = do
+  t <- baseType
+  option t (reservedOp "->" >> TFun t <$> typeP)
+
+baseType :: Parser Type
+baseType
+  =  effectType
+ <|> try tupleTy
+ <|> simpleTy
+
+effectType :: Parser Type
+effectType = do
+  effs <- angles (commaSep identifier)
+  t    <- simpleTy
+  return (TEffect effs t)
+
+tupleTy :: Parser Type
+tupleTy = TTuple <$> parens (commaSep2 typeP)
+
+simpleTy :: Parser Type
+simpleTy = do
+  n    <- identifier
+  args <- option [] (angles (commaSep typeP))
+  return (TName n args)
+
+-- ─── Expressions ─────────────────────────────────────────────────────────────
+
+expr :: Parser Expr
+expr =  lamExpr
+    <|> ifExpr
+    <|> doExpr
+    <|> caseExpr
+    <|> letExpr
+    <|> infixExpr
+
+lamExpr :: Parser Expr
+lamExpr = do
+  reservedOp "\\"
+  n <- identifier
+  reservedOp "->"
+  e <- expr
+  return (ELam n e)
+
+ifExpr :: Parser Expr
+ifExpr = do
+  reserved "if"
+  c <- expr
+  reserved "then"
+  t <- expr
+  reserved "else"
+  f <- expr
+  return (EIf c t f)
+
+doExpr :: Parser Expr
+doExpr = reserved "do" >> braces (EDo <$> semiSep doStmt)
+
+doStmt :: Parser DoStmt
+doStmt = try bindStmt <|> (DSExpr <$> expr)
+
+bindStmt :: Parser DoStmt
+bindStmt = do
+  n <- identifier
+  reservedOp "<-"
+  e <- expr
+  return (DSBind n e)
+
+caseExpr :: Parser Expr
+caseExpr = do
+  reserved "case"
+  e  <- expr
+  reserved "of"
+  ab <- armBlock
+  return (ECase e ab)
+
+letExpr :: Parser Expr
+letExpr = do
+  reserved "let"
+  n <- identifier
+  reservedOp "="
+  e1 <- expr
+  reserved "in"
+  e2 <- expr
+  return (ELet n e1 e2)
+
+-- Operator table for infix expressions
+infixExpr :: Parser Expr
+infixExpr = Ex.buildExpressionParser opTable appExpr
+
+opTable :: Ex.OperatorTable String () Identity Expr
+opTable =
+  [ [ prefix "!" ENot ]
+  , [ infixL "==" OpEq, infixL "!=" OpNeq
+    , infixL "<"  OpLt, infixL "<=" OpLte
+    , infixL ">"  OpGt, infixL ">=" OpGte
+    , infixIn ]
+  , [ infixR "&&" OpAnd ]
+  , [ infixR "||" OpOr  ]
+  , [ infixR "++" OpConcat ]
+  , [ infixL ">>=" OpBind ]
+  , [ infixL ">>"  OpThen ]
+  ]
+  where
+    prefix op f = Ex.Prefix  (reservedOp op >> return f)
+    infixL op c = Ex.Infix   (reservedOp op >> return (EInfix c)) Ex.AssocLeft
+    infixR op c = Ex.Infix   (reservedOp op >> return (EInfix c)) Ex.AssocRight
+    infixIn     = Ex.Infix
+      ((memberOp <|> reserved "in") >> return (EInfix OpIn))
+      Ex.AssocNone
+
+appExpr :: Parser Expr
+appExpr = do
+  f    <- atom
+  args <- many atom
+  return (foldl EApp f args)
+
+atom :: Parser Expr
+atom
+  =  try performExpr
+ <|> try mapLit
+ <|> try setLit
+ <|> try tupleLit
+ <|> try (parens expr)
+ <|> try litExpr
+ <|> try portExpr
+ <|> qualNameExpr
+
+performExpr :: Parser Expr
+performExpr = do
+  reserved "perform"
+  parts <- sepBy1 identifier dot
+  args  <- parens (commaSep expr)
+  return (EPerform parts args)
+
+qualNameExpr :: Parser Expr
+qualNameExpr = do
+  parts <- sepBy1 identifier (try (dot <* notFollowedBy digit))
+  case parts of
+    [n] -> return (EVar n)
+    ns  -> return (EQual ns)
+
+litExpr :: Parser Expr
+litExpr = ELit <$> literal
+
+portExpr :: Parser Expr
+portExpr = do
+  void (char ':')
+  n <- fromIntegral <$> natural
+  return (ELit (LPort n))
+
+tupleLit :: Parser Expr
+tupleLit = ETuple <$> parens (commaSep2 expr)
+
+setLit :: Parser Expr
+setLit = braces $ do
+  items <- commaSep expr
+  return (ESet items)
+
+-- map literal: { expr -> expr, ... }
+mapLit :: Parser Expr
+mapLit = braces $ do
+  entries <- commaSep1 mapEntry
+  return (EMap entries)
+
+mapEntry :: Parser (Expr, Expr)
+mapEntry = do
+  k <- expr
+  reservedOp "->"
+  v <- expr
+  return (k, v)
+
+-- ─── Literals ────────────────────────────────────────────────────────────────
+
+literal :: Parser Literal
+literal
+  =  try cidrOrIpLit
+ <|> try hexLit
+ <|> try (LBool True  <$ reserved "true")
+ <|> try (LBool False <$ reserved "false")
+ <|> try (LString <$> stringLit)
+ <|> try (LInt . fromIntegral <$> natural)
+
+hexLit :: Parser Literal
+hexLit = LHex <$> hexByte
+
+cidrOrIpLit :: Parser Literal
+cidrOrIpLit = do
+  a <- fromIntegral <$> natural
+  void (char '.')
+  b <- fromIntegral <$> natural
+  void (char '.')
+  c <- fromIntegral <$> natural
+  void (char '.')
+  d <- fromIntegral <$> natural
+  whiteSpace
+  mPrefix <- optionMaybe (char '/' >> fromIntegral <$> natural)
+  whiteSpace
+  let ip = LIPv4 (a,b,c,d)
+  return $ case mPrefix of
+    Nothing -> ip
+    Just p  -> LCIDR ip p
+
+cidrLit :: Parser CIDR
+cidrLit = do
+  l <- cidrOrIpLit
+  case l of
+    LCIDR ip p -> return (ip, p)
+    _          -> fail "expected CIDR notation"

src/FWL/Pretty.hs

@@ -0,0 +1,191 @@
+-- | Pretty printer: round-trips the AST back to FWL source.
+module FWL.Pretty (prettyProgram) where
+
+import Data.List (intercalate)
+import FWL.AST
+
+prettyProgram :: Program -> String
+prettyProgram (Program cfg ds) =
+  prettyConfig cfg ++ "\n" ++ unlines (map prettyDecl ds)
+
+prettyConfig :: Config -> String
+prettyConfig (Config t)
+  | t == "fwl" = ""
+  | otherwise  = "config { table = \"" ++ t ++ "\"; }\n"
+
+prettyDecl :: Decl -> String
+prettyDecl (DInterface n k ps) =
+  "interface " ++ n ++ " : " ++ prettyKind k ++ " {\n" ++
+  concatMap (\p -> "  " ++ prettyIfaceProp p ++ ";\n") ps ++
+  "};"
+prettyDecl (DZone n ns) =
+  "zone " ++ n ++ " = { " ++ intercalate ", " ns ++ " };"
+prettyDecl (DImport n t s) =
+  "import " ++ n ++ " : " ++ prettyType t ++ " from \"" ++ s ++ "\";"
+prettyDecl (DLet n t e) =
+  "let " ++ n ++ " : " ++ prettyType t ++ " = " ++ prettyExpr e ++ ";"
+prettyDecl (DPattern n t p) =
+  "pattern " ++ n ++ " : " ++ prettyType t ++ " = " ++ prettyPat p ++ ";"
+prettyDecl (DFlow n f) =
+  "flow " ++ n ++ " : FlowPattern = " ++ prettyFlow f ++ ";"
+prettyDecl (DRule n t e) =
+  "rule " ++ n ++ " : " ++ prettyType t ++ " =\n  " ++ prettyExpr e ++ ";"
+prettyDecl (DPolicy n t pm ab) =
+  "policy " ++ n ++ " : " ++ prettyType t ++ "\n" ++
+  "  on { hook = " ++ prettyHook (pmHook pm) ++
+       ", table = " ++ prettyTable (pmTable pm) ++
+       ", priority = " ++ prettyPriority (pmPriority pm) ++ " }\n" ++
+  "  = " ++ prettyArmBlock ab ++ ";"
+
+prettyKind :: IfaceKind -> String
+prettyKind IWan        = "WAN"
+prettyKind ILan        = "LAN"
+prettyKind IWireGuard  = "WireGuard"
+prettyKind (IUser n)   = n
+
+prettyIfaceProp :: IfaceProp -> String
+prettyIfaceProp IPDynamic    = "dynamic"
+prettyIfaceProp (IPCidr4 cs) = "cidr4 = { " ++ intercalate ", " (map prettyCidr cs) ++ " }"
+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
+prettyHook HInput       = "Input"
+prettyHook HForward     = "Forward"
+prettyHook HOutput      = "Output"
+prettyHook HPrerouting  = "Prerouting"
+prettyHook HPostrouting = "Postrouting"
+
+prettyTable :: TableName -> String
+prettyTable TFilter = "Filter"
+prettyTable TNAT    = "NAT"
+
+prettyPriority :: Priority -> String
+prettyPriority PFilter = "Filter"
+prettyPriority PDstNat = "DstNat"
+prettyPriority PSrcNat = "SrcNat"
+prettyPriority PMangle = "Mangle"
+prettyPriority (PInt n)= show n
+
+prettyType :: Type -> String
+prettyType (TName n [])   = n
+prettyType (TName n ts)   = n ++ "<" ++ intercalate ", " (map prettyType ts) ++ ">"
+prettyType (TTuple ts)    = "(" ++ intercalate ", " (map prettyType ts) ++ ")"
+prettyType (TFun a b)     = prettyType a ++ " -> " ++ prettyType b
+prettyType (TEffect es t) = "<" ++ intercalate ", " es ++ "> " ++ prettyType t
+
+prettyPat :: Pat -> String
+prettyPat PWild            = "_"
+prettyPat (PVar n)         = n
+prettyPat (PNamed n)       = n
+prettyPat (PCtor n ps)     = n ++ "(" ++ intercalate ", " (map prettyPat ps) ++ ")"
+prettyPat (PRecord n fs)   = n ++ " { " ++ intercalate ", " (map prettyFP fs) ++ " }"
+prettyPat (PTuple ps)      = "(" ++ intercalate ", " (map prettyPat ps) ++ ")"
+prettyPat (PFrame mp inner)=
+  "Frame(" ++ maybe "" (\pp -> prettyPath pp ++ ", ") mp ++ prettyPat inner ++ ")"
+prettyPat (PBytes bs)      = "[" ++ unwords (map prettyBE bs) ++ "]"
+
+prettyFP :: FieldPat -> String
+prettyFP (FPEq n l)  = n ++ " = " ++ prettyLit l
+prettyFP (FPBind n)  = n
+prettyFP (FPAs n v)  = n ++ " as " ++ v
+
+prettyPath :: PathPat -> String
+prettyPath (PathPat ms md) =
+  maybe "_" prettyEP ms ++ maybe "" (\d -> " -> " ++ prettyEP d) md
+
+prettyEP :: EndpointPat -> String
+prettyEP EPWild         = "_"
+prettyEP (EPName n)     = n
+prettyEP (EPMember n z) = n ++ " in " ++ z
+
+prettyBE :: ByteElem -> String
+prettyBE (BEHex w) = "0x" ++ pad (show w)  -- simplified
+  where pad s = if length s < 2 then '0':s else s
+prettyBE BEWild     = "_"
+prettyBE BEWildStar = "_*"
+
+prettyFlow :: FlowExpr -> String
+prettyFlow (FAtom n)      = n
+prettyFlow (FSeq a b mw)  =
+  prettyFlow a ++ " . " ++ prettyFlow b ++
+  maybe "" (\(n,u) -> " within " ++ show n ++ prettyUnit u) mw
+
+prettyUnit :: TimeUnit -> String
+prettyUnit Seconds = "s"
+prettyUnit Millis  = "ms"
+prettyUnit Minutes = "m"
+prettyUnit Hours   = "h"
+
+prettyExpr :: Expr -> String
+prettyExpr (EVar n)         = n
+prettyExpr (EQual ns)       = intercalate "." ns
+prettyExpr (ELit l)         = prettyLit l
+prettyExpr (ELam n e)       = "\\" ++ n ++ " -> " ++ prettyExpr e
+prettyExpr (EApp f x)       = prettyExpr f ++ " " ++ prettyAtom x
+prettyExpr (ECase e ab)     =
+  "case " ++ prettyExpr e ++ " of " ++ prettyArmBlock ab
+prettyExpr (EIf c t f)      =
+  "if " ++ prettyExpr c ++ " then " ++ prettyExpr t ++ " else " ++ prettyExpr f
+prettyExpr (EDo ss)         =
+  "do { " ++ intercalate "; " (map prettyStmt ss) ++ " }"
+prettyExpr (ELet n e1 e2)   =
+  "let " ++ n ++ " = " ++ prettyExpr e1 ++ " in " ++ prettyExpr e2
+prettyExpr (ETuple es)      = "(" ++ intercalate ", " (map prettyExpr es) ++ ")"
+prettyExpr (ESet es)        = "{ " ++ intercalate ", " (map prettyExpr es) ++ " }"
+prettyExpr (EMap ms)        =
+  "{ " ++ intercalate ", " (map (\(k,v) -> prettyExpr k ++ " -> " ++ prettyExpr v) ms) ++ " }"
+prettyExpr (EPerform ns as_) =
+  "perform " ++ intercalate "." ns ++ "(" ++ intercalate ", " (map prettyExpr as_) ++ ")"
+prettyExpr (EInfix op l r)  =
+  prettyAtom l ++ " " ++ prettyOp op ++ " " ++ prettyAtom r
+prettyExpr (ENot e)         = "!" ++ prettyAtom e
+
+prettyAtom :: Expr -> String
+prettyAtom e@(EInfix _ _ _) = "(" ++ prettyExpr e ++ ")"
+prettyAtom e@(ELam _ _)     = "(" ++ prettyExpr e ++ ")"
+prettyAtom e                 = prettyExpr e
+
+prettyOp :: InfixOp -> String
+prettyOp OpAnd    = "&&"
+prettyOp OpOr     = "||"
+prettyOp OpEq     = "=="
+prettyOp OpNeq    = "!="
+prettyOp OpLt     = "<"
+prettyOp OpLte    = "<="
+prettyOp OpGt     = ">"
+prettyOp OpGte    = ">="
+prettyOp OpIn     = "in"
+prettyOp OpConcat = "++"
+prettyOp OpThen   = ">>"
+prettyOp OpBind   = ">>="
+
+prettyStmt :: DoStmt -> String
+prettyStmt (DSBind n e) = n ++ " <- " ++ prettyExpr e
+prettyStmt (DSExpr e)   = prettyExpr e
+
+prettyArmBlock :: ArmBlock -> String
+prettyArmBlock arms =
+  "{\n" ++
+  concatMap (\(Arm p mg e) ->
+    "    | " ++ prettyPat p ++
+    maybe "" (\g -> " if " ++ prettyExpr g) mg ++
+    " -> " ++ prettyExpr e ++ ";\n") arms ++
+  "  }"
+
+prettyLit :: Literal -> String
+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 _)          = "<ipv6>"
+prettyLit (LCIDR ip p)       = prettyLit ip ++ "/" ++ show p
+prettyLit (LPort p)          = ":" ++ show p
+prettyLit (LDuration n u)    = show n ++ prettyUnit u
+prettyLit (LHex b)           = "0x" ++ show b