~jojo/Carth

2d5e5be3b7e0ce88608095cd809ea805435a7658 — JoJo 22 days ago 4b56062
Less desugaring in Parse (do in Infer instead), more concrete Parsed.

Step towards improving error messages. Among others, the function-related ones can
end up misleading due to bad SrcPos:s given to nodes generated from desugaring.
7 files changed, 114 insertions(+), 217 deletions(-)

M app/Main.hs
M examples/hello-world.carth
M src/FreeVars.hs
M src/Infer.hs
M src/Parse.hs
M src/Parsed.hs
M src/Pretty.hs
M app/Main.hs => app/Main.hs +0 -2
@@ 8,7 8,6 @@ import Control.Monad.Except
import Prelude hiding (lex)

import Misc
import Pretty
import qualified Err
import qualified Lexd
import qualified Parsed


@@ 65,7 64,6 @@ frontend cfg f = do
    when d $ writeFile ".dbg.expanded" (show tts')
    verbose cfg ("   Parsing")
    ast <- parse f tts'
    when d $ writeFile ".dbg.parsed" (pretty ast)
    verbose cfg ("   Typechecking")
    ann <- typecheck' f ast
    when d $ writeFile ".dbg.checked" (show ann)

M examples/hello-world.carth => examples/hello-world.carth +1 -1
@@ 1,4 1,4 @@
(import std)

(define main
  (display (str-append "Hello, world!" "\n")))
  (display "Hello, World!"))

M src/FreeVars.hs => src/FreeVars.hs +1 -1
@@ 17,7 17,7 @@ fvIf p c a = Set.unions (map freeVars [p, c, a])
fvFun :: FreeVars e t => t -> e -> Set t
fvFun p b = Set.delete p (freeVars b)

fvLet :: (FreeVars e t, Foldable f) => ([t], f e) -> e -> Set t
fvLet :: (FreeVars a t, FreeVars b t, Foldable f) => ([t], f a) -> b -> Set t
fvLet (bVs, bBs) e = Set.difference
    (Set.union (freeVars e) (foldr (Set.union . freeVars) Set.empty bBs))
    (Set.fromList bVs)

M src/Infer.hs => src/Infer.hs +53 -24
@@ 12,6 12,7 @@ import Control.Monad.State.Strict
import Control.Monad.Writer
import Data.Bifunctor
import Data.Graph (SCC(..), stronglyConnComp)
import Data.List hiding (span)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe


@@ 23,7 24,7 @@ import SrcPos
import FreeVars
import Subst
import qualified Parsed
import Parsed (Id(..), IdCase(..), idstr)
import Parsed (Id(..), IdCase(..), idstr, defLhs)
import Err
import Inferred hiding (Id)
import TypeAst hiding (TConst)


@@ 116,11 117,11 @@ inferDefs envDefs defs = do
checkNoDuplicateDefs :: [Parsed.Def] -> Infer ()
checkNoDuplicateDefs = checkNoDuplicateDefs' Set.empty
  where
    checkNoDuplicateDefs' already = \case
        (Id (WithPos p x), _) : ds -> if Set.member x already
    checkNoDuplicateDefs' already = uncons >>> fmap (first defLhs) >>> \case
        Just (Id (WithPos p x), ds) -> if Set.member x already
            then throwError (ConflictingVarDef p x)
            else checkNoDuplicateDefs' (Set.insert x already) ds
        [] -> pure ()
        Nothing -> pure ()

-- For unification to work properly with mutually recursive functions,
-- we need to create a dependency graph of non-recursive /


@@ 132,29 133,39 @@ checkNoDuplicateDefs = checkNoDuplicateDefs' Set.empty
-- generalizing.
orderDefs :: [Parsed.Def] -> [SCC Parsed.Def]
orderDefs = stronglyConnComp . graph
    where graph = map (\d@(n, _) -> (d, n, Set.toList (freeVars d)))
    where graph = map (\d -> (d, defLhs d, Set.toList (freeVars d)))

inferComponent :: SCC Parsed.Def -> Infer Def
inferComponent = \case
    AcyclicSCC vert -> fmap VarDef (inferVarDef vert)
    AcyclicSCC vert -> fmap VarDef (inferNonrecDef vert)
    CyclicSCC verts -> fmap RecDefs (inferRecDefs verts)

