~jojo/Carth

1bdc8508ecce3a1ec7e1f692844cea90c2739a45 — JoJo 1 year, 10 months ago 33c51d2
Refactor desugaring, remove AnnotAst.{Fun,Match}
8 files changed, 86 insertions(+), 163 deletions(-)

M src/AnnotAst.hs
M src/Check.hs
M src/Codegen.hs
D src/Desugar.hs
M src/DesugaredAst.hs
M src/Infer.hs
M src/Match.hs
M src/Subst.hs
M src/AnnotAst.hs => src/AnnotAst.hs +19 -33
@@ 10,14 10,11 @@ module AnnotAst
    , TypedVar(..)
    , Const(..)
    , VariantIx
    , Access(..)
    , Span
    , Con(..)
    , Pat'(..)
    , Pat
    , Cases(..)
    , DecisionTree(..)
    , VarBindings
    , Cases
    , Expr
    , Expr'(..)
    , Defs


@@ 29,7 26,6 @@ module AnnotAst
where

import Data.Map.Strict (Map)
import Data.Word

import Ast
    (TVar(..), TPrim(..), TConst, Type(..), Scheme(..), Const(..), startType)


@@ 43,13 39,6 @@ data TypedVar = TypedVar Id Type

type VariantIx = Integer

data Access
    = Obj
    | As Access Span [Type]
    | Sel Word32 Span Access
    | ADeref Access
    deriving (Show, Eq, Ord)

type Span = Integer

data Con = Con


@@ 67,33 56,30 @@ data Pat'
    deriving Show
type Pat = WithPos Pat'

newtype Cases = Cases [(Pat, Expr Cases)]
    deriving Show

data DecisionTree
    = DLeaf (VarBindings, Expr DecisionTree)
    | DSwitch Access (Map VariantIx DecisionTree) DecisionTree
    deriving Show

type VarBindings = Map TypedVar Access
type Cases = [(Pat, Expr)]

data Expr' m
data Expr'
    = Lit Const
    | Var TypedVar
    | App (Expr m) (Expr m) Type
    | If (Expr m) (Expr m) (Expr m)
    | Let (Defs m) (Expr m)
    | Match (Expr m) m Type Type
    | FunMatch m Type Type
    | App Expr Expr Type
    | If Expr Expr Expr
    | Let Defs Expr
    | FunMatch Cases Type Type
    | Ctor VariantIx Span TConst [Type]
    | Box (Expr m)
    | Deref (Expr m)
    | Absurd Type
    deriving (Show)
    | Box Expr
    | Deref Expr
    deriving Show

