From 63a7ffe02d6c84614cc4891bdded728f85b5d36f Mon Sep 17 00:00:00 2001
From: Julien Moutinho <julm+symantic@autogeree.net>
Date: Sat, 19 Nov 2016 14:39:02 +0100
Subject: [PATCH] factorizing Type1_From ast Type0
---
Language/Symantic/AST/Test.hs | 36 ---------------------------------
Language/Symantic/Type/Type1.hs | 25 +++++++++++------------
2 files changed, 12 insertions(+), 49 deletions(-)
diff --git a/Language/Symantic/AST/Test.hs b/Language/Symantic/AST/Test.hs
index 7d98085..c1fe2cc 100644
--- a/Language/Symantic/AST/Test.hs
+++ b/Language/Symantic/AST/Test.hs
@@ -401,42 +401,6 @@ instance -- Type0_From AST Type_Either
Error_Type_Wrong_number_of_arguments ast 2
_ -> Left $ error_type_unsupported ty ast
-instance -- Type1_From AST Type_Bool
- ( Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , IBool (Is_Last_Type (Type_Bool root) root)
- ) => Type1_From AST (Type_Bool root)
-instance -- Type1_From AST Type_Int
- ( Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , IBool (Is_Last_Type (Type_Int root) root)
- ) => Type1_From AST (Type_Int root)
-instance -- Type1_From AST Type_Integer
- ( Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , IBool (Is_Last_Type (Type_Integer root) root)
- ) => Type1_From AST (Type_Integer root)
-instance -- Type1_From AST Type_Unit
- ( Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , IBool (Is_Last_Type (Type_Unit root) root)
- ) => Type1_From AST (Type_Unit root)
-instance -- Type1_From AST Type_Ordering
- ( Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , IBool (Is_Last_Type (Type_Ordering root) root)
- ) => Type1_From AST (Type_Ordering root)
-instance -- Type1_From AST Type_Text
- ( Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , IBool (Is_Last_Type (Type_Text root) root)
- ) => Type1_From AST (Type_Text root)
-instance -- Type1_From AST Type_Char
- ( Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , IBool (Is_Last_Type (Type_Char root) root)
- ) => Type1_From AST (Type_Char root)
-instance -- Type1_From AST Type_Var0
- ( Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , IBool (Is_Last_Type (Type_Var0 root) root)
- ) => Type1_From AST (Type_Var0 root)
-instance -- Type1_From AST Type_Var1
- ( Error_Type_Lift (Error_Type AST) (Error_of_Type AST root)
- , IBool (Is_Last_Type (Type_Var1 root) root)
- ) => Type1_From AST (Type_Var1 root)
instance -- Type1_From AST Type_Maybe
( Type0_From AST root
, Type_Root_Lift Type_Maybe root
diff --git a/Language/Symantic/Type/Type1.hs b/Language/Symantic/Type/Type1.hs
index 3c1e803..6db0abf 100644
--- a/Language/Symantic/Type/Type1.hs
+++ b/Language/Symantic/Type/Type1.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
@@ -104,24 +103,12 @@ class Type1_From ast (ty:: * -> *) where
-> (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
- default type1_from ::
- ( Error_Type_Lift (Error_Type ast) (Error_of_Type ast (Root_of_Type ty))
- , IBool (Is_Last_Type ty (Root_of_Type ty))
- ) => 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
- type1_from ty ast _k =
- Left $ error_type_unsupported ty ast
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)
@@ -138,6 +125,18 @@ instance -- Type_Alt
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
--
2.47.2