inferVarDef :: Parsed.Def -> Infer VarDef
inferNonrecDef :: Parsed.Def -> Infer VarDef
inferRecDefs :: [Parsed.Def] -> Infer RecDefs
(inferVarDef, inferRecDefs) = (inferVarDef', inferRecDefs')
(inferNonrecDef, inferRecDefs) = (inferNonrecDef', inferRecDefs')
  where
    inferVarDef' (lhs, WithPos defPos (mayscm, body)) = do
    inferNonrecDef' (Parsed.FunDef dpos lhs mayscm params body) =
        -- FIXME: Just wanted to get things working, but this isn't really better than
        --        doing the fold in the parser. Handle this such that we don't have to
        --        assign the definition position to the nested lambdas.
        inferNonrecDef' $ Parsed.VarDef dpos lhs mayscm $ foldr
            (\p b -> WithPos dpos (Parsed.FunMatch [(p, b)]))
            body
            params
    inferNonrecDef' (Parsed.VarDef dpos lhs mayscm body) = do
        t <- fresh
        (body', cs) <- listen $ inferDef t lhs mayscm (getPos body) (infer body)
        sub <- lift $ lift $ lift $ solve cs
        env <- view envLocalDefs
        let scm = generalize (substEnv sub env) (subst sub t)
        let body'' = substExpr sub body'
        pure (idstr lhs, WithPos defPos (scm, body''))
        pure (idstr lhs, WithPos dpos (scm, body''))

    inferRecDefs' ds = do
        ts <- replicateM (length ds) fresh
        let (names, poss) = unzip (map (bimap idstr getPos) ds)
        let (names, poss) = unzip $ flip map ds $ \case
                Parsed.FunDef p x _ _ _ -> (idstr x, p)
                Parsed.VarDef p x _ _ -> (idstr x, p)
        let dummyDefs = Map.fromList (zip names (map (Forall Set.empty) ts))
        (fs, cs) <- listen $ augment envLocalDefs dummyDefs $ zipWithM inferRecDef ts ds
        sub <- lift $ lift $ lift $ solve cs


@@ 164,10 175,16 @@ inferRecDefs :: [Parsed.Def] -> Infer RecDefs
        pure (zip names (zipWith3 (curry . WithPos) poss scms fs'))

    inferRecDef :: Type -> Parsed.Def -> Infer (WithPos FunMatch)
    inferRecDef t = uncurry $ \(Id lhs) -> unpos >>> \case
        (mayscm, WithPos fPos (Parsed.FunMatch cs)) ->
            fmap (WithPos fPos) $ inferDef t (Id lhs) mayscm fPos (inferFunMatch cs)
        _ -> throwError (RecursiveVarDef lhs)
    inferRecDef t = \case
        Parsed.FunDef fpos lhs mayscm params body ->
            let (initps, lastp) = fromJust $ unsnoc params
            in  fmap (WithPos fpos) $ inferDef t lhs mayscm fpos $ inferFunMatch $ foldr
                    (\p cs -> [(p, WithPos fpos (Parsed.FunMatch cs))])
                    [(lastp, body)]
                    initps
        Parsed.VarDef fpos lhs mayscm (WithPos _ (Parsed.FunMatch cs)) ->
            fmap (WithPos fpos) $ inferDef t lhs mayscm fpos (inferFunMatch cs)
        Parsed.VarDef _ (Id lhs) _ _ -> throwError (RecursiveVarDef lhs)

    inferDef t lhs mayscm bodyPos inferBody = do
        checkScheme (idstr lhs) mayscm >>= \case


@@ 211,10 228,11 @@ infer (WithPos pos e) = fmap (second (WithPos pos)) $ case e of
        unify (Expected tBool) (Found (getPos p) tp)
        unify (Expected tc) (Found (getPos a) ta)
        pure (tc, If p' c' a')
    Parsed.Let1 def body -> do
        def' <- inferVarDef def
        (t, body') <- augment1 envLocalDefs (defSig def') (infer body)
        pure (t, Let (VarDef def') body')
    Parsed.Let1 def body -> inferLet1 pos def body
    Parsed.Let defs body ->
        -- FIXME: positions
        let (def, defs') = fromJust $ uncons defs
        in  inferLet1 pos def $ foldr (\d b -> WithPos pos (Parsed.Let1 d b)) body defs'
    Parsed.LetRec defs b -> do
        Topo defs' <- inferDefs envLocalDefs defs
        let withDef def inferX = do


@@ 226,15 244,26 @@ infer (WithPos pos e) = fmap (second (WithPos pos)) $ case e of
        t' <- checkType pos t
        unify (Expected t') (Found (getPos x) tx)
        pure (t', x')
    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)
    Parsed.Match matchee cases -> inferMatch pos matchee cases
    Parsed.FunMatch cases -> fmap (second FunMatch) (inferFunMatch cases)
    Parsed.Ctor c -> inferExprConstructor c
    Parsed.Sizeof t -> fmap ((TPrim TNatSize, ) . Sizeof) (checkType pos t)

inferLet1 :: SrcPos -> Parsed.DefLike -> Parsed.Expr -> Infer (Type, Expr')
inferLet1 pos defl body = case defl of
    Parsed.Def def -> do
        def' <- inferNonrecDef def
        (t, body') <- augment1 envLocalDefs (defSig def') (infer body)
        pure (t, Let (VarDef def') body')
    Parsed.Deconstr pat matchee -> inferMatch pos matchee [(pat, body)]

inferMatch :: SrcPos -> Parsed.Expr -> [(Parsed.Pat, Parsed.Expr)] -> Infer (Type, Expr')
inferMatch pos 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)

inferFunMatch :: [(Parsed.Pat, Parsed.Expr)] -> Infer (Type, FunMatch)
inferFunMatch cases = do
    tpat <- fresh

M src/Parse.hs => src/Parse.hs +16 -33
@@ 53,10 53,7 @@ defUntyped pos = reserved Kdefine *> def' (pure Nothing) pos
defTyped :: SrcPos -> Parser Def
defTyped pos = reserved KdefineColon *> def' (fmap Just scheme) pos

def'
    :: Parser (Maybe Scheme)
    -> SrcPos
    -> Parser (Id 'Small, (WithPos (Maybe Scheme, Expr)))
def' :: Parser (Maybe Scheme) -> SrcPos -> Parser Def
def' schemeParser topPos = varDef <|> funDef
  where
    parenDef = try (parens' def)


@@ 67,13 64,12 @@ def' schemeParser topPos = varDef <|> funDef
        name <- small
        scm <- schemeParser
        b <- body
        pure (name, (WithPos topPos (scm, b)))
        pure (VarDef topPos name scm b)
    funDef = do
        (name, params) <- parens (liftM2 (,) small (some pat))
        scm <- schemeParser
        b <- body
        let f = foldr (WithPos topPos . FunMatch . pure .* (,)) b params
        pure (name, (WithPos topPos (scm, f)))
        pure (FunDef topPos name scm params b)

expr :: Parser Expr
expr = withPos expr'


@@ 97,15 93,9 @@ expr' = choice [var, lit, eConstructor, etuple, pexpr]
            $ tuple expr (\p -> WithPos p (Ctor (Id (WithPos p "Unit"))))
            $ \l r ->
                  let p = getPos l
                  in  WithPos
                          p
                          (App
                              (WithPos
                                  p
                                  (App (WithPos p (Ctor (Id (WithPos p "Cons")))) l)
                              )
                              r
                          )
                  in  WithPos p $ App
                          (WithPos p (App (WithPos p (Ctor (Id (WithPos p "Cons")))) l))
                          r
    var = fmap Var small
    pexpr = parens' $ \p -> choice
        [funMatch, match, if', fun, let1 p, let', letrec, typeAscr, sizeof, app]


@@ 119,43 109,36 @@ expr' = choice [var, lit, eConstructor, etuple, pexpr]
        body <- expr
        pure $ unpos $ foldr (\p b -> WithPos (getPos p) (FunMatch [(p, b)])) body params
    let1 p = reserved Klet1 *> (varLhs <|> try funLhs <|> caseVarLhs) >>= \case
        VarLhs lhs -> liftA2 Let1 (varBinding p lhs) expr
        FunLhs name params -> liftA2 Let1 (funBinding p name params) expr
        CaseVarLhs lhs -> liftA2 Match expr (fmap (pure . (lhs, )) expr)
        VarLhs lhs -> liftA2 (Let1 . Def) (varBinding p lhs) expr
        FunLhs name params -> liftA2 (Let1 . Def) (funBinding p name params) expr
        CaseVarLhs lhs -> liftA2 Let1 (fmap (Deconstr lhs) expr) expr
    let' = do
        reserved Klet
        bs <- parens (many pbinding)
        e <- expr
        pure $ unpos $ foldr
            (\b x -> case b of
                Left (lhs, rhs) -> WithPos (getPos rhs) (Let1 (lhs, rhs) x)
                Right (lhs, rhs) -> WithPos (getPos rhs) (Match rhs [(lhs, x)])
            )
            e
            bs
        pure (Let bs e)
      where
        pbinding = parens' binding
        binding p = (varLhs <|> try funLhs <|> caseVarLhs) >>= \case
            VarLhs lhs -> fmap Left (varBinding p lhs)
            FunLhs name params -> fmap Left (funBinding p name params)
            CaseVarLhs lhs -> fmap (Right . (lhs, )) expr
            VarLhs lhs -> fmap Def (varBinding p lhs)
            FunLhs name params -> fmap Def (funBinding p name params)
            CaseVarLhs lhs -> fmap (Deconstr lhs) expr
    letrec = reserved Kletrec *> liftA2 LetRec (parens (many pbinding)) expr
      where
        pbinding = parens' binding
        binding p = (varLhs <|> funLhs) >>= \case
            VarLhs lhs -> varBinding p lhs
            FunLhs name params -> funBinding p name params
            CaseVarLhs _ -> ice "binding: CaseVarLhs unreachable"
            CaseVarLhs _ -> ice "letrec binding: CaseVarLhs"
    varLhs = fmap VarLhs small
    funLhs = parens (liftA2 FunLhs small (some pat))
    caseVarLhs = fmap CaseVarLhs pat
    varBinding pos lhs = do
        rhs <- expr
        pure (lhs, WithPos pos (Nothing, rhs))
        pure (VarDef pos lhs Nothing rhs)
    funBinding pos name params = do
        b <- expr
        let f = foldr (WithPos pos . FunMatch . pure .* (,)) b params
        pure (name, WithPos pos (Nothing, f))
        pure (FunDef pos name Nothing params b)
    typeAscr = reserved Kcolon *> liftA2 TypeAscr expr type_
    sizeof = reserved Ksizeof *> fmap Sizeof type_
    app = do

M src/Parsed.hs => src/Parsed.hs +43 -20
@@ 6,7 6,6 @@ module Parsed (module Parsed, Const (..), TPrim(..), TConst) where

import qualified Data.Set as Set
import Data.Set (Set)
import Data.Bifunctor
import Control.Arrow ((>>>))
import Data.Data



@@ 26,9 25,6 @@ data TVar
    | TVImplicit String
    deriving (Show, Eq, Ord, Data)

-- TODO: Now that AnnotAst.Type is not just an alias to Ast.Type, it makes sense
--       to add SrcPos-itions to Ast.Type! Would simplify / improve error
--       messages quite a bit.
data Type
    = TVar TVar
    | TPrim TPrim


@@ 55,7 51,8 @@ data Expr'
    | Var (Id 'Small)
    | App Expr Expr
    | If Expr Expr Expr
    | Let1 Def Expr
    | Let1 DefLike Expr
    | Let [DefLike] Expr
    | LetRec [Def] Expr
    | TypeAscr Expr Type
    | Match Expr [(Pat, Expr)]


@@ 66,7 63,12 @@ data Expr'

type Expr = WithPos Expr'

type Def = (Id 'Small, WithPos (Maybe Scheme, Expr))
data Def = VarDef SrcPos (Id 'Small) (Maybe Scheme) Expr
         | FunDef SrcPos (Id 'Small) (Maybe Scheme) [Pat] Expr
    deriving (Show, Eq)

data DefLike = Def Def | Deconstr Pat Expr
    deriving (Show, Eq)

newtype ConstructorDefs = ConstructorDefs [(Id 'Big, [Type])]
    deriving (Show, Eq)


@@ 94,7 96,15 @@ instance Eq Pat where
        _ -> False

instance FreeVars Def (Id 'Small) where
    freeVars (_, (WithPos _ (_, body))) = freeVars body
    freeVars = \case
        VarDef _ _ _ body -> freeVars body
        FunDef _ _ _ pats body ->
            Set.difference (freeVars body) (Set.unions (map bvPat pats))

instance FreeVars DefLike (Id 'Small) where
    freeVars = \case
        Def d -> freeVars d
        Deconstr _ matchee -> freeVars matchee

instance FreeVars Expr (Id 'Small) where
    freeVars = fvExpr


@@ 112,19 122,32 @@ instance HasPos Pat where


fvExpr :: Expr -> Set (Id 'Small)
fvExpr = unpos >>> \case
    Lit _ -> Set.empty
    Var x -> Set.singleton x
    App f a -> fvApp f a
    If p c a -> fvIf p c a
    Let1 (lhs, WithPos _ (_, rhs)) e ->
        Set.union (freeVars rhs) (Set.delete lhs (freeVars e))
    LetRec ds e -> fvLet (unzip (map (second (snd . unpos)) ds)) e
    TypeAscr e _t -> freeVars e
    Match e cs -> fvMatch e cs
    FunMatch cs -> fvCases cs
    Ctor _ -> Set.empty
    Sizeof _t -> Set.empty
fvExpr = unpos >>> fvExpr'
  where
    fvExpr' = \case
        Lit _ -> Set.empty
        Var x -> Set.singleton x
        App f a -> fvApp f a
        If p c a -> fvIf p c a
        Let1 b e -> Set.union (freeVars b) (Set.difference (freeVars e) (bvDefLike b))
        Let bs e -> foldr
            (\b fvs -> Set.union (freeVars b) (Set.difference fvs (bvDefLike b)))
            (freeVars e)
            bs
        LetRec ds e -> fvLet (unzip (map (\d -> (defLhs d, d)) ds)) e
        TypeAscr e _t -> freeVars e
        Match e cs -> fvMatch e cs
        FunMatch cs -> fvCases cs
        Ctor _ -> Set.empty
        Sizeof _t -> Set.empty
    bvDefLike = \case
        Def d -> Set.singleton (defLhs d)
        Deconstr pat _ -> bvPat pat

defLhs :: Def -> Id 'Small
defLhs = \case
    VarDef _ lhs _ _ -> lhs
    FunDef _ lhs _ _ _ -> lhs

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

M src/Pretty.hs => src/Pretty.hs +0 -136
@@ 3,7 3,6 @@
module Pretty (pretty, Pretty(..)) where

import Prelude hiding (showChar)
import Data.List
import Data.Bifunctor
import qualified Data.Set as Set
import Data.Set (Set)


@@ 11,7 10,6 @@ import LLVM.AST (Module)
import LLVM.Pretty ()
import qualified Data.Text.Prettyprint.Doc as Prettyprint

import Misc
import SrcPos
import qualified Lexd
import qualified Parsed


@@ 60,20 58,6 @@ instance Pretty Lexd.Keyword where
        Lexd.Kdefmacro -> "defmacro"


instance Pretty Parsed.Program where
    pretty' = prettyProg
instance Pretty Parsed.Extern where
    pretty' = prettyExtern
instance Pretty Parsed.ConstructorDefs where
    pretty' = prettyConstructorDefs
instance Pretty Parsed.TypeDef where
    pretty' = prettyTypeDef
instance Pretty Parsed.Expr' where
    pretty' = prettyExpr'
instance Pretty Parsed.Pat where
    pretty' _ = prettyPat
instance Pretty Parsed.Const where
    pretty' _ = prettyConst
instance Pretty Parsed.Scheme where
    pretty' _ (Parsed.Forall _ ps t) = prettyScheme ps t
instance Pretty Parsed.Type where


@@ 85,126 69,6 @@ instance Pretty Parsed.TVar where
instance Pretty (Parsed.Id a) where
    pretty' _ = Parsed.idstr

prettyProg :: Int -> Parsed.Program -> String
prettyProg d (Parsed.Program defs tdefs externs) =
    let prettyDef = \case
            (name, WithPos _ (Just scm, body)) -> concat
                [ indent d ++ "(define: " ++ pretty name ++ "\n"
                , indent (d + 4) ++ pretty' (d + 4) scm ++ "\n"
                , indent (d + 2) ++ pretty' (d + 2) body ++ ")"
                ]
            (name, WithPos _ (Nothing, body)) -> concat
                [ indent d ++ "(define " ++ pretty name ++ "\n"
                , indent (d + 2) ++ pretty' (d + 2) body ++ ")"
                ]
    in  unlines (map prettyDef defs ++ map pretty tdefs ++ map pretty externs)

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

prettyTypeDef :: Int -> Parsed.TypeDef -> String
prettyTypeDef d (Parsed.TypeDef name params constrs) = concat
    [ "(type "
    , if null params
        then pretty name
        else "(" ++ pretty name ++ " " ++ spcPretty params ++ ")"
    , "\n" ++ indent (d + 2) ++ pretty' (d + 2) constrs ++ ")"
    ]

prettyConstructorDefs :: Int -> Parsed.ConstructorDefs -> String
prettyConstructorDefs d (Parsed.ConstructorDefs cs) = intercalate
    ("\n" ++ indent d)
    (map prettyConstrDef cs)
  where
    prettyConstrDef = \case
        (c, []) -> pretty c
        (c, ts) -> concat ["(", pretty c, " ", spcPretty ts, ")"]

prettyExpr' :: Int -> Parsed.Expr' -> String
prettyExpr' d = \case
    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 ++ ")"]
    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 ++ ")"
        ]
    Parsed.Let1 bind body -> concat
        [ "(let1 "
        , prettyDef (d + 6) bind
        , "\n" ++ indent (d + 2) ++ pretty' (d + 2) body ++ ")"
        ]
    Parsed.LetRec binds body -> concat
        [ "(let ("
        , intercalate ("\n" ++ indent (d + 6)) (map (prettyDef (d + 6)) binds)
        , ")\n"
        , indent (d + 2) ++ pretty' (d + 2) body ++ ")"
        ]
    Parsed.TypeAscr e t ->
        concat ["(: ", pretty' (d + 3) e, "\n", pretty' (d + 3) t, ")"]
    Parsed.Match e cs -> concat
        [ "(match " ++ pretty' (d + 7) e
        , precalate ("\n" ++ indent (d + 2)) (map (prettyBracketPair (d + 2)) cs)
        , ")"
        ]
    Parsed.FunMatch cs -> concat
        [ "(fmatch"
        , precalate ("\n" ++ indent (d + 2)) (map (prettyBracketPair (d + 2)) cs)
        , ")"
        ]
    Parsed.Ctor c -> pretty c
    Parsed.Sizeof t -> concat ["(sizeof ", pretty' (d + 8) t, ")"]

prettyDef :: Int -> Parsed.Def -> String
prettyDef d' = \case
    (name, WithPos _ (Just scm, dbody)) -> concat
        [ "(: " ++ pretty' (d' + 3) name ++ "\n"
        , indent (d' + 3) ++ pretty' (d' + 3) scm ++ "\n"
        , indent (d' + 1) ++ pretty' (d' + 1) dbody ++ ")"
        ]
    (name, WithPos _ (Nothing, dbody)) -> concat
        [ "(" ++ pretty' (d' + 1) name ++ "\n"
        , indent (d' + 1) ++ pretty' (d' + 1) dbody ++ ")"
        ]

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 :: Parsed.Pat -> String
prettyPat = \case
    Parsed.PConstruction _ (Parsed.Id (WithPos _ c)) ps ->
        if null ps then c else concat ["(", c, " ", spcPretty ps, ")"]
    Parsed.PInt _ n -> show n
    Parsed.PStr _ s -> prettyStr s
    Parsed.PVar v -> Parsed.idstr v
    Parsed.PBox _ p -> "(Box " ++ prettyPat p ++ ")"

prettyConst :: Parsed.Const -> String
prettyConst = \case
    Parsed.Int n -> show n
    Parsed.F64 x -> show x
    Parsed.Str s -> prettyStr s

prettyStr :: String -> String
prettyStr s = '"' : (s >>= showChar) ++ "\""
  where
    showChar = \case
        '\0' -> "\\0"
        '\a' -> "\\a"
        '\b' -> "\\b"
        '\t' -> "\\t"
        '\n' -> "\\n"
        '\v' -> "\\v"
        '\f' -> "\\f"
        '\r' -> "\\r"
        '\\' -> "\\\\"
        '\"' -> "\\\""
        c -> [c]

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