Skip to content

Commit 623a0e4

Browse files
WoWasterWoWaster
committed
Add Core AST and LmlToCore translation
1 parent 46daded commit 623a0e4

File tree

14 files changed

+419
-5
lines changed

14 files changed

+419
-5
lines changed

Diff for: ‎.pre-commit-config.yaml

+1-1
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@ repos:
44
hooks:
55
- id: trailing-whitespace
66
- id: end-of-file-fixer
7-
exclude: "ast/.*|ppr/.*"
7+
exclude: "ast/.*|ppr/.*|core/.*"
88
- id: check-yaml
99
- id: fix-byte-order-marker
1010
- id: mixed-line-ending

Diff for: ‎lamagraph-compiler/lamagraph-compiler.cabal

+5
Original file line numberDiff line numberDiff line change
@@ -24,6 +24,10 @@ source-repository head
2424

2525
library
2626
exposed-modules:
27+
Lamagraph.Compiler.Core
28+
Lamagraph.Compiler.Core.LmlToCore
29+
Lamagraph.Compiler.Core.MonadDesugar
30+
Lamagraph.Compiler.Core.Pretty
2731
Lamagraph.Compiler.Extension
2832
Lamagraph.Compiler.Parser
2933
Lamagraph.Compiler.Parser.Lexer
@@ -109,6 +113,7 @@ test-suite lamagraph-compiler-test
109113
type: exitcode-stdio-1.0
110114
main-is: Spec.hs
111115
other-modules:
116+
Lamagraph.Compiler.Core.PrettyCoreGolden
112117
Lamagraph.Compiler.GoldenCommon
113118
Lamagraph.Compiler.Parser.LexerTest
114119
Lamagraph.Compiler.Parser.ParserRoundtrip

Diff for: ‎lamagraph-compiler/src/Lamagraph/Compiler/Core.hs

+37
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,37 @@
1+
module Lamagraph.Compiler.Core where
2+
3+
import Relude
4+
5+
import Lamagraph.Compiler.Typechecker.TcTypes
6+
7+
data Literal = LitInt Int | LitChar Char | LitString Text deriving (Show)
8+
9+
-- FIXME: Must change after addition of ADTs
10+
type DataCon = Name
11+
12+
data Var
13+
= Id Name -- Term variable
14+
deriving (Eq, Show)
15+
16+
data Expr b
17+
= Var b
18+
| Lit Literal
19+
| App (Expr b) (Expr b)
20+
| Lam b (Expr b)
21+
| Let (Bind b) (Expr b)
22+
| -- | For a reason behind this signature see https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/core-syn-type#case-expressions
23+
Match (Expr b) b (NonEmpty (MatchAlt b))
24+
| -- In Haskell, tuples are just syntactic sugar for @data TupleN a1...aN = TupleN a1...aN@,
25+
-- but in Caml they are separate construction
26+
Tuple (Expr b) (NonEmpty (Expr b))
27+
deriving (Show)
28+
29+
type MatchAlt b = (AltCon, [b], Expr b)
30+
31+
data AltCon = DataAlt DataCon | LitAlt Literal | TupleAlt | DEFAULT deriving (Show)
32+
33+
data Bind b = NonRec b (Expr b) | Rec (NonEmpty (b, Expr b)) deriving (Show)
34+
35+
type CoreExpr = Expr Var
36+
type CoreMatchAlt = MatchAlt Var
37+
type CoreBind = Bind Var

Diff for: ‎lamagraph-compiler/src/Lamagraph/Compiler/Core/LmlToCore.hs

