detect redundant clauses through usefulness analysis

src/Tessera/Serialize.hs

@@ -0,0 +1,190 @@
+module Tessera.Serialize where
+
+import Data.Char (isAlphaNum, isDigit)
+import Data.List (isPrefixOf)
+
+import Tessera.Check (checkProgram)
+import Tessera.Env (Env, lookupConstructor)
+import Tessera.Matrix (Key (..))
+import Tessera.Parser (parseProgram)
+import Tessera.Syntax
+import Tessera.Tree
+
+data Artifact = Artifact
+  { artifactFunction :: String
+  , artifactStrategy :: Strategy
+  , artifactTree :: Tree
+  , artifactSource :: String
+  , artifactProgram :: Program
+  , artifactEnv :: Env
+  }
+
+formatVersion :: String
+formatVersion = "1"
+
+encodeArtifact :: String -> String -> Strategy -> Tree -> String
+encodeArtifact function source strategy tree = unlines
+  [ "tessera-tree " ++ formatVersion
+  , "function " ++ function
+  , "strategy " ++ strategyName strategy
+  , "tree " ++ encodeTree tree
+  , "source-begin"
+  , source
+  , "source-end"
+  ]
+
+encodeTree :: Tree -> String
+encodeTree tree = case tree of
+  Success index -> "L" ++ show index
+  Failure -> "X"
+  Bind (Occurrence path) name inner -> "B[" ++ joinIntegers path ++ "|" ++ name ++ "]" ++ encodeTree inner
+  Switch (Occurrence path) branches fallback ->
+    "W[" ++ joinIntegers path ++ "]{"
+      ++ concatMap encodeBranch branches
+      ++ "}[" ++ maybe "" encodeTree fallback ++ "]"
+
+encodeBranch :: (Key, Tree) -> String
+encodeBranch (key, tree) = encodeKey key ++ ":" ++ encodeTree tree ++ ";"
+
+encodeKey :: Key -> String
+encodeKey key = case key of
+  KeyCon name -> "c" ++ name
+  KeyInt n -> "i" ++ show n
+  KeyBool b -> if b then "bT" else "bF"
+  KeyTuple n -> "t" ++ show n
+
+joinIntegers :: [Int] -> String
+joinIntegers [] = ""
+joinIntegers [x] = show x
+joinIntegers (x : rest) = show x ++ "," ++ joinIntegers rest
+
+decodeArtifact :: String -> Either String Artifact
+decodeArtifact input = do
+  let numbered = zip [1 ..] (lines input)
+  version <- lookupHeader "tessera-tree" numbered
+  if version /= formatVersion then Left ("unsupported tree format version " ++ version) else Right ()
+  function <- lookupHeader "function" numbered
+  strategyText <- lookupHeader "strategy" numbered
+  strategy <- case strategyText of
+    "leftmost" -> Right Leftmost
+    "heuristic" -> Right Heuristic
+    _ -> Left ("unknown strategy " ++ strategyText)
+  treeText <- lookupHeader "tree" numbered
+  tree <- decodeTree treeText
+  source <- extractSource numbered
+  program <- either (Left . renderDiagnostic) Right (parseProgram source)
+  env <- either (Left . renderDiagnostic) Right (checkProgram program)
+  if function `elem` [name | MatchDeclaration name _ _ _ <- program]
+    then Right ()
+    else Left ("function " ++ function ++ " is not declared in the embedded source")
+  validateTree env tree
+  return (Artifact function strategy tree source program env)
+
+lookupHeader :: String -> [(Int, String)] -> Either String String
+lookupHeader key numbered =
+  case [drop (length key + 1) line | (_, line) <- numbered, (key ++ " ") `isPrefixOf` line] of
+    (value : _) -> Right value
+    [] -> Left ("missing " ++ key ++ " header")
+
+extractSource :: [(Int, String)] -> Either String String
+extractSource numbered = case break (\(_, line) -> line == "source-begin") numbered of
+  (_, _ : rest) -> case break (\(_, line) -> line == "source-end") rest of
+    (body, _ : _) -> Right (unlines (map snd body))
+    _ -> Left "missing source-end marker"
+  _ -> Left "missing source-begin marker"
+
+renderDiagnostic :: Diagnostic -> String
+renderDiagnostic (Diagnostic span' message) =
+  "line " ++ show (spanLine span') ++ " column " ++ show (spanColumn span') ++ ": " ++ message
+
+decodeTree :: String -> Either String Tree
+decodeTree input = do
+  (tree, rest) <- parseTree input
+  if null rest then Right tree else Left ("trailing characters in tree encoding " ++ take 20 rest)
+
+parseTree :: String -> Either String (Tree, String)
+parseTree ('L' : rest) =
+  let (digits, remaining) = span isDigit rest
+  in if null digits then Left "malformed success node" else Right (Success (read digits), remaining)
+parseTree ('X' : rest) = Right (Failure, rest)
+parseTree ('B' : '[' : rest) = do
+  let (inside, afterInside) = break (== ']') rest
+  (path, name) <- case break (== '|') inside of
+    (p, '|' : n) -> Right (p, n)
+    _ -> Left "malformed bind node"
+  (inner, remaining) <- parseTree (drop 1 afterInside)
+  Right (Bind (Occurrence (parseIntegers path)) name inner, remaining)
+parseTree ('W' : '[' : rest) = do
+  let (path, afterPath) = break (== ']') rest
+  afterPath' <- expect ']' afterPath
+  afterBrace <- expect '{' afterPath'
+  (branches, afterBranches) <- parseBranches afterBrace
+  afterBranches' <- expect '}' afterBranches
+  afterBracket <- expect '[' afterBranches'
+  let (fallbackText, afterFallback) = break (== ']') afterBracket
+  fallback <- if null fallbackText then Right Nothing else do
+    (tree, _) <- parseTree fallbackText
+    Right (Just tree)
+  afterFallback' <- expect ']' afterFallback
+  Right (Switch (Occurrence (parseIntegers path)) branches fallback, afterFallback')
+parseTree _ = Left "malformed tree encoding"
+
+expect :: Char -> String -> Either String String
+expect c (x : rest) | x == c = Right rest
+expect c _ = Left ("expected " ++ [c])
+
+parseBranches :: String -> Either String ([(Key, Tree)], String)
+parseBranches input = go input []
+  where
+    go ('}' : rest) acc = Right (reverse acc, '}' : rest)
+    go (c : rest) acc = do
+      (key, rest1) <- parseKey c rest
+      rest2 <- expect ':' rest1
+      (tree, rest3) <- parseTree rest2
+      rest4 <- expect ';' rest3
+      go rest4 ((key, tree) : acc)
+    go [] _ = Left "unterminated branch list"
+
+parseKey :: Char -> String -> Either String (Key, String)
+parseKey 'c' rest = let (name, remaining) = span (\c -> isAlphaNum c || c == '_') rest in Right (KeyCon name, remaining)
+parseKey 'i' rest = let (digits, remaining) = span isDigit rest in Right (KeyInt (read digits), remaining)
+parseKey 'b' rest = case rest of
+  ('T' : remaining) -> Right (KeyBool True, remaining)
+  ('F' : remaining) -> Right (KeyBool False, remaining)
+  _ -> Left "malformed boolean key"
+parseKey 't' rest = let (digits, remaining) = span isDigit rest in Right (KeyTuple (read digits), remaining)
+parseKey _ _ = Left "malformed branch key"
+
+parseIntegers :: String -> [Int]
+parseIntegers [] = []
+parseIntegers text = map read (splitOn ',' text)
+
+splitOn :: Char -> String -> [String]
+splitOn _ [] = []
+splitOn c text = case break (== c) text of
+  (piece, []) -> [piece]
+  (piece, _ : rest) -> piece : splitOn c rest
+
+validateTree :: Env -> Tree -> Either String ()
+validateTree env = go
+  where
+    go tree = case tree of
+      Success _ -> Right ()
+      Failure -> Right ()
+      Bind (Occurrence path) _ inner -> validatePath path >> go inner
+      Switch (Occurrence path) branches fallback -> do
+        validatePath path
+        mapM_ (validateKey env) (map fst branches)
+        mapM_ (go . snd) branches
+        mapM_ go fallback
+
+    validatePath path = if all (>= 0) path then Right () else Left "negative occurrence path"
+
+validateKey :: Env -> Key -> Either String ()
+validateKey env key = case key of
+  KeyCon name -> case lookupConstructor env name of
+    Just _ -> Right ()
+    Nothing -> Left ("unknown constructor in tree " ++ name)
+  KeyInt _ -> Right ()
+  KeyBool _ -> Right ()
+  KeyTuple _ -> Right ()