~jojo/Carth

02f5fba32a36d41af010a4b7f1bec8d0f691e308 — JoJo 1 year, 7 months ago 4ada578
Improve module names. Ast -> Parsed, AnnotAst -> Inferred, and more
20 files changed, 337 insertions(+), 318 deletions(-)

M app/Main.hs
M package.yaml
M src/Abi.hs
M src/Check.hs
R src/{DesugaredAst.hs => Checked.hs}
M src/Codegen.hs
M src/Compile.hs
M src/Gen.hs
M src/Infer.hs
R src/{AnnotAst.hs => Inferred.hs}
M src/Match.hs
R src/{MonoAst.hs => Monomorphic.hs}
R src/{Mono.hs => Monomorphize.hs}
M src/Parse.hs
R src/{Ast.hs => Parsed.hs}
M src/Pretty.hs
M src/Selections.hs
M src/Subst.hs
M src/TypeErr.hs
M test/CheckSpec.hs
M app/Main.hs => app/Main.hs +5 -5
@@ 8,12 8,12 @@ import Control.Monad
import Misc
import Pretty
import qualified TypeErr
import qualified Ast
import qualified DesugaredAst
import qualified Parsed
import qualified Checked
import Check
import GetConfig
import Compile
import Mono
import Monomorphize
import qualified Parse
import EnvVars



@@ 41,7 41,7 @@ compileFile cfg = do
    compile f cfg mon
    putStrLn ""

parse :: FilePath -> IO Ast.Program
parse :: FilePath -> IO Parsed.Program
parse f = Parse.parse f >>= \case
    Left e -> putStrLn (formatParseErr e) >> abort f
    Right p -> pure p


@@ 49,7 49,7 @@ parse f = Parse.parse f >>= \case
    formatParseErr e =
        let ss = lines e in (unlines ((head ss ++ " Error:") : tail ss))

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

M package.yaml => package.yaml +2 -0
@@ 91,7 91,9 @@ tests:
    - -Wno-unsafe
    - -Wno-missing-import-lists
    - -Wno-missing-exported-signatures
    - -Wno-missing-export-lists
    - -Wno-missing-local-signatures
    - -Wno-missing-signatures
    - -Wno-monomorphism-restriction
    - -Wno-implicit-prelude
    - -Wno-name-shadowing

M src/Abi.hs => src/Abi.hs +1 -1
@@ 42,7 42,7 @@ import Data.Foldable
import Lens.Micro.Platform (view, to)

import Misc
import MonoAst (Span)
import Monomorphic (Span)
import Gen



M src/Check.hs => src/Check.hs +83 -69
@@ 18,26 18,26 @@ import Data.Set (Set)
import Misc
import SrcPos
import Subst
import qualified Ast
import Ast (Id(..), TVar(..), TPrim(..), idstr)
import qualified Parsed
import Parsed (Id(..), TVar(..), TPrim(..), idstr)
import TypeErr
import qualified AnnotAst as An
import qualified Inferred
import Match
import Infer
import qualified DesugaredAst as Des
import qualified Checked


typecheck :: Ast.Program -> Either TypeErr Des.Program
typecheck (Ast.Program defs tdefs externs) = runExcept $ do
typecheck :: Parsed.Program -> Either TypeErr Checked.Program
typecheck (Parsed.Program defs tdefs externs) = runExcept $ do
    (tdefs', ctors) <- checkTypeDefs tdefs
    (externs', inferred, substs) <- inferTopDefs tdefs' ctors externs defs
    let substd = substTopDefs substs inferred
    checkTypeVarsBound substd
    let mTypeDefs = fmap (map (unpos . fst) . snd) tdefs'
    desugared <- compileDecisionTreesAndDesugar mTypeDefs substd
    desugared <- compileDecisionTrees mTypeDefs substd
    checkStartDefined desugared
    let tdefs'' = fmap (second (map snd)) tdefs'
    pure (Des.Program desugared tdefs'' externs')
    pure (Checked.Program desugared tdefs'' externs')
  where
    checkStartDefined ds =
        when (not (Map.member "start" ds)) (throwError StartNotDefined)


@@ 45,22 45,27 @@ typecheck (Ast.Program defs tdefs externs) = runExcept $ do
type CheckTypeDefs a
    = ReaderT
          (Map String Int)
          (StateT (An.TypeDefs, An.Ctors) (Except TypeErr))
          (StateT (Inferred.TypeDefs, Inferred.Ctors) (Except TypeErr))
          a

checkTypeDefs :: [Ast.TypeDef] -> Except TypeErr (An.TypeDefs, An.Ctors)
checkTypeDefs
    :: [Parsed.TypeDef] -> Except TypeErr (Inferred.TypeDefs, Inferred.Ctors)
checkTypeDefs tdefs = do
    let tdefsParams =
            Map.union (fmap (length . fst) builtinDataTypes) $ Map.fromList
                (map (\(Ast.TypeDef x ps _) -> (idstr x, length ps)) tdefs)
            Map.union (fmap (length . fst) builtinDataTypes)
                $ Map.fromList
                    (map
                        (\(Parsed.TypeDef x ps _) -> (idstr x, length ps))
                        tdefs
                    )
    (tdefs', ctors) <- execStateT
        (runReaderT (forM_ tdefs checkTypeDef) tdefsParams)
        (builtinDataTypes, builtinConstructors)
    forM_ (Map.toList tdefs') (assertNoRec tdefs')
    pure (tdefs', ctors)

checkTypeDef :: Ast.TypeDef -> CheckTypeDefs ()
checkTypeDef (Ast.TypeDef (Ast.Id (WithPos xpos x)) ps cs) = do
checkTypeDef :: Parsed.TypeDef -> CheckTypeDefs ()
checkTypeDef (Parsed.TypeDef (Parsed.Id (WithPos xpos x)) ps cs) = do
    tAlreadyDefined <- gets (Map.member x . fst)
    when tAlreadyDefined (throwError (ConflictingTypeDef xpos x))
    let ps' = map TVExplicit ps


@@ 69,9 74,9 @@ checkTypeDef (Ast.TypeDef (Ast.Id (WithPos xpos x)) ps cs) = do

checkCtors
    :: (String, [TVar])
    -> Ast.ConstructorDefs
    -> CheckTypeDefs [(An.Id, [An.Type])]
checkCtors parent (Ast.ConstructorDefs cs) =
    -> Parsed.ConstructorDefs
    -> CheckTypeDefs [(Inferred.Id, [Inferred.Type])]
checkCtors parent (Parsed.ConstructorDefs cs) =
    let cspan = fromIntegral (length cs)
    in mapM (checkCtor cspan) (zip [0 ..] cs)
  where


@@ 84,12 89,12 @@ checkCtors parent (Ast.ConstructorDefs cs) =
    checkType pos t =
        ask >>= \tdefs -> checkType' (\x -> Map.lookup x tdefs) pos t

builtinDataTypes :: An.TypeDefs
builtinDataTypes :: Inferred.TypeDefs
builtinDataTypes = Map.fromList $ map
    (\(x, ps, cs) -> (x, (ps, map (first (WithPos dummyPos)) cs)))
    builtinDataTypes'

builtinConstructors :: An.Ctors
builtinConstructors :: Inferred.Ctors
builtinConstructors = Map.unions (map builtinConstructors' builtinDataTypes')
  where
    builtinConstructors' (x, ps, cs) =


@@ 102,22 107,28 @@ builtinConstructors = Map.unions (map builtinConstructors' builtinDataTypes')
                Map.empty
                (zip [0 ..] cs)

builtinDataTypes' :: [(String, [TVar], [(String, [An.Type])])]
builtinDataTypes' :: [(String, [TVar], [(String, [Inferred.Type])])]
builtinDataTypes' =
    [ ( "Array"
      , [TVImplicit 0]
      , [("Array", [An.TBox (An.TVar (TVImplicit 0)), An.TPrim TNat])]
      , [ ( "Array"
          , [Inferred.TBox (Inferred.TVar (TVImplicit 0)), Inferred.TPrim TNat]
          )
        ]
      )
    , ( "Str"
      , []
      , [("Str", [Inferred.TConst ("Array", [Inferred.TPrim TNat8])])]
      )
    , ("Str", [], [("Str", [An.TConst ("Array", [An.TPrim TNat8])])])
    , ( "Pair"
      , [TVImplicit 0, TVImplicit 1]
      , [("Pair", [An.TVar (TVImplicit 0), An.TVar (TVImplicit 1)])]
      , [("Pair", [Inferred.TVar (TVImplicit 0), Inferred.TVar (TVImplicit 1)])]
      )
    ]

assertNoRec
    :: An.TypeDefs
    -> (String, ([TVar], [(An.Id, [An.Type])]))
    :: Inferred.TypeDefs
    -> (String, ([TVar], [(Inferred.Id, [Inferred.Type])]))
    -> Except TypeErr ()
assertNoRec tdefs' (x, (_, ctors)) = assertNoRec' ctors Map.empty
  where


@@ 125,7 136,7 @@ assertNoRec tdefs' (x, (_, ctors)) = assertNoRec' ctors Map.empty
        forM_ cs $ \(WithPos cpos _, cts) ->
            forM_ cts (assertNoRecType cpos . subst s)
    assertNoRecType cpos = \case
        An.TConst (y, ts) -> do
        Inferred.TConst (y, ts) -> do
            when (x == y) $ throwError (RecTypeDef x cpos)
            let (tvs, cs) = tdefs' Map.! y
            let substs = Map.fromList (zip tvs ts)


@@ 136,89 147,92 @@ 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 -> Except TypeErr ()
checkTypeVarsBound :: Inferred.Defs -> Except TypeErr ()
checkTypeVarsBound ds = runReaderT (boundInDefs ds) Set.empty
  where
    boundInDefs :: An.Defs -> Bound
    boundInDefs :: Inferred.Defs -> Bound
    boundInDefs = mapM_ boundInDef
    boundInDef ((An.Forall tvs _), e) =
    boundInDef ((Inferred.Forall tvs _), e) =
        local (Set.union tvs) (boundInExpr e)
    boundInExpr (WithPos pos e) = case e of
        An.Lit _ -> pure ()
        An.Var (An.TypedVar _ t) -> boundInType pos t
        An.App f a rt -> do
        Inferred.Lit _ -> pure ()
        Inferred.Var (Inferred.TypedVar _ t) -> boundInType pos t
        Inferred.App f a rt -> do
            boundInExpr f
            boundInExpr a
            boundInType pos rt
        An.If p c a -> do
        Inferred.If p c a -> do
            boundInExpr p
            boundInExpr c
            boundInExpr a
        An.Let lds b -> do
        Inferred.Let lds b -> do
            boundInDefs lds
            boundInExpr b
        An.FunMatch cs pt bt -> do
        Inferred.FunMatch cs pt bt -> do
            boundInCases cs
            boundInType pos pt
            boundInType pos bt
        An.Ctor _ _ (_, instTs) ts -> do
        Inferred.Ctor _ _ (_, instTs) ts -> do
            forM_ instTs (boundInType pos)
            forM_ ts (boundInType pos)
        An.Box x -> boundInExpr x
        An.Deref x -> boundInExpr x
    boundInType :: SrcPos -> An.Type -> Bound
        Inferred.Box x -> boundInExpr x
        Inferred.Deref x -> boundInExpr x
    boundInType :: SrcPos -> Inferred.Type -> Bound
    boundInType pos = \case
        An.TVar tv -> do
        Inferred.TVar tv -> do
            bound <- ask
            when (not (Set.member tv bound)) (throwError (UnboundTVar pos))
        An.TPrim _ -> pure ()
        An.TConst (_, ts) -> forM_ ts (boundInType pos)
        An.TFun ft at -> forM_ [ft, at] (boundInType pos)
        An.TBox t -> boundInType pos t
        Inferred.TPrim _ -> pure ()
        Inferred.TConst (_, ts) -> forM_ ts (boundInType pos)
        Inferred.TFun ft at -> forM_ [ft, at] (boundInType pos)
        Inferred.TBox t -> boundInType pos t
    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 ()
        An.PCon con ps -> boundInCon pos con *> forM_ ps boundInPat
        An.PBox p -> boundInPat p
        Inferred.PVar (Inferred.TypedVar _ t) -> boundInType pos t
        Inferred.PWild -> pure ()
        Inferred.PCon con ps -> boundInCon pos con *> forM_ ps boundInPat
        Inferred.PBox p -> boundInPat p
    boundInCon pos (Con _ _ ts) = forM_ ts (boundInType pos)

compileDecisionTreesAndDesugar
    :: MTypeDefs -> An.Defs -> Except TypeErr Des.Defs
compileDecisionTreesAndDesugar tdefs = compDefs
compileDecisionTrees
    :: MTypeDefs -> Inferred.Defs -> Except TypeErr Checked.Defs
compileDecisionTrees tdefs = compDefs
  where
    compDefs = mapM compDef
    compDef = bimapM pure compExpr
    compExpr :: An.Expr -> Except TypeErr Des.Expr
    compExpr :: Inferred.Expr -> Except TypeErr Checked.Expr
    compExpr (WithPos pos expr) = case expr 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
        Inferred.Lit c -> pure (Checked.Lit c)
        Inferred.Var (Inferred.TypedVar (WithPos _ x) t) ->
            pure (Checked.Var (Checked.TypedVar x t))
        Inferred.App f a tr ->
            liftA3 Checked.App (compExpr f) (compExpr a) (pure tr)
        Inferred.If p c a ->
            liftA3 Checked.If (compExpr p) (compExpr c) (compExpr a)
        Inferred.Let lds b ->
            liftA2 Checked.Let (compDefs lds) (compExpr b)
        Inferred.FunMatch cs tp tb -> do
            cs' <- mapM (secondM compExpr) cs
            case runExceptT (toDecisionTree tdefs pos tp cs') of
                Nothing -> pure (Des.Absurd tb)
                Nothing -> pure (Checked.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 ->
                        v = Checked.Var (Checked.TypedVar p tp)
                        b = Checked.Match v dt tb
                    pure (Checked.Fun (p, tp) (b, tb))
        Inferred.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
                args = map (Checked.Var . uncurry Checked.TypedVar) params
            in pure $ snd $ foldr
                (\(p, pt) (bt, b) ->
                    (An.TFun pt bt, Des.Fun (p, pt) (b, bt))
                    (Inferred.TFun pt bt, Checked.Fun (p, pt) (b, bt))
                )
                (An.TConst inst, Des.Ction v span' inst args)
                (Inferred.TConst inst, Checked.Ction v span' inst args)
                params
        An.Box x -> fmap Des.Box (compExpr x)
        An.Deref x -> fmap Des.Deref (compExpr x)
        Inferred.Box x -> fmap Checked.Box (compExpr x)
        Inferred.Deref x -> fmap Checked.Deref (compExpr x)

R src/DesugaredAst.hs => src/Checked.hs +2 -2
@@ 1,4 1,4 @@
module DesugaredAst
module Checked
    ( TVar(..)
    , TPrim(..)
    , TConst


@@ 24,7 24,7 @@ where
import Data.Map.Strict (Map)
import Data.Word

import AnnotAst
import Inferred
    ( TVar(..)
    , TPrim(..)
    , TConst

M src/Codegen.hs => src/Codegen.hs +27 -26
@@ 31,8 31,8 @@ import Lens.Micro.Platform (modifying, use, assign, to, view)
import Misc
import Pretty
import FreeVars
import qualified MonoAst
import MonoAst hiding (Type, Const)
import qualified Monomorphic
import Monomorphic hiding (Type, Const)
import Selections
import Gen
import Abi


@@ 148,10 148,10 @@ builtins = Map.fromList
      )
    ]

genExterns :: [(String, MonoAst.Type)] -> Gen' [Definition]
genExterns :: [(String, Monomorphic.Type)] -> Gen' [Definition]
genExterns = mapM (uncurry genExtern)

genExtern :: String -> MonoAst.Type -> Gen' Definition
genExtern :: String -> Monomorphic.Type -> Gen' Definition
genExtern name t = genType' t
    <&> \t' -> GlobalDefinition $ simpleGlobVar' (mkName name) t' Nothing



@@ 171,14 171,14 @@ genMain = do
--       start, or an interpretation step is added between monomorphization and
--       codegen that evaluates all expressions in relevant contexts, like
--       constexprs.
genGlobDef :: (TypedVar, ([MonoAst.Type], Expr)) -> Gen' [Definition]
genGlobDef :: (TypedVar, ([Monomorphic.Type], Expr)) -> Gen' [Definition]
genGlobDef (TypedVar v _, (ts, e)) = case e of
    Fun p (body, _) ->
        fmap (map GlobalDefinition) (genClosureWrappedFunDef (v, ts) p body)
    _ -> nyi $ "Global non-function defs: " ++ show e

genClosureWrappedFunDef
    :: (String, [MonoAst.Type]) -> TypedVar -> Expr -> Gen' [Global]
    :: (String, [Monomorphic.Type]) -> TypedVar -> Expr -> Gen' [Global]
genClosureWrappedFunDef var p body = do
    let name = mangleName var
    assign lambdaParentFunc (Just name)


@@ 284,7 284,7 @@ genExpr expr = do
        Deref e -> genDeref e
        Absurd t -> fmap (VLocal . undef) (genType t)

genConst :: MonoAst.Const -> Gen Val
genConst :: Monomorphic.Const -> Gen Val
genConst = \case
    Unit -> pure (VLocal litUnit)
    Int n -> pure (VLocal (litI64 n))


@@ 300,7 300,7 @@ genStrLit s = do
        (LLConst.GlobalReference (LLType.ptr typeStr) var)

-- | Beta-reduction and closure application
genApp :: Expr -> Expr -> MonoAst.Type -> Gen Val
genApp :: Expr -> Expr -> Monomorphic.Type -> Gen Val
genApp fe' ae' rt' = genApp' (fe', [(ae', rt')])
  where
    -- TODO: Could/should the beta-reduction maybe happen in an earlier stage,


@@ 393,14 393,14 @@ genMatch m dt tbody = do

genDecisionTree :: Type -> DecisionTree -> Selections Operand -> Gen Val
genDecisionTree tbody = \case
    MonoAst.DLeaf l -> genDecisionLeaf l
    MonoAst.DSwitch selector cs def ->
    Monomorphic.DLeaf l -> genDecisionLeaf l
    Monomorphic.DSwitch selector cs def ->
        genDecisionSwitchIx selector cs def tbody
    MonoAst.DSwitchStr selector cs def ->
    Monomorphic.DSwitchStr selector cs def ->
        genDecisionSwitchStr selector cs def tbody

genDecisionSwitchIx
    :: MonoAst.Access
    :: Monomorphic.Access
    -> Map VariantIx DecisionTree
    -> DecisionTree
    -> Type


@@ 431,7 431,7 @@ genDecisionSwitchIx selector cs def tbody selections = do
    fmap VLocal (emitAnonReg (phi (v : vs)))

genDecisionSwitchStr
    :: MonoAst.Access
    :: Monomorphic.Access
    -> Map String DecisionTree
    -> DecisionTree
    -> Type


@@ 450,12 450,13 @@ genDecisionSwitchStr selector cs def tbody selections = do
    f <- foldrM genCase (genDT def) cs'
    f

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

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


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

genCtion :: MonoAst.Ction -> Gen Val
genCtion :: Monomorphic.Ction -> Gen Val
genCtion (i, span', dataType, as) = do
    as' <- mapM genExpr as
    let tag = maybe


@@ 498,7 499,7 @@ genCtion (i, span', dataType, as) = do
--
--   Inside of the function, first all the captured variables are extracted from
--   the environment, then the body of the function is run.
genLambda :: TypedVar -> (Expr, MonoAst.Type) -> Gen Val
genLambda :: TypedVar -> (Expr, Monomorphic.Type) -> Gen Val
genLambda p@(TypedVar px pt) (b, bt) = do
    let fvXs = Set.toList (Set.delete (TypedVar px pt) (freeVars b))
    captures <- if null fvXs


@@ 596,11 597,11 @@ genStackAllocated v = do
    emitDo (store v ptr)
    pure ptr

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

-- | Convert to the LLVM representation of a type in an expression-context.
genType' :: MonoAst.Type -> Gen' Type
genType' :: Monomorphic.Type -> Gen' Type
genType' = \case
    TPrim tc -> pure $ case tc of
        TUnit -> typeUnit


@@ 627,12 628,12 @@ genType' = \case
--
--   An argument of a structure-type is passed by reference, to be compatible
--   with the C calling convention.
genClosureType :: MonoAst.Type -> MonoAst.Type -> Gen' Type
genClosureType :: Monomorphic.Type -> Monomorphic.Type -> Gen' Type
genClosureType a r = genClosureFunType a r
    <&> \c -> typeStruct [LLType.ptr typeUnit, LLType.ptr c]

-- The type of the function itself within the closure
genClosureFunType :: MonoAst.Type -> MonoAst.Type -> Gen' Type
genClosureFunType :: Monomorphic.Type -> Monomorphic.Type -> Gen' Type
genClosureFunType a r = do
    a' <- genType' a
    r' <- genType' r


@@ 654,10 655,10 @@ genClosureFunType a r = do
genCapturesType :: [TypedVar] -> Gen Type
genCapturesType = fmap typeStruct . mapM (\(TypedVar _ t) -> genType t)

genDatatypeRef :: MonoAst.TConst -> Type
genDatatypeRef :: Monomorphic.TConst -> Type
genDatatypeRef = NamedTypeReference . mkName . mangleTConst

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


@@ 863,15 864,15 @@ getIntBitWidth = \case
    LLType.IntegerType w -> w
    t -> ice $ "Tried to get bit width of non-integer type " ++ show t

mangleName :: (String, [MonoAst.Type]) -> String
mangleName :: (String, [Monomorphic.Type]) -> String
mangleName (x, us) = x ++ mangleInst us

mangleInst :: [MonoAst.Type] -> String
mangleInst :: [Monomorphic.Type] -> String
mangleInst ts = if not (null ts)
    then "<" ++ intercalate ", " (map mangleType ts) ++ ">"
    else ""

mangleType :: MonoAst.Type -> String
mangleType :: Monomorphic.Type -> String
mangleType = \case
    TPrim c -> pretty c
    TFun p r -> mangleTConst ("Fun", [p, r])

M src/Compile.hs => src/Compile.hs +2 -2
@@ 12,12 12,12 @@ import qualified LLVM.CodeModel as CodeModel
import qualified LLVM.CodeGenOpt as CodeGenOpt

import Config
import qualified MonoAst
import qualified Monomorphic
import Codegen


-- TODO: CodeGenOpt level
compile :: FilePath -> Config -> MonoAst.Program -> IO ()
compile :: FilePath -> Config -> Monomorphic.Program -> IO ()
compile f cfg pgm = withContext $ \c -> withHostTargetMachinePIC $ \t -> do
    layout <- getTargetMachineDataLayout t
    putStrLn ("   Generating LLVM")

M src/Gen.hs => src/Gen.hs +1 -1
@@ 31,7 31,7 @@ import Lens.Micro.Platform (makeLenses, view, to)

import Misc
import SrcPos
import MonoAst hiding (Type, Const)
import Monomorphic hiding (Type, Const)


data Env = Env

M src/Infer.hs => src/Infer.hs +49 -48
@@ 20,10 20,10 @@ import Misc
import SrcPos
import FreeVars
import Subst
import qualified Ast
import Ast (Id(..), IdCase(..), idstr, isFunLike)
import qualified Parsed
import Parsed (Id(..), IdCase(..), idstr, isFunLike)
import TypeErr
import AnnotAst hiding (Id)
import Inferred hiding (Id)


newtype ExpectedType = Expected Type


@@ 53,8 53,8 @@ type Infer a = ReaderT Env (StateT St (Except TypeErr)) a
inferTopDefs
    :: TypeDefs
    -> Ctors
    -> [Ast.Extern]
    -> [Ast.Def]
    -> [Parsed.Extern]
    -> [Parsed.Def]
    -> Except TypeErr (Externs, Defs, Subst)
inferTopDefs tdefs ctors externs defs =
    let


@@ 75,16 75,16 @@ inferTopDefs tdefs ctors externs defs =

-- TODO: Check that the types of the externs are valid more than just not
--       containing type vars. E.g., they may not refer to undefined types, duh.
checkExterns :: [Ast.Extern] -> Infer Externs
checkExterns :: [Parsed.Extern] -> Infer Externs
checkExterns = fmap Map.fromList . mapM checkExtern
  where
    checkExtern (Ast.Extern name t) = do
    checkExtern (Parsed.Extern name t) = do
        t' <- checkType (getPos name) t
        case Set.lookupMin (ftv t') of
            Just tv -> throwError (ExternNotMonomorphic name tv)
            Nothing -> pure (idstr name, t')

checkType :: SrcPos -> Ast.Type -> Infer Type
checkType :: SrcPos -> Parsed.Type -> Infer Type
checkType pos t = do
    tds <- view envTypeDefs
    checkType' (\x -> fmap (length . fst) (Map.lookup x tds)) pos t


@@ 93,16 93,16 @@ checkType'
    :: MonadError TypeErr m
    => (String -> Maybe Int)
    -> SrcPos
    -> Ast.Type
    -> Parsed.Type
    -> m Type
checkType' tdefsParams pos = checkType''
  where
    checkType'' = \case
        Ast.TVar v -> pure (TVar v)
        Ast.TPrim p -> pure (TPrim p)
        Ast.TConst tc -> fmap TConst (checkTConst tc)
        Ast.TFun f a -> liftA2 TFun (checkType'' f) (checkType'' a)
        Ast.TBox t -> fmap TBox (checkType'' t)
        Parsed.TVar v -> pure (TVar v)
        Parsed.TPrim p -> pure (TPrim p)
        Parsed.TConst tc -> fmap TConst (checkTConst tc)
        Parsed.TFun f a -> liftA2 TFun (checkType'' f) (checkType'' a)
        Parsed.TBox t -> fmap TBox (checkType'' t)
    checkTConst (x, inst) = case tdefsParams x of
        Just expectedN -> do
            let foundN = length inst


@@ 114,7 114,7 @@ checkType' tdefsParams pos = checkType''
                    (TypeInstArityMismatch pos x expectedN foundN)
        Nothing -> throwError (UndefType pos x)

inferDefs :: [Ast.Def] -> Infer Defs
inferDefs :: [Parsed.Def] -> Infer Defs
inferDefs defs = do
    checkNoDuplicateDefs defs
    let ordered = orderDefs defs


@@ 135,11 135,11 @@ inferDefs defs = do
-- edge is a reference to another definition. For each SCC, we infer
-- types for all the definitions / the single definition before
-- generalizing.
orderDefs :: [Ast.Def] -> [SCC Ast.Def]
orderDefs :: [Parsed.Def] -> [SCC Parsed.Def]
orderDefs = stronglyConnComp . graph
    where graph = map (\d@(n, _) -> (d, n, Set.toList (freeVars d)))

inferDefsComponents :: [SCC Ast.Def] -> Infer Defs
inferDefsComponents :: [SCC Parsed.Def] -> Infer Defs
inferDefsComponents = \case
    [] -> pure Map.empty
    (scc : sccs) -> do


@@ 171,14 171,14 @@ inferDefsComponents = \case
        pure (Map.union annotRest annotDefs)

-- | Verify that user-provided type signature schemes are valid
checkScheme :: (String, Maybe Ast.Scheme) -> Infer (Maybe Scheme)
checkScheme :: (String, Maybe Parsed.Scheme) -> Infer (Maybe Scheme)
checkScheme = \case
    ("start", Nothing) -> pure (Just (Forall Set.empty startType))
    ("start", Just s@(Ast.Forall pos vs t))
        | Set.size vs /= 0 || t /= Ast.startType -> throwError
    ("start", Just s@(Parsed.Forall pos vs t))
        | Set.size vs /= 0 || t /= Parsed.startType -> throwError
            (WrongStartType pos s)
    (_, Nothing) -> pure Nothing
    (_, Just (Ast.Forall pos vs t)) -> do
    (_, Just (Parsed.Forall pos vs t)) -> do
        t' <- checkType pos t
        let s1 = Forall vs t'
        s2 <- generalize t'


@@ 186,12 186,12 @@ checkScheme = \case
            then pure (Just s1)
            else throwError (InvalidUserTypeSig pos s1 s2)

infer :: Ast.Expr -> Infer (Type, Expr)
infer :: Parsed.Expr -> Infer (Type, Expr)
infer (WithPos pos e) = fmap (second (WithPos pos)) $ case e of
    Ast.Lit l -> pure (litType l, Lit l)
    Ast.Var (Id (WithPos p "_")) -> throwError (FoundHole p)
    Ast.Var x@(Id x') -> fmap (\t -> (t, Var (TypedVar x' t))) (lookupEnv x)
    Ast.App f a -> do
    Parsed.Lit l -> pure (litType l, Lit l)
    Parsed.Var (Id (WithPos p "_")) -> throwError (FoundHole p)
    Parsed.Var x@(Id x') -> fmap (\t -> (t, Var (TypedVar x' t))) (lookupEnv x)
    Parsed.App f a -> do
        ta <- fresh
        tr <- fresh
        (tf', f') <- infer f


@@ 199,39 199,39 @@ infer (WithPos pos e) = fmap (second (WithPos pos)) $ case e of
        (ta', a') <- infer a
        unify (Expected ta) (Found (getPos a) ta')
        pure (tr, App f' a' tr)
    Ast.If p c a -> do
    Parsed.If p c a -> do
        (tp, p') <- infer p
        (tc, c') <- infer c
        (ta, a') <- infer a
        unify (Expected (TPrim TBool)) (Found (getPos p) tp)
        unify (Expected tc) (Found (getPos a) ta)
        pure (tc, If p' c' a')
    Ast.Fun p b -> inferFunMatch (pure (p, b))
    Ast.Let defs b -> do
    Parsed.Fun p b -> inferFunMatch (pure (p, b))
    Parsed.Let defs b -> do
        annotDefs <- inferDefs defs
        let defsScms = fmap (\(scm, _) -> scm) annotDefs
        (bt, b') <- withLocals' defsScms (infer b)
        pure (bt, Let annotDefs b')
    Ast.TypeAscr x t -> do
    Parsed.TypeAscr x t -> do
        (tx, WithPos _ x') <- infer x
        t' <- checkType pos t
        unify (Expected t') (Found (getPos x) tx)
        pure (t', x')
    Ast.Match matchee cases -> do
    Parsed.Match matchee cases -> do
        (tmatchee, matchee') <- infer matchee
        (tbody, cases') <- inferCases (Expected tmatchee) cases
        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)
    Ast.Deref x -> do
    Parsed.FunMatch cases -> inferFunMatch cases
    Parsed.Ctor c -> inferExprConstructor c
    Parsed.Box x -> fmap (\(tx, x') -> (TBox tx, Box x')) (infer x)
    Parsed.Deref x -> do
        t <- fresh
        (tx, x') <- infer x
        unify (Expected (TBox t)) (Found (getPos x) tx)
        pure (t, Deref x')

inferFunMatch :: [(Ast.Pat, Ast.Expr)] -> Infer (Type, Expr')
inferFunMatch :: [(Parsed.Pat, Parsed.Expr)] -> Infer (Type, Expr')
inferFunMatch cases = do
    tpat <- fresh
    (tbody, cases') <- inferCases (Expected tpat) cases


@@ 241,7 241,7 @@ inferFunMatch cases = do
--   the same type.
inferCases
    :: ExpectedType -- Type of matchee. Expected type of pattern.
    -> [(Ast.Pat, Ast.Expr)]
    -> [(Parsed.Pat, Parsed.Expr)]
    -> Infer (Type, Cases)
inferCases tmatchee cases = do
    (tpats, tbodies, cases') <- fmap unzip3 (mapM inferCase cases)


@@ 250,39 250,40 @@ inferCases tmatchee cases = do
    forM_ tbodies (unify (Expected tbody))
    pure (tbody, cases')

inferCase :: (Ast.Pat, Ast.Expr) -> Infer (FoundType, FoundType, (Pat, Expr))
inferCase
    :: (Parsed.Pat, Parsed.Expr) -> Infer (FoundType, FoundType, (Pat, Expr))
inferCase (p, b) = do
    (tp, p', pvs) <- inferPat p
    let pvs' = Map.mapKeys Ast.idstr pvs
    let pvs' = Map.mapKeys Parsed.idstr pvs
    (tb, b') <- withLocals' pvs' (infer b)
    pure (Found (getPos p) tp, Found (getPos b) tb, (p', b'))

inferPat :: Ast.Pat -> Infer (Type, Pat, Map (Id 'Small) Scheme)
inferPat :: Parsed.Pat -> Infer (Type, Pat, Map (Id 'Small) Scheme)
inferPat pat = fmap
    (\(t, p, ss) -> (t, WithPos (getPos pat) p, ss))
    (inferPat' pat)
  where
    inferPat' = \case
        Ast.PConstruction pos c ps -> inferPatConstruction pos c ps
        Ast.PInt _ n -> pure (TPrim TInt, intToPCon n 64, Map.empty)
        Ast.PBool _ b ->
        Parsed.PConstruction pos c ps -> inferPatConstruction pos c ps
        Parsed.PInt _ n -> pure (TPrim TInt, intToPCon n 64, Map.empty)
        Parsed.PBool _ b ->
            pure (TPrim TBool, intToPCon (fromEnum b) 1, Map.empty)
        Ast.PStr _ s ->
        Parsed.PStr _ s ->
            let
                span' = ice "span of Con with VariantStr"
                p = PCon (Con (VariantStr s) span' []) []
            in pure (typeStr, p, Map.empty)
        Ast.PVar (Id (WithPos _ "_")) -> do
        Parsed.PVar (Id (WithPos _ "_")) -> do
            tv <- fresh
            pure (tv, PWild, Map.empty)
        Ast.PVar x@(Id x') -> do
        Parsed.PVar x@(Id x') -> do
            tv <- fresh
            pure
                ( tv
                , PVar (TypedVar x' tv)
                , Map.singleton x (Forall Set.empty tv)
                )
        Ast.PBox _ p -> do
        Parsed.PBox _ p -> do
            (tp', p', vs) <- inferPat p
            pure (TBox tp', PBox p', vs)
    intToPCon n w = PCon


@@ 297,7 298,7 @@ inferPat pat = fmap
inferPatConstruction
    :: SrcPos
    -> Id 'Big
    -> [Ast.Pat]
    -> [Parsed.Pat]
    -> Infer (Type, Pat', Map (Id 'Small) Scheme)
inferPatConstruction pos c cArgs = do
    (variantIx, tdefLhs, cParams, cSpan) <- lookupEnvConstructor c

R src/AnnotAst.hs => src/Inferred.hs +2 -2
@@ 1,7 1,7 @@
{-# LANGUAGE LambdaCase, TemplateHaskell #-}

-- | Type annotated AST as a result of typechecking
module AnnotAst
module Inferred
    ( WithPos(..)
    , TVar(..)
    , TPrim(..)


@@ 34,7 34,7 @@ import Data.Set (Set)
import Data.Map.Strict (Map)
import Lens.Micro.Platform (makeLenses)

import Ast (TVar(..), TPrim(..), Const(..))
import Parsed (TVar(..), TPrim(..), Const(..))
import SrcPos



M src/Match.hs => src/Match.hs +4 -4
@@ 24,9 24,9 @@ import Misc hiding (augment)
import Pretty
import SrcPos
import TypeErr
import qualified AnnotAst as An
import AnnotAst (Pat, Pat'(..), Variant(..))
import DesugaredAst
import qualified Inferred
import Inferred (Pat, Pat'(..), Variant(..))
import Checked


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


@@ 129,7 129,7 @@ match
    -> Pat'
    -> Match DecisionTree'
match obj descr ctx work rhs rules = \case
    PVar (An.TypedVar (An.WithPos _ x) tx) ->
    PVar (Inferred.TypedVar (Inferred.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

R src/MonoAst.hs => src/Monomorphic.hs +3 -3
@@ 3,7 3,7 @@
{-# LANGUAGE TemplateHaskell, LambdaCase, MultiParamTypeClasses
           , FlexibleInstances, FlexibleContexts #-}

module MonoAst
module Monomorphic
    ( TPrim(..)
    , TConst
    , Type(..)


@@ 30,9 30,9 @@ import qualified Data.Set as Set
import Data.Set (Set)
import Data.Word

import DesugaredAst (VariantIx, Span)
import Checked (VariantIx, Span)
import FreeVars
import Ast (Const(..), TPrim(..))
import Parsed (Const(..), TPrim(..))

type TConst = (String, [Type])


R src/Mono.hs => src/Monomorphize.hs +58 -56
@@ 3,7 3,7 @@
           , FlexibleContexts #-}

-- | Monomorphization
module Mono (monomorphize) where
module Monomorphize (monomorphize) where

import Control.Applicative (liftA2, liftA3)
import Lens.Micro.Platform (makeLenses, view, use, modifying, to)


@@ 18,13 18,12 @@ import Data.Set (Set)
import Data.Bitraversable

import Misc
import qualified DesugaredAst as An
import DesugaredAst (TVar(..), Scheme(..))
import MonoAst

import qualified Checked
import Checked (TVar(..), Scheme(..))
import Monomorphic

data Env = Env
    { _envDefs :: Map String (Scheme, An.Expr)
    { _envDefs :: Map String (Scheme, Checked.Expr)
    , _tvBinds :: Map TVar Type
    }
makeLenses ''Env


@@ 38,10 37,12 @@ makeLenses ''Insts
-- | The monomorphization monad
type Mono = StateT Insts (Reader Env)

monomorphize :: An.Program -> Program
monomorphize (An.Program defs tdefs externs) = evalMono $ do
monomorphize :: Checked.Program -> Program
monomorphize (Checked.Program defs tdefs externs) = evalMono $ do
    externs' <- mapM (bimapM pure monotype) (Map.toList externs)
    (defs', _) <- monoLet defs (An.Var (An.TypedVar "start" An.startType))
    (defs', _) <- monoLet
        defs
        (Checked.Var (Checked.TypedVar "start" Checked.startType))
    tdefs' <- instTypeDefs tdefs
    pure (Program defs' tdefs' externs')



@@ 54,24 55,24 @@ initInsts = Insts Map.empty Set.empty
initEnv :: Env
initEnv = Env { _envDefs = Map.empty, _tvBinds = Map.empty }

mono :: An.Expr -> Mono Expr
mono :: Checked.Expr -> Mono Expr
mono = \case
    An.Lit c -> pure (Lit c)
    An.Var (An.TypedVar x t) -> do
    Checked.Lit c -> pure (Lit c)
    Checked.Var (Checked.TypedVar x t) -> do
        t' <- monotype t
        addDefInst x t'
        pure (Var (TypedVar x t'))
    An.App f a rt -> liftA3 App (mono f) (mono a) (monotype rt)
    An.If p c a -> liftA3 If (mono p) (mono c) (mono a)
    An.Fun p b -> monoFun p b
    An.Let ds b -> fmap (uncurry Let) (monoLet ds b)
    An.Match e cs tbody -> monoMatch e cs tbody
    An.Ction v span' inst as -> monoCtion v span' inst as
    An.Box x -> fmap Box (mono x)
    An.Deref x -> fmap Deref (mono x)
    An.Absurd t -> fmap Absurd (monotype t)

monoFun :: (String, An.Type) -> (An.Expr, An.Type) -> Mono Expr
    Checked.App f a rt -> liftA3 App (mono f) (mono a) (monotype rt)
    Checked.If p c a -> liftA3 If (mono p) (mono c) (mono a)
    Checked.Fun p b -> monoFun p b
    Checked.Let ds b -> fmap (uncurry Let) (monoLet ds b)
    Checked.Match e cs tbody -> monoMatch e cs tbody
    Checked.Ction v span' inst as -> monoCtion v span' inst as
    Checked.Box x -> fmap Box (mono x)
    Checked.Deref x -> fmap Deref (mono x)
    Checked.Absurd t -> fmap Absurd (monotype t)

monoFun :: (String, Checked.Type) -> (Checked.Expr, Checked.Type) -> Mono Expr
monoFun (p, tp) (b, bt) = do
    parentInst <- use (defInsts . to (Map.lookup p))
    modifying defInsts (Map.delete p)


@@ 81,7 82,7 @@ monoFun (p, tp) (b, bt) = do
    maybe (pure ()) (modifying defInsts . Map.insert p) parentInst
    pure (Fun (TypedVar p tp') (b', bt'))

monoLet :: An.Defs -> An.Expr -> Mono (Defs, Expr)
monoLet :: Checked.Defs -> Checked.Expr -> Mono (Defs, Expr)
monoLet ds body = do
    let ks = Map.keys ds
    parentInsts <- use (defInsts . to (lookups ks))


@@ 96,22 97,22 @@ monoLet ds body = do
            pure (TypedVar name t, (us, dbody))
    pure (ds', body')

monoMatch :: An.Expr -> An.DecisionTree -> An.Type -> Mono Expr
monoMatch :: Checked.Expr -> Checked.DecisionTree -> Checked.Type -> Mono Expr
monoMatch e dt tbody =
    liftA3 Match (mono e) (monoDecisionTree dt) (monotype tbody)

monoDecisionTree :: An.DecisionTree -> Mono DecisionTree
monoDecisionTree :: Checked.DecisionTree -> Mono DecisionTree
monoDecisionTree = \case
    An.DSwitch obj cs def -> monoDecisionSwitch obj cs def DSwitch
    An.DSwitchStr obj cs def -> monoDecisionSwitch obj cs def DSwitchStr
    An.DLeaf (bs, e) -> do
    Checked.DSwitch obj cs def -> monoDecisionSwitch obj cs def DSwitch
    Checked.DSwitchStr obj cs def -> monoDecisionSwitch obj cs def DSwitchStr
    Checked.DLeaf (bs, e) -> do
        let bs' = Map.toList bs
        let ks = map (\((An.TypedVar x _), _) -> x) bs'
        let ks = map (\((Checked.TypedVar x _), _) -> x) bs'
        parentInsts <- use (defInsts . to (lookups ks))
        modifying defInsts (deletes ks)
        bs'' <- mapM
            (bimapM
                (\(An.TypedVar x t) -> fmap (TypedVar x) (monotype t))
                (\(Checked.TypedVar x t) -> fmap (TypedVar x) (monotype t))
                monoAccess
            )
            bs'


@@ 125,15 126,15 @@ monoDecisionTree = \case
        def' <- monoDecisionTree def
        pure (f obj' cs' def')

monoAccess :: An.Access -> Mono Access
monoAccess :: Checked.Access -> Mono Access
monoAccess = \case
    An.Obj -> pure Obj
    An.As a span' ts ->
    Checked.Obj -> pure Obj
    Checked.As a span' ts ->
        liftA3 As (monoAccess a) (pure span') (mapM monotype ts)
    An.Sel i span' a -> fmap (Sel i span') (monoAccess a)
    An.ADeref a -> fmap ADeref (monoAccess a)
    Checked.Sel i span' a -> fmap (Sel i span') (monoAccess a)
    Checked.ADeref a -> fmap ADeref (monoAccess a)

monoCtion :: VariantIx -> Span -> An.TConst -> [An.Expr] -> Mono Expr
monoCtion :: VariantIx -> Span -> Checked.TConst -> [Checked.Expr] -> Mono Expr
monoCtion i span' (tdefName, tdefArgs) as = do
    tdefArgs' <- mapM monotype tdefArgs
    let tdefInst = (tdefName, tdefArgs')


@@ 158,39 159,40 @@ addDefInst x t1 = do
            pure ()
    where insertInst t b = modifying defInsts (Map.adjust (Map.insert t b) x)

bindTvs :: An.Type -> Type -> Map TVar Type
bindTvs :: Checked.Type -> Type -> Map TVar Type
bindTvs a b = case (a, b) of
    (An.TVar v, t) -> Map.singleton v t
    (An.TFun p0 r0, TFun p1 r1) -> Map.union (bindTvs p0 p1) (bindTvs r0 r1)
    (An.TBox t0, TBox t1) -> bindTvs t0 t1
    (An.TPrim _, TPrim _) -> Map.empty
    (An.TConst (_, ts0), TConst (_, ts1)) ->
    (Checked.TVar v, t) -> Map.singleton v t
    (Checked.TFun p0 r0, TFun p1 r1) ->
        Map.union (bindTvs p0 p1) (bindTvs r0 r1)
    (Checked.TBox t0, TBox t1) -> bindTvs t0 t1
    (Checked.TPrim _, TPrim _) -> Map.empty
    (Checked.TConst (_, ts0), TConst (_, ts1)) ->
        Map.unions (zipWith bindTvs ts0 ts1)
    (An.TPrim _, _) -> err
    (An.TFun _ _, _) -> err
    (An.TBox _, _) -> err
    (An.TConst _, _) -> err
    (Checked.TPrim _, _) -> err
    (Checked.TFun _ _, _) -> err
    (Checked.TBox _, _) -> err
    (Checked.TConst _, _) -> err
    where err = ice $ "bindTvs: " ++ show a ++ ", " ++ show b

monotype :: An.Type -> Mono Type
monotype :: Checked.Type -> Mono Type
monotype = \case
    An.TVar v ->
    Checked.TVar v ->
        view (tvBinds . to (lookup' (ice (show v ++ " not in tvBinds")) v))
    An.TPrim c -> pure (TPrim c)
    An.TFun a b -> liftA2 TFun (monotype a) (monotype b)
    An.TBox t -> fmap TBox (monotype t)
    An.TConst (c, ts) -> do
    Checked.TPrim c -> pure (TPrim c)
    Checked.TFun a b -> liftA2 TFun (monotype a) (monotype b)
    Checked.TBox t -> fmap TBox (monotype t)
    Checked.TConst (c, ts) -> do
        ts' <- mapM monotype ts
        let tdefInst = (c, ts')
        modifying tdefInsts (Set.insert tdefInst)
        pure (TConst tdefInst)

instTypeDefs :: An.TypeDefs -> Mono TypeDefs
instTypeDefs :: Checked.TypeDefs -> Mono TypeDefs
instTypeDefs tdefs = do
    insts <- use (tdefInsts . to Set.toList)
    instTypeDefs' tdefs insts

instTypeDefs' :: An.TypeDefs -> [TConst] -> Mono TypeDefs
instTypeDefs' :: Checked.TypeDefs -> [TConst] -> Mono TypeDefs
instTypeDefs' tdefs = \case
    [] -> pure []
    inst : insts -> do


@@ 200,7 202,7 @@ instTypeDefs' tdefs = \case
        let newInsts = Set.difference newTdefInsts oldTdefInsts
        tdefs' <- instTypeDefs' tdefs (Set.toList newInsts ++ insts)
        pure (tdef' : tdefs')
instTypeDef :: An.TypeDefs -> TConst -> Mono (TConst, [VariantTypes])
instTypeDef :: Checked.TypeDefs -> TConst -> Mono (TConst, [VariantTypes])
instTypeDef tdefs (x, ts) = do
    let (tvs, vs) = lookup' (ice "lookup' failed in instTypeDef") x tdefs
    vs' <- augment tvBinds (Map.fromList (zip tvs ts)) (mapM (mapM monotype) vs)

M src/Parse.hs => src/Parse.hs +1 -1
@@ 38,7 38,7 @@ import qualified Data.List.NonEmpty as NonEmpty

import Misc
import SrcPos
import Ast
import Parsed
import Literate
import EnvVars


R src/Ast.hs => src/Parsed.hs +1 -1
@@ 1,7 1,7 @@
{-# LANGUAGE LambdaCase, TypeSynonymInstances, FlexibleInstances
           , MultiParamTypeClasses, KindSignatures, DataKinds #-}

module Ast
module Parsed
    ( TVar(..)
    , TPrim(..)
    , TConst

M src/Pretty.hs => src/Pretty.hs +85 -85
@@ 10,8 10,8 @@ import Data.Set (Set)

import Misc
import SrcPos
import qualified Ast
import qualified AnnotAst as An
import qualified Parsed
import qualified Inferred


-- Pretty print starting at some indentation depth


@@ 29,33 29,33 @@ instance Pretty a => Pretty (WithPos a) where
    pretty' d = pretty' d . unpos


instance Pretty Ast.Program where
instance Pretty Parsed.Program where
    pretty' = prettyProg
instance Pretty Ast.Extern where
instance Pretty Parsed.Extern where
    pretty' = prettyExtern
instance Pretty Ast.ConstructorDefs where
instance Pretty Parsed.ConstructorDefs where
    pretty' = prettyConstructorDefs
instance Pretty Ast.TypeDef where
instance Pretty Parsed.TypeDef where
    pretty' = prettyTypeDef
instance Pretty Ast.Expr' where
instance Pretty Parsed.Expr' where
    pretty' = prettyExpr'
instance Pretty Ast.Pat where
instance Pretty Parsed.Pat where
    pretty' _ = prettyPat
instance Pretty Ast.Const where
instance Pretty Parsed.Const where
    pretty' _ = prettyConst
instance Pretty Ast.Scheme where
    pretty' _ (Ast.Forall _ ps t) = prettyScheme ps t
instance Pretty Ast.Type where
instance Pretty Parsed.Scheme where
    pretty' _ (Parsed.Forall _ ps t) = prettyScheme ps t
instance Pretty Parsed.Type where
    pretty' _ = prettyType
instance Pretty Ast.TPrim where
instance Pretty Parsed.TPrim where
    pretty' _ = prettyTPrim
instance Pretty Ast.TVar where
instance Pretty Parsed.TVar where
    pretty' _ = prettyTVar
instance Pretty (Ast.Id a) where
    pretty' _ = Ast.idstr
instance Pretty (Parsed.Id a) where
    pretty' _ = Parsed.idstr

prettyProg :: Int -> Ast.Program -> String
prettyProg d (Ast.Program defs tdefs externs) =
prettyProg :: Int -> Parsed.Program -> String
prettyProg d (Parsed.Program defs tdefs externs) =
    let
        prettyDef = \case
            (name, (Just scm, body)) -> concat


@@ 69,12 69,12 @@ prettyProg d (Ast.Program defs tdefs externs) =
                ]
    in unlines (map prettyDef defs ++ map pretty tdefs ++ map pretty externs)

prettyExtern :: Int -> Ast.Extern -> String
prettyExtern _ (Ast.Extern name t) =
    concat ["(extern ", Ast.idstr name, " ", pretty t, ")"]
prettyExtern :: Int -> Parsed.Extern -> String
prettyExtern _ (Parsed.Extern name t) =
    concat ["(extern ", Parsed.idstr name, " ", pretty t, ")"]

prettyTypeDef :: Int -> Ast.TypeDef -> String
prettyTypeDef d (Ast.TypeDef name params constrs) = concat
prettyTypeDef :: Int -> Parsed.TypeDef -> String
prettyTypeDef d (Parsed.TypeDef name params constrs) = concat
    [ "(type "
    , if null params
        then pretty name


@@ 82,8 82,8 @@ prettyTypeDef d (Ast.TypeDef name params constrs) = concat
    , "\n" ++ indent (d + 2) ++ pretty' (d + 2) constrs ++ ")"
    ]

prettyConstructorDefs :: Int -> Ast.ConstructorDefs -> String
prettyConstructorDefs d (Ast.ConstructorDefs cs) = intercalate
prettyConstructorDefs :: Int -> Parsed.ConstructorDefs -> String
prettyConstructorDefs d (Parsed.ConstructorDefs cs) = intercalate
    ("\n" ++ indent d)
    (map prettyConstrDef cs)
  where


@@ 91,20 91,20 @@ prettyConstructorDefs d (Ast.ConstructorDefs cs) = intercalate
        (c, []) -> pretty c
        (c, ts) -> concat ["(", pretty c, " ", spcPretty ts, ")"]

prettyExpr' :: Int -> Ast.Expr' -> String
prettyExpr' :: Int -> Parsed.Expr' -> String
prettyExpr' d = \case
    Ast.Lit l -> pretty l
    Ast.Var v -> Ast.idstr v
    Ast.App f x -> concat
    Parsed.Lit l -> pretty l
    Parsed.Var v -> Parsed.idstr v
    Parsed.App f x -> concat
        [ "(" ++ pretty' (d + 1) f ++ "\n"
        , indent (d + 1) ++ pretty' (d + 1) x ++ ")"
        ]
    Ast.If pred' cons alt -> concat
    Parsed.If pred' cons alt -> concat
        [ "(if " ++ pretty' (d + 4) pred' ++ "\n"
        , indent (d + 4) ++ pretty' (d + 4) cons ++ "\n"
        , indent (d + 2) ++ pretty' (d + 2) alt ++ ")"
        ]
    Ast.Fun param body -> concat
    Parsed.Fun param body -> concat
        [ "(fun ("
        , prettyPat param
        , ")\n"


@@ 112,7 112,7 @@ prettyExpr' d = \case
        , pretty' (d + 2) body
        , ")"
        ]
    Ast.Let binds body -> concat
    Parsed.Let binds body -> concat
        [ "(let ["
        , intercalate ("\n" ++ indent (d + 6)) (map (prettyDef (d + 6)) binds)
        , "]\n"


@@ 129,47 129,47 @@ prettyExpr' d = \case
                [ "[" ++ pretty' (d' + 1) name ++ "\n"
                , indent (d' + 1) ++ pretty' (d' + 1) dbody ++ "]"
                ]
    Ast.TypeAscr e t ->
    Parsed.TypeAscr e t ->
        concat ["(: ", pretty' (d + 3) e, "\n", pretty' (d + 3) t, ")"]
    Ast.Match e cs -> concat
    Parsed.Match e cs -> concat
        [ "(match " ++ pretty' (d + 7) e
        , precalate
            ("\n" ++ indent (d + 2))
            (map (prettyBracketPair (d + 2)) cs)
        , ")"
        ]
    Ast.FunMatch cs -> concat
    Parsed.FunMatch cs -> concat
        [ "(fun-match"
        , precalate
            ("\n" ++ indent (d + 2))
            (map (prettyBracketPair (d + 2)) cs)
        , ")"
        ]
    Ast.Ctor c -> pretty c
    Ast.Box e -> concat ["(box ", pretty' (d + 5) e, ")"]
    Ast.Deref e -> concat ["(deref ", pretty' (d + 7) e, ")"]
    Parsed.Ctor c -> pretty c
    Parsed.Box e -> concat ["(box ", pretty' (d + 5) e, ")"]
    Parsed.Deref e -> concat ["(deref ", pretty' (d + 7) e, ")"]

prettyBracketPair :: (Pretty a, Pretty b) => Int -> (a, b) -> String
prettyBracketPair d (a, b) = concat
    ["[", pretty' (d + 1) a, "\n", indent (d + 1), pretty' (d + 1) b, "]"]

prettyPat :: Ast.Pat -> String
prettyPat :: Parsed.Pat -> String
prettyPat = \case
    Ast.PConstruction _ (Ast.Id (WithPos _ c)) ps ->
    Parsed.PConstruction _ (Parsed.Id (WithPos _ c)) ps ->
        if null ps then c else concat ["(", c, " ", spcPretty ps, ")"]
    Ast.PInt _ n -> show n
    Ast.PBool _ b -> if b then "true" else "false"
    Ast.PStr _ s -> prettyStr s
    Ast.PVar v -> Ast.idstr v
    Ast.PBox _ p -> "(Box " ++ prettyPat p ++ ")"
    Parsed.PInt _ n -> show n
    Parsed.PBool _ b -> if b then "true" else "false"
    Parsed.PStr _ s -> prettyStr s
    Parsed.PVar v -> Parsed.idstr v
    Parsed.PBox _ p -> "(Box " ++ prettyPat p ++ ")"

prettyConst :: Ast.Const -> String
prettyConst :: Parsed.Const -> String
prettyConst = \case
    Ast.Unit -> "unit"
    Ast.Int n -> show n
    Ast.Double x -> show x
    Ast.Str s -> prettyStr s
    Ast.Bool b -> if b then "true" else "false"
    Parsed.Unit -> "unit"
    Parsed.Int n -> show n
    Parsed.Double x -> show x
    Parsed.Str s -> prettyStr s
    Parsed.Bool b -> if b then "true" else "false"

prettyStr :: String -> String
prettyStr s = '"' : (s >>= showChar) ++ "\""


@@ 191,13 191,13 @@ prettyScheme :: (Pretty p, Pretty t) => Set p -> t -> String
prettyScheme ps t =
    concat ["(forall [" ++ spcPretty (Set.toList ps) ++ "] ", pretty t ++ ")"]

prettyType :: Ast.Type -> String
prettyType :: Parsed.Type -> String
prettyType = \case
    Ast.TVar tv -> pretty tv
    Ast.TPrim c -> pretty c
    Ast.TFun a b -> prettyTFun a b
    Ast.TBox t -> prettyTBox t
    Ast.TConst tc -> prettyTConst tc
    Parsed.TVar tv -> pretty tv
    Parsed.TPrim c -> pretty c
    Parsed.TFun a b -> prettyTFun a b
    Parsed.TBox t -> prettyTBox t
    Parsed.TConst tc -> prettyTConst tc

prettyTConst :: Pretty t => (String, [t]) -> String
prettyTConst (c, ts) = case ts of


@@ 207,53 207,53 @@ prettyTConst (c, ts) = case ts of
prettyTBox :: Pretty t => t -> String
prettyTBox t = "(Box " ++ pretty t ++ ")"

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

prettyTPrim :: Ast.TPrim -> String
prettyTPrim :: Parsed.TPrim -> String
prettyTPrim = \case
    Ast.TUnit -> "Unit"
    Ast.TNat8 -> "Nat8"
    Ast.TNat16 -> "Nat16"
    Ast.TNat32 -> "Nat32"
    Ast.TNat -> "Nat"
    Ast.TInt8 -> "Int8"
    Ast.TInt16 -> "Int16"
    Ast.TInt32 -> "Int32"
    Ast.TInt -> "Int"
    Ast.TDouble -> "Double"
    Ast.TBool -> "Bool"
    Parsed.TUnit -> "Unit"
    Parsed.TNat8 -> "Nat8"
    Parsed.TNat16 -> "Nat16"
    Parsed.TNat32 -> "Nat32"
    Parsed.TNat -> "Nat"
    Parsed.TInt8 -> "Int8"
    Parsed.TInt16 -> "Int16"
    Parsed.TInt32 -> "Int32"
    Parsed.TInt -> "Int"
    Parsed.TDouble -> "Double"
    Parsed.TBool -> "Bool"

prettyTVar :: Ast.TVar -> String
prettyTVar :: Parsed.TVar -> String
prettyTVar = \case
    Ast.TVExplicit v -> Ast.idstr v
    Ast.TVImplicit n -> "#" ++ show n
    Parsed.TVExplicit v -> Parsed.idstr v
    Parsed.TVImplicit n -> "#" ++ show n


instance Pretty An.Scheme where
    pretty' _ (An.Forall ps t) = prettyScheme ps t
instance Pretty An.Type where
instance Pretty Inferred.Scheme where
    pretty' _ (Inferred.Forall ps t) = prettyScheme ps t
instance Pretty Inferred.Type where
    pretty' _ = prettyAnType

prettyAnType :: An.Type -> String
prettyAnType :: Inferred.Type -> String
prettyAnType = \case
    An.TVar tv -> pretty tv
    An.TPrim c -> pretty c
    An.TFun a b -> prettyAnTFun a b
    An.TBox t -> prettyTBox t
    An.TConst tc -> prettyTConst tc
    Inferred.TVar tv -> pretty tv
    Inferred.TPrim c -> pretty c
    Inferred.TFun a b -> prettyAnTFun a b
    Inferred.TBox t -> prettyTBox t
    Inferred.TConst tc -> prettyTConst tc

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

M src/Selections.hs => src/Selections.hs +1 -1
@@ 8,7 8,7 @@ import Data.Word
import Control.Monad

import Misc
import MonoAst
import Monomorphic


type Selections a = Map Access a

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

import AnnotAst
import Inferred


-- | Map of substitutions from type-variables to more specific types

M src/TypeErr.hs => src/TypeErr.hs +5 -5
@@ 6,8 6,8 @@ import Text.Megaparsec (SourcePos(..), unPos)

import Misc
import SrcPos
import qualified Ast
import AnnotAst
import qualified Parsed
import Inferred
import Pretty
import Parse



@@ 25,12 25,12 @@ data TypeErr
    | ConflictingCtorDef SrcPos String
    | RedundantCase SrcPos
    | InexhaustivePats SrcPos String
    | ExternNotMonomorphic (Ast.Id 'Ast.Small) TVar
    | ExternNotMonomorphic (Parsed.Id 'Parsed.Small) TVar
    | FoundHole SrcPos
    | RecTypeDef String SrcPos
    | UndefType SrcPos String
    | UnboundTVar SrcPos
    | WrongStartType SrcPos Ast.Scheme
    | WrongStartType SrcPos Parsed.Scheme
    | RecursiveVarDef (WithPos String)
    | TypeInstArityMismatch SrcPos String Int Int
    | ConflictingVarDef SrcPos String


@@ 76,7 76,7 @@ printErr = \case
    InexhaustivePats p patStr ->
        posd p $ "Inexhaustive patterns: " ++ patStr ++ " not covered."
    ExternNotMonomorphic name tv -> case tv of
        TVExplicit (Ast.Id (WithPos p tv')) ->
        TVExplicit (Parsed.Id (WithPos p tv')) ->
            posd p
                $ ("Extern " ++ pretty name ++ " is not monomorphic. ")
                ++ ("Type variable " ++ tv' ++ " encountered in type signature")

M test/CheckSpec.hs => test/CheckSpec.hs +4 -5
@@ 4,8 4,8 @@ module CheckSpec where

import Test.Hspec

import qualified Ast
import qualified DesugaredAst as Des
import qualified Parsed
import qualified Checked
import Parse
import Check
import TypeErr


@@ 63,7 63,6 @@ pConflictingVarDef_b = "(define foo (let ((a 1) (a 2)) a))"

spec :: Spec
spec = do
    let startDef = "(define (start _) unit)"
    describe "typecheck" $ do
        it "detects when start is not defined"
            $ shouldSatisfy (typecheck' pStartNotDefined)


@@ 189,7 188,7 @@ spec = do
                Right (Left (ConflictingVarDef{})) -> True
                _ -> False

typecheck' :: String -> Either String (Either TypeErr Des.Program)
typecheck' :: String -> Either String (Either TypeErr Checked.Program)
typecheck' =
    fmap (\(_, ds, tds, es) -> typecheck (Ast.Program ds tds es))
    fmap (\(_, ds, tds, es) -> typecheck (Parsed.Program ds tds es))
        . parse' toplevels "TEST"