+162
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,162 @@
1+
module Lamagraph.Compiler.Core.LmlToCore where
2+
3+
import Relude
4+
5+
import Control.Monad.Extra
6+
import Data.Foldable.Extra hiding (elem)
7+
8+
import Lamagraph.Compiler.Core
9+
import Lamagraph.Compiler.Core.MonadDesugar
10+
import Lamagraph.Compiler.Extension
11+
import Lamagraph.Compiler.Parser.SrcLoc
12+
import Lamagraph.Compiler.Syntax
13+
import Lamagraph.Compiler.Typechecker.DefaultEnv
14+
import Lamagraph.Compiler.Typechecker.TcTypes
15+
16+
desugarLmlLit :: LmlLit LmlcTc -> Literal
17+
desugarLmlLit = \case
18+
LmlInt _ int -> LitInt int
19+
LmlChar _ char -> LitChar char
20+
LmlString _ string -> LitString string
21+
22+
desugarLLmlExpr :: LLmlExpr LmlcTc -> MonadDesugar CoreExpr
23+
desugarLLmlExpr (L _ expr) = desugarLmlExpr expr
24+
25+
desugarLmlExpr :: LmlExpr LmlcTc -> MonadDesugar CoreExpr
26+
desugarLmlExpr = \case
27+
LmlExprIdent _ longident -> pure $ Var $ Id $ Name longident
28+
LmlExprConstant _ lit -> pure $ Lit $ desugarLmlLit lit
29+
LmlExprLet _ lBindGroup lExpr -> foldr Let <$> desugarLLmlExpr lExpr <*> desugarLLmlBindGroup lBindGroup
30+
LmlExprFunction _ lPat lExpr -> Lam <$> desugarLLmlPat lPat <*> desugarLLmlExpr lExpr
31+
LmlExprApply _ lExpr lExprs -> App <$> desugarLLmlExpr lExpr <*> (foldr1 App <$> mapM desugarLLmlExpr lExprs)
32+
LmlExprMatch _ lExpr lCases -> do
33+
scrutineeVar <- freshVar
34+
expr <- desugarLLmlExpr lExpr
35+
cases <- mapM (desugarLLmlCase scrutineeVar) lCases
36+
pure $ Match expr scrutineeVar cases
37+
LmlExprTuple _ lExpr lExprs -> Tuple <$> desugarLLmlExpr lExpr <*> mapM desugarLLmlExpr lExprs
38+
LmlExprConstruct _ (L _ longident) maybeArgs ->
39+
let constructorVar = Var $ Id $ Name longident
40+
in case maybeArgs of
41+
Nothing -> pure constructorVar
42+
Just lArgs -> App constructorVar <$> desugarLLmlExpr lArgs
43+
LmlExprIfThenElse _ lCond lTrue lFalse -> do
44+
trueExpr <- desugarLLmlExpr lTrue
45+
falseExpr <- desugarLLmlExpr lFalse
46+
let trueAlt = (DataAlt trueConstrName, [], trueExpr)
47+
falseAlt = (DataAlt falseConstrName, [], falseExpr)
48+
condExpr <- desugarLLmlExpr lCond
49+
var <- freshVar
50+
pure $ Match condExpr var (trueAlt :| [falseAlt])
51+
LmlExprConstraint _ lExpr _ -> desugarLLmlExpr lExpr
52+
53+
desugarLLmlCase :: Var -> LLmlCase LmlcTc -> MonadDesugar CoreMatchAlt
54+
desugarLLmlCase scrutineeVar (L _ case') = desugarLmlCase scrutineeVar case'
55+
56+
desugarLmlCase :: Var -> LmlCase LmlcTc -> MonadDesugar CoreMatchAlt
57+
desugarLmlCase scrutineeVar (LmlCase _ (L _ pat) Nothing lExpr) = do
58+
expr <- desugarLLmlExpr lExpr
59+
case pat of
60+
LmlPatAny _ -> pure (DEFAULT, [], expr)
61+
LmlPatVar _ (L _ ident) ->
62+
pure
63+
( DEFAULT
64+
, []
65+
, replaceVar (Id $ Name $ mkLongident $ pure ident) scrutineeVar expr
66+
)
67+
LmlPatConstant _ lit -> pure (LitAlt $ desugarLmlLit lit, [], expr)
68+
LmlPatTuple _ lPat lPats ->
69+
let vars = map helper (lPat : toList lPats)
70+
in pure (TupleAlt, vars, expr)
71+
LmlPatConstruct _ (L _ longident) maybeLPat ->
72+
let constuctorName = Name longident
73+
in case maybeLPat of
74+
Nothing -> pure (DataAlt constuctorName, [], expr)
75+
Just (L _ args) ->
76+
case args of
77+
LmlPatVar _ (L _ ident) -> pure (DataAlt constuctorName, [Id $ Name $ mkLongident $ pure ident], expr)
78+
LmlPatTuple _ lPat lPats ->
79+
let vars = map helper (lPat : toList lPats)
80+
in pure (DataAlt constuctorName, vars, expr)
81+
_ -> error "Internal error: Constructors can only be applied to Var or Tuple."
82+
LmlPatOr{} -> error "FIXME: Or patterns in match expressions aren't supported."
83+
LmlPatConstraint{} -> error "FIXME: Constraints in pattern-matching are currently unsupported."
84+
where
85+
helper lPat = case unLoc lPat of
86+
LmlPatVar _ (L _ ident) -> Id $ Name $ mkLongident $ pure ident
87+
_ -> error "FIXME: Nested patterns are currently unsupported."
88+
desugarLmlCase _ (LmlCase _ _ (Just _) _) = error "FIXME: Guards in pattern-matching are currently unsupported."
89+
90+
desugarLLmlPat :: LLmlPat LmlcTc -> MonadDesugar Var
91+
desugarLLmlPat (L _ pat) = desugarLmlPat pat
92+
93+
desugarLmlPat :: LmlPat LmlcTc -> MonadDesugar Var
94+
desugarLmlPat = \case
95+
LmlPatVar _ (L _ ident) -> pure $ Id $ Name $ mkLongident $ pure ident
96+
LmlPatConstraint _ lPat _ -> desugarLLmlPat lPat
97+
_ -> error "FIXME: Only Var and Constraint patterns are currently supported."
98+
99+
desugarLLmlBindGroup :: LLmlBindGroup LmlcTc -> MonadDesugar (NonEmpty CoreBind)
100+
desugarLLmlBindGroup (L _ bindGroup) = desugarLmlBindGroup bindGroup
101+
102+
{- | Invariant of this function:
103+
If we have 'Recursive' bind group then we have only one element in the list,
104+
otherwise we have as many elements in the list as let exprs.
105+
-}
106+
desugarLmlBindGroup :: LmlBindGroup LmlcTc -> MonadDesugar (NonEmpty CoreBind)
107+
desugarLmlBindGroup (LmlBindGroup _ NonRecursive lBinds) = do
108+
binds <- mapM desugarLLmlBind lBinds
109+
pure $ fmap (uncurry NonRec) binds
110+
desugarLmlBindGroup (LmlBindGroup _ Recursive lBinds) = do
111+
binds <- mapM desugarLLmlBind lBinds
112+
pure $ pure $ Rec binds
113+
114+
desugarLLmlBind :: LLmlBind LmlcTc -> MonadDesugar (Var, CoreExpr)
115+
desugarLLmlBind (L _ bind) = desugarLmlBind bind
116+
117+
desugarLmlBind :: LmlBind LmlcTc -> MonadDesugar (Var, CoreExpr)
118+
desugarLmlBind (LmlBind _ lPat lExpr) = liftA2 (,) (desugarLLmlPat lPat) (desugarLLmlExpr lExpr)
119+
120+
replaceVar :: Var -> Var -> CoreExpr -> CoreExpr
121+
replaceVar oldVar newVar = \case
122+
var@(Var id') -> if id' == oldVar then Var newVar else var
123+
lit@(Lit _) -> lit
124+
App leftExpr rightExpr -> App (replaceVar oldVar newVar leftExpr) (replaceVar oldVar newVar rightExpr)
125+
lam@(Lam var expr) -> if var == oldVar then lam else Lam var (replaceVar oldVar newVar expr)
126+
Let bind expr ->
127+
let (newBind, control) = replaceVarBind oldVar newVar bind
128+
in if control then Let newBind (replaceVar oldVar newVar expr) else Let newBind expr
129+
Match scrutinee scrutineeVar alts ->
130+
if scrutineeVar == oldVar
131+
then Match (replaceVar oldVar newVar scrutinee) scrutineeVar alts
132+
else Match (replaceVar oldVar newVar scrutinee) scrutineeVar (fmap (replaceVarMatchAlt oldVar newVar) alts)
133+
Tuple expr exprs -> Tuple (replaceVar oldVar newVar expr) $ fmap (replaceVar oldVar newVar) exprs
134+
135+
{- | Replaces variable in 'Bind'.
136+
If this binding binds variable then we emit 'False' to stop replacing further, otherwise return 'True'.
137+
-}
138+
replaceVarBind :: Var -> Var -> CoreBind -> (CoreBind, Bool)
139+
replaceVarBind oldVar newVar = \case
140+
nr@(NonRec var expr) -> if var == oldVar then (nr, False) else (NonRec newVar (replaceVar oldVar newVar expr), True)
141+
r@(Rec binds) ->
142+
if elem oldVar $ fmap fst binds
143+
then (r, False)
144+
else (Rec $ fmap (second (replaceVar oldVar newVar)) binds, True)
145+
146+
replaceVarMatchAlt :: Var -> Var -> CoreMatchAlt -> CoreMatchAlt
147+
replaceVarMatchAlt oldVar newVar alt@(altCon, boundVars, expr) =
148+
if oldVar `elem` boundVars
149+
then alt
150+
else
151+
(altCon, boundVars, replaceVar oldVar newVar expr)
152+
153+
desugarLLmlDecl :: LLmlDecl LmlcTc -> MonadDesugar [CoreBind]
154+
desugarLLmlDecl (L _ decl) = desugarLmlDecl decl
155+
156+
desugarLmlDecl :: LmlDecl LmlcTc -> MonadDesugar [CoreBind]
157+
desugarLmlDecl = \case
158+
ValD _ lBindGroup -> toList <$> desugarLLmlBindGroup lBindGroup
159+
_ -> pure []
160+
161+
desugarLmlModule :: LmlModule LmlcTc -> MonadDesugar [CoreBind]
162+
desugarLmlModule (LmlModule _ _ lDecls) = concatMapM desugarLLmlDecl lDecls

Diff for: ‎lamagraph-compiler/src/Lamagraph/Compiler/Core/MonadDesugar.hs

+42
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,42 @@
1+
{-# LANGUAGE TemplateHaskell #-}
2+
3+
module Lamagraph.Compiler.Core.MonadDesugar where
4+
5+
import Relude
6+
import Relude.Unsafe ((!!))
7+
8+
import Control.Lens
9+
import Data.Sequences qualified
10+
11+
import Lamagraph.Compiler.Core
12+
import Lamagraph.Compiler.Syntax
13+
import Lamagraph.Compiler.Typechecker.TcTypes
14+
15+
newtype MonadDesugarState = MonadDesugarState {_freshDsCounter :: Int}
16+
17+
makeLenses 'MonadDesugarState
18+
19+
defaultMonadDesugarState :: MonadDesugarState
20+
defaultMonadDesugarState =
21+
MonadDesugarState
22+
{ _freshDsCounter = 0
23+
}
24+
25+
data DesugarError
26+
27+
type MonadDesugar a = ExceptT DesugarError (State MonadDesugarState) a
28+
29+
runMonadDesugar :: MonadDesugar a -> Either DesugarError a
30+
runMonadDesugar f = evalState (runExceptT f) defaultMonadDesugarState
31+
32+
-- FIXME: Copied from Typechecker
33+
34+
-- | This function generates words @a@, ..., @z@, @aa@, ..., @az@ and so on.
35+
letters :: [Text]
36+
letters = [1 ..] >>= flip Data.Sequences.replicateM ['a' .. 'z']
37+
38+
freshVar :: MonadDesugar Var
39+
freshVar = do
40+
count <- use freshDsCounter
41+
freshDsCounter += 1
42+
pure $ Id $ Name $ mkLongident $ pure $ "t#" <> letters !! count

Diff for: ‎lamagraph-compiler/src/Lamagraph/Compiler/Core/Pretty.hs

+77
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,77 @@
1+
{-# OPTIONS_GHC -Wno-orphans #-}
2+
3+
module Lamagraph.Compiler.Core.Pretty where
4+
5+
import Relude
6+
7+
import Lamagraph.Compiler.Core
8+
9+
import Lamagraph.Compiler.Syntax.Longident
10+
import Lamagraph.Compiler.Typechecker.TcTypes
11+
import Prettyprinter
12+
13+
-- TODO: These instances will conflict with "PrettyAST"!
14+
15+
instance Pretty Longident where
16+
pretty :: Longident -> Doc ann
17+
pretty (Longident idents) = hsep $ punctuate comma (map pretty (toList idents))
18+
19+
instance Pretty Name where
20+
pretty :: Name -> Doc ann
21+
pretty (Name longident) = pretty longident
22+
23+
instance Pretty Var where
24+
pretty :: Var -> Doc ann
25+
pretty (Id name) = pretty name
26+
27+
instance Pretty CoreBind where
28+
pretty :: CoreBind -> Doc ann
29+
pretty = \case
30+
NonRec var expr -> "let" <+> helper var expr
31+
Rec binds -> "let rec" <+> concatWith (surround (hardline <> "and" <> hardline)) (map inner (toList binds))
32+
where
33+
inner (var, expr) = helper var expr
34+
where
35+
helper var expr = pretty var <+> "=" <+> align (pretty expr)
36+
prettyList :: [CoreBind] -> Doc ann
37+
prettyList binds = vsep $ map pretty binds
38+
39+
instance Pretty CoreExpr where
40+
pretty :: CoreExpr -> Doc ann
41+
pretty = \case
42+
Var var -> pretty var
43+
Lit lit -> pretty lit
44+
App expr1 expr2 ->
45+
( case expr1 of
46+
var@(Var{}) -> pretty var
47+
lit@(Lit{}) -> pretty lit
48+
tuple@(Tuple{}) -> pretty tuple
49+
other -> parens $ pretty other
50+
)
51+
<+> parens (pretty expr2) -- FIXME: Correct parens
52+
Lam var expr -> "fun" <+> pretty var <+> "->" <> softline <> pretty expr
53+
Let bind expr -> pretty bind <> softline <> "in" <+> pretty expr
54+
Match scrutinee scrutineeVar alts ->
55+
align $
56+
"match"
57+
<+> pretty scrutinee
58+
<+> "as"
59+
<+> pretty scrutineeVar
60+
<+> "with"
61+
<+> encloseSep emptyDoc emptyDoc (flatAlt "| " " | ") (map pretty (toList alts))
62+
Tuple expr exprs -> parens (fillSep $ punctuate comma (map (parens . pretty) (expr : toList exprs)))
63+
64+
instance Pretty Literal where
65+
pretty :: Literal -> Doc ann
66+
pretty = \case
67+
LitInt int -> pretty int
68+
LitChar char -> squotes $ pretty char
69+
LitString string -> dquotes $ pretty string
70+
71+
instance Pretty AltCon where
72+
pretty :: AltCon -> Doc ann
73+
pretty = \case
74+
DataAlt dataCon -> pretty dataCon
75+
LitAlt lit -> pretty lit
76+
TupleAlt -> "TUPLE"
77+
DEFAULT -> "DEFAULT"

Diff for: ‎lamagraph-compiler/src/Lamagraph/Compiler/Typechecker/DefaultEnv.hs

+17-3
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,12 @@
1-
module Lamagraph.Compiler.Typechecker.DefaultEnv (tyInt, tyChar, tyString, tyBool, defaultEnv) where
1+
module Lamagraph.Compiler.Typechecker.DefaultEnv (
2+
tyInt,
3+
tyChar,
4+
tyString,
5+
tyBool,
6+
trueConstrName,
7+
falseConstrName,
8+
defaultEnv,
9+
) where
210

311
import Relude
412

@@ -30,6 +38,12 @@ tyString = mkTConstr "string" []
3038
tyBool :: Ty
3139
tyBool = mkTConstr "bool" []
3240

41+
trueConstrName :: Name
42+
trueConstrName = Name $ mkLongident $ pure "true"
43+
44+
falseConstrName :: Name
45+
falseConstrName = Name $ mkLongident $ pure "false"
46+
3347
tyList :: Ty
3448
tyList = mkTConstr "list" [TVar $ Name $ mkLongident $ pure "a"]
3549

@@ -63,6 +77,6 @@ defaultEnv = TyEnv env
6377
( Name $ mkLongident $ pure "Some"
6478
, Forall [Name $ mkLongident $ pure "a"] (TVar (Name $ mkLongident $ pure "a") `TArrow` tyOption)
6579
)
66-
, (Name $ mkLongident $ pure "true", Forall [] tyBool)
67-
, (Name $ mkLongident $ pure "false", Forall [] tyBool)
80+
, (trueConstrName, Forall [] tyBool)
81+
, (falseConstrName, Forall [] tyBool)
6882
]

0 commit comments

Comments
 (0)