Support sort annotations.

[goldfirere]

This panics:

-# LANGUAGE GADTs, PolyKinds, TypeOperators, TemplateHaskell,
             DataKinds, TypeFamilies, UndecidableInstances,
             FlexibleContexts, RankNTypes, ScopedTypeVariables,
             FlexibleInstances #-}
-- {-# OPTIONS_GHC -fwarn-unticked-promoted-constructors #-}

module Part5 where

import Prelude ( Bool(..), undefined, return )
import GHC.TypeLits ( type (-) )
import Data.Singletons
import Data.Singletons.TH
import Data.Singletons.Prelude
import Data.Type.Equality
import Data.Singletons.CustomStar

data Nat :: * where
  Zero :: Nat
  Succ :: Nat -> Nat

data instance Sing (n :: Nat) where
  SZero :: Sing 'Zero
  SSucc :: Sing n -> Sing ('Succ n)

data instance Sing (t :: *) where
  SNat  :: Sing Nat
  SBool :: Sing Bool

(+) :: Nat -> Nat -> Nat
Zero   + m = m
Succ n + m = Succ (n + m)
infixl 6 +

type family a :+ b where
  'Zero :+ m = m
  'Succ n :+ m = 'Succ (n :+ m)

type a ~> b = TyFun a b -> *

$(return [])

data Expr (st :: Sing t) where
  Val  :: t -> Expr (st :: Sing t)
  Plus :: Expr 'SNat -> Expr 'SNat -> Expr 'SNat
  If   :: Expr 'SBool -> Expr st -> Expr st -> Expr st

data instance Sing (e :: Expr st) where
  SVal  :: Sing t -> Sing ('Val t)
  SPlus :: Sing a -> Sing b -> Sing ('Plus a b)
  SIf   :: Sing b -> Sing t -> Sing f -> Sing ('If b t f)

eval :: Expr (st :: Sing t) -> t
eval (Val n)        = n
eval (e1 `Plus` e2) = eval e1 + eval e2
eval (If e0 e1 e2)  = if eval e0 then eval e1 else eval e2

type family Eval (x :: Expr (st :: Sing t)) :: t where
  Eval ('Val n) = n
  Eval ('Plus e1 e2) = Eval e1 :+ Eval e2
  Eval ('If e0 e1 e2) = If (Eval e0) (Eval e1) (Eval e2)