sem.hs

{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveFunctor, DeriveFoldable, DeriveTraversable, FlexibleInstances #-}
{-# LANGUAGE LambdaCase, FlexibleContexts, UndecidableInstances, TypeOperators, DataKinds, MultiParamTypeClasses #-}
module Sem where
  
import Data.Algebra
import Data.Constraint
import Data.Constraint.Class1
import Data.Functor.Free

class BaseSem a where
  val :: Int -> a
  add :: a -> a -> a

instance BaseSem Int where
  val = id
  add = (+)

class BaseSem a => AdvSem a where
  mul :: a -> a -> a

instance AdvSem Int where
  mul = (*)

deriveInstances ''BaseSem
deriveInstances ''AdvSem

instance HasSuperClasses BaseSem
instance HasSuperClasses AdvSem where
  type SuperClasses AdvSem = AdvSem ': SuperClasses BaseSem
  superClasses = Sub Dict
  containsSelf = Sub Dict

eval :: Free AdvSem Int -> Int
eval = counit

test :: Free AdvSem String
test = mul (add (pure "a") (val 3)) (val 5)

main :: IO ()
main = print $ rightAdjunct lookupVar test
  where
    lookupVar :: String -> Int
    lookupVar "a" = 2
    lookupVar v = error $ "Unknown variable: " ++ v