~jojo/Carth

87f18de1268b26d31f0b9e9f093d73ec39211714 — JoJo 1 year, 4 months ago 7811a09
Change formatting: 90 cols, IndentPolicyFree, etc. Add brittany.yaml

Most people have pretty wide and high res screens at this point. I
can't fit two windows with 100 line length next to eachother with my
font size, but 90 works and most people have smaller font size than me
I think.

Also, change brittanys indentation policy to Free. This almost always
looks better. I just had to disable formatting of imports -- I don't
want to align those, but IndentationPolicyFree insists.

Finally, actually add a project-local brittany config file, so that
anyone (or me in the future / on another computer) can use the same
formatting rules.
A brittany.yaml => brittany.yaml +20 -0
@@ 0,0 1,20 @@
conf_version: 1
conf_layout:
  lconfig_reformatModulePreamble: false
  lconfig_altChooser:
    tag: AltChooserBoundedSearch
    contents: 5
  lconfig_allowSingleLineExportList: true
  lconfig_importColumn: 50
  lconfig_hangingTypeSignature: false
  lconfig_importAsColumn: 50
  lconfig_alignmentLimit: 0
  lconfig_allowHangingQuasiQuotes: true
  lconfig_indentListSpecial: true
  lconfig_indentAmount: 4
  lconfig_alignmentBreakOnMultiline: true
  lconfig_cols: 90
  lconfig_indentPolicy: IndentPolicyFree
  lconfig_indentWhereSpecial: true
  lconfig_columnAlignMode:
    tag: ColumnAlignModeDisabled

M src/Check.hs => src/Check.hs +40 -79
@@ 42,9 42,8 @@ typecheck (Parsed.Program defs tdefs externs) = runExcept $ do
    let tdefs'' = fmap (second (map snd)) tdefs'
    pure (Checked.Program compiled tdefs'' externs')
  where
    checkMainDefined ds = when
        (not (elem "main" (map fst (Checked.flattenDefs ds))))
        (throwError MainNotDefined)
    checkMainDefined ds = when (not (elem "main" (map fst (Checked.flattenDefs ds))))
                               (throwError MainNotDefined)

type CheckTypeDefs a
    = ReaderT


@@ 52,19 51,12 @@ type CheckTypeDefs a
          (StateT (Inferred.TypeDefs, Inferred.Ctors) (Except TypeErr))
          a

checkTypeDefs
    :: [Parsed.TypeDef] -> Except TypeErr (Inferred.TypeDefs, Inferred.Ctors)
checkTypeDefs :: [Parsed.TypeDef] -> Except TypeErr (Inferred.TypeDefs, Inferred.Ctors)
checkTypeDefs tdefs = do
    let tdefsParams =
            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)
    let tdefsParams = 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)



@@ 81,8 73,7 @@ checkCtors
    -> Parsed.ConstructorDefs
    -> CheckTypeDefs [(Inferred.Id, [Inferred.Type])]
