~jojo/Carth

e742f2d94fb239a7ce2b3e6a6a8460adb5257710 — JoJo 1 year, 10 months ago 56b1bb2
Fix some harmless warnings
5 files changed, 57 insertions(+), 54 deletions(-)

M src/Ast.hs
M src/Check.hs
M src/Infer.hs
M src/Match.hs
M src/Parse.hs
M src/Ast.hs => src/Ast.hs +18 -18
@@ 45,7 45,7 @@ newtype Id (case' :: IdCase) = Id (WithPos String)
    deriving (Show, Eq, Ord)

data TVar
    = TVExplicit (Id Small)
    = TVExplicit (Id 'Small)
    | TVImplicit Int
    deriving (Show, Eq, Ord)



@@ 81,8 81,8 @@ data Scheme = Forall
makeLenses ''Scheme

data Pat
    = PConstruction SrcPos (Id Big) [Pat]
    | PVar (Id Small)
    = PConstruction SrcPos (Id 'Big) [Pat]
    | PVar (Id 'Small)
    deriving Show

data Const


@@ 96,30 96,30 @@ data Const

data Expr'
    = Lit Const
    | Var (Id Small)
    | Var (Id 'Small)
    | App Expr Expr
    | If Expr Expr Expr
    | Fun (Id Small) Expr
    | Fun (Id 'Small) Expr
    | Let (NonEmpty Def) Expr
    | TypeAscr Expr Type
    | Match Expr (NonEmpty (Pat, Expr))
    | FunMatch (NonEmpty (Pat, Expr))
    | Ctor (Id Big)
    | Ctor (Id 'Big)
    | Box Expr
    | Deref Expr
    deriving (Show, Eq)

type Expr = WithPos Expr'

type Def = (Id Small, (Maybe (WithPos Scheme), Expr))
type Def = (Id 'Small, (Maybe (WithPos Scheme), Expr))

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

data TypeDef = TypeDef (Id Big) [Id Small] ConstructorDefs
data TypeDef = TypeDef (Id 'Big) [Id 'Small] ConstructorDefs
    deriving (Show, Eq)

data Extern = Extern (Id Small) Type
data Extern = Extern (Id 'Small) Type
    deriving (Show, Eq)

data Program = Program [Def] [TypeDef] [Extern]


@@ 132,10 132,10 @@ instance Eq Pat where
        (PVar x, PVar x') -> x == x'
        _ -> False

instance FreeVars Def (Id Small) where
instance FreeVars Def (Id 'Small) where
    freeVars (_, (_, body)) = freeVars body

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

instance HasPos (Id a) where


@@ 172,7 172,7 @@ instance Pretty (Id a) where
    pretty' _ = idstr


fvExpr :: Expr -> Set (Id Small)
fvExpr :: Expr -> Set (Id 'Small)
fvExpr = unpos >>> \case
    Lit _ -> Set.empty
    Var x -> Set.singleton x


@@ 188,13 188,13 @@ fvExpr = unpos >>> \case
    Box e -> fvExpr e
    Deref e -> fvExpr e

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

fvCases :: [(Pat, Expr)] -> Set (Id Small)
fvCases :: [(Pat, Expr)] -> Set (Id 'Small)
fvCases = Set.unions . map (\(p, e) -> Set.difference (freeVars e) (bvPat p))

bvPat :: Pat -> Set (Id Small)
bvPat :: Pat -> Set (Id 'Small)
bvPat = \case
    PConstruction _ _ ps -> Set.unions (map bvPat ps)
    PVar x -> Set.singleton x


@@ 244,8 244,8 @@ prettyExpr' d = \case
        [ "(" ++ pretty' (d + 1) f ++ "\n"
        , indent (d + 1) ++ pretty' (d + 1) x ++ ")"
        ]
    If pred cons alt -> concat
        [ "(if " ++ pretty' (d + 4) pred ++ "\n"
    If pred' cons alt -> concat
        [ "(if " ++ pretty' (d + 4) pred' ++ "\n"
        , indent (d + 4) ++ pretty' (d + 4) cons ++ "\n"
        , indent (d + 2) ++ pretty' (d + 2) alt ++ ")"
        ]

M src/Check.hs => src/Check.hs +9 -9
@@ 89,7 89,7 @@ checkTypeDef
           ( (String, ([TVar], [(SrcPos, (String, [Type]))]))
           , Map
                 String
                 (Id Big, (VariantIx, (String, [TVar]), [Type], Span))
                 (Id 'Big, (VariantIx, (String, [TVar]), [Type], Span))
           )
checkTypeDef (Ast.TypeDef x' ps (Ast.ConstructorDefs cs)) = do
    let x = idstr x'


@@ 157,13 157,13 @@ checkTypeVarsBound ds = runReaderT (boundInDefs ds) Set.empty
            boundInExpr p
            boundInExpr c
            boundInExpr a
        An.Fun (_, pt) (e, et) -> do
        An.Fun (_, pt) (b, bt) -> do
            boundInType pos pt
            boundInExpr e
            boundInType pos et
        An.Let ds e -> do
            boundInDefs ds
            boundInExpr e
            boundInExpr b
            boundInType pos bt
        An.Let lds b -> do
            boundInDefs lds
            boundInExpr b
        An.Match m dt bt -> do
            boundInExpr m
            boundInDecTree dt


@@ 175,8 175,8 @@ checkTypeVarsBound ds = runReaderT (boundInDefs ds) Set.empty
        An.Ctor _ (_, instTs) ts -> do
            forM_ instTs (boundInType pos)
            forM_ ts (boundInType pos)
        An.Box e -> boundInExpr e
        An.Deref e -> boundInExpr e
        An.Box x -> boundInExpr x
        An.Deref x -> boundInExpr x
    boundInType :: SrcPos -> An.Type -> Bound
    boundInType pos = \case
        TVar tv ->

M src/Infer.hs => src/Infer.hs +15 -12
@@ 194,12 194,12 @@ infer (WithPos pos e) = fmap (second (WithPos pos)) $ case e of
        dt <- toDecisionTree' pos tpat cases'
        pure (TFun tpat tbody, FunMatch dt tpat tbody)
    Ast.Ctor c -> inferExprConstructor c
    Ast.Box e -> fmap (\(te, e') -> (TBox te, Box e')) (infer e)
    Ast.Deref e -> do
    Ast.Box x -> fmap (\(tx, x') -> (TBox tx, Box x')) (infer x)
    Ast.Deref x -> do
        t <- fresh
        (te, e') <- infer e
        unify (Expected (TBox t)) (Found (getPos e) te)
        pure (t, Deref e')
        (tx, x') <- infer x
        unify (Expected (TBox t)) (Found (getPos x) tx)
        pure (t, Deref x')

toDecisionTree' :: SrcPos -> Type -> [(SrcPos, Pat, Expr)] -> Infer DecisionTree
toDecisionTree' pos tpat cases = do


@@ 209,7 209,7 @@ toDecisionTree' pos tpat cases = do
    -- error messages for inexhaustive patterns, so apply substitutions.
    s <- use substs
    let tpat' = subst s tpat
    let cases' = map (\(pos, p, e) -> (pos, substPat s p, e)) cases
    let cases' = map (\(cpos, p, e) -> (cpos, substPat s p, e)) cases
    mTypeDefs <- views envTypeDefs (fmap (map fst . snd))
    lift (lift (toDecisionTree mTypeDefs pos tpat' cases'))



@@ 235,7 235,7 @@ inferCase (p, b) = do
    let ppos = getPos p
    pure (Found ppos tp, Found (getPos b) tb, (ppos, p', b'))

inferPat :: Ast.Pat -> Infer (Type, Pat, Map (Id Small) Scheme)
inferPat :: Ast.Pat -> Infer (Type, Pat, Map (Id 'Small) Scheme)
inferPat = \case
    Ast.PConstruction pos c ps -> inferPatConstruction pos c ps
    Ast.PVar (Id (WithPos _ "_")) -> do


@@ 246,7 246,10 @@ inferPat = \case
        pure (tv, PVar (TypedVar x' tv), Map.singleton x (Forall Set.empty tv))

inferPatConstruction
    :: SrcPos -> Id Big -> [Ast.Pat] -> Infer (Type, Pat, Map (Id Small) Scheme)
    :: SrcPos
    -> Id 'Big
    -> [Ast.Pat]
    -> Infer (Type, Pat, Map (Id 'Small) Scheme)
inferPatConstruction pos c cArgs = do
    (variantIx, tdefLhs, cParams, cSpan) <- lookupEnvConstructor c
    let arity = length cParams


@@ 262,13 265,13 @@ inferPatConstruction pos c cArgs = do
    pure (t, PCon con cArgs', cArgsVars')

nonconflictingPatVarDefs
    :: [Map (Id Small) Scheme] -> Infer (Map (Id Small) Scheme)
    :: [Map (Id 'Small) Scheme] -> Infer (Map (Id 'Small) Scheme)
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)
        Nothing -> pure (Map.union acc ks)

inferExprConstructor :: Id Big -> Infer (Type, Expr')
inferExprConstructor :: Id 'Big -> Infer (Type, Expr')
inferExprConstructor c = do
    (variantIx, tdefLhs, cParams, _) <- lookupEnvConstructor c
    (tdefInst, cParams') <- instantiateConstructorOfTypeDef tdefLhs cParams


@@ 283,7 286,7 @@ instantiateConstructorOfTypeDef (tName, tParams) cParams = do
    pure ((tName, tVars), cParams')

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


@@ 297,7 300,7 @@ litType = \case
    Str _ -> TConst ("Str", [])
    Bool _ -> TPrim TBool

lookupEnv :: Id Small -> Infer Type
lookupEnv :: Id 'Small -> Infer Type
lookupEnv (Id (WithPos pos x)) = views envDefs (Map.lookup x) >>= \case
    Just scm -> instantiate scm
    Nothing -> throwError (UndefVar pos x)

M src/Match.hs => src/Match.hs +2 -2
@@ 78,12 78,12 @@ toDecisionTree
    -> Type
    -> [(SrcPos, Pat, Expr)]
    -> Except TypeErr DecisionTree
toDecisionTree tds exprPos tpat cases =
toDecisionTree tds ePos tp cases =
    let
        rules = map (\(pos, p, e) -> (p, (pos, Map.empty, e))) cases
        redundantCases = map (\(pos, _, _) -> pos) cases
    in do
        let env = Env { _tdefs = tds, _tpat = tpat, _exprPos = exprPos }
        let env = Env { _tdefs = tds, _tpat = tp, _exprPos = ePos }
        (d, redundantCases') <- runStateT
            (runReaderT (compile rules) env)
            redundantCases

M src/Parse.hs => src/Parse.hs +13 -13
@@ 101,7 101,7 @@ defTyped = (reserved "define:" *>) . def' (fmap Just scheme)
def'
    :: Parser (Maybe (WithPos Scheme))
    -> SrcPos
    -> Parser (Id Small, (Maybe (WithPos Scheme), Expr))
    -> Parser (Id 'Small, (Maybe (WithPos Scheme), Expr))
def' schemeParser topPos = varDef <|> funDef
  where
    varDef = do


@@ 113,15 113,15 @@ def' schemeParser topPos = varDef <|> funDef
        (name, params) <- parens (liftM2 (,) small' (some small'))
        scm <- schemeParser
        body <- expr
        let fun = foldr (WithPos topPos .* Fun) body params
        pure (name, (scm, fun))
        let f = foldr (WithPos topPos .* Fun) body params
        pure (name, (scm, f))

expr :: Parser Expr
expr = andSkipSpaceAfter ns_expr

ns_expr :: Parser Expr
ns_expr = withPos
    $ choice [unit, charLit, str, bool, var, num, eConstructor, pexpr]
    $ choice [unit, charLit, str, ebool, var, num, eConstructor, pexpr]
  where
    unit = ns_reserved "unit" $> Lit Unit
    num = do


@@ 139,13 139,13 @@ ns_expr = withPos
        (between (char '\'') (char '\'') Lexer.charLiteral)
    str =
        fmap (Lit . Str) $ char '"' >> manyTill Lexer.charLiteral (char '"')
    bool = do
        b <- (ns_reserved "true" $> True) <|> (ns_reserved "false" $> False)
        pure (Lit (Bool b))
    ebool = fmap (Lit . Bool) bool
    pexpr =
        ns_parens $ choice
            [funMatch, match, if', fun, let', typeAscr, box, deref, app]

bool :: Parser Bool
bool = (ns_reserved "true" $> True) <|> (ns_reserved "false" $> False)

eConstructor :: Parser Expr'
eConstructor = fmap Ctor ns_big'


@@ 190,10 190,10 @@ app = do
if' :: Parser Expr'
if' = do
    reserved "if"
    pred <- expr
    pred' <- expr
    conseq <- expr
    alt <- expr
    pure (If pred conseq alt)
    pure (If pred' conseq alt)

fun :: Parser Expr'
fun = do


@@ 304,10 304,10 @@ ns_parens p = choice
        [("(", ")"), ("[", "]")]
    )

big' :: Parser (Id Big)
big' :: Parser (Id 'Big)
big' = andSkipSpaceAfter ns_big'

ns_big' :: Parser (Id Big)
ns_big' :: Parser (Id 'Big)
ns_big' = fmap Id (withPos ns_big)

big :: Parser String


@@ 321,10 321,10 @@ ns_big = try $ do
        then pure s
        else fail "Big identifier must start with an uppercase letter or colon."

small' :: Parser (Id Small)
small' :: Parser (Id 'Small)
small' = andSkipSpaceAfter ns_small'

ns_small' :: Parser (Id Small)
ns_small' :: Parser (Id 'Small)
ns_small' = fmap Id $ withPos $ try $ do
    s <- identifier
    let c = head s