Language/Symantic/Expr/If.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 {-# LANGUAGE TypeOperators #-}
   6 -- | Expression for @if@.
   7 module Language.Symantic.Expr.If where
   8
   9 import Data.Proxy (Proxy(..))
  10 import Data.Type.Equality ((:~:)(Refl))
  11 import Language.Symantic.Expr.Common
  12 import Language.Symantic.Repr.Dup
  13 import Language.Symantic.Trans.Common
  14 import Language.Symantic.Type
  15
  16 -- * Class 'Sym_If'
  17 -- | Symantic.
  18 class Sym_If repr where
  19         if_  :: repr Bool -> repr a -> repr a -> repr a
  20         default if_ :: Trans t repr => t repr Bool -> t repr a -> t repr a -> t repr a
  21         if_  = trans_map3 if_
  22
  23 instance -- Sym_If Dup
  24  ( Sym_If r1
  25  , Sym_If r2
  26  ) => Sym_If (Dup r1 r2) where
  27         if_ (c1 `Dup` c2) (ok1 `Dup` ok2) (ko1 `Dup` ko2) =
  28                 if_ c1 ok1 ko1 `Dup` if_ c2 ok2 ko2
  29
  30 -- * Class 'Sym_When'
  31 -- | Symantic.
  32 class Sym_When repr where
  33         when :: repr Bool -> repr () -> repr ()
  34         default when :: Trans t repr => t repr Bool -> t repr () -> t repr ()
  35         when = trans_map2 when
  36
  37 instance -- Sym_When Dup
  38  ( Sym_When r1
  39  , Sym_When r2
  40  ) => Sym_When (Dup r1 r2) where
  41         when (c1 `Dup` c2) (ok1 `Dup` ok2) =
  42                 when c1 ok1 `Dup` when c2 ok2
  43
  44 -- * Type 'Expr_If'
  45 -- | Expression.
  46 data Expr_If (root:: *)
  47 type instance Root_of_Expr      (Expr_If root)      = root
  48 type instance Type_of_Expr      (Expr_If root)      = No_Type
  49 type instance Sym_of_Expr       (Expr_If root) repr = (Sym_If repr)
  50 type instance Error_of_Expr ast (Expr_If root)      = No_Error_Expr
  51
  52 if_from
  53  :: forall root ty ast hs ret.
  54  ( ty ~ Type_Root_of_Expr (Expr_If root)
  55  , Eq_Type ty
  56  , Type_Root_Lift Type_Bool (Type_Root_of_Expr root)
  57  , Expr_from ast root
  58  , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
  59                    (Error_of_Expr ast root)
  60  , Root_of_Expr root ~ root
  61  ) => ast -> ast -> ast
  62  -> Expr_From ast (Expr_If root) hs ret
  63 if_from ast_cond ast_ok ast_ko ex ast ctx k =
  64         expr_from (Proxy::Proxy root) ast_cond ctx $
  65          \(ty_cond::Type_Root_of_Expr root h_n) (Forall_Repr_with_Context cond) ->
  66         expr_from (Proxy::Proxy root) ast_ok ctx $
  67          \(ty_ok::Type_Root_of_Expr root h_ok) (Forall_Repr_with_Context ok) ->
  68         expr_from (Proxy::Proxy root) ast_ko ctx $
  69          \(ty_ko::Type_Root_of_Expr root h_ko) (Forall_Repr_with_Context ko) ->
  70         check_eq_type ex ast type_bool ty_cond $ \Refl ->
  71         check_eq_type ex ast ty_ok ty_ko $ \Refl ->
  72         k ty_ok $ Forall_Repr_with_Context $
  73          \c -> if_ (cond c) (ok c) (ko c)
  74
  75 -- * Type 'Expr_When'
  76 -- | Expression.
  77 data Expr_When (root:: *)
  78 type instance Root_of_Expr      (Expr_When root)      = root
  79 type instance Type_of_Expr      (Expr_When root)      = No_Type
  80 type instance Sym_of_Expr       (Expr_When root) repr = (Sym_When repr)
  81 type instance Error_of_Expr ast (Expr_When root)      = No_Error_Expr
  82
  83 when_from
  84  :: forall root ty ast hs ret.
  85  ( ty ~ Type_Root_of_Expr (Expr_When root)
  86  , Eq_Type ty
  87  , Type_Root_Lift Type_Bool (Type_Root_of_Expr root)
  88  , Type_Root_Lift Type_Unit (Type_Root_of_Expr root)
  89  , Expr_from ast root
  90  , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
  91                    (Error_of_Expr ast root)
  92  , Root_of_Expr root ~ root
  93  ) => ast -> ast
  94  -> Expr_From ast (Expr_When root) hs ret
  95 when_from ast_cond ast_ok ex ast ctx k =
  96         expr_from (Proxy::Proxy root) ast_cond ctx $
  97          \(ty_cond::Type_Root_of_Expr root h_n) (Forall_Repr_with_Context cond) ->
  98         expr_from (Proxy::Proxy root) ast_ok ctx $
  99          \(ty_ok::Type_Root_of_Expr root h_ok) (Forall_Repr_with_Context ok) ->
 100         check_eq_type ex ast type_bool ty_cond $ \Refl ->
 101         check_eq_type ex ast type_unit ty_ok $ \Refl ->
 102         k ty_ok $ Forall_Repr_with_Context $
 103          \c -> when (cond c) (ok c)