Created
June 13, 2021 16:50
-
-
Save JSuder-xx/6f674b866e967e7b33ca4a9df123073a to your computer and use it in GitHub Desktop.
Using an expression evaluator as the occasion to experiment with type classes.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| 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) | |
| ] |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment