Expression som comonad

Expression.hs

{-# 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)

Grammar.hs

{-# 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

Positioned.hs

{-# 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

Typed.hs

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