Core

.github/workflows/build-and-test.yaml

@@ -15,6 +15,7 @@ jobs:
         with:
           enable-stack: true
           stack-version: "latest"
+          ghc-version: "9.4.8"
 
       - name: Cache dependencies
         uses: actions/cache@v4
@@ -53,6 +54,7 @@ jobs:
         with:
           enable-stack: true
           stack-version: "latest"
+          ghc-version: "9.4.8"
 
       - name: Cache dependencies
         uses: actions/cache@v4

.pre-commit-config.yaml

@@ -4,7 +4,7 @@ repos:
     hooks:
       - id: trailing-whitespace
       - id: end-of-file-fixer
-        exclude: "ast/.*|ppr/.*"
+        exclude: "ast/.*|ppr/.*|core/.*"
       - id: check-yaml
       - id: fix-byte-order-marker
       - id: mixed-line-ending

lamagraph-compiler/lamagraph-compiler.cabal

@@ -24,6 +24,10 @@ source-repository head
 
 library
   exposed-modules:
+      Lamagraph.Compiler.Core
+      Lamagraph.Compiler.Core.LmlToCore
+      Lamagraph.Compiler.Core.MonadDesugar
+      Lamagraph.Compiler.Core.Pretty
       Lamagraph.Compiler.Extension
       Lamagraph.Compiler.Parser
       Lamagraph.Compiler.Parser.Lexer
@@ -109,6 +113,7 @@ test-suite lamagraph-compiler-test
   type: exitcode-stdio-1.0
   main-is: Spec.hs
   other-modules:
+      Lamagraph.Compiler.Core.PrettyCoreGolden
       Lamagraph.Compiler.GoldenCommon
       Lamagraph.Compiler.Parser.LexerTest
       Lamagraph.Compiler.Parser.ParserRoundtrip

lamagraph-compiler/src/Lamagraph/Compiler/Core.hs

@@ -0,0 +1,49 @@
+module Lamagraph.Compiler.Core (
+  Literal (..),
+  DataCon,
+  Var (..),
+  Expr (..),
+  MatchAlt,
+  AltCon (..),
+  Bind (..),
+  CoreExpr,
+  CoreMatchAlt,
+  CoreBind,
+) where
+
+import Relude
+
+import Lamagraph.Compiler.Typechecker.TcTypes
+
+data Literal = LitInt Int | LitChar Char | LitString Text deriving (Show)
+
+-- FIXME: Must change after addition of ADTs
+type DataCon = Name
+
+-- TODO: Is this wrapper really required?
+newtype Var
+  = Id Name -- Term variable
+  deriving (Eq, Show)
+
+data Expr b
+  = Var b
+  | Lit Literal
+  | App (Expr b) (Expr b)
+  | Lam b (Expr b)
+  | Let (Bind b) (Expr b)
+  | -- | For a reason behind this signature see https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/core-syn-type#case-expressions
+    Match (Expr b) b (NonEmpty (MatchAlt b))
+  | -- In Haskell, tuples are just syntactic sugar for @data TupleN a1...aN = TupleN a1...aN@,
+    -- but in Caml they are separate construction
+    Tuple (Expr b) (NonEmpty (Expr b))
+  deriving (Show)
+
+type MatchAlt b = (AltCon, [b], Expr b)
+
+data AltCon = DataAlt DataCon | LitAlt Literal | TupleAlt | DEFAULT deriving (Show)
+
+data Bind b = NonRec b (Expr b) | Rec (NonEmpty (b, Expr b)) deriving (Show)
+
+type CoreExpr = Expr Var
+type CoreMatchAlt = MatchAlt Var
+type CoreBind = Bind Var

lamagraph-compiler/src/Lamagraph/Compiler/Core/LmlToCore.hs

