Using an expression evaluator as the occasion to experiment with type classes.

ExpressionTypeClasses.purs

module Main where

import Prelude

import Data.Foldable (fold)
import Effect (Effect)
import TryPureScript (h1, p, text, render)

import Control.Apply (lift2)
import Data.HeytingAlgebra (ff, tt)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Map (Map, empty, lookup, insert)

data DataType = DTInt Int | DTNumber Number | DTString String

type Environment = Map String DataType

data Expr a = Expr (Environment -> Maybe a)

derive instance functorExpr :: Functor Expr 

instance applyExpr :: Apply Expr where
  apply (Expr fn) (Expr value) = Expr (\env -> do
    fn' <- fn env
    value' <- value env
    Just $ fn' value'
  )

instance applicativeExpr :: Applicative Expr where
  pure = Just >>> const >>> Expr

instance heytingAlgebraExpr :: HeytingAlgebra a => HeytingAlgebra (Expr a) where
  ff = pure ff
  tt = pure tt
  not expr = (not) <$> expr
  conj = lift2 (&&)
  disj = lift2 (||)
  implies = lift2 (\a b -> not a || b)

equals :: forall a. Eq a => Expr a -> Expr a -> Expr Boolean
equals = lift2 (==) 

lessThan :: forall a. Ord a => Expr a -> Expr a -> Expr Boolean
lessThan = lift2 (<) 

greaterThan :: forall a. Ord a => Expr a -> Expr a -> Expr Boolean
greaterThan = lift2 (>)

lessThanOrEqual :: forall a. Ord a => Expr a -> Expr a -> Expr Boolean
lessThanOrEqual = lift2 (<=)

greaterThanOrEqual :: forall a. Ord a => Expr a -> Expr a -> Expr Boolean
greaterThanOrEqual = lift2 (>=)

instance semiRingExpr :: Semiring a => Semiring (Expr a) where
  add = lift2 add
  zero = pure zero
  one = pure one
  mul = lift2 mul

instance ringExpr :: Ring a => Ring (Expr a) where
  sub = lift2 sub

instance commutativeRingExpr :: Ring (Expr a) => CommutativeRing (Expr a)
  
instance euclideanRingExpr :: EuclideanRing a => EuclideanRing (Expr a) where
  degree = const 1
  div = lift2 div
  mod = lift2 mod
  
int :: Int -> Expr Int
int v = pure v

num :: Number -> Expr Number
num n = pure n

readVar :: forall a. (DataType -> Maybe a) -> String -> Expr a
readVar mapResult name = Expr $ (\env -> lookup name env >>= mapResult)

intVar :: String -> Expr Int
intVar = readVar (case _ of 
    DTInt v -> Just v
    _ -> Nothing
)

numVar :: String -> Expr Number
numVar = readVar (case _ of 
  DTNumber n -> Just n 
  _ -> Nothing
)

toString :: forall a. Show a => Expr a -> Expr String
toString = map show

run :: forall a. Expr a -> Environment -> Maybe a
run (Expr expr) map = expr map

----------------------------------------------
-- EXAMPLE
----------------------------------------------
myComputation :: Expr String
myComputation = toString $ (int 10) * (intVar "Stuff") - (intVar "OtherStuff")

main :: Effect Unit
main =
  render $ fold
    [ h1 (text "Try PureScript!")
    , p $ text $ fromMaybe "???" $ run myComputation empty
    , p $ text $ fromMaybe "???" $ run myComputation $ empty # insert "Stuff" (DTInt 5) # insert "OtherStuff" (DTInt 3)
    ]