~jojo/Carth

b55c3767dbf0272b7533fc28d12f5f026d8a0e2c — JoJo 1 year, 6 months ago ee5251b
Add `transmute` special form

Use to change the type of an expression without modifying the bits in
any way -- just interpret them as if they represented the new type.

Example:
    (: (transmute (: 4623716258932001341 Int)) F64)
results in
    (: 13.37 F64)
M app/Main.hs => app/Main.hs +2 -2
@@ 7,7 7,7 @@ import Control.Monad

import Misc
import Pretty
import qualified TypeErr
import qualified Err
import qualified Parsed
import qualified Checked
import Check


@@ 72,5 72,5 @@ parse f = Parse.parse f >>= \case

typecheck' :: FilePath -> Parsed.Program -> IO Checked.Program
typecheck' f p = case typecheck p of
    Left e -> TypeErr.printErr e >> abort f
    Left e -> Err.printTypeErr e >> abort f
    Right p -> pure p

M carth.cabal => carth.cabal +1 -1
@@ 44,7 44,7 @@ library
      Selections
      SrcPos
      Subst
      TypeErr
      Err
  other-modules:
  hs-source-dirs:
      src

M src/Check.hs => src/Check.hs +6 -1
@@ 6,6 6,7 @@ import Prelude hiding (span)
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Functor
import Data.Bifunctor
import Data.Bitraversable
import Data.Foldable


@@ 20,7 21,7 @@ import SrcPos
import Subst
import qualified Parsed
import Parsed (Id(..), TVar(..), TPrim(..), idstr)
import TypeErr
import Err
import qualified Inferred
import Match
import Infer


@@ 182,6 183,8 @@ checkTypeVarsBound ds = runReaderT (boundInDefs ds) Set.empty
            forM_ ts (boundInType pos)
        Inferred.Box x -> boundInExpr x
        Inferred.Deref x -> boundInExpr x
        Inferred.Transmute x t u ->
            boundInExpr x *> boundInType pos t *> boundInType pos u
    boundInType :: SrcPos -> Inferred.Type -> Bound
    boundInType pos = \case
        Inferred.TVar tv -> do


@@ 243,3 246,5 @@ compileDecisionTrees tdefs = compDefs
                params
        Inferred.Box x -> fmap Checked.Box (compExpr x)
        Inferred.Deref x -> fmap Checked.Deref (compExpr x)
        Inferred.Transmute x t u ->
            compExpr x <&> \x' -> Checked.Transmute pos x' t u

M src/Checked.hs => src/Checked.hs +1 -0
@@ 60,6 60,7 @@ data Expr'
    | Box Expr
    | Deref Expr
    | Absurd Type
    | Transmute SrcPos Expr Type Type
    deriving (Show)

data Expr = Expr (Maybe SrcPos) Expr'

M src/Codegen.hs => src/Codegen.hs +83 -19
@@ 15,6 15,7 @@ import qualified LLVM.AST.Constant as LLConst
import Data.String
import System.FilePath
import Control.Monad.Writer
import Control.Monad.Except
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set


@@ 24,6 25,7 @@ import Data.Foldable
import Data.List
import Data.Function
import Data.Functor
import Data.Functor.Identity
import Data.Bifunctor
import Control.Applicative
import Lens.Micro.Platform (use, assign)


@@ 31,19 33,23 @@ import Lens.Micro.Platform (use, assign)
import Misc
import SrcPos
import FreeVars
import qualified Monomorphic
import qualified Monomorphic as M
import Monomorphic hiding (Type, Const)
import Selections
import Gen
import Extern


