Skip to content

Instantly share code, notes, and snippets.

@mbloms
Last active December 15, 2017 13:38
Show Gist options
  • Save mbloms/d5af954c3ff2c55fff5da900c7fb72e8 to your computer and use it in GitHub Desktop.
Save mbloms/d5af954c3ff2c55fff5da900c7fb72e8 to your computer and use it in GitHub Desktop.
Expression som comonad
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}
import Grammar (BinOp, Identifier, Type, HashMap)
import Typed
import Control.Comonad
import Control.Applicative (liftA2)
data Expression t
= BinOp {lhs :: Expression t, op :: BinOp, rhs :: Expression t, typ :: t}
| MethodCall (Expression t) Identifier [Expression t] t
| LitInt Int t
| LitString String t
| LitTrue t
| LitFalse t
| Identifier {id :: Identifier, typ :: t}
| LitThis t
| LitNull t
| New {obj ::Identifier, typ :: t}
| Not {expr :: (Expression t), typ :: t}
| Block [Expression t] t
| If { predicate :: Expression t
, body :: Expression t
, elseBody :: (Maybe (Expression t))
, typ :: t
}
| While { predicate :: Expression t, body :: Expression t, typ :: t }
| Println { expr :: Expression t, typ :: t }
| Assign { var :: Identifier, expr :: Expression t, typ :: t }
| Lambda { var :: Identifier
, argType :: Type
, expr :: Expression t
, returnType :: (Maybe Type)
, typ :: t
}
| Closure { free :: (HashMap Identifier ())
, var :: Identifier
, argType :: Type
, expr :: Expression t
, returnType :: (Maybe Type)
, typ :: t
}
deriving (Eq, Show)
instance Functor Expression where
fmap = liftW
instance Comonad Expression where
extract (MethodCall _ _ _ t) = t
extract (LitInt _ t) = t
extract (LitString _ t) = t
extract (LitTrue t) = t
extract (LitFalse t) = t
extract (LitThis t) = t
extract (LitNull t) = t
extract (Block _ t) = t
extract exp = typ exp
extend f exp@(MethodCall object iden params t) = MethodCall (extend f object) iden (fmap (extend f) params) (f exp)
extend f exp@(LitInt x _) = LitInt x (f exp)
extend f exp@(LitString x _) = LitString x (f exp)
extend f exp@(LitTrue _) = LitTrue (f exp)
extend f exp@(LitFalse _) = LitFalse (f exp)
extend f exp@(LitThis _) = LitThis (f exp)
extend f exp@(LitNull _) = LitNull (f exp)
extend f exp@(Block x _) = Block (fmap (extend f) x) (f exp)
extend f (Not exp t) = Not (extend f exp) (f $ Not exp t)
extend f exp@(If pred body elseB _) = If (e pred) (e body) (fmap e elseB) (f exp)
where e = extend f
extend f exp@While{predicate,body} = While (e predicate) (e body) (f exp)
where e = extend f
extend f exp@Println{expr} = exp {expr = extend f expr, typ = f exp}
extend f exp@Assign{expr} = exp {expr = extend f expr, typ = f exp}
extend f exp@Lambda{expr} = exp {expr = extend f expr, typ = f exp}
extend f exp@Closure{expr} = exp {expr = extend f expr, typ = f exp}
extend f exp@BinOp{lhs,rhs} = exp {lhs = extend f lhs, rhs = extend f rhs, typ = f exp}
extend f exp@(Identifier i _) = Identifier i (f exp)
extend f exp@(New o _) = New o (f exp)
isLeaf exp = case exp of
LitInt _ t -> True
LitString _ t -> True
LitTrue t -> True
LitFalse t -> True
Identifier _ t -> True
LitThis t -> True
LitNull t -> True
New _ t -> True
_ -> False
extractSimple exp = case exp of
Not{expr,typ} -> Just (expr,typ)
Println{expr,typ} -> Just (expr,typ)
Assign{expr,typ} -> Just (expr,typ)
Lambda{expr,typ} -> Just (expr,typ)
Closure{expr,typ} -> Just (expr,typ)
_ -> Nothing
instance ComonadApply Expression where
fxp@(extract -> f) <@> exp@(extract -> x) | isLeaf exp = exp $> f x
(BinOp lf _ rf f) <@> (BinOp lx o rx x) = BinOp (lf <@> lx) o (rf <@> rx) (f x)
(MethodCall fo _ fp f) <@> (MethodCall xo iden xp x) = MethodCall (fo <@> xo) iden (zipWith (<@>) fp xp) (f x)
(Not fe f) <@> (Not xe x) = Not (fe <@> xe) (f x)
(Block fe f) <@> (Block xe x) = Block (zipWith (<@>) fe xe) (f x)
(If fp fb fe f) <@> (If xp xb xe x) = If (fp <@> xp) (fb <@> xb) (liftA2 (<@>) fe xe) (f x)
(While fp fb f) <@> (While xp xb x) = While (fp <@> xp) (fb <@> xb) (f x)
(extractSimple -> Just (fe,f)) <@> (Not xe x) = Not (fe <@> xe) (f x)
(extractSimple -> Just (fe,f)) <@> (Println xe x) = Println (fe <@> xe) (f x)
(extractSimple -> Just (fe,f)) <@> (Assign var xe x) = Assign var (fe <@> xe) (f x)
(extractSimple -> Just (fe,f)) <@> exp@Lambda{expr,typ} = exp {expr = fe <@> expr, typ = f typ}
(extractSimple -> Just (fe,f)) <@> exp@Closure{expr,typ} = exp {expr = fe <@> expr, typ = f typ}
types :: Expression String -> Expression TType -> TType
types LitInt{} = const TInt
types Not{} = const TBool
types While{} = \(While _ xb _) -> extract xb
types LitTrue{} = const TBool
types (LitThis klass) = const (TClass klass)
types' :: Expression TType -> TType
types' LitInt{} = TInt
types' Not{} = TBool
types' (While _ xb _) = extract xb
types' LitTrue{} = TBool
-- ComonadInject (TM) där man kan byta översta elementet.
class Comonad w => ComonadInject w where
inject :: a -> w a -> w a
instance ComonadInject Expression where
inject x e | isLeaf e = x <$ e
inject x (Not e _) = Not e x
inject x e = e {typ = x}
--kfix :: ComonadApply w => w (w a -> a) -> w a
--kfix w = fix $ \u -> w <@> duplicate u
--kfix (extend types $ (LitInt 1 ())) :: Expression (Expression TType -> TType) =
-- fix $ \u :: Expression TType -> (extend types $ (LitInt 1 ())) <@> duplicate u
fix f = f (fix f)
-- kfix med 0 sharing.
pfix :: Comonad w => w (w a -> a) -> w a
pfix = fmap wfix . duplicate
bfix :: ComonadApply w => w (w a -> a) -> w a
bfix w = w <@> extend bfix w
bfix2 :: (ComonadApply w, ComonadInject w) => w (w a -> a) -> w a
bfix2 w = let x = w <@> inject undefined (extend bfix2 w) in x
fixtend :: ComonadApply w => (w a -> w b -> b) -> w a -> w b
fixtend f = bfix . extend f
deepen w = While w w (extract w)
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
module Grammar where
import Positioned
import Typed
data Program = Program [ClassDeclaration] [FunctionDeclaration] MainDeclaration Position
deriving (Eq, Show)
data FunctionDeclaration
= Function {name :: Identifier, expr :: Expression, pos :: Position}
deriving (Eq, Show)
data ClassDeclaration = Class
{ name :: Identifier
, extends :: (Maybe Identifier)
, vars :: [VarDeclaration]
, methods :: [MethodDeclaration]
, pos :: Position
}
deriving (Eq, Show)
data MainDeclaration = Main
{ name :: Identifier
, extendsApp :: Identifier
, vars :: [VarDeclaration]
, body :: [Expression]
, pos :: Position
}
deriving (Eq, Show)
data VarDeclaration = Var
{ name :: Identifier
, varType :: Type
, expr :: Expression
, pos :: Position
}
deriving (Eq, Show)
data MethodDeclaration = MethodDeclaration
{ override :: Bool
, name :: Identifier
, args :: [(Identifier, Type)]
, methodType :: Type
, vars :: [VarDeclaration]
, exprs :: [Expression]
, pos :: Position
}
deriving (Eq, Show)
data Type
= Bool
| Int
| String
| Unit
| User {typeName :: Identifier}
| Arrow Type Type
deriving (Eq, Show)
data LocalType
= Param
| LocalVar
deriving (Eq, Show)
data SymbolType
= ClassSymbol
| FieldSymbol String
| MethodSymbol String
| LocalSymbol LocalType Int
| LambdaSymbol
| FunctionSymbol
deriving (Show, Eq)
data Identifier
= ID {str :: String, pos :: Position}
| Symbol{id :: Int, symType :: SymbolType, t :: TType, name :: Identifier}
| FreeSymbol { innerLambda :: Identifier, name :: Identifier}
deriving Show
instance Eq Identifier where
(ID a _) == (ID b _) = a == b
(Symbol _ _ _ a) == (Symbol _ _ _ b) = a == b
(Symbol _ _ _ a) == (b@(ID _ _)) = a == b
(FreeSymbol{name=a}) == b = a == b
a == (FreeSymbol{name=b}) = a == b
(a@(ID _ _)) == (Symbol _ _ _ b) = a == b
instance Ord Identifier where
(ID a _) `compare` (ID b _) = a `compare` b
(Symbol _ _ _ a) `compare` (Symbol _ _ _ b) = a `compare` b
(Symbol _ _ _ a) `compare` (b@(ID _ _)) = a `compare` b
(a@(ID _ _)) `compare` (Symbol _ _ _ b) = a `compare` b
data BinOp
= And
| Or
| Equals
| LessThan
| Plus
| Minus
| Times
| Div
| Apply
deriving (Show, Eq)
data Expression
= BinOp {lhs :: Expression, op :: BinOp, rhs :: Expression, pos :: Position}
| MethodCall Expression Identifier [Expression] Position
| LitInt Int Position
| LitString String Position
| LitTrue Position
| LitFalse Position
| Identifier {id :: Identifier, pos :: Position}
| LitThis Position
| LitNull Position
| New {obj ::Identifier, pos :: Position}
| Not {expr :: Expression, pos :: Position}
| Block [Expression] Position
| If { predicate :: Expression
, body :: Expression
, elseBody :: (Maybe Expression)
, pos :: Position
}
| While { predicate :: Expression, body :: Expression, pos :: Position }
| Println { expr :: Expression, pos :: Position }
| Assign { var :: Identifier, expr :: Expression, pos :: Position }
| Typed { t :: TType, expr :: Expression}
| Lambda { var :: Identifier
, argType :: Type
, expr :: Expression
, returnType :: (Maybe Type)
, pos :: Position
}
| Closure { free :: (HashMap Identifier ())
, var :: Identifier
, argType :: Type
, expr :: Expression
, returnType :: (Maybe Type)
, pos :: Position
}
deriving (Eq, Show)
data HashMap a b = HM
deriving (Show, Eq)
class Named t where
nameOf :: t -> String
class WithId t where
idOf :: t -> Identifier
setId :: Identifier -> t -> t
instance WithId Identifier where
idOf i = i
setId i _ = i
instance WithId ClassDeclaration where
idOf (Class{name}) = name
setId name c = c {name=name}
instance WithId FunctionDeclaration where
idOf Function{name} = name
setId name fn = fn {name=name}
instance WithId MethodDeclaration where
idOf (MethodDeclaration{name}) = name
setId name v = v {name=name}
instance WithId VarDeclaration where
idOf (Var{name}) = name
setId name v = v {name=name}
instance Named Identifier where
nameOf (ID n _) = n
nameOf (Symbol _ _ _ id) = nameOf id
nameOf (FreeSymbol{name}) = nameOf name
instance Named ClassDeclaration where
nameOf (Class{name=id}) = nameOf id
instance Named VarDeclaration where
nameOf (Var{name=id}) = nameOf id
instance Named MethodDeclaration where
nameOf (MethodDeclaration{name=id}) = nameOf id
{-# LANGUAGE FlexibleInstances #-}
module Positioned where
data Position = Pos {offset, line, col :: Int}
deriving Show
initialPosition = Pos 0 1 1
-- All positions are regarded equal
instance Eq Position where
_ == _ = True
class Positioned t where
position :: t -> Position
instance Positioned (a, Position) where
position (_, pos) = pos
module Typed where
data TType
= TBool
| TInt
| TString
| TUnit
| TClass String
| TMethod ([TType], TType)
| TAnyRef
| TBottomRef
| TArrow TType TType
deriving (Eq, Show)
class Typed g where
typeOf :: g -> TType
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment