super-simple language and type system

gistfile1.hs

{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-missing-methods #-}
{-# LANGUAGE PatternGuards #-}

import Control.Applicative
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Monoid
import Data.Traversable
import System.Exit

type Possibly a = Either Error a

-- | Errors.
data Error =
    NotBool String
  | NotInt String
  | NotStruct String
  | NotRecord String
  | NoMatch String
  deriving Eq

instance Show Error where
  show (NotBool s)   = s
  show (NotInt s)    = s
  show (NotStruct s) = s
  show (NotRecord s) = s
  show (NoMatch s)   = s

typeErrorPrefix :: String -> String
typeErrorPrefix s = "type error: " <> s

exprErrorPrefix :: String -> String
exprErrorPrefix s = "error: " <> s

-- | Type error handler.
typeHandler :: Show s => Either s a -> IO a
typeHandler (Right r) = return r
typeHandler (Left e)  = do
  putStrLn . typeErrorPrefix . show $ e
  exitFailure

-- | Expression error handler.
exprHandler :: Show s => Either s a -> IO a
exprHandler (Right r) = return r
exprHandler (Left e)  = do
  putStrLn . exprErrorPrefix . show $ e
  exitFailure

type Environment a = HashMap String a

-- | Expressions for our toy language.
data Expr = 
    LitInt Int
  | Add Expr Expr
  | LitBool Bool
  | If Expr Expr Expr
  | Struct (Environment Expr)
  | Projection Expr String
  deriving (Eq, Show)

instance Num Expr where
  e0 + e1     = Add e0 e1
  fromInteger = LitInt . fromInteger

-- | Values that expressions can evaluate to.
data Value =
    ValInt Int
  | ValBool Bool
  | ValStruct (Environment Value)
  deriving Eq

instance Show Value where
  show (ValInt j)    = show j
  show (ValBool b)   = show b
  show (ValStruct s) = show $ HashMap.toList s

-- | Semantics of our language.
eval :: Expr -> Possibly Value
eval (LitInt j)   = return $ ValInt j
eval (LitBool b)  = return $ ValBool b
eval (Add e0 e1)  = do
  i0 <- eval e0
  i1 <- eval e1
  addVals i0 i1

eval (If b e0 e1) 
  | Right (ValBool True)  <- eval b = eval e0
  | Right (ValBool False) <- eval b = eval e1
  | otherwise = do
      checked <- typeCheck b
      Left . NotBool $ "expected Bool, got: " <> show checked

eval (Struct env)               = ValStruct <$> traverse eval env
eval (Projection struct record) = eval struct >>= projectVal record

-- | The type system of our language.
data Type =
    BoolType
  | IntType
  | StructType (Environment Type)
  deriving Eq

instance Show Type where
  show BoolType       = "Bool"
  show IntType        = "Int"
  show (StructType s) = "Struct " <> show (HashMap.toList s)

-- | The type checker.
typeCheck :: Expr -> Possibly Type
typeCheck (LitBool _) = return BoolType
typeCheck (LitInt _)  = return IntType
typeCheck (Add e0 e1) 
  | typeCheck e0 /= typeCheck e1 = do
      checked0 <- typeCheck e0
      checked1 <- typeCheck e1
      Left . NotInt $ "expected two Ints, got: " <> show checked0 <> ", "
                   <> show checked1

  | Right IntType <- typeCheck e0
      = return IntType

  | otherwise = Left . NotInt $
      "expected Int, got: " 

typeCheck (If b e0 e1)
  | typeCheck b /= Right BoolType = do
      checked <- typeCheck b
      Left . NotBool $ "expected Bool, got: " <> show checked

  | typeCheck e0 /= typeCheck e1 = do
      checked0 <- typeCheck e0
      checked1 <- typeCheck e1
      Left . NoMatch $
           "expected types to match, got: " <> show checked0 <> " and "
        <> show checked1

  | otherwise = typeCheck e0

typeCheck (Struct s) = StructType <$> traverse typeCheck s

typeCheck (Projection struct record)
  | Right (StructType _) <- typeCheck struct
      = projectExpr record struct >>= typeCheck
  | otherwise = do
      checked <- typeCheck struct
      Left . NotStruct $ "expected Struct, got: "<> show checked

-- | Projection from a ValStruct.
projectVal :: String -> Value -> Possibly Value
projectVal record (ValStruct env) =
    note (NotRecord msg) . HashMap.lookup record $ env
  where
    msg = "record not found: " <> record

projectVal record v = Left . NotStruct $
  "expected struct for record " <> record <> ", got:" <> show v

-- | Projection from a Struct.
projectExpr :: String -> Expr -> Possibly Expr
projectExpr record (Struct env) =
    note (NotRecord msg) . HashMap.lookup record $ env
  where
    msg = "record not found: " <> record

projectExpr record e = Left . NotStruct $
  "expected struct for record " <> record <> ", got:" <> show e

-- | Add ValInts together.
addVals :: Value -> Value -> Possibly Value
addVals (ValInt i) (ValInt j) = return . ValInt $ i + j
addVals i j = Left . NotInt $
  "expected Ints, got: " <> show i <> " and " <> show j

-- | Add some information to a Maybe.
note :: a -> Maybe b -> Either a b
note _ (Just j) = Right j
note e Nothing  = Left e

-- | An embedded interpreter.
interpret :: Expr -> IO ()
interpret e
    | Right _ <- check = exprHandler (eval e) >>= print
    | otherwise        = typeHandler check >>= print
  where
    check = typeCheck e

-- Examples

ex0 :: Expr
ex0 = Struct $ HashMap.fromList [
    ("one", LitInt 1)
  , ("two", LitBool True)
  , ("three", Add (LitInt 1) (LitInt 1))
  ]

ex1 :: Expr
ex1 = Struct $ HashMap.fromList [
    ("one", LitInt 1)
  , ("two", LitBool True)
  , ("three", Add (LitInt 1) (LitBool False))
  ]

ex2 :: Expr
ex2 = Projection (Struct $ HashMap.fromList [
    ("one", LitInt 1)
  , ("two", If (LitBool True) (LitInt 1) (LitInt 0))
  ]) "two"

ex3 :: Expr
ex3 = Projection (Struct $ HashMap.fromList [
    ("one", LitInt 1)
  , ("two", If (LitInt 0) (LitInt 1) (LitInt 2))
  ]) "one"