module Language.Symantic
( -- * Types for the expressions.
- module Language.Symantic.Type
+ module Language.Symantic.Typing
+ {-
, -- * Expressions.
module Language.Symantic.Expr
, -- * Interpreters of expressions.
module Language.Symantic.Repr
, -- * Transformers of expressions
- module Language.Symantic.Trans
+ module Language.Symantic.Trans
+ -}
) where
-import Language.Symantic.Type
-import Language.Symantic.Expr
-import Language.Symantic.Repr
-import Language.Symantic.Trans
+import Language.Symantic.Typing
+-- import Language.Symantic.Expr
+-- import Language.Symantic.Repr
+-- import Language.Symantic.Trans
+++ /dev/null
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
--- | Abstract Syntax Tree.
-module AST.Test where
-
-import Test.Tasty
--- import Test.Tasty.HUnit
-
-import qualified Data.Ord as Ord
-import qualified Data.List as List
-import Data.Map.Strict (Map)
-import Data.Proxy (Proxy(..))
-import Data.Text (Text)
-import qualified Data.Text as Text
-import qualified Data.MonoTraversable as MT
-
-import Language.Symantic.Lib.Data.Bool
-import Language.Symantic.Type
-import Language.Symantic.Expr as Expr
-
-tests :: TestTree
-tests = testGroup "AST" $
- [
- ]
-
--- * Type 'AST'
-data AST
- = AST Text [AST]
- deriving (Eq)
--- | Custom 'Show' instance a little bit more readable
--- than the automatically derived one.
-instance Show AST where
- showsPrec p ast@(AST f args) =
- let n = Text.unpack f in
- case ast of
- AST _ [] -> showString n
- AST "->" [a] ->
- showParen (p Ord.>= prec_arrow) $
- showString ("("++n++") ") .
- showsPrec prec_arrow a
- AST "->" [a, b] ->
- showParen (p Ord.>= prec_arrow) $
- showsPrec prec_arrow a .
- showString (" "++n++" ") .
- showsPrec prec_arrow b
- AST "\\" [var, ty, body] ->
- showParen (p Ord.>= prec_lambda) $
- showString ("\\(") .
- showsPrec prec_lambda var .
- showString (":") .
- showsPrec prec_lambda ty .
- showString (") -> ") .
- showsPrec prec_lambda body
- AST "$" [fun, arg] ->
- showParen (p Ord.>= prec_app) $
- showsPrec prec_app fun .
- showString (" $ ") .
- showsPrec prec_app arg
- _ ->
- showString n .
- showString "(" .
- showString (List.intercalate ", " $ show Prelude.<$> args) .
- showString ")"
- where prec_arrow = 1
- prec_lambda = 1
- prec_app = 1
-
--- ** Parsing utilities
-from_ast0
- :: forall ty ast ex hs ret.
- ( ty ~ Type_Root_of_Expr ex
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast (Root_of_Expr ex))
- ) => [ast]
- -> ExprFrom ast ex hs ret
- -> ExprFrom ast ex hs ret
-from_ast0 asts from ex ast ctx k =
- case asts of
- [] -> from ex ast ctx k
- _ -> Left $ error_expr ex $
- Error_Expr_Wrong_number_of_arguments ast 0
-
-from_ast1
- :: forall ty ast ex hs ret.
- ( ty ~ Type_Root_of_Expr ex
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast (Root_of_Expr ex))
- ) => [ast] -> (ast -> ExprFrom ast ex hs ret)
- -> ExprFrom ast ex hs ret
-from_ast1 asts from ex ast ctx k =
- case asts of
- [ast_0] -> from ast_0 ex ast ctx k
- _ -> Left $ error_expr ex $
- Error_Expr_Wrong_number_of_arguments ast 1
-
-from_ast01
- :: forall ty ast ex hs ret.
- ( ty ~ Type_Root_of_Expr ex
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast (Root_of_Expr ex))
- ) => [ast]
- -> Maybe (ExprFrom ast ex hs ret)
- -> (ast -> ExprFrom ast ex hs ret)
- -> ExprFrom ast ex hs ret
-from_ast01 asts from0 from1 ex ast ctx k =
- case asts of
- [] | Just from <- from0 -> from ex ast ctx k
- [ast_0] -> from1 ast_0 ex ast ctx k
- _ -> Left $ error_expr ex $
- Error_Expr_Wrong_number_of_arguments ast 1
-
-from_ast2
- :: forall ty ast ex hs ret.
- ( ty ~ Type_Root_of_Expr ex
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast (Root_of_Expr ex))
- ) => [ast] -> (ast -> ast -> ExprFrom ast ex hs ret)
- -> ExprFrom ast ex hs ret
-from_ast2 asts from ex ast ctx k =
- case asts of
- [ast_0, ast_1] -> from ast_0 ast_1 ex ast ctx k
- _ -> Left $ error_expr ex $
- Error_Expr_Wrong_number_of_arguments ast 2
-
-from_ast012
- :: forall ty ast ex hs ret.
- ( ty ~ Type_Root_of_Expr ex
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast (Root_of_Expr ex))
- ) => [ast]
- -> Maybe ( ExprFrom ast ex hs ret)
- -> Maybe ( ast -> ExprFrom ast ex hs ret)
- -> (ast -> ast -> ExprFrom ast ex hs ret)
- -> ExprFrom ast ex hs ret
-from_ast012 asts from0 from1 from2 ex ast ctx k =
- case asts of
- [] | Just from <- from0 -> from ex ast ctx k
- [ast_0] | Just from <- from1 -> from ast_0 ex ast ctx k
- [ast_0, ast_1] -> from2 ast_0 ast_1 ex ast ctx k
- _ -> Left $ error_expr ex $
- Error_Expr_Wrong_number_of_arguments ast 2
-
-from_ast3
- :: forall ty ast ex hs ret.
- ( ty ~ Type_Root_of_Expr ex
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast (Root_of_Expr ex))
- ) => [ast] -> (ast -> ast -> ast -> ExprFrom ast ex hs ret)
- -> ExprFrom ast ex hs ret
-from_ast3 asts from ex ast ctx k =
- case asts of
- [ast_0, ast_1, ast_2] -> from ast_0 ast_1 ast_2 ex ast ctx k
- _ -> Left $ error_expr ex $
- Error_Expr_Wrong_number_of_arguments ast 3
-
-lit_from_AST
- :: forall root ty lit ex ast hs ret.
- ( ty ~ Type_Root_of_Expr ex
- , root ~ Root_of_Expr ex
- , ast ~ AST
- , Read lit
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- ) => (forall repr. Sym_of_Expr ex repr => lit -> repr lit)
- -> ty lit -> [ast]
- -> ExprFrom ast ex hs ret
-lit_from_AST op ty_lit asts ex ast ctx k =
- case asts of
- [AST lit []] -> lit_from op ty_lit lit ex ast ctx k
- _ -> Left $ error_expr ex $
- Error_Expr_Wrong_number_of_arguments ast 1
-
-instance -- Type0_From AST Type_Var0
- ( Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , IBool (Is_Last_Type (Type_Var0 root) root)
- ) => Type0_From AST (Type_Var0 root) where
- type0_from ty ast _k =
- Left $ error_type_unsupported ty ast
- -- NOTE: no support so far.
-instance -- Type0_From AST Type_Var1
- ( Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , IBool (Is_Last_Type (Type_Var1 root) root)
- ) => Type0_From AST (Type_Var1 root) where
- type0_from ty ast _k =
- Left $ error_type_unsupported ty ast
- -- NOTE: no support so far.
-instance -- Type0_From AST Type_Unit
- ( Type_Root_Lift Type_Unit root
- , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , IBool (Is_Last_Type (Type_Unit root) root)
- ) => Type0_From AST (Type_Unit root) where
- type0_from ty ast k =
- case ast of
- AST "()" asts ->
- case asts of
- [] -> k type_unit
- _ -> Left $ error_type_lift $
- Error_Type_Wrong_number_of_arguments ast 0
- _ -> Left $ error_type_unsupported ty ast
-instance -- Type0_From AST Type_Bool
- ( Type_Root_Lift Type_Bool root
- , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , IBool (Is_Last_Type (Type_Bool root) root)
- ) => Type0_From AST (Type_Bool root) where
- type0_from ty ast k =
- case ast of
- AST "Bool" asts ->
- case asts of
- [] -> k type_bool
- _ -> Left $ error_type_lift $
- Error_Type_Wrong_number_of_arguments ast 0
- _ -> Left $ error_type_unsupported ty ast
-instance -- Type0_From AST Type_Char
- ( Type_Root_Lift Type_Char root
- , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , IBool (Is_Last_Type (Type_Char root) root)
- ) => Type0_From AST (Type_Char root) where
- type0_from ty ast k =
- case ast of
- AST "Char" asts ->
- case asts of
- [] -> k type_char
- _ -> Left $ error_type_lift $
- Error_Type_Wrong_number_of_arguments ast 0
- _ -> Left $ error_type_unsupported ty ast
-instance -- Type0_From AST Type_Int
- ( Type_Root_Lift Type_Int root
- , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , IBool (Is_Last_Type (Type_Int root) root)
- ) => Type0_From AST (Type_Int root) where
- type0_from ty ast k =
- case ast of
- AST "Int" asts ->
- case asts of
- [] -> k type_int
- _ -> Left $ error_type_lift $
- Error_Type_Wrong_number_of_arguments ast 0
- _ -> Left $ error_type_unsupported ty ast
-instance -- Type0_From AST Type_Integer
- ( Type_Root_Lift Type_Integer root
- , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , IBool (Is_Last_Type (Type_Integer root) root)
- ) => Type0_From AST (Type_Integer root) where
- type0_from ty ast k =
- case ast of
- AST "Integer" asts ->
- case asts of
- [] -> k type_integer
- _ -> Left $ error_type_lift $
- Error_Type_Wrong_number_of_arguments ast 0
- _ -> Left $ error_type_unsupported ty ast
-instance -- Type0_From AST Type_Text
- ( Type_Root_Lift Type_Text root
- , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , IBool (Is_Last_Type (Type_Text root) root)
- ) => Type0_From AST (Type_Text root) where
- type0_from ty ast k =
- case ast of
- AST "Text" asts ->
- case asts of
- [] -> k type_text
- _ -> Left $ error_type_lift $
- Error_Type_Wrong_number_of_arguments ast 0
- _ -> Left $ error_type_unsupported ty ast
-instance -- Type0_From AST Type_Ordering
- ( Type_Root_Lift Type_Ordering root
- , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , IBool (Is_Last_Type (Type_Ordering root) root)
- ) => Type0_From AST (Type_Ordering root) where
- type0_from ty ast k =
- case ast of
- AST "Ordering" asts ->
- case asts of
- [] -> k type_ordering
- _ -> Left $ error_type_lift $
- Error_Type_Wrong_number_of_arguments ast 0
- _ -> Left $ error_type_unsupported ty ast
-instance -- Type0_From AST Type_Fun
- ( Type0_Eq root
- , Type0_From AST root
- , Type_Root_Lift Type_Fun root
- , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
- , Root_of_Type root ~ root
- , IBool (Is_Last_Type (Type_Fun root) root)
- ) => Type0_From AST (Type_Fun root) where
- type0_from ty ast k =
- case ast of
- AST "->" asts ->
- case asts of
- [ast_arg, ast_res] -> type_fun_from ty ast_arg ast_res k
- _ -> Left $ error_type_lift $
- Error_Type_Wrong_number_of_arguments ast 2
- _ -> Left $ error_type_unsupported ty ast
-instance -- Type0_From AST Type_Maybe
- ( Type0_Eq root
- , Type0_From AST root
- , Type_Root_Lift Type_Maybe root
- , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
- , Root_of_Type root ~ root
- , IBool (Is_Last_Type (Type_Maybe root) root)
- ) => Type0_From AST (Type_Maybe root) where
- type0_from ty ast k =
- case ast of
- AST "Maybe" asts ->
- case asts of
- [ast_a] ->
- type0_from (Proxy::Proxy root) ast_a $ \ty_a ->
- k (type_maybe ty_a)
- _ -> Left $ error_type_lift $
- Error_Type_Wrong_number_of_arguments ast 1
- _ -> Left $ error_type_unsupported ty ast
-instance -- Type0_From AST Type_List
- ( Type0_Eq root
- , Type0_From AST root
- , Type_Root_Lift Type_List root
- , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
- , Root_of_Type root ~ root
- , IBool (Is_Last_Type (Type_List root) root)
- ) => Type0_From AST (Type_List root) where
- type0_from ty ast k =
- case ast of
- AST "[]" asts ->
- case asts of
- [ast_a] ->
- type0_from (Proxy::Proxy root) ast_a $ \ty_a ->
- k (type_list ty_a)
- _ -> Left $ error_type_lift $
- Error_Type_Wrong_number_of_arguments ast 1
- _ -> Left $ error_type_unsupported ty ast
-instance -- Type0_From AST Type_Map
- ( Type0_Eq root
- , Type0_From AST root
- , Type_Root_Lift Type_Map root
- , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
- , Type0_Constraint Ord root
- , Root_of_Type root ~ root
- , IBool (Is_Last_Type (Type_Map root) root)
- ) => Type0_From AST (Type_Map root) where
- type0_from ty ast k =
- case ast of
- AST "Map" asts ->
- case asts of
- [ast_k, ast_a] ->
- type0_from (Proxy::Proxy root) ast_k $ \ty_k ->
- type0_from (Proxy::Proxy root) ast_a $ \ty_a ->
- k (type_map ty_k ty_a)
- _ -> Left $ error_type_lift $
- Error_Type_Wrong_number_of_arguments ast 2
- _ -> Left $ error_type_unsupported ty ast
-instance -- Type0_From AST Type_Tuple2
- ( Type0_Eq root
- , Type0_From AST root
- , Type_Root_Lift Type_Tuple2 root
- , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
- , Root_of_Type root ~ root
- , IBool (Is_Last_Type (Type_Tuple2 root) root)
- ) => Type0_From AST (Type_Tuple2 root) where
- type0_from ty ast k =
- case ast of
- AST "(,)" asts ->
- case asts of
- [ast_a, ast_b] ->
- type0_from (Proxy::Proxy root) ast_a $ \ty_a ->
- type0_from (Proxy::Proxy root) ast_b $ \ty_b ->
- k (type_tuple2 ty_a ty_b)
- _ -> Left $ error_type_lift $
- Error_Type_Wrong_number_of_arguments ast 2
- _ -> Left $ error_type_unsupported ty ast
-instance -- Type0_From AST Type_Either
- ( Type0_Eq root
- , Type0_From AST root
- , Type_Root_Lift Type_Either root
- , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
- , Root_of_Type root ~ root
- , IBool (Is_Last_Type (Type_Either root) root)
- ) => Type0_From AST (Type_Either root) where
- type0_from ty ast k =
- case ast of
- AST "Either" asts ->
- case asts of
- [ast_l, ast_r] ->
- type0_from (Proxy::Proxy root) ast_l $ \ty_l ->
- type0_from (Proxy::Proxy root) ast_r $ \ty_r ->
- k (type_either ty_l ty_r)
- _ -> Left $ error_type_lift $
- Error_Type_Wrong_number_of_arguments ast 2
- _ -> Left $ error_type_unsupported ty ast
-
-instance -- Type1_From AST Type_Maybe
- ( Type0_From AST root
- , Type_Root_Lift Type_Maybe root
- , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
- , Root_of_Type root ~ root
- , IBool (Is_Last_Type (Type_Maybe root) root)
- ) => Type1_From AST (Type_Maybe root) where
- type1_from ty ast k =
- case ast of
- AST "Maybe" asts ->
- case asts of
- [] -> k (Proxy::Proxy Maybe) type_maybe
- _ -> Left $ error_type_lift $
- Error_Type_Wrong_number_of_arguments ast 0
- _ -> Left $ error_type_unsupported ty ast
-instance -- Type1_From AST Type_List
- ( Type0_Eq root
- , Type0_From AST root
- , Type_Root_Lift Type_List root
- , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
- , Root_of_Type root ~ root
- , IBool (Is_Last_Type (Type_List root) root)
- ) => Type1_From AST (Type_List root) where
- type1_from ty ast k =
- case ast of
- AST "[]" asts ->
- case asts of
- [] -> k (Proxy::Proxy []) type_list
- _ -> Left $ error_type_lift $
- Error_Type_Wrong_number_of_arguments ast 0
- _ -> Left $ error_type_unsupported ty ast
-instance -- Type1_From AST Type_IO
- ( Type0_Eq root
- , Type0_From AST root
- , Type_Root_Lift Type_IO root
- , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
- , Root_of_Type root ~ root
- , IBool (Is_Last_Type (Type_IO root) root)
- ) => Type1_From AST (Type_IO root) where
- type1_from ty ast k =
- case ast of
- AST "IO" asts ->
- case asts of
- [] -> k (Proxy::Proxy IO) type_io
- _ -> Left $ error_type_lift $
- Error_Type_Wrong_number_of_arguments ast 0
- _ -> Left $ error_type_unsupported ty ast
-instance -- Type1_From AST Type_Fun
- ( Type0_Eq root
- , Type0_From AST root
- , Type_Root_Lift Type_Fun root
- , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
- , Root_of_Type root ~ root
- , IBool (Is_Last_Type (Type_Fun root) root)
- ) => Type1_From AST (Type_Fun root) where
- type1_from ty ast k =
- case ast of
- AST "->" asts ->
- case asts of
- [ast_arg] ->
- type0_from (Proxy::Proxy root) ast_arg $ \(ty_arg::root h_arg) ->
- k (Proxy::Proxy ((->) h_arg)) $
- type_fun ty_arg
- _ -> Left $ error_type_lift $
- Error_Type_Wrong_number_of_arguments ast 1
- _ -> Left $ error_type_unsupported ty ast
-instance -- Type1_From AST Type_Either
- ( Type0_Eq root
- , Type0_From AST root
- , Type_Root_Lift Type_Either root
- , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
- , Root_of_Type root ~ root
- , IBool (Is_Last_Type (Type_Either root) root)
- ) => Type1_From AST (Type_Either root) where
- type1_from ty ast k =
- case ast of
- AST "Either" asts ->
- case asts of
- [ast_l] ->
- type0_from (Proxy::Proxy root) ast_l $ \(ty_l::root h_l) ->
- k (Proxy::Proxy (Either h_l)) $
- type_either ty_l
- _ -> Left $ error_type_lift $
- Error_Type_Wrong_number_of_arguments ast 1
- _ -> Left $ error_type_unsupported ty ast
-instance -- Type1_From AST Type_Map
- ( Type0_Eq root
- , Type0_From AST root
- , Type_Root_Lift Type_Map root
- , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
- , Root_of_Type root ~ root
- , IBool (Is_Last_Type (Type_Map root) root)
- ) => Type1_From AST (Type_Map root) where
- type1_from ty ast k =
- case ast of
- AST "Map" asts ->
- case asts of
- [ast_k] ->
- type0_from (Proxy::Proxy root) ast_k $ \(ty_k::root h_k) ->
- k (Proxy::Proxy (Map h_k)) $
- type_map ty_k
- _ -> Left $ error_type_lift $
- Error_Type_Wrong_number_of_arguments ast 1
- _ -> Left $ error_type_unsupported ty ast
-instance -- Type1_From AST Type_Tuple2
- ( Type0_Eq root
- , Type0_From AST root
- , Type_Root_Lift Type_Tuple2 root
- , Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , Error_Type_Unlift (Error_Type AST) (Error_of_Type AST root)
- , Root_of_Type root ~ root
- , IBool (Is_Last_Type (Type_Tuple2 root) root)
- ) => Type1_From AST (Type_Tuple2 root) where
- type1_from ty ast k =
- case ast of
- AST "(,)" asts ->
- case asts of
- [ast_a] ->
- type0_from (Proxy::Proxy root) ast_a $ \(ty_a::root h_a) ->
- k (Proxy::Proxy ((,) h_a)) $
- type_tuple2 ty_a
- _ -> Left $ error_type_lift $
- Error_Type_Wrong_number_of_arguments ast 1
- _ -> Left $ error_type_unsupported ty ast
-
-instance -- Expr_From AST Expr_Bool
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Type0_Unlift Type_Bool (Type_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_Bool root) root)
- ) => Expr_From AST (Expr_Bool root) where
- expr_from ex ast =
- case ast of
- AST "bool" asts -> lit_from_AST bool t asts ex ast
- AST "not" asts -> from_ast01 asts (Just $ op1_from0 Expr.not t) (op1_from Expr.not t) ex ast
- AST "&&" asts -> from_ast012 asts (Just $ op2_from0 (Expr.&&) t) (Just $ op2_from1 (Expr.&&) t) (op2_from (Expr.&&) t) ex ast
- AST "||" asts -> from_ast012 asts (Just $ op2_from0 (Expr.||) t) (Just $ op2_from1 (Expr.||) t) (op2_from (Expr.||) t) ex ast
- AST "xor" asts -> from_ast012 asts (Just $ op2_from0 (Expr.xor) t) (Just $ op2_from1 Expr.xor t) (op2_from Expr.xor t) ex ast
- _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
- where t = type_bool
-instance -- Expr_From AST Expr_If
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_If root) root)
- ) => Expr_From AST (Expr_If root) where
- expr_from ex ast ctx k =
- case ast of
- AST "if" asts -> from_ast3 asts if_from ex ast ctx k
- _ -> Left $ error_expr_unsupported ex ast
-instance -- Expr_From AST Expr_When
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Type0_Lift Type_Unit (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_When root) root)
- ) => Expr_From AST (Expr_When root) where
- expr_from ex ast ctx k =
- case ast of
- AST "when" asts -> from_ast2 asts when_from ex ast ctx k
- _ -> Left $ error_expr_unsupported ex ast
-instance -- Expr_From AST Expr_Int
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_Lift Type_Int (Type_of_Expr root)
- , Type0_Unlift Type_Int (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_Int root) root)
- ) => Expr_From AST (Expr_Int root) where
- expr_from ex ast =
- case ast of
- AST "int" asts -> lit_from_AST int type_int asts ex ast
- _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
-instance -- Expr_From AST Expr_Integer
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_Lift Type_Integer (Type_of_Expr root)
- , Type0_Unlift Type_Integer (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_Integer root) root)
- ) => Expr_From AST (Expr_Integer root) where
- expr_from ex ast =
- case ast of
- AST "integer" asts -> lit_from_AST integer type_integer asts ex ast
- _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
-instance -- Expr_From AST Expr_Num
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_Constraint Num (Type_Root_of_Expr root)
- , Type0_Lift Type_Integer (Type_of_Expr root)
- , Type0_Unlift Type_Integer (Type_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_Num root) root)
- ) => Expr_From AST (Expr_Num root) where
- expr_from ex ast =
- let c = (Proxy :: Proxy Num) in
- case ast of
- AST "abs" asts -> from_ast1 asts (class_op1_from Expr.abs c) ex ast
- AST "negate" asts -> from_ast1 asts (class_op1_from Expr.negate c) ex ast
- AST "signum" asts -> from_ast1 asts (class_op1_from Expr.signum c) ex ast
- AST "+" asts -> from_ast012 asts Nothing (Just $ class_op2_from1 (Expr.+) c) (class_op2_from (Expr.+) c) ex ast
- AST "-" asts -> from_ast012 asts Nothing (Just $ class_op2_from1 (Expr.-) c) (class_op2_from (Expr.-) c) ex ast
- AST "*" asts -> from_ast012 asts Nothing (Just $ class_op2_from1 (Expr.*) c) (class_op2_from (Expr.*) c) ex ast
- AST "fromInteger" asts -> from_ast1 asts fromInteger_from ex ast
- _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
-instance -- Expr_From AST Expr_Integral
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_Constraint Integral (Type_Root_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Lift Type_Integer (Type_of_Expr root)
- , Type0_Lift Type_Tuple2 (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_Integral root) root)
- ) => Expr_From AST (Expr_Integral root) where
- expr_from ex ast =
- let c = (Proxy :: Proxy Integral) in
- case ast of
- AST "quot" asts -> from_ast012 asts Nothing (Just $ class_op2_from1 Expr.quot c) (class_op2_from Expr.quot c) ex ast
- AST "div" asts -> from_ast012 asts Nothing (Just $ class_op2_from1 Expr.div c) (class_op2_from Expr.div c) ex ast
- AST "rem" asts -> from_ast012 asts Nothing (Just $ class_op2_from1 Expr.rem c) (class_op2_from Expr.rem c) ex ast
- AST "mod" asts -> from_ast012 asts Nothing (Just $ class_op2_from1 Expr.mod c) (class_op2_from Expr.mod c) ex ast
- AST "quotRem" asts -> from_ast012 asts Nothing (Just quotRem_from1) quotRem_from ex ast
- AST "divMod" asts -> from_ast012 asts Nothing (Just divMod_from1) divMod_from ex ast
- _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
-instance -- Expr_From AST Expr_Text
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_Lift Type_Text (Type_of_Expr root)
- , Type0_Unlift Type_Text (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_Text root) root)
- ) => Expr_From AST (Expr_Text root) where
- expr_from ex ast =
- case ast of
- AST "text" asts ->
- case asts of
- [AST lit []] -> \_ctx k ->
- k type_text $ Forall_Repr_with_Context $ \_c -> text lit
- _ -> \_ctx _k -> Left $ error_expr ex $
- Error_Expr_Wrong_number_of_arguments ast 1
- _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
-instance -- Expr_From AST Expr_Char
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_Lift Type_Char (Type_of_Expr root)
- , Type0_Unlift Type_Char (Type_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_Char root) root)
- ) => Expr_From AST (Expr_Char root) where
- expr_from ex ast =
- case ast of
- AST "char" asts ->
- case asts of
- [AST lit []] ->
- case Text.uncons lit of
- Just (c, "") -> \_ctx k ->
- k type_char $ Forall_Repr_with_Context $ \_c -> char c
- _ -> \_ctx _k -> Left $ error_expr ex $
- Error_Expr_Read (Error_Read lit) ast
- _ -> \_ctx _k -> Left $ error_expr ex $
- Error_Expr_Wrong_number_of_arguments ast 1
- AST "char_toUpper" asts -> from_ast01 asts (Just $ op1_from0 char_toUpper type_char) (op1_from char_toUpper type_char) ex ast
- _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
-instance -- Expr_From AST Expr_Lambda
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_From AST (Type_Root_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr_Lambda AST) (Error_of_Expr AST root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_Lambda root) root)
- ) => Expr_From AST (Expr_Lambda root) where
- expr_from ex ast ctx k =
- case ast of
- AST "var" asts ->
- case asts of
- [AST name []] -> var_from name ex ast ctx k
- _ -> Left $ error_expr ex $
- Error_Expr_Wrong_number_of_arguments ast 1
- AST "$" asts -> from_ast2 asts app_from ex ast ctx k
- AST "\\" asts -> go_lam asts
- AST "let" asts -> go_let asts
- _ -> Left $ error_expr_unsupported ex ast
- where
- go_lam asts =
- case asts of
- [AST name [], ast_ty_arg, ast_body] ->
- lam_from name ast_ty_arg ast_body ex ast ctx k
- _ -> Left $ error_expr ex $
- Error_Expr_Wrong_number_of_arguments ast 3
- go_let asts =
- case asts of
- [AST name [], ast_var, ast_body] ->
- let_from name ast_var ast_body ex ast ctx k
- _ -> Left $ error_expr ex $
- Error_Expr_Wrong_number_of_arguments ast 3
-instance -- Expr_From AST Expr_Maybe
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_From AST (Type_Root_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type0_Lift Type_Maybe (Type_of_Expr root)
- , Type0_Unlift Type_Maybe (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_Maybe root) root)
- ) => Expr_From AST (Expr_Maybe root) where
- expr_from ex ast =
- case ast of
- AST "maybe" asts -> from_ast3 asts maybe_from ex ast
- AST "nothing" asts -> from_ast1 asts nothing_from ex ast
- AST "just" asts -> from_ast1 asts just_from ex ast
- _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
-instance -- Expr_From AST Expr_Eq
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Constraint Eq (Type_Root_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_Eq root) root)
- ) => Expr_From AST (Expr_Eq root) where
- expr_from ex ast =
- case ast of
- AST "==" asts -> from_ast012 asts Nothing (Just (eq_from1 (Expr.==))) (eq_from (Expr.==)) ex ast
- AST "/=" asts -> from_ast012 asts Nothing (Just (eq_from1 (Expr./=))) (eq_from (Expr./=)) ex ast
- _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
-instance -- Expr_From AST Expr_Ord
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Lift Type_Ordering (Type_of_Expr root)
- , Type0_Constraint Ord (Type_Root_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_Ord root) root)
- ) => Expr_From AST (Expr_Ord root) where
- expr_from ex ast =
- let c = (Proxy :: Proxy Ord) in
- case ast of
- AST "compare" asts -> from_ast012 asts Nothing (Just compare_from1) compare_from ex ast
- AST "<" asts -> from_ast012 asts Nothing (Just $ ord_from1 (Expr.<)) (ord_from (Expr.<)) ex ast
- AST "<=" asts -> from_ast012 asts Nothing (Just $ ord_from1 (Expr.<=)) (ord_from (Expr.<=)) ex ast
- AST ">" asts -> from_ast012 asts Nothing (Just $ ord_from1 (Expr.>)) (ord_from (Expr.>)) ex ast
- AST ">=" asts -> from_ast012 asts Nothing (Just $ ord_from1 (Expr.>=)) (ord_from (Expr.>=)) ex ast
- AST "min" asts -> from_ast012 asts Nothing (Just $ class_op2_from1 Expr.min c) (class_op2_from Expr.min c) ex ast
- AST "max" asts -> from_ast012 asts Nothing (Just $ class_op2_from1 Expr.max c) (class_op2_from Expr.max c) ex ast
- _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
-instance -- Expr_From AST Expr_List
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_From AST (Type_Root_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type0_Lift Type_List (Type_of_Expr root)
- , Type0_Unlift Type_List (Type_of_Expr root)
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_List root) root)
- ) => Expr_From AST (Expr_List root) where
- expr_from ex ast =
- case ast of
- AST "[]" asts -> from_ast1 asts list_empty_from ex ast
- AST ":" asts -> from_ast2 asts list_cons_from ex ast
- AST "list_filter" asts -> from_ast2 asts list_filter_from ex ast
- AST "list" asts -> \ctx k ->
- case asts of
- ast_ty_a:asts' -> list_from ast_ty_a asts' ex ast ctx k
- _ -> Left $ error_expr ex $
- Error_Expr_Wrong_number_of_arguments ast 1
- AST "list_zipWith" asts -> from_ast3 asts list_zipWith_from ex ast
- AST "list_reverse" asts -> from_ast1 asts list_reverse_from ex ast
- _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
-instance -- Expr_From AST Expr_Map
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Type0_Unlift Type_Bool (Type_of_Expr root)
- , Type0_Lift Type_List (Type_of_Expr root)
- , Type0_Unlift Type_List (Type_of_Expr root)
- , Type0_Lift Type_Map (Type_of_Expr root)
- , Type0_Unlift Type_Map (Type_of_Expr root)
- , Type0_Lift Type_Maybe (Type_of_Expr root)
- , Type0_Unlift Type_Maybe (Type_of_Expr root)
- , Type0_Lift Type_Tuple2 (Type_of_Expr root)
- , Type0_Unlift Type_Tuple2 (Type_of_Expr root)
- , Type0_Constraint Ord (Type_Root_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_Map root) root)
- ) => Expr_From AST (Expr_Map root) where
- expr_from ex ast =
- case ast of
- AST "map_from_list" asts -> from_ast1 asts map_from_list_from ex ast
- AST "mapWithKey" asts -> from_ast2 asts mapWithKey_from ex ast
- AST "map_lookup" asts -> from_ast2 asts map_lookup_from ex ast
- AST "map_keys" asts -> from_ast1 asts map_keys_from ex ast
- AST "map_member" asts -> from_ast2 asts map_member_from ex ast
- AST "map_insert" asts -> from_ast3 asts map_insert_from ex ast
- AST "map_delete" asts -> from_ast2 asts map_delete_from ex ast
- AST "map_difference" asts -> from_ast2 asts map_difference_from ex ast
- AST "map_foldrWithKey" asts -> from_ast3 asts map_foldrWithKey_from ex ast
- _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
-instance -- Expr_From AST Expr_Functor
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type1_Unlift (Type_of_Expr root)
- , Type1_Constraint Functor (Type_Root_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_Functor root) root)
- ) => Expr_From AST (Expr_Functor root) where
- expr_from ex ast =
- case ast of
- AST "fmap" asts -> from_ast2 asts fmap_from ex ast
- AST "<$>" asts -> from_ast2 asts fmap_from ex ast
- _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
-instance -- Expr_From AST Expr_MonoFunctor
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type1_Unlift (Type_of_Expr root)
- , Type0_Constraint MT.MonoFunctor (Type_Root_of_Expr root)
- , Type0_Family Type_Family_MonoElement (Type_Root_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_MonoFunctor root) root)
- ) => Expr_From AST (Expr_MonoFunctor root) where
- expr_from ex ast ctx k =
- case ast of
- AST "omap" asts -> from_ast2 asts omap_from ex ast ctx k
- _ -> Left $ error_expr_unsupported ex ast
-instance -- Expr_From AST Expr_Applicative
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type1_From AST (Type_Root_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type1_Eq (Type_Root_of_Expr root)
- , Type1_Unlift (Type_of_Expr root)
- , Type1_Constraint Applicative (Type_Root_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_Applicative root) root)
- ) => Expr_From AST (Expr_Applicative root) where
- expr_from ex ast =
- case ast of
- AST "pure" asts -> from_ast2 asts pure_from ex ast
- AST "<*>" asts -> from_ast2 asts ltstargt_from ex ast
- _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
-instance -- Expr_From AST Expr_Traversable
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type1_Eq (Type_Root_of_Expr root)
- , Type1_Unlift (Type_of_Expr root)
- , Type1_Constraint Applicative (Type_Root_of_Expr root)
- , Type1_Constraint Traversable (Type_Root_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_Traversable root) root)
- ) => Expr_From AST (Expr_Traversable root) where
- expr_from ex ast ctx k =
- case ast of
- AST "traverse" asts -> from_ast2 asts traverse_from ex ast ctx k
- _ -> Left $ error_expr_unsupported ex ast
-instance -- Expr_From AST Expr_Foldable
- ( Expr_From AST root
- , Type0_Constraint Eq (Type_Root_of_Expr root)
- , Type0_Constraint Monoid (Type_Root_of_Expr root)
- , Type0_Constraint Num (Type_Root_of_Expr root)
- , Type0_Constraint Ord (Type_Root_of_Expr root)
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Lift Type_Int (Type_of_Expr root)
- , Type0_Lift Type_List (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type1_Constraint Foldable (Type_Root_of_Expr root)
- , Type1_Eq (Type_Root_of_Expr root)
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_Foldable root) root)
- ) => Expr_From AST (Expr_Foldable root) where
- expr_from ex ast =
- case ast of
- AST "foldMap" asts -> from_ast2 asts foldMap_from ex ast
- AST "foldr" asts -> from_ast3 asts (foldr_from Expr.foldr) ex ast
- AST "foldr'" asts -> from_ast3 asts (foldr_from Expr.foldr') ex ast
- AST "foldl" asts -> from_ast3 asts (foldl_from Expr.foldl) ex ast
- AST "foldl'" asts -> from_ast3 asts (foldl_from Expr.foldl') ex ast
- AST "null" asts -> from_ast1 asts null_from ex ast
- AST "length" asts -> from_ast1 asts length_from ex ast
- AST "minimum" asts -> from_ast1 asts minimum_from ex ast
- AST "maximum" asts -> from_ast1 asts maximum_from ex ast
- AST "elem" asts -> from_ast2 asts elem_from ex ast
- AST "sum" asts -> from_ast1 asts sum_from ex ast
- AST "product" asts -> from_ast1 asts product_from ex ast
- AST "toList" asts -> from_ast1 asts toList_from ex ast
- _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
-instance -- Expr_From AST Expr_Monoid
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_From AST (Type_Root_of_Expr root)
- , Type0_Constraint Monoid (Type_Root_of_Expr root)
- , Type0_Lift Type_Int (Type_of_Expr root)
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_Monoid root) root)
- ) => Expr_From AST (Expr_Monoid root) where
- expr_from ex ast =
- case ast of
- AST "mempty" asts -> from_ast1 asts mempty_from ex ast
- AST "mappend" asts -> from_ast012 asts Nothing (Just mappend_from1) mappend_from ex ast
- AST "<>" asts -> from_ast012 asts Nothing (Just mappend_from1) mappend_from ex ast
- _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
-instance -- Expr_From AST Expr_Monad
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type1_From AST (Type_Root_of_Expr root)
- , Type1_Constraint Monad (Type_Root_of_Expr root)
- , Type1_Eq (Type_Root_of_Expr root)
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_Monad root) root)
- ) => Expr_From AST (Expr_Monad root) where
- expr_from ex ast =
- case ast of
- AST "return" asts -> from_ast2 asts return_from ex ast
- AST ">>=" asts -> from_ast2 asts bind_from ex ast
- _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
-instance -- Expr_From AST Expr_Either
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_From AST (Type_Root_of_Expr root)
- , Type0_Lift Type_Either (Type_of_Expr root)
- , Type0_Unlift Type_Either (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_Either root) root)
- ) => Expr_From AST (Expr_Either root) where
- expr_from ex ast =
- case ast of
- AST "left" asts -> from_ast2 asts left_from ex ast
- AST "right" asts -> from_ast2 asts right_from ex ast
- _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
-instance -- Expr_From AST Expr_Tuple2
- ( Expr_From AST root
- , Type0_Eq (Type_Root_of_Expr root)
- , Type0_Lift Type_Tuple2 (Type_of_Expr root)
- , Type0_Unlift Type_Tuple2 (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr_of_Root AST root) (Error_of_Expr AST root)
- , Root_of_Expr root ~ root
- , IBool (Is_Last_Expr (Expr_Tuple2 root) root)
- ) => Expr_From AST (Expr_Tuple2 root) where
- expr_from ex ast =
- case ast of
- AST "(,)" asts -> from_ast2 asts tuple2_from ex ast
- AST "fst" asts -> from_ast1 asts fst_from ex ast
- AST "snd" asts -> from_ast1 asts snd_from ex ast
- _ -> \_ctx _k -> Left $ error_expr_unsupported ex ast
+++ /dev/null
--- | Expressions.
-module Language.Symantic.Expr
- ( module Language.Symantic.Expr.Alt
- , module Language.Symantic.Expr.Applicative
- , module Language.Symantic.Expr.Bool
- , module Language.Symantic.Expr.Char
- , module Language.Symantic.Expr.Either
- , module Language.Symantic.Expr.Eq
- , module Language.Symantic.Expr.Error
- , module Language.Symantic.Expr.Foldable
- , module Language.Symantic.Expr.From
- , module Language.Symantic.Expr.Functor
- , module Language.Symantic.Expr.IO
- , module Language.Symantic.Expr.If
- , module Language.Symantic.Expr.Int
- , module Language.Symantic.Expr.Integer
- , module Language.Symantic.Expr.Integral
- , module Language.Symantic.Expr.Lambda
- , module Language.Symantic.Expr.List
- , module Language.Symantic.Expr.Map
- , module Language.Symantic.Expr.Maybe
- , module Language.Symantic.Expr.Monad
- , module Language.Symantic.Expr.MonoFunctor
- , module Language.Symantic.Expr.Monoid
- , module Language.Symantic.Expr.Num
- , module Language.Symantic.Expr.Ord
- , module Language.Symantic.Expr.Root
- , module Language.Symantic.Expr.Text
- , module Language.Symantic.Expr.Traversable
- , module Language.Symantic.Expr.Tuple
- ) where
-
-import Language.Symantic.Expr.Alt
-import Language.Symantic.Expr.Applicative
-import Language.Symantic.Expr.Bool
-import Language.Symantic.Expr.Char
-import Language.Symantic.Expr.Either
-import Language.Symantic.Expr.Eq
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.Foldable
-import Language.Symantic.Expr.From
-import Language.Symantic.Expr.Functor
-import Language.Symantic.Expr.IO
-import Language.Symantic.Expr.If
-import Language.Symantic.Expr.Int
-import Language.Symantic.Expr.Integer
-import Language.Symantic.Expr.Integral
-import Language.Symantic.Expr.Lambda
-import Language.Symantic.Expr.List
-import Language.Symantic.Expr.Map
-import Language.Symantic.Expr.Maybe
-import Language.Symantic.Expr.Monad
-import Language.Symantic.Expr.MonoFunctor
-import Language.Symantic.Expr.Monoid
-import Language.Symantic.Expr.Num
-import Language.Symantic.Expr.Ord
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Text
-import Language.Symantic.Expr.Traversable
-import Language.Symantic.Expr.Tuple
+++ /dev/null
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-module Language.Symantic.Expr.Alt where
-
-import Language.Symantic.Type
-import Language.Symantic.Expr.Root
-
--- * Type 'Expr_Alt'
--- | Expression making an alternative between two expressions.
-data Expr_Alt curr next (root:: *)
- = Expr_Alt_Curr (curr root)
- | Expr_Alt_Next (next root)
-
--- | Convenient alias. Requires @TypeOperators@.
---
--- TODO: see if using a type-level list is better.
-type (.|.) = Expr_Alt
-infixr 5 .|.
-type instance Root_of_Expr (Expr_Alt curr next root) = root
-type instance Type_of_Expr (Expr_Alt curr next root)
- = Type_of_Expr_Alt (Type_of_Expr (curr root))
- (Type_of_Expr (next root))
-
--- ** Type family 'Type_of_Expr_Alt'
--- | Remove 'No_Type' type when building 'Type_of_Expr'.
-type family Type_of_Expr_Alt
- (type_curr:: (* -> *) -> * -> *)
- (type_next:: (* -> *) -> * -> *)
- where
- Type_of_Expr_Alt No_Type next = next
- Type_of_Expr_Alt curr No_Type = curr
- Type_of_Expr_Alt curr next = Type_Alt curr next
-
--- ** Type family 'Is_Last_Expr'
--- | Return whether a given expression is the last one in a given expression stack.
---
--- NOTE: each expression parser uses this type family
--- when it encounters unsupported syntax:
--- to know if it is the last expression parser component that will be tried
--- (and thus return 'Error_Expr_Unsupported')
--- or if some other expression parser component shall be tried
--- (and thus return 'Error_Expr_Unsupported_here',
--- which is then handled accordingly by the 'Expr_From' instance of 'Expr_Alt').
-type family Is_Last_Expr (ex:: *) (exs:: *) :: Bool where
- Is_Last_Expr ex ex = 'True
- Is_Last_Expr ex (Expr_Root exs) = Is_Last_Expr ex (exs (Expr_Root exs))
- Is_Last_Expr (ex root) (Expr_Alt ex next root) = 'False
- Is_Last_Expr other (Expr_Alt curr next root) = Is_Last_Expr other (next root)
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
--- | Expression for 'Applicative'.
-module Language.Symantic.Expr.Applicative where
-
-import Control.Applicative (Applicative)
-import qualified Control.Applicative as Applicative
-import Control.Monad
-import qualified Data.Function as Fun
-import Data.Proxy (Proxy(..))
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding (Functor(..), (<$>), Applicative(..), id, const)
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Trans.Common
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Expr.Lambda
-import Language.Symantic.Expr.Functor
-
--- * Class 'Sym_Applicative'
--- | Symantic.
-class Sym_Functor repr => Sym_Applicative repr where
- pure :: Applicative f => repr a -> repr (f a)
- (<*>) :: Applicative f => repr (f ((->) a b)) -> repr (f a) -> repr (f b)
-
- default pure :: (Trans t repr, Applicative f) => t repr a -> t repr (f a)
- default (<*>) :: (Trans t repr, Applicative f)
- => t repr (f ((->) a b)) -> t repr (f a) -> t repr (f b)
-
- pure = trans_map1 pure
- (<*>) = trans_map2 (<*>)
- (*>) :: Applicative f => repr (f a) -> repr (f b) -> repr (f b)
- (<*) :: Applicative f => repr (f a) -> repr (f b) -> repr (f a)
- x *> y = (lam Fun.id <$ x) <*> y
- x <* y = (lam (lam . Fun.const) <$> x) <*> y
-
-infixl 4 *>
-infixl 4 <*
-infixl 4 <*>
-
-instance Sym_Applicative Repr_Host where
- pure = liftM Applicative.pure
- (<*>) = liftM2 (Applicative.<*>)
-instance Sym_Applicative Repr_Text where
- pure = repr_text_app1 "pure"
- (<*>) = repr_text_infix "<*>" (Precedence 4)
- (<* ) = repr_text_infix "<*" (Precedence 4)
- ( *>) = repr_text_infix "*>" (Precedence 4)
-instance (Sym_Applicative r1, Sym_Applicative r2) => Sym_Applicative (Repr_Dup r1 r2) where
- pure (a1 `Repr_Dup` a2) =
- pure a1 `Repr_Dup` pure a2
- (<*>) (f1 `Repr_Dup` f2) (m1 `Repr_Dup` m2) =
- (<*>) f1 m1 `Repr_Dup` (<*>) f2 m2
-
--- * Type 'Expr_Applicative'
--- | Expression.
-data Expr_Applicative (root:: *)
-type instance Root_of_Expr (Expr_Applicative root) = root
-type instance Type_of_Expr (Expr_Applicative root) = No_Type
-type instance Sym_of_Expr (Expr_Applicative root) repr = Sym_Applicative repr
-type instance Error_of_Expr ast (Expr_Applicative root) = No_Error_Expr
-
--- | Parse 'pure'.
-pure_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Applicative root)
- , Type0_Eq ty
- , Type1_From ast ty
- , Expr_From ast root
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- , Type1_Constraint Applicative ty
- ) => ast -> ast
- -> ExprFrom ast (Expr_Applicative root) hs ret
-pure_from ast_f ast_a ex ast ctx k =
- -- pure :: Applicative f => a -> f a
- either (\err -> Left $ error_expr ex $ Error_Expr_Type err ast) Fun.id $
- type1_from (Proxy::Proxy ty) ast_f $ \_f ty_f -> Right $
- expr_from (Proxy::Proxy root) ast_a ctx $
- \(ty_a::ty h_a) (Forall_Repr_with_Context a) ->
- let ty_fa = ty_f ty_a in
- check_type1_constraint ex (Proxy::Proxy Applicative) ast ty_fa $ \Dict ->
- k ty_fa $ Forall_Repr_with_Context $
- \c -> pure (a c)
-
--- | Parse '<*>'.
-ltstargt_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Applicative root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type1_Eq ty
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- , Type1_Constraint Applicative ty
- ) => ast -> ast
- -> ExprFrom ast (Expr_Applicative root) hs ret
-ltstargt_from ast_fg ast_fa ex ast ctx k =
- -- (<*>) :: Applicative f => f (a -> b) -> f a -> f b
- expr_from (Proxy::Proxy root) ast_fg ctx $
- \(ty_fg::ty h_fg) (Forall_Repr_with_Context fg) ->
- expr_from (Proxy::Proxy root) ast_fa ctx $
- \(ty_fa::ty h_fa) (Forall_Repr_with_Context fa) ->
- check_type1 ex ast ty_fg $ \(Type1 _f (ty_g::ty h_g), _) ->
- check_type1 ex ast ty_fa $ \(Type1 f ty_fa_a, Type1_Lift ty_f) ->
- check_type1_eq ex ast ty_fg ty_fa $ \Refl ->
- check_type_fun ex ast ty_g $ \(Type2 Proxy ty_g_a ty_g_b) ->
- check_type1_constraint ex (Proxy::Proxy Applicative) ast ty_fa $ \Dict ->
- check_type0_eq ex ast ty_g_a ty_fa_a $ \Refl ->
- k (Type_Root $ ty_f $ Type1 f ty_g_b) $ Forall_Repr_with_Context $
- \c -> (<*>) (fg c) (fa c)
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-
-module Expr.Applicative.Test where
-
-import Test.Tasty
-import Test.Tasty.HUnit
-
-import qualified Control.Arrow as Arrow
-import qualified Control.Monad as Monad
-import Data.Proxy (Proxy(..))
-import Data.Text (Text)
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding ((&&), not, (||), (==), (<$>), (+), Applicative(..))
-
-import Language.Symantic.Type
-import Language.Symantic.Expr as Expr
-import Language.Symantic.Repr
-
-import AST.Test
-
--- * Expressions
-t = bool True
-f = bool False
-e1 = lam (\x -> lam $ \y -> x + y)
- <$> just (int 1)
- <*> just (int 2)
-
--- * Tests
-type Ex = Expr_Root
- ( Expr_Lambda
- .|. Expr_List
- .|. Expr_Maybe
- .|. Expr_Int
- .|. Expr_Integer
- .|. Expr_Num
- .|. Expr_Bool
- .|. Expr_Functor
- .|. Expr_Applicative
- )
-ex_from = root_expr_from (Proxy::Proxy Ex)
-
-(==>) ast expected =
- testCase (show ast) $
- case ex_from ast of
- Left err -> Left err @?= Prelude.snd `Arrow.left` expected
- Right (Exists_Type0_and_Repr ty (Forall_Repr r)) ->
- case expected of
- Left (_, err) -> Right ("…"::String) @?= Left err
- Right (ty_expected::Type_Root_of_Expr Ex h, _::h, _::Text) ->
- (Monad.>>= (@?= (\(_::Proxy h, err) -> err) `Arrow.left` expected)) $
- case ty `type0_eq` ty_expected of
- Nothing -> Monad.return $ Left $
- error_expr (Proxy::Proxy Ex) $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 ty)
- (Exists_Type0 ty_expected)
- Just Refl -> do
- let h = host_from_expr r
- Monad.return $
- Right
- ( ty
- , h
- , text_from_expr r
- -- , (text_from_expr :: Repr_Text h -> Text) r
- )
-
-tests :: TestTree
-tests = testGroup "Applicative"
- [ AST "<*>"
- [ AST "<$>"
- [ AST "\\"
- [ AST "x" [], AST "Int" []
- , AST "\\"
- [ AST "y" [], AST "Int" []
- , AST "+" [ AST "var" [AST "x" []]
- , AST "var" [AST "y" []] ]
- ]
- ]
- , AST "just" [ AST "int" [AST "1" []] ]
- ]
- , AST "just" [ AST "int" [AST "2" []] ]
- ] ==> Right
- ( type_maybe type_int
- , Just 3
- , "fmap (\\x0 -> (\\x1 -> x0 + x1)) (just 1) <*> just 2" )
- ]
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
--- | Expression for 'Bool'.
-module Language.Symantic.Expr.Bool where
-
-import Control.Monad
-import qualified Data.Bool as Bool
-import Data.Monoid
-import Data.Proxy
-import qualified Data.Text as Text
-import Prelude hiding ((&&), not, (||))
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_Bool'
--- | Symantic.
-class Sym_Bool repr where
- bool :: Bool -> repr Bool
- not :: repr Bool -> repr Bool
- (&&) :: repr Bool -> repr Bool -> repr Bool
- (||) :: repr Bool -> repr Bool -> repr Bool
- xor :: repr Bool -> repr Bool -> repr Bool
- xor x y = (x || y) && not (x && y)
-
- default bool :: Trans t repr => Bool -> t repr Bool
- default not :: Trans t repr => t repr Bool -> t repr Bool
- default (&&) :: Trans t repr => t repr Bool -> t repr Bool -> t repr Bool
- default (||) :: Trans t repr => t repr Bool -> t repr Bool -> t repr Bool
-
- bool = trans_lift . bool
- not = trans_map1 not
- (&&) = trans_map2 (&&)
- (||) = trans_map2 (||)
-
-infixr 2 ||
-infixr 2 `xor`
-infixr 3 &&
-
-instance Sym_Bool Repr_Host where
- bool = Repr_Host
- not = liftM Bool.not
- (&&) = liftM2 (Bool.&&)
- (||) = liftM2 (Bool.||)
-instance Sym_Bool Repr_Text where
- bool a = Repr_Text $ \_p _v ->
- Text.pack (show a)
- not (Repr_Text x) =
- Repr_Text $ \p v ->
- let p' = Precedence 9 in
- paren p p' $ "not " <> x p' v
- (&&) = repr_text_infix "&&" (Precedence 6)
- (||) = repr_text_infix "||" (Precedence 5)
- xor = repr_text_infix "`xor`" (Precedence 5)
-instance (Sym_Bool r1, Sym_Bool r2) => Sym_Bool (Repr_Dup r1 r2) where
- bool x = bool x `Repr_Dup` bool x
- not = repr_dup1 sym_Bool not
- (&&) = repr_dup2 sym_Bool (&&)
- (||) = repr_dup2 sym_Bool (||)
- xor = repr_dup2 sym_Bool xor
-
-sym_Bool :: Proxy Sym_Bool
-sym_Bool = Proxy
-
--- * Type 'Expr_Bool'
--- | Expression.
-data Expr_Bool (root:: *)
-type instance Root_of_Expr (Expr_Bool root) = root
-type instance Type_of_Expr (Expr_Bool root) = Type_Bool
-type instance Sym_of_Expr (Expr_Bool root) repr = Sym_Bool repr
-type instance Error_of_Expr ast (Expr_Bool root) = No_Error_Expr
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-module Expr.Bool.Test where
-
-import Test.Tasty
-import Test.Tasty.HUnit
-
-import qualified Control.Arrow as Arrow
-import qualified Control.Monad as Monad
--- import Control.Monad.IO.Class (MonadIO(..))
-import Data.Proxy (Proxy(..))
-import Data.Text (Text)
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding ((&&), not, (||))
-
-import Language.Symantic.Repr
-import Language.Symantic.Expr
-import Language.Symantic.Type
-import Language.Symantic.Trans
-
-import AST.Test
-
--- * Class 'Sym_Bool_Vars'
-
--- | A few boolean variables.
-class Sym_Bool_Vars repr where
- x :: repr Bool
- y :: repr Bool
- z :: repr Bool
-instance Sym_Bool_Vars Repr_Text where
- x = Repr_Text $ \_p _v -> "x"
- y = Repr_Text $ \_p _v -> "y"
- z = Repr_Text $ \_p _v -> "z"
-instance -- Trans_Boo_Const
- ( Sym_Bool repr
- , Sym_Bool_Vars repr
- ) => Sym_Bool_Vars (Trans_Bool_Const repr) where
- x = trans_lift x
- y = trans_lift y
- z = trans_lift z
-
--- * Expressions
-e1 = bool True && bool False
-e2 = (bool True && bool False) || (bool True && bool True)
-e3 = (bool True || bool False) && (bool True || bool True)
-e4 = bool True && not (bool False)
-e5 = bool True && not x
-e6 = x `xor` y
-e7 = (x `xor` y) `xor` z
-e8 = x `xor` (y `xor` bool True)
-
--- * Tests
-type Ex = Expr_Root
- ( Expr_Lambda
- .|. Expr_Bool
- )
-ex_from = root_expr_from (Proxy::Proxy Ex)
-
-(==>) ast expected =
- testCase (show ast) $
- case ex_from ast of
- Left err -> Left err @?= Prelude.snd `Arrow.left` expected
- Right (Exists_Type0_and_Repr ty (Forall_Repr r)) ->
- case expected of
- Left (_, err) -> Right ("…"::String) @?= Left err
- Right (ty_expected::Type_Root_of_Expr Ex h, _::h, _::Text) ->
- (Monad.>>= (@?= (\(_::Proxy h, err) -> err) `Arrow.left` expected)) $
- case ty `type0_eq` ty_expected of
- Nothing -> Monad.return $ Left $
- error_expr (Proxy::Proxy Ex) $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 ty)
- (Exists_Type0 ty_expected)
- Just Refl -> do
- let h = host_from_expr r
- Monad.return $
- Right
- ( ty
- , h
- , text_from_expr r
- -- , (text_from_expr :: Repr_Text h -> Text) r
- )
-
-tests :: TestTree
-tests = testGroup "Bool" $
- [ AST "bool" [AST "True" []] ==> Right
- ( type_bool
- , True
- , "True" )
- , AST "int" [AST "1" []] ==> Left (Proxy::Proxy Int,
- Error_Expr_Alt_Curr $
- Error_Expr_Unsupported $ AST "int" [AST "1" []])
- , AST "xor"
- [ AST "bool" [AST "True" []]
- , AST "bool" [AST "True" []]
- ] ==> Right
- ( type_bool
- , False
- , "True `xor` True" )
- , AST "$"
- [ AST "\\"
- [ AST "x" []
- , AST "Bool" []
- , AST "var" [AST "x" []]
- ]
- , AST "bool" [AST "True" []]
- ] ==> Right
- ( type_bool
- , True
- , "(\\x0 -> x0) True" )
- , let ast = AST "$"
- [ AST "bool" [AST "True" []]
- , AST "bool" [AST "True" []]
- ] in ast ==> Left (Proxy::Proxy Bool,
- Error_Expr_Alt_Curr $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 (type_var0 SZero `type_fun` type_var0 (SSucc SZero)
- ::Type_Root (Type_Var0 :|: Type_Var1 :|: Type_Fun :|: Type_Bool)
- ((->) Var0 Var0)))
- (Exists_Type0 type_bool))
- , AST "$"
- [ AST "\\"
- [ AST "x" []
- , AST "Bool" []
- , AST "xor"
- [ AST "var" [AST "x" []]
- , AST "bool" [AST "True" []]
- ]
- ]
- , AST "bool" [AST "True" []]
- ] ==> Right
- ( type_bool
- , False
- , "(\\x0 -> x0 `xor` True) True" )
- , AST "let"
- [ AST "x" []
- , AST "bool" [AST "True" []]
- , AST "xor"
- [ AST "var" [AST "x" []]
- , AST "bool" [AST "True" []]
- ]
- ] ==> Right
- ( type_bool
- , False
- , "let x0 = True in x0 `xor` True" )
- ]
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
--- | Expression for 'Char'.
-module Language.Symantic.Expr.Char where
-
-import Control.Monad
-import qualified Data.Char as Char
-import Data.Proxy
-import qualified Data.Text as Text
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_Char'
--- | Symantic.
-class Sym_Char repr where
- char :: Char -> repr Char
- char_toUpper :: repr Char -> repr Char
-
- default char :: Trans t repr => Char -> t repr Char
- default char_toUpper :: Trans t repr => t repr Char -> t repr Char
-
- char = trans_lift . char
- char_toUpper = trans_map1 char_toUpper
-instance Sym_Char Repr_Host where
- char = Repr_Host
- char_toUpper = liftM Char.toUpper
-instance Sym_Char Repr_Text where
- char a = Repr_Text $ \_p _v ->
- Text.pack (show a)
- char_toUpper = repr_text_app1 "char_toUpper"
-instance (Sym_Char r1, Sym_Char r2) => Sym_Char (Repr_Dup r1 r2) where
- char x = char x `Repr_Dup` char x
- char_toUpper = repr_dup1 sym_Char char_toUpper
-
-sym_Char :: Proxy Sym_Char
-sym_Char = Proxy
-
--- * Type 'Expr_Char'
--- | Expression.
-data Expr_Char (root:: *)
-type instance Root_of_Expr (Expr_Char root) = root
-type instance Type_of_Expr (Expr_Char root) = Type_Char
-type instance Sym_of_Expr (Expr_Char root) repr = Sym_Char repr
-type instance Error_of_Expr ast (Expr_Char root) = No_Error_Expr
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
--- | Expression for 'Either'.
-module Language.Symantic.Expr.Either where
-
-import Control.Monad
-import Data.Proxy (Proxy(..))
-import Prelude hiding (maybe)
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Trans.Common
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-
--- * Class 'Sym_Tuple_Lam'
--- | Symantic.
-class Sym_Either repr where
- left :: repr l -> repr (Either l r)
- right :: repr r -> repr (Either l r)
- default left :: Trans t repr => t repr l -> t repr (Either l r)
- default right :: Trans t repr => t repr r -> t repr (Either l r)
- left = trans_map1 left
- right = trans_map1 right
-instance Sym_Either Repr_Host where
- right = liftM Right
- left = liftM Left
-instance Sym_Either Repr_Text where
- right = repr_text_app1 "right"
- left = repr_text_app1 "left"
-instance (Sym_Either r1, Sym_Either r2) => Sym_Either (Repr_Dup r1 r2) where
- left = repr_dup1 sym_Either left
- right = repr_dup1 sym_Either right
-
-sym_Either :: Proxy Sym_Either
-sym_Either = Proxy
-
--- * Type 'Expr_Either'
--- | Expression.
-data Expr_Either (root:: *)
-type instance Root_of_Expr (Expr_Either root) = root
-type instance Type_of_Expr (Expr_Either root) = Type_Either
-type instance Sym_of_Expr (Expr_Either root) repr = Sym_Either repr
-type instance Error_of_Expr ast (Expr_Either root) = No_Error_Expr
-
--- | Parsing utility to check that the given type is a 'Type_Either'
--- or raise 'Error_Expr_Type_mismatch'.
-check_type_either
- :: forall ast ex root ty h ret.
- ( root ~ Root_of_Expr ex
- , ty ~ Type_Root_of_Expr ex
- , Type0_Lift Type_Either (Type_of_Expr root)
- , Type0_Unlift Type_Either (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- )
- => Proxy ex -> ast -> ty h
- -> (Type_Either ty h -> Either (Error_of_Expr ast root) ret)
- -> Either (Error_of_Expr ast root) ret
-check_type_either ex ast ty k =
- case type0_unlift $ unType_Root ty of
- Just ty_e -> k ty_e
- Nothing -> Left $
- error_expr ex $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 (type_either (type_var0 SZero) (type_var0 $ SSucc SZero)
- :: ty (Either Var0 Var0)))
- (Exists_Type0 ty)
-
--- | Parse 'left'.
-left_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Either root)
- , Type0_From ast ty
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Either (Type_of_Expr root)
- , Type0_Unlift Type_Either (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast -> ast
- -> ExprFrom ast (Expr_Either root) hs ret
-left_from ast_ty_r ast_l ex ast ctx k =
- either (\err -> Left $ error_expr ex $ Error_Expr_Type err ast) id $
- type0_from (Proxy::Proxy ty) ast_ty_r $ \ty_r -> Right $
- expr_from (Proxy::Proxy root) ast_l ctx $
- \(ty_l::ty h_l) (Forall_Repr_with_Context l) ->
- k (type_either ty_l ty_r) $ Forall_Repr_with_Context $
- \c -> left (l c)
-
--- | Parse 'right'.
-right_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Either root)
- , Type0_From ast ty
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Either (Type_of_Expr root)
- , Type0_Unlift Type_Either (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast -> ast
- -> ExprFrom ast (Expr_Either root) hs ret
-right_from ast_ty_l ast_r ex ast ctx k =
- either (\err -> Left $ error_expr ex $ Error_Expr_Type err ast) id $
- type0_from (Proxy::Proxy ty) ast_ty_l $ \ty_l -> Right $
- expr_from (Proxy::Proxy root) ast_r ctx $
- \(ty_r::ty h_r) (Forall_Repr_with_Context r) ->
- k (type_either ty_l ty_r) $ Forall_Repr_with_Context $
- \c -> right (r c)
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
--- | Expression for 'Eq'.
-module Language.Symantic.Expr.Eq where
-
-import Control.Monad
-import qualified Data.Eq as Eq
-import Data.Proxy (Proxy(..))
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding ((==), (/=))
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_Eq'
--- | Symantic.
-class Sym_Eq repr where
- (==) :: Eq a => repr a -> repr a -> repr Bool
- (/=) :: Eq a => repr a -> repr a -> repr Bool
-
- default (==) :: (Trans t repr, Eq a) => t repr a -> t repr a -> t repr Bool
- default (/=) :: (Trans t repr, Eq a) => t repr a -> t repr a -> t repr Bool
-
- (==) = trans_map2 (==)
- (/=) = trans_map2 (/=)
-
-infix 4 ==
-infix 4 /=
-
-instance Sym_Eq Repr_Host where
- (==) = liftM2 (Eq.==)
- (/=) = liftM2 (Eq./=)
-instance Sym_Eq Repr_Text where
- (==) = repr_text_infix "==" (Precedence 4)
- (/=) = repr_text_infix "/=" (Precedence 4)
-instance (Sym_Eq r1, Sym_Eq r2) => Sym_Eq (Repr_Dup r1 r2) where
- (==) = repr_dup2 sym_Eq (==)
- (/=) = repr_dup2 sym_Eq (/=)
-
-sym_Eq :: Proxy Sym_Eq
-sym_Eq = Proxy
-
--- * Type 'Expr_Eq'
--- | Expression.
-data Expr_Eq (root:: *)
-type instance Root_of_Expr (Expr_Eq root) = root
-type instance Type_of_Expr (Expr_Eq root) = No_Type
-type instance Sym_of_Expr (Expr_Eq root) repr = Sym_Eq repr
-type instance Error_of_Expr ast (Expr_Eq root) = No_Error_Expr
-
--- | Parse '==' or '/='.
-eq_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Eq root)
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Type0_Eq ty
- , Type0_Constraint Eq ty
- , Expr_From ast root
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => (forall repr a. (Sym_Eq repr, Eq a) => repr a -> repr a -> repr Bool)
- -> ast -> ast
- -> ExprFrom ast (Expr_Eq root) hs ret
-eq_from test ast_x ast_y ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_x ctx $ \ty_x (Forall_Repr_with_Context x) ->
- expr_from (Proxy::Proxy root) ast_y ctx $ \ty_y (Forall_Repr_with_Context y) ->
- check_type0_eq ex ast ty_x ty_y $ \Refl ->
- check_type0_constraint ex (Proxy::Proxy Eq) ast ty_x $ \Dict ->
- k type_bool $ Forall_Repr_with_Context $
- \c -> x c `test` y c
-
--- | Parse '==' or '/=', with only one argument.
-eq_from1
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Eq root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Type0_Eq ty
- , Type0_Constraint Eq ty
- , Expr_From ast root
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => (forall repr a. (Sym_Eq repr, Eq a) => repr a -> repr a -> repr Bool)
- -> ast
- -> ExprFrom ast (Expr_Eq root) hs ret
-eq_from1 test ast_x ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_x ctx $ \ty_x (Forall_Repr_with_Context x) ->
- check_type0_constraint ex (Proxy::Proxy Eq) ast ty_x $ \Dict ->
- k (type_fun ty_x type_bool) $ Forall_Repr_with_Context $
- \c -> lam $ \y -> x c `test` y
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-
-module Expr.Eq.Test where
-
-import Test.Tasty
-import Test.Tasty.HUnit
-
-import qualified Control.Arrow as Arrow
-import qualified Control.Monad as Monad
-import Data.Proxy (Proxy(..))
-import Data.Text (Text)
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding ((&&), not, (||), (==))
-
-import Language.Symantic.Type
-import Language.Symantic.Expr
-import Language.Symantic.Repr
-
-import AST.Test
-
--- * Expressions
-t = bool True
-f = bool False
-e1 = if_ ((t && t) == (t || f)) t f
-e2 = if_ (((t && t) || f) == (t && (t || f))) t f
-e3 = if_ (not (t == f) == (t == t)) t f
-
--- * Tests
-type Ex = Expr_Root
- ( Expr_Lambda
- .|. Expr_Bool
- .|. Expr_Eq
- )
-ex_from = root_expr_from (Proxy::Proxy Ex)
-
-(==>) ast expected =
- testCase (show ast) $
- case ex_from ast of
- Left err -> Left err @?= Prelude.snd `Arrow.left` expected
- Right (Exists_Type0_and_Repr ty (Forall_Repr r)) ->
- case expected of
- Left (_, err) -> Right ("…"::String) @?= Left err
- Right (ty_expected::Type_Root_of_Expr Ex h, _::h, _::Text) ->
- (Monad.>>= (@?= (\(_::Proxy h, err) -> err) `Arrow.left` expected)) $
- case ty `type0_eq` ty_expected of
- Nothing -> Monad.return $ Left $
- error_expr (Proxy::Proxy Ex) $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 ty)
- (Exists_Type0 ty_expected)
- Just Refl -> do
- let h = host_from_expr r
- Monad.return $
- Right
- ( ty
- , h
- , text_from_expr r
- -- , (text_from_expr :: Repr_Text h -> Text) r
- )
-
-tests :: TestTree
-tests = testGroup "Eq"
- [ AST "==" [ AST "bool" [AST "True" []]
- , AST "bool" [AST "True" []]
- ] ==> Right
- ( type_bool
- , True
- , "True == True" )
- , AST "$"
- [ AST "\\"
- [ AST "x" []
- , AST "Bool" []
- , AST "==" [ AST "var" [AST "x" []]
- , AST "not" [AST "var" [AST "x" []]] ]
- ]
- , AST "bool" [AST "True" []]
- ] ==> Right
- ( type_bool
- , False
- , "(\\x0 -> x0 == not x0) True" )
- ]
+++ /dev/null
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
-module Language.Symantic.Expr.Error where
-
-import Data.Proxy (Proxy(..))
-import Data.Text (Text)
-import qualified Data.Text as Text
-
-import Language.Symantic.Lib.Data.Bool
-import Language.Symantic.Type
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Alt
-
--- * Type family 'Error_of_Expr'
--- | The error(s) of an expression.
-type family Error_of_Expr (ast:: *) (ex:: *) :: *
-type instance Error_of_Expr ast (Expr_Root ex)
- = Error_Expr_Alt (Error_Expr (Error_of_Type ast (Type_Root_of_Expr (ex (Expr_Root ex))))
- (Type_Root_of_Expr (ex (Expr_Root ex)))
- ast)
- (Error_of_Expr ast (ex (Expr_Root ex)))
-type instance Error_of_Expr ast (Expr_Alt curr next root)
- = Error_of_Expr_Alt ast (Error_of_Expr ast (curr root))
- (Error_of_Expr ast (next root))
-
--- ** Type family 'Error_of_Expr_Alt'
--- | Remove 'No_Error_Expr' type when building the error of an expression.
-type family Error_of_Expr_Alt ast curr next where
- Error_of_Expr_Alt ast No_Error_Expr next = next
- Error_of_Expr_Alt ast curr No_Error_Expr = curr
- Error_of_Expr_Alt ast curr next = Error_Expr_Alt curr next
-
--- * Type 'Error_Expr_Alt'
--- | Error expression making an alternative between two error expressions.
-data Error_Expr_Alt curr next
- = Error_Expr_Alt_Curr curr
- | Error_Expr_Alt_Next next
- deriving (Eq, Show)
-
--- ** Type 'Error_Expr_Lift'
--- | Apply 'Peano_of_Error_Expr' on 'Error_Expr_LiftP'.
-type Error_Expr_Lift err errs
- = Error_Expr_LiftP (Peano_of_Error_Expr err errs) err errs
-
--- | Convenient wrapper around 'error_expr_liftP',
--- passing it the 'Peano' number from 'Peano_of_Error_Expr'.
-error_expr_lift
- :: forall err errs.
- Error_Expr_Lift err errs => err -> errs
-error_expr_lift = error_expr_liftP (Proxy::Proxy (Peano_of_Error_Expr err errs))
-
--- *** Type family 'Peano_of_Error_Expr'
--- | Return a 'Peano' number derived from the location
--- of a given error expression within a given error expression stack,
--- which is used to avoid @OverlappingInstances@.
-type family Peano_of_Error_Expr (err:: *) (errs:: *) :: * where
- Peano_of_Error_Expr err err = Zero
- Peano_of_Error_Expr err (Error_Expr_Alt err next) = Zero
- Peano_of_Error_Expr other (Error_Expr_Alt curr next) = Succ (Peano_of_Error_Expr other next)
-
--- *** Class 'Error_Expr_LiftP'
--- | Lift a given expression to the top of a given expression stack including it,
--- by constructing the appropriate sequence of 'Error_Expr_Alt_Curr' and 'Error_Expr_Alt_Next'.
-class Error_Expr_LiftP (p:: *) err errs where
- error_expr_liftP :: Proxy p -> err -> errs
-instance Error_Expr_LiftP Zero curr curr where
- error_expr_liftP _ = id
-instance Error_Expr_LiftP Zero curr (Error_Expr_Alt curr next) where
- error_expr_liftP _ = Error_Expr_Alt_Curr
-instance
- Error_Expr_LiftP p other next =>
- Error_Expr_LiftP (Succ p) other (Error_Expr_Alt curr next) where
- error_expr_liftP _ = Error_Expr_Alt_Next . error_expr_liftP (Proxy::Proxy p)
-
--- ** Type 'Error_Expr_Unlift'
--- | Apply 'Peano_of_Error_Expr' on 'Error_Expr_UnliftP'.
-type Error_Expr_Unlift ex exs
- = Error_Expr_UnliftP (Peano_of_Error_Expr ex exs) ex exs
-
--- | Convenient wrapper around 'error_expr_unliftP',
--- passing it the 'Peano' number from 'Peano_of_Error_Expr'.
-error_expr_unlift
- :: forall ex exs.
- Error_Expr_Unlift ex exs => exs -> Maybe ex
-error_expr_unlift = error_expr_unliftP (Proxy::Proxy (Peano_of_Error_Expr ex exs))
-
--- *** Class 'Error_Expr_UnliftP'
--- | Try to unlift a given expression error out of a given expression error stack including it,
--- by deconstructing the appropriate sequence of 'Error_Expr_Alt_Curr' and 'Error_Expr_Alt_Next'.
-class Error_Expr_UnliftP (p:: *) ex exs where
- error_expr_unliftP :: Proxy p -> exs -> Maybe ex
-instance Error_Expr_UnliftP Zero curr curr where
- error_expr_unliftP _ = Just
-instance Error_Expr_UnliftP Zero curr (Error_Expr_Alt curr next) where
- error_expr_unliftP _ (Error_Expr_Alt_Curr x) = Just x
- error_expr_unliftP _ (Error_Expr_Alt_Next _) = Nothing
-instance
- Error_Expr_UnliftP p other next =>
- Error_Expr_UnliftP (Succ p) other (Error_Expr_Alt curr next) where
- error_expr_unliftP _ (Error_Expr_Alt_Next x) = error_expr_unliftP (Proxy::Proxy p) x
- error_expr_unliftP _ (Error_Expr_Alt_Curr _) = Nothing
-
--- * Type 'Error_Expr_Read'
--- | Common expression errors.
-data Error_Expr err_ty ty ast
- = Error_Expr_Wrong_number_of_arguments ast Int
- -- ^ Wrong number of arguments applied to a term,
- -- the integer is the number of arguments expected.
- | Error_Expr_Type_mismatch ast (Exists_Type0 ty) (Exists_Type0 ty)
- -- ^ Mismatch between respectively expected and actual type.
- | Error_Expr_Constraint_missing ast {-Exists_Dict-} (Exists_Type0 ty)
- -- ^ A 'Constraint' is missing.
- | Error_Expr_Read Error_Read ast
- -- ^ Error when reading a literal.
- | Error_Expr_Type err_ty ast
- -- ^ Error when parsing a type.
- | Error_Expr_Unsupported ast
- -- ^ Given syntax is supported by none
- -- of the expression parser components
- -- of the expression stack.
- | Error_Expr_Unsupported_here ast
- -- ^ Given syntax not supported by
- -- the current expression parser component.
- deriving (Eq, Show)
-
--- | Convenient type alias.
-type Error_Expr_of_Root ast root
- = Error_Expr (Error_of_Type ast (Type_Root_of_Expr root))
- (Type_Root_of_Expr root)
- ast
-
--- | Convenient wrapper around 'error_expr_lift',
--- passing the type family boilerplate.
-error_expr
- :: forall ast ex ty.
- (ty ~ Type_Root_of_Expr ex)
- => Error_Expr_Lift
- (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast (Root_of_Expr ex))
- => Proxy ex
- -> Error_Expr (Error_of_Type ast ty) ty ast
- -> Error_of_Expr ast (Root_of_Expr ex)
-error_expr _ = error_expr_lift
-
--- | Parsing utility to return 'Error_Expr_Unsupported'
--- or 'Error_Expr_Unsupported_here'
--- according to the given expression.
-error_expr_unsupported
- :: forall ast ex ty root.
- ( root ~ Root_of_Expr ex
- , ty ~ Type_Root_of_Expr ex
- , IBool (Is_Last_Expr ex root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- ) => Proxy ex -> ast
- -> Error_of_Expr ast (Root_of_Expr ex)
-error_expr_unsupported ex ast =
- case iBool :: SBool (Is_Last_Expr ex root) of
- STrue -> error_expr ex $ Error_Expr_Unsupported ast
- SFalse -> error_expr ex $ Error_Expr_Unsupported_here ast
-
--- ** Type 'No_Error_Expr'
--- | A discarded error.
-data No_Error_Expr
- = No_Error_Expr
- deriving (Eq, Show)
-
--- * Type 'Error_Read'
--- | Error parsing a host-term.
-data Error_Read
- = Error_Read Text
- deriving (Eq, Show)
-
--- | Parse a host-term.
-read_safe :: Read h => Text -> Either Error_Read h
-read_safe t =
- case reads $ Text.unpack t of
- [(x, "")] -> Right x
- _ -> Left $ Error_Read t
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
--- | Expression for 'Foldable'.
-module Language.Symantic.Expr.Foldable where
-
-import Control.Monad (liftM, liftM2, liftM3)
-import Data.Monoid
-import Data.Foldable (Foldable)
-import qualified Data.Foldable as Foldable
-import Data.Proxy (Proxy(..))
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding ((<$>), Foldable(..)
- , all, and, any, concat, concatMap, mapM_
- , notElem, or, sequence_)
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Expr.Lambda
-import Language.Symantic.Expr.List
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_Foldable'
--- | Symantic.
-class Sym_Foldable repr where
- foldMap :: (Foldable f, Monoid m) => repr (a -> m) -> repr (f a) -> repr m
- foldr :: Foldable f => repr (a -> b -> b) -> repr b -> repr (f a) -> repr b
- foldr' :: Foldable f => repr (a -> b -> b) -> repr b -> repr (f a) -> repr b
- foldl :: Foldable f => repr (b -> a -> b) -> repr b -> repr (f a) -> repr b
- foldl' :: Foldable f => repr (b -> a -> b) -> repr b -> repr (f a) -> repr b
- length :: Foldable f => repr (f a) -> repr Int
- null :: Foldable f => repr (f a) -> repr Bool
- minimum :: (Foldable f, Ord a) => repr (f a) -> repr a
- maximum :: (Foldable f, Ord a) => repr (f a) -> repr a
- elem :: (Foldable f, Eq a) => repr a -> repr (f a) -> repr Bool
- sum :: (Foldable f, Num a) => repr (f a) -> repr a
- product :: (Foldable f, Num a) => repr (f a) -> repr a
- toList :: Foldable f => repr (f a) -> repr [a]
- all :: Foldable f => repr (a -> Bool) -> repr (f a) -> repr Bool
- and :: Foldable f => repr (f Bool) -> repr Bool
- any :: Foldable f => repr (a -> Bool) -> repr (f a) -> repr Bool
- concat :: Foldable f => repr (f [a]) -> repr [a]
- concatMap :: Foldable f => repr (a -> [b]) -> repr (f a) -> repr [b]
- find :: Foldable f => repr (a -> Bool) -> repr (f a) -> repr (Maybe a)
- foldlM :: (Foldable f, Monad m) => repr (b -> a -> m b) -> repr b -> repr (f a) -> repr (m b)
- foldrM :: (Foldable f, Monad m) => repr (a -> b -> m b) -> repr b -> repr (f a) -> repr (m b)
- forM_ :: (Foldable f, Monad m) => repr (f a) -> repr (a -> m b) -> repr (m ())
- for_ :: (Foldable f, Applicative p) => repr (f a) -> repr (a -> p b) -> repr (p ())
- mapM_ :: (Foldable f, Monad m) => repr (a -> m b) -> repr (f a) -> repr (m ())
- maximumBy :: Foldable f => repr (a -> a -> Ordering) -> repr (f a) -> repr a
- minimumBy :: Foldable f => repr (a -> a -> Ordering) -> repr (f a) -> repr a
- notElem :: (Foldable f, Eq a) => repr a -> repr (f a) -> repr Bool
- or :: Foldable f => repr (f Bool) -> repr Bool
- sequenceA_ :: (Foldable f, Applicative p) => repr (f (p a)) -> repr (p ())
- sequence_ :: (Foldable f, Monad m) => repr (f (m a)) -> repr (m ())
- traverse_ :: (Foldable f, Applicative p) => repr (a -> p b) -> repr (f a) -> repr (p ())
- -- asum :: (Foldable t, GHC.Base.Alternative f) => t (f a) -> f a
- -- msum :: (Foldable t, GHC.Base.MonadPlus m) => t (m a) -> m a
-
- default foldMap :: (Trans t repr, Foldable f, Monoid m) => t repr (a -> m) -> t repr (f a) -> t repr m
- default foldr :: (Trans t repr, Foldable f) => t repr (a -> b -> b) -> t repr b -> t repr (f a) -> t repr b
- default foldr' :: (Trans t repr, Foldable f) => t repr (a -> b -> b) -> t repr b -> t repr (f a) -> t repr b
- default foldl :: (Trans t repr, Foldable f) => t repr (b -> a -> b) -> t repr b -> t repr (f a) -> t repr b
- default foldl' :: (Trans t repr, Foldable f) => t repr (b -> a -> b) -> t repr b -> t repr (f a) -> t repr b
- default length :: (Trans t repr, Foldable f) => t repr (f a) -> t repr Int
- default null :: (Trans t repr, Foldable f) => t repr (f a) -> t repr Bool
- default minimum :: (Trans t repr, Foldable f, Ord a) => t repr (f a) -> t repr a
- default maximum :: (Trans t repr, Foldable f, Ord a) => t repr (f a) -> t repr a
- default elem :: (Trans t repr, Foldable f, Eq a) => t repr a -> t repr (f a) -> t repr Bool
- default sum :: (Trans t repr, Foldable f, Num a) => t repr (f a) -> t repr a
- default product :: (Trans t repr, Foldable f, Num a) => t repr (f a) -> t repr a
- default toList :: (Trans t repr, Foldable f) => t repr (f a) -> t repr [a]
- default all :: (Trans t repr, Foldable f) => t repr (a -> Bool) -> t repr (f a) -> t repr Bool
- default and :: (Trans t repr, Foldable f) => t repr (f Bool) -> t repr Bool
- default any :: (Trans t repr, Foldable f) => t repr (a -> Bool) -> t repr (f a) -> t repr Bool
- default concat :: (Trans t repr, Foldable f) => t repr (f [a]) -> t repr [a]
- default concatMap :: (Trans t repr, Foldable f) => t repr (a -> [b]) -> t repr (f a) -> t repr [b]
- default find :: (Trans t repr, Foldable f) => t repr (a -> Bool) -> t repr (f a) -> t repr (Maybe a)
- default foldlM :: (Trans t repr, Foldable f, Monad m) => t repr (b -> a -> m b) -> t repr b -> t repr (f a) -> t repr (m b)
- default foldrM :: (Trans t repr, Foldable f, Monad m) => t repr (a -> b -> m b) -> t repr b -> t repr (f a) -> t repr (m b)
- default forM_ :: (Trans t repr, Foldable f, Monad m) => t repr (f a) -> t repr (a -> m b) -> t repr (m ())
- default for_ :: (Trans t repr, Foldable f, Applicative p) => t repr (f a) -> t repr (a -> p b) -> t repr (p ())
- default mapM_ :: (Trans t repr, Foldable f, Monad m) => t repr (a -> m b) -> t repr (f a) -> t repr (m ())
- default maximumBy :: (Trans t repr, Foldable f) => t repr (a -> a -> Ordering) -> t repr (f a) -> t repr a
- default minimumBy :: (Trans t repr, Foldable f) => t repr (a -> a -> Ordering) -> t repr (f a) -> t repr a
- default notElem :: (Trans t repr, Foldable f, Eq a) => t repr a -> t repr (f a) -> t repr Bool
- default or :: (Trans t repr, Foldable f) => t repr (f Bool) -> t repr Bool
- default sequenceA_ :: (Trans t repr, Foldable f, Applicative p) => t repr (f (p a)) -> t repr (p ())
- default sequence_ :: (Trans t repr, Foldable f, Monad m) => t repr (f (m a)) -> t repr (m ())
- default traverse_ :: (Trans t repr, Foldable f, Applicative p) => t repr (a -> p b) -> t repr (f a) -> t repr (p ())
-
- foldMap = trans_map2 foldMap
- foldr = trans_map3 foldr
- foldr' = trans_map3 foldr'
- foldl = trans_map3 foldl
- foldl' = trans_map3 foldl'
- length = trans_map1 length
- null = trans_map1 null
- minimum = trans_map1 minimum
- maximum = trans_map1 maximum
- elem = trans_map2 elem
- sum = trans_map1 sum
- product = trans_map1 product
- toList = trans_map1 toList
- all = trans_map2 all
- and = trans_map1 and
- any = trans_map2 any
- concat = trans_map1 concat
- concatMap = trans_map2 concatMap
- find = trans_map2 find
- foldlM = trans_map3 foldlM
- foldrM = trans_map3 foldrM
- forM_ = trans_map2 forM_
- for_ = trans_map2 for_
- mapM_ = trans_map2 mapM_
- maximumBy = trans_map2 maximumBy
- minimumBy = trans_map2 minimumBy
- notElem = trans_map2 notElem
- or = trans_map1 or
- sequenceA_ = trans_map1 sequenceA_
- sequence_ = trans_map1 sequence_
- traverse_ = trans_map2 traverse_
-instance Sym_Foldable Repr_Host where
- foldMap = liftM2 Foldable.foldMap
- foldr = liftM3 Foldable.foldr
- foldr' = liftM3 Foldable.foldr'
- foldl = liftM3 Foldable.foldl
- foldl' = liftM3 Foldable.foldl'
- null = liftM Foldable.null
- length = liftM Foldable.length
- minimum = liftM Foldable.minimum
- maximum = liftM Foldable.maximum
- elem = liftM2 Foldable.elem
- sum = liftM Foldable.sum
- product = liftM Foldable.product
- toList = liftM Foldable.toList
- all = liftM2 Foldable.all
- and = liftM Foldable.and
- any = liftM2 Foldable.any
- concat = liftM Foldable.concat
- concatMap = liftM2 Foldable.concatMap
- find = liftM2 Foldable.find
- foldlM = liftM3 Foldable.foldlM
- foldrM = liftM3 Foldable.foldrM
- forM_ = liftM2 Foldable.forM_
- for_ = liftM2 Foldable.for_
- mapM_ = liftM2 Foldable.mapM_
- maximumBy = liftM2 Foldable.maximumBy
- minimumBy = liftM2 Foldable.minimumBy
- notElem = liftM2 Foldable.notElem
- or = liftM Foldable.or
- sequenceA_ = liftM Foldable.sequenceA_
- sequence_ = liftM Foldable.sequence_
- traverse_ = liftM2 Foldable.traverse_
-instance Sym_Foldable Repr_Text where
- foldMap = repr_text_app2 "foldMap"
- foldr = repr_text_app3 "foldr"
- foldr' = repr_text_app3 "foldr'"
- foldl = repr_text_app3 "foldl"
- foldl' = repr_text_app3 "foldl'"
- null = repr_text_app1 "null"
- length = repr_text_app1 "length"
- minimum = repr_text_app1 "minimum"
- maximum = repr_text_app1 "maximum"
- elem = repr_text_app2 "elem"
- sum = repr_text_app1 "sum"
- product = repr_text_app1 "product"
- toList = repr_text_app1 "toList"
- all = repr_text_app2 "all"
- and = repr_text_app1 "and"
- any = repr_text_app2 "any"
- concat = repr_text_app1 "concat"
- concatMap = repr_text_app2 "concatMap"
- find = repr_text_app2 "find"
- foldlM = repr_text_app3 "foldlM"
- foldrM = repr_text_app3 "foldrM"
- forM_ = repr_text_app2 "forM_"
- for_ = repr_text_app2 "for_"
- mapM_ = repr_text_app2 "mapM_"
- maximumBy = repr_text_app2 "maximumBy"
- minimumBy = repr_text_app2 "minimumBy"
- notElem = repr_text_app2 "notElem"
- or = repr_text_app1 "or"
- sequenceA_ = repr_text_app1 "sequenceA_"
- sequence_ = repr_text_app1 "sequence_"
- traverse_ = repr_text_app2 "traverse_"
-instance (Sym_Foldable r1, Sym_Foldable r2) => Sym_Foldable (Repr_Dup r1 r2) where
- foldMap = repr_dup2 sym_Foldable foldMap
- foldr = repr_dup3 sym_Foldable foldr
- foldr' = repr_dup3 sym_Foldable foldr'
- foldl = repr_dup3 sym_Foldable foldl
- foldl' = repr_dup3 sym_Foldable foldl'
- null = repr_dup1 sym_Foldable null
- length = repr_dup1 sym_Foldable length
- minimum = repr_dup1 sym_Foldable minimum
- maximum = repr_dup1 sym_Foldable maximum
- elem = repr_dup2 sym_Foldable elem
- sum = repr_dup1 sym_Foldable sum
- product = repr_dup1 sym_Foldable product
- toList = repr_dup1 sym_Foldable toList
- all = repr_dup2 sym_Foldable all
- and = repr_dup1 sym_Foldable and
- any = repr_dup2 sym_Foldable any
- concat = repr_dup1 sym_Foldable concat
- concatMap = repr_dup2 sym_Foldable concatMap
- find = repr_dup2 sym_Foldable find
- foldlM = repr_dup3 sym_Foldable foldlM
- foldrM = repr_dup3 sym_Foldable foldrM
- forM_ = repr_dup2 sym_Foldable forM_
- for_ = repr_dup2 sym_Foldable for_
- mapM_ = repr_dup2 sym_Foldable mapM_
- maximumBy = repr_dup2 sym_Foldable maximumBy
- minimumBy = repr_dup2 sym_Foldable minimumBy
- notElem = repr_dup2 sym_Foldable notElem
- or = repr_dup1 sym_Foldable or
- sequenceA_ = repr_dup1 sym_Foldable sequenceA_
- sequence_ = repr_dup1 sym_Foldable sequence_
- traverse_ = repr_dup2 sym_Foldable traverse_
-
-sym_Foldable :: Proxy Sym_Foldable
-sym_Foldable = Proxy
-
--- * Type 'Expr_Foldable'
--- | Expression.
-data Expr_Foldable (root:: *)
-type instance Root_of_Expr (Expr_Foldable root) = root
-type instance Type_of_Expr (Expr_Foldable root) = No_Type
-type instance Sym_of_Expr (Expr_Foldable root) repr = Sym_Foldable repr
-type instance Error_of_Expr ast (Expr_Foldable root) = No_Error_Expr
-
--- | Parse 'foldMap'.
-foldMap_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Foldable root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type0_Constraint Monoid ty
- , Type1_Constraint Foldable ty
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast -> ast
- -> ExprFrom ast (Expr_Foldable root) hs ret
-foldMap_from ast_f ast_ta ex ast ctx k =
- -- foldMap :: (Foldable t, Monoid m) => (a -> m) -> t a -> m
- expr_from (Proxy::Proxy root) ast_f ctx $
- \(ty_f::ty h_f) (Forall_Repr_with_Context f) ->
- expr_from (Proxy::Proxy root) ast_ta ctx $
- \(ty_ta::ty h_ta) (Forall_Repr_with_Context ta) ->
- check_type_fun ex ast ty_f $ \(Type2 Proxy ty_f_a ty_f_m) ->
- check_type1 ex ast ty_ta $ \(Type1 _t (ty_t_a::ty h_t_a), Type1_Lift _ty_t) ->
- check_type0_eq ex ast ty_f_a ty_t_a $ \Refl ->
- check_type1_constraint ex (Proxy::Proxy Foldable) ast ty_ta $ \Dict ->
- check_type0_constraint ex (Proxy::Proxy Monoid) ast ty_f_m $ \Dict ->
- k ty_f_m $ Forall_Repr_with_Context $
- \c -> foldMap (f c) (ta c)
-
--- | Parse 'foldr' or |foldr'|.
-foldr_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Foldable root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type1_Constraint Foldable ty
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => (forall repr f a b. (Sym_Foldable repr, Foldable f) => repr (a -> b -> b) -> repr b -> repr (f a) -> repr b)
- -> ast -> ast -> ast
- -> ExprFrom ast (Expr_Foldable root) hs ret
-foldr_from fold ast_f ast_b ast_ta ex ast ctx k =
- -- foldr :: Foldable t => (a -> b -> b) -> b -> t a -> b
- expr_from (Proxy::Proxy root) ast_f ctx $
- \(ty_f::ty h_f) (Forall_Repr_with_Context f) ->
- expr_from (Proxy::Proxy root) ast_b ctx $
- \(ty_b::ty h_b) (Forall_Repr_with_Context b) ->
- expr_from (Proxy::Proxy root) ast_ta ctx $
- \(ty_ta::ty h_ta) (Forall_Repr_with_Context ta) ->
- check_type_fun ex ast ty_f $ \(Type2 Proxy ty_f_a ty_f_b2b) ->
- check_type_fun ex ast ty_f_b2b $ \(Type2 Proxy ty_f_b ty_f_b') ->
- check_type0_eq ex ast ty_f_b ty_f_b' $ \Refl ->
- check_type0_eq ex ast ty_b ty_f_b $ \Refl ->
- check_type1 ex ast ty_ta $ \(Type1 _t (ty_t_a::ty h_t_a), Type1_Lift _ty_t) ->
- check_type0_eq ex ast ty_f_a ty_t_a $ \Refl ->
- check_type1_constraint ex (Proxy::Proxy Foldable) ast ty_ta $ \Dict ->
- k ty_b $ Forall_Repr_with_Context $
- \c -> fold (f c) (b c) (ta c)
-
--- | Parse 'foldl' or |foldl'|.
-foldl_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Foldable root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type1_Constraint Foldable ty
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => (forall repr f a b. (Sym_Foldable repr, Foldable f) => repr (b -> a -> b) -> repr b -> repr (f a) -> repr b)
- -> ast -> ast -> ast
- -> ExprFrom ast (Expr_Foldable root) hs ret
-foldl_from fold ast_f ast_b ast_ta ex ast ctx k =
- -- foldl :: Foldable t => (b -> a -> b) -> b -> t a -> b
- expr_from (Proxy::Proxy root) ast_f ctx $
- \(ty_f::ty h_f) (Forall_Repr_with_Context f) ->
- expr_from (Proxy::Proxy root) ast_b ctx $
- \(ty_b::ty h_b) (Forall_Repr_with_Context b) ->
- expr_from (Proxy::Proxy root) ast_ta ctx $
- \(ty_ta::ty h_ta) (Forall_Repr_with_Context ta) ->
- check_type_fun ex ast ty_f $ \(Type2 Proxy ty_f_b ty_f_a2b) ->
- check_type_fun ex ast ty_f_a2b $ \(Type2 Proxy ty_f_a ty_f_b') ->
- check_type0_eq ex ast ty_f_b ty_f_b' $ \Refl ->
- check_type0_eq ex ast ty_b ty_f_b $ \Refl ->
- check_type1 ex ast ty_ta $ \(Type1 _t (ty_t_a::ty h_t_a), Type1_Lift _ty_t) ->
- check_type0_eq ex ast ty_f_a ty_t_a $ \Refl ->
- check_type1_constraint ex (Proxy::Proxy Foldable) ast ty_ta $ \Dict ->
- k ty_b $ Forall_Repr_with_Context $
- \c -> fold (f c) (b c) (ta c)
-
--- | Parse 'length'.
-length_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Foldable root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Lift Type_Int (Type_of_Expr root)
- , Type1_Constraint Foldable ty
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast
- -> ExprFrom ast (Expr_Foldable root) hs ret
-length_from ast_ta ex ast ctx k =
- -- length :: Foldable t => t a -> Int
- expr_from (Proxy::Proxy root) ast_ta ctx $
- \(ty_ta::ty h_ta) (Forall_Repr_with_Context ta) ->
- check_type1 ex ast ty_ta $ \(Type1{}, _) ->
- check_type1_constraint ex (Proxy::Proxy Foldable) ast ty_ta $ \Dict ->
- k type_int $ Forall_Repr_with_Context $
- \c -> length (ta c)
-
--- | Parse 'null'.
-null_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Foldable root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Type1_Constraint Foldable ty
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast
- -> ExprFrom ast (Expr_Foldable root) hs ret
-null_from ast_ta ex ast ctx k =
- -- null :: Foldable t => t a -> Bool
- expr_from (Proxy::Proxy root) ast_ta ctx $
- \(ty_ta::ty h_ta) (Forall_Repr_with_Context ta) ->
- check_type1 ex ast ty_ta $ \(Type1{}, _) ->
- check_type1_constraint ex (Proxy::Proxy Foldable) ast ty_ta $ \Dict ->
- k type_bool $ Forall_Repr_with_Context $
- \c -> null (ta c)
-
--- | Parse 'minimum'.
-minimum_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Foldable root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Constraint Ord ty
- , Type1_Constraint Foldable ty
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast
- -> ExprFrom ast (Expr_Foldable root) hs ret
-minimum_from ast_ta ex ast ctx k =
- -- minimum :: (Foldable t, Ord a) => t a -> a
- expr_from (Proxy::Proxy root) ast_ta ctx $
- \(ty_ta::ty h_ta) (Forall_Repr_with_Context ta) ->
- check_type1 ex ast ty_ta $ \(Type1 _ ty_t_a, _) ->
- check_type1_constraint ex (Proxy::Proxy Foldable) ast ty_ta $ \Dict ->
- check_type0_constraint ex (Proxy::Proxy Ord) ast ty_t_a $ \Dict ->
- k ty_t_a $ Forall_Repr_with_Context $
- \c -> minimum (ta c)
-
--- | Parse 'maximum'.
-maximum_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Foldable root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Constraint Ord ty
- , Type1_Constraint Foldable ty
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast
- -> ExprFrom ast (Expr_Foldable root) hs ret
-maximum_from ast_ta ex ast ctx k =
- -- maximum :: (Foldable t, Ord a) => t a -> a
- expr_from (Proxy::Proxy root) ast_ta ctx $
- \(ty_ta::ty h_ta) (Forall_Repr_with_Context ta) ->
- check_type1 ex ast ty_ta $ \(Type1 _ ty_t_a, _) ->
- check_type1_constraint ex (Proxy::Proxy Foldable) ast ty_ta $ \Dict ->
- check_type0_constraint ex (Proxy::Proxy Ord) ast ty_t_a $ \Dict ->
- k ty_t_a $ Forall_Repr_with_Context $
- \c -> maximum (ta c)
-
--- | Parse 'elem'.
-elem_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Foldable root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Constraint Eq ty
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Type1_Constraint Foldable ty
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast -> ast
- -> ExprFrom ast (Expr_Foldable root) hs ret
-elem_from ast_a ast_ta ex ast ctx k =
- -- elem :: (Foldable t, Eq a) => a -> t a -> Bool
- expr_from (Proxy::Proxy root) ast_a ctx $
- \(ty_a::ty h_a) (Forall_Repr_with_Context a) ->
- expr_from (Proxy::Proxy root) ast_ta ctx $
- \(ty_ta::ty h_ta) (Forall_Repr_with_Context ta) ->
- check_type1 ex ast ty_ta $ \(Type1 _ ty_t_a, _) ->
- check_type0_eq ex ast ty_a ty_t_a $ \Refl ->
- check_type1_constraint ex (Proxy::Proxy Foldable) ast ty_ta $ \Dict ->
- check_type0_constraint ex (Proxy::Proxy Eq) ast ty_a $ \Dict ->
- k type_bool $ Forall_Repr_with_Context $
- \c -> a c `elem` ta c
-
--- | Parse 'sum'.
-sum_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Foldable root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Constraint Num ty
- , Type1_Constraint Foldable ty
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast
- -> ExprFrom ast (Expr_Foldable root) hs ret
-sum_from ast_ta ex ast ctx k =
- -- sum :: (Foldable t, Num a) => t a -> a
- expr_from (Proxy::Proxy root) ast_ta ctx $
- \(ty_ta::ty h_ta) (Forall_Repr_with_Context ta) ->
- check_type1 ex ast ty_ta $ \(Type1 _ ty_t_a, _) ->
- check_type1_constraint ex (Proxy::Proxy Foldable) ast ty_ta $ \Dict ->
- check_type0_constraint ex (Proxy::Proxy Num) ast ty_t_a $ \Dict ->
- k ty_t_a $ Forall_Repr_with_Context $
- \c -> sum (ta c)
-
--- | Parse 'product'.
-product_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Foldable root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Constraint Num ty
- , Type1_Constraint Foldable ty
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast
- -> ExprFrom ast (Expr_Foldable root) hs ret
-product_from ast_ta ex ast ctx k =
- -- product :: (Foldable t, Num a) => t a -> a
- expr_from (Proxy::Proxy root) ast_ta ctx $
- \(ty_ta::ty h_ta) (Forall_Repr_with_Context ta) ->
- check_type1 ex ast ty_ta $ \(Type1 _ ty_t_a, _) ->
- check_type1_constraint ex (Proxy::Proxy Foldable) ast ty_ta $ \Dict ->
- check_type0_constraint ex (Proxy::Proxy Num) ast ty_t_a $ \Dict ->
- k ty_t_a $ Forall_Repr_with_Context $
- \c -> product (ta c)
-
--- | Parse 'toList'.
-toList_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Foldable root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Lift Type_List (Type_of_Expr root)
- , Type1_Constraint Foldable ty
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast
- -> ExprFrom ast (Expr_Foldable root) hs ret
-toList_from ast_ta ex ast ctx k =
- -- toList :: Foldable t => t a -> [a]
- expr_from (Proxy::Proxy root) ast_ta ctx $
- \(ty_ta::ty h_ta) (Forall_Repr_with_Context ta) ->
- check_type1 ex ast ty_ta $ \(Type1 _ ty_t_a, _) ->
- check_type1_constraint ex (Proxy::Proxy Foldable) ast ty_ta $ \Dict ->
- k (type_list ty_t_a) $ Forall_Repr_with_Context $
- \c -> toList (ta c)
-
--- | Parse 'all'.
-all_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Foldable root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type1_Constraint Foldable ty
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast -> ast
- -> ExprFrom ast (Expr_Foldable root) hs ret
-all_from ast_f ast_ta ex ast ctx k =
- -- all :: Foldable t => (a -> Bool) -> t a -> Bool
- expr_from (Proxy::Proxy root) ast_f ctx $
- \(ty_f::ty h_f) (Forall_Repr_with_Context f) ->
- expr_from (Proxy::Proxy root) ast_ta ctx $
- \(ty_ta::ty h_ta) (Forall_Repr_with_Context ta) ->
- check_type_fun ex ast ty_f $ \(Type2 Proxy ty_f_a ty_f_b) ->
- check_type0_eq ex ast type_bool ty_f_b $ \Refl ->
- check_type1 ex ast ty_ta $ \(Type1 _ ty_t_a, _) ->
- check_type0_eq ex ast ty_f_a ty_t_a $ \Refl ->
- check_type1_constraint ex (Proxy::Proxy Foldable) ast ty_ta $ \Dict ->
- k type_bool $ Forall_Repr_with_Context $
- \c -> all (f c) (ta c)
-
--- | Parse 'any'.
-any_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Foldable root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type0_Constraint Num ty
- , Type1_Constraint Foldable ty
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast -> ast
- -> ExprFrom ast (Expr_Foldable root) hs ret
-any_from ast_f ast_ta ex ast ctx k =
- -- any :: Foldable t => (a -> Bool) -> t a -> Bool
- expr_from (Proxy::Proxy root) ast_f ctx $
- \(ty_f::ty h_f) (Forall_Repr_with_Context f) ->
- expr_from (Proxy::Proxy root) ast_ta ctx $
- \(ty_ta::ty h_ta) (Forall_Repr_with_Context ta) ->
- check_type_fun ex ast ty_f $ \(Type2 Proxy ty_f_a ty_f_b) ->
- check_type0_eq ex ast type_bool ty_f_b $ \Refl ->
- check_type1 ex ast ty_ta $ \(Type1 _ ty_t_a, _) ->
- check_type0_eq ex ast ty_f_a ty_t_a $ \Refl ->
- check_type1_constraint ex (Proxy::Proxy Foldable) ast ty_ta $ \Dict ->
- k type_bool $ Forall_Repr_with_Context $
- \c -> any (f c) (ta c)
-
--- | Parse 'and'.
-and_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Foldable root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Type1_Constraint Foldable ty
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast
- -> ExprFrom ast (Expr_Foldable root) hs ret
-and_from ast_ta ex ast ctx k =
- -- and :: Foldable t => t Bool -> Bool
- expr_from (Proxy::Proxy root) ast_ta ctx $
- \(ty_ta::ty h_ta) (Forall_Repr_with_Context ta) ->
- check_type1 ex ast ty_ta $ \(Type1 _ ty_t_a, _) ->
- check_type0_eq ex ast type_bool ty_t_a $ \Refl ->
- check_type1_constraint ex (Proxy::Proxy Foldable) ast ty_ta $ \Dict ->
- k type_bool $ Forall_Repr_with_Context $
- \c -> and (ta c)
-
--- | Parse 'or'.
-or_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Foldable root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Type1_Constraint Foldable ty
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast
- -> ExprFrom ast (Expr_Foldable root) hs ret
-or_from ast_ta ex ast ctx k =
- -- or :: Foldable t => t Bool -> Bool
- expr_from (Proxy::Proxy root) ast_ta ctx $
- \(ty_ta::ty h_ta) (Forall_Repr_with_Context ta) ->
- check_type1 ex ast ty_ta $ \(Type1 _ ty_t_a, _) ->
- check_type0_eq ex ast type_bool ty_t_a $ \Refl ->
- check_type1_constraint ex (Proxy::Proxy Foldable) ast ty_ta $ \Dict ->
- k type_bool $ Forall_Repr_with_Context $
- \c -> or (ta c)
-
--- | Parse 'concat'.
-concat_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Foldable root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Lift Type_List (Type_of_Expr root)
- , Type0_Unlift Type_List (Type_of_Expr root)
- , Type1_Constraint Foldable ty
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast
- -> ExprFrom ast (Expr_Foldable root) hs ret
-concat_from ast_ta ex ast ctx k =
- -- concat :: Foldable t => t [a] -> [a]
- expr_from (Proxy::Proxy root) ast_ta ctx $
- \(ty_ta::ty h_ta) (Forall_Repr_with_Context ta) ->
- check_type1 ex ast ty_ta $ \(Type1 _ ty_t_a, _) ->
- check_type_list ex ast ty_t_a $ \Type1{} ->
- check_type1_constraint ex (Proxy::Proxy Foldable) ast ty_ta $ \Dict ->
- k ty_t_a $ Forall_Repr_with_Context $
- \c -> concat (ta c)
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-
-module Expr.Foldable.Test where
-
-import Test.Tasty
-import Test.Tasty.HUnit
-
-import qualified Control.Arrow as Arrow
-import qualified Control.Monad as Monad
-import qualified Data.Functor as Functor
-import Data.Proxy (Proxy(..))
-import Data.Text (Text)
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding ((&&), not, (||), (==), (<$>), (+), Foldable(..))
-
-import Language.Symantic.Type
-import Language.Symantic.Expr as Expr
-import Language.Symantic.Repr
-
-import AST.Test
-
--- * Expressions
-t = bool True
-f = bool False
-e1 = foldMap
- (lam $ \x -> list [x, x])
- (list $ int Functor.<$> [1..3])
-
--- * Tests
-type Ex = Expr_Root
- ( Expr_Lambda
- .|. Expr_List
- .|. Expr_Maybe
- .|. Expr_Int
- .|. Expr_Bool
- .|. Expr_Functor
- .|. Expr_Applicative
- .|. Expr_Foldable
- )
-ex_from = root_expr_from (Proxy::Proxy Ex)
-
-(==>) ast expected =
- testCase (show ast) $
- case ex_from ast of
- Left err -> Left err @?= Prelude.snd `Arrow.left` expected
- Right (Exists_Type0_and_Repr ty (Forall_Repr r)) ->
- case expected of
- Left (_, err) -> Right ("…"::String) @?= Left err
- Right (ty_expected::Type_Root_of_Expr Ex h, _::h, _::Text) ->
- (Monad.>>= (@?= (\(_::Proxy h, err) -> err) `Arrow.left` expected)) $
- case ty `type0_eq` ty_expected of
- Nothing -> Monad.return $ Left $
- error_expr (Proxy::Proxy Ex) $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 ty)
- (Exists_Type0 ty_expected)
- Just Refl -> do
- let h = host_from_expr r
- Monad.return $
- Right
- ( ty
- , h
- , text_from_expr r
- -- , (text_from_expr :: Repr_Text h -> Text) r
- )
-
-tests :: TestTree
-tests = testGroup "Foldable"
- [ AST "foldMap"
- [ AST "\\"
- [ AST "x" [], AST "Int" []
- , AST "list"
- [ AST "Int" []
- , AST "var" [ AST "x" [] ]
- , AST "var" [ AST "x" [] ]
- ]
- ]
- , AST "list"
- [ AST "Int" []
- , AST "int" [AST "1" []]
- , AST "int" [AST "2" []]
- , AST "int" [AST "3" []]
- ]
- ] ==> Right
- ( type_list type_int
- , [1, 1, 2, 2, 3, 3]
- , "foldMap (\\x0 -> [x0, x0]) [1, 2, 3]" )
- ]
+++ /dev/null
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-module Language.Symantic.Expr.From where
-
-import Data.Maybe (fromMaybe)
-import Data.Monoid
-import Data.Proxy (Proxy(..))
-import Data.Text (Text)
-import qualified Data.Text as Text
-import Data.Type.Equality ((:~:)(Refl))
-import GHC.Prim (Constraint)
-
-import Language.Symantic.Type
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Alt
-import Language.Symantic.Expr.Error
-import Language.Symantic.Trans.Common
-import Language.Symantic.Repr
-
--- * Class 'Expr_From'
--- | Parse given @ast@ into
--- a 'Type_Root_of_Expr' and
--- a 'Forall_Repr_with_Context',
--- or return an 'Error_of_Expr'.
-class Expr_From ast (ex:: *) where
- expr_from :: ExprFrom ast ex hs ret
-instance -- Expr_From
- ( Expr_From ast (ex (Expr_Root ex))
- , Root_of_Expr (ex (Expr_Root ex)) ~ Expr_Root ex
- ) => Expr_From ast (Expr_Root ex) where
- expr_from _ex ctx ast k =
- expr_from (Proxy::Proxy (ex (Expr_Root ex)))
- ctx ast $ \ty (Forall_Repr_with_Context repr) ->
- k ty (Forall_Repr_with_Context repr)
-instance -- Expr_From
- ( Expr_From ast (curr root)
- , Expr_From ast (next root)
- , Root_of_Expr (curr root) ~ root
- , Root_of_Expr (next root) ~ root
- , Error_Expr_Unlift (Error_Expr (Error_of_Type ast (Type_Root_of_Expr root))
- (Type_Root_of_Expr root) ast)
- (Error_of_Expr ast root)
- ) => Expr_From ast (Expr_Alt curr next root) where
- expr_from _ex ctx ast k =
- case expr_from (Proxy::Proxy (curr root)) ctx ast $
- \ty (Forall_Repr_with_Context repr) ->
- Right $ k ty (Forall_Repr_with_Context repr) of
- Right ret -> ret
- Left err ->
- case error_expr_unlift err of
- Just (Error_Expr_Unsupported_here _
- :: Error_Expr (Error_of_Type ast (Type_Root_of_Expr root))
- (Type_Root_of_Expr root) ast) ->
- expr_from (Proxy::Proxy (next root)) ctx ast $
- \ty (Forall_Repr_with_Context repr) ->
- k ty (Forall_Repr_with_Context repr)
- _ -> Left err
-
--- ** Type 'ExprFrom'
--- | Convenient type synonym defining a parser.
-type ExprFrom ast ex hs ret
- = Proxy ex
- -- ^ Select the 'Expr_From' instance.
- -> ast
- -- ^ The input data to parse.
- -> Lambda_Context (Lambda_Var (Type_Root_of_Expr ex)) hs
- -- ^ The bound variables in scope and their types:
- -- built top-down in the heterogeneous list @hs@,
- -- from the closest including lambda abstraction to the farest.
- -> ( forall h
- . Type_Root_of_Expr ex h
- -> Forall_Repr_with_Context ex hs h
- -> Either (Error_of_Expr ast (Root_of_Expr ex)) ret )
- -- ^ The accumulating continuation called bottom-up.
- -> Either (Error_of_Expr ast (Root_of_Expr ex)) ret
-
--- ** Type 'Lambda_Context'
--- | GADT for a typing context,
--- accumulating an @item@ at each lambda;
--- used to accumulate object-types (in 'Expr_From')
--- or host-terms (in 'Repr_Host')
--- associated with the 'Lambda_Var's in scope.
-data Lambda_Context :: (* -> *) -> [*] -> * where
- Lambda_Context_Empty :: Lambda_Context item '[]
- Lambda_Context_Next :: item h
- -> Lambda_Context item hs
- -> Lambda_Context item (h ': hs)
-infixr 5 `Lambda_Context_Next`
-
--- ** Type 'Lambda_Var'
--- | Join a name and a type.
---
--- This data type is used to handle lambda variables by name
--- (instead of DeBruijn indices for instance).
-data Lambda_Var ty h
- = Lambda_Var Lambda_Var_Name (ty h)
-type Lambda_Var_Name = Text
-
--- ** Type 'Forall_Repr_with_Context'
--- | A data type embedding a universal quantification
--- over an interpreter @repr@
--- and qualified by the symantics of an expression.
---
--- Moreover the expression is abstracted by a 'Lambda_Context'
--- built top-down at parsing time
--- to build a /Higher-Order Abstract Syntax/ (HOAS)
--- for lambda abstractions.
---
--- This data type is used to keep a parsed expression polymorphic enough
--- to stay interpretable by different interpreters.
---
--- NOTE: 'Sym_of_Expr'@ ex repr@
--- is needed to be able to use symantic methods of the parsed expression
--- into a 'Forall_Repr_with_Context'@ ex@.
---
--- NOTE: 'Sym_of_Expr'@ (@'Root_of_Expr'@ ex) repr@
--- is needed to be able to use an expression
--- out of a 'Forall_Repr_with_Context'@ (@'Root_of_Expr'@ ex)@
--- into a 'Forall_Repr_with_Context'@ ex@,
--- which happens when a symantic method includes a polymorphic type
--- and thus calls: 'expr_from'@ (Proxy::Proxy (@'Root_of_Expr'@ ex))@.
---
--- NOTE: 'Sym_Lambda_Lam'@ repr@
--- is needed to be able to parse partially applied functions
--- (when their type is knowable).
-data Forall_Repr_with_Context ex hs h
- = Forall_Repr_with_Context
- ( forall repr. ( Sym_of_Expr ex repr
- , Sym_of_Expr (Root_of_Expr ex) repr
- , Sym_Lambda_Lam repr
- ) => Lambda_Context repr hs -> repr h )
-
--- ** Type 'Forall_Repr'
--- | 'Forall_Repr_with_Context' applied on a 'Lambda_Context'.
-data Forall_Repr ex h
- = Forall_Repr
- { unForall_Repr :: forall repr
- . ( Sym_of_Expr ex repr
- , Sym_of_Expr (Root_of_Expr ex) repr
- , Sym_Lambda_Lam repr )
- => repr h }
-
--- ** Class 'Sym_Lambda_Lam'
-class Sym_Lambda_Lam repr where
- -- | /Lambda abstraction/.
- lam :: (repr arg -> repr res) -> repr ((->) arg res)
- default lam :: Trans t repr
- => (t repr arg -> t repr res) -> t repr ((->) arg res)
- lam f = trans_lift $ lam $ trans_apply . f . trans_lift
-instance Sym_Lambda_Lam Repr_Host where
- lam f = Repr_Host (unRepr_Host . f . Repr_Host)
-instance Sym_Lambda_Lam Repr_Text where
- lam f = Repr_Text $ \p v ->
- let p' = Precedence 1 in
- let x = "x" <> Text.pack (show v) in
- paren p p' $ "\\" <> x <> " -> "
- <> unRepr_Text (f (Repr_Text $ \_p _v -> x)) p' (succ v)
-instance (Sym_Lambda_Lam r1, Sym_Lambda_Lam r2) => Sym_Lambda_Lam (Repr_Dup r1 r2) where
- lam f = let lam_f = lam f in repr_dup_1 lam_f `Repr_Dup` repr_dup_2 lam_f
-
--- ** Type family 'Sym_of_Expr'
--- | The symantic of an expression.
-type family Sym_of_Expr (ex:: *) (repr:: * -> *) :: Constraint
-type instance Sym_of_Expr (Expr_Root ex) repr
- = Sym_of_Expr (ex (Expr_Root ex)) repr
-type instance Sym_of_Expr (Expr_Alt curr next root) repr
- = ( Sym_of_Expr (curr root) repr
- , Sym_of_Expr (next root) repr
- )
-
--- * Checks
-
--- | Parsing utility to check that the type resulting
--- from the application of a given type family to a given type
--- is within the type stack,
--- or raise 'Error_Expr_Type_mismatch'.
-check_type0_family
- :: forall ast ex tf root ty h ret.
- ( root ~ Root_of_Expr ex
- , ty ~ Type_Root_of_Expr ex
- , Type0_Family tf ty
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- ) => Proxy tf -> Proxy ex -> ast -> ty h
- -> (ty (Host_of_Type0_Family tf h) -> Either (Error_of_Expr ast root) ret)
- -> Either (Error_of_Expr ast root) ret
-check_type0_family tf ex ast ty k =
- case type0_family tf ty of
- Just t -> k t
- Nothing -> Left $ error_expr ex $
- Error_Expr_Type (error_type_lift $ Error_Type_No_Type_Family ast) ast
-
--- | Parsing utility to check that two types are equal,
--- or raise 'Error_Expr_Type_mismatch'.
-check_type0_eq
- :: forall ast ex root ty x y ret.
- ( root ~ Root_of_Expr ex
- , ty ~ Type_Root_of_Expr ex
- , Type0_Eq ty
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- ) => Proxy ex -> ast -> ty x -> ty y
- -> (x :~: y -> Either (Error_of_Expr ast root) ret)
- -> Either (Error_of_Expr ast root) ret
-check_type0_eq ex ast x y k =
- case x `type0_eq` y of
- Just Refl -> k Refl
- Nothing -> Left $ error_expr ex $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 x)
- (Exists_Type0 y)
-
--- | Parsing utility to check that two 'Type1' are equal,
--- or raise 'Error_Expr_Type_mismatch'.
-check_type1_eq
- :: forall ast ex root ty h1 h2 a1 a2 ret.
- ( root ~ Root_of_Expr ex
- , ty ~ Type_Root_of_Expr ex
- , Type1_Eq ty
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- )
- => Proxy ex -> ast -> ty (h1 a1) -> ty (h2 a2)
- -> (h1 :~: h2 -> Either (Error_of_Expr ast root) ret)
- -> Either (Error_of_Expr ast root) ret
-check_type1_eq ex ast h1 h2 k =
- case h1 `type1_eq` h2 of
- Just Refl -> k Refl
- Nothing -> Left $ error_expr ex $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 h1)
- (Exists_Type0 h2)
-
--- | Parsing utility to check that a 'Type0' or higher
--- is an instance of a given 'Constraint',
--- or raise 'Error_Expr_Constraint_missing'.
-check_type0_constraint
- :: forall ast ex c root ty h ret.
- ( root ~ Root_of_Expr ex
- , ty ~ Type_Root_of_Expr ex
- , Type0_Constraint c ty
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- )
- => Proxy ex -> Proxy c -> ast -> ty h
- -> (Dict (c h) -> Either (Error_of_Expr ast root) ret)
- -> Either (Error_of_Expr ast root) ret
-check_type0_constraint ex c ast ty k =
- case type0_constraint c ty of
- Just Dict -> k Dict
- Nothing -> Left $ error_expr ex $
- Error_Expr_Constraint_missing ast
- {-(Exists_Dict c)-}
- -- FIXME: not easy to report the constraint
- -- and still support 'Eq' and 'Show' deriving.
- (Exists_Type0 ty)
-
--- | Parsing utility to check that a 'Type1' or higher
--- is an instance of a given 'Constraint',
--- or raise 'Error_Expr_Constraint_missing'.
-check_type1_constraint
- :: forall ast ex c root ty h a ret.
- ( root ~ Root_of_Expr ex
- , ty ~ Type_Root_of_Expr ex
- , Type1_Constraint c ty
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- ) => Proxy ex -> Proxy c -> ast -> ty (h a)
- -> (Dict (c h) -> Either (Error_of_Expr ast root) ret)
- -> Either (Error_of_Expr ast root) ret
-check_type1_constraint ex c ast ty k =
- case type1_constraint c ty of
- Just Dict -> k Dict
- Nothing -> Left $ error_expr ex $
- Error_Expr_Constraint_missing ast
- (Exists_Type0 ty)
-
--- | Parsing utility to check that the given type is at least a 'Type1'
--- or raise 'Error_Expr_Type_mismatch'.
-check_type1
- :: forall ast ex root ty h ret.
- ( root ~ Root_of_Expr ex
- , ty ~ Type_Root_of_Expr ex
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- ) => Proxy ex -> ast -> ty h
- -> (forall (t1:: *).
- ( Type1 t1 ty h
- , Type1_Lift t1 ty (Type_Var0 :|: Type_Var1 :|: Type_of_Expr root)
- ) -> Either (Error_of_Expr ast root) ret)
- -> Either (Error_of_Expr ast root) ret
-check_type1 ex ast ty k =
- (`fromMaybe` type1_unlift (unType_Root ty) (Just . k)) $
- Left $ error_expr ex $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 (type_var1 SZero (type_var0 SZero)
- :: ty (Var1 Var0)))
- (Exists_Type0 ty)
-
--- * Parsers
-
--- | Like 'expr_from' but for a root expression.
-root_expr_from
- :: forall ast root.
- ( Expr_From ast root
- , Root_of_Expr root ~ root
- ) => Proxy root -> ast
- -> Either (Error_of_Expr ast root)
- (Exists_Type0_and_Repr (Type_Root_of_Expr root)
- (Forall_Repr root))
-root_expr_from _ex ast =
- expr_from (Proxy::Proxy root) ast
- Lambda_Context_Empty $ \ty (Forall_Repr_with_Context repr) ->
- Right $ Exists_Type0_and_Repr ty $
- Forall_Repr $ repr Lambda_Context_Empty
-
--- | Parse a literal.
-lit_from
- :: forall ty lit ex ast hs ret.
- ( ty ~ Type_Root_of_Expr ex
- , Read lit
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast (Root_of_Expr ex))
- ) => (forall repr. Sym_of_Expr ex repr => lit -> repr lit)
- -> ty lit -> Text
- -> ExprFrom ast ex hs ret
-lit_from lit ty_lit toread ex ast _ctx k =
- case read_safe toread of
- Left err -> Left $ error_expr ex $ Error_Expr_Read err ast
- Right (i::lit) -> k ty_lit $ Forall_Repr_with_Context $ const $ lit i
-
--- | Parse a unary class operator.
-class_op1_from
- :: forall root ty cl ex ast hs ret.
- ( ty ~ Type_Root_of_Expr ex
- , root ~ Root_of_Expr ex
- , Type0_Eq ty
- , Expr_From ast root
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- , Type0_Constraint cl ty
- ) => (forall lit repr. (cl lit, Sym_of_Expr ex repr) => repr lit -> repr lit)
- -> Proxy cl -> ast
- -> ExprFrom ast ex hs ret
-class_op1_from op cl ast_x ex _ast ctx k =
- expr_from (Proxy::Proxy root) ast_x ctx $ \ty_x (Forall_Repr_with_Context x) ->
- check_type0_constraint ex cl ast_x ty_x $ \Dict ->
- k ty_x $ Forall_Repr_with_Context (op . x)
-
--- | Parse a binary class operator.
-class_op2_from
- :: forall root ty cl ex ast hs ret.
- ( ty ~ Type_Root_of_Expr ex
- , root ~ Root_of_Expr ex
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Constraint cl ty
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => (forall lit repr. (cl lit, Sym_of_Expr ex repr) => repr lit -> repr lit -> repr lit)
- -> Proxy cl -> ast -> ast
- -> ExprFrom ast ex hs ret
-class_op2_from op cl ast_x ast_y ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_x ctx $ \ty_x (Forall_Repr_with_Context x) ->
- expr_from (Proxy::Proxy root) ast_y ctx $ \ty_y (Forall_Repr_with_Context y) ->
- check_type0_constraint ex cl ast_x ty_x $ \Dict ->
- check_type0_constraint ex cl ast_y ty_y $ \Dict ->
- check_type0_eq ex ast ty_x ty_y $ \Refl ->
- k ty_x $ Forall_Repr_with_Context $
- \c -> x c `op` y c
-
--- | Parse a binary class operator, partially applied.
-class_op2_from1
- :: forall root ty cl ex ast hs ret.
- ( ty ~ Type_Root_of_Expr ex
- , root ~ Root_of_Expr ex
- , Type0_Eq ty
- , Type0_Constraint cl ty
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Expr_From ast root
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => (forall lit repr. (cl lit, Sym_of_Expr ex repr) => repr lit -> repr lit -> repr lit)
- -> Proxy cl -> ast
- -> ExprFrom ast ex hs ret
-class_op2_from1 op cl ast_x ex _ast ctx k =
- expr_from (Proxy::Proxy root) ast_x ctx $ \ty_x (Forall_Repr_with_Context x) ->
- check_type0_constraint ex cl ast_x ty_x $ \Dict ->
- k (type_fun ty_x ty_x) $ Forall_Repr_with_Context $
- \c -> lam $ \y -> x c `op` y
-
--- | Parse a unary operator.
-op1_from
- :: forall root ty lit ex ast hs ret.
- ( ty ~ Type_Root_of_Expr ex
- , root ~ Root_of_Expr ex
- , Type0_Eq ty
- , Expr_From ast root
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => (forall repr. Sym_of_Expr ex repr => repr lit -> repr lit)
- -> ty lit -> ast
- -> ExprFrom ast ex hs ret
-op1_from op ty_lit ast_x ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_x ctx $ \ty_x (Forall_Repr_with_Context x) ->
- check_type0_eq ex ast ty_lit ty_x $ \Refl ->
- k ty_x $ Forall_Repr_with_Context (op . x)
-
--- | Parse a unary operator, partially applied.
-op1_from0
- :: forall root ty lit ex ast hs ret.
- ( ty ~ Type_Root_of_Expr ex
- , root ~ Root_of_Expr ex
- , Type0_Eq ty
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Expr_From ast root
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => (forall repr. Sym_of_Expr ex repr => repr lit -> repr lit)
- -> ty lit
- -> ExprFrom ast ex hs ret
-op1_from0 op ty_lit _ex _ast _ctx k =
- k (type_fun ty_lit ty_lit) $ Forall_Repr_with_Context $
- \_c -> lam op
-
--- | Parse a binary operator.
-op2_from
- :: forall root ty lit ex ast hs ret.
- ( ty ~ Type_Root_of_Expr ex
- , root ~ Root_of_Expr ex
- , Type0_Eq ty
- , Expr_From ast root
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => (forall repr. Sym_of_Expr ex repr => repr lit -> repr lit -> repr lit)
- -> ty lit -> ast -> ast
- -> ExprFrom ast ex hs ret
-op2_from op ty_lit ast_x ast_y ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_x ctx $ \ty_x (Forall_Repr_with_Context x) ->
- expr_from (Proxy::Proxy root) ast_y ctx $ \ty_y (Forall_Repr_with_Context y) ->
- check_type0_eq ex ast ty_lit ty_x $ \Refl ->
- check_type0_eq ex ast ty_lit ty_y $ \Refl ->
- k ty_x $ Forall_Repr_with_Context $
- \c -> x c `op` y c
-
--- | Parse a binary operator, partially applied.
-op2_from1
- :: forall root ty lit ex ast hs ret.
- ( ty ~ Type_Root_of_Expr ex
- , root ~ Root_of_Expr ex
- , Type0_Eq ty
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Expr_From ast root
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => (forall repr. Sym_of_Expr ex repr => repr lit -> repr lit -> repr lit)
- -> ty lit -> ast
- -> ExprFrom ast ex hs ret
-op2_from1 op ty_lit ast_x ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_x ctx $ \ty_x (Forall_Repr_with_Context x) ->
- check_type0_eq ex ast ty_lit ty_x $ \Refl ->
- k (type_fun ty_x ty_x) $ Forall_Repr_with_Context $
- \c -> lam $ \y -> x c `op` y
-
--- | Parse a binary operator, partially applied.
-op2_from0
- :: forall root ty lit ex ast hs ret.
- ( ty ~ Type_Root_of_Expr ex
- , root ~ Root_of_Expr ex
- , Type0_Eq ty
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Expr_From ast root
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => (forall repr. Sym_of_Expr ex repr => repr lit -> repr lit -> repr lit)
- -> ty lit
- -> ExprFrom ast ex hs ret
-op2_from0 op ty_lit _ex _ast _ctx k =
- k (type_fun ty_lit $ type_fun ty_lit ty_lit) $ Forall_Repr_with_Context $
- \_c -> lam $ \x -> lam $ \y -> x `op` y
+++ /dev/null
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
--- | Expression for 'Functor'.
-module Language.Symantic.Expr.Functor where
-
-import Control.Monad (liftM2)
-import Data.Proxy (Proxy(..))
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding (fmap, (<$))
-import qualified Data.Function as Fun
-import qualified Data.Functor as Functor
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Expr.Lambda
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_Functor'
--- | Symantic.
-class Sym_Lambda repr => Sym_Functor repr where
- fmap :: Functor f => repr (a -> b) -> repr (f a) -> repr (f b)
- default fmap
- :: (Trans t repr, Functor f)
- => t repr (a -> b)
- -> t repr (f a)
- -> t repr (f b)
- fmap = trans_map2 fmap
-
- (<$) :: Functor f => repr a -> repr (f b) -> repr (f a)
- (<$) a = fmap (lam (Fun.const a))
-
-infixl 4 <$
-
-instance Sym_Functor Repr_Host where
- fmap = liftM2 Functor.fmap
- (<$) = liftM2 (Functor.<$)
-instance Sym_Functor Repr_Text where
- fmap = repr_text_app2 "fmap"
- (<$) = repr_text_infix "<$" (Precedence 4)
-instance (Sym_Functor r1, Sym_Functor r2) => Sym_Functor (Repr_Dup r1 r2) where
- fmap = repr_dup2 sym_Functor fmap
- (<$) = repr_dup2 sym_Functor (<$)
-
-sym_Functor :: Proxy Sym_Functor
-sym_Functor = Proxy
-
--- | 'fmap' alias.
-(<$>) :: (Sym_Functor repr, Functor f)
- => repr (a -> b) -> repr (f a) -> repr (f b)
-(<$>) = fmap
-infixl 4 <$>
-
--- * Type 'Expr_Functor'
--- | Expression.
-data Expr_Functor (root:: *)
-type instance Root_of_Expr (Expr_Functor root) = root
-type instance Type_of_Expr (Expr_Functor root) = No_Type
-type instance Sym_of_Expr (Expr_Functor root) repr = Sym_Functor repr
-type instance Error_of_Expr ast (Expr_Functor root) = No_Error_Expr
-
--- | Parse 'fmap'.
-fmap_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Functor root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- , Type1_Constraint Functor ty
- ) => ast -> ast
- -> ExprFrom ast (Expr_Functor root) hs ret
-fmap_from ast_g ast_fa ex ast ctx k =
- -- fmap :: Functor f => (a -> b) -> f a -> f b
- expr_from (Proxy::Proxy root) ast_g ctx $
- \(ty_g::ty h_g) (Forall_Repr_with_Context g) ->
- expr_from (Proxy::Proxy root) ast_fa ctx $
- \(ty_fa::ty h_fa) (Forall_Repr_with_Context fa) ->
- check_type_fun ex ast ty_g $ \(Type2 Proxy ty_g_a ty_g_b) ->
- check_type1 ex ast ty_fa $ \(Type1 f ty_fa_a, Type1_Lift f_lift) ->
- check_type1_constraint ex (Proxy::Proxy Functor) ast ty_fa $ \Dict ->
- check_type0_eq ex ast ty_g_a ty_fa_a $ \Refl ->
- k (Type_Root $ f_lift $ Type1 f ty_g_b) $ Forall_Repr_with_Context $
- \c -> fmap (g c) (fa c)
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-
-module Expr.Functor.Test where
-
-import Test.Tasty
-import Test.Tasty.HUnit
-
-import qualified Control.Arrow as Arrow
-import qualified Control.Monad as Monad
-import Data.Proxy (Proxy(..))
-import Data.Text (Text)
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding ((&&), not, (||), (==), fmap, (+))
-
-import Language.Symantic.Type
-import Language.Symantic.Expr as Expr
-import Language.Symantic.Repr
-
-import AST.Test
-
--- * Expressions
-t = bool True
-f = bool False
-e1 = fmap (lam $ \x -> x + int 1) (list $ int Prelude.<$> [1..3])
-
--- * Tests
-type Ex = Expr_Root
- ( Expr_Lambda
- .|. Expr_Maybe
- .|. Expr_List
- .|. Expr_Functor
- .|. Expr_Int
- .|. Expr_Integer
- .|. Expr_Num
- .|. Expr_Bool
- )
-ex_from = root_expr_from (Proxy::Proxy Ex)
-
-(==>) ast expected =
- testCase (show ast) $
- case ex_from ast of
- Left err -> Left err @?= Prelude.snd `Arrow.left` expected
- Right (Exists_Type0_and_Repr ty (Forall_Repr r)) ->
- case expected of
- Left (_, err) -> Right ("…"::String) @?= Left err
- Right (ty_expected::Type_Root_of_Expr Ex h, _::h, _::Text) ->
- (Monad.>>= (@?= (\(_::Proxy h, err) -> err) `Arrow.left` expected)) $
- case ty `type0_eq` ty_expected of
- Nothing -> Monad.return $ Left $
- error_expr (Proxy::Proxy Ex) $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 ty)
- (Exists_Type0 ty_expected)
- Just Refl -> do
- let h = host_from_expr r
- Monad.return $
- Right
- ( ty
- , h
- , text_from_expr r
- -- , (text_from_expr :: Repr_Text h -> Text) r
- )
-
-tests :: TestTree
-tests = testGroup "Functor"
- [ AST "fmap"
- [ AST "\\"
- [ AST "x" []
- , AST "Int" []
- , AST "+" [ AST "var" [AST "x" []]
- , AST "int" [AST "1" []] ]
- ]
- , AST "list"
- [ AST "Int" []
- , AST "int" [AST "1" []]
- , AST "int" [AST "2" []]
- , AST "int" [AST "3" []]
- ]
- ] ==> Right
- ( type_list type_int
- , [2,3,4]
- , "fmap (\\x0 -> x0 + 1) [1, 2, 3]" )
- ]
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
--- | Expression for 'IO'.
-module Language.Symantic.Expr.IO where
-
-import Control.Monad
-import Data.Proxy (Proxy(..))
-import Data.Type.Equality ((:~:)(Refl))
-import qualified System.IO as IO
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_IO_Lam'
--- | Symantic.
-class Sym_IO repr where
- io_hClose :: repr IO.Handle -> repr (IO ())
- io_openFile :: repr IO.FilePath -> repr IO.IOMode -> repr (IO IO.Handle)
-
- default io_hClose :: Trans t repr => t repr IO.Handle -> t repr (IO ())
- default io_openFile :: Trans t repr => t repr IO.FilePath -> t repr IO.IOMode -> t repr (IO IO.Handle)
- io_hClose = trans_map1 io_hClose
- io_openFile = trans_map2 io_openFile
-instance Sym_IO Repr_Host where
- io_hClose = liftM IO.hClose
- io_openFile = liftM2 IO.openFile
-instance Sym_IO Repr_Text where
- io_hClose = repr_text_app1 "io_hClose"
- io_openFile = repr_text_app2 "io_openFile"
-instance (Sym_IO r1, Sym_IO r2) => Sym_IO (Repr_Dup r1 r2) where
- io_hClose = repr_dup1 sym_IO io_hClose
- io_openFile = repr_dup2 sym_IO io_openFile
-
-sym_IO :: Proxy Sym_IO
-sym_IO = Proxy
-
--- * Type 'Expr_IO'
--- | Expression.
-data Expr_IO (root:: *)
-type instance Root_of_Expr (Expr_IO root) = root
-type instance Type_of_Expr (Expr_IO root) = Type_IO
-type instance Sym_of_Expr (Expr_IO root) repr = Sym_IO repr
-type instance Error_of_Expr ast (Expr_IO root) = No_Error_Expr
-
--- | Parsing utility to check that the given type is a 'Type_IO'
--- or raise 'Error_Expr_Type_mismatch'.
-check_type_io
- :: forall ast ex root ty h ret.
- ( root ~ Root_of_Expr ex
- , ty ~ Type_Root_of_Expr ex
- , Type0_Lift Type_IO (Type_of_Expr root)
- , Type0_Unlift Type_IO (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- )
- => Proxy ex -> ast -> ty h
- -> (Type_IO ty h -> Either (Error_of_Expr ast root) ret)
- -> Either (Error_of_Expr ast root) ret
-check_type_io ex ast ty k =
- case type0_unlift $ unType_Root ty of
- Just ty_l -> k ty_l
- Nothing -> Left $
- error_expr ex $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 (type_io $ type_var0 SZero
- :: ty (IO Var0)))
- (Exists_Type0 ty)
-
--- | Parse 'io_hClose'.
-io_hclose_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_IO root)
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Unit (Type_of_Expr root)
- , Type0_Lift Type_IO_Handle (Type_of_Expr root)
- , Type0_Lift Type_IO (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast
- -> ExprFrom ast (Expr_IO root) hs ret
-io_hclose_from ast_h ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_h ctx $
- \(ty_h::ty h_h) (Forall_Repr_with_Context h) ->
- check_type0_eq ex ast type_io_handle ty_h $ \Refl ->
- k (type_io type_unit) $ Forall_Repr_with_Context $
- \c -> io_hClose (h c)
-
--- | Parse 'io_openFile'.
-io_openfile_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_IO root)
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_IO_FilePath (Type_of_Expr root)
- , Type0_Lift Type_IO_Handle (Type_of_Expr root)
- , Type0_Lift Type_IO_Mode (Type_of_Expr root)
- , Type0_Lift Type_IO (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast -> ast
- -> ExprFrom ast (Expr_IO root) hs ret
-io_openfile_from ast_file ast_mode ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_file ctx $
- \(ty_file::ty h_file) (Forall_Repr_with_Context file) ->
- expr_from (Proxy::Proxy root) ast_mode ctx $
- \(ty_mode::ty h_mode) (Forall_Repr_with_Context mode) ->
- check_type0_eq ex ast type_io_filepath ty_file $ \Refl ->
- check_type0_eq ex ast type_io_mode ty_mode $ \Refl ->
- k (type_io type_io_handle) $ Forall_Repr_with_Context $
- \c -> io_openFile (file c) (mode c)
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
--- | Expression for @if@.
-module Language.Symantic.Expr.If where
-
-import qualified Control.Monad as Monad
-import Data.Monoid
-import Data.Proxy (Proxy(..))
-import Data.Type.Equality ((:~:)(Refl))
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_If'
--- | Symantic.
-class Sym_If repr where
- if_ :: repr Bool -> repr a -> repr a -> repr a
- default if_ :: Trans t repr => t repr Bool -> t repr a -> t repr a -> t repr a
- if_ = trans_map3 if_
-instance Sym_If Repr_Host where
- if_ (Repr_Host b) ok ko = if b then ok else ko
-instance Sym_If Repr_Text where
- if_ (Repr_Text cond) (Repr_Text ok) (Repr_Text ko) =
- Repr_Text $ \p v ->
- let p' = Precedence 2 in
- paren p p' $
- "if " <> cond p' v <>
- " then " <> ok p' v <>
- " else " <> ko p' v
-
-instance (Sym_If r1, Sym_If r2) => Sym_If (Repr_Dup r1 r2) where
- if_ = repr_dup3 sym_If if_
-
-sym_If :: Proxy Sym_If
-sym_If = Proxy
-
--- * Class 'Sym_When'
--- | Symantic.
-class Sym_When repr where
- when :: repr Bool -> repr () -> repr ()
- default when :: Trans t repr => t repr Bool -> t repr () -> t repr ()
- when = trans_map2 when
-instance Sym_When Repr_Host where
- when (Repr_Host b) = Monad.when b
-instance Sym_When Repr_Text where
- when (Repr_Text cond) (Repr_Text ok) =
- Repr_Text $ \p v ->
- let p' = Precedence 2 in
- paren p p' $
- "when " <> cond p' v <>
- " " <> ok p' v
-instance (Sym_When r1, Sym_When r2) => Sym_When (Repr_Dup r1 r2) where
- when = repr_dup2 sym_When when
-
-sym_When :: Proxy Sym_When
-sym_When = Proxy
-
--- * Type 'Expr_If'
--- | Expression.
-data Expr_If (root:: *)
-type instance Root_of_Expr (Expr_If root) = root
-type instance Type_of_Expr (Expr_If root) = No_Type
-type instance Sym_of_Expr (Expr_If root) repr = Sym_If repr
-type instance Error_of_Expr ast (Expr_If root) = No_Error_Expr
-
-if_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_If root)
- , Type0_Eq ty
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Expr_From ast root
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast -> ast -> ast
- -> ExprFrom ast (Expr_If root) hs ret
-if_from ast_cond ast_ok ast_ko ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_cond ctx $
- \(ty_cond::ty h_n) (Forall_Repr_with_Context cond) ->
- expr_from (Proxy::Proxy root) ast_ok ctx $
- \(ty_ok::ty h_ok) (Forall_Repr_with_Context ok) ->
- expr_from (Proxy::Proxy root) ast_ko ctx $
- \(ty_ko::ty h_ko) (Forall_Repr_with_Context ko) ->
- check_type0_eq ex ast type_bool ty_cond $ \Refl ->
- check_type0_eq ex ast ty_ok ty_ko $ \Refl ->
- k ty_ok $ Forall_Repr_with_Context $
- \c -> if_ (cond c) (ok c) (ko c)
-
--- * Type 'Expr_When'
--- | Expression.
-data Expr_When (root:: *)
-type instance Root_of_Expr (Expr_When root) = root
-type instance Type_of_Expr (Expr_When root) = No_Type
-type instance Sym_of_Expr (Expr_When root) repr = Sym_When repr
-type instance Error_of_Expr ast (Expr_When root) = No_Error_Expr
-
-when_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_When root)
- , Type0_Eq ty
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Type0_Lift Type_Unit (Type_of_Expr root)
- , Expr_From ast root
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast -> ast
- -> ExprFrom ast (Expr_When root) hs ret
-when_from ast_cond ast_ok ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_cond ctx $
- \(ty_cond::ty h_n) (Forall_Repr_with_Context cond) ->
- expr_from (Proxy::Proxy root) ast_ok ctx $
- \(ty_ok::ty h_ok) (Forall_Repr_with_Context ok) ->
- check_type0_eq ex ast type_bool ty_cond $ \Refl ->
- check_type0_eq ex ast type_unit ty_ok $ \Refl ->
- k ty_ok $ Forall_Repr_with_Context $
- \c -> when (cond c) (ok c)
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-module Expr.If.Test where
-
-import Test.Tasty
-import Test.Tasty.HUnit
-
-import qualified Control.Arrow as Arrow
-import qualified Control.Monad as Monad
-import Data.Proxy (Proxy(..))
-import Data.Text (Text)
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding (maybe, not, (&&), Monad(..))
-
-import Language.Symantic.Repr
-import Language.Symantic.Expr
-import Language.Symantic.Type
-
-import AST.Test
-
--- * Expressions
-e1 = if_ (bool True) (bool False) (bool True)
-e2 = if_ (bool True && bool True) (bool False) (bool True)
-
--- * Tests
-type Ex = Expr_Root
- ( Expr_Lambda
- .|. Expr_If
- .|. Expr_Bool
- )
-ex_from = root_expr_from (Proxy::Proxy Ex)
-
-(==>) ast expected =
- testCase (show ast) $
- case ex_from ast of
- Left err -> Left err @?= Prelude.snd `Arrow.left` expected
- Right (Exists_Type0_and_Repr ty (Forall_Repr r)) ->
- case expected of
- Left (_, err) -> Right ("…"::String) @?= Left err
- Right (ty_expected::Type_Root_of_Expr Ex h, _::h, _::Text) ->
- (Monad.>>= (@?= (\(_::Proxy h, err) -> err) `Arrow.left` expected)) $
- case ty `type0_eq` ty_expected of
- Nothing -> Monad.return $ Left $
- error_expr (Proxy::Proxy Ex) $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 ty)
- (Exists_Type0 ty_expected)
- Just Refl -> do
- let h = host_from_expr r
- Monad.return $
- Right
- ( ty
- , h
- , text_from_expr r
- -- , (text_from_expr :: Repr_Text h -> Text) r
- )
-
-tests :: TestTree
-tests = testGroup "If"
- [ AST "if"
- [ AST "bool" [AST "True" []]
- , AST "bool" [AST "False" []]
- , AST "bool" [AST "True" []]
- ] ==> Right
- ( type_bool
- , False
- , "if True then False else True" )
- ]
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
--- | Expression for 'Int'.
-module Language.Symantic.Expr.Int where
-
-import Data.Proxy
-import qualified Data.Text as Text
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_Int'
--- | Symantic.
-class Sym_Int repr where
- int :: Int -> repr Int
- default int :: Trans t repr => Int -> t repr Int
- int = trans_lift . int
-instance Sym_Int Repr_Host where
- int = Repr_Host
-instance Sym_Int Repr_Text where
- int a = Repr_Text $ \_p _v ->
- Text.pack (show a)
-instance (Sym_Int r1, Sym_Int r2) => Sym_Int (Repr_Dup r1 r2) where
- int x = int x `Repr_Dup` int x
-
-sym_Int :: Proxy Sym_Int
-sym_Int = Proxy
-
--- * Type 'Expr_Int'
--- | Expression.
-data Expr_Int (root:: *)
-type instance Root_of_Expr (Expr_Int root) = root
-type instance Type_of_Expr (Expr_Int root) = Type_Int
-type instance Sym_of_Expr (Expr_Int root) repr = Sym_Int repr
-type instance Error_of_Expr ast (Expr_Int root) = No_Error_Expr
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-module Expr.Int.Test where
-
-import Test.Tasty
-import Test.Tasty.HUnit
-
-import qualified Control.Arrow as Arrow
-import qualified Control.Monad as Monad
-import Data.Proxy (Proxy(..))
-import Data.Text (Text)
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding ((&&), not, (||), (+), negate)
-
-import Language.Symantic.Repr
-import Language.Symantic.Expr
-import Language.Symantic.Type
--- import Language.Symantic.Trans
-
-import AST.Test
-
--- * Class 'Sym_Int_Vars'
-
--- | A few boolean variables.
-class Sym_Int_Vars repr where
- x :: repr Int
- y :: repr Int
- z :: repr Int
-instance Sym_Int_Vars Repr_Text where
- x = Repr_Text $ \_p _v -> "x"
- y = Repr_Text $ \_p _v -> "y"
- z = Repr_Text $ \_p _v -> "z"
-
--- * Expressions
-e1 = int 1 + int 0
-e2 = (int 1 + int 0) + negate (int 1 + int 1)
-e3 = (int 1 + negate (int 0)) + (int 1 + negate (int 1))
-e4 = int 0 + negate (int 1)
-e5 = int 1 + negate x
-e6 = x + y
-e7 = (x + y) + z
-e8 = x + (y + int 1)
-
--- * Tests
-type Ex = Expr_Root
- ( Expr_Lambda
- .|. Expr_Int
- .|. Expr_Integer
- .|. Expr_Num
- )
-ex_from = root_expr_from (Proxy::Proxy Ex)
-
-(==>) ast expected =
- testCase (show ast) $
- case ex_from ast of
- Left err -> Left err @?= Prelude.snd `Arrow.left` expected
- Right (Exists_Type0_and_Repr ty (Forall_Repr r)) ->
- case expected of
- Left (_, err) -> Right ("…"::String) @?= Left err
- Right (ty_expected::Type_Root_of_Expr Ex h, _::h, _::Text) ->
- (Monad.>>= (@?= (\(_::Proxy h, err) -> err) `Arrow.left` expected)) $
- case ty `type0_eq` ty_expected of
- Nothing -> Monad.return $ Left $
- error_expr (Proxy::Proxy Ex) $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 ty)
- (Exists_Type0 ty_expected)
- Just Refl -> do
- let h = host_from_expr r
- Monad.return $
- Right
- ( ty
- , h
- , text_from_expr r
- -- , (text_from_expr :: Repr_Text h -> Text) r
- )
-
-tests :: TestTree
-tests = testGroup "Int" $
- [ AST "int" [AST "1" []] ==> Right
- ( type_int
- , 1
- , "1" )
- , AST "bool" [AST "True" []] ==> Left (Proxy::Proxy Bool,
- Error_Expr_Alt_Curr $
- Error_Expr_Unsupported $ AST "bool" [AST "True" []])
- , AST "+"
- [ AST "int" [AST "1" []]
- , AST "int" [AST "1" []]
- ] ==> Right
- ( type_int
- , 2
- , "1 + 1" )
- , let ast = AST "$"
- [ AST "int" [AST "1" []]
- , AST "int" [AST "1" []]
- ] in ast ==> Left (Proxy::Proxy Int,
- Error_Expr_Alt_Curr $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 (type_var0 SZero `type_fun` type_var0 (SSucc SZero)
- ::Type_Root_of_Expr Ex ((->) Var0 Var0)))
- (Exists_Type0 type_int))
- , AST "$"
- [ AST "\\"
- [ AST "x" []
- , AST "Int" []
- , AST "var" [AST "x" []]
- ]
- , AST "int" [AST "1" []]
- ] ==> Right
- ( type_int
- , 1
- , "(\\x0 -> x0) 1" )
- , AST "$"
- [ AST "\\"
- [ AST "x" []
- , AST "Int" []
- , AST "+"
- [ AST "var" [AST "x" []]
- , AST "int" [AST "1" []]
- ]
- ]
- , AST "int" [AST "1" []]
- ] ==> Right
- ( type_int
- , 2
- , "(\\x0 -> x0 + 1) 1" )
- , AST "let"
- [ AST "x" []
- , AST "int" [AST "1" []]
- , AST "+"
- [ AST "var" [AST "x" []]
- , AST "int" [AST "1" []]
- ]
- ] ==> Right
- ( type_int
- , 2
- , "let x0 = 1 in x0 + 1" )
- ]
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
--- | Expression for 'Integer'.
-module Language.Symantic.Expr.Integer where
-
-import Data.Proxy
-import qualified Data.Text as Text
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_Int'
--- | Symantic.
-class Sym_Integer repr where
- integer :: Integer -> repr Integer
- default integer :: Trans t repr => Integer -> t repr Integer
- integer = trans_lift . integer
-instance Sym_Integer Repr_Host where
- integer = Repr_Host
-instance Sym_Integer Repr_Text where
- integer a = Repr_Text $ \_p _v ->
- Text.pack (show a)
-instance (Sym_Integer r1, Sym_Integer r2) => Sym_Integer (Repr_Dup r1 r2) where
- integer x = integer x `Repr_Dup` integer x
-
-sym_Integer :: Proxy Sym_Integer
-sym_Integer = Proxy
-
--- * Type 'Expr_Integer'
--- | Expression.
-data Expr_Integer (root:: *)
-type instance Root_of_Expr (Expr_Integer root) = root
-type instance Type_of_Expr (Expr_Integer root) = Type_Integer
-type instance Sym_of_Expr (Expr_Integer root) repr = Sym_Integer repr
-type instance Error_of_Expr ast (Expr_Integer root) = No_Error_Expr
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
--- | Expression for 'Integral'.
-module Language.Symantic.Expr.Integral where
-
-import Control.Monad
-import Data.Proxy (Proxy(..))
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding (Integral(..))
-import Prelude (Integral)
-import qualified Prelude
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_Integral'
--- | Symantic.
-class Sym_Integral repr where
- quot :: Integral i => repr i -> repr i -> repr i
- rem :: Integral i => repr i -> repr i -> repr i
- div :: Integral i => repr i -> repr i -> repr i
- mod :: Integral i => repr i -> repr i -> repr i
- quotRem :: Integral i => repr i -> repr i -> repr (i, i)
- divMod :: Integral i => repr i -> repr i -> repr (i, i)
- toInteger :: Integral i => repr i -> repr Integer
-
- default quot :: (Trans t repr, Integral i) => t repr i -> t repr i -> t repr i
- default rem :: (Trans t repr, Integral i) => t repr i -> t repr i -> t repr i
- default div :: (Trans t repr, Integral i) => t repr i -> t repr i -> t repr i
- default mod :: (Trans t repr, Integral i) => t repr i -> t repr i -> t repr i
- default quotRem :: (Trans t repr, Integral i) => t repr i -> t repr i -> t repr (i, i)
- default divMod :: (Trans t repr, Integral i) => t repr i -> t repr i -> t repr (i, i)
- default toInteger :: (Trans t repr, Integral i) => t repr i -> t repr Integer
-
- quot = trans_map2 quot
- rem = trans_map2 rem
- div = trans_map2 div
- mod = trans_map2 mod
- quotRem = trans_map2 quotRem
- divMod = trans_map2 divMod
- toInteger = trans_map1 toInteger
-
-infixl 7 `quot`
-infixl 7 `rem`
-infixl 7 `div`
-infixl 7 `mod`
-
-instance Sym_Integral Repr_Host where
- quot = liftM2 Prelude.quot
- rem = liftM2 Prelude.rem
- div = liftM2 Prelude.div
- mod = liftM2 Prelude.mod
- quotRem = liftM2 Prelude.quotRem
- divMod = liftM2 Prelude.divMod
- toInteger = liftM Prelude.toInteger
-instance Sym_Integral Repr_Text where
- quot = repr_text_infix "`quot`" (Precedence 7)
- div = repr_text_infix "`div`" (Precedence 7)
- rem = repr_text_infix "`rem`" (Precedence 7)
- mod = repr_text_infix "`mod`" (Precedence 7)
- quotRem = repr_text_app2 "quotRem"
- divMod = repr_text_app2 "divMod"
- toInteger = repr_text_app1 "toInteger"
-instance (Sym_Integral r1, Sym_Integral r2) => Sym_Integral (Repr_Dup r1 r2) where
- quot = repr_dup2 sym_Integral quot
- rem = repr_dup2 sym_Integral rem
- div = repr_dup2 sym_Integral div
- mod = repr_dup2 sym_Integral mod
- quotRem = repr_dup2 sym_Integral quotRem
- divMod = repr_dup2 sym_Integral divMod
- toInteger = repr_dup1 sym_Integral toInteger
-
-sym_Integral :: Proxy Sym_Integral
-sym_Integral = Proxy
-
--- * Type 'Expr_Integral'
--- | Expression.
-data Expr_Integral (root:: *)
-type instance Root_of_Expr (Expr_Integral root) = root
-type instance Type_of_Expr (Expr_Integral root) = No_Type
-type instance Sym_of_Expr (Expr_Integral root) repr = Sym_Integral repr
-type instance Error_of_Expr ast (Expr_Integral root) = No_Error_Expr
-
--- | Parse 'quotRem'.
-quotRem_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Integral root)
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Tuple2 (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- , Type0_Constraint Integral ty
- ) => ast -> ast
- -> ExprFrom ast (Expr_Integral root) hs ret
-quotRem_from ast_x ast_y ex ast ctx k =
- -- quotRem :: a -> a -> (a, a)
- expr_from (Proxy::Proxy root) ast_x ctx $
- \(ty_x::ty h_x) (Forall_Repr_with_Context x) ->
- expr_from (Proxy::Proxy root) ast_y ctx $
- \(ty_y::ty h_y) (Forall_Repr_with_Context y) ->
- check_type0_eq ex ast ty_x ty_y $ \Refl ->
- check_type0_constraint ex (Proxy::Proxy Integral) ast ty_x $ \Dict ->
- k (type_tuple2 ty_x ty_x) $ Forall_Repr_with_Context $
- \c -> quotRem (x c) (y c)
-
--- | Parse 'quotRem', partially applied.
-quotRem_from1
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Integral root)
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Lift Type_Tuple2 (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- , Type0_Constraint Integral ty
- ) => ast
- -> ExprFrom ast (Expr_Integral root) hs ret
-quotRem_from1 ast_x ex ast ctx k =
- -- quotRem :: a -> a -> (a, a)
- expr_from (Proxy::Proxy root) ast_x ctx $
- \(ty_x::ty h_x) (Forall_Repr_with_Context x) ->
- check_type0_constraint ex (Proxy::Proxy Integral) ast ty_x $ \Dict ->
- k (type_fun ty_x $ type_tuple2 ty_x ty_x) $ Forall_Repr_with_Context $
- \c -> lam $ quotRem (x c)
-
--- | Parse 'divMod'.
-divMod_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Integral root)
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Tuple2 (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- , Type0_Constraint Integral ty
- ) => ast -> ast
- -> ExprFrom ast (Expr_Integral root) hs ret
-divMod_from ast_x ast_y ex ast ctx k =
- -- divMod :: a -> a -> (a, a)
- expr_from (Proxy::Proxy root) ast_x ctx $
- \(ty_x::ty h_x) (Forall_Repr_with_Context x) ->
- expr_from (Proxy::Proxy root) ast_y ctx $
- \(ty_y::ty h_y) (Forall_Repr_with_Context y) ->
- check_type0_eq ex ast ty_x ty_y $ \Refl ->
- check_type0_constraint ex (Proxy::Proxy Integral) ast ty_x $ \Dict ->
- k (type_tuple2 ty_x ty_x) $ Forall_Repr_with_Context $
- \c -> divMod (x c) (y c)
-
--- | Parse 'divMod', partially applied.
-divMod_from1
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Integral root)
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Lift Type_Tuple2 (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- , Type0_Constraint Integral ty
- ) => ast
- -> ExprFrom ast (Expr_Integral root) hs ret
-divMod_from1 ast_x ex ast ctx k =
- -- divMod :: a -> a -> (a, a)
- expr_from (Proxy::Proxy root) ast_x ctx $
- \(ty_x::ty h_x) (Forall_Repr_with_Context x) ->
- check_type0_constraint ex (Proxy::Proxy Integral) ast ty_x $ \Dict ->
- k (type_fun ty_x $ type_tuple2 ty_x ty_x) $ Forall_Repr_with_Context $
- \c -> lam $ divMod (x c)
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
--- | Expression for /lambda abstraction/s
--- in /Higher-Order Abstract Syntax/ (HOAS).
-module Language.Symantic.Expr.Lambda
- ( module Language.Symantic.Expr.Lambda
- , Sym_Lambda_Lam(..)
- ) where
-
-import qualified Control.Applicative as Applicative
-import qualified Data.Function as Fun
-import Data.Monoid
-import Data.Proxy (Proxy(..))
-import Data.Text (Text)
-import qualified Data.Text as Text
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding (const, id)
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_Lambda'
--- | Symantic.
-class Sym_Lambda_Lam repr => Sym_Lambda repr where
- -- | /Lambda application/.
- ($$) :: repr ((->) arg res) -> repr arg -> repr res
- default ($$) :: Trans t repr
- => t repr ((->) arg res) -> t repr arg -> t repr res
- ($$) f x = trans_lift (trans_apply f $$ trans_apply x)
-
- -- | Convenient 'lam' and '$$' wrapper.
- let_ :: repr var -> (repr var -> repr res) -> repr res
- let_ x y = lam y $$ x
-
- id :: repr a -> repr a
- id a = (lam Fun.id) $$ a
-
- const :: repr a -> repr b -> repr a
- const a b = lam (lam . Fun.const) $$ a $$ b
-
- -- | /Lambda composition/.
- (#) :: repr (b -> c) -> repr (a -> b) -> repr (a -> c)
- (#) f g = lam $ \a -> f $$ (g $$ a)
-
- flip :: repr (a -> b -> c) -> repr (b -> a -> c)
- flip f = lam $ \b -> lam $ \a -> f $$ a $$ b
-
-infixl 0 $$
-infixr 9 #
-
-instance Sym_Lambda Repr_Host where
- ($$) = (Applicative.<*>)
-instance Sym_Lambda Repr_Text where
- -- ($$) = repr_text_infix "$" (Precedence 0)
- ($$) (Repr_Text a1) (Repr_Text a2) =
- Repr_Text $ \p v ->
- let p' = precedence_App in
- paren p p' $ a1 p' v <> " " <> a2 p' v
- let_ e in_ =
- Repr_Text $ \p v ->
- let p' = Precedence 2 in
- let x = "x" <> Text.pack (show v) in
- paren p p' $ "let" <> " " <> x <> " = "
- <> unRepr_Text e (Precedence 0) (succ v) <> " in "
- <> unRepr_Text (in_ (Repr_Text $ \_p _v -> x)) p' (succ v)
- (#) = repr_text_infix "." (Precedence 9)
- id = repr_text_app1 "id"
- const = repr_text_app2 "const"
- flip = repr_text_app1 "flip"
-instance (Sym_Lambda r1, Sym_Lambda r2) => Sym_Lambda (Repr_Dup r1 r2) where
- ($$) = repr_dup2 sym_Lambda ($$)
-
-sym_Lambda :: Proxy Sym_Lambda
-sym_Lambda = Proxy
-
--- * Type 'Expr_Lambda'
--- | Expression.
-data Expr_Lambda (root:: *)
-type instance Root_of_Expr (Expr_Lambda root) = root
-type instance Type_of_Expr (Expr_Lambda root) = Type_Fun
-type instance Sym_of_Expr (Expr_Lambda root) repr = Sym_Lambda repr
-type instance Error_of_Expr ast (Expr_Lambda root) = Error_Expr_Lambda ast
-
--- | Parsing utility to check that the given type is a 'Type_Fun'
--- or raise 'Error_Expr_Type_mismatch'.
-check_type_fun
- :: forall ast ex root ty h ret.
- ( root ~ Root_of_Expr ex
- , ty ~ Type_Root_of_Expr ex
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- )
- => Proxy ex -> ast -> ty h
- -> (Type_Fun ty h -> Either (Error_of_Expr ast root) ret)
- -> Either (Error_of_Expr ast root) ret
-check_type_fun ex ast ty k =
- case type0_unlift $ unType_Root ty of
- Just ty_f -> k ty_f
- Nothing -> Left $ error_expr ex $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 (type_var0 SZero `type_fun` type_var0 (SSucc SZero)
- :: ty ((->) Var0 Var0)))
- (Exists_Type0 ty)
-
--- | Parse a /lambda variable/.
-var_from
- :: forall ast root hs ret.
- ( Type0_From ast (Type_Root_of_Expr root)
- , Error_Expr_Lift (Error_Expr_Lambda ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => Text -> ExprFrom ast (Expr_Lambda root) hs ret
-var_from name _ex ast = go
- where
- go :: forall ex hs'. (ex ~ (Expr_Lambda root))
- => Lambda_Context (Lambda_Var (Type_Root_of_Expr ex)) hs'
- -> ( forall h. Type_Root_of_Expr ex h
- -> Forall_Repr_with_Context ex hs' h
- -> Either (Error_of_Expr ast (Root_of_Expr ex)) ret )
- -> Either (Error_of_Expr ast (Root_of_Expr ex)) ret
- go c k' =
- case c of
- Lambda_Context_Empty -> Left $ error_expr_lift $
- Error_Expr_Lambda_Var_unbound name ast
- Lambda_Var n ty `Lambda_Context_Next` _ | n == name ->
- k' ty $ Forall_Repr_with_Context $
- \(repr `Lambda_Context_Next` _) -> repr
- _ `Lambda_Context_Next` ctx' ->
- go ctx' $ \ty (Forall_Repr_with_Context repr) ->
- k' ty $ Forall_Repr_with_Context $
- \(_ `Lambda_Context_Next` c') -> repr c'
-
--- | Parse '$$'.
-app_from
- :: forall ty ast root hs ret.
- ( ty ~ Type_Root_of_Expr root
- , Type0_From ast ty
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Root_of_Expr root ~ root
- ) => ast -> ast
- -> ExprFrom ast (Expr_Lambda root) hs ret
-app_from ast_lam ast_arg_actual ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_lam ctx $
- \(ty_lam::ty h_lam) (Forall_Repr_with_Context l) ->
- expr_from (Proxy::Proxy root) ast_arg_actual ctx $
- \ty_arg_actual (Forall_Repr_with_Context arg_actual) ->
- case type0_unlift $ unType_Root ty_lam of
- Nothing -> Left $ error_expr ex $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 (type_var0 SZero `type_fun` type_var0 (SSucc SZero)
- :: ty ((->) Var0 Var0)))
- (Exists_Type0 ty_lam)
- Just (Type2 Proxy ty_arg_expected ty_res
- :: Type_Fun ty h_lam) ->
- check_type0_eq ex ast ty_arg_expected ty_arg_actual $ \Refl ->
- k ty_res $ Forall_Repr_with_Context $
- \c -> l c $$ arg_actual c
-
--- | Parse 'lam'.
-lam_from
- :: forall ty ast root hs ret.
- ( ty ~ Type_Root_of_Expr root
- , root ~ Root_of_Expr root
- , Type0_From ast ty
- , Expr_From ast root
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- ) => Text -> ast -> ast
- -> ExprFrom ast (Expr_Lambda root) hs ret
-lam_from name ast_ty_arg ast_body ex ast ctx k =
- either (\err -> Left $ error_expr ex $ Error_Expr_Type err ast) Fun.id $
- type0_from (Proxy::Proxy ty) ast_ty_arg $ \ty_arg -> Right $
- expr_from (Proxy::Proxy root) ast_body
- (Lambda_Var name ty_arg `Lambda_Context_Next` ctx) $
- \ty_res (Forall_Repr_with_Context res) ->
- k (ty_arg `type_fun` ty_res) $ Forall_Repr_with_Context $
- \c -> lam $ \arg -> res (arg `Lambda_Context_Next` c)
-
--- | Parse 'let_'.
-let_from
- :: forall ty ast root hs ret.
- ( ty ~ Type_Root_of_Expr root
- , root ~ Root_of_Expr root
- , Type0_From ast ty
- , Expr_From ast root
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- ) => Text -> ast -> ast
- -> ExprFrom ast (Expr_Lambda root) hs ret
-let_from name ast_var ast_body _ex _ast ctx k =
- expr_from (Proxy::Proxy root) ast_var ctx $
- \ty_var (Forall_Repr_with_Context var) ->
- expr_from (Proxy::Proxy root) ast_body
- (Lambda_Var name ty_var `Lambda_Context_Next` ctx) $
- \ty_res (Forall_Repr_with_Context res) ->
- k ty_res $ Forall_Repr_with_Context $
- \c -> let_ (var c) $ \arg -> res (arg `Lambda_Context_Next` c)
-
--- * Type 'Error_Expr_Lambda'
-data Error_Expr_Lambda ast
- = Error_Expr_Lambda_Var_unbound Lambda_Var_Name ast
- deriving (Eq, Show)
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-
-module Expr.Lambda.Test where
-
-import Test.Tasty
-
-import Prelude hiding ((&&), not, (||), (==), id)
-
-import Language.Symantic.Expr.Lambda
-import Language.Symantic.Expr.Bool
-
--- * Expressions
-e1 = lam $ \x -> lam $ \y -> (x || y) && not (x && y)
-e2 = lam $ \x -> lam $ \y -> (x && not y) || (not x && y)
-e3 = let_ (bool True) $ \x -> x && x
-e4 = let_ (lam $ \x -> x && x) $ \f -> f $$ bool True
-e5 = lam $ \x0 -> lam $ \x1 -> x0 && x1
-e6 = let_ (bool True) id && bool False
-e7 = lam $ \f -> (f $$ bool True) && bool True
-e8 = lam $ \f -> f $$ (bool True && bool True)
-
-tests :: TestTree
-tests =
- testGroup "Lambda"
- [
- ]
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
--- | Expression for 'List'.
-module Language.Symantic.Expr.List where
-
-import Control.Monad
-import qualified Data.Function as Fun
-import qualified Data.List as List
-import Data.Monoid
-import Data.Proxy (Proxy(..))
-import qualified Data.Text as Text
-import Data.Type.Equality ((:~:)(Refl))
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Expr.Lambda
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_List_Lam'
--- | Symantic.
-class Sym_List repr where
- list_empty :: repr [a]
- list_cons :: repr a -> repr [a] -> repr [a]
- list :: [repr a] -> repr [a]
- list_filter :: repr (a -> Bool) -> repr [a] -> repr [a]
- list_zipWith :: repr (a -> b -> c) -> repr [a] -> repr [b] -> repr [c]
- list_reverse :: repr [a] -> repr [a]
-
- default list_empty :: Trans t repr => t repr [a]
- default list_cons :: Trans t repr => t repr a -> t repr [a] -> t repr [a]
- default list :: Trans t repr => [t repr a] -> t repr [a]
- default list_filter :: Trans t repr => t repr (a -> Bool) -> t repr [a] -> t repr [a]
- default list_zipWith :: Trans t repr => t repr (a -> b -> c) -> t repr [a] -> t repr [b] -> t repr [c]
- default list_reverse :: Trans t repr => t repr [a] -> t repr [a]
-
- list_empty = trans_lift list_empty
- list_cons = trans_map2 list_cons
- list l = trans_lift (list (trans_apply Prelude.<$> l))
- list_filter = trans_map2 list_filter
- list_zipWith = trans_map3 list_zipWith
- list_reverse = trans_map1 list_reverse
-instance Sym_List Repr_Host where
- list_empty = return []
- list_cons = liftM2 (:)
- list = sequence
- list_filter = liftM2 List.filter
- list_zipWith = liftM3 List.zipWith
- list_reverse = liftM List.reverse
-instance Sym_List Repr_Text where
- list_empty = Repr_Text $ \_p _v -> "[]"
- list_cons (Repr_Text x) (Repr_Text xs) =
- Repr_Text $ \p v ->
- let p' = Precedence 5 in
- paren p p' $ x p' v <> ":" <> xs p' v
- list l = Repr_Text $ \_p v ->
- let p' = precedence_Toplevel in
- "[" <> Text.intercalate ", " ((\(Repr_Text a) -> a p' v) Prelude.<$> l) <> "]"
- list_filter = repr_text_app2 "list_filter"
- list_zipWith = repr_text_app3 "list_zipWith"
- list_reverse = repr_text_app1 "list_reverse"
-instance (Sym_List r1, Sym_List r2) => Sym_List (Repr_Dup r1 r2) where
- list_empty = repr_dup0 sym_List list_empty
- list_cons = repr_dup2 sym_List list_cons
- list l =
- let (l1, l2) =
- foldr (\(x1 `Repr_Dup` x2) (xs1, xs2) ->
- (x1:xs1, x2:xs2)) ([], []) l in
- list l1 `Repr_Dup` list l2
- list_filter = repr_dup2 sym_List list_filter
- list_zipWith = repr_dup3 sym_List list_zipWith
- list_reverse = repr_dup1 sym_List list_reverse
-
-sym_List :: Proxy Sym_List
-sym_List = Proxy
-
--- * Type 'Expr_List'
--- | Expression.
-data Expr_List (root:: *)
-type instance Root_of_Expr (Expr_List root) = root
-type instance Type_of_Expr (Expr_List root) = Type_List
-type instance Sym_of_Expr (Expr_List root) repr = Sym_List repr
-type instance Error_of_Expr ast (Expr_List root) = No_Error_Expr
-
--- | Parsing utility to check that the given type is a 'Type_List'
--- or raise 'Error_Expr_Type_mismatch'.
-check_type_list
- :: forall ast ex root ty h ret.
- ( root ~ Root_of_Expr ex
- , ty ~ Type_Root_of_Expr ex
- , Type0_Lift Type_List (Type_of_Expr root)
- , Type0_Unlift Type_List (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- )
- => Proxy ex -> ast -> ty h
- -> (Type_List ty h -> Either (Error_of_Expr ast root) ret)
- -> Either (Error_of_Expr ast root) ret
-check_type_list ex ast ty k =
- case type0_unlift $ unType_Root ty of
- Just ty_l -> k ty_l
- Nothing -> Left $ error_expr ex $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 (type_list $ type_var0 SZero :: ty [Var0]))
- (Exists_Type0 ty)
-
--- | Parse 'list_empty'.
-list_empty_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_List root)
- , Type0_From ast ty
- , Type0_Lift Type_List (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast
- -> ExprFrom ast (Expr_List root) hs ret
-list_empty_from ast_ty_a ex ast _ctx k =
- either (\err -> Left $ error_expr ex $ Error_Expr_Type err ast) Fun.id $
- type0_from (Proxy::Proxy ty) ast_ty_a $ \ty_a -> Right $
- k (type_list ty_a) $ Forall_Repr_with_Context $
- Fun.const list_empty
-
--- | Parse 'list_cons'.
-list_cons_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_List root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Lift Type_List (Type_of_Expr root)
- , Type0_Unlift Type_List (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast -> ast
- -> ExprFrom ast (Expr_List root) hs ret
-list_cons_from ast_a ast_l ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_a ctx $
- \(ty_a::ty h_a) (Forall_Repr_with_Context a) ->
- expr_from (Proxy::Proxy root) ast_l ctx $
- \(ty_l::ty h_l) (Forall_Repr_with_Context l) ->
- check_type_list ex ast ty_l $ \(Type1 _ ty_l_a) ->
- check_type0_eq ex ast ty_a ty_l_a $ \Refl ->
- k (type_list ty_a) $ Forall_Repr_with_Context $
- \c -> list_cons (a c) (l c)
-
--- | Parse 'list'.
-list_from
- :: forall root ex ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_List root)
- , ex ~ Expr_List root
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_From ast ty
- , Type0_Lift Type_List (Type_of_Expr root)
- , Type0_Unlift Type_List (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast -> [ast]
- -> ExprFrom ast ex hs ret
-list_from ast_ty_a ast_as =
- case type0_from (Proxy::Proxy ty)
- ast_ty_a (Right . Exists_Type0) of
- Left err -> \ex ast _ctx _k -> Left $ error_expr ex $ Error_Expr_Type err ast
- Right (Exists_Type0 ty_a) -> go ty_a [] ast_as
- where
- go :: ty ty_a
- -> [Forall_Repr_with_Context root hs ty_a]
- -> [ast]
- -> ExprFrom ast (Expr_List root) hs ret
- go ty_a as [] _ex _ast _ctx k =
- k (type_list ty_a) $ Forall_Repr_with_Context $
- \c -> list ((\(Forall_Repr_with_Context a) -> a c) Prelude.<$> reverse as)
- go ty_a as (ast_x:ast_xs) ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_x ctx $
- \(ty_x::ty h_x) x ->
- check_type0_eq ex ast ty_a ty_x $ \Refl ->
- go ty_a (x:as) ast_xs ex ast ctx k
-
--- | Parse 'list_filter'.
-list_filter_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_List root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type0_Lift Type_List (Type_of_Expr root)
- , Type0_Unlift Type_List (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast -> ast
- -> ExprFrom ast (Expr_List root) hs ret
-list_filter_from ast_f ast_l ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_f ctx $
- \(ty_f::ty h_f) (Forall_Repr_with_Context f) ->
- expr_from (Proxy::Proxy root) ast_l ctx $
- \(ty_l::ty h_l) (Forall_Repr_with_Context l) ->
- check_type_fun ex ast ty_f $ \(Type2 Proxy ty_f_a ty_f_b) ->
- check_type0_eq ex ast type_bool ty_f_b $ \Refl ->
- check_type_list ex ast ty_l $ \(Type1 _ ty_l_a) ->
- check_type0_eq ex ast ty_f_a ty_l_a $ \Refl ->
- k ty_l $ Forall_Repr_with_Context $
- \c -> list_filter (f c) (l c)
-
--- | Parse 'list_zipWith'.
-list_zipWith_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_List root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type0_Lift Type_List (Type_of_Expr root)
- , Type0_Unlift Type_List (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast -> ast -> ast
- -> ExprFrom ast (Expr_List root) hs ret
-list_zipWith_from ast_f ast_la ast_lb ex ast ctx k =
- -- zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
- expr_from (Proxy::Proxy root) ast_f ctx $
- \(ty_f::ty h_f) (Forall_Repr_with_Context f) ->
- expr_from (Proxy::Proxy root) ast_la ctx $
- \(ty_la::ty h_la) (Forall_Repr_with_Context la) ->
- expr_from (Proxy::Proxy root) ast_lb ctx $
- \(ty_lb::ty h_lb) (Forall_Repr_with_Context lb) ->
- check_type_fun ex ast ty_f $ \(Type2 Proxy ty_f_a ty_f_b2c) ->
- check_type_fun ex ast ty_f_b2c $ \(Type2 Proxy ty_f_b ty_f_c) ->
- check_type_list ex ast ty_la $ \(Type1 _ ty_l_a) ->
- check_type_list ex ast ty_lb $ \(Type1 _ ty_l_b) ->
- check_type0_eq ex ast ty_f_a ty_l_a $ \Refl ->
- check_type0_eq ex ast ty_f_b ty_l_b $ \Refl ->
- check_type0_eq ex ast ty_f_a ty_l_a $ \Refl ->
- k (type_list ty_f_c) $ Forall_Repr_with_Context $
- \c -> list_zipWith (f c) (la c) (lb c)
-
--- | Parse 'list_reverse'.
-list_reverse_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_List root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Lift Type_List (Type_of_Expr root)
- , Type0_Unlift Type_List (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast
- -> ExprFrom ast (Expr_List root) hs ret
-list_reverse_from ast_l ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_l ctx $
- \(ty_l::ty h_l) (Forall_Repr_with_Context l) ->
- check_type_list ex ast ty_l $ \(Type1 _ _ty_l_a) ->
- k ty_l $ Forall_Repr_with_Context $
- \c -> list_reverse (l c)
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-module Expr.List.Test where
-
-import Test.Tasty
-import Test.Tasty.HUnit
-
-import qualified Control.Arrow as Arrow
-import qualified Control.Monad as Monad
-import Data.Proxy (Proxy(..))
-import Data.Text (Text)
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding (mod, (==), return)
-
-import Language.Symantic.Repr
-import Language.Symantic.Expr
-import Language.Symantic.Type
-
-import AST.Test
-
--- * Expressions
-t = bool True
-f = bool False
-e1 = list_filter (lam $ \x -> if_ (x `mod` int 2 == int 0) t f)
- (list $ int Prelude.<$> [1..5])
-
--- * Tests
-type Ex = Expr_Root
- ( Expr_Lambda
- .|. Expr_List
- .|. Expr_Int
- .|. Expr_Bool
- )
-ex_from = root_expr_from (Proxy::Proxy Ex)
-
-(==>) ast expected =
- testCase (show ast) $
- case ex_from ast of
- Left err -> Left err @?= Prelude.snd `Arrow.left` expected
- Right (Exists_Type0_and_Repr ty (Forall_Repr r)) ->
- case expected of
- Left (_, err) -> Right ("…"::String) @?= Left err
- Right (ty_expected::Type_Root_of_Expr Ex h, _::h, _::Text) ->
- (Monad.>>= (@?= (\(_::Proxy h, err) -> err) `Arrow.left` expected)) $
- case ty `type0_eq` ty_expected of
- Nothing -> Monad.return $ Left $
- error_expr (Proxy::Proxy Ex) $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 ty)
- (Exists_Type0 ty_expected)
- Just Refl -> do
- let h = host_from_expr r
- Monad.return $
- Right
- ( ty
- , h
- , text_from_expr r
- -- , (text_from_expr :: Repr_Text h -> Text) r
- )
-
-tests :: TestTree
-tests = testGroup "List"
- [ AST "list_reverse"
- [ AST "list"
- [ AST "Int" []
- , AST "int" [AST "1" []]
- , AST "int" [AST "2" []]
- , AST "int" [AST "3" []]
- ]
- ] ==> Right
- ( type_list type_int
- , [3,2,1]
- , "list_reverse [1, 2, 3]" )
- ]
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
--- | Expression for 'Map'.
-module Language.Symantic.Expr.Map where
-
-import Control.Monad
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import Data.Proxy (Proxy(..))
-import Data.Type.Equality ((:~:)(Refl))
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Expr.Lambda
-import Language.Symantic.Expr.List
-import Language.Symantic.Expr.Tuple
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_Map_Lam'
--- | Symantic.
-class Sym_Map repr where
- map_from_list :: Ord k => repr [(k, a)] -> repr (Map k a)
- mapWithKey :: repr (k -> a -> b) -> repr (Map k a) -> repr (Map k b)
- map_lookup :: Ord k => repr k -> repr (Map k a) -> repr (Maybe a)
- map_keys :: repr (Map k a) -> repr [k]
- map_member :: Ord k => repr k -> repr (Map k a) -> repr Bool
- map_insert :: Ord k => repr k -> repr a -> repr (Map k a) -> repr (Map k a)
- map_delete :: Ord k => repr k -> repr (Map k a) -> repr (Map k a)
- map_difference :: Ord k => repr (Map k a) -> repr (Map k b) -> repr (Map k a)
- map_foldrWithKey :: repr (k -> a -> b -> b) -> repr b -> repr (Map k a) -> repr b
-
- default map_from_list :: (Trans t repr, Ord k) => t repr [(k, a)] -> t repr (Map k a)
- default mapWithKey :: Trans t repr => t repr (k -> a -> b) -> t repr (Map k a) -> t repr (Map k b)
- default map_lookup :: (Trans t repr, Ord k) => t repr k -> t repr (Map k a) -> t repr (Maybe a)
- default map_keys :: (Trans t repr, Ord k) => t repr (Map k a) -> t repr [k]
- default map_member :: (Trans t repr, Ord k) => t repr k -> t repr (Map k a) -> t repr Bool
- default map_insert :: (Trans t repr, Ord k) => t repr k -> t repr a -> t repr (Map k a) -> t repr (Map k a)
- default map_delete :: (Trans t repr, Ord k) => t repr k -> t repr (Map k a) -> t repr (Map k a)
- default map_difference :: (Trans t repr, Ord k) => t repr (Map k a) -> t repr (Map k b) -> t repr (Map k a)
- default map_foldrWithKey :: Trans t repr => t repr (k -> a -> b -> b) -> t repr b -> t repr (Map k a) -> t repr b
-
- map_from_list = trans_map1 map_from_list
- mapWithKey = trans_map2 mapWithKey
- map_lookup = trans_map2 map_lookup
- map_keys = trans_map1 map_keys
- map_member = trans_map2 map_member
- map_insert = trans_map3 map_insert
- map_delete = trans_map2 map_delete
- map_difference = trans_map2 map_difference
- map_foldrWithKey = trans_map3 map_foldrWithKey
-instance Sym_Map Repr_Host where
- map_from_list = liftM Map.fromList
- mapWithKey = liftM2 Map.mapWithKey
- map_lookup = liftM2 Map.lookup
- map_keys = liftM Map.keys
- map_member = liftM2 Map.member
- map_insert = liftM3 Map.insert
- map_delete = liftM2 Map.delete
- map_difference = liftM2 Map.difference
- map_foldrWithKey = liftM3 Map.foldrWithKey
-instance Sym_Map Repr_Text where
- map_from_list = repr_text_app1 "map_from_list"
- mapWithKey = repr_text_app2 "mapWithKey"
- map_lookup = repr_text_app2 "map_lookup"
- map_keys = repr_text_app1 "map_keys"
- map_member = repr_text_app2 "map_member"
- map_insert = repr_text_app3 "map_insert"
- map_delete = repr_text_app2 "map_delete"
- map_difference = repr_text_app2 "map_difference"
- map_foldrWithKey = repr_text_app3 "map_foldrWithKey"
-instance (Sym_Map r1, Sym_Map r2) => Sym_Map (Repr_Dup r1 r2) where
- map_from_list = repr_dup1 sym_Map map_from_list
- mapWithKey = repr_dup2 sym_Map mapWithKey
- map_lookup = repr_dup2 sym_Map map_lookup
- map_keys = repr_dup1 sym_Map map_keys
- map_member = repr_dup2 sym_Map map_member
- map_insert = repr_dup3 sym_Map map_insert
- map_delete = repr_dup2 sym_Map map_delete
- map_difference = repr_dup2 sym_Map map_difference
- map_foldrWithKey = repr_dup3 sym_Map map_foldrWithKey
-
-sym_Map :: Proxy Sym_Map
-sym_Map = Proxy
-
--- | Parsing utility to check that the given type is a 'Type_List'
--- or raise 'Error_Expr_Type_mismatch'.
-check_type_map
- :: forall ast ex root ty h ret.
- ( root ~ Root_of_Expr ex
- , ty ~ Type_Root_of_Expr ex
- , Type0_Lift Type_Map (Type_of_Expr root)
- , Type0_Unlift Type_Map (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- )
- => Proxy ex -> ast -> ty h
- -> (Type_Map ty h -> Either (Error_of_Expr ast root) ret)
- -> Either (Error_of_Expr ast root) ret
-check_type_map ex ast ty k =
- case type0_unlift $ unType_Root ty of
- Just ty_l -> k ty_l
- Nothing -> Left $
- error_expr ex $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 (type_map (type_var0 SZero) (type_var0 $ SSucc SZero)
- :: ty (Map Var0 Var0)))
- (Exists_Type0 ty)
-
--- | Parse 'map_from_list'.
-map_from_list_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Map root)
- , Expr_From ast root
- , Type0_Lift Type_List (Type_of_Expr root)
- , Type0_Unlift Type_List (Type_of_Expr root)
- , Type0_Lift Type_Map (Type_of_Expr root)
- , Type0_Lift Type_Tuple2 (Type_of_Expr root)
- , Type0_Unlift Type_Tuple2 (Type_of_Expr root)
- , Type0_Constraint Ord ty
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast
- -> ExprFrom ast (Expr_Map root) hs ret
-map_from_list_from ast_l ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_l ctx $
- \(ty_l::ty h_l) (Forall_Repr_with_Context l) ->
- check_type_list ex ast ty_l $ \(Type1 _ ty_l_t) ->
- check_type_tuple2 ex ast ty_l_t $ \(Type2 Proxy ty_k ty_a) ->
- check_type0_constraint ex (Proxy::Proxy Ord) ast ty_k $ \Dict ->
- k (type_map ty_k ty_a) $ Forall_Repr_with_Context $
- \c -> map_from_list (l c)
-
--- | Parse 'mapWithKey'.
-mapWithKey_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Map root)
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type0_Lift Type_Map (Type_of_Expr root)
- , Type0_Unlift Type_Map (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast -> ast
- -> ExprFrom ast (Expr_Map root) hs ret
-mapWithKey_from ast_f ast_m ex ast ctx k =
- -- mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
- expr_from (Proxy::Proxy root) ast_f ctx $
- \(ty_f::ty h_f) (Forall_Repr_with_Context f) ->
- expr_from (Proxy::Proxy root) ast_m ctx $
- \(ty_m::ty h_m) (Forall_Repr_with_Context m) ->
- check_type_fun ex ast ty_f $ \(Type2 Proxy ty_f_k ty_f_a2b
- :: Type_Fun ty h_f) ->
- check_type_fun ex ast ty_f_a2b $ \(Type2 Proxy ty_f_a ty_f_b
- :: Type_Fun ty h_f_a2b) ->
- check_type_map ex ast ty_m $ \(Type2 Proxy ty_m_k ty_m_a) ->
- check_type0_eq ex ast ty_f_k ty_m_k $ \Refl ->
- check_type0_eq ex ast ty_f_a ty_m_a $ \Refl ->
- k (type_map ty_m_k ty_f_b) $ Forall_Repr_with_Context $
- \c -> mapWithKey (f c) (m c)
-
--- | Parse 'map_lookup'.
-map_lookup_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Map root)
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Map (Type_of_Expr root)
- , Type0_Unlift Type_Map (Type_of_Expr root)
- , Type0_Lift Type_Maybe (Type_of_Expr root)
- , Type0_Constraint Ord ty
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast -> ast
- -> ExprFrom ast (Expr_Map root) hs ret
-map_lookup_from ast_k ast_m ex ast ctx k =
- -- lookup :: Ord k => k -> Map k a -> Maybe a
- expr_from (Proxy::Proxy root) ast_k ctx $
- \(ty_k::ty h_k) (Forall_Repr_with_Context key) ->
- expr_from (Proxy::Proxy root) ast_m ctx $
- \(ty_m::ty h_m) (Forall_Repr_with_Context m) ->
- check_type_map ex ast ty_m $ \(Type2 Proxy ty_m_k ty_m_a) ->
- check_type0_eq ex ast ty_k ty_m_k $ \Refl ->
- check_type0_constraint ex (Proxy::Proxy Ord) ast ty_k $ \Dict ->
- k (type_maybe ty_m_a) $ Forall_Repr_with_Context $
- \c -> map_lookup (key c) (m c)
-
--- | Parse 'map_keys'.
-map_keys_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Map root)
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Map (Type_of_Expr root)
- , Type0_Unlift Type_Map (Type_of_Expr root)
- , Type0_Lift Type_List (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast
- -> ExprFrom ast (Expr_Map root) hs ret
-map_keys_from ast_m ex ast ctx k =
- -- keys :: Map k a -> [k]
- expr_from (Proxy::Proxy root) ast_m ctx $
- \(ty_m::ty h_m) (Forall_Repr_with_Context m) ->
- check_type_map ex ast ty_m $ \(Type2 Proxy ty_m_k _ty_m_a) ->
- k (type_list ty_m_k) $ Forall_Repr_with_Context $
- \c -> map_keys (m c)
-
--- | Parse 'map_member'.
-map_member_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Map root)
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Constraint Ord ty
- , Type0_Lift Type_Map (Type_of_Expr root)
- , Type0_Unlift Type_Map (Type_of_Expr root)
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast -> ast
- -> ExprFrom ast (Expr_Map root) hs ret
-map_member_from ast_k ast_m ex ast ctx k =
- -- member :: Ord k => k -> Map k a -> Bool
- expr_from (Proxy::Proxy root) ast_k ctx $
- \(ty_k::ty h_k) (Forall_Repr_with_Context key) ->
- expr_from (Proxy::Proxy root) ast_m ctx $
- \(ty_m::ty h_m) (Forall_Repr_with_Context m) ->
- check_type_map ex ast ty_m $ \(Type2 Proxy ty_m_k _ty_m_a) ->
- check_type0_eq ex ast ty_k ty_m_k $ \Refl ->
- check_type0_constraint ex (Proxy::Proxy Ord) ast ty_k $ \Dict ->
- k type_bool $ Forall_Repr_with_Context $
- \c -> map_member (key c) (m c)
-
--- | Parse 'map_insert'.
-map_insert_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Map root)
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Constraint Ord ty
- , Type0_Lift Type_Map (Type_of_Expr root)
- , Type0_Unlift Type_Map (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast -> ast -> ast
- -> ExprFrom ast (Expr_Map root) hs ret
-map_insert_from ast_k ast_a ast_m ex ast ctx k =
- -- insert :: Ord k => k -> a -> Map k a -> Map k a
- expr_from (Proxy::Proxy root) ast_k ctx $
- \(ty_k::ty h_k) (Forall_Repr_with_Context key) ->
- expr_from (Proxy::Proxy root) ast_a ctx $
- \(ty_a::ty h_a) (Forall_Repr_with_Context a) ->
- expr_from (Proxy::Proxy root) ast_m ctx $
- \(ty_m::ty h_m) (Forall_Repr_with_Context m) ->
- check_type_map ex ast ty_m $ \(Type2 Proxy ty_m_k ty_m_a) ->
- check_type0_eq ex ast ty_k ty_m_k $ \Refl ->
- check_type0_eq ex ast ty_a ty_m_a $ \Refl ->
- check_type0_constraint ex (Proxy::Proxy Ord) ast ty_k $ \Dict ->
- k ty_m $ Forall_Repr_with_Context $
- \c -> map_insert (key c) (a c) (m c)
-
--- | Parse 'map_delete'.
-map_delete_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Map root)
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Map (Type_of_Expr root)
- , Type0_Unlift Type_Map (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Type0_Constraint Ord ty
- , Root_of_Expr root ~ root
- ) => ast -> ast
- -> ExprFrom ast (Expr_Map root) hs ret
-map_delete_from ast_k ast_m ex ast ctx k =
- -- delete :: Ord k => k -> Map k a -> Map k a
- expr_from (Proxy::Proxy root) ast_k ctx $
- \(ty_k::ty h_k) (Forall_Repr_with_Context key) ->
- expr_from (Proxy::Proxy root) ast_m ctx $
- \(ty_m::ty h_m) (Forall_Repr_with_Context m) ->
- check_type_map ex ast ty_m $ \(Type2 Proxy ty_m_k _ty_m_a) ->
- check_type0_eq ex ast ty_k ty_m_k $ \Refl ->
- check_type0_constraint ex (Proxy::Proxy Ord) ast ty_k $ \Dict ->
- k ty_m $ Forall_Repr_with_Context $
- \c -> map_delete (key c) (m c)
-
--- | Parse 'map_difference'.
-map_difference_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Map root)
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Map (Type_of_Expr root)
- , Type0_Unlift Type_Map (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Type0_Constraint Ord ty
- , Root_of_Expr root ~ root
- ) => ast -> ast
- -> ExprFrom ast (Expr_Map root) hs ret
-map_difference_from ast_ma ast_mb ex ast ctx k =
- -- difference :: Ord k => Map k a -> Map k b -> Map k a
- expr_from (Proxy::Proxy root) ast_ma ctx $
- \(ty_ma::ty h_ma) (Forall_Repr_with_Context ma) ->
- expr_from (Proxy::Proxy root) ast_mb ctx $
- \(ty_mb::ty h_mb) (Forall_Repr_with_Context mb) ->
- check_type_map ex ast ty_ma $ \(Type2 Proxy ty_ma_k _ty_ma_a) ->
- check_type_map ex ast ty_mb $ \(Type2 Proxy ty_mb_k _ty_mb_b) ->
- check_type0_eq ex ast ty_ma_k ty_mb_k $ \Refl ->
- check_type0_constraint ex (Proxy::Proxy Ord) ast ty_ma_k $ \Dict ->
- k ty_ma $ Forall_Repr_with_Context $
- \c -> map_difference (ma c) (mb c)
-
--- | Parse 'map_foldrWithKey'.
-map_foldrWithKey_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Map root)
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type0_Lift Type_Map (Type_of_Expr root)
- , Type0_Unlift Type_Map (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Type0_Constraint Ord ty
- , Root_of_Expr root ~ root
- ) => ast -> ast -> ast
- -> ExprFrom ast (Expr_Map root) hs ret
-map_foldrWithKey_from ast_f ast_b ast_m ex ast ctx k =
- -- foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
- expr_from (Proxy::Proxy root) ast_f ctx $
- \(ty_f::ty h_f) (Forall_Repr_with_Context f) ->
- expr_from (Proxy::Proxy root) ast_b ctx $
- \(ty_b::ty h_b) (Forall_Repr_with_Context b) ->
- expr_from (Proxy::Proxy root) ast_m ctx $
- \(ty_m::ty h_m) (Forall_Repr_with_Context m) ->
- check_type_fun ex ast ty_f $ \(Type2 Proxy ty_f_k ty_f_a2b2b) ->
- check_type_fun ex ast ty_f_a2b2b $ \(Type2 Proxy ty_f_a ty_f_b2b) ->
- check_type_fun ex ast ty_f_b2b $ \(Type2 Proxy ty_f_b ty_f_b') ->
- check_type_map ex ast ty_m $ \(Type2 Proxy ty_m_k ty_m_a) ->
- check_type0_eq ex ast ty_f_k ty_m_k $ \Refl ->
- check_type0_eq ex ast ty_f_a ty_m_a $ \Refl ->
- check_type0_eq ex ast ty_b ty_f_b $ \Refl ->
- check_type0_eq ex ast ty_f_b ty_f_b' $ \Refl ->
- check_type0_constraint ex (Proxy::Proxy Ord) ast ty_m_k $ \Dict ->
- k ty_b $ Forall_Repr_with_Context $
- \c -> map_foldrWithKey (f c) (b c) (m c)
-
--- * Type 'Expr_Map'
--- | Expression.
-data Expr_Map (root:: *)
-type instance Root_of_Expr (Expr_Map root) = root
-type instance Type_of_Expr (Expr_Map root) = Type_Map
-type instance Sym_of_Expr (Expr_Map root) repr = Sym_Map repr
-type instance Error_of_Expr ast (Expr_Map root) = No_Error_Expr
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-module Expr.Map.Test where
-
-import Test.Tasty
-import Test.Tasty.HUnit
-
-import qualified Control.Arrow as Arrow
-import qualified Control.Monad as Monad
--- import qualified Data.List as List
-import qualified Data.Map.Strict as Map
-import Data.Proxy (Proxy(..))
-import Data.Text (Text)
-import qualified Data.Text as Text
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding (maybe, not)
-
-import Language.Symantic.Repr
-import Language.Symantic.Expr
-import Language.Symantic.Type
-
-import AST.Test
-
--- * Expressions
-t = bool True
-f = bool False
-e1 = map_from_list $ list_zipWith (lam (lam . tuple2))
- (list $ int Prelude.<$> [1..5])
- (list $ (text . Text.singleton) Prelude.<$> ['a'..'e'])
-
--- * Tests
-type Ex = Expr_Root
- ( Expr_Lambda
- .|. Expr_Map
- .|. Expr_Bool
- .|. Expr_Maybe
- .|. Expr_List
- .|. Expr_Eq
- .|. Expr_Ord
- .|. Expr_Tuple2
- .|. Expr_Int
- .|. Expr_Integer
- .|. Expr_Text
- .|. Expr_Monoid
- .|. Expr_Num
- )
-ex_from = root_expr_from (Proxy::Proxy Ex)
-
-(==>) ast expected =
- testCase (show ast) $
- case ex_from ast of
- Left err -> Left err @?= Prelude.snd `Arrow.left` expected
- Right (Exists_Type0_and_Repr ty (Forall_Repr r)) ->
- case expected of
- Left (_, err) -> Right ("…"::String) @?= Left err
- Right (ty_expected::Type_Root_of_Expr Ex h, _::h, _::Text) ->
- (Monad.>>= (@?= (\(_::Proxy h, err) -> err) `Arrow.left` expected)) $
- case ty `type0_eq` ty_expected of
- Nothing -> Monad.return $ Left $
- error_expr (Proxy::Proxy Ex) $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 ty)
- (Exists_Type0 ty_expected)
- Just Refl -> do
- let h = host_from_expr r
- Monad.return $
- Right
- ( ty
- , h
- , text_from_expr r
- -- , (text_from_expr :: Repr_Text h -> Text) r
- )
-
-tests :: TestTree
-tests = testGroup "Map"
- [ AST "map_from_list"
- [ AST "list_zipWith"
- [ AST "\\"
- [ AST "x" []
- , AST "Int" []
- , AST "\\"
- [ AST "y" []
- , AST "Text" []
- , AST "(,)"
- [ AST "var" [AST "x" []]
- , AST "var" [AST "y" []]
- ]
- ]
- ]
- , AST "list"
- [ AST "Int" []
- , AST "int" [AST "1" []]
- , AST "int" [AST "2" []]
- , AST "int" [AST "3" []]
- ]
- , AST "list"
- [ AST "Text" []
- , AST "text" [AST "a" []]
- , AST "text" [AST "b" []]
- , AST "text" [AST "c" []]
- ]
- ]
- ] ==> Right
- ( type_map type_int type_text
- , Map.fromList [(1, "a"), (2, "b"), (3, "c")]
- , "map_from_list (list_zipWith (\\x0 -> (\\x1 -> (x0, x1))) [1, 2, 3] [\"a\", \"b\", \"c\"])" )
- , AST "map_foldrWithKey"
- [ AST "\\"
- [ AST "k" []
- , AST "Int" []
- , AST "\\"
- [ AST "v" []
- , AST "Text" []
- , AST "\\"
- [ AST "a" []
- , AST "(,)" [AST "Int" [], AST "Text" []]
- , AST "(,)"
- [ AST "+"
- [ AST "var" [AST "k" []]
- , AST "fst" [ AST "var" [AST "a" []] ]
- ]
- , AST "mappend"
- [ AST "var" [AST "v" []]
- , AST "snd" [ AST "var" [AST "a" []] ]
- ]
- ]
- ]
- ]
- ]
- , AST "(,)"
- [ AST "int" [AST "0" []]
- , AST "text" [AST "" []]
- ]
- , AST "map_from_list"
- [ AST "list_zipWith"
- [ AST "\\"
- [ AST "x" []
- , AST "Int" []
- , AST "\\"
- [ AST "y" []
- , AST "Text" []
- , AST "(,)"
- [ AST "var" [AST "x" []]
- , AST "var" [AST "y" []]
- ]
- ]
- ]
- , AST "list"
- [ AST "Int" []
- , AST "int" [AST "1" []]
- , AST "int" [AST "2" []]
- , AST "int" [AST "3" []]
- ]
- , AST "list"
- [ AST "Text" []
- , AST "text" [AST "a" []]
- , AST "text" [AST "b" []]
- , AST "text" [AST "c" []]
- ]
- ]
- ]
- ] ==> Right
- ( type_tuple2 type_int type_text
- , (6, "abc")
- , "map_foldrWithKey (\\x0 -> (\\x1 -> (\\x2 -> (x0 + fst x2, mappend x1 (snd x2))))) (0, \"\") (map_from_list (list_zipWith (\\x0 -> (\\x1 -> (x0, x1))) [1, 2, 3] [\"a\", \"b\", \"c\"]))" )
- ]
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
--- | Expression for 'Maybe'.
-module Language.Symantic.Expr.Maybe where
-
-import Control.Monad
-import qualified Data.Maybe as Maybe
-import qualified Data.Function as Fun
-import Data.Proxy (Proxy(..))
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding (maybe)
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Expr.Lambda
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_Maybe_Lam'
--- | Symantic.
-class Sym_Maybe repr where
- nothing :: repr (Maybe a)
- just :: repr a -> repr (Maybe a)
- maybe :: repr b -> repr ((->) a b) -> repr (Maybe a) -> repr b
-
- default nothing :: Trans t repr => t repr (Maybe a)
- default just :: Trans t repr => t repr a -> t repr (Maybe a)
- default maybe :: Trans t repr => t repr b -> t repr ((->) a b) -> t repr (Maybe a) -> t repr b
-
- nothing = trans_lift nothing
- just = trans_map1 just
- maybe = trans_map3 maybe
-instance Sym_Maybe Repr_Host where
- nothing = Repr_Host Nothing
- just = liftM Just
- maybe = liftM3 Maybe.maybe
-instance Sym_Maybe Repr_Text where
- nothing = repr_text_app0 "nothing"
- just = repr_text_app1 "just"
- maybe = repr_text_app3 "maybe"
-instance (Sym_Maybe r1, Sym_Maybe r2) => Sym_Maybe (Repr_Dup r1 r2) where
- nothing = repr_dup0 sym_Maybe nothing
- just = repr_dup1 sym_Maybe just
- maybe = repr_dup3 sym_Maybe maybe
-
-sym_Maybe :: Proxy Sym_Maybe
-sym_Maybe = Proxy
-
--- * Type 'Expr_Maybe'
--- | Expression.
-data Expr_Maybe (root:: *)
-type instance Root_of_Expr (Expr_Maybe root) = root
-type instance Type_of_Expr (Expr_Maybe root) = Type_Maybe
-type instance Sym_of_Expr (Expr_Maybe root) repr = Sym_Maybe repr
-type instance Error_of_Expr ast (Expr_Maybe root) = No_Error_Expr
-
--- | Parsing utility to check that the given type is a 'Type_Maybe'
--- or raise 'Error_Expr_Type_mismatch'.
-check_type_maybe
- :: forall ast ex root ty h ret.
- ( root ~ Root_of_Expr ex
- , ty ~ Type_Root_of_Expr ex
- , Type0_Lift Type_Maybe (Type_of_Expr root)
- , Type0_Unlift Type_Maybe (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- )
- => Proxy ex -> ast -> ty h
- -> (Type_Maybe ty h -> Either (Error_of_Expr ast root) ret)
- -> Either (Error_of_Expr ast root) ret
-check_type_maybe ex ast ty k =
- case type0_unlift $ unType_Root ty of
- Just ty_l -> k ty_l
- Nothing -> Left $
- error_expr ex $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 (type_maybe $ type_var0 SZero
- :: ty (Maybe Var0)))
- (Exists_Type0 ty)
-
--- | Parse 'maybe'.
-maybe_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Maybe root)
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type0_Lift Type_Maybe (Type_of_Expr root)
- , Type0_Unlift Type_Maybe (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast -> ast -> ast
- -> ExprFrom ast (Expr_Maybe root) hs ret
-maybe_from ast_n ast_j ast_m ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_n ctx $
- \(ty_n::ty h_n) (Forall_Repr_with_Context n) ->
- expr_from (Proxy::Proxy root) ast_j ctx $
- \(ty_j::ty h_j) (Forall_Repr_with_Context j) ->
- expr_from (Proxy::Proxy root) ast_m ctx $
- \(ty_m::ty h_m) (Forall_Repr_with_Context m) ->
- check_type_fun ex ast ty_j $ \(Type2 Proxy ty_j_a ty_j_b) ->
- check_type_maybe ex ast ty_m $ \(Type1 _ ty_m_a) ->
- check_type0_eq ex ast ty_n ty_j_b $ \Refl ->
- check_type0_eq ex ast ty_m_a ty_j_a $ \Refl ->
- k ty_n $ Forall_Repr_with_Context $
- \c -> maybe (n c) (j c) (m c)
-
--- | Parse 'nothing'.
-nothing_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Maybe root)
- , Type0_From ast ty
- , Type0_Lift Type_Maybe (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast
- -> ExprFrom ast (Expr_Maybe root) hs ret
-nothing_from ast_ty_a ex ast _ctx k =
- case type0_from (Proxy::Proxy ty)
- ast_ty_a (Right . Exists_Type0) of
- Left err -> Left $ error_expr ex $ Error_Expr_Type err ast
- Right (Exists_Type0 ty_a) ->
- k (type_maybe ty_a) $ Forall_Repr_with_Context $
- Fun.const nothing
-
--- | Parse 'just'.
-just_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Maybe root)
- , Expr_From ast root
- , Type0_Lift Type_Maybe (Type_of_Expr root)
- , Root_of_Expr root ~ root
- ) => ast
- -> ExprFrom ast (Expr_Maybe root) hs ret
-just_from ast_a _ex _ast ctx k =
- expr_from (Proxy::Proxy root) ast_a ctx $
- \(ty_a::ty h_a) (Forall_Repr_with_Context a) ->
- k (type_maybe ty_a) $ Forall_Repr_with_Context $
- \c -> just (a c)
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-module Expr.Maybe.Test where
-
-import Test.Tasty
-import Test.Tasty.HUnit
-
-import qualified Control.Arrow as Arrow
-import qualified Control.Monad as Monad
-import Data.Proxy (Proxy(..))
-import Data.Text (Text)
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding (maybe, not)
-
-import Language.Symantic.Repr
-import Language.Symantic.Expr
-import Language.Symantic.Type
-
-import AST.Test
-
--- * Expressions
-e1 = maybe (bool True) (lam not) (just $ bool True)
-
--- * Tests
-type Ex = Expr_Root
- ( Expr_Lambda
- .|. Expr_Maybe
- .|. Expr_Bool
- )
-ex_from = root_expr_from (Proxy::Proxy Ex)
-
-(==>) ast expected =
- testCase (show ast) $
- case ex_from ast of
- Left err -> Left err @?= Prelude.snd `Arrow.left` expected
- Right (Exists_Type0_and_Repr ty (Forall_Repr r)) ->
- case expected of
- Left (_, err) -> Right ("…"::String) @?= Left err
- Right (ty_expected::Type_Root_of_Expr Ex h, _::h, _::Text) ->
- (Monad.>>= (@?= (\(_::Proxy h, err) -> err) `Arrow.left` expected)) $
- case ty `type0_eq` ty_expected of
- Nothing -> Monad.return $ Left $
- error_expr (Proxy::Proxy Ex) $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 ty)
- (Exists_Type0 ty_expected)
- Just Refl -> do
- let h = host_from_expr r
- Monad.return $
- Right
- ( ty
- , h
- , text_from_expr r
- -- , (text_from_expr :: Repr_Text h -> Text) r
- )
-
-tests :: TestTree
-tests = testGroup "Maybe"
- [ AST "just" [AST "bool" [AST "True" []]] ==> Right
- ( type_maybe type_bool
- , Just True
- , "just True" )
- , AST "just"
- [ AST "let"
- [ AST "x" []
- , AST "bool" [AST "True" []]
- , AST "var" [AST "x" []]
- ]
- ] ==> Right
- ( type_maybe type_bool
- , Just True
- , "just (let x0 = True in x0)" )
- , AST "maybe"
- [ AST "bool" [AST "True" []]
- , AST "\\"
- [ AST "x" []
- , AST "Bool" []
- , AST "not" [AST "var" [AST "x" []]]
- ]
- , AST "nothing"
- [ AST "Bool" []
- ]
- ] ==> Right
- ( type_bool
- , True
- , "maybe True (\\x0 -> not x0) nothing" )
- , AST "maybe"
- [ AST "bool" [AST "False" []]
- , AST "\\"
- [ AST "x" []
- , AST "Bool" []
- , AST "not" [AST "var" [AST "x" []]]
- ]
- , AST "just"
- [ AST "bool" [AST "True" []]
- ]
- ] ==> Right
- ( type_bool
- , False
- , "maybe False (\\x0 -> not x0) (just True)" )
- ]
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
--- | Expression for 'Monad'.
-module Language.Symantic.Expr.Monad where
-
-import Control.Monad (Monad)
-import qualified Control.Monad as Monad
-import qualified Data.Function as Fun
-import Data.Proxy (Proxy(..))
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding ((<$>), Monad(..))
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Expr.Lambda
-import Language.Symantic.Expr.Functor
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_Monad'
--- | Symantic.
-class Sym_Functor repr => Sym_Monad repr where
- return :: Monad m => repr a -> repr (m a)
- (>>=) :: Monad m => repr (m a) -> repr (a -> m b) -> repr (m b)
-
- default return :: (Trans t repr, Monad m)
- => t repr a -> t repr (m a)
- default (>>=) :: (Trans t repr, Monad m)
- => t repr (m a) -> t repr (a -> m b) -> t repr (m b)
-
- return = trans_map1 return
- (>>=) = trans_map2 (>>=)
-infixl 1 >>=
-instance Sym_Monad Repr_Host where
- return = Monad.liftM Monad.return
- (>>=) = Monad.liftM2 (Monad.>>=)
-instance Sym_Monad Repr_Text where
- return = repr_text_app1 "return"
- (>>=) = repr_text_infix ">>=" (Precedence 1)
-instance (Sym_Monad r1, Sym_Monad r2) => Sym_Monad (Repr_Dup r1 r2) where
- return = repr_dup1 sym_Monad return
- (>>=) = repr_dup2 sym_Monad (>>=)
-
-sym_Monad :: Proxy Sym_Monad
-sym_Monad = Proxy
-
--- * Type 'Expr_Monad'
--- | Expression.
-data Expr_Monad (root:: *)
-type instance Root_of_Expr (Expr_Monad root) = root
-type instance Type_of_Expr (Expr_Monad root) = No_Type
-type instance Sym_of_Expr (Expr_Monad root) repr = Sym_Monad repr
-type instance Error_of_Expr ast (Expr_Monad root) = No_Error_Expr
-
-return_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Monad root)
- , Type0_Eq ty
- , Type1_From ast ty
- , Type1_Constraint Monad ty
- , Expr_From ast root
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast -> ast
- -> ExprFrom ast (Expr_Monad root) hs ret
-return_from ast_f ast_a ex ast ctx k =
- -- return :: Monad f => a -> f a
- either (\err -> Left $ error_expr ex $ Error_Expr_Type err ast) Fun.id $
- type1_from (Proxy::Proxy ty) ast_f $ \_f ty_f -> Right $
- expr_from (Proxy::Proxy root) ast_a ctx $
- \(ty_a::ty h_a) (Forall_Repr_with_Context a) ->
- let ty_fa = ty_f ty_a in
- check_type1_constraint ex (Proxy::Proxy Monad) ast ty_fa $ \Dict ->
- k ty_fa $ Forall_Repr_with_Context $
- \c -> return (a c)
-
-bind_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Monad root)
- , Type0_Eq ty
- , Type1_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- , Type1_Constraint Monad ty
- ) => ast -> ast
- -> ExprFrom ast (Expr_Monad root) hs ret
-bind_from ast_ma ast_f ex ast ctx k =
- -- (>>=) :: Monad m => m a -> (a -> m b) -> m b
- expr_from (Proxy::Proxy root) ast_ma ctx $
- \(ty_ma::ty h_ma) (Forall_Repr_with_Context ma) ->
- expr_from (Proxy::Proxy root) ast_f ctx $
- \(ty_f::ty h_f) (Forall_Repr_with_Context f) ->
- check_type1 ex ast ty_ma $ \(Type1 m ty_m_a, Type1_Lift ty_m) ->
- check_type_fun ex ast ty_f $ \(Type2 Proxy ty_f_a ty_f_mb) ->
- check_type0_eq ex ast ty_m_a ty_f_a $ \Refl ->
- check_type1 ex ast ty_f_mb $ \(Type1 _ ty_f_m_b, _) ->
- check_type1_eq ex ast ty_ma ty_f_mb $ \Refl ->
- check_type1_constraint ex (Proxy::Proxy Monad) ast ty_ma $ \Dict ->
- k (Type_Root $ ty_m $ Type1 m ty_f_m_b) $ Forall_Repr_with_Context $
- \c -> (>>=) (ma c) (f c)
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-
-module Expr.Monad.Test where
-
-import Test.Tasty
-import Test.Tasty.HUnit
-
-import qualified Control.Arrow as Arrow
-import qualified Control.Monad as Monad
-import qualified Data.Functor as Functor
-import Data.Proxy (Proxy(..))
-import Data.Text (Text)
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding ((&&), not, (||), (==), (<$>), (+), Applicative(..), Monad(..), Monad(..))
-
-import Language.Symantic.Type
-import Language.Symantic.Expr as Expr
-import Language.Symantic.Repr
-
-import AST.Test
-
--- * Expressions
-t = bool True
-f = bool False
-e1 = (>>=) (list $ int Functor.<$> [1..3])
- (lam $ \i -> list [i, i])
-
--- * Tests
-type Ex = Expr_Root
- ( Expr_Lambda
- .|. Expr_List
- .|. Expr_Maybe
- .|. Expr_Int
- .|. Expr_Bool
- .|. Expr_Functor
- .|. Expr_Applicative
- .|. Expr_Monad
- .|. Expr_Either
- )
-ex_from = root_expr_from (Proxy::Proxy Ex)
-
-(==>) ast expected =
- testCase (show ast) $
- case ex_from ast of
- Left err -> Left err @?= Prelude.snd `Arrow.left` expected
- Right (Exists_Type0_and_Repr ty (Forall_Repr r)) ->
- case expected of
- Left (_, err) -> Right ("…"::String) @?= Left err
- Right (ty_expected::Type_Root_of_Expr Ex h, _::h, _::Text) ->
- (Monad.>>= (@?= (\(_::Proxy h, err) -> err) `Arrow.left` expected)) $
- case ty `type0_eq` ty_expected of
- Nothing -> Monad.return $ Left $
- error_expr (Proxy::Proxy Ex) $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 ty)
- (Exists_Type0 ty_expected)
- Just Refl -> do
- let h = host_from_expr r
- Monad.return $
- Right
- ( ty
- , h
- , text_from_expr r
- -- , (text_from_expr :: Repr_Text h -> Text) r
- )
-
-tests :: TestTree
-tests = testGroup "Monad"
- [ AST ">>="
- [ AST "list"
- [ AST "Int" []
- , AST "int" [AST "1" []]
- , AST "int" [AST "2" []]
- , AST "int" [AST "3" []]
- ]
- , AST "\\"
- [ AST "x" [], AST "Int" []
- , AST "list"
- [ AST "Int" []
- , AST "var" [ AST "x" [] ]
- , AST "var" [ AST "x" [] ]
- ]
- ]
- ] ==> Right
- ( type_list type_int
- , [1, 1, 2, 2, 3, 3]
- , "[1, 2, 3] >>= (\\x0 -> [x0, x0])" )
- , AST ">>="
- [ AST "just" [ AST "int" [AST "1" []] ]
- , AST "\\"
- [ AST "x" [], AST "Int" []
- , AST "nothing"
- [ AST "Int" []
- ]
- ]
- ] ==> Right
- ( type_maybe type_int
- , Nothing
- , "just 1 >>= (\\x0 -> nothing)" )
- , AST ">>="
- [ AST "right"
- [ AST "Bool" []
- , AST "int" [AST "1" []]
- ]
- , AST "\\"
- [ AST "x" [], AST "Int" []
- , AST "left"
- [ AST "Int" []
- , AST "bool" [AST "True" []]
- ]
- ]
- ] ==> Right
- ( type_either type_bool type_int
- , Left True
- , "right 1 >>= (\\x0 -> left True)" )
- ]
+++ /dev/null
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
--- | Expression for 'MonoFunctor'.
-module Language.Symantic.Expr.MonoFunctor where
-
-import Control.Monad (liftM2)
-import Data.Proxy (Proxy(..))
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding (fmap)
--- import qualified Data.Function as Fun
-import qualified Data.MonoTraversable as MT
-import Data.MonoTraversable (MonoFunctor)
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Expr.Lambda
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_MonoFunctor'
--- | Symantic.
-class Sym_Lambda repr => Sym_MonoFunctor repr where
- omap :: MonoFunctor o => repr (MT.Element o -> MT.Element o) -> repr o -> repr o
- default omap :: (Trans t repr, MonoFunctor o)
- => t repr (MT.Element o -> MT.Element o) -> t repr o -> t repr o
- omap = trans_map2 omap
-instance Sym_MonoFunctor Repr_Host where
- omap = liftM2 MT.omap
-instance Sym_MonoFunctor Repr_Text where
- omap = repr_text_app2 "omap"
-instance (Sym_MonoFunctor r1, Sym_MonoFunctor r2) => Sym_MonoFunctor (Repr_Dup r1 r2) where
- omap = repr_dup2 sym_MonoFunctor omap
-
-sym_MonoFunctor :: Proxy Sym_MonoFunctor
-sym_MonoFunctor = Proxy
-
--- * Type 'Expr_MonoFunctor'
--- | Expression.
-data Expr_MonoFunctor (root:: *)
-type instance Root_of_Expr (Expr_MonoFunctor root) = root
-type instance Type_of_Expr (Expr_MonoFunctor root) = No_Type
-type instance Sym_of_Expr (Expr_MonoFunctor root) repr = Sym_MonoFunctor repr
-type instance Error_of_Expr ast (Expr_MonoFunctor root) = No_Error_Expr
-
--- | Parse 'omap'.
-omap_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_MonoFunctor root)
- , Expr_From ast root
- , Type0_Eq ty
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type0_Constraint MonoFunctor ty
- , Type0_Family Type_Family_MonoElement ty
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast -> ast
- -> ExprFrom ast (Expr_MonoFunctor root) hs ret
-omap_from ast_f ast_m ex ast ctx k =
- -- omap :: (Element mono -> Element mono) -> mono -> mono
- expr_from (Proxy::Proxy root) ast_f ctx $
- \(ty_f::ty h_f) (Forall_Repr_with_Context f) ->
- expr_from (Proxy::Proxy root) ast_m ctx $
- \(ty_m::ty h_m) (Forall_Repr_with_Context m) ->
- check_type_fun ex ast ty_f $ \(Type2 Proxy ty_f_a ty_f_b) ->
- check_type0_constraint ex (Proxy::Proxy MonoFunctor) ast ty_m $ \Dict ->
- check_type0_eq ex ast ty_f_a ty_f_b $ \Refl ->
- check_type0_family (Proxy::Proxy Type_Family_MonoElement) ex ast ty_m $ \ty_m_ele ->
- check_type0_eq ex ast ty_f_a ty_m_ele $ \Refl ->
- k ty_m $ Forall_Repr_with_Context $
- \c -> omap (f c) (m c)
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-
-module Expr.MonoFunctor.Test where
-
-import Test.Tasty
-import Test.Tasty.HUnit
-
-import qualified Control.Arrow as Arrow
-import qualified Control.Monad as Monad
-import Data.Proxy (Proxy(..))
-import Data.Text (Text)
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding ((&&), not, (||), (==), fmap, (+))
-
-import Language.Symantic.Type
-import Language.Symantic.Expr as Expr
-import Language.Symantic.Repr
-
-import AST.Test
-
--- * Expressions
-t = bool True
-f = bool False
-e1 = omap (lam $ \x -> x + int 1) (list $ int Prelude.<$> [1..3])
-e2 = omap (lam char_toUpper) (text "abcde")
-
--- * Tests
-type Ex = Expr_Root
- ( Expr_Lambda
- .|. Expr_Maybe
- .|. Expr_List
- .|. Expr_MonoFunctor
- .|. Expr_Int
- .|. Expr_Integer
- .|. Expr_Num
- .|. Expr_Bool
- .|. Expr_Char
- .|. Expr_Text
- )
-ex_from = root_expr_from (Proxy::Proxy Ex)
-
-(==>) ast expected =
- testCase (show ast) $
- case ex_from ast of
- Left err -> Left err @?= Prelude.snd `Arrow.left` expected
- Right (Exists_Type0_and_Repr ty (Forall_Repr r)) ->
- case expected of
- Left (_, err) -> Right ("…"::String) @?= Left err
- Right (ty_expected::Type_Root_of_Expr Ex h, _::h, _::Text) ->
- (Monad.>>= (@?= (\(_::Proxy h, err) -> err) `Arrow.left` expected)) $
- case ty `type0_eq` ty_expected of
- Nothing -> Monad.return $ Left $
- error_expr (Proxy::Proxy Ex) $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 ty)
- (Exists_Type0 ty_expected)
- Just Refl -> do
- let h = host_from_expr r
- Monad.return $
- Right
- ( ty
- , h
- , text_from_expr r
- -- , (text_from_expr :: Repr_Text h -> Text) r
- )
-
-tests :: TestTree
-tests = testGroup "MonoFunctor"
- [ AST "omap"
- [ AST "\\"
- [ AST "x" []
- , AST "Int" []
- , AST "+" [ AST "var" [AST "x" []]
- , AST "int" [AST "1" []] ]
- ]
- , AST "list"
- [ AST "Int" []
- , AST "int" [AST "1" []]
- , AST "int" [AST "2" []]
- , AST "int" [AST "3" []]
- ]
- ] ==> Right
- ( type_list type_int
- , [2,3,4]
- , "omap (\\x0 -> x0 + 1) [1, 2, 3]" )
- , AST "omap"
- [ AST "\\"
- [ AST "x" []
- , AST "Char" []
- , AST "char_toUpper" [ AST "var" [AST "x" []] ]
- ]
- , AST "text" [ AST "abcde" [] ]
- ] ==> Right
- ( type_text
- , "ABCDE"
- , "omap (\\x0 -> char_toUpper x0) \"abcde\"" )
- ]
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
--- | Expression for 'Monoid'.
-module Language.Symantic.Expr.Monoid where
-
-import Control.Monad
-import Data.Monoid (Monoid)
-import qualified Data.Monoid as Monoid
-import Data.Proxy (Proxy(..))
-import Prelude hiding ((<$>), Monoid(..))
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_Monoid'
--- | Symantic.
-class Sym_Monoid repr where
- mempty :: Monoid a => repr a
- mappend :: Monoid a => repr a -> repr a -> repr a
- default mempty :: (Trans t repr, Monoid a) => t repr a
- default mappend :: (Trans t repr, Monoid a) => t repr a -> t repr a -> t repr a
- mempty = trans_lift mempty
- mappend = trans_map2 mappend
-instance Sym_Monoid Repr_Host where
- mempty = Repr_Host Monoid.mempty
- mappend = liftM2 Monoid.mappend
-instance Sym_Monoid Repr_Text where
- mempty = repr_text_app0 "mempty"
- mappend = repr_text_app2 "mappend"
-instance (Sym_Monoid r1, Sym_Monoid r2) => Sym_Monoid (Repr_Dup r1 r2) where
- mempty = repr_dup0 sym_Monoid mempty
- mappend = repr_dup2 sym_Monoid mappend
-
-sym_Monoid :: Proxy Sym_Monoid
-sym_Monoid = Proxy
-
--- | 'mappend' alias.
-(<>) ::
- ( Sym_Monoid repr
- , Monoid a )
- => repr a -> repr a -> repr a
-(<>) = mappend
-infixr 6 <>
-
--- * Type 'Expr_Monoid'
--- | Expression.
-data Expr_Monoid (root:: *)
-type instance Root_of_Expr (Expr_Monoid root) = root
-type instance Type_of_Expr (Expr_Monoid root) = No_Type
-type instance Sym_of_Expr (Expr_Monoid root) repr = Sym_Monoid repr
-type instance Error_of_Expr ast (Expr_Monoid root) = No_Error_Expr
-
--- | Parse 'mempty'.
-mempty_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Monoid root)
- , Type0_From ast ty
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- , Type0_Constraint Monoid ty
- ) => ast
- -> ExprFrom ast (Expr_Monoid root) hs ret
-mempty_from ast_a ex ast _ctx k =
- -- mempty :: Monoid a => a
- either (\err -> Left $ error_expr ex $ Error_Expr_Type err ast) id $
- type0_from (Proxy::Proxy ty) ast_a $ \ty_a -> Right $
- check_type0_constraint ex (Proxy::Proxy Monoid) ast ty_a $ \Dict ->
- k ty_a $ Forall_Repr_with_Context $
- const mempty
-
--- | Parse 'mappend'.
-mappend_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Monoid root)
- , Type0_Eq ty
- , Expr_From ast root
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- , Type0_Constraint Monoid ty
- ) => ast -> ast
- -> ExprFrom ast (Expr_Monoid root) hs ret
-mappend_from = class_op2_from mappend (Proxy::Proxy Monoid)
-
--- | Parse 'mappend', partially applied.
-mappend_from1
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Monoid root)
- , Type0_Eq ty
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Expr_From ast root
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- , Type0_Constraint Monoid ty
- ) => ast
- -> ExprFrom ast (Expr_Monoid root) hs ret
-mappend_from1 = class_op2_from1 mappend (Proxy::Proxy Monoid)
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
--- | Expression for 'Num'.
-module Language.Symantic.Expr.Num where
-
-import Control.Monad
-import Prelude hiding (Num(..))
-import Prelude (Num)
-import qualified Prelude
-import Data.Proxy (Proxy(..))
-import Data.Type.Equality ((:~:)(Refl))
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_Num'
--- | Symantic.
-class Sym_Num repr where
- abs :: Num n => repr n -> repr n
- negate :: Num n => repr n -> repr n
- signum :: Num n => repr n -> repr n
- (+) :: Num n => repr n -> repr n -> repr n
- (-) :: Num n => repr n -> repr n -> repr n
- (*) :: Num n => repr n -> repr n -> repr n
- fromInteger :: Num n => repr Integer -> repr n
-
- default abs :: (Trans t repr, Num n) => t repr n -> t repr n
- default negate :: (Trans t repr, Num n) => t repr n -> t repr n
- default signum :: (Trans t repr, Num n) => t repr n -> t repr n
- default (+) :: (Trans t repr, Num n) => t repr n -> t repr n -> t repr n
- default (-) :: (Trans t repr, Num n) => t repr n -> t repr n -> t repr n
- default (*) :: (Trans t repr, Num n) => t repr n -> t repr n -> t repr n
- default fromInteger :: (Trans t repr, Num n) => t repr Integer -> t repr n
-
- abs = trans_map1 abs
- negate = trans_map1 negate
- signum = trans_map1 signum
- (+) = trans_map2 (+)
- (-) = trans_map2 (-)
- (*) = trans_map2 (*)
- fromInteger = trans_map1 fromInteger
-
-infixl 6 +
-infixl 6 -
-infixl 7 *
-
-instance Sym_Num Repr_Host where
- abs = liftM Prelude.abs
- negate = liftM Prelude.negate
- signum = liftM Prelude.signum
- (+) = liftM2 (Prelude.+)
- (-) = liftM2 (Prelude.-)
- (*) = liftM2 (Prelude.*)
- fromInteger = liftM Prelude.fromInteger
-instance Sym_Num Repr_Text where
- abs = repr_text_app1 "abs"
- negate = repr_text_app1 "negate"
- signum = repr_text_app1 "signum"
- (+) = repr_text_infix "+" (Precedence 6)
- (-) = repr_text_infix "-" (Precedence 6)
- (*) = repr_text_infix "-" (Precedence 7)
- fromInteger = repr_text_app1 "fromInteger"
-instance (Sym_Num r1, Sym_Num r2) => Sym_Num (Repr_Dup r1 r2) where
- abs = repr_dup1 sym_Num abs
- negate = repr_dup1 sym_Num negate
- signum = repr_dup1 sym_Num signum
- (+) = repr_dup2 sym_Num (+)
- (-) = repr_dup2 sym_Num (-)
- (*) = repr_dup2 sym_Num (*)
- fromInteger = repr_dup1 sym_Num fromInteger
-
-sym_Num :: Proxy Sym_Num
-sym_Num = Proxy
-
--- * Type 'Expr_Num'
--- | Expression.
-data Expr_Num (root:: *)
-type instance Root_of_Expr (Expr_Num root) = root
-type instance Type_of_Expr (Expr_Num root) = No_Type
-type instance Sym_of_Expr (Expr_Num root) repr = Sym_Num repr
-type instance Error_of_Expr ast (Expr_Num root) = No_Error_Expr
-
--- | Parse 'fst'.
-fromInteger_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Num root)
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Integer (Type_of_Expr root)
- , Type0_Unlift Type_Integer (Type_of_Expr root)
- , Type0_Constraint Num ty
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast
- -> ExprFrom ast (Expr_Num root) hs ret
-fromInteger_from ast_i ex ast ctx k =
- -- fromInteger :: Num a => Integer -> a
- expr_from (Proxy::Proxy root) ast_i ctx $
- \(ty_i::ty h_i) (Forall_Repr_with_Context i) ->
- check_type0_eq ex ast type_integer ty_i $ \Refl ->
- k ty_i $ Forall_Repr_with_Context $
- \c -> fromInteger (i c)
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
--- | Expression for 'Ord'.
-module Language.Symantic.Expr.Ord where
-
-import Control.Monad
-import qualified Data.Ord as Ord
-import Data.Proxy (Proxy(..))
-import Data.Type.Equality ((:~:)(Refl))
-import Data.Ord (Ord)
-import Prelude hiding (Ord(..))
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Expr.Eq
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_Ord'
--- | Symantic.
-class Sym_Eq repr => Sym_Ord repr where
- compare :: Ord a => repr a -> repr a -> repr Ordering
- (<) :: Ord a => repr a -> repr a -> repr Bool
- (<=) :: Ord a => repr a -> repr a -> repr Bool
- (>) :: Ord a => repr a -> repr a -> repr Bool
- (>=) :: Ord a => repr a -> repr a -> repr Bool
- max :: Ord a => repr a -> repr a -> repr a
- min :: Ord a => repr a -> repr a -> repr a
-
- default compare :: (Trans t repr, Ord a) => t repr a -> t repr a -> t repr Ordering
- default (<) :: (Trans t repr, Ord a) => t repr a -> t repr a -> t repr Bool
- default (<=) :: (Trans t repr, Ord a) => t repr a -> t repr a -> t repr Bool
- default (>) :: (Trans t repr, Ord a) => t repr a -> t repr a -> t repr Bool
- default (>=) :: (Trans t repr, Ord a) => t repr a -> t repr a -> t repr Bool
- default max :: (Trans t repr, Ord a) => t repr a -> t repr a -> t repr a
- default min :: (Trans t repr, Ord a) => t repr a -> t repr a -> t repr a
-
- compare = trans_map2 compare
- (<) = trans_map2 (<)
- (<=) = trans_map2 (<=)
- (>) = trans_map2 (>)
- (>=) = trans_map2 (>=)
- min = trans_map2 min
- max = trans_map2 max
-
-infix 4 <
-infix 4 <=
-infix 4 >
-infix 4 >=
-
-instance Sym_Ord Repr_Host where
- compare = liftM2 Ord.compare
- (<) = liftM2 (Ord.<)
- (<=) = liftM2 (Ord.<=)
- (>) = liftM2 (Ord.>)
- (>=) = liftM2 (Ord.>=)
- min = liftM2 Ord.min
- max = liftM2 Ord.max
-instance Sym_Ord Repr_Text where
- compare = repr_text_app2 "compare"
- (<) = repr_text_infix "<" (Precedence 4)
- (<=) = repr_text_infix "<=" (Precedence 4)
- (>) = repr_text_infix ">" (Precedence 4)
- (>=) = repr_text_infix ">=" (Precedence 4)
- min = repr_text_app2 "min"
- max = repr_text_app2 "max"
-instance (Sym_Ord r1, Sym_Ord r2) => Sym_Ord (Repr_Dup r1 r2) where
- compare = repr_dup2 sym_Ord compare
- (<) = repr_dup2 sym_Ord (<)
- (<=) = repr_dup2 sym_Ord (<=)
- (>) = repr_dup2 sym_Ord (>)
- (>=) = repr_dup2 sym_Ord (>=)
- min = repr_dup2 sym_Ord min
- max = repr_dup2 sym_Ord max
-
-sym_Ord :: Proxy Sym_Ord
-sym_Ord = Proxy
-
--- * Type 'Expr_Ord'
--- | Expression.
-data Expr_Ord (root:: *)
-type instance Root_of_Expr (Expr_Ord root) = root
-type instance Type_of_Expr (Expr_Ord root) = Type_Ordering
-type instance Sym_of_Expr (Expr_Ord root) repr = Sym_Ord repr
-type instance Error_of_Expr ast (Expr_Ord root) = No_Error_Expr
-
--- | Parse 'compare'.
-compare_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Ord root)
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Ordering (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- , Type0_Constraint Ord ty
- ) => ast -> ast
- -> ExprFrom ast (Expr_Ord root) hs ret
-compare_from ast_x ast_y ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_x ctx $
- \(ty_x::ty h_x) (Forall_Repr_with_Context x) ->
- expr_from (Proxy::Proxy root) ast_y ctx $
- \(ty_y::ty h_y) (Forall_Repr_with_Context y) ->
- check_type0_eq ex ast ty_x ty_y $ \Refl ->
- check_type0_constraint ex (Proxy::Proxy Ord) ast ty_x $ \Dict ->
- k type_ordering $ Forall_Repr_with_Context $
- \c -> x c `compare` y c
-
--- | Parse 'compare', partially applied.
-compare_from1
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Ord root)
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Ordering (Type_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- , Type0_Constraint Ord ty
- ) => ast
- -> ExprFrom ast (Expr_Ord root) hs ret
-compare_from1 ast_x ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_x ctx $
- \(ty_x::ty h_x) (Forall_Repr_with_Context x) ->
- check_type0_constraint ex (Proxy::Proxy Ord) ast ty_x $ \Dict ->
- k (type_fun ty_x type_ordering) $ Forall_Repr_with_Context $
- \c -> lam $ \y -> x c `compare` y
-
--- | Parse '<', '<=', '>', or '>='.
-ord_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Ord root)
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Type0_Eq ty
- , Expr_From ast root
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- , Type0_Constraint Ord ty
- ) => (forall repr a. (Sym_Ord repr, Ord a) => repr a -> repr a -> repr Bool)
- -> ast -> ast
- -> ExprFrom ast (Expr_Ord root) hs ret
-ord_from test ast_x ast_y ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_x ctx $
- \(ty_x::ty h_x) (Forall_Repr_with_Context x) ->
- expr_from (Proxy::Proxy root) ast_y ctx $
- \(ty_y::ty h_y) (Forall_Repr_with_Context y) ->
- check_type0_eq ex ast ty_x ty_y $ \Refl ->
- check_type0_constraint ex (Proxy::Proxy Ord) ast ty_x $ \Dict ->
- k type_bool $ Forall_Repr_with_Context $
- \c -> x c `test` y c
-
--- | Parse '<', '<=', '>', or '>=', partially applied.
-ord_from1
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Ord root)
- , Type0_Lift Type_Bool (Type_of_Expr root)
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Eq ty
- , Expr_From ast root
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- , Type0_Constraint Ord ty
- ) => (forall repr a. (Sym_Ord repr, Ord a) => repr a -> repr a -> repr Bool)
- -> ast
- -> ExprFrom ast (Expr_Ord root) hs ret
-ord_from1 test ast_x ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_x ctx $
- \(ty_x::ty h_x) (Forall_Repr_with_Context x) ->
- check_type0_constraint ex (Proxy::Proxy Ord) ast ty_x $ \Dict ->
- k (type_fun ty_x type_bool) $ Forall_Repr_with_Context $
- \c -> lam $ \y -> x c `test` y
+++ /dev/null
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-module Language.Symantic.Expr.Root where
-
-import Language.Symantic.Type
-
--- * Type 'Expr_Root'
--- | The root expression, passing itself as parameter to the given expression.
-newtype Expr_Root (ex:: * -> *)
- = Expr_Root (ex (Expr_Root ex))
-type instance Root_of_Expr (Expr_Root ex) = Expr_Root ex
-type instance Type_of_Expr (Expr_Root ex) = Type_of_Expr (ex (Expr_Root ex))
-
--- * Type family 'Root_of_Expr'
--- | The root expression of an expression.
-type family Root_of_Expr (ex:: *) :: *
-
--- * Type family 'Type_of_Expr'
--- | The type of an expression, parameterized by a root type.
-type family Type_of_Expr (ex:: *) :: {-root-}(* -> *) -> {-h-}* -> *
-
--- ** Type 'Type_Root_of_Expr'
--- | Convenient alias.
---
--- NOTE: include 'Type_Var' only to use it
--- within 'Error_Expr_Type_mismatch' so far.
-type Type_Root_of_Expr (ex:: *)
- = Type_Root (Type_Var0 :|: Type_Var1 :|: Type_of_Expr (Root_of_Expr ex))
+++ /dev/null
-module Expr.Test where
-
-import Test.Tasty
-
-import qualified Expr.Lambda.Test as Lambda
-import qualified Expr.Bool.Test as Bool
-import qualified Expr.Int.Test as Int
-import qualified Expr.Maybe.Test as Maybe
-import qualified Expr.If.Test as If
-import qualified Expr.Eq.Test as Eq
-import qualified Expr.List.Test as List
-import qualified Expr.Functor.Test as Functor
-import qualified Expr.Applicative.Test as Applicative
-import qualified Expr.Foldable.Test as Foldable
-import qualified Expr.Traversable.Test as Traversable
-import qualified Expr.Monad.Test as Monad
-import qualified Expr.Map.Test as Map
-import qualified Expr.MonoFunctor.Test as MonoFunctor
-
-tests :: TestTree
-tests =
- testGroup "Expr"
- [ Lambda.tests
- , Bool.tests
- , Int.tests
- , Maybe.tests
- , If.tests
- , Eq.tests
- , List.tests
- , Functor.tests
- , Applicative.tests
- , Foldable.tests
- , Traversable.tests
- , Monad.tests
- , Map.tests
- , MonoFunctor.tests
- ]
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
--- | Expression for 'Text'.
-module Language.Symantic.Expr.Text where
-
-import Data.Proxy
-import Data.Text (Text)
-import qualified Data.Text as Text
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_Text'
--- | Symantic.
-class Sym_Text repr where
- text :: Text -> repr Text
- default text :: Trans t repr => Text -> t repr Text
- text = trans_lift . text
-instance Sym_Text Repr_Host where
- text = Repr_Host
-instance Sym_Text Repr_Text where
- text a = Repr_Text $ \_p _v -> Text.pack (show a)
-instance (Sym_Text r1, Sym_Text r2) => Sym_Text (Repr_Dup r1 r2) where
- text x = text x `Repr_Dup` text x
-
-sym_Text :: Proxy Sym_Text
-sym_Text = Proxy
-
--- * Type 'Expr_Text'
--- | Expression.
-data Expr_Text (root:: *)
-type instance Root_of_Expr (Expr_Text root) = root
-type instance Type_of_Expr (Expr_Text root) = Type_Text
-type instance Sym_of_Expr (Expr_Text root) repr = Sym_Text repr
-type instance Error_of_Expr ast (Expr_Text root) = No_Error_Expr
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
--- | Expression for 'Traversable'.
-module Language.Symantic.Expr.Traversable where
-
-import Control.Monad
-import Data.Traversable (Traversable)
-import qualified Data.Traversable as Traversable
-import Data.Proxy (Proxy(..))
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding (Traversable(..))
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Expr.Lambda
-import Language.Symantic.Expr.Applicative
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_Traversable'
--- | Symantic.
-class Sym_Applicative repr => Sym_Traversable repr where
- traverse :: (Traversable t, Applicative f)
- => repr ((->) a (f b)) -> repr (t a) -> repr (f (t b))
- default traverse :: (Trans tr repr, Traversable t, Applicative f)
- => tr repr ((->) a (f b)) -> tr repr (t a) -> tr repr (f (t b))
- traverse = trans_map2 traverse
-instance Sym_Traversable Repr_Host where
- traverse = liftM2 Traversable.traverse
-instance Sym_Traversable Repr_Text where
- traverse = repr_text_app2 "traverse"
-instance (Sym_Traversable r1, Sym_Traversable r2) => Sym_Traversable (Repr_Dup r1 r2) where
- traverse = repr_dup2 sym_Traversable traverse
-
-sym_Traversable :: Proxy Sym_Traversable
-sym_Traversable = Proxy
-
--- * Type 'Expr_Traversable'
--- | Expression.
-data Expr_Traversable (root:: *)
-type instance Root_of_Expr (Expr_Traversable root) = root
-type instance Type_of_Expr (Expr_Traversable root) = No_Type
-type instance Sym_of_Expr (Expr_Traversable root) repr = Sym_Traversable repr
-type instance Error_of_Expr ast (Expr_Traversable root) = No_Error_Expr
-
-traverse_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Traversable root)
- , Type0_Eq ty
- , Type1_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Fun (Type_of_Expr root)
- , Type0_Unlift Type_Fun (Type_of_Expr root)
- , Type1_Unlift (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- , Type1_Constraint Applicative ty
- , Type1_Constraint Traversable ty
- ) => ast -> ast
- -> ExprFrom ast (Expr_Traversable root) hs ret
-traverse_from ast_g ast_ta ex ast ctx k =
- -- traverse :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b)
- expr_from (Proxy::Proxy root) ast_g ctx $
- \(ty_g::ty h_g) (Forall_Repr_with_Context g) ->
- expr_from (Proxy::Proxy root) ast_ta ctx $
- \ty_ta (Forall_Repr_with_Context ta) ->
-
- check_type_fun ex ast ty_g $ \(Type2 Proxy ty_g_a ty_g_fb) ->
-
- check_type1 ex ast ty_g_fb $ \(Type1 f ty_g_fb_b, Type1_Lift ty_f) ->
- check_type1 ex ast ty_ta $ \(Type1 t ty_ta_a, Type1_Lift ty_t) ->
-
- check_type1_constraint ex (Proxy::Proxy Applicative) ast ty_g_fb $ \Dict ->
- check_type1_constraint ex (Proxy::Proxy Traversable) ast ty_ta $ \Dict ->
-
- check_type0_eq ex ast ty_g_a ty_ta_a $ \Refl ->
-
- k (
- Type_Root $ ty_f $ Type1 f $
- Type_Root $ ty_t $ Type1 t ty_g_fb_b
- ) $ Forall_Repr_with_Context $
- \c -> traverse (g c) (ta c)
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-
-module Expr.Traversable.Test where
-
-import Test.Tasty
-import Test.Tasty.HUnit
-
-import qualified Control.Arrow as Arrow
-import qualified Control.Monad as Monad
-import qualified Data.Functor as Functor
-import Data.Proxy (Proxy(..))
-import Data.Text (Text)
-import Data.Type.Equality ((:~:)(Refl))
-import Prelude hiding ((&&), not, (||), (==), (<$>), (+), Applicative(..), Monad(..), Traversable(..))
-
-import Language.Symantic.Type
-import Language.Symantic.Expr as Expr
-import Language.Symantic.Repr
-
-import AST.Test
-
--- * Expressions
-t = bool True
-f = bool False
-e1 = traverse (lam Right)
- (list $ int Functor.<$> [1..3])
-
--- * Tests
-type Ex = Expr_Root
- ( Expr_Lambda
- .|. Expr_List
- .|. Expr_Maybe
- .|. Expr_Int
- .|. Expr_Bool
- .|. Expr_Functor
- .|. Expr_Applicative
- .|. Expr_Traversable
- .|. Expr_Either
- )
-ex_from = root_expr_from (Proxy::Proxy Ex)
-
-(==>) ast expected =
- testCase (show ast) $
- case ex_from ast of
- Left err -> Left err @?= Prelude.snd `Arrow.left` expected
- Right (Exists_Type0_and_Repr ty (Forall_Repr r)) ->
- case expected of
- Left (_, err) -> Right ("…"::String) @?= Left err
- Right (ty_expected::Type_Root_of_Expr Ex h, _::h, _::Text) ->
- (Monad.>>= (@?= (\(_::Proxy h, err) -> err) `Arrow.left` expected)) $
- case ty `type0_eq` ty_expected of
- Nothing -> Monad.return $ Left $
- error_expr (Proxy::Proxy Ex) $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 ty)
- (Exists_Type0 ty_expected)
- Just Refl -> do
- let h = host_from_expr r
- Monad.return $
- Right
- ( ty
- , h
- , text_from_expr r
- -- , (text_from_expr :: Repr_Text h -> Text) r
- )
-
-tests :: TestTree
-tests = testGroup "Traversable"
- [ AST "traverse"
- [ AST "\\"
- [ AST "x" [], AST "Int" []
- , AST "just" [ AST "var" [ AST "x" [] ] ]
- ]
- , AST "list"
- [ AST "Int" []
- , AST "int" [AST "1" []]
- , AST "int" [AST "2" []]
- , AST "int" [AST "3" []]
- ]
- ] ==> Right
- ( type_maybe (type_list type_int)
- , Just [1, 2, 3]
- , "traverse (\\x0 -> just x0) [1, 2, 3]" )
- , AST "traverse"
- [ AST "\\"
- [ AST "x" [], AST "Int" []
- , AST "right" [ AST "Int" [], AST "var" [ AST "x" [] ] ]
- ]
- , AST "list"
- [ AST "Int" []
- , AST "int" [AST "1" []]
- , AST "int" [AST "2" []]
- , AST "int" [AST "3" []]
- ]
- ] ==> Right
- ( type_either type_int (type_list type_int)
- , Right [1, 2, 3]
- , "traverse (\\x0 -> right x0) [1, 2, 3]" )
- ]
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
--- | Expression for tuples.
-module Language.Symantic.Expr.Tuple where
-
-import Control.Monad
-import Data.Monoid
-import Data.Proxy (Proxy(..))
-import qualified Data.Tuple as Tuple
-import Prelude hiding (maybe, fst, snd)
-
-import Language.Symantic.Type
-import Language.Symantic.Repr
-import Language.Symantic.Expr.Root
-import Language.Symantic.Expr.Error
-import Language.Symantic.Expr.From
-import Language.Symantic.Trans.Common
-
--- * Class 'Sym_Tuple_Lam'
--- | Symantic.
-class Sym_Tuple2 repr where
- tuple2 :: repr a -> repr b -> repr (a, b)
- fst :: repr (a, b) -> repr a
- snd :: repr (a, b) -> repr b
-
- default tuple2 :: Trans t repr => t repr a -> t repr b -> t repr (a, b)
- default fst :: Trans t repr => t repr (a, b) -> t repr a
- default snd :: Trans t repr => t repr (a, b) -> t repr b
-
- tuple2 = trans_map2 tuple2
- fst = trans_map1 fst
- snd = trans_map1 snd
-instance Sym_Tuple2 Repr_Host where
- tuple2 = liftM2 (,)
- fst = liftM Tuple.fst
- snd = liftM Tuple.snd
-instance Sym_Tuple2 Repr_Text where
- tuple2 (Repr_Text a) (Repr_Text b) =
- Repr_Text $ \_p v ->
- let p' = precedence_Toplevel in
- "(" <> a p' v <> ", " <> b p' v <> ")"
- fst = repr_text_app1 "fst"
- snd = repr_text_app1 "snd"
-instance (Sym_Tuple2 r1, Sym_Tuple2 r2) => Sym_Tuple2 (Repr_Dup r1 r2) where
- tuple2 = repr_dup2 sym_Tuple2 tuple2
- fst = repr_dup1 sym_Tuple2 fst
- snd = repr_dup1 sym_Tuple2 snd
-
-sym_Tuple2 :: Proxy Sym_Tuple2
-sym_Tuple2 = Proxy
-
--- * Type 'Expr_Tuple2'
--- | Expression.
-data Expr_Tuple2 (root:: *)
-type instance Root_of_Expr (Expr_Tuple2 root) = root
-type instance Type_of_Expr (Expr_Tuple2 root) = Type_Tuple2
-type instance Sym_of_Expr (Expr_Tuple2 root) repr = Sym_Tuple2 repr
-type instance Error_of_Expr ast (Expr_Tuple2 root) = No_Error_Expr
-
--- | Parsing utility to check that the given type is a 'Type_Tuple2'
--- or raise 'Error_Expr_Type_mismatch'.
-check_type_tuple2
- :: forall ast ex root ty h ret.
- ( root ~ Root_of_Expr ex
- , ty ~ Type_Root_of_Expr ex
- , Type0_Lift Type_Tuple2 (Type_of_Expr root)
- , Type0_Unlift Type_Tuple2 (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- )
- => Proxy ex -> ast -> ty h
- -> (Type_Tuple2 ty h -> Either (Error_of_Expr ast root) ret)
- -> Either (Error_of_Expr ast root) ret
-check_type_tuple2 ex ast ty k =
- case type0_unlift $ unType_Root ty of
- Just ty_t -> k ty_t
- Nothing -> Left $
- error_expr ex $
- Error_Expr_Type_mismatch ast
- (Exists_Type0 (type_tuple2 (type_var0 SZero) (type_var0 $ SSucc SZero)
- :: ty (Var0, Var0)))
- (Exists_Type0 ty)
-
--- | Parse 'tuple2'.
-tuple2_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Tuple2 root)
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Tuple2 (Type_of_Expr root)
- , Type0_Unlift Type_Tuple2 (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast -> ast
- -> ExprFrom ast (Expr_Tuple2 root) hs ret
-tuple2_from ast_a ast_b _ex _ast ctx k =
- expr_from (Proxy::Proxy root) ast_a ctx $
- \(ty_a::ty h_a) (Forall_Repr_with_Context a) ->
- expr_from (Proxy::Proxy root) ast_b ctx $
- \(ty_b::ty h_b) (Forall_Repr_with_Context b) ->
- k (type_tuple2 ty_a ty_b) $ Forall_Repr_with_Context $
- \c -> tuple2 (a c) (b c)
-
--- | Parse 'fst'.
-fst_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Tuple2 root)
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Tuple2 (Type_of_Expr root)
- , Type0_Unlift Type_Tuple2 (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast
- -> ExprFrom ast (Expr_Tuple2 root) hs ret
-fst_from ast_t ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_t ctx $
- \(ty_t::ty h_t) (Forall_Repr_with_Context t) ->
- check_type_tuple2 ex ast ty_t $ \(Type2 _ ty_a _ty_b) ->
- k ty_a $ Forall_Repr_with_Context $
- \c -> fst (t c)
-
--- | Parse 'snd'.
-snd_from
- :: forall root ty ast hs ret.
- ( ty ~ Type_Root_of_Expr (Expr_Tuple2 root)
- , Type0_Eq ty
- , Expr_From ast root
- , Type0_Lift Type_Tuple2 (Type_of_Expr root)
- , Type0_Unlift Type_Tuple2 (Type_of_Expr root)
- , Error_Expr_Lift (Error_Expr (Error_of_Type ast ty) ty ast)
- (Error_of_Expr ast root)
- , Root_of_Expr root ~ root
- ) => ast
- -> ExprFrom ast (Expr_Tuple2 root) hs ret
-snd_from ast_t ex ast ctx k =
- expr_from (Proxy::Proxy root) ast_t ctx $
- \(ty_t::ty h_t) (Forall_Repr_with_Context t) ->
- check_type_tuple2 ex ast ty_t $ \(Type2 _ _ty_a ty_b) ->
- k ty_b $ Forall_Repr_with_Context $
- \c -> snd (t c)
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-module Language.Symantic.Lib.Control.Monad where
-
-import Control.Monad (liftM2, liftM3, liftM4, join)
-
--- * 'Monad'ic utilities
-
--- | Perform some operation on 'Just', given the field inside the 'Just'.
-whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
-whenJust mg f = maybe (pure ()) f mg
-
--- | Like 'when', but where the test can be 'Monad'-ic.
-whenM :: Monad m => m Bool -> m () -> m ()
-whenM b t = ifM b t (return ())
-
--- | Like 'unless', but where the test can be 'Monad'-ic.
-unlessM :: Monad m => m Bool -> m () -> m ()
-unlessM b = ifM b (return ())
-
--- | Like @if@, but where the test can be 'Monad'-ic.
-ifM :: Monad m => m Bool -> m a -> m a -> m a
-ifM b t f = do b' <- b; if b' then t else f
-
--- | Like 'liftM' but 'join' the result of the lifted function.
-liftMJoin :: Monad m => (a -> m b) -> m a -> m b
-liftMJoin = (=<<)
-
--- | Like 'liftM2' but 'join' the result of the lifted function.
-liftM2Join :: Monad m => (a -> b -> m c) -> m a -> m b -> m c
-liftM2Join f ma mb = join (liftM2 f ma mb)
-
--- | Like 'liftM3' but 'join' the result of the lifted function.
-liftM3Join :: Monad m => (a -> b -> c -> m d) -> m a -> m b -> m c -> m d
-liftM3Join f ma mb mc = join (liftM3 f ma mb mc)
-
--- | Like 'liftM3' but 'join' the result of the lifted function.
-liftM4Join :: Monad m => (a -> b -> c -> d -> m e) -> m a -> m b -> m c -> m d -> m e
-liftM4Join f ma mb mc md = join (liftM4 f ma mb mc md)
+++ /dev/null
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE TypeFamilies #-}
-module Language.Symantic.Lib.Data.Bool where
-
--- * Type 'SBool'
--- | Singleton for 'Bool'.
-data SBool b where
- STrue :: SBool 'True
- SFalse :: SBool 'False
-
--- * Class 'IBool'
--- | Implicitely construct a 'SBool' from a type of kind 'Bool'.
-class IBool b where iBool :: SBool b
-instance IBool 'True where iBool = STrue
-instance IBool 'False where iBool = SFalse
-
--- * Type family 'HEq'
--- | Host-type equality.
-type family HEq x y :: Bool where
- HEq x x = 'True
- HEq x y = 'False
-- | Natural numbers at the type-level, and of kind @*@.
module Language.Symantic.Lib.Data.Peano where
-import Data.Type.Equality ((:~:)(Refl))
+import Data.Type.Equality
-- * Types 'Zero' and 'Succ'
--- | Type-level peano numbers of kind '*'.
data Zero
data Succ p
type P1 = Succ P0
type P2 = Succ P1
type P3 = Succ P2
+-- ...
-- * Type 'SPeano'
-- | Singleton for 'Zero' and 'Succ'.
data SPeano p where
SZero :: SPeano Zero
SSucc :: SPeano p -> SPeano (Succ p)
+instance TestEquality SPeano where
+ testEquality SZero SZero = Just Refl
+ testEquality (SSucc x) (SSucc y)
+ | Just Refl <- testEquality x y
+ = Just Refl
+ testEquality _ _ = Nothing
-- * Type 'IPeano'
-- | Implicit construction of 'SPeano'.
EPeano :: SPeano p -> EPeano
instance Eq EPeano where
EPeano x == EPeano y =
- (integral_from_peano x::Integer) ==
- integral_from_peano y
+ case testEquality x y of
+ Just _ -> True
+ _ -> False
+instance Show EPeano where
+ show (EPeano x) = show (integral_from_peano x::Integer)
+-- * Interface with 'Integral'
integral_from_peano :: Integral i => SPeano p -> i
integral_from_peano SZero = 0
integral_from_peano (SSucc x) = 1 + integral_from_peano x
peano_from_integral i k | i > 0 =
peano_from_integral (i - 1) $ \p -> k (SSucc p)
peano_from_integral _ _ = error "peano_from_integral"
-
-peano_eq :: forall x y. SPeano x -> SPeano y -> Maybe (x :~: y)
-peano_eq SZero SZero = Just Refl
-peano_eq (SSucc x) (SSucc y)
- | Just Refl <- x `peano_eq` y
- = Just Refl
-peano_eq _ _ = Nothing
-
-{-
--- * Type family '<='
-type family n <= m :: Bool where
- Zero <= m = 'True
- n <= Zero = 'False
- Succ n <= Succ m = n <= m
-
--- * Type 'VList'
--- | Vector list.
-data VList :: * -> * -> * where
- VNil :: VList Zero a
- (:::) :: a -> VList p a -> VList (Succ p) a
-infixr 5 :::
--}
+++ /dev/null
--- | Interpreters of expressions.
-module Language.Symantic.Repr
- ( module Language.Symantic.Repr.Dup
- , module Language.Symantic.Repr.Host
- , module Language.Symantic.Repr.Text
- ) where
-
-import Language.Symantic.Repr.Dup
-import Language.Symantic.Repr.Host
-import Language.Symantic.Repr.Text
+++ /dev/null
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
--- | Interpreter to duplicate the representation of an expression
--- in order to evaluate it with different interpreters.
---
--- NOTE: this is a more verbose, less clear,
--- and maybe less efficient alternative
--- to maintaining the universal polymorphism of @repr@ at parsing time
--- as done with 'Forall_Repr_with_Context';
--- it is mainly here for the sake of curiosity.
-module Language.Symantic.Repr.Dup where
-
-import Data.Proxy
-
--- | Interpreter's data.
-data Repr_Dup repr1 repr2 a
- = Repr_Dup
- { repr_dup_1 :: repr1 a
- , repr_dup_2 :: repr2 a
- }
-
-repr_dup0
- :: (cl r, cl s)
- => Proxy cl
- -> (forall repr. cl repr => repr a)
- -> Repr_Dup r s a
-repr_dup0 _cl f = f `Repr_Dup` f
-
-repr_dup1
- :: (cl r, cl s)
- => Proxy cl
- -> (forall repr. cl repr => repr a -> repr b)
- -> Repr_Dup r s a
- -> Repr_Dup r s b
-repr_dup1 _cl f (a1 `Repr_Dup` a2) =
- f a1 `Repr_Dup` f a2
-
-repr_dup2
- :: (cl r, cl s)
- => Proxy cl
- -> (forall repr. cl repr => repr a -> repr b -> repr c)
- -> Repr_Dup r s a
- -> Repr_Dup r s b
- -> Repr_Dup r s c
-repr_dup2 _cl f (a1 `Repr_Dup` a2) (b1 `Repr_Dup` b2) =
- f a1 b1 `Repr_Dup` f a2 b2
-
-repr_dup3
- :: (cl r, cl s)
- => Proxy cl
- -> (forall repr. cl repr => repr a -> repr b -> repr c -> repr d)
- -> Repr_Dup r s a
- -> Repr_Dup r s b
- -> Repr_Dup r s c
- -> Repr_Dup r s d
-repr_dup3 _cl f (a1 `Repr_Dup` a2) (b1 `Repr_Dup` b2) (c1 `Repr_Dup` c2) =
- f a1 b1 c1 `Repr_Dup` f a2 b2 c2
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
--- | Interpreter to compute a host-term.
-module Language.Symantic.Repr.Host where
-
--- * Type 'Repr_Host'
-
--- | Interpreter's data.
-newtype Repr_Host h = Repr_Host { unRepr_Host :: h }
-instance Functor Repr_Host where
- fmap f (Repr_Host a) = Repr_Host (f a)
-instance Applicative Repr_Host where
- pure = Repr_Host
- (Repr_Host f) <*> (Repr_Host a) = Repr_Host (f a)
-instance Monad Repr_Host where
- return = Repr_Host
- (Repr_Host a) >>= f = f a
-
--- | Interpreter.
-host_from_expr :: Repr_Host h -> h
-host_from_expr = unRepr_Host
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Repr.Host.Test where
-
--- import Data.Function (($))
-import Test.Tasty
-import Test.Tasty.HUnit
-
-import Data.Text (Text)
-import qualified Data.Text as Text
-import Prelude hiding (and, not, or, Monad(..), id)
-
-import Language.Symantic.Repr
-import Language.Symantic.Expr
-import qualified Expr.Lambda.Test as Lambda.Test
-import qualified Expr.Bool.Test as Bool.Test
-import qualified Expr.Maybe.Test as Maybe.Test
-import qualified Expr.If.Test as If.Test
-import qualified Expr.List.Test as List.Test
-import qualified Expr.Functor.Test as Functor.Test
-import qualified Expr.Applicative.Test as Applicative.Test
-import qualified Expr.Foldable.Test as Foldable.Test
-
-tests :: TestTree
-tests = testGroup "Host" $
- [ testGroup "Bool" $
- let (==>) (expr::forall repr. Sym_of_Expr (Expr_Root ( Expr_Lambda
- .|. Expr_Bool
- )) repr => repr h) expected =
- testCase (Text.unpack $ text_from_expr $ expr) $
- -- (>>= (@?= expected)) $
- (@?= expected) $
- host_from_expr expr in
- [ Bool.Test.e1 ==> False
- , Bool.Test.e2 ==> True
- , Bool.Test.e3 ==> True
- , Bool.Test.e4 ==> True
- ]
- , testGroup "Lambda" $
- let (==>) (expr::forall repr. Sym_of_Expr (Expr_Root ( Expr_Lambda
- .|. Expr_Bool
- )) repr => repr h) expected =
- testCase (Text.unpack $ text_from_expr $ expr) $
- (@?= expected) $
- host_from_expr expr in
- [ (Lambda.Test.e1 $$ bool True $$ bool True) ==> False
- , (Lambda.Test.e1 $$ bool True $$ bool False) ==> True
- , (Lambda.Test.e1 $$ bool False $$ bool True) ==> True
- , (Lambda.Test.e1 $$ bool False $$ bool False) ==> False
-
- , (Lambda.Test.e2 $$ bool True $$ bool True) ==> False
- , (Lambda.Test.e2 $$ bool True $$ bool False) ==> True
- , (Lambda.Test.e2 $$ bool False $$ bool True) ==> True
- , (Lambda.Test.e2 $$ bool False $$ bool False) ==> False
-
- , Lambda.Test.e3 ==> True
- , Lambda.Test.e4 ==> True
-
- , (Lambda.Test.e5 $$ bool True $$ bool True) ==> True
- , (Lambda.Test.e5 $$ bool True $$ bool False) ==> False
- , (Lambda.Test.e5 $$ bool False $$ bool True) ==> False
- , (Lambda.Test.e5 $$ bool False $$ bool False) ==> False
-
- , Lambda.Test.e6 ==> False
- , (Lambda.Test.e7 $$ lam id) ==> True
- , (Lambda.Test.e7 $$ lam not) ==> False
- ]
- , testGroup "Maybe" $
- let (==>) (expr::forall repr. Sym_of_Expr (Expr_Root ( Expr_Lambda
- .|. Expr_Maybe
- .|. Expr_Bool )) repr => repr h) expected =
- testCase (Text.unpack $ text_from_expr $ expr) $
- (@?= expected) $
- host_from_expr expr in
- [ Maybe.Test.e1 ==> False
- ]
- , testGroup "If" $
- let (==>) (expr::forall repr. Sym_of_Expr (Expr_Root ( Expr_Lambda
- .|. Expr_If
- .|. Expr_Bool )) repr => repr h) expected =
- testCase (Text.unpack $ text_from_expr $ expr) $
- (@?= expected) $
- host_from_expr expr in
- [ If.Test.e1 ==> False
- ]
- , testGroup "List" $
- let (==>) (expr::forall repr. Sym_of_Expr (Expr_Root ( Expr_Lambda
- .|. Expr_List
- .|. Expr_Bool
- .|. Expr_Int
- .|. Expr_Num
- .|. Expr_Integral
- .|. Expr_If
- .|. Expr_Eq )) repr => repr h) expected =
- testCase (Text.unpack $ text_from_expr $ expr) $
- (@?= expected) $
- host_from_expr expr in
- [ List.Test.e1 ==> [2::Int,4]
- ]
- , testGroup "Functor" $
- let (==>) (expr::forall repr. Sym_of_Expr (Expr_Root ( Expr_Lambda
- .|. Expr_List
- .|. Expr_Functor
- .|. Expr_Bool
- .|. Expr_Int
- .|. Expr_Num
- .|. Expr_If
- .|. Expr_Eq )) repr => repr h) expected =
- testCase (Text.unpack $ (text_from_expr :: Repr_Text _h -> Text) $ expr) $
- (@?= expected) $
- host_from_expr expr in
- [ Functor.Test.e1 ==> [2::Int,3,4]
- ]
- , testGroup "Applicative" $
- let (==>) (expr::forall repr. Sym_of_Expr (Expr_Root ( Expr_Lambda
- .|. Expr_List
- .|. Expr_Functor
- .|. Expr_Applicative
- .|. Expr_Maybe
- .|. Expr_Bool
- .|. Expr_Int
- .|. Expr_Num
- .|. Expr_If
- .|. Expr_Eq )) repr => repr h) expected =
- testCase (Text.unpack $ text_from_expr $ expr) $
- (@?= expected) $
- host_from_expr expr in
- [ Applicative.Test.e1 ==> Just (3::Int)
- ]
- , testGroup "Foldable" $
- let (==>) (expr::forall repr. Sym_of_Expr (Expr_Root ( Expr_Lambda
- .|. Expr_List
- .|. Expr_Foldable
- .|. Expr_Maybe
- .|. Expr_Bool
- .|. Expr_Int
- .|. Expr_Num
- .|. Expr_If
- .|. Expr_Eq )) repr => repr h) expected =
- testCase (Text.unpack $ text_from_expr $ expr) $
- (@?= expected) $
- host_from_expr expr in
- [ Foldable.Test.e1 ==> [1::Int,1,2,2,3,3]
- ]
- ]
+++ /dev/null
-module Repr.Test where
-
-import Test.Tasty
-import qualified Repr.Host.Test as Host
-import qualified Repr.Text.Test as Text
-
-tests :: TestTree
-tests =
- testGroup "Repr"
- [ Host.tests
- , Text.tests
- ]
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
--- | Interpreter to serialize an expression into a 'Text'.
-module Language.Symantic.Repr.Text where
-
-import Data.Monoid ((<>))
-import Data.String (IsString(..))
-import Data.Text (Text)
-import qualified Data.Text as Text
-import Prelude hiding (Integral(..))
-
--- * Type 'Repr_Text'
-
--- | Interpreter's data.
-newtype Repr_Text h
- = Repr_Text
- { unRepr_Text
- -- Inherited attributes:
- :: Precedence
- -> Repr_Text_Lambda_Depth
- -- Synthetised attributes:
- -> Text
- }
-type Repr_Text_Lambda_Depth = Int
-instance Show (Repr_Text h) where
- show = Text.unpack . text_from_expr
-
--- | Interpreter.
-text_from_expr :: Repr_Text h -> Text
-text_from_expr r = unRepr_Text r precedence_Toplevel 0
-
--- * Helpers
-
--- ** Helpers for lambda applications
-repr_text_app0 :: Text -> Repr_Text h
-repr_text_app0 name = Repr_Text $ \_p _v -> name
-repr_text_app1
- :: Text
- -> Repr_Text a1
- -> Repr_Text h
-repr_text_app1 name (Repr_Text a1) =
- Repr_Text $ \p v ->
- let p' = precedence_App in
- paren p p' $ name
- <> " " <> a1 p' v
-repr_text_app2
- :: Text
- -> Repr_Text a1
- -> Repr_Text a2
- -> Repr_Text h
-repr_text_app2 name (Repr_Text a1) (Repr_Text a2) =
- Repr_Text $ \p v ->
- let p' = precedence_App in
- paren p p' $ name
- <> " " <> a1 p' v
- <> " " <> a2 p' v
-repr_text_app3
- :: Text
- -> Repr_Text a1
- -> Repr_Text a2
- -> Repr_Text a3
- -> Repr_Text h
-repr_text_app3 name (Repr_Text a1) (Repr_Text a2) (Repr_Text a3) =
- Repr_Text $ \p v ->
- let p' = precedence_App in
- paren p p' $ name
- <> " " <> a1 p' v
- <> " " <> a2 p' v
- <> " " <> a3 p' v
-repr_text_infix
- :: Text
- -> Precedence
- -> Repr_Text a1
- -> Repr_Text a2
- -> Repr_Text h
-repr_text_infix name p' (Repr_Text a1) (Repr_Text a2) =
- Repr_Text $ \p v ->
- paren p p' $ a1 p' v <> " " <> name <> " " <> a2 p' v
-
--- ** Type 'Precedence'
-
-newtype Precedence = Precedence Int
- deriving (Eq, Ord, Show)
-precedence_pred :: Precedence -> Precedence
-precedence_pred (Precedence p) = Precedence (pred p)
-precedence_succ :: Precedence -> Precedence
-precedence_succ (Precedence p) = Precedence (succ p)
-paren :: (Monoid s, IsString s) => Precedence -> Precedence -> s -> s
-paren prec prec' x =
- if prec >= prec'
- then fromString "(" <> x <> fromString ")"
- else x
-
-precedence_Toplevel :: Precedence
-precedence_Toplevel = Precedence 0
-precedence_App :: Precedence
-precedence_App = Precedence 10
-precedence_Atomic :: Precedence
-precedence_Atomic = Precedence maxBound
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-module Repr.Text.Test where
-
-import Test.Tasty
-import Test.Tasty.HUnit
-
-import qualified Data.Text as Text
-
-import Language.Symantic.Repr
-import qualified Expr.Lambda.Test as Lambda.Test
-import qualified Expr.Bool.Test as Bool.Test
-import qualified Expr.Maybe.Test as Maybe.Test
-import qualified Expr.Eq.Test as Eq.Test
-import qualified Expr.If.Test as If.Test
-import qualified Expr.List.Test as List.Test
-import qualified Expr.Functor.Test as Functor.Test
-import qualified Expr.Applicative.Test as Applicative.Test
-import qualified Expr.Foldable.Test as Foldable.Test
-import qualified Expr.Map.Test as Map.Test
-
-tests :: TestTree
-tests = testGroup "Text" $
- let (==>) expr expected =
- testCase (Text.unpack expected) $
- (@?= expected) $
- text_from_expr expr in
- [ testGroup "Bool"
- [ Bool.Test.e1 ==> "True && False"
- , Bool.Test.e2 ==> "True && False || True && True"
- , Bool.Test.e3 ==> "(True || False) && (True || True)"
- , Bool.Test.e4 ==> "True && not False"
- , Bool.Test.e5 ==> "True && not x"
- , Bool.Test.e6 ==> "x `xor` y"
- , Bool.Test.e7 ==> "(x `xor` y) `xor` z"
- , Bool.Test.e8 ==> "x `xor` (y `xor` True)"
- ]
- , testGroup "Lambda"
- [ Lambda.Test.e1 ==> "\\x0 -> (\\x1 -> (x0 || x1) && not (x0 && x1))"
- , Lambda.Test.e2 ==> "\\x0 -> (\\x1 -> x0 && not x1 || not x0 && x1)"
- , Lambda.Test.e3 ==> "let x0 = True in x0 && x0"
- , Lambda.Test.e4 ==> "let x0 = \\x1 -> x1 && x1 in x0 True"
- , Lambda.Test.e5 ==> "\\x0 -> (\\x1 -> x0 && x1)"
- , Lambda.Test.e6 ==> "(let x0 = True in id x0) && False"
- , Lambda.Test.e7 ==> "\\x0 -> x0 True && True"
- , Lambda.Test.e8 ==> "\\x0 -> x0 (True && True)"
- ]
- , testGroup "Maybe"
- [ Maybe.Test.e1 ==> "maybe True (\\x0 -> not x0) (just True)"
- ]
- , testGroup "Eq"
- [ Eq.Test.e1 ==> "if True && True == True || False then True else False"
- , Eq.Test.e2 ==> "if True && True || False == True && (True || False) then True else False"
- , Eq.Test.e3 ==> "if not (True == False) == (True == True) then True else False"
- ]
- , testGroup "If"
- [ If.Test.e1 ==> "if True then False else True"
- , If.Test.e2 ==> "if True && True then False else True"
- ]
- , testGroup "List"
- [ List.Test.e1 ==> "list_filter (\\x0 -> if x0 `mod` 2 == 0 then True else False) [1, 2, 3, 4, 5]"
- ]
- , testGroup "Functor"
- [ Functor.Test.e1 ==> "fmap (\\x0 -> x0 + 1) [1, 2, 3]"
- ]
- , testGroup "Applicative"
- [ Applicative.Test.e1 ==> "fmap (\\x0 -> (\\x1 -> x0 + x1)) (just 1) <*> just 2"
- ]
- , testGroup "Foldable"
- [ Foldable.Test.e1 ==> "foldMap (\\x0 -> [x0, x0]) [1, 2, 3]"
- ]
- , testGroup "Map"
- [ Map.Test.e1 ==> "map_from_list (list_zipWith (\\x0 -> (\\x1 -> (x0, x1))) [1, 2, 3, 4, 5] [\"a\", \"b\", \"c\", \"d\", \"e\"])"
- ]
- ]
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
module Test where
import Test.Tasty
-import qualified Expr.Test as Expr
-import qualified Repr.Test as Repr
-import qualified Type.Test as Type
-import qualified Trans.Test as Trans
+import qualified Typing.Test as Typing
main :: IO ()
main =
defaultMain $
testGroup "Language.Symantic"
- [ Type.tests
- , Repr.tests
- , Expr.tests
- , Trans.tests
+ [ Typing.tests
]
+++ /dev/null
--- | Transformers of expressions
--- (a special family of interpreters).
-module Language.Symantic.Trans
- ( module Language.Symantic.Trans.Common
- , module Language.Symantic.Trans.Bool
- ) where
-
-import Language.Symantic.Trans.Common
-import Language.Symantic.Trans.Bool
+++ /dev/null
--- | Transformers acting on booleans.
-module Language.Symantic.Trans.Bool
- ( module Language.Symantic.Trans.Bool.Const
- ) where
-
-import Language.Symantic.Trans.Bool.Const
+++ /dev/null
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-
--- | Transformer propagating boolean constants.
-module Language.Symantic.Trans.Bool.Const where
-
-import qualified Data.Bool as Bool
-import Prelude hiding ((&&), not, (||))
-
-import Language.Symantic.Trans.Common
-import Language.Symantic.Expr.Bool
-
--- * Type 'Trans_Bool_Const'
-
--- | Annotation.
-data Trans_Bool_Const repr h where
- Trans_Bool_Const_Unknown :: repr h -> Trans_Bool_Const repr h
- Trans_Bool_Const_Known :: Bool -> Trans_Bool_Const repr Bool
-
-instance
- Sym_Bool repr =>
- Trans Trans_Bool_Const repr where
- trans_lift = Trans_Bool_Const_Unknown
- trans_apply (Trans_Bool_Const_Unknown x) = x
- trans_apply (Trans_Bool_Const_Known x) = bool x
-
-instance
- Sym_Bool repr =>
- Sym_Bool (Trans_Bool_Const repr) where
- bool = Trans_Bool_Const_Known
-
- not (Trans_Bool_Const_Unknown e) = Trans_Bool_Const_Unknown $ not e
- not (Trans_Bool_Const_Known x) = Trans_Bool_Const_Known $ Bool.not x
-
- (&&) (Trans_Bool_Const_Known True) y = y
- (&&) (Trans_Bool_Const_Known False) _y = Trans_Bool_Const_Known False
- (&&) x (Trans_Bool_Const_Known True) = x
- (&&) _x (Trans_Bool_Const_Known False) = Trans_Bool_Const_Known False
- (&&) (Trans_Bool_Const_Unknown x)
- (Trans_Bool_Const_Unknown y)
- = Trans_Bool_Const_Unknown $ (&&) x y
-
- (||) (Trans_Bool_Const_Known False) y = y
- (||) (Trans_Bool_Const_Known True) _y = Trans_Bool_Const_Known True
- (||) x (Trans_Bool_Const_Known False) = x
- (||) _x (Trans_Bool_Const_Known True) = Trans_Bool_Const_Known True
- (||) (Trans_Bool_Const_Unknown x)
- (Trans_Bool_Const_Unknown y)
- = Trans_Bool_Const_Unknown $ (||) x y
-
--- | Transformer.
-trans_bool_const
- :: Sym_Bool repr
- => (Trans_Bool_Const repr) h -> repr h
-trans_bool_const = trans_apply
+++ /dev/null
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Trans.Bool.Const.Test where
-
-import Test.Tasty
-import Test.Tasty.HUnit
-
-import qualified Data.Text as Text
-
-import qualified Expr.Bool.Test as Bool
-import qualified Repr.Text.Test ()
-import Language.Symantic.Repr
-import Language.Symantic.Trans
-
-tests :: TestTree
-tests = testGroup "Const" $
- let (==>) expr expected =
- testCase (Text.unpack expected) $
- (@?= expected) $
- text_from_expr (trans_bool_const expr) in
- [ Bool.e1 ==> "False"
- , Bool.e2 ==> "True"
- , Bool.e3 ==> "True"
- , Bool.e4 ==> "True"
- , Bool.e5 ==> "not x"
- , Bool.e6 ==> "(x || y) && not (x && y)"
- , Bool.e7 ==> "((x || y) && not (x && y) || z) && not (((x || y) && not (x && y)) && z)"
- , Bool.e8 ==> "(x || not y) && not (x && not y)"
- ]
-
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-module Trans.Bool.Test where
-
-import Test.Tasty
-import qualified Trans.Bool.Const.Test as Const
-
-tests :: TestTree
-tests =
- testGroup "Bool"
- [ Const.tests
- ]
+++ /dev/null
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-module Language.Symantic.Trans.Common where
-
--- |
--- * 'trans_lift' is generally not /surjective/
--- * 'trans_apply' is not /injective/
--- * 'trans_apply' . 'trans_lift' == 'id'
--- * 'trans_lift' . 'trans_apply' /= 'id'
---
--- NOTE: @DefaultSignatures@ can be used
--- when declaring a symantic type class
--- to provide default definition of the methods:
--- implementing their identity transformation
--- in order to avoid boilerplate code
--- when writting 'Trans' instances which
--- do not need to alterate those methods.
-class Trans t repr where
- -- | Lift an interpreter to the transformer's.
- trans_lift :: repr a -> t repr a
- -- | Unlift an interpreter from the transformer's.
- trans_apply :: t repr a -> repr a
-
- -- | Convenient method to define the identity transformation for a unary symantic method.
- trans_map1 :: (repr a -> repr b) -> (t repr a -> t repr b)
- trans_map1 f = trans_lift . f . trans_apply
-
- -- | Convenient method to define the identity transformation for a binary symantic method.
- trans_map2
- :: (repr a -> repr b -> repr c)
- -> (t repr a -> t repr b -> t repr c)
- trans_map2 f e1 e2 = trans_lift (trans_apply e1 `f` trans_apply e2)
-
- -- | Convenient method to define the identity transformation for a terary symantic method.
- trans_map3
- :: (repr a -> repr b -> repr c -> repr d)
- -> (t repr a -> t repr b -> t repr c -> t repr d)
- trans_map3 f e1 e2 e3 = trans_lift $ f (trans_apply e1) (trans_apply e2) (trans_apply e3)
-
--- | Closed type family extracting the representation
--- upon which a transformer is applied.
---
--- This is useful to write default associated types in symantics.
-type family Repr_of_Trans (repr :: * -> *) :: (* -> *) where
- Repr_of_Trans (t repr) = repr
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-module Trans.Test where
-
-import Test.Tasty
-import qualified Trans.Bool.Test as Bool
-
-tests :: TestTree
-tests =
- testGroup "Trans"
- [ Bool.tests
- ]
+++ /dev/null
--- | Types for the expressions.
-module Language.Symantic.Type
- ( module Language.Symantic.Type.Root
- , module Language.Symantic.Type.Alt
- , module Language.Symantic.Type.Error
- , module Language.Symantic.Type.Type0
- , module Language.Symantic.Type.Type1
- , module Language.Symantic.Type.Type2
- , module Language.Symantic.Type.Constraint
- , module Language.Symantic.Type.Family
- , module Language.Symantic.Type.Var
- , module Language.Symantic.Type.Fun
- , module Language.Symantic.Type.Unit
- , module Language.Symantic.Type.Bool
- , module Language.Symantic.Type.Int
- , module Language.Symantic.Type.Integer
- , module Language.Symantic.Type.Char
- , module Language.Symantic.Type.IO
- , module Language.Symantic.Type.Maybe
- , module Language.Symantic.Type.List
- , module Language.Symantic.Type.Ordering
- , module Language.Symantic.Type.Tuple
- , module Language.Symantic.Type.Map
- , module Language.Symantic.Type.Either
- , module Language.Symantic.Type.Text
- ) where
-
-import Language.Symantic.Type.Root
-import Language.Symantic.Type.Alt
-import Language.Symantic.Type.Error
-import Language.Symantic.Type.Type0
-import Language.Symantic.Type.Type1
-import Language.Symantic.Type.Type2
-import Language.Symantic.Type.Constraint
-import Language.Symantic.Type.Family
-import Language.Symantic.Type.Var
-import Language.Symantic.Type.Fun
-import Language.Symantic.Type.Unit
-import Language.Symantic.Type.Bool
-import Language.Symantic.Type.Int
-import Language.Symantic.Type.Integer
-import Language.Symantic.Type.Char
-import Language.Symantic.Type.IO
-import Language.Symantic.Type.Maybe
-import Language.Symantic.Type.List
-import Language.Symantic.Type.Ordering
-import Language.Symantic.Type.Tuple
-import Language.Symantic.Type.Map
-import Language.Symantic.Type.Either
-import Language.Symantic.Type.Text
+++ /dev/null
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-module Language.Symantic.Type.Alt where
-
-import Language.Symantic.Type.Root
-
--- * Type 'Type_Alt'
--- | Type making an alternative between two types.
-data Type_Alt curr next (root:: * -> *) h
- = Type_Alt_Curr (curr root h)
- | Type_Alt_Next (next root h)
--- | Convenient alias. Requires @TypeOperators@.
-type (:|:) = Type_Alt
-infixr 5 :|:
-type instance Root_of_Type (Type_Alt curr next root) = root
-
--- * Type family 'Is_Last_Type'
--- | Return whether a given type is the last one in a given type stack.
---
--- NOTE: each type parser uses this type family
--- when it encounters unsupported syntax:
--- to know if it is the last type parser component that will be tried
--- (and thus return 'Error_Type_Unsupported')
--- or if some other type parser component shall be tried
--- (and thus return 'Error_Type_Unsupported_here',
--- which is then handled accordingly by the 'Type0_From' instance of 'Type_Alt').
-type family Is_Last_Type (ty:: * -> *) (tys:: * -> *) :: Bool where
- Is_Last_Type ty ty = 'True
- Is_Last_Type ty (Type_Root tys) = Is_Last_Type ty (tys (Type_Root tys))
- Is_Last_Type (ty root) (Type_Alt ty next root) = 'False
- Is_Last_Type other (Type_Alt curr next root) = Is_Last_Type other (next root)
-
--- * Type 'No_Type'
--- | A discarded type.
-data No_Type (root:: * -> *) h
- = No_Type (root h)
- deriving (Eq, Show)
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Language.Symantic.Type.Bool where
-
-import Data.Proxy
-import Language.Symantic.Type.Root
-import Language.Symantic.Type.Type0
-import Language.Symantic.Type.Constraint
-import Language.Symantic.Type.Family
-import qualified Data.MonoTraversable as MT
-
--- * Type 'Type_Bool'
--- | The 'Bool' type.
-type Type_Bool = Type0 (Proxy Bool)
-
-pattern Type_Bool :: Type_Bool root Bool
-pattern Type_Bool = Type0 Proxy
-
-instance Type0_Constraint Eq (Type_Bool root) where
- type0_constraint _c Type0{} = Just Dict
-instance Type0_Constraint Ord (Type_Bool root) where
- type0_constraint _c Type0{} = Just Dict
-instance Type0_Constraint Monoid (Type_Bool root)
-instance Type0_Constraint Num (Type_Bool root)
-instance Type0_Constraint Integral (Type_Bool root)
-instance Type0_Family Type_Family_MonoElement (Type_Bool root)
-instance Type0_Constraint MT.MonoFunctor (Type_Bool root)
-instance String_from_Type (Type_Bool root) where
- string_from_type _ = "Bool"
-
--- | Inject 'Type_Bool' within a root type.
-type_bool :: Type_Root_Lift Type_Bool root => root Bool
-type_bool = type0
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Language.Symantic.Type.Char where
-
-import qualified Data.MonoTraversable as MT
-import Data.Proxy
-
-import Language.Symantic.Type.Root
-import Language.Symantic.Type.Type0
-import Language.Symantic.Type.Constraint
-import Language.Symantic.Type.Family
-
--- * Type 'Type_Char'
--- | The 'Char' type.
-type Type_Char = Type0 (Proxy Char)
-
-pattern Type_Char :: Type_Char root Char
-pattern Type_Char = Type0 Proxy
-
-instance Type0_Constraint Eq (Type_Char root) where
- type0_constraint _c Type0{} = Just Dict
-instance Type0_Constraint Ord (Type_Char root) where
- type0_constraint _c Type0{} = Just Dict
-instance Type0_Constraint Monoid (Type_Char root)
-instance Type0_Constraint Num (Type_Char root)
-instance Type0_Constraint Integral (Type_Char root)
-instance Type0_Family Type_Family_MonoElement (Type_Char root)
-instance Type0_Constraint MT.MonoFunctor (Type_Char root)
-instance String_from_Type (Type_Char root) where
- string_from_type _ = "Char"
-
--- | Inject 'Type_Char' within a root type.
-type_char :: Type_Root_Lift Type_Char root => root Char
-type_char = type0
+++ /dev/null
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Language.Symantic.Type.Constraint where
-
-import Data.Proxy
-import GHC.Prim (Constraint)
-
-import Language.Symantic.Type.Root
-import Language.Symantic.Type.Alt
-import Language.Symantic.Type.Error
-import Language.Symantic.Type.Type0
-
--- * Type 'Dict'
--- | 'Dict' captures the dictionary of a 'Constraint':
--- pattern matching on the 'Dict' constructor
--- brings the 'Constraint' into scope.
-data Dict :: Constraint -> * where
- Dict :: c => Dict c
-
--- * Class 'Type0_Constraint'
--- | Test if a type satisfies a given 'Constraint',
--- returning an Haskell type-level proof
--- of that satisfaction when it holds.
-class Type0_Constraint (c:: * -> Constraint) (ty:: * -> *) where
- type0_constraint :: forall h. Proxy c -> ty h -> Maybe (Dict (c h))
- type0_constraint _c _ = Nothing
-instance -- Type_Root
- Type0_Constraint c (ty (Type_Root ty)) =>
- Type0_Constraint c (Type_Root ty) where
- type0_constraint c (Type_Root ty) = type0_constraint c ty
-instance -- Type_Alt
- ( Type0_Constraint c (curr root)
- , Type0_Constraint c (next root)
- ) => Type0_Constraint c (Type_Alt curr next root) where
- type0_constraint c (Type_Alt_Curr ty) = type0_constraint c ty
- type0_constraint c (Type_Alt_Next ty) = type0_constraint c ty
-
--- | Parsing utility to check that a type is an instance of a given 'Constraint',
--- or raise 'Error_Type_Constraint_missing'.
-check_type_type0_constraint
- :: forall ast c root ty h ret.
- ( root ~ Root_of_Type ty
- , Error_Type_Lift (Error_Type ast) (Error_of_Type ast root)
- , Type0_Constraint c ty
- ) => Proxy c -> ast -> ty h
- -> (Dict (c h) -> Either (Error_of_Type ast root) ret)
- -> Either (Error_of_Type ast root) ret
-check_type_type0_constraint c ast ty k =
- case type0_constraint c ty of
- Just Dict -> k Dict
- Nothing -> Left $ error_type_lift $
- Error_Type_Constraint_missing ast -- (Exists_Type0 ty_k)
-
--- * Class 'Type1_Constraint'
--- | Test if a type constructor satisfies a given 'Constraint',
--- returning an Haskell type-level proof
--- of that satisfaction when it holds.
-class Type1_Constraint (c:: (* -> *) -> Constraint) (ty:: * -> *) where
- type1_constraint :: forall h1 h. Proxy c -> ty (h1 h) -> Maybe (Dict (c h1))
- type1_constraint _c _ = Nothing
-instance -- Type_Root
- Type1_Constraint c (ty (Type_Root ty)) =>
- Type1_Constraint c (Type_Root ty) where
- type1_constraint c (Type_Root ty) = type1_constraint c ty
-instance -- Type_Alt
- ( Type1_Constraint c (curr root)
- , Type1_Constraint c (next root)
- ) => Type1_Constraint c (Type_Alt curr next root) where
- type1_constraint c (Type_Alt_Curr ty) = type1_constraint c ty
- type1_constraint c (Type_Alt_Next ty) = type1_constraint c ty
-instance Type1_Constraint c (Type0 px root)
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Language.Symantic.Type.Either where
-
-import Data.Proxy
-import Data.Type.Equality ((:~:)(Refl))
-import qualified Data.MonoTraversable as MT
-
-import Language.Symantic.Type.Root
-import Language.Symantic.Type.Type0
-import Language.Symantic.Type.Type1
-import Language.Symantic.Type.Type2
-import Language.Symantic.Type.Constraint
-import Language.Symantic.Type.Family
-
--- * Type 'Type_Either'
--- | The 'Either' type.
-type Type_Either = Type2 (Proxy Either)
-
-pattern Type_Either
- :: root l -> root r
- -> Type_Either root (Either l r)
-pattern Type_Either l r
- = Type2 Proxy l r
-
-instance Type1_Unlift Type_Either where
- type1_unlift (Type2 px a b) k =
- k ( Type1 (Proxy::Proxy (Either a)) b
- , Type1_Lift (\(Type1 _ b') -> Type2 px a b')
- )
-instance Type0_Eq root => Type1_Eq (Type_Either root) where
- type1_eq (Type2 _ a1 _b1) (Type2 _ a2 _b2)
- | Just Refl <- type0_eq a1 a2
- = Just Refl
- type1_eq _ _ = Nothing
-instance
- Type0_Constraint Eq root =>
- Type0_Constraint Eq (Type_Either root) where
- type0_constraint c (Type2 _ l r)
- | Just Dict <- type0_constraint c l
- , Just Dict <- type0_constraint c r
- = Just Dict
- type0_constraint _c _ = Nothing
-instance
- Type0_Constraint Ord root =>
- Type0_Constraint Ord (Type_Either root) where
- type0_constraint c (Type2 _ l r)
- | Just Dict <- type0_constraint c l
- , Just Dict <- type0_constraint c r
- = Just Dict
- type0_constraint _c _ = Nothing
-instance Type0_Constraint Num (Type_Either root)
-instance Type0_Constraint Integral (Type_Either root)
-instance Type0_Family Type_Family_MonoElement (Type_Either root) where
- type0_family _at (Type2 _px _l r) = Just r
-instance Type0_Constraint MT.MonoFunctor (Type_Either root) where
- type0_constraint _c Type2{} = Just Dict
-instance Type1_Constraint Functor (Type_Either root) where
- type1_constraint _c Type2{} = Just Dict
-instance Type1_Constraint Applicative (Type_Either root) where
- type1_constraint _c Type2{} = Just Dict
-instance Type1_Constraint Traversable (Type_Either root) where
- type1_constraint _c Type2{} = Just Dict
-instance Type1_Constraint Foldable (Type_Either root) where
- type1_constraint _c Type2{} = Just Dict
-instance Type1_Constraint Monad (Type_Either root) where
- type1_constraint _c Type2{} = Just Dict
-instance -- Type0_Eq
- Type0_Eq root =>
- Type0_Eq (Type_Either root) where
- type0_eq
- (Type2 _ l1 r1)
- (Type2 _ l2 r2)
- | Just Refl <- l1 `type0_eq` l2
- , Just Refl <- r1 `type0_eq` r2
- = Just Refl
- type0_eq _ _ = Nothing
-instance -- String_from_Type
- String_from_Type root =>
- String_from_Type (Type_Either root) where
- string_from_type (Type2 _ l r) =
- "Either"
- ++ " (" ++ string_from_type l ++ ")"
- ++ " (" ++ string_from_type r ++ ")"
-
--- | Inject 'Type_Either' within a root type.
-type_either
- :: Type_Root_Lift Type_Either root
- => root h_l -> root h_r -> root (Either h_l h_r)
-type_either = type2
+++ /dev/null
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
-module Language.Symantic.Type.Error where
-
-import Data.Proxy
-import Language.Symantic.Lib.Data.Peano
-import Language.Symantic.Lib.Data.Bool
-
-import Language.Symantic.Type.Root
-import Language.Symantic.Type.Alt
-
--- * Type family 'Error_of_Type'
--- | Return the error type of a type.
-type family Error_of_Type (ast:: *) (ty:: * -> *) :: *
-type instance Error_of_Type ast (Type_Root ty)
- = Error_Type_Alt (Error_Type ast)
- (Error_of_Type ast (ty (Type_Root ty)))
-type instance Error_of_Type ast (Type_Alt curr next root)
- = Error_of_Type_Alt ast (Error_of_Type ast (curr root))
- (Error_of_Type ast (next root))
-
--- ** Type family 'Error_of_Type_Alt'
--- | Remove 'No_Error_Type' type when building 'Error_of_Type'.
-type family Error_of_Type_Alt ast curr next where
- Error_of_Type_Alt ast curr No_Error_Type = curr
- Error_of_Type_Alt ast No_Error_Type next = next
- Error_of_Type_Alt ast curr next = Error_Type_Alt curr next
-
--- * Type 'Error_Type_Alt'
--- | Error type making an alternative between two error types.
-data Error_Type_Alt curr next
- = Error_Type_Alt_Curr curr
- | Error_Type_Alt_Next next
- deriving (Eq, Show)
-
--- ** Type 'Error_Type_Lift'
-type Error_Type_Lift err errs
- = Error_Type_LiftP (Peano_of_Error_Type err errs) err errs
-
--- *** Type 'Peano_of_Error_Type'
--- | Return a 'Peano' number derived from the location
--- of a given error type within a given error type stack.
-type family Peano_of_Error_Type (err:: *) (errs:: *) :: * where
- Peano_of_Error_Type err err = Zero
- Peano_of_Error_Type err (Error_Type_Alt err next) = Zero
- Peano_of_Error_Type other (Error_Type_Alt curr next) = Succ (Peano_of_Error_Type other next)
-
--- *** Class 'Error_Type_LiftP'
--- | Lift a given error type to the top of a given error type stack including it,
--- by constructing the appropriate sequence of 'Error_Type_Alt_Curr' and 'Error_Type_Alt_Next'.
-class Error_Type_LiftP (p:: *) err errs where
- error_type_liftP :: Proxy p -> err -> errs
-instance Error_Type_LiftP Zero curr curr where
- error_type_liftP _ = id
-instance Error_Type_LiftP Zero curr (Error_Type_Alt curr next) where
- error_type_liftP _ = Error_Type_Alt_Curr
-instance
- Error_Type_LiftP p other next =>
- Error_Type_LiftP (Succ p) other (Error_Type_Alt curr next) where
- error_type_liftP _ = Error_Type_Alt_Next . error_type_liftP (Proxy::Proxy p)
-
--- | Convenient wrapper around 'error_type_unliftP',
--- passing it the 'Peano' number from 'Peano_of_Error_Type'.
-error_type_lift
- :: forall err errs.
- Error_Type_Lift err errs =>
- err -> errs
-error_type_lift = error_type_liftP (Proxy::Proxy (Peano_of_Error_Type err errs))
-
--- ** Type 'Error_Type_Unlift'
--- | Apply 'Peano_of_Error_Type' on 'Error_Type_UnliftP'.
-type Error_Type_Unlift ty tys
- = Error_Type_UnliftP (Peano_of_Error_Type ty tys) ty tys
-
--- | Convenient wrapper around 'error_type_unliftP',
--- passing it the 'Peano' number from 'Peano_of_Error_Type'.
-error_type_unlift
- :: forall ty tys.
- Error_Type_Unlift ty tys =>
- tys -> Maybe ty
-error_type_unlift = error_type_unliftP (Proxy::Proxy (Peano_of_Error_Type ty tys))
-
--- *** Class 'Error_Type_UnliftP'
--- | Try to unlift a given type error out of a given type error stack including it,
--- by deconstructing the appropriate sequence of 'Error_Type_Alt_Curr' and 'Error_Type_Alt_Next'.
-class Error_Type_UnliftP (p:: *) ty tys where
- error_type_unliftP :: Proxy p -> tys -> Maybe ty
-instance Error_Type_UnliftP Zero curr curr where
- error_type_unliftP _ = Just
-instance Error_Type_UnliftP Zero curr (Error_Type_Alt curr next) where
- error_type_unliftP _ (Error_Type_Alt_Curr x) = Just x
- error_type_unliftP _ (Error_Type_Alt_Next _) = Nothing
-instance
- Error_Type_UnliftP p other next =>
- Error_Type_UnliftP (Succ p) other (Error_Type_Alt curr next) where
- error_type_unliftP _ (Error_Type_Alt_Next x) = error_type_unliftP (Proxy::Proxy p) x
- error_type_unliftP _ (Error_Type_Alt_Curr _) = Nothing
-
--- ** Type 'Error_Type_Read'
--- | Common type errors.
-data Error_Type ast
- = Error_Type_Unsupported ast
- -- ^ Given syntax is supported by none
- -- of the type parser components
- -- of the type stack.
- | Error_Type_Unsupported_here ast
- -- ^ Given syntax not supported by the current type parser component.
- | Error_Type_Wrong_number_of_arguments ast Int
- | Error_Type_Constraint_missing ast {-Exists_Dict-} {-Exists_Type0 ty-}
- | Error_Type_No_Type_Family ast
- -- ^ A 'Constraint' is missing.
- deriving (Eq, Show)
-
--- | Convenient wrapper around 'error_type_lift',
--- passing the type family boilerplate.
-error_type
- :: Error_Type_Lift (Error_Type ast)
- (Error_of_Type ast (Root_of_Type ty))
- => Proxy ty
- -> Error_Type ast
- -> Error_of_Type ast (Root_of_Type ty)
-error_type _ = error_type_lift
-
-error_type_unsupported
- :: forall ast ty.
- ( IBool (Is_Last_Type ty (Root_of_Type ty))
- , Error_Type_Lift (Error_Type ast) (Error_of_Type ast (Root_of_Type ty))
- ) => Proxy ty -> ast
- -> Error_of_Type ast (Root_of_Type ty)
-error_type_unsupported ty ast =
- case iBool :: SBool (Is_Last_Type ty (Root_of_Type ty)) of
- STrue -> error_type ty $ Error_Type_Unsupported ast
- SFalse -> error_type ty $ Error_Type_Unsupported_here ast
-
--- ** Type 'No_Error_Type'
--- | A discarded error.
-data No_Error_Type
- = No_Error_Type
- deriving (Eq, Show)
-
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
--- | Type Families.
-module Language.Symantic.Type.Family where
-
-import Data.Proxy (Proxy(..))
-import qualified Data.MonoTraversable as MT
-
-import Language.Symantic.Type.Error
-import Language.Symantic.Type.Root
-import Language.Symantic.Type.Alt
-
--- * Type 'Host_of_Type0_Family'
-type family Host_of_Type0_Family tf h0 :: *
-
--- * Class 'Type0_Family'
-class Type0_Family (tf:: *) (ty:: * -> *) where
- type0_family
- :: forall h0. Proxy tf -> ty h0
- -> Maybe (Root_of_Type ty (Host_of_Type0_Family tf h0))
- type0_family _tf _ty = Nothing
-instance -- Type_Root
- ( Type0_Family tf (ty (Type_Root ty))
- , Root_of_Type (ty (Type_Root ty)) ~ Type_Root ty
- ) => Type0_Family tf (Type_Root ty) where
- type0_family tf (Type_Root ty) = type0_family tf ty
-instance -- Type_Alt
- ( Type0_Family tf (curr root)
- , Type0_Family tf (next root)
- , Root_of_Type (curr root) ~ root
- , Root_of_Type (next root) ~ root
- ) => Type0_Family tf (Type_Alt curr next root) where
- type0_family tf (Type_Alt_Curr ty) = type0_family tf ty
- type0_family tf (Type_Alt_Next ty) = type0_family tf ty
-
--- | Parsing utility to check that the resulting type
--- from the application of a given type family to a given type
--- is within the type stack,
--- or raise 'Error_Type_No_Type0_Family'.
-check_type_type0_family
- :: forall ast ty tf h ret.
- ( Error_Type_Lift (Error_Type ast) (Error_of_Type ast ty)
- , Type0_Family tf ty
- , Root_of_Type ty ~ ty
- ) => Proxy tf -> ast -> ty h
- -> (ty (Host_of_Type0_Family tf h) -> Either (Error_of_Type ast ty) ret)
- -> Either (Error_of_Type ast ty) ret
-check_type_type0_family tf ast ty k =
- case type0_family tf ty of
- Just t -> k t
- Nothing -> Left $ error_type_lift $
- Error_Type_No_Type_Family ast -- (Exists_Type0 ty)
-
--- * Type 'Type_Family_MonoElement'
--- | Proxy type for 'MT.Element'.
-data Type_Family_MonoElement
-type instance Host_of_Type0_Family Type_Family_MonoElement h = MT.Element h
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Language.Symantic.Type.Fun where
-
-import Data.Proxy
-import Data.Type.Equality ((:~:)(Refl))
-import qualified Data.MonoTraversable as MT
-
-import Language.Symantic.Type.Root
-import Language.Symantic.Type.Error
-import Language.Symantic.Type.Type0
-import Language.Symantic.Type.Type1
-import Language.Symantic.Type.Type2
-import Language.Symantic.Type.Constraint
-import Language.Symantic.Type.Family
-
--- * Type 'Type_Fun'
--- | The @->@ type.
-type Type_Fun = Type2 (Proxy (->))
-
-pattern Type_Fun
- :: root arg -> root res
- -> Type_Fun root ((->) arg res)
-pattern Type_Fun arg res
- = Type2 Proxy arg res
-
-instance Type1_Unlift Type_Fun where
- type1_unlift (Type2 px a b) k =
- k ( Type1 (Proxy::Proxy ((->) a)) b
- , Type1_Lift (\(Type1 _ b') -> Type2 px a b')
- )
-instance Type0_Eq root => Type1_Eq (Type_Fun root) where
- type1_eq (Type2 _ a1 _b1) (Type2 _ a2 _b2)
- | Just Refl <- type0_eq a1 a2
- = Just Refl
- type1_eq _ _ = Nothing
-instance Type0_Constraint Eq (Type_Fun root)
-instance Type0_Constraint Ord (Type_Fun root)
-instance
- Type0_Constraint Monoid root =>
- Type0_Constraint Monoid (Type_Fun root) where
- type0_constraint c (Type2 _ _arg res)
- | Just Dict <- type0_constraint c res
- = Just Dict
- type0_constraint _c _ = Nothing
-instance Type0_Constraint Num (Type_Fun root)
-instance Type0_Constraint Integral (Type_Fun root)
-instance Type0_Family Type_Family_MonoElement (Type_Fun root) where
- type0_family _at (Type2 _px _r a) = Just a
-instance Type0_Constraint MT.MonoFunctor (Type_Fun root) where
- type0_constraint _c Type2{} = Just Dict
-instance Type1_Constraint Functor (Type_Fun root) where
- type1_constraint _c Type2{} = Just Dict
-instance Type1_Constraint Applicative (Type_Fun root) where
- type1_constraint _c Type2{} = Just Dict
-instance Type1_Constraint Foldable (Type_Fun root)
-instance Type1_Constraint Traversable (Type_Fun root)
-instance Type1_Constraint Monad (Type_Fun root) where
- type1_constraint _c Type2{} = Just Dict
-
-instance -- Type0_Eq
- Type0_Eq root =>
- Type0_Eq (Type_Fun root) where
- type0_eq
- (Type2 _ arg1 res1)
- (Type2 _ arg2 res2)
- | Just Refl <- arg1 `type0_eq` arg2
- , Just Refl <- res1 `type0_eq` res2
- = Just Refl
- type0_eq _ _ = Nothing
-instance -- String_from_Type
- String_from_Type root =>
- String_from_Type (Type_Fun root) where
- string_from_type (Type2 _ arg res) =
- "(" ++ string_from_type arg ++ " -> "
- ++ string_from_type res ++ ")"
-
--- | Convenient alias to include a 'Type_Fun' within a type.
-type_fun
- :: Type_Root_Lift Type_Fun root
- => root h_arg -> root h_res -> root ((->) h_arg h_res)
-type_fun = type2
-
--- | Parse 'Type_Fun'.
-type_fun_from
- :: forall (root :: * -> *) ast ret.
- ( Type_Root_Lift Type_Fun root
- , Type0_From ast root
- , Root_of_Type root ~ root
- ) => Proxy (Type_Fun root)
- -> ast -> ast
- -> (forall h. root h -> Either (Error_of_Type ast root) ret)
- -> Either (Error_of_Type ast root) ret
-type_fun_from _ty ast_arg ast_res k =
- type0_from (Proxy::Proxy root) ast_arg $ \ty_arg ->
- type0_from (Proxy::Proxy root) ast_res $ \ty_res ->
- k (ty_arg `type_fun` ty_res)
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Language.Symantic.Type.IO where
-
-import qualified Data.MonoTraversable as MT
-import Data.Proxy
-import Data.Type.Equality ((:~:)(Refl))
-import qualified System.IO as IO
-
-import Language.Symantic.Type.Root
-import Language.Symantic.Type.Type0
-import Language.Symantic.Type.Type1
-import Language.Symantic.Type.Constraint
-import Language.Symantic.Type.Family
-
--- * Type 'Type_IO'
--- | The list type.
-type Type_IO = Type1 (Proxy IO)
-type Type_IO_Handle = Type0 (Proxy IO.Handle)
-type Type_IO_FilePath = Type0 (Proxy IO.FilePath)
-type Type_IO_Mode = Type0 (Proxy IO.IOMode)
-
-pattern Type_IO :: root a -> Type_IO root (IO a)
-pattern Type_IO a = Type1 Proxy a
-
-instance Type0_Constraint Eq (Type_IO root)
-instance Type0_Constraint Ord (Type_IO root)
-instance Type0_Constraint Monoid (Type_IO root)
-instance Type0_Constraint Num (Type_IO root)
-instance Type0_Constraint Integral (Type_IO root)
-instance Type0_Family Type_Family_MonoElement (Type_IO root) where
- type0_family _at (Type1 _px a) = Just a
-instance Type0_Constraint MT.MonoFunctor (Type_IO root) where
- type0_constraint _c Type1{} = Just Dict
-instance Type1_Constraint Functor (Type_IO root) where
- type1_constraint _c Type1{} = Just Dict
-instance Type1_Constraint Applicative (Type_IO root) where
- type1_constraint _c Type1{} = Just Dict
-instance Type1_Constraint Monad (Type_IO root) where
- type1_constraint _c Type1{} = Just Dict
-instance -- Type0_Eq
- Type0_Eq root =>
- Type0_Eq (Type_IO root) where
- type0_eq (Type1 _px1 a1) (Type1 _px2 a2)
- | Just Refl <- a1 `type0_eq` a2
- = Just Refl
- type0_eq _ _ = Nothing
-instance -- Type1_Eq
- Type1_Eq (Type_IO root) where
- type1_eq Type1{} Type1{} = Just Refl
-instance -- String_from_Type
- String_from_Type root =>
- String_from_Type (Type_IO root) where
- string_from_type (Type1 _f a) =
- "[" ++ string_from_type a ++ "]"
-
--- | Inject 'Type_IO' within a root type.
-type_io :: Type_Root_Lift Type_IO root => root h_a -> root (IO h_a)
-type_io = type1
-
--- | Inject 'Type_IO_Handle' within a root type.
-type_io_handle
- :: Type_Root_Lift Type_IO_Handle root
- => root IO.Handle
-type_io_handle = type_root_lift $ Type0 (Proxy::Proxy IO.Handle)
-
--- | Inject 'Type_IO_FilePath' within a root type.
-type_io_filepath
- :: Type_Root_Lift Type_IO_FilePath root
- => root IO.FilePath
-type_io_filepath = type_root_lift $ Type0 (Proxy::Proxy IO.FilePath)
-
--- | Inject 'Type_IO_Mode' within a root type.
-type_io_mode
- :: Type_Root_Lift Type_IO_Mode root
- => root IO.IOMode
-type_io_mode = type_root_lift $ Type0 (Proxy::Proxy IO.IOMode)
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Language.Symantic.Type.Int where
-
-import qualified Data.MonoTraversable as MT
-import Data.Proxy
-
-import Language.Symantic.Type.Root
-import Language.Symantic.Type.Type0
-import Language.Symantic.Type.Constraint
-import Language.Symantic.Type.Family
-
--- * Type 'Type_Int'
--- | The 'Int' type.
-type Type_Int = Type0 (Proxy Int)
-
-pattern Type_Int :: Type_Int root Int
-pattern Type_Int = Type0 Proxy
-
-instance Type0_Constraint Eq (Type_Int root) where
- type0_constraint _c Type0{} = Just Dict
-instance Type0_Constraint Ord (Type_Int root) where
- type0_constraint _c Type0{} = Just Dict
-instance Type0_Constraint Monoid (Type_Int root)
-instance Type0_Constraint Num (Type_Int root) where
- type0_constraint _c Type0{} = Just Dict
-instance Type0_Constraint Integral (Type_Int root) where
- type0_constraint _c Type0{} = Just Dict
-instance Type0_Family Type_Family_MonoElement (Type_Int root)
-instance Type0_Constraint MT.MonoFunctor (Type_Int root)
-instance String_from_Type (Type_Int root) where
- string_from_type _ = "Int"
-
--- | Inject 'Type_Int' within a root type.
-type_int :: Type_Root_Lift Type_Int root => root Int
-type_int = type0
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Language.Symantic.Type.Integer where
-
-import qualified Data.MonoTraversable as MT
-import Data.Proxy
-
-import Language.Symantic.Type.Root
-import Language.Symantic.Type.Type0
-import Language.Symantic.Type.Constraint
-import Language.Symantic.Type.Family
-
--- * Type 'Type_Integer'
--- | The 'Integer' type.
-type Type_Integer = Type0 (Proxy Integer)
-
-pattern Type_Integer :: Type_Integer root Integer
-pattern Type_Integer = Type0 Proxy
-
-instance Type0_Constraint Eq (Type_Integer root) where
- type0_constraint _c Type0{} = Just Dict
-instance Type0_Constraint Ord (Type_Integer root) where
- type0_constraint _c Type0{} = Just Dict
-instance Type0_Constraint Monoid (Type_Integer root)
-instance Type0_Constraint Num (Type_Integer root) where
- type0_constraint _c Type0{} = Just Dict
-instance Type0_Constraint Integral (Type_Integer root) where
- type0_constraint _c Type0{} = Just Dict
-instance Type0_Family Type_Family_MonoElement (Type_Integer root)
-instance Type0_Constraint MT.MonoFunctor (Type_Integer root)
-instance String_from_Type (Type_Integer root) where
- string_from_type _ = "Integer"
-
--- | Inject 'Type_Integer' within a root type.
-type_integer :: Type_Root_Lift Type_Integer root => root Integer
-type_integer = type0
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Language.Symantic.Type.List where
-
-import qualified Data.MonoTraversable as MT
-import Data.Proxy
-import Data.Type.Equality ((:~:)(Refl))
-
-import Language.Symantic.Type.Root
-import Language.Symantic.Type.Type0
-import Language.Symantic.Type.Type1
-import Language.Symantic.Type.Constraint
-import Language.Symantic.Type.Family
-
--- * Type 'Type_List'
--- | The list type.
-type Type_List = Type1 (Proxy [])
-
-pattern Type_List :: root a -> Type_List root ([] a)
-pattern Type_List a = Type1 Proxy a
-
-instance Type0_Constraint Eq root => Type0_Constraint Eq (Type_List root) where
- type0_constraint c (Type1 _ a)
- | Just Dict <- type0_constraint c a
- = Just Dict
- type0_constraint _c _ = Nothing
-instance Type0_Constraint Ord root => Type0_Constraint Ord (Type_List root) where
- type0_constraint c (Type1 _ a)
- | Just Dict <- type0_constraint c a
- = Just Dict
- type0_constraint _c _ = Nothing
-instance Type0_Constraint Monoid (Type_List root) where
- type0_constraint _c Type1{} = Just Dict
-instance Type0_Constraint Num (Type_List root)
-instance Type0_Constraint Integral (Type_List root)
-instance Type0_Family Type_Family_MonoElement (Type_List root) where
- type0_family _at (Type1 _px a) = Just a
-instance Type0_Constraint MT.MonoFunctor (Type_List root) where
- type0_constraint _c Type1{} = Just Dict
-instance Type1_Constraint Functor (Type_List root) where
- type1_constraint _c Type1{} = Just Dict
-instance Type1_Constraint Applicative (Type_List root) where
- type1_constraint _c Type1{} = Just Dict
-instance Type1_Constraint Foldable (Type_List root) where
- type1_constraint _c Type1{} = Just Dict
-instance Type1_Constraint Traversable (Type_List root) where
- type1_constraint _c Type1{} = Just Dict
-instance Type1_Constraint Monad (Type_List root) where
- type1_constraint _c Type1{} = Just Dict
-instance -- Type0_Eq
- Type0_Eq root =>
- Type0_Eq (Type_List root) where
- type0_eq (Type1 _px1 a1) (Type1 _px2 a2)
- | Just Refl <- a1 `type0_eq` a2
- = Just Refl
- type0_eq _ _ = Nothing
-instance -- Type1_Eq
- Type1_Eq (Type_List root) where
- type1_eq Type1{} Type1{} = Just Refl
-instance -- String_from_Type
- String_from_Type root =>
- String_from_Type (Type_List root) where
- string_from_type (Type1 _f a) =
- "[" ++ string_from_type a ++ "]"
-
--- | Inject 'Type_List' within a root type.
-type_list :: Type_Root_Lift Type_List root => root h_a -> root ([] h_a)
-type_list = type1
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Language.Symantic.Type.Map where
-
-import Data.Map.Strict as Map
-import qualified Data.MonoTraversable as MT
-import Data.Proxy
-import Data.Type.Equality ((:~:)(Refl))
-
-import Language.Symantic.Type.Root
-import Language.Symantic.Type.Type0
-import Language.Symantic.Type.Type1
-import Language.Symantic.Type.Type2
-import Language.Symantic.Type.Constraint
-import Language.Symantic.Type.Family
-
--- * Type 'Type_Map'
--- | The 'Map' type.
-type Type_Map = Type2 (Proxy Map)
-
-pattern Type_Map
- :: root k -> root a
- -> Type2 (Proxy Map) root (Map k a)
-pattern Type_Map k a
- = Type2 Proxy k a
-
-instance Type1_Unlift Type_Map where
- type1_unlift (Type2 px a b) k =
- k ( Type1 (Proxy::Proxy (Map a)) b
- , Type1_Lift (\(Type1 _ b') -> Type2 px a b')
- )
-instance
- Type0_Constraint Eq root =>
- Type0_Constraint Eq (Type_Map root) where
- type0_constraint c (Type2 _ k a)
- | Just Dict <- type0_constraint c k
- , Just Dict <- type0_constraint c a
- = Just Dict
- type0_constraint _c _ = Nothing
-instance
- Type0_Constraint Ord root =>
- Type0_Constraint Ord (Type_Map root) where
- type0_constraint c (Type2 _ k a)
- | Just Dict <- type0_constraint c k
- , Just Dict <- type0_constraint c a
- = Just Dict
- type0_constraint _c _ = Nothing
-instance
- Type0_Constraint Ord root =>
- Type0_Constraint Monoid (Type_Map root) where
- type0_constraint _c (Type2 _ k _a)
- | Just Dict <- type0_constraint (Proxy::Proxy Ord) k
- = Just Dict
- type0_constraint _c _ = Nothing
-instance Type0_Constraint Num (Type_Map root)
-instance Type0_Constraint Integral (Type_Map root)
-instance Type0_Constraint MT.MonoFunctor (Type_Map root) where
- type0_constraint _c Type2{} = Just Dict
-instance Type1_Constraint Functor (Type_Map root) where
- type1_constraint _c Type2{} = Just Dict
-instance Type1_Constraint Traversable (Type_Map root) where
- type1_constraint _c Type2{} = Just Dict
-instance Type1_Constraint Foldable (Type_Map root) where
- type1_constraint _c Type2{} = Just Dict
-instance Type0_Family Type_Family_MonoElement (Type_Map root) where
- type0_family _at (Type2 _px _k a) = Just a
-instance -- Type0_Eq
- Type0_Eq root =>
- Type0_Eq (Type_Map root) where
- type0_eq (Type2 _px1 k1 a1) (Type2 _px2 k2 a2)
- | Just Refl <- k1 `type0_eq` k2
- , Just Refl <- a1 `type0_eq` a2
- = Just Refl
- type0_eq _ _ = Nothing
-instance -- Type1_Eq
- Type0_Eq root =>
- Type1_Eq (Type_Map root) where
- type1_eq (Type2 _px1 k1 _a1) (Type2 _px2 k2 _a2)
- | Just Refl <- k1 `type0_eq` k2
- = Just Refl
- type1_eq _ _ = Nothing
-instance -- String_from_Type
- String_from_Type root =>
- String_from_Type (Type_Map root) where
- string_from_type (Type2 _ k a) =
- "Map (" ++ string_from_type k ++ ")"
- ++ " (" ++ string_from_type a ++ ")"
-
--- | Inject 'Type_Map' within a root type.
-type_map
- :: Type_Root_Lift Type_Map root
- => root h_k -> root h_a -> root (Map h_k h_a)
-type_map = type2
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Language.Symantic.Type.Maybe where
-
-import qualified Data.MonoTraversable as MT
-import Data.Proxy
-import Data.Type.Equality ((:~:)(Refl))
-
-import Language.Symantic.Type.Root
-import Language.Symantic.Type.Type0
-import Language.Symantic.Type.Type1
-import Language.Symantic.Type.Constraint
-import Language.Symantic.Type.Family
-
--- * Type 'Type_Maybe'
--- | The 'Maybe' type.
-type Type_Maybe = Type1 (Proxy Maybe)
-
-pattern Type_Maybe :: root a -> Type_Maybe root (Maybe a)
-pattern Type_Maybe a = Type1 Proxy a
-
-instance Type0_Constraint Eq root => Type0_Constraint Eq (Type_Maybe root) where
- type0_constraint c (Type1 _ a)
- | Just Dict <- type0_constraint c a
- = Just Dict
- type0_constraint _c _ = Nothing
-instance Type0_Constraint Ord root => Type0_Constraint Ord (Type_Maybe root) where
- type0_constraint c (Type1 _ a)
- | Just Dict <- type0_constraint c a
- = Just Dict
- type0_constraint _c _ = Nothing
-instance Type0_Constraint Monoid root => Type0_Constraint Monoid (Type_Maybe root) where
- type0_constraint c (Type1 _ a)
- | Just Dict <- type0_constraint c a
- = Just Dict
- type0_constraint _c _ = Nothing
-instance Type0_Constraint Num (Type_Maybe root)
-instance Type0_Constraint Integral (Type_Maybe root)
-instance Type0_Family Type_Family_MonoElement (Type_Maybe root) where
- type0_family _at (Type1 _px a) = Just a
-instance Type0_Constraint MT.MonoFunctor (Type_Maybe root) where
- type0_constraint _c Type1{} = Just Dict
-instance Type1_Constraint Functor (Type_Maybe root) where
- type1_constraint _c (Type1 _ _) = Just Dict
-instance Type1_Constraint Applicative (Type_Maybe root) where
- type1_constraint _c (Type1 _ _) = Just Dict
-instance Type1_Constraint Foldable (Type_Maybe root) where
- type1_constraint _c (Type1 _ _) = Just Dict
-instance Type1_Constraint Traversable (Type_Maybe root) where
- type1_constraint _c (Type1 _ _) = Just Dict
-instance Type1_Constraint Monad (Type_Maybe root) where
- type1_constraint _c Type1{} = Just Dict
-instance -- Type0_Eq
- Type0_Eq root =>
- Type0_Eq (Type_Maybe root) where
- type0_eq (Type1 _px1 a1) (Type1 _px2 a2)
- | Just Refl <- a1 `type0_eq` a2
- = Just Refl
- type0_eq _ _ = Nothing
-instance -- Type1_Eq
- Type1_Eq (Type_Maybe root) where
- type1_eq Type1{} Type1{} = Just Refl
-instance -- String_from_Type
- String_from_Type root =>
- String_from_Type (Type_Maybe root) where
- string_from_type (Type1 _f a) =
- "Maybe" ++ " (" ++ string_from_type a ++ ")"
-
--- | Inject 'Type_Maybe' within a root type.
-type_maybe :: Type_Root_Lift Type_Maybe root => root h_a -> root (Maybe h_a)
-type_maybe = type1
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Language.Symantic.Type.Ordering where
-
-import qualified Data.MonoTraversable as MT
-import Data.Proxy
-
-import Language.Symantic.Type.Root
-import Language.Symantic.Type.Type0
-import Language.Symantic.Type.Constraint
-import Language.Symantic.Type.Family
-
--- * Type 'Type_Ordering'
--- | The 'Ordering' type.
-type Type_Ordering = Type0 (Proxy Ordering)
-
-pattern Type_Ordering :: Type_Ordering root Ordering
-pattern Type_Ordering = Type0 Proxy
-
-instance Type0_Constraint Eq (Type_Ordering root) where
- type0_constraint _c Type0{} = Just Dict
-instance Type0_Constraint Ord (Type_Ordering root) where
- type0_constraint _c Type0{} = Just Dict
-instance Type0_Constraint Monoid (Type_Ordering root)
-instance Type0_Constraint Num (Type_Ordering root)
-instance Type0_Constraint Integral (Type_Ordering root)
-instance Type0_Constraint MT.MonoFunctor (Type_Ordering root)
-instance Type0_Family Type_Family_MonoElement (Type_Ordering root)
-instance String_from_Type (Type_Ordering root) where
- string_from_type _ = "Ordering"
-
--- | Inject 'Type_Ordering' within a root type.
-type_ordering :: Type_Root_Lift Type_Ordering root => root Ordering
-type_ordering = type0
+++ /dev/null
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-module Language.Symantic.Type.Root where
-
--- * Type 'Type_Root'
--- | The root type, passing itself as parameter to the given type.
-newtype Type_Root (ty:: (* -> *) -> * -> *) h
- = Type_Root { unType_Root :: ty (Type_Root ty) h }
-type instance Root_of_Type (Type_Root ty) = Type_Root ty
-
--- ** Type family 'Root_of_Type'
--- | Return the root type of a type.
-type family Root_of_Type (ty:: * -> *) :: * -> *
-
--- ** Class 'Type_Root_Lift'
--- | Lift a given type to a given root type.
-class Type_Root_Lift ty root where
- type_root_lift :: forall h. ty root h -> root h
-
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeOperators #-}
-module Type.Test where
-
-import Test.Tasty
-import Test.Tasty.HUnit
-import Data.Proxy
-
-import Language.Symantic.Type
-
-import AST.Test
-
-type Type_Fun_Bool = Type_Root (Type_Fun :|: Type_Bool)
-type Type_Fun_Bool_Int = Type_Root (Type_Fun :|: Type_Bool :|: Type_Int)
-type Type_Fun_Int = Type_Root (Type_Fun :|: Type_Int)
-
-tests :: TestTree
-tests = testGroup "Type" $
- let (==>) ast expected p =
- testCase (show ast) $
- (@?= Exists_Type0 <$> expected) $
- type0_from p ast (Right . Exists_Type0) in
- [ testGroup "Bool"
- [ AST "Bool" []
- ==> Right (type_bool :: Type_Fun_Bool Bool) $
- (Proxy :: Proxy (Type_Fun_Bool))
- , AST "->" [AST "Bool" []]
- ==> Left (error_type_lift $
- Error_Type_Wrong_number_of_arguments (AST "->" [AST "Bool" []]) 2) $
- (Proxy :: Proxy (Type_Fun_Bool))
- , AST "->" [AST "Bool" [], AST "Bool" []]
- ==> Right (type_bool `type_fun` type_bool
- :: Type_Fun_Bool ((->) Bool Bool)) $
- (Proxy :: Proxy (Type_Fun_Bool))
- , AST "->" [ AST "->" [AST "Bool" [], AST "Bool" []]
- , AST "Bool" [] ]
- ==> Right ((type_bool `type_fun` type_bool) `type_fun` type_bool
- :: Type_Fun_Bool ((->) ((->) Bool Bool) Bool)) $
- (Proxy :: Proxy (Type_Fun_Bool))
- , AST "->" [ AST "Bool" []
- , AST "->" [AST "Bool" [], AST "Bool" []] ]
- ==> Right (type_bool `type_fun` (type_bool `type_fun` type_bool)
- :: Type_Fun_Bool ((->) Bool ((->) Bool Bool))) $
- (Proxy :: Proxy (Type_Fun_Bool))
- , AST "Int" []
- ==> Left (error_type_lift $ Error_Type_Unsupported $ AST "Int" []) $
- (Proxy :: Proxy (Type_Fun_Bool))
- , AST "->" [AST "Bool" [], AST "Int" []]
- ==> Left (error_type_lift $ Error_Type_Unsupported $ AST "Int" []) $
- (Proxy :: Proxy (Type_Fun_Bool))
- , AST "->" [ AST "->" [AST "Int" [], AST "Bool" []]
- , AST "Int" [] ]
- ==> Left (error_type_lift $ Error_Type_Unsupported $ AST "Int" []) $
- (Proxy :: Proxy (Type_Fun_Bool))
- ]
- , testGroup "Int"
- [ AST "Int" []
- ==> Right (type_int :: Type_Fun_Int Int) $
- (Proxy :: Proxy (Type_Fun_Int))
- , AST "->" [AST "Int" []]
- ==> Left (error_type_lift $
- Error_Type_Wrong_number_of_arguments (AST "->" [AST "Int" []]) 2) $
- (Proxy :: Proxy (Type_Fun_Int))
- , AST "->" [AST "Int" [], AST "Int" []]
- ==> Right (type_int `type_fun` type_int
- :: Type_Fun_Int ((->) Int Int)) $
- (Proxy :: Proxy (Type_Fun_Int))
- , AST "->" [ AST "->" [AST "Int" [], AST "Int" []]
- , AST "Int" [] ]
- ==> Right ((type_int `type_fun` type_int) `type_fun` type_int
- :: Type_Fun_Int ((->) ((->) Int Int) Int)) $
- (Proxy :: Proxy (Type_Fun_Int))
- , AST "->" [ AST "Int" []
- , AST "->" [AST "Int" [], AST "Int" []] ]
- ==> Right (type_int `type_fun` (type_int `type_fun` type_int)
- :: Type_Fun_Int ((->) Int ((->) Int Int))) $
- (Proxy :: Proxy (Type_Fun_Int))
- , AST "Bool" []
- ==> Left (error_type_lift $ Error_Type_Unsupported $ AST "Bool" []) $
- (Proxy :: Proxy (Type_Fun_Int))
- , AST "->" [AST "Int" [], AST "Bool" []]
- ==> Left (error_type_lift $ Error_Type_Unsupported $ AST "Bool" []) $
- (Proxy :: Proxy (Type_Fun_Int))
- , AST "->" [ AST "->" [AST "Bool" [], AST "Int" []]
- , AST "Bool" [] ]
- ==> Left (error_type_lift $ Error_Type_Unsupported $ AST "Bool" []) $
- (Proxy :: Proxy (Type_Fun_Int))
- ]
- , testGroup "Fun" $
- [ AST "Int" []
- ==> Right (type_int :: Type_Fun_Bool_Int Int) $
- (Proxy :: Proxy (Type_Fun_Bool_Int))
- , AST "->" [AST "Bool" [], AST "Int" []]
- ==> Right (type_bool `type_fun` type_int
- :: Type_Fun_Bool_Int ((->) Bool Int)) $
- (Proxy :: Proxy (Type_Fun_Bool_Int))
- , AST "->" [ AST "->" [AST "Int" [], AST "Bool" []]
- , AST "Int" [] ]
- ==> Right ((type_int `type_fun` type_bool) `type_fun` type_int
- :: Type_Fun_Bool_Int ((->) ((->) Int Bool) Int)) $
- (Proxy :: Proxy (Type_Fun_Bool_Int))
- ]
- ]
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Language.Symantic.Type.Text where
-
-import qualified Data.MonoTraversable as MT
-import Data.Proxy
-import Data.Text (Text)
-
-import Language.Symantic.Type.Root
-import Language.Symantic.Type.Type0
-import Language.Symantic.Type.Constraint
-import Language.Symantic.Type.Family
-
--- * Type 'Type_Text'
--- | The 'Text' type.
-type Type_Text = Type0 (Proxy Text)
-
-pattern Type_Text :: Type0 (Proxy Text) root Text
-pattern Type_Text = Type0 Proxy
-
-instance Type0_Constraint Eq (Type_Text root) where
- type0_constraint _c Type0{} = Just Dict
-instance Type0_Constraint Ord (Type_Text root) where
- type0_constraint _c Type0{} = Just Dict
-instance Type0_Constraint Monoid (Type_Text root) where
- type0_constraint _c Type0{} = Just Dict
-instance Type0_Constraint Num (Type_Text root)
-instance Type0_Constraint Integral (Type_Text root)
-instance Type_Root_Lift (Type0 (Proxy (MT.Element Text))) root =>
- Type0_Family Type_Family_MonoElement (Type_Text root) where
- type0_family _at Type0{} = Just type0
-instance Type0_Constraint MT.MonoFunctor (Type_Text root) where
- type0_constraint _c Type0{} = Just Dict
-instance -- String_from_Type
- String_from_Type (Type_Text root) where
- string_from_type _ = "Text"
-
--- | Inject 'Type_Text' within a root type.
-type_text :: Type_Root_Lift Type_Text root => root Text
-type_text = type0
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Language.Symantic.Type.Tuple where
-
-import qualified Data.MonoTraversable as MT
-import Data.Proxy
-import Data.Type.Equality ((:~:)(Refl))
-
-import Language.Symantic.Type.Root
-import Language.Symantic.Type.Type0
-import Language.Symantic.Type.Type1
-import Language.Symantic.Type.Type2
-import Language.Symantic.Type.Constraint
-import Language.Symantic.Type.Family
-
--- * Type 'Type_Tuple2'
--- | The @(,)@ type.
-type Type_Tuple2 = Type2 (Proxy (,))
-
-pattern Type_Tuple2
- :: root a -> root b
- -> Type_Tuple2 root ((,) a b)
-pattern Type_Tuple2 a b
- = Type2 Proxy a b
-
-instance Type1_Unlift Type_Tuple2 where
- type1_unlift (Type2 px a b) k =
- k ( Type1 (Proxy::Proxy ((,) a)) b
- , Type1_Lift (\(Type1 _ b') -> Type2 px a b')
- )
-instance
- Type0_Constraint Eq root =>
- Type0_Constraint Eq (Type_Tuple2 root) where
- type0_constraint c (Type2 _ a b)
- | Just Dict <- type0_constraint c a
- , Just Dict <- type0_constraint c b
- = Just Dict
- type0_constraint _c _ = Nothing
-instance
- Type0_Constraint Ord root =>
- Type0_Constraint Ord (Type_Tuple2 root) where
- type0_constraint c (Type2 _ a b)
- | Just Dict <- type0_constraint c a
- , Just Dict <- type0_constraint c b
- = Just Dict
- type0_constraint _c _ = Nothing
-instance
- Type0_Constraint Monoid root =>
- Type0_Constraint Monoid (Type_Tuple2 root) where
- type0_constraint c (Type2 _ a b)
- | Just Dict <- type0_constraint c a
- , Just Dict <- type0_constraint c b
- = Just Dict
- type0_constraint _c _ = Nothing
-instance Type0_Constraint Num (Type_Tuple2 root)
-instance Type0_Constraint Integral (Type_Tuple2 root)
-instance Type0_Family Type_Family_MonoElement (Type_Tuple2 root) where
- type0_family _at (Type2 _px _a b) = Just b
-instance Type0_Constraint MT.MonoFunctor (Type_Tuple2 root) where
- type0_constraint _c Type2{} = Just Dict
-instance Type1_Constraint Functor (Type_Tuple2 root) where
- type1_constraint _c Type2{} = Just Dict
-instance
- Type0_Constraint Monoid root =>
- Type1_Constraint Applicative (Type_Tuple2 root) where
- type1_constraint _c (Type2 _ a _b)
- | Just Dict <- type0_constraint (Proxy::Proxy Monoid) a
- = Just Dict
- type1_constraint _c _ = Nothing
-instance Type1_Constraint Foldable (Type_Tuple2 root) where
- type1_constraint _c Type2{} = Just Dict
-instance Type1_Constraint Traversable (Type_Tuple2 root) where
- type1_constraint _c Type2{} = Just Dict
-instance -- Type0_Eq
- Type0_Eq root =>
- Type0_Eq (Type_Tuple2 root) where
- type0_eq (Type2 _px1 a1 b1) (Type2 _px2 a2 b2)
- | Just Refl <- a1 `type0_eq` a2
- , Just Refl <- b1 `type0_eq` b2
- = Just Refl
- type0_eq _ _ = Nothing
-instance -- Type1_Eq
- Type0_Eq root =>
- Type1_Eq (Type_Tuple2 root) where
- type1_eq (Type2 _px1 a1 _b1) (Type2 _px2 a2 _b2)
- | Just Refl <- a1 `type0_eq` a2
- = Just Refl
- type1_eq _ _ = Nothing
-instance -- String_from_Type
- String_from_Type root =>
- String_from_Type (Type_Tuple2 root) where
- string_from_type (Type2 _ a b) =
- "(" ++ string_from_type a ++
- ", " ++ string_from_type b ++ ")"
-
--- | Inject 'Type_Tuple2' within a root type.
-type_tuple2
- :: Type_Root_Lift Type_Tuple2 root
- => root h_a -> root h_b -> root (h_a, h_b)
-type_tuple2 = type2
+++ /dev/null
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Language.Symantic.Type.Type0 where
-
-import Data.Maybe (isJust)
-import Data.Proxy
-import Data.Type.Equality ((:~:)(Refl))
-
-import Language.Symantic.Lib.Data.Peano
-import Language.Symantic.Type.Root
-import Language.Symantic.Type.Alt
-import Language.Symantic.Type.Error
-
--- * Type 'Type0'
--- | A type of kind @*@.
-data Type0 px (root:: * -> *) h where
- Type0 :: px -> Type0 px root (Host0_of px)
-
-type instance Root_of_Type (Type0 px root) = root
-type instance Error_of_Type ast (Type0 px root) = No_Error_Type
-
-instance -- Type0_Eq
- Type0_Eq (Type0 (Proxy h0) root) where
- type0_eq Type0{} Type0{} = Just Refl
-instance -- Type0_Eq
- Type0_Eq (Type0 EPeano root) where
- type0_eq (Type0 p1) (Type0 p2) | p1 == p2 = Just Refl
- type0_eq _ _ = Nothing
-instance -- Eq
- Type0_Eq (Type0 px root) =>
- Eq (Type0 px root h) where
- x == y = isJust $ x `type0_eq` y
-instance -- Show
- String_from_Type (Type0 (Proxy h0) root) =>
- Show (Type0 (Proxy h0) root h0) where
- show = string_from_type
-
--- | Inject a 'Type0' within a root type.
-type0 :: Type_Root_Lift (Type0 (Proxy h0)) root => root h0
-type0 = type_root_lift (Type0 (Proxy::Proxy h0))
-
--- ** Type family 'Host0_of'
-type family Host0_of px :: *
-type instance Host0_of (Proxy h0) = h0
-
--- ** Type 'Type0_Lift'
--- | Apply 'Peano_of_Type' on 'Type0_LiftP'.
-type Type0_Lift ty tys
- = Type0_LiftP (Peano_of_Type ty tys) ty tys
-instance
- Type0_Lift ty root =>
- Type_Root_Lift ty (Type_Root root) where
- type_root_lift = Type_Root . type0_lift
-
--- *** Type 'Peano_of_Type'
--- | Return a 'Peano' number derived from the location
--- of a given type within a given type stack,
--- which is used to avoid @OverlappingInstances@.
-type family Peano_of_Type
- (ty:: (* -> *) -> * -> *)
- (tys:: (* -> *) -> * -> *) :: * where
- Peano_of_Type ty ty = Zero
- Peano_of_Type ty (Type_Alt ty next) = Zero
- Peano_of_Type other (Type_Alt curr next) = Succ (Peano_of_Type other next)
-
--- *** Class 'Type0_LiftP'
--- | Lift a given type to the top of a given type stack including it,
--- by constructing the appropriate sequence of 'Type_Alt_Curr' and 'Type_Alt_Next'.
-class Type0_LiftP (p:: *) ty tys where
- type0_liftP :: forall (root:: * -> *) h. Proxy p -> ty root h -> tys root h
-instance Type0_LiftP Zero curr curr where
- type0_liftP _ = id
-instance Type0_LiftP Zero curr (Type_Alt curr next) where
- type0_liftP _ = Type_Alt_Curr
-instance
- Type0_LiftP p other next =>
- Type0_LiftP (Succ p) other (Type_Alt curr next) where
- type0_liftP _ = Type_Alt_Next . type0_liftP (Proxy::Proxy p)
-
--- | Convenient wrapper around 'type0_liftP',
--- passing it the 'Peano' number from 'Peano_of_Type'.
-type0_lift
- :: forall ty tys (root:: * -> *) h.
- Type0_Lift ty tys =>
- ty root h -> tys root h
-type0_lift = type0_liftP (Proxy::Proxy (Peano_of_Type ty tys))
-
--- ** Type 'Type0_Unlift'
--- | Apply 'Peano_of_Type' on 'Type0_UnliftP'.
-type Type0_Unlift ty tys
- = Type0_UnliftP (Peano_of_Type ty tys) ty tys
-
--- *** Class 'Type0_UnliftP'
--- | Try to unlift a given type out of a given type stack including it,
--- by deconstructing the appropriate sequence of 'Type_Alt_Curr' and 'Type_Alt_Next'.
-class Type0_UnliftP (p:: *) ty tys where
- type0_unliftP :: forall (root:: * -> *) h. Proxy p -> tys root h -> Maybe (ty root h)
-instance Type0_UnliftP Zero curr curr where
- type0_unliftP _ = Just
-instance Type0_UnliftP Zero curr (Type_Alt curr next) where
- type0_unliftP _ (Type_Alt_Curr x) = Just x
- type0_unliftP _ (Type_Alt_Next _) = Nothing
-instance
- Type0_UnliftP p other next =>
- Type0_UnliftP (Succ p) other (Type_Alt curr next) where
- type0_unliftP _ (Type_Alt_Next x) = type0_unliftP (Proxy::Proxy p) x
- type0_unliftP _ (Type_Alt_Curr _) = Nothing
-
--- | Convenient wrapper around 'type0_unliftP',
--- passing it the 'Peano' number from 'Peano_of_Type'.
-type0_unlift
- :: forall ty tys (root:: * -> *) h.
- Type0_Unlift ty tys =>
- tys root h -> Maybe (ty root h)
-type0_unlift = type0_unliftP (Proxy::Proxy (Peano_of_Type ty tys))
-
--- * Class 'Type0_Eq'
--- | Test two types for equality,
--- returning an Haskell type-level proof
--- of the equality when it holds.
-class Type0_Eq (ty:: * -> *) where
- type0_eq :: forall h1 h2. ty h1 -> ty h2 -> Maybe (h1 :~: h2)
-instance -- Type_Root
- Type0_Eq (ty (Type_Root ty)) =>
- Type0_Eq (Type_Root ty) where
- type0_eq (Type_Root x) (Type_Root y) = x `type0_eq` y
-instance -- Eq Type_Root
- Type0_Eq (Type_Root ty) =>
- Eq (Type_Root ty h) where
- x == y = isJust $ x `type0_eq` y
-instance -- Type_Alt
- ( Type0_Eq (curr root)
- , Type0_Eq (next root)
- ) => Type0_Eq (Type_Alt curr next root) where
- type0_eq (Type_Alt_Curr x) (Type_Alt_Curr y) = x `type0_eq` y
- type0_eq (Type_Alt_Next x) (Type_Alt_Next y) = x `type0_eq` y
- type0_eq _ _ = Nothing
-instance -- Eq Type_Alt
- ( Type0_Eq (curr root)
- , Type0_Eq (next root)
- ) => Eq (Type_Alt curr next root h) where
- x == y = isJust $ x `type0_eq` y
-
--- * Class 'Type0_From'
--- | Parse given @ast@ into a 'Root_of_Type',
--- or return an 'Error_of_Type'.
---
--- NOTE: making a distinction between @ty@ and 'Root_of_Type'@ ty@,
--- instead of having only a @root@ variable
--- is what enables to define many instances, one per type.
-class Type0_From ast (ty:: * -> *) where
- type0_from
- :: Proxy ty
- -> ast
- -> (forall h. Root_of_Type ty h
- -> Either (Error_of_Type ast (Root_of_Type ty)) ret)
- -> Either (Error_of_Type ast (Root_of_Type ty)) ret
-instance -- Type_Root
- ( Type0_Eq (Type_Root ty)
- , Type0_From ast (ty (Type_Root ty))
- , Root_of_Type (ty (Type_Root ty)) ~ Type_Root ty
- ) => Type0_From ast (Type_Root ty) where
- type0_from _ty = type0_from (Proxy::Proxy (ty (Type_Root ty)))
-instance -- Type_Alt
- ( Type0_Eq (curr root)
- , Type0_From ast (curr root)
- , Type0_From ast (next root)
- , Root_of_Type (curr root) ~ root
- , Root_of_Type (next root) ~ root
- , Error_Type_Unlift (Error_Type ast) (Error_of_Type ast root)
- ) => Type0_From ast (Type_Alt curr next root) where
- type0_from _ty ast k =
- case type0_from (Proxy::Proxy (curr root)) ast (Right . k) of
- Right ret -> ret
- Left err ->
- case error_type_unlift err of
- Just (Error_Type_Unsupported_here (_::ast)) ->
- type0_from (Proxy::Proxy (next root)) ast k
- _ -> Left err
-
--- * Class 'String_from_Type'
--- | Return a 'String' from a type.
-class String_from_Type ty where
- string_from_type :: ty h -> String
-instance -- Type_Root
- String_from_Type (ty (Type_Root ty)) =>
- String_from_Type (Type_Root ty) where
- string_from_type (Type_Root ty) = string_from_type ty
-instance -- Show Type_Root
- String_from_Type (Type_Root ty) =>
- Show (Type_Root ty h) where
- show = string_from_type
-instance -- Type_Alt
- ( String_from_Type (curr root)
- , String_from_Type (next root)
- ) => String_from_Type (Type_Alt curr next root) where
- string_from_type (Type_Alt_Curr t) = string_from_type t
- string_from_type (Type_Alt_Next t) = string_from_type t
-
--- * Type 'Exists_Type0'
--- | Existential data type wrapping the index of a 'Type0'.
-data Exists_Type0 ty
- = forall h. Exists_Type0 (ty h)
-instance -- Eq
- Type0_Eq ty =>
- Eq (Exists_Type0 ty) where
- Exists_Type0 xh == Exists_Type0 yh =
- isJust $ xh `type0_eq` yh
-instance -- Show
- String_from_Type ty =>
- Show (Exists_Type0 ty) where
- show (Exists_Type0 ty) = string_from_type ty
-
--- * Type 'Exists_Type0_and_Repr'
-data Exists_Type0_and_Repr ty repr
- = forall h.
- Exists_Type0_and_Repr (ty h) (repr h)
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-module Language.Symantic.Type.Type1 where
-
-import Data.Maybe (isJust, fromMaybe)
-import Data.Proxy
-import Data.Type.Equality ((:~:)(Refl))
-
-import Language.Symantic.Lib.Data.Peano
-import Language.Symantic.Lib.Data.Bool
-import Language.Symantic.Type.Root
-import Language.Symantic.Type.Alt
-import Language.Symantic.Type.Error
-import Language.Symantic.Type.Type0
-
--- * Type 'Type1'
--- | A type of kind @(* -> *)@.
-data Type1 px (root:: * -> *) h where
- Type1 :: px -> root a -> Type1 px root ((Host1_of px) a)
-
-type instance Root_of_Type (Type1 px root) = root
-type instance Error_of_Type ast (Type1 px root) = No_Error_Type
-
-instance -- Type0_Eq
- Type0_Eq root =>
- Type0_Eq (Type1 (Proxy h1) root) where
- type0_eq (Type1 _px1 a1) (Type1 _px2 a2)
- | Just Refl <- a1 `type0_eq` a2
- = Just Refl
- type0_eq _ _ = Nothing
-instance -- Type0_Eq
- Type0_Eq root =>
- Type0_Eq (Type1 EPeano root) where
- type0_eq (Type1 p1 a1)
- (Type1 p2 a2)
- | p1 == p2
- , Just Refl <- a1 `type0_eq` a2
- = Just Refl
- type0_eq _ _ = Nothing
-instance -- Eq
- Type0_Eq root =>
- Eq (Type1 (Proxy h1) root h) where
- x == y = isJust $ type0_eq x y
-instance -- Eq
- Type0_Eq root =>
- Eq (Type1 EPeano root h) where
- x == y = isJust $ type0_eq x y
-instance -- Type1_Eq
- Type1_Eq (Type1 (Proxy t1) root) where
- type1_eq Type1{} Type1{} = Just Refl
-instance -- Show
- String_from_Type (Type1 px root) =>
- Show (Type1 px root h) where
- show = string_from_type
-
--- | Inject a 'Type1' within a root type.
-type1
- :: forall root h1 a.
- Type_Root_Lift (Type1 (Proxy h1)) root
- => root a -> root (h1 a)
-type1 = type_root_lift . Type1 (Proxy::Proxy h1)
-
--- ** Type family 'Host1_of'
-type family Host1_of px :: * -> *
-type instance Host1_of (Proxy h1) = h1
-
--- * Class 'Type1_Eq'
--- | Test two type constructors for equality,
--- returning an Haskell type-level proof
--- of the equality when it holds.
-class Type1_Eq (ty:: * -> *) where
- type1_eq :: forall h1 h2 a1 a2. ty (h1 a1) -> ty (h2 a2) -> Maybe (h1 :~: h2)
- type1_eq = error "type1_eq"
-instance -- Type_Root
- Type1_Eq (ty (Type_Root ty)) =>
- Type1_Eq (Type_Root ty) where
- type1_eq (Type_Root x) (Type_Root y) = x `type1_eq` y
-instance -- Type_Alt
- ( Type1_Eq (curr root)
- , Type1_Eq (next root)
- ) => Type1_Eq (Type_Alt curr next root) where
- type1_eq (Type_Alt_Curr x) (Type_Alt_Curr y) = x `type1_eq` y
- type1_eq (Type_Alt_Next x) (Type_Alt_Next y) = x `type1_eq` y
- type1_eq _ _ = Nothing
-instance -- Type0 (Proxy h0)
- Type1_Eq (Type0 (Proxy h0) root)
-
--- * Class 'Type1_From'
--- | Parse given @ast@ into a 'Root_of_Type' constructor,
--- or return an 'Error_of_Type'.
-class Type1_From ast (ty:: * -> *) where
- type1_from
- :: Proxy ty
- -> ast
- -> (forall (h1:: * -> *). Proxy h1
- -> (forall h. Root_of_Type ty h -> Root_of_Type ty (h1 h))
- -> Either (Error_of_Type ast (Root_of_Type ty)) ret)
- -> Either (Error_of_Type ast (Root_of_Type ty)) ret
-instance -- Type_Root
- ( Type0_Eq (Type_Root ty)
- , Type1_From ast (ty (Type_Root ty))
- , Root_of_Type (ty (Type_Root ty)) ~ Type_Root ty
- ) => Type1_From ast (Type_Root ty) where
- type1_from _ty = type1_from (Proxy::Proxy (ty (Type_Root ty)))
-instance -- Type_Alt
- ( Type0_Eq (curr root)
- , Type1_From ast (curr root)
- , Type1_From ast (next root)
- , Root_of_Type (curr root) ~ root
- , Root_of_Type (next root) ~ root
- , Error_Type_Unlift (Error_Type ast) (Error_of_Type ast root)
- ) => Type1_From ast (Type_Alt curr next root) where
- type1_from _ty ast k =
- case type1_from (Proxy::Proxy (curr root)) ast (\f ty -> Right $ k f ty) of
- Right ret -> ret
- Left err ->
- case error_type_unlift err of
- Just (Error_Type_Unsupported_here (_::ast)) ->
- type1_from (Proxy::Proxy (next root)) ast k
- _ -> Left err
-instance
- ( Error_Type_Lift (Error_Type ast) (Error_of_Type ast root)
- , IBool (Is_Last_Type (Type0 px root) root)
- ) => Type1_From ast (Type0 px root) where
- type1_from ty ast _k =
- Left $ error_type_unsupported ty ast
-instance
- ( Error_Type_Lift (Error_Type ast) (Error_of_Type ast root)
- , IBool (Is_Last_Type (Type1 EPeano root) root)
- ) => Type1_From ast (Type1 EPeano root) where
- type1_from ty ast _k =
- Left $ error_type_unsupported ty ast
-
--- ** Type 'Type1_Lift'
-data Type1_Lift px root tys
- = Type1_Lift (forall h. Type1 px root h -> tys root h)
-
--- ** Type 'Type1_Unlift'
-class Type1_Unlift ty where
- type1_unlift
- :: forall (root:: * -> *) ret h.
- ty root h
- -> (forall (px:: *).
- ( Type1 px root h
- , Type1_Lift px root ty
- ) -> Maybe ret)
- -> Maybe ret
-instance Type1_Unlift (Type0 px) where
- type1_unlift _ty _k = Nothing
-instance Type1_Unlift (Type1 px) where
- type1_unlift ty k = k (ty, Type1_Lift id)
-instance -- Type_Alt
- ( Type1_Unlift curr
- , Type1_Unlift next
- ) => Type1_Unlift (Type_Alt curr next) where
- type1_unlift (Type_Alt_Curr ty) k =
- fromMaybe Nothing $ type1_unlift ty $ \(t, Type1_Lift l) ->
- Just $ k (t, Type1_Lift $ Type_Alt_Curr . l)
- type1_unlift (Type_Alt_Next ty) k =
- fromMaybe Nothing $ type1_unlift ty $ \(t, Type1_Lift l) ->
- Just $ k (t, Type1_Lift $ Type_Alt_Next . l)
-
--- * Type 'Exists_Type1'
--- | Existential data type wrapping the index of a 'Type1'.
-data Exists_Type1 ty
- = forall h. Exists_Type1 (ty h -> ty h)
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
-module Language.Symantic.Type.Type2 where
-
-import Data.Maybe (isJust)
-import Data.Proxy
-import Data.Type.Equality ((:~:)(Refl))
-
-import Language.Symantic.Lib.Data.Peano
--- import Language.Symantic.Lib.Data.Bool
-import Language.Symantic.Type.Root
--- import Language.Symantic.Type.Alt
-import Language.Symantic.Type.Error
-import Language.Symantic.Type.Type0
--- import Language.Symantic.Type.Type1
-
--- * Type 'Type2'
--- | A type of kind @(* -> * -> *)@.
-data Type2 px (root:: * -> *) h where
- Type2 :: px -> root a -> root b
- -> Type2 px root ((Host2_of px) a b)
-
-type instance Root_of_Type (Type2 px root) = root
-type instance Error_of_Type ast (Type2 px root) = No_Error_Type
-
-instance -- Type0_Eq
- Type0_Eq root =>
- Type0_Eq (Type2 (Proxy h2) root) where
- type0_eq
- (Type2 _ arg1 res1)
- (Type2 _ arg2 res2)
- | Just Refl <- arg1 `type0_eq` arg2
- , Just Refl <- res1 `type0_eq` res2
- = Just Refl
- type0_eq _ _ = Nothing
-instance -- Type0_Eq
- Type0_Eq root =>
- Type0_Eq (Type2 EPeano root) where
- type0_eq (Type2 p1 arg1 res1)
- (Type2 p2 arg2 res2)
- | p1 == p2
- , Just Refl <- arg1 `type0_eq` arg2
- , Just Refl <- res1 `type0_eq` res2
- = Just Refl
- type0_eq _ _ = Nothing
-instance -- Eq
- Type0_Eq root =>
- Eq (Type2 (Proxy h2) root h) where
- x == y = isJust $ x `type0_eq` y
-instance -- Eq
- Type0_Eq root =>
- Eq (Type2 EPeano root h) where
- x == y = isJust $ x `type0_eq` y
-instance -- Show
- ( String_from_Type root
- , String_from_Type (Type2 px root)
- ) => Show (Type2 px root h) where
- show = string_from_type
-
--- | Inject a 'Type2' within a root type.
-type2
- :: forall root h2 a b.
- Type_Root_Lift (Type2 (Proxy h2)) root
- => root a -> root b -> root (h2 a b)
-type2 a b = type_root_lift $ Type2 (Proxy::Proxy h2) a b
-
--- ** Type 'Host2_of'
-type family Host2_of px :: * -> * -> *
-type instance Host2_of (Proxy h2) = h2
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Language.Symantic.Type.Unit where
-
-import qualified Data.MonoTraversable as MT
-import Data.Proxy
-
-import Language.Symantic.Type.Root
-import Language.Symantic.Type.Type0
-import Language.Symantic.Type.Constraint
-import Language.Symantic.Type.Family
-
--- * Type 'Type_Unit'
--- | The @()@ type.
-type Type_Unit = Type0 (Proxy ())
-
-pattern Type_Unit :: Type_Unit root ()
-pattern Type_Unit = Type0 Proxy
-
-instance Type0_Constraint Eq (Type_Unit root) where
- type0_constraint _c Type0{} = Just Dict
-instance Type0_Constraint Ord (Type_Unit root) where
- type0_constraint _c Type0{} = Just Dict
-instance Type0_Constraint Monoid (Type_Unit root)
-instance Type0_Constraint Num (Type_Unit root)
-instance Type0_Constraint Integral (Type_Unit root)
-instance Type0_Family Type_Family_MonoElement (Type_Unit root)
-instance Type0_Constraint MT.MonoFunctor (Type_Unit root)
-instance String_from_Type (Type_Unit root) where
- string_from_type _ = "()"
-
--- | Inject 'Type_Unit' within a root type.
-type_unit :: Type_Root_Lift Type_Unit root => root ()
-type_unit = type0
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-missing-methods #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
--- | Type variable.
-module Language.Symantic.Type.Var
- ( module Language.Symantic.Type.Var
- , module Language.Symantic.Lib.Data.Peano
- ) where
-
-import qualified Data.MonoTraversable as MT
-import Data.Type.Equality ((:~:)(Refl))
-
-import Language.Symantic.Lib.Data.Peano
-import Language.Symantic.Type.Root
-import Language.Symantic.Type.Type0
-import Language.Symantic.Type.Type1
-import Language.Symantic.Type.Constraint
-import Language.Symantic.Type.Family
-
--- * Type 'Var0'
-newtype Var0 = Var0 EPeano
-type instance Host0_of EPeano = Var0
-
--- | Undefined instance required to build errors.
-instance Eq Var0
--- | Undefined instance required to build errors.
-instance Ord Var0
--- | Undefined instance required to build errors.
-instance Monoid Var0
-
--- * Type 'Var1'
-newtype Var1 a = Var1 EPeano
-type instance Host1_of EPeano = Var1
-
--- * Type 'Type_Var0'
--- | The variable type of kind @*@.
-type Type_Var0 = Type0 EPeano
-
-pattern Type_Var0 :: SPeano p -> Type_Var0 root Var0
-pattern Type_Var0 p = Type0 (EPeano p)
-
-instance Type1_Eq (Type_Var0 root) where
-instance Type0_Constraint Eq (Type_Var0 root)
-instance Type0_Constraint Monoid (Type_Var0 root)
-instance Type0_Constraint Ord (Type_Var0 root)
-instance Type0_Constraint Num (Type_Var0 root)
-instance Type0_Constraint Integral (Type_Var0 root)
-instance Type0_Constraint MT.MonoFunctor (Type_Var0 root)
-instance Type0_Family Type_Family_MonoElement (Type_Var0 root)
-instance String_from_Type (Type_Var0 root) where
- string_from_type (Type0 (EPeano p)) =
- "t" ++ show (integral_from_peano p::Integer)
-
--- | Inject 'Type_Var0' within a root type.
-type_var0 :: Type_Root_Lift Type_Var0 root => SPeano p -> root Var0
-type_var0 = type_root_lift . Type0 . EPeano
-
--- * Type 'Type_Var1'
--- | The variable type of kind @* -> *@.
-type Type_Var1 = Type1 EPeano
-
-pattern Type_Var1 :: SPeano p -> root a -> Type_Var1 root (Var1 a)
-pattern Type_Var1 p a = Type1 (EPeano p) a
-
-instance Type0_Constraint Eq (Type_Var1 root)
-instance Type0_Constraint Ord (Type_Var1 root)
-instance Type0_Constraint Monoid (Type_Var1 root)
-instance Type0_Constraint Num (Type_Var1 root)
-instance Type0_Constraint Integral (Type_Var1 root)
-instance Type0_Constraint MT.MonoFunctor (Type_Var1 root)
-instance Type1_Constraint Applicative (Type_Var1 root)
-instance Type1_Constraint Foldable (Type_Var1 root)
-instance Type1_Constraint Functor (Type_Var1 root)
-instance Type1_Constraint Monad (Type_Var1 root)
-instance Type1_Constraint Traversable (Type_Var1 root)
-instance Type0_Family Type_Family_MonoElement (Type_Var1 root)
-instance Type1_Eq (Type_Var1 root) where
- type1_eq (Type1 p1 _) (Type1 p2 _) | p1 == p2 = Just Refl
- type1_eq _ _ = Nothing
-instance -- String_from_Type
- String_from_Type root =>
- String_from_Type (Type_Var1 root) where
- string_from_type (Type1 (EPeano p) a) =
- "t_" ++ show (integral_from_peano p::Integer) ++
- " " ++ string_from_type a
-
--- | Inject 'Type_Var1' within a root type.
-type_var1 :: Type_Root_Lift Type_Var1 root => SPeano p -> root a -> root (Var1 a)
-type_var1 p = type_root_lift . Type_Var1 p
--- /dev/null
+-- | Types for the expressions.
+module Language.Symantic.Typing
+ ( module Language.Symantic.Typing.Kind
+ , module Language.Symantic.Typing.Constant
+ , module Language.Symantic.Typing.Type
+ , module Language.Symantic.Typing.Constraint
+ , module Language.Symantic.Typing.Syntax
+ ) where
+
+import Language.Symantic.Typing.Kind
+import Language.Symantic.Typing.Constant
+import Language.Symantic.Typing.Type
+import Language.Symantic.Typing.Constraint
+import Language.Symantic.Typing.Syntax
--- /dev/null
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Language.Symantic.Typing.Constant where
+
+import Data.Proxy
+import Data.Type.Equality
+import GHC.Prim (Constraint)
+
+import Language.Symantic.Lib.Data.Peano
+import Language.Symantic.Typing.Kind
+
+-- * Type 'Const'
+-- | A /type constant/,
+-- indexed at the Haskell type and term level amongst a list of them.
+-- When used, @c@ is actually wrapped within a 'Proxy'
+-- to be able to handle constants of different 'Kind's.
+data Const (cs::[*]) (c:: *) where
+ ConstZ :: SKind (Kind_of_Proxy c) -> Const (c ': cs) c
+ ConstS :: Const cs c -> Const (not_c ': cs) c
+infixr 5 `ConstS`
+
+instance TestEquality (Const cs) where
+ testEquality ConstZ{} ConstZ{} = Just Refl
+ testEquality (ConstS x) (ConstS y) = testEquality x y
+ testEquality _ _ = Nothing
+
+kind_of_const :: Const cs h -> SKind (Kind_of_Proxy h)
+kind_of_const (ConstZ ki) = ki
+kind_of_const (ConstS c) = kind_of_const c
+
+-- ** Type 'Const_of'
+-- | Convenient type synonym.
+type Const_of cs c = Const cs (Proxy c)
+
+-- ** Type 'ConstP'
+-- | Return the position of a 'Const' within a list of them.
+-- This is useful to work around @OverlappingInstances@
+-- in 'Inj_ConstP' and 'Proj_ConstP'.
+type family ConstP cs c where
+ ConstP (c ': cs) c = Zero
+ ConstP (nc ': cs) c = Succ (ConstP cs c)
+
+-- ** Type 'Inj_Const'
+-- | Convenient type synonym wrapping 'Inj_ConstP'
+-- applied on the correct 'ConstP'.
+type Inj_Const cs c = Inj_ConstP (ConstP cs (Proxy c)) cs (Proxy c)
+
+-- | Inject a given /type constant/ @c@ into a list of them,
+-- by returning a proof that 'Proxy'@ c@ is in @cs@.
+inj_const :: forall cs c. Inj_Const cs c => Const cs (Proxy c)
+inj_const = inj_constP (Proxy::Proxy (ConstP cs (Proxy c)))
+
+-- ** Class 'Inj_ConstP'
+class Inj_ConstP p cs c where
+ inj_constP :: Proxy p -> Const cs c
+instance IKind (Kind_of_Proxy c) => Inj_ConstP Zero (c ': cs) c where
+ inj_constP _ = ConstZ kind
+instance Inj_ConstP p cs c => Inj_ConstP (Succ p) (not_c ': cs) c where
+ inj_constP _p = ConstS (inj_constP (Proxy::Proxy p))
+
+-- ** Class 'Proj_Const'
+-- | Convenient class synonym wrapping 'Proj_ConstP'
+-- applied on the correct 'ConstP'.
+--
+-- NOTE: using a /class synonym/ instead of a /type synonym/
+-- allows to use it partially applied, which is useful in 'Map_Consts'.
+class Proj_ConstP (ConstP cs c) cs c => Proj_Const cs c
+instance Proj_ConstP (ConstP cs c) cs c => Proj_Const cs c
+-- type Proj_Const cs c = Proj_ConstP (ConstP cs c) cs c
+
+-- | Project a 'Const' onto a Haskell type level /type constant/ @c@,
+-- returning a proof that the 'Const' indexes @c@ iif. it's the case.
+proj_const :: forall cs c u. Proj_Const cs c => Const cs u -> c -> Maybe (c :~: u)
+proj_const = proj_constP (Proxy::Proxy (ConstP cs c))
+
+(=?) :: forall cs c u. Proj_Const cs c => Const cs u -> c -> Maybe (c :~: u)
+(=?) = proj_constP (Proxy::Proxy (ConstP cs c))
+
+-- *** Type 'Proj_ConstP'
+class Proj_ConstP p cs c where
+ proj_constP :: Proxy p -> Const cs u -> c -> Maybe (c :~: u)
+instance Proj_ConstP Zero (c ': cs) c where
+ proj_constP _p ConstZ{} _c = Just Refl
+ proj_constP _p ConstS{} _c = Nothing
+instance Proj_ConstP p cs c => Proj_ConstP (Succ p) (not_c ': cs) c where
+ proj_constP _p ConstZ{} _c = Nothing
+ proj_constP _p (ConstS u) c = proj_constP (Proxy::Proxy p) u c
+
+-- * Type 'Proj_Consts'
+type Proj_Consts rs cs = Concat_Constraints (Map_Consts (Proj_Const rs) cs)
+
+-- * Type 'Consts'
+-- | Usual 'Const's.
+type Consts = Terms ++ Constraints
+
+-- ** Type 'Terms'
+-- | Usual 'Const's of /terms constructors/.
+type Terms =
+ [ Proxy []
+ , Proxy (->)
+ , Proxy Bool
+ , Proxy Int
+ , Proxy Integral
+ , Proxy IO
+ , Proxy Maybe
+ ]
+
+-- ** Type 'Constraints'
+-- | Usual 'Const's of /type constraint constructors/.
+type Constraints =
+ [ Proxy Applicative
+ , Proxy Bounded
+ , Proxy Enum
+ , Proxy Eq
+ , Proxy Foldable
+ , Proxy Functor
+ , Proxy Monad
+ , Proxy Monoid
+ , Proxy Num
+ , Proxy Ord
+ , Proxy Real
+ , Proxy Traversable
+ ]
+
+-- * Class 'Const_from'
+-- | Try to build a 'Const' from raw data.
+class Const_from raw cs where
+ const_from
+ :: raw -> (forall c. Const cs c -> Maybe ret)
+ -> Maybe ret
+
+instance Const_from raw '[] where
+ const_from _c _k = Nothing
+
+instance Const_from String cs => Const_from String (Proxy [] ': cs) where
+ const_from "[]" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+instance Const_from String cs => Const_from String (Proxy (->) ': cs) where
+ const_from "(->)" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+instance Const_from String cs => Const_from String (Proxy Applicative ': cs) where
+ const_from "Applicative" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+instance Const_from String cs => Const_from String (Proxy Bool ': cs) where
+ const_from "Bool" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+instance Const_from String cs => Const_from String (Proxy Bounded ': cs) where
+ const_from "Bounded" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+instance Const_from String cs => Const_from String (Proxy Char ': cs) where
+ const_from "Char" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+instance Const_from String cs => Const_from String (Proxy Eq ': cs) where
+ const_from "Eq" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+instance Const_from String cs => Const_from String (Proxy Enum ': cs) where
+ const_from "Enum" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+instance Const_from String cs => Const_from String (Proxy Foldable ': cs) where
+ const_from "Foldable" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+instance Const_from String cs => Const_from String (Proxy Fractional ': cs) where
+ const_from "Fractional" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+instance Const_from String cs => Const_from String (Proxy Functor ': cs) where
+ const_from "Functor" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+instance Const_from String cs => Const_from String (Proxy Int ': cs) where
+ const_from "Int" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+instance Const_from String cs => Const_from String (Proxy Integer ': cs) where
+ const_from "Integer" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+instance Const_from String cs => Const_from String (Proxy Integral ': cs) where
+ const_from "Integral" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+instance Const_from String cs => Const_from String (Proxy IO ': cs) where
+ const_from "IO" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+instance Const_from String cs => Const_from String (Proxy Maybe ': cs) where
+ const_from "Maybe" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+instance Const_from String cs => Const_from String (Proxy Monad ': cs) where
+ const_from "Monad" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+instance Const_from String cs => Const_from String (Proxy Monoid ': cs) where
+ const_from "Monoid" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+instance Const_from String cs => Const_from String (Proxy Num ': cs) where
+ const_from "Num" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+instance Const_from String cs => Const_from String (Proxy Ord ': cs) where
+ const_from "Ord" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+instance Const_from String cs => Const_from String (Proxy Real ': cs) where
+ const_from "Real" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+instance Const_from String cs => Const_from String (Proxy Traversable ': cs) where
+ const_from "Traversable" k = k (ConstZ kind)
+ const_from s k = const_from s $ k . ConstS
+
+-- * Class 'Show_Const'
+class Show_Const cs where
+ show_const :: Const cs c -> String
+
+instance Show_Const cs => Show (Const cs c) where
+ show = show_const
+instance Show_Const '[] where
+ show_const = error "Show_Const unreachable pattern"
+
+instance Show_Const cs => Show_Const (Proxy [] ': cs) where
+ show_const ConstZ{} = "[]"
+ show_const (ConstS c) = show_const c
+instance Show_Const cs => Show_Const (Proxy (->) ': cs) where
+ show_const ConstZ{} = "(->)"
+ show_const (ConstS c) = show_const c
+instance Show_Const cs => Show_Const (Proxy Applicative ': cs) where
+ show_const ConstZ{} = "Applicative"
+ show_const (ConstS c) = show_const c
+instance Show_Const cs => Show_Const (Proxy Bool ': cs) where
+ show_const ConstZ{} = "Bool"
+ show_const (ConstS c) = show_const c
+instance Show_Const cs => Show_Const (Proxy Bounded ': cs) where
+ show_const ConstZ{} = "Bounded"
+ show_const (ConstS c) = show_const c
+instance Show_Const cs => Show_Const (Proxy Char ': cs) where
+ show_const ConstZ{} = "Char"
+ show_const (ConstS c) = show_const c
+instance Show_Const cs => Show_Const (Proxy Enum ': cs) where
+ show_const ConstZ{} = "Enum"
+ show_const (ConstS c) = show_const c
+instance Show_Const cs => Show_Const (Proxy Eq ': cs) where
+ show_const ConstZ{} = "Eq"
+ show_const (ConstS c) = show_const c
+instance Show_Const cs => Show_Const (Proxy Foldable ': cs) where
+ show_const ConstZ{} = "Foldable"
+ show_const (ConstS c) = show_const c
+instance Show_Const cs => Show_Const (Proxy Fractional ': cs) where
+ show_const ConstZ{} = "Fractional"
+ show_const (ConstS c) = show_const c
+instance Show_Const cs => Show_Const (Proxy Functor ': cs) where
+ show_const ConstZ{} = "Functor"
+ show_const (ConstS c) = show_const c
+instance Show_Const cs => Show_Const (Proxy Int ': cs) where
+ show_const ConstZ{} = "Int"
+ show_const (ConstS c) = show_const c
+instance Show_Const cs => Show_Const (Proxy Integer ': cs) where
+ show_const ConstZ{} = "Integer"
+ show_const (ConstS c) = show_const c
+instance Show_Const cs => Show_Const (Proxy Integral ': cs) where
+ show_const ConstZ{} = "Integral"
+ show_const (ConstS c) = show_const c
+instance Show_Const cs => Show_Const (Proxy IO ': cs) where
+ show_const ConstZ{} = "IO"
+ show_const (ConstS c) = show_const c
+instance Show_Const cs => Show_Const (Proxy Maybe ': cs) where
+ show_const ConstZ{} = "Maybe"
+ show_const (ConstS c) = show_const c
+instance Show_Const cs => Show_Const (Proxy Monad ': cs) where
+ show_const ConstZ{} = "Monad"
+ show_const (ConstS c) = show_const c
+instance Show_Const cs => Show_Const (Proxy Monoid ': cs) where
+ show_const ConstZ{} = "Monoid"
+ show_const (ConstS c) = show_const c
+instance Show_Const cs => Show_Const (Proxy Num ': cs) where
+ show_const ConstZ{} = "Num"
+ show_const (ConstS c) = show_const c
+instance Show_Const cs => Show_Const (Proxy Ord ': cs) where
+ show_const ConstZ{} = "Ord"
+ show_const (ConstS c) = show_const c
+instance Show_Const cs => Show_Const (Proxy Real ': cs) where
+ show_const ConstZ{} = "Real"
+ show_const (ConstS c) = show_const c
+instance Show_Const cs => Show_Const (Proxy Traversable ': cs) where
+ show_const ConstZ{} = "Traversable"
+ show_const (ConstS c) = show_const c
+
+-- * Type family @(++)@
+type family (++) xs ys where
+ '[] ++ ys = ys
+ (x ': xs) ++ ys = x ': xs ++ ys
+infixr 5 ++
+
+-- * Type family 'Concat_Constraints'
+type family Concat_Constraints (cs::[Constraint]) :: Constraint where
+ Concat_Constraints '[] = ()
+ Concat_Constraints (c ': cs) = (c, Concat_Constraints cs)
+
+-- * Type family 'Map_Consts'
+type family Map_Consts (f:: * -> k) (cs::[*]) :: [k] where
+ Map_Consts f '[] = '[]
+ Map_Consts f (c ': cs) = f c ': Map_Consts f cs
+
--- /dev/null
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Language.Symantic.Typing.Constraint where
+
+import Data.Maybe (fromMaybe)
+import Data.Proxy
+import Data.Type.Equality
+import GHC.Prim (Constraint)
+
+import Language.Symantic.Typing.Kind
+import Language.Symantic.Typing.Constant
+import Language.Symantic.Typing.Type
+
+-- * Type 'Dict'
+-- | 'Dict' captures the dictionary of a 'Constraint':
+-- pattern matching on the 'Dict' constructor
+-- brings the 'Constraint' into scope.
+data Dict :: Constraint -> * where
+ Dict :: c => Dict c
+
+-- * Type family 'Consts_imported_by'
+-- | Return the /type constant/s that a given /type constant/
+-- wants to be part of the final list of /type constants/.
+type family Consts_imported_by (c::k) :: [*]
+type instance Consts_imported_by [] =
+ [ Proxy Applicative
+ , Proxy Eq
+ , Proxy Foldable
+ , Proxy Functor
+ , Proxy Monad
+ , Proxy Monoid
+ , Proxy Ord
+ , Proxy Traversable
+ ]
+type instance Consts_imported_by (->) =
+ [ Proxy Applicative
+ , Proxy Functor
+ , Proxy Monad
+ , Proxy Monoid
+ ]
+type instance Consts_imported_by Applicative = '[]
+type instance Consts_imported_by Bool =
+ [ Proxy Bounded
+ , Proxy Enum
+ , Proxy Eq
+ , Proxy Ord
+ ]
+type instance Consts_imported_by Bounded = '[]
+type instance Consts_imported_by Eq = '[]
+type instance Consts_imported_by Enum = '[]
+type instance Consts_imported_by Foldable = '[]
+type instance Consts_imported_by Functor = '[]
+type instance Consts_imported_by Int =
+ [ Proxy Bounded
+ , Proxy Enum
+ , Proxy Eq
+ , Proxy Integral
+ , Proxy Num
+ , Proxy Ord
+ , Proxy Real
+ ]
+type instance Consts_imported_by Integer =
+ [ Proxy Enum
+ , Proxy Eq
+ , Proxy Integral
+ , Proxy Num
+ , Proxy Ord
+ , Proxy Real
+ ]
+type instance Consts_imported_by Integral =
+ [ Proxy Enum
+ , Proxy Real
+ ]
+type instance Consts_imported_by IO =
+ [ Proxy Applicative
+ , Proxy Functor
+ , Proxy Monad
+ ]
+type instance Consts_imported_by Maybe =
+ [ Proxy Applicative
+ , Proxy Eq
+ , Proxy Foldable
+ , Proxy Functor
+ , Proxy Monad
+ , Proxy Monoid
+ , Proxy Traversable
+ ]
+type instance Consts_imported_by Monad = '[]
+type instance Consts_imported_by Monoid = '[]
+type instance Consts_imported_by Num = '[]
+type instance Consts_imported_by Ord = '[]
+type instance Consts_imported_by Real = '[]
+type instance Consts_imported_by Traversable = '[]
+
+-- * Type 'Proj_Con'
+-- | Convenient type synonym wrapping 'Proj_ConR'
+-- initiating its recursion.
+type Proj_Con cs = Proj_ConR cs cs
+
+-- | Project a /type class/ constructor
+-- applied to a parameter onto a 'Constraint'.
+proj_con
+ :: forall cs q x ki_x. Proj_Con cs
+ => Type cs (ki_x ':> 'KiCon) q -- ^ 'Constraint' constructor.
+ -> Type cs ki_x x -- ^ Parameter for the 'Constraint' constructor.
+ -> Maybe (Dict (Con q x)) -- ^ 'Constraint' projected onto.
+proj_con = proj_conR (Proxy::Proxy cs)
+
+-- ** Class 'Proj_ConR'
+-- | Intermediate type class to construct an instance of 'Proj_Con'
+-- from many instances of 'Proj_ConC', one for each 'Const' of @cs@.
+--
+-- * @cs@: starting list of /type constants/.
+-- * @rs@: remaining list of /type constants/.
+class Proj_ConR cs rs where
+ proj_conR
+ :: Proxy rs
+ -> Type cs (ki_x ':> 'KiCon) q
+ -> Type cs ki_x x
+ -> Maybe (Dict (Con q x))
+ proj_conR _c _x _y = Nothing
+
+-- | Test whether @c@ handles the work of 'Proj_Con' or not,
+-- or recurse on @rs@, preserving the starting list of /type constants/.
+instance
+ ( Proj_ConC cs c
+ , Proj_ConR cs rs
+ ) => Proj_ConR cs (c ': rs) where
+ proj_conR _cs x y =
+ proj_conR (Proxy::Proxy rs) x y `fromMaybe`
+ proj_conC (Proxy::Proxy c) x y
+-- | End the recursion.
+instance Proj_ConR cs '[] where
+ proj_conR _cs _x _y = Nothing
+
+-- ** Class 'Proj_ConC'
+class Proj_ConC cs c where
+ proj_conC
+ :: Proxy c
+ -> Type cs (ki_x ':> 'KiCon) q
+ -> Type cs ki_x x
+ -> Maybe (Maybe (Dict (Con q x)))
+ proj_conC _c _x _y = Nothing
+
+instance -- []
+ ( Proj_Const cs (Proxy [])
+ , Proj_Consts cs (Consts_imported_by [])
+ , Proj_Con cs
+ ) => Proj_ConC cs (Proxy []) where
+ proj_conC _ x (TyConst c)
+ | Just Refl <- proj_const c (Proxy::Proxy [])
+ = Just $ case x of
+ TyConst q
+ | Just Refl <- proj_const q (Proxy::Proxy Applicative) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Foldable) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Functor) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Monad) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Traversable) -> Just Dict
+ _ -> Nothing
+ proj_conC _ x (TyConst c :$ a)
+ | Just Refl <- proj_const c (Proxy::Proxy [])
+ = Just $ case x of
+ t@(TyConst q)
+ | Just Refl <- proj_const q (Proxy::Proxy Eq)
+ , Just Dict <- proj_con t a -> Just Dict
+ t@(TyConst q)
+ | Just Refl <- proj_const q (Proxy::Proxy Monoid)
+ , Just Dict <- proj_con t a -> Just Dict
+ t@(TyConst q)
+ | Just Refl <- proj_const q (Proxy::Proxy Ord)
+ , Just Dict <- proj_con t a -> Just Dict
+ _ -> Nothing
+ proj_conC _ _ _ = Nothing
+instance -- (->)
+ ( Proj_Const cs (Proxy (->))
+ , Proj_Consts cs (Consts_imported_by (->))
+ , Proj_Con cs
+ ) => Proj_ConC cs (Proxy (->)) where
+ proj_conC _ x (TyConst c :$ _r)
+ | Just Refl <- proj_const c (Proxy::Proxy (->))
+ = Just $ case x of
+ (TyConst q)
+ | Just Refl <- proj_const q (Proxy::Proxy Functor) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Applicative) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Monad) -> Just Dict
+ _ -> Nothing
+ proj_conC _ x (TyConst c :$ _a :$ b)
+ | Just Refl <- proj_const c (Proxy::Proxy (->))
+ = Just $ case x of
+ t@(TyConst q)
+ | Just Refl <- proj_const q (Proxy::Proxy Monoid)
+ , Just Dict <- proj_con t b
+ -> Just Dict
+ _ -> Nothing
+ proj_conC _ _ _ = Nothing
+instance -- Applicative
+ ( Proj_Const cs (Proxy Applicative)
+ , Proj_Consts cs (Consts_imported_by Applicative)
+ ) => Proj_ConC cs (Proxy Applicative)
+instance -- Bool
+ ( Proj_Const cs (Proxy Bool)
+ , Proj_Consts cs (Consts_imported_by Bool)
+ ) => Proj_ConC cs (Proxy Bool) where
+ proj_conC _ x (TyConst c)
+ | Just Refl <- proj_const c (Proxy::Proxy Bool)
+ = Just $ case x of
+ TyConst q
+ | Just Refl <- proj_const q (Proxy::Proxy Bounded) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Enum) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Eq) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Ord) -> Just Dict
+ _ -> Nothing
+ proj_conC _ _ _ = Nothing
+instance -- Bounded
+ ( Proj_Const cs (Proxy Bounded)
+ , Proj_Consts cs (Consts_imported_by Bounded)
+ ) => Proj_ConC cs (Proxy Bounded)
+instance -- Enum
+ ( Proj_Const cs (Proxy Enum)
+ , Proj_Consts cs (Consts_imported_by Enum)
+ ) => Proj_ConC cs (Proxy Enum)
+instance -- Eq
+ ( Proj_Const cs (Proxy Eq)
+ , Proj_Consts cs (Consts_imported_by Eq)
+ ) => Proj_ConC cs (Proxy Eq)
+instance -- Foldable
+ ( Proj_Const cs (Proxy Foldable)
+ , Proj_Consts cs (Consts_imported_by Foldable)
+ ) => Proj_ConC cs (Proxy Foldable)
+instance -- Functor
+ ( Proj_Const cs (Proxy Functor)
+ , Proj_Consts cs (Consts_imported_by Functor)
+ ) => Proj_ConC cs (Proxy Functor)
+instance -- Int
+ ( Proj_Const cs (Proxy Int)
+ , Proj_Consts cs (Consts_imported_by Int)
+ ) => Proj_ConC cs (Proxy Int) where
+ proj_conC _ x (TyConst c)
+ | Just Refl <- proj_const c (Proxy::Proxy Int)
+ = Just $ case x of
+ TyConst q
+ | Just Refl <- proj_const q (Proxy::Proxy Bounded) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Enum) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Eq) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Integral) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Num) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Ord) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Real) -> Just Dict
+ _ -> Nothing
+ proj_conC _ _ _ = Nothing
+instance -- Integer
+ ( Proj_Const cs (Proxy Integer)
+ , Proj_Consts cs (Consts_imported_by Integer)
+ ) => Proj_ConC cs (Proxy Integer) where
+ proj_conC _ x (TyConst c)
+ | Just Refl <- proj_const c (Proxy::Proxy Integer)
+ = Just $ case x of
+ TyConst q
+ | Just Refl <- proj_const q (Proxy::Proxy Enum) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Eq) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Integral) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Num) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Ord) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Real) -> Just Dict
+ _ -> Nothing
+ proj_conC _ _ _ = Nothing
+instance -- Integral
+ ( Proj_Const cs (Proxy Integral)
+ , Proj_Consts cs (Consts_imported_by Integral)
+ ) => Proj_ConC cs (Proxy Integral)
+instance -- IO
+ ( Proj_Const cs (Proxy IO)
+ , Proj_Consts cs (Consts_imported_by IO)
+ ) => Proj_ConC cs (Proxy IO) where
+ proj_conC _ x (TyConst c)
+ | Just Refl <- proj_const c (Proxy::Proxy IO)
+ = Just $ case x of
+ TyConst q
+ | Just Refl <- proj_const q (Proxy::Proxy Applicative) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Functor) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Monad) -> Just Dict
+ _ -> Nothing
+ proj_conC _ _ _ = Nothing
+instance -- Maybe
+ ( Proj_Const cs (Proxy Maybe)
+ , Proj_Consts cs (Consts_imported_by Maybe)
+ , Proj_Con cs
+ ) => Proj_ConC cs (Proxy Maybe) where
+ proj_conC _ x (TyConst c)
+ | Just Refl <- proj_const c (Proxy::Proxy Maybe)
+ = Just $ case x of
+ TyConst q
+ | Just Refl <- proj_const q (Proxy::Proxy Applicative) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Foldable) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Functor) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Monad) -> Just Dict
+ | Just Refl <- proj_const q (Proxy::Proxy Traversable) -> Just Dict
+ _ -> Nothing
+ proj_conC _ x (TyConst c :$ a)
+ | Just Refl <- proj_const c (Proxy::Proxy Maybe)
+ = Just $ case x of
+ t@(TyConst q)
+ | Just Refl <- proj_const q (Proxy::Proxy Eq)
+ , Just Dict <- proj_con t a -> Just Dict
+ t@(TyConst q)
+ | Just Refl <- proj_const q (Proxy::Proxy Monoid)
+ , Just Dict <- proj_con t a -> Just Dict
+ _ -> Nothing
+ proj_conC _ _ _ = Nothing
+instance -- Monad
+ ( Proj_Const cs (Proxy Monad)
+ , Proj_Consts cs (Consts_imported_by Monad)
+ ) => Proj_ConC cs (Proxy Monad)
+instance -- Monoid
+ ( Proj_Const cs (Proxy Monoid)
+ , Proj_Consts cs (Consts_imported_by Monoid)
+ ) => Proj_ConC cs (Proxy Monoid)
+instance -- Num
+ ( Proj_Const cs (Proxy Num)
+ , Proj_Consts cs (Consts_imported_by Num)
+ ) => Proj_ConC cs (Proxy Num)
+instance -- Ord
+ ( Proj_Const cs (Proxy Ord)
+ , Proj_Consts cs (Consts_imported_by Ord)
+ ) => Proj_ConC cs (Proxy Ord)
+instance -- Real
+ ( Proj_Const cs (Proxy Real)
+ , Proj_Consts cs (Consts_imported_by Real)
+ ) => Proj_ConC cs (Proxy Real)
+instance -- Traversable
+ ( Proj_Const cs (Proxy Traversable)
+ , Proj_Consts cs (Consts_imported_by Traversable)
+ ) => Proj_ConC cs (Proxy Traversable)
--- /dev/null
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+module Language.Symantic.Typing.Kind where
+
+import Data.Proxy
+import Data.Type.Equality
+import GHC.Prim (Constraint)
+
+-- * Type 'Kind'
+-- | /Type of types/.
+data Kind
+ = KiTerm -- ^ \*
+ | KiCon -- ^ 'Constraint'
+ | (:>) Kind Kind -- ^ \->
+infixr 0 :>
+
+-- * Type family 'Kind_of'
+-- | To be completed on need, according to the /type constants/ used.
+type family Kind_of (x::k) :: Kind
+type instance Kind_of (x:: Constraint) = 'KiCon
+type instance Kind_of (x:: * -> Constraint) = 'KiTerm ':> 'KiCon
+type instance Kind_of (x:: *) = 'KiTerm
+type instance Kind_of (x:: * -> *) = 'KiTerm ':> 'KiTerm
+type instance Kind_of (x:: (* -> *) -> *) = ('KiTerm ':> 'KiTerm) ':> 'KiTerm
+type instance Kind_of (x:: (* -> *) -> Constraint) = ('KiTerm ':> 'KiTerm) ':> 'KiCon
+type instance Kind_of (x:: * -> * -> *) = 'KiTerm ':> 'KiTerm ':> 'KiTerm
+
+-- ** Type family 'Kind_of_Proxy'
+type family Kind_of_Proxy (x:: *) :: Kind where
+ Kind_of_Proxy (Proxy x) = Kind_of x
+-- | Convenient shorter type synonym.
+type Ki h = Kind_of_Proxy h
+
+-- * Type 'EKind'
+-- | Existential for 'Kind'.
+data EKind = forall k. EKind (SKind k)
+instance Eq EKind where
+ EKind x == EKind y
+ | Just _ <- testEquality x y = True
+ _x == _y = False
+instance Show EKind where
+ show (EKind x) = show x
+
+-- * Type 'SKind'
+-- | Singleton for 'Kind'.
+data SKind (k::Kind) where
+ SKiTerm :: SKind 'KiTerm
+ SKiCon :: SKind 'KiCon
+ SKiArrow :: SKind a -> SKind b -> SKind (a ':> b)
+instance TestEquality SKind where
+ testEquality SKiTerm SKiTerm = Just Refl
+ testEquality SKiCon SKiCon = Just Refl
+ testEquality (SKiArrow xa xb) (SKiArrow ya yb)
+ | Just Refl <- testEquality xa ya
+ , Just Refl <- testEquality xb yb
+ = Just Refl
+ testEquality _ _ = Nothing
+instance Show (SKind k) where
+ show SKiTerm = "*"
+ show SKiCon = "Constraint"
+ show (SKiArrow a b) = "(" ++ show a ++ " -> " ++ show b ++ ")"
+
+-- * Type 'IKind'
+-- | Implicit for 'Kind'.
+class IKind (k::Kind) where
+ kind :: SKind k
+instance IKind 'KiTerm where
+ kind = SKiTerm
+instance IKind 'KiCon where
+ kind = SKiCon
+instance (IKind a, IKind b) => IKind (a ':> b) where
+ kind = kind `SKiArrow` kind
--- /dev/null
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Language.Symantic.Typing.Syntax where
+
+import qualified Data.List as List
+import Data.Maybe
+import Data.Type.Equality
+import Data.String (IsString(..))
+
+import Language.Symantic.Typing.Kind
+import Language.Symantic.Typing.Constant
+import Language.Symantic.Typing.Type
+import Language.Symantic.Typing.Constraint
+
+-- * Class 'AST'
+class AST node where
+ type Lexem node
+ ast_lexem :: node -> Lexem node
+ ast_nodes :: node -> [node]
+
+instance AST (Syntax a) where
+ type Lexem (Syntax a) = a
+ ast_lexem (Syntax x _) = x
+ ast_nodes (Syntax _ ns) = ns
+
+-- * Type 'At'
+-- | Attach a location.
+data At ast a
+ = At ast a
+ deriving (Eq, Show)
+instance Functor (At ast) where
+ fmap f (At ast a) = At ast (f a)
+
+-- * Type 'Syntax'
+data Syntax a
+ = Syntax a [Syntax a]
+ deriving (Eq)
+
+-- | Custom 'Show' instance a little bit more readable
+-- than the automatically derived one.
+instance Show (Syntax String) where
+ showsPrec p ast@(Syntax n args) =
+ case ast of
+ Syntax _ [] -> showString n
+ Syntax "(->)" [a] ->
+ showParen (p <= prec_arrow) $
+ showString (""++n++" ") .
+ showsPrec prec_arrow a
+ Syntax "(->)" [a, b] ->
+ showParen (p <= prec_arrow) $
+ showsPrec prec_arrow a .
+ showString (" -> ") .
+ showsPrec (prec_arrow + 1) b
+ Syntax "\\" [var, ty, body] ->
+ showParen (p <= prec_lambda) $
+ showString ("\\(") .
+ showsPrec prec_lambda var .
+ showString (":") .
+ showsPrec prec_lambda ty .
+ showString (") -> ") .
+ showsPrec prec_lambda body
+ Syntax "$" [fun, arg] ->
+ showParen (p <= prec_dollar) $
+ showsPrec prec_dollar fun .
+ showString (" $ ") .
+ showsPrec prec_dollar arg
+ _ ->
+ showParen (p <= prec_app) $
+ showString n .
+ showString " " .
+ showString (List.unwords $ show <$> args)
+ where
+ prec_arrow = 1
+ prec_lambda = 1
+ prec_dollar = 1
+ prec_app = 10
+
+-- * Type 'Error_Type'
+data Error_Type cs ast
+ = Error_Type_Constant_unknown (At ast ())
+ | Error_Type_Kind_mismatch (At ast EKind) (At ast EKind)
+ | Error_Type_Kind_not_applicable (At ast EKind)
+ | Error_Type_Constraint_missing (At ast (EType cs))
+deriving instance (Eq ast, Eq (Lexem ast)) => Eq (Error_Type cs ast)
+deriving instance (Show ast, Show (Lexem ast), Show_Const cs) => Show (Error_Type cs ast)
+
+-- * Class 'Type_from'
+-- | Try to build a 'Type' from raw data.
+class Type_from ast cs where
+ type_from
+ :: ast
+ -> (forall ki_h h. Type cs ki_h h -> Either (Error_Type cs ast) ret)
+ -> Either (Error_Type cs ast) ret
+
+instance
+ ( Proj_Con cs
+ , Const_from (Lexem ast) cs
+ , AST ast
+ ) => Type_from ast cs where
+ type_from ast kk =
+ fromMaybe (Left $ Error_Type_Constant_unknown $ At ast ()) $
+ const_from (ast_lexem ast) $ \c -> Just $
+ go (ast_nodes ast) (TyConst c) kk
+ where
+ go :: forall ki h ret. [ast]
+ -> Type cs ki h
+ -> (forall ki' h'. Type cs ki' h' -> Either (Error_Type cs ast) ret)
+ -> Either (Error_Type cs ast) ret
+ go [] ty k = k ty
+ go (ast_x:ast_xs) ty_f k =
+ type_from ast_x $ \ty_x ->
+ let ki_x = kind_of ty_x in
+ case kind_of ty_f of
+ ki_f_a `SKiArrow` ki_f_b ->
+ case testEquality ki_f_a ki_x of
+ Nothing -> Left $ Error_Type_Kind_mismatch
+ (At ast $ EKind ki_f_a)
+ (At ast_x $ EKind ki_x)
+ Just Refl ->
+ let ty_fx = ty_f :$ ty_x in
+ case ki_f_b of
+ SKiCon ->
+ case proj_con ty_f ty_x of
+ Nothing -> Left $ Error_Type_Constraint_missing $ At ast (EType ty_fx)
+ Just Dict -> go ast_xs (ty_f :~ ty_x) k
+ _ -> go ast_xs ty_fx k
+ ki -> Left $ Error_Type_Kind_not_applicable $ At ast (EKind ki)
+
+syBool :: IsString a => Syntax a
+syBool = Syntax "Bool" []
+syEq :: IsString a => [Syntax a] -> Syntax a
+syEq = Syntax "Eq"
+syFun :: IsString a => [Syntax a] -> Syntax a
+syFun = Syntax "(->)"
+syInt :: IsString a => Syntax a
+syInt = Syntax "Int" []
+syIO :: IsString a => [Syntax a] -> Syntax a
+syIO = Syntax "IO"
+syTraversable :: IsString a => [Syntax a] -> Syntax a
+syTraversable = Syntax "Traversable"
+syMonad :: IsString a => [Syntax a] -> Syntax a
+syMonad = Syntax "Monad"
+(.>) :: IsString a => Syntax a -> Syntax a -> Syntax a
+a .> b = syFun [a, b]
+infixr 3 .>
--- /dev/null
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+-- {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NoOverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Typing.Test where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+-- import Data.Proxy
+
+import Language.Symantic.Typing
+
+tests :: TestTree
+tests = testGroup "Typing" $
+ let (==>) (stx::Syntax String) expected =
+ testCase (show stx) $
+ (@?= EType <$> expected) $
+ type_from stx (Right . (EType::Type Consts ki h -> EType Consts))
+ in
+ [ syBool ==> Right tyBool
+ , syFun [syBool] ==> Right (tyFun :$ tyBool)
+ , syEq [syBool] ==> Right (tyEq :~ tyBool)
+ , syMonad [syIO []] ==> Right (tyMonad :~ tyIO)
+ , syFun [syIO [syBool]] ==> Right (tyFun :$ (tyIO :$ tyBool))
+ , (syBool .> syBool) ==> Right
+ (tyBool ~> tyBool)
+ , ((syBool .> syBool) .> syBool) ==> Right
+ ((tyBool ~> tyBool) ~> tyBool)
+ , ((syBool .> syInt) .> syBool) ==> Right
+ ((tyBool ~> tyInt) ~> tyBool)
+ , (syBool .> syInt .> syBool) ==> Right
+ (tyBool ~> tyInt ~> tyBool)
+ , ((syBool .> (syBool .> syInt)) .> syBool) ==> Right
+ ((tyBool ~> (tyBool ~> tyInt)) ~> tyBool)
+ , testGroup "Error"
+ [ syTraversable [syIO []] ==> Left
+ (Error_Type_Constraint_missing
+ (At (syTraversable [syIO []]) $ EType $ tyTraversable :$ tyIO))
+ , syFun [syIO []] ==> Left
+ (Error_Type_Kind_mismatch
+ (At (syFun [syIO []]) $ EKind SKiTerm)
+ (At (syIO []) $ EKind $ SKiTerm `SKiArrow` SKiTerm))
+ , syIO [syEq [syBool]] ==> Left
+ (Error_Type_Kind_mismatch
+ (At (syIO [syEq [syBool]]) $ EKind SKiTerm)
+ (At (syEq [syBool]) $ EKind $ SKiCon))
+ , Syntax "Bool" [syBool] ==> Left
+ (Error_Type_Kind_not_applicable
+ (At (Syntax "Bool" [syBool]) $ EKind SKiTerm))
+ , Syntax "Unknown" [] ==> Left (Error_Type_Constant_unknown $
+ At (Syntax "Unknown" []) ())
+ ]
+ ]
--- /dev/null
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+module Language.Symantic.Typing.Type where
+
+import Data.Maybe (isJust)
+import Data.Proxy
+import Data.Type.Equality
+import GHC.Prim (Constraint)
+
+import Language.Symantic.Typing.Kind
+import Language.Symantic.Typing.Constant
+
+-- * Type 'Type'
+
+-- | /Type of terms/.
+--
+-- * @cs@: /type constants/.
+-- * @ki@: 'Kind' (/type of the type/).
+-- * @h@: Haskell type projected onto.
+--
+-- * 'TyConst': /type constant/
+-- * '(:$)': /type application/
+-- * '(:~)': /type constraint constructor/
+--
+-- NOTE: when used, @h@ is a 'Proxy',
+-- because @GADTs@ constructors cannot alter kinds.
+-- Neither is it possible to assert that @(@'UnProxy'@ f :: * -> *)@,
+-- and therefore @(@'UnProxy'@ f (@'UnProxy'@ x))@ cannot kind check;
+-- however a type application of @f@ is needed in 'App' and 'Con',
+-- so this is worked around with the introduction of the 'App' type family,
+-- which handles the type application when @(@'UnProxy'@ f :: * -> *)@
+-- is true from elsewhere, or stay abstract otherwise.
+-- However, since type synonym family cannot be used within the pattern
+-- of another type family, the kind of an abstract
+-- @(@'App'@ f x)@ cannot be derived from @f@,
+-- so this is worked around with the introduction of the @ki@ parameter.
+data Type (cs::[*]) (ki::Kind) (h:: *) where
+ TyConst
+ :: Const cs c
+ -> Type cs (Kind_of_Proxy c) c
+ (:$)
+ :: Type cs (ki_x ':> ki) f
+ -> Type cs ki_x x
+ -> Type cs ki (App f x)
+ (:~)
+ :: Con q x
+ => Type cs (ki_x ':> 'KiCon) q
+ -> Type cs ki_x x
+ -> Type cs 'KiCon (App q x)
+ {-
+ TyVar
+ :: SKind ki
+ -> SPeano v
+ -> Type cs ki v
+ -}
+infixl 5 :$
+infixl 5 :~
+
+-- ** Type family 'UnProxy'
+-- | Useful to have 'App' and 'Con' type families working on all @a@.
+type family UnProxy px :: k where
+ UnProxy (Proxy h) = h
+
+-- ** Type family 'App'
+-- | Lift the Haskell /type application/ within a 'Proxy'.
+type family App (f:: *) (a:: *) :: *
+type instance App (Proxy (f:: ki_a -> ki_fa)) a = Proxy (f (UnProxy a))
+
+-- ** Type family 'Con'
+-- | Lift the Haskell /type constraint/ within a 'Proxy'.
+type family Con (q:: *) (a:: *) :: Constraint
+type instance Con (Proxy (q:: ki_a -> Constraint)) a = q (UnProxy a)
+
+-- ** Type 'Type_of'
+-- | Convenient wrapper when @t@ is statically known.
+type Type_of cs t = Type cs (Kind_of t) (Proxy t)
+
+kind_of :: Type cs ki h -> SKind ki
+kind_of ty =
+ case ty of
+ TyConst c -> kind_of_const c
+ f :$ _x -> case kind_of f of _ `SKiArrow` ki -> ki
+ q :~ _x -> case kind_of q of _ `SKiArrow` ki -> ki
+
+eq_type
+ :: Type cs ki_x x -> Type cs ki_y y
+ -> Maybe (x :~: y)
+eq_type (TyConst x) (TyConst y)
+ | Just Refl <- testEquality x y
+ = Just Refl
+eq_type (xf :$ xx) (yf :$ yx)
+ | Just Refl <- eq_type xf yf
+ , Just Refl <- eq_type xx yx
+ = Just Refl
+eq_type (xq :~ xx) (yq :~ yx)
+ | Just Refl <- eq_type xq yq
+ , Just Refl <- eq_type xx yx
+ = Just Refl
+eq_type _ _ = Nothing
+
+instance TestEquality (Type cs ki) where
+ testEquality = eq_type
+
+-- * Type 'EType'
+-- | Existential for 'Type'.
+data EType cs = forall ki h. EType (Type cs ki h)
+
+instance Eq (EType cs) where
+ EType x == EType y = isJust $ eq_type x y
+instance Show_Const cs => Show (EType cs) where
+ show (EType ty) = show_type ty
+
+show_type :: Show_Const cs => Type cs ki_h h -> String
+show_type (TyConst c) = show c
+show_type ((:$) f@(:$){} a@(:$){}) = "(" ++ show_type f ++ ") (" ++ show_type a ++ ")"
+show_type ((:$) f@(:$){} a) = "(" ++ show_type f ++ ") " ++ show_type a
+show_type ((:$) f a@(:$){}) = show_type f ++ " (" ++ show_type a ++ ")"
+show_type ((:$) f a) = show_type f ++ " " ++ show_type a
+show_type ((:~) q a) = show_type q ++ " " ++ show_type a
+-- show_type (TyVar v) = "t" ++ show (integral_from_peano v::Integer)
+
+-- * Type 'Args'
+data Args (cs::[*]) (args::[*]) where
+ ArgZ :: Args cs '[]
+ ArgS :: Type cs ki arg
+ -> Args cs args
+ -> Args cs (arg ': args)
+infixr 5 `ArgS`
+
+-- | Build the left spine of a 'Type'.
+spine_of_type
+ :: Type cs ki_h h
+ -> (forall c as. Const cs c
+ -> Args cs as -> ret) -> ret
+spine_of_type (TyConst c) k = k c ArgZ
+spine_of_type (f :$ a) k = spine_of_type f $ \c as -> k c (a `ArgS` as)
+spine_of_type (q :~ a) k = spine_of_type q $ \c as -> k c (a `ArgS` as)
+
+-- * Usual 'Type's
+
+-- | The 'Bool' 'Type'
+tyBool :: Inj_Const cs Bool => Type_of cs Bool
+tyBool = TyConst inj_const
+
+-- | The 'Eq' 'Type'
+tyEq :: Inj_Const cs Eq => Type_of cs Eq
+tyEq = TyConst inj_const
+
+-- | The 'Int' 'Type'
+tyInt :: Inj_Const cs Int => Type_of cs Int
+tyInt = TyConst inj_const
+
+-- | The 'IO'@ a@ 'Type'
+tyIO :: Inj_Const cs IO => Type_of cs IO
+tyIO = TyConst inj_const
+
+-- | The 'Traversable'@ a@ 'Type'
+tyTraversable :: Inj_Const cs Traversable => Type_of cs Traversable
+tyTraversable = TyConst inj_const
+
+-- | The 'Monad'@ a@ 'Type'
+tyMonad :: Inj_Const cs Monad => Type_of cs Monad
+tyMonad = TyConst inj_const
+
+-- | The 'Int' 'Type'
+tyFun :: Inj_Const cs (->) => Type_of cs (->)
+tyFun = TyConst inj_const
+
+-- | The function 'Type' @(\->) a b@
+-- with an infix notation more readable.
+(~>) :: forall cs a b. Inj_Const cs (->)
+ => Type cs 'KiTerm (Proxy a)
+ -> Type cs 'KiTerm (Proxy b)
+ -> Type_of cs (a -> b)
+(~>) a b = TyConst (inj_const::Const cs (Proxy (->))) :$ a :$ b
+infixr 5 ~>
-- data-dir: data
-- data-files:
description:
- Library gathering main ideas from the
- <http://okmij.org/ftp/tagless-final/ Tagless-Final>
- approach of embedded DSL (Domain-Specific Language)
- developed by Jacques Carette, Oleg Kiselyov and Chung-chieh Shan,
- and pursuing their work to make it usable as a non-embedded DSL.
- .
- A so-called /symantic/ type class defines a /syntax/
- and each of its instances defines a new /semantic/
- (computing a Haskell term, serializing, optimizing, …).
- .
- Combining the methods of those /symantic/ type classes
- gives rise to a DSL within which one can
- write /symantic/ expressions at developing time;
- but in order to handle such expression when entered by an end-user,
- one has to be able to construct it at runtime.
- .
- This library (including its Test.hs files) demonstrates this
- for a few usual types and methods, by:
- .
- * Parsing a /symantic/ expression
- from an AST (Abstract Syntax Tree).
- .
- * Removing or adding /symantic/ parsers
- by fully reusing old parsers
- (i.e. without copying or altering them).
- .
- * Interpreting a /symantic/ expression
- multiple times and with different interpreters
- without reparsing the expression.
- .
- Hence, one can select all or a few expressions (and associated types)
- of this library, add its own, parse them at runtime from its own AST,
- and then interpret them at will.
- .
- One important drawback of this flexibility
- is the introduction of a lot of type constraints;
- those may be more readable directly in the source code
- than in its Haddock rendition.
+ Library for composing, typing, compiling and interpreting
+ a custom DSL (Domain-Specific Language)
+ expressing a subset of GHC's Haskell.
.
Your comments, problem reports, or questions are very welcome! :-)
.
+ NOTE: the symantic approach was developped for embedded DSL
+ by Jacques Carette, Oleg Kiselyov and Chung-chieh Shan,
+ see: <http://okmij.org/ftp/tagless-final/ Tagless-Final>.
+ .
NOTE: alternative libraries to do more or less the same things
include: <https://hackage.haskell.org/package/syntactic syntactic>.
extra-source-files:
stability: experimental
synopsis: Library for Typed Tagless-Final Higher-Order Extensible DSL
tested-with: GHC==7.10.3
-version: 1.20161112
+version: 2.20161124
Source-Repository head
location: git://git.autogeree.net/symantic
default-language: Haskell2010
exposed-modules:
Language.Symantic
- Language.Symantic.Expr
- Language.Symantic.Expr.Alt
- Language.Symantic.Expr.Applicative
- Language.Symantic.Expr.Bool
- Language.Symantic.Expr.Char
- Language.Symantic.Expr.Either
- Language.Symantic.Expr.Eq
- Language.Symantic.Expr.Error
- Language.Symantic.Expr.Foldable
- Language.Symantic.Expr.From
- Language.Symantic.Expr.Functor
- Language.Symantic.Expr.If
- Language.Symantic.Expr.Int
- Language.Symantic.Expr.Integer
- Language.Symantic.Expr.Integral
- Language.Symantic.Expr.IO
- Language.Symantic.Expr.Lambda
- Language.Symantic.Expr.List
- Language.Symantic.Expr.Map
- Language.Symantic.Expr.Maybe
- Language.Symantic.Expr.Monad
- Language.Symantic.Expr.MonoFunctor
- Language.Symantic.Expr.Monoid
- Language.Symantic.Expr.Num
- Language.Symantic.Expr.Ord
- Language.Symantic.Expr.Root
- Language.Symantic.Expr.Text
- Language.Symantic.Expr.Traversable
- Language.Symantic.Expr.Tuple
- Language.Symantic.Lib.Control.Monad
- Language.Symantic.Lib.Data.Bool
Language.Symantic.Lib.Data.Peano
- Language.Symantic.Repr
- Language.Symantic.Repr.Dup
- Language.Symantic.Repr.Host
- Language.Symantic.Repr.Text
- Language.Symantic.Trans
- Language.Symantic.Trans.Bool
- Language.Symantic.Trans.Bool.Const
- Language.Symantic.Trans.Common
- Language.Symantic.Type
- Language.Symantic.Type.Alt
- Language.Symantic.Type.Bool
- Language.Symantic.Type.Char
- Language.Symantic.Type.Constraint
- Language.Symantic.Type.Either
- Language.Symantic.Type.Error
- Language.Symantic.Type.Family
- Language.Symantic.Type.Fun
- Language.Symantic.Type.Int
- Language.Symantic.Type.Integer
- Language.Symantic.Type.IO
- Language.Symantic.Type.List
- Language.Symantic.Type.Map
- Language.Symantic.Type.Maybe
- Language.Symantic.Type.Ordering
- Language.Symantic.Type.Root
- Language.Symantic.Type.Text
- Language.Symantic.Type.Tuple
- Language.Symantic.Type.Type0
- Language.Symantic.Type.Type1
- Language.Symantic.Type.Type2
- Language.Symantic.Type.Unit
- Language.Symantic.Type.Var
+ Language.Symantic.Typing
+ Language.Symantic.Typing.Kind
+ Language.Symantic.Typing.Constant
+ Language.Symantic.Typing.Type
+ Language.Symantic.Typing.Constraint
+ Language.Symantic.Typing.Syntax
build-depends:
base >= 4.6 && < 5
, containers
, ghc-prim
- , mono-traversable
+ -- , mono-traversable
, transformers
, text
hs-source-dirs: Language/Symantic
main-is: Test.hs
other-modules:
- AST.Test
- Expr.Applicative.Test
- Expr.Bool.Test
- Expr.Eq.Test
- Expr.Foldable.Test
- Expr.Functor.Test
- Expr.If.Test
- Expr.Int.Test
- Expr.Lambda.Test
- Expr.List.Test
- Expr.Map.Test
- Expr.Maybe.Test
- Expr.Monad.Test
- Expr.MonoFunctor.Test
- Expr.Test
- Expr.Traversable.Test
- Repr.Host.Test
- Repr.Test
- Repr.Text.Test
- Trans.Bool.Const.Test
- Trans.Bool.Test
- Trans.Test
- Type.Test
+ Typing.Test
if flag(threaded)
ghc-options: -threaded -rtsopts -with-rtsopts=-N
if flag(dev)
build-depends:
base >= 4.6 && < 5
, containers
- , mono-traversable
+ -- , mono-traversable
, transformers
, tasty >= 0.11
, tasty-hunit
sourcephile / git / haskell / symantic.git / commitdiff