parse algebraic declarations and ordered match clauses

.gitignore

@@ -0,0 +1,7 @@
+dist/
+.toolchain/
+*.o
+*.hi
+*.dyn_o
+*.dyn_hi
+*.tree

makefile

@@ -0,0 +1,20 @@
+.PHONY: all build test bench clean graphs
+
+all: build
+
+build:
+	./scripts/env cabal v1-build
+
+test: build
+	./scripts/env cabal v1-test
+
+bench: build
+	./scripts/env cabal v1-bench
+
+graphs: build
+	./scripts/env ./dist/build/tessera/tessera compile examples/protocol.tess --function classify -o artifacts/protocol.tree
+	./scripts/env ./dist/build/tessera/tessera graph artifacts/protocol.tree -o artifacts/protocol-decision-tree.dot
+	dot -Tsvg artifacts/protocol-decision-tree.dot -o artifacts/protocol-decision-tree.svg
+
+clean:
+	rm -rf dist artifacts/protocol.tree artifacts/protocol-decision-tree.dot

scripts/env

@@ -0,0 +1,6 @@
+#!/bin/sh
+set -eu
+root=$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd)
+export PATH="$root/.toolchain/bin:$root/.toolchain/ghc-bin:$PATH"
+export CABAL_DIR="$root/.toolchain/cabal"
+exec "$@"

scripts/setup

@@ -0,0 +1,20 @@
+#!/bin/sh
+set -eu
+root=$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd)
+cd "$root"
+mkdir -p .toolchain/bin .toolchain/ghc-bin .toolchain/cabal
+if [ ! -x .toolchain/bin/cabal ]; then
+  curl -fL https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-unknown-linux.tar.xz -o .toolchain/cabal.tar.xz
+  tar xf .toolchain/cabal.tar.xz -C .toolchain/bin
+  rm .toolchain/cabal.tar.xz
+fi
+ghc_bin=/home/rack/.ghcup/ghc/8.6.5/bin
+for tool in ghc ghc-pkg ghci runghc haddock hsc2hs hpc; do
+  ln -sf "$ghc_bin/$tool" ".toolchain/ghc-bin/$tool"
+done
+if [ ! -f .toolchain/cabal/config ]; then
+  printf -- '-- isolated cabal configuration for the pinned historical toolchain\n-- no remote repository is configured because only GHC boot libraries are used\n' > .toolchain/cabal/config
+fi
+./scripts/env ghc --version
+./scripts/env cabal --version
+./scripts/env cabal v1-build

src/Tessera/Parser.hs

@@ -0,0 +1,517 @@
+module Tessera.Parser (parseProgram, parseExpression, tokenize) where
+
+import Data.Char (isAlpha, isAlphaNum, isDigit, isLower, isUpper)
+import Data.List (foldl')
+import qualified Data.Map.Strict as Map
+
+import Tessera.Syntax
+
+data Token
+  = TkLower String
+  | TkUpper String
+  | TkInt Integer
+  | TkSym String
+  | TkEof
+  deriving (Eq, Show)
+
+data Located = Located
+  { locatedSpan :: Span
+  , locatedToken :: Token
+  } deriving (Eq, Show)
+
+data PState = PState
+  { psTokens :: [Located]
+  , psArities :: Map.Map String Int
+  , psTypeArities :: Map.Map String Int
+  }
+
+newtype Parser a = Parser { runParser :: PState -> Either Diagnostic (a, PState) }
+
+instance Functor Parser where
+  fmap f (Parser g) = Parser $ \s -> case g s of
+    Left e -> Left e
+    Right (a, s') -> Right (f a, s')
+
+instance Applicative Parser where
+  pure a = Parser $ \s -> Right (a, s)
+  Parser f <*> Parser g = Parser $ \s -> case f s of
+    Left e -> Left e
+    Right (h, s') -> case g s' of
+      Left e -> Left e
+      Right (a, s'') -> Right (h a, s'')
+
+instance Monad Parser where
+  return = pure
+  Parser g >>= f = Parser $ \s -> case g s of
+    Left e -> Left e
+    Right (a, s') -> runParser (f a) s'
+
+parseError :: Span -> String -> Parser a
+parseError sp message = Parser $ \_ -> Left (Diagnostic sp message)
+
+peekToken :: Parser Located
+peekToken = Parser $ \s -> case psTokens s of
+  [] -> Right (Located (Span 0 0) TkEof, s)
+  (t : _) -> Right (t, s)
+
+advanceToken :: Parser Located
+advanceToken = Parser $ \s -> case psTokens s of
+  [] -> Right (Located (Span 0 0) TkEof, s)
+  (t : ts) -> Right (t, s { psTokens = ts })
+
+withArities :: (Map.Map String Int -> Map.Map String Int) -> Parser ()
+withArities f = Parser $ \s -> Right ((), s { psArities = f (psArities s) })
+
+lookupArity :: Span -> String -> Parser Int
+lookupArity sp name = Parser $ \s -> case Map.lookup name (psArities s) of
+  Just n -> Right (n, s)
+  Nothing -> Left (Diagnostic sp ("unknown constructor " ++ name))
+
+builtinTypeArities :: Map.Map String Int
+builtinTypeArities = Map.fromList [("Int", 0), ("Bool", 0)]
+
+withTypeArities :: (Map.Map String Int -> Map.Map String Int) -> Parser ()
+withTypeArities f = Parser $ \s -> Right ((), s { psTypeArities = f (psTypeArities s) })
+
+lookupTypeArity :: Span -> String -> Parser Int
+lookupTypeArity sp name = Parser $ \s -> case Map.lookup name (psTypeArities s) of
+  Just n -> Right (n, s)
+  Nothing -> Left (Diagnostic sp ("unknown type " ++ name))
+
+matchSymbol :: String -> Parser ()
+matchSymbol symbol = do
+  located <- peekToken
+  case locatedToken located of
+    TkSym s | s == symbol -> advanceToken >> return ()
+    _ -> parseError (locatedSpan located) ("expected " ++ symbol)
+
+matchLower :: Parser String
+matchLower = do
+  located <- peekToken
+  case locatedToken located of
+    TkLower name -> advanceToken >> return name
+    _ -> parseError (locatedSpan located) "expected a lowercase name"
+
+matchUpper :: Parser String
+matchUpper = do
+  located <- peekToken
+  case locatedToken located of
+    TkUpper name -> advanceToken >> return name
+    _ -> parseError (locatedSpan located) "expected an uppercase constructor name"
+
+matchInt :: Parser Integer
+matchInt = do
+  located <- peekToken
+  case locatedToken located of
+    TkInt n -> advanceToken >> return n
+    _ -> parseError (locatedSpan located) "expected an integer literal"
+
+matchEof :: Parser ()
+matchEof = do
+  located <- peekToken
+  case locatedToken located of
+    TkEof -> return ()
+    _ -> parseError (locatedSpan located) "unexpected trailing input"
+
+currentSpan :: Parser Span
+currentSpan = locatedSpan <$> peekToken
+
+isSymbol :: String -> Located -> Bool
+isSymbol symbol located = locatedToken located == TkSym symbol
+
+parseProgram :: String -> Either Diagnostic Program
+parseProgram input = case tokenize input of
+  Left e -> Left e
+  Right tokens -> case runParser program (PState tokens Map.empty builtinTypeArities) of
+    Left e -> Left e
+    Right (declarations, _) -> Right declarations
+
+program :: Parser Program
+program = do
+  located <- peekToken
+  case locatedToken located of
+    TkEof -> return []
+    _ -> do
+      declaration <- parseDeclaration
+      rest <- program
+      return (declaration : rest)
+
+parseDeclaration :: Parser Declaration
+parseDeclaration = do
+  located <- peekToken
+  case locatedToken located of
+    TkLower "data" -> parseData
+    TkLower "match" -> parseMatch
+    _ -> parseError (locatedSpan located) "expected data or match"
+
+parseData :: Parser Declaration
+parseData = do
+  matchLower
+  name <- matchUpper
+  parameters <- parseParameters
+  withTypeArities (Map.insert name (length parameters))
+  matchSymbol "="
+  constructors <- parseConstructors
+  withArities $ \m ->
+    foldl' (\acc c -> Map.insert (constructorName c) (length (constructorArgs c)) acc) m constructors
+  return (DataDeclaration name parameters constructors)
+
+parseParameters :: Parser [String]
+parseParameters = do
+  located <- peekToken
+  case locatedToken located of
+    TkLower name -> do
+      advanceToken
+      rest <- parseParameters
+      return (name : rest)
+    _ -> return []
+
+parseConstructors :: Parser [Constructor]
+parseConstructors = do
+  name <- matchUpper
+  arguments <- parseTypeAtoms
+  located <- peekToken
+  if isSymbol "|" located
+    then do
+      advanceToken
+      rest <- parseConstructors
+      return (Constructor name arguments : rest)
+    else return [Constructor name arguments]
+
+parseMatch :: Parser Declaration
+parseMatch = do
+  matchLower
+  name <- matchLower
+  arguments <- parseMatchArguments
+  matchSymbol ":"
+  result <- parseType
+  matchSymbol "="
+  clauses <- parseClauses
+  return (MatchDeclaration name arguments result clauses)
+
+parseMatchArguments :: Parser [(String, Type)]
+parseMatchArguments = do
+  located <- peekToken
+  if isSymbol "(" located
+    then do
+      advanceToken
+      argument <- matchLower
+      matchSymbol ":"
+      ty <- parseType
+      matchSymbol ")"
+      rest <- parseMatchArguments
+      return ((argument, ty) : rest)
+    else return []
+
+parseClauses :: Parser [Clause]
+parseClauses = do
+  located <- peekToken
+  if isSymbol "|" located
+    then do
+      span' <- currentSpan
+      advanceToken
+      patterns <- parseClausePatterns
+      matchSymbol "->"
+      body <- expression
+      rest <- parseClauses
+      return (Clause span' patterns body : rest)
+    else return []
+
+parseClausePatterns :: Parser [Pattern]
+parseClausePatterns = do
+  located <- peekToken
+  if isSymbol "->" located || isSymbol "|" located
+    then return []
+    else do
+      pattern <- parsePattern
+      rest <- parseClausePatterns
+      return (pattern : rest)
+
+isReserved :: String -> Bool
+isReserved name = name `elem` ["data", "match", "if", "then", "else", "let", "in", "true", "false"]
+
+parseType :: Parser Type
+parseType = parseTypeAtom
+
+parseTypeArguments :: Int -> Parser [Type]
+parseTypeArguments 0 = return []
+parseTypeArguments n = do
+  first <- parseTypeAtom
+  rest <- parseTypeArguments (n - 1)
+  return (first : rest)
+
+parseTypeAtom :: Parser Type
+parseTypeAtom = do
+  located <- peekToken
+  case locatedToken located of
+    TkLower name | not (isReserved name) -> advanceToken >> return (TVar name)
+    TkUpper name -> do
+      arity <- lookupTypeArity (locatedSpan located) name
+      advanceToken
+      arguments <- parseTypeArguments arity
+      return (TName name arguments)
+    TkSym "(" -> do
+      advanceToken
+      first <- parseType
+      located' <- peekToken
+      if isSymbol "," located'
+        then do
+          advanceToken
+          rest <- parseTupleTypes
+          matchSymbol ")"
+          return (TTuple (first : rest))
+        else do
+          matchSymbol ")"
+          return first
+    _ -> parseError (locatedSpan located) "expected a type"
+
+parseTupleTypes :: Parser [Type]
+parseTupleTypes = do
+  ty <- parseType
+  located <- peekToken
+  if isSymbol "," located
+    then do
+      advanceToken
+      rest <- parseTupleTypes
+      return (ty : rest)
+    else return [ty]
+
+parseTypeAtoms :: Parser [Type]
+parseTypeAtoms = do
+  located <- peekToken
+  case locatedToken located of
+    TkLower name | not (isReserved name) -> advanceToken >> fmap (TVar name :) parseTypeAtoms
+    TkUpper name -> do
+      arity <- lookupTypeArity (locatedSpan located) name
+      advanceToken
+      arguments <- parseTypeArguments arity
+      fmap (TName name arguments :) parseTypeAtoms
+    TkSym "(" -> do
+      advanceToken
+      first <- parseType
+      located' <- peekToken
+      if isSymbol "," located'
+        then do
+          advanceToken
+          rest <- parseTupleTypes
+          matchSymbol ")"
+          fmap (TTuple (first : rest) :) parseTypeAtoms
+        else do
+          matchSymbol ")"
+          fmap (first :) parseTypeAtoms
+    _ -> return []
+
+parsePattern :: Parser Pattern
+parsePattern = do
+  located <- peekToken
+  case locatedToken located of
+    TkLower "_" -> advanceToken >> return PWild
+    TkLower name -> advanceToken >> return (PVar name)
+    TkInt n -> advanceToken >> return (PInt n)
+    TkUpper "True" -> advanceToken >> return (PBool True)
+    TkUpper "False" -> advanceToken >> return (PBool False)
+    TkUpper name -> do
+      arity <- lookupArity (locatedSpan located) name
+      advanceToken
+      arguments <- parsePatternArguments arity
+      return (PCon name arguments)
+    TkSym "(" -> do
+      advanceToken
+      first <- parsePattern
+      located' <- peekToken
+      if isSymbol "," located'
+        then do
+          advanceToken
+          rest <- parsePatternTuple
+          matchSymbol ")"
+          return (PTuple (first : rest))
+        else do
+          matchSymbol ")"
+          return first
+    _ -> parseError (locatedSpan located) "expected a pattern"
+
+parsePatternArguments :: Int -> Parser [Pattern]
+parsePatternArguments 0 = return []
+parsePatternArguments n = do
+  pattern <- parsePattern
+  rest <- parsePatternArguments (n - 1)
+  return (pattern : rest)
+
+parsePatternTuple :: Parser [Pattern]
+parsePatternTuple = do
+  pattern <- parsePattern
+  located <- peekToken
+  if isSymbol "," located
+    then do
+      advanceToken
+      rest <- parsePatternTuple
+      return (pattern : rest)
+    else return [pattern]
+
+parseExpression :: [(String, Int)] -> String -> Either Diagnostic Expr
+parseExpression arities input = case tokenize input of
+  Left e -> Left e
+  Right tokens -> case runParser expression (PState tokens (Map.fromList arities) builtinTypeArities) of
+    Left e -> Left e
+    Right (e, _) -> Right e
+
+expression :: Parser Expr
+expression = do
+  located <- peekToken
+  case locatedToken located of
+    TkLower "if" -> parseIf
+    _ -> parseOr
+
+parseIf :: Parser Expr
+parseIf = do
+  matchLower
+  condition <- expression
+  matchLower
+  yes <- expression
+  matchLower
+  no <- expression
+  return (EIf condition yes no)
+
+binaryLevel :: Parser Expr -> [(String, Op)] -> Parser Expr -> Parser Expr
+binaryLevel next operators parseOperand = do
+  first <- parseOperand
+  loop first
+  where
+    loop left = do
+      located <- peekToken
+      case locatedToken located of
+        TkSym symbol
+          | Just op <- lookup symbol operators -> do
+              advanceToken
+              right <- parseOperand
+              loop (EBin op left right)
+        _ -> return left
+
+parseOr :: Parser Expr
+parseOr = do
+  first <- parseAnd
+  loop first
+  where
+    loop left = do
+      located <- peekToken
+      if isSymbol "||" located
+        then do
+          advanceToken
+          right <- parseAnd
+          loop (EBin OpOr left right)
+        else return left
+
+parseAnd :: Parser Expr
+parseAnd = do
+  first <- parseComparison
+  loop first
+  where
+    loop left = do
+      located <- peekToken
+      if isSymbol "&&" located
+        then do
+          advanceToken
+          right <- parseComparison
+          loop (EBin OpAnd left right)
+        else return left
+
+parseComparison :: Parser Expr
+parseComparison = do
+  left <- parseAdditive
+  located <- peekToken
+  case locatedToken located of
+    TkSym "==" -> advanceToken >> fmap (EBin OpEq left) parseAdditive
+    TkSym "!=" -> advanceToken >> fmap (EBin OpNe left) parseAdditive
+    TkSym "<" -> advanceToken >> fmap (EBin OpLt left) parseAdditive
+    TkSym "<=" -> advanceToken >> fmap (EBin OpLe left) parseAdditive
+    TkSym ">" -> advanceToken >> fmap (EBin OpGt left) parseAdditive
+    TkSym ">=" -> advanceToken >> fmap (EBin OpGe left) parseAdditive
+    _ -> return left
+
+parseAdditive :: Parser Expr
+parseAdditive = binaryLevel parseMultiplicative [("+", OpAdd), ("-", OpSub)] parseMultiplicative
+
+parseMultiplicative :: Parser Expr
+parseMultiplicative = binaryLevel parseAtom [("*", OpMul), ("/", OpDiv), ("%", OpMod)] parseAtom
+
+parseAtom :: Parser Expr
+parseAtom = do
+  located <- peekToken
+  case locatedToken located of
+    TkLower name -> advanceToken >> return (EVar name)
+    TkInt n -> advanceToken >> return (EInt n)
+    TkUpper "True" -> advanceToken >> return (EBool True)
+    TkUpper "False" -> advanceToken >> return (EBool False)
+    TkUpper name -> do
+      arity <- lookupArity (locatedSpan located) name
+      advanceToken
+      arguments <- parseExpressionArguments arity
+      return (ECon name arguments)
+    TkSym "(" -> do
+      advanceToken
+      first <- expression
+      located' <- peekToken
+      if isSymbol "," located'
+        then do
+          advanceToken
+          rest <- parseExpressionTuple
+          matchSymbol ")"
+          return (ETuple (first : rest))
+        else do
+          matchSymbol ")"
+          return first
+    _ -> parseError (locatedSpan located) "expected an expression"
+
+parseExpressionArguments :: Int -> Parser [Expr]
+parseExpressionArguments 0 = return []
+parseExpressionArguments n = do
+  argument <- parseAtom
+  rest <- parseExpressionArguments (n - 1)
+  return (argument : rest)
+
+parseExpressionTuple :: Parser [Expr]
+parseExpressionTuple = do
+  e <- expression
+  located <- peekToken
+  if isSymbol "," located
+    then do
+      advanceToken
+      rest <- parseExpressionTuple
+      return (e : rest)
+    else return [e]
+
+tokenize :: String -> Either Diagnostic [Located]
+tokenize = go 1 1
+  where
+    go line column input = case input of
+      [] -> Right [Located (Span line column) TkEof]
+      (c : rest)
+        | c == '\n' -> go (line + 1) 1 rest
+        | c == ' ' || c == '\t' || c == '\r' -> go line (column + 1) rest
+        | c == '-' && not (null rest) && head rest == '-' ->
+            let (comment, after) = break (== '\n') rest
+            in go line (column + length comment) after
+        | isAlpha c || c == '_' ->
+            let (word, after) = span (\x -> isAlphaNum x || x == '_' || x == '\'') (c : rest)
+            in fmap (Located (Span line column) (classifyWord word) :) (go line (column + length word) after)
+        | isDigit c ->
+            let (digits, after) = span isDigit (c : rest)
+            in fmap (Located (Span line column) (TkInt (read digits)) :) (go line (column + length digits) after)
+        | otherwise ->
+            case matchSymbolAt input of
+              Just (symbol, after) ->
+                fmap (Located (Span line column) (TkSym symbol) :) (go line (column + length symbol) after)
+              Nothing -> Left (Diagnostic (Span line column) ("unexpected character " ++ [c]))
+
+    classifyWord word
+      | isUpper (head word) = TkUpper word
+      | otherwise = TkLower word
+
+    matchSymbolAt input = firstJust
+      [ if take (length symbol) input == symbol then Just (symbol, drop (length symbol) input) else Nothing
+      | symbol <- ["->", "==", "!=", "<=", ">=", "&&", "||", "|", "(", ")", "[", "]", ",", ":", "=", "+", "-", "*", "/", "%", "<", ">", ";"]
+      ]
+
+    firstJust [] = Nothing
+    firstJust (Just x : _) = Just x
+    firstJust (Nothing : xs) = firstJust xs

src/Tessera/Syntax.hs

@@ -0,0 +1,76 @@
+module Tessera.Syntax where
+
+data Span = Span
+  { spanLine :: Int
+  , spanColumn :: Int
+  } deriving (Eq, Show)
+
+data Diagnostic = Diagnostic Span String deriving (Eq, Show)
+
+data Type
+  = TName String [Type]
+  | TVar String
+  | TTuple [Type]
+  deriving (Eq, Show)
+
+data Op
+  = OpAdd
+  | OpSub
+  | OpMul
+  | OpDiv
+  | OpMod
+  | OpEq
+  | OpNe
+  | OpLt
+  | OpLe
+  | OpGt
+  | OpGe
+  | OpAnd
+  | OpOr
+  deriving (Eq, Show)
+
+data Pattern
+  = PVar String
+  | PWild
+  | PCon String [Pattern]
+  | PInt Integer
+  | PBool Bool
+  | PTuple [Pattern]
+  deriving (Eq, Show)
+
+data Expr
+  = EVar String
+  | EInt Integer
+  | EBool Bool
+  | ECon String [Expr]
+  | ETuple [Expr]
+  | EBin Op Expr Expr
+  | EIf Expr Expr Expr
+  deriving (Eq, Show)
+
+data Clause = Clause
+  { clauseSpan :: Span
+  , clausePatterns :: [Pattern]
+  , clauseBody :: Expr
+  } deriving (Eq, Show)
+
+data Constructor = Constructor
+  { constructorName :: String
+  , constructorArgs :: [Type]
+  } deriving (Eq, Show)
+
+data Declaration
+  = DataDeclaration
+      { dataName :: String
+      , dataParams :: [String]
+      , dataConstructors :: [Constructor]
+      }
+  | MatchDeclaration
+      { matchName :: String
+      , matchArguments :: [(String, Type)]
+      , matchResult :: Type
+      , matchClauses :: [Clause]
+      }
+  deriving (Eq, Show)
+
+type Program = [Declaration]