From b6f46144ef4aeef415f330574d6ec8e4671b0b6b Mon Sep 17 00:00:00 2001 From: Nikolai Ponomarev Date: Tue, 16 Apr 2024 11:40:37 +0300 Subject: [PATCH] Rework IL Ast --- distiller/src/Lib.hs | 6 +-- lang/app/Main.hs | 39 ++++++++++------- lang/lang.cabal | 8 +++- lang/package.yaml | 2 + lang/src/Ast.hs | 102 +++++++++++++++++++++++++++++++++++++++++++ lang/src/Syntax.hs | 50 --------------------- 6 files changed, 138 insertions(+), 69 deletions(-) create mode 100644 lang/src/Ast.hs delete mode 100644 lang/src/Syntax.hs diff --git a/distiller/src/Lib.hs b/distiller/src/Lib.hs index ad97ce1..f13892e 100644 --- a/distiller/src/Lib.hs +++ b/distiller/src/Lib.hs @@ -2,10 +2,10 @@ module Lib ( someFunc, ) where -import Syntax +import Ast -f :: Expression -f = Lambda "x" (Variable "x") +f :: Expr +f = Lam (VarName "x") (Var $ VarName "x") someFunc :: IO () someFunc = print f diff --git a/lang/app/Main.hs b/lang/app/Main.hs index dd91cde..7869328 100644 --- a/lang/app/Main.hs +++ b/lang/app/Main.hs @@ -1,6 +1,8 @@ module Main (main) where -import Syntax +import Ast +import Data.Map.Strict as Map +import Text.PrettyPrint.Leijen.Text (pretty) {- append xs ys = λ xs . λ ys . case xs of @@ -8,23 +10,30 @@ append xs ys = λ xs . λ ys . case xs of Cons x' xs' => Cons x' (append xs' ys) -} -bodyOfAppend :: Expression +bodyOfAppend :: Expr bodyOfAppend = Case - (Variable "xs") - [ (Pat "Nil" [], Variable "ys") - , - ( Pat "Cons" ["x'", "xs'"] - , Constructor "Cons" [Variable "x'", Application (Application (Function "append") (Variable "xs'")) (Variable "ys")] - ) - ] + (Var $ VarName "xs") + $ Map.fromList + [ (ConName "Nil", Alt [] (Var $ VarName "ys")) + , + ( ConName "Cons" + , Alt + [VarName "x'", VarName "xs'"] + ( Con (ConName "Cons") [Var $ VarName "x'", App (App (Fun $ FunName "append") (Var $ VarName "xs'")) (Var $ VarName "ys")] + ) + ) + ] -appendInExp :: FunctionHeader +appendInExp :: Expr appendInExp = - Header - "append" - ["xs", "ys"] - (Lambda "xs" (Lambda "ys" bodyOfAppend)) + App + ( Fun + (FunName "append") + ) + (Lam (VarName "xs") (Lam (VarName "ys") bodyOfAppend)) main :: IO () -main = print appendInExp +main = do + print $ appendInExp + print $ pretty appendInExp diff --git a/lang/lang.cabal b/lang/lang.cabal index 223597f..c96a362 100644 --- a/lang/lang.cabal +++ b/lang/lang.cabal @@ -25,7 +25,7 @@ source-repository head library exposed-modules: - Syntax + Ast other-modules: Paths_lang autogen-modules: @@ -37,7 +37,9 @@ library ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: base >=4.7 && <5 + , containers , text + , wl-pprint-text default-language: GHC2021 executable lang-exe @@ -53,8 +55,10 @@ executable lang-exe ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 + , containers , lang , text + , wl-pprint-text default-language: GHC2021 test-suite lang-test @@ -71,6 +75,8 @@ test-suite lang-test ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 + , containers , lang , text + , wl-pprint-text default-language: GHC2021 diff --git a/lang/package.yaml b/lang/package.yaml index ec50258..ae73166 100644 --- a/lang/package.yaml +++ b/lang/package.yaml @@ -22,6 +22,8 @@ description: Please see the README on GitHub at = 4.7 && < 5 - text + - wl-pprint-text + - containers language: GHC2021 diff --git a/lang/src/Ast.hs b/lang/src/Ast.hs new file mode 100644 index 0000000..aeaa894 --- /dev/null +++ b/lang/src/Ast.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE InstanceSigs #-} + +{- | Basic IL datatypes + +The grammar is based on [A Hierarchy of Program Transformers](https://www.researchgate.net/publication/229062264_A_Hierarchy_of_Program_Transformers). +-} +module Ast ( + Expr (Var, Con, Lam, Fun, App, Case, Let), + Fun (FunName, funName), + Var (VarName, varName), + Con (ConName, conName), + Alt (Alt), +) where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) + +import Text.PrettyPrint.Leijen.Text ( + Doc, + Pretty, + align, + hsep, + parens, + pretty, + text, + textStrict, + vsep, + (<+>), + ) + +-- | Function name, must be lowercase +newtype Fun = FunName {funName :: Text} + deriving (Show) + +instance Pretty Fun where + pretty :: Fun -> Doc + pretty fun = textStrict $ funName fun + +-- | Variable name, must be lowercase +newtype Var = VarName {varName :: Text} + deriving (Show) + +instance Pretty Var where + pretty :: Var -> Doc + pretty var = textStrict $ varName var + +-- | Constructor name, must start with uppercase letter +newtype Con = ConName {conName :: Text} + deriving (Show, Ord, Eq) + +instance Pretty Con where + pretty :: Con -> Doc + pretty con = textStrict $ conName con + +-- | Case pattern-matching alternatives map +type Alts = Map Con Alt + +instance Pretty Alts where + pretty :: Alts -> Doc + pretty alts = vsep $ map (\(con, alt) -> pretty con <+> pretty alt) list + where + list = Map.toList alts + +-- | Case pattern-matching alternative +data Alt = Alt [Var] Expr + deriving (Show) + +instance Pretty Alt where + pretty :: Alt -> Doc + pretty (Alt vars expr) = hsep (fmap pretty vars) <> text " => " <> pretty expr + +-- | IL expression type +data Expr + = -- | Variable + Var Var + | -- | Sum type constructor with arbitrary expression inside + Con Con [Expr] + | -- | Lambda abstraction + Lam Var Expr + | -- | Function call + Fun Fun + | -- | Expressions' application + App Expr Expr + | -- | Pattern-matching using case, patterns must be non-overlapping and exhaustive + Case Expr Alts + | -- | Simple let expression, can be introduced only by distillation + Let Var Expr Expr + deriving (Show) + +{- | PPrinting currently is very simple and only used for debugging. +Most probably will change after source language design. +-} +instance Pretty Expr where + pretty :: Expr -> Doc + pretty (Var var) = pretty var + pretty (Con con exprs) = pretty con <+> hsep (fmap pretty exprs) + pretty (Lam var expr) = text "\\" <> pretty var <> text "." <> pretty expr + pretty (Fun fun) = pretty fun + pretty (App expr1 expr2) = parens (pretty expr1) <+> parens (pretty expr2) + pretty (Case expr alts) = text "case" <+> pretty expr <+> text "of" <+> align (pretty alts) + pretty (Let var varExpr expr) = text "let" <+> pretty var <+> text "=" <+> pretty varExpr <+> text "in" <+> pretty expr diff --git a/lang/src/Syntax.hs b/lang/src/Syntax.hs deleted file mode 100644 index 7c7aef6..0000000 --- a/lang/src/Syntax.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE InstanceSigs #-} - -module Syntax ( - Expression (Variable, Constructor, Lambda, Application, Case, Let, Function), - Fun, - Pattern (Pat), - FunctionHeader (Header), -) where - -type Fun = String - -type Var = String - -data Pattern = Pat String [Var] - -data Expression - = Variable Var - | Constructor String [Expression] - | Lambda Var Expression - | Application Expression Expression - | Case Expression [(Pattern, Expression)] - | Let Var Expression Expression - | Function Fun - -data FunctionHeader = Header Fun [Var] Expression - -instance Show Expression where - show :: Expression -> String - show expr = - case expr of - Variable v -> "(" ++ show v ++ ")" - Lambda v exp' -> "(λ" ++ show v ++ "." ++ show exp' ++ ")" - Constructor name exps -> "(" ++ name ++ foldr (\x acc -> "(" ++ show x ++ ")" ++ acc) "" exps ++ ")" - Application exp1 exp2 -> "(" ++ show exp1 ++ ")(" ++ show exp2 ++ ")" - Case exp' ls -> - "(case " - ++ show exp' - ++ "of\n" - ++ foldr (\(pat, exp'') acc -> "\t" ++ show pat ++ " => " ++ show exp'' ++ "\n" ++ acc) "" ls - ++ ")" - Let var exp1 exp2 -> "let " ++ show var ++ " = " ++ show exp1 ++ " in " ++ show exp2 - Function f -> show f - -instance Show Pattern where - show :: Pattern -> String - show (Pat patName vars) = show patName ++ " " ++ foldr (\x acc -> show x ++ " " ++ acc) "" vars - -instance Show FunctionHeader where - show :: FunctionHeader -> String - show (Header funcName vars expr) = show funcName ++ " " ++ foldr (\x acc -> show x ++ " " ++ acc) "" vars ++ " = " ++ show expr