type Expr m = WithPos (Expr' m)
type Expr = WithPos Expr'

type Defs m = Map String (Scheme, Expr m)
type Defs = Map String (Scheme, Expr)
type TypeDefs = Map String ([TVar], [(String, [Type])])
type Ctors = Map String (VariantIx, (String, [TVar]), [Type], Span)
type Externs = Map String Type


instance Eq Con where
    (==) (Con c1 _ _) (Con c2 _ _) = c1 == c2

instance Ord Con where
    compare (Con c1 _ _) (Con c2 _ _) = compare c1 c2

M src/Check.hs => src/Check.hs +40 -40
@@ 25,7 25,6 @@ import AnnotAst (VariantIx)
import qualified AnnotAst as An
import Match
import Infer
import Desugar
import qualified DesugaredAst as Des




@@ 36,8 35,7 @@ typecheck (Ast.Program defs tdefs externs) = runExcept $ do
    let substd = substTopDefs substs inferred
    checkTypeVarsBound substd
    let mTypeDefs = fmap (map fst . snd) tdefs'
    checked <- checkPatternMatches mTypeDefs substd
    let desugared = desugar checked
    desugared <- compileDecisionTreesAndDesugar mTypeDefs substd
    let tdefs'' = fmap (second (map snd)) tdefs'
    pure (Des.Program desugared tdefs'' externs')



@@ 148,10 146,10 @@ type Bound = ReaderT (Set TVar) (Except TypeErr) ()

-- TODO: Many of these positions are weird and kind of arbitrary, man. They may
--       not align with where the type variable is actually detected.
checkTypeVarsBound :: An.Defs An.Cases -> Except TypeErr ()
checkTypeVarsBound :: An.Defs -> Except TypeErr ()
checkTypeVarsBound ds = runReaderT (boundInDefs ds) Set.empty
  where
    boundInDefs :: An.Defs An.Cases -> Bound
    boundInDefs :: An.Defs -> Bound
    boundInDefs = mapM_ boundInDef
    boundInDef ((An.Forall tvs _), e) =
        local (Set.union tvs) (boundInExpr e)


@@ 169,11 167,6 @@ checkTypeVarsBound ds = runReaderT (boundInDefs ds) Set.empty
        An.Let lds b -> do
            boundInDefs lds
            boundInExpr b
        An.Match m cs tp tb -> do
            boundInExpr m
            boundInCases cs
            boundInType pos tp
            boundInType pos tb
        An.FunMatch cs pt bt -> do
            boundInCases cs
            boundInType pos pt


@@ 183,7 176,6 @@ checkTypeVarsBound ds = runReaderT (boundInDefs ds) Set.empty
            forM_ ts (boundInType pos)
        An.Box x -> boundInExpr x
        An.Deref x -> boundInExpr x
        An.Absurd t -> boundInType pos t
    boundInType :: SrcPos -> An.Type -> Bound
    boundInType pos = \case
        TVar tv -> do


@@ 193,7 185,7 @@ checkTypeVarsBound ds = runReaderT (boundInDefs ds) Set.empty
        TConst (_, ts) -> forM_ ts (boundInType pos)
        TFun ft at -> forM_ [ft, at] (boundInType pos)
        TBox t -> boundInType pos t
    boundInCases (An.Cases cs) = forM_ cs (bimapM boundInPat boundInExpr)
    boundInCases cs = forM_ cs (bimapM boundInPat boundInExpr)
    boundInPat (WithPos pos pat) = case pat of
        An.PVar (An.TypedVar _ t) -> boundInType pos t
        An.PWild -> pure ()


@@ 201,32 193,40 @@ checkTypeVarsBound ds = runReaderT (boundInDefs ds) Set.empty
        An.PBox p -> boundInPat p
    boundInCon pos (Con _ _ ts) = forM_ ts (boundInType pos)

checkPatternMatches
    :: MTypeDefs -> An.Defs An.Cases -> Except TypeErr (An.Defs An.DecisionTree)
checkPatternMatches tdefs = checkMsDefs
compileDecisionTreesAndDesugar
    :: MTypeDefs -> An.Defs -> Except TypeErr Des.Defs
compileDecisionTreesAndDesugar tdefs = compDefs
  where
    checkMsDefs = mapM checkMsDef
    checkMsDef = bimapM pure checkMsExpr
    checkMsExpr
        :: An.Expr An.Cases -> Except TypeErr (An.Expr An.DecisionTree)
    checkMsExpr (WithPos pos e) = fmap (WithPos pos) $ case e of
        An.Lit c -> pure (An.Lit c)
        An.Var v -> pure (An.Var v)
        An.App f a tr ->
            liftA3 An.App (checkMsExpr f) (checkMsExpr a) (pure tr)
        An.If p c a ->
            liftA3 An.If (checkMsExpr p) (checkMsExpr c) (checkMsExpr a)
        An.Let lds b -> liftA2 An.Let (checkMsDefs lds) (checkMsExpr b)
        An.Match m cs tp tb -> do
            m' <- checkMsExpr m
            toDecisionTree' pos tp cs tb (An.Match m')
        An.FunMatch cs tp tb -> toDecisionTree' pos tp cs tb An.FunMatch
        An.Ctor v s tc ts -> pure (An.Ctor v s tc ts)
        An.Box x -> fmap An.Box (checkMsExpr x)
        An.Deref x -> fmap An.Deref (checkMsExpr x)
        An.Absurd t -> pure (An.Absurd t)
    toDecisionTree' pos tp (An.Cases cs) tb f = do
        cs' <- mapM (secondM checkMsExpr) cs
        case runExceptT (toDecisionTree tdefs pos tp cs') of
            Nothing -> pure (An.Absurd tb)
            Just e -> fmap (\dt -> f dt tp tb) (liftEither e)
    compDefs = mapM compDef
    compDef = bimapM pure compExpr
    compExpr :: An.Expr -> Except TypeErr Des.Expr
    compExpr (WithPos pos e) = case e of
        An.Lit c -> pure (Des.Lit c)
        An.Var (An.TypedVar (WithPos _ x) t) ->
            pure (Des.Var (Des.TypedVar x t))
        An.App f a tr -> liftA3 Des.App (compExpr f) (compExpr a) (pure tr)
        An.If p c a -> liftA3 Des.If (compExpr p) (compExpr c) (compExpr a)
        An.Let lds b -> liftA2 Des.Let (compDefs lds) (compExpr b)
        An.FunMatch cs tp tb -> do
            cs' <- mapM (secondM compExpr) cs
            case runExceptT (toDecisionTree tdefs pos tp cs') of
                Nothing -> pure (Des.Absurd tb)
                Just e -> do
                    dt <- liftEither e
                    let p = "#x"
                        v = Des.Var (Des.TypedVar p tp)
                        b = Des.Match v dt tb
                    pure (Des.Fun (p, tp) (b, tb))
        An.Ctor v span' inst ts ->
            let
                xs = map
                    (\n -> "#x" ++ show n)
                    (take (length ts) [0 :: Word ..])
                params = zip xs ts
                args = map (Des.Var . uncurry Des.TypedVar) params
            in pure $ snd $ foldr
                (\(p, pt) (bt, b) -> (TFun pt bt, Des.Fun (p, pt) (b, bt)))
                (TConst inst, Des.Ction v span' inst args)
                params
        An.Box x -> fmap Des.Box (compExpr x)
        An.Deref x -> fmap Des.Deref (compExpr x)

M src/Codegen.hs => src/Codegen.hs +3 -3
@@ 416,9 416,9 @@ genDecisionSwitch selector cs def tbody selections = do
    fmap VLocal (emitAnon (phi (v : vs)))

genDecisionLeaf :: (MonoAst.VarBindings, Expr) -> Selections Operand -> Gen Val
genDecisionLeaf (bs, e) selections =
    flip withLocals (genExpr e)
        =<< selectVarBindings selAs selSub selDeref selections bs
genDecisionLeaf (bs, e) selections = do
    bs' <- selectVarBindings selAs selSub selDeref selections bs
    withLocals bs' (genExpr e)

selAs :: Span -> [MonoAst.Type] -> Operand -> Gen Operand
selAs totVariants ts matchee = do

D src/Desugar.hs => src/Desugar.hs +0 -55
@@ 1,55 0,0 @@
{-# LANGUAGE LambdaCase #-}

-- TODO: Let's get rid of this module. It wasn't a good idea after all.

module Desugar (desugar) where

import Data.Bifunctor
import qualified Data.Map as Map

import SrcPos
import qualified AnnotAst as An
import DesugaredAst


type ADefs = An.Defs An.DecisionTree
type AExpr = An.Expr An.DecisionTree

desugar :: ADefs -> Defs
desugar = desugarDefs

desugarDefs :: ADefs -> Defs
desugarDefs = fmap (second desugarExpr)

desugarExpr :: AExpr -> Expr
desugarExpr (WithPos _ e) = case e of
    An.Lit c -> Lit c
    An.Var v -> Var (desugarTypedVar v)
    An.App f a rt -> App (desugarExpr f) (desugarExpr a) rt
    An.If p c a -> If (desugarExpr p) (desugarExpr c) (desugarExpr a)
    An.Let ds b -> Let (desugarDefs ds) (desugarExpr b)
    An.Match m dt _ tb -> Match (desugarExpr m) (desugarDecTree dt) tb
    An.FunMatch dt pt bt ->
        let x = "#x"
        in Fun (x, pt) (Match (Var (TypedVar x pt)) (desugarDecTree dt) bt, bt)
    An.Ctor v span' inst ts ->
        let
            xs = map (\n -> "#x" ++ show n) (take (length ts) [0 :: Word ..])
            params = zip xs ts
            args = map (Var . uncurry TypedVar) params
        in snd $ foldr
            (\(p, pt) (bt, b) -> (TFun pt bt, Fun (p, pt) (b, bt)))
            (TConst inst, Ction v span' inst args)
            params
    An.Box e -> Box (desugarExpr e)
    An.Deref e -> Deref (desugarExpr e)
    An.Absurd t -> Absurd t

desugarDecTree :: An.DecisionTree -> DecisionTree
desugarDecTree = \case
    An.DLeaf (bs, e) -> DLeaf (Map.mapKeys desugarTypedVar bs, desugarExpr e)
    An.DSwitch a cs def ->
        DSwitch a (fmap desugarDecTree cs) (desugarDecTree def)

desugarTypedVar :: An.TypedVar -> TypedVar
desugarTypedVar (An.TypedVar (WithPos _ x) t) = TypedVar x t

M src/DesugaredAst.hs => src/DesugaredAst.hs +10 -1
@@ 8,6 8,7 @@ module DesugaredAst
    , Const(..)
    , VariantIx
    , Span
    , Con(..)
    , Access(..)
    , VarBindings
    , DecisionTree(..)


@@ 21,6 22,7 @@ module DesugaredAst
where

import Data.Map.Strict (Map)
import Data.Word

import AnnotAst
    ( TVar(..)


@@ 31,13 33,20 @@ import AnnotAst
    , Const(..)
    , VariantIx
    , Span
    , Access(..)
    , Con(..)
    , startType
    )

data TypedVar = TypedVar String Type
    deriving (Show, Eq, Ord)

data Access
    = Obj
    | As Access Span [Type]
    | Sel Word32 Span Access
    | ADeref Access
    deriving (Show, Eq, Ord)

type VarBindings = Map TypedVar Access

data DecisionTree

M src/Infer.hs => src/Infer.hs +4 -8
@@ 22,14 22,9 @@ import Subst
import qualified Ast
import Ast (Id(..), IdCase(..), idstr, scmBody, isFunLike)
import TypeErr
import qualified AnnotAst
import AnnotAst hiding (Expr, Expr', Defs, Id)
import AnnotAst hiding (Id)


type Expr' = AnnotAst.Expr' Cases
type Expr = AnnotAst.Expr Cases
type Defs = AnnotAst.Defs Cases

newtype ExpectedType = Expected Type
data FoundType = Found SrcPos Type



@@ 184,7 179,8 @@ infer (WithPos pos e) = fmap (second (WithPos pos)) $ case e of
    Ast.Match matchee cases -> do
        (tmatchee, matchee') <- infer matchee
        (tbody, cases') <- inferCases (Expected tmatchee) cases
        pure (tbody, Match matchee' cases' tmatchee tbody)
        let f = WithPos pos (FunMatch cases' tmatchee tbody)
        pure (tbody, App f matchee' tbody)
    Ast.FunMatch cases -> inferFunMatch cases
    Ast.Ctor c -> inferExprConstructor c
    Ast.Box x -> fmap (\(tx, x') -> (TBox tx, Box x')) (infer x)


@@ 211,7 207,7 @@ inferCases tmatchee cases = do
    forM_ tpats (unify tmatchee)
    tbody <- fresh
    forM_ tbodies (unify (Expected tbody))
    pure (tbody, Cases cases')
    pure (tbody, cases')

inferCase :: (Ast.Pat, Ast.Expr) -> Infer (FoundType, FoundType, (Pat, Expr))
inferCase (p, b) = do

M src/Match.hs => src/Match.hs +7 -13
@@ 4,7 4,7 @@
--   and partial evaluation/ by Peter Sestoft. Close to 1:1, and includes the
--   additional checks for exhaustiveness and redundancy described in section
--   7.4.
module Match (toDecisionTree, Span, Con(..), MTypeDefs) where
module Match (toDecisionTree, Span, Con(..), Access(..), MTypeDefs) where

import Prelude hiding (span)
import qualified Data.Set as Set


@@ 23,12 23,11 @@ import Control.Lens (makeLenses, view, views)
import Misc hiding (augment)
import SrcPos
import TypeErr
import qualified AnnotAst
import AnnotAst hiding (Expr)
import qualified AnnotAst as An
import AnnotAst (Pat, Pat'(..))
import DesugaredAst


type Expr = AnnotAst.Expr DecisionTree

data Descr = Pos Con [Descr] | Neg (Set Con)
    deriving Show



@@ 55,13 54,6 @@ makeLenses ''Env
type Match = ReaderT Env (StateT RedundantCases (ExceptT TypeErr Maybe))


instance Eq Con where
    (==) (Con c1 _ _) (Con c2 _ _) = c1 == c2

instance Ord Con where
    compare (Con c1 _ _) (Con c2 _ _) = compare c1 c2


toDecisionTree
    :: MTypeDefs
    -> SrcPos


@@ 131,7 123,9 @@ match
    -> Pat'
    -> Match DecisionTree'
match obj descr ctx work rhs rules = \case
    PVar x -> conjunct (augment descr ctx) (addBind x obj rhs) rules work
    PVar (An.TypedVar (An.WithPos _ x) tx) ->
        let x' = TypedVar x tx
        in conjunct (augment descr ctx) (addBind x' obj rhs) rules work
    PWild -> conjunct (augment descr ctx) rhs rules work
    PBox (WithPos _ p) -> match (ADeref obj) descr ctx work rhs rules p
    PCon pcon pargs ->

M src/Subst.hs => src/Subst.hs +3 -10
@@ 7,13 7,9 @@ import Data.Map.Strict (Map)
import Data.Bifunctor
import Data.Maybe

import qualified AnnotAst as An
import AnnotAst hiding (Defs, Expr)
import AnnotAst


type Defs = An.Defs Cases
type Expr = An.Expr Cases

-- | Map of substitutions from type-variables to more specific types
type Subst = Map TVar Type



@@ 24,23 20,20 @@ substDef :: Subst -> (Scheme, Expr) -> (Scheme, Expr)
substDef s = second (substExpr s)

substExpr :: Subst -> Expr -> Expr
substExpr s (WithPos p e) = WithPos p $ case e of
substExpr s (WithPos pos expr) = WithPos pos $ case expr of
    Lit c -> Lit c
    Var v -> Var (substTypedVar s v)
    App f a rt -> App (substExpr s f) (substExpr s a) (subst s rt)
    If p c a -> If (substExpr s p) (substExpr s c) (substExpr s a)
    Let defs body -> Let (fmap (substDef s) defs) (substExpr s body)
    Match e cs tp tbody ->
        Match (substExpr s e) (substCases s cs) (subst s tp) (subst s tbody)
    FunMatch cs tp tb -> FunMatch (substCases s cs) (subst s tp) (subst s tb)
    Ctor i span' (tx, tts) ps ->
        Ctor i span' (tx, map (subst s) tts) (map (subst s) ps)
    Box e -> Box (substExpr s e)
    Deref e -> Deref (substExpr s e)
    Absurd t -> Absurd (subst s t)

substCases :: Subst -> Cases -> Cases
substCases s (Cases cs) = Cases (map (bimap (substPat s) (substExpr s)) cs)
substCases s cs = map (bimap (substPat s) (substExpr s)) cs

substPat :: Subst -> Pat -> Pat
substPat s (WithPos pos pat) = WithPos pos $ case pat of