module Abt.Tutorial where
import Abt.Class
import Abt.Types
import Abt.Concrete.LocallyNameless
import Control.Applicative
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Maybe
import Data.Vinyl
newtype M α
= M
{ _M ∷ State Int α
} deriving (Functor, Applicative, Monad)
runM ∷ M α → α
runM (M m) = evalState m 0
instance MonadVar Var M where
fresh = M $ do
n ← get
let n' = n + 1
put n'
return $ Var Nothing n'
named a = do
v ← fresh
return $ v { _varName = Just a }
data Lang ns where
Lam ∷ Lang '[S Z]
Ap ∷ Lang '[Z,Z]
instance Show1 Lang where
show1 = \case
Lam → "lam"
Ap → "ap"
instance HEq1 Lang where
Lam === Lam = True
Ap === Ap = True
_ === _ = False
newtype StepT m α
= StepT
{ runStepT ∷ MaybeT m α
} deriving (Monad, Functor, Applicative, Alternative)
stepsExhausted
∷ Applicative m
⇒ StepT m α
stepsExhausted = StepT . MaybeT $ pure Nothing
instance MonadVar Var m ⇒ MonadVar Var (StepT m) where
fresh = StepT . MaybeT $ Just <$> fresh
named str = StepT . MaybeT $ Just <$> named str
step
∷ Tm0 Lang
→ StepT M (Tm0 Lang)
step tm =
out tm >>= \case
Ap :$ m :& n :& RNil →
out m >>= \case
Lam :$ xe :& RNil → xe // n
_ → app <$> step m <*> pure n <|> app <$> pure m <*> step n
where
app a b = Ap $$ a :& b :& RNil
_ → stepsExhausted
star
∷ Monad m
⇒ (α → StepT m α)
→ (α → m α)
star f a =
runMaybeT (runStepT $ f a) >>=
return a `maybe` star f
eval ∷ Tm0 Lang → Tm0 Lang
eval = runM . star step
identityTm ∷ M (Tm0 Lang)
identityTm = do
x ← fresh
return $ Lam $$ (x \\ var x) :& RNil
appTm ∷ M (Tm0 Lang)
appTm = do
tm ← identityTm
return $ Ap $$ tm :& tm :& RNil
main ∷ IO ()
main = do
let mm = runM $ appTm >>= toString
mm' = runM $ appTm >>= toString . eval
print $ mm ++ " ~>* " ++ mm'