checkCtors parent (Parsed.ConstructorDefs cs) =
    let cspan = fromIntegral (length cs)
    in mapM (checkCtor cspan) (zip [0 ..] cs)
    let cspan = fromIntegral (length cs) in mapM (checkCtor cspan) (zip [0 ..] cs)
  where
    checkCtor cspan (i, (Id c'@(WithPos pos c), ts)) = do
        cAlreadyDefined <- gets (Map.member c . snd)


@@ 90,14 81,11 @@ checkCtors parent (Parsed.ConstructorDefs cs) =
        ts' <- mapM (checkType pos) ts
        modify (second (Map.insert c (i, parent, ts', cspan)))
        pure (c', ts')
    checkType pos t =
        ask >>= \tdefs -> checkType'' (\x -> Map.lookup x tdefs) pos t
    checkType pos t = ask >>= \tdefs -> checkType'' (\x -> Map.lookup x tdefs) pos t

builtinDataTypes :: Inferred.TypeDefs
builtinDataTypes = Map.fromList $ map
    (\(x, ps, cs) ->
        (x, (ps, map (first (WithPos (SrcPos "<builtin>" 0 0))) cs))
    )
    (\(x, ps, cs) -> (x, (ps, map (first (WithPos (SrcPos "<builtin>" 0 0))) cs)))
    builtinDataTypes'

builtinConstructors :: Inferred.Ctors


@@ 105,11 93,8 @@ builtinConstructors = Map.unions (map builtinConstructors' builtinDataTypes')
  where
    builtinConstructors' (x, ps, cs) =
        let cSpan = fromIntegral (length cs)
        in
            foldl'
                (\csAcc (i, (cx, cps)) ->
                    Map.insert cx (i, (x, ps), cps, cSpan) csAcc
                )
        in  foldl'
                (\csAcc (i, (cx, cps)) -> Map.insert cx (i, (x, ps), cps, cSpan) csAcc)
                Map.empty
                (zip [0 ..] cs)



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


@@ 141,8 120,7 @@ assertNoRec
assertNoRec tdefs' (x, (_, ctors)) = assertNoRec' ctors Map.empty
  where
    assertNoRec' cs s =
        forM_ cs $ \(WithPos cpos _, cts) ->
            forM_ cts (assertNoRecType cpos . subst s)
        forM_ cs $ \(WithPos cpos _, cts) -> forM_ cts (assertNoRecType cpos . subst s)
    assertNoRecType cpos = \case
        Inferred.TConst (y, ts) -> do
            when (x == y) $ throwError (RecTypeDef x cpos)


@@ 151,8 129,7 @@ assertNoRec tdefs' (x, (_, ctors)) = assertNoRec' ctors Map.empty
            assertNoRec' cs substs
        _ -> pure ()

checkExterns
    :: Inferred.TypeDefs -> [Parsed.Extern] -> Except TypeErr Inferred.Externs
checkExterns :: Inferred.TypeDefs -> [Parsed.Extern] -> Except TypeErr Inferred.Externs
checkExterns tdefs = fmap (Map.union Inferred.builtinExterns . Map.fromList)
    . mapM checkExtern
  where


@@ 216,67 193,51 @@ checkTypeVarsBound ds = runReaderT (boundInDefs ds) Set.empty
        Inferred.PBox p -> boundInPat p
    boundInCon pos (Con _ _ ts) = forM_ ts (boundInType pos)

compileDecisionTrees
    :: MTypeDefs -> Inferred.Defs -> Except TypeErr Checked.Defs
compileDecisionTrees :: MTypeDefs -> Inferred.Defs -> Except TypeErr Checked.Defs
compileDecisionTrees tdefs = compDefs
  where
    compDefs (Topo defs) = fmap Topo $ mapM compDef defs

    compDef :: Inferred.Def -> Except TypeErr Checked.Def
    compDef = \case
        Inferred.VarDef (lhs, WithPos p rhs) -> fmap
            (Checked.VarDef . (lhs, ) . WithPos p)
            (secondM compExpr rhs)
        Inferred.RecDefs ds ->
            fmap Checked.RecDefs $ flip mapM ds $ secondM $ mapPosdM
                (secondM compFunMatch)
        Inferred.VarDef (lhs, WithPos p rhs) ->
            fmap (Checked.VarDef . (lhs, ) . WithPos p) (secondM compExpr rhs)
        Inferred.RecDefs ds -> fmap Checked.RecDefs $ flip mapM ds $ secondM $ mapPosdM
            (secondM compFunMatch)

    compFunMatch
        :: WithPos Inferred.FunMatch -> Except TypeErr (WithPos Checked.Fun)
    compFunMatch :: WithPos Inferred.FunMatch -> Except TypeErr (WithPos Checked.Fun)
    compFunMatch (WithPos pos (cs, tp, tb)) = do
        cs' <- mapM (secondM compExpr) cs
        let p = "#x"
        fmap (WithPos pos)
            $ case runExceptT (toDecisionTree tdefs pos tp cs') of
                Nothing -> pure ((p, tp), (noPos (Checked.Absurd tb), tb))
                Just e -> do
                    dt <- liftEither e
                    let v = noPos (Checked.Var (Checked.TypedVar p tp))
                        b = noPos (Checked.Match v dt tb)
                    pure ((p, tp), (b, tb))
        fmap (WithPos pos) $ case runExceptT (toDecisionTree tdefs pos tp cs') of
            Nothing -> pure ((p, tp), (noPos (Checked.Absurd tb), tb))
            Just e -> do
                dt <- liftEither e
                let v = noPos (Checked.Var (Checked.TypedVar p tp))
                    b = noPos (Checked.Match v dt tb)
                pure ((p, tp), (b, tb))

    compExpr :: Inferred.Expr -> Except TypeErr Checked.Expr
    compExpr (WithPos pos ex) = fmap (withPos pos) $ case ex of
        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.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 ld b -> liftA2 Checked.Let (compDef ld) (compExpr b)
        Inferred.FunMatch fm ->
            fmap (Checked.Fun . unpos) (compFunMatch (WithPos pos fm))
        Inferred.Ctor v span' inst ts ->
            let
                xs = map
                    (\n -> "x" ++ show n)
                    (take (length ts) [0 ..] :: [Word])
            let xs = map (\n -> "x" ++ show n) (take (length ts) [0 ..] :: [Word])
                params = zip xs ts
                args = map
                    (noPos . Checked.Var . uncurry Checked.TypedVar)
                    params
            in pure $ snd $ foldr
                (\(p, pt) (bt, b) ->
                    ( Inferred.TFun pt bt
                    , Checked.Fun ((p, pt), (noPos b, bt))
                args = map (noPos . Checked.Var . uncurry Checked.TypedVar) params
            in  pure $ snd $ foldr
                    (\(p, pt) (bt, b) ->
                        (Inferred.TFun pt bt, Checked.Fun ((p, pt), (noPos b, bt)))
                    )
                )
                (Inferred.TConst inst, Checked.Ction v span' inst args)
                params
                    (Inferred.TConst inst, Checked.Ction v span' inst args)
                    params
        Inferred.Sizeof t -> pure (Checked.Sizeof t)
        Inferred.Deref x -> fmap Checked.Deref (compExpr x)
        Inferred.Store x p ->
            liftA2 Checked.Store (compExpr x) (compExpr p)
        Inferred.Transmute x t u ->
            compExpr x <&> \x' -> Checked.Transmute pos x' t u
        Inferred.Store x p -> liftA2 Checked.Store (compExpr x) (compExpr p)
        Inferred.Transmute x t u -> compExpr x <&> \x' -> Checked.Transmute pos x' t u

M src/Checked.hs => src/Checked.hs +1 -2
@@ 103,5 103,4 @@ defToVarDefs = \case
    RecDefs ds -> map funDefToVarDef ds

funDefToVarDef :: (String, WithPos (Scheme, WithPos Fun)) -> VarDef
funDefToVarDef =
    second (mapPosd (second (\(WithPos p f) -> Expr (Just p) (Fun f))))
funDefToVarDef = second (mapPosd (second (\(WithPos p f) -> Expr (Just p) (Fun f))))

M src/Codegen.hs => src/Codegen.hs +73 -114
@@ 41,44 41,42 @@ import Extern


codegen :: DataLayout -> FilePath -> Program -> Either GenErr Module
codegen layout moduleFilePath (Program (Topo defs) tdefs externs) =
    runExcept $ do
        (tdefs', externs', globDefs) <-
            let
                (enums, tdefs'') =
                    runIdentity (runGen' (defineDataTypes tdefs))
                defs' = defToVarDefs =<< defs
                (funDefs, varDefs) = separateFunDefs defs'
            in
                runGen'
                $ augment enumTypes enums
                $ augment dataTypes tdefs''
                $ withBuiltins
                $ withExternSigs externs
                $ withGlobDefSigs (map (second unpos) defs')
                $ do
                    es <- genExterns externs
                    funDefs' <- mapM genGlobFunDef funDefs
                    varDecls <- mapM genGlobVarDecl varDefs
                    init_ <- genInit varDefs
                    main <- genMain
                    let ds = main : init_ : join funDefs' ++ varDecls
                    pure (tdefs'', es, ds)
        pure $ Module
            { moduleName = fromString ((takeBaseName moduleFilePath))
            , moduleSourceFileName = fromString moduleFilePath
            , moduleDataLayout = Just layout
            , moduleTargetTriple = Nothing
            , moduleDefinitions = concat
                [ map
                    (\(n, tmax) -> TypeDefinition n (Just (typeStruct tmax)))
                    (Map.toList tdefs')
                , defineBuiltinsHidden
                , externs'
                , globDefs
                , globMetadataDefs
                ]
            }
codegen layout moduleFilePath (Program (Topo defs) tdefs externs) = runExcept $ do
    (tdefs', externs', globDefs) <-
        let (enums, tdefs'') = runIdentity (runGen' (defineDataTypes tdefs))
            defs' = defToVarDefs =<< defs
            (funDefs, varDefs) = separateFunDefs defs'
        in  runGen'
            $ augment enumTypes enums
            $ augment dataTypes tdefs''
            $ withBuiltins
            $ withExternSigs externs
            $ withGlobDefSigs (map (second unpos) defs')
            $ do
                  es <- genExterns externs
                  funDefs' <- mapM genGlobFunDef funDefs
                  varDecls <- mapM genGlobVarDecl varDefs
                  init_ <- genInit varDefs
                  main <- genMain
                  let ds = main : init_ : join funDefs' ++ varDecls
                  pure (tdefs'', es, ds)
    pure $ Module
        { moduleName = fromString ((takeBaseName moduleFilePath))
        , moduleSourceFileName = fromString moduleFilePath
        , moduleDataLayout = Just layout
        , moduleTargetTriple = Nothing
        , moduleDefinitions = concat
                                  [ map
                                      (\(n, tmax) ->
                                          TypeDefinition n (Just (typeStruct tmax))
                                      )
                                      (Map.toList tdefs')
                                  , defineBuiltinsHidden
                                  , externs'
                                  , globDefs
                                  , globMetadataDefs
                                  ]
        }
  where
    withGlobDefSigs sigs ga = do
        sigs' <- forM sigs $ \(v@(TypedVar x t), (us, _)) -> do


@@ 96,8 94,7 @@ codegen layout moduleFilePath (Program (Topo defs) tdefs externs) =
    globMetadataDefs =
        [ MetadataNodeDefinition compileUnitId
            $ DINode (LLOp.DIScope (LLOp.DICompileUnit compileUnitDef))
        , MetadataNodeDefinition fileId
            $ DINode (LLOp.DIScope (LLOp.DIFile fileDef))
        , MetadataNodeDefinition fileId $ DINode (LLOp.DIScope (LLOp.DIFile fileDef))
        , MetadataNodeDefinition debugInfoVersionId $ MDTuple
            [ Just (MDValue (litI32 2))
            , Just (MDString "Debug Info Version")


@@ 107,8 104,7 @@ codegen layout moduleFilePath (Program (Topo defs) tdefs externs) =
        , NamedMetadataDefinition "llvm.module.flags" [debugInfoVersionId]
        ]
    compileUnitDef = LLCompunit.CompileUnit
        { LLCompunit.language =
            let unstandardized_c = 1 in unstandardized_c
        { LLCompunit.language = let unstandardized_c = 1 in unstandardized_c
        , LLCompunit.file = MDRef fileId
        , LLCompunit.producer = "carth version alpha"
        , LLCompunit.optimized = False


@@ 129,12 125,10 @@ codegen layout moduleFilePath (Program (Topo defs) tdefs externs) =
        }
    fileDef =
        let (dir, file) = splitFileName moduleFilePath
        in
            LLOp.File
                { LLSubprog.filename = fromString file
                , LLSubprog.directory = fromString dir
                , LLSubprog.checksum = Nothing
                }
        in  LLOp.File { LLSubprog.filename = fromString file
                      , LLSubprog.directory = fromString dir
                      , LLSubprog.checksum = Nothing
                      }

-- | A data-type is a tagged union, and we represent it in LLVM as a struct
--   where, if there are more than 1 variant, the first element is the


@@ 162,13 156,13 @@ defineDataTypes tds = do
            $ augment dataTypes datas'
            $ forM datas
            $ \(tc, vs) -> do
                let n = mkName (mangleTConst tc)
                let totVariants = fromIntegral (length vs)
                ts <- mapM (genVariantType totVariants) vs
                sizedTs <- mapM (\t -> sizeof (typeStruct t) <&> (, t)) ts
                if null sizedTs
                    then ice ("defineDataTypes: sizedTs empty for " ++ show n)
                    else pure (n, snd (maximum sizedTs))
                  let n = mkName (mangleTConst tc)
                  let totVariants = fromIntegral (length vs)
                  ts <- mapM (genVariantType totVariants) vs
                  sizedTs <- mapM (\t -> sizeof (typeStruct t) <&> (, t)) ts
                  if null sizedTs
                      then ice ("defineDataTypes: sizedTs empty for " ++ show n)
                      else pure (n, snd (maximum sizedTs))
    pure (enums', datas'')

genMain :: Gen' Definition


@@ 258,8 252,7 @@ genExpr (Expr pos expr) = locally srcPos (pos <|>) $ do
        Let d b -> genLet d b
        Match e cs tbody -> genMatch e cs =<< genType tbody
        Ction c -> genCtion c
        Sizeof t ->
            (VLocal . litI64 . fromIntegral) <$> ((lift . sizeof) =<< genType t)
        Sizeof t -> (VLocal . litI64 . fromIntegral) <$> ((lift . sizeof) =<< genType t)
        Deref e -> genDeref e
        Store x p -> genStore x p
        Absurd t -> fmap (VLocal . undef) (genType t)


@@ 281,8 274,7 @@ genStrLit :: String -> Gen Val
genStrLit s = do
    var <- newName "strlit"
    scribe outStrings [(var, s)]
    pure $ VVar $ ConstantOperand
        (LLConst.GlobalReference (LLType.ptr typeStr) var)
    pure $ VVar $ ConstantOperand (LLConst.GlobalReference (LLType.ptr typeStr) var)

genTailApp :: Expr -> Expr -> Gen ()
genTailApp fe' ae' =


@@ 373,18 365,11 @@ genLet' def genBody = case def of
        (binds, cs) <- fmap unzip $ forM ds $ \case
            (lhs, WithPos _ (_, (p, (fb, fbt)))) -> do
                let fvXs = Set.toList (Set.delete p (freeVars fb))
                tcaptures <- fmap
                    typeStruct
                    (mapM (\(TypedVar _ t) -> genType t) fvXs)
                tcaptures <- fmap typeStruct (mapM (\(TypedVar _ t) -> genType t) fvXs)
                captures <- genHeapAllocGeneric tcaptures
                fbt' <- genRetType fbt
                lam <-
                    getVar
                        =<< genLambda'
                                p
                                (genTailExpr fb, fbt')
                                (VLocal captures)
                                fvXs
                    getVar =<< genLambda' p (genTailExpr fb, fbt') (VLocal captures) fvXs
                pure ((lhs, lam), (captures, fvXs))
        withVars binds $ do
            forM_ cs (uncurry populateCaptures)


@@ 423,8 408,7 @@ genDecisionTree'
    -> Selections Operand
    -> Gen a
genDecisionTree' genExpr' genCondBr' genCases' tbody =
    let
        genDecisionLeaf (bs, e) selections = do
    let genDecisionLeaf (bs, e) selections = do
            bs' <- selectVarBindings selAs selSub selDeref selections bs
            withLocals bs' (genExpr' e)



@@ 436,21 420,14 @@ genDecisionTree' genExpr' genCondBr' genCases' tbody =
                _ -> emitReg "found_variant_ix" =<< extractvalue m [0]
            let ixBits = getIntBitWidth (typeOf mVariantIx)
            let litIxInt = LLConst.Int ixBits
            variantLs <- mapM
                (newName . (++ "_") . ("variant_" ++) . show)
                variantIxs
            variantLs <- mapM (newName . (++ "_") . ("variant_" ++) . show) variantIxs
            defaultL <- newName "default"
            let dests' = zip (map litIxInt variantIxs) variantLs
            commitToNewBlock (switch mVariantIx defaultL dests') defaultL
            genCases' tbody selections' variantLs variantDts def

        genDecisionSwitchStr selector cs def selections = do
            (matchee, selections') <- select
                selAs
                selSub
                selDeref
                selector
                selections
            (matchee, selections') <- select selAs selSub selDeref selector selections
            let cs' = Map.toAscList cs
            let genCase (s, dt) next = do
                    s' <- genStrLit s


@@ 462,17 439,11 @@ genDecisionTree' genExpr' genCondBr' genCases' tbody =
        genDT = \case
            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
            M.DSwitchStr selector cs def -> genDecisionSwitchStr selector cs def
    in  genDT

genTailCases
    :: Type
    -> Selections Operand
    -> [Name]
    -> [DecisionTree]
    -> DecisionTree
    -> Gen ()
    :: Type -> Selections Operand -> [Name] -> [DecisionTree] -> DecisionTree -> Gen ()
genTailCases tbody selections variantLs variantDts def = do
    genTailDecisionTree tbody def selections
    forM_ (zip variantLs variantDts) $ \(l, dt) -> do


@@ 480,18 451,12 @@ genTailCases tbody selections variantLs variantDts def = do
        genTailDecisionTree tbody dt selections

genCases
    :: Type
    -> Selections Operand
    -> [Name]
    -> [DecisionTree]
    -> DecisionTree
    -> Gen Val
    :: Type -> Selections Operand -> [Name] -> [DecisionTree] -> DecisionTree -> Gen Val
genCases tbody selections variantLs variantDts def = do
    nextL <- newName "next"
    let genDT dt = liftA2
            (,)
            (getLocal =<< genDecisionTree tbody dt selections)
            (use currentBlockLabel)
    let genDT dt = liftA2 (,)
                          (getLocal =<< genDecisionTree tbody dt selections)
                          (use currentBlockLabel)
    v <- genDT def
    let genCase l dt = do
            commitToNewBlock (br nextL) l


@@ 512,7 477,7 @@ selAs totVariants ts matchee = do
selSub :: Span -> Word32 -> Operand -> Gen Operand
selSub span' i matchee =
    let tagOffset = if span' > 1 then 1 else 0
    in emitReg "submatchee" =<< extractvalue matchee (pure (tagOffset + i))
    in  emitReg "submatchee" =<< extractvalue matchee (pure (tagOffset + i))

selDeref :: Operand -> Gen Operand
selDeref x = emitAnonReg (load x)


@@ 524,17 489,14 @@ genCtion (i, span', dataType, as) = do
        Just w -> pure (VLocal (ConstantOperand (LLConst.Int w i)))
        Nothing -> do
            as' <- mapM genExpr as
            let tag = maybe
                    id
                    ((:) . VLocal . ConstantOperand . flip LLConst.Int i)
                    (tagBitWidth span')
            let tag = maybe id
                            ((:) . VLocal . ConstantOperand . flip LLConst.Int i)
                            (tagBitWidth span')
            s <- getLocal =<< genStruct (tag as')
            let t = typeOf s
            let tgeneric = genDatatypeRef dataType
            pGeneric <- emitReg "ction_ptr_nominal" (alloca tgeneric)
            p <- emitReg
                "ction_ptr_structural"
                (bitcast pGeneric (LLType.ptr t))
            p <- emitReg "ction_ptr_structural" (bitcast pGeneric (LLType.ptr t))
            emitDo (store s p)
            pure (VVar pGeneric)



@@ 581,9 543,8 @@ transmute t u x = case (t, u) of
    (IntegerType _, FloatingPointType _) -> bitcast'
    (IntegerType _, VectorType _ _) -> bitcast'

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


@@ 593,9 554,8 @@ transmute t u x = case (t, u) of
    (FloatingPointType _, IntegerType _) -> bitcast'
    (FloatingPointType _, VectorType _ _) -> bitcast'

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



@@ 608,8 568,7 @@ transmute t u x = case (t, u) of
  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
    stackCast = getVar x >>= \x' -> emitAnonReg (bitcast x' (LLType.ptr u)) <&> VVar

genStrEq :: Val -> Val -> Gen Val
genStrEq s1 s2 = do

M src/Compile.hs => src/Compile.hs +46 -59
@@ 69,22 69,20 @@ handleProgram f file cfg pgm = withContext $ \ctx ->
            flip
                    catch
                    (\case
                        EncodeException msg ->
                            ice $ "LLVM encode exception:\n" ++ msg
                        EncodeException msg -> ice $ "LLVM encode exception:\n" ++ msg
                    )
                $ withModuleFromAST ctx amod
                $ \mod -> do
                    verbose cfg ("   Verifying LLVM")
                    when (getDebug cfg) $ writeLLVMAssemblyToFile' ".dbg.ll" mod
                    catch (verify mod) $ \case
                        VerifyException msg ->
                            ice $ "LLVM verification exception:\n" ++ msg
                    withPassManager (optPasses optLvl tm) $ \passman -> do
                        verbose cfg "   Optimizing"
                        _ <- runPassManager passman mod
                        when (getDebug cfg)
                            $ writeLLVMAssemblyToFile' ".dbg.opt.ll" mod
                        f cfg tm mod
                      verbose cfg ("   Verifying LLVM")
                      when (getDebug cfg) $ writeLLVMAssemblyToFile' ".dbg.ll" mod
                      catch (verify mod) $ \case
                          VerifyException msg ->
                              ice $ "LLVM verification exception:\n" ++ msg
                      withPassManager (optPasses optLvl tm) $ \passman -> do
                          verbose cfg "   Optimizing"
                          _ <- runPassManager passman mod
                          when (getDebug cfg) $ 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


@@ 159,28 157,23 @@ orcJitModule cfg tm mod = do
--   running process, which includes all shared object code added with
--   `Linking.loadLibraryPermanently`. Disjoint from the compile and linking
--   layer.
resolver
    :: CompileLayer cl
    => cl
    -> MangledSymbol
    -> IO (Either JITSymbolError JITSymbol)
resolver :: CompileLayer cl => cl -> MangledSymbol -> IO (Either JITSymbolError JITSymbol)
resolver compLay symb =
    let
        flags = JITSymbolFlags
            { jitSymbolWeak = False
            , jitSymbolCommon = False
            , jitSymbolAbsolute = False
            , jitSymbolExported = True
            }
        flags = JITSymbolFlags { jitSymbolWeak = False
                               , jitSymbolCommon = False
                               , jitSymbolAbsolute = False
                               , jitSymbolExported = True
                               }
        err = fromString ("Error resolving symbol: " ++ show symb)
        findInLlvmModules = CL.findSymbol compLay symb False
        findInSharedObjects = getSymbolAddressInProcess symb <&> \addr ->
            if addr == 0
                then Left (JITSymbolError err)
                else Right (JITSymbol addr flags)
    in findInLlvmModules >>= \case
        Right js -> pure (Right js)
        Left _ -> findInSharedObjects
        findInSharedObjects = getSymbolAddressInProcess symb <&> \addr -> if addr == 0
            then Left (JITSymbolError err)
            else Right (JITSymbol addr flags)
    in
        findInLlvmModules >>= \case
            Right js -> pure (Right js)
            Left _ -> findInSharedObjects

-- | `writeLLVMAssemblyToFile` doesn't clear file contents before writing,
--   so this is a workaround.


@@ 198,38 191,32 @@ withMyTargetMachine codeGenOpt f = do
    (target, _) <- lookupTarget Nothing triple
    withTargetOptions $ \toptions -> do
        options <- peekTargetOptions toptions
        pokeTargetOptions
            (options { guaranteedTailCallOptimization = True })
            toptions
        withTargetMachine
            target
            triple
            cpu
            features
            toptions
            Reloc.PIC
            CodeModel.Default
            codeGenOpt
            f
        pokeTargetOptions (options { guaranteedTailCallOptimization = True }) toptions
        withTargetMachine target
                          triple
                          cpu
                          features
                          toptions
                          Reloc.PIC
                          CodeModel.Default
                          codeGenOpt
                          f

optPasses :: CodeGenOpt.Level -> TargetMachine -> PassSetSpec
optPasses level tm =
    let
        levelN = case level of
    let levelN = case level of
            CodeGenOpt.None -> 0
            CodeGenOpt.Less -> 1
            CodeGenOpt.Default -> 2
            CodeGenOpt.Aggressive -> 3
    in
        CuratedPassSetSpec
            { optLevel = Just levelN
            , sizeLevel = Nothing
            , unitAtATime = Nothing
            , simplifyLibCalls = Nothing
            , loopVectorize = Nothing
            , superwordLevelParallelismVectorize = Nothing
            , useInlinerWithThreshold = Nothing
            , dataLayout = Nothing
            , targetLibraryInfo = Nothing
            , targetMachine = Just tm
            }
    in  CuratedPassSetSpec { optLevel = Just levelN
                           , sizeLevel = Nothing
                           , unitAtATime = Nothing
                           , simplifyLibCalls = Nothing
                           , loopVectorize = Nothing
                           , superwordLevelParallelismVectorize = Nothing
                           , useInlinerWithThreshold = Nothing
                           , dataLayout = Nothing
                           , targetLibraryInfo = Nothing
                           , targetMachine = Just tm
                           }

M src/Conf.hs => src/Conf.hs +1 -8
@@ 1,11 1,4 @@
module Conf
    ( Conf(..)
    , CompileConfig(..)
    , RunConfig(..)
    , verbose
    , Config(..)
    )
where
module Conf (Conf(..), CompileConfig(..), RunConfig(..), verbose, Config(..)) where

import Control.Monad


M src/Err.hs => src/Err.hs +7 -15
@@ 26,10 26,7 @@ printTypeErr = \case
            ++ ("` in pattern.\nExpected " ++ show arity)
            ++ (", found " ++ show nArgs)
    ConflictingPatVarDefs p v ->
        posd p
            $ "Conflicting definitions for variable `"
            ++ v
            ++ "` in pattern."
        posd p $ "Conflicting definitions for variable `" ++ v ++ "` in pattern."
    UndefCtor p c -> posd p $ "Undefined constructor `" ++ c ++ "`"
    UndefVar p v -> posd p $ "Undefined variable `" ++ v ++ "`"
    InfType p t1 t2 a t ->


@@ 43,8 40,7 @@ printTypeErr = \case
            $ ("Couldn't match type " ++ pretty t'2 ++ " with " ++ pretty t'1)
            ++ (".\nExpected type: " ++ pretty t1)
            ++ (".\nFound type: " ++ pretty t2 ++ ".")
    ConflictingTypeDef p x ->
        posd p $ "Conflicting definitions for type `" ++ x ++ "`."
    ConflictingTypeDef p x -> posd p $ "Conflicting definitions for type `" ++ x ++ "`."
    ConflictingCtorDef p x ->
        posd p $ "Conflicting definitions for constructor `" ++ x ++ "`."
    RedundantCase p -> posd p $ "Redundant case in pattern match."


@@ 73,8 69,7 @@ printTypeErr = \case
            ++ ("Expected: " ++ pretty mainType)
            ++ ("\nFound: " ++ pretty s)
    RecursiveVarDef (WithPos p x) ->
        posd p
            $ ("Non-function variable definition `" ++ x ++ "` is recursive.")
        posd p $ ("Non-function variable definition `" ++ x ++ "` is recursive.")
    TypeInstArityMismatch p t expected found ->
        posd p
            $ ("Arity mismatch for instantiation of type `" ++ t)


@@ 105,15 100,12 @@ posd (pos@(SrcPos f lineN colN)) msg = do
        rest = if (colN' <= length line)
            then drop (colN' - 1) line
            else
                ice
                $ "col num in SourcePos is greater than "
                ++ "num of cols in src line"
                ice $ "col num in SourcePos is greater than " ++ "num of cols in src line"
        lineNS = show lineN'
        pad = length lineNS + 1
        s = either
            (\e -> ice ("posd: msg=|" ++ msg ++ "|,err=|" ++ show e ++ "|"))
            id
            (parseTokenTreeOrRest rest)
        s = either (\e -> ice ("posd: msg=|" ++ msg ++ "|,err=|" ++ show e ++ "|"))
                   id
                   (parseTokenTreeOrRest rest)
    putStrLn $ unlines
        [ prettySrcPos pos ++ ": Error:"
        , indent pad ++ "|"

M src/Extern.hs => src/Extern.hs +16 -32
@@ 46,9 46,8 @@ withExternSigs es ga = do
        t' <- genType' t
        pure
            ( TypedVar name t
            , ConstantOperand $ LLConst.GlobalReference
                (LLType.ptr t')
                (mkName ("_wrapper_" ++ name))
            , ConstantOperand
                $ LLConst.GlobalReference (LLType.ptr t') (mkName ("_wrapper_" ++ name))
            )
    augment env (Map.fromList es') ga



@@ 79,25 78,20 @@ genWrapper pos externName rt paramTs =
                    passByRef rt >>= \case
                        True -> do
                            out <- emitReg "out" (alloca rt)
                            let
                                f = ConstantOperand $ LLConst.GlobalReference
                                    (LLType.ptr $ FunctionType
                                        LLType.void
                                        (typeOf out : ats)
                                        False
                            let f = ConstantOperand $ LLConst.GlobalReference
                                    (LLType.ptr $ FunctionType LLType.void
                                                               (typeOf out : ats)
                                                               False
                                    )
                                    fname
                            emitDo $ callExtern f ((out, [SRet]) : as)
                            pure (VVar out)
                        False ->
                            let
                                f = ConstantOperand $ LLConst.GlobalReference
                            let f = ConstantOperand $ LLConst.GlobalReference
                                    (LLType.ptr $ FunctionType rt ats False)
                                    fname
                            in
                                if rt == LLType.void
                                    then emitDo (callExtern f as)
                                        $> VLocal litUnit
                            in  if rt == LLType.void
                                    then emitDo (callExtern f as) $> VLocal litUnit
                                    else fmap VLocal $ emitAnonReg $ WithRetType
                                        (callExtern f as)
                                        rt


@@ 108,30 102,20 @@ genWrapper pos externName rt paramTs =
                        (p : ps) -> do
                            pts <- mapM (\(TypedVar _ t) -> genType t) ps
                            let bt = foldr closureType rt pts
                            genLambda
                                fvs
                                p
                                (genWrapper' (fvs ++ [p]) ps $> (), bt)
                            genLambda fvs p (genWrapper' (fvs ++ [p]) ps $> (), bt)
                    if typeOf r == typeUnit
                        then commitFinalFuncBlock retVoid $> LLType.void
                        else commitFinalFuncBlock (ret r) $> typeOf r
            let wrapperName = "_wrapper_" ++ externName
            assign lambdaParentFunc (Just wrapperName)
            let fname = mkName (wrapperName ++ "_func")
            (f, gs) <-
                locallySet srcPos (Just pos)
                    $ genFunDef
                        ( fname
                        , []
                        , pos
                        , firstParam
                        , genWrapper' [firstParam] restParams
                        )
            (f, gs) <- locallySet srcPos (Just pos)
                $ genFunDef
                      (fname, [], pos, firstParam, genWrapper' [firstParam] restParams)
            let fref = LLConst.GlobalReference (LLType.ptr (typeOf f)) fname
            let captures = LLConst.Null (LLType.ptr typeUnit)
            let closure = litStruct [captures, fref]
            let closureDef = simpleGlobConst
                    (mkName ("_wrapper_" ++ externName))
                    (typeOf closure)
                    closure
            let closureDef = simpleGlobConst (mkName ("_wrapper_" ++ externName))
                                             (typeOf closure)
                                             closure
            pure (GlobalDefinition closureDef : GlobalDefinition f : gs)

M src/Gen.hs => src/Gen.hs +144 -188
@@ 119,33 119,28 @@ instance Typed Val where
--
--   The signature definition, the parameter-loading, and the result return are
--   all done according to the calling convention.
genFunDef
    :: (Name, [TypedVar], SrcPos, TypedVar, Gen Type)
    -> Gen' (Global, [Definition])
genFunDef :: (Name, [TypedVar], SrcPos, TypedVar, Gen Type) -> Gen' (Global, [Definition])
genFunDef (name, fvs, dpos, ptv@(TypedVar px pt), genBody) = do
    assign currentBlockLabel (mkName "entry")
    assign currentBlockInstrs []
    ((rt, fParams), Out basicBlocks globStrings lambdaFuncs srcPoss) <-
        runWriterT $ do
    ((rt, fParams), Out basicBlocks globStrings lambdaFuncs srcPoss) <- runWriterT $ do
            -- Two equal SrcPos's in different scopes are not equal at the
            -- metadata level. Reset cache every scope.
            assign srcPosToMetadata Map.empty
            (capturesParam, captureLocals) <- genExtractCaptures
            pt' <- genType pt
            px' <- newName px
            let pRef = LocalReference pt' px'
            rt' <- withLocal ptv pRef (withLocals captureLocals genBody)
            let fParams' =
                    [uncurry Parameter capturesParam [], Parameter pt' px' []]
            pure (rt', fParams')
        assign srcPosToMetadata Map.empty
        (capturesParam, captureLocals) <- genExtractCaptures
        pt' <- genType pt
        px' <- newName px
        let pRef = LocalReference pt' px'
        rt' <- withLocal ptv pRef (withLocals captureLocals genBody)
        let fParams' = [uncurry Parameter capturesParam [], Parameter pt' px' []]
        pure (rt', fParams')
    (funScopeMdId, funScopeMdDef) <- defineFunScopeMetadata
    ss <- mapM globStrVar globStrings
    ls <- fmap
        concat
        (mapM (fmap (uncurry ((:) . GlobalDefinition)) . genFunDef) lambdaFuncs)
    ps <- mapM (defineSrcPos (MDRef funScopeMdId)) srcPoss
    let f =
            internFunc name fParams rt basicBlocks [("dbg", MDRef funScopeMdId)]
    let f = internFunc name fParams rt basicBlocks [("dbg", MDRef funScopeMdId)]
    pure (f, concat ss ++ ls ++ (funScopeMdDef : ps))
  where
    globStrVar (strName, s) = do


@@ 153,23 148,18 @@ genFunDef (name, fvs, dpos, ptv@(TypedVar px pt), genBody) = do
        let bytes = UTF8.String.encode s
            len = length bytes
            tInner = ArrayType (fromIntegral len) i8
            defInner = simpleGlobConst
                name_inner
                tInner
                (LLConst.Array i8 (map litI8' bytes))
            defInner =
                simpleGlobConst name_inner tInner (LLConst.Array i8 (map litI8' bytes))
            inner = LLConst.GlobalReference (LLType.ptr tInner) name_inner
            ptrBytes = LLConst.BitCast inner (LLType.ptr i8)
            array = litStructNamed
                ("Array", [M.TPrim TNat8])
                [ptrBytes, litI64' len]
            array = litStructNamed ("Array", [M.TPrim TNat8]) [ptrBytes, litI64' len]
            str = litStructNamed ("Str", []) [array]
            defStr = simpleGlobConst strName typeStr str
        pure (map GlobalDefinition [defInner, defStr])
    genExtractCaptures = do
        capturesName <- newName "captures"
        let capturesPtrGenericType = LLType.ptr typeUnit
        let capturesPtrGeneric =
                LocalReference capturesPtrGenericType capturesName
        let capturesPtrGeneric = LocalReference capturesPtrGenericType capturesName
        let capturesParam = (capturesPtrGenericType, capturesName)
        fmap (capturesParam, ) $ if null fvs
            then pure []


@@ 179,9 169,7 @@ genFunDef (name, fvs, dpos, ptv@(TypedVar px pt), genBody) = do
                    (bitcast capturesPtrGeneric (LLType.ptr capturesType))
                captures <- emitAnonReg (load capturesPtr)
                captureVals <- mapM
                    (\(TypedVar x _, i) ->
                        emitReg x =<< extractvalue captures [i]
                    )
                    (\(TypedVar x _, i) -> emitReg x =<< extractvalue captures [i])
                    (zip fvs [0 ..])
                pure (zip fvs captureVals)
    defineSrcPos funScopeMdRef (SrcPos _ line col, mdId) = do


@@ 202,40 190,36 @@ genFunDef (name, fvs, dpos, ptv@(TypedVar px pt), genBody) = do
                )
            )
    funMetadataSubprog =
        let
            SrcPos path line _ = dpos
        let SrcPos path line _ = dpos
            -- TODO: Maybe only define this once and cache MDRef somewhere?
            fileNode =
                let (dir, file) = splitFileName path
                in
                    LLSubprog.File
                        { LLSubprog.filename = fromString file
                        , LLSubprog.directory = fromString dir
                        , LLSubprog.checksum = Nothing
                        }
        in LLOp.Subprogram
            { LLSubprog.scope = Just (MDInline (LLOp.DIFile fileNode))
            , LLSubprog.name = nameSBString name
            , LLSubprog.linkageName = nameSBString name
            , LLSubprog.file = Just (MDInline fileNode)
            , LLSubprog.line = fromIntegral line
            , LLSubprog.type' = Just
                (MDInline (LLOp.SubroutineType [] 0 []))
            , LLSubprog.localToUnit = True
            , LLSubprog.definition = True
            , LLSubprog.scopeLine = fromIntegral line
            , LLSubprog.containingType = Nothing
            , LLSubprog.virtuality = LLOp.NoVirtuality
            , LLSubprog.virtualityIndex = 0
            , LLSubprog.thisAdjustment = 0
            , LLSubprog.flags = []
            , LLSubprog.optimized = False
            , LLSubprog.unit = Just compileUnitRef
            , LLSubprog.templateParams = []
            , LLSubprog.declaration = Nothing
            , LLSubprog.retainedNodes = []
            , LLSubprog.thrownTypes = []
            }
                    let (dir, file) = splitFileName path
                    in  LLSubprog.File { LLSubprog.filename = fromString file
                                       , LLSubprog.directory = fromString dir
                                       , LLSubprog.checksum = Nothing
                                       }
        in  LLOp.Subprogram
                { LLSubprog.scope = Just (MDInline (LLOp.DIFile fileNode))
                , LLSubprog.name = nameSBString name
                , LLSubprog.linkageName = nameSBString name
                , LLSubprog.file = Just (MDInline fileNode)
                , LLSubprog.line = fromIntegral line
                , LLSubprog.type' = Just (MDInline (LLOp.SubroutineType [] 0 []))
                , LLSubprog.localToUnit = True
                , LLSubprog.definition = True
                , LLSubprog.scopeLine = fromIntegral line
                , LLSubprog.containingType = Nothing
                , LLSubprog.virtuality = LLOp.NoVirtuality
                , LLSubprog.virtualityIndex = 0
                , LLSubprog.thisAdjustment = 0
                , LLSubprog.flags = []
                , LLSubprog.optimized = False
                , LLSubprog.unit = Just compileUnitRef
                , LLSubprog.templateParams = []
                , LLSubprog.declaration = Nothing
                , LLSubprog.retainedNodes = []
                , LLSubprog.thrownTypes = []
                }
    nameSBString = \case
        Name s -> s
        UnName n -> fromString (show n)


@@ 256,9 240,7 @@ genLambda fvXs p body = do
    captures <- if null fvXs
        then pure (null' (LLType.ptr typeUnit))
        else do
            tcaptures <- fmap
                typeStruct
                (mapM (\(TypedVar _ t) -> genType t) fvXs)
            tcaptures <- fmap typeStruct (mapM (\(TypedVar _ t) -> genType t) fvXs)
            captures' <- genHeapAllocGeneric tcaptures
            populateCaptures captures' fvXs
            pure captures'


@@ 273,14 255,10 @@ populateCaptures ptrGeneric fvXs = do
genLambda' :: TypedVar -> (Gen (), Type) -> Val -> [TypedVar] -> Gen Val
genLambda' p@(TypedVar _ pt) (b, bt) captures fvXs = do
    fname <- use lambdaParentFunc >>= \case
        Just s ->
            fmap (mkName . ((s ++ "_func_") ++) . show) (outerLambdaN <<+= 1)
        Just s -> fmap (mkName . ((s ++ "_func_") ++) . show) (outerLambdaN <<+= 1)
        Nothing -> newName "func"
    ft <- genType pt <&> \pt' -> closureFunType pt' bt
    let
        f = VLocal $ ConstantOperand $ LLConst.GlobalReference
            (LLType.ptr ft)
            fname
    let f = VLocal $ ConstantOperand $ LLConst.GlobalReference (LLType.ptr ft) fname
    pos <- view (srcPos . to (fromMaybe (ice "srcPos is Nothing in genLambda")))
    scribe outFuncs [(fname, fvXs, pos, p, b $> bt)]
    genStruct [captures, f]


@@ 294,24 272,22 @@ compileUnitId = MetadataNodeID 0
runGen' :: Monad m => StateT St (ReaderT Env m) a -> m a
runGen' g = runReaderT (evalStateT g initSt) initEnv
  where
    initEnv = Env
        { _env = Map.empty
        , _enumTypes = Map.empty
        , _dataTypes = Map.empty
        , _builtins = Map.empty
        , _srcPos = Nothing
        }
    initSt = St
        { _currentBlockLabel = "entry"
        , _currentBlockInstrs = []
        , _registerCount = 0
        , _metadataCount = 3
        , _lambdaParentFunc = Nothing
        , _outerLambdaN = 1
    initEnv = Env { _env = Map.empty
                  , _enumTypes = Map.empty
                  , _dataTypes = Map.empty
                  , _builtins = Map.empty
                  , _srcPos = Nothing
                  }
    initSt = St { _currentBlockLabel = "entry"
                , _currentBlockInstrs = []
                , _registerCount = 0
                , _metadataCount = 3
                , _lambdaParentFunc = Nothing
                , _outerLambdaN = 1
             -- TODO: Maybe add a pass before this that just generates all
             --       SrcPos:s, separately and more cleanly?
        , _srcPosToMetadata = Map.empty
        }
                , _srcPosToMetadata = Map.empty
                }

internFunc
    :: Name


@@ 320,25 296,24 @@ internFunc
    -> [BasicBlock]
    -> [(ShortByteString, MDRef MDNode)]
    -> Global
internFunc n ps rt bs meta = Function
    { LLGlob.linkage = LLLink.External
    , LLGlob.visibility = LLVis.Hidden
    , LLGlob.dllStorageClass = Nothing
    , LLGlob.callingConvention = LLCallConv.Fast
    , LLGlob.returnAttributes = []
    , LLGlob.returnType = rt
    , LLGlob.name = n
    , LLGlob.parameters = (ps, False)
    , LLGlob.functionAttributes = []
    , LLGlob.section = Nothing
    , LLGlob.comdat = Nothing
    , LLGlob.alignment = 0
    , LLGlob.garbageCollectorName = Nothing
    , LLGlob.prefix = Nothing
    , LLGlob.basicBlocks = bs
    , LLGlob.personalityFunction = Nothing
    , LLGlob.metadata = meta
    }
internFunc n ps rt bs meta = Function { LLGlob.linkage = LLLink.External
                                      , LLGlob.visibility = LLVis.Hidden
                                      , LLGlob.dllStorageClass = Nothing
                                      , LLGlob.callingConvention = LLCallConv.Fast
                                      , LLGlob.returnAttributes = []
                                      , LLGlob.returnType = rt
                                      , LLGlob.name = n
                                      , LLGlob.parameters = (ps, False)
                                      , LLGlob.functionAttributes = []
                                      , LLGlob.section = Nothing
                                      , LLGlob.comdat = Nothing
                                      , LLGlob.alignment = 0
                                      , LLGlob.garbageCollectorName = Nothing
                                      , LLGlob.prefix = Nothing
                                      , LLGlob.basicBlocks = bs
                                      , LLGlob.personalityFunction = Nothing
                                      , LLGlob.metadata = meta
                                      }

externFunc
    :: Name


@@ 347,25 322,24 @@ externFunc
    -> [BasicBlock]
    -> [(ShortByteString, MDRef MDNode)]
    -> Global
externFunc n ps rt bs meta = Function
    { LLGlob.linkage = LLLink.External
    , LLGlob.visibility = LLVis.Default
    , LLGlob.dllStorageClass = Nothing
    , LLGlob.callingConvention = LLCallConv.C
    , LLGlob.returnAttributes = []
    , LLGlob.returnType = rt
    , LLGlob.name = n
    , LLGlob.parameters = (ps, False)
    , LLGlob.functionAttributes = []
    , LLGlob.section = Nothing
    , LLGlob.comdat = Nothing
    , LLGlob.alignment = 0
    , LLGlob.garbageCollectorName = Nothing
    , LLGlob.prefix = Nothing
    , LLGlob.basicBlocks = bs
    , LLGlob.personalityFunction = Nothing
    , LLGlob.metadata = meta
    }
externFunc n ps rt bs meta = Function { LLGlob.linkage = LLLink.External
                                      , LLGlob.visibility = LLVis.Default
                                      , LLGlob.dllStorageClass = Nothing
                                      , LLGlob.callingConvention = LLCallConv.C
                                      , LLGlob.returnAttributes = []
                                      , LLGlob.returnType = rt
                                      , LLGlob.name = n
                                      , LLGlob.parameters = (ps, False)
                                      , LLGlob.functionAttributes = []
                                      , LLGlob.section = Nothing
                                      , LLGlob.comdat = Nothing
                                      , LLGlob.alignment = 0
                                      , LLGlob.garbageCollectorName = Nothing
                                      , LLGlob.prefix = Nothing
                                      , LLGlob.basicBlocks = bs
                                      , LLGlob.personalityFunction = Nothing
                                      , LLGlob.metadata = meta
                                      }

simpleGlobVar :: Name -> Type -> LLConst.Constant -> Global
simpleGlobVar name t = simpleGlobVar' False name t . Just


@@ 434,10 408,9 @@ genStruct :: [Val] -> Gen Val
genStruct xs = do
    xs' <- mapM getLocal xs
    let t = typeStruct (map typeOf xs')
    fmap VLocal $ foldlM
        (\s (i, x) -> emitAnonReg (insertvalue s x [i]))
        (undef t)
        (zip [0 ..] xs')
    fmap VLocal $ foldlM (\s (i, x) -> emitAnonReg (insertvalue s x [i]))
                         (undef t)
                         (zip [0 ..] xs')

genHeapAllocGeneric :: Type -> Gen Operand
genHeapAllocGeneric t = do


@@ 488,22 461,19 @@ call
    -> [(Operand, [LLVM.AST.ParameterAttribute.ParameterAttribute])]
    -> InstructionMetadata
    -> Instruction
call callconv tailkind f as meta = Call
    { tailCallKind = tailkind
    , callingConvention = callconv
    , returnAttributes = []
    , function = Right f
    , arguments = as
    , functionAttributes = []
    , metadata = meta
    }
call callconv tailkind f as meta = Call { tailCallKind = tailkind
                                        , callingConvention = callconv
                                        , returnAttributes = []
                                        , function = Right f
                                        , arguments = as
                                        , functionAttributes = []
                                        , metadata = meta
                                        }

withBuiltins :: Gen' a -> Gen' a
withBuiltins ga = builtinExterns
    >>= \es -> augment builtins (Map.union builtinsHidden es) ga
  where
    builtinExterns =
        mapM (fmap snd . genExternTypeSig) Monomorphize.builtinExterns
    where builtinExterns = mapM (fmap snd . genExternTypeSig) Monomorphize.builtinExterns

defineBuiltinsHidden :: [Definition]
defineBuiltinsHidden = map


@@ 513,9 483,7 @@ defineBuiltinsHidden = map
builtinsHidden :: Map String ([Parameter], Type)
builtinsHidden = Map.fromList
    [ ( "carth_str_eq"
      , ( [ Parameter typeStr (mkName "s1") []
          , Parameter typeStr (mkName "s2") []
          ]
      , ( [Parameter typeStr (mkName "s1") [], Parameter typeStr (mkName "s2") []]
        , typeBool
        )
      )


@@ 555,8 523,7 @@ passByRef' :: Type -> Gen' Bool
passByRef' = \case
    NamedTypeReference x -> view (dataTypes . to (Map.lookup x)) >>= \case
        Just ts -> passByRef' (typeStruct ts)
        Nothing ->
            ice $ "passByRef': No dataType for NamedTypeReference " ++ show x
        Nothing -> ice $ "passByRef': No dataType for NamedTypeReference " ++ show x
    -- Simple scalar types. They go in registers.
    VoidType -> pure False
    IntegerType _ -> pure False


@@ 620,33 587,29 @@ genDatatypeRef = NamedTypeReference . mkName . mangleTConst
--   actual function, which takes as first parameter the captures-pointer, and
--   as second parameter the argument.
closureType :: Type -> Type -> Type
closureType a r =
    typeStruct [LLType.ptr typeUnit, LLType.ptr (closureFunType a r)]
closureType a r = typeStruct [LLType.ptr typeUnit, LLType.ptr (closureFunType a r)]

-- The type of the function itself within the closure
closureFunType :: Type -> Type -> Type
closureFunType a r = FunctionType
    { resultType = r
    , argumentTypes = [LLType.ptr typeUnit, a]
    , isVarArg = False
    }
closureFunType a r = FunctionType { resultType = r
                                  , argumentTypes = [LLType.ptr typeUnit, a]
                                  , isVarArg = False
                                  }

genCapturesType :: [M.TypedVar] -> Gen Type
genCapturesType = fmap typeStruct . mapM (\(M.TypedVar _ t) -> genType t)

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

tagBitWidth :: M.Span -> Maybe Word32
tagBitWidth span'
    | span' <= 2 ^ (0 :: Integer) = Nothing
    | span' <= 2 ^ (8 :: Integer) = Just 8
    | span' <= 2 ^ (16 :: Integer) = Just 16
    | span' <= 2 ^ (32 :: Integer) = Just 32
    | span' <= 2 ^ (64 :: Integer) = Just 64
    | otherwise = ice $ "tagBitWidth: span' = " ++ show span'
tagBitWidth span' | span' <= 2 ^ (0 :: Integer) = Nothing
                  | span' <= 2 ^ (8 :: Integer) = Just 8
                  | span' <= 2 ^ (16 :: Integer) = Just 16
                  | span' <= 2 ^ (32 :: Integer) = Just 32
                  | span' <= 2 ^ (64 :: Integer) = Just 64
                  | otherwise = ice $ "tagBitWidth: span' = " ++ show span'

-- TODO: Handle different data layouts. Check out LLVMs DataLayout class and
--       impl of `getTypeAllocSize`.


@@ 709,8 672,7 @@ emitDo :: Instr -> Gen ()
emitNamedReg :: Name -> FunInstr -> Gen Operand
(emitDo, emitNamedReg) =
    ( emit' Do
    , \reg (WithRetType instr rt) ->
        emit' (reg :=) instr $> LocalReference rt reg
    , \reg (WithRetType instr rt) -> emit' (reg :=) instr $> LocalReference rt reg
    )
  where
    emit' :: (Instruction -> Named Instruction) -> Instr -> Gen ()


@@ 774,14 736,12 @@ 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)
    Nothing -> fmap
        (maybe (ice ("Undefined datatype " ++ show x)) typeStruct)
        (view (dataTypes . to (Map.lookup x)))
    Nothing -> fmap (maybe (ice ("Undefined datatype " ++ show x)) typeStruct)
                    (view (dataTypes . to (Map.lookup x)))

extractvalue :: Operand -> [Word32] -> Gen FunInstr
extractvalue struct is = fmap
    (WithRetType (ExtractValue struct is))
    (getIndexed (typeOf struct) (map fromIntegral is))
extractvalue struct is = fmap (WithRetType (ExtractValue struct is))
                              (getIndexed (typeOf struct) (map fromIntegral is))
  where
    getIndexed = foldlM $ \t i -> getMembers t <&> \us -> if i < length us
        then us !! i


@@ 792,8 752,7 @@ extractvalue struct is = fmap
    getMembers = \case
        NamedTypeReference x -> getMembers =<< lift (lookupDatatype x)
        StructureType _ members -> pure members
        t ->
            ice $ "Tried to get member types of non-struct type " ++ show t
        t -> ice $ "Tried to get member types of non-struct type " ++ show t

undef :: Type -> Operand
undef = ConstantOperand . LLConst.Undef


@@ 832,24 791,22 @@ insertvalue :: Operand -> Operand -> [Word32] -> FunInstr
insertvalue s e is = WithRetType (InsertValue s e is) (typeOf s)

store :: Operand -> Operand -> Instr
store srcVal destPtr meta = Store
    { volatile = False
    , address = destPtr
    , value = srcVal
    , maybeAtomicity = Nothing
    , alignment = 0
    , metadata = meta
    }
store srcVal destPtr meta = Store { volatile = False
                                  , address = destPtr
                                  , value = srcVal
                                  , maybeAtomicity = Nothing
                                  , alignment = 0
                                  , metadata = meta
                                  }

load :: Operand -> FunInstr
load p = WithRetType
    (\meta -> Load
        { volatile = False
        , address = p
        , maybeAtomicity = Nothing
        , alignment = 0
        , metadata = meta
        }
    (\meta -> Load { volatile = False
                   , address = p
                   , maybeAtomicity = Nothing
                   , alignment = 0
                   , metadata = meta
                   }
    )
    (getPointee (typeOf p))



@@ 931,9 888,8 @@ mangleName = \case
    (x, us) -> x ++ mangleInst us

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

mangleType :: M.Type -> String
mangleType = \case

M src/Infer.hs => src/Infer.hs +29 -71
@@ 53,20 53,11 @@ type Infer a = ReaderT Env (StateT St (Except TypeErr)) a


inferTopDefs
    :: TypeDefs
    -> Ctors
    -> Externs
    -> [Parsed.Def]
    -> Except TypeErr (Defs, Subst)
    :: TypeDefs -> Ctors -> Externs -> [Parsed.Def] -> Except TypeErr (Defs, Subst)
inferTopDefs tdefs ctors externs defs =
    let
        initEnv = Env
            { _envTypeDefs = tdefs
            , _envDefs = Map.empty
            , _envCtors = ctors
            }
    let initEnv = Env { _envTypeDefs = tdefs, _envDefs = Map.empty, _envCtors = ctors }
        initSt = St { _tvCount = 0, _substs = Map.empty }
    in evalStateT (runReaderT inferTopDefs' initEnv) initSt
    in  evalStateT (runReaderT inferTopDefs' initEnv) initSt
  where
    inferTopDefs' = do
        let externs' = fmap (first (Forall Set.empty)) externs


@@ 77,16 68,11 @@ inferTopDefs tdefs ctors externs defs =
checkType :: SrcPos -> Parsed.Type -> Infer Type
checkType pos t = view envTypeDefs >>= \tds -> checkType' tds pos t

checkType'
    :: MonadError TypeErr m => TypeDefs -> SrcPos -> Parsed.Type -> m Type
checkType' :: MonadError TypeErr m => TypeDefs -> SrcPos -> Parsed.Type -> m Type
checkType' tdefs = checkType'' (\x -> fmap (length . fst) (Map.lookup x tdefs))

checkType''
    :: MonadError TypeErr m
    => (String -> Maybe Int)
    -> SrcPos
    -> Parsed.Type
    -> m Type
    :: MonadError TypeErr m => (String -> Maybe Int) -> SrcPos -> Parsed.Type -> m Type
checkType'' tdefsParams pos = go
  where
    go = \case


@@ 102,8 88,7 @@ checkType'' tdefsParams pos = go
                then do
                    inst' <- mapM go inst
                    pure (x, inst')
                else throwError
                    (TypeInstArityMismatch pos x expectedN foundN)
                else throwError (TypeInstArityMismatch pos x expectedN foundN)
        Nothing -> throwError (UndefType pos x)

inferDefs :: [Parsed.Def] -> Infer Defs


@@ 161,8 146,7 @@ inferDefsComponents = flip foldr (pure (Topo [])) $ \scc inferRest -> do
    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)
            fmap (WithPos fPos) $ inferDef t (Id lhs) mayscm fPos (inferFunMatch cs)
        _ -> throwError (RecursiveVarDef lhs)

    inferDef t lhs mayscm bodyPos inferBody = do


@@ 178,16 162,13 @@ checkScheme :: String -> Maybe Parsed.Scheme -> Infer (Maybe Scheme)
checkScheme = curry $ \case
    ("main", Nothing) -> pure (Just (Forall Set.empty mainType))
    ("main", Just s@(Parsed.Forall pos vs t))
        | Set.size vs /= 0 || t /= Parsed.mainType -> throwError
            (WrongMainType pos s)
        | Set.size vs /= 0 || t /= Parsed.mainType -> throwError (WrongMainType pos s)
    (_, Nothing) -> pure Nothing
    (_, Just (Parsed.Forall pos vs t)) -> do
        t' <- checkType pos t
        let s1 = Forall vs t'
        s2 <- generalize t'
        if (s1 == s2)
            then pure (Just s1)
            else throwError (InvalidUserTypeSig pos s1 s2)
        if (s1 == s2) then pure (Just s1) else throwError (InvalidUserTypeSig pos s1 s2)

infer :: Parsed.Expr -> Infer (Type, Expr)
infer (WithPos pos e) = fmap (second (WithPos pos)) $ case e of


@@ 239,8 220,7 @@ infer (WithPos pos e) = fmap (second (WithPos pos)) $ case e of
        unify (Expected (TBox tx)) (Found (getPos p) tp)
        pure (tp, Store x' p')

    Parsed.Transmute x ->
        fresh >>= \u -> infer x <&> \(t, x') -> (u, Transmute x' t u)
    Parsed.Transmute x -> fresh >>= \u -> infer x <&> \(t, x') -> (u, Transmute x' t u)

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


@@ 261,14 241,10 @@ inferCases tmatchee cases = do
    forM_ tbodies (unify (Expected tbody))
    pure (tbody, cases')

inferCase
    :: (Parsed.Pat, Parsed.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
            (bimap (Parsed.idstr) (Forall Set.empty . TVar))
            (Map.toList pvs)
    let pvs' = map (bimap (Parsed.idstr) (Forall Set.empty . TVar)) (Map.toList pvs)
    (tb, b') <- withLocals pvs' (infer b)
    pure (Found (getPos p) tp, Found (getPos b) tb, (p', b'))



@@ 276,18 252,15 @@ inferCase (p, b) = do
--   Match module wants, and a Map from the variables bound in the pattern to
--   fresh schemes.
inferPat :: Parsed.Pat -> Infer (Type, Pat, Map (Id 'Small) TVar)
inferPat pat = fmap
    (\(t, p, ss) -> (t, WithPos (getPos pat) p, ss))
    (inferPat' pat)
inferPat pat = fmap (\(t, p, ss) -> (t, WithPos (getPos pat) p, ss)) (inferPat' pat)
  where
    inferPat' = \case
        Parsed.PConstruction pos c ps -> inferPatConstruction pos c ps
        Parsed.PInt _ n -> pure (TPrim TInt, intToPCon n 64, Map.empty)
        Parsed.PStr _ s ->
            let
                span' = ice "span of Con with VariantStr"
            let span' = ice "span of Con with VariantStr"
                p = PCon (Con (VariantStr s) span' []) []
            in pure (typeStr, p, Map.empty)
            in  pure (typeStr, p, Map.empty)
        Parsed.PVar (Id (WithPos _ "_")) -> do
            tv <- fresh
            pure (tv, PWild, Map.empty)


@@ 298,41 271,30 @@ inferPat pat = fmap
            (tp', p', vs) <- inferPat p
            pure (TBox tp', PBox p', vs)
    intToPCon n w = PCon
        (Con
            { variant = VariantIx (fromIntegral n)
            , span = 2 ^ (w :: Integer)
            , argTs = []
            }
        (Con { variant = VariantIx (fromIntegral n)
             , span = 2 ^ (w :: Integer)
             , argTs = []
             }
        )
        []

inferPatConstruction
    :: SrcPos
    -> Id 'Big
    -> [Parsed.Pat]
    -> Infer (Type, Pat', Map (Id 'Small) TVar)
    :: SrcPos -> Id 'Big -> [Parsed.Pat] -> Infer (Type, Pat', Map (Id 'Small) TVar)
inferPatConstruction pos c cArgs = do
    (variantIx, tdefLhs, cParams, cSpan) <- lookupEnvConstructor c
    let arity = length cParams
    let nArgs = length cArgs
    unless
        (arity == nArgs)
        (throwError (CtorArityMismatch pos (idstr c) arity nArgs))
    unless (arity == nArgs) (throwError (CtorArityMismatch pos (idstr c) arity nArgs))
    (tdefInst, cParams') <- instantiateConstructorOfTypeDef tdefLhs cParams
    let t = TConst tdefInst
    (cArgTs, cArgs', cArgsVars) <- fmap unzip3 (mapM inferPat cArgs)
    cArgsVars' <- nonconflictingPatVarDefs cArgsVars
    forM_ (zip3 cParams' cArgTs cArgs) $ \(cParamT, cArgT, cArg) ->
        unify (Expected cParamT) (Found (getPos cArg) cArgT)
    let con = Con
            { variant = VariantIx variantIx
            , span = cSpan
            , argTs = cArgTs
            }
    let con = Con { variant = VariantIx variantIx, span = cSpan, argTs = cArgTs }
    pure (t, PCon con cArgs', cArgsVars')

nonconflictingPatVarDefs
    :: [Map (Id 'Small) TVar] -> Infer (Map (Id 'Small) TVar)
nonconflictingPatVarDefs :: [Map (Id 'Small) TVar] -> Infer (Map (Id 'Small) TVar)
nonconflictingPatVarDefs = flip foldM Map.empty $ \acc ks ->
    case listToMaybe (Map.keys (Map.intersection acc ks)) of
        Just (Id (WithPos pos v)) -> throwError (ConflictingPatVarDefs pos v)


@@ 345,18 307,15 @@ inferExprConstructor c = do
    let t = foldr TFun (TConst tdefInst) cParams'
    pure (t, Ctor variantIx cSpan tdefInst cParams')

instantiateConstructorOfTypeDef
    :: (String, [TVar]) -> [Type] -> Infer (TConst, [Type])
instantiateConstructorOfTypeDef :: (String, [TVar]) -> [Type] -> Infer (TConst, [Type])
instantiateConstructorOfTypeDef (tName, tParams) cParams = do
    tVars <- mapM (const fresh) tParams
    let cParams' = map (subst (Map.fromList (zip tParams tVars))) cParams
    pure ((tName, tVars), cParams')

lookupEnvConstructor
    :: Id 'Big -> Infer (VariantIx, (String, [TVar]), [Type], Span)
lookupEnvConstructor :: Id 'Big -> Infer (VariantIx, (String, [TVar]), [Type], Span)
lookupEnvConstructor (Id (WithPos pos cx)) =
    view (envCtors . to (Map.lookup cx))
        >>= maybe (throwError (UndefCtor pos cx)) pure
    view (envCtors . to (Map.lookup cx)) >>= maybe (throwError (UndefCtor pos cx)) pure

litType :: Const -> Type
litType = \case


@@ 397,10 356,9 @@ data UnifyErr'' = InfiniteType'' TVar Type | UnificationFailed'' Type Type
unify'' :: Type -> Type -> Except UnifyErr'' Subst
unify'' = curry $ \case
    (TPrim a, TPrim b) | a == b -> pure Map.empty
    (TConst (c0, ts0), TConst (c1, ts1)) | c0 == c1 ->
        if length ts0 /= length ts1
            then ice "lengths of TConst params differ in unify"
            else unifys ts0 ts1
    (TConst (c0, ts0), TConst (c1, ts1)) | c0 == c1 -> if length ts0 /= length ts1
        then ice "lengths of TConst params differ in unify"
        else unifys ts0 ts1
    (TVar a, TVar b) | a == b -> pure Map.empty
    (TVar a, t) | occursIn a t -> throwError (InfiniteType'' a t)
    -- Do not allow "override" of explicit (user given) type variables.

M src/Inferred.hs => src/Inferred.hs +1 -8
@@ 1,14 1,7 @@
{-# LANGUAGE LambdaCase, TemplateHaskell, DataKinds, TupleSections #-}

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

import Data.Set (Set)
import qualified Data.Set as Set

M src/Literate.hs => src/Literate.hs +7 -10
@@ 11,21 11,18 @@ untangleOrg s = unlines (untangleOrg' False (lines s))
    untangleOrg' inSrc = \case
        [] -> []
        x : xs -> if inSrc
            then if endSrc x
                then "" : untangleOrg' False xs
                else x : untangleOrg' True xs
            then if endSrc x then "" : untangleOrg' False xs else x : untangleOrg' True xs
            else "" : untangleOrg' (beginSrc x) xs

beginSrc :: String -> Bool
beginSrc l =
    let ws = words l
    in
        (length ws >= 2)
        && (map toLower (ws !! 0) == "#+begin_src")
        && (ws !! 1 == "carth")
        && case elemIndex ":tangle" ws of
               Just i -> length ws >= i + 2 && ws !! (i + 1) == "yes"
               Nothing -> True
    in  (length ws >= 2)
            && (map toLower (ws !! 0) == "#+begin_src")
            && (ws !! 1 == "carth")
            && case elemIndex ":tangle" ws of
                   Just i -> length ws >= i + 2 && ws !! (i + 1) == "yes"
                   Nothing -> True

endSrc :: String -> Bool
endSrc = (\ws -> length ws > 0 && map toLower (ws !! 0) == "#+end_src") . words

M src/Match.hs => src/Match.hs +38 -51
@@ 56,22 56,16 @@ type Match = ReaderT Env (StateT RedundantCases (ExceptT TypeErr Maybe))


toDecisionTree
    :: MTypeDefs
    -> SrcPos
    -> Type
    -> [(Pat, Expr)]
    -> ExceptT TypeErr Maybe DecisionTree
    :: MTypeDefs -> SrcPos -> Type -> [(Pat, Expr)] -> ExceptT TypeErr Maybe DecisionTree
toDecisionTree tds ePos tp cases =
    let
        rules = map (\(WithPos pos p, e) -> (p, (pos, Map.empty, e))) cases
    let rules = map (\(WithPos pos p, e) -> (p, (pos, Map.empty, e))) cases
        redundantCases = map (getPos . fst) cases
    in do
        let env = Env { _tdefs = tds, _tpat = tp, _exprPos = ePos }
        (d, redundantCases') <- runStateT
            (runReaderT (compile rules) env)
            redundantCases
        forM_ redundantCases' $ throwError . RedundantCase
        pure (switchify d)
    in  do
            let env = Env { _tdefs = tds, _tpat = tp, _exprPos = ePos }
            (d, redundantCases') <- runStateT (runReaderT (compile rules) env)
                                              redundantCases
            forM_ redundantCases' $ throwError . RedundantCase
            pure (switchify d)

compile :: [(Pat', Rhs)] -> Match DecisionTree'
compile = disjunct (Neg Set.empty)


@@ 98,26 92,24 @@ missingPat t descr = case t of

missingPat' :: [String] -> Descr -> Match String
missingPat' vs =
    let
        allVariants = Map.fromList (zip [0 ..] vs)
    let allVariants = Map.fromList (zip [0 ..] vs)
        variant' = \case
            Con (VariantIx v) _ _ -> v
            Con (VariantStr _) _ _ -> ice "variant' of Con VariantStr"
    in \case
        Neg cs -> lift $ lift $ lift $ listToMaybe $ Map.elems
            (Map.withoutKeys allVariants (Set.map variant' cs))
        Pos (Con (VariantStr _) _ _) _ -> ice "missingPat' of Con VariantStr"
        Pos (Con (VariantIx v) _ argTs') dargs ->
            let
                i = fromIntegral v
                s = if i < length vs
                    then vs !! i
                    else ice "variant >= type number of variants in missingPat'"
            in if null dargs
                then pure s
                else do
                    ps <- zipWithM missingPat argTs' dargs
                    pure ("(" ++ s ++ precalate " " ps ++ ")")
    in  \case
            Neg cs -> lift $ lift $ lift $ listToMaybe $ Map.elems
                (Map.withoutKeys allVariants (Set.map variant' cs))
            Pos (Con (VariantStr _) _ _) _ -> ice "missingPat' of Con VariantStr"
            Pos (Con (VariantIx v) _ argTs') dargs ->
                let i = fromIntegral v
                    s = if i < length vs
                        then vs !! i
                        else ice "variant >= type number of variants in missingPat'"
                in  if null dargs
                        then pure s
                        else do
                            ps <- zipWithM missingPat argTs' dargs
                            pure ("(" ++ s ++ precalate " " ps ++ ")")

match
    :: Access


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


@@ 140,15 132,11 @@ match obj descr ctx work rhs rules = \case
            disjunct' newDescr = disjunct (buildDescr newDescr ctx work) rules

            conjunct' :: Match DecisionTree'
            conjunct' = conjunct
                ((pcon, []) : ctx)
                rhs
                rules
                ((pargs, getoargs, getdargs) : work)
            conjunct' =
                conjunct ((pcon, []) : ctx) rhs rules ((pargs, getoargs, getdargs) : work)

            getoargs :: [Access]
            getoargs =
                args (\i -> Sel i (span pcon) (As obj (span pcon) (argTs pcon)))
            getoargs = args (\i -> Sel i (span pcon) (As obj (span pcon) (argTs pcon)))

            getdargs :: [Descr]
            getdargs = case descr of


@@ 157,13 145,14 @@ match obj descr ctx work rhs rules = \case

            args :: (Word32 -> a) -> [a]
            args f = map f (take (arity pcon) [0 ..])
        in case staticMatch pcon descr of
            Yes -> conjunct'
            No -> disjunct' descr
            Maybe -> do
                yes <- conjunct'
                no <- disjunct' (addneg pcon descr)
                pure (IfEq obj pcon yes no)
        in
            case staticMatch pcon descr of
                Yes -> conjunct'
                No -> disjunct' descr
                Maybe -> do
                    yes <- conjunct'
                    no <- disjunct' (addneg pcon descr)
                    pure (IfEq obj pcon yes no)

conjunct :: Ctx -> Rhs -> [(Pat', Rhs)] -> Work -> Match DecisionTree'
conjunct ctx rhs@(casePos, binds, e) rules = \case


@@ 202,12 191,10 @@ augment descr = \case

staticMatch :: Con -> Descr -> Answer
staticMatch = curry $ \case
    (pcon, Pos c _)
        | pcon == c -> Yes
        | otherwise -> No
    (pcon, Pos c _) | pcon == c -> Yes
                    | otherwise -> No
    (pcon, Neg cs) | Set.member pcon cs -> No
    (Con (VariantIx _) span' _, Neg cs)
        | span' == 1 + fromIntegral (Set.size cs) -> Yes
    (Con (VariantIx _) span' _, Neg cs) | span' == 1 + fromIntegral (Set.size cs) -> Yes
    _ -> Maybe

addneg :: Con -> Descr -> Descr

M src/Misc.hs => src/Misc.hs +3 -6
@@ 43,8 43,7 @@ both f (a0, a1) = (f a0, f a1)
firstM :: (Bitraversable t, Applicative f) => (a -> f a') -> t a b -> f (t a' b)
firstM = flip bimapM pure

secondM
    :: (Bitraversable t, Applicative f) => (b -> f b') -> t a b -> f (t a b')
secondM :: (Bitraversable t, Applicative f) => (b -> f b') -> t a b -> f (t a b')
secondM = bimapM pure

locallySet :: MonadReader s m => Lens' s a -> a -> m r -> m r


@@ 53,12 52,10 @@ locallySet l = locally l . const
locally :: MonadReader s m => Lens' s a -> (a -> a) -> m r -> m r
locally l f = local (over l f)

augment1
    :: (MonadReader e m, Ord k) => Lens' e (Map k v) -> (k, v) -> m a -> m a
augment1 :: (MonadReader e m, Ord k) => Lens' e (Map k v) -> (k, v) -> m a -> m a
augment1 l = locally l . uncurry Map.insert

augment
    :: (MonadReader e m, Ord k) => Lens' e (Map k v) -> Map k v -> m a -> m a
augment :: (MonadReader e m, Ord k) => Lens' e (Map k v) -> Map k v -> m a -> m a
augment l = locally l . Map.union

scribe :: (MonadWriter t m, Monoid s) => Lens s t a b -> b -> m ()

M src/Monomorphic.hs => src/Monomorphic.hs +3 -14
@@ 2,15 2,7 @@
           , FlexibleInstances, FlexibleContexts #-}

-- | Monomorphic AST as a result of monomorphization
module Monomorphic
    ( module Monomorphic
    , TPrim(..)
    , Const(..)
    , VariantIx
    , Span
    , tUnit
    )
where
module Monomorphic (module Monomorphic, TPrim(..), Const(..), VariantIx, Span, tUnit) where

import qualified Data.Map as Map
import Data.Map (Map)


@@ 106,8 98,7 @@ fvExpr' = \case
    If p c a -> fvIf p c a
    Fun (p, (b, _)) -> fvFun p b
    Let d (Expr _ e) ->
        let bs = defToVarDefs d
        in fvLet (unzip (map (second (snd . unpos)) bs)) e
        let bs = defToVarDefs d in fvLet (unzip (map (second (snd . unpos)) bs)) e
    Match e dt _ -> Set.union (freeVars e) (fvDecisionTree dt)
    Ction (_, _, _, as) -> Set.unions (map freeVars as)
    Sizeof _t -> Set.empty


@@ 121,9 112,7 @@ fvDecisionTree = \case
    DLeaf (bs, e) -> Set.difference (freeVars e) (Set.fromList (map fst bs))
    DSwitch _ cs def -> fvDSwitch (Map.elems cs) def
    DSwitchStr _ cs def -> fvDSwitch (Map.elems cs) def
  where
    fvDSwitch es def =
        Set.unions $ fvDecisionTree def : map fvDecisionTree es
    where fvDSwitch es def = Set.unions $ fvDecisionTree def : map fvDecisionTree es

defToVarDefs :: Def -> [(TypedVar, WithPos ([Type], Expr'))]
defToVarDefs = \case

M src/Monomorphize.hs => src/Monomorphize.hs +12 -22
@@ 41,15 41,12 @@ type Mono = StateT Insts (Reader Env)

monomorphize :: Checked.Program -> Program
monomorphize (Checked.Program (Topo defs) tdefs externs) = evalMono $ do
    externs' <- mapM
        (\(x, (t, p)) -> fmap (\t' -> (x, t', p)) (monotype t))
        (Map.toList externs)
    let callMain =
            noPos (Checked.Var (Checked.TypedVar "main" Checked.mainType))
    defs' <- foldr
        (\d1 md2s -> fmap (uncurry (++)) (monoLet' d1 md2s))
        (mono callMain $> [])
        defs
    externs' <- mapM (\(x, (t, p)) -> fmap (\t' -> (x, t', p)) (monotype t))
                     (Map.toList externs)
    let callMain = noPos (Checked.Var (Checked.TypedVar "main" Checked.mainType))
    defs' <- foldr (\d1 md2s -> fmap (uncurry (++)) (monoLet' d1 md2s))
                   (mono callMain $> [])
                   defs
    tdefs' <- instTypeDefs tdefs
    pure (Program (Topo defs') tdefs' externs')



@@ 129,8 126,7 @@ monoLetRecs ds ma = foldr
    ds

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

monoDecisionTree :: Checked.DecisionTree -> Mono DecisionTree
monoDecisionTree = \case


@@ 142,9 138,7 @@ monoDecisionTree = \case
        parentInsts <- use (defInsts . to (lookups ks))
        modifying defInsts (deletes ks)
        bs'' <- mapM
            (bimapM
                (\(Checked.TypedVar x t) -> fmap (TypedVar x) (monotype t))
                monoAccess
            (bimapM (\(Checked.TypedVar x t) -> fmap (TypedVar x) (monotype t)) monoAccess
            )
            bs'
        e' <- mono e


@@ 160,8 154,7 @@ monoDecisionTree = \case
monoAccess :: Checked.Access -> Mono Access
monoAccess = \case
    Checked.Obj -> pure Obj
    Checked.As a span' ts ->
        liftA3 As (monoAccess a) (pure span') (mapM monotype ts)
    Checked.As a span' ts -> liftA3 As (monoAccess a) (pure span') (mapM monotype ts)
    Checked.Sel i span' a -> fmap (Sel i span') (monoAccess a)
    Checked.ADeref a -> fmap ADeref (monoAccess a)



@@ 193,12 186,10 @@ addDefInst x t1 = do
bindTvs :: Checked.Type -> Type -> Map TVar Type
bindTvs a b = case (a, b) of
    (Checked.TVar v, t) -> Map.singleton v t
    (Checked.TFun p0 r0, TFun p1 r1) ->
        Map.union (bindTvs p0 p1) (bindTvs r0 r1)
    (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)
    (Checked.TConst (_, ts0), TConst (_, ts1)) -> Map.unions (zipWith bindTvs ts0 ts1)
    (Checked.TPrim _, _) -> err
    (Checked.TFun _ _, _) -> err
    (Checked.TBox _, _) -> err


@@ 207,8 198,7 @@ bindTvs a b = case (a, b) of

monotype :: Checked.Type -> Mono Type
monotype = \case
    Checked.TVar v ->
        view (tvBinds . to (lookup' (ice (show v ++ " not in tvBinds")) v))
    Checked.TVar v -> view (tvBinds . to (lookup' (ice (show v ++ " not in tvBinds")) v))
    Checked.TPrim c -> pure (TPrim c)
    Checked.TFun a b -> liftA2 TFun (monotype a) (monotype b)
    Checked.TBox t -> fmap TBox (monotype t)

M src/Parse.hs => src/Parse.hs +25 -68
@@ 7,15 7,7 @@
--       If a parser has a variant with a "ns_" prefix, that variant does not
--       consume succeding space, while the unprefixed variant does.

module Parse
    ( Parser
    , Source
    , parse
    , parse'
    , parseTokenTreeOrRest
    , toplevels
    )
where
module Parse (Parser, Source, parse, parse', parseTokenTreeOrRest, toplevels) where

import Control.Monad
import Data.Char (isMark, isPunctuation, isSymbol, isUpper)


@@ 62,8 54,7 @@ parseModule
    -> [String]
    -> IO (Either String ([Def], [TypeDef], [Extern]))
parseModule filepath dir m visiteds nexts =
    let
        readModuleIn modPaths = do
    let readModuleIn modPaths = do
            let fs = do
                    p <- modPaths
                    let pm = p </> m


@@ 90,15 81,15 @@ parseModule filepath dir m visiteds nexts =
            next : nexts' -> fmap
                (fmap (\(ds', ts', es') -> (ds ++ ds', ts ++ ts', es ++ es')))
                (parseModule filepath dir next (Set.insert m visiteds) nexts')
    in if Set.member m visiteds
        then advance ([], [], [], [])
        else do
            -- TODO: make dir absolute to make debug work when binary is moved?
            modPaths <- fmap (dir :) modulePaths
            (src, f) <- readModuleIn modPaths
            case parse' toplevels f src of
                Left e -> pure (Left e)
                Right r -> advance r
    in  if Set.member m visiteds
            then advance ([], [], [], [])
            else do
             -- TODO: make dir absolute to make debug work when binary is moved?
                modPaths <- fmap (dir :) modulePaths
                (src, f) <- readModuleIn modPaths
                case parse' toplevels f src of
                    Left e -> pure (Left e)
                    Right r -> advance r

parse' :: Parser a -> FilePath -> Source -> Either String a
parse' p name src = first errorBundlePretty (Mega.parse p name src)


@@ 108,14 99,9 @@ parse' p name src = first errorBundlePretty (Mega.parse p name src)
parseTokenTreeOrRest :: Source -> Either String String
parseTokenTreeOrRest = parse' tokenTreeOrRest ""
  where
    tokenTreeOrRest =
        fmap fst (Mega.match (try ns_tokenTree <|> (restOfInput $> ())))
    tokenTreeOrRest = fmap fst (Mega.match (try ns_tokenTree <|> (restOfInput $> ())))
    ns_tokenTree = choice
        [ ns_strlit $> ()
        , ns_ident $> ()
        , ns_num $> ()
        , ns_parens (many tokenTree) $> ()
        ]
        [ns_strlit $> (), ns_ident $> (), ns_num $> (), ns_parens (many tokenTree) $> ()]
    tokenTree = andSkipSpaceAfter ns_tokenTree
    restOfInput = many Mega.anySingle



@@ 130,9 116,7 @@ toplevels = do
        topPos <- getSrcPos
        parens $ choice
            [ fmap (\i (is, ds, ts, es) -> (i : is, ds, ts, es)) import'
            , fmap
                (\d (is, ds, ts, es) -> (is, d : ds, ts, es))
                (def topPos)
            , fmap (\d (is, ds, ts, es) -> (is, d : ds, ts, es)) (def topPos)
            , fmap (\t (is, ds, ts, es) -> (is, ds, t : ts, es)) typedef
            , fmap (\e (is, ds, ts, es) -> (is, ds, ts, e : es)) extern
            ]


@@ 193,18 177,7 @@ expr' = choice [var, estr, num, eConstructor, pexpr]
    eConstructor = fmap Ctor big
    var = fmap Var small
    pexpr = parens $ choice
        [ funMatch
        , match
        , if'
        , fun
        , let'
        , typeAscr
        , sizeof
        , deref
        , store
        , transmute
        , app
        ]
        [funMatch, match, if', fun, let', typeAscr, sizeof, deref, store, transmute, app]
    funMatch = reserved "fmatch" *> fmap FunMatch cases
    match = reserved "match" *> liftA2 Match expr cases
    cases = many (parens (reserved "case" *> (liftA2 (,) pat expr)))


@@ 213,10 186,7 @@ expr' = choice [var, estr, num, eConstructor, pexpr]
        reserved "fun"
        params <- parens (some pat)
        body <- expr
        pure $ unpos $ foldr
            (\p b -> WithPos (getPos p) (FunMatch [(p, b)]))
            body
            params
        pure $ unpos $ foldr (\p b -> WithPos (getPos p) (FunMatch [(p, b)])) body params
    let' = reserved "let" *> liftA2 Let (parens (many binding)) expr
    binding = getSrcPos >>= \p -> parens (varBinding p <|> funBinding p)
    varBinding pos = do


@@ 245,10 215,9 @@ ns_num :: Parser Expr'
ns_num = do
    neg <- option False (char '-' $> True)
    a <- eitherP (try (Lexer.decimal <* notFollowedBy (char '.'))) Lexer.float
    let e = either
            (\n -> Int (if neg then -n else n))
            (\x -> F64 (if neg then -x else x))
            a
    let e = either (\n -> Int (if neg then -n else n))
                   (\x -> F64 (if neg then -x else x))
                   a
    pure (Lit e)

strlit :: Parser String


@@ 283,8 252,7 @@ type_ :: Parser Type
type_ = nonptype <|> parens ptype

nonptype :: Parser Type
nonptype = choice
    [fmap TPrim tprim, fmap TVar tvar, fmap (TConst . (, []) . idstr) big]
nonptype = choice [fmap TPrim tprim, fmap TVar tvar, fmap (TConst . (, []) . idstr) big]
  where
    tprim = try $ do
        s <- big


@@ 329,9 297,7 @@ big = fmap Id (special <|> normal)
        let c = head s
        if (isUpper c || [c] == ":")
            then pure s
            else
                fail
                    "Big identifier must start with an uppercase letter or colon."
            else fail "Big identifier must start with an uppercase letter or colon."

small :: Parser (Id 'Small)
small = fmap Id (special <|> normal)


@@ 341,17 307,14 @@ small = fmap Id (special <|> normal)
        s <- identifier
        let c = head s
        if (isUpper c || [c] == ":")
            then
                fail
                    "Small identifier must not start with an uppercase letter or colon."
            then fail "Small identifier must not start with an uppercase letter or colon."
            else pure s

identifier :: Parser String
identifier = do
    name <- ident
    if elem name reserveds
        then unexpected
            (Label (NonEmpty.fromList ("reserved word " ++ show name)))
        then unexpected (Label (NonEmpty.fromList ("reserved word " ++ show name)))
        else pure name

ident :: Parser String


@@ 361,11 324,7 @@ ns_ident :: Parser String
ns_ident = label "identifier" $ liftA2 (:) identStart (many identLetter)
  where
    identStart =
        choice
            [ letterChar
            , otherChar
            , try (oneOf "-+" <* notFollowedBy digitChar)
            ]
        choice [letterChar, otherChar, try (oneOf "-+" <* notFollowedBy digitChar)]
    identLetter = letterChar <|> otherChar <|> oneOf "-+" <|> digitChar

reserved :: String -> Parser ()


@@ 423,7 382,5 @@ withPos = liftA2 WithPos getSrcPos

getSrcPos :: Parser SrcPos
getSrcPos = fmap
    (\(SourcePos f l c) ->
        SrcPos f (fromIntegral (unPos l)) (fromIntegral (unPos c))
    )
    (\(SourcePos f l c) -> SrcPos f (fromIntegral (unPos l)) (fromIntegral (unPos c)))
    getSourcePos

M src/Pretty.hs => src/Pretty.hs +14 -26
@@ 57,8 57,7 @@ instance Pretty (Parsed.Id a) where

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


@@ 68,7 67,7 @@ prettyProg d (Parsed.Program defs tdefs externs) =
                [ indent d ++ "(define " ++ pretty name ++ "\n"
                , indent (d + 2) ++ pretty' (d + 2) body ++ ")"
                ]
    in unlines (map prettyDef defs ++ map pretty tdefs ++ map pretty externs)
    in  unlines (map prettyDef defs ++ map pretty tdefs ++ map pretty externs)

prettyExtern :: Int -> Parsed.Extern -> String
prettyExtern _ (Parsed.Extern name t) =


@@ 97,9 96,7 @@ 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 ++ ")"
        ]
        ["(" ++ 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"


@@ 126,30 123,24 @@ prettyExpr' d = \case
        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)
        , 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)
        , precalate ("\n" ++ indent (d + 2)) (map (prettyBracketPair (d + 2)) cs)
        , ")"
        ]
    Parsed.Ctor c -> pretty c
    Parsed.Sizeof t -> concat ["(sizeof ", pretty' (d + 8) t, ")"]
    Parsed.Deref e -> concat ["(deref ", pretty' (d + 7) e, ")"]
    Parsed.Store x p -> concat
        [ "(store " ++ pretty' (d + 7) x
        , indent (d + 7) ++ pretty' (d + 7) p ++ ")"
        ]
        ["(store " ++ pretty' (d + 7) x, indent (d + 7) ++ pretty' (d + 7) p ++ ")"]
    Parsed.Transmute e -> concat ["(transmute ", pretty' (d + 11) 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, "]"]
prettyBracketPair d (a, b) =
    concat ["[", pretty' (d + 1) a, "\n", indent (d + 1), pretty' (d + 1) b, "]"]

prettyPat :: Parsed.Pat -> String
prettyPat = \case


@@ 204,12 195,11 @@ prettyTBox t = "(Box " ++ pretty t ++ ")"

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

prettyTPrim :: Parsed.TPrim -> String
prettyTPrim = \case


@@ 244,12 234,11 @@ prettyAnType = \case

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


instance Pretty M.Type where


@@ 264,9 253,8 @@ prettyMonoType = \case

prettyMonoTFun :: M.Type -> M.Type -> String
prettyMonoTFun a b =
    let
        (bParams, bBody) = f 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]), ")"]
    in  concat ["(Fun ", pretty a, " ", spcPretty (bParams ++ [bBody]), ")"]

M src/Selections.hs => src/Selections.hs +18 -19
@@ 25,25 25,24 @@ select
    -> Access
    -> Selections a
    -> m (a, Selections a)
select conv sub deref selector selections =
    case Map.lookup selector selections of
        Just a -> pure (a, selections)
        Nothing -> do
            (a, selections') <- case selector of
                Obj -> ice "select: Obj not in selections"
                As x span' ts -> do
                    (a', s') <- select conv sub deref x selections
                    a'' <- conv span' ts a'
                    pure (a'', s')
                Sel i span' x -> do
                    (a', s') <- select conv sub deref x selections
                    a'' <- sub span' i a'
                    pure (a'', s')
                ADeref x -> do
                    (a', s') <- select conv sub deref x selections
                    a'' <- deref a'
                    pure (a'', s')
            pure (a, Map.insert selector a selections')
select conv sub deref selector selections = case Map.lookup selector selections of
    Just a -> pure (a, selections)
    Nothing -> do
        (a, selections') <- case selector of
            Obj -> ice "select: Obj not in selections"
            As x span' ts -> do
                (a', s') <- select conv sub deref x selections
                a'' <- conv span' ts a'
                pure (a'', s')
            Sel i span' x -> do
                (a', s') <- select conv sub deref x selections
                a'' <- sub span' i a'
                pure (a'', s')
            ADeref x -> do
                (a', s') <- select conv sub deref x selections
                a'' <- deref a'
                pure (a'', s')
        pure (a, Map.insert selector a selections')

selectVarBindings
    :: (Show a, Monad m)

M src/SrcPos.hs => src/SrcPos.hs +2 -2
@@ 35,5 35,5 @@ unpos :: WithPos a -> a
unpos (WithPos _ a) = a

prettySrcPos :: SrcPos -> String
prettySrcPos (SrcPos f l c) = sourcePosPretty
    (SourcePos f (mkPos (fromIntegral l)) (mkPos (fromIntegral c)))
prettySrcPos (SrcPos f l c) =
    sourcePosPretty (SourcePos f (mkPos (fromIntegral l)) (mkPos (fromIntegral c)))

M src/Subst.hs => src/Subst.hs +1 -2
@@ 32,8 32,7 @@ substExpr s (WithPos pos expr) = WithPos pos $ case expr of
    If p c a -> If (substExpr s p) (substExpr s c) (substExpr s a)
    Let def body -> Let (substDef s def) (substExpr s body)
    FunMatch f -> FunMatch (substFunMatch s f)
    Ctor i span' (tx, tts) ps ->
        Ctor i span' (tx, map (subst s) tts) (map (subst s) ps)
    Ctor i span' (tx, tts) ps -> Ctor i span' (tx, map (subst s) tts) (map (subst s) ps)
    Sizeof t -> Sizeof (subst s t)
    Deref e -> Deref (substExpr s e)
    Store x p -> Store (substExpr s x) (substExpr s p)