From: Mart Lubbers Date: Wed, 20 Apr 2016 14:29:35 +0000 (+0200) Subject: small update, inference X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=392b823861ae02cc42454abce8c97e606931c3d6;p=cc1516.git small update, inference --- diff --git a/RWST.dcl b/RWST.dcl index 334df7e..70a07e1 100644 --- a/RWST.dcl +++ b/RWST.dcl @@ -2,7 +2,6 @@ definition module RWST from Control.Applicative import class Applicative from Control.Monad import class Monad -from Data.Void import :: Void from Data.Functor import class Functor from Data.Functor.Identity import :: Identity from Data.Monoid import class Monoid, class Semigroup @@ -36,7 +35,7 @@ local :: (r -> r) (RWST r w s m a) -> RWST r w s m a | Monoid w & Monad m asks :: (r -> a) -> RWST r w s m a | Monoid w & Monad m // Writer operations -tell :: w -> RWST r w s m Void | Monoid w & Monad m +tell :: w -> RWST r w s m () | Monoid w & Monad m listen :: (RWST r w s m a) -> RWST r w s m (a, w) | Monoid w & Monad m pass :: (RWST r w s m (a, w -> w)) -> RWST r w s m a | Monoid w & Monad m listens :: (w -> b) (RWST r w s m a) -> RWST r w s m (a, b)| Monoid w & Monad m @@ -44,8 +43,8 @@ censor :: (w -> w) (RWST r w s m a) -> RWST r w s m a | Monoid w & Monad m // State operations get :: RWST r w s m s | Monoid w & Monad m -put :: s -> RWST r w s m Void | Monoid w & Monad m -modify :: (s -> s) -> RWST r w s m Void | Monoid w & Monad m +put :: s -> RWST r w s m () | Monoid w & Monad m +modify :: (s -> s) -> RWST r w s m () | Monoid w & Monad m gets :: (s -> a) -> RWST r w s m a | Monoid w & Monad m // Lifting other operations diff --git a/RWST.icl b/RWST.icl index 9caa0e6..712f71e 100644 --- a/RWST.icl +++ b/RWST.icl @@ -4,7 +4,6 @@ from StdFunc import o import StdTuple from Data.Func import $ -import Data.Void import Data.Functor.Identity import Data.Functor import Data.Monoid @@ -73,8 +72,8 @@ asks :: (r -> a) -> RWST r w s m a | Monoid w & Monad m asks f = ask >>= \r->pure $ f r // Writer operations -tell :: w -> RWST r w s m Void | Monoid w & Monad m -tell w = RWST \_ s->pure (Void, s,w) +tell :: w -> RWST r w s m () | Monoid w & Monad m +tell w = RWST \_ s->pure ((), s,w) listen :: (RWST r w s m a) -> RWST r w s m (a, w) | Monoid w & Monad m listen m = RWST \r s->runRWST m r s >>= \(a, s`, w)->pure ((a, w), s`, w) @@ -92,10 +91,10 @@ censor f m = pass $ m >>= \a->pure (a, f) get :: RWST r w s m s | Monoid w & Monad m get = RWST \_ s->pure (s, s, mempty) -put :: s -> RWST r w s m Void | Monoid w & Monad m -put s = RWST \_ _->pure (Void, s, mempty) +put :: s -> RWST r w s m () | Monoid w & Monad m +put s = RWST \_ _->pure ((), s, mempty) -modify :: (s -> s) -> RWST r w s m Void | Monoid w & Monad m +modify :: (s -> s) -> RWST r w s m () | Monoid w & Monad m modify f = get >>= \s->put $ f s gets :: (s -> a) -> RWST r w s m a | Monoid w & Monad m diff --git a/sem.icl b/sem.icl index dc774cc..fa081d4 100644 --- a/sem.icl +++ b/sem.icl @@ -5,10 +5,13 @@ import qualified Data.Map as Map from Data.Func import $ from StdFunc import o +import Control.Monad import Data.Either +import Data.Monoid import StdString import StdList +import StdMisc import StdEnum import RWST import GenEq @@ -17,9 +20,10 @@ from Text import class Text(concat), instance Text String import AST -:: Gamma :== 'Map'.Map String Type -:: Constraint :== String -:: Infer a :== RWST [String] [Constraint] Gamma (Either SemError) a +:: Scheme = Forall [String] Type +:: Gamma :== 'Map'.Map String Scheme +:: Constraints :== [(Type, Type)] +:: Infer a :== RWST Gamma Constraints [String] (Either SemError) a :: SemError = ParseError Pos String | UnifyError Pos Type Type @@ -35,8 +39,76 @@ variableStream = map toString [1..] sem :: AST -> SemOutput sem (AST vd fd) = Right $ (AST vd fd, 'Map'.newMap) +instance toString Scheme where + toString (Forall x t) = concat ["Forall ": map ((+++) "\n") x] +++ toString t + instance toString Gamma where toString mp = concat [concat [k, ": ", toString v, "\n"]\\(k, v)<-'Map'.toList mp] instance toString SemError where toString se = "SemError: " + +uni :: Type Type -> Infer () +uni t1 t2 = tell [(t1, t2)] + +inEnv :: (String, Scheme) (Infer a) -> (Infer a) +inEnv (x, sc) m = local scope m + where + scope e = 'Map'.put x sc ('Map'.del x e ) + +class infer a :: a -> Infer Type + +instance infer Expr where + infer (VarExpr _ vd) = undef + infer (Op2Expr _ e1 op e2) = case op of + BiPlus = pure IntType + BiMinus = pure IntType + BiTimes = pure IntType + BiDivide = pure IntType + BiMod = pure IntType + BiLesser = pure IntType + BiGreater = pure IntType + BiLesserEq = pure IntType + BiGreaterEq = pure IntType + BiAnd = pure BoolType + BiOr = pure BoolType + BiEquals = infer e1 + BiUnEqual = infer e1 // maybe check e2? + BiCons = infer e1 >>= \it1->pure $ ListType it1 + infer (Op1Expr _ op e) = case op of + UnMinus = pure IntType + UnNegation = pure BoolType + infer (IntExpr _ _) = pure IntType + infer (CharExpr _ _) = pure CharType + infer (BoolExpr _ _) = pure BoolType + infer (FunExpr _ fc) = undef + infer (EmptyListExpr _) = undef + infer (TupleExpr _ (e1, e2)) = + infer e1 >>= \et1->infer e2 >>= \et2->pure $ TupleType (et1, et2) + +//:: VarDef = VarDef String [FieldSelector] +//:: FieldSelector = FieldHd | FieldTl | FieldFst | FieldSnd +//:: Op1 = UnNegation | UnMinus +//:: Op2 = BiPlus | BiMinus | BiTimes | BiDivide | BiMod | BiEquals | BiLesser | +// BiGreater | BiLesserEq | BiGreaterEq | BiUnEqual | BiAnd | BiOr | BiCons +//:: FunDecl = FunDecl Pos String [String] (Maybe Type) [VarDecl] [Stmt] +//:: FunCall = FunCall String [Expr] +//:: Stmt +// = IfStmt Expr [Stmt] [Stmt] +// | WhileStmt Expr [Stmt] +// | AssStmt VarDef Expr +// | FunStmt FunCall +// | ReturnStmt (Maybe Expr) +//:: Pos = {line :: Int, col :: Int} +//:: AST = AST [VarDecl] [FunDecl] +//:: VarDecl = VarDecl Pos Type String Expr +//:: Type +// = TupleType (Type, Type) +// | ListType Type +// | IdType String +// | IntType +// | BoolType +// | CharType +// | VarType +// | VoidType +// | (->>) infixl 7 Type Type