@@ -0,0 +1,162 @@
+module Lamagraph.Compiler.Core.LmlToCore (desugarLmlModule) where
+
+import Relude
+
+import Control.Monad.Extra
+import Data.Foldable.Extra hiding (elem)
+
+import Lamagraph.Compiler.Core
+import Lamagraph.Compiler.Core.MonadDesugar
+import Lamagraph.Compiler.Extension
+import Lamagraph.Compiler.Parser.SrcLoc
+import Lamagraph.Compiler.Syntax
+import Lamagraph.Compiler.Typechecker.DefaultEnv
+import Lamagraph.Compiler.Typechecker.TcTypes
+
+desugarLmlLit :: LmlLit LmlcTc -> Literal
+desugarLmlLit = \case
+  LmlInt _ int -> LitInt int
+  LmlChar _ char -> LitChar char
+  LmlString _ string -> LitString string
+
+desugarLLmlExpr :: LLmlExpr LmlcTc -> MonadDesugar CoreExpr
+desugarLLmlExpr (L _ expr) = desugarLmlExpr expr
+
+desugarLmlExpr :: LmlExpr LmlcTc -> MonadDesugar CoreExpr
+desugarLmlExpr = \case
+  LmlExprIdent _ longident -> pure $ Var $ Id $ Name longident
+  LmlExprConstant _ lit -> pure $ Lit $ desugarLmlLit lit
+  LmlExprLet _ lBindGroup lExpr -> foldr Let <$> desugarLLmlExpr lExpr <*> desugarLLmlBindGroup lBindGroup
+  LmlExprFunction _ lPat lExpr -> Lam <$> desugarLLmlPat lPat <*> desugarLLmlExpr lExpr
+  LmlExprApply _ lExpr lExprs -> foldl App <$> desugarLLmlExpr lExpr <*> mapM desugarLLmlExpr lExprs
+  LmlExprMatch _ lExpr lCases -> do
+    scrutineeVar <- freshVar
+    expr <- desugarLLmlExpr lExpr
+    cases <- mapM (desugarLLmlCase scrutineeVar) lCases
+    pure $ Match expr scrutineeVar cases
+  LmlExprTuple _ lExpr lExprs -> Tuple <$> desugarLLmlExpr lExpr <*> mapM desugarLLmlExpr lExprs
+  LmlExprConstruct _ (L _ longident) maybeArgs ->
+    let constructorVar = Var $ Id $ Name longident
+     in case maybeArgs of
+          Nothing -> pure constructorVar
+          Just lArgs -> App constructorVar <$> desugarLLmlExpr lArgs
+  LmlExprIfThenElse _ lCond lTrue lFalse -> do
+    trueExpr <- desugarLLmlExpr lTrue
+    falseExpr <- desugarLLmlExpr lFalse
+    let trueAlt = (DataAlt trueConstrName, [], trueExpr)
+        falseAlt = (DataAlt falseConstrName, [], falseExpr)
+    condExpr <- desugarLLmlExpr lCond
+    var <- freshVar
+    pure $ Match condExpr var (trueAlt :| [falseAlt])
+  LmlExprConstraint _ lExpr _ -> desugarLLmlExpr lExpr
+
+desugarLLmlCase :: Var -> LLmlCase LmlcTc -> MonadDesugar CoreMatchAlt
+desugarLLmlCase scrutineeVar (L _ case') = desugarLmlCase scrutineeVar case'
+
+desugarLmlCase :: Var -> LmlCase LmlcTc -> MonadDesugar CoreMatchAlt
+desugarLmlCase scrutineeVar (LmlCase _ (L _ pat) Nothing lExpr) = do
+  expr <- desugarLLmlExpr lExpr
+  case pat of
+    LmlPatAny _ -> pure (DEFAULT, [], expr)
+    LmlPatVar _ (L _ ident) ->
+      pure
+        ( DEFAULT
+        , []
+        , replaceVar (Id $ Name $ mkLongident $ pure ident) scrutineeVar expr
+        )
+    LmlPatConstant _ lit -> pure (LitAlt $ desugarLmlLit lit, [], expr)
+    LmlPatTuple _ lPat lPats ->
+      let vars = map helper (lPat : toList lPats)
+       in pure (TupleAlt, vars, expr)
+    LmlPatConstruct _ (L _ longident) maybeLPat ->
+      let constuctorName = Name longident
+       in case maybeLPat of
+            Nothing -> pure (DataAlt constuctorName, [], expr)
+            Just (L _ args) ->
+              case args of
+                LmlPatVar _ (L _ ident) -> pure (DataAlt constuctorName, [Id $ Name $ mkLongident $ pure ident], expr)
+                LmlPatTuple _ lPat lPats ->
+                  let vars = map helper (lPat : toList lPats)
+                   in pure (DataAlt constuctorName, vars, expr)
+                _ -> error "Internal error: Constructors can only be applied to Var or Tuple."
+    LmlPatOr{} -> error "FIXME: Or patterns in match expressions aren't supported."
+    LmlPatConstraint{} -> error "FIXME: Constraints in pattern-matching are currently unsupported."
+ where
+  helper lPat = case unLoc lPat of
+    LmlPatVar _ (L _ ident) -> Id $ Name $ mkLongident $ pure ident
+    _ -> error "FIXME: Nested patterns are currently unsupported."
+desugarLmlCase _ (LmlCase _ _ (Just _) _) = error "FIXME: Guards in pattern-matching are currently unsupported."
+
+desugarLLmlPat :: LLmlPat LmlcTc -> MonadDesugar Var
+desugarLLmlPat (L _ pat) = desugarLmlPat pat
+
+desugarLmlPat :: LmlPat LmlcTc -> MonadDesugar Var
+desugarLmlPat = \case
+  LmlPatVar _ (L _ ident) -> pure $ Id $ Name $ mkLongident $ pure ident
+  LmlPatConstraint _ lPat _ -> desugarLLmlPat lPat
+  _ -> error "FIXME: Only Var and Constraint patterns are currently supported."
+
+desugarLLmlBindGroup :: LLmlBindGroup LmlcTc -> MonadDesugar (NonEmpty CoreBind)
+desugarLLmlBindGroup (L _ bindGroup) = desugarLmlBindGroup bindGroup
+
+{- | Invariant of this function:
+If we have 'Recursive' bind group then we have only one element in the list,
+otherwise we have as many elements in the list as let exprs.
+-}
+desugarLmlBindGroup :: LmlBindGroup LmlcTc -> MonadDesugar (NonEmpty CoreBind)
+desugarLmlBindGroup (LmlBindGroup _ NonRecursive lBinds) = do
+  binds <- mapM desugarLLmlBind lBinds
+  pure $ fmap (uncurry NonRec) binds
+desugarLmlBindGroup (LmlBindGroup _ Recursive lBinds) = do
+  binds <- mapM desugarLLmlBind lBinds
+  pure $ pure $ Rec binds
+
+desugarLLmlBind :: LLmlBind LmlcTc -> MonadDesugar (Var, CoreExpr)
+desugarLLmlBind (L _ bind) = desugarLmlBind bind
+
+desugarLmlBind :: LmlBind LmlcTc -> MonadDesugar (Var, CoreExpr)
+desugarLmlBind (LmlBind _ lPat lExpr) = liftA2 (,) (desugarLLmlPat lPat) (desugarLLmlExpr lExpr)
+
+replaceVar :: Var -> Var -> CoreExpr -> CoreExpr
+replaceVar oldVar newVar = \case
+  var@(Var id') -> if id' == oldVar then Var newVar else var
+  lit@(Lit _) -> lit
+  App leftExpr rightExpr -> App (replaceVar oldVar newVar leftExpr) (replaceVar oldVar newVar rightExpr)
+  lam@(Lam var expr) -> if var == oldVar then lam else Lam var (replaceVar oldVar newVar expr)
+  Let bind expr ->
+    let (newBind, control) = replaceVarBind oldVar newVar bind
+     in if control then Let newBind (replaceVar oldVar newVar expr) else Let newBind expr
+  Match scrutinee scrutineeVar alts ->
+    if scrutineeVar == oldVar
+      then Match (replaceVar oldVar newVar scrutinee) scrutineeVar alts
+      else Match (replaceVar oldVar newVar scrutinee) scrutineeVar (fmap (replaceVarMatchAlt oldVar newVar) alts)
+  Tuple expr exprs -> Tuple (replaceVar oldVar newVar expr) $ fmap (replaceVar oldVar newVar) exprs
+
+{- | Replaces variable in 'Bind'.
+If this binding binds variable then we emit 'False' to stop replacing further, otherwise return 'True'.
+-}
+replaceVarBind :: Var -> Var -> CoreBind -> (CoreBind, Bool)
+replaceVarBind oldVar newVar = \case
+  nr@(NonRec var expr) -> if var == oldVar then (nr, False) else (NonRec newVar (replaceVar oldVar newVar expr), True)
+  r@(Rec binds) ->
+    if elem oldVar $ fmap fst binds
+      then (r, False)
+      else (Rec $ fmap (second (replaceVar oldVar newVar)) binds, True)
+
+replaceVarMatchAlt :: Var -> Var -> CoreMatchAlt -> CoreMatchAlt
+replaceVarMatchAlt oldVar newVar alt@(altCon, boundVars, expr) =
+  if oldVar `elem` boundVars
+    then alt
+    else
+      (altCon, boundVars, replaceVar oldVar newVar expr)
+
+desugarLLmlDecl :: LLmlDecl LmlcTc -> MonadDesugar [CoreBind]
+desugarLLmlDecl (L _ decl) = desugarLmlDecl decl
+
+desugarLmlDecl :: LmlDecl LmlcTc -> MonadDesugar [CoreBind]
+desugarLmlDecl = \case
+  ValD _ lBindGroup -> toList <$> desugarLLmlBindGroup lBindGroup
+  _ -> pure []
+
+desugarLmlModule :: LmlModule LmlcTc -> MonadDesugar [CoreBind]
+desugarLmlModule (LmlModule _ _ lDecls) = concatMapM desugarLLmlDecl lDecls

lamagraph-compiler/src/Lamagraph/Compiler/Core/MonadDesugar.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Lamagraph.Compiler.Core.MonadDesugar (MonadDesugar, runMonadDesugar, freshVar) where
+
+import Relude
+import Relude.Unsafe ((!!))
+
+import Control.Lens
+import Data.Sequences qualified
+
+import Lamagraph.Compiler.Core
+import Lamagraph.Compiler.Syntax
+import Lamagraph.Compiler.Typechecker.TcTypes
+
+newtype MonadDesugarState = MonadDesugarState {_freshDsCounter :: Int}
+
+makeLenses 'MonadDesugarState
+
+defaultMonadDesugarState :: MonadDesugarState
+defaultMonadDesugarState =
+  MonadDesugarState
+    { _freshDsCounter = 0
+    }
+
+data DesugarError
+
+type MonadDesugar a = ExceptT DesugarError (State MonadDesugarState) a
+
+runMonadDesugar :: MonadDesugar a -> Either DesugarError a
+runMonadDesugar f = evalState (runExceptT f) defaultMonadDesugarState
+
+-- FIXME: Copied from Typechecker
+
+-- | This function generates words @a@, ..., @z@, @aa@, ..., @az@ and so on.
+letters :: [Text]
+letters = [1 ..] >>= flip Data.Sequences.replicateM ['a' .. 'z']
+
+freshVar :: MonadDesugar Var
+freshVar = do
+  count <- use freshDsCounter
+  freshDsCounter += 1
+  pure $ Id $ Name $ mkLongident $ pure $ "t#" <> letters !! count

lamagraph-compiler/src/Lamagraph/Compiler/Core/Pretty.hs

@@ -0,0 +1,76 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Lamagraph.Compiler.Core.Pretty () where
+
+import Relude
+
+import Lamagraph.Compiler.Core
+
+import Lamagraph.Compiler.Syntax.Longident
+import Lamagraph.Compiler.Typechecker.TcTypes
+import Prettyprinter
+
+-- TODO: These instances will conflict with "PrettyAST"!
+
+instance Pretty Longident where
+  pretty :: Longident -> Doc ann
+  pretty (Longident idents) = hsep $ punctuate comma (map pretty (toList idents))
+
+instance Pretty Name where
+  pretty :: Name -> Doc ann
+  pretty (Name longident) = pretty longident
+
+instance Pretty Var where
+  pretty :: Var -> Doc ann
+  pretty (Id name) = pretty name
+
+instance Pretty CoreBind where
+  pretty :: CoreBind -> Doc ann
+  pretty = \case
+    NonRec var expr -> "let" <+> helper var expr
+    Rec binds -> "let rec" <+> concatWith (surround (hardline <> "and" <> hardline)) (map inner (toList binds))
+     where
+      inner (var, expr) = helper var expr
+   where
+    helper var expr = pretty var <+> "=" <+> align (pretty expr)
+  prettyList :: [CoreBind] -> Doc ann
+  prettyList binds = vsep $ map pretty binds
+
+instance Pretty CoreExpr where
+  pretty :: CoreExpr -> Doc ann
+  pretty = \case
+    Var var -> pretty var
+    Lit lit -> pretty lit
+    App expr1 expr2 -> helper expr1 <+> helper expr2
+     where
+      helper expr = case expr of
+        var@(Var{}) -> pretty var
+        lit@(Lit{}) -> pretty lit
+        tuple@(Tuple{}) -> pretty tuple
+        other -> parens $ pretty other
+    Lam var expr -> "fun" <+> pretty var <+> "->" <> softline <> pretty expr
+    Let bind expr -> pretty bind <> softline <> "in" <+> pretty expr
+    Match scrutinee scrutineeVar alts ->
+      align $
+        "match"
+          <+> pretty scrutinee
+          <+> "as"
+          <+> pretty scrutineeVar
+          <+> "with"
+          <+> encloseSep emptyDoc emptyDoc (flatAlt "| " " | ") (map pretty (toList alts))
+    Tuple expr exprs -> parens (fillSep $ punctuate comma (map (parens . pretty) (expr : toList exprs)))
+
+instance Pretty Literal where
+  pretty :: Literal -> Doc ann
+  pretty = \case
+    LitInt int -> pretty int
+    LitChar char -> squotes $ pretty char
+    LitString string -> dquotes $ pretty string
+
+instance Pretty AltCon where
+  pretty :: AltCon -> Doc ann
+  pretty = \case
+    DataAlt dataCon -> pretty dataCon
+    LitAlt lit -> pretty lit
+    TupleAlt -> "TUPLE"
+    DEFAULT -> "DEFAULT"