codegen :: DataLayout -> FilePath -> Program -> Module
codegen :: DataLayout -> FilePath -> Program -> Either GenErr Module
codegen layout moduleFilePath (Program (Topo defs) tdefs externs) =
    let
        (tdefs', externs', globDefs) = runGen' $ do
            (enums, tdefs'') <- defineDataTypes tdefs
            augment enumTypes enums
    runExcept $ do
        (tdefs', externs', globDefs) <-
            let
                (enums, tdefs'') =
                    runIdentity (runGen' (defineDataTypes tdefs))
            in
                runGen'
                $ augment enumTypes enums
                $ augment dataTypes tdefs''
                $ withExternSigs externs
                $ withGlobDefSigs (map (second unpos) defs)


@@ 51,8 57,7 @@ codegen layout moduleFilePath (Program (Topo defs) tdefs externs) =
                    es <- genExterns externs
                    ds <- liftA2 (:) genMain (fmap join (mapM genGlobDef defs))
                    pure (tdefs'', es, ds)
    in
        Module
        pure $ Module
            { moduleName = fromString ((takeBaseName moduleFilePath))
            , moduleSourceFileName = fromString moduleFilePath
            , moduleDataLayout = Just layout


@@ 133,7 138,7 @@ codegen layout moduleFilePath (Program (Topo defs) tdefs externs) =
--   enumeration, which is represented as a single integer, equal to the size it
--   would have been as a tag. If further there's only a single variant, the
--   data-type is represented as `{}`.
defineDataTypes :: TypeDefs -> Gen' (Map Name Word32, Map Name [Type])
defineDataTypes :: TypeDefs -> Gen'T Identity (Map Name Word32, Map Name [Type])
defineDataTypes tds = do
    let (enums, datas) = partition (all null . snd) tds
    let enums' = Map.fromList $ map


@@ 175,8 180,7 @@ genMain = do
--       start, or an interpretation step is added between monomorphization and
--       codegen that evaluates all expressions in relevant contexts, like
--       constexprs.
genGlobDef
    :: (TypedVar, WithPos ([Monomorphic.Type], Expr)) -> Gen' [Definition]
genGlobDef :: (TypedVar, WithPos ([M.Type], Expr)) -> Gen' [Definition]
genGlobDef (TypedVar v _, WithPos dpos (ts, (Expr _ e))) = case e of
    Fun p (body, rt) -> do
        let var = (v, ts)


@@ 226,14 230,15 @@ genExpr (Expr pos expr) = locally srcPos (pos <|>) $ do
        Box e -> genBox =<< genExpr e
        Deref e -> genDeref e
        Absurd t -> fmap (VLocal . undef) (genType t)
        Transmute epos e t u -> genTransmute epos e t u

genExprLambda :: TypedVar -> (Expr, Monomorphic.Type) -> Gen Val
genExprLambda :: TypedVar -> (Expr, M.Type) -> Gen Val
genExprLambda p (b, bt) = do
    let fvXs = Set.toList (Set.delete p (freeVars b))
    bt' <- genRetType bt
    genLambda fvXs p (genTailExpr b, bt')

genConst :: Monomorphic.Const -> Gen Val
genConst :: M.Const -> Gen Val
genConst = \case
    Int n -> pure (VLocal (litI64 n))
    F64 x -> pure (VLocal (litF64 x))


@@ 429,10 434,9 @@ genDecisionTree' genExpr' genCondBr' genCases' tbody =
            join (foldrM genCase (genDT def selections') cs')

        genDT = \case
            Monomorphic.DLeaf l -> genDecisionLeaf l
            Monomorphic.DSwitch selector cs def ->
                genDecisionSwitchIx selector cs def
            Monomorphic.DSwitchStr selector cs def ->
            M.DLeaf l -> genDecisionLeaf l
            M.DSwitch selector cs def -> genDecisionSwitchIx selector cs def
            M.DSwitchStr selector cs def ->
                genDecisionSwitchStr selector cs def
    in genDT



@@ 470,7 474,7 @@ genCases tbody selections variantLs variantDts def = do
    commitToNewBlock (br nextL) nextL
    fmap VLocal (emitAnonReg (phi (v : vs)))

selAs :: Span -> [Monomorphic.Type] -> Operand -> Gen Operand
selAs :: Span -> [M.Type] -> Operand -> Gen Operand
selAs totVariants ts matchee = do
    tvariant <- fmap typeStruct (lift (genVariantType totVariants ts))
    let tgeneric = typeOf matchee


@@ 487,7 491,7 @@ selSub span' i matchee =
selDeref :: Operand -> Gen Operand
selDeref x = emitAnonReg (load x)

genCtion :: Monomorphic.Ction -> Gen Val
genCtion :: M.Ction -> Gen Val
genCtion (i, span', dataType, as) = do
    lookupEnum dataType & lift >>= \case
        Just 0 -> pure (VLocal litUnit)


@@ 525,6 529,66 @@ genDeref e = genExpr e >>= \case
    VVar x -> fmap VVar (selDeref x)
    VLocal x -> pure (VVar x)

genTransmute :: SrcPos -> Expr -> M.Type -> M.Type -> Gen Val
genTransmute pos e t u = do
    t' <- genType t
    u' <- genType u
    st <- lift (sizeof t')
    su <- lift (sizeof u')
    if st == su
        then genExpr e >>= transmute t' u'
        else throwError (TransmuteErr pos (t, st) (u, su))

-- | Assumes that the from-type and to-type are of the same size.
transmute :: Type -> Type -> Val -> Gen Val
transmute t u x = case (t, u) of
    (FunctionType _ _ _, _) -> transmuteIce
    (_, FunctionType _ _ _) -> transmuteIce
    (MetadataType, _) -> transmuteIce
    (_, MetadataType) -> transmuteIce
    (LabelType, _) -> transmuteIce
    (_, LabelType) -> transmuteIce
    (TokenType, _) -> transmuteIce
    (_, TokenType) -> transmuteIce
    (VoidType, _) -> transmuteIce
    (_, VoidType) -> transmuteIce

    (IntegerType _, IntegerType _) -> bitcast'
    (IntegerType _, PointerType _ _) ->
        getLocal x >>= \x' -> emitAnonReg (inttoptr x' u) <&> VLocal
    (IntegerType _, FloatingPointType _) -> bitcast'
    (IntegerType _, VectorType _ _) -> bitcast'

    (PointerType pt _, PointerType pu _)
        | pt == pu -> pure x
        | otherwise -> bitcast'
    (PointerType _ _, IntegerType _) ->
        getLocal x >>= \x' -> emitAnonReg (ptrtoint x' u) <&> VLocal
    (PointerType _ _, _) -> stackCast
    (_, PointerType _ _) -> stackCast

    (FloatingPointType _, FloatingPointType _) -> pure x
    (FloatingPointType _, IntegerType _) -> bitcast'
    (FloatingPointType _, VectorType _ _) -> bitcast'

    (VectorType _ vt, VectorType _ vu)
        | vt == vu -> pure x
        | otherwise -> bitcast'
    (VectorType _ _, IntegerType _) -> bitcast'
    (VectorType _ _, FloatingPointType _) -> bitcast'

    (StructureType _ _, _) -> stackCast
    (_, StructureType _ _) -> stackCast
    (ArrayType _ _, _) -> stackCast
    (_, ArrayType _ _) -> stackCast
    (NamedTypeReference _, _) -> stackCast
    (_, NamedTypeReference _) -> stackCast
  where
    transmuteIce = ice $ "transmute " ++ show t ++ " to " ++ show u
    bitcast' = getLocal x >>= \x' -> emitAnonReg (bitcast x' u) <&> VLocal
    stackCast = getVar x
        >>= \x' -> emitAnonReg (bitcast x' (LLType.ptr u)) <&> VVar

genStrEq :: Val -> Val -> Gen Val
genStrEq s1 s2 = do
    s1' <- getLocal s1

M src/Compile.hs => src/Compile.hs +9 -1
@@ 16,6 16,8 @@ import LLVM.Exception
import qualified LLVM.Relocation as Reloc
import qualified LLVM.CodeModel as CodeModel
import qualified LLVM.CodeGenOpt as CodeGenOpt
import LLVM.AST.DataLayout
import qualified LLVM.AST as LLAST
import Control.Monad
import Control.Monad.Catch
import System.FilePath


@@ 33,6 35,7 @@ import Misc
import Conf
import qualified Monomorphic
import Codegen
import Err


compile :: FilePath -> CompileConfig -> Monomorphic.Program -> IO ()


@@ 62,7 65,7 @@ handleProgram f file cfg pgm = withContext $ \ctx ->
        withMyTargetMachine optLvl $ \tm -> do
            layout <- getTargetMachineDataLayout tm
            verbose cfg ("   Generating LLVM")
            let amod = codegen layout file pgm
            amod <- codegen' layout file pgm
            flip
                    catch
                    (\case


@@ 83,6 86,11 @@ handleProgram f file cfg pgm = withContext $ \ctx ->
                            $ writeLLVMAssemblyToFile' ".dbg.opt.ll" mod
                        f cfg tm mod

codegen' :: DataLayout -> FilePath -> Monomorphic.Program -> IO LLAST.Module
codegen' dl f pgm = case codegen dl f pgm of
    Right m -> pure m
    Left e -> printGenErr e *> abort f

compileModule :: CompileConfig -> TargetMachine -> Module -> IO ()
compileModule cfg tm mod = do
    let exefile = cOutfile cfg

R src/TypeErr.hs => src/Err.hs +15 -27
@@ 1,6 1,6 @@
{-# LANGUAGE LambdaCase, FlexibleContexts, DataKinds #-}

module TypeErr (TypeErr(..), printErr) where
module Err (module Err, TypeErr(..), GenErr(..)) where

import Misc
import SrcPos


@@ 8,36 8,13 @@ import qualified Parsed
import Inferred
import Pretty
import Parse
import Gen


data TypeErr
    = MainNotDefined
    | InvalidUserTypeSig SrcPos Scheme Scheme
    | CtorArityMismatch SrcPos String Int Int
    | ConflictingPatVarDefs SrcPos String
    | UndefCtor SrcPos String
    | UndefVar SrcPos String
    | InfType SrcPos Type Type TVar Type
    | UnificationFailed SrcPos Type Type Type Type
    | ConflictingTypeDef SrcPos String
    | ConflictingCtorDef SrcPos String
    | RedundantCase SrcPos
    | InexhaustivePats SrcPos String
    | ExternNotMonomorphic (Parsed.Id 'Parsed.Small) TVar
    | FoundHole SrcPos
    | RecTypeDef String SrcPos
    | UndefType SrcPos String
    | UnboundTVar SrcPos
    | WrongMainType SrcPos Parsed.Scheme
    | RecursiveVarDef (WithPos String)
    | TypeInstArityMismatch SrcPos String Int Int
    | ConflictingVarDef SrcPos String
    deriving Show

type Message = String

printErr :: TypeErr -> IO ()
printErr = \case
printTypeErr :: TypeErr -> IO ()
printTypeErr = \case
    MainNotDefined -> putStrLn "Error: main not defined"
    InvalidUserTypeSig p s1 s2 ->
        posd p


@@ 106,6 83,17 @@ printErr = \case
    ConflictingVarDef p x ->
        posd p $ "Conflicting definitions for variable `" ++ x ++ "`."

printGenErr :: GenErr -> IO ()
printGenErr = \case
    TransmuteErr p (t, sizet) (u, sizeu) ->
        posd p
            $ "Cannot transmute between types of different sizes."
            ++ ("\nSource type: " ++ pretty t)
            ++ (" (" ++ show sizet ++ " bytes)")
            ++ ("\nTarget type: " ++ pretty u)
            ++ (" (" ++ show sizeu ++ " bytes)")


posd :: SrcPos -> Message -> IO ()
posd (pos@(SrcPos f lineN colN)) msg = do
    src <- readFile f

M src/Gen.hs => src/Gen.hs +22 -10
@@ 10,6 10,7 @@ module Gen where
import Control.Monad.Writer
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Except
import Control.Applicative
import qualified Codec.Binary.UTF8.String as UTF8.String
import Data.Map (Map)


@@ 45,6 46,9 @@ import Monomorphic (TypedVar(..), TPrim(..))
import SrcPos


data GenErr
    = TransmuteErr SrcPos (Monomorphic.Type, Word64) (Monomorphic.Type, Word64)

type Instr = InstructionMetadata -> Instruction

-- | An instruction that returns a value. The name refers to the fact that a


@@ 73,7 77,8 @@ data St = St
    , _srcPosToMetadata :: Map SrcPos (MDRef MDNode)
    }

type Gen' = StateT St (Reader Env)
type Gen'T m = StateT St (ReaderT Env m)
type Gen' = Gen'T (Except GenErr)

-- | The output of generating a function. Dependencies of stuff within the
--   function that must be generated at the top-level.


@@ 283,8 288,8 @@ compileUnitRef = MDRef compileUnitId
compileUnitId :: MetadataNodeID
compileUnitId = MetadataNodeID 0

runGen' :: Gen' a -> a
runGen' g = runReader (evalStateT g initSt) initEnv
runGen' :: Monad m => StateT St (ReaderT Env m) a -> m a
runGen' g = runReaderT (evalStateT g initSt) initEnv
  where
    initEnv = Env
        { _env = Map.empty


@@ 508,14 513,14 @@ builtins = Map.fromList
genRetType :: Monomorphic.Type -> Gen Type
genRetType = lift . genRetType'

genRetType' :: Monomorphic.Type -> Gen' Type
genRetType' :: Monad m => Monomorphic.Type -> Gen'T m Type
genRetType' = fmap (\t -> if t == typeUnit then LLType.void else t) . genType'

genType :: Monomorphic.Type -> Gen Type
genType = lift . genType'

-- | Convert to the LLVM representation of a type in an expression-context.
genType' :: Monomorphic.Type -> Gen' Type
genType' :: Monad m => Monomorphic.Type -> Gen'T m Type
genType' = \case
    Monomorphic.TPrim tc -> pure $ case tc of
        Monomorphic.TNat8 -> i8


@@ 559,7 564,8 @@ genCapturesType :: [Monomorphic.TypedVar] -> Gen Type
genCapturesType =
    fmap typeStruct . mapM (\(Monomorphic.TypedVar _ t) -> genType t)

genVariantType :: Monomorphic.Span -> [Monomorphic.Type] -> Gen' [Type]
genVariantType
    :: Monad m => Monomorphic.Span -> [Monomorphic.Type] -> Gen'T m [Type]
genVariantType totVariants =
    fmap (maybe id ((:) . IntegerType) (tagBitWidth totVariants))
        . mapM genType'


@@ 587,7 593,7 @@ tagBitWidth span'
--
--   See the [System V ABI docs](https://software.intel.com/sites/default/files/article/402129/mpx-linux64-abi.pdf)
--   for more info.
sizeof :: Type -> Gen' Word64
sizeof :: Monad m => Type -> Gen'T m Word64
sizeof = \case
    NamedTypeReference x -> sizeof =<< lookupDatatype x
    IntegerType bits -> pure (fromIntegral (toBytesCeil bits))


@@ 614,7 620,7 @@ sizeof = \case
        size <- sizeof u
        pure (accSize + padding + size)

alignmentof :: Type -> Gen' Word64
alignmentof :: Monad m => Type -> Gen'T m Word64
alignmentof = \case
    NamedTypeReference x -> alignmentof =<< lookupDatatype x
    StructureType _ [] -> pure 0


@@ 689,13 695,13 @@ newMetadataId = lift newMetadataId'
newMetadataId' :: Gen' MetadataNodeID
newMetadataId' = fmap MetadataNodeID (metadataCount <<+= 1)

lookupEnum :: Monomorphic.TConst -> Gen' (Maybe Word32)
lookupEnum :: Monad m => Monomorphic.TConst -> Gen'T m (Maybe Word32)
lookupEnum tc = view (enumTypes . to (tconstLookup tc))

tconstLookup :: Monomorphic.TConst -> Map Name a -> Maybe a
tconstLookup = Map.lookup . mkName . mangleTConst

lookupDatatype :: Name -> Gen' Type
lookupDatatype :: Monad m => Name -> Gen'T m Type
lookupDatatype x = view (enumTypes . to (Map.lookup x)) >>= \case
    Just 0 -> pure typeUnit
    Just w -> pure (IntegerType w)


@@ 744,6 750,12 @@ switch x def cs = Switch x def cs []
bitcast :: Operand -> Type -> FunInstr
bitcast x t = WithRetType (BitCast x t) t

inttoptr :: Operand -> Type -> FunInstr
inttoptr x t = WithRetType (IntToPtr x t) t

ptrtoint :: Operand -> Type -> FunInstr
ptrtoint x t = WithRetType (PtrToInt x t) t

trunc :: Operand -> Type -> FunInstr
trunc x t = WithRetType (Trunc x t) t


M src/Infer.hs => src/Infer.hs +3 -1
@@ 8,6 8,7 @@ import Control.Applicative hiding (Const(..))
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Functor
import Data.Bifunctor
import Data.Graph (SCC(..), stronglyConnComp)
import qualified Data.Map.Strict as Map


@@ 22,7 23,6 @@ import FreeVars
import Subst
import qualified Parsed
import Parsed (Id(..), IdCase(..), idstr, isFunLike)
import TypeErr
import Inferred hiding (Id)




@@ 234,6 234,8 @@ infer (WithPos pos e) = fmap (second (WithPos pos)) $ case e of
        (tx, x') <- infer x
        unify (Expected (TBox t)) (Found (getPos x) tx)
        pure (t, Deref x')
    Parsed.Transmute x ->
        fresh >>= \u -> infer x <&> \(t, x') -> (u, Transmute x' t u)

inferFunMatch :: [(Parsed.Pat, Parsed.Expr)] -> Infer (Type, Expr')
inferFunMatch cases = do

M src/Inferred.hs => src/Inferred.hs +27 -1
@@ 1,4 1,4 @@
{-# LANGUAGE LambdaCase, TemplateHaskell #-}
{-# LANGUAGE LambdaCase, TemplateHaskell, DataKinds #-}

-- | Type annotated AST as a result of typechecking
module Inferred


@@ 15,10 15,35 @@ import Data.Map.Strict (Map)
import Lens.Micro.Platform (makeLenses)

import Misc
import qualified Parsed
import Parsed (TVar(..), TPrim(..), Const(..), tUnit)
import SrcPos


data TypeErr
    = MainNotDefined
    | InvalidUserTypeSig SrcPos Scheme Scheme
    | CtorArityMismatch SrcPos String Int Int
    | ConflictingPatVarDefs SrcPos String
    | UndefCtor SrcPos String
    | UndefVar SrcPos String
    | InfType SrcPos Type Type TVar Type
    | UnificationFailed SrcPos Type Type Type Type
    | ConflictingTypeDef SrcPos String
    | ConflictingCtorDef SrcPos String
    | RedundantCase SrcPos
    | InexhaustivePats SrcPos String
    | ExternNotMonomorphic (Parsed.Id 'Parsed.Small) TVar
    | FoundHole SrcPos
    | RecTypeDef String SrcPos
    | UndefType SrcPos String
    | UnboundTVar SrcPos
    | WrongMainType SrcPos Parsed.Scheme
    | RecursiveVarDef (WithPos String)
    | TypeInstArityMismatch SrcPos String Int Int
    | ConflictingVarDef SrcPos String
    deriving Show

type TConst = (String, [Type])

data Type


@@ 74,6 99,7 @@ data Expr'
    | Ctor VariantIx Span TConst [Type]
    | Box Expr
    | Deref Expr
    | Transmute Expr Type Type
    deriving Show

type Expr = WithPos Expr'

M src/Match.hs => src/Match.hs +1 -1
@@ 23,7 23,7 @@ import Lens.Micro.Platform (makeLenses, view, to)
import Misc hiding (augment)
import Pretty
import SrcPos
import TypeErr
import Err
import qualified Inferred
import Inferred (Pat, Pat'(..), Variant(..))
import Checked

M src/Monomorphic.hs => src/Monomorphic.hs +2 -0
@@ 67,6 67,7 @@ data Expr'
    | Box Expr
    | Deref Expr
    | Absurd Type
    | Transmute SrcPos Expr Type Type
    deriving (Show)

data Expr = Expr (Maybe SrcPos) Expr'


@@ 98,6 99,7 @@ fvExpr (Expr _ ex) = case ex of
    Box e -> fvExpr e
    Deref e -> fvExpr e
    Absurd _ -> Set.empty
    Transmute _ x _ _ -> fvExpr x

fvDecisionTree :: DecisionTree -> Set TypedVar
fvDecisionTree = \case

M src/Monomorphize.hs => src/Monomorphize.hs +2 -0
@@ 78,6 78,8 @@ mono (Checked.Expr pos ex) = fmap (Expr pos) $ case ex of
    Checked.Box x -> fmap Box (mono x)
    Checked.Deref x -> fmap Deref (mono x)
    Checked.Absurd t -> fmap Absurd (monotype t)
    Checked.Transmute xpos x t u ->
        liftA3 (Transmute xpos) (mono x) (monotype t) (monotype u)

monoFun :: (String, Checked.Type) -> (Checked.Expr, Checked.Type) -> Mono Expr'
monoFun (p, tp) (b, bt) = do

M src/Parse.hs => src/Parse.hs +15 -2
@@ 193,8 193,19 @@ expr' = choice [estr, var, num, eConstructor, pexpr]
    eConstructor = fmap Ctor big'
    var = fmap Var small'
    pexpr =
        parens $ choice
            [funMatch, match, if', fun, let', typeAscr, box, deref, app]
        parens
            $ choice
                [ funMatch
                , match
                , if'
                , fun
                , let'
                , typeAscr
                , box
                , deref
                , transmute
                , app
                ]
    funMatch = reserved "fmatch" *> fmap FunMatch cases
    match = reserved "match" *> liftA2 Match expr cases
    cases = many (parens (reserved "case" *> (liftA2 (,) pat expr)))


@@ 221,6 232,7 @@ expr' = choice [estr, var, num, eConstructor, pexpr]
    typeAscr = reserved ":" *> liftA2 TypeAscr expr type_
    box = reserved "box" *> fmap Box expr
    deref = reserved "deref" *> fmap Deref expr
    transmute = reserved "transmute" *> fmap Transmute expr
    app = do
        rator <- expr
        rands <- some expr


@@ 380,6 392,7 @@ reserveds =
    , "data"
    , "box"
    , "deref"
    , "transmute"
    , "import"
    , "case"
    ]

M src/Parsed.hs => src/Parsed.hs +2 -0
@@ 75,6 75,7 @@ data Expr'
    | Ctor (Id 'Big)
    | Box Expr
    | Deref Expr
    | Transmute Expr
    deriving (Show, Eq)

type Expr = WithPos Expr'


@@ 131,6 132,7 @@ fvExpr = unpos >>> \case
    Ctor _ -> Set.empty
    Box e -> fvExpr e
    Deref e -> fvExpr e
    Transmute e -> fvExpr e

fvMatch :: Expr -> [(Pat, Expr)] -> Set (Id 'Small)
fvMatch e cs = Set.union (freeVars e) (fvCases cs)

M src/Pretty.hs => src/Pretty.hs +22 -0
@@ 12,6 12,7 @@ import Misc
import SrcPos
import qualified Parsed
import qualified Inferred
import qualified Monomorphic as M


-- Pretty print starting at some indentation depth


@@ 140,6 141,7 @@ prettyExpr' d = \case
    Parsed.Ctor c -> pretty c
    Parsed.Box e -> concat ["(box ", pretty' (d + 5) e, ")"]
    Parsed.Deref e -> concat ["(deref ", pretty' (d + 7) e, ")"]
    Parsed.Transmute e -> concat ["(transmute ", pretty' (d + 11) e, ")"]

prettyBracketPair :: (Pretty a, Pretty b) => Int -> (a, b) -> String
prettyBracketPair d (a, b) = concat


@@ 244,3 246,23 @@ prettyAnTFun a b =
            Inferred.TFun a' b' -> first (a' :) (f b')
            t -> ([], t)
    in concat ["(Fun ", pretty a, " ", spcPretty (bParams ++ [bBody]), ")"]


instance Pretty M.Type where
    pretty' _ = prettyMonoType

prettyMonoType :: M.Type -> String
prettyMonoType = \case
    M.TPrim c -> pretty c
    M.TFun a b -> prettyMonoTFun a b
    M.TBox t -> prettyTBox t
    M.TConst tc -> prettyTConst tc

prettyMonoTFun :: M.Type -> M.Type -> String
prettyMonoTFun a b =
    let
        (bParams, bBody) = f b
        f = \case
            M.TFun a' b' -> first (a' :) (f b')
            t -> ([], t)
    in concat ["(Fun ", pretty a, " ", spcPretty (bParams ++ [bBody]), ")"]

M src/Subst.hs => src/Subst.hs +1 -0
@@ 34,6 34,7 @@ substExpr s (WithPos pos expr) = WithPos pos $ case expr of
        Ctor i span' (tx, map (subst s) tts) (map (subst s) ps)
    Box e -> Box (substExpr s e)
    Deref e -> Deref (substExpr s e)
    Transmute e t u -> Transmute (substExpr s e) (subst s t) (subst s u)

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