From c41939485c7ca4a79665da3b89ee15926fabf4bc Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Thu, 5 Jan 2017 06:13:22 +0100 Subject: [PATCH 01/16] Clarify names, and add commentaries (bis). --- Language/Symantic/Compiling/Applicative.hs | 2 +- Language/Symantic/Compiling/Either.hs | 4 +- Language/Symantic/Compiling/List.hs | 4 +- Language/Symantic/Compiling/Maybe.hs | 2 +- Language/Symantic/Compiling/Monad.hs | 2 +- Language/Symantic/Compiling/Monoid.hs | 2 +- Language/Symantic/Compiling/Num.hs | 2 +- Language/Symantic/Compiling/Term.hs | 2 +- Language/Symantic/Parsing/Token.hs | 11 ++- Language/Symantic/Typing/Test.hs | 4 +- Language/Symantic/Typing/Type.hs | 16 ++-- symantic.cabal | 90 +++++++++++++--------- 12 files changed, 82 insertions(+), 59 deletions(-) diff --git a/Language/Symantic/Compiling/Applicative.hs b/Language/Symantic/Compiling/Applicative.hs index 7139f0c..605dfbf 100644 --- a/Language/Symantic/Compiling/Applicative.hs +++ b/Language/Symantic/Compiling/Applicative.hs @@ -81,7 +81,7 @@ instance -- CompileI case tok of Token_Term_Applicative_pure tok_ty_f tok_a -> -- pure :: Applicative f => a -> f a - type_from tok_ty_f $ \(ty_f::Type (Consts_of_Ifaces is) f) -> + compile_type tok_ty_f $ \(ty_f::Type (Consts_of_Ifaces is) f) -> check_kind (At Nothing $ SKiType `SKiArrow` SKiType) (At (Just tok_ty_f) $ kind_of ty_f) $ \Refl -> diff --git a/Language/Symantic/Compiling/Either.hs b/Language/Symantic/Compiling/Either.hs index 8e28ddf..27874cb 100644 --- a/Language/Symantic/Compiling/Either.hs +++ b/Language/Symantic/Compiling/Either.hs @@ -109,7 +109,7 @@ instance -- CompileI case tok of Token_Term_Either_Left tok_ty_r tok_l -> -- Left :: l -> Either l r - type_from tok_ty_r $ \(ty_r::Type (Consts_of_Ifaces is) r) -> + compile_type tok_ty_r $ \(ty_r::Type (Consts_of_Ifaces is) r) -> check_kind (At Nothing SKiType) (At (Just tok_ty_r) $ kind_of ty_r) $ \Refl -> @@ -118,7 +118,7 @@ instance -- CompileI \c -> _Left (l c) Token_Term_Either_Right tok_ty_l tok_r -> -- Right :: r -> Either l r - type_from tok_ty_l $ \(ty_l::Type (Consts_of_Ifaces is) l) -> + compile_type tok_ty_l $ \(ty_l::Type (Consts_of_Ifaces is) l) -> check_kind (At Nothing SKiType) (At (Just tok_ty_l) $ kind_of ty_l) $ \Refl -> diff --git a/Language/Symantic/Compiling/List.hs b/Language/Symantic/Compiling/List.hs index 27922be..a5c28e1 100644 --- a/Language/Symantic/Compiling/List.hs +++ b/Language/Symantic/Compiling/List.hs @@ -132,14 +132,14 @@ instance -- CompileI case tok of Token_Term_List_empty tok_ty_a -> -- [] :: [a] - type_from tok_ty_a $ \(ty_a::Type (Consts_of_Ifaces is) a) -> + compile_type tok_ty_a $ \(ty_a::Type (Consts_of_Ifaces is) a) -> check_kind (At Nothing SKiType) (At (Just tok_ty_a) $ kind_of ty_a) $ \Refl -> k (ty @[] :$ ty_a) $ TermO $ Fun.const list_empty Token_Term_List_list tok_ty_a tok_as -> - type_from tok_ty_a $ \(ty_a::Type (Consts_of_Ifaces is) a) -> + compile_type tok_ty_a $ \(ty_a::Type (Consts_of_Ifaces is) a) -> check_kind (At Nothing SKiType) (At (Just tok_ty_a) $ kind_of ty_a) $ \Refl -> diff --git a/Language/Symantic/Compiling/Maybe.hs b/Language/Symantic/Compiling/Maybe.hs index e530800..1d7cb1a 100644 --- a/Language/Symantic/Compiling/Maybe.hs +++ b/Language/Symantic/Compiling/Maybe.hs @@ -108,7 +108,7 @@ instance -- CompileI case tok of Token_Term_Maybe_Nothing tok_ty_a -> -- Nothing :: Maybe a - type_from tok_ty_a $ \(ty_a::Type (Consts_of_Ifaces is) a) -> + compile_type tok_ty_a $ \(ty_a::Type (Consts_of_Ifaces is) a) -> check_kind (At Nothing SKiType) (At (Just tok_ty_a) $ kind_of ty_a) $ \Refl -> diff --git a/Language/Symantic/Compiling/Monad.hs b/Language/Symantic/Compiling/Monad.hs index d7b563a..5115605 100644 --- a/Language/Symantic/Compiling/Monad.hs +++ b/Language/Symantic/Compiling/Monad.hs @@ -91,7 +91,7 @@ instance -- CompileI case tok of Token_Term_Monad_return tok_ty_m tok_a -> -- return :: Monad m => a -> m a - type_from tok_ty_m $ \(ty_m::Type (Consts_of_Ifaces is) m) -> + compile_type tok_ty_m $ \(ty_m::Type (Consts_of_Ifaces is) m) -> check_kind (At Nothing (SKiType `SKiArrow` SKiType)) (At (Just tok_ty_m) $ kind_of ty_m) $ \Refl -> diff --git a/Language/Symantic/Compiling/Monoid.hs b/Language/Symantic/Compiling/Monoid.hs index a1e05ca..83d0208 100644 --- a/Language/Symantic/Compiling/Monoid.hs +++ b/Language/Symantic/Compiling/Monoid.hs @@ -73,7 +73,7 @@ instance -- CompileI case tok of Token_Term_Monoid_mempty tok_ty_a -> -- mempty :: Monoid a => a - type_from tok_ty_a $ \(ty_a::Type (Consts_of_Ifaces is) a) -> + compile_type tok_ty_a $ \(ty_a::Type (Consts_of_Ifaces is) a) -> check_kind (At Nothing SKiType) (At (Just tok_ty_a) $ kind_of ty_a) $ \Refl -> diff --git a/Language/Symantic/Compiling/Num.hs b/Language/Symantic/Compiling/Num.hs index e520571..d7ccc00 100644 --- a/Language/Symantic/Compiling/Num.hs +++ b/Language/Symantic/Compiling/Num.hs @@ -115,7 +115,7 @@ instance -- CompileI Token_Term_Num_mul tok_a -> op2_from tok_a (*) Token_Term_Num_fromInteger tok_ty_a -> -- fromInteger :: Num a => Integer -> a - type_from tok_ty_a $ \(ty_a::Type (Consts_of_Ifaces is) a) -> + compile_type tok_ty_a $ \(ty_a::Type (Consts_of_Ifaces is) a) -> check_kind (At Nothing SKiType) (At (Just tok_ty_a) $ kind_of ty_a) $ \Refl -> diff --git a/Language/Symantic/Compiling/Term.hs b/Language/Symantic/Compiling/Term.hs index 38f103d..a2a5779 100644 --- a/Language/Symantic/Compiling/Term.hs +++ b/Language/Symantic/Compiling/Term.hs @@ -466,7 +466,7 @@ instance -- CompileI (->) compileI tok ctx k = case tok of Token_Term_Abst name_arg tok_ty_arg tok_body -> - type_from tok_ty_arg $ \(ty_arg::Type (Consts_of_Ifaces is) h) -> + compile_type tok_ty_arg $ \(ty_arg::Type (Consts_of_Ifaces is) h) -> check_kind (At Nothing SKiType) (At (Just $ tok_ty_arg) $ kind_of ty_arg) $ \Refl -> diff --git a/Language/Symantic/Parsing/Token.hs b/Language/Symantic/Parsing/Token.hs index 0764de0..d4f3d4a 100644 --- a/Language/Symantic/Parsing/Token.hs +++ b/Language/Symantic/Parsing/Token.hs @@ -110,12 +110,21 @@ instance Show_Token meta ts => Show (EToken meta ts) where type Inj_Token meta ts t = Inj_TokenP (Index ts (Proxy t)) meta ts ts t inj_token - :: forall meta ts t. Inj_Token meta ts t + :: forall meta ts t. + Inj_Token meta ts t => meta -> TokenT meta ts (Proxy t) -> Token meta ts (Proxy t) inj_token = inj_tokenP (Proxy::Proxy (Index ts (Proxy t))) +inj_etoken + :: forall meta ts t. + Inj_Token meta ts t + => meta + -> TokenT meta ts (Proxy t) + -> EToken meta ts +inj_etoken meta = EToken . inj_tokenP (Proxy::Proxy (Index ts (Proxy t))) meta + -- ** Class 'Inj_TokenP' class Inj_TokenP p meta ts rs (t::kt) where inj_tokenP :: Proxy p -> meta diff --git a/Language/Symantic/Typing/Test.hs b/Language/Symantic/Typing/Test.hs index 2958481..c6e2ebf 100644 --- a/Language/Symantic/Typing/Test.hs +++ b/Language/Symantic/Typing/Test.hs @@ -19,12 +19,12 @@ import Parsing.Test -- * Tests tests :: TestTree tests = testGroup "Typing" $ - [ testGroup "type_from" $ + [ testGroup "compile_type" $ let (==>) (syn::Syntax Text) expected = let Right (tok::EToken (Syntax Text) '[Proxy Token_Type]) = tokenize_type syn in testCase (Prelude.show syn) $ (@?= EType Prelude.<$> expected) $ - (type_from tok (Right . EType) + (compile_type tok (Right . EType) :: Either (Error_Type (Syntax Text) '[Proxy Token_Type]) (EType Constants)) in diff --git a/Language/Symantic/Typing/Type.hs b/Language/Symantic/Typing/Type.hs index 41ce83c..6f4aeee 100644 --- a/Language/Symantic/Typing/Type.hs +++ b/Language/Symantic/Typing/Type.hs @@ -122,10 +122,10 @@ instance Show_Const cs => Show_Const (Proxy Token_Type ': cs) where show_const ConstZ{} = "Type" show_const (ConstS c) = show_const c --- * Class 'Type_from' +-- * Class 'Compile_Type' -- | Try to build a 'Type' from raw data. -class Type_from ts cs where - type_from +class Compile_Type ts cs where + compile_type :: ( MonoLift (Error_Type meta ts) err , MonoLift (Constraint_Kind meta ts) err ) => EToken meta ts @@ -172,15 +172,15 @@ deriving instance (Show_TokenR meta ts ts) => Show (Error_Type meta ts) instance ( Const_from Text cs , Proj_Token ts Token_Type - ) => Type_from ts cs where - type_from + ) => Compile_Type ts cs where + compile_type :: forall meta err ret. ( MonoLift (Error_Type meta ts) err , MonoLift (Constraint_Kind meta ts) err ) => EToken meta ts -> (forall k h. Type cs (h::k) -> Either err ret) -> Either err ret - type_from tok@(proj_etoken -> Just (Token_Type cst args)) kk = + compile_type tok@(proj_etoken -> Just (Token_Type cst args)) kk = fromMaybe (Left $ olift $ Error_Type_Constant_unknown $ At (Just tok) cst) $ const_from cst $ \c -> Just $ go args (TyConst c) kk @@ -191,14 +191,14 @@ instance -> Either err ret go [] typ k = k typ go (tok_x:tok_xs) ty_f k = - type_from tok_x $ \(ty_x::Type cs (h'::k')) -> + compile_type tok_x $ \(ty_x::Type cs (h'::k')) -> check_kind_arrow (At (Just tok) $ kind_of ty_f) $ \Refl ki_f_a _ki_f_b -> check_kind (At (Just tok) ki_f_a) (At (Just tok_x) $ kind_of ty_x) $ \Refl -> go tok_xs (ty_f :$ ty_x) k - type_from tok _k = Left $ olift $ Error_Type_Token_invalid tok + compile_type tok _k = Left $ olift $ Error_Type_Token_invalid tok -- * Type 'Types' data Types cs (hs::[K.Type]) where diff --git a/symantic.cabal b/symantic.cabal index 67b7786..8e82922 100644 --- a/symantic.cabal +++ b/symantic.cabal @@ -3,40 +3,28 @@ bug-reports: Julien Moutinho build-type: Simple cabal-version: >= 1.24 category: Language --- data-dir: data --- data-files: description: Library for composing, typing, compiling, transforming and interpreting a custom DSL (Domain-Specific Language) expressing a subset of GHC's Haskell. . - Main ideas are: + __Main ideas__ . * To encode terms in the way (aka. the /symantic/ way) i.e. to use a /class/ to encode the /syntax/ of terms (eg. 'Sym_Bool') - and /class instances/ to encode their /semantics/ (eg. 'HostI' or 'TextI' instances). + and /class instances/ to encode their /semantics/ + (eg. @(Sym_Bool HostI)@ interprets the term as a @Bool@ + or @(Sym_Bool TextI)@ interprets the term as a @Text@). /Lambda abstractions/ being handled by an higher-order approach, meaning that it directly reuses GHC's internal machinery to abstract or instantiate variables, which I think is by far the most efficient and simplest way of doing it (no DeBruijn encoding nor 's monads). - . * To typecheck terms using a @(Type cs h)@ @GADT@ which acts - as a /singleton type/ for all Haskell type @h@ - buildable from a /type-level list/ of /type constants/ @cs@ - wrapped inside a @Proxy@ - (eg. @[Proxy Bool, Proxy (->), Proxy Eq]@). - @TypeInType@ (introduced in GHC 8.0.1) - enabling 'Type' to also be @GADT@-like - in the kind of the Haskell type @h@ it encodes. - This making the /type application/ (':$') - giving us an /arrow kind/ for the Haskell /type constructor/ - it applies an Haskell type to, - which avoids some tricky workarounds. - @Rank2Types@ enabling @GADT@s to be built from "raw data". - @ConstraintKinds@ enabling @h@ to be built from /classes/. - @PolyKinds@ enabling to avoid a lot of uses of 'Proxy'. - . + as a /singleton type/ for any Haskell type @h@ + buildable by composing the /type constants/ @cs@, + each wrapped inside a @Proxy@ to fit into a /type-level list/ + (eg. @cs ~ [Proxy Bool, Proxy (->), Proxy Eq]@). * To inject a type into a /type-level list/ or project a /type-level list/ onto a type, to compose an /extensible data type/ @@ -52,7 +40,6 @@ description: 's @Elem@, and now have no incentive to study and compare these techniques: /type-level lists/ are simple enough. - . * To recurse on a /type-level list/ through /class instances/ to compose an /extensible class/ (eg. 'CompileR' gathering the 'CompileI' /class instances/, @@ -61,33 +48,60 @@ description: while providing in scope the current 'Sym_of_Iface' within each 'TermO' built in a 'CompileI' /class instance/). . - * To use @DefaultSignatures@ to provide identity transformations of terms, + __Main extensions__ + . + * @GADTs@ for knowing types by pattern-matching terms, + or building terms by using type classes. + * @Rank2Types@ for parsing @GADT@s. + * @TypeInType@ (introduced in GHC 8.0.1) + for 'Type' to also be @GADT@-like + in the kind of the Haskell type @h@ it encodes. + Which makes the /type application/ (':$') + give us an /arrow kind/ for the Haskell /type constructor/ + it applies an Haskell type to, releaving us from tricky workarounds. + * @ConstraintKinds@ for @cs@ to contain 'Constraint's, + or defining /type synonym/ of /type classes/, + or merging /type constraints/. + * @DataKinds@ for type-level data structures (eg. /type-level lists/). + * @TypeFamilies@ for type-level programming. + * @UndecidableInstances@ for type-level programming + that may never terminate. + * @PolyKinds@ for avoiding a lot of uses of 'Proxy'. + * @TypeApplications@ for having a more concise syntax + to build 'Type' (eg. @ty \@Bool@). + * @DefaultSignatures@ for providing identity transformations of terms, and thus avoid boilerplate code when a transformation does not need to alter all semantics. As explained in . . - There are a few examples of use in the @Test.hs@ files, - and shall be more one day in the reverse dependencies of this library. + __Usage__ . - Your comments, problem reports, or questions are welcome! :-) + There are a few examples in the @Test.hs@ files, + and shall be more one day in the + + of this library. . - TODO: there is no /type inferencing/ for now, only (hand written :( ) /type checking/. - This implies that the variable introduced - by a /lambda abstraction/ has to be explicitely typed, - and that terms must be called with enough arguments to typecheck, - be it term arguments (for instance - @(+) :: Num a => a -> a -> a@ needs at least one term argument to check @Num a@) - or type arguments (for instance - @return :: Monad m => a -> m a@ needs a type argument to check @Monad m@). + __Bugs__ + . + Your comments, problem reports, or questions are welcome! :-) . - TODO: a lot of common terms should be added in @Compiling.*@ modules. - Maybe as separate packages to limit dependencies. + __TODO__ . - TODO: no transformation are implemented so far, - there should be some, at least as examples to demonstrate their power. + * /Type inferencing/ to improve the current hand written /type checking/, + and remove some type annotations in the DSL. + Currently all /lambda abstractions/ must have its variable explicitely typed, + and terms must be called with enough arguments to typecheck, + be it term arguments (for instance + @(+) :: Num a => a -> a -> a@ needs at least one term argument to check @Num a@) + or type arguments (for instance + @return :: Monad m => a -> m a@ needs a type argument to check @Monad m@). + * A lot of common terms should be added in @Compiling.*@ modules. + Maybe as separate packages to limit dependencies. + * No transformation is implemented so far, + there should be some, at least as examples to demonstrate their power. extra-source-files: extra-tmp-files: --- homepage: http://pad.autogeree.net/informatique/symantic/ +-- homepage: license: GPL-3 license-file: COPYING maintainer: Julien Moutinho -- 2.47.2 From 177f87b20fa2f34892f4b94a5ca2b88962c5042a Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Thu, 5 Jan 2017 20:48:43 +0100 Subject: [PATCH 02/16] Renaming textI_app* to textI*. --- Language/Symantic/Compiling/Applicative.hs | 6 +- .../Symantic/Compiling/Applicative/Test.hs | 2 +- Language/Symantic/Compiling/Char.hs | 4 +- Language/Symantic/Compiling/Either.hs | 6 +- Language/Symantic/Compiling/Foldable.hs | 62 +++++++++---------- Language/Symantic/Compiling/Functor.hs | 2 +- Language/Symantic/Compiling/IO.hs | 4 +- Language/Symantic/Compiling/Integral.hs | 6 +- Language/Symantic/Compiling/List.hs | 2 +- Language/Symantic/Compiling/Map.hs | 18 +++--- Language/Symantic/Compiling/Maybe.hs | 6 +- Language/Symantic/Compiling/Monad.hs | 2 +- Language/Symantic/Compiling/MonoFoldable.hs | 16 ++--- Language/Symantic/Compiling/MonoFunctor.hs | 2 +- Language/Symantic/Compiling/Monoid.hs | 4 +- Language/Symantic/Compiling/NonNull.hs | 18 +++--- Language/Symantic/Compiling/Num.hs | 8 +-- Language/Symantic/Compiling/Ord.hs | 6 +- Language/Symantic/Compiling/Sequences.hs | 10 +-- Language/Symantic/Compiling/Show.hs | 6 +- Language/Symantic/Compiling/Term.hs | 6 +- Language/Symantic/Compiling/Text.hs | 9 +-- Language/Symantic/Compiling/Traversable.hs | 2 +- Language/Symantic/Compiling/Tuple2.hs | 4 +- Language/Symantic/Interpreting/Text.hs | 35 +++-------- 25 files changed, 111 insertions(+), 135 deletions(-) diff --git a/Language/Symantic/Compiling/Applicative.hs b/Language/Symantic/Compiling/Applicative.hs index 605dfbf..4e4c4a0 100644 --- a/Language/Symantic/Compiling/Applicative.hs +++ b/Language/Symantic/Compiling/Applicative.hs @@ -47,7 +47,7 @@ instance Sym_Applicative HostI where pure = liftM Applicative.pure (<*>) = liftM2 (Applicative.<*>) instance Sym_Applicative TextI where - pure = textI_app1 "pure" + pure = textI1 "pure" (<*>) = textI_infix "<*>" (Precedence 4) (<* ) = textI_infix "<*" (Precedence 4) ( *>) = textI_infix "*>" (Precedence 4) @@ -65,7 +65,7 @@ instance Show_Const cs => Show_Const (Proxy Applicative ': cs) where instance Proj_ConC cs (Proxy Applicative) data instance TokenT meta (ts::[*]) (Proxy Applicative) = Token_Term_Applicative_pure (EToken meta '[Proxy Token_Type]) (EToken meta ts) - | Token_Term_Applicative_ltstargt (EToken meta ts) + | Token_Term_Applicative_app (EToken meta ts) | Token_Term_Applicative_stargt (EToken meta ts) (EToken meta ts) | Token_Term_Applicative_ltstar (EToken meta ts) (EToken meta ts) deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Applicative)) @@ -89,7 +89,7 @@ instance -- CompileI compileO tok_a ctx $ \ty_a (TermO a) -> k (ty_f :$ ty_a) $ TermO $ \c -> pure (a c) - Token_Term_Applicative_ltstargt tok_fa2b -> + Token_Term_Applicative_app tok_fa2b -> -- (<*>) :: Applicative f => f (a -> b) -> f a -> f b compileO tok_fa2b ctx $ \ty_fa2b (TermO fa2b) -> check_con1 (ty @Applicative) diff --git a/Language/Symantic/Compiling/Applicative/Test.hs b/Language/Symantic/Compiling/Applicative/Test.hs index 22ed61a..c434b91 100644 --- a/Language/Symantic/Compiling/Applicative/Test.hs +++ b/Language/Symantic/Compiling/Applicative/Test.hs @@ -32,7 +32,7 @@ instance tokenizeT _t (Syntax "(<*>)" (ast_fa2b : as)) = Just $ do fa2b <- tokenize ast_fa2b Right $ (as,) $ EToken $ inj_token (Syntax "(<*>)" [ast_fa2b]) $ - Token_Term_Applicative_ltstargt fa2b + Token_Term_Applicative_app fa2b tokenizeT _t (Syntax "(<*)" (ast_fa : ast_fb : as)) = Just $ do fa <- tokenize ast_fa fb <- tokenize ast_fb diff --git a/Language/Symantic/Compiling/Char.hs b/Language/Symantic/Compiling/Char.hs index 10753a0..6bddc02 100644 --- a/Language/Symantic/Compiling/Char.hs +++ b/Language/Symantic/Compiling/Char.hs @@ -47,8 +47,8 @@ instance Sym_Char HostI where instance Sym_Char TextI where char a = TextI $ \_p _v -> Text.pack (show a) - char_toUpper = textI_app1 "Char.toUpper" - char_toLower = textI_app1 "Char.toLower" + char_toUpper = textI1 "Char.toUpper" + char_toLower = textI1 "Char.toLower" instance (Sym_Char r1, Sym_Char r2) => Sym_Char (DupI r1 r2) where char x = char x `DupI` char x char_toUpper = dupI1 (Proxy @Sym_Char) char_toUpper diff --git a/Language/Symantic/Compiling/Either.hs b/Language/Symantic/Compiling/Either.hs index 27874cb..3d35d0f 100644 --- a/Language/Symantic/Compiling/Either.hs +++ b/Language/Symantic/Compiling/Either.hs @@ -48,9 +48,9 @@ instance Sym_Either HostI where _Left = liftM Left either = liftM3 Either.either instance Sym_Either TextI where - _Right = textI_app1 "Right" - _Left = textI_app1 "Left" - either = textI_app3 "either" + _Right = textI1 "Right" + _Left = textI1 "Left" + either = textI3 "either" instance (Sym_Either r1, Sym_Either r2) => Sym_Either (DupI r1 r2) where _Left = dupI1 (Proxy @Sym_Either) _Left _Right = dupI1 (Proxy @Sym_Either) _Right diff --git a/Language/Symantic/Compiling/Foldable.hs b/Language/Symantic/Compiling/Foldable.hs index b6dc98f..b09d7d3 100644 --- a/Language/Symantic/Compiling/Foldable.hs +++ b/Language/Symantic/Compiling/Foldable.hs @@ -157,37 +157,37 @@ instance Sym_Foldable HostI where sequence_ = liftM Foldable.sequence_ traverse_ = liftM2 Foldable.traverse_ instance Sym_Foldable TextI where - foldMap = textI_app2 "foldMap" - foldr = textI_app3 "foldr" - foldr' = textI_app3 "foldr'" - foldl = textI_app3 "foldl" - foldl' = textI_app3 "foldl'" - null = textI_app1 "null" - length = textI_app1 "length" - minimum = textI_app1 "minimum" - maximum = textI_app1 "maximum" - elem = textI_app2 "elem" - sum = textI_app1 "sum" - product = textI_app1 "product" - toList = textI_app1 "toList" - all = textI_app2 "all" - and = textI_app1 "and" - any = textI_app2 "any" - concat = textI_app1 "concat" - concatMap = textI_app2 "concatMap" - find = textI_app2 "find" - foldlM = textI_app3 "foldlM" - foldrM = textI_app3 "foldrM" - forM_ = textI_app2 "forM_" - for_ = textI_app2 "for_" - mapM_ = textI_app2 "mapM_" - maximumBy = textI_app2 "maximumBy" - minimumBy = textI_app2 "minimumBy" - notElem = textI_app2 "notElem" - or = textI_app1 "or" - sequenceA_ = textI_app1 "sequenceA_" - sequence_ = textI_app1 "sequence_" - traverse_ = textI_app2 "traverse_" + foldMap = textI2 "foldMap" + foldr = textI3 "foldr" + foldr' = textI3 "foldr'" + foldl = textI3 "foldl" + foldl' = textI3 "foldl'" + null = textI1 "null" + length = textI1 "length" + minimum = textI1 "minimum" + maximum = textI1 "maximum" + elem = textI2 "elem" + sum = textI1 "sum" + product = textI1 "product" + toList = textI1 "toList" + all = textI2 "all" + and = textI1 "and" + any = textI2 "any" + concat = textI1 "concat" + concatMap = textI2 "concatMap" + find = textI2 "find" + foldlM = textI3 "foldlM" + foldrM = textI3 "foldrM" + forM_ = textI2 "forM_" + for_ = textI2 "for_" + mapM_ = textI2 "mapM_" + maximumBy = textI2 "maximumBy" + minimumBy = textI2 "minimumBy" + notElem = textI2 "notElem" + or = textI1 "or" + sequenceA_ = textI1 "sequenceA_" + sequence_ = textI1 "sequence_" + traverse_ = textI2 "traverse_" instance (Sym_Foldable r1, Sym_Foldable r2) => Sym_Foldable (DupI r1 r2) where foldMap = dupI2 (Proxy @Sym_Foldable) foldMap foldr = dupI3 (Proxy @Sym_Foldable) foldr diff --git a/Language/Symantic/Compiling/Functor.hs b/Language/Symantic/Compiling/Functor.hs index 8056ac7..4a74461 100644 --- a/Language/Symantic/Compiling/Functor.hs +++ b/Language/Symantic/Compiling/Functor.hs @@ -41,7 +41,7 @@ instance Sym_Functor HostI where fmap = liftM2 Functor.fmap (<$) = liftM2 (Functor.<$) instance Sym_Functor TextI where - fmap = textI_app2 "fmap" + fmap = textI2 "fmap" (<$) = textI_infix "<$" (Precedence 4) instance (Sym_Functor r1, Sym_Functor r2) => Sym_Functor (DupI r1 r2) where fmap = dupI2 (Proxy @Sym_Functor) fmap diff --git a/Language/Symantic/Compiling/IO.hs b/Language/Symantic/Compiling/IO.hs index 3152d69..06eaacf 100644 --- a/Language/Symantic/Compiling/IO.hs +++ b/Language/Symantic/Compiling/IO.hs @@ -49,8 +49,8 @@ instance Sym_IO HostI where io_hClose = liftM IO.hClose io_openFile = liftM2 IO.openFile instance Sym_IO TextI where - io_hClose = textI_app1 "IO.hClose" - io_openFile = textI_app2 "IO.openFile" + io_hClose = textI1 "IO.hClose" + io_openFile = textI2 "IO.openFile" instance (Sym_IO r1, Sym_IO r2) => Sym_IO (DupI r1 r2) where io_hClose = dupI1 (Proxy @Sym_IO) io_hClose io_openFile = dupI2 (Proxy @Sym_IO) io_openFile diff --git a/Language/Symantic/Compiling/Integral.hs b/Language/Symantic/Compiling/Integral.hs index b10e169..a0e3004 100644 --- a/Language/Symantic/Compiling/Integral.hs +++ b/Language/Symantic/Compiling/Integral.hs @@ -67,9 +67,9 @@ instance Sym_Integral TextI where div = textI_infix "`div`" (Precedence 7) rem = textI_infix "`rem`" (Precedence 7) mod = textI_infix "`mod`" (Precedence 7) - quotRem = textI_app2 "quotRem" - divMod = textI_app2 "divMod" - toInteger = textI_app1 "toInteger" + quotRem = textI2 "quotRem" + divMod = textI2 "divMod" + toInteger = textI1 "toInteger" instance (Sym_Integral r1, Sym_Integral r2) => Sym_Integral (DupI r1 r2) where quot = dupI2 (Proxy @Sym_Integral) quot rem = dupI2 (Proxy @Sym_Integral) rem diff --git a/Language/Symantic/Compiling/List.hs b/Language/Symantic/Compiling/List.hs index a5c28e1..dfdd65c 100644 --- a/Language/Symantic/Compiling/List.hs +++ b/Language/Symantic/Compiling/List.hs @@ -61,7 +61,7 @@ instance Sym_List TextI where list l = TextI $ \_p v -> let p' = precedence_Toplevel in "[" <> Text.intercalate ", " ((\(TextI a) -> a p' v) Functor.<$> l) <> "]" - zipWith = textI_app3 "zipWith" + zipWith = textI3 "zipWith" instance (Sym_List r1, Sym_List r2) => Sym_List (DupI r1 r2) where list_empty = dupI0 (Proxy @Sym_List) list_empty list l = diff --git a/Language/Symantic/Compiling/Map.hs b/Language/Symantic/Compiling/Map.hs index 771691f..bdbb3a3 100644 --- a/Language/Symantic/Compiling/Map.hs +++ b/Language/Symantic/Compiling/Map.hs @@ -79,15 +79,15 @@ instance Sym_Map HostI where map_difference = liftM2 Map.difference map_foldrWithKey = liftM3 Map.foldrWithKey instance Sym_Map TextI where - map_fromList = textI_app1 "Map.fromList" - map_mapWithKey = textI_app2 "Map.mapWithKey" - map_lookup = textI_app2 "Map.lookup" - map_keys = textI_app1 "Map.keys" - map_member = textI_app2 "Map.member" - map_insert = textI_app3 "Map.insert" - map_delete = textI_app2 "Map.delete" - map_difference = textI_app2 "Map.difference" - map_foldrWithKey = textI_app3 "Map.foldrWithKey" + map_fromList = textI1 "Map.fromList" + map_mapWithKey = textI2 "Map.mapWithKey" + map_lookup = textI2 "Map.lookup" + map_keys = textI1 "Map.keys" + map_member = textI2 "Map.member" + map_insert = textI3 "Map.insert" + map_delete = textI2 "Map.delete" + map_difference = textI2 "Map.difference" + map_foldrWithKey = textI3 "Map.foldrWithKey" instance (Sym_Map r1, Sym_Map r2) => Sym_Map (DupI r1 r2) where map_fromList = dupI1 (Proxy @Sym_Map) map_fromList map_mapWithKey = dupI2 (Proxy @Sym_Map) map_mapWithKey diff --git a/Language/Symantic/Compiling/Maybe.hs b/Language/Symantic/Compiling/Maybe.hs index 1d7cb1a..d238cd2 100644 --- a/Language/Symantic/Compiling/Maybe.hs +++ b/Language/Symantic/Compiling/Maybe.hs @@ -50,9 +50,9 @@ instance Sym_Maybe HostI where _Just = liftM Just maybe = liftM3 Maybe.maybe instance Sym_Maybe TextI where - _Nothing = textI_app0 "Nothing" - _Just = textI_app1 "Just" - maybe = textI_app3 "maybe" + _Nothing = textI0 "Nothing" + _Just = textI1 "Just" + maybe = textI3 "maybe" instance (Sym_Maybe r1, Sym_Maybe r2) => Sym_Maybe (DupI r1 r2) where _Nothing = dupI0 (Proxy @Sym_Maybe) _Nothing _Just = dupI1 (Proxy @Sym_Maybe) _Just diff --git a/Language/Symantic/Compiling/Monad.hs b/Language/Symantic/Compiling/Monad.hs index 5115605..49ef737 100644 --- a/Language/Symantic/Compiling/Monad.hs +++ b/Language/Symantic/Compiling/Monad.hs @@ -50,7 +50,7 @@ instance Sym_Monad HostI where (>>=) = Monad.liftM2 (Monad.>>=) when = Monad.liftM2 Monad.when instance Sym_Monad TextI where - return = textI_app1 "return" + return = textI1 "return" (>>=) = textI_infix ">>=" (Precedence 1) when (TextI cond) (TextI ok) = TextI $ \p v -> diff --git a/Language/Symantic/Compiling/MonoFoldable.hs b/Language/Symantic/Compiling/MonoFoldable.hs index d393a06..445943b 100644 --- a/Language/Symantic/Compiling/MonoFoldable.hs +++ b/Language/Symantic/Compiling/MonoFoldable.hs @@ -72,14 +72,14 @@ instance Sym_MonoFoldable HostI where oany = liftM2 MT.oany otoList = liftM MT.otoList instance Sym_MonoFoldable TextI where - ofoldMap = textI_app2 "ofoldMap" - ofoldr = textI_app3 "ofoldr" - ofoldl' = textI_app3 "ofoldl'" - olength = textI_app1 "olength" - onull = textI_app1 "onull" - oall = textI_app2 "oall" - oany = textI_app2 "oany" - otoList = textI_app1 "otoList" + ofoldMap = textI2 "ofoldMap" + ofoldr = textI3 "ofoldr" + ofoldl' = textI3 "ofoldl'" + olength = textI1 "olength" + onull = textI1 "onull" + oall = textI2 "oall" + oany = textI2 "oany" + otoList = textI1 "otoList" instance (Sym_MonoFoldable r1, Sym_MonoFoldable r2) => Sym_MonoFoldable (DupI r1 r2) where ofoldMap = dupI2 (Proxy @Sym_MonoFoldable) ofoldMap ofoldr = dupI3 (Proxy @Sym_MonoFoldable) ofoldr diff --git a/Language/Symantic/Compiling/MonoFunctor.hs b/Language/Symantic/Compiling/MonoFunctor.hs index 777ea4d..3de54bd 100644 --- a/Language/Symantic/Compiling/MonoFunctor.hs +++ b/Language/Symantic/Compiling/MonoFunctor.hs @@ -44,7 +44,7 @@ type instance Consts_imported_by MonoFunctor = instance Sym_MonoFunctor HostI where omap = liftM2 MT.omap instance Sym_MonoFunctor TextI where - omap = textI_app2 "omap" + omap = textI2 "omap" instance (Sym_MonoFunctor r1, Sym_MonoFunctor r2) => Sym_MonoFunctor (DupI r1 r2) where omap = dupI2 (Proxy @Sym_MonoFunctor) omap diff --git a/Language/Symantic/Compiling/Monoid.hs b/Language/Symantic/Compiling/Monoid.hs index 83d0208..d1565bc 100644 --- a/Language/Symantic/Compiling/Monoid.hs +++ b/Language/Symantic/Compiling/Monoid.hs @@ -35,8 +35,8 @@ instance Sym_Monoid HostI where mempty = HostI Monoid.mempty mappend = liftM2 Monoid.mappend instance Sym_Monoid TextI where - mempty = textI_app0 "mempty" - mappend = textI_app2 "mappend" + mempty = textI0 "mempty" + mappend = textI2 "mappend" instance (Sym_Monoid r1, Sym_Monoid r2) => Sym_Monoid (DupI r1 r2) where mempty = dupI0 (Proxy @Sym_Monoid) mempty mappend = dupI2 (Proxy @Sym_Monoid) mappend diff --git a/Language/Symantic/Compiling/NonNull.hs b/Language/Symantic/Compiling/NonNull.hs index b78a691..6cc6921 100644 --- a/Language/Symantic/Compiling/NonNull.hs +++ b/Language/Symantic/Compiling/NonNull.hs @@ -78,15 +78,15 @@ instance Sym_NonNull HostI where init = liftM NonNull.init nfilter = liftM2 NonNull.nfilter instance Sym_NonNull TextI where - fromNullable = textI_app1 "fromNullable" - toNullable = textI_app1 "toNullable" - ncons = textI_app2 "ncons" - nuncons = textI_app1 "nuncons" - head = textI_app1 "head" - last = textI_app1 "last" - tail = textI_app1 "tail" - init = textI_app1 "init" - nfilter = textI_app2 "nfilter" + fromNullable = textI1 "fromNullable" + toNullable = textI1 "toNullable" + ncons = textI2 "ncons" + nuncons = textI1 "nuncons" + head = textI1 "head" + last = textI1 "last" + tail = textI1 "tail" + init = textI1 "init" + nfilter = textI2 "nfilter" instance (Sym_NonNull r1, Sym_NonNull r2) => Sym_NonNull (DupI r1 r2) where fromNullable = dupI1 (Proxy @Sym_NonNull) fromNullable toNullable = dupI1 (Proxy @Sym_NonNull) toNullable diff --git a/Language/Symantic/Compiling/Num.hs b/Language/Symantic/Compiling/Num.hs index d7ccc00..8e0af47 100644 --- a/Language/Symantic/Compiling/Num.hs +++ b/Language/Symantic/Compiling/Num.hs @@ -63,13 +63,13 @@ instance Sym_Num HostI where (*) = liftM2 (Prelude.*) fromInteger = liftM Prelude.fromInteger instance Sym_Num TextI where - abs = textI_app1 "abs" - negate = textI_app1 "negate" - signum = textI_app1 "signum" + abs = textI1 "abs" + negate = textI1 "negate" + signum = textI1 "signum" (+) = textI_infix "+" (Precedence 6) (-) = textI_infix "-" (Precedence 6) (*) = textI_infix "-" (Precedence 7) - fromInteger = textI_app1 "fromInteger" + fromInteger = textI1 "fromInteger" instance (Sym_Num r1, Sym_Num r2) => Sym_Num (DupI r1 r2) where abs = dupI1 (Proxy @Sym_Num) abs negate = dupI1 (Proxy @Sym_Num) negate diff --git a/Language/Symantic/Compiling/Ord.hs b/Language/Symantic/Compiling/Ord.hs index d5f65d4..9eeda2c 100644 --- a/Language/Symantic/Compiling/Ord.hs +++ b/Language/Symantic/Compiling/Ord.hs @@ -62,13 +62,13 @@ instance Sym_Ord HostI where min = liftM2 Ord.min max = liftM2 Ord.max instance Sym_Ord TextI where - compare = textI_app2 "compare" + compare = textI2 "compare" (<) = textI_infix "<" (Precedence 4) (<=) = textI_infix "<=" (Precedence 4) (>) = textI_infix ">" (Precedence 4) (>=) = textI_infix ">=" (Precedence 4) - min = textI_app2 "min" - max = textI_app2 "max" + min = textI2 "min" + max = textI2 "max" instance (Sym_Ord r1, Sym_Ord r2) => Sym_Ord (DupI r1 r2) where compare = dupI2 (Proxy @Sym_Ord) compare (<) = dupI2 (Proxy @Sym_Ord) (<) diff --git a/Language/Symantic/Compiling/Sequences.hs b/Language/Symantic/Compiling/Sequences.hs index 7473318..926ffd2 100644 --- a/Language/Symantic/Compiling/Sequences.hs +++ b/Language/Symantic/Compiling/Sequences.hs @@ -48,10 +48,10 @@ instance Sym_SemiSequence HostI where snoc = liftM2 Seqs.snoc reverse = liftM Seqs.reverse instance Sym_SemiSequence TextI where - intersperse = textI_app2 "intersperse" - cons = textI_app2 "cons" - snoc = textI_app2 "snoc" - reverse = textI_app1 "reverse" + intersperse = textI2 "intersperse" + cons = textI2 "cons" + snoc = textI2 "snoc" + reverse = textI1 "reverse" instance (Sym_SemiSequence r1, Sym_SemiSequence r2) => Sym_SemiSequence (DupI r1 r2) where intersperse = dupI2 (Proxy @Sym_SemiSequence) intersperse cons = dupI2 (Proxy @Sym_SemiSequence) cons @@ -151,7 +151,7 @@ type instance Consts_imported_by IsSequence = instance Sym_IsSequence HostI where filter = liftM2 Seqs.filter instance Sym_IsSequence TextI where - filter = textI_app2 "filter" + filter = textI2 "filter" instance (Sym_IsSequence r1, Sym_IsSequence r2) => Sym_IsSequence (DupI r1 r2) where filter = dupI2 (Proxy @Sym_IsSequence) filter diff --git a/Language/Symantic/Compiling/Show.hs b/Language/Symantic/Compiling/Show.hs index 3cd6ee4..31e11ce 100644 --- a/Language/Symantic/Compiling/Show.hs +++ b/Language/Symantic/Compiling/Show.hs @@ -45,9 +45,9 @@ instance Sym_Show HostI where show = liftM Show.show showList = liftM Show.showList instance Sym_Show TextI where - showsPrec = textI_app2 "showsPrec" - show = textI_app1 "show" - showList = textI_app1 "showList" + showsPrec = textI2 "showsPrec" + show = textI1 "show" + showList = textI1 "showList" instance (Sym_Show r1, Sym_Show r2) => Sym_Show (DupI r1 r2) where showsPrec = dupI2 (Proxy @Sym_Show) showsPrec show = dupI1 (Proxy @Sym_Show) show diff --git a/Language/Symantic/Compiling/Term.hs b/Language/Symantic/Compiling/Term.hs index a2a5779..829fe79 100644 --- a/Language/Symantic/Compiling/Term.hs +++ b/Language/Symantic/Compiling/Term.hs @@ -415,9 +415,9 @@ instance Sym_Lambda TextI where <> unTextI e (Precedence 0) (succ v) <> " in " <> unTextI (in_ (TextI $ \_p _v -> x)) p' (succ v) (#) = textI_infix "." (Precedence 9) - id = textI_app1 "id" - const = textI_app2 "const" - flip = textI_app1 "flip" + id = textI1 "id" + const = textI2 "const" + flip = textI1 "flip" instance (Sym_Lambda r1, Sym_Lambda r2) => Sym_Lambda (DupI r1 r2) where lam f = dupI_1 lam_f `DupI` dupI_2 lam_f where lam_f = lam f diff --git a/Language/Symantic/Compiling/Text.hs b/Language/Symantic/Compiling/Text.hs index 7c81282..51f17b5 100644 --- a/Language/Symantic/Compiling/Text.hs +++ b/Language/Symantic/Compiling/Text.hs @@ -67,11 +67,4 @@ instance -- CompileI CompileI is (Proxy Text) where compileI tok _ctx k = case tok of - Token_Term_Text i -> k tyText $ TermO $ \_c -> text i - --- | The 'Text' 'Type' -tyText :: Inj_Const cs Text => Type cs Text -tyText = TyConst inj_const - -sym_Text :: Proxy Sym_Text -sym_Text = Proxy + Token_Term_Text i -> k (ty @Text) $ TermO $ \_c -> text i diff --git a/Language/Symantic/Compiling/Traversable.hs b/Language/Symantic/Compiling/Traversable.hs index 686875f..04e957e 100644 --- a/Language/Symantic/Compiling/Traversable.hs +++ b/Language/Symantic/Compiling/Traversable.hs @@ -32,7 +32,7 @@ type instance Consts_imported_by Traversable = '[] instance Sym_Traversable HostI where traverse = liftM2 Traversable.traverse instance Sym_Traversable TextI where - traverse = textI_app2 "traverse" + traverse = textI2 "traverse" instance (Sym_Traversable r1, Sym_Traversable r2) => Sym_Traversable (DupI r1 r2) where traverse = dupI2 (Proxy @Sym_Traversable) traverse diff --git a/Language/Symantic/Compiling/Tuple2.hs b/Language/Symantic/Compiling/Tuple2.hs index 2f6b73e..448788a 100644 --- a/Language/Symantic/Compiling/Tuple2.hs +++ b/Language/Symantic/Compiling/Tuple2.hs @@ -56,8 +56,8 @@ instance Sym_Tuple2 TextI where TextI $ \_p v -> let p' = precedence_Toplevel in "(" <> a p' v <> ", " <> b p' v <> ")" - fst = textI_app1 "fst" - snd = textI_app1 "snd" + fst = textI1 "fst" + snd = textI1 "snd" instance (Sym_Tuple2 r1, Sym_Tuple2 r2) => Sym_Tuple2 (DupI r1 r2) where tuple2 = dupI2 (Proxy @Sym_Tuple2) tuple2 fst = dupI1 (Proxy @Sym_Tuple2) fst diff --git a/Language/Symantic/Interpreting/Text.hs b/Language/Symantic/Interpreting/Text.hs index e513891..7337fe8 100644 --- a/Language/Symantic/Interpreting/Text.hs +++ b/Language/Symantic/Interpreting/Text.hs @@ -30,47 +30,30 @@ text_from_term r = unTextI r precedence_Toplevel 0 -- * Helpers -- ** Helpers for lambda applications -textI_app0 :: Text -> TextI h -textI_app0 name = TextI $ \_p _v -> name -textI_app1 - :: Text - -> TextI a1 - -> TextI h -textI_app1 name (TextI a1) = +textI0 :: Text -> TextI h +textI0 name = TextI $ \_p _v -> name +textI1 :: Text -> TextI a1 -> TextI h +textI1 name (TextI a1) = TextI $ \p v -> let p' = precedence_App in paren p p' $ name <> " " <> a1 p' v -textI_app2 - :: Text - -> TextI a1 - -> TextI a2 - -> TextI h -textI_app2 name (TextI a1) (TextI a2) = +textI2 :: Text -> TextI a1 -> TextI a2 -> TextI h +textI2 name (TextI a1) (TextI a2) = TextI $ \p v -> let p' = precedence_App in paren p p' $ name <> " " <> a1 p' v <> " " <> a2 p' v -textI_app3 - :: Text - -> TextI a1 - -> TextI a2 - -> TextI a3 - -> TextI h -textI_app3 name (TextI a1) (TextI a2) (TextI a3) = +textI3 :: Text -> TextI a1 -> TextI a2 -> TextI a3 -> TextI h +textI3 name (TextI a1) (TextI a2) (TextI a3) = TextI $ \p v -> let p' = precedence_App in paren p p' $ name <> " " <> a1 p' v <> " " <> a2 p' v <> " " <> a3 p' v -textI_infix - :: Text - -> Precedence - -> TextI a1 - -> TextI a2 - -> TextI h +textI_infix :: Text -> Precedence -> TextI a1 -> TextI a2 -> TextI h textI_infix name p' (TextI a1) (TextI a2) = TextI $ \p v -> paren p p' $ a1 p' v <> " " <> name <> " " <> a2 p' v -- 2.47.2 From 399063aa2e57c74caf29bf8fdba04c8cb211838c Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Thu, 5 Jan 2017 20:49:19 +0100 Subject: [PATCH 03/16] Add Compiling.Alternative. --- Language/Symantic/Compiling.hs | 2 + Language/Symantic/Compiling/Alternative.hs | 91 ++++++++++++++++++++++ 2 files changed, 93 insertions(+) create mode 100644 Language/Symantic/Compiling/Alternative.hs diff --git a/Language/Symantic/Compiling.hs b/Language/Symantic/Compiling.hs index 0027227..0b54ba4 100644 --- a/Language/Symantic/Compiling.hs +++ b/Language/Symantic/Compiling.hs @@ -2,6 +2,7 @@ module Language.Symantic.Compiling ( module Language.Symantic.Compiling.Term , module Language.Symantic.Compiling.Applicative + , module Language.Symantic.Compiling.Alternative , module Language.Symantic.Compiling.Bool , module Language.Symantic.Compiling.Char , module Language.Symantic.Compiling.Either @@ -33,6 +34,7 @@ module Language.Symantic.Compiling import Language.Symantic.Compiling.Term import Language.Symantic.Compiling.Applicative +import Language.Symantic.Compiling.Alternative import Language.Symantic.Compiling.Bool import Language.Symantic.Compiling.Char import Language.Symantic.Compiling.Either diff --git a/Language/Symantic/Compiling/Alternative.hs b/Language/Symantic/Compiling/Alternative.hs new file mode 100644 index 0000000..25b176b --- /dev/null +++ b/Language/Symantic/Compiling/Alternative.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | Symantic for 'Alternative'. +module Language.Symantic.Compiling.Alternative where + +import Control.Applicative (Alternative) +import qualified Control.Applicative as Alternative +import Control.Monad (liftM2) +import qualified Data.Function as Fun +import Data.Proxy +import Data.Text (Text) +import Data.Type.Equality ((:~:)(Refl)) +import Prelude hiding (Functor(..), (<$>), id, const, Monoid(..)) + +import Language.Symantic.Parsing +import Language.Symantic.Typing +import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling.Functor (Sym_Functor(..)) +import Language.Symantic.Interpreting +import Language.Symantic.Transforming.Trans + +-- * Class 'Sym_Alternative' +class Sym_Functor term => Sym_Alternative term where + empty :: Alternative f => term (f a) + (<|>) :: Alternative f => term (f a) -> term (f a) -> term (f a) + + default empty :: (Trans t term, Alternative f) => t term (f a) + default (<|>) :: (Trans t term, Alternative f) + => t term (f a) -> t term (f a) -> t term (f a) + + empty = trans_lift empty + (<|>) = trans_map2 (<|>) + +infixl 3 <|> + +type instance Sym_of_Iface (Proxy Alternative) = Sym_Alternative +type instance Consts_of_Iface (Proxy Alternative) = Proxy Alternative ': Consts_imported_by Alternative +type instance Consts_imported_by Alternative = '[] + +instance Sym_Alternative HostI where + empty = HostI Alternative.empty + (<|>) = liftM2 (Alternative.<|>) +instance Sym_Alternative TextI where + empty = textI0 "empty" + (<|>) = textI_infix "<|>" (Precedence 3) +instance (Sym_Alternative r1, Sym_Alternative r2) => Sym_Alternative (DupI r1 r2) where + empty = dupI0 (Proxy @Sym_Alternative) empty + (<|>) = dupI2 (Proxy @Sym_Alternative) (<|>) + +instance Const_from Text cs => Const_from Text (Proxy Alternative ': cs) where + const_from "Alternative" k = k (ConstZ kind) + const_from s k = const_from s $ k . ConstS +instance Show_Const cs => Show_Const (Proxy Alternative ': cs) where + show_const ConstZ{} = "Alternative" + show_const (ConstS c) = show_const c + +instance Proj_ConC cs (Proxy Alternative) +data instance TokenT meta (ts::[*]) (Proxy Alternative) + = Token_Term_Alternative_empty (EToken meta '[Proxy Token_Type]) (EToken meta '[Proxy Token_Type]) + | Token_Term_Alternative_alt (EToken meta ts) +deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Alternative)) +deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Alternative)) +instance -- CompileI + ( Const_from Name_LamVar (Consts_of_Ifaces is) + , Inj_Const (Consts_of_Ifaces is) Alternative + , Inj_Const (Consts_of_Ifaces is) (->) + , Proj_Con (Consts_of_Ifaces is) + , Compile is + ) => CompileI is (Proxy Alternative) where + compileI tok ctx k = + case tok of + Token_Term_Alternative_empty tok_ty_f tok_ty_a -> + -- empty :: Alternative f => f a + compile_type tok_ty_f $ \(ty_f::Type (Consts_of_Ifaces is) f) -> + compile_type tok_ty_a $ \(ty_a::Type (Consts_of_Ifaces is) a) -> + check_kind + (At Nothing $ SKiType `SKiArrow` SKiType) + (At (Just tok_ty_f) $ kind_of ty_f) $ \Refl -> + check_con (At (Just tok_ty_f) (ty @Alternative :$ ty_f)) $ \Con -> + check_kind + (At Nothing $ SKiType) + (At (Just tok_ty_a) $ kind_of ty_a) $ \Refl -> + k (ty_f :$ ty_a) $ TermO $ + Fun.const empty + Token_Term_Alternative_alt tok_fl -> + -- (<|>) :: Alternative f => f a -> f a -> f a + compileO tok_fl ctx $ \ty_fa (TermO fl) -> + check_con1 (ty @Alternative) + (At (Just tok_fl) ty_fa) $ \Refl Con _ty_f _ty_a -> + k (ty_fa ~> ty_fa) $ TermO $ + \c -> lam $ \fr -> (<|>) (fl c) fr -- 2.47.2 From 7fd8d4d74d9a589ce518e9e207985e7b63ef4c0a Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Fri, 6 Jan 2017 19:48:29 +0100 Subject: [PATCH 04/16] Fix comment typo. --- Language/Symantic/Compiling/Term.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Language/Symantic/Compiling/Term.hs b/Language/Symantic/Compiling/Term.hs index 829fe79..b437175 100644 --- a/Language/Symantic/Compiling/Term.hs +++ b/Language/Symantic/Compiling/Term.hs @@ -35,8 +35,8 @@ data Term is h -- qualified by the symantics of a term. -- -- Moreover the term is abstracted by a 'LamCtx_Term' --- built top-down at by 'compileO' --- to build a /Higher-Order Abstract Syntax/ (HOAS) +-- built top-down by 'compileO', +-- to enable a /Higher-Order Abstract Syntax/ (HOAS) -- for /lambda abstractions/ ('lam'). -- -- This data type is used to keep a parsed term polymorphic enough -- 2.47.2 From bb1e732362cab52923fec44558763a8219ab83c5 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Wed, 11 Jan 2017 02:18:47 +0100 Subject: [PATCH 05/16] Add Parsing.Grammar. --- Language/Symantic/Compiling/Alternative.hs | 11 +- Language/Symantic/Compiling/Applicative.hs | 11 +- Language/Symantic/Compiling/Bool.hs | 9 +- Language/Symantic/Compiling/Char.hs | 9 +- Language/Symantic/Compiling/Either.hs | 11 +- Language/Symantic/Compiling/Eq.hs | 9 +- Language/Symantic/Compiling/Foldable.hs | 9 +- Language/Symantic/Compiling/Functor.hs | 9 +- Language/Symantic/Compiling/IO.hs | 27 +- Language/Symantic/Compiling/If.hs | 9 +- Language/Symantic/Compiling/Int.hs | 9 +- Language/Symantic/Compiling/Integer.hs | 9 +- Language/Symantic/Compiling/Integral.hs | 9 +- Language/Symantic/Compiling/List.hs | 14 +- Language/Symantic/Compiling/Map.hs | 9 +- Language/Symantic/Compiling/Maybe.hs | 11 +- Language/Symantic/Compiling/Monad.hs | 11 +- Language/Symantic/Compiling/MonoFoldable.hs | 9 +- Language/Symantic/Compiling/MonoFunctor.hs | 9 +- Language/Symantic/Compiling/Monoid.hs | 11 +- Language/Symantic/Compiling/NonNull.hs | 9 +- Language/Symantic/Compiling/Num.hs | 11 +- Language/Symantic/Compiling/Ord.hs | 9 +- Language/Symantic/Compiling/Sequences.hs | 18 +- Language/Symantic/Compiling/Show.hs | 9 +- Language/Symantic/Compiling/Term.hs | 19 +- Language/Symantic/Compiling/Text.hs | 9 +- Language/Symantic/Compiling/Traversable.hs | 9 +- Language/Symantic/Compiling/Tuple2.hs | 9 +- Language/Symantic/Compiling/Unit.hs | 9 +- Language/Symantic/Parsing/EBNF.hs | 15 + Language/Symantic/Parsing/Grammar.hs | 463 ++++++++++++++++++++ Language/Symantic/Parsing/Grammar/Test.hs | 179 ++++++++ Language/Symantic/Parsing/Test.hs | 3 +- Language/Symantic/Typing/Constant.hs | 24 - Language/Symantic/Typing/Test.hs | 134 +++--- Language/Symantic/Typing/Type.hs | 170 ++++++- symantic.cabal | 40 +- 38 files changed, 1152 insertions(+), 202 deletions(-) create mode 100644 Language/Symantic/Parsing/EBNF.hs create mode 100644 Language/Symantic/Parsing/Grammar.hs create mode 100644 Language/Symantic/Parsing/Grammar/Test.hs diff --git a/Language/Symantic/Compiling/Alternative.hs b/Language/Symantic/Compiling/Alternative.hs index 25b176b..2b99cd8 100644 --- a/Language/Symantic/Compiling/Alternative.hs +++ b/Language/Symantic/Compiling/Alternative.hs @@ -47,9 +47,12 @@ instance (Sym_Alternative r1, Sym_Alternative r2) => Sym_Alternative (DupI r1 r2 empty = dupI0 (Proxy @Sym_Alternative) empty (<|>) = dupI2 (Proxy @Sym_Alternative) (<|>) -instance Const_from Text cs => Const_from Text (Proxy Alternative ': cs) where - const_from "Alternative" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Alternative + ) => Read_TypeNameR Text cs (Proxy Alternative ': rs) where + read_typenameR _cs "Alternative" k = k (ty @Alternative) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Alternative ': cs) where show_const ConstZ{} = "Alternative" show_const (ConstS c) = show_const c @@ -61,7 +64,7 @@ data instance TokenT meta (ts::[*]) (Proxy Alternative) deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Alternative)) deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Alternative)) instance -- CompileI - ( Const_from Name_LamVar (Consts_of_Ifaces is) + ( Read_TypeName Name_LamVar (Consts_of_Ifaces is) , Inj_Const (Consts_of_Ifaces is) Alternative , Inj_Const (Consts_of_Ifaces is) (->) , Proj_Con (Consts_of_Ifaces is) diff --git a/Language/Symantic/Compiling/Applicative.hs b/Language/Symantic/Compiling/Applicative.hs index 4e4c4a0..c9f0279 100644 --- a/Language/Symantic/Compiling/Applicative.hs +++ b/Language/Symantic/Compiling/Applicative.hs @@ -55,9 +55,12 @@ instance (Sym_Applicative r1, Sym_Applicative r2) => Sym_Applicative (DupI r1 r2 pure = dupI1 (Proxy @Sym_Applicative) pure (<*>) = dupI2 (Proxy @Sym_Applicative) (<*>) -instance Const_from Text cs => Const_from Text (Proxy Applicative ': cs) where - const_from "Applicative" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Applicative + ) => Read_TypeNameR Text cs (Proxy Applicative ': rs) where + read_typenameR _cs "Applicative" k = k (ty @Applicative) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Applicative ': cs) where show_const ConstZ{} = "Applicative" show_const (ConstS c) = show_const c @@ -71,7 +74,7 @@ data instance TokenT meta (ts::[*]) (Proxy Applicative) deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Applicative)) deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Applicative)) instance -- CompileI - ( Const_from Name_LamVar (Consts_of_Ifaces is) + ( Read_TypeName Name_LamVar (Consts_of_Ifaces is) , Inj_Const (Consts_of_Ifaces is) Applicative , Inj_Const (Consts_of_Ifaces is) (->) , Proj_Con (Consts_of_Ifaces is) diff --git a/Language/Symantic/Compiling/Bool.hs b/Language/Symantic/Compiling/Bool.hs index 41ef6f7..b3dda74 100644 --- a/Language/Symantic/Compiling/Bool.hs +++ b/Language/Symantic/Compiling/Bool.hs @@ -73,9 +73,12 @@ instance (Sym_Bool r1, Sym_Bool r2) => Sym_Bool (DupI r1 r2) where (||) = dupI2 (Proxy @Sym_Bool) (||) xor = dupI2 (Proxy @Sym_Bool) xor -instance Const_from Text cs => Const_from Text (Proxy Bool ': cs) where - const_from "Bool" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Bool + ) => Read_TypeNameR Text cs (Proxy Bool ': rs) where + read_typenameR _cs "Bool" k = k (ty @Bool) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Bool ': cs) where show_const ConstZ{} = "Bool" show_const (ConstS c) = show_const c diff --git a/Language/Symantic/Compiling/Char.hs b/Language/Symantic/Compiling/Char.hs index 6bddc02..cb0aefc 100644 --- a/Language/Symantic/Compiling/Char.hs +++ b/Language/Symantic/Compiling/Char.hs @@ -54,9 +54,12 @@ instance (Sym_Char r1, Sym_Char r2) => Sym_Char (DupI r1 r2) where char_toUpper = dupI1 (Proxy @Sym_Char) char_toUpper char_toLower = dupI1 (Proxy @Sym_Char) char_toLower -instance Const_from Text cs => Const_from Text (Proxy Char ': cs) where - const_from "Char" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Char + ) => Read_TypeNameR Text cs (Proxy Char ': rs) where + read_typenameR _cs "Char" k = k (ty @Char) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Char ': cs) where show_const ConstZ{} = "Char" show_const (ConstS c) = show_const c diff --git a/Language/Symantic/Compiling/Either.hs b/Language/Symantic/Compiling/Either.hs index 3d35d0f..51dcd33 100644 --- a/Language/Symantic/Compiling/Either.hs +++ b/Language/Symantic/Compiling/Either.hs @@ -56,9 +56,12 @@ instance (Sym_Either r1, Sym_Either r2) => Sym_Either (DupI r1 r2) where _Right = dupI1 (Proxy @Sym_Either) _Right either = dupI3 (Proxy @Sym_Either) either -instance Const_from Text cs => Const_from Text (Proxy Either ': cs) where - const_from "Either" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Either + ) => Read_TypeNameR Text cs (Proxy Either ': rs) where + read_typenameR _cs "Either" k = k (ty @Either) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Either ': cs) where show_const ConstZ{} = "Either" show_const (ConstS c) = show_const c @@ -99,7 +102,7 @@ data instance TokenT meta (ts::[*]) (Proxy Either) deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Either)) deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Either)) instance -- CompileI - ( Const_from Name_LamVar (Consts_of_Ifaces is) + ( Read_TypeName Name_LamVar (Consts_of_Ifaces is) , Inj_Const (Consts_of_Ifaces is) Either , Inj_Const (Consts_of_Ifaces is) (->) -- , Proj_Token is Token_Type diff --git a/Language/Symantic/Compiling/Eq.hs b/Language/Symantic/Compiling/Eq.hs index ddb5866..7b115fd 100644 --- a/Language/Symantic/Compiling/Eq.hs +++ b/Language/Symantic/Compiling/Eq.hs @@ -43,9 +43,12 @@ instance (Sym_Eq r1, Sym_Eq r2) => Sym_Eq (DupI r1 r2) where (==) = dupI2 (Proxy @Sym_Eq) (==) (/=) = dupI2 (Proxy @Sym_Eq) (/=) -instance Const_from Text cs => Const_from Text (Proxy Eq ': cs) where - const_from "Eq" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Eq + ) => Read_TypeNameR Text cs (Proxy Eq ': rs) where + read_typenameR _cs "Eq" k = k (ty @Eq) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Eq ': cs) where show_const ConstZ{} = "Eq" show_const (ConstS c) = show_const c diff --git a/Language/Symantic/Compiling/Foldable.hs b/Language/Symantic/Compiling/Foldable.hs index b09d7d3..e0f7d31 100644 --- a/Language/Symantic/Compiling/Foldable.hs +++ b/Language/Symantic/Compiling/Foldable.hs @@ -221,9 +221,12 @@ instance (Sym_Foldable r1, Sym_Foldable r2) => Sym_Foldable (DupI r1 r2) where sequence_ = dupI1 (Proxy @Sym_Foldable) sequence_ traverse_ = dupI2 (Proxy @Sym_Foldable) traverse_ -instance Const_from Text cs => Const_from Text (Proxy Foldable ': cs) where - const_from "Foldable" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Foldable + ) => Read_TypeNameR Text cs (Proxy Foldable ': rs) where + read_typenameR _cs "Foldable" k = k (ty @Foldable) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Foldable ': cs) where show_const ConstZ{} = "Foldable" show_const (ConstS c) = show_const c diff --git a/Language/Symantic/Compiling/Functor.hs b/Language/Symantic/Compiling/Functor.hs index 4a74461..38c2867 100644 --- a/Language/Symantic/Compiling/Functor.hs +++ b/Language/Symantic/Compiling/Functor.hs @@ -53,9 +53,12 @@ instance (Sym_Functor r1, Sym_Functor r2) => Sym_Functor (DupI r1 r2) where (<$>) = fmap infixl 4 <$> -instance Const_from Text cs => Const_from Text (Proxy Functor ': cs) where - const_from "Functor" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Functor + ) => Read_TypeNameR Text cs (Proxy Functor ': rs) where + read_typenameR _cs "Functor" k = k (ty @Functor) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Functor ': cs) where show_const ConstZ{} = "Functor" show_const (ConstS c) = show_const c diff --git a/Language/Symantic/Compiling/IO.hs b/Language/Symantic/Compiling/IO.hs index 06eaacf..afbf782 100644 --- a/Language/Symantic/Compiling/IO.hs +++ b/Language/Symantic/Compiling/IO.hs @@ -55,15 +55,24 @@ instance (Sym_IO r1, Sym_IO r2) => Sym_IO (DupI r1 r2) where io_hClose = dupI1 (Proxy @Sym_IO) io_hClose io_openFile = dupI2 (Proxy @Sym_IO) io_openFile -instance Const_from Text cs => Const_from Text (Proxy IO ': cs) where - const_from "IO" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS -instance Const_from Text cs => Const_from Text (Proxy IO.Handle ': cs) where - const_from "IO.Handle" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS -instance Const_from Text cs => Const_from Text (Proxy IO.IOMode ': cs) where - const_from "IO.IOMode" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs IO + ) => Read_TypeNameR Text cs (Proxy IO ': rs) where + read_typenameR _cs "IO" k = k (ty @IO) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs IO.Handle + ) => Read_TypeNameR Text cs (Proxy IO.Handle ': rs) where + read_typenameR _cs "IO.Handle" k = k (ty @IO.Handle) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs IO.IOMode + ) => Read_TypeNameR Text cs (Proxy IO.IOMode ': rs) where + read_typenameR _cs "IO.Mode" k = k (ty @IO.IOMode) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy IO ': cs) where show_const ConstZ{} = "IO" diff --git a/Language/Symantic/Compiling/If.hs b/Language/Symantic/Compiling/If.hs index 588dbd0..73f03e4 100644 --- a/Language/Symantic/Compiling/If.hs +++ b/Language/Symantic/Compiling/If.hs @@ -41,8 +41,13 @@ instance Sym_If TextI where instance (Sym_If r1, Sym_If r2) => Sym_If (DupI r1 r2) where if_ = dupI3 (Proxy @Sym_If) if_ -instance Const_from Text cs => Const_from Text (Proxy If ': cs) where - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + ) => Read_TypeNameR Text cs (Proxy If ': rs) where + read_typenameR _rs = read_typenameR (Proxy @rs) +instance Show_Const cs => Show_Const (Proxy If ': cs) where + show_const ConstZ{} = "If" + show_const (ConstS c) = show_const c instance Proj_ConC cs (Proxy If) data instance TokenT meta (ts::[*]) (Proxy If) diff --git a/Language/Symantic/Compiling/Int.hs b/Language/Symantic/Compiling/Int.hs index a82b13f..d929fd5 100644 --- a/Language/Symantic/Compiling/Int.hs +++ b/Language/Symantic/Compiling/Int.hs @@ -42,9 +42,12 @@ instance Sym_Int TextI where instance (Sym_Int r1, Sym_Int r2) => Sym_Int (DupI r1 r2) where int x = int x `DupI` int x -instance Const_from Text cs => Const_from Text (Proxy Int ': cs) where - const_from "Int" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Int + ) => Read_TypeNameR Text cs (Proxy Int ': rs) where + read_typenameR _cs "Int" k = k (ty @Int) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Int ': cs) where show_const ConstZ{} = "Int" show_const (ConstS c) = show_const c diff --git a/Language/Symantic/Compiling/Integer.hs b/Language/Symantic/Compiling/Integer.hs index 4c91cac..80cb4ee 100644 --- a/Language/Symantic/Compiling/Integer.hs +++ b/Language/Symantic/Compiling/Integer.hs @@ -41,9 +41,12 @@ instance Sym_Integer TextI where instance (Sym_Integer r1, Sym_Integer r2) => Sym_Integer (DupI r1 r2) where integer x = integer x `DupI` integer x -instance Const_from Text cs => Const_from Text (Proxy Integer ': cs) where - const_from "Integer" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Integer + ) => Read_TypeNameR Text cs (Proxy Integer ': rs) where + read_typenameR _cs "Integer" k = k (ty @Integer) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Integer ': cs) where show_const ConstZ{} = "Integer" show_const (ConstS c) = show_const c diff --git a/Language/Symantic/Compiling/Integral.hs b/Language/Symantic/Compiling/Integral.hs index a0e3004..b288a10 100644 --- a/Language/Symantic/Compiling/Integral.hs +++ b/Language/Symantic/Compiling/Integral.hs @@ -79,9 +79,12 @@ instance (Sym_Integral r1, Sym_Integral r2) => Sym_Integral (DupI r1 r2) where divMod = dupI2 (Proxy @Sym_Integral) divMod toInteger = dupI1 (Proxy @Sym_Integral) toInteger -instance Const_from Text cs => Const_from Text (Proxy Integral ': cs) where - const_from "Integral" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Integral + ) => Read_TypeNameR Text cs (Proxy Integral ': rs) where + read_typenameR _cs "Integral" k = k (ty @Integral) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Integral ': cs) where show_const ConstZ{} = "Integral" show_const (ConstS c) = show_const c diff --git a/Language/Symantic/Compiling/List.hs b/Language/Symantic/Compiling/List.hs index dfdd65c..e24da86 100644 --- a/Language/Symantic/Compiling/List.hs +++ b/Language/Symantic/Compiling/List.hs @@ -71,15 +71,15 @@ instance (Sym_List r1, Sym_List r2) => Sym_List (DupI r1 r2) where list l1 `DupI` list l2 zipWith = dupI3 (Proxy @Sym_List) zipWith -instance Const_from Text cs => Const_from Text (Proxy [] ': cs) where - const_from "[]" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs [] + ) => Read_TypeNameR Text cs (Proxy [] ': rs) where + read_typenameR _cs "[]" k = k (ty @[]) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy [] ': cs) where show_const ConstZ{} = "[]" show_const (ConstS c) = show_const c -instance Const_from String cs => Const_from String (Proxy String ': cs) where - const_from "String" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS instance Show_Const cs => Show_Const (Proxy String ': cs) where show_const ConstZ{} = "String" show_const (ConstS c) = show_const c @@ -119,7 +119,7 @@ data instance TokenT meta (ts::[*]) (Proxy []) deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy [])) deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy [])) instance -- CompileI - ( Const_from Name_LamVar (Consts_of_Ifaces is) + ( Read_TypeName Name_LamVar (Consts_of_Ifaces is) , Inj_Const (Consts_of_Ifaces is) [] , Inj_Const (Consts_of_Ifaces is) (->) , Compile is diff --git a/Language/Symantic/Compiling/Map.hs b/Language/Symantic/Compiling/Map.hs index bdbb3a3..3cd504a 100644 --- a/Language/Symantic/Compiling/Map.hs +++ b/Language/Symantic/Compiling/Map.hs @@ -99,9 +99,12 @@ instance (Sym_Map r1, Sym_Map r2) => Sym_Map (DupI r1 r2) where map_difference = dupI2 (Proxy @Sym_Map) map_difference map_foldrWithKey = dupI3 (Proxy @Sym_Map) map_foldrWithKey -instance Const_from Text cs => Const_from Text (Proxy Map ': cs) where - const_from "Map" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Map + ) => Read_TypeNameR Text cs (Proxy Map ': rs) where + read_typenameR _cs "Map" k = k (ty @Map) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Map ': cs) where show_const ConstZ{} = "Map" show_const (ConstS c) = show_const c diff --git a/Language/Symantic/Compiling/Maybe.hs b/Language/Symantic/Compiling/Maybe.hs index d238cd2..325a15b 100644 --- a/Language/Symantic/Compiling/Maybe.hs +++ b/Language/Symantic/Compiling/Maybe.hs @@ -58,9 +58,12 @@ instance (Sym_Maybe r1, Sym_Maybe r2) => Sym_Maybe (DupI r1 r2) where _Just = dupI1 (Proxy @Sym_Maybe) _Just maybe = dupI3 (Proxy @Sym_Maybe) maybe -instance Const_from Text cs => Const_from Text (Proxy Maybe ': cs) where - const_from "Maybe" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Maybe + ) => Read_TypeNameR Text cs (Proxy Maybe ': rs) where + read_typenameR _cs "Maybe" k = k (ty @Maybe) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Maybe ': cs) where show_const ConstZ{} = "Maybe" show_const (ConstS c) = show_const c @@ -99,7 +102,7 @@ data instance TokenT meta (ts::[*]) (Proxy Maybe) deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Maybe)) deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Maybe)) instance -- CompileI - ( Const_from Name_LamVar (Consts_of_Ifaces is) + ( Read_TypeName Name_LamVar (Consts_of_Ifaces is) , Inj_Const (Consts_of_Ifaces is) Maybe , Inj_Const (Consts_of_Ifaces is) (->) , Compile is diff --git a/Language/Symantic/Compiling/Monad.hs b/Language/Symantic/Compiling/Monad.hs index 49ef737..86d5b26 100644 --- a/Language/Symantic/Compiling/Monad.hs +++ b/Language/Symantic/Compiling/Monad.hs @@ -63,9 +63,12 @@ instance (Sym_Monad r1, Sym_Monad r2) => Sym_Monad (DupI r1 r2) where (>>=) = dupI2 (Proxy @Sym_Monad) (>>=) when = dupI2 (Proxy @Sym_Monad) when -instance Const_from Text cs => Const_from Text (Proxy Monad ': cs) where - const_from "Monad" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Monad + ) => Read_TypeNameR Text cs (Proxy Monad ': rs) where + read_typenameR _cs "Monad" k = k (ty @Monad) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Monad ': cs) where show_const ConstZ{} = "Monad" show_const (ConstS c) = show_const c @@ -78,7 +81,7 @@ data instance TokenT meta (ts::[*]) (Proxy Monad) deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Monad)) deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Monad)) instance -- CompileI - ( Const_from Name_LamVar (Consts_of_Ifaces is) + ( Read_TypeName Name_LamVar (Consts_of_Ifaces is) , Inj_Const (Consts_of_Ifaces is) Monad , Inj_Const (Consts_of_Ifaces is) (->) , Inj_Const (Consts_of_Ifaces is) () diff --git a/Language/Symantic/Compiling/MonoFoldable.hs b/Language/Symantic/Compiling/MonoFoldable.hs index 445943b..cc5e6c1 100644 --- a/Language/Symantic/Compiling/MonoFoldable.hs +++ b/Language/Symantic/Compiling/MonoFoldable.hs @@ -90,9 +90,12 @@ instance (Sym_MonoFoldable r1, Sym_MonoFoldable r2) => Sym_MonoFoldable (DupI r1 oany = dupI2 (Proxy @Sym_MonoFoldable) oany otoList = dupI1 (Proxy @Sym_MonoFoldable) otoList -instance Const_from Text cs => Const_from Text (Proxy MonoFoldable ': cs) where - const_from "MonoFoldable" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs MonoFoldable + ) => Read_TypeNameR Text cs (Proxy MonoFoldable ': rs) where + read_typenameR _cs "MonoFoldable" k = k (ty @MonoFoldable) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy MonoFoldable ': cs) where show_const ConstZ{} = "MonoFoldable" show_const (ConstS c) = show_const c diff --git a/Language/Symantic/Compiling/MonoFunctor.hs b/Language/Symantic/Compiling/MonoFunctor.hs index 3de54bd..4d5be61 100644 --- a/Language/Symantic/Compiling/MonoFunctor.hs +++ b/Language/Symantic/Compiling/MonoFunctor.hs @@ -48,9 +48,12 @@ instance Sym_MonoFunctor TextI where instance (Sym_MonoFunctor r1, Sym_MonoFunctor r2) => Sym_MonoFunctor (DupI r1 r2) where omap = dupI2 (Proxy @Sym_MonoFunctor) omap -instance Const_from Text cs => Const_from Text (Proxy MonoFunctor ': cs) where - const_from "MonoFunctor" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs MonoFunctor + ) => Read_TypeNameR Text cs (Proxy MonoFunctor ': rs) where + read_typenameR _cs "MonoFunctor" k = k (ty @MonoFunctor) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy MonoFunctor ': cs) where show_const ConstZ{} = "MonoFunctor" show_const (ConstS c) = show_const c diff --git a/Language/Symantic/Compiling/Monoid.hs b/Language/Symantic/Compiling/Monoid.hs index d1565bc..50c91dc 100644 --- a/Language/Symantic/Compiling/Monoid.hs +++ b/Language/Symantic/Compiling/Monoid.hs @@ -49,9 +49,12 @@ instance (Sym_Monoid r1, Sym_Monoid r2) => Sym_Monoid (DupI r1 r2) where (<>) = mappend infixr 6 <> -instance Const_from Text cs => Const_from Text (Proxy Monoid ': cs) where - const_from "Monoid" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Monoid + ) => Read_TypeNameR Text cs (Proxy Monoid ': rs) where + read_typenameR _cs "Monoid" k = k (ty @Monoid) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Monoid ': cs) where show_const ConstZ{} = "Monoid" show_const (ConstS c) = show_const c @@ -63,7 +66,7 @@ data instance TokenT meta (ts::[*]) (Proxy Monoid) deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Monoid)) deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Monoid)) instance -- CompileI - ( Const_from Name_LamVar (Consts_of_Ifaces is) + ( Read_TypeName Name_LamVar (Consts_of_Ifaces is) , Inj_Const (Consts_of_Ifaces is) Monoid , Inj_Const (Consts_of_Ifaces is) (->) , Proj_Con (Consts_of_Ifaces is) diff --git a/Language/Symantic/Compiling/NonNull.hs b/Language/Symantic/Compiling/NonNull.hs index 6cc6921..95b5e35 100644 --- a/Language/Symantic/Compiling/NonNull.hs +++ b/Language/Symantic/Compiling/NonNull.hs @@ -98,9 +98,12 @@ instance (Sym_NonNull r1, Sym_NonNull r2) => Sym_NonNull (DupI r1 r2) where init = dupI1 (Proxy @Sym_NonNull) init nfilter = dupI2 (Proxy @Sym_NonNull) nfilter -instance Const_from Text cs => Const_from Text (Proxy NonNull ': cs) where - const_from "NonNull" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs NonNull + ) => Read_TypeNameR Text cs (Proxy NonNull ': rs) where + read_typenameR _cs "NonNull" k = k (ty @NonNull) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy NonNull ': cs) where show_const ConstZ{} = "NonNull" show_const (ConstS c) = show_const c diff --git a/Language/Symantic/Compiling/Num.hs b/Language/Symantic/Compiling/Num.hs index 8e0af47..e4a5d45 100644 --- a/Language/Symantic/Compiling/Num.hs +++ b/Language/Symantic/Compiling/Num.hs @@ -79,9 +79,12 @@ instance (Sym_Num r1, Sym_Num r2) => Sym_Num (DupI r1 r2) where (*) = dupI2 (Proxy @Sym_Num) (*) fromInteger = dupI1 (Proxy @Sym_Num) fromInteger -instance Const_from Text cs => Const_from Text (Proxy Num ': cs) where - const_from "Num" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Num + ) => Read_TypeNameR Text cs (Proxy Num ': rs) where + read_typenameR _cs "Num" k = k (ty @Num) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Num ': cs) where show_const ConstZ{} = "Num" show_const (ConstS c) = show_const c @@ -98,7 +101,7 @@ data instance TokenT meta (ts::[*]) (Proxy Num) deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Num)) deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Num)) instance -- CompileI - ( Const_from Name_LamVar (Consts_of_Ifaces is) + ( Read_TypeName Name_LamVar (Consts_of_Ifaces is) , Inj_Const (Consts_of_Ifaces is) Num , Inj_Const (Consts_of_Ifaces is) (->) , Inj_Const (Consts_of_Ifaces is) Integer diff --git a/Language/Symantic/Compiling/Ord.hs b/Language/Symantic/Compiling/Ord.hs index 9eeda2c..693ad61 100644 --- a/Language/Symantic/Compiling/Ord.hs +++ b/Language/Symantic/Compiling/Ord.hs @@ -78,9 +78,12 @@ instance (Sym_Ord r1, Sym_Ord r2) => Sym_Ord (DupI r1 r2) where min = dupI2 (Proxy @Sym_Ord) min max = dupI2 (Proxy @Sym_Ord) max -instance Const_from Text cs => Const_from Text (Proxy Ord ': cs) where - const_from "Ord" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Ord + ) => Read_TypeNameR Text cs (Proxy Ord ': rs) where + read_typenameR _cs "Ord" k = k (ty @Ord) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Ord ': cs) where show_const ConstZ{} = "Ord" show_const (ConstS c) = show_const c diff --git a/Language/Symantic/Compiling/Sequences.hs b/Language/Symantic/Compiling/Sequences.hs index 926ffd2..aeb6f1a 100644 --- a/Language/Symantic/Compiling/Sequences.hs +++ b/Language/Symantic/Compiling/Sequences.hs @@ -58,9 +58,12 @@ instance (Sym_SemiSequence r1, Sym_SemiSequence r2) => Sym_SemiSequence (DupI r1 snoc = dupI2 (Proxy @Sym_SemiSequence) snoc reverse = dupI1 (Proxy @Sym_SemiSequence) reverse -instance Const_from Text cs => Const_from Text (Proxy SemiSequence ': cs) where - const_from "SemiSequence" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs SemiSequence + ) => Read_TypeNameR Text cs (Proxy SemiSequence ': rs) where + read_typenameR _cs "SemiSequence" k = k (ty @SemiSequence) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy SemiSequence ': cs) where show_const ConstZ{} = "SemiSequence" show_const (ConstS c) = show_const c @@ -155,9 +158,12 @@ instance Sym_IsSequence TextI where instance (Sym_IsSequence r1, Sym_IsSequence r2) => Sym_IsSequence (DupI r1 r2) where filter = dupI2 (Proxy @Sym_IsSequence) filter -instance Const_from Text cs => Const_from Text (Proxy IsSequence ': cs) where - const_from "IsSequence" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs IsSequence + ) => Read_TypeNameR Text cs (Proxy IsSequence ': rs) where + read_typenameR _cs "IsSequence" k = k (ty @IsSequence) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy IsSequence ': cs) where show_const ConstZ{} = "IsSequence" show_const (ConstS c) = show_const c diff --git a/Language/Symantic/Compiling/Show.hs b/Language/Symantic/Compiling/Show.hs index 31e11ce..052b7ae 100644 --- a/Language/Symantic/Compiling/Show.hs +++ b/Language/Symantic/Compiling/Show.hs @@ -53,9 +53,12 @@ instance (Sym_Show r1, Sym_Show r2) => Sym_Show (DupI r1 r2) where show = dupI1 (Proxy @Sym_Show) show showList = dupI1 (Proxy @Sym_Show) showList -instance Const_from Text cs => Const_from Text (Proxy Show ': cs) where - const_from "Show" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Show + ) => Read_TypeNameR Text cs (Proxy Show ': rs) where + read_typenameR _cs "Show" k = k (ty @Show) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Show ': cs) where show_const ConstZ{} = "Show" show_const (ConstS c) = show_const c diff --git a/Language/Symantic/Compiling/Term.hs b/Language/Symantic/Compiling/Term.hs index b437175..e54e02f 100644 --- a/Language/Symantic/Compiling/Term.hs +++ b/Language/Symantic/Compiling/Term.hs @@ -375,14 +375,14 @@ class Sym_Lambda term where const a b = lam (lam . Fun.const) .$ a .$ b -- | /Lambda composition/. - (#) :: term (b -> c) -> term (a -> b) -> term (a -> c) - (#) f g = lam $ \a -> f .$ (g .$ a) + (^) :: term (b -> c) -> term (a -> b) -> term (a -> c) + (^) f g = lam $ \a -> f .$ (g .$ a) flip :: term (a -> b -> c) -> term (b -> a -> c) flip f = lam $ \b -> lam $ \a -> f .$ a .$ b infixl 0 .$ -infixr 9 # +infixr 9 ^ type instance Sym_of_Iface (Proxy (->)) = Sym_Lambda type instance Consts_of_Iface (Proxy (->)) = Proxy (->) ': Consts_imported_by (->) @@ -414,7 +414,7 @@ instance Sym_Lambda TextI where paren p p' $ "let" <> " " <> x <> " = " <> unTextI e (Precedence 0) (succ v) <> " in " <> unTextI (in_ (TextI $ \_p _v -> x)) p' (succ v) - (#) = textI_infix "." (Precedence 9) + (^) = textI_infix "." (Precedence 9) id = textI1 "id" const = textI2 "const" flip = textI1 "flip" @@ -423,9 +423,12 @@ instance (Sym_Lambda r1, Sym_Lambda r2) => Sym_Lambda (DupI r1 r2) where where lam_f = lam f (.$) = dupI2 (Proxy::Proxy Sym_Lambda) (.$) -instance Const_from Text cs => Const_from Text (Proxy (->) ': cs) where - const_from "(->)" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs (->) + ) => Read_TypeNameR Text cs (Proxy (->) ': rs) where + read_typenameR _cs "(->)" k = k (ty @(->)) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy (->) ': cs) where show_const ConstZ{} = "(->)" show_const (ConstS c) = show_const c @@ -460,7 +463,7 @@ deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy (->)) deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy (->))) instance -- CompileI (->) ( Inj_Const (Consts_of_Ifaces is) (->) - , Const_from Name_LamVar (Consts_of_Ifaces is) + , Read_TypeName Name_LamVar (Consts_of_Ifaces is) , Compile is ) => CompileI is (Proxy (->)) where compileI tok ctx k = diff --git a/Language/Symantic/Compiling/Text.hs b/Language/Symantic/Compiling/Text.hs index 51f17b5..c0348d8 100644 --- a/Language/Symantic/Compiling/Text.hs +++ b/Language/Symantic/Compiling/Text.hs @@ -37,9 +37,12 @@ instance Sym_Text TextI where instance (Sym_Text r1, Sym_Text r2) => Sym_Text (DupI r1 r2) where text x = text x `DupI` text x -instance Const_from Text cs => Const_from Text (Proxy Text ': cs) where - const_from "Text" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Text + ) => Read_TypeNameR Text cs (Proxy Text ': rs) where + read_typenameR _cs "Text" k = k (ty @Text) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Text ': cs) where show_const ConstZ{} = "Text" show_const (ConstS c) = show_const c diff --git a/Language/Symantic/Compiling/Traversable.hs b/Language/Symantic/Compiling/Traversable.hs index 04e957e..74985e2 100644 --- a/Language/Symantic/Compiling/Traversable.hs +++ b/Language/Symantic/Compiling/Traversable.hs @@ -36,9 +36,12 @@ instance Sym_Traversable TextI where instance (Sym_Traversable r1, Sym_Traversable r2) => Sym_Traversable (DupI r1 r2) where traverse = dupI2 (Proxy @Sym_Traversable) traverse -instance Const_from Text cs => Const_from Text (Proxy Traversable ': cs) where - const_from "Traversable" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Traversable + ) => Read_TypeNameR Text cs (Proxy Traversable ': rs) where + read_typenameR _cs "Traversable" k = k (ty @Traversable) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Traversable ': cs) where show_const ConstZ{} = "Traversable" show_const (ConstS c) = show_const c diff --git a/Language/Symantic/Compiling/Tuple2.hs b/Language/Symantic/Compiling/Tuple2.hs index 448788a..2a1c073 100644 --- a/Language/Symantic/Compiling/Tuple2.hs +++ b/Language/Symantic/Compiling/Tuple2.hs @@ -63,9 +63,12 @@ instance (Sym_Tuple2 r1, Sym_Tuple2 r2) => Sym_Tuple2 (DupI r1 r2) where fst = dupI1 (Proxy @Sym_Tuple2) fst snd = dupI1 (Proxy @Sym_Tuple2) snd -instance Const_from Text cs => Const_from Text (Proxy (,) ': cs) where - const_from "(,)" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs (,) + ) => Read_TypeNameR Text cs (Proxy (,) ': rs) where + read_typenameR _cs "(,)" k = k (ty @(,)) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy (,) ': cs) where show_const ConstZ{} = "(,)" show_const (ConstS c) = show_const c diff --git a/Language/Symantic/Compiling/Unit.hs b/Language/Symantic/Compiling/Unit.hs index 2f86542..1ee5f47 100644 --- a/Language/Symantic/Compiling/Unit.hs +++ b/Language/Symantic/Compiling/Unit.hs @@ -41,9 +41,12 @@ instance Sym_Unit TextI where instance (Sym_Unit r1, Sym_Unit r2) => Sym_Unit (DupI r1 r2) where unit = unit `DupI` unit -instance Const_from Text cs => Const_from Text (Proxy () ': cs) where - const_from "()" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs () + ) => Read_TypeNameR Text cs (Proxy () ': rs) where + read_typenameR _cs "()" k = k (ty @()) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy () ': cs) where show_const ConstZ{} = "()" show_const (ConstS c) = show_const c diff --git a/Language/Symantic/Parsing/EBNF.hs b/Language/Symantic/Parsing/EBNF.hs new file mode 100644 index 0000000..033d1c4 --- /dev/null +++ b/Language/Symantic/Parsing/EBNF.hs @@ -0,0 +1,15 @@ +module Parsing.EBNF where + +import Data.Text.IO as Text +import Control.Monad + +import Language.Symantic.Typing +import Language.Symantic.Parsing.Grammar +import Parsing.Grammar.Test +import Typing.Test + +main :: IO () +main = do + forM_ gram_lexer render + forM_ gram_type render + where render = Text.putStrLn . renderEBNF . unCF diff --git a/Language/Symantic/Parsing/Grammar.hs b/Language/Symantic/Parsing/Grammar.hs new file mode 100644 index 0000000..b1c23e9 --- /dev/null +++ b/Language/Symantic/Parsing/Grammar.hs @@ -0,0 +1,463 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} +-- | This module defines symantics +-- for regular or context-free grammars. +module Language.Symantic.Parsing.Grammar where + +import Control.Applicative (Applicative(..), Alternative(..)) +import Control.Monad +import Data.Char as Char +import Data.Foldable hiding (any) +import qualified Data.List as List +import Data.Semigroup hiding (option) +import Data.String (IsString(..)) +import Data.Text (Text) +import qualified Data.Text as Text +import Prelude hiding (any) + +-- * Class 'Gram_Rule' +type Id a = a -> a +class Gram_Rule p where + rule :: Text -> Id (p a) + rule _n = id + rule1 :: Text -> Id (p a -> p b) + rule1 _n p = p + rule2 :: Text -> Id (p a -> p b -> p c) + rule2 _n p = p + rule3 :: Text -> Id (p a -> p b -> p c -> p d) + rule3 _n p = p + rule4 :: Text -> Id (p a -> p b -> p c -> p d -> p e) + rule4 _n p = p + +-- * Type 'Term' +-- | Terminal grammar. +newtype Term p a + = Term { unTerm :: p a } + deriving (Functor, Gram_Term) + +-- ** Class 'Gram_Term' +-- | Symantics for terminal grammars. +class Gram_Term p where + any :: p Char + eof :: p () + char :: Char -> p Char + string :: String -> p String + unicat :: Unicat -> p Char + range :: (Char, Char) -> p Char + -- string = foldr (\c -> (<*>) ((:) <$> char c)) (pure "") + -- string [] = pure [] + -- string (c:cs) = (:) <$> char c <*> string cs + +-- *** Type 'Unicat' +-- | Unicode category. +data Unicat + = Unicat_Letter + | Unicat_Mark + | Unicat_Number + | Unicat_Punctuation + | Unicat_Symbol + | Unicat Char.GeneralCategory + deriving (Eq, Show) + +unicode_categories :: Unicat -> [Char.GeneralCategory] +unicode_categories c = + case c of + Unicat_Letter -> + [ UppercaseLetter + , LowercaseLetter + , TitlecaseLetter + , ModifierLetter + , OtherLetter + ] + Unicat_Mark -> + [ NonSpacingMark + , SpacingCombiningMark + , EnclosingMark + ] + Unicat_Number -> + [ DecimalNumber + , LetterNumber + , OtherNumber + ] + Unicat_Punctuation -> + [ ConnectorPunctuation + , DashPunctuation + , OpenPunctuation + , ClosePunctuation + , OtherPunctuation + ] + Unicat_Symbol -> + [ MathSymbol + , CurrencySymbol + , ModifierSymbol + , OtherSymbol + ] + Unicat cat -> [cat] + +-- * Type 'Reg' +-- | Left or right regular grammar. +newtype Reg (lr::LR) p a = Reg { unReg :: p a } + deriving (IsString, Functor, Gram_Term, Alter) +deriving instance Gram_Rule p => Gram_Rule (Reg lr p) +deriving instance (Functor p, Alter p, Gram_RegL p) => Gram_RegL (RegL p) +deriving instance (Functor p, Alter p, Gram_RegR p) => Gram_RegR (RegR p) + +-- ** Type 'LR' +data LR + = L -- ^ Left + | R -- ^ Right + deriving (Eq, Show) +type RegL = Reg 'L +type RegR = Reg 'R + +-- ** Class 'Alter' +-- | Like 'Alternative' but without the 'Applicative' super-class, +-- because a regular grammar is not closed under 'Applicative'. +class Alter p where + nil :: p a + (<+>) :: p a -> p a -> p a + choice :: [p a] -> p a + default nil :: Alternative p => p a + default (<+>) :: Alternative p => p a -> p a -> p a + default choice :: Alternative p => [p a] -> p a + nil = empty + (<+>) = (<|>) + choice = foldr (<+>) empty +infixl 3 <+> + +-- ** Class 'Gram_RegR' +-- | Symantics for right regular grammars. +class (Functor p, Alter p) => Gram_RegR p where + (.*>) :: Term p (a -> b) -> RegR p a -> RegR p b + manyR :: Term p a -> RegR p [a] + manyR p = (:) <$> p .*> manyR p <+> nil + someR :: Term p a -> RegR p [a] + someR p = (:) <$> p .*> manyR p +infixl 4 .*> + +-- ** Class 'Gram_RegL' +-- | Symantics for left regular grammars. +class (Functor p, Alter p) => Gram_RegL p where + (<*.) :: RegL p (a -> b) -> Term p a -> RegL p b + manyL :: Term p a -> RegL p [a] + manyL p' = reverse <$> go p' + where go p = flip (:) <$> go p <*. p <+> nil + someL :: Term p a -> RegL p [a] + someL p = (\cs c -> cs ++ [c]) <$> manyL p <*. p +infixl 4 <*. + +-- * Type 'CF' +-- | Context-free grammar. +newtype CF p a = CF { unCF :: p a } + deriving (IsString, Functor, Gram_Term, Applicative, App, Alternative, Alter, Alt) +deriving instance Gram_Rule p => Gram_Rule (CF p) +deriving instance Gram_CF p => Gram_CF (CF p) + +cf_of_reg :: Reg lr p a -> CF p a +cf_of_reg (Reg p) = CF p + +-- ** Class 'Gram_CF' +-- | Symantics for context-free grammars. +class Gram_CF p where + -- | NOTE: CFL ∩ RL is a CFL. + -- See ISBN 81-7808-347-7, Theorem 7.27, p.286 + (<&) :: CF p (a -> b) -> Reg lr p a -> CF p b + (&>) :: Reg lr p (a -> b) -> CF p a -> CF p b + -- | NOTE: CFL - RL is a CFL. + -- See ISBN 81-7808-347-7, Theorem 7.29, p.289 + but :: CF p a -> Reg lr p b -> CF p a +infixl 4 <& +infixl 4 &> + +-- ** Class 'App' +class Applicative p => App p where + between :: p open -> p close -> p a -> p a + between open close p = open *> p <* close + +-- ** Class 'Alt' +class Alternative p => Alt p where + option :: a -> p a -> p a + option x p = p <|> pure x + skipMany :: p a -> p () + skipMany = void . many + --manyTill :: p a -> p end -> p [a] + --manyTill p end = go where go = ([] <$ end) <|> ((:) <$> p <*> go) + +-- * Type 'EBNF' +-- | Extended Bachus-Norm Form, following the +-- +-- notations, augmented with the following notations: +-- +-- * @("U+", code_point)@: for (aka. Unicode). +-- * @(rule, "&", rule)@: for the intersection. +-- * @(rule, "-", rule)@: for the difference. +-- * @(rule, " ", rule)@: for rule application. +data EBNF a = EBNF { unEBNF :: RuleMode -> (Op, LR) -> Text } + +runEBNF :: EBNF a -> Text +runEBNF (EBNF p) = p RuleMode_Body (nop, L) + +-- | Get textual rendition of given EBNF rule. +renderEBNF :: RuleDef a -> Text +renderEBNF = runEBNF . unRuleDef + +ebnf_const :: Text -> EBNF a +ebnf_const t = EBNF $ \_rm _op -> t + +-- ** Type 'RuleDef' +newtype RuleDef a = RuleDef { unRuleDef :: EBNF a } + deriving (Functor, Gram_Term, Applicative, App + , Alternative, Alter, Alt, Gram_RegL, Gram_RegR, Gram_CF) +deriving instance Gram_RuleDef RuleDef +deriving instance Gram_RuleDef p => Gram_RuleDef (RegR p) +deriving instance Gram_RuleDef p => Gram_RuleDef (RegL p) +deriving instance Gram_RuleDef p => Gram_RuleDef (CF p) + +instance Gram_Rule RuleDef where + rule n = rule_def (ebnf_const n) + rule1 n p a = rule_def (ebnf_const n `ebnf_arg` unRuleDef a) (p a) + rule2 n p a b = rule_def (ebnf_const n `ebnf_arg` unRuleDef a `ebnf_arg` unRuleDef b) (p a b) + rule3 n p a b c = rule_def (ebnf_const n `ebnf_arg` unRuleDef a `ebnf_arg` unRuleDef b `ebnf_arg` unRuleDef c) (p a b c) + rule4 n p a b c d = rule_def (ebnf_const n `ebnf_arg` unRuleDef a `ebnf_arg` unRuleDef b `ebnf_arg` unRuleDef c `ebnf_arg` unRuleDef d) (p a b c d) + +-- *** Class 'Gram_RuleDef' +class Gram_RuleDef p where + rule_def :: EBNF () -> p a -> RuleDef a + rule_arg :: Text -> p a + +-- | Helper for 'Gram_Rule' 'EBNF'. +ebnf_arg :: EBNF a -> EBNF b -> EBNF () +ebnf_arg (EBNF a) (EBNF b) = EBNF $ \bo po -> op_paren po op $ + a bo (op, L) <> " " <> b bo (op, R) + where op = Op " " 11 AssocL +infixl 5 `ebnf_arg` + +instance Gram_RuleDef EBNF where + rule_arg = ebnf_const + rule_def call body = + RuleDef $ EBNF $ \mo po -> + case mo of + RuleMode_Ref -> unEBNF call mo po + RuleMode_Body -> + Text.intercalate " " $ concat $ + [ [unEBNF call RuleMode_Ref (nop, L)] + , ["="] + , [unEBNF body RuleMode_Ref (nop, R)] + , [";"] + ] +instance IsString (EBNF String) where + fromString = string +instance Show (EBNF a) where + show = Text.unpack . runEBNF +instance Gram_Rule EBNF where + rule n p = EBNF $ \rm po -> + case rm of + RuleMode_Body -> unEBNF p RuleMode_Ref po + RuleMode_Ref -> n + rule1 n p a = EBNF $ \rm po -> + case rm of + RuleMode_Body -> unEBNF (p a) RuleMode_Ref po + RuleMode_Ref -> unEBNF (ebnf_const n `ebnf_arg` a) RuleMode_Ref po + rule2 n p a b = EBNF $ \rm po -> + case rm of + RuleMode_Body -> unEBNF (p a b) RuleMode_Ref po + RuleMode_Ref -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b) RuleMode_Ref po + rule3 n p a b c = EBNF $ \rm po -> + case rm of + RuleMode_Body -> unEBNF (p a b c) RuleMode_Ref po + RuleMode_Ref -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b `ebnf_arg` c) RuleMode_Ref po + rule4 n p a b c d = EBNF $ \rm po -> + case rm of + RuleMode_Body -> unEBNF (p a b c d) RuleMode_Ref po + RuleMode_Ref -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b `ebnf_arg` c `ebnf_arg` d) RuleMode_Ref po +instance Functor EBNF where + fmap _f (EBNF x) = EBNF x +instance Applicative EBNF where + pure _ = empty + EBNF f <*> EBNF x = EBNF $ \bo po -> op_paren po op $ + f bo (op, L) <> ", " <> x bo (op, R) + where op = Op "," 10 AssocB +instance App EBNF +instance Alternative EBNF where + empty = ebnf_const $ "\"\"" + EBNF x <|> EBNF y = EBNF $ \bo po -> op_paren po op $ + x bo (op, L) <> " | " <> y bo (op, R) + where op = Op "|" 2 AssocB + many (EBNF x) = EBNF $ \rm _po -> "{ " <> x rm (op, L) <> " }" where op = nop + some (EBNF x) = EBNF $ \rm _po -> "{ " <> x rm (op, L) <> " }-" where op = nop +instance Alter EBNF where + choice [] = empty + choice [p] = p + choice l@(_:_) = EBNF $ \bo po -> op_paren po op $ + Text.intercalate " | " $ + (unEBNF <$> l) <*> pure bo <*> pure (op, L) + where op = Op "|" 2 AssocB +instance Alt EBNF +instance Gram_Term EBNF where + any = ebnf_const "_" + eof = ebnf_const "EOF" + char = ebnf_const . escape + where + escape c | Char.isPrint c && c /= '"' = Text.concat $ ["\"", Text.singleton c, "\""] + escape c = Text.concat ["U+", Text.pack $ show $ ord c] + string s = + case List.break (\c -> not (Char.isPrint c) || c == '"') s of + (ps, "") -> raw ps + ("", [c]) -> "" <$ char c + (ps, [c]) -> "" <$ raw ps <* char c + ("", c:rs) -> "" <$ char c <* string rs + (ps, c:rs) -> "" <$ raw ps <* char c <* string rs + where + raw cs = ebnf_const $ Text.concat $ ["\"", Text.pack cs, "\""] + unicat = ebnf_const . Text.pack . show + range (l, h) = ebnf_const $ Text.concat + [ runEBNF $ char l + , "…" + , runEBNF $ char h + ] +instance Gram_RegR EBNF where + Term f .*> Reg x = Reg $ f <*> x + manyR = Reg . many . unTerm + someR = Reg . some . unTerm +instance Gram_RegL EBNF where + Reg f <*. Term x = Reg $ f <*> x + manyL = Reg . many . unTerm + someL = Reg . some . unTerm +instance Gram_CF EBNF where + CF (EBNF f) <& Reg (EBNF p) = CF $ EBNF $ \bo po -> op_paren po op $ + f bo (op, L) <> " & " <> p bo (op, R) + where op = Op "&" 4 AssocL + Reg (EBNF f) &> CF (EBNF p) = CF $ EBNF $ \bo po -> op_paren po op $ + f bo (op, L) <> " & " <> p bo (op, R) + where op = Op "&" 4 AssocL + CF (EBNF f) `but` Reg (EBNF p) = CF $ EBNF $ \bo po -> op_paren po op $ + f bo (op, L) <> " - " <> p bo (op, R) + where op = Op "-" 6 AssocL + +-- ** Type 'RuleMode' +data RuleMode + = RuleMode_Body -- ^ Generate the body of the rule. + | RuleMode_Ref -- ^ Generate a ref to the rule. + deriving (Eq, Show) + +-- ** Type 'Op' +data Op = Op + { op_ident :: Text + , op_prece :: Precedence + , op_assoc :: Associativity + } deriving (Eq, Show) + +nop :: Op +nop = Op "" 0 AssocN + +-- *** Type 'Precedence' +type Precedence = Int + +-- *** Type 'Associativity' +data Associativity + = AssocL | AssocR | AssocN | AssocB + deriving (Eq, Show) + +op_paren + :: (Semigroup s, IsString s) + => (Op, LR) -> Op -> s -> s +op_paren (po, lr) op s = + if op_prece op <= op_prece po && not associate + then fromString "(" <> s <> fromString ")" + else s + where + associate = + op_ident po == op_ident op && + case (lr, op_assoc po) of + (_, AssocB) -> True + (L, AssocL) -> True + (R, AssocR) -> True + _ -> False + +-- * Class 'Gram_Context' +-- | A monadic backdoor, but limited by 'Context'. +-- In 'CF', the context must obviously not be used to change the parser, +-- but it can be used to change the parsed value, +-- for instance by recording source positions into it. +class Gram_Context p where + type Context p + type Context p = () + default context :: (Context p ~ ()) => (Context p -> p a) -> p a + context :: (Context p -> p a) -> p a + context f = f () +instance Gram_Context p => Gram_Context (CF p) where + type Context (CF p) = Context p + context f = CF $ context (unCF . f) +instance Gram_Context EBNF +instance Gram_Context RuleDef + +-- * Class 'Gram_Lexer' +class + ( Alt p + , Alter p + , Alternative p + , App p + , Gram_CF p + , Gram_Rule p + , Gram_Term p + ) => Gram_Lexer p where + commentable :: p () -> p () -> p () -> p () + commentable = rule3 "commentable" $ \p line block -> + skipMany $ choice [p, line, block] + comment_line :: CF p String -> CF p String + comment_line prefix = rule "comment_line" $ + prefix *> many (any `but` (void (char '\n') <+> eof)) + comment_block :: CF p String -> Reg lr p String -> CF p String + comment_block start end = rule "comment_block" $ + start *> many (any `but` void end) + lexeme :: CF p a -> CF p a + lexeme = rule1 "lexeme" $ \p -> p + <* commentable + (void $ char ' ') + (void $ comment_line (string "--")) + (void $ comment_block (string "{-") (string "-}")) + parens :: CF p a -> CF p a + parens = rule1 "parens" $ + between + (lexeme $ string "(") + (lexeme $ string ")") + infixrP :: (a -> a -> a) -> CF p a -> CF p sep -> CF p a -> CF p a + infixrP f = + rule3 "infixrP" $ \next sep root -> + (\a -> \case Just b -> f a b; Nothing -> a) + <$> next <*> option Nothing (Just <$ sep <*> root) + inside :: (a -> b) -> CF p begin -> CF p a -> CF p end -> CF p b -> CF p b + inside f = rule4 "inside" $ \begin i end n -> + (f <$ begin <*> i <* end) <+> n + symbol :: String -> CF p String + symbol = lexeme . string + +deriving instance Gram_Lexer p => Gram_Lexer (CF p) +instance Gram_Lexer EBNF +instance Gram_Lexer RuleDef + +gram_lexer :: forall p . (Gram_Lexer p, Gram_RuleDef p) => [CF p ()] +gram_lexer = + [ () <$ commentable (void $ rule_arg "space") (void $ rule_arg "line") (void $ rule_arg "block") + , () <$ comment_line (rule_arg "prefix") + , () <$ comment_block (rule_arg "start") (rule_arg "end" :: Reg 'L p String) + , () <$ lexeme (rule_arg "p") + , () <$ parens (rule_arg "p") + , () <$ inside id (rule_arg "begin") (rule_arg "i") (rule_arg "end") (rule_arg "next") + , () <$ infixrP const (rule_arg "next") (rule_arg "sep") (rule_arg "root") + ] diff --git a/Language/Symantic/Parsing/Grammar/Test.hs b/Language/Symantic/Parsing/Grammar/Test.hs new file mode 100644 index 0000000..e5b7d23 --- /dev/null +++ b/Language/Symantic/Parsing/Grammar/Test.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | This module defines symantics +-- for regular or context-free grammars. +-- It is intended to be imported qualified. +module Parsing.Grammar.Test where + +import Control.Applicative (Applicative(..), Alternative(..)) +import Data.Maybe +import Control.Monad +-- import Control.Comonad +import qualified Data.Char as Char +import Data.Foldable hiding (any) +import Data.Functor.Identity +import qualified Data.List as List +import Data.Semigroup ((<>)) +import Data.Proxy +import Data.Text (Text) +import Data.String (IsString(..)) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Prelude hiding (any, (^)) +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Lexer as L + +import qualified Language.Symantic.Compiling as Sym +import qualified Language.Symantic.Typing as Sym +import qualified Language.Symantic.Parsing as Sym +import Language.Symantic.Parsing.Grammar + +-- * Type 'ParsecT' +type ParsecC e s = (P.Token s ~ Char, P.Stream s, P.ErrorComponent e) +instance ParsecC e s => IsString (P.ParsecT e s m [Char]) where + fromString = P.string +instance ParsecC e s => Gram_Rule (P.ParsecT e s m) where + rule = P.label . Text.unpack +instance ParsecC e s => Gram_Term (P.ParsecT e s m) where + any = P.anyChar + eof = P.eof + char = P.char + string = P.string + unicat cat = P.satisfy $ (`List.elem` cats) . Char.generalCategory + where cats = unicode_categories cat + range (l, h) = P.satisfy $ \c -> l <= c && c <= h +instance ParsecC e s => Alter (P.ParsecT e s m) where + x <+> y = P.try x <|> y +instance ParsecC e s => Gram_RegR (P.ParsecT e s m) where + Term f .*> Reg x = Reg $ f <*> x +instance ParsecC e s => Gram_RegL (P.ParsecT e s m) where + Reg f <*. Term x = Reg $ f <*> x +instance ParsecC e s => App (P.ParsecT e s m) +instance ParsecC e s => Alt (P.ParsecT e s m) +instance ParsecC e s => Gram_CF (P.ParsecT e s m) where + CF f <& Reg p = CF $ P.lookAhead f <*> p + Reg f &> CF p = CF $ P.lookAhead f <*> p + but (CF f) (Reg p) = CF $ P.notFollowedBy (P.try p) *> f +instance ParsecC e s => Gram_Context (P.ParsecT e s m) where + type Context (P.ParsecT e s m) = P.SourcePos + context = (P.getPosition >>=) +instance ParsecC e s => Gram_Lexer (P.ParsecT e s m) +instance ParsecC e s => Sym.Gram_Type (P.ParsecT e s m) + +runParserT :: Monad m + => P.ParsecT P.Dec s m a -> s + -> m (Either (P.ParseError (P.Token s) P.Dec) a) +runParserT p = P.runParserT p "" + +runParser + :: P.ParsecT P.Dec s Identity a -> s + -> Either (P.ParseError (P.Token s) P.Dec) a +runParser p = P.runParser p "" + + + +{- +-- Tests +g1 = (<>) <$> string "0" <*> string "1" +g2 = (<>) <$> string "0" <* string "X" <*> string "1" +g3 = (<>) <$> (string "0" <|> string "1") <*> string "2" +g4 = string "0" <|> string "1" <|> string "2" +g5 = choice [string "0", string "1", string "2"] +g6 = (<>) <$> choice [(<>) <$> string "0" <*> string "1", string "2" <|> string "3", string "4"] <*> string "5" +g7 = concat <$> many (string "0") +g8 = (concat <$>) $ (<>) <$> many (string "0" <|> string "1") <*> some (string "2") +g9 = (<>) <$> string "0" .*> someR (char '1') +g10 = (<>) <$> someL (char '1') <*. string "0" +g11 = string "0" `but` g9 `but` g10 +g12 = (<>) <$> string "0" <& g9 +g13 = string "abé\"to" +g14 = string "\"" +g15 = string "" +g16 = many $ unicat [Unicat_Letter] +g17 = many $ range ('a', 'z') +g18 = ("" <$) $ commentable (void g1) (void g2) (void g3) +g19 = ("" <$) $ choice [g5] +g20 = "" <$ char 'a' <* char 'b' <* char 'c' +g21 = "" <$ comment_line "--" +g22 = "" <$ lexeme (string "A") +g23 = "" <$ keywords + +main :: IO () +main = do + putStrLn "EBNF" + {- + forM_ + [ g1, g2, g3, g4, g5, g6, g7, g8 + , g11, g12, g13, g14, g15, g16, g17, g18 + , g19, g20, g21, g22, cf_of_reg g23 + ] $ \g -> do + Text.putStrLn $ runEBNF RuleMode_Def $ unCF g + -} + forM_ + [ "" <$ comment_line (rule_arg "prefix") + , "" <$ comment_block (rule_arg "start") (rule_arg "end" :: Reg 'L RuleDef String) + , "" <$ commentable (void $ rule_arg "space") (void $ rule_arg "line") (void $ rule_arg "block") + , "" <$ lexeme (rule_arg "p") + , "" <$ parens (rule_arg "p") + , "" <$ inside id (rule_arg "begin") (rule_arg "i") (rule_arg "end") (rule_arg "next") + , "" <$ infixrP const (rule_arg "next") (rule_arg "sep") (rule_arg "root") + {- + , "" <$ typeP + , "" <$ type_list + , "" <$ type_tuple2 + , "" <$ type_fun + , "" <$ type_app + , "" <$ type_atom + , "" <$ type_name + -} + ] $ \g -> do + Text.putStrLn $ runEBNF $ unRuleDef $ unCF g + putStrLn "" + {- + putStrLn "Tests" + forM_ + [ "Bool" + , "(Bool)" + , "((Bool))" + , "Bool, Int" + , "(Bool, Int)" + , "((Bool, Int), Char)" + , "(Bool, Int) -> Char" + , "(Bool -> Int)" + , "((Bool, Int), Char)" + , "String" + , "[Char]" + , "[Char] -> String" + , "String -> [Char]" + , "Maybe Bool" + , "Either Bool Int" + , "Bool -> Int" + , "(Bool -> Int) -> Char" + , "(Bool -> Int) Char" + , "Bool -> (Int -> Char)" + , "Bool -> Int -> Char" + ] $ \s -> do + putStr (show (s::Text)) + Text.putStr " ==> " + print $ (compile_type <$>) $ runIdentity $ runParser (unCF (typeP <* eof)) s + -} + +-} diff --git a/Language/Symantic/Parsing/Test.hs b/Language/Symantic/Parsing/Test.hs index e72766a..f7fcedb 100644 --- a/Language/Symantic/Parsing/Test.hs +++ b/Language/Symantic/Parsing/Test.hs @@ -1,8 +1,9 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} diff --git a/Language/Symantic/Typing/Constant.hs b/Language/Symantic/Typing/Constant.hs index c250aef..3ab34eb 100644 --- a/Language/Symantic/Typing/Constant.hs +++ b/Language/Symantic/Typing/Constant.hs @@ -100,30 +100,6 @@ type family Proj_ConstsR cs cs_to_proj :: [Constraint] where Proj_ConstsR cs '[] = '[] Proj_ConstsR cs (Proxy x ': xs) = Proj_Const cs x ': Proj_ConstsR cs xs --- * Class 'Const_from' --- | Try to build a 'Const' from raw data. -class Const_from raw cs where - const_from - :: raw -> (forall k c. Const cs (c::k) -> Maybe ret) - -> Maybe ret - -instance Const_from raw '[] where - const_from _c _k = Nothing - --- TODO: move each of these to a dedicated module. -instance Const_from Text cs => Const_from Text (Proxy Bounded ': cs) where - const_from "Bounded" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS -instance Const_from Text cs => Const_from Text (Proxy Enum ': cs) where - const_from "Enum" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS -instance Const_from Text cs => Const_from Text (Proxy Fractional ': cs) where - const_from "Fractional" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS -instance Const_from Text cs => Const_from Text (Proxy Real ': cs) where - const_from "Real" 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 diff --git a/Language/Symantic/Typing/Test.hs b/Language/Symantic/Typing/Test.hs index c6e2ebf..51c33fe 100644 --- a/Language/Symantic/Typing/Test.hs +++ b/Language/Symantic/Typing/Test.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeInType #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Typing.Test where @@ -5,73 +9,103 @@ module Typing.Test where import Test.Tasty import Test.Tasty.HUnit +import Control.Applicative (Applicative(..), Alternative(..)) +import Control.Arrow (left) +import qualified Data.Char as Char +import Data.Functor.Identity import Data.Maybe (isJust) import Data.Proxy +import Data.Semigroup ((<>)) import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text import GHC.Exts (Constraint) +import Prelude hiding (exp) +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Lexer as L +import Language.Symantic.Lib.Data.Type.List import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling +import Language.Symantic.Compiling ((~>)) import Parsing.Test +import Parsing.Grammar.Test -- * Tests +type Tys = Constants ++ '[Proxy String] + tests :: TestTree tests = testGroup "Typing" $ [ testGroup "compile_type" $ - let (==>) (syn::Syntax Text) expected = - let Right (tok::EToken (Syntax Text) '[Proxy Token_Type]) = tokenize_type syn in - testCase (Prelude.show syn) $ - (@?= EType Prelude.<$> expected) $ - (compile_type tok (Right . EType) - :: Either (Error_Type (Syntax Text) '[Proxy Token_Type]) - (EType Constants)) - in - [ sy @Bool ==> Right (ty @Bool) - , sy @IO [] ==> Right (ty @IO) - , sy @Eq [] ==> Right (ty @Eq) - , sy @(->) [sy @Bool] ==> Right (ty @(->) :$ ty @Bool) - , sy @Eq [sy @Bool] ==> Right (ty @Eq :$ ty @Bool) - , sy @Monad [sy @IO []] ==> Right (ty @Monad :$ ty @IO) - , sy @(->) [sy @IO [sy @Bool]] ==> Right (ty @(->) :$ (ty @IO :$ ty @Bool)) - , (sy @Bool .> sy @Bool) ==> Right - (ty @Bool ~> ty @Bool) - , ((sy @Bool .> sy @Bool) .> sy @Bool) ==> Right - ((ty @Bool ~> ty @Bool) ~> ty @Bool) - , ((sy @Bool .> sy @Int) .> sy @Bool) ==> Right - ((ty @Bool ~> ty @Int) ~> ty @Bool) - , (sy @Bool .> sy @Int .> sy @Bool) ==> Right - (ty @Bool ~> ty @Int ~> ty @Bool) - , ((sy @Bool .> (sy @Bool .> sy @Int)) .> sy @Bool) ==> Right - ((ty @Bool ~> (ty @Bool ~> ty @Int)) ~> ty @Bool) - , testGroup "Error_Type" - [ sy @(->) [sy @IO []] ==> Left - (Error_Type_Constraint_Kind $ Constraint_Kind_Eq - (At (maybeRight $ tokenize_type $ sy @(->) [sy @IO []]) $ EKind SKiType) - (At (maybeRight $ tokenize_type $ sy @IO []) $ EKind $ SKiType `SKiArrow` SKiType)) - , sy @IO [sy @Eq [sy @Bool]] ==> Left - (Error_Type_Constraint_Kind $ Constraint_Kind_Eq - (At (maybeRight $ tokenize_type $ sy @IO [sy @Eq [sy @Bool]]) $ EKind SKiType) - (At (maybeRight $ tokenize_type $ sy @Eq [sy @Bool]) $ EKind $ SKiConstraint)) - , Syntax "Bool" [sy @Bool] ==> Left - (Error_Type_Constraint_Kind $ Constraint_Kind_Arrow - (At (maybeRight $ tokenize_type $ Syntax "Bool" [sy @Bool]) $ EKind SKiType)) - , Syntax ("Unknown"::Text) [] ==> Left - (Error_Type_Constant_unknown $ - At (maybeRight $ tokenize_type $ Syntax ("Unknown"::Text) []) "Unknown") - ] + let (==>) inp exp = testCase inp $ got @?= Right (Right (exp::EType Tys)) + where got = (compile_etype <$>) $ (`runParser` inp) $ unCF $ typeP <* eof in + uncurry (==>) <$> + [ ("Bool", EType $ ty @Bool) + , ("[]", EType $ ty @[]) + , ("[Char]", EType $ ty @[] :$ ty @Char) + , ("([])", EType $ ty @[]) + , ("[()]", EType $ ty @[] :$ ty @()) + , ("()", EType $ ty @()) + , ("(())", EType $ ty @()) + , ("(,)", EType $ ty @(,)) + , ("((,))", EType $ ty @(,)) + , ("(,) Int", EType $ ty @(,) :$ ty @Int) + , ("(Bool)", EType $ ty @Bool) + , ("((Bool))", EType $ ty @Bool) + , ("(Bool, Int)", EType $ ty @(,) :$ ty @Bool :$ ty @Int) + , ("((Bool, Int))", EType $ ty @(,) :$ ty @Bool :$ ty @Int) + , ("((Bool, Int), Char)", EType $ ty @(,) :$ (ty @(,) :$ ty @Bool :$ ty @Int) :$ ty @Char) + , ("(Bool, Int) -> Char", EType $ (ty @(,) :$ ty @Bool :$ ty @Int) ~> ty @Char) + , ("(Bool -> Int)", EType $ ty @Bool ~> ty @Int) + , ("String", EType $ ty @[] :$ ty @Char) + , ("[Char] -> String", EType $ (ty @[] :$ ty @Char) ~> (ty @[] :$ ty @Char)) + , ("String -> [Char]", EType $ (ty @[] :$ ty @Char) ~> (ty @[] :$ ty @Char)) + , ("Maybe Bool", EType $ ty @Maybe :$ ty @Bool) + , ("Either Bool Int", EType $ ty @Either :$ ty @Bool :$ ty @Int) + , ("Bool -> Int", EType $ ty @Bool ~> ty @Int) + , ("(Bool -> Int) -> Char", EType $ (ty @Bool ~> ty @Int) ~> ty @Char) + , ("Bool -> (Int -> Char)", EType $ ty @Bool ~> (ty @Int ~> ty @Char)) + , ("Bool -> Int -> Char", EType $ ty @Bool ~> ty @Int ~> ty @Char) + , ("Bool -> (Int -> Char) -> ()", EType $ ty @Bool ~> (ty @Int ~> ty @Char) ~> ty @()) + , ("IO", EType $ ty @IO) + , ("Eq", EType $ ty @Eq) + , ("Eq Bool", EType $ ty @Eq :$ ty @Bool) + , ("Traversable IO", EType $ ty @Traversable :$ ty @IO) + , ("Monad IO", EType $ ty @Monad :$ ty @IO) + , ("(->) Bool", EType $ ty @(->) :$ ty @Bool) + , ("(->) (IO Bool)", EType $ ty @(->) :$ (ty @IO :$ ty @Bool)) + , ("Monad IO", EType $ ty @Monad :$ ty @IO) ] + , testGroup "Parsing errors" $ + let (==>) inp _exp = testCase inp $ got @?= Left () + where got = left (const ()) $ (`runParser` inp) $ unCF $ typeP <* eof in + uncurry (==>) <$> + [ ("Bool, Int", ()) + , ("(Bool -> Int) Char", ()) + ] + , testGroup "Compiling errors" $ + let (==>) inp _exp = testCase inp $ got @?= Right (Left () :: Either () (EType Tys)) + where got = (left (const ()) . compile_etype <$>) $ + (`runParser` inp) $ unCF $ typeP <* eof in + uncurry (==>) <$> + [ ("NonExistingType", ()) + , ("Bool Int", ()) + , ("[IO]", ()) + , ("(->) IO", ()) + , ("(->) Bool Int Char", ()) + , ("Monad Eq", ()) + ] , testGroup "proj_con" $ let (==>) (typ::Type Constants (h::Constraint)) expected = testCase (show_type typ) $ - isJust (proj_con typ) @?= expected - in - [ (ty @Eq :$ ty @Bool) ==> True - , (ty @Ord :$ ty @Bool) ==> True - , (ty @Functor :$ ty @Maybe) ==> True - , (ty @Functor :$ ty @IO) ==> True - , (ty @Monad :$ ty @IO) ==> True - , (ty @Traversable :$ ty @IO) ==> False + isJust (proj_con typ) @?= expected in + [ ty @Eq :$ ty @Bool ==> True + , ty @Ord :$ ty @Bool ==> True + , ty @Functor :$ ty @Maybe ==> True + , ty @Functor :$ ty @IO ==> True + , ty @Monad :$ ty @IO ==> True + , ty @Traversable :$ ty @IO ==> False ] ] diff --git a/Language/Symantic/Typing/Type.hs b/Language/Symantic/Typing/Type.hs index 6f4aeee..9a21a8b 100644 --- a/Language/Symantic/Typing/Type.hs +++ b/Language/Symantic/Typing/Type.hs @@ -1,20 +1,26 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Symantic.Typing.Type where +import Control.Applicative (Applicative(..), Alternative(..)) +import qualified Data.Char as Char import Data.Monoid ((<>)) import Data.Proxy import Data.Maybe (fromMaybe, isJust) import Data.Text (Text) +import qualified Data.Text as Text import Data.Type.Equality import qualified Data.Kind as K import Language.Symantic.Typing.Kind import Language.Symantic.Typing.Constant -import Language.Symantic.Parsing.Token +import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar -- * Type 'Type' @@ -80,12 +86,17 @@ eq_kind_type _x _y = Nothing show_type :: Show_Const cs => Type cs 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 (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 (TyVar v) = "t" <> show (integral_from_peano v::Integer) +-- | Cons a @new_c@ to @cs@. +type_lift :: Type cs c -> Type (new_c ': cs) c +type_lift (TyConst c) = TyConst (ConstS c) +type_lift (f :$ a) = type_lift f :$ type_lift a + -- * Type 'EType' -- | Existential for 'Type'. data EType cs = forall h. EType (Type cs h) @@ -115,15 +126,18 @@ data instance TokenT meta ts (Proxy Token_Type) deriving instance Eq_Token meta ts => Eq (TokenT meta ts (Proxy Token_Type)) deriving instance Show_Token meta ts => Show (TokenT meta ts (Proxy Token_Type)) -instance Const_from Text cs => Const_from Text (Proxy Token_Type ': cs) where - const_from "Type" k = k (ConstZ kind) - const_from s k = const_from s $ k . ConstS +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Token_Type + ) => Read_TypeNameR Text cs (Proxy Token_Type ': rs) where + read_typenameR _rs "Type" k = k (ty @Token_Type) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Token_Type ': cs) where show_const ConstZ{} = "Type" show_const (ConstS c) = show_const c -- * Class 'Compile_Type' --- | Try to build a 'Type' from raw data. +-- | Try to build a 'Type' from name data. class Compile_Type ts cs where compile_type :: ( MonoLift (Error_Type meta ts) err @@ -132,6 +146,12 @@ class Compile_Type ts cs where -> (forall k h. Type cs (h::k) -> Either err ret) -> Either err ret +compile_etype + :: Read_TypeName Text cs + => EToken meta '[Proxy Token_Type] + -> Either (Error_Type meta '[Proxy Token_Type]) (EType cs) +compile_etype tok = compile_type tok (Right . EType) + -- ** Type 'Constraint_Kind' data Constraint_Kind meta ts = Constraint_Kind_Eq (At meta ts EKind) (At meta ts EKind) @@ -169,8 +189,60 @@ data Error_Type meta ts deriving instance (Eq_TokenR meta ts ts) => Eq (Error_Type meta ts) deriving instance (Show_TokenR meta ts ts) => Show (Error_Type meta ts) +-- * Class 'Read_TypeName' +type Read_TypeName raw cs = Read_TypeNameR raw cs cs + +read_typename + :: forall raw cs ret. + Read_TypeNameR raw cs cs + => raw -> (forall k c. Type cs (c::k) -> Maybe ret) + -> Maybe ret +read_typename = read_typenameR (Proxy @cs) + +-- ** Class 'Read_TypeNameR' +class Read_TypeNameR raw cs rs where + read_typenameR + :: Proxy rs -> raw -> (forall k c. Type cs (c::k) -> Maybe ret) + -> Maybe ret + +instance Read_TypeNameR raw cs '[] where + read_typenameR _cs _c _k = Nothing + +-- TODO: move each of these to a dedicated module. +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Bounded + ) => Read_TypeNameR Text cs (Proxy Bounded ': rs) where + read_typenameR _cs "Bounded" k = k (ty @Bounded) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Enum + ) => Read_TypeNameR Text cs (Proxy Enum ': rs) where + read_typenameR _cs "Enum" k = k (ty @Enum) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Fractional + ) => Read_TypeNameR Text cs (Proxy Fractional ': rs) where + read_typenameR _cs "Fractional" k = k (ty @Fractional) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs Real + ) => Read_TypeNameR Text cs (Proxy Real ': rs) where + read_typenameR _cs "Real" k = k (ty @Real) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k +instance + ( Read_TypeNameR Text cs rs + , Inj_Const cs [] + , Inj_Const cs Char + ) => Read_TypeNameR Text cs (Proxy String ': rs) where + read_typenameR _cs "String" k = k (ty @[] :$ ty @Char) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k + instance - ( Const_from Text cs + ( Read_TypeName Text cs , Proj_Token ts Token_Type ) => Compile_Type ts cs where compile_type @@ -182,8 +254,8 @@ instance -> Either err ret compile_type tok@(proj_etoken -> Just (Token_Type cst args)) kk = fromMaybe (Left $ olift $ Error_Type_Constant_unknown $ At (Just tok) cst) $ - const_from cst $ \c -> Just $ - go args (TyConst c) kk + read_typename cst $ \typ -> Just $ + go args typ kk where go :: [EToken meta ts] -> Type cs h @@ -233,3 +305,77 @@ instance MonoLift instance MonoLift (Constraint_Kind meta ts) (Error_Type meta ts) where olift = olift . Error_Type_Constraint_Kind + +-- * Class 'Gram_Type' +type ToType p = EToken (Context p) '[Proxy Token_Type] +class + ( Alt p + , Alter p + , Alternative p + , App p + , Gram_CF p + , Gram_Rule p + , Gram_Term p + , Gram_Lexer p + , Gram_Context p + ) => Gram_Type p where + typeP :: CF p (ToType p) + typeP = rule "type" $ type_fun + type_fun :: CF p (ToType p) + type_fun = rule "type_fun" $ + context $ \meta -> + let f a b = inj_etoken meta $ Token_Type "(->)" [a, b] in + infixrP f type_list (symbol "->") typeP + type_list :: CF p (ToType p) + type_list = rule "type_list" $ + context $ \meta -> + let f = inj_etoken meta . Token_Type "[]" in + inside f (symbol "[") (option [] (pure <$> typeP)) (symbol "]") type_tuple2 + type_tuple2 :: CF p (ToType p) + type_tuple2 = rule "type_tuple2" $ + context $ \meta -> + let f a b = inj_etoken meta $ Token_Type "(,)" [a, b] in + parens (infixrP f typeP (symbol ",") typeP) <+> type_app + type_app :: CF p (ToType p) + type_app = rule "type_app" $ + (\(EToken (TokenZ meta (Token_Type f as)):as') -> + (EToken (TokenZ meta (Token_Type f (as <> as'))))) + <$> some type_atom + type_atom :: CF p (ToType p) + type_atom = rule "type_atom" $ + parens typeP <+> + type_name <+> + type_symbol + type_name :: CF p (ToType p) + type_name = rule "type_name" $ + context $ \meta -> + lexeme $ + (\c cs -> EToken $ TokenZ meta $ Token_Type (Text.pack $ c:cs) []) + <$> unicat (Unicat Char.UppercaseLetter) + <*> many (choice $ unicat <$> [Unicat_Letter, Unicat_Number]) + type_symbol :: CF p (ToType p) + type_symbol = rule "type_symbol" $ + context $ \meta -> + let f s = inj_etoken meta $ (`Token_Type` []) $ + Text.concat ["(", Text.pack s, ")"] in + (f <$>) $ parens $ many $ choice (unicat <$> + [ Unicat_Symbol + , Unicat_Punctuation + , Unicat_Mark + ]) `but` char ')' + +deriving instance Gram_Type p => Gram_Type (CF p) +instance Gram_Type EBNF +instance Gram_Type RuleDef + +gram_type :: Gram_Type p => [CF p (ToType p)] +gram_type = + [ typeP + , type_fun + , type_list + , type_tuple2 + , type_app + , type_atom + , type_name + , type_symbol + ] diff --git a/symantic.cabal b/symantic.cabal index 8e82922..21d82c4 100644 --- a/symantic.cabal +++ b/symantic.cabal @@ -172,6 +172,7 @@ Library Language.Symantic.Lib.Data.Type.Peano Language.Symantic.Parsing Language.Symantic.Parsing.Token + Language.Symantic.Parsing.Grammar Language.Symantic.Transforming Language.Symantic.Transforming.Trans Language.Symantic.Typing @@ -202,7 +203,7 @@ Test-Suite symantic-test TypeFamilies TypeOperators default-language: Haskell2010 - ghc-options: -Wall -fno-warn-tabs + ghc-options: -Wall -fno-warn-tabs -O0 -main-is Test -- -fprint-explicit-kinds hs-source-dirs: Language/Symantic @@ -216,14 +217,51 @@ Test-Suite symantic-test Compiling.MonoFunctor.Test Compiling.Term.Test Compiling.Test + Parsing.Grammar.Test Parsing.Test Typing.Test build-depends: base >= 4.6 && < 5 , containers + , megaparsec , mono-traversable , transformers , tasty >= 0.11 , tasty-hunit , text , symantic + +Test-Suite ebnf + type: exitcode-stdio-1.0 + default-extensions: + ConstraintKinds + DataKinds + EmptyDataDecls + FlexibleContexts + FlexibleInstances + MultiParamTypeClasses + NamedFieldPuns + OverloadedStrings + PatternGuards + PolyKinds + Rank2Types + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeApplications + TypeOperators + ghc-options: -Wall -fno-warn-tabs + -main-is Parsing.EBNF + main-is: Parsing/EBNF.hs + default-language: Haskell2010 + hs-source-dirs: Language/Symantic + build-depends: + base >= 4.6 && < 5 + , containers + , megaparsec + , transformers + , tasty >= 0.11 + , tasty-hunit + , text + , symantic -- 2.47.2 From 24d41b942ccb6b87f61d479a803015e58ad9e769 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Mon, 23 Jan 2017 14:31:20 +0100 Subject: [PATCH 06/16] Add Gram_Term. --- Language/Symantic/Compiling.hs | 2 + Language/Symantic/Compiling/Alternative.hs | 29 +- Language/Symantic/Compiling/Applicative.hs | 42 +- .../Symantic/Compiling/Applicative/Test.hs | 61 +- Language/Symantic/Compiling/Bool.hs | 53 +- Language/Symantic/Compiling/Bool/Test.hs | 135 ++-- Language/Symantic/Compiling/Char.hs | 50 +- Language/Symantic/Compiling/Either.hs | 48 +- Language/Symantic/Compiling/Eq.hs | 23 +- Language/Symantic/Compiling/Foldable.hs | 31 +- Language/Symantic/Compiling/Foldable/Test.hs | 53 +- Language/Symantic/Compiling/Functor.hs | 28 +- Language/Symantic/Compiling/Functor/Test.hs | 53 +- Language/Symantic/Compiling/IO.hs | 51 +- Language/Symantic/Compiling/If.hs | 23 +- Language/Symantic/Compiling/Int.hs | 27 +- Language/Symantic/Compiling/Integer.hs | 43 +- Language/Symantic/Compiling/Integral.hs | 82 +- Language/Symantic/Compiling/Lambda.hs | 208 +++++ Language/Symantic/Compiling/List.hs | 143 +++- Language/Symantic/Compiling/Map.hs | 44 +- Language/Symantic/Compiling/Map/Test.hs | 114 +-- Language/Symantic/Compiling/Maybe.hs | 45 +- Language/Symantic/Compiling/Monad.hs | 53 +- Language/Symantic/Compiling/MonoFoldable.hs | 55 +- Language/Symantic/Compiling/MonoFunctor.hs | 54 +- .../Symantic/Compiling/MonoFunctor/Test.hs | 44 +- Language/Symantic/Compiling/Monoid.hs | 28 +- Language/Symantic/Compiling/NonNull.hs | 57 +- Language/Symantic/Compiling/Num.hs | 39 +- Language/Symantic/Compiling/Num/Test.hs | 112 +++ Language/Symantic/Compiling/Ord.hs | 107 ++- Language/Symantic/Compiling/Sequences.hs | 58 +- Language/Symantic/Compiling/Show.hs | 20 +- Language/Symantic/Compiling/Term.hs | 215 +----- Language/Symantic/Compiling/Term/Grammar.hs | 571 ++++++++++++++ Language/Symantic/Compiling/Term/HLint.hs | 1 + Language/Symantic/Compiling/Term/Test.hs | 112 ++- Language/Symantic/Compiling/Test.hs | 30 +- Language/Symantic/Compiling/Text.hs | 20 +- Language/Symantic/Compiling/Traversable.hs | 17 +- Language/Symantic/Compiling/Tuple2.hs | 70 +- Language/Symantic/Compiling/Tuple2/Test.hs | 30 + Language/Symantic/Compiling/Unit.hs | 38 +- Language/Symantic/Interpreting/Dup.hs | 18 +- Language/Symantic/Interpreting/Text.hs | 83 +- Language/Symantic/Parsing/EBNF.hs | 210 +++++- Language/Symantic/Parsing/EBNF/Print.hs | 16 + Language/Symantic/Parsing/Grammar.hs | 710 +++++++++--------- Language/Symantic/Parsing/Grammar/Test.hs | 202 ++--- Language/Symantic/Parsing/Test.hs | 333 +------- Language/Symantic/Parsing/Token.hs | 19 +- Language/Symantic/Test.hs | 2 + Language/Symantic/Typing/Constant.hs | 13 +- Language/Symantic/Typing/Constraint.hs | 6 +- Language/Symantic/Typing/Family.hs | 6 +- Language/Symantic/Typing/Kind.hs | 10 +- Language/Symantic/Typing/Test.hs | 47 +- Language/Symantic/Typing/Type.hs | 139 ++-- symantic.cabal | 172 ++++- 60 files changed, 3090 insertions(+), 2015 deletions(-) create mode 100644 Language/Symantic/Compiling/Lambda.hs create mode 100644 Language/Symantic/Compiling/Num/Test.hs create mode 100644 Language/Symantic/Compiling/Term/Grammar.hs create mode 120000 Language/Symantic/Compiling/Term/HLint.hs create mode 100644 Language/Symantic/Compiling/Tuple2/Test.hs create mode 100644 Language/Symantic/Parsing/EBNF/Print.hs diff --git a/Language/Symantic/Compiling.hs b/Language/Symantic/Compiling.hs index 0b54ba4..1362985 100644 --- a/Language/Symantic/Compiling.hs +++ b/Language/Symantic/Compiling.hs @@ -14,6 +14,7 @@ module Language.Symantic.Compiling , module Language.Symantic.Compiling.Integer , module Language.Symantic.Compiling.Integral , module Language.Symantic.Compiling.IO + , module Language.Symantic.Compiling.Lambda , module Language.Symantic.Compiling.List , module Language.Symantic.Compiling.Map , module Language.Symantic.Compiling.Maybe @@ -46,6 +47,7 @@ import Language.Symantic.Compiling.Int import Language.Symantic.Compiling.Integer import Language.Symantic.Compiling.Integral import Language.Symantic.Compiling.IO +import Language.Symantic.Compiling.Lambda import Language.Symantic.Compiling.List import Language.Symantic.Compiling.Map import Language.Symantic.Compiling.Maybe diff --git a/Language/Symantic/Compiling/Alternative.hs b/Language/Symantic/Compiling/Alternative.hs index 2b99cd8..c37d42d 100644 --- a/Language/Symantic/Compiling/Alternative.hs +++ b/Language/Symantic/Compiling/Alternative.hs @@ -8,13 +8,14 @@ import qualified Control.Applicative as Alternative import Control.Monad (liftM2) import qualified Data.Function as Fun import Data.Proxy -import Data.Text (Text) import Data.Type.Equality ((:~:)(Refl)) -import Prelude hiding (Functor(..), (<$>), id, const, Monoid(..)) +import Prelude hiding (Functor(..), (<$>), id, const) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling.Lambda import Language.Symantic.Compiling.Functor (Sym_Functor(..)) import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans @@ -42,16 +43,16 @@ instance Sym_Alternative HostI where (<|>) = liftM2 (Alternative.<|>) instance Sym_Alternative TextI where empty = textI0 "empty" - (<|>) = textI_infix "<|>" (Precedence 3) + (<|>) = textI_infix "<|>" (infixL 3) instance (Sym_Alternative r1, Sym_Alternative r2) => Sym_Alternative (DupI r1 r2) where empty = dupI0 (Proxy @Sym_Alternative) empty (<|>) = dupI2 (Proxy @Sym_Alternative) (<|>) instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Alternative - ) => Read_TypeNameR Text cs (Proxy Alternative ': rs) where - read_typenameR _cs "Alternative" k = k (ty @Alternative) + ) => Read_TypeNameR Type_Name cs (Proxy Alternative ': rs) where + read_typenameR _cs (Type_Name "Alternative") k = k (ty @Alternative) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Alternative ': cs) where show_const ConstZ{} = "Alternative" @@ -64,7 +65,7 @@ data instance TokenT meta (ts::[*]) (Proxy Alternative) deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Alternative)) deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Alternative)) instance -- CompileI - ( Read_TypeName Name_LamVar (Consts_of_Ifaces is) + ( Read_TypeName Type_Name (Consts_of_Ifaces is) , Inj_Const (Consts_of_Ifaces is) Alternative , Inj_Const (Consts_of_Ifaces is) (->) , Proj_Con (Consts_of_Ifaces is) @@ -92,3 +93,17 @@ instance -- CompileI (At (Just tok_fl) ty_fa) $ \Refl Con _ty_f _ty_a -> k (ty_fa ~> ty_fa) $ TermO $ \c -> lam $ \fr -> (<|>) (fl c) fr +instance -- TokenizeT + Inj_Token meta ts Alternative => + TokenizeT meta ts (Proxy Alternative) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ (Term_Name "empty",) Term_ProTok + { term_protok = \meta -> ProTokPi $ \f -> ProTokPi $ \a -> + ProTok $ inj_etoken meta $ Token_Term_Alternative_empty f a + , term_fixity = infixN5 + } + , tokenize1 "<|>" (infixL 3) Token_Term_Alternative_alt + ] + } +instance Gram_Term_AtomsT meta ts (Proxy Alternative) g diff --git a/Language/Symantic/Compiling/Applicative.hs b/Language/Symantic/Compiling/Applicative.hs index c9f0279..2c16430 100644 --- a/Language/Symantic/Compiling/Applicative.hs +++ b/Language/Symantic/Compiling/Applicative.hs @@ -8,13 +8,14 @@ import qualified Control.Applicative as Applicative import Control.Monad (liftM, liftM2) import qualified Data.Function as Fun import Data.Proxy -import Data.Text (Text) import Data.Type.Equality ((:~:)(Refl)) -import Prelude hiding (Functor(..), (<$>), Applicative(..), id, const, Monoid(..)) +import Prelude hiding (Functor(..), (<$>), Applicative(..), id, const) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling.Lambda import Language.Symantic.Compiling.Functor (Sym_Functor(..), (<$>)) import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans @@ -48,18 +49,18 @@ instance Sym_Applicative HostI where (<*>) = liftM2 (Applicative.<*>) instance Sym_Applicative TextI where pure = textI1 "pure" - (<*>) = textI_infix "<*>" (Precedence 4) - (<* ) = textI_infix "<*" (Precedence 4) - ( *>) = textI_infix "*>" (Precedence 4) + (<*>) = textI_infix "<*>" (infixL 4) + (<* ) = textI_infix "<*" (infixL 4) + ( *>) = textI_infix "*>" (infixL 4) instance (Sym_Applicative r1, Sym_Applicative r2) => Sym_Applicative (DupI r1 r2) where pure = dupI1 (Proxy @Sym_Applicative) pure (<*>) = dupI2 (Proxy @Sym_Applicative) (<*>) instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Applicative - ) => Read_TypeNameR Text cs (Proxy Applicative ': rs) where - read_typenameR _cs "Applicative" k = k (ty @Applicative) + ) => Read_TypeNameR Type_Name cs (Proxy Applicative ': rs) where + read_typenameR _cs (Type_Name "Applicative") k = k (ty @Applicative) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Applicative ': cs) where show_const ConstZ{} = "Applicative" @@ -67,14 +68,14 @@ instance Show_Const cs => Show_Const (Proxy Applicative ': cs) where instance Proj_ConC cs (Proxy Applicative) data instance TokenT meta (ts::[*]) (Proxy Applicative) - = Token_Term_Applicative_pure (EToken meta '[Proxy Token_Type]) (EToken meta ts) - | Token_Term_Applicative_app (EToken meta ts) - | Token_Term_Applicative_stargt (EToken meta ts) (EToken meta ts) - | Token_Term_Applicative_ltstar (EToken meta ts) (EToken meta ts) + = Token_Term_Applicative_pure (EToken meta '[Proxy Token_Type]) (EToken meta ts) + | Token_Term_Applicative_app (EToken meta ts) + | Token_Term_Applicative_tsnoc (EToken meta ts) (EToken meta ts) + | Token_Term_Applicative_const (EToken meta ts) (EToken meta ts) deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Applicative)) deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Applicative)) instance -- CompileI - ( Read_TypeName Name_LamVar (Consts_of_Ifaces is) + ( Read_TypeName Type_Name (Consts_of_Ifaces is) , Inj_Const (Consts_of_Ifaces is) Applicative , Inj_Const (Consts_of_Ifaces is) (->) , Proj_Con (Consts_of_Ifaces is) @@ -100,7 +101,7 @@ instance -- CompileI check_type2 (ty @(->)) (At (Just tok_fa2b) ty_fa2b_a2b) $ \Refl ty_fa2b_a ty_fa2b_b -> k (ty_fa2b_f :$ ty_fa2b_a ~> ty_fa2b_f :$ ty_fa2b_b) $ TermO $ \c -> lam $ \fa -> (<*>) (fa2b c) fa - Token_Term_Applicative_ltstar tok_fa tok_fb -> + Token_Term_Applicative_const tok_fa tok_fb -> -- (<*) :: Applicative f => f a -> f b -> f a compileO tok_fa ctx $ \ty_fa (TermO fa) -> compileO tok_fb ctx $ \ty_fb (TermO fb) -> @@ -109,7 +110,7 @@ instance -- CompileI check_type1 ty_fa_f (At (Just tok_fb) ty_fb) $ \Refl _ty_fb_b -> k ty_fa $ TermO $ \c -> (<*) (fa c) (fb c) - Token_Term_Applicative_stargt tok_fa tok_fb -> + Token_Term_Applicative_tsnoc tok_fa tok_fb -> -- (*>) :: Applicative f => f a -> f b -> f b compileO tok_fa ctx $ \ty_fa (TermO fa) -> compileO tok_fb ctx $ \ty_fb (TermO fb) -> @@ -118,3 +119,14 @@ instance -- CompileI check_type1 ty_fa_f (At (Just tok_fb) ty_fb) $ \Refl _ty_fb_b -> k ty_fb $ TermO $ \c -> (*>) (fa c) (fb c) +instance -- TokenizeT + Inj_Token meta ts Applicative => + TokenizeT meta ts (Proxy Applicative) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ tokenize1 "<*>" (infixL 4) Token_Term_Applicative_app + , tokenize2 "<*" (infixL 4) Token_Term_Applicative_const + , tokenize2 "*>" (infixL 4) Token_Term_Applicative_tsnoc + ] + } +instance Gram_Term_AtomsT meta ts (Proxy Applicative) g diff --git a/Language/Symantic/Compiling/Applicative/Test.hs b/Language/Symantic/Compiling/Applicative/Test.hs index c434b91..f1e8b3a 100644 --- a/Language/Symantic/Compiling/Applicative/Test.hs +++ b/Language/Symantic/Compiling/Applicative/Test.hs @@ -1,62 +1,45 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Compiling.Applicative.Test where import Test.Tasty import Data.Proxy (Proxy(..)) -import Data.Text (Text) import Prelude hiding ((&&), not, (||)) -import Language.Symantic.Parsing import Language.Symantic.Typing -import Language.Symantic.Compiling import Compiling.Term.Test import Compiling.Bool.Test () -import Parsing.Test --- * Tests type Ifaces = [ Proxy (->) + , Proxy Integer , Proxy Bool , Proxy Maybe + , Proxy Functor , Proxy Applicative ] (==>) = test_compile (Proxy::Proxy Ifaces) -instance - ( Inj_Token (Syntax Text) ts Applicative - , Tokenize (Syntax Text) (Syntax Text) ts ) => - TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Applicative) where - tokenizeT _t (Syntax "(<*>)" (ast_fa2b : as)) = Just $ do - fa2b <- tokenize ast_fa2b - Right $ (as,) $ EToken $ inj_token (Syntax "(<*>)" [ast_fa2b]) $ - Token_Term_Applicative_app fa2b - tokenizeT _t (Syntax "(<*)" (ast_fa : ast_fb : as)) = Just $ do - fa <- tokenize ast_fa - fb <- tokenize ast_fb - Right $ (as,) $ EToken $ inj_token (Syntax "(<*)" [ast_fa, ast_fb]) $ - Token_Term_Applicative_ltstar fa fb - tokenizeT _t (Syntax "(*>)" (ast_fa : ast_fb : as)) = Just $ do - fa <- tokenize ast_fa - fb <- tokenize ast_fb - Right $ (as,) $ EToken $ inj_token (Syntax "(*>)" [ast_fa, ast_fb]) $ - Token_Term_Applicative_stargt fa fb - tokenizeT _t _sy = Nothing - tests :: TestTree tests = testGroup "Applicative" - [ Syntax "(<*>)" - [ Syntax "Just" [Syntax "xor" [syLit True]] - , Syntax "Just" [syLit True] - ] ==> Right (ty @Maybe :$ ty @Bool, Just False, "(\\x0 -> Just ((\\x1 -> (\\x2 -> x1 `xor` x2)) True) <*> x0) (Just True)") - , Syntax "(*>)" - [ Syntax "Just" [syLit False] - , Syntax "Just" [syLit True] - ] ==> Right (ty @Maybe :$ ty @Bool, Just True, "Just False *> Just True") - , Syntax "(<*)" - [ Syntax "Just" [syLit False] - , Syntax "Just" [syLit True] - ] ==> Right (ty @Maybe :$ ty @Bool, Just False, "Just False <* Just True") + [ "Just (xor True) <*> Just True" ==> Right + ( ty @Maybe :$ ty @Bool + , Just False + , "(\\x0 -> Just ((\\x1 -> (\\x2 -> x1 `xor` x2)) True) <*> x0) (Just True)" ) + , "Just (xor True) <*> Nothing @Bool" ==> Right + ( ty @Maybe :$ ty @Bool + , Nothing + , "(\\x0 -> Just ((\\x1 -> (\\x2 -> x1 `xor` x2)) True) <*> x0) Nothing" ) + , "xor <$> Just True <*> Just False" ==> Right + ( ty @Maybe :$ ty @Bool + , Just True + , "(\\x0 -> fmap (\\x1 -> (\\x2 -> x1 `xor` x2)) (Just True) <*> x0) (Just False)" ) + , "Just False <* Just True" ==> Right + ( ty @Maybe :$ ty @Bool + , Just False + , "Just False <* Just True" ) + , "Just False *> Just True" ==> Right + ( ty @Maybe :$ ty @Bool + , Just True + , "Just False *> Just True" ) ] diff --git a/Language/Symantic/Compiling/Bool.hs b/Language/Symantic/Compiling/Bool.hs index b3dda74..96f0aa2 100644 --- a/Language/Symantic/Compiling/Bool.hs +++ b/Language/Symantic/Compiling/Bool.hs @@ -5,16 +5,16 @@ module Language.Symantic.Compiling.Bool where import Control.Monad import qualified Data.Bool as Bool -import Data.Monoid import Data.Proxy -import Data.Text (Text) import qualified Data.Text as Text import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding ((&&), not, (||)) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling.Lambda import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans @@ -57,27 +57,24 @@ instance Sym_Bool HostI where (&&) = liftM2 (Bool.&&) (||) = liftM2 (Bool.||) instance Sym_Bool TextI where - bool a = TextI $ \_p _v -> - Text.pack (show a) - not (TextI x) = - TextI $ \p v -> - let p' = Precedence 9 in - paren p p' $ "not " <> x p' v - (&&) = textI_infix "&&" (Precedence 6) - (||) = textI_infix "||" (Precedence 5) - xor = textI_infix "`xor`" (Precedence 5) + bool o = TextI $ \_p _v -> + Text.pack (show o) + not = textI1 "not" + (&&) = textI_infix "&&" (infixR 3) + (||) = textI_infix "||" (infixR 2) + xor = textI_infix "`xor`" (infixR 2) instance (Sym_Bool r1, Sym_Bool r2) => Sym_Bool (DupI r1 r2) where - bool x = bool x `DupI` bool x + bool b = bool b `DupI` bool b not = dupI1 (Proxy @Sym_Bool) not (&&) = dupI2 (Proxy @Sym_Bool) (&&) (||) = dupI2 (Proxy @Sym_Bool) (||) xor = dupI2 (Proxy @Sym_Bool) xor instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Bool - ) => Read_TypeNameR Text cs (Proxy Bool ': rs) where - read_typenameR _cs "Bool" k = k (ty @Bool) + ) => Read_TypeNameR Type_Name cs (Proxy Bool ': rs) where + read_typenameR _cs (Type_Name "Bool") k = k (ty @Bool) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Bool ': cs) where show_const ConstZ{} = "Bool" @@ -89,13 +86,13 @@ instance -- Proj_ConC ) => Proj_ConC cs (Proxy Bool) where proj_conC _ (TyConst q :$ TyConst c) | Just Refl <- eq_skind (kind_of_const c) SKiType - , Just Refl <- proj_const c (Proxy::Proxy Bool) + , Just Refl <- proj_const c (Proxy @Bool) = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Bounded) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Enum) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Eq) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Ord) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Show) -> Just Con + _ | Just Refl <- proj_const q (Proxy @Bounded) -> Just Con + | Just Refl <- proj_const q (Proxy @Enum) -> Just Con + | Just Refl <- proj_const q (Proxy @Eq) -> Just Con + | Just Refl <- proj_const q (Proxy @Ord) -> Just Con + | Just Refl <- proj_const q (Proxy @Show) -> Just Con _ -> Nothing proj_conC _c _q = Nothing data instance TokenT meta (ts::[*]) (Proxy Bool) @@ -124,3 +121,17 @@ instance -- CompileI op2_from (op::forall term. Sym_Bool term => term Bool -> term Bool -> term Bool) = k (ty @Bool ~> ty @Bool ~> ty @Bool) $ TermO $ \_c -> lam $ lam . op +instance -- TokenizeT + Inj_Token meta ts Bool => + TokenizeT meta ts (Proxy Bool) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ tokenize0 "False" infixN5 $ Token_Term_Bool False + , tokenize0 "True" infixN5 $ Token_Term_Bool True + , tokenize0 "not" infixN5 Token_Term_Bool_not + , tokenize0 "and" (infixR 3) Token_Term_Bool_and + , tokenize0 "or" (infixR 2) Token_Term_Bool_or + , tokenize0 "xor" (infixR 2) Token_Term_Bool_xor + ] + } +instance Gram_Term_AtomsT meta ts (Proxy Bool) g diff --git a/Language/Symantic/Compiling/Bool/Test.hs b/Language/Symantic/Compiling/Bool/Test.hs index 1779c2f..bf36b81 100644 --- a/Language/Symantic/Compiling/Bool/Test.hs +++ b/Language/Symantic/Compiling/Bool/Test.hs @@ -1,14 +1,9 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Compiling.Bool.Test where import Test.Tasty import Data.Proxy (Proxy(..)) -import Data.Text (Text) -import qualified Data.Text as Text import Prelude hiding ((&&), not, (||)) import Language.Symantic.Parsing @@ -17,10 +12,53 @@ import Language.Symantic.Compiling import Language.Symantic.Interpreting import Compiling.Term.Test -import Parsing.Test +type Ifaces = + [ Proxy Bool + , Proxy (->) + , Proxy Integer + ] +(==>) = test_compile (Proxy::Proxy Ifaces) --- * Class 'Sym_Bool_Vars' +tests :: TestTree +tests = testGroup "Bool" $ + [ "True" ==> Right (ty @Bool, True, "True") + , "xor True True" ==> Right (ty @Bool, False, "((\\x0 -> (\\x1 -> x0 `xor` x1)) True) True") + , "xor False True" ==> Right (ty @Bool, True, "((\\x0 -> (\\x1 -> x0 `xor` x1)) False) True") + , "True `xor` True" ==> Right (ty @Bool, False, "((\\x0 -> (\\x1 -> x0 `xor` x1)) True) True") + , "(\\(x:Bool) -> x) True" ==> Right (ty @Bool, True, "(\\x0 -> x0) True") + , "(\\(False:Bool) -> False) True" ==> Right (ty @Bool, True, "(\\x0 -> x0) True") + , "(\\(False:Bool) -> False) (False `xor` True)" ==> Right + (ty @Bool, True, "(\\x0 -> x0) (((\\x0 -> (\\x1 -> x0 `xor` x1)) False) True)") + , "(\\(lett:Bool) -> lett) True" ==> Right (ty @Bool, True, "(\\x0 -> x0) True") + , "(\\(x:Bool) -> xor x x) True" ==> Right + (ty @Bool, False, "(\\x0 -> ((\\x1 -> (\\x2 -> x1 `xor` x2)) x0) x0) True") + , "let x = True in xor x True" ==> Right + (ty @Bool, False, "let x0 = True in ((\\x1 -> (\\x2 -> x1 `xor` x2)) x0) True") + , testGroup "Error_Term" + [ "True True" ==> Left (ty @Bool, + Right $ Error_Term_Constraint_Type $ + Right $ Constraint_Type_App $ + At (maybeRight $ test_tokenizer "True") $ + EType $ ty @Bool) + , "(\\(x:Bool) -> x `xor` True) Bool" ==> Left (ty @Bool, + Right $ Error_Term_unbound $ Term_Name "Bool") + , "(\\(x:Bool) -> x) True True" ==> Left (ty @Bool, + Right $ Error_Term_Constraint_Type $ + Right $ Constraint_Type_App $ + At (maybeRight $ test_tokenizer "(\\(x:Bool) -> x) True") $ + EType $ ty @Bool) + , "(\\(x:Bool -> Bool) -> x True) True" ==> Left (ty @Bool, + Right $ Error_Term_Constraint_Type $ Right $ + Constraint_Type_Eq + (Right $ At (maybeRight $ test_tokenizer "(\\(x:Bool -> Bool) -> x True)") $ + EType $ (ty @Bool ~> ty @Bool)) + (At (maybeRight $ test_tokenizer "True") $ + EType $ ty @Bool) + ) + ] + ] +-- * Class 'Sym_Bool_Vars' -- | A few boolean variables. class Sym_Bool_Vars repr where x :: repr Bool @@ -40,7 +78,7 @@ instance -- Trans_Boo_Const z = trans_lift z -} --- * Terms +-- * EDSL tests te1 = bool True && bool False te2 = (bool True && bool False) || (bool True && bool True) te3 = (bool True || bool False) && (bool True || bool True) @@ -49,84 +87,3 @@ te5 = bool True && not x te6 = x `xor` y te7 = (x `xor` y) `xor` z te8 = x `xor` (y `xor` bool True) - -instance - ( Inj_Token (Syntax Text) ts Bool - {-, Tokenize (Syntax Text) (Syntax Text) ts-} ) => - TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Bool) where - tokenizeT _t (Syntax "bool" (ast_b : as)) = Just $ do - b <- read_syntax ast_b - Right $ (as,) $ EToken $ inj_token (Syntax "bool" [ast_b]) $ - Token_Term_Bool b - tokenizeT _t (Syntax "xor" as) = Just $ - Right $ (as,) $ EToken $ inj_token (Syntax "xor" []) $ - Token_Term_Bool_xor - tokenizeT _t (Syntax "not" as) = Just $ - Right $ (as,) $ EToken $ inj_token (Syntax "not" []) $ - Token_Term_Bool_not - tokenizeT _t _sy = Nothing - --- * Tests -type Ifaces = - [ Proxy Bool - , Proxy (->) - ] -(==>) = test_compile (Proxy::Proxy Ifaces) - -syBool b = Syntax "bool" [Syntax (Text.pack $ Prelude.show b) []] - -tests :: TestTree -tests = testGroup "Bool" $ - [ syBool True ==> Right (ty @Bool, True, "True") - , Syntax "xor" [syBool True, syBool True] ==> Right - (ty @Bool, False, "((\\x0 -> (\\x1 -> x0 `xor` x1)) True) True") - , syApp (syLam "x" (sy @Bool) (syVar "x")) (syBool True) ==> Right - (ty @Bool, True, "(\\x0 -> x0) True") - , syApp - (syLam "x" (sy @Bool) - (Syntax "xor" [ syVar "x", syBool True ])) - (syBool True) ==> Right - (ty @Bool, False, "(\\x0 -> ((\\x1 -> (\\x2 -> x1 `xor` x2)) x0) True) True" ) - , syLet "x" (syBool True) - (Syntax "xor" [ syVar "x", syBool True ]) ==> Right - (ty @Bool, False, "let x0 = True in ((\\x1 -> (\\x2 -> x1 `xor` x2)) x0) True") - , testGroup "Error_Term" $ - [ (syBool True `syApp` syBool True) ==> Left (ty @Bool, - Right $ Error_Term_Constraint_Type $ - Right $ Constraint_Type_App $ - At (maybeRight $ tokenize $ syBool True) $ - EType $ ty @Bool) - , syApp - (syLam "x" (sy @Bool) - (Syntax "xor" [ syVar "x", syBool True ])) - (sy @Bool) ==> Left (ty @Bool, - Left $ Error_Syntax_unsupported $ - sy @Bool) - , let syn = Syntax " " - [ syLam "x" (sy @Bool) (syVar "x") - ] in syn ==> Left (ty @Bool, - Left $ Error_Syntax_unsupported syn) - , Syntax " " - [ syLam "x" (sy @Bool) (syVar "x") - , syBool True - , syBool True - ] ==> Left (ty @Bool, - Right $ Error_Term_Constraint_Type $ - Right $ Constraint_Type_App $ - At (maybeRight $ tokenize $ - Syntax " " - [ syLam "x" (sy @Bool) (syVar "x") - , syBool True - ]) $ - EType $ ty @Bool) - , let syn = - syLam "x" (sy @Bool .> sy @Bool) - (Syntax " " [syVar "x", syBool True]) in - syApp syn (syBool True) ==> Left (ty @Bool, - Right $ Error_Term_Constraint_Type $ Right $ - Constraint_Type_Eq - (Right $ At (maybeRight $ tokenize syn) $ EType $ (ty @Bool ~> ty @Bool)) - (At (maybeRight $ tokenize $ syBool $ True) $ EType $ ty @Bool) - ) - ] - ] diff --git a/Language/Symantic/Compiling/Char.hs b/Language/Symantic/Compiling/Char.hs index cb0aefc..b8ff184 100644 --- a/Language/Symantic/Compiling/Char.hs +++ b/Language/Symantic/Compiling/Char.hs @@ -6,13 +6,15 @@ module Language.Symantic.Compiling.Char where import Control.Monad (liftM) import qualified Data.Char as Char import Data.Proxy -import Data.Text (Text) import qualified Data.Text as Text import Data.Type.Equality ((:~:)(Refl)) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar hiding (char) +import qualified Language.Symantic.Parsing.Grammar as Gram import Language.Symantic.Typing import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling.Lambda import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans @@ -55,10 +57,10 @@ instance (Sym_Char r1, Sym_Char r2) => Sym_Char (DupI r1 r2) where char_toLower = dupI1 (Proxy @Sym_Char) char_toLower instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Char - ) => Read_TypeNameR Text cs (Proxy Char ': rs) where - read_typenameR _cs "Char" k = k (ty @Char) + ) => Read_TypeNameR Type_Name cs (Proxy Char ': rs) where + read_typenameR _cs (Type_Name "Char") k = k (ty @Char) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Char ': cs) where show_const ConstZ{} = "Char" @@ -70,13 +72,13 @@ instance -- Proj_ConC ) => Proj_ConC cs (Proxy Char) where proj_conC _ (TyConst q :$ TyConst c) | Just Refl <- eq_skind (kind_of_const c) SKiType - , Just Refl <- proj_const c (Proxy::Proxy Char) + , Just Refl <- proj_const c (Proxy @Char) = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Bounded) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Enum) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Eq) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Ord) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Show) -> Just Con + _ | Just Refl <- proj_const q (Proxy @Bounded) -> Just Con + | Just Refl <- proj_const q (Proxy @Enum) -> Just Con + | Just Refl <- proj_const q (Proxy @Eq) -> Just Con + | Just Refl <- proj_const q (Proxy @Ord) -> Just Con + | Just Refl <- proj_const q (Proxy @Show) -> Just Con _ -> Nothing proj_conC _c _q = Nothing data instance TokenT meta (ts::[*]) (Proxy Char) @@ -97,3 +99,31 @@ instance -- CompileI where from_op (op::forall term. Sym_Char term => term Char -> term Char) = k (ty @Char ~> ty @Char) $ TermO $ \_c -> lam op +instance -- TokenizeT + Inj_Token meta ts Char => + TokenizeT meta ts (Proxy Char) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [Mod_Name "Char"] + [ tokenize0 "toLower" infixN5 Token_Term_Char_toLower + , tokenize0 "toUpper" infixN5 Token_Term_Char_toUpper + ] + } +instance -- Gram_Term_AtomsT + ( Alt g + , Gram_Rule g + , Gram_Lexer g + , Gram_Meta meta g + , Inj_Token meta ts Char + ) => Gram_Term_AtomsT meta ts (Proxy Char) g where + term_atomsT _t = + [ rule "term_char" $ + lexeme $ metaG $ + (\c meta -> ProTok $ inj_etoken meta $ Token_Term_Char c) + <$> Gram.between tickG tickG ( + Gram.cf_of_term (Gram.any `Gram.but` tickG) Gram.<+> + '\'' <$ Gram.string "\\'" + ) + ] + where + tickG :: Gram_Terminal g' => g' Char + tickG = Gram.char '\'' diff --git a/Language/Symantic/Compiling/Either.hs b/Language/Symantic/Compiling/Either.hs index 51dcd33..0e87cfe 100644 --- a/Language/Symantic/Compiling/Either.hs +++ b/Language/Symantic/Compiling/Either.hs @@ -7,13 +7,14 @@ module Language.Symantic.Compiling.Either where import Control.Monad (liftM, liftM3) import qualified Data.Either as Either import Data.Proxy -import Data.Text (Text) import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (either) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling.Lambda import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans @@ -57,10 +58,10 @@ instance (Sym_Either r1, Sym_Either r2) => Sym_Either (DupI r1 r2) where either = dupI3 (Proxy @Sym_Either) either instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Either - ) => Read_TypeNameR Text cs (Proxy Either ': rs) where - read_typenameR _cs "Either" k = k (ty @Either) + ) => Read_TypeNameR Type_Name cs (Proxy Either ': rs) where + read_typenameR _cs (Type_Name "Either") k = k (ty @Either) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Either ': cs) where show_const ConstZ{} = "Either" @@ -72,25 +73,25 @@ instance -- Proj_ConC ) => Proj_ConC cs (Proxy Either) where proj_conC _ (TyConst q :$ (TyConst c :$ _l)) | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy Either) + , Just Refl <- proj_const c (Proxy @Either) = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Functor) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Applicative) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Monad) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Foldable) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Traversable) -> Just Con + _ | Just Refl <- proj_const q (Proxy @Functor) -> Just Con + | Just Refl <- proj_const q (Proxy @Applicative) -> Just Con + | Just Refl <- proj_const q (Proxy @Monad) -> Just Con + | Just Refl <- proj_const q (Proxy @Foldable) -> Just Con + | Just Refl <- proj_const q (Proxy @Traversable) -> Just Con _ -> Nothing proj_conC _ (t@(TyConst q) :$ (TyConst c :$ l :$ r)) | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy Either) + , Just Refl <- proj_const c (Proxy @Either) = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Eq) + _ | Just Refl <- proj_const q (Proxy @Eq) , Just Con <- proj_con (t :$ l) , Just Con <- proj_con (t :$ r) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Ord) + | Just Refl <- proj_const q (Proxy @Ord) , Just Con <- proj_con (t :$ l) , Just Con <- proj_con (t :$ r) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Show) + | Just Refl <- proj_const q (Proxy @Show) , Just Con <- proj_con (t :$ l) , Just Con <- proj_con (t :$ r) -> Just Con _ -> Nothing @@ -102,7 +103,7 @@ data instance TokenT meta (ts::[*]) (Proxy Either) deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Either)) deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Either)) instance -- CompileI - ( Read_TypeName Name_LamVar (Consts_of_Ifaces is) + ( Read_TypeName Type_Name (Consts_of_Ifaces is) , Inj_Const (Consts_of_Ifaces is) Either , Inj_Const (Consts_of_Ifaces is) (->) -- , Proj_Token is Token_Type @@ -137,3 +138,20 @@ instance -- CompileI check_type (At (Just tok_l2a) ty_l2a_a) (At (Just tok_r2a) ty_r2a_a) $ \Refl -> k ((ty @Either :$ ty_l2a_l) :$ ty_r2a_r ~> ty_l2a_a) $ TermO $ \c -> lam $ either (l2a c) (r2a c) +instance -- TokenizeT + Inj_Token meta ts Either => + TokenizeT meta ts (Proxy Either) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ (Term_Name "Left",) Term_ProTok + { term_protok = \meta -> ProTokLam $ \l -> ProTokPi $ \r -> + ProTok $ inj_etoken meta $ Token_Term_Either_Left r l + , term_fixity = infixN5 } + , (Term_Name "Right",) Term_ProTok + { term_protok = \meta -> ProTokPi $ \l -> ProTokLam $ \r -> + ProTok $ inj_etoken meta $ Token_Term_Either_Right l r + , term_fixity = infixN5 } + , tokenize2 "either" infixN5 Token_Term_Either_either + ] + } +instance Gram_Term_AtomsT meta ts (Proxy Either) g diff --git a/Language/Symantic/Compiling/Eq.hs b/Language/Symantic/Compiling/Eq.hs index 7b115fd..db09b50 100644 --- a/Language/Symantic/Compiling/Eq.hs +++ b/Language/Symantic/Compiling/Eq.hs @@ -6,12 +6,13 @@ module Language.Symantic.Compiling.Eq where import Control.Monad import qualified Data.Eq as Eq import Data.Proxy (Proxy(..)) -import Data.Text (Text) import Prelude hiding ((==), (/=)) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling.Lambda import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans @@ -37,17 +38,17 @@ instance Sym_Eq HostI where (==) = liftM2 (Eq.==) (/=) = liftM2 (Eq./=) instance Sym_Eq TextI where - (==) = textI_infix "==" (Precedence 4) - (/=) = textI_infix "/=" (Precedence 4) + (==) = textI_infix "==" (infixN 4) + (/=) = textI_infix "/=" (infixN 4) instance (Sym_Eq r1, Sym_Eq r2) => Sym_Eq (DupI r1 r2) where (==) = dupI2 (Proxy @Sym_Eq) (==) (/=) = dupI2 (Proxy @Sym_Eq) (/=) instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Eq - ) => Read_TypeNameR Text cs (Proxy Eq ': rs) where - read_typenameR _cs "Eq" k = k (ty @Eq) + ) => Read_TypeNameR Type_Name cs (Proxy Eq ': rs) where + read_typenameR _cs (Type_Name "Eq") k = k (ty @Eq) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Eq ': cs) where show_const ConstZ{} = "Eq" @@ -76,3 +77,13 @@ instance -- CompileI check_con (At (Just tok_a) (ty @Eq :$ ty_a)) $ \Con -> k (ty_a ~> ty @Bool) $ TermO $ \c -> lam $ op (a c) +instance -- TokenizeT + Inj_Token meta ts Eq => + TokenizeT meta ts (Proxy Eq) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ tokenize1 "==" (infixN 4) Token_Term_Eq_eq + , tokenize1 "/=" (infixN 4) Token_Term_Eq_ne + ] + } +instance Gram_Term_AtomsT meta ts (Proxy Eq) g diff --git a/Language/Symantic/Compiling/Foldable.hs b/Language/Symantic/Compiling/Foldable.hs index e0f7d31..a971d68 100644 --- a/Language/Symantic/Compiling/Foldable.hs +++ b/Language/Symantic/Compiling/Foldable.hs @@ -8,13 +8,13 @@ import Data.Foldable (Foldable) import qualified Data.Foldable as Foldable import Control.Monad (liftM, liftM2, liftM3) import Data.Proxy -import Data.Text (Text) import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (Foldable(..) , all, and, any, concat, concatMap , mapM_, notElem, or, sequence, sequence_) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar hiding (any) import Language.Symantic.Typing import Language.Symantic.Compiling.Term import Language.Symantic.Interpreting @@ -120,6 +120,8 @@ class Sym_Foldable term where sequence_ = trans_map1 sequence_ traverse_ = trans_map2 traverse_ +infix 4 `elem` + type instance Sym_of_Iface (Proxy Foldable) = Sym_Foldable type instance Consts_of_Iface (Proxy Foldable) = Proxy Foldable ': Consts_imported_by Foldable type instance Consts_imported_by Foldable = '[] @@ -222,10 +224,10 @@ instance (Sym_Foldable r1, Sym_Foldable r2) => Sym_Foldable (DupI r1 r2) where traverse_ = dupI2 (Proxy @Sym_Foldable) traverse_ instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Foldable - ) => Read_TypeNameR Text cs (Proxy Foldable ': rs) where - read_typenameR _cs "Foldable" k = k (ty @Foldable) + ) => Read_TypeNameR Type_Name cs (Proxy Foldable ': rs) where + read_typenameR _cs (Type_Name "Foldable") k = k (ty @Foldable) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Foldable ': cs) where show_const ConstZ{} = "Foldable" @@ -425,3 +427,24 @@ instance -- CompileI (At (Just tok_tBool) ty_tBool_Bool) $ \Refl -> k (ty @Bool) $ TermO $ \c -> g (tBool c) +instance -- TokenizeT + Inj_Token meta ts Foldable => + TokenizeT meta ts (Proxy Foldable) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ tokenize2 "foldMap" infixN5 Token_Term_Foldable_foldMap + , tokenize3 "foldr" infixN5 Token_Term_Foldable_foldr + , tokenize3 "foldr'" infixN5 Token_Term_Foldable_foldr' + , tokenize3 "foldl" infixN5 Token_Term_Foldable_foldl + , tokenize2 "elem" (infixN 4) Token_Term_Foldable_elem + , tokenize1 "sum" infixN5 Token_Term_Foldable_sum + , tokenize1 "product" infixN5 Token_Term_Foldable_product + , tokenize1 "toList" infixN5 Token_Term_Foldable_toList + , tokenize2 "all" infixN5 Token_Term_Foldable_all + , tokenize2 "any" infixN5 Token_Term_Foldable_any + , tokenize1 "and" infixN5 Token_Term_Foldable_and + , tokenize1 "or" infixN5 Token_Term_Foldable_or + , tokenize1 "concat" infixN5 Token_Term_Foldable_concat + ] + } +instance Gram_Term_AtomsT meta ts (Proxy Foldable) g diff --git a/Language/Symantic/Compiling/Foldable/Test.hs b/Language/Symantic/Compiling/Foldable/Test.hs index 15d071c..a07b948 100644 --- a/Language/Symantic/Compiling/Foldable/Test.hs +++ b/Language/Symantic/Compiling/Foldable/Test.hs @@ -1,57 +1,38 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -{-# OPTIONS_GHC -O0 #-} -- speedup compile-time… module Compiling.Foldable.Test where import Test.Tasty import Data.Proxy (Proxy(..)) -import Data.Text (Text) +import Prelude hiding ((&&), not, (||)) -import Language.Symantic.Parsing import Language.Symantic.Typing -import Language.Symantic.Compiling import Compiling.Term.Test -import Parsing.Test +import Compiling.Bool.Test () --- * Tests type Ifaces = [ Proxy (->) - , Proxy [] , Proxy Int + , Proxy Integer + , Proxy [] + , Proxy () + , Proxy (,) , Proxy Foldable ] (==>) = test_compile (Proxy::Proxy Ifaces) -instance - ( Inj_Token (Syntax Text) ts Foldable - , Tokenize (Syntax Text) (Syntax Text) ts ) => - TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Foldable) where - tokenizeT _t (Syntax "foldMap" (ast_f : ast_m : as)) = Just $ do - f <- tokenize ast_f - m <- tokenize ast_m - Right $ (as,) $ EToken $ inj_token (Syntax "foldMap" [ast_f, ast_m]) $ - Token_Term_Foldable_foldMap f m - tokenizeT _t _sy = Nothing - tests :: TestTree tests = testGroup "Foldable" - [ Syntax "foldMap" - [ syLam "x" (sy @Int) $ - Syntax "list" - [ sy @Int - , syVar "x" - , syVar "x" - ] - , Syntax "list" - [ sy @Int - , syLit (1::Int) - , syLit (2::Int) - , syLit (3::Int) - ] - ] ==> Right - ( ty @[] :$ ty @Int + [ "[] @Integer" ==> Right + ( ty @[] :$ ty @Integer + , [] + , "[]" ) + , "[1, 2, 3]" ==> Right + ( ty @[] :$ ty @Integer + , [1, 2, 3] + , "1 : 2 : 3 : []" ) + , "foldMap (\\(x0:Integer) -> [x0, x0]) [1, 2, 3]" ==> Right + ( ty @[] :$ ty @Integer , [1, 1, 2, 2, 3, 3] - , "foldMap (\\x0 -> [x0, x0]) [1, 2, 3]" ) + , "foldMap (\\x0 -> x0 : x0 : []) (1 : 2 : 3 : [])" ) ] diff --git a/Language/Symantic/Compiling/Functor.hs b/Language/Symantic/Compiling/Functor.hs index 38c2867..174f259 100644 --- a/Language/Symantic/Compiling/Functor.hs +++ b/Language/Symantic/Compiling/Functor.hs @@ -8,13 +8,14 @@ import qualified Data.Function as Fun import Data.Functor (Functor) import qualified Data.Functor as Functor import Data.Proxy (Proxy(..)) -import Data.Text (Text) import Data.Type.Equality import Prelude hiding (Functor(..)) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling.Lambda import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans @@ -42,7 +43,7 @@ instance Sym_Functor HostI where (<$) = liftM2 (Functor.<$) instance Sym_Functor TextI where fmap = textI2 "fmap" - (<$) = textI_infix "<$" (Precedence 4) + (<$) = textI_infix "<$" (infixL 4) instance (Sym_Functor r1, Sym_Functor r2) => Sym_Functor (DupI r1 r2) where fmap = dupI2 (Proxy @Sym_Functor) fmap (<$) = dupI2 (Proxy @Sym_Functor) (<$) @@ -54,10 +55,10 @@ instance (Sym_Functor r1, Sym_Functor r2) => Sym_Functor (DupI r1 r2) where infixl 4 <$> instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Functor - ) => Read_TypeNameR Text cs (Proxy Functor ': rs) where - read_typenameR _cs "Functor" k = k (ty @Functor) + ) => Read_TypeNameR Type_Name cs (Proxy Functor ': rs) where + read_typenameR _cs (Type_Name "Functor") k = k (ty @Functor) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Functor ': cs) where show_const ConstZ{} = "Functor" @@ -65,8 +66,8 @@ instance Show_Const cs => Show_Const (Proxy Functor ': cs) where instance Proj_ConC cs (Proxy Functor) data instance TokenT meta (ts::[*]) (Proxy Functor) - = Token_Term_Functor_fmap (EToken meta ts) (EToken meta ts) - | Token_Term_Functor_ltdollar (EToken meta ts) (EToken meta ts) + = Token_Term_Functor_fmap (EToken meta ts) (EToken meta ts) + | Token_Term_Functor_const (EToken meta ts) (EToken meta ts) deriving instance Eq_Token meta ts => Eq (TokenT meta ts (Proxy Functor)) deriving instance Show_Token meta ts => Show (TokenT meta ts (Proxy Functor)) instance -- CompileI @@ -90,7 +91,7 @@ instance -- CompileI (At (Just tok_fa) ty_fa_a) $ \Refl -> k (ty_fa_f :$ ty_a2b_b) $ TermO $ \c -> fmap (a2b c) (fa c) - Token_Term_Functor_ltdollar tok_a tok_fb -> + Token_Term_Functor_const tok_a tok_fb -> -- (<$) :: Functor f => a -> f b -> f a compileO tok_a ctx $ \ty_a (TermO a) -> compileO tok_fb ctx $ \ty_fb (TermO fb) -> @@ -98,3 +99,14 @@ instance -- CompileI (At (Just tok_fb) ty_fb) $ \Refl Con ty_fb_f _ty_fb_b -> k (ty_fb_f :$ ty_a) $ TermO $ \c -> (<$) (a c) (fb c) +instance -- TokenizeT + Inj_Token meta ts Functor => + TokenizeT meta ts (Proxy Functor) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ tokenize2 "fmap" infixN5 Token_Term_Functor_fmap + , tokenize2 "<$" (infixL 4) Token_Term_Functor_const + , tokenize2 "<$>" (infixL 4) Token_Term_Functor_fmap + ] + } +instance Gram_Term_AtomsT meta ts (Proxy Functor) g diff --git a/Language/Symantic/Compiling/Functor/Test.hs b/Language/Symantic/Compiling/Functor/Test.hs index c58e647..e9504fe 100644 --- a/Language/Symantic/Compiling/Functor/Test.hs +++ b/Language/Symantic/Compiling/Functor/Test.hs @@ -1,57 +1,40 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -{-# OPTIONS_GHC -O0 #-} -- speedup compiling… module Compiling.Functor.Test where import Test.Tasty import Data.Proxy (Proxy(..)) -import Data.Text (Text) import Prelude hiding ((&&), not, (||)) -import Language.Symantic.Parsing import Language.Symantic.Typing -import Language.Symantic.Compiling import Compiling.Term.Test import Compiling.Bool.Test () -import Parsing.Test --- * Tests type Ifaces = [ Proxy (->) , Proxy Bool - , Proxy Maybe , Proxy Functor + , Proxy Integer + , Proxy Maybe ] (==>) = test_compile (Proxy::Proxy Ifaces) -instance - ( Inj_Token (Syntax Text) ts Functor - , Tokenize (Syntax Text) (Syntax Text) ts ) => - TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Functor) where - tokenizeT _t (Syntax "fmap" (ast_f : ast_m : as)) = Just $ do - f <- tokenize ast_f - m <- tokenize ast_m - Right $ (as,) $ EToken $ inj_token (Syntax "fmap" [ast_f, ast_m]) $ - Token_Term_Functor_fmap f m - tokenizeT _t (Syntax "(<$)" (ast_a : ast_fb : as)) = Just $ do - a <- tokenize ast_a - fb <- tokenize ast_fb - Right $ (as,) $ EToken $ inj_token (Syntax "fmap" [ast_a, ast_fb]) $ - Token_Term_Functor_ltdollar a fb - tokenizeT _t _sy = Nothing - tests :: TestTree tests = testGroup "Functor" - [ Syntax "fmap" - [ syLam "x" (sy @Bool) - (Syntax "not" [syVar "x"]) - , Syntax "Just" [syLit True] - ] ==> Right (ty @Maybe :$ ty @Bool, Just False, "fmap (\\x0 -> (\\x1 -> not x1) x0) (Just True)") - , Syntax "(<$)" - [ syLit False - , Syntax "Just" [syLit True] - ] ==> Right (ty @Maybe :$ ty @Bool, Just False, "False <$ Just True") + [ "fmap not (Just True)" ==> Right + ( ty @Maybe :$ ty @Bool + , Just False + , "fmap (\\x0 -> not x0) (Just True)") + , "not `fmap` Just True" ==> Right + ( ty @Maybe :$ ty @Bool + , Just False + , "fmap (\\x0 -> not x0) (Just True)") + , "not <$> Just True" ==> Right + ( ty @Maybe :$ ty @Bool + , Just False + , "fmap (\\x0 -> not x0) (Just True)") + , "False <$ Just True" ==> Right + ( ty @Maybe :$ ty @Bool + , Just False + , "False <$ Just True" ) ] diff --git a/Language/Symantic/Compiling/IO.hs b/Language/Symantic/Compiling/IO.hs index afbf782..24f624c 100644 --- a/Language/Symantic/Compiling/IO.hs +++ b/Language/Symantic/Compiling/IO.hs @@ -6,13 +6,14 @@ module Language.Symantic.Compiling.IO where import Control.Monad (liftM, liftM2) import Data.Proxy -import Data.Text (Text) import Data.Type.Equality ((:~:)(Refl)) import qualified System.IO as IO import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling.Lambda import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans @@ -56,22 +57,22 @@ instance (Sym_IO r1, Sym_IO r2) => Sym_IO (DupI r1 r2) where io_openFile = dupI2 (Proxy @Sym_IO) io_openFile instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs IO - ) => Read_TypeNameR Text cs (Proxy IO ': rs) where - read_typenameR _cs "IO" k = k (ty @IO) + ) => Read_TypeNameR Type_Name cs (Proxy IO ': rs) where + read_typenameR _cs (Type_Name "IO") k = k (ty @IO) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs IO.Handle - ) => Read_TypeNameR Text cs (Proxy IO.Handle ': rs) where - read_typenameR _cs "IO.Handle" k = k (ty @IO.Handle) + ) => Read_TypeNameR Type_Name cs (Proxy IO.Handle ': rs) where + read_typenameR _cs (Type_Name "IO.Handle") k = k (ty @IO.Handle) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs IO.IOMode - ) => Read_TypeNameR Text cs (Proxy IO.IOMode ': rs) where - read_typenameR _cs "IO.Mode" k = k (ty @IO.IOMode) + ) => Read_TypeNameR Type_Name cs (Proxy IO.IOMode ': rs) where + read_typenameR _cs (Type_Name "IO.Mode") k = k (ty @IO.IOMode) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy IO ': cs) where @@ -90,11 +91,11 @@ instance -- Proj_ConC IO ) => Proj_ConC cs (Proxy IO) where proj_conC _ (TyConst q :$ TyConst c) | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy IO) + , Just Refl <- proj_const c (Proxy @IO) = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Applicative) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Functor) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Monad) -> Just Con + _ | Just Refl <- proj_const q (Proxy @Applicative) -> Just Con + | Just Refl <- proj_const q (Proxy @Functor) -> Just Con + | Just Refl <- proj_const q (Proxy @Monad) -> Just Con _ -> Nothing proj_conC _c _q = Nothing instance -- Proj_ConC IO.Handle @@ -103,9 +104,9 @@ instance -- Proj_ConC IO.Handle ) => Proj_ConC cs (Proxy IO.Handle) where proj_conC _ (TyConst q :$ TyConst c) | Just Refl <- eq_skind (kind_of_const c) SKiType - , Just Refl <- proj_const c (Proxy::Proxy IO.Handle) + , Just Refl <- proj_const c (Proxy @IO.Handle) = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Eq) -> Just Con + _ | Just Refl <- proj_const q (Proxy @Eq) -> Just Con _ -> Nothing proj_conC _c _q = Nothing instance -- Proj_ConC IO.IOMode @@ -114,11 +115,11 @@ instance -- Proj_ConC IO.IOMode ) => Proj_ConC cs (Proxy IO.IOMode) where proj_conC _ (TyConst q :$ TyConst c) | Just Refl <- eq_skind (kind_of_const c) SKiType - , Just Refl <- proj_const c (Proxy::Proxy IO.IOMode) + , Just Refl <- proj_const c (Proxy @IO.IOMode) = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Enum) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Eq) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Ord) -> Just Con + _ | Just Refl <- proj_const q (Proxy @Enum) -> Just Con + | Just Refl <- proj_const q (Proxy @Eq) -> Just Con + | Just Refl <- proj_const q (Proxy @Ord) -> Just Con _ -> Nothing proj_conC _c _q = Nothing data instance TokenT meta (ts::[*]) (Proxy IO) @@ -155,3 +156,13 @@ instance -- CompileI k (ty @IO.IOMode ~> ty @IO :$ ty @IO.Handle) $ TermO $ \c -> lam $ io_openFile (fp c) where tyFilePath = ty @[] :$ ty @Char +instance -- TokenizeT + Inj_Token meta ts IO => + TokenizeT meta ts (Proxy IO) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [Mod_Name "IO"] + [ tokenize1 "hClose" infixN5 Token_Term_IO_hClose + , tokenize1 "openFile" infixN5 Token_Term_IO_openFile + ] + } +instance Gram_Term_AtomsT meta ts (Proxy IO) g diff --git a/Language/Symantic/Compiling/If.hs b/Language/Symantic/Compiling/If.hs index 73f03e4..4578d4a 100644 --- a/Language/Symantic/Compiling/If.hs +++ b/Language/Symantic/Compiling/If.hs @@ -5,13 +5,14 @@ module Language.Symantic.Compiling.If where import Data.Proxy -import Data.Text (Text) import qualified Data.Text as Text import Data.Type.Equality ((:~:)(Refl)) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling.Lambda import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans @@ -31,19 +32,19 @@ instance Sym_If HostI where if_ (HostI b) ok ko = if b then ok else ko instance Sym_If TextI where if_ (TextI cond) (TextI ok) (TextI ko) = - TextI $ \p v -> - let p' = Precedence 2 in - paren p p' $ + TextI $ \po v -> + infix_paren po op $ Text.concat - [ "if ", cond p' v - , " then ", ok p' v - , " else ", ko p' v ] + [ "if ", cond (op, L) v + , " then ", ok (op, L) v + , " else ", ko (op, L) v ] + where op = infixN 2 instance (Sym_If r1, Sym_If r2) => Sym_If (DupI r1 r2) where if_ = dupI3 (Proxy @Sym_If) if_ instance - ( Read_TypeNameR Text cs rs - ) => Read_TypeNameR Text cs (Proxy If ': rs) where + ( Read_TypeNameR Type_Name cs rs + ) => Read_TypeNameR Type_Name cs (Proxy If ': rs) where read_typenameR _rs = read_typenameR (Proxy @rs) instance Show_Const cs => Show_Const (Proxy If ': cs) where show_const ConstZ{} = "If" @@ -70,3 +71,7 @@ instance -- CompileI (At (Just tok_cond) ty_cond) $ \Refl -> k (ty_ok ~> ty_ok) $ TermO $ \c -> lam $ if_ (cond c) (ok c) +instance -- TokenizeT + -- Inj_Token meta ts If => + TokenizeT meta ts (Proxy If) +instance Gram_Term_AtomsT meta ts (Proxy If) g -- TODO diff --git a/Language/Symantic/Compiling/Int.hs b/Language/Symantic/Compiling/Int.hs index d929fd5..4b2b6bb 100644 --- a/Language/Symantic/Compiling/Int.hs +++ b/Language/Symantic/Compiling/Int.hs @@ -5,7 +5,6 @@ module Language.Symantic.Compiling.Int where import Data.Proxy -import Data.Text (Text) import qualified Data.Text as Text import Data.Type.Equality ((:~:)(Refl)) @@ -43,10 +42,10 @@ instance (Sym_Int r1, Sym_Int r2) => Sym_Int (DupI r1 r2) where int x = int x `DupI` int x instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Int - ) => Read_TypeNameR Text cs (Proxy Int ': rs) where - read_typenameR _cs "Int" k = k (ty @Int) + ) => Read_TypeNameR Type_Name cs (Proxy Int ': rs) where + read_typenameR _cs (Type_Name "Int") k = k (ty @Int) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Int ': cs) where show_const ConstZ{} = "Int" @@ -58,16 +57,16 @@ instance -- Proj_ConC ) => Proj_ConC cs (Proxy Int) where proj_conC _ (TyConst q :$ TyConst c) | Just Refl <- eq_skind (kind_of_const c) SKiType - , Just Refl <- proj_const c (Proxy::Proxy Int) + , Just Refl <- proj_const c (Proxy @Int) = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Bounded) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Enum) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Eq) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Integral) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Num) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Ord) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Real) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Show) -> Just Con + _ | Just Refl <- proj_const q (Proxy @Bounded) -> Just Con + | Just Refl <- proj_const q (Proxy @Enum) -> Just Con + | Just Refl <- proj_const q (Proxy @Eq) -> Just Con + | Just Refl <- proj_const q (Proxy @Integral) -> Just Con + | Just Refl <- proj_const q (Proxy @Num) -> Just Con + | Just Refl <- proj_const q (Proxy @Ord) -> Just Con + | Just Refl <- proj_const q (Proxy @Real) -> Just Con + | Just Refl <- proj_const q (Proxy @Show) -> Just Con _ -> Nothing proj_conC _c _q = Nothing data instance TokenT meta (ts::[*]) (Proxy Int) @@ -80,3 +79,5 @@ instance -- CompileI compileI tok _ctx k = case tok of Token_Term_Int i -> k (ty @Int) $ TermO $ \_c -> int i +instance TokenizeT meta ts (Proxy Int) +instance Gram_Term_AtomsT meta ts (Proxy Int) g diff --git a/Language/Symantic/Compiling/Integer.hs b/Language/Symantic/Compiling/Integer.hs index 80cb4ee..2d2d136 100644 --- a/Language/Symantic/Compiling/Integer.hs +++ b/Language/Symantic/Compiling/Integer.hs @@ -4,12 +4,13 @@ -- | Symantic for 'Integer'. module Language.Symantic.Compiling.Integer where +import Control.Applicative (Alternative(..)) import Data.Proxy -import Data.Text (Text) import qualified Data.Text as Text import Data.Type.Equality ((:~:)(Refl)) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term import Language.Symantic.Interpreting @@ -42,10 +43,10 @@ instance (Sym_Integer r1, Sym_Integer r2) => Sym_Integer (DupI r1 r2) where integer x = integer x `DupI` integer x instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Integer - ) => Read_TypeNameR Text cs (Proxy Integer ': rs) where - read_typenameR _cs "Integer" k = k (ty @Integer) + ) => Read_TypeNameR Type_Name cs (Proxy Integer ': rs) where + read_typenameR _cs (Type_Name "Integer") k = k (ty @Integer) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Integer ': cs) where show_const ConstZ{} = "Integer" @@ -57,15 +58,15 @@ instance -- Proj_ConC ) => Proj_ConC cs (Proxy Integer) where proj_conC _ (TyConst q :$ TyConst c) | Just Refl <- eq_skind (kind_of_const c) SKiType - , Just Refl <- proj_const c (Proxy::Proxy Integer) + , Just Refl <- proj_const c (Proxy @Integer) = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Enum) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Eq) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Integral) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Num) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Ord) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Real) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Show) -> Just Con + _ | Just Refl <- proj_const q (Proxy @Enum) -> Just Con + | Just Refl <- proj_const q (Proxy @Eq) -> Just Con + | Just Refl <- proj_const q (Proxy @Integral) -> Just Con + | Just Refl <- proj_const q (Proxy @Num) -> Just Con + | Just Refl <- proj_const q (Proxy @Ord) -> Just Con + | Just Refl <- proj_const q (Proxy @Real) -> Just Con + | Just Refl <- proj_const q (Proxy @Show) -> Just Con _ -> Nothing proj_conC _c _q = Nothing data instance TokenT meta (ts::[*]) (Proxy Integer) @@ -78,3 +79,21 @@ instance -- CompileI compileI tok _ctx k = case tok of Token_Term_Integer i -> k (ty @Integer) $ TermO $ \_c -> integer i +instance -- TokenizeT + -- Inj_Token meta ts Integer => + TokenizeT meta ts (Proxy Integer) +instance -- Gram_Term_AtomsT + ( Alt g + , Alter g + , Alternative g + , Gram_Rule g + , Gram_Lexer g + , Gram_Meta meta g + , Inj_Token meta ts Integer + ) => Gram_Term_AtomsT meta ts (Proxy Integer) g where + term_atomsT _t = + [ rule "term_integer" $ + lexeme $ metaG $ + (\i meta -> ProTok $ inj_etoken meta $ Token_Term_Integer $ read i) + <$> some (choice $ char <$> ['0'..'9']) + ] diff --git a/Language/Symantic/Compiling/Integral.hs b/Language/Symantic/Compiling/Integral.hs index b288a10..5ae5b56 100644 --- a/Language/Symantic/Compiling/Integral.hs +++ b/Language/Symantic/Compiling/Integral.hs @@ -5,15 +5,18 @@ module Language.Symantic.Compiling.Integral where import Control.Monad (liftM, liftM2) +import qualified Data.Function as Fun import Data.Proxy -import Data.Text (Text) +import Data.Type.Equality ((:~:)(Refl)) import qualified Prelude -import Prelude hiding (Integral(..)) import Prelude (Integral) +import Prelude hiding (Integral(..)) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling.Lambda import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans @@ -63,10 +66,10 @@ instance Sym_Integral HostI where divMod = liftM2 Prelude.divMod toInteger = liftM Prelude.toInteger instance Sym_Integral TextI where - quot = textI_infix "`quot`" (Precedence 7) - div = textI_infix "`div`" (Precedence 7) - rem = textI_infix "`rem`" (Precedence 7) - mod = textI_infix "`mod`" (Precedence 7) + quot = textI_infix "`quot`" (infixL 7) + div = textI_infix "`div`" (infixL 7) + rem = textI_infix "`rem`" (infixL 7) + mod = textI_infix "`mod`" (infixL 7) quotRem = textI2 "quotRem" divMod = textI2 "divMod" toInteger = textI1 "toInteger" @@ -80,10 +83,10 @@ instance (Sym_Integral r1, Sym_Integral r2) => Sym_Integral (DupI r1 r2) where toInteger = dupI1 (Proxy @Sym_Integral) toInteger instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Integral - ) => Read_TypeNameR Text cs (Proxy Integral ': rs) where - read_typenameR _cs "Integral" k = k (ty @Integral) + ) => Read_TypeNameR Type_Name cs (Proxy Integral ': rs) where + read_typenameR _cs (Type_Name "Integral") k = k (ty @Integral) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Integral ': cs) where show_const ConstZ{} = "Integral" @@ -91,29 +94,41 @@ instance Show_Const cs => Show_Const (Proxy Integral ': cs) where instance Proj_ConC cs (Proxy Integral) data instance TokenT meta (ts::[*]) (Proxy Integral) - = Token_Term_Integral_quot (EToken meta ts) - | Token_Term_Integral_rem (EToken meta ts) - | Token_Term_Integral_div (EToken meta ts) - | Token_Term_Integral_mod (EToken meta ts) - | Token_Term_Integral_quotRem (EToken meta ts) - | Token_Term_Integral_divMod (EToken meta ts) -deriving instance Eq_Token meta ts => Eq (TokenT meta ts (Proxy Integral)) -deriving instance Show_Token meta ts => Show (TokenT meta ts (Proxy Integral)) + = Token_Term_Integral_quot (EToken meta ts) + | Token_Term_Integral_rem (EToken meta ts) + | Token_Term_Integral_div (EToken meta ts) + | Token_Term_Integral_mod (EToken meta ts) + | Token_Term_Integral_quotRem (EToken meta ts) + | Token_Term_Integral_divMod (EToken meta ts) + | Token_Term_Integral_toInteger (EToken meta '[Proxy Token_Type]) +deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Integral)) +deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Integral)) instance -- CompileI - ( Inj_Const (Consts_of_Ifaces is) Integral + ( Read_TypeName Type_Name (Consts_of_Ifaces is) + , Inj_Const (Consts_of_Ifaces is) Integral , Inj_Const (Consts_of_Ifaces is) (->) , Inj_Const (Consts_of_Ifaces is) (,) + , Inj_Const (Consts_of_Ifaces is) Integer , Proj_Con (Consts_of_Ifaces is) , Compile is ) => CompileI is (Proxy Integral) where compileI tok ctx k = case tok of - Token_Term_Integral_quot tok_a -> op2_from tok_a quot - Token_Term_Integral_rem tok_a -> op2_from tok_a rem - Token_Term_Integral_div tok_a -> op2_from tok_a div - Token_Term_Integral_mod tok_a -> op2_from tok_a mod - Token_Term_Integral_quotRem tok_a -> op2t2_from tok_a quotRem - Token_Term_Integral_divMod tok_a -> op2t2_from tok_a divMod + Token_Term_Integral_quot tok_a -> op2_from tok_a quot + Token_Term_Integral_rem tok_a -> op2_from tok_a rem + Token_Term_Integral_div tok_a -> op2_from tok_a div + Token_Term_Integral_mod tok_a -> op2_from tok_a mod + Token_Term_Integral_quotRem tok_a -> op2t2_from tok_a quotRem + Token_Term_Integral_divMod tok_a -> op2t2_from tok_a divMod + Token_Term_Integral_toInteger tok_ty_a -> + -- toInteger :: Integral a => a -> Integer + compile_type tok_ty_a $ \(ty_a::Type (Consts_of_Ifaces is) a) -> + check_kind + (At Nothing SKiType) + (At (Just tok_ty_a) $ kind_of ty_a) $ \Refl -> + check_con (At (Just tok_ty_a) (ty @Integral :$ ty_a)) $ \Con -> + k (ty_a ~> ty @Integer) $ TermO $ + Fun.const $ lam toInteger where op2_from tok_a (op::forall term a. (Sym_Integral term, Integral a) @@ -135,3 +150,22 @@ instance -- CompileI check_con (At (Just tok_a) (ty @Integral :$ ty_a)) $ \Con -> k (ty_a ~> (ty @(,) :$ ty_a) :$ ty_a) $ TermO $ \c -> lam $ \y -> op (x c) y +instance -- TokenizeT + Inj_Token meta ts Integral => + TokenizeT meta ts (Proxy Integral) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ tokenize1 "quot" (infixL 7) Token_Term_Integral_quot + , tokenize1 "rem" (infixL 7) Token_Term_Integral_rem + , tokenize1 "div" (infixL 7) Token_Term_Integral_div + , tokenize1 "mod" (infixL 7) Token_Term_Integral_mod + , tokenize1 "quotRem" infixN5 Token_Term_Integral_quotRem + , tokenize1 "divMod" infixN5 Token_Term_Integral_divMod + , (Term_Name "toInteger",) Term_ProTok + { term_protok = \meta -> ProTokPi $ \a -> + ProTok $ inj_etoken meta $ Token_Term_Integral_toInteger a + , term_fixity = infixN5 + } + ] + } +instance Gram_Term_AtomsT meta ts (Proxy Integral) g diff --git a/Language/Symantic/Compiling/Lambda.hs b/Language/Symantic/Compiling/Lambda.hs new file mode 100644 index 0000000..544892c --- /dev/null +++ b/Language/Symantic/Compiling/Lambda.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Language.Symantic.Compiling.Lambda where + +import qualified Data.Function as Fun +import qualified Data.Kind as Kind +import Data.Monoid ((<>)) +import Data.Proxy (Proxy(..)) +import qualified Data.Text as Text +import Data.Type.Equality ((:~:)(..)) +import Prelude hiding ((^)) + +import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar +import Language.Symantic.Typing +import Language.Symantic.Interpreting +import Language.Symantic.Transforming.Trans + +import Language.Symantic.Compiling.Term + +-- * Class 'Sym_Lambda' +class Sym_Lambda term where + -- | /Lambda abstraction/. + lam :: (term arg -> term res) -> term (arg -> res) + default lam :: Trans t term => (t term arg -> t term res) -> t term (arg -> res) + lam f = trans_lift $ lam $ trans_apply . f . trans_lift + + -- | /Lambda application/. + (.$) :: term (arg -> res) -> term arg -> term res + default (.$) :: Trans t term => t term (arg -> res) -> t term arg -> t term res + (.$) f x = trans_lift (trans_apply f .$ trans_apply x) + + -- | Convenient 'lam' and '.$' wrapper. + let_ :: term var -> (term var -> term res) -> term res + let_ x y = lam y .$ x + + id :: term a -> term a + id a = lam Fun.id .$ a + + const :: term a -> term b -> term a + const a b = (lam (lam . Fun.const) .$ a) .$ b + + -- | /Lambda composition/. + (^) :: term (b -> c) -> term (a -> b) -> term (a -> c) + (^) f g = lam $ \a -> f .$ (g .$ a) + + flip :: term (a -> b -> c) -> term (b -> a -> c) + flip f = lam $ \b -> lam $ \a -> (f .$ a) .$ b + +infixr 0 .$ +infixr 9 ^ + +type instance Sym_of_Iface (Proxy (->)) = Sym_Lambda +type instance Consts_of_Iface (Proxy (->)) = Proxy (->) ': Consts_imported_by (->) +type instance Consts_imported_by (->) = + [ Proxy Applicative + , Proxy Functor + , Proxy Monad + , Proxy Monoid + ] + +instance Sym_Lambda HostI where + lam f = HostI (unHostI . f . HostI) + (.$) = (<*>) +instance Sym_Lambda TextI where + lam f = TextI $ \po v -> + let x = "x" <> Text.pack (show v) in + infix_paren po op $ + "\\" <> x <> " -> " <> + unTextI (f (TextI $ \_po _v -> x)) (op, L) (succ v) + where op = infixN 1 + -- (.$) = textI_infix "$" (Precedence 0) + (.$) (TextI a1) (TextI a2) = TextI $ \po v -> + infix_paren po op $ + a1 (op, L) v <> " " <> a2 (op, R) v + where op = infixN 10 + let_ e in_ = + TextI $ \po v -> + let x = "x" <> Text.pack (show v) in + infix_paren po op $ + "let" <> " " <> x <> " = " + <> unTextI e (infixN 0, L) (succ v) <> " in " + <> unTextI (in_ (TextI $ \_po _v -> x)) (op, L) (succ v) + where op = infixN 2 + (^) = textI_infix "." (infixR 9) + id = textI1 "id" + const = textI2 "const" + flip = textI1 "flip" +instance (Sym_Lambda r1, Sym_Lambda r2) => Sym_Lambda (DupI r1 r2) where + lam f = dupI_1 lam_f `DupI` dupI_2 lam_f + where lam_f = lam f + (.$) = dupI2 (Proxy @Sym_Lambda) (.$) + +instance + ( Read_TypeNameR Type_Name cs rs + , Inj_Const cs (->) + ) => Read_TypeNameR Type_Name cs (Proxy (->) ': rs) where + read_typenameR _cs (Type_Name "(->)") k = k (ty @(->)) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k +instance Show_Const cs => Show_Const (Proxy (->) ': cs) where + show_const ConstZ{} = "(->)" + show_const (ConstS c) = show_const c + +instance -- Proj_ConC (->) + ( Proj_Const cs (->) + , Proj_Consts cs (Consts_imported_by (->)) + , Proj_Con cs + ) => Proj_ConC cs (Proxy (->)) where + proj_conC _ (TyConst q :$ (TyConst c :$ _r)) + | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType `SKiArrow` SKiType) + , Just Refl <- proj_const c (Proxy @(->)) + = case () of + _ | Just Refl <- proj_const q (Proxy @Functor) -> Just Con + | Just Refl <- proj_const q (Proxy @Applicative) -> Just Con + | Just Refl <- proj_const q (Proxy @Monad) -> Just Con + _ -> Nothing + proj_conC _ (t@(TyConst q) :$ (TyConst c :$ _a :$ b)) + | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType `SKiArrow` SKiType) + , Just Refl <- proj_const c (Proxy @(->)) + = case () of + _ | Just Refl <- proj_const q (Proxy @Monoid) + , Just Con <- proj_con (t :$ b) -> Just Con + _ -> Nothing + proj_conC _c _q = Nothing +deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy (->))) +deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy (->))) +instance -- CompileI (->) + ( Inj_Const (Consts_of_Ifaces is) (->) + , Read_TypeName Type_Name (Consts_of_Ifaces is) + , Compile is + ) => CompileI is (Proxy (->)) where + compileI tok ctx k = + case tok of + Token_Term_Abst name_arg tok_ty_arg tok_body -> + compile_type tok_ty_arg $ \(ty_arg::Type (Consts_of_Ifaces is) h) -> + check_kind + (At Nothing SKiType) + (At (Just $ tok_ty_arg) $ kind_of ty_arg) $ \Refl -> + compileO tok_body + (LamCtx_TypeS name_arg ty_arg ctx) $ + \ty_res (TermO res) -> + k (ty_arg ~> ty_res) $ TermO $ + \c -> lam $ \arg -> + res (arg `LamCtx_TermS` c) + Token_Term_App tok_lam tok_arg_actual -> + compileO tok_lam ctx $ \ty_lam (TermO lam_) -> + compileO tok_arg_actual ctx $ \ty_arg_actual (TermO arg_actual) -> + check_type2 (ty @(->)) (At (Just tok_lam) ty_lam) $ \Refl ty_arg ty_res -> + check_type + (At (Just tok_lam) ty_arg) + (At (Just tok_arg_actual) ty_arg_actual) $ \Refl -> + k ty_res $ TermO $ + \c -> lam_ c .$ arg_actual c + Token_Term_Let name tok_bound tok_body -> + compileO tok_bound ctx $ \ty_bound (TermO bound) -> + compileO tok_body (LamCtx_TypeS name ty_bound ctx) $ + \ty_res (TermO res) -> + k ty_res $ TermO $ + \c -> let_ (bound c) $ \arg -> res (arg `LamCtx_TermS` c) + Token_Term_Var nam -> go nam ctx k + where + go :: forall meta lc ret ls rs. + Term_Name + -> LamCtx_Type is Term_Name lc + -> ( forall h. + Type (Consts_of_Ifaces is) (h::Kind.Type) + -> TermO lc h is ls rs + -> Either (Error_Term meta is) ret ) + -> Either (Error_Term meta is) ret + go name lc k' = + case lc of + LamCtx_TypeZ -> Left $ Error_Term_unbound name + LamCtx_TypeS n typ _ | n == name -> + k' typ $ TermO $ \(te `LamCtx_TermS` _) -> te + LamCtx_TypeS _n _ty lc' -> + go name lc' $ \typ (TermO te::TermO lc' h is '[] is) -> + k' typ $ TermO $ \(_ `LamCtx_TermS` c) -> te c + Token_Term_Compose tok_f tok_g -> + -- (.) :: (b -> c) -> (a -> b) -> a -> c + compileO tok_f ctx $ \ty_f (TermO f) -> + compileO tok_g ctx $ \ty_g (TermO g) -> + check_type2 (ty @(->)) (At (Just tok_f) ty_f) $ \Refl ty_f_b ty_c -> + check_type2 (ty @(->)) (At (Just tok_g) ty_g) $ \Refl ty_a ty_g_b -> + check_type + (At (Just tok_f) ty_f_b) + (At (Just tok_g) ty_g_b) $ \Refl -> + k (ty_a ~> ty_c) $ TermO $ + \c -> (^) (f c) (g c) +instance + Inj_Token meta ts (->) => + TokenizeT meta ts (Proxy (->)) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ tokenize2 "." (infixR 9) Token_Term_Compose + , tokenize2 "$" (infixR 0) Token_Term_App + ] + } +instance Gram_Term_AtomsT meta ts (Proxy (->)) g + +-- | The function 'Type' @(->)@, +-- with an infix notation more readable. +(~>) :: forall cs a b. Inj_Const cs (->) + => Type cs a -> Type cs b -> Type cs (a -> b) +(~>) a b = ty @(->) :$ a :$ b +infixr 5 ~> diff --git a/Language/Symantic/Compiling/List.hs b/Language/Symantic/Compiling/List.hs index e24da86..ab28bd0 100644 --- a/Language/Symantic/Compiling/List.hs +++ b/Language/Symantic/Compiling/List.hs @@ -4,38 +4,47 @@ -- | Symantic for '[]'. module Language.Symantic.Compiling.List where -import Control.Monad (liftM3) +import Control.Monad (liftM, liftM2, liftM3) import qualified Data.Foldable as Foldable import qualified Data.Function as Fun import qualified Data.Functor as Functor import qualified Data.List as List import Data.Monoid ((<>)) import Data.Proxy -import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Traversable as Traversable import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (zipWith) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling.Lambda import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans -- * Class 'Sym_List' class Sym_List term where - list_empty :: term [a] - zipWith :: term (a -> b -> c) -> term [a] -> term [b] -> term [c] - list :: [term a] -> term [a] + list_empty :: term [a] + list_singleton :: term a -> term [a] + (.:) :: term a -> term [a] -> term [a] + list :: [term a] -> term [a] + zipWith :: term (a -> b -> c) -> term [a] -> term [b] -> term [c] - default list_empty :: Trans t term => t term [a] - default zipWith :: Trans t term => t term (a -> b -> c) -> t term [a] -> t term [b] -> t term [c] - default list :: Trans t term => [t term a] -> t term [a] + default list_empty :: Trans t term => t term [a] + default list_singleton :: Trans t term => t term a -> t term [a] + default (.:) :: Trans t term => t term a -> t term [a] -> t term [a] + default list :: Trans t term => [t term a] -> t term [a] + default zipWith :: Trans t term => t term (a -> b -> c) -> t term [a] -> t term [b] -> t term [c] - list_empty = trans_lift list_empty - zipWith = trans_map3 zipWith - list l = trans_lift (list (trans_apply Functor.<$> l)) + list_empty = trans_lift list_empty + list_singleton = trans_map1 list_singleton + (.:) = trans_map2 (.:) + list l = trans_lift (list (trans_apply Functor.<$> l)) + zipWith = trans_map3 zipWith + +infixr 5 .: type instance Sym_of_Iface (Proxy []) = Sym_List type instance Consts_of_Iface (Proxy []) = Proxy [] ': Consts_imported_by [] @@ -53,17 +62,24 @@ type instance Consts_imported_by [] = ] instance Sym_List HostI where - list_empty = return [] - list = Traversable.sequence - zipWith = liftM3 List.zipWith + list_empty = return [] + list_singleton = liftM return + (.:) = liftM2 (:) + list = Traversable.sequence + zipWith = liftM3 List.zipWith instance Sym_List TextI where list_empty = TextI $ \_p _v -> "[]" - list l = TextI $ \_p v -> - let p' = precedence_Toplevel in - "[" <> Text.intercalate ", " ((\(TextI a) -> a p' v) Functor.<$> l) <> "]" + list_singleton a = textI_infix ":" op a list_empty + where op = infixR 5 + (.:) = textI_infix ":" (infixR 5) + list l = TextI $ \_po v -> + "[" <> Text.intercalate ", " ((\(TextI a) -> a op v) Functor.<$> l) <> "]" + where op = (infixN0, L) zipWith = textI3 "zipWith" instance (Sym_List r1, Sym_List r2) => Sym_List (DupI r1 r2) where list_empty = dupI0 (Proxy @Sym_List) list_empty + list_singleton = dupI1 (Proxy @Sym_List) list_singleton + (.:) = dupI2 (Proxy @Sym_List) (.:) list l = let (l1, l2) = Foldable.foldr (\(x1 `DupI` x2) (xs1, xs2) -> @@ -72,10 +88,10 @@ instance (Sym_List r1, Sym_List r2) => Sym_List (DupI r1 r2) where zipWith = dupI3 (Proxy @Sym_List) zipWith instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs [] - ) => Read_TypeNameR Text cs (Proxy [] ': rs) where - read_typenameR _cs "[]" k = k (ty @[]) + ) => Read_TypeNameR Type_Name cs (Proxy [] ': rs) where + read_typenameR _cs (Type_Name "[]") k = k (ty @[]) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy [] ': cs) where show_const ConstZ{} = "[]" @@ -91,35 +107,37 @@ instance -- Proj_ConC ) => Proj_ConC cs (Proxy []) where proj_conC _ (TyConst q :$ TyConst c) | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy []) + , Just Refl <- proj_const c (Proxy @[]) = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Applicative) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Foldable) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Functor) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Monad) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Traversable) -> Just Con + _ | Just Refl <- proj_const q (Proxy @Applicative) -> Just Con + | Just Refl <- proj_const q (Proxy @Foldable) -> Just Con + | Just Refl <- proj_const q (Proxy @Functor) -> Just Con + | Just Refl <- proj_const q (Proxy @Monad) -> Just Con + | Just Refl <- proj_const q (Proxy @Traversable) -> Just Con _ -> Nothing proj_conC _ (t@(TyConst q) :$ (TyConst c :$ a)) | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy []) + , Just Refl <- proj_const c (Proxy @[]) = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Eq) + _ | Just Refl <- proj_const q (Proxy @Eq) , Just Con <- proj_con (t :$ a) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Monoid) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Show) + | Just Refl <- proj_const q (Proxy @Monoid) -> Just Con + | Just Refl <- proj_const q (Proxy @Show) , Just Con <- proj_con (t :$ a) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Ord) + | Just Refl <- proj_const q (Proxy @Ord) , Just Con <- proj_con (t :$ a) -> Just Con _ -> Nothing proj_conC _c _q = Nothing data instance TokenT meta (ts::[*]) (Proxy []) - = Token_Term_List_empty (EToken meta '[Proxy Token_Type]) - | Token_Term_List_list (EToken meta '[Proxy Token_Type]) [EToken meta ts] - | Token_Term_List_zipWith (EToken meta ts) + = Token_Term_List_empty (EToken meta '[Proxy Token_Type]) + | Token_Term_List_cons (EToken meta ts) (EToken meta ts) + | Token_Term_List_singleton (EToken meta ts) + | Token_Term_List_list (EToken meta '[Proxy Token_Type]) [EToken meta ts] + | Token_Term_List_zipWith (EToken meta ts) deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy [])) deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy [])) instance -- CompileI - ( Read_TypeName Name_LamVar (Consts_of_Ifaces is) + ( Read_TypeName Type_Name (Consts_of_Ifaces is) , Inj_Const (Consts_of_Ifaces is) [] , Inj_Const (Consts_of_Ifaces is) (->) , Compile is @@ -138,6 +156,21 @@ instance -- CompileI (At (Just tok_ty_a) $ kind_of ty_a) $ \Refl -> k (ty @[] :$ ty_a) $ TermO $ Fun.const list_empty + Token_Term_List_singleton tok_a -> + -- [a] :: [a] + compileO tok_a ctx $ \ty_a (TermO a) -> + check_kind + (At Nothing SKiType) + (At (Just tok_a) $ kind_of ty_a) $ \Refl -> + k (ty @[] :$ ty_a) $ TermO $ + \c -> list_singleton (a c) + Token_Term_List_cons tok_a tok_as -> + compileO tok_a ctx $ \ty_a (TermO a) -> + compileO tok_as ctx $ \ty_as (TermO as) -> + check_type1 (ty @[]) (At (Just tok_as) ty_as) $ \Refl ty_as_a -> + check_type (At (Just tok_a) ty_a) (At (Just tok_as) ty_as_a) $ \Refl -> + k ty_as $ TermO $ + \c -> a c .: as c Token_Term_List_list tok_ty_a tok_as -> compile_type tok_ty_a $ \(ty_a::Type (Consts_of_Ifaces is) a) -> check_kind @@ -166,3 +199,43 @@ instance -- CompileI ~> ty @[] :$ ty_a2b2c_b2c_b ~> ty @[] :$ ty_a2b2c_b2c_c ) $ TermO $ \c -> lam $ lam . zipWith (a2b2c c) +instance -- TokenizeT + Inj_Token meta ts [] => + TokenizeT meta ts (Proxy []) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ (Term_Name "[]",) $ Term_ProTok + { term_protok = \meta -> ProTokPi $ \a -> + ProTok $ inj_etoken meta $ Token_Term_List_empty a + , term_fixity = infixN5 + } + , tokenize2 ":" (infixR 5) Token_Term_List_cons + , tokenize1 "zipWith" infixN0 Token_Term_List_zipWith + ] + } +instance + ( App g + , Gram_Rule g + , Gram_Lexer g + , Gram_Term ts meta g + , Inj_Token meta ts (->) + , Inj_Token meta ts [] + ) => Gram_Term_AtomsT meta ts (Proxy []) g where + term_atomsT _t = + [ rule "term_list" $ + ProTok <$> between (symbol "[") (symbol "]") listG + , rule "term_list_empty" $ + metaG $ + (\meta -> ProTokPi $ \a -> ProTok $ inj_etoken meta $ Token_Term_List_empty a) + <$ symbol "[" + <* symbol "]" + ] + where + listG :: CF g (EToken meta ts) + listG = rule "list" $ + metaG $ + (\a mb meta -> inj_etoken meta $ case mb of + Just b -> Token_Term_List_cons a b + Nothing -> Token_Term_List_singleton a) + <$> termG + <*> option Nothing (Just <$ symbol "," <*> listG) diff --git a/Language/Symantic/Compiling/Map.hs b/Language/Symantic/Compiling/Map.hs index 3cd504a..d35a7a9 100644 --- a/Language/Symantic/Compiling/Map.hs +++ b/Language/Symantic/Compiling/Map.hs @@ -8,13 +8,14 @@ import Control.Monad (liftM, liftM2, liftM3) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Proxy -import Data.Text (Text) import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (either) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling.Lambda import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans @@ -100,10 +101,10 @@ instance (Sym_Map r1, Sym_Map r2) => Sym_Map (DupI r1 r2) where map_foldrWithKey = dupI3 (Proxy @Sym_Map) map_foldrWithKey instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Map - ) => Read_TypeNameR Text cs (Proxy Map ': rs) where - read_typenameR _cs "Map" k = k (ty @Map) + ) => Read_TypeNameR Type_Name cs (Proxy Map ': rs) where + read_typenameR _cs (Type_Name "Map") k = k (ty @Map) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Map ': cs) where show_const ConstZ{} = "Map" @@ -117,25 +118,25 @@ instance -- Proj_ConC ) => Proj_ConC cs (Proxy Map) where proj_conC _ (TyConst q :$ (TyConst c :$ _k)) | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy Map) + , Just Refl <- proj_const c (Proxy @Map) = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Functor) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Foldable) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Traversable) -> Just Con + _ | Just Refl <- proj_const q (Proxy @Functor) -> Just Con + | Just Refl <- proj_const q (Proxy @Foldable) -> Just Con + | Just Refl <- proj_const q (Proxy @Traversable) -> Just Con _ -> Nothing proj_conC _ (t@(TyConst q) :$ (TyConst c :$ k :$ a)) | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy Map) + , Just Refl <- proj_const c (Proxy @Map) = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Eq) + _ | Just Refl <- proj_const q (Proxy @Eq) , Just Con <- proj_con (t :$ k) , Just Con <- proj_con (t :$ a) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Ord) + | Just Refl <- proj_const q (Proxy @Ord) , Just Con <- proj_con (t :$ k) , Just Con <- proj_con (t :$ a) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Monoid) + | Just Refl <- proj_const q (Proxy @Monoid) , Just Con <- proj_con (ty @Ord :$ k) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Show) + | Just Refl <- proj_const q (Proxy @Show) , Just Con <- proj_con (t :$ k) , Just Con <- proj_con (t :$ a) -> Just Con _ -> Nothing @@ -249,3 +250,20 @@ instance -- CompileI (At (Just tok_f) ty_b') $ \Refl -> k (ty_b ~> (ty @Map :$ ty_k) :$ ty_a ~> ty_b) $ TermO $ \c -> lam $ \b -> lam $ \m -> map_foldrWithKey (f c) b m +instance -- TokenizeT + Inj_Token meta ts Map => + TokenizeT meta ts (Proxy Map) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [Mod_Name "Map"] + [ tokenize1 "fromList" infixN5 Token_Term_Map_fromList + , tokenize1 "mapWithKey" infixN5 Token_Term_Map_mapWithKey + , tokenize2 "lookup" infixN5 Token_Term_Map_lookup + , tokenize1 "keys" infixN5 Token_Term_Map_keys + , tokenize2 "member" infixN5 Token_Term_Map_member + , tokenize2 "insert" infixN5 Token_Term_Map_insert + , tokenize2 "delete" infixN5 Token_Term_Map_delete + , tokenize2 "difference" infixN5 Token_Term_Map_difference + , tokenize1 "foldrWithKey" infixN5 Token_Term_Map_foldrWithKey + ] + } +instance Gram_Term_AtomsT meta ts (Proxy Map) g diff --git a/Language/Symantic/Compiling/Map/Test.hs b/Language/Symantic/Compiling/Map/Test.hs index 1b72151..d2ce8d2 100644 --- a/Language/Symantic/Compiling/Map/Test.hs +++ b/Language/Symantic/Compiling/Map/Test.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -{-# OPTIONS_GHC -O0 #-} -- speedup compiling… module Compiling.Map.Test where import Test.Tasty @@ -10,119 +6,39 @@ import Test.Tasty import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Proxy (Proxy(..)) -import Data.Text (Text) -import qualified Data.Text as Text import Prelude hiding (zipWith) -import Language.Symantic.Parsing import Language.Symantic.Typing -import Language.Symantic.Compiling import Compiling.Term.Test import Compiling.Bool.Test () -import Compiling.Foldable.Test () -import Parsing.Test --- * Terms -e1 = map_fromList $ zipWith (lam (lam . tuple2)) - (list $ int Prelude.<$> [1..5]) - (list $ (text . Text.singleton) Prelude.<$> ['a'..'e']) - --- * Tests type Ifaces = [ Proxy (->) , Proxy [] , Proxy Int + , Proxy Integer , Proxy Map - , Proxy Text + , Proxy Char , Proxy (,) , Proxy Num , Proxy Monoid ] (==>) = test_compile (Proxy::Proxy Ifaces) -instance - ( Inj_Token (Syntax Text) ts Map - , Tokenize (Syntax Text) (Syntax Text) ts ) => - TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Map) where - tokenizeT _t (Syntax "Map.fromList" (ast_f : as)) = Just $ do - f <- tokenize ast_f - Right $ (as,) $ EToken $ inj_token (Syntax "Map.fromList" [ast_f]) $ - Token_Term_Map_fromList f - tokenizeT _t (Syntax "Map.foldrWithKey" (ast_f : as)) = Just $ do - f <- tokenize ast_f - Right $ (as,) $ EToken $ inj_token (Syntax "Map.foldrWithKey" [ast_f]) $ - Token_Term_Map_foldrWithKey f - tokenizeT _t _sy = Nothing - tests :: TestTree tests = testGroup "Map" - [ Syntax "Map.fromList" - [ Syntax "zipWith" - [ syLam "x" (sy @Int) $ - syLam "y" (sy @Text) $ - Syntax "(,)" - [ syVar "x" - , syVar "y" - ] - , Syntax "list" - [ sy @Int - , syLit (1::Int) - , syLit (2::Int) - , syLit (3::Int) - ] - , Syntax "list" - [ sy @Text - , syLit ("a"::Text) - , syLit ("b"::Text) - , syLit ("c"::Text) - ] - ] - ] ==> Right - ( (ty @Map :$ ty @Int) :$ ty @Text - , Map.fromList [(1, "a"), (2, "b"), (3, "c")] - , "Map.fromList (((\\x0 -> (\\x1 -> zipWith (\\x2 -> (\\x3 -> (x2, x3))) x0 x1)) [1, 2, 3]) [\"a\", \"b\", \"c\"])" ) - , Syntax "Map.foldrWithKey" - [ syLam "k" (sy @Int) $ - syLam "v" (sy @Text) $ - syLam "a" (sy @(,) [sy @Int, sy @Text]) $ - sy @(,) - [ Syntax "(+)" - [ syVar "k" - , Syntax "fst" [ syVar "a" ] - ] - , Syntax "mappend" - [ syVar "v" - , Syntax "snd" [ syVar "a" ] - ] - ] - , sy @(,) - [ syLit (0::Int) - , syLit (""::Text) - ] - , Syntax "Map.fromList" - [ Syntax "zipWith" - [ syLam "x" (sy @Int) $ - syLam "y" (sy @Text) $ - sy @(,) - [ syVar "x" - , syVar "y" - ] - , Syntax "list" - [ sy @Int - , syLit (1::Int) - , syLit (2::Int) - , syLit (3::Int) - ] - , Syntax "list" - [ sy @Text - , syLit ("a"::Text) - , syLit ("b"::Text) - , syLit ("c"::Text) - ] - ] - ] - ] ==> Right - ( (ty @(,) :$ ty @Int) :$ ty @Text + [ "Map.fromList (zipWith (\\(x:Integer) (y:Char) -> (x, y)) [1, 2, 3] ['a', 'b', 'c'])" ==> Right + ( (ty @Map :$ ty @Integer) :$ ty @Char + , Map.fromList [(1, 'a'), (2, 'b'), (3, 'c')] + , "Map.fromList (((\\x0 -> (\\x1 -> zipWith (\\x2 -> (\\x3 -> (x2, x3))) x0 x1)) (1 : 2 : 3 : [])) ('a' : 'b' : 'c' : []))" ) + , concat + [ "Map.foldrWithKey" + , " (\\(k:Integer) (v:Char) (acc:(Integer,[Char])) ->" + , " (k + fst acc, v : snd acc))" + , " (0, [] @Char)" + , " (Map.fromList (zipWith (\\(x:Integer) (y:Char) -> (x,y)) [1, 2, 3] ['a', 'b', 'c']))" + ] ==> Right + ( (ty @(,) :$ ty @Integer) :$ (ty @[] :$ ty @Char) , (6, "abc") - , "((\\x0 -> (\\x1 -> Map.foldrWithKey (\\x2 -> (\\x3 -> (\\x4 -> ((\\x5 -> x2 + x5) (fst x4), (\\x5 -> mappend x3 x5) (snd x4))))) x0 x1)) (0, \"\")) (Map.fromList (((\\x0 -> (\\x1 -> zipWith (\\x2 -> (\\x3 -> (x2, x3))) x0 x1)) [1, 2, 3]) [\"a\", \"b\", \"c\"]))" ) + , "((\\x0 -> (\\x1 -> Map.foldrWithKey (\\x2 -> (\\x3 -> (\\x4 -> ((\\x5 -> x2 + x5) (fst x4), x3 : snd x4)))) x0 x1)) (0, [])) (Map.fromList (((\\x0 -> (\\x1 -> zipWith (\\x2 -> (\\x3 -> (x2, x3))) x0 x1)) (1 : 2 : 3 : [])) ('a' : 'b' : 'c' : [])))" ) ] diff --git a/Language/Symantic/Compiling/Maybe.hs b/Language/Symantic/Compiling/Maybe.hs index 325a15b..72b5965 100644 --- a/Language/Symantic/Compiling/Maybe.hs +++ b/Language/Symantic/Compiling/Maybe.hs @@ -8,13 +8,14 @@ import Control.Monad import qualified Data.Function as Fun import qualified Data.Maybe as Maybe import Data.Proxy -import Data.Text (Text) import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (maybe) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling.Lambda import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans @@ -59,10 +60,10 @@ instance (Sym_Maybe r1, Sym_Maybe r2) => Sym_Maybe (DupI r1 r2) where maybe = dupI3 (Proxy @Sym_Maybe) maybe instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Maybe - ) => Read_TypeNameR Text cs (Proxy Maybe ': rs) where - read_typenameR _cs "Maybe" k = k (ty @Maybe) + ) => Read_TypeNameR Type_Name cs (Proxy Maybe ': rs) where + read_typenameR _cs (Type_Name "Maybe") k = k (ty @Maybe) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Maybe ': cs) where show_const ConstZ{} = "Maybe" @@ -75,23 +76,23 @@ instance -- Proj_ConC ) => Proj_ConC cs (Proxy Maybe) where proj_conC _ (TyConst q :$ TyConst c) | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy Maybe) + , Just Refl <- proj_const c (Proxy @Maybe) = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Applicative) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Foldable) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Functor) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Monad) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Traversable) -> Just Con + _ | Just Refl <- proj_const q (Proxy @Applicative) -> Just Con + | Just Refl <- proj_const q (Proxy @Foldable) -> Just Con + | Just Refl <- proj_const q (Proxy @Functor) -> Just Con + | Just Refl <- proj_const q (Proxy @Monad) -> Just Con + | Just Refl <- proj_const q (Proxy @Traversable) -> Just Con _ -> Nothing proj_conC _ (t@(TyConst q) :$ (TyConst c :$ a)) | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy Maybe) + , Just Refl <- proj_const c (Proxy @Maybe) = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Eq) + _ | Just Refl <- proj_const q (Proxy @Eq) , Just Con <- proj_con (t :$ a) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Monoid) + | Just Refl <- proj_const q (Proxy @Monoid) , Just Con <- proj_con (t :$ a) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Show) + | Just Refl <- proj_const q (Proxy @Show) , Just Con <- proj_con (t :$ a) -> Just Con _ -> Nothing proj_conC _c _q = Nothing @@ -102,7 +103,7 @@ data instance TokenT meta (ts::[*]) (Proxy Maybe) deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Maybe)) deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Maybe)) instance -- CompileI - ( Read_TypeName Name_LamVar (Consts_of_Ifaces is) + ( Read_TypeName Type_Name (Consts_of_Ifaces is) , Inj_Const (Consts_of_Ifaces is) Maybe , Inj_Const (Consts_of_Ifaces is) (->) , Compile is @@ -132,3 +133,17 @@ instance -- CompileI (At (Just tok_b) ty_b) $ \Refl -> k (ty @Maybe :$ ty_a2b_a ~> ty_b) $ TermO $ \c -> lam $ maybe (b c) (a2b c) +instance + Inj_Token meta ts Maybe => + TokenizeT meta ts (Proxy Maybe) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ (Term_Name "Nothing",) Term_ProTok + { term_protok = \meta -> ProTokPi $ \a -> + ProTok $ inj_etoken meta $ Token_Term_Maybe_Nothing a + , term_fixity = infixN5 + } + , tokenize1 "Just" infixN5 Token_Term_Maybe_Just + ] + } +instance Gram_Term_AtomsT meta ts (Proxy Maybe) g diff --git a/Language/Symantic/Compiling/Monad.hs b/Language/Symantic/Compiling/Monad.hs index 86d5b26..88b90c9 100644 --- a/Language/Symantic/Compiling/Monad.hs +++ b/Language/Symantic/Compiling/Monad.hs @@ -5,13 +5,12 @@ module Language.Symantic.Compiling.Monad where import Control.Monad (Monad) import qualified Control.Monad as Monad -import Data.Monoid ((<>)) import Data.Proxy -import Data.Text (Text) import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (Monad(..)) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term import Language.Symantic.Compiling.Applicative (Sym_Applicative) @@ -22,17 +21,21 @@ import Language.Symantic.Transforming.Trans class Sym_Applicative term => Sym_Monad term where return :: Monad m => term a -> term (m a) (>>=) :: Monad m => term (m a) -> term (a -> m b) -> term (m b) + join :: Monad m => term (m (m a)) -> term (m a) when :: Applicative f => term Bool -> term (f ()) -> term (f ()) default return :: (Trans t term, Monad m) => t term a -> t term (m a) default (>>=) :: (Trans t term, Monad m) => t term (m a) -> t term (a -> m b) -> t term (m b) + default join :: (Trans t term, Monad m) + => t term (m (m a)) -> t term (m a) default when :: (Trans t term, Applicative f) => t term Bool -> t term (f ()) -> t term (f ()) return = trans_map1 return (>>=) = trans_map2 (>>=) + join = trans_map1 join when = trans_map2 when infixl 1 >>= @@ -46,28 +49,26 @@ type instance Consts_imported_by Monad = ] instance Sym_Monad HostI where - return = Monad.liftM Monad.return + return = Monad.liftM Monad.return (>>=) = Monad.liftM2 (Monad.>>=) + join = Monad.liftM Monad.join when = Monad.liftM2 Monad.when instance Sym_Monad TextI where return = textI1 "return" - (>>=) = textI_infix ">>=" (Precedence 1) - when (TextI cond) (TextI ok) = - TextI $ \p v -> - let p' = Precedence 2 in - paren p p' $ - "when " <> cond p' v <> - " " <> ok p' v + (>>=) = textI_infix ">>=" (infixL 1) + join = textI1 "join" + when = textI2 "when" instance (Sym_Monad r1, Sym_Monad r2) => Sym_Monad (DupI r1 r2) where return = dupI1 (Proxy @Sym_Monad) return (>>=) = dupI2 (Proxy @Sym_Monad) (>>=) + join = dupI1 (Proxy @Sym_Monad) join when = dupI2 (Proxy @Sym_Monad) when instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Monad - ) => Read_TypeNameR Text cs (Proxy Monad ': rs) where - read_typenameR _cs "Monad" k = k (ty @Monad) + ) => Read_TypeNameR Type_Name cs (Proxy Monad ': rs) where + read_typenameR _cs (Type_Name "Monad") k = k (ty @Monad) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Monad ': cs) where show_const ConstZ{} = "Monad" @@ -77,11 +78,12 @@ instance Proj_ConC cs (Proxy Monad) data instance TokenT meta (ts::[*]) (Proxy Monad) = Token_Term_Monad_return (EToken meta '[Proxy Token_Type]) (EToken meta ts) | Token_Term_Monad_bind (EToken meta ts) (EToken meta ts) + | Token_Term_Monad_join (EToken meta ts) | Token_Term_Monad_when (EToken meta ts) (EToken meta ts) deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Monad)) deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Monad)) instance -- CompileI - ( Read_TypeName Name_LamVar (Consts_of_Ifaces is) + ( Read_TypeName Type_Name (Consts_of_Ifaces is) , Inj_Const (Consts_of_Ifaces is) Monad , Inj_Const (Consts_of_Ifaces is) (->) , Inj_Const (Consts_of_Ifaces is) () @@ -114,6 +116,13 @@ instance -- CompileI (At (Just tok_ma) ty_ma_a) $ \Refl -> k ty_a2mb_mb $ TermO $ \c -> (>>=) (ma c) (a2mb c) + Token_Term_Monad_join tok_mma -> + -- join :: Monad m => m (m a) -> m a + compileO tok_mma ctx $ \ty_mma (TermO mma) -> + check_con1 (ty @Monad) (At (Just tok_mma) ty_mma) $ \Refl Con ty_mma_m ty_mma_ma -> + check_type1 ty_mma_m (At (Just tok_mma) ty_mma_ma) $ \Refl _ty_mma_ma_a -> + k ty_mma_ma $ TermO $ + \c -> join (mma c) Token_Term_Monad_when tok_cond tok_ok -> -- when :: Applicative f => Bool -> f () -> f () compileO tok_cond ctx $ \ty_cond (TermO cond) -> @@ -127,3 +136,19 @@ instance -- CompileI (At (Just tok_ok) ty_ok_u) $ \Refl -> k ty_ok $ TermO $ \c -> when (cond c) (ok c) +instance -- TokenizeT + Inj_Token meta ts Monad => + TokenizeT meta ts (Proxy Monad) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ (Term_Name "Nothing",) Term_ProTok + { term_protok = \meta -> ProTokPi $ \m -> ProTokLam $ \a -> + ProTok $ inj_etoken meta $ Token_Term_Monad_return m a + , term_fixity = infixN5 + } + , tokenize2 ">>=" (infixL 1) Token_Term_Monad_bind + , tokenize1 "join" infixN5 Token_Term_Monad_join + , tokenize2 "when" infixN5 Token_Term_Monad_when + ] + } +instance Gram_Term_AtomsT meta ts (Proxy Monad) g diff --git a/Language/Symantic/Compiling/MonoFoldable.hs b/Language/Symantic/Compiling/MonoFoldable.hs index cc5e6c1..e38f656 100644 --- a/Language/Symantic/Compiling/MonoFoldable.hs +++ b/Language/Symantic/Compiling/MonoFoldable.hs @@ -12,6 +12,7 @@ import Data.Text (Text) import Data.Type.Equality ((:~:)(Refl)) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term import Language.Symantic.Compiling.MonoFunctor @@ -21,13 +22,13 @@ import Language.Symantic.Transforming.Trans -- * Class 'Sym_MonoFoldable' class Sym_MonoFunctor term => Sym_MonoFoldable term where ofoldMap :: (MonoFoldable o, Monoid m) => term (MT.Element o -> m) -> term o -> term m - ofoldr :: MonoFoldable o => term (MT.Element o -> b -> b) -> term b -> term o -> term b - ofoldl' :: MonoFoldable o => term (b -> MT.Element o -> b) -> term b -> term o -> term b - olength :: MonoFoldable o => term o -> term Int - onull :: MonoFoldable o => term o -> term Bool - oall :: MonoFoldable o => term (MT.Element o -> Bool) -> term o -> term Bool - oany :: MonoFoldable o => term (MT.Element o -> Bool) -> term o -> term Bool - otoList :: MonoFoldable o => term o -> term [MT.Element o] + ofoldr :: MonoFoldable o => term (MT.Element o -> b -> b) -> term b -> term o -> term b + ofoldl' :: MonoFoldable o => term (b -> MT.Element o -> b) -> term b -> term o -> term b + olength :: MonoFoldable o => term o -> term Int + onull :: MonoFoldable o => term o -> term Bool + oall :: MonoFoldable o => term (MT.Element o -> Bool) -> term o -> term Bool + oany :: MonoFoldable o => term (MT.Element o -> Bool) -> term o -> term Bool + otoList :: MonoFoldable o => term o -> term [MT.Element o] default ofoldMap :: (Trans t term, MonoFoldable o, Monoid m) => t term (MT.Element o -> m) -> t term o -> t term m default ofoldr :: (Trans t term, MonoFoldable o) @@ -35,9 +36,9 @@ class Sym_MonoFunctor term => Sym_MonoFoldable term where default ofoldl' :: (Trans t term, MonoFoldable o) => t term (b -> MT.Element o -> b) -> t term b -> t term o -> t term b default olength :: (Trans t term, MonoFoldable o) => t term o -> t term Int - default onull :: (Trans t term, MonoFoldable o) => t term o -> t term Bool - default oall :: (Trans t term, MonoFoldable o) => t term (MT.Element o -> Bool) -> t term o -> t term Bool - default oany :: (Trans t term, MonoFoldable o) => t term (MT.Element o -> Bool) -> t term o -> t term Bool + default onull :: (Trans t term, MonoFoldable o) => t term o -> t term Bool + default oall :: (Trans t term, MonoFoldable o) => t term (MT.Element o -> Bool) -> t term o -> t term Bool + default oany :: (Trans t term, MonoFoldable o) => t term (MT.Element o -> Bool) -> t term o -> t term Bool default otoList :: (Trans t term, MonoFoldable o) => t term o -> t term [MT.Element o] ofoldMap = trans_map2 ofoldMap ofoldr = trans_map3 ofoldr @@ -91,10 +92,10 @@ instance (Sym_MonoFoldable r1, Sym_MonoFoldable r2) => Sym_MonoFoldable (DupI r1 otoList = dupI1 (Proxy @Sym_MonoFoldable) otoList instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs MonoFoldable - ) => Read_TypeNameR Text cs (Proxy MonoFoldable ': rs) where - read_typenameR _cs "MonoFoldable" k = k (ty @MonoFoldable) + ) => Read_TypeNameR Type_Name cs (Proxy MonoFoldable ': rs) where + read_typenameR _cs (Type_Name "MonoFoldable") k = k (ty @MonoFoldable) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy MonoFoldable ': cs) where show_const ConstZ{} = "MonoFoldable" @@ -106,21 +107,21 @@ instance -- Proj_ConC ) => Proj_ConC cs (Proxy MonoFoldable) where proj_conC _ (TyConst q :$ typ) | Just Refl <- eq_skind (kind_of_const q) (SKiType `SKiArrow` SKiConstraint) - , Just Refl <- proj_const q (Proxy::Proxy MonoFoldable) + , Just Refl <- proj_const q (Proxy @MonoFoldable) = case typ of TyConst c - | Just Refl <- proj_const c (Proxy::Proxy Text) -> Just Con + | Just Refl <- proj_const c (Proxy @Text) -> Just Con TyConst c :$ _a | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType) -> case () of - _ | Just Refl <- proj_const c (Proxy::Proxy []) -> Just Con - | Just Refl <- proj_const c (Proxy::Proxy Maybe) -> Just Con + _ | Just Refl <- proj_const c (Proxy @[]) -> Just Con + | Just Refl <- proj_const c (Proxy @Maybe) -> Just Con _ -> Nothing TyConst c :$ _a :$ _b | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType `SKiArrow` SKiType) -> case () of - _ | Just Refl <- proj_const c (Proxy::Proxy (,)) -> Just Con - | Just Refl <- proj_const c (Proxy::Proxy Either) -> Just Con + _ | Just Refl <- proj_const c (Proxy @(,)) -> Just Con + | Just Refl <- proj_const c (Proxy @Either) -> Just Con _ -> Nothing _ -> Nothing proj_conC _c _q = Nothing @@ -259,3 +260,19 @@ instance -- CompileI (At (Just tok_e2Bool) ty_e2Bool_Bool) $ \Refl -> k (ty @Bool) $ TermO $ \c -> g (e2Bool c) (o c) +instance -- TokenizeT + Inj_Token meta ts MonoFoldable => + TokenizeT meta ts (Proxy MonoFoldable) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ tokenize2 "ofoldMap" infixN5 Token_Term_MonoFoldable_ofoldMap + , tokenize3 "ofoldr" infixN5 Token_Term_MonoFoldable_ofoldr + , tokenize3 "ofoldl'" infixN5 Token_Term_MonoFoldable_ofoldl' + , tokenize1 "olength" infixN5 Token_Term_MonoFoldable_olength + , tokenize1 "onull" infixN5 Token_Term_MonoFoldable_onull + , tokenize2 "oall" infixN5 Token_Term_MonoFoldable_oall + , tokenize2 "oany" infixN5 Token_Term_MonoFoldable_oany + , tokenize1 "otoList" infixN5 Token_Term_MonoFoldable_otoList + ] + } +instance Gram_Term_AtomsT meta ts (Proxy MonoFoldable) g diff --git a/Language/Symantic/Compiling/MonoFunctor.hs b/Language/Symantic/Compiling/MonoFunctor.hs index 4d5be61..6d8f033 100644 --- a/Language/Symantic/Compiling/MonoFunctor.hs +++ b/Language/Symantic/Compiling/MonoFunctor.hs @@ -15,6 +15,7 @@ import GHC.Exts (Constraint) import qualified System.IO as IO import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term import Language.Symantic.Interpreting @@ -49,10 +50,10 @@ instance (Sym_MonoFunctor r1, Sym_MonoFunctor r2) => Sym_MonoFunctor (DupI r1 r2 omap = dupI2 (Proxy @Sym_MonoFunctor) omap instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs MonoFunctor - ) => Read_TypeNameR Text cs (Proxy MonoFunctor ': rs) where - read_typenameR _cs "MonoFunctor" k = k (ty @MonoFunctor) + ) => Read_TypeNameR Type_Name cs (Proxy MonoFunctor ': rs) where + read_typenameR _cs (Type_Name "MonoFunctor") k = k (ty @MonoFunctor) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy MonoFunctor ': cs) where show_const ConstZ{} = "MonoFunctor" @@ -74,13 +75,17 @@ instance -- Bool Proj_FamC cs Fam_MonoElement Bool instance -- Char Proj_FamC cs Fam_MonoElement Char +instance -- Int + Proj_FamC cs Fam_MonoElement Int +instance -- Integer + Proj_FamC cs Fam_MonoElement Integer instance -- Text ( Proj_Const cs Text , Inj_Const cs (MT.Element Text) ) => Proj_FamC cs Fam_MonoElement Text where proj_famC _c _fam (TyConst c `TypesS` TypesZ) | Just Refl <- eq_skind (kind_of_const c) SKiType - , Just Refl <- proj_const c (Proxy::Proxy Text) + , Just Refl <- proj_const c (Proxy @Text) = Just (TyConst inj_const::Type cs (MT.Element Text)) proj_famC _c _fam _ty = Nothing instance -- [] @@ -88,7 +93,7 @@ instance -- [] ) => Proj_FamC cs Fam_MonoElement [] where proj_famC _c _fam ((TyConst c :$ ty_a) `TypesS` TypesZ) | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy []) + , Just Refl <- proj_const c (Proxy @[]) = Just ty_a proj_famC _c _fam _ty = Nothing instance -- IO @@ -96,7 +101,7 @@ instance -- IO ) => Proj_FamC cs Fam_MonoElement IO where proj_famC _c _fam ((TyConst c :$ ty_a) `TypesS` TypesZ) | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy IO) + , Just Refl <- proj_const c (Proxy @IO) = Just ty_a proj_famC _c _fam _ty = Nothing instance -- IO.Handle @@ -108,7 +113,7 @@ instance -- Maybe ) => Proj_FamC cs Fam_MonoElement Maybe where proj_famC _c _fam ((TyConst c :$ ty_a) `TypesS` TypesZ) | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy Maybe) + , Just Refl <- proj_const c (Proxy @Maybe) = Just ty_a proj_famC _c _fam _ty = Nothing instance -- (->) @@ -116,7 +121,7 @@ instance -- (->) ) => Proj_FamC cs Fam_MonoElement (->) where proj_famC _c _fam ((TyConst c :$ _ty_r :$ ty_a) `TypesS` TypesZ) | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy (->)) + , Just Refl <- proj_const c (Proxy @(->)) = Just ty_a proj_famC _c _fam _ty = Nothing instance -- (,) @@ -124,7 +129,7 @@ instance -- (,) ) => Proj_FamC cs Fam_MonoElement (,) where proj_famC _c _fam ((TyConst c :$ _ty_a :$ ty_b) `TypesS` TypesZ) | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy (,)) + , Just Refl <- proj_const c (Proxy @(,)) = Just ty_b proj_famC _c _fam _ty = Nothing instance -- Either @@ -132,7 +137,7 @@ instance -- Either ) => Proj_FamC cs Fam_MonoElement Either where proj_famC _c _fam ((TyConst c :$ _ty_l :$ ty_r) `TypesS` TypesZ) | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy Either) + , Just Refl <- proj_const c (Proxy @Either) = Just ty_r proj_famC _c _fam _ty = Nothing instance -- Map @@ -140,7 +145,7 @@ instance -- Map ) => Proj_FamC cs Fam_MonoElement Map where proj_famC _c _fam ((TyConst c :$ _ty_k :$ ty_a) `TypesS` TypesZ) | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy Map) + , Just Refl <- proj_const c (Proxy @Map) = Just ty_a proj_famC _c _fam _ty = Nothing @@ -150,24 +155,24 @@ instance -- Proj_ConC ) => Proj_ConC cs (Proxy MonoFunctor) where proj_conC _ (TyConst q :$ typ) | Just Refl <- eq_skind (kind_of_const q) (SKiType `SKiArrow` SKiConstraint) - , Just Refl <- proj_const q (Proxy::Proxy MonoFunctor) + , Just Refl <- proj_const q (Proxy @MonoFunctor) = case typ of TyConst c - | Just Refl <- proj_const c (Proxy::Proxy Text) -> Just Con + | Just Refl <- proj_const c (Proxy @Text) -> Just Con TyConst c :$ _a | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType) -> case () of - _ | Just Refl <- proj_const c (Proxy::Proxy []) -> Just Con - | Just Refl <- proj_const c (Proxy::Proxy IO) -> Just Con - | Just Refl <- proj_const c (Proxy::Proxy Maybe) -> Just Con + _ | Just Refl <- proj_const c (Proxy @[]) -> Just Con + | Just Refl <- proj_const c (Proxy @IO) -> Just Con + | Just Refl <- proj_const c (Proxy @Maybe) -> Just Con _ -> Nothing TyConst c :$ _a :$ _b | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType `SKiArrow` SKiType) -> case () of - _ | Just Refl <- proj_const c (Proxy::Proxy (->)) -> Just Con - | Just Refl <- proj_const c (Proxy::Proxy (,)) -> Just Con - | Just Refl <- proj_const c (Proxy::Proxy Either) -> Just Con - | Just Refl <- proj_const c (Proxy::Proxy Map) -> Just Con + _ | Just Refl <- proj_const c (Proxy @(->)) -> Just Con + | Just Refl <- proj_const c (Proxy @(,)) -> Just Con + | Just Refl <- proj_const c (Proxy @Either) -> Just Con + | Just Refl <- proj_const c (Proxy @Map) -> Just Con _ -> Nothing _ -> Nothing proj_conC _c _q = Nothing @@ -199,3 +204,12 @@ instance -- CompileI (At (Just tok_f) ty_f_a) $ \Refl -> k ty_o $ TermO $ \c -> omap (f c) (m c) +instance -- TokenizeT + Inj_Token meta ts MonoFunctor => + TokenizeT meta ts (Proxy MonoFunctor) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ tokenize2 "omap" infixN5 Token_Term_MonoFunctor_omap + ] + } +instance Gram_Term_AtomsT meta ts (Proxy MonoFunctor) g diff --git a/Language/Symantic/Compiling/MonoFunctor/Test.hs b/Language/Symantic/Compiling/MonoFunctor/Test.hs index c7a5cae..21c58f2 100644 --- a/Language/Symantic/Compiling/MonoFunctor/Test.hs +++ b/Language/Symantic/Compiling/MonoFunctor/Test.hs @@ -1,58 +1,36 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -{-# OPTIONS_GHC -O0 #-} -- speedup compiling… module Compiling.MonoFunctor.Test where import Test.Tasty import qualified Data.MonoTraversable as MT import Data.Proxy (Proxy(..)) -import Data.Text (Text) import Prelude hiding (zipWith) -import Language.Symantic.Parsing import Language.Symantic.Typing -import Language.Symantic.Compiling +import Language.Symantic.Compiling () import Compiling.Term.Test -import Compiling.Bool.Test (syBool) -import Compiling.Foldable.Test () -import Parsing.Test +import Compiling.Bool.Test () --- * Tests type Ifaces = [ Proxy (->) , Proxy [] + , Proxy Integer , Proxy Bool , Proxy Char - , Proxy Text , Proxy MT.MonoFunctor , Proxy Maybe ] (==>) = test_compile (Proxy::Proxy Ifaces) -instance - ( Inj_Token (Syntax Text) ts MT.MonoFunctor - , Tokenize (Syntax Text) (Syntax Text) ts ) => - TokenizeT (Syntax Text) (Syntax Text) ts (Proxy MT.MonoFunctor) where - tokenizeT _t (Syntax "omap" (ast_f : ast_m : as)) = Just $ do - f <- tokenize ast_f - m <- tokenize ast_m - Right $ (as,) $ EToken $ inj_token (Syntax "omap" [ast_f, ast_m]) $ - Token_Term_MonoFunctor_omap f m - tokenizeT _t _sy = Nothing - tests :: TestTree tests = testGroup "MonoFunctor" - [ Syntax "omap" - [ syLam "x" (sy @Bool) - (Syntax "not" [syVar "x"]) - , Syntax "Just" [syBool True] - ] ==> Right (ty @Maybe :$ ty @Bool, Just False, "omap (\\x0 -> (\\x1 -> not x1) x0) (Just True)") - , Syntax "omap" - [ syLam "x" (sy @Char) - (Syntax "Char.toUpper" [syVar "x"]) - , Syntax "text" [Syntax "\"abc\"" []] - ] ==> Right (ty @Text, "ABC", "omap (\\x0 -> (\\x1 -> Char.toUpper x1) x0) \"abc\"") + [ "omap not (Just True)" ==> Right + ( ty @Maybe :$ ty @Bool + , Just False + , "omap (\\x0 -> not x0) (Just True)" ) + , "omap Char.toUpper ['a', 'b', 'c']" ==> Right + ( ty @[] :$ ty @Char + , "ABC" + , "omap (\\x0 -> Char.toUpper x0) ('a' : 'b' : 'c' : [])" ) ] diff --git a/Language/Symantic/Compiling/Monoid.hs b/Language/Symantic/Compiling/Monoid.hs index 50c91dc..b016816 100644 --- a/Language/Symantic/Compiling/Monoid.hs +++ b/Language/Symantic/Compiling/Monoid.hs @@ -8,13 +8,14 @@ import qualified Data.Function as Fun import Data.Monoid (Monoid) import qualified Data.Monoid as Monoid import Data.Proxy -import Data.Text (Text) import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (Monoid(..)) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling.Lambda import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans @@ -42,6 +43,8 @@ instance (Sym_Monoid r1, Sym_Monoid r2) => Sym_Monoid (DupI r1 r2) where mappend = dupI2 (Proxy @Sym_Monoid) mappend -- | 'mappend' alias. +-- +-- TODO: move to Semigroup (<>) :: ( Sym_Monoid term , Monoid a ) @@ -50,10 +53,10 @@ instance (Sym_Monoid r1, Sym_Monoid r2) => Sym_Monoid (DupI r1 r2) where infixr 6 <> instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Monoid - ) => Read_TypeNameR Text cs (Proxy Monoid ': rs) where - read_typenameR _cs "Monoid" k = k (ty @Monoid) + ) => Read_TypeNameR Type_Name cs (Proxy Monoid ': rs) where + read_typenameR _cs (Type_Name "Monoid") k = k (ty @Monoid) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Monoid ': cs) where show_const ConstZ{} = "Monoid" @@ -66,7 +69,7 @@ data instance TokenT meta (ts::[*]) (Proxy Monoid) deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Monoid)) deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Monoid)) instance -- CompileI - ( Read_TypeName Name_LamVar (Consts_of_Ifaces is) + ( Read_TypeName Type_Name (Consts_of_Ifaces is) , Inj_Const (Consts_of_Ifaces is) Monoid , Inj_Const (Consts_of_Ifaces is) (->) , Proj_Con (Consts_of_Ifaces is) @@ -88,3 +91,18 @@ instance -- CompileI check_con (At (Just tok_a) (ty @Monoid :$ ty_a)) $ \Con -> k (ty_a ~> ty_a) $ TermO $ \c -> lam $ \y -> mappend (x c) y +instance -- TokenizeT + Inj_Token meta ts Monoid => + TokenizeT meta ts (Proxy Monoid) where + tokenizeT _t = Monoid.mempty + { tokenizers_infix = tokenizeTMod [] + [ (Term_Name "mempty",) Term_ProTok + { term_protok = \meta -> ProTokPi $ \a -> + ProTok $ inj_etoken meta $ Token_Term_Monoid_mempty a + , term_fixity = infixN5 + } + , tokenize1 "mappend" infixN5 Token_Term_Monoid_mappend + , tokenize1 "<>" (infixR 6) Token_Term_Monoid_mappend + ] + } +instance Gram_Term_AtomsT meta ts (Proxy Monoid) g diff --git a/Language/Symantic/Compiling/NonNull.hs b/Language/Symantic/Compiling/NonNull.hs index 95b5e35..568eb5a 100644 --- a/Language/Symantic/Compiling/NonNull.hs +++ b/Language/Symantic/Compiling/NonNull.hs @@ -11,11 +11,11 @@ import Data.NonNull (NonNull) import qualified Data.NonNull as NonNull import Data.Proxy import Data.Sequences (IsSequence, SemiSequence) -import Data.Text (Text) import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (head, init, last, tail) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term import Language.Symantic.Compiling.MonoFunctor @@ -99,10 +99,10 @@ instance (Sym_NonNull r1, Sym_NonNull r2) => Sym_NonNull (DupI r1 r2) where nfilter = dupI2 (Proxy @Sym_NonNull) nfilter instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs NonNull - ) => Read_TypeNameR Text cs (Proxy NonNull ': rs) where - read_typenameR _cs "NonNull" k = k (ty @NonNull) + ) => Read_TypeNameR Type_Name cs (Proxy NonNull ': rs) where + read_typenameR _cs (Type_Name "NonNull") k = k (ty @NonNull) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy NonNull ': cs) where show_const ConstZ{} = "NonNull" @@ -114,7 +114,7 @@ instance -- Fam_MonoElement ) => Proj_FamC cs Fam_MonoElement NonNull where proj_famC _c _fam ((TyConst c :$ ty_o) `TypesS` TypesZ) | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy NonNull) + , Just Refl <- proj_const c (Proxy @NonNull) = proj_fam Fam_MonoElement (ty_o `TypesS` TypesZ) proj_famC _c _fam _ty = Nothing instance -- Proj_ConC @@ -124,19 +124,19 @@ instance -- Proj_ConC ) => Proj_ConC cs (Proxy NonNull) where proj_conC _ (t@(TyConst q) :$ (TyConst c :$ o)) | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy NonNull) + , Just Refl <- proj_const c (Proxy @NonNull) = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Eq) + _ | Just Refl <- proj_const q (Proxy @Eq) , Just Con <- proj_con (t :$ o) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy MT.MonoFoldable) + | Just Refl <- proj_const q (Proxy @MT.MonoFoldable) , Just Con <- proj_con (t :$ o) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy MT.MonoFunctor) + | Just Refl <- proj_const q (Proxy @MT.MonoFunctor) , Just Con <- proj_con (t :$ o) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Ord) + | Just Refl <- proj_const q (Proxy @Ord) , Just Con <- proj_con (t :$ o) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy SemiSequence) + | Just Refl <- proj_const q (Proxy @SemiSequence) , Just Con <- proj_con (t :$ o) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Show) + | Just Refl <- proj_const q (Proxy @Show) , Just Con <- proj_con (t :$ o) -> Just Con _ -> Nothing proj_conC _c _q = Nothing @@ -248,19 +248,20 @@ instance -- CompileI check_con (At (Just tok_n) (ty @IsSequence :$ ty_s)) $ \Con -> k ty_s $ TermO $ \c -> f (n c) - {- - "ncons" -> ncons_from - "nuncons" -> nuncons_from - "head" -> n2e_from head - "last" -> n2e_from last - "tail" -> n2s_from tail - "init" -> n2s_from init - "nfilter" -> nfilter_from - _ -> Left $ Error_Term_unsupported - where - fromNullable_from = - toNullable_from = - ncons_from = - nuncons_from = - nfilter_from = - -} +instance -- TokenizeT + Inj_Token meta ts NonNull => + TokenizeT meta ts (Proxy NonNull) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ tokenize1 "fromNullable" infixN5 Token_Term_NonNull_fromNullable + , tokenize1 "toNullable" infixN5 Token_Term_NonNull_toNullable + , tokenize2 "ncons" infixN5 Token_Term_NonNull_ncons + , tokenize1 "nuncons" infixN5 Token_Term_NonNull_nuncons + , tokenize1 "head" infixN5 Token_Term_NonNull_head + , tokenize1 "last" infixN5 Token_Term_NonNull_last + , tokenize1 "tail" infixN5 Token_Term_NonNull_tail + , tokenize1 "init" infixN5 Token_Term_NonNull_init + , tokenize2 "nfilter" infixN5 Token_Term_NonNull_nfilter + ] + } +instance Gram_Term_AtomsT meta ts (Proxy NonNull) g diff --git a/Language/Symantic/Compiling/Num.hs b/Language/Symantic/Compiling/Num.hs index e4a5d45..414b113 100644 --- a/Language/Symantic/Compiling/Num.hs +++ b/Language/Symantic/Compiling/Num.hs @@ -6,15 +6,16 @@ module Language.Symantic.Compiling.Num where import Control.Monad (liftM, liftM2) import qualified Data.Function as Fun import Data.Proxy -import Data.Text (Text) import Data.Type.Equality ((:~:)(Refl)) import qualified Prelude import Prelude hiding (Num(..)) import Prelude (Num) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling.Lambda import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans @@ -66,9 +67,9 @@ instance Sym_Num TextI where abs = textI1 "abs" negate = textI1 "negate" signum = textI1 "signum" - (+) = textI_infix "+" (Precedence 6) - (-) = textI_infix "-" (Precedence 6) - (*) = textI_infix "-" (Precedence 7) + (+) = textI_infix "+" (infixB L 6) + (-) = textI_infix "-" (infixL 6) + (*) = textI_infix "*" (infixB L 7) fromInteger = textI1 "fromInteger" instance (Sym_Num r1, Sym_Num r2) => Sym_Num (DupI r1 r2) where abs = dupI1 (Proxy @Sym_Num) abs @@ -80,10 +81,10 @@ instance (Sym_Num r1, Sym_Num r2) => Sym_Num (DupI r1 r2) where fromInteger = dupI1 (Proxy @Sym_Num) fromInteger instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Num - ) => Read_TypeNameR Text cs (Proxy Num ': rs) where - read_typenameR _cs "Num" k = k (ty @Num) + ) => Read_TypeNameR Type_Name cs (Proxy Num ': rs) where + read_typenameR _cs (Type_Name "Num") k = k (ty @Num) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Num ': cs) where show_const ConstZ{} = "Num" @@ -101,7 +102,7 @@ data instance TokenT meta (ts::[*]) (Proxy Num) deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Num)) deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Num)) instance -- CompileI - ( Read_TypeName Name_LamVar (Consts_of_Ifaces is) + ( Read_TypeName Type_Name (Consts_of_Ifaces is) , Inj_Const (Consts_of_Ifaces is) Num , Inj_Const (Consts_of_Ifaces is) (->) , Inj_Const (Consts_of_Ifaces is) Integer @@ -146,3 +147,25 @@ instance -- CompileI check_con (At (Just tok_a) (ty @Num :$ ty_a)) $ \Con -> k (ty_a ~> ty_a) $ TermO $ \c -> lam $ \y -> op (x c) y +instance -- TokenizeT + Inj_Token meta ts Num => + TokenizeT meta ts (Proxy Num) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ tokenize1 "abs" infixN5 Token_Term_Num_abs + , tokenize1 "negate" infixN5 Token_Term_Num_negate + , tokenize1 "signum" infixN5 Token_Term_Num_signum + , tokenize1 "+" (infixB L 6) Token_Term_Num_add + , tokenize1 "-" (infixL 6) Token_Term_Num_sub + , tokenize1 "*" (infixB L 7) Token_Term_Num_mul + , (Term_Name "fromInteger",) Term_ProTok + { term_protok = \meta -> ProTokPi $ \a -> + ProTok $ inj_etoken meta $ Token_Term_Num_fromInteger a + , term_fixity = infixN5 + } + ] + , tokenizers_prefix = tokenizeTMod [] + [ tokenize1 "-" (Prefix 10) Token_Term_Num_negate + ] + } +instance Gram_Term_AtomsT meta ts (Proxy Num) g diff --git a/Language/Symantic/Compiling/Num/Test.hs b/Language/Symantic/Compiling/Num/Test.hs new file mode 100644 index 0000000..f39f381 --- /dev/null +++ b/Language/Symantic/Compiling/Num/Test.hs @@ -0,0 +1,112 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +module Compiling.Num.Test where + +import Test.Tasty + +import Compiling.Bool.Test () +import Compiling.Term.Test +import qualified Data.Monoid as Monoid +import Data.Proxy (Proxy(..)) +import Prelude (Num) +import Prelude hiding (Num(..)) + +import Language.Symantic.Compiling +import Language.Symantic.Interpreting +import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar +import Language.Symantic.Typing + +-- * Tests +type Ifaces = + [ Proxy (->) + , Proxy Integer + , Proxy Num + , Proxy Num2 + , Proxy Int + , Proxy Integral + , Proxy Foldable + , Proxy Traversable + , Proxy [] + ] +(==>) = test_compile (Proxy::Proxy Ifaces) + +tests :: TestTree +tests = testGroup "Num" + [ "42" ==> Right (ty @Integer, 42, "42") + , "-42" ==> Right (ty @Integer, -42, "negate 42") + , "- -42" ==> Right (ty @Integer, 42, "negate (negate 42)") + , "1 + -2" ==> Right (ty @Integer, -1, "(\\x0 -> 1 + x0) (negate 2)") + , "-1 + -2" ==> Right (ty @Integer, -3, "(\\x0 -> negate 1 + x0) (negate 2)") + , "-(1 + -2)" ==> Right (ty @Integer, 1, "negate ((\\x0 -> 1 + x0) (negate 2))") + , "(+) 1 2" ==> Right (ty @Integer, 3, "(\\x0 -> 1 + x0) 2") + , "1 + 2" ==> Right (ty @Integer, 3, "(\\x0 -> 1 + x0) 2") + , "1 + 2 - 3" ==> Right (ty @Integer, 0, "(\\x0 -> (\\x1 -> 1 + x1) 2 - x0) 3") + , "1 + 2 * 3" ==> Right (ty @Integer, 7, "(\\x0 -> 1 + x0) ((\\x0 -> 2 * x0) 3)") + , "3 * 2 + 1" ==> Right (ty @Integer, 7, "(\\x0 -> (\\x1 -> 3 * x1) 2 + x0) 1") + , "3 * (2 + 1)" ==> Right (ty @Integer, 9, "(\\x0 -> 3 * x0) ((\\x0 -> 2 + x0) 1)") + , "4 + 3 * 2 + 1" ==> Right (ty @Integer, 11, + "(\\x0 -> (\\x1 -> 4 + x1) ((\\x1 -> 3 * x1) 2) + x0) 1") + , "5 * 4 + 3 * 2 + 1" ==> Right (ty @Integer, 27, + "(\\x0 -> (\\x1 -> (\\x2 -> 5 * x2) 4 + x1) ((\\x1 -> 3 * x1) 2) + x0) 1") + , "negate`42" ==> Right (ty @Integer, -42, "negate 42") + , "42`negate" ==> Right (ty @Integer, -42, "negate 42") + , "42`negate " ==> Right (ty @Integer, -42, "negate 42") + , "42`negate`negate" ==> Right (ty @Integer, 42, "negate (negate 42)") + , "42`abs`negate" ==> Right (ty @Integer, -42, "negate (abs 42)") + , "42`negate`abs" ==> Right (ty @Integer, 42, "abs (negate 42)") + , "abs`negate`42" ==> Right (ty @Integer, 42, "abs (negate 42)") + , "negate`abs`42" ==> Right (ty @Integer, -42, "negate (abs 42)") + , "abs`42`negate" ==> Right (ty @Integer, 42, "abs (negate 42)") + , "negate`42`abs" ==> Right (ty @Integer, 42, "abs (negate 42)") + , "negate`abs`42`mod`9" ==> Right + (ty @Integer,3, "(\\x0 -> negate (abs 42) `mod` x0) 9") + , "42`abs`negate`mod`abs`negate`9" ==> Right + (ty @Integer, 3, "(\\x0 -> negate (abs 42) `mod` x0) (abs (negate 9))") + ] + +-- | A newtype to test prefix and postfix. +newtype Num2 a = Num2 a + +class Sym_Num2 (term:: * -> *) where + +type instance Sym_of_Iface (Proxy Num2) = Sym_Num2 +type instance Consts_of_Iface (Proxy Num2) = Proxy Num2 ': Consts_imported_by Num2 +type instance Consts_imported_by Num2 = '[ Proxy Integer ] + +instance Sym_Num2 HostI where +instance Sym_Num2 TextI where +instance Sym_Num2 (DupI r1 r2) where + +instance + ( Read_TypeNameR Type_Name cs rs + , Inj_Const cs Num2 + ) => Read_TypeNameR Type_Name cs (Proxy Num2 ': rs) where + read_typenameR _cs (Type_Name "Num2") k = k (ty @Num2) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k +instance Show_Const cs => Show_Const (Proxy Num2 ': cs) where + show_const ConstZ{} = "Num2" + show_const (ConstS c) = show_const c + +instance Proj_ConC cs (Proxy Num2) +data instance TokenT meta (ts::[*]) (Proxy Num2) +deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Num2)) +deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Num2)) +instance CompileI is (Proxy Num2) where + compileI _tok _ctx _k = undefined +instance -- TokenizeT + Inj_Token meta ts Num => + TokenizeT meta ts (Proxy Num2) where + tokenizeT _t = Monoid.mempty + { tokenizers_prefix = tokenizeTMod [] + [ tokenize1 "abs" (Prefix 9) Token_Term_Num_abs + , tokenize1 "negate" (Prefix 10) Token_Term_Num_negate + ] + , tokenizers_postfix = tokenizeTMod [] + [ tokenize1 "abs" (Postfix 9) Token_Term_Num_abs + , tokenize1 "negate" (Postfix 10) Token_Term_Num_negate + ] + } +instance Gram_Term_AtomsT meta ts (Proxy Num2) g diff --git a/Language/Symantic/Compiling/Ord.hs b/Language/Symantic/Compiling/Ord.hs index 693ad61..1e3aeba 100644 --- a/Language/Symantic/Compiling/Ord.hs +++ b/Language/Symantic/Compiling/Ord.hs @@ -7,35 +7,40 @@ import Control.Monad import Data.Ord (Ord) import qualified Data.Ord as Ord import Data.Proxy (Proxy(..)) -import Data.Text (Text) +import qualified Data.Text as Text import qualified Data.Kind as Kind import Prelude hiding (Ord(..)) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling.Lambda import Language.Symantic.Compiling.Eq (Sym_Eq) import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans -- * Class 'Sym_Ord' class Sym_Eq term => Sym_Ord term where - compare :: Ord a => term a -> term a -> term Ordering - (<) :: Ord a => term a -> term a -> term Bool - (<=) :: Ord a => term a -> term a -> term Bool - (>) :: Ord a => term a -> term a -> term Bool - (>=) :: Ord a => term a -> term a -> term Bool - max :: Ord a => term a -> term a -> term a - min :: Ord a => term a -> term a -> term a + ordering :: Ordering -> term Ordering + compare :: Ord a => term a -> term a -> term Ordering + (<) :: Ord a => term a -> term a -> term Bool + (<=) :: Ord a => term a -> term a -> term Bool + (>) :: Ord a => term a -> term a -> term Bool + (>=) :: Ord a => term a -> term a -> term Bool + max :: Ord a => term a -> term a -> term a + min :: Ord a => term a -> term a -> term a - default compare :: (Trans t term, Ord a) => t term a -> t term a -> t term Ordering - default (<) :: (Trans t term, Ord a) => t term a -> t term a -> t term Bool - default (<=) :: (Trans t term, Ord a) => t term a -> t term a -> t term Bool - default (>) :: (Trans t term, Ord a) => t term a -> t term a -> t term Bool - default (>=) :: (Trans t term, Ord a) => t term a -> t term a -> t term Bool - default max :: (Trans t term, Ord a) => t term a -> t term a -> t term a - default min :: (Trans t term, Ord a) => t term a -> t term a -> t term a + default ordering :: Trans t term => Ordering -> t term Ordering + default compare :: (Trans t term, Ord a) => t term a -> t term a -> t term Ordering + default (<) :: (Trans t term, Ord a) => t term a -> t term a -> t term Bool + default (<=) :: (Trans t term, Ord a) => t term a -> t term a -> t term Bool + default (>) :: (Trans t term, Ord a) => t term a -> t term a -> t term Bool + default (>=) :: (Trans t term, Ord a) => t term a -> t term a -> t term Bool + default max :: (Trans t term, Ord a) => t term a -> t term a -> t term a + default min :: (Trans t term, Ord a) => t term a -> t term a -> t term a + ordering = trans_lift . ordering compare = trans_map2 compare (<) = trans_map2 (<) (<=) = trans_map2 (<=) @@ -54,35 +59,39 @@ type instance Consts_of_Iface (Proxy Ord) = Proxy Ord ': Consts_imported_by Ord type instance Consts_imported_by Ord = '[] instance Sym_Ord HostI where - compare = liftM2 Ord.compare - (<) = liftM2 (Ord.<) - (<=) = liftM2 (Ord.<=) - (>) = liftM2 (Ord.>) - (>=) = liftM2 (Ord.>=) - min = liftM2 Ord.min - max = liftM2 Ord.max + ordering = HostI + compare = liftM2 Ord.compare + (<) = liftM2 (Ord.<) + (<=) = liftM2 (Ord.<=) + (>) = liftM2 (Ord.>) + (>=) = liftM2 (Ord.>=) + min = liftM2 Ord.min + max = liftM2 Ord.max instance Sym_Ord TextI where - compare = textI2 "compare" - (<) = textI_infix "<" (Precedence 4) - (<=) = textI_infix "<=" (Precedence 4) - (>) = textI_infix ">" (Precedence 4) - (>=) = textI_infix ">=" (Precedence 4) - min = textI2 "min" - max = textI2 "max" + ordering o = TextI $ \_p _v -> + Text.pack (show o) + compare = textI2 "compare" + (<) = textI_infix "<" (infixN 4) + (<=) = textI_infix "<=" (infixN 4) + (>) = textI_infix ">" (infixN 4) + (>=) = textI_infix ">=" (infixN 4) + min = textI2 "min" + max = textI2 "max" instance (Sym_Ord r1, Sym_Ord r2) => Sym_Ord (DupI r1 r2) where - compare = dupI2 (Proxy @Sym_Ord) compare - (<) = dupI2 (Proxy @Sym_Ord) (<) - (<=) = dupI2 (Proxy @Sym_Ord) (<=) - (>) = dupI2 (Proxy @Sym_Ord) (>) - (>=) = dupI2 (Proxy @Sym_Ord) (>=) - min = dupI2 (Proxy @Sym_Ord) min - max = dupI2 (Proxy @Sym_Ord) max + ordering o = ordering o `DupI` ordering o + compare = dupI2 (Proxy @Sym_Ord) compare + (<) = dupI2 (Proxy @Sym_Ord) (<) + (<=) = dupI2 (Proxy @Sym_Ord) (<=) + (>) = dupI2 (Proxy @Sym_Ord) (>) + (>=) = dupI2 (Proxy @Sym_Ord) (>=) + min = dupI2 (Proxy @Sym_Ord) min + max = dupI2 (Proxy @Sym_Ord) max instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Ord - ) => Read_TypeNameR Text cs (Proxy Ord ': rs) where - read_typenameR _cs "Ord" k = k (ty @Ord) + ) => Read_TypeNameR Type_Name cs (Proxy Ord ': rs) where + read_typenameR _cs (Type_Name "Ord") k = k (ty @Ord) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Ord ': cs) where show_const ConstZ{} = "Ord" @@ -90,7 +99,8 @@ instance Show_Const cs => Show_Const (Proxy Ord ': cs) where instance Proj_ConC cs (Proxy Ord) data instance TokenT meta (ts::[*]) (Proxy Ord) - = Token_Term_Ord_compare (EToken meta ts) + = Token_Term_Ordering Ordering + | Token_Term_Ord_compare (EToken meta ts) | Token_Term_Ord_le (EToken meta ts) | Token_Term_Ord_lt (EToken meta ts) | Token_Term_Ord_ge (EToken meta ts) @@ -113,6 +123,7 @@ instance -- CompileI -> CompileT meta ctx ret is ls (Proxy Ord ': rs) compileI tok ctx k = case tok of + Token_Term_Ordering o -> k (ty @Ordering) $ TermO $ \_c -> ordering o Token_Term_Ord_compare tok_a -> compare_from tok_a (ty @Ordering) compare Token_Term_Ord_le tok_a -> compare_from tok_a (ty @Bool) (<=) Token_Term_Ord_lt tok_a -> compare_from tok_a (ty @Bool) (<) @@ -145,3 +156,19 @@ instance -- CompileI check_con (At (Just tok_a) (ty @Ord :$ ty_a)) $ \Con -> k (ty_a ~> ty_a) $ TermO $ \c -> lam $ \y -> op (x c) y +instance -- TokenizeT + Inj_Token meta ts Ord => + TokenizeT meta ts (Proxy Ord) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ tokenize0 "LT" infixN5 $ Token_Term_Ordering LT + , tokenize0 "EQ" infixN5 $ Token_Term_Ordering EQ + , tokenize0 "GT" infixN5 $ Token_Term_Ordering GT + , tokenize1 "compare" infixN5 Token_Term_Ord_compare + , tokenize1 "<" (infixN 4) Token_Term_Ord_lt + , tokenize1 "<=" (infixN 4) Token_Term_Ord_le + , tokenize1 ">" (infixN 4) Token_Term_Ord_gt + , tokenize1 ">=" (infixN 4) Token_Term_Ord_ge + ] + } +instance Gram_Term_AtomsT meta ts (Proxy Ord) g diff --git a/Language/Symantic/Compiling/Sequences.hs b/Language/Symantic/Compiling/Sequences.hs index aeb6f1a..dadd1f6 100644 --- a/Language/Symantic/Compiling/Sequences.hs +++ b/Language/Symantic/Compiling/Sequences.hs @@ -13,6 +13,7 @@ import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (filter, reverse) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term import Language.Symantic.Compiling.MonoFunctor (Fam_MonoElement(..)) @@ -22,13 +23,13 @@ import Language.Symantic.Transforming.Trans -- * Class 'Sym_SemiSequence' class Sym_SemiSequence term where intersperse :: SemiSequence s => term (MT.Element s) -> term s -> term s - cons :: SemiSequence s => term (MT.Element s) -> term s -> term s - snoc :: SemiSequence s => term s -> term (MT.Element s) -> term s - reverse :: SemiSequence s => term s -> term s + cons :: SemiSequence s => term (MT.Element s) -> term s -> term s + snoc :: SemiSequence s => term s -> term (MT.Element s) -> term s + reverse :: SemiSequence s => term s -> term s default intersperse :: (Trans t term, SemiSequence s) => t term (MT.Element s) -> t term s -> t term s - default cons :: (Trans t term, SemiSequence s) => t term (MT.Element s) -> t term s -> t term s - default snoc :: (Trans t term, SemiSequence s) => t term s -> t term (MT.Element s) -> t term s - default reverse :: (Trans t term, SemiSequence s) => t term s -> t term s + default cons :: (Trans t term, SemiSequence s) => t term (MT.Element s) -> t term s -> t term s + default snoc :: (Trans t term, SemiSequence s) => t term s -> t term (MT.Element s) -> t term s + default reverse :: (Trans t term, SemiSequence s) => t term s -> t term s intersperse = trans_map2 cons cons = trans_map2 cons snoc = trans_map2 snoc @@ -59,10 +60,10 @@ instance (Sym_SemiSequence r1, Sym_SemiSequence r2) => Sym_SemiSequence (DupI r1 reverse = dupI1 (Proxy @Sym_SemiSequence) reverse instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs SemiSequence - ) => Read_TypeNameR Text cs (Proxy SemiSequence ': rs) where - read_typenameR _cs "SemiSequence" k = k (ty @SemiSequence) + ) => Read_TypeNameR Type_Name cs (Proxy SemiSequence ': rs) where + read_typenameR _cs (Type_Name "SemiSequence") k = k (ty @SemiSequence) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy SemiSequence ': cs) where show_const ConstZ{} = "SemiSequence" @@ -74,17 +75,17 @@ instance -- Proj_ConC ) => Proj_ConC cs (Proxy SemiSequence) where proj_conC _ (TyConst q :$ s) | Just Refl <- eq_skind (kind_of_const q) (SKiType `SKiArrow` SKiConstraint) - , Just Refl <- proj_const q (Proxy::Proxy SemiSequence) + , Just Refl <- proj_const q (Proxy @SemiSequence) = case s of TyConst c | Just Refl <- eq_skind (kind_of_const c) SKiType -> case () of - _ | Just Refl <- proj_const c (Proxy::Proxy Text) -> Just Con + _ | Just Refl <- proj_const c (Proxy @Text) -> Just Con _ -> Nothing TyConst c :$ _o | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType) -> case () of - _ | Just Refl <- proj_const c (Proxy::Proxy []) -> Just Con + _ | Just Refl <- proj_const c (Proxy @[]) -> Just Con _ -> Nothing _ -> Nothing proj_conC _c _q = Nothing @@ -134,6 +135,18 @@ instance -- CompileI check_type (At Nothing ty_s_e) (At (Just tok_e) ty_e) $ \Refl -> k ty_s $ TermO $ \c -> f (e c) (s c) +instance -- TokenizeT + Inj_Token meta ts SemiSequence => + TokenizeT meta ts (Proxy SemiSequence) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ tokenize2 "intersperse" infixN5 Token_Term_SemiSequence_intersperse + , tokenize2 "cons" infixN5 Token_Term_SemiSequence_cons + , tokenize2 "snoc" infixN5 Token_Term_SemiSequence_snoc + , tokenize1 "reverse" infixN5 Token_Term_SemiSequence_reverse + ] + } +instance Gram_Term_AtomsT meta ts (Proxy SemiSequence) g -- * Class 'Sym_IsSequence' class Sym_IsSequence term where @@ -159,10 +172,10 @@ instance (Sym_IsSequence r1, Sym_IsSequence r2) => Sym_IsSequence (DupI r1 r2) w filter = dupI2 (Proxy @Sym_IsSequence) filter instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs IsSequence - ) => Read_TypeNameR Text cs (Proxy IsSequence ': rs) where - read_typenameR _cs "IsSequence" k = k (ty @IsSequence) + ) => Read_TypeNameR Type_Name cs (Proxy IsSequence ': rs) where + read_typenameR _cs (Type_Name "IsSequence") k = k (ty @IsSequence) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy IsSequence ': cs) where show_const ConstZ{} = "IsSequence" @@ -174,17 +187,17 @@ instance -- Proj_ConC ) => Proj_ConC cs (Proxy IsSequence) where proj_conC _ (TyConst q :$ s) | Just Refl <- eq_skind (kind_of_const q) (SKiType `SKiArrow` SKiConstraint) - , Just Refl <- proj_const q (Proxy::Proxy IsSequence) + , Just Refl <- proj_const q (Proxy @IsSequence) = case s of TyConst c | Just Refl <- eq_skind (kind_of_const c) SKiType -> case () of - _ | Just Refl <- proj_const c (Proxy::Proxy Text) -> Just Con + _ | Just Refl <- proj_const c (Proxy @Text) -> Just Con _ -> Nothing TyConst c :$ _o | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType) -> case () of - _ | Just Refl <- proj_const c (Proxy::Proxy []) -> Just Con + _ | Just Refl <- proj_const c (Proxy @[]) -> Just Con _ -> Nothing _ -> Nothing proj_conC _c _q = Nothing @@ -221,3 +234,12 @@ instance -- CompileI (At (Just tok_e2Bool) ty_e2Bool_e) $ \Refl -> k ty_s $ TermO $ \c -> filter (e2Bool c) (s c) +instance -- TokenizeT + Inj_Token meta ts IsSequence => + TokenizeT meta ts (Proxy IsSequence) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ tokenize2 "filter" infixN5 Token_Term_IsSequence_filter + ] + } +instance Gram_Term_AtomsT meta ts (Proxy IsSequence) g diff --git a/Language/Symantic/Compiling/Show.hs b/Language/Symantic/Compiling/Show.hs index 052b7ae..c440e0c 100644 --- a/Language/Symantic/Compiling/Show.hs +++ b/Language/Symantic/Compiling/Show.hs @@ -5,15 +5,16 @@ module Language.Symantic.Compiling.Show where import Control.Monad import Data.Proxy (Proxy(..)) -import Data.Text (Text) import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (Show(..)) import Text.Show (Show) import qualified Text.Show as Show import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling.Lambda import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans @@ -54,10 +55,10 @@ instance (Sym_Show r1, Sym_Show r2) => Sym_Show (DupI r1 r2) where showList = dupI1 (Proxy @Sym_Show) showList instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Show - ) => Read_TypeNameR Text cs (Proxy Show ': rs) where - read_typenameR _cs "Show" k = k (ty @Show) + ) => Read_TypeNameR Type_Name cs (Proxy Show ': rs) where + read_typenameR _cs (Type_Name "Show") k = k (ty @Show) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Show ': cs) where show_const ConstZ{} = "Show" @@ -102,3 +103,14 @@ instance -- CompileI where tyString = ty @[] :$ ty @Char tyShowS = tyString ~> tyString +instance -- TokenizeT + Inj_Token meta ts Show => + TokenizeT meta ts (Proxy Show) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ tokenize2 "showsPrec" infixN5 Token_Term_Show_showsPrec + , tokenize1 "show" infixN5 Token_Term_Show_show + , tokenize1 "showList" infixN5 Token_Term_Show_showList + ] + } +instance Gram_Term_AtomsT meta ts (Proxy Show) g diff --git a/Language/Symantic/Compiling/Term.hs b/Language/Symantic/Compiling/Term.hs index e54e02f..a25865b 100644 --- a/Language/Symantic/Compiling/Term.hs +++ b/Language/Symantic/Compiling/Term.hs @@ -1,31 +1,31 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Language.Symantic.Compiling.Term where +module Language.Symantic.Compiling.Term + ( module Language.Symantic.Compiling.Term + , module Language.Symantic.Compiling.Term.Grammar + ) where -import qualified Data.Function as Fun import qualified Data.Kind as Kind -import Data.Monoid ((<>)) import Data.Proxy (Proxy(..)) -import Data.Text (Text) import qualified Data.Text as Text import Data.Type.Equality ((:~:)(..)) import GHC.Exts (Constraint) -import Prelude hiding (not) import Language.Symantic.Lib.Data.Type.List import Language.Symantic.Parsing import Language.Symantic.Typing -import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans + +import Language.Symantic.Compiling.Term.Grammar -- * Type 'Term' -- | Closed 'TermO'. data Term is h = Term (forall term. ( Sym_of_Ifaces is term - , Sym_Lambda term + , Sym_of_Iface (Proxy (->)) term ) => term h) -- ** Type 'TermO' @@ -49,14 +49,14 @@ data Term is h -- * @(@'Sym_of_Ifaces'@ ls term)@ and @(@'Sym_of_Ifaces'@ rs term)@ -- make a zipper needed to be able to write the recursing 'CompileR' instance. -- --- * @(@'Sym_Lambda'@ term)@ +-- * @(@'Sym_of_Iface'@ (@'Proxy'@ (->)) term)@ -- is needed to handle partially applied functions. data TermO ctx h is ls rs = TermO (forall term. ( Sym_of_Ifaces is term , Sym_of_Ifaces ls term , Sym_of_Ifaces rs term - , Sym_Lambda term + , Sym_of_Iface (Proxy (->)) term ) => LamCtx_Term term ctx -> term h) -- * Type 'ETerm' @@ -73,7 +73,7 @@ class Compile is where instance CompileR is '[] is => Compile is where compileO (EToken tok) = compileR tok --- | Like 'compileO' but for a term with an empty /lambda context/. +-- | Like 'compileO' minus for a term with an empty /lambda context/. compile :: Compile is => EToken meta is @@ -85,7 +85,7 @@ compile tok = -- ** Type 'CompileT' -- | Convenient type synonym defining a term parser. type CompileT meta ctx ret is ls rs - = LamCtx_Type is Name_LamVar ctx + = LamCtx_Type is Term_Name ctx -- ^ The bound variables in scope and their types: -- built top-down in the heterogeneous list @ctx@, -- from the closest including /lambda abstraction/ to the farest. @@ -165,9 +165,6 @@ data LamCtx_Type (is::[*]) (name:: *) (ctx::[*]) where -> LamCtx_Type is name (h ': hs) infixr 5 `LamCtx_TypeS` --- ** Type 'Name_LamVar' -type Name_LamVar = Text - -- * Type 'LamCtx_Term' data LamCtx_Term (term:: * -> *) (ctx::[*]) where LamCtx_TermZ :: LamCtx_Term term '[] @@ -178,7 +175,7 @@ infixr 5 `LamCtx_TermS` -- * Type 'Error_Term' data Error_Term meta (is::[*]) - = Error_Term_unbound Name_LamVar + = Error_Term_unbound Term_Name | Error_Term_Typing (Error_Type meta '[Proxy Token_Type]) | Error_Term_Constraint_Type (Either @@ -206,7 +203,6 @@ deriving instance , Show_Const cs ) => Show (Constraint_Type meta ts cs) - instance MonoLift (Error_Type meta '[Proxy Token_Type]) (Error_Term meta ts) where olift = Error_Term_Typing . olift instance MonoLift (Error_Term meta ts) (Error_Term meta ts) where @@ -348,188 +344,3 @@ check_fam fam tys k = Constraint_Type_Fam (Text.pack . show <$> fam) (etypes tys) - --- * Class 'Sym_Lambda' -class Sym_Lambda term where - -- | /Lambda abstraction/. - lam :: (term arg -> term res) -> term ((->) arg res) - default lam :: Trans t term - => (t term arg -> t term res) - -> t term ((->) arg res) - lam f = trans_lift $ lam $ trans_apply . f . trans_lift - - -- | /Lambda application/. - (.$) :: term ((->) arg res) -> term arg -> term res - default (.$) :: Trans t term - => t term ((->) arg res) -> t term arg -> t term res - (.$) f x = trans_lift (trans_apply f .$ trans_apply x) - - -- | Convenient 'lam' and '.$' wrapper. - let_ :: term var -> (term var -> term res) -> term res - let_ x y = lam y .$ x - - id :: term a -> term a - id a = lam Fun.id .$ a - - const :: term a -> term b -> term a - const a b = lam (lam . Fun.const) .$ a .$ b - - -- | /Lambda composition/. - (^) :: term (b -> c) -> term (a -> b) -> term (a -> c) - (^) f g = lam $ \a -> f .$ (g .$ a) - - flip :: term (a -> b -> c) -> term (b -> a -> c) - flip f = lam $ \b -> lam $ \a -> f .$ a .$ b - -infixl 0 .$ -infixr 9 ^ - -type instance Sym_of_Iface (Proxy (->)) = Sym_Lambda -type instance Consts_of_Iface (Proxy (->)) = Proxy (->) ': Consts_imported_by (->) -type instance Consts_imported_by (->) = - [ Proxy Applicative - , Proxy Functor - , Proxy Monad - , Proxy Monoid - ] - -instance Sym_Lambda HostI where - lam f = HostI (unHostI . f . HostI) - (.$) = (<*>) -instance Sym_Lambda TextI where - lam f = TextI $ \p v -> - let p' = Precedence 1 in - let x = "x" <> Text.pack (show v) in - paren p p' $ "\\" <> x <> " -> " - <> unTextI (f (TextI $ \_p _v -> x)) p' (succ v) - -- (.$) = textI_infix "$" (Precedence 0) - (.$) (TextI a1) (TextI a2) = - TextI $ \p v -> - let p' = precedence_App in - paren p p' $ a1 p' v <> " " <> a2 p' v - let_ e in_ = - TextI $ \p v -> - let p' = Precedence 2 in - let x = "x" <> Text.pack (show v) in - paren p p' $ "let" <> " " <> x <> " = " - <> unTextI e (Precedence 0) (succ v) <> " in " - <> unTextI (in_ (TextI $ \_p _v -> x)) p' (succ v) - (^) = textI_infix "." (Precedence 9) - id = textI1 "id" - const = textI2 "const" - flip = textI1 "flip" -instance (Sym_Lambda r1, Sym_Lambda r2) => Sym_Lambda (DupI r1 r2) where - lam f = dupI_1 lam_f `DupI` dupI_2 lam_f - where lam_f = lam f - (.$) = dupI2 (Proxy::Proxy Sym_Lambda) (.$) - -instance - ( Read_TypeNameR Text cs rs - , Inj_Const cs (->) - ) => Read_TypeNameR Text cs (Proxy (->) ': rs) where - read_typenameR _cs "(->)" k = k (ty @(->)) - read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k -instance Show_Const cs => Show_Const (Proxy (->) ': cs) where - show_const ConstZ{} = "(->)" - show_const (ConstS c) = show_const c - -instance -- Proj_ConC (->) - ( Proj_Const cs (->) - , Proj_Consts cs (Consts_imported_by (->)) - , Proj_Con cs - ) => Proj_ConC cs (Proxy (->)) where - proj_conC _ (TyConst q :$ (TyConst c :$ _r)) - | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy (->)) - = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Functor) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Applicative) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Monad) -> Just Con - _ -> Nothing - proj_conC _ (t@(TyConst q) :$ (TyConst c :$ _a :$ b)) - | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy (->)) - = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Monoid) - , Just Con <- proj_con (t :$ b) -> Just Con - _ -> Nothing - proj_conC _c _q = Nothing -data instance TokenT meta (ts::[*]) (Proxy (->)) - = Token_Term_Abst Name_LamVar (EToken meta '[Proxy Token_Type]) (EToken meta ts) - | Token_Term_App (EToken meta ts) (EToken meta ts) - | Token_Term_Let Name_LamVar (EToken meta ts) (EToken meta ts) - | Token_Term_Var Name_LamVar -deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy (->))) -deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy (->))) -instance -- CompileI (->) - ( Inj_Const (Consts_of_Ifaces is) (->) - , Read_TypeName Name_LamVar (Consts_of_Ifaces is) - , Compile is - ) => CompileI is (Proxy (->)) where - compileI tok ctx k = - case tok of - Token_Term_Abst name_arg tok_ty_arg tok_body -> - compile_type tok_ty_arg $ \(ty_arg::Type (Consts_of_Ifaces is) h) -> - check_kind - (At Nothing SKiType) - (At (Just $ tok_ty_arg) $ kind_of ty_arg) $ \Refl -> - compileO tok_body - (LamCtx_TypeS name_arg ty_arg ctx) $ - \ty_res (TermO res) -> - k (ty_arg ~> ty_res) $ TermO $ - \c -> lam $ \arg -> - res (arg `LamCtx_TermS` c) - Token_Term_App tok_lam tok_arg_actual -> - compileO tok_lam ctx $ \ty_lam (TermO lam_) -> - compileO tok_arg_actual ctx $ \ty_arg_actual (TermO arg_actual) -> - check_type2 (ty @(->)) (At (Just tok_lam) ty_lam) $ \Refl ty_arg ty_res -> - check_type - (At (Just tok_lam) ty_arg) - (At (Just tok_arg_actual) ty_arg_actual) $ \Refl -> - k ty_res $ TermO $ - \c -> lam_ c .$ arg_actual c - Token_Term_Let name tok_bound tok_body -> - compileO tok_bound ctx $ \ty_bound (TermO bound) -> - compileO tok_body (LamCtx_TypeS name ty_bound ctx) $ - \ty_res (TermO res) -> - k ty_res $ TermO $ - \c -> let_ (bound c) $ \arg -> res (arg `LamCtx_TermS` c) - Token_Term_Var nam -> go nam ctx k - where - go :: forall meta lc ret ls rs. - Name_LamVar - -> LamCtx_Type is Name_LamVar lc - -> ( forall h. - Type (Consts_of_Ifaces is) (h::Kind.Type) - -> TermO lc h is ls rs - -> Either (Error_Term meta is) ret ) - -> Either (Error_Term meta is) ret - go name lc k' = - case lc of - LamCtx_TypeZ -> Left $ Error_Term_unbound name - LamCtx_TypeS n typ _ | n == name -> - k' typ $ TermO $ \(te `LamCtx_TermS` _) -> te - LamCtx_TypeS _n _ty lc' -> - go name lc' $ \typ (TermO te::TermO lc' h is '[] is) -> - k' typ $ TermO $ \(_ `LamCtx_TermS` c) -> te c - --- | The function 'Type' @(->)@, --- with an infix notation more readable. -(~>) :: forall cs a b. Inj_Const cs (->) - => Type cs a -> Type cs b -> Type cs (a -> b) -(~>) a b = ty @(->) :$ a :$ b -infixr 5 ~> - -{- --- * Class 'Sym_Type' -class Sym_Type term -instance Sym_Type term -type instance Sym_of_Iface (Proxy Token_Type) = Sym_Type -type instance Consts_of_Iface (Proxy Token_Type) = '[] -type instance Consts_imported_by Token_Type = '[] -instance -- Proj_ConC - Proj_ConC cs (Proxy Token_Type) -instance -- CompileI (->) - CompileI is (Proxy Token_Type) where - compileI _tok _ctx _k = Left $ Error_Term_unbound --} diff --git a/Language/Symantic/Compiling/Term/Grammar.hs b/Language/Symantic/Compiling/Term/Grammar.hs new file mode 100644 index 0000000..4ed4378 --- /dev/null +++ b/Language/Symantic/Compiling/Term/Grammar.hs @@ -0,0 +1,571 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Language.Symantic.Compiling.Term.Grammar where + +import Control.Applicative (Alternative(..)) +import Control.Arrow (left) +import Control.Monad (foldM, void, (=<<)) +import qualified Data.Char as Char +import qualified Data.Function as Fun +import qualified Data.List as List +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Monoid ((<>)) +import Data.Proxy (Proxy(..)) +import Data.Text (Text) +import qualified Data.Text as Text +import Prelude hiding (mod, not, any) + +import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar +import Language.Symantic.Parsing.EBNF +import Language.Symantic.Typing + +-- * Type 'Term_Name' +newtype Term_Name = Term_Name Text + deriving (Eq, Ord, Show) + +-- * Type 'ProTok' +-- | Proto 'EToken'. It's almost like a free monad, +-- but has a third constructor ('ProTokPi') +-- to require a type argument. +-- +-- NOTE: this type may one day be removed +-- if proper type inferencing is done. +-- In the meantime it is used to require +-- term or type arguments needed to build +-- the 'EToken's of polymorphic terms. +data ProTok meta ts + = ProTokLam (EToken meta ts -> ProTok meta ts) + -- ^ Require a term argument. + | ProTokPi (EToken meta '[Proxy Token_Type] -> ProTok meta ts) + -- ^ Require a type argument. + | ProTok (EToken meta ts) + -- ^ No need for any argument. + +-- | Declared here and not in @Compiling.Lambda@ +-- to be able to use 'Token_Term_Var' in 'protok'. +data instance TokenT meta (ts::[*]) (Proxy (->)) + = Token_Term_Abst Term_Name (EToken meta '[Proxy Token_Type]) (EToken meta ts) + | Token_Term_App (EToken meta ts) (EToken meta ts) + | Token_Term_Let Term_Name (EToken meta ts) (EToken meta ts) + | Token_Term_Var Term_Name + | Token_Term_Compose (EToken meta ts) (EToken meta ts) + +-- * Class 'Tokenize' +type Tokenize meta ts + = TokenizeR meta ts ts + +-- ** Type 'Tokenizers' +data Tokenizers meta ts + = Tokenizers + { tokenizers_prefix :: Map Mod_Path (Map Term_Name (Term_ProTok Unifix meta ts)) + , tokenizers_infix :: Map Mod_Path (Map Term_Name (Term_ProTok Infix meta ts)) + , tokenizers_postfix :: Map Mod_Path (Map Term_Name (Term_ProTok Unifix meta ts)) + } +instance Monoid (Tokenizers meta ts) where + mempty = Tokenizers Map.empty Map.empty Map.empty + mappend x y = + Tokenizers + (Map.unionWith Map.union + (tokenizers_prefix x) + (tokenizers_prefix y)) + (Map.unionWith Map.union + (tokenizers_infix x) + (tokenizers_infix y)) + (Map.unionWith Map.union + (tokenizers_postfix x) + (tokenizers_postfix y)) + +data Term_ProTok fixy meta ts + = Term_ProTok + { term_protok :: meta -> ProTok meta ts + , term_fixity :: fixy + } + +tokenizers :: forall meta ts. Tokenize meta ts => Tokenizers meta ts +tokenizers = tokenizeR (Proxy @ts) + +unProTok + :: ProTok meta ts + -> Either Error_Term_Gram (EToken meta ts) +unProTok (ProTok t) = Right t +unProTok _ = Left Error_Term_Gram_Term_incomplete + +protok + :: Inj_Token meta ts (->) + => Mod Term_Name + -> Tokenizers meta ts + -> Either Error_Term_Gram + ( Maybe (Term_ProTok Unifix meta ts) + , Term_ProTok Infix meta ts + , Maybe (Term_ProTok Unifix meta ts) + ) +protok (mod `Mod` tn) (Tokenizers pres ins posts) = do + let pre = Map.lookup mod pres >>= Map.lookup tn + let post = Map.lookup mod posts >>= Map.lookup tn + in_ <- var_or_err $ Map.lookup mod ins >>= Map.lookup tn + return (pre, in_, post) + where + var_or_err (Just x) = Right x + var_or_err Nothing = + case mod of + [] -> Right (var infixN5) + _ -> Left $ Error_Term_Gram_Undefined_term + var term_fixity = + Term_ProTok + { term_protok = \meta -> ProTok $ inj_etoken meta $ Token_Term_Var tn + , term_fixity + } + +protok_app + :: Inj_Token meta ts (->) + => ProTok meta ts + -> [Either (EToken meta '[Proxy Token_Type]) (EToken meta ts)] + -> Either Error_Term_Gram (ProTok meta ts) +protok_app = + foldM app + where + app acc (Left typ) = + case acc of + ProTokPi g -> Right $ g typ + _ -> Left Error_Term_Gram_Cannot_apply_type + app acc (Right te) = + case acc of + ProTokLam f -> Right $ f te + ProTok tok@(EToken e) -> Right $ + ProTok $ inj_etoken (meta_of e) $ + Token_Term_App tok te + _ -> Left Error_Term_Gram_Cannot_apply_term + +-- ** Class 'TokenizeR' +class TokenizeR meta (ts::[*]) (rs::[*]) where + tokenizeR :: Proxy rs -> Tokenizers meta ts +instance TokenizeR meta ts '[] where + tokenizeR _rs = mempty +instance + ( TokenizeT meta ts t + , TokenizeR meta ts rs + ) => TokenizeR meta ts (t ': rs) where + tokenizeR _ = + tokenizeR (Proxy @rs) `mappend` + tokenizeT (Proxy @t) + +-- ** Class 'TokenizeT' +class TokenizeT meta ts t where + tokenizeT :: Proxy t -> Tokenizers meta ts + -- tokenizeT _t = [] `Mod` [] + tokenizeT _t = mempty + +tokenizeTMod + :: Mod_Path + -> [(Term_Name, Term_ProTok fix meta ts)] + -> Map Mod_Path (Map Term_Name (Term_ProTok fix meta ts)) +tokenizeTMod mod tbl = Map.singleton mod $ Map.fromList tbl + +tokenize0 + :: Inj_Token meta ts t + => Text -> fixity -> TokenT meta ts (Proxy t) + -> (Term_Name, Term_ProTok fixity meta ts) +tokenize0 n term_fixity tok = + (Term_Name n,) Term_ProTok + { term_protok = \meta -> ProTok $ inj_etoken meta $ tok + , term_fixity } + +tokenize1 + :: Inj_Token meta ts t + => Text -> fixity + -> (EToken meta ts -> TokenT meta ts (Proxy t)) + -> (Term_Name, Term_ProTok fixity meta ts) +tokenize1 n term_fixity tok = + (Term_Name n,) Term_ProTok + { term_protok = \meta -> + ProTokLam $ \a -> + ProTok $ inj_etoken meta $ tok a + , term_fixity } + +tokenize2 + :: Inj_Token meta ts t + => Text -> fixity + -> (EToken meta ts -> EToken meta ts -> TokenT meta ts (Proxy t)) + -> (Term_Name, Term_ProTok fixity meta ts) +tokenize2 n term_fixity tok = + (Term_Name n,) Term_ProTok + { term_protok = \meta -> + ProTokLam $ \a -> ProTokLam $ \b -> + ProTok $ inj_etoken meta $ tok a b + , term_fixity + } + +tokenize3 + :: Inj_Token meta ts t + => Text -> fixity + -> (EToken meta ts -> EToken meta ts -> EToken meta ts -> TokenT meta ts (Proxy t)) + -> (Term_Name, Term_ProTok fixity meta ts) +tokenize3 n term_fixity tok = + (Term_Name n,) Term_ProTok + { term_protok = \meta -> + ProTokLam $ \a -> ProTokLam $ \b -> ProTokLam $ \c -> + ProTok $ inj_etoken meta $ tok a b c + , term_fixity + } + +-- * Type 'Mod' +type Mod_Path = [Mod_Name] +newtype Mod_Name = Mod_Name Text + deriving (Eq, Ord, Show) +data Mod a = Mod Mod_Path a + deriving (Eq, Functor, Ord, Show) + +-- * Class 'Gram_Term_Name' +class + ( Alternative g + , Alt g + , Alter g + , Alter g + , App g + , Gram_CF g + , Gram_Lexer g + , Gram_RegL g + , Gram_Rule g + , Gram_Terminal g + ) => Gram_Term_Name g where + mod_path :: CF g Mod_Path + mod_path = rule "mod_path" $ + infixrG + (pure <$> mod_name) + (op <$ char '.') + where op = mappend + mod_name :: CF g Mod_Name + mod_name = rule "mod_name" $ + (Mod_Name . Text.pack <$>) $ + identG `minus` + (Fun.const + <$> term_keywords + <*. (any `but` term_idname_tail)) + where + identG = (:) <$> headG <*> many (cf_of_term term_idname_tail) + headG = unicat $ Unicat Char.UppercaseLetter + + term_mod_name :: CF g (Mod Term_Name) + term_mod_name = rule "term_mod_name" $ + lexeme $ + term_mod_idname <+> + parens term_mod_opname + term_name :: CF g Term_Name + term_name = rule "term_name" $ + lexeme $ + term_idname <+> + parens term_opname + + term_mod_idname :: CF g (Mod Term_Name) + term_mod_idname = rule "term_mod_idname" $ + Mod + <$> option [] (mod_path <* char '.') + <*> term_idname + term_idname :: CF g Term_Name + term_idname = rule "term_idname" $ + (Term_Name . Text.pack <$>) $ + (identG `minus`) $ + Fun.const + <$> term_keywords + <*. (any `but` term_idname_tail) + where + identG = (:) <$> headG <*> many (cf_of_term term_idname_tail) + headG = unicat $ Unicat_Letter + term_idname_tail :: Terminal g Char + term_idname_tail = rule "term_idname_tail" $ + unicat Unicat_Letter <+> + unicat Unicat_Number + term_keywords :: Reg rl g String + term_keywords = rule "term_keywords" $ + choice $ string <$> ["in", "let"] + + term_mod_opname :: CF g (Mod Term_Name) + term_mod_opname = rule "term_mod_opname" $ + Mod + <$> option [] (mod_path <* char '.') + <*> term_opname + term_opname :: CF g Term_Name + term_opname = rule "term_opname" $ + (Term_Name . Text.pack <$>) $ + (symG `minus`) $ + Fun.const + <$> term_keysyms + <*. (any `but` term_opname_ok) + where + symG = some $ cf_of_term $ term_opname_ok + term_opname_ok :: Terminal g Char + term_opname_ok = rule "term_opname_ok" $ + choice (unicat <$> + [ Unicat_Symbol + , Unicat_Punctuation + , Unicat_Mark + ]) `but` koG + where + koG = choice (char <$> ['(', ')', '`', '\'', ',', '[', ']']) + term_keysyms :: Reg rl g String + term_keysyms = rule "term_keysyms" $ + choice $ string <$> ["\\", "->", "="] + +deriving instance Gram_Term_Name g => Gram_Term_Name (CF g) +instance Gram_Term_Name EBNF +instance Gram_Term_Name RuleDef + +-- * Class 'Gram_Term_Type' +class + ( Alternative g + , Alt g + , Alter g + , App g + , Gram_CF g + , Gram_Lexer g + , Gram_Meta meta g + , Gram_Rule g + , Gram_Terminal g + , Gram_Term_Name g + , Gram_Type meta g + ) => Gram_Term_Type meta g where + term_abst_decl + :: CF g (Term_Name, TokType meta) + term_abst_decl = rule "term_abst_decl" $ + parens $ (,) + <$> term_name + <* symbol ":" + <*> typeG + +deriving instance Gram_Term_Type meta g => Gram_Term_Type meta (CF g) +instance Gram_Term_Type meta EBNF +instance Gram_Term_Type meta RuleDef + +-- * Class 'Gram_Error' +class Gram_Error g where + term_unError :: CF g (Either Error_Term_Gram a) -> CF g a +deriving instance Gram_Error g => Gram_Error (CF g) +instance Gram_Error EBNF where + term_unError (CF (EBNF g)) = CF $ EBNF g +instance Gram_Error RuleDef where + term_unError (CF (RuleDef (EBNF g))) = + CF $ RuleDef $ EBNF $ g + +-- ** Type 'Error_Term_Gram' +data Error_Term_Gram + = Error_Term_Gram_Fixity Error_Fixity + | Error_Term_Gram_Cannot_apply_term + | Error_Term_Gram_Cannot_apply_type + | Error_Term_Gram_Undefined_term + | Error_Term_Gram_Term_incomplete + deriving (Eq, Show) + +-- * Class 'Gram_Term' +class + ( Alternative g + , Alt g + , Alter g + , App g + , Gram_CF g + , Gram_Lexer g + , Gram_Meta meta g + , Gram_Rule g + , Gram_Terminal g + , Gram_Error g + , Gram_Term_AtomsR meta ts ts g + , Gram_Term_Name g + , Gram_Term_Type meta g + , Gram_Type meta g + ) => Gram_Term ts meta g where + -- | Wrap 'term_abst'. Useful to modify body's scope. + term_abst_args_body + :: CF g [(Term_Name, TokType meta)] + -> CF g (EToken meta ts) + -> CF g ([(Term_Name, TokType meta)], EToken meta ts) + term_abst_args_body args body = (,) <$> args <*> body + term_tokenizers :: CF g (Tokenizers meta ts -> a) -> CF g a + + termG + :: Inj_Tokens meta ts '[Proxy (->)] + => CF g (EToken meta ts) + termG = rule "term" $ + choice $ + [ term_abst + , term_let + , term_operators + ] + term_operators + :: Inj_Tokens meta ts '[Proxy (->)] + => CF g (EToken meta ts) + term_operators = rule "term_operators" $ + term_unError $ + term_unError $ + left Error_Term_Gram_Fixity <$> + operators + (Right <$> term_app) + (term_unError $ metaG $ term_tokenizers $ op_prefix <$> term_op_prefix) + (term_unError $ metaG $ term_tokenizers $ op_infix <$> term_op_infix) + (term_unError $ metaG $ term_tokenizers $ op_postfix <$> term_op_postfix) + where + bqG :: Gram_Terminal g' => g' Char + bqG = char '`' + op_infix name toks meta = do + (_pre, in_, _post) <- protok name toks + return $ + (term_fixity in_,) $ \ma mb -> do + a <- ma + b <- mb + unProTok =<< term_protok in_ meta `protok_app` [Right a, Right b] + op_prefix name toks meta = do + (pre, _in_, _post) <- protok name toks + case pre of + Just p -> + Right $ (term_fixity p,) $ (=<<) $ \a -> + unProTok =<< term_protok p meta `protok_app` [Right a] + Nothing -> Left $ Error_Term_Gram_Fixity Error_Fixity_NeedPrefix + op_postfix name toks meta = do + (_pre, _in_, post) <- protok name toks + case post of + Just p -> + Right $ (term_fixity p,) $ (=<<) $ \a -> + unProTok =<< term_protok p meta `protok_app` [Right a] + Nothing -> Left $ Error_Term_Gram_Fixity Error_Fixity_NeedPostfix + term_op_postfix :: CF g (Mod Term_Name) + term_op_postfix = rule "term_op_postfix" $ + lexeme $ + bqG *> term_mod_idname <+> -- <* (cf_of_term $ Gram.Term (pure ' ') `but` bqG) + term_mod_opname + term_op_infix :: CF g (Mod Term_Name) + term_op_infix = rule "term_op_infix" $ + lexeme $ + between bqG bqG term_mod_idname <+> + term_mod_opname + term_op_prefix :: CF g (Mod Term_Name) + term_op_prefix = rule "term_op_prefix" $ + lexeme $ + term_mod_idname <* bqG <+> + term_mod_opname + term_app + :: Inj_Tokens meta ts '[Proxy (->)] + => CF g (EToken meta ts) + term_app = rule "term_app" $ + term_unError $ + (\a as -> unProTok =<< protok_app a as) + <$> term_atom_proto + <*> many term_atom + term_atom + :: Inj_Tokens meta ts '[Proxy (->)] + => CF g (Either (EToken meta '[Proxy Token_Type]) + (EToken meta ts)) + term_atom = rule "term_atom" $ + (Left <$ char '@' <*> typeG) <+> + (Right <$> term_unError (unProTok <$> term_atom_proto)) + term_atom_proto + :: Inj_Tokens meta ts '[Proxy (->)] + => CF g (ProTok meta ts) + term_atom_proto = + choice $ + term_atomsR (Proxy @ts) <> + [ metaG $ ((\(_, in_, _) -> term_protok in_) <$>) $ term_unError $ term_tokenizers $ + protok <$> term_mod_name + , ProTok <$> term_group + ] + term_group + :: Inj_Tokens meta ts '[Proxy (->)] + => CF g (EToken meta ts) + term_group = rule "term_group" $ parens termG + term_abst + :: Inj_Tokens meta ts '[Proxy (->)] + => CF g (EToken meta ts) + term_abst = rule "term_abst" $ + metaG $ + ((\(xs, te) meta -> + List.foldr (\(x, ty_x) -> + inj_etoken meta . + Token_Term_Abst x ty_x) te xs) <$>) $ + term_abst_args_body + (symbol "\\" *> some term_abst_decl <* symbol "->") + termG + term_let + :: Inj_Tokens meta ts '[Proxy (->)] + => CF g (EToken meta ts) + term_let = rule "term_let" $ + metaG $ + (\name args bound body meta -> + inj_etoken meta $ + Token_Term_Let name + (List.foldr + (\(x, ty_x) -> inj_etoken meta . Token_Term_Abst x ty_x) bound args + ) body) + <$ symbol "let" + <*> term_name + <*> many term_abst_decl + <* symbol "=" + <*> termG + <* symbol "in" + <*> termG + +deriving instance + ( Gram_Term ts meta g + , Gram_Term_AtomsR meta ts ts (CF g) + ) => Gram_Term ts meta (CF g) +instance + Gram_Term_AtomsR meta ts ts EBNF => + Gram_Term ts meta EBNF where + term_tokenizers (CF (EBNF g)) = CF $ EBNF g +instance + Gram_Term_AtomsR meta ts ts RuleDef => + Gram_Term ts meta RuleDef where + term_tokenizers (CF (RuleDef (EBNF g))) = + CF $ RuleDef $ EBNF $ g + +-- ** Class 'Gram_Term_AtomsR' +class Gram_Term_AtomsR meta (ts::[*]) (rs::[*]) g where + term_atomsR :: Proxy rs -> [CF g (ProTok meta ts)] +instance Gram_Term_AtomsR meta ts '[] g where + term_atomsR _rs = [] +instance + ( Gram_Term_AtomsT meta ts t g + , Gram_Term_AtomsR meta ts rs g + ) => Gram_Term_AtomsR meta ts (t ': rs) g where + term_atomsR _ = + term_atomsT (Proxy @t) <> + term_atomsR (Proxy @rs) + +-- ** Class 'Gram_Term_AtomsT' +class Gram_Term_AtomsT meta ts t g where + term_atomsT :: Proxy t -> [CF g (ProTok meta ts)] + term_atomsT _t = [] + +gram_term + :: forall g. + ( Gram_Term '[Proxy (->), Proxy Integer] () g + ) => [CF g ()] +gram_term = + [ ue termG + , ue term_operators + , ue term_app + , ug term_atom + , ue term_group + , ue term_abst + , void (term_abst_decl::CF g (Term_Name, TokType ())) + , ue term_let + , void term_mod_name + , void term_name + , void term_idname + , void $ cf_of_term term_idname_tail + , void $ cf_of_reg term_keywords + , void term_mod_opname + , void term_opname + , void $ cf_of_term term_opname_ok + , void $ cf_of_reg term_keysyms + ] where + ue :: CF g (EToken () '[Proxy (->), Proxy Integer]) -> CF g () + ue = (() <$) + -- uf :: CF g (ProTok () '[Proxy (->)]) -> CF g () + -- uf = (() <$) + ug :: CF g (Either (EToken () '[Proxy Token_Type]) + (EToken () '[Proxy (->), Proxy Integer])) -> CF g () + ug = (() <$) diff --git a/Language/Symantic/Compiling/Term/HLint.hs b/Language/Symantic/Compiling/Term/HLint.hs new file mode 120000 index 0000000..ab18269 --- /dev/null +++ b/Language/Symantic/Compiling/Term/HLint.hs @@ -0,0 +1 @@ +../HLint.hs \ No newline at end of file diff --git a/Language/Symantic/Compiling/Term/Test.hs b/Language/Symantic/Compiling/Term/Test.hs index 9fd0170..8077e93 100644 --- a/Language/Symantic/Compiling/Term/Test.hs +++ b/Language/Symantic/Compiling/Term/Test.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Compiling.Term.Test where import Test.Tasty @@ -5,44 +7,111 @@ import Test.Tasty.HUnit import qualified Control.Arrow as Arrow import qualified Control.Monad as Monad +import qualified Control.Monad.Classes as MC +import qualified Control.Monad.Classes.Run as MC -- import Control.Monad.IO.Class (MonadIO(..)) +import qualified Control.Monad.Trans.State.Strict as SS +import qualified Data.Foldable as Foldable +import Data.Functor.Identity (Identity(..)) +import qualified Data.Map.Strict as Map import Data.Proxy (Proxy(..)) import Data.Text (Text) import Data.Type.Equality ((:~:)(Refl)) -import Prelude as P +import Prelude as Pre +import qualified Text.Megaparsec as P -import Language.Symantic.Parsing -import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting +import Language.Symantic.Parsing +import qualified Language.Symantic.Parsing.Grammar as Gram +import Language.Symantic.Typing -import Parsing.Test +import Parsing.Grammar.Test +import Typing.Test () + +type Meta = () + +--- +-- P.ParsecT instances +--- +type instance MC.CanDo (P.ParsecT e s m) eff = 'False +instance ParsecC e s => Gram_Term_Name (P.ParsecT e s m) +instance ParsecC e s => Gram.Gram_Meta Meta (P.ParsecT e s m) where + metaG = (($ ()) Pre.<$>) +instance + ( ParsecC e s + , Gram.Gram_Meta meta (P.ParsecT e s m) + ) => Gram_Term_Type meta (P.ParsecT e s m) +instance + ( ParsecC e s + ) => Gram_Error (P.ParsecT e s m) where + term_unError (Gram.CF me) = Gram.CF $ do + e <- me + case e of + Left err -> Monad.fail $ Pre.show err + Right a -> Monad.return a +instance + ( ParsecC e s + , Gram.Gram_Meta meta (P.ParsecT e s m) + , MC.MonadState (Tokenizers meta ts) m + , Gram_Term_AtomsR meta ts ts (P.ParsecT e s m) + ) => Gram_Term ts meta (P.ParsecT e s m) where + term_tokenizers (Gram.CF ma) = Gram.CF $ do + a <- ma + toks :: Tokenizers meta ts <- MC.get + Monad.return $ a toks + term_abst_args_body (Gram.CF args) (Gram.CF body) = Gram.CF $ do + as <- args + bo <- do + toks :: Tokenizers meta ts <- MC.get + MC.put $ + Tokenizers + { tokenizers_prefix = del (tokenizers_prefix toks) as + , tokenizers_infix = del (tokenizers_infix toks) as + , tokenizers_postfix = del (tokenizers_postfix toks) as + } + body Pre.<* MC.put toks + Monad.return (as, bo) + where del = Foldable.foldr (\(n, _) -> Map.adjust (Map.delete n) []) + +test_tokenizer :: forall is. + ( Inj_Tokens Meta is [Proxy (->), Proxy Integer] + , Gram_Term is Meta (P.ParsecT P.Dec String (SS.StateT (Tokenizers Meta is) Identity)) + , Tokenize Meta is + ) => String -> Either (P.ParseError Char P.Dec) (EToken Meta is) +test_tokenizer inp = + runIdentity $ + MC.evalStateStrict (tokenizers::Tokenizers Meta is) $ + (`runParserT` inp) $ + Gram.unCF $ (termG Pre.<* Gram.eoi) test_compile - :: forall ast is h. + :: forall is h. ( Eq h - , Eq ast - , Eq_Token ast is - , Show ast + , Eq_Token Meta is , Show h , Show_Const (Consts_of_Ifaces is) - , Show_Token ast is + , Show_Token Meta is , Sym_of_Ifaces is HostI , Sym_of_Ifaces is TextI , Compile is - , Tokenize ast ast is + , Inj_Tokens Meta is [Proxy (->), Proxy Integer] + , Gram_Term is Meta (P.ParsecT P.Dec String (SS.StateT (Tokenizers Meta is) Identity)) + , Tokenize Meta is ) => Proxy is - -> ast - -> Either (Type (Consts_of_Ifaces is) h, Either (Error_Syntax ast) (Error_Term ast is)) + -> String + -> Either ( Type (Consts_of_Ifaces is) h + , Either (P.ParseError Char P.Dec) + (Error_Term Meta is) ) (Type (Consts_of_Ifaces is) h, h, Text) -> TestTree -test_compile _is syn expected = - testCase (elide $ P.show syn) $ - case tokenize syn of - Left err -> Left (Left err) @?= P.snd `Arrow.left` expected - Right (tok::EToken ast is) -> +test_compile _is inp expected = + testCase (elide inp) $ + case test_tokenizer inp of + Left err -> Left (Left err) @?= Pre.snd `Arrow.left` expected + Right tok -> case compile tok of - Left err -> Left (Right err) @?= P.snd `Arrow.left` expected + Left err -> Left (Right err) @?= Pre.snd `Arrow.left` expected Right (ETerm typ (Term te)) -> case expected of Left (_, err) -> Right ("…"::Text) @?= Left err @@ -63,6 +132,7 @@ test_compile _is syn expected = , text_from_term te -- , (text_from_term :: Repr_Text h -> Text) r ) - where - elide s | P.length s P.> 42 = P.take 42 s P.++ ['…'] - elide s = s + +maybeRight :: Either l r -> Maybe r +maybeRight (Right r) = Just r +maybeRight Left{} = Nothing diff --git a/Language/Symantic/Compiling/Test.hs b/Language/Symantic/Compiling/Test.hs index 3b872b5..c6a3f3d 100644 --- a/Language/Symantic/Compiling/Test.hs +++ b/Language/Symantic/Compiling/Test.hs @@ -4,29 +4,19 @@ module Compiling.Test where import Test.Tasty +import Language.Symantic.Compiling + import qualified Compiling.Applicative.Test as Applicative import qualified Compiling.Bool.Test as Bool import qualified Compiling.Foldable.Test as Foldable import qualified Compiling.Functor.Test as Functor import qualified Compiling.Map.Test as Map import qualified Compiling.MonoFunctor.Test as MonoFunctor +import qualified Compiling.Num.Test as Num +import qualified Compiling.Tuple2.Test as Tuple2 import Prelude hiding ((&&), not, (||), (==), id) -{- -import Language.Symantic.Compiling - --- * Terms -te1 = lam $ \x -> lam $ \y -> (x || y) && not (x && y) -te2 = lam $ \x -> lam $ \y -> (x && not y) || (not x && y) -te3 = let_ (bool True) $ \x -> x && x -te4 = let_ (lam $ \x -> x && x) $ \f -> f .$ bool True -te5 = lam $ \x0 -> lam $ \x1 -> x0 && x1 -te6 = let_ (bool True) id && bool False -te7 = lam $ \f -> (f .$ bool True) && bool True -te8 = lam $ \f -> f .$ (bool True && bool True) --} - -- * Tests tests :: TestTree tests = testGroup "Compiling" $ @@ -36,4 +26,16 @@ tests = testGroup "Compiling" $ , Functor.tests , Map.tests , MonoFunctor.tests + , Num.tests + , Tuple2.tests ] + +-- * EDSL tests +te1 = lam $ \x -> lam $ \y -> (x || y) && not (x && y) +te2 = lam $ \x -> lam $ \y -> (x && not y) || (not x && y) +te3 = let_ (bool True) $ \x -> x && x +te4 = let_ (lam $ \x -> x && x) $ \f -> f .$ bool True +te5 = lam $ \x0 -> lam $ \x1 -> x0 && x1 +te6 = let_ (bool True) id && bool False +te7 = lam $ \f -> (f .$ bool True) && bool True +te8 = lam $ \f -> f .$ (bool True && bool True) diff --git a/Language/Symantic/Compiling/Text.hs b/Language/Symantic/Compiling/Text.hs index c0348d8..b24ed00 100644 --- a/Language/Symantic/Compiling/Text.hs +++ b/Language/Symantic/Compiling/Text.hs @@ -38,10 +38,10 @@ instance (Sym_Text r1, Sym_Text r2) => Sym_Text (DupI r1 r2) where text x = text x `DupI` text x instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Text - ) => Read_TypeNameR Text cs (Proxy Text ': rs) where - read_typenameR _cs "Text" k = k (ty @Text) + ) => Read_TypeNameR Type_Name cs (Proxy Text ': rs) where + read_typenameR _cs (Type_Name "Text") k = k (ty @Text) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Text ': cs) where show_const ConstZ{} = "Text" @@ -53,12 +53,12 @@ instance -- Proj_ConC ) => Proj_ConC cs (Proxy Text) where proj_conC _ (TyConst q :$ TyConst c) | Just Refl <- eq_skind (kind_of_const c) SKiType - , Just Refl <- proj_const c (Proxy::Proxy Text) + , Just Refl <- proj_const c (Proxy @Text) = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Eq) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Monoid) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Ord) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Show) -> Just Con + _ | Just Refl <- proj_const q (Proxy @Eq) -> Just Con + | Just Refl <- proj_const q (Proxy @Monoid) -> Just Con + | Just Refl <- proj_const q (Proxy @Ord) -> Just Con + | Just Refl <- proj_const q (Proxy @Show) -> Just Con _ -> Nothing proj_conC _c _q = Nothing data instance TokenT meta (ts::[*]) (Proxy Text) @@ -71,3 +71,7 @@ instance -- CompileI compileI tok _ctx k = case tok of Token_Term_Text i -> k (ty @Text) $ TermO $ \_c -> text i +instance -- TokenizeT + -- Inj_Token meta ts Show => + TokenizeT meta ts (Proxy Show) +instance Gram_Term_AtomsT meta ts (Proxy Show) g -- TODO diff --git a/Language/Symantic/Compiling/Traversable.hs b/Language/Symantic/Compiling/Traversable.hs index 74985e2..d96c43e 100644 --- a/Language/Symantic/Compiling/Traversable.hs +++ b/Language/Symantic/Compiling/Traversable.hs @@ -5,12 +5,12 @@ module Language.Symantic.Compiling.Traversable where import Control.Monad (liftM2) import Data.Proxy -import Data.Text (Text) import qualified Data.Traversable as Traversable import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (traverse) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term import Language.Symantic.Compiling.Applicative (Sym_Applicative) @@ -37,10 +37,10 @@ instance (Sym_Traversable r1, Sym_Traversable r2) => Sym_Traversable (DupI r1 r2 traverse = dupI2 (Proxy @Sym_Traversable) traverse instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Traversable - ) => Read_TypeNameR Text cs (Proxy Traversable ': rs) where - read_typenameR _cs "Traversable" k = k (ty @Traversable) + ) => Read_TypeNameR Type_Name cs (Proxy Traversable ': rs) where + read_typenameR _cs (Type_Name "Traversable") k = k (ty @Traversable) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Traversable ': cs) where show_const ConstZ{} = "Traversable" @@ -72,3 +72,12 @@ instance -- CompileI (At (Just tok_ta) ty_ta_a) $ \Refl -> k (ty_a2fb_fb_f :$ (ty_ta_t :$ ty_a2fb_fb_b)) $ TermO $ \c -> traverse (a2fb c) (ta c) +instance -- TokenizeT + Inj_Token meta ts Traversable => + TokenizeT meta ts (Proxy Traversable) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ tokenize2 "traverse" infixN5 Token_Term_Traversable_traverse + ] + } +instance Gram_Term_AtomsT meta ts (Proxy Traversable) g diff --git a/Language/Symantic/Compiling/Tuple2.hs b/Language/Symantic/Compiling/Tuple2.hs index 2a1c073..f3b9197 100644 --- a/Language/Symantic/Compiling/Tuple2.hs +++ b/Language/Symantic/Compiling/Tuple2.hs @@ -7,12 +7,12 @@ module Language.Symantic.Compiling.Tuple2 where import Control.Monad (liftM, liftM2) import Data.Monoid ((<>)) import Data.Proxy -import Data.Text (Text) import qualified Data.Tuple as Tuple import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (fst, snd) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term import Language.Symantic.Interpreting @@ -53,9 +53,9 @@ instance Sym_Tuple2 HostI where snd = liftM Tuple.snd instance Sym_Tuple2 TextI where tuple2 (TextI a) (TextI b) = - TextI $ \_p v -> - let p' = precedence_Toplevel in - "(" <> a p' v <> ", " <> b p' v <> ")" + TextI $ \_po v -> + "(" <> a (op, L) v <> ", " <> b (op, R) v <> ")" + where op = infixN 0 fst = textI1 "fst" snd = textI1 "snd" instance (Sym_Tuple2 r1, Sym_Tuple2 r2) => Sym_Tuple2 (DupI r1 r2) where @@ -64,10 +64,10 @@ instance (Sym_Tuple2 r1, Sym_Tuple2 r2) => Sym_Tuple2 (DupI r1 r2) where snd = dupI1 (Proxy @Sym_Tuple2) snd instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs (,) - ) => Read_TypeNameR Text cs (Proxy (,) ': rs) where - read_typenameR _cs "(,)" k = k (ty @(,)) + ) => Read_TypeNameR Type_Name cs (Proxy (,) ': rs) where + read_typenameR _cs (Type_Name "(,)") k = k (ty @(,)) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy (,) ': cs) where show_const ConstZ{} = "(,)" @@ -81,33 +81,33 @@ instance -- Proj_ConC ) => Proj_ConC cs (Proxy (,)) where proj_conC _ (TyConst q :$ (TyConst c :$ a)) | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy (,)) + , Just Refl <- proj_const c (Proxy @(,)) = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Applicative) + _ | Just Refl <- proj_const q (Proxy @Applicative) + , Just Con <- proj_con (ty @Monoid :$ a) -> Just Con + | Just Refl <- proj_const q (Proxy @Functor) -> Just Con + | Just Refl <- proj_const q (Proxy @Foldable) -> Just Con + | Just Refl <- proj_const q (Proxy @Monad) , Just Con <- proj_con (ty @Monoid :$ a) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Functor) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Foldable) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Monad) - , Just Con <- proj_con (ty @Monoid :$ a) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Traversable) -> Just Con + | Just Refl <- proj_const q (Proxy @Traversable) -> Just Con _ -> Nothing proj_conC _ (t@(TyConst q) :$ (TyConst c :$ a :$ b)) | Just Refl <- eq_skind (kind_of_const c) (SKiType `SKiArrow` SKiType `SKiArrow` SKiType) - , Just Refl <- proj_const c (Proxy::Proxy (,)) + , Just Refl <- proj_const c (Proxy @(,)) = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Bounded) + _ | Just Refl <- proj_const q (Proxy @Bounded) , Just Con <- proj_con (t :$ a) , Just Con <- proj_con (t :$ b) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Eq) + | Just Refl <- proj_const q (Proxy @Eq) , Just Con <- proj_con (t :$ a) , Just Con <- proj_con (t :$ b) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Monoid) + | Just Refl <- proj_const q (Proxy @Monoid) , Just Con <- proj_con (t :$ a) , Just Con <- proj_con (t :$ b) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Ord) + | Just Refl <- proj_const q (Proxy @Ord) , Just Con <- proj_con (t :$ a) , Just Con <- proj_con (t :$ b) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Show) + | Just Refl <- proj_const q (Proxy @Show) , Just Con <- proj_con (t :$ a) , Just Con <- proj_con (t :$ b) -> Just Con _ -> Nothing @@ -142,3 +142,33 @@ instance -- CompileI check_type2 (ty @(,)) (At (Just tok_ab) ty_ab) $ \Refl _ty_a ty_b -> k ty_b $ TermO $ \c -> snd (ab c) +instance -- TokenizeT + Inj_Token meta ts (,) => + TokenizeT meta ts (Proxy (,)) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ tokenize1 "fst" infixN5 Token_Term_Tuple2_fst + , tokenize1 "snd" infixN5 Token_Term_Tuple2_snd + ] + } +instance -- Gram_Term_AtomsT + ( Alt g + , Gram_Rule g + , Gram_Lexer g + , Gram_Meta meta g + , Gram_Term ts meta g + , Inj_Token meta ts (->) + , Inj_Token meta ts (,) + ) => Gram_Term_AtomsT meta ts (Proxy (,)) g where + term_atomsT _t = + [ rule "term_tuple2" $ + metaG $ parens $ + (\a b meta -> ProTok $ inj_etoken meta $ Token_Term_Tuple2 a b) + <$> termG + <* symbol "," + <*> termG + , rule "term_tuple2" $ + metaG $ + (\meta -> ProTokLam $ \a -> ProTokLam $ \b -> ProTok $ inj_etoken meta $ Token_Term_Tuple2 a b) + <$ symbol "(,)" + ] diff --git a/Language/Symantic/Compiling/Tuple2/Test.hs b/Language/Symantic/Compiling/Tuple2/Test.hs new file mode 100644 index 0000000..45a2ebd --- /dev/null +++ b/Language/Symantic/Compiling/Tuple2/Test.hs @@ -0,0 +1,30 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module Compiling.Tuple2.Test where + +import Test.Tasty + +import Data.Proxy (Proxy(..)) +import Prelude hiding ((&&), not, (||)) + +import Language.Symantic.Typing +import Compiling.Term.Test +import Compiling.Bool.Test () + +type Ifaces = + [ Proxy (->) + , Proxy Integer + , Proxy () + , Proxy (,) + ] +(==>) = test_compile (Proxy::Proxy Ifaces) + +tests :: TestTree +tests = testGroup "Tuple2" + [ "()" ==> Right (ty @(), (), "()") + , "(,) 1 2" ==> Right (ty @(,) :$ ty @Integer :$ ty @Integer, (1,2), "(1, 2)") + , "(1,2)" ==> Right (ty @(,) :$ ty @Integer :$ ty @Integer, (1,2), "(1, 2)") + , "((1,2), (3,4))" ==> Right + ( let t = ty @(,) :$ ty @Integer :$ ty @Integer in ty @(,) :$ t :$ t + , ((1,2),(3,4)) + , "((1, 2), (3, 4))" ) + ] diff --git a/Language/Symantic/Compiling/Unit.hs b/Language/Symantic/Compiling/Unit.hs index 1ee5f47..a65ed0a 100644 --- a/Language/Symantic/Compiling/Unit.hs +++ b/Language/Symantic/Compiling/Unit.hs @@ -7,11 +7,11 @@ module Language.Symantic.Compiling.Unit where import qualified Data.Function as Fun import Data.Monoid import Data.Proxy -import Data.Text (Text) import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding ((&&), not, (||)) import Language.Symantic.Parsing +import Language.Symantic.Parsing.Grammar as Gram import Language.Symantic.Typing import Language.Symantic.Compiling.Term import Language.Symantic.Interpreting @@ -42,10 +42,10 @@ instance (Sym_Unit r1, Sym_Unit r2) => Sym_Unit (DupI r1 r2) where unit = unit `DupI` unit instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs () - ) => Read_TypeNameR Text cs (Proxy () ': rs) where - read_typenameR _cs "()" k = k (ty @()) + ) => Read_TypeNameR Type_Name cs (Proxy () ': rs) where + read_typenameR _cs (Type_Name "()") k = k (ty @()) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy () ': cs) where show_const ConstZ{} = "()" @@ -57,14 +57,14 @@ instance -- Proj_ConC ) => Proj_ConC cs (Proxy ()) where proj_conC _ (TyConst q :$ TyConst c) | Just Refl <- eq_skind (kind_of_const c) SKiType - , Just Refl <- proj_const c (Proxy::Proxy ()) + , Just Refl <- proj_const c (Proxy @()) = case () of - _ | Just Refl <- proj_const q (Proxy::Proxy Bounded) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Enum) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Eq) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Monoid) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Ord) -> Just Con - | Just Refl <- proj_const q (Proxy::Proxy Show) -> Just Con + _ | Just Refl <- proj_const q (Proxy @Bounded) -> Just Con + | Just Refl <- proj_const q (Proxy @Enum) -> Just Con + | Just Refl <- proj_const q (Proxy @Eq) -> Just Con + | Just Refl <- proj_const q (Proxy @Monoid) -> Just Con + | Just Refl <- proj_const q (Proxy @Ord) -> Just Con + | Just Refl <- proj_const q (Proxy @Show) -> Just Con _ -> Nothing proj_conC _c _q = Nothing data instance TokenT meta (ts::[*]) (Proxy ()) @@ -77,3 +77,19 @@ instance -- CompileI compileI tok _ctx k = case tok of Token_Term_Unit -> k (ty @()) $ TermO $ Fun.const unit +instance -- TokenizeT + -- Inj_Token meta ts () => + TokenizeT meta ts (Proxy ()) +instance -- Gram_Term_AtomsT + ( Gram_Rule g + , Gram_Lexer g + , Gram_Meta meta g + , Inj_Token meta ts () + ) => Gram_Term_AtomsT meta ts (Proxy ()) g where + term_atomsT _t = + [ rule "term_unit" $ + metaG $ + (\meta -> ProTok $ inj_etoken meta $ Token_Term_Unit) + <$ symbol "(" + <* symbol ")" + ] diff --git a/Language/Symantic/Interpreting/Dup.hs b/Language/Symantic/Interpreting/Dup.hs index bab0837..7a5ff58 100644 --- a/Language/Symantic/Interpreting/Dup.hs +++ b/Language/Symantic/Interpreting/Dup.hs @@ -4,31 +4,31 @@ -- -- 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'; +-- to maintaining the universal polymorphism of @term@ at parsing time +-- as done with 'TermO'; -- it is mainly here for the sake of curiosity. module Language.Symantic.Interpreting.Dup where import Data.Proxy -- | Interpreter's data. -data DupI repr1 repr2 a +data DupI term1 term2 a = DupI - { dupI_1 :: repr1 a - , dupI_2 :: repr2 a + { dupI_1 :: term1 a + , dupI_2 :: term2 a } dupI0 :: (cl r, cl s) => Proxy cl - -> (forall repr. cl repr => repr a) + -> (forall term. cl term => term a) -> DupI r s a dupI0 _cl f = f `DupI` f dupI1 :: (cl r, cl s) => Proxy cl - -> (forall repr. cl repr => repr a -> repr b) + -> (forall term. cl term => term a -> term b) -> DupI r s a -> DupI r s b dupI1 _cl f (a1 `DupI` a2) = @@ -37,7 +37,7 @@ dupI1 _cl f (a1 `DupI` a2) = dupI2 :: (cl r, cl s) => Proxy cl - -> (forall repr. cl repr => repr a -> repr b -> repr c) + -> (forall term. cl term => term a -> term b -> term c) -> DupI r s a -> DupI r s b -> DupI r s c @@ -47,7 +47,7 @@ dupI2 _cl f (a1 `DupI` a2) (b1 `DupI` b2) = dupI3 :: (cl r, cl s) => Proxy cl - -> (forall repr. cl repr => repr a -> repr b -> repr c -> repr d) + -> (forall term. cl term => term a -> term b -> term c -> term d) -> DupI r s a -> DupI r s b -> DupI r s c diff --git a/Language/Symantic/Interpreting/Text.hs b/Language/Symantic/Interpreting/Text.hs index 7337fe8..ff7bf7e 100644 --- a/Language/Symantic/Interpreting/Text.hs +++ b/Language/Symantic/Interpreting/Text.hs @@ -2,19 +2,19 @@ -- | Interpreter to serialize an expression into a 'Text'. module Language.Symantic.Interpreting.Text where -import Data.Monoid ((<>)) -import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as Text import Prelude hiding (Integral(..)) +import Language.Symantic.Parsing.Grammar + -- * Type 'TextI' -- | Interpreter's data. newtype TextI h = TextI { unTextI -- Inherited attributes: - :: Precedence + :: (Infix, LR) -> TextI_Lambda_Depth -- Synthetised attributes: -> Text @@ -25,56 +25,49 @@ instance Show (TextI h) where -- | Interpreter. text_from_term :: TextI h -> Text -text_from_term r = unTextI r precedence_Toplevel 0 +text_from_term r = unTextI r (infixN0, L) 0 -- * Helpers -- ** Helpers for lambda applications textI0 :: Text -> TextI h -textI0 name = TextI $ \_p _v -> name +textI0 name = TextI $ \_op _v -> name textI1 :: Text -> TextI a1 -> TextI h -textI1 name (TextI a1) = - TextI $ \p v -> - let p' = precedence_App in - paren p p' $ name - <> " " <> a1 p' v +textI1 name (TextI a1) = TextI $ \po v -> + infix_paren po op $ + Text.intercalate " " + [ name + , a1 (op, L) v + ] + where op = infixN 10 textI2 :: Text -> TextI a1 -> TextI a2 -> TextI h textI2 name (TextI a1) (TextI a2) = - TextI $ \p v -> - let p' = precedence_App in - paren p p' $ name - <> " " <> a1 p' v - <> " " <> a2 p' v + TextI $ \po v -> + infix_paren po op $ + Text.intercalate " " + [ name + , a1 (op, L) v + , a2 (op, L) v + ] + where op = infixN 10 textI3 :: Text -> TextI a1 -> TextI a2 -> TextI a3 -> TextI h textI3 name (TextI a1) (TextI a2) (TextI a3) = - TextI $ \p v -> - let p' = precedence_App in - paren p p' $ name - <> " " <> a1 p' v - <> " " <> a2 p' v - <> " " <> a3 p' v -textI_infix :: Text -> Precedence -> TextI a1 -> TextI a2 -> TextI h -textI_infix name p' (TextI a1) (TextI a2) = - TextI $ \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 + TextI $ \po v -> + infix_paren po op $ + Text.intercalate " " + [ name + , a1 (op, L) v + , a2 (op, L) v + , a3 (op, L) v + ] + where op = infixN 10 -precedence_Toplevel :: Precedence -precedence_Toplevel = Precedence 0 -precedence_App :: Precedence -precedence_App = Precedence 10 -precedence_Atomic :: Precedence -precedence_Atomic = Precedence maxBound +textI_infix :: Text -> Infix -> TextI a1 -> TextI a2 -> TextI h +textI_infix name op (TextI a1) (TextI a2) = + TextI $ \po v -> + infix_paren po op $ + Text.intercalate " " + [ a1 (op, L) v + , name + , a2 (op, R) v + ] diff --git a/Language/Symantic/Parsing/EBNF.hs b/Language/Symantic/Parsing/EBNF.hs index 033d1c4..ed49038 100644 --- a/Language/Symantic/Parsing/EBNF.hs +++ b/Language/Symantic/Parsing/EBNF.hs @@ -1,15 +1,203 @@ -module Parsing.EBNF where +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} +module Language.Symantic.Parsing.EBNF where -import Data.Text.IO as Text +import Control.Applicative (Applicative(..), Alternative(..)) import Control.Monad +import Data.Bool as Bool +import Data.Char as Char +import qualified Data.List as List +import Data.Semigroup hiding (option) +import Data.String (IsString(..)) +import Data.Text (Text) +import qualified Data.Text as Text +import Prelude hiding (any) -import Language.Symantic.Typing import Language.Symantic.Parsing.Grammar -import Parsing.Grammar.Test -import Typing.Test - -main :: IO () -main = do - forM_ gram_lexer render - forM_ gram_type render - where render = Text.putStrLn . renderEBNF . unCF + +-- * Type 'EBNF' +-- | Extended Backus-Naur-Form, following the +-- +-- notations, augmented with the following notations: +-- +-- * @("U+", code_point)@: for (aka. Unicode). +-- * @(char, "…", char)@: for character range. +-- * @(rule, "&", rule)@: for the intersection. +-- * @(rule, "-", rule)@: for the difference. +-- * @(rule, " ", rule)@: for rule application. +data EBNF a = EBNF { unEBNF :: RuleMode -> (Infix, LR) -> Text } + +runEBNF :: EBNF a -> Text +runEBNF (EBNF g) = g RuleMode_Body (infixN0, L) + +-- | Get textual rendition of given EBNF rule. +renderEBNF :: RuleDef a -> Text +renderEBNF = runEBNF . unRuleDef + +ebnf_const :: Text -> EBNF a +ebnf_const t = EBNF $ \_rm _op -> t + +-- ** Type 'RuleMode' +data RuleMode + = RuleMode_Body -- ^ Generate the body of the rule. + | RuleMode_Ref -- ^ Generate a ref to the rule. + deriving (Eq, Show) + +-- ** Type 'RuleDef' +newtype RuleDef a = RuleDef { unRuleDef :: EBNF a } + deriving (Functor, Gram_Terminal, Applicative, App + , Alternative, Alter, Alt, Gram_RegL, Gram_RegR, Gram_CF) +deriving instance Gram_RuleDef RuleDef +deriving instance Gram_RuleDef g => Gram_RuleDef (RegR g) +deriving instance Gram_RuleDef g => Gram_RuleDef (RegL g) +deriving instance Gram_RuleDef g => Gram_RuleDef (CF g) +instance Gram_Rule RuleDef where + rule n = rule_def (ebnf_const n) + rule1 n g a = rule_def (ebnf_const n `ebnf_arg` unRuleDef a) (g a) + rule2 n g a b = rule_def (ebnf_const n `ebnf_arg` unRuleDef a `ebnf_arg` unRuleDef b) (g a b) + rule3 n g a b c = rule_def (ebnf_const n `ebnf_arg` unRuleDef a `ebnf_arg` unRuleDef b `ebnf_arg` unRuleDef c) (g a b c) + rule4 n g a b c d = rule_def (ebnf_const n `ebnf_arg` unRuleDef a `ebnf_arg` unRuleDef b `ebnf_arg` unRuleDef c `ebnf_arg` unRuleDef d) (g a b c d) +instance Gram_Meta meta RuleDef where + metaG (RuleDef x) = RuleDef $ metaG x +instance Gram_Lexer RuleDef + +-- *** Class 'Gram_RuleDef' +class Gram_RuleDef g where + rule_def :: EBNF () -> g a -> RuleDef a + rule_arg :: Text -> g a + +-- | Helper for 'Gram_Rule' 'EBNF'. +ebnf_arg :: EBNF a -> EBNF b -> EBNF () +ebnf_arg (EBNF a) (EBNF b) = EBNF $ \bo po -> infix_paren po op $ + a bo (op, L) <> " " <> b bo (op, R) + where op = infixL 11 +infixl 5 `ebnf_arg` + +instance Gram_RuleDef EBNF where + rule_arg = ebnf_const + rule_def call body = + RuleDef $ EBNF $ \mo po -> + case mo of + RuleMode_Ref -> unEBNF call mo po + RuleMode_Body -> + Text.intercalate " " $ + [ unEBNF call RuleMode_Ref (infixN0, L) + , "=" + , unEBNF body RuleMode_Ref (infixN0, R) + , ";" + ] +instance IsString (EBNF String) where + fromString = string +instance Show (EBNF a) where + show = Text.unpack . runEBNF +instance Gram_Rule EBNF where + rule n g = EBNF $ \rm po -> + case rm of + RuleMode_Body -> unEBNF g RuleMode_Ref po + RuleMode_Ref -> n + rule1 n g a = EBNF $ \rm po -> + case rm of + RuleMode_Body -> unEBNF (g a) RuleMode_Ref po + RuleMode_Ref -> unEBNF (ebnf_const n `ebnf_arg` a) RuleMode_Ref po + rule2 n g a b = EBNF $ \rm po -> + case rm of + RuleMode_Body -> unEBNF (g a b) RuleMode_Ref po + RuleMode_Ref -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b) RuleMode_Ref po + rule3 n g a b c = EBNF $ \rm po -> + case rm of + RuleMode_Body -> unEBNF (g a b c) RuleMode_Ref po + RuleMode_Ref -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b `ebnf_arg` c) RuleMode_Ref po + rule4 n g a b c d = EBNF $ \rm po -> + case rm of + RuleMode_Body -> unEBNF (g a b c d) RuleMode_Ref po + RuleMode_Ref -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b `ebnf_arg` c `ebnf_arg` d) RuleMode_Ref po +instance Functor EBNF where + fmap _f (EBNF x) = EBNF x +instance Applicative EBNF where + pure _ = empty + EBNF f <*> EBNF x = EBNF $ \bo po -> infix_paren po op $ + f bo (op, L) <> ", " <> x bo (op, R) + where op = infixB L 10 +instance App EBNF +instance Alternative EBNF where + empty = ebnf_const $ "\"\"" + EBNF g <|> EBNF q = EBNF $ \bo po -> infix_paren po op $ + g bo (op, L) <> " | " <> q bo (op, R) + where op = infixB L 2 + many (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}" where op = infixN0 + some (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}-" where op = infixN0 +instance Alter EBNF where + nil = ebnf_const $ "\"\"" + choice [] = empty + choice [g] = g + choice l@(_:_) = EBNF $ \bo po -> infix_paren po op $ + Text.intercalate " | " $ + (unEBNF <$> l) <*> pure bo <*> pure (op, L) + where op = infixB L 2 + star (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}" where op = infixN0 +instance Alt EBNF where + option _x (EBNF g) = EBNF $ \rm _po -> + "[" <> g rm (op, L) <> "]" where op = infixN0 +instance Gram_Terminal EBNF where + any = ebnf_const "_" + Terminal (EBNF f) `but` Terminal (EBNF g) = + Terminal $ EBNF $ \bo po -> infix_paren po op $ + f bo (op, L) <> " - " <> g bo (op, R) + where op = infixL 6 + eoi = ebnf_const "EOF" + char = ebnf_const . escape + where + escape c | Char.isPrint c && c /= '"' = Text.concat $ ["\"", Text.singleton c, "\""] + escape c = Text.concat ["U+", Text.pack $ show $ ord c] + string s = + case List.break (\c -> Bool.not (Char.isPrint c) || c == '"') s of + (ps, "") -> raw ps + ("", [c]) -> "" <$ char c + (ps, [c]) -> "" <$ raw ps <* char c + ("", c:rs) -> "" <$ char c <* string rs + (ps, c:rs) -> "" <$ raw ps <* char c <* string rs + where + raw cs = ebnf_const $ Text.concat $ ["\"", Text.pack cs, "\""] + unicat = ebnf_const . Text.pack . show + range (l, h) = ebnf_const $ Text.concat + [ runEBNF $ char l + , "…" + , runEBNF $ char h + ] +instance Gram_RegR EBNF where + Terminal f .*> Reg x = Reg $ f <*> x + manyR = Reg . many . unTerminal + someR = Reg . some . unTerminal +instance Gram_RegL EBNF where + Reg f <*. Terminal x = Reg $ f <*> x + manyL = Reg . many . unTerminal + someL = Reg . some . unTerminal +instance Gram_CF EBNF where + CF (EBNF f) <& Reg (EBNF g) = CF $ EBNF $ \bo po -> infix_paren po op $ + f bo (op, L) <> " & " <> g bo (op, R) + where op = infixB L 4 + Reg (EBNF f) &> CF (EBNF g) = CF $ EBNF $ \bo po -> infix_paren po op $ + f bo (op, L) <> " & " <> g bo (op, R) + where op = infixB L 4 + CF (EBNF f) `minus` Reg (EBNF g) = CF $ EBNF $ \bo po -> infix_paren po op $ + f bo (op, L) <> " - " <> g bo (op, R) + where op = infixL 6 +instance Gram_Meta meta EBNF where + metaG (EBNF x) = EBNF x +instance Gram_Lexer EBNF + +gram_lexer :: forall g . (Gram_Lexer g, Gram_RuleDef g) => [CF g ()] +gram_lexer = + [ void $ commentable (void $ rule_arg "space") (void $ rule_arg "line") (void $ rule_arg "block") + , void $ comment_line (rule_arg "prefix") + , void $ comment_block (rule_arg "start") (rule_arg "end" :: RegL g String) + , void $ lexeme (rule_arg "g") + , void $ parens (rule_arg "g") + , void $ operators (rule_arg "expr") (rule_arg "prefix") (rule_arg "infix") (rule_arg "postfix") + , void $ inside id (rule_arg "begin") (rule_arg "i") (rule_arg "end") (rule_arg "next") + ] diff --git a/Language/Symantic/Parsing/EBNF/Print.hs b/Language/Symantic/Parsing/EBNF/Print.hs new file mode 100644 index 0000000..679f613 --- /dev/null +++ b/Language/Symantic/Parsing/EBNF/Print.hs @@ -0,0 +1,16 @@ +module Parsing.EBNF.Print where + +import Data.Text.IO as Text +import Control.Monad + +import Language.Symantic.Typing +import Language.Symantic.Parsing.Grammar +import Language.Symantic.Parsing.EBNF +import Language.Symantic.Compiling (gram_term) + +main :: IO () +main = do + forM_ gram_lexer render + forM_ gram_type render + forM_ gram_term render + where render = Text.putStrLn . renderEBNF . unCF diff --git a/Language/Symantic/Parsing/Grammar.hs b/Language/Symantic/Parsing/Grammar.hs index b1c23e9..f17dc14 100644 --- a/Language/Symantic/Parsing/Grammar.hs +++ b/Language/Symantic/Parsing/Grammar.hs @@ -1,64 +1,56 @@ {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE Rank2Types #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} -- | This module defines symantics -- for regular or context-free grammars. +-- +-- The default grammar can be printed in 'EBNF' +-- with: @cabal test ebnf --show-details=always@. module Language.Symantic.Parsing.Grammar where import Control.Applicative (Applicative(..), Alternative(..)) import Control.Monad -import Data.Char as Char +import qualified Data.Bool as Bool +import qualified Data.Char as Char import Data.Foldable hiding (any) -import qualified Data.List as List import Data.Semigroup hiding (option) import Data.String (IsString(..)) import Data.Text (Text) -import qualified Data.Text as Text import Prelude hiding (any) -- * Class 'Gram_Rule' type Id a = a -> a -class Gram_Rule p where - rule :: Text -> Id (p a) +class Gram_Rule g where + rule :: Text -> Id (g a) rule _n = id - rule1 :: Text -> Id (p a -> p b) - rule1 _n p = p - rule2 :: Text -> Id (p a -> p b -> p c) - rule2 _n p = p - rule3 :: Text -> Id (p a -> p b -> p c -> p d) - rule3 _n p = p - rule4 :: Text -> Id (p a -> p b -> p c -> p d -> p e) - rule4 _n p = p - --- * Type 'Term' + rule1 :: Text -> Id (g a -> g b) + rule1 _n g = g + rule2 :: Text -> Id (g a -> g b -> g c) + rule2 _n g = g + rule3 :: Text -> Id (g a -> g b -> g c -> g d) + rule3 _n g = g + rule4 :: Text -> Id (g a -> g b -> g c -> g d -> g e) + rule4 _n g = g + +-- * Type 'Terminal' -- | Terminal grammar. -newtype Term p a - = Term { unTerm :: p a } - deriving (Functor, Gram_Term) +newtype Terminal g a + = Terminal { unTerminal :: g a } + deriving (Functor, Gram_Terminal) +deriving instance Gram_Rule g => Gram_Rule (Terminal g) --- ** Class 'Gram_Term' +-- ** Class 'Gram_Terminal' -- | Symantics for terminal grammars. -class Gram_Term p where - any :: p Char - eof :: p () - char :: Char -> p Char - string :: String -> p String - unicat :: Unicat -> p Char - range :: (Char, Char) -> p Char +class Gram_Terminal g where + any :: g Char + but :: Terminal g Char -> Terminal g Char -> Terminal g Char + eoi :: g () + char :: Char -> g Char + string :: String -> g String + unicat :: Unicat -> g Char + range :: (Char, Char) -> g Char -- string = foldr (\c -> (<*>) ((:) <$> char c)) (pure "") -- string [] = pure [] -- string (c:cs) = (:) <$> char c <*> string cs @@ -78,44 +70,47 @@ unicode_categories :: Unicat -> [Char.GeneralCategory] unicode_categories c = case c of Unicat_Letter -> - [ UppercaseLetter - , LowercaseLetter - , TitlecaseLetter - , ModifierLetter - , OtherLetter + [ Char.UppercaseLetter + , Char.LowercaseLetter + , Char.TitlecaseLetter + , Char.ModifierLetter + , Char.OtherLetter ] Unicat_Mark -> - [ NonSpacingMark - , SpacingCombiningMark - , EnclosingMark + [ Char.NonSpacingMark + , Char.SpacingCombiningMark + , Char.EnclosingMark ] Unicat_Number -> - [ DecimalNumber - , LetterNumber - , OtherNumber + [ Char.DecimalNumber + , Char.LetterNumber + , Char.OtherNumber ] Unicat_Punctuation -> - [ ConnectorPunctuation - , DashPunctuation - , OpenPunctuation - , ClosePunctuation - , OtherPunctuation + [ Char.ConnectorPunctuation + , Char.DashPunctuation + , Char.OpenPunctuation + , Char.ClosePunctuation + , Char.OtherPunctuation ] Unicat_Symbol -> - [ MathSymbol - , CurrencySymbol - , ModifierSymbol - , OtherSymbol + [ Char.MathSymbol + , Char.CurrencySymbol + , Char.ModifierSymbol + , Char.OtherSymbol ] Unicat cat -> [cat] -- * Type 'Reg' -- | Left or right regular grammar. -newtype Reg (lr::LR) p a = Reg { unReg :: p a } - deriving (IsString, Functor, Gram_Term, Alter) -deriving instance Gram_Rule p => Gram_Rule (Reg lr p) -deriving instance (Functor p, Alter p, Gram_RegL p) => Gram_RegL (RegL p) -deriving instance (Functor p, Alter p, Gram_RegR p) => Gram_RegR (RegR p) +newtype Reg (lr::LR) g a = Reg { unReg :: g a } + deriving (IsString, Functor, Gram_Terminal, Alter) +deriving instance Gram_Rule g => Gram_Rule (Reg lr g) +deriving instance (Functor g, Alter g, Gram_RegL g) => Gram_RegL (RegL g) +deriving instance (Functor g, Alter g, Gram_RegR g) => Gram_RegR (RegR g) + +reg_of_term :: Terminal g a -> Reg lr g a +reg_of_term (Terminal g) = Reg g -- ** Type 'LR' data LR @@ -128,336 +123,341 @@ type RegR = Reg 'R -- ** Class 'Alter' -- | Like 'Alternative' but without the 'Applicative' super-class, -- because a regular grammar is not closed under 'Applicative'. -class Alter p where - nil :: p a - (<+>) :: p a -> p a -> p a - choice :: [p a] -> p a - default nil :: Alternative p => p a - default (<+>) :: Alternative p => p a -> p a -> p a - default choice :: Alternative p => [p a] -> p a +class Alter g where + nil :: g a + (<+>) :: g a -> g a -> g a + choice :: [g a] -> g a + star :: g a -> g [a] + default nil :: Alternative g => g a + default (<+>) :: Alternative g => g a -> g a -> g a + default choice :: Alternative g => [g a] -> g a + default star :: Alternative g => g a -> g [a] nil = empty (<+>) = (<|>) choice = foldr (<+>) empty + -- star g = (:) <$> g *> star g <+> nil + + star a = many_a + where + many_a = some_a <+> pure [] + some_a = ((:) <$> a) <*> many_a + infixl 3 <+> +deriving instance Alter p => Alter (Terminal p) -- ** Class 'Gram_RegR' -- | Symantics for right regular grammars. -class (Functor p, Alter p) => Gram_RegR p where - (.*>) :: Term p (a -> b) -> RegR p a -> RegR p b - manyR :: Term p a -> RegR p [a] - manyR p = (:) <$> p .*> manyR p <+> nil - someR :: Term p a -> RegR p [a] - someR p = (:) <$> p .*> manyR p +class (Functor g, Alter g) => Gram_RegR g where + (.*>) :: Terminal g (a -> b) -> RegR g a -> RegR g b + manyR :: Terminal g a -> RegR g [a] + manyR g = (:) <$> g .*> manyR g <+> nil + someR :: Terminal g a -> RegR g [a] + someR g = (:) <$> g .*> manyR g infixl 4 .*> -- ** Class 'Gram_RegL' -- | Symantics for left regular grammars. -class (Functor p, Alter p) => Gram_RegL p where - (<*.) :: RegL p (a -> b) -> Term p a -> RegL p b - manyL :: Term p a -> RegL p [a] - manyL p' = reverse <$> go p' - where go p = flip (:) <$> go p <*. p <+> nil - someL :: Term p a -> RegL p [a] - someL p = (\cs c -> cs ++ [c]) <$> manyL p <*. p +class (Functor g, Alter g) => Gram_RegL g where + (<*.) :: RegL g (a -> b) -> Terminal g a -> RegL g b + manyL :: Terminal g a -> RegL g [a] + manyL g' = reverse <$> go g' + where go g = flip (:) <$> go g <*. g <+> nil + someL :: Terminal g a -> RegL g [a] + someL g = (\cs c -> cs ++ [c]) <$> manyL g <*. g infixl 4 <*. +-- * Class 'Alt' +class (Alternative g, Alter g) => Alt g where + option :: a -> g a -> g a + option x g = g <+> pure x + skipMany :: g a -> g () + skipMany = void . many + --manyTill :: g a -> g end -> g [a] + --manyTill g end = go where go = ([] <$ end) <|> ((:) <$> g <*> go) + +-- * Class 'App' +class Applicative g => App g where + between :: g open -> g close -> g a -> g a + between open close g = open *> g <* close + -- * Type 'CF' -- | Context-free grammar. -newtype CF p a = CF { unCF :: p a } - deriving (IsString, Functor, Gram_Term, Applicative, App, Alternative, Alter, Alt) -deriving instance Gram_Rule p => Gram_Rule (CF p) -deriving instance Gram_CF p => Gram_CF (CF p) +newtype CF g a = CF { unCF :: g a } + deriving (IsString, Functor, Gram_Terminal, Applicative, App, Alternative, Alter, Alt) +deriving instance Gram_Rule g => Gram_Rule (CF g) +deriving instance Gram_RegL g => Gram_RegL (CF g) +deriving instance Gram_RegR g => Gram_RegR (CF g) +deriving instance Gram_CF g => Gram_CF (CF g) -cf_of_reg :: Reg lr p a -> CF p a -cf_of_reg (Reg p) = CF p +cf_of_term :: Terminal g a -> CF g a +cf_of_term (Terminal g) = CF g + +cf_of_reg :: Reg lr g a -> CF g a +cf_of_reg (Reg g) = CF g -- ** Class 'Gram_CF' -- | Symantics for context-free grammars. -class Gram_CF p where +class Gram_CF g where -- | NOTE: CFL ∩ RL is a CFL. - -- See ISBN 81-7808-347-7, Theorem 7.27, p.286 - (<&) :: CF p (a -> b) -> Reg lr p a -> CF p b - (&>) :: Reg lr p (a -> b) -> CF p a -> CF p b + -- See ISBN 81-7808-347-7, Theorem 7.27, g.286 + (<&) :: CF g (a -> b) -> Reg lr g a -> CF g b + (&>) :: Reg lr g (a -> b) -> CF g a -> CF g b -- | NOTE: CFL - RL is a CFL. - -- See ISBN 81-7808-347-7, Theorem 7.29, p.289 - but :: CF p a -> Reg lr p b -> CF p a + -- See ISBN 81-7808-347-7, Theorem 7.29, g.289 + minus :: CF g a -> Reg lr g b -> CF g a infixl 4 <& infixl 4 &> --- ** Class 'App' -class Applicative p => App p where - between :: p open -> p close -> p a -> p a - between open close p = open *> p <* close - --- ** Class 'Alt' -class Alternative p => Alt p where - option :: a -> p a -> p a - option x p = p <|> pure x - skipMany :: p a -> p () - skipMany = void . many - --manyTill :: p a -> p end -> p [a] - --manyTill p end = go where go = ([] <$ end) <|> ((:) <$> p <*> go) +-- * Class 'Gram_Meta' +class Gram_Meta meta g where + metaG :: g (meta -> a) -> g a +instance Gram_Meta meta g => Gram_Meta meta (CF g) where + metaG = CF . metaG . unCF --- * Type 'EBNF' --- | Extended Bachus-Norm Form, following the --- --- notations, augmented with the following notations: --- --- * @("U+", code_point)@: for (aka. Unicode). --- * @(rule, "&", rule)@: for the intersection. --- * @(rule, "-", rule)@: for the difference. --- * @(rule, " ", rule)@: for rule application. -data EBNF a = EBNF { unEBNF :: RuleMode -> (Op, LR) -> Text } - -runEBNF :: EBNF a -> Text -runEBNF (EBNF p) = p RuleMode_Body (nop, L) - --- | Get textual rendition of given EBNF rule. -renderEBNF :: RuleDef a -> Text -renderEBNF = runEBNF . unRuleDef - -ebnf_const :: Text -> EBNF a -ebnf_const t = EBNF $ \_rm _op -> t - --- ** Type 'RuleDef' -newtype RuleDef a = RuleDef { unRuleDef :: EBNF a } - deriving (Functor, Gram_Term, Applicative, App - , Alternative, Alter, Alt, Gram_RegL, Gram_RegR, Gram_CF) -deriving instance Gram_RuleDef RuleDef -deriving instance Gram_RuleDef p => Gram_RuleDef (RegR p) -deriving instance Gram_RuleDef p => Gram_RuleDef (RegL p) -deriving instance Gram_RuleDef p => Gram_RuleDef (CF p) - -instance Gram_Rule RuleDef where - rule n = rule_def (ebnf_const n) - rule1 n p a = rule_def (ebnf_const n `ebnf_arg` unRuleDef a) (p a) - rule2 n p a b = rule_def (ebnf_const n `ebnf_arg` unRuleDef a `ebnf_arg` unRuleDef b) (p a b) - rule3 n p a b c = rule_def (ebnf_const n `ebnf_arg` unRuleDef a `ebnf_arg` unRuleDef b `ebnf_arg` unRuleDef c) (p a b c) - rule4 n p a b c d = rule_def (ebnf_const n `ebnf_arg` unRuleDef a `ebnf_arg` unRuleDef b `ebnf_arg` unRuleDef c `ebnf_arg` unRuleDef d) (p a b c d) - --- *** Class 'Gram_RuleDef' -class Gram_RuleDef p where - rule_def :: EBNF () -> p a -> RuleDef a - rule_arg :: Text -> p a - --- | Helper for 'Gram_Rule' 'EBNF'. -ebnf_arg :: EBNF a -> EBNF b -> EBNF () -ebnf_arg (EBNF a) (EBNF b) = EBNF $ \bo po -> op_paren po op $ - a bo (op, L) <> " " <> b bo (op, R) - where op = Op " " 11 AssocL -infixl 5 `ebnf_arg` - -instance Gram_RuleDef EBNF where - rule_arg = ebnf_const - rule_def call body = - RuleDef $ EBNF $ \mo po -> - case mo of - RuleMode_Ref -> unEBNF call mo po - RuleMode_Body -> - Text.intercalate " " $ concat $ - [ [unEBNF call RuleMode_Ref (nop, L)] - , ["="] - , [unEBNF body RuleMode_Ref (nop, R)] - , [";"] - ] -instance IsString (EBNF String) where - fromString = string -instance Show (EBNF a) where - show = Text.unpack . runEBNF -instance Gram_Rule EBNF where - rule n p = EBNF $ \rm po -> - case rm of - RuleMode_Body -> unEBNF p RuleMode_Ref po - RuleMode_Ref -> n - rule1 n p a = EBNF $ \rm po -> - case rm of - RuleMode_Body -> unEBNF (p a) RuleMode_Ref po - RuleMode_Ref -> unEBNF (ebnf_const n `ebnf_arg` a) RuleMode_Ref po - rule2 n p a b = EBNF $ \rm po -> - case rm of - RuleMode_Body -> unEBNF (p a b) RuleMode_Ref po - RuleMode_Ref -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b) RuleMode_Ref po - rule3 n p a b c = EBNF $ \rm po -> - case rm of - RuleMode_Body -> unEBNF (p a b c) RuleMode_Ref po - RuleMode_Ref -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b `ebnf_arg` c) RuleMode_Ref po - rule4 n p a b c d = EBNF $ \rm po -> - case rm of - RuleMode_Body -> unEBNF (p a b c d) RuleMode_Ref po - RuleMode_Ref -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b `ebnf_arg` c `ebnf_arg` d) RuleMode_Ref po -instance Functor EBNF where - fmap _f (EBNF x) = EBNF x -instance Applicative EBNF where - pure _ = empty - EBNF f <*> EBNF x = EBNF $ \bo po -> op_paren po op $ - f bo (op, L) <> ", " <> x bo (op, R) - where op = Op "," 10 AssocB -instance App EBNF -instance Alternative EBNF where - empty = ebnf_const $ "\"\"" - EBNF x <|> EBNF y = EBNF $ \bo po -> op_paren po op $ - x bo (op, L) <> " | " <> y bo (op, R) - where op = Op "|" 2 AssocB - many (EBNF x) = EBNF $ \rm _po -> "{ " <> x rm (op, L) <> " }" where op = nop - some (EBNF x) = EBNF $ \rm _po -> "{ " <> x rm (op, L) <> " }-" where op = nop -instance Alter EBNF where - choice [] = empty - choice [p] = p - choice l@(_:_) = EBNF $ \bo po -> op_paren po op $ - Text.intercalate " | " $ - (unEBNF <$> l) <*> pure bo <*> pure (op, L) - where op = Op "|" 2 AssocB -instance Alt EBNF -instance Gram_Term EBNF where - any = ebnf_const "_" - eof = ebnf_const "EOF" - char = ebnf_const . escape +-- * Class 'Gram_Lexer' +class + ( Alt g + , Alter g + , Alternative g + , App g + , Gram_CF g + , Gram_Rule g + , Gram_Terminal g + ) => Gram_Lexer g where + commentable :: g () -> g () -> g () -> g () + commentable = rule3 "commentable" $ \g line block -> + skipMany $ choice [g, line, block] + comment_line :: CF g String -> CF g String + comment_line prefix = rule "comment_line" $ + prefix *> many (any `minus` (void (char '\n') <+> eoi)) + comment_block :: CF g String -> Reg lr g String -> CF g String + comment_block start end = rule "comment_block" $ + start *> many (any `minus` void end) + lexeme :: CF g a -> CF g a + lexeme = rule1 "lexeme" $ \g -> + g <* commentable + (void $ char ' ') + (void $ comment_line (string "--")) + (void $ comment_block (string "{-") (string "-}")) + parens :: CF g a -> CF g a + parens = rule1 "parens" $ + between + (lexeme $ string "(") + (lexeme $ string ")") + operators + :: CF g a -- ^ expression + -> CF g (Unifix, a -> a) -- ^ prefix operator + -> CF g (Infix , a -> a -> a) -- ^ infix operator + -> CF g (Unifix, a -> a) -- ^ postfix operator + -> CF g (Either Error_Fixity a) + operators g prG iG poG = + (evalOpTree <$>) + <$> go g prG iG poG where - escape c | Char.isPrint c && c /= '"' = Text.concat $ ["\"", Text.singleton c, "\""] - escape c = Text.concat ["U+", Text.pack $ show $ ord c] - string s = - case List.break (\c -> not (Char.isPrint c) || c == '"') s of - (ps, "") -> raw ps - ("", [c]) -> "" <$ char c - (ps, [c]) -> "" <$ raw ps <* char c - ("", c:rs) -> "" <$ char c <* string rs - (ps, c:rs) -> "" <$ raw ps <* char c <* string rs + go + :: CF g a + -> CF g (Unifix, a -> a) + -> CF g (Infix , a -> a -> a) + -> CF g (Unifix, a -> a) + -> CF g (Either Error_Fixity (OpTree a)) + go = rule4 "operators" $ \aG preG inG postG -> + (\pres a posts -> + let nod_a = + foldr insert_unifix + (foldl' (flip insert_unifix) (OpNode0 a) posts) + pres + in \case + Just (in_, b) -> insert_infix nod_a in_ b + Nothing -> Right nod_a) + <$> star preG + <*> aG + <*> star postG + <*> option Nothing (curry Just <$> inG <*> go aG preG inG postG) + + insert_unifix :: (Unifix, a -> a) -> OpTree a -> OpTree a + insert_unifix a@(uni_a@(Prefix prece_a), op_a) nod_b = + case nod_b of + OpNode0{} -> OpNode1 uni_a op_a nod_b + OpNode1 Prefix{} _op_b _nod -> OpNode1 uni_a op_a nod_b + OpNode1 uni_b@(Postfix prece_b) op_b nod -> + case prece_b `compare` prece_a of + GT -> OpNode1 uni_a op_a nod_b + EQ -> OpNode1 uni_a op_a nod_b + LT -> OpNode1 uni_b op_b $ insert_unifix a nod + OpNode2 inf_b op_b l r -> + case infix_prece inf_b `compare` prece_a of + GT -> OpNode1 uni_a op_a nod_b + EQ -> OpNode1 uni_a op_a nod_b + LT -> OpNode2 inf_b op_b (insert_unifix a l) r + insert_unifix a@(uni_a@(Postfix prece_a), op_a) nod_b = + case nod_b of + OpNode0{} -> OpNode1 uni_a op_a nod_b + OpNode1 uni_b@(Prefix prece_b) op_b nod -> + case prece_b `compare` prece_a of + GT -> OpNode1 uni_a op_a nod_b + EQ -> OpNode1 uni_a op_a nod_b + LT -> OpNode1 uni_b op_b $ insert_unifix a nod + OpNode1 Postfix{} _op_b _nod -> OpNode1 uni_a op_a nod_b + OpNode2 inf_b op_b l r -> + case infix_prece inf_b `compare` prece_a of + GT -> OpNode1 uni_a op_a nod_b + EQ -> OpNode1 uni_a op_a nod_b + LT -> OpNode2 inf_b op_b l (insert_unifix a r) + + insert_infix + :: OpTree a + -> (Infix, a -> a -> a) + -> Either Error_Fixity (OpTree a) + -> Either Error_Fixity (OpTree a) + insert_infix nod_a in_@(inf_a, op_a) e_nod_b = do + nod_b <- e_nod_b + case nod_b of + OpNode0{} -> Right $ OpNode2 inf_a op_a nod_a nod_b + OpNode1 uni_b op_b nod -> + case unifix_prece uni_b `compare` infix_prece inf_a of + EQ -> Right $ OpNode2 inf_a op_a nod_a nod_b + GT -> Right $ OpNode2 inf_a op_a nod_a nod_b + LT -> do + n <- insert_infix nod_a in_ (Right nod) + Right $ OpNode1 uni_b op_b n + OpNode2 inf_b op_b l r -> + case infix_prece inf_b `compare` infix_prece inf_a of + GT -> Right $ OpNode2 inf_a op_a nod_a nod_b + LT -> do + n <- insert_infix nod_a in_ (Right l) + Right $ OpNode2 inf_b op_b n r + EQ -> + let ass = \case + AssocL -> L + AssocR -> R + AssocB lr -> lr in + case (ass <$> infix_assoc inf_b, ass <$> infix_assoc inf_a) of + (Just L, Just L) -> do + n <- insert_infix nod_a in_ (Right l) + Right $ OpNode2 inf_b op_b n r + (Just R, Just R) -> + Right $ OpNode2 inf_a op_a nod_a nod_b + _ -> Left $ Error_Fixity_Infix_not_combinable inf_a inf_b + -- NOTE: non-associating infix ops + -- of the same precedence cannot be mixed. + infixrG :: CF g a -> CF g (a -> a -> a) -> CF g a + infixrG = rule2 "infixr" $ \g opG -> + (\a -> \case + Just (op, b) -> a `op` b + Nothing -> a) + <$> g + <*> option Nothing (curry Just <$> opG <*> infixrG g opG) + infixlG :: CF g a -> CF g (a -> a -> a) -> CF g a + infixlG = rule2 "infixl" $ \g opG -> + -- NOTE: infixl uses the same grammar than infixr, + -- but build the parsed value by applying + -- the operator in the opposite way. + ($ id) <$> go g opG where - raw cs = ebnf_const $ Text.concat $ ["\"", Text.pack cs, "\""] - unicat = ebnf_const . Text.pack . show - range (l, h) = ebnf_const $ Text.concat - [ runEBNF $ char l - , "…" - , runEBNF $ char h - ] -instance Gram_RegR EBNF where - Term f .*> Reg x = Reg $ f <*> x - manyR = Reg . many . unTerm - someR = Reg . some . unTerm -instance Gram_RegL EBNF where - Reg f <*. Term x = Reg $ f <*> x - manyL = Reg . many . unTerm - someL = Reg . some . unTerm -instance Gram_CF EBNF where - CF (EBNF f) <& Reg (EBNF p) = CF $ EBNF $ \bo po -> op_paren po op $ - f bo (op, L) <> " & " <> p bo (op, R) - where op = Op "&" 4 AssocL - Reg (EBNF f) &> CF (EBNF p) = CF $ EBNF $ \bo po -> op_paren po op $ - f bo (op, L) <> " & " <> p bo (op, R) - where op = Op "&" 4 AssocL - CF (EBNF f) `but` Reg (EBNF p) = CF $ EBNF $ \bo po -> op_paren po op $ - f bo (op, L) <> " - " <> p bo (op, R) - where op = Op "-" 6 AssocL - --- ** Type 'RuleMode' -data RuleMode - = RuleMode_Body -- ^ Generate the body of the rule. - | RuleMode_Ref -- ^ Generate a ref to the rule. + go :: CF g a -> CF g (a -> a -> a) -> CF g ((a -> a) -> a) + go g opG = + (\a -> \case + Just (op, kb) -> \k -> kb (k a `op`) + Nothing -> ($ a)) + <$> g + <*> option Nothing (curry Just <$> opG <*> go g opG) + inside :: (a -> b) -> CF g begin -> CF g a -> CF g end -> CF g b -> CF g b + inside f = rule4 "inside" $ \begin i end n -> + (f <$ begin <*> i <* end) <+> n + symbol :: String -> CF g String + symbol = lexeme . string + +deriving instance Gram_Lexer g => Gram_Lexer (CF g) + +-- ** Type 'Error_Fixity' +data Error_Fixity + = Error_Fixity_Infix_not_combinable Infix Infix + | Error_Fixity_NeedPostfixOrInfix + | Error_Fixity_NeedPrefix + | Error_Fixity_NeedPostfix + | Error_Fixity_NeedInfix deriving (Eq, Show) --- ** Type 'Op' -data Op = Op - { op_ident :: Text - , op_prece :: Precedence - , op_assoc :: Associativity - } deriving (Eq, Show) +-- ** Type 'NeedFixity' +data NeedFixity + = NeedPrefix + | NeedPostfix + | NeedPostfixOrInfix + deriving (Eq, Ord, Show) -nop :: Op -nop = Op "" 0 AssocN +-- ** Type 'Fixity' +data Fixity a + = FixityPrefix Unifix (a -> a) + | FixityPostfix Unifix (a -> a) + | FixityInfix Infix (a -> a -> a) --- *** Type 'Precedence' +-- ** Type 'Precedence' type Precedence = Int --- *** Type 'Associativity' +-- ** Type 'Associativity' +-- type Associativity = LR data Associativity - = AssocL | AssocR | AssocN | AssocB + = AssocL -- ^ Associate to the left: @a ¹ b ² c == (a ¹ b) ² c@ + | AssocR -- ^ Associate to the right: @a ¹ b ² c == a ¹ (b ² c)@ + | AssocB LR -- ^ Associate to both side, but to 'LR' when reading. + deriving (Eq, Show) + +-- ** Type 'Unifix' +data Unifix + = Prefix { unifix_prece :: Precedence } + | Postfix { unifix_prece :: Precedence } deriving (Eq, Show) -op_paren +-- ** Type 'Infix' +data Infix + = Infix + { infix_assoc :: Maybe Associativity + , infix_prece :: Precedence + } deriving (Eq, Show) + +infixL :: Precedence -> Infix +infixL = Infix (Just AssocL) + +infixR :: Precedence -> Infix +infixR = Infix (Just AssocR) + +infixB :: LR -> Precedence -> Infix +infixB = Infix . Just . AssocB + +infixN :: Precedence -> Infix +infixN = Infix Nothing + +infixN0 :: Infix +infixN0 = infixN 0 + +infixN5 :: Infix +infixN5 = infixN 5 + +infix_paren :: (Semigroup s, IsString s) - => (Op, LR) -> Op -> s -> s -op_paren (po, lr) op s = - if op_prece op <= op_prece po && not associate + => (Infix, LR) -> Infix -> s -> s +infix_paren (po, lr) op s = + if infix_prece op < infix_prece po + || infix_prece op == infix_prece po + && Bool.not associate then fromString "(" <> s <> fromString ")" else s where associate = - op_ident po == op_ident op && - case (lr, op_assoc po) of - (_, AssocB) -> True - (L, AssocL) -> True - (R, AssocR) -> True - _ -> False - --- * Class 'Gram_Context' --- | A monadic backdoor, but limited by 'Context'. --- In 'CF', the context must obviously not be used to change the parser, --- but it can be used to change the parsed value, --- for instance by recording source positions into it. -class Gram_Context p where - type Context p - type Context p = () - default context :: (Context p ~ ()) => (Context p -> p a) -> p a - context :: (Context p -> p a) -> p a - context f = f () -instance Gram_Context p => Gram_Context (CF p) where - type Context (CF p) = Context p - context f = CF $ context (unCF . f) -instance Gram_Context EBNF -instance Gram_Context RuleDef - --- * Class 'Gram_Lexer' -class - ( Alt p - , Alter p - , Alternative p - , App p - , Gram_CF p - , Gram_Rule p - , Gram_Term p - ) => Gram_Lexer p where - commentable :: p () -> p () -> p () -> p () - commentable = rule3 "commentable" $ \p line block -> - skipMany $ choice [p, line, block] - comment_line :: CF p String -> CF p String - comment_line prefix = rule "comment_line" $ - prefix *> many (any `but` (void (char '\n') <+> eof)) - comment_block :: CF p String -> Reg lr p String -> CF p String - comment_block start end = rule "comment_block" $ - start *> many (any `but` void end) - lexeme :: CF p a -> CF p a - lexeme = rule1 "lexeme" $ \p -> p - <* commentable - (void $ char ' ') - (void $ comment_line (string "--")) - (void $ comment_block (string "{-") (string "-}")) - parens :: CF p a -> CF p a - parens = rule1 "parens" $ - between - (lexeme $ string "(") - (lexeme $ string ")") - infixrP :: (a -> a -> a) -> CF p a -> CF p sep -> CF p a -> CF p a - infixrP f = - rule3 "infixrP" $ \next sep root -> - (\a -> \case Just b -> f a b; Nothing -> a) - <$> next <*> option Nothing (Just <$ sep <*> root) - inside :: (a -> b) -> CF p begin -> CF p a -> CF p end -> CF p b -> CF p b - inside f = rule4 "inside" $ \begin i end n -> - (f <$ begin <*> i <* end) <+> n - symbol :: String -> CF p String - symbol = lexeme . string - -deriving instance Gram_Lexer p => Gram_Lexer (CF p) -instance Gram_Lexer EBNF -instance Gram_Lexer RuleDef - -gram_lexer :: forall p . (Gram_Lexer p, Gram_RuleDef p) => [CF p ()] -gram_lexer = - [ () <$ commentable (void $ rule_arg "space") (void $ rule_arg "line") (void $ rule_arg "block") - , () <$ comment_line (rule_arg "prefix") - , () <$ comment_block (rule_arg "start") (rule_arg "end" :: Reg 'L p String) - , () <$ lexeme (rule_arg "p") - , () <$ parens (rule_arg "p") - , () <$ inside id (rule_arg "begin") (rule_arg "i") (rule_arg "end") (rule_arg "next") - , () <$ infixrP const (rule_arg "next") (rule_arg "sep") (rule_arg "root") - ] + case (lr, infix_assoc po) of + (_, Just AssocB{}) -> True + (L, Just AssocL) -> True + (R, Just AssocR) -> True + _ -> False + +-- ** Type 'OpTree' +data OpTree a + = OpNode0 a + | OpNode1 Unifix (a -> a) (OpTree a) + | OpNode2 Infix (a -> a -> a) (OpTree a) (OpTree a) + +-- | Collapse an 'OpTree'. +evalOpTree :: OpTree a -> a +evalOpTree (OpNode0 a) = a +evalOpTree (OpNode1 _uni op n) = op $ evalOpTree n +evalOpTree (OpNode2 _inf op l r) = evalOpTree l `op` evalOpTree r diff --git a/Language/Symantic/Parsing/Grammar/Test.hs b/Language/Symantic/Parsing/Grammar/Test.hs index e5b7d23..e992e8d 100644 --- a/Language/Symantic/Parsing/Grammar/Test.hs +++ b/Language/Symantic/Parsing/Grammar/Test.hs @@ -1,50 +1,28 @@ -{-# LANGUAGE ConstrainedClassMethods #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | This module defines symantics -- for regular or context-free grammars. -- It is intended to be imported qualified. module Parsing.Grammar.Test where +import Test.Tasty +import Test.Tasty.HUnit + import Control.Applicative (Applicative(..), Alternative(..)) -import Data.Maybe import Control.Monad +import Data.Monoid ((<>)) -- import Control.Comonad import qualified Data.Char as Char -import Data.Foldable hiding (any) import Data.Functor.Identity import qualified Data.List as List -import Data.Semigroup ((<>)) -import Data.Proxy -import Data.Text (Text) import Data.String (IsString(..)) import qualified Data.Text as Text -import qualified Data.Text.IO as Text -import Prelude hiding (any, (^)) +import Prelude hiding (any, (^), exp) import qualified Text.Megaparsec as P -import qualified Text.Megaparsec.Lexer as L +-- import qualified Text.Megaparsec.Lexer as L -import qualified Language.Symantic.Compiling as Sym -import qualified Language.Symantic.Typing as Sym -import qualified Language.Symantic.Parsing as Sym import Language.Symantic.Parsing.Grammar +import Language.Symantic.Parsing.EBNF -- * Type 'ParsecT' type ParsecC e s = (P.Token s ~ Char, P.Stream s, P.ErrorComponent e) @@ -52,31 +30,32 @@ instance ParsecC e s => IsString (P.ParsecT e s m [Char]) where fromString = P.string instance ParsecC e s => Gram_Rule (P.ParsecT e s m) where rule = P.label . Text.unpack -instance ParsecC e s => Gram_Term (P.ParsecT e s m) where +instance ParsecC e s => Gram_Terminal (P.ParsecT e s m) where any = P.anyChar - eof = P.eof + eoi = P.eof char = P.char string = P.string unicat cat = P.satisfy $ (`List.elem` cats) . Char.generalCategory where cats = unicode_categories cat range (l, h) = P.satisfy $ \c -> l <= c && c <= h + but (Terminal f) (Terminal p) = Terminal $ P.notFollowedBy (P.try p) *> f instance ParsecC e s => Alter (P.ParsecT e s m) where x <+> y = P.try x <|> y instance ParsecC e s => Gram_RegR (P.ParsecT e s m) where - Term f .*> Reg x = Reg $ f <*> x + Terminal f .*> Reg x = Reg $ f <*> x instance ParsecC e s => Gram_RegL (P.ParsecT e s m) where - Reg f <*. Term x = Reg $ f <*> x + Reg f <*. Terminal x = Reg $ f <*> x instance ParsecC e s => App (P.ParsecT e s m) instance ParsecC e s => Alt (P.ParsecT e s m) instance ParsecC e s => Gram_CF (P.ParsecT e s m) where - CF f <& Reg p = CF $ P.lookAhead f <*> p - Reg f &> CF p = CF $ P.lookAhead f <*> p - but (CF f) (Reg p) = CF $ P.notFollowedBy (P.try p) *> f -instance ParsecC e s => Gram_Context (P.ParsecT e s m) where - type Context (P.ParsecT e s m) = P.SourcePos - context = (P.getPosition >>=) + CF f <& Reg p = CF $ P.lookAhead f <*> p + Reg f &> CF p = CF $ P.lookAhead f <*> p + minus (CF f) (Reg p) = CF $ P.notFollowedBy (P.try p) *> f +instance ParsecC e s => Gram_Meta P.SourcePos (P.ParsecT e s m) where + metaG p = do + pos <- P.getPosition + ($ pos) <$> p instance ParsecC e s => Gram_Lexer (P.ParsecT e s m) -instance ParsecC e s => Sym.Gram_Type (P.ParsecT e s m) runParserT :: Monad m => P.ParsecT P.Dec s m a -> s @@ -88,92 +67,59 @@ runParser -> Either (P.ParseError (P.Token s) P.Dec) a runParser p = P.runParser p "" +elide :: String -> String +elide s | length s > 42 = take 42 s ++ ['…'] +elide s = s - -{- --- Tests -g1 = (<>) <$> string "0" <*> string "1" -g2 = (<>) <$> string "0" <* string "X" <*> string "1" -g3 = (<>) <$> (string "0" <|> string "1") <*> string "2" -g4 = string "0" <|> string "1" <|> string "2" -g5 = choice [string "0", string "1", string "2"] -g6 = (<>) <$> choice [(<>) <$> string "0" <*> string "1", string "2" <|> string "3", string "4"] <*> string "5" -g7 = concat <$> many (string "0") -g8 = (concat <$>) $ (<>) <$> many (string "0" <|> string "1") <*> some (string "2") -g9 = (<>) <$> string "0" .*> someR (char '1') -g10 = (<>) <$> someL (char '1') <*. string "0" -g11 = string "0" `but` g9 `but` g10 -g12 = (<>) <$> string "0" <& g9 -g13 = string "abé\"to" -g14 = string "\"" -g15 = string "" -g16 = many $ unicat [Unicat_Letter] -g17 = many $ range ('a', 'z') -g18 = ("" <$) $ commentable (void g1) (void g2) (void g3) -g19 = ("" <$) $ choice [g5] -g20 = "" <$ char 'a' <* char 'b' <* char 'c' -g21 = "" <$ comment_line "--" -g22 = "" <$ lexeme (string "A") -g23 = "" <$ keywords - -main :: IO () -main = do - putStrLn "EBNF" - {- - forM_ - [ g1, g2, g3, g4, g5, g6, g7, g8 - , g11, g12, g13, g14, g15, g16, g17, g18 - , g19, g20, g21, g22, cf_of_reg g23 - ] $ \g -> do - Text.putStrLn $ runEBNF RuleMode_Def $ unCF g - -} - forM_ - [ "" <$ comment_line (rule_arg "prefix") - , "" <$ comment_block (rule_arg "start") (rule_arg "end" :: Reg 'L RuleDef String) - , "" <$ commentable (void $ rule_arg "space") (void $ rule_arg "line") (void $ rule_arg "block") - , "" <$ lexeme (rule_arg "p") - , "" <$ parens (rule_arg "p") - , "" <$ inside id (rule_arg "begin") (rule_arg "i") (rule_arg "end") (rule_arg "next") - , "" <$ infixrP const (rule_arg "next") (rule_arg "sep") (rule_arg "root") - {- - , "" <$ typeP - , "" <$ type_list - , "" <$ type_tuple2 - , "" <$ type_fun - , "" <$ type_app - , "" <$ type_atom - , "" <$ type_name - -} - ] $ \g -> do - Text.putStrLn $ runEBNF $ unRuleDef $ unCF g - putStrLn "" - {- - putStrLn "Tests" - forM_ - [ "Bool" - , "(Bool)" - , "((Bool))" - , "Bool, Int" - , "(Bool, Int)" - , "((Bool, Int), Char)" - , "(Bool, Int) -> Char" - , "(Bool -> Int)" - , "((Bool, Int), Char)" - , "String" - , "[Char]" - , "[Char] -> String" - , "String -> [Char]" - , "Maybe Bool" - , "Either Bool Int" - , "Bool -> Int" - , "(Bool -> Int) -> Char" - , "(Bool -> Int) Char" - , "Bool -> (Int -> Char)" - , "Bool -> Int -> Char" - ] $ \s -> do - putStr (show (s::Text)) - Text.putStr " ==> " - print $ (compile_type <$>) $ runIdentity $ runParser (unCF (typeP <* eof)) s - -} - --} +tests :: TestTree +tests = testGroup "Grammar" + [ testGroup "Terminal" $ + let (==>) inp exp = + testCase (elide $ Text.unpack exp) $ + runEBNF (unTerminal (void inp)) @?= exp + ; infix 1 ==> in + [ string "" ==> "\"\"" + , string "abé\"to" ==> "\"abé\", U+34, \"to\"" + , string "\"" ==> "U+34" + , range ('a', 'z') ==> "\"a\"…\"z\"" + , unicat Unicat_Letter ==> "Unicat_Letter" + , unicat (Unicat Char.LowercaseLetter) ==> "Unicat LowercaseLetter" + ] + , testGroup "Reg" $ + let (==>) inp exp = + testCase (elide $ Text.unpack exp) $ + runEBNF (unReg (void inp)) @?= exp + ; infix 1 ==> in + [ (<>) <$> string "0" .*> someR (char '1') ==> "\"0\", {\"1\"}-" + , (<>) <$> someL (char '1') <*. string "0" ==> "{\"1\"}-, \"0\"" + ] + , testGroup "CF" $ + let (==>) inp exp = + testCase (elide $ Text.unpack exp) $ + runEBNF (unCF (void inp)) @?= exp + ; infix 1 ==> in + [ (<>) <$> string "0" <*> string "1" ==> "\"0\", \"1\"" + , (<>) <$> string "0" <* string "X" <*> string "1" ==> "\"0\", \"X\", \"1\"" + , (<>) <$> (string "0" <|> string "1") <*> string "2" ==> "(\"0\" | \"1\"), \"2\"" + , (<>) <$> (string "0" <+> string "1") <*> string "2" ==> "(\"0\" | \"1\"), \"2\"" + , (<>) <$> string "0" <*> (string "1" <+> string "2") ==> "\"0\", (\"1\" | \"2\")" + , string "0" <|> string "1" <|> string "2" ==> "\"0\" | \"1\" | \"2\"" + , choice [string "0", string "1", string "2"] ==> "\"0\" | \"1\" | \"2\"" + , (<>) <$> choice + [ (<>) <$> string "0" <*> string "1" + , string "2" <|> string "3" + , string "4" + ] <*> string "5" ==> "(\"0\", \"1\" | \"2\" | \"3\" | \"4\"), \"5\"" + , concat <$> many (string "0") ==> "{\"0\"}" + , () <$ char 'a' <* char 'b' <* char 'c' ==> "\"a\", \"b\", \"c\"" + ,let g0 = (<>) <$> string "0" .*> someR (char '1') in + (<>) <$> string "0" <& g0 ==> "\"0\" & \"0\", {\"1\"}-" + ,let g0 = (<>) <$> string "0" .*> someR (char '1') in + let g1 = (<>) <$> someL (char '1') <*. string "0" in + string "0" `minus` g0 `minus` g1 ==> + "\"0\" - \"0\", {\"1\"}- - {\"1\"}-, \"0\"" + , (<>) + <$> many (string "0" <|> string "1") + <*> some (string "2") ==> "{\"0\" | \"1\"}, {\"2\"}-" + ] + ] diff --git a/Language/Symantic/Parsing/Test.hs b/Language/Symantic/Parsing/Test.hs index f7fcedb..f73a012 100644 --- a/Language/Symantic/Parsing/Test.hs +++ b/Language/Symantic/Parsing/Test.hs @@ -1,329 +1,10 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstrainedClassMethods #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Parsing.Test where -import qualified Data.Char as Char -import qualified Data.MonoTraversable as MT -import qualified Data.Kind as Kind -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.List as List -import Data.String (IsString(..)) -import Data.Proxy +import Test.Tasty +import qualified Parsing.Grammar.Test as Grammar -import Language.Symantic.Parsing -import Language.Symantic.Typing -import Language.Symantic.Compiling (TokenT(..)) - --- * Type 'Syntax' -data Syntax a - = Syntax a [Syntax a] - deriving (Eq) -instance Monoid (Syntax Text) where - mempty = Syntax "" [] - mappend (Syntax "" []) x = x - mappend x (Syntax "" []) = x - mappend x y = Syntax " " [x, y] - --- * Class 'Sy' -class Sy c where - type SyT c - sy :: - ( Show_Const '[Proxy c] - , Inj_Const '[Proxy c] c - ) => SyT c -instance Sy (c::Kind.Type) where - type SyT c = Syntax Text - sy = Syntax (Text.pack $ show_const (inj_const::Const '[Proxy c] c)) [] -instance Sy (c::a -> b) where - type SyT c = [Syntax Text] -> Syntax Text - sy = Syntax (Text.pack $ show_const (inj_const::Const '[Proxy c] c)) - --- | Custom 'Show' instance a little bit more readable --- than the automatically derived one. -instance Show (Syntax Text) where - showsPrec p ast@(Syntax name args) = - let n = Text.unpack name in - case ast of - Syntax _ [] -> showString n - Syntax "(->)" [a] -> - showParen (p Prelude.<= prec_arrow) $ - showString (""++n++" ") . - showsPrec prec_arrow a - Syntax "(->)" [a, b] -> - showParen (p Prelude.<= prec_arrow) $ - showsPrec prec_arrow a . - showString (" -> ") . - showsPrec (prec_arrow Prelude.+ 1) b - Syntax "\\" [var, typ, body] -> - showParen (p Prelude.<= prec_lambda) $ - showString ("\\(") . - showsPrec prec_lambda var . - showString (":") . - showsPrec prec_lambda typ . - showString (") -> ") . - showsPrec prec_lambda body - Syntax " " (fun:as) -> - showParen (p Prelude.<= prec_app) $ - showsPrec prec_dollar fun . - List.foldl - (\acc arg -> - acc . showString (" ") . - showsPrec prec_dollar arg) - (showString ("")) as - Syntax "$" [fun, arg] -> - showParen (p Prelude.<= prec_dollar) $ - showsPrec prec_dollar fun . - showString (" $ ") . - showsPrec prec_dollar arg - _ -> - showParen (p Prelude.<= prec_app) $ - showString n . - showString " " . - showString (List.unwords $ show Prelude.<$> args) - where - prec_arrow = 1 - prec_lambda = 1 - prec_dollar = 1 - prec_app = 10 - --- * Class 'Tokenize' --- | A minimal parser, dispatched in many class instances. --- One could also have used a framework like megaparsec, --- and many class instances to handle 'TokenT's --- (and be able to handle the fact that --- they may have a different number of arguments). --- Here 'TokenizeR' try each 'TokenizeT' --- up until one works, but this could --- also be made more efficient by --- building a 'Map' instead of these nested cases. -type Tokenize ast meta ts = TokenizeR ast meta ts ts - -tokenize :: forall meta ast ts. Tokenize ast meta ts - => ast -> Either (Error_Syntax ast) (EToken meta ts) -tokenize = tokenizeR (Proxy::Proxy ts) - --- ** Class 'TokenizeR' -class TokenizeR ast meta ts rs where - tokenizeR :: Proxy rs -> ast -> Either (Error_Syntax ast) (EToken meta ts) -instance - ( TokenizeT ast meta ts (Proxy Token_Var) - , TokenizeR ast meta ts ts - , Inj_Token meta ts (->) - , Monoid meta - ) => TokenizeR ast meta ts '[] where - tokenizeR _rs ast = - case tokenizeT (Proxy::Proxy (Proxy Token_Var)) ast of - Nothing -> Left $ Error_Syntax_unsupported ast - Just (Left err) -> Left err - Just (Right (as, tok)) -> - List.foldl (\mf ma -> do - a <- tokenize ma - f <- mf - Right $ EToken $ inj_token (meta_of f `mappend` meta_of a) $ - Token_Term_App f a - ) (Right tok) as -instance - ( TokenizeT ast meta ts t - , TokenizeR ast meta ts ts - , TokenizeR ast meta ts rs - , Inj_Token meta ts (->) - ) => TokenizeR ast meta ts (t ': rs) where - tokenizeR _ ast = - case tokenizeT (Proxy::Proxy t) ast of - Nothing -> tokenizeR (Proxy::Proxy rs) ast - Just (Left err) -> Left err - Just (Right (as, tok)) -> - List.foldl (\mf ma -> do - a <- tokenize ma - f <- mf - Right $ EToken $ inj_token (meta_of f {-`mappend` meta_of a-}) $ - Token_Term_App f a - ) (Right tok) as - --- Type 'Token_Var' -data Token_Var -instance - Inj_Token (Syntax Text) ts (->) => - TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Token_Var) where - tokenizeT _t meta@(Syntax x as) - | Just (x0, xs) <- Text.uncons x - , Char.isLetter x0 && Char.isLower x0 - , MT.oall (\c -> Char.isLetter c || Char.isNumber c) xs - = Just $ Right $ (as,) $ EToken $ inj_token meta $ - Token_Term_Var x - tokenizeT _t _sy = Nothing - --- ** Class 'TokenizeT' -class TokenizeT ast meta ts t where - tokenizeT :: Proxy t -> ast - -> Maybe ( Either (Error_Syntax ast) - ([ast], EToken meta ts) ) -instance - ( Inj_Token (Syntax Text) ts (->) - , Tokenize (Syntax Text) (Syntax Text) ts ) => - TokenizeT (Syntax Text) (Syntax Text) ts (Proxy (->)) where - tokenizeT _t (Syntax "\\" (Syntax n [] : ast_ty : ast_te : as)) = Just $ do - tok_ty <- tokenize_type ast_ty - tok_te <- tokenize ast_te - Right $ (as,) $ EToken $ - inj_token (Syntax "\\" [Syntax n [], ast_ty, ast_te]) $ - Token_Term_Abst n tok_ty tok_te - tokenizeT _t (Syntax " " (ast_f : ast_x : as)) = Just $ do - tok_f <- tokenize ast_f - tok_x <- tokenize ast_x - Right $ (as,) $ EToken $ - inj_token (Syntax " " [ast_f, ast_x]) $ - Token_Term_App tok_f tok_x - tokenizeT _t (Syntax "let" (Syntax n [] : ast_te : ast_in : as)) = Just $ do - tok_te <- tokenize ast_te - tok_in <- tokenize ast_in - Right $ (as,) $ EToken $ - inj_token (Syntax "let" [Syntax n [], ast_te, ast_in]) $ - Token_Term_Let n tok_te tok_in - tokenizeT _t _sy = Nothing -instance - ( Inj_Token (Syntax Text) ts Int - {-, Tokenize (Syntax Text) (Syntax Text) ts-} ) => - TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Int) where - tokenizeT _t (Syntax "int" (ast_i : as)) = Just $ do - i <- read_syntax ast_i - Right $ (as,) $ EToken $ inj_token (Syntax "int" [ast_i]) $ - Token_Term_Int i - tokenizeT _t _sy = Nothing -instance - ( Inj_Token (Syntax Text) ts [] - , Tokenize (Syntax Text) (Syntax Text) ts ) => - TokenizeT (Syntax Text) (Syntax Text) ts (Proxy []) where - tokenizeT _t meta@(Syntax "list" (ast_ty : ast_as)) = Just $ do - typ <- tokenize_type ast_ty - as <- tokenize `mapM` ast_as - Right $ ([],) $ EToken $ inj_token meta $ - Token_Term_List_list typ as - tokenizeT _t (Syntax "zipWith" (ast_f : as)) = Just $ do - f <- tokenize ast_f - Right $ (as,) $ EToken $ inj_token (Syntax "zipWith" [ast_f]) $ - Token_Term_List_zipWith f - tokenizeT _t _sy = Nothing -instance - ( Inj_Token (Syntax Text) ts Char ) => - TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Char) where - tokenizeT _t (Syntax "char" (ast_c : as)) = Just $ do - c <- read_syntax ast_c - Right $ (as,) $ EToken $ inj_token (Syntax "char" [ast_c]) $ - Token_Term_Char c - tokenizeT _t (Syntax "Char.toUpper" as) = Just $ - Right $ (as,) $ EToken $ inj_token (Syntax "Char.toUpper" []) $ - Token_Term_Char_toUpper - tokenizeT _t _sy = Nothing -instance - ( Inj_Token (Syntax Text) ts Text ) => - TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Text) where - tokenizeT _t (Syntax "text" (ast_t : as)) = Just $ do - t <- read_syntax ast_t - Right $ (as,) $ EToken $ inj_token (Syntax "text" [ast_t]) $ - Token_Term_Text t - tokenizeT _t _sy = Nothing -instance - ( Inj_Token (Syntax Text) ts Maybe - , Tokenize (Syntax Text) (Syntax Text) ts ) => - TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Maybe) where - tokenizeT _t (Syntax "Just" (ast_a : as)) = Just $ do - a <- tokenize ast_a - Right $ (as,) $ EToken $ inj_token (Syntax "Just" [ast_a]) $ - Token_Term_Maybe_Just a - tokenizeT _t _sy = Nothing -instance - ( Inj_Token (Syntax Text) ts (,) - , Tokenize (Syntax Text) (Syntax Text) ts ) => - TokenizeT (Syntax Text) (Syntax Text) ts (Proxy (,)) where - tokenizeT _t (Syntax "(,)" (ast_a : ast_b : as)) = Just $ do - a <- tokenize ast_a - b <- tokenize ast_b - Right $ (as,) $ EToken $ inj_token (Syntax "(,)" [ast_a, ast_b]) $ - Token_Term_Tuple2 a b - tokenizeT _t (Syntax "fst" (ast_t : as)) = Just $ do - t <- tokenize ast_t - Right $ (as,) $ EToken $ inj_token (Syntax "fst" [ast_t]) $ - Token_Term_Tuple2_fst t - tokenizeT _t (Syntax "snd" (ast_t : as)) = Just $ do - t <- tokenize ast_t - Right $ (as,) $ EToken $ inj_token (Syntax "snd" [ast_t]) $ - Token_Term_Tuple2_snd t - tokenizeT _t _sy = Nothing -instance - ( Inj_Token (Syntax Text) ts Num - , Tokenize (Syntax Text) (Syntax Text) ts ) => - TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Num) where - tokenizeT _t (Syntax "(+)" (ast_x : as)) = Just $ do - x <- tokenize ast_x - Right $ (as,) $ EToken $ inj_token (Syntax "(+)" [ast_x]) $ - Token_Term_Num_add x - tokenizeT _t _sy = Nothing -instance - ( Inj_Token (Syntax Text) ts Monoid - , Tokenize (Syntax Text) (Syntax Text) ts ) => - TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Monoid) where - tokenizeT _t (Syntax "mappend" (ast_x : as)) = Just $ do - x <- tokenize ast_x - Right $ (as,) $ EToken $ inj_token (Syntax "mappend" [ast_x]) $ - Token_Term_Monoid_mappend x - tokenizeT _t _sy = Nothing - -tokenize_type - :: Inj_Token (Syntax Text) ts Token_Type - => Syntax Text - -> Either (Error_Syntax (Syntax Text)) (EToken (Syntax Text) ts) -tokenize_type meta@(Syntax n as) - | Just (c, _) <- Text.uncons n - , (Char.isUpper c && MT.oall Char.isLetter n) - || MT.oall (\x -> Char.isSymbol x || Char.isPunctuation x) n = - EToken . inj_token meta . Token_Type n - <$> sequence (tokenize_type <$> as) -tokenize_type syn = Left $ Error_Syntax_unsupported syn - --- * Type 'Error_Syntax' -data Error_Syntax ast - = Error_Syntax_read ast Text - | Error_Syntax_unsupported ast - deriving (Eq, Show) - -syLam x typ te = Syntax "\\" [syVar x, typ, te] -syVar x = Syntax x [] -syApp f x = Syntax " " [f, x] -syLet x b i = Syntax "let" [syVar x, b, i] - -syLit :: forall c. - ( Show_Const '[Proxy c] - , Inj_Const '[Proxy c] c - , Show c - ) => c -> Syntax Text -syLit x = Syntax n [Syntax (Text.pack $ show x) []] - where - c:cs = show_const (inj_const::Const '[Proxy c] c) - n = Text.cons (Char.toLower c) $ Text.pack cs - -syFun :: IsString a => [Syntax a] -> Syntax a -syFun = Syntax "(->)" - -(.>) :: IsString a => Syntax a -> Syntax a -> Syntax a -a .> b = syFun [a, b] -infixr 3 .> - -read_syntax :: Read a => Syntax Text -> Either (Error_Syntax (Syntax Text)) a -read_syntax ast@(Syntax t as) = - case reads $ Text.unpack t of - [(x, "")] | List.null as -> Right x - _ -> Left $ Error_Syntax_read ast t - -maybeRight :: Either l r -> Maybe r -maybeRight (Right r) = Just r -maybeRight Left{} = Nothing +-- * Tests +tests :: TestTree +tests = testGroup "Parsing" $ + [ Grammar.tests + ] diff --git a/Language/Symantic/Parsing/Token.hs b/Language/Symantic/Parsing/Token.hs index d4f3d4a..a19ad37 100644 --- a/Language/Symantic/Parsing/Token.hs +++ b/Language/Symantic/Parsing/Token.hs @@ -115,7 +115,7 @@ inj_token => meta -> TokenT meta ts (Proxy t) -> Token meta ts (Proxy t) -inj_token = inj_tokenP (Proxy::Proxy (Index ts (Proxy t))) +inj_token = inj_tokenP (Proxy @(Index ts (Proxy t))) inj_etoken :: forall meta ts t. @@ -123,7 +123,7 @@ inj_etoken => meta -> TokenT meta ts (Proxy t) -> EToken meta ts -inj_etoken meta = EToken . inj_tokenP (Proxy::Proxy (Index ts (Proxy t))) meta +inj_etoken meta = EToken . inj_tokenP (Proxy @(Index ts (Proxy t))) meta -- ** Class 'Inj_TokenP' class Inj_TokenP p meta ts rs (t::kt) where @@ -135,7 +135,16 @@ instance Inj_TokenP Zero meta ts (Proxy t ': rs) t where instance Inj_TokenP p meta ts rs t => Inj_TokenP (Succ p) meta ts (not_t ': rs) t where - inj_tokenP _p meta = TokenS . inj_tokenP (Proxy::Proxy p) meta + inj_tokenP _p meta = TokenS . inj_tokenP (Proxy @p) meta + +-- ** Type 'Inj_Tokens' +type Inj_Tokens meta ts ts_to_inj + = Concat_Constraints (Inj_TokensR meta ts ts_to_inj) + +-- *** Type family 'Inj_TokensR' +type family Inj_TokensR meta ts ts_to_inj where + Inj_TokensR meta ts '[] = '[] + Inj_TokensR meta ts (Proxy t ': rs) = Inj_Token meta ts t ': Inj_TokensR meta ts rs -- * Class 'Proj_Token' -- | Convenient type synonym wrapping 'Proj_TokenP' @@ -146,7 +155,7 @@ proj_token :: forall meta ts t u. Proj_Token ts t => Token meta ts u -> Maybe (Proxy t :~: u, meta, TokenT meta ts u) -proj_token = proj_tokenP (Proxy::Proxy (Index ts (Proxy t))) +proj_token = proj_tokenP (Proxy @(Index ts (Proxy t))) proj_etoken :: forall meta ts t. Proj_Token ts t @@ -167,7 +176,7 @@ instance Proj_TokenP Zero ts (Proxy t ': rs) t where proj_tokenP _p TokenS{} = Nothing instance Proj_TokenP p ts rs t => Proj_TokenP (Succ p) ts (not_t ': rs) t where proj_tokenP _p TokenZ{} = Nothing - proj_tokenP _p (TokenS u) = proj_tokenP (Proxy::Proxy p) u + proj_tokenP _p (TokenS u) = proj_tokenP (Proxy @p) u -- * Type 'At' -- | Attach a location. diff --git a/Language/Symantic/Test.hs b/Language/Symantic/Test.hs index b7219b0..a17b294 100644 --- a/Language/Symantic/Test.hs +++ b/Language/Symantic/Test.hs @@ -4,6 +4,7 @@ import Test.Tasty import qualified Typing.Test as Typing import qualified Compiling.Test as Compiling +import qualified Parsing.Test as Parsing main :: IO () main = @@ -11,4 +12,5 @@ main = testGroup "Language.Symantic" [ Typing.tests , Compiling.tests + , Parsing.tests ] diff --git a/Language/Symantic/Typing/Constant.hs b/Language/Symantic/Typing/Constant.hs index 3ab34eb..eb08362 100644 --- a/Language/Symantic/Typing/Constant.hs +++ b/Language/Symantic/Typing/Constant.hs @@ -11,7 +11,6 @@ import Data.NonNull (NonNull) import Data.Proxy import Data.Text (Text) import Data.Type.Equality -import GHC.Exts (Constraint) import qualified System.IO as IO import Language.Symantic.Lib.Data.Type.List @@ -48,7 +47,7 @@ type Inj_Const cs c = Inj_ConstP (Index cs (Proxy c)) cs 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 c -inj_const = inj_constP (Proxy::Proxy (Index cs (Proxy c))) +inj_const = inj_constP (Proxy @(Index cs (Proxy c))) -- ** Class 'Inj_ConstP' class Inj_ConstP p cs c where @@ -65,7 +64,7 @@ instance ) => Inj_ConstP Zero (Proxy c ': cs) (c::k) where inj_constP _ = ConstZ (kindP (Proxy :: Proxy (Ty_of_Type k))) instance Inj_ConstP p cs c => Inj_ConstP (Succ p) (not_c ': cs) c where - inj_constP _p = ConstS (inj_constP (Proxy::Proxy p)) + inj_constP _p = ConstS (inj_constP (Proxy @p)) -- * Class 'Proj_Const' -- | Convenient type synonym wrapping 'Proj_ConstP' @@ -76,10 +75,10 @@ type Proj_Const cs c = Proj_ConstP (Index cs (Proxy c)) cs c -- returning a proof that the 'Const' indexes @c@ iif. it's the case. proj_const :: forall cs k (c::k) (u::k). Proj_Const cs c => Const cs u -> Proxy c -> Maybe (c :~: u) -proj_const = proj_constP (Proxy::Proxy (Index cs (Proxy c))) +proj_const = proj_constP (Proxy @(Index cs (Proxy c))) (=?) :: forall cs c u. Proj_Const cs c => Const cs u -> Proxy c -> Maybe (c :~: u) -(=?) = proj_constP (Proxy::Proxy (Index cs (Proxy c))) +(=?) = proj_constP (Proxy @(Index cs (Proxy c))) -- ** Type 'Proj_ConstP' class Proj_ConstP p cs c where @@ -89,14 +88,14 @@ instance Proj_ConstP Zero (Proxy c ': cs) c where 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 + proj_constP _p (ConstS u) c = proj_constP (Proxy @p) u c -- ** Type 'Proj_Consts' type Proj_Consts cs cs_to_proj = Concat_Constraints (Proj_ConstsR cs cs_to_proj) -- *** Type family 'Proj_ConstsR' -type family Proj_ConstsR cs cs_to_proj :: [Constraint] where +type family Proj_ConstsR cs cs_to_proj where Proj_ConstsR cs '[] = '[] Proj_ConstsR cs (Proxy x ': xs) = Proj_Const cs x ': Proj_ConstsR cs xs diff --git a/Language/Symantic/Typing/Constraint.hs b/Language/Symantic/Typing/Constraint.hs index 7a9411f..80def6a 100644 --- a/Language/Symantic/Typing/Constraint.hs +++ b/Language/Symantic/Typing/Constraint.hs @@ -37,7 +37,7 @@ proj_con :: forall cs q. Proj_Con cs => Type cs q -> Maybe (Con q) -proj_con = proj_conR (Proxy::Proxy cs) +proj_con = proj_conR (Proxy @cs) -- ** Class 'Proj_ConR' -- | Intermediate type class to construct an instance of 'Proj_Con' @@ -56,8 +56,8 @@ instance , Proj_ConR cs rs ) => Proj_ConR cs (c ': rs) where proj_conR _rs q = - proj_conC (Proxy::Proxy c) q <|> - proj_conR (Proxy::Proxy rs) q + proj_conC (Proxy @c) q <|> + proj_conR (Proxy @rs) q -- | End the recursion. instance Proj_ConR cs '[] diff --git a/Language/Symantic/Typing/Family.hs b/Language/Symantic/Typing/Family.hs index fc56399..1904a8c 100644 --- a/Language/Symantic/Typing/Family.hs +++ b/Language/Symantic/Typing/Family.hs @@ -26,7 +26,7 @@ type Proj_Fam cs = Proj_FamR cs cs proj_fam :: forall fam cs hs. Proj_Fam cs fam => fam -> Types cs hs -> Maybe (Type cs (Fam fam hs)) -proj_fam = proj_famR (Proxy::Proxy cs) +proj_fam = proj_famR (Proxy @cs) -- ** Class 'Proj_FamR' -- | Intermediate type class to construct an instance of 'Proj_Fam' @@ -47,8 +47,8 @@ instance , Proj_FamR cs rs fam ) => Proj_FamR cs (Proxy c ': rs) fam where proj_famR _rs fam typ = - proj_famC (Proxy::Proxy c) fam typ <|> - proj_famR (Proxy::Proxy rs) fam typ + proj_famC (Proxy @c) fam typ <|> + proj_famR (Proxy @rs) fam typ -- | End the recursion. instance Proj_FamR cs '[] fam diff --git a/Language/Symantic/Typing/Kind.hs b/Language/Symantic/Typing/Kind.hs index 2e74e09..0ee74b1 100644 --- a/Language/Symantic/Typing/Kind.hs +++ b/Language/Symantic/Typing/Kind.hs @@ -43,7 +43,7 @@ eq_skind _ _ = Nothing -- hence the introduction of 'Ty', 'Ty_of_Type', 'Type_of_Ty' and 'IKindP'. class (IKindP (Ty_of_Type k), Type_of_Ty (Ty_of_Type k) ~ k) => IKind k where kind :: SKind k - kind = kindP (Proxy::Proxy (Ty_of_Type k)) + kind = kindP (Proxy @(Ty_of_Type k)) instance (IKindP (Ty_of_Type k), Type_of_Ty (Ty_of_Type k) ~ k) => IKind k -- ** Type 'IKindP' @@ -54,7 +54,7 @@ instance IKindP Constraint where instance IKindP Ty where kindP _ = SKiType instance (IKindP a, IKindP b) => IKindP (a -> b) where - kindP _ = kindP (Proxy::Proxy a) `SKiArrow` kindP (Proxy::Proxy b) + kindP _ = kindP (Proxy @a) `SKiArrow` kindP (Proxy @b) -- ** Type 'Ty' -- | FIXME: to be removed when @@ -112,11 +112,11 @@ instance , Eq_Kind (Any::k1) (Any::k3) ) => Eq_KindB 'True (x::k0 -> k1) (y::k2 -> k3) where eq_kindB _b _x _y - | Just HRefl <- eq_kind (Proxy::Proxy (Any::k0)) (Proxy::Proxy (Any::k2)) - , Just HRefl <- eq_kind (Proxy::Proxy (Any::k1)) (Proxy::Proxy (Any::k3)) + | Just HRefl <- eq_kind (Proxy @(Any::k0)) (Proxy @(Any::k2)) + , Just HRefl <- eq_kind (Proxy @(Any::k1)) (Proxy @(Any::k3)) = Just HRefl eq_kindB _b _x _y = Nothing eq_kind :: forall x y. Eq_Kind x y => Proxy x -> Proxy y -> Maybe (x:~~:y) -eq_kind = eq_kindB (Proxy::Proxy (Eq_KindF x y)) +eq_kind = eq_kindB (Proxy @(Eq_KindF x y)) -} diff --git a/Language/Symantic/Typing/Test.hs b/Language/Symantic/Typing/Test.hs index 51c33fe..c0f361f 100644 --- a/Language/Symantic/Typing/Test.hs +++ b/Language/Symantic/Typing/Test.hs @@ -1,50 +1,48 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Typing.Test where import Test.Tasty import Test.Tasty.HUnit -import Control.Applicative (Applicative(..), Alternative(..)) +import Control.Applicative (Applicative(..)) import Control.Arrow (left) -import qualified Data.Char as Char -import Data.Functor.Identity import Data.Maybe (isJust) import Data.Proxy -import Data.Semigroup ((<>)) -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.IO as Text import GHC.Exts (Constraint) import Prelude hiding (exp) import qualified Text.Megaparsec as P -import qualified Text.Megaparsec.Lexer as L import Language.Symantic.Lib.Data.Type.List -import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling ((~>)) -import Parsing.Test import Parsing.Grammar.Test -- * Tests type Tys = Constants ++ '[Proxy String] +instance + ( ParsecC e s + , Gram_Meta meta (P.ParsecT e s m) + ) => Gram_Type meta (P.ParsecT e s m) tests :: TestTree tests = testGroup "Typing" $ [ testGroup "compile_type" $ - let (==>) inp exp = testCase inp $ got @?= Right (Right (exp::EType Tys)) - where got = (compile_etype <$>) $ (`runParser` inp) $ unCF $ typeP <* eof in + let (==>) inp exp = testCase inp $ got @?= Right (Right exp) + where + got :: Either (P.ParseError Char P.Dec) + (Either (Error_Type P.SourcePos '[Proxy Token_Type]) + (EType Tys)) + got = (compile_etype <$>) $ (`runParser` inp) $ unCF p + p :: Gram_Type P.SourcePos p => CF p (TokType P.SourcePos) + p = typeG <* eoi in uncurry (==>) <$> [ ("Bool", EType $ ty @Bool) , ("[]", EType $ ty @[]) , ("[Char]", EType $ ty @[] :$ ty @Char) + , ("[Char -> [Char]]", EType $ ty @[] :$ (ty @Char ~> ty @[] :$ ty @Char)) , ("([])", EType $ ty @[]) , ("[()]", EType $ ty @[] :$ ty @()) , ("()", EType $ ty @()) @@ -80,15 +78,22 @@ tests = testGroup "Typing" $ ] , testGroup "Parsing errors" $ let (==>) inp _exp = testCase inp $ got @?= Left () - where got = left (const ()) $ (`runParser` inp) $ unCF $ typeP <* eof in + where + got :: Either () (TokType P.SourcePos) + got = left (const ()) $ (`runParser` inp) $ unCF p + p :: Gram_Type P.SourcePos p => CF p (TokType P.SourcePos) + p = typeG <* eoi in uncurry (==>) <$> [ ("Bool, Int", ()) , ("(Bool -> Int) Char", ()) ] , testGroup "Compiling errors" $ - let (==>) inp _exp = testCase inp $ got @?= Right (Left () :: Either () (EType Tys)) - where got = (left (const ()) . compile_etype <$>) $ - (`runParser` inp) $ unCF $ typeP <* eof in + let (==>) inp _exp = testCase inp $ got @?= Right (Left ()) + where + got :: Either (P.ParseError Char P.Dec) (Either () (EType Tys)) + got = (left (const ()) . compile_etype <$>) $ (`runParser` inp) $ unCF p + p :: Gram_Type P.SourcePos p => CF p (TokType P.SourcePos) + p = typeG <* eoi in uncurry (==>) <$> [ ("NonExistingType", ()) , ("Bool Int", ()) diff --git a/Language/Symantic/Typing/Type.hs b/Language/Symantic/Typing/Type.hs index 9a21a8b..918ea74 100644 --- a/Language/Symantic/Typing/Type.hs +++ b/Language/Symantic/Typing/Type.hs @@ -20,7 +20,8 @@ import qualified Data.Kind as K import Language.Symantic.Typing.Kind import Language.Symantic.Typing.Constant import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar +import Language.Symantic.Parsing.Grammar as Gram +import Language.Symantic.Parsing.EBNF -- * Type 'Type' @@ -31,6 +32,14 @@ import Language.Symantic.Parsing.Grammar -- -- * 'TyConst': /type constant/, selected amongst @cs@. -- * @(:$)@: /type application/. +-- +-- See also: https://ghc.haskell.org/trac/ghc/wiki/Typeable +-- Which currently concludes: +-- "Why kind equalities, then? Given the fact that Richard's branch +-- doesn't solve this problem, what is it good for? +-- It still works wonders in the mono-kinded case, +-- such as for decomposing ->. +-- It's just that poly-kinded constructors are still a pain." data Type (cs::[K.Type]) (h::k) where TyConst :: Const cs c -> Type cs c (:$) :: Type cs f -> Type cs x -> Type cs (f x) @@ -120,17 +129,19 @@ instance Show_Const cs => Show (KType cs ki) where -- * Type 'Token_Type' type Token_Type = Type '[] () +newtype Type_Name = Type_Name Text + deriving (Eq, Ord, Show) data instance TokenT meta ts (Proxy Token_Type) - = Token_Type Text [EToken meta ts] + = Token_Type Type_Name [EToken meta ts] deriving instance Eq_Token meta ts => Eq (TokenT meta ts (Proxy Token_Type)) deriving instance Show_Token meta ts => Show (TokenT meta ts (Proxy Token_Type)) instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Token_Type - ) => Read_TypeNameR Text cs (Proxy Token_Type ': rs) where - read_typenameR _rs "Type" k = k (ty @Token_Type) + ) => Read_TypeNameR Type_Name cs (Proxy Token_Type ': rs) where + read_typenameR _rs (Type_Name "Type") k = k (ty @Token_Type) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance Show_Const cs => Show_Const (Proxy Token_Type ': cs) where show_const ConstZ{} = "Type" @@ -147,7 +158,7 @@ class Compile_Type ts cs where -> Either err ret compile_etype - :: Read_TypeName Text cs + :: Read_TypeName Type_Name cs => EToken meta '[Proxy Token_Type] -> Either (Error_Type meta '[Proxy Token_Type]) (EType cs) compile_etype tok = compile_type tok (Right . EType) @@ -184,7 +195,7 @@ check_kind_arrow x k = -- ** Type 'Error_Type' data Error_Type meta ts = Error_Type_Token_invalid (EToken meta ts) - | Error_Type_Constant_unknown (At meta ts Text) + | Error_Type_Constant_unknown (At meta ts Type_Name) | Error_Type_Constraint_Kind (Constraint_Kind meta ts) deriving instance (Eq_TokenR meta ts ts) => Eq (Error_Type meta ts) deriving instance (Show_TokenR meta ts ts) => Show (Error_Type meta ts) @@ -210,39 +221,39 @@ instance Read_TypeNameR raw cs '[] where -- TODO: move each of these to a dedicated module. instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Bounded - ) => Read_TypeNameR Text cs (Proxy Bounded ': rs) where - read_typenameR _cs "Bounded" k = k (ty @Bounded) + ) => Read_TypeNameR Type_Name cs (Proxy Bounded ': rs) where + read_typenameR _cs (Type_Name "Bounded") k = k (ty @Bounded) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Enum - ) => Read_TypeNameR Text cs (Proxy Enum ': rs) where - read_typenameR _cs "Enum" k = k (ty @Enum) + ) => Read_TypeNameR Type_Name cs (Proxy Enum ': rs) where + read_typenameR _cs (Type_Name "Enum") k = k (ty @Enum) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Fractional - ) => Read_TypeNameR Text cs (Proxy Fractional ': rs) where - read_typenameR _cs "Fractional" k = k (ty @Fractional) + ) => Read_TypeNameR Type_Name cs (Proxy Fractional ': rs) where + read_typenameR _cs (Type_Name "Fractional") k = k (ty @Fractional) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs Real - ) => Read_TypeNameR Text cs (Proxy Real ': rs) where - read_typenameR _cs "Real" k = k (ty @Real) + ) => Read_TypeNameR Type_Name cs (Proxy Real ': rs) where + read_typenameR _cs (Type_Name "Real") k = k (ty @Real) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance - ( Read_TypeNameR Text cs rs + ( Read_TypeNameR Type_Name cs rs , Inj_Const cs [] , Inj_Const cs Char - ) => Read_TypeNameR Text cs (Proxy String ': rs) where - read_typenameR _cs "String" k = k (ty @[] :$ ty @Char) + ) => Read_TypeNameR Type_Name cs (Proxy String ': rs) where + read_typenameR _cs (Type_Name "String") k = k (ty @[] :$ ty @Char) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k instance - ( Read_TypeName Text cs + ( Read_TypeName Type_Name cs , Proj_Token ts Token_Type ) => Compile_Type ts cs where compile_type @@ -307,7 +318,7 @@ instance olift = olift . Error_Type_Constraint_Kind -- * Class 'Gram_Type' -type ToType p = EToken (Context p) '[Proxy Token_Type] +type TokType meta = EToken meta '[Proxy Token_Type] class ( Alt p , Alter p @@ -315,62 +326,66 @@ class , App p , Gram_CF p , Gram_Rule p - , Gram_Term p + , Gram_Terminal p , Gram_Lexer p - , Gram_Context p - ) => Gram_Type p where - typeP :: CF p (ToType p) - typeP = rule "type" $ type_fun - type_fun :: CF p (ToType p) + , Gram_Meta meta p + ) => Gram_Type meta p where + typeG :: CF p (TokType meta) + typeG = rule "type" $ type_fun + type_fun :: CF p (TokType meta) type_fun = rule "type_fun" $ - context $ \meta -> - let f a b = inj_etoken meta $ Token_Type "(->)" [a, b] in - infixrP f type_list (symbol "->") typeP - type_list :: CF p (ToType p) + infixrG type_list (metaG $ op <$ symbol "->") + where op meta a b = inj_etoken meta $ Token_Type (Type_Name "(->)") [a, b] + type_list :: CF p (TokType meta) type_list = rule "type_list" $ - context $ \meta -> - let f = inj_etoken meta . Token_Type "[]" in - inside f (symbol "[") (option [] (pure <$> typeP)) (symbol "]") type_tuple2 - type_tuple2 :: CF p (ToType p) + metaG $ inside f + (symbol "[") (option [] (pure <$> typeG)) (symbol "]") + (const <$> type_tuple2) + where f a meta = inj_etoken meta $ Token_Type (Type_Name "[]") a + type_tuple2 :: CF p (TokType meta) type_tuple2 = rule "type_tuple2" $ - context $ \meta -> - let f a b = inj_etoken meta $ Token_Type "(,)" [a, b] in - parens (infixrP f typeP (symbol ",") typeP) <+> type_app - type_app :: CF p (ToType p) + parens (infixrG typeG (metaG $ op <$ symbol ",")) <+> type_app + where op meta a b = inj_etoken meta $ Token_Type (Type_Name "(,)") [a, b] + type_app :: CF p (TokType meta) type_app = rule "type_app" $ - (\(EToken (TokenZ meta (Token_Type f as)):as') -> - (EToken (TokenZ meta (Token_Type f (as <> as'))))) - <$> some type_atom - type_atom :: CF p (ToType p) + f <$> some type_atom + where + f :: [TokType meta] -> TokType meta + f (EToken (TokenZ meta (Token_Type a as)):as') = + EToken $ TokenZ meta $ Token_Type a $ as <> as' + f _ = error "Oops, the impossible happened" + type_atom :: CF p (TokType meta) type_atom = rule "type_atom" $ - parens typeP <+> + parens typeG <+> type_name <+> type_symbol - type_name :: CF p (ToType p) + type_name :: CF p (TokType meta) type_name = rule "type_name" $ - context $ \meta -> - lexeme $ - (\c cs -> EToken $ TokenZ meta $ Token_Type (Text.pack $ c:cs) []) + metaG $ lexeme $ + (\c cs meta -> EToken $ TokenZ meta $ Token_Type (Type_Name $ Text.pack $ c:cs) []) <$> unicat (Unicat Char.UppercaseLetter) <*> many (choice $ unicat <$> [Unicat_Letter, Unicat_Number]) - type_symbol :: CF p (ToType p) + type_symbol :: CF p (TokType meta) type_symbol = rule "type_symbol" $ - context $ \meta -> - let f s = inj_etoken meta $ (`Token_Type` []) $ - Text.concat ["(", Text.pack s, ")"] in - (f <$>) $ parens $ many $ choice (unicat <$> + metaG $ (f <$>) $ + parens $ many $ cf_of_term $ choice okG `but` choice koG + where + f s meta = inj_etoken meta $ (`Token_Type` []) $ + Type_Name $ Text.concat ["(", Text.pack s, ")"] + okG = unicat <$> [ Unicat_Symbol , Unicat_Punctuation , Unicat_Mark - ]) `but` char ')' + ] + koG = char <$> ['(', ')', '`'] -deriving instance Gram_Type p => Gram_Type (CF p) -instance Gram_Type EBNF -instance Gram_Type RuleDef +deriving instance Gram_Type meta p => Gram_Type meta (CF p) +instance Gram_Type meta EBNF +instance Gram_Type meta RuleDef -gram_type :: Gram_Type p => [CF p (ToType p)] +gram_type :: Gram_Type meta p => [CF p (TokType meta)] gram_type = - [ typeP + [ typeG , type_fun , type_list , type_tuple2 diff --git a/symantic.cabal b/symantic.cabal index 21d82c4..64a000b 100644 --- a/symantic.cabal +++ b/symantic.cabal @@ -4,43 +4,112 @@ build-type: Simple cabal-version: >= 1.24 category: Language description: + __Description__ + . Library for composing, typing, compiling, transforming and interpreting a custom DSL (Domain-Specific Language) expressing a subset of GHC's Haskell. + Its main goal is to enable the runtime handling of terms typed + according to some compile-time defined types. + The idea being that the more complex logic shall remain coded in Haskell + and then this library used to project an interface into a DSL + giving runtime users the flexibility to write simple programs suited to their needs. + . + Typical use cases: + . + * Enabling runtime users to enter some Haskell-like expressions + without using GHC at runtime (eg. by using ). + * Limiting those expressions to be built only from well-controlled expressions. + * Run some analyzes/optimizations on those well-controlled expressions. + . + __Warning__ + . + Please be aware that despite its using of powerful ideas from clever people, + this remains a fund-less single-person experimental library. + Meaning that it is all but heavily tested and documented, + does not have a strong commitment to preserving backward compatibility, + and can just die without notice. + Its version follows the , + so you may want to use upper-bounds in @build-depends@. + This said, hope you'll enjoy the tool :) + . + __Usage__ + . + Reading the boring @Test.hs@ files should give you enough examples + to understand how to use this library, + and reading some of the repetitively boring and painfully repetitive @Compiling/*.hs@ files + should give you some templates and the general pattern + to let you extend this library with your own symantics. + . + The @Test.hs@ files use as parser + and a default grammar somehow sticking to Haskell's, but staying context-free + (so in particular: insensitive to the indentation). + This grammar, itself written as a symantic embedded DSL, + can be reused to build another one, + is not bound to a specific parser, + and can produce its EBNF rendition. . __Main ideas__ . - * To encode terms in the way + * __Symantic DSL__. + To encode terms in the way (aka. the /symantic/ way) i.e. to use a /class/ to encode the /syntax/ of terms (eg. 'Sym_Bool') - and /class instances/ to encode their /semantics/ - (eg. @(Sym_Bool HostI)@ interprets the term as a @Bool@ - or @(Sym_Bool TextI)@ interprets the term as a @Text@). - /Lambda abstractions/ being handled by an higher-order approach, - meaning that it directly reuses GHC's internal machinery + and /class instances/ on a dedicated type to encode their /semantics/ + (eg. @(Sym_Bool HostI)@ interprets a term as a value of its type + in the host language (Haskell here), + or @(Sym_Bool TextI)@ interprets a term as a textual rendition, etc.). + + DSL are then composed by selecting those symantic /classes/. + When using symantics for an embedded DSL + those /classes/ are all inferred by GHC from the terms used, + provided that the @NoMonomorphismRestriction@ extension is on. + Otherwise, when using symantics for a non-embedded DSL + — the whole point of this library — the /classes/ composing the DSL + are selected manually at GHC's compile-time, + through the /type-level list/ given to 'compile'. + + Moreover, the terms are parameterized by the type of the value they encode, + in order to get the same type safety as with plain Haskell values. + Hence the symantic /classes/ have the higher kind: @((* -> *) -> Constraint)@ + instead of just @(* -> Constraint)@. + + Amongst those symantics, 'Sym_Lambda' introduces /lambda abstractions/ by an higher-order approach, + meaning that they directly reuse GHC's internal machinery to abstract or instantiate variables, which I think is by far the most efficient and simplest way of doing it (no DeBruijn encoding nor 's monads). - * To typecheck terms using a @(Type cs h)@ @GADT@ which acts + + * __Singleton for any type__. + To typecheck terms using a @(Type cs h)@ @GADT@ which acts as a /singleton type/ for any Haskell type @h@ buildable by composing the /type constants/ @cs@, - each wrapped inside a @Proxy@ to fit into a /type-level list/ + each one wrapped inside a @Proxy@ to fit into a common /type-level list/ (eg. @cs ~ [Proxy Bool, Proxy (->), Proxy Eq]@). - * To inject a type into a /type-level list/ + + * __Extensible data type__. + To inject a type into a /type-level list/ or project a /type-level list/ onto a type, to compose an /extensible data type/ (eg. the 'Token' @GADT@ gathering the 'TokenT' /data instances/, that a parser can build and then give to 'compile'). This type-level programming requires @UndecidableInstances@, but not @OverlappingInstances@. - I guess there is a similarity with + + There is a similarity with - (as exploited in for instance), - but not knowing much about them I can't tell, - I just came up using /type-level lists/ by hacking - 's @Elem@, - and now have no incentive to study and compare these techniques: - /type-level lists/ are simple enough. - * To recurse on a /type-level list/ through + (see for instance + or ). + Those also enable to compose a DSL using some machinery + based upon (co)free(r) (co)monads and (cata|ana)morphisms. + Which library fits best your problem domain and brain is for you to judge :) + On that topic, see also: + . + + Here, I just came up using /type-level lists/ by hacking + 's @Elem@. + + * __Extensible class__. + To recurse on a /type-level list/ through /class instances/ to compose an /extensible class/ (eg. 'CompileR' gathering the 'CompileI' /class instances/, or the more tricky 'TermO' /type-level list-zipper/ @@ -54,11 +123,10 @@ description: or building terms by using type classes. * @Rank2Types@ for parsing @GADT@s. * @TypeInType@ (introduced in GHC 8.0.1) - for 'Type' to also be @GADT@-like - in the kind of the Haskell type @h@ it encodes. + for 'Type' to also bind a kind equality for the type @h@ it encodes. Which makes the /type application/ (':$') give us an /arrow kind/ for the Haskell /type constructor/ - it applies an Haskell type to, releaving us from tricky workarounds. + it applies an Haskell type to, releaving me from tricky workarounds. * @ConstraintKinds@ for @cs@ to contain 'Constraint's, or defining /type synonym/ of /type classes/, or merging /type constraints/. @@ -74,31 +142,30 @@ description: does not need to alter all semantics. As explained in . . - __Usage__ - . - There are a few examples in the @Test.hs@ files, - and shall be more one day in the - - of this library. - . __Bugs__ . - Your comments, problem reports, or questions are welcome! :-) + Your comments, problem reports, or questions are welcome! + . + You have my email address, so… just send me some emails :] . - __TODO__ + __To do__ . - * /Type inferencing/ to improve the current hand written /type checking/, + * Study to which point /type inferencing/ is doable, + so that it would improve the current /type checking/, and remove some type annotations in the DSL. - Currently all /lambda abstractions/ must have its variable explicitely typed, + Currently each /lambda abstraction/ must have its variable explicitely typed, and terms must be called with enough arguments to typecheck, be it term arguments (for instance @(+) :: Num a => a -> a -> a@ needs at least one term argument to check @Num a@) or type arguments (for instance @return :: Monad m => a -> m a@ needs a type argument to check @Monad m@). + * Study to which point error messages can be improved. * A lot of common terms should be added in @Compiling.*@ modules. Maybe as separate packages to limit dependencies. * No transformation is implemented so far, - there should be some, at least as examples to demonstrate their power. + maybe there should be some, at least as examples + to demonstrate their power. + * Study where to put @INLINE@, @INLINEABLE@ or @SPECIALIZE@ pragmas. extra-source-files: extra-tmp-files: -- homepage: @@ -109,7 +176,10 @@ name: symantic stability: experimental synopsis: Library for Typed Tagless-Final Higher-Order Composable DSL tested-with: GHC==8.0.1 -version: 3.20170104 +-- PVP: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 4.0.0.20170124 Source-Repository head location: git://git.autogeree.net/symantic @@ -122,19 +192,26 @@ Library FlexibleContexts FlexibleInstances InstanceSigs + LambdaCase MultiParamTypeClasses + NamedFieldPuns OverloadedStrings Rank2Types ScopedTypeVariables StandaloneDeriving + TupleSections TypeApplications TypeFamilies TypeOperators - ghc-options: -Wall -fno-warn-tabs -fprint-explicit-kinds + ghc-options: -Wall + -fwarn-incomplete-patterns + -fno-warn-tabs + -fprint-explicit-kinds default-language: Haskell2010 exposed-modules: Language.Symantic Language.Symantic.Compiling + Language.Symantic.Compiling.Alternative Language.Symantic.Compiling.Applicative Language.Symantic.Compiling.Bool Language.Symantic.Compiling.Char @@ -147,6 +224,7 @@ Library Language.Symantic.Compiling.Int Language.Symantic.Compiling.Integer Language.Symantic.Compiling.Integral + Language.Symantic.Compiling.Lambda Language.Symantic.Compiling.List Language.Symantic.Compiling.Map Language.Symantic.Compiling.Maybe @@ -160,6 +238,7 @@ Library Language.Symantic.Compiling.Sequences Language.Symantic.Compiling.Show Language.Symantic.Compiling.Term + Language.Symantic.Compiling.Term.Grammar Language.Symantic.Compiling.Text Language.Symantic.Compiling.Traversable Language.Symantic.Compiling.Tuple2 @@ -173,6 +252,7 @@ Library Language.Symantic.Parsing Language.Symantic.Parsing.Token Language.Symantic.Parsing.Grammar + Language.Symantic.Parsing.EBNF Language.Symantic.Transforming Language.Symantic.Transforming.Trans Language.Symantic.Typing @@ -196,6 +276,7 @@ Test-Suite symantic-test FlexibleContexts FlexibleInstances MultiParamTypeClasses + NoMonomorphismRestriction OverloadedStrings ScopedTypeVariables TupleSections @@ -203,8 +284,13 @@ Test-Suite symantic-test TypeFamilies TypeOperators default-language: Haskell2010 - ghc-options: -Wall -fno-warn-tabs -O0 + ghc-options: -Wall + -fwarn-incomplete-patterns + -fno-warn-tabs -main-is Test + -O0 + -- -dshow-passes + -- -fmax-simplifier-iterations=0 -- -fprint-explicit-kinds hs-source-dirs: Language/Symantic main-is: Test.hs @@ -215,8 +301,10 @@ Test-Suite symantic-test Compiling.Functor.Test Compiling.Map.Test Compiling.MonoFunctor.Test + Compiling.Num.Test Compiling.Term.Test Compiling.Test + Compiling.Tuple2.Test Parsing.Grammar.Test Parsing.Test Typing.Test @@ -224,12 +312,13 @@ Test-Suite symantic-test base >= 4.6 && < 5 , containers , megaparsec + , monad-classes , mono-traversable - , transformers + , symantic , tasty >= 0.11 , tasty-hunit , text - , symantic + , transformers Test-Suite ebnf type: exitcode-stdio-1.0 @@ -251,17 +340,18 @@ Test-Suite ebnf TypeFamilies TypeApplications TypeOperators - ghc-options: -Wall -fno-warn-tabs - -main-is Parsing.EBNF - main-is: Parsing/EBNF.hs + ghc-options: -Wall + -fno-warn-tabs + -main-is Parsing.EBNF.Print + main-is: Parsing/EBNF/Print.hs default-language: Haskell2010 hs-source-dirs: Language/Symantic build-depends: base >= 4.6 && < 5 , containers , megaparsec + , symantic , transformers , tasty >= 0.11 , tasty-hunit , text - , symantic -- 2.47.2 From 6f83ad044158e8c8980e1bdca108a761b868e392 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Thu, 2 Feb 2017 04:14:08 +0100 Subject: [PATCH 07/16] Move libraries in Lib. --- Language/Symantic/Compiling.hs | 60 ------------ Language/Symantic/Compiling/Term.hs | 2 +- .../{Compiling/Bool => Helper/Data}/HLint.hs | 0 .../Functor => Helper/Data/Type}/HLint.hs | 0 .../{Lib => Helper}/Data/Type/List.hs | 4 +- .../{Lib => Helper}/Data/Type/Peano.hs | 2 +- .../MonoFunctor => Helper}/HLint.hs | 0 Language/Symantic/Lib.hs | 64 +++++++++++++ .../{Compiling => Lib}/Alternative.hs | 8 +- .../{Compiling => Lib}/Applicative.hs | 6 +- .../Lib/{Data => Applicative}/HLint.hs | 0 .../{Compiling => Lib}/Applicative/Test.hs | 4 +- Language/Symantic/{Compiling => Lib}/Bool.hs | 6 +- .../Symantic/Lib/{Data/Type => Bool}/HLint.hs | 0 .../Symantic/{Compiling => Lib}/Bool/Test.hs | 4 +- Language/Symantic/{Compiling => Lib}/Char.hs | 6 +- .../Symantic/{Compiling => Lib}/Either.hs | 6 +- Language/Symantic/{Compiling => Lib}/Eq.hs | 6 +- .../Symantic/{Compiling => Lib}/Foldable.hs | 4 +- Language/Symantic/Lib/Foldable/HLint.hs | 1 + .../{Compiling => Lib}/Foldable/Test.hs | 3 +- .../Symantic/{Compiling => Lib}/Functor.hs | 6 +- Language/Symantic/Lib/Functor/HLint.hs | 1 + .../{Compiling => Lib}/Functor/Test.hs | 3 +- Language/Symantic/{Compiling => Lib}/IO.hs | 6 +- Language/Symantic/{Compiling => Lib}/If.hs | 6 +- Language/Symantic/{Compiling => Lib}/Int.hs | 4 +- .../Symantic/{Compiling => Lib}/Integer.hs | 4 +- .../Symantic/{Compiling => Lib}/Integral.hs | 6 +- .../Symantic/{Compiling => Lib}/Lambda.hs | 4 +- Language/Symantic/{Compiling => Lib}/List.hs | 6 +- Language/Symantic/{Compiling => Lib}/Map.hs | 6 +- .../Symantic/{Compiling => Lib}/Map/Test.hs | 3 +- Language/Symantic/{Compiling => Lib}/Maybe.hs | 6 +- Language/Symantic/{Compiling => Lib}/Monad.hs | 6 +- .../{Compiling => Lib}/MonoFoldable.hs | 6 +- .../{Compiling => Lib}/MonoFunctor.hs | 6 +- Language/Symantic/Lib/MonoFunctor/HLint.hs | 1 + .../{Compiling => Lib}/MonoFunctor/Test.hs | 4 +- .../Symantic/{Compiling => Lib}/Monoid.hs | 6 +- .../Symantic/{Compiling => Lib}/NonNull.hs | 6 +- Language/Symantic/{Compiling => Lib}/Num.hs | 6 +- Language/Symantic/Lib/Num/HLint.hs | 1 + .../Symantic/{Compiling => Lib}/Num/Test.hs | 10 +- Language/Symantic/{Compiling => Lib}/Ord.hs | 8 +- .../Symantic/{Compiling => Lib}/Sequences.hs | 6 +- Language/Symantic/{Compiling => Lib}/Show.hs | 6 +- Language/Symantic/{Compiling => Lib}/Test.hs | 22 ++--- Language/Symantic/{Compiling => Lib}/Text.hs | 4 +- .../{Compiling => Lib}/Traversable.hs | 6 +- .../Symantic/{Compiling => Lib}/Tuple2.hs | 4 +- Language/Symantic/Lib/Tuple2/HLint.hs | 1 + .../{Compiling => Lib}/Tuple2/Test.hs | 3 +- Language/Symantic/{Compiling => Lib}/Unit.hs | 4 +- Language/Symantic/Parsing/Token.hs | 4 +- Language/Symantic/Test.hs | 4 +- Language/Symantic/Typing/Constant.hs | 4 +- Language/Symantic/Typing/Test.hs | 5 +- symantic.cabal | 94 ++++++++++--------- 59 files changed, 241 insertions(+), 233 deletions(-) rename Language/Symantic/{Compiling/Bool => Helper/Data}/HLint.hs (100%) rename Language/Symantic/{Compiling/Functor => Helper/Data/Type}/HLint.hs (100%) rename Language/Symantic/{Lib => Helper}/Data/Type/List.hs (93%) rename Language/Symantic/{Lib => Helper}/Data/Type/Peano.hs (96%) rename Language/Symantic/{Compiling/MonoFunctor => Helper}/HLint.hs (100%) create mode 100644 Language/Symantic/Lib.hs rename Language/Symantic/{Compiling => Lib}/Alternative.hs (95%) rename Language/Symantic/{Compiling => Lib}/Applicative.hs (97%) rename Language/Symantic/Lib/{Data => Applicative}/HLint.hs (100%) rename Language/Symantic/{Compiling => Lib}/Applicative/Test.hs (94%) rename Language/Symantic/{Compiling => Lib}/Bool.hs (97%) rename Language/Symantic/Lib/{Data/Type => Bool}/HLint.hs (100%) rename Language/Symantic/{Compiling => Lib}/Bool/Test.hs (96%) rename Language/Symantic/{Compiling => Lib}/Char.hs (97%) rename Language/Symantic/{Compiling => Lib}/Either.hs (97%) rename Language/Symantic/{Compiling => Lib}/Eq.hs (95%) rename Language/Symantic/{Compiling => Lib}/Foldable.hs (99%) create mode 120000 Language/Symantic/Lib/Foldable/HLint.hs rename Language/Symantic/{Compiling => Lib}/Foldable/Test.hs (91%) rename Language/Symantic/{Compiling => Lib}/Functor.hs (96%) create mode 120000 Language/Symantic/Lib/Functor/HLint.hs rename Language/Symantic/{Compiling => Lib}/Functor/Test.hs (92%) rename Language/Symantic/{Compiling => Lib}/IO.hs (97%) rename Language/Symantic/{Compiling => Lib}/If.hs (95%) rename Language/Symantic/{Compiling => Lib}/Int.hs (96%) rename Language/Symantic/{Compiling => Lib}/Integer.hs (97%) rename Language/Symantic/{Compiling => Lib}/Integral.hs (98%) rename Language/Symantic/{Compiling => Lib}/Lambda.hs (98%) rename Language/Symantic/{Compiling => Lib}/List.hs (98%) rename Language/Symantic/{Compiling => Lib}/Map.hs (98%) rename Language/Symantic/{Compiling => Lib}/Map/Test.hs (95%) rename Language/Symantic/{Compiling => Lib}/Maybe.hs (97%) rename Language/Symantic/{Compiling => Lib}/Monad.hs (97%) rename Language/Symantic/{Compiling => Lib}/MonoFoldable.hs (98%) rename Language/Symantic/{Compiling => Lib}/MonoFunctor.hs (98%) create mode 120000 Language/Symantic/Lib/MonoFunctor/HLint.hs rename Language/Symantic/{Compiling => Lib}/MonoFunctor/Test.hs (87%) rename Language/Symantic/{Compiling => Lib}/Monoid.hs (96%) rename Language/Symantic/{Compiling => Lib}/NonNull.hs (98%) rename Language/Symantic/{Compiling => Lib}/Num.hs (98%) create mode 120000 Language/Symantic/Lib/Num/HLint.hs rename Language/Symantic/{Compiling => Lib}/Num/Test.hs (98%) rename Language/Symantic/{Compiling => Lib}/Ord.hs (97%) rename Language/Symantic/{Compiling => Lib}/Sequences.hs (98%) rename Language/Symantic/{Compiling => Lib}/Show.hs (96%) rename Language/Symantic/{Compiling => Lib}/Test.hs (59%) rename Language/Symantic/{Compiling => Lib}/Text.hs (96%) rename Language/Symantic/{Compiling => Lib}/Traversable.hs (95%) rename Language/Symantic/{Compiling => Lib}/Tuple2.hs (98%) create mode 120000 Language/Symantic/Lib/Tuple2/HLint.hs rename Language/Symantic/{Compiling => Lib}/Tuple2/Test.hs (91%) rename Language/Symantic/{Compiling => Lib}/Unit.hs (97%) diff --git a/Language/Symantic/Compiling.hs b/Language/Symantic/Compiling.hs index 1362985..69001ea 100644 --- a/Language/Symantic/Compiling.hs +++ b/Language/Symantic/Compiling.hs @@ -1,66 +1,6 @@ -- | Compiling terms. module Language.Symantic.Compiling ( module Language.Symantic.Compiling.Term - , module Language.Symantic.Compiling.Applicative - , module Language.Symantic.Compiling.Alternative - , module Language.Symantic.Compiling.Bool - , module Language.Symantic.Compiling.Char - , module Language.Symantic.Compiling.Either - , module Language.Symantic.Compiling.Eq - , module Language.Symantic.Compiling.Foldable - , module Language.Symantic.Compiling.Functor - , module Language.Symantic.Compiling.If - , module Language.Symantic.Compiling.Int - , module Language.Symantic.Compiling.Integer - , module Language.Symantic.Compiling.Integral - , module Language.Symantic.Compiling.IO - , module Language.Symantic.Compiling.Lambda - , module Language.Symantic.Compiling.List - , module Language.Symantic.Compiling.Map - , module Language.Symantic.Compiling.Maybe - , module Language.Symantic.Compiling.Monad - , module Language.Symantic.Compiling.MonoFoldable - , module Language.Symantic.Compiling.MonoFunctor - , module Language.Symantic.Compiling.Monoid - , module Language.Symantic.Compiling.NonNull - , module Language.Symantic.Compiling.Num - , module Language.Symantic.Compiling.Ord - , module Language.Symantic.Compiling.Sequences - , module Language.Symantic.Compiling.Show - , module Language.Symantic.Compiling.Text - , module Language.Symantic.Compiling.Traversable - , module Language.Symantic.Compiling.Tuple2 - , module Language.Symantic.Compiling.Unit ) where import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.Applicative -import Language.Symantic.Compiling.Alternative -import Language.Symantic.Compiling.Bool -import Language.Symantic.Compiling.Char -import Language.Symantic.Compiling.Either -import Language.Symantic.Compiling.Eq -import Language.Symantic.Compiling.Foldable -import Language.Symantic.Compiling.Functor -import Language.Symantic.Compiling.If -import Language.Symantic.Compiling.Int -import Language.Symantic.Compiling.Integer -import Language.Symantic.Compiling.Integral -import Language.Symantic.Compiling.IO -import Language.Symantic.Compiling.Lambda -import Language.Symantic.Compiling.List -import Language.Symantic.Compiling.Map -import Language.Symantic.Compiling.Maybe -import Language.Symantic.Compiling.Monad -import Language.Symantic.Compiling.MonoFoldable -import Language.Symantic.Compiling.MonoFunctor -import Language.Symantic.Compiling.Monoid -import Language.Symantic.Compiling.NonNull -import Language.Symantic.Compiling.Num -import Language.Symantic.Compiling.Ord -import Language.Symantic.Compiling.Sequences -import Language.Symantic.Compiling.Show -import Language.Symantic.Compiling.Text -import Language.Symantic.Compiling.Traversable -import Language.Symantic.Compiling.Tuple2 -import Language.Symantic.Compiling.Unit diff --git a/Language/Symantic/Compiling/Term.hs b/Language/Symantic/Compiling/Term.hs index a25865b..8227e73 100644 --- a/Language/Symantic/Compiling/Term.hs +++ b/Language/Symantic/Compiling/Term.hs @@ -14,7 +14,7 @@ import qualified Data.Text as Text import Data.Type.Equality ((:~:)(..)) import GHC.Exts (Constraint) -import Language.Symantic.Lib.Data.Type.List +import Language.Symantic.Helper.Data.Type.List import Language.Symantic.Parsing import Language.Symantic.Typing diff --git a/Language/Symantic/Compiling/Bool/HLint.hs b/Language/Symantic/Helper/Data/HLint.hs similarity index 100% rename from Language/Symantic/Compiling/Bool/HLint.hs rename to Language/Symantic/Helper/Data/HLint.hs diff --git a/Language/Symantic/Compiling/Functor/HLint.hs b/Language/Symantic/Helper/Data/Type/HLint.hs similarity index 100% rename from Language/Symantic/Compiling/Functor/HLint.hs rename to Language/Symantic/Helper/Data/Type/HLint.hs diff --git a/Language/Symantic/Lib/Data/Type/List.hs b/Language/Symantic/Helper/Data/Type/List.hs similarity index 93% rename from Language/Symantic/Lib/Data/Type/List.hs rename to Language/Symantic/Helper/Data/Type/List.hs index ca14c63..e73a247 100644 --- a/Language/Symantic/Lib/Data/Type/List.hs +++ b/Language/Symantic/Helper/Data/Type/List.hs @@ -1,11 +1,11 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE UndecidableInstances #-} -- | List utilities at the type-level. -module Language.Symantic.Lib.Data.Type.List where +module Language.Symantic.Helper.Data.Type.List where import GHC.Exts (Constraint) -import Language.Symantic.Lib.Data.Type.Peano +import Language.Symantic.Helper.Data.Type.Peano -- ** Type 'Index' -- | Return the position of a type within a list of them. diff --git a/Language/Symantic/Lib/Data/Type/Peano.hs b/Language/Symantic/Helper/Data/Type/Peano.hs similarity index 96% rename from Language/Symantic/Lib/Data/Type/Peano.hs rename to Language/Symantic/Helper/Data/Type/Peano.hs index d72f4fe..7f02697 100644 --- a/Language/Symantic/Lib/Data/Type/Peano.hs +++ b/Language/Symantic/Helper/Data/Type/Peano.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -fno-warn-missing-methods #-} -- | Natural numbers at the type-level, and of kind @*@. -module Language.Symantic.Lib.Data.Type.Peano where +module Language.Symantic.Helper.Data.Type.Peano where import Data.Type.Equality diff --git a/Language/Symantic/Compiling/MonoFunctor/HLint.hs b/Language/Symantic/Helper/HLint.hs similarity index 100% rename from Language/Symantic/Compiling/MonoFunctor/HLint.hs rename to Language/Symantic/Helper/HLint.hs diff --git a/Language/Symantic/Lib.hs b/Language/Symantic/Lib.hs new file mode 100644 index 0000000..8b69d89 --- /dev/null +++ b/Language/Symantic/Lib.hs @@ -0,0 +1,64 @@ +-- | Libraries. +module Language.Symantic.Lib + ( module Language.Symantic.Lib.Applicative + , module Language.Symantic.Lib.Alternative + , module Language.Symantic.Lib.Bool + , module Language.Symantic.Lib.Char + , module Language.Symantic.Lib.Either + , module Language.Symantic.Lib.Eq + , module Language.Symantic.Lib.Foldable + , module Language.Symantic.Lib.Functor + , module Language.Symantic.Lib.If + , module Language.Symantic.Lib.Int + , module Language.Symantic.Lib.Integer + , module Language.Symantic.Lib.Integral + , module Language.Symantic.Lib.IO + , module Language.Symantic.Lib.Lambda + , module Language.Symantic.Lib.List + , module Language.Symantic.Lib.Map + , module Language.Symantic.Lib.Maybe + , module Language.Symantic.Lib.Monad + , module Language.Symantic.Lib.MonoFoldable + , module Language.Symantic.Lib.MonoFunctor + , module Language.Symantic.Lib.Monoid + , module Language.Symantic.Lib.NonNull + , module Language.Symantic.Lib.Num + , module Language.Symantic.Lib.Ord + , module Language.Symantic.Lib.Sequences + , module Language.Symantic.Lib.Show + , module Language.Symantic.Lib.Text + , module Language.Symantic.Lib.Traversable + , module Language.Symantic.Lib.Tuple2 + , module Language.Symantic.Lib.Unit + ) where + +import Language.Symantic.Lib.Applicative +import Language.Symantic.Lib.Alternative +import Language.Symantic.Lib.Bool +import Language.Symantic.Lib.Char +import Language.Symantic.Lib.Either +import Language.Symantic.Lib.Eq +import Language.Symantic.Lib.Foldable +import Language.Symantic.Lib.Functor +import Language.Symantic.Lib.If +import Language.Symantic.Lib.Int +import Language.Symantic.Lib.Integer +import Language.Symantic.Lib.Integral +import Language.Symantic.Lib.IO +import Language.Symantic.Lib.Lambda +import Language.Symantic.Lib.List +import Language.Symantic.Lib.Map +import Language.Symantic.Lib.Maybe +import Language.Symantic.Lib.Monad +import Language.Symantic.Lib.MonoFoldable +import Language.Symantic.Lib.MonoFunctor +import Language.Symantic.Lib.Monoid +import Language.Symantic.Lib.NonNull +import Language.Symantic.Lib.Num +import Language.Symantic.Lib.Ord +import Language.Symantic.Lib.Sequences +import Language.Symantic.Lib.Show +import Language.Symantic.Lib.Text +import Language.Symantic.Lib.Traversable +import Language.Symantic.Lib.Tuple2 +import Language.Symantic.Lib.Unit diff --git a/Language/Symantic/Compiling/Alternative.hs b/Language/Symantic/Lib/Alternative.hs similarity index 95% rename from Language/Symantic/Compiling/Alternative.hs rename to Language/Symantic/Lib/Alternative.hs index c37d42d..54517ec 100644 --- a/Language/Symantic/Compiling/Alternative.hs +++ b/Language/Symantic/Lib/Alternative.hs @@ -1,7 +1,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Symantic for 'Alternative'. -module Language.Symantic.Compiling.Alternative where +module Language.Symantic.Lib.Alternative where import Control.Applicative (Alternative) import qualified Control.Applicative as Alternative @@ -14,9 +14,9 @@ import Prelude hiding (Functor(..), (<$>), id, const) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.Lambda -import Language.Symantic.Compiling.Functor (Sym_Functor(..)) +import Language.Symantic.Compiling +import Language.Symantic.Lib.Lambda +import Language.Symantic.Lib.Functor (Sym_Functor(..)) import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans diff --git a/Language/Symantic/Compiling/Applicative.hs b/Language/Symantic/Lib/Applicative.hs similarity index 97% rename from Language/Symantic/Compiling/Applicative.hs rename to Language/Symantic/Lib/Applicative.hs index 2c16430..2825abf 100644 --- a/Language/Symantic/Compiling/Applicative.hs +++ b/Language/Symantic/Lib/Applicative.hs @@ -1,7 +1,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Symantic for 'Applicative'. -module Language.Symantic.Compiling.Applicative where +module Language.Symantic.Lib.Applicative where import Control.Applicative (Applicative) import qualified Control.Applicative as Applicative @@ -15,8 +15,8 @@ import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.Lambda -import Language.Symantic.Compiling.Functor (Sym_Functor(..), (<$>)) +import Language.Symantic.Lib.Lambda +import Language.Symantic.Lib.Functor (Sym_Functor(..), (<$>)) import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans diff --git a/Language/Symantic/Lib/Data/HLint.hs b/Language/Symantic/Lib/Applicative/HLint.hs similarity index 100% rename from Language/Symantic/Lib/Data/HLint.hs rename to Language/Symantic/Lib/Applicative/HLint.hs diff --git a/Language/Symantic/Compiling/Applicative/Test.hs b/Language/Symantic/Lib/Applicative/Test.hs similarity index 94% rename from Language/Symantic/Compiling/Applicative/Test.hs rename to Language/Symantic/Lib/Applicative/Test.hs index f1e8b3a..cc9cbc6 100644 --- a/Language/Symantic/Compiling/Applicative/Test.hs +++ b/Language/Symantic/Lib/Applicative/Test.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module Compiling.Applicative.Test where +module Lib.Applicative.Test where import Test.Tasty @@ -8,7 +8,7 @@ import Prelude hiding ((&&), not, (||)) import Language.Symantic.Typing import Compiling.Term.Test -import Compiling.Bool.Test () +import Lib.Bool.Test () type Ifaces = [ Proxy (->) diff --git a/Language/Symantic/Compiling/Bool.hs b/Language/Symantic/Lib/Bool.hs similarity index 97% rename from Language/Symantic/Compiling/Bool.hs rename to Language/Symantic/Lib/Bool.hs index 96f0aa2..bee8db6 100644 --- a/Language/Symantic/Compiling/Bool.hs +++ b/Language/Symantic/Lib/Bool.hs @@ -1,7 +1,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Symantic for 'Bool'. -module Language.Symantic.Compiling.Bool where +module Language.Symantic.Lib.Bool where import Control.Monad import qualified Data.Bool as Bool @@ -13,10 +13,10 @@ import Prelude hiding ((&&), not, (||)) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.Lambda +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans +import Language.Symantic.Lib.Lambda -- * Class 'Sym_Bool' class Sym_Bool term where diff --git a/Language/Symantic/Lib/Data/Type/HLint.hs b/Language/Symantic/Lib/Bool/HLint.hs similarity index 100% rename from Language/Symantic/Lib/Data/Type/HLint.hs rename to Language/Symantic/Lib/Bool/HLint.hs diff --git a/Language/Symantic/Compiling/Bool/Test.hs b/Language/Symantic/Lib/Bool/Test.hs similarity index 96% rename from Language/Symantic/Compiling/Bool/Test.hs rename to Language/Symantic/Lib/Bool/Test.hs index bf36b81..ddd0d78 100644 --- a/Language/Symantic/Compiling/Bool/Test.hs +++ b/Language/Symantic/Lib/Bool/Test.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module Compiling.Bool.Test where +module Lib.Bool.Test where import Test.Tasty @@ -10,6 +10,8 @@ import Language.Symantic.Parsing import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting +import Language.Symantic.Lib.Bool +import Language.Symantic.Lib.Lambda ((~>)) import Compiling.Term.Test type Ifaces = diff --git a/Language/Symantic/Compiling/Char.hs b/Language/Symantic/Lib/Char.hs similarity index 97% rename from Language/Symantic/Compiling/Char.hs rename to Language/Symantic/Lib/Char.hs index b8ff184..f0fdda6 100644 --- a/Language/Symantic/Compiling/Char.hs +++ b/Language/Symantic/Lib/Char.hs @@ -1,7 +1,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Symantic for 'Char'. -module Language.Symantic.Compiling.Char where +module Language.Symantic.Lib.Char where import Control.Monad (liftM) import qualified Data.Char as Char @@ -13,10 +13,10 @@ import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar hiding (char) import qualified Language.Symantic.Parsing.Grammar as Gram import Language.Symantic.Typing -import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.Lambda +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans +import Language.Symantic.Lib.Lambda -- * Class 'Sym_Char' class Sym_Char term where diff --git a/Language/Symantic/Compiling/Either.hs b/Language/Symantic/Lib/Either.hs similarity index 97% rename from Language/Symantic/Compiling/Either.hs rename to Language/Symantic/Lib/Either.hs index 0e87cfe..c791477 100644 --- a/Language/Symantic/Compiling/Either.hs +++ b/Language/Symantic/Lib/Either.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=8 #-} -- | Symantic for 'Either'. -module Language.Symantic.Compiling.Either where +module Language.Symantic.Lib.Either where import Control.Monad (liftM, liftM3) import qualified Data.Either as Either @@ -13,10 +13,10 @@ import Prelude hiding (either) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.Lambda +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans +import Language.Symantic.Lib.Lambda -- * Class 'Sym_Tuple' class Sym_Either term where diff --git a/Language/Symantic/Compiling/Eq.hs b/Language/Symantic/Lib/Eq.hs similarity index 95% rename from Language/Symantic/Compiling/Eq.hs rename to Language/Symantic/Lib/Eq.hs index db09b50..5c6e3ad 100644 --- a/Language/Symantic/Compiling/Eq.hs +++ b/Language/Symantic/Lib/Eq.hs @@ -1,7 +1,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Symantic for 'Eq'. -module Language.Symantic.Compiling.Eq where +module Language.Symantic.Lib.Eq where import Control.Monad import qualified Data.Eq as Eq @@ -11,10 +11,10 @@ import Prelude hiding ((==), (/=)) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.Lambda +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans +import Language.Symantic.Lib.Lambda -- * Class 'Sym_Eq' class Sym_Eq term where diff --git a/Language/Symantic/Compiling/Foldable.hs b/Language/Symantic/Lib/Foldable.hs similarity index 99% rename from Language/Symantic/Compiling/Foldable.hs rename to Language/Symantic/Lib/Foldable.hs index a971d68..00049c7 100644 --- a/Language/Symantic/Compiling/Foldable.hs +++ b/Language/Symantic/Lib/Foldable.hs @@ -2,7 +2,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Symantic for 'Foldable'. -module Language.Symantic.Compiling.Foldable where +module Language.Symantic.Lib.Foldable where import Data.Foldable (Foldable) import qualified Data.Foldable as Foldable @@ -16,7 +16,7 @@ import Prelude hiding (Foldable(..) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar hiding (any) import Language.Symantic.Typing -import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans diff --git a/Language/Symantic/Lib/Foldable/HLint.hs b/Language/Symantic/Lib/Foldable/HLint.hs new file mode 120000 index 0000000..ab18269 --- /dev/null +++ b/Language/Symantic/Lib/Foldable/HLint.hs @@ -0,0 +1 @@ +../HLint.hs \ No newline at end of file diff --git a/Language/Symantic/Compiling/Foldable/Test.hs b/Language/Symantic/Lib/Foldable/Test.hs similarity index 91% rename from Language/Symantic/Compiling/Foldable/Test.hs rename to Language/Symantic/Lib/Foldable/Test.hs index a07b948..7c23c00 100644 --- a/Language/Symantic/Compiling/Foldable/Test.hs +++ b/Language/Symantic/Lib/Foldable/Test.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module Compiling.Foldable.Test where +module Lib.Foldable.Test where import Test.Tasty @@ -8,7 +8,6 @@ import Prelude hiding ((&&), not, (||)) import Language.Symantic.Typing import Compiling.Term.Test -import Compiling.Bool.Test () type Ifaces = [ Proxy (->) diff --git a/Language/Symantic/Compiling/Functor.hs b/Language/Symantic/Lib/Functor.hs similarity index 96% rename from Language/Symantic/Compiling/Functor.hs rename to Language/Symantic/Lib/Functor.hs index 174f259..2e3d709 100644 --- a/Language/Symantic/Compiling/Functor.hs +++ b/Language/Symantic/Lib/Functor.hs @@ -1,7 +1,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Symantic for 'Functor'. -module Language.Symantic.Compiling.Functor where +module Language.Symantic.Lib.Functor where import Control.Monad (liftM2) import qualified Data.Function as Fun @@ -14,10 +14,10 @@ import Prelude hiding (Functor(..)) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.Lambda +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans +import Language.Symantic.Lib.Lambda -- * Class 'Sym_Functor' class Sym_Lambda term => Sym_Functor term where diff --git a/Language/Symantic/Lib/Functor/HLint.hs b/Language/Symantic/Lib/Functor/HLint.hs new file mode 120000 index 0000000..ab18269 --- /dev/null +++ b/Language/Symantic/Lib/Functor/HLint.hs @@ -0,0 +1 @@ +../HLint.hs \ No newline at end of file diff --git a/Language/Symantic/Compiling/Functor/Test.hs b/Language/Symantic/Lib/Functor/Test.hs similarity index 92% rename from Language/Symantic/Compiling/Functor/Test.hs rename to Language/Symantic/Lib/Functor/Test.hs index e9504fe..5116934 100644 --- a/Language/Symantic/Compiling/Functor/Test.hs +++ b/Language/Symantic/Lib/Functor/Test.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module Compiling.Functor.Test where +module Lib.Functor.Test where import Test.Tasty @@ -8,7 +8,6 @@ import Prelude hiding ((&&), not, (||)) import Language.Symantic.Typing import Compiling.Term.Test -import Compiling.Bool.Test () type Ifaces = [ Proxy (->) diff --git a/Language/Symantic/Compiling/IO.hs b/Language/Symantic/Lib/IO.hs similarity index 97% rename from Language/Symantic/Compiling/IO.hs rename to Language/Symantic/Lib/IO.hs index 24f624c..aa9d689 100644 --- a/Language/Symantic/Compiling/IO.hs +++ b/Language/Symantic/Lib/IO.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=5 #-} -- | Symantic for 'IO'. -module Language.Symantic.Compiling.IO where +module Language.Symantic.Lib.IO where import Control.Monad (liftM, liftM2) import Data.Proxy @@ -12,10 +12,10 @@ import qualified System.IO as IO import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.Lambda +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans +import Language.Symantic.Lib.Lambda -- * Class 'Sym_IO' class Sym_IO term where diff --git a/Language/Symantic/Compiling/If.hs b/Language/Symantic/Lib/If.hs similarity index 95% rename from Language/Symantic/Compiling/If.hs rename to Language/Symantic/Lib/If.hs index 4578d4a..fe14dbe 100644 --- a/Language/Symantic/Compiling/If.hs +++ b/Language/Symantic/Lib/If.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=5 #-} -- | Symantic for @if@. -module Language.Symantic.Compiling.If where +module Language.Symantic.Lib.If where import Data.Proxy import qualified Data.Text as Text @@ -11,10 +11,10 @@ import Data.Type.Equality ((:~:)(Refl)) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.Lambda +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans +import Language.Symantic.Lib.Lambda -- * Class 'Sym_If' class Sym_If term where diff --git a/Language/Symantic/Compiling/Int.hs b/Language/Symantic/Lib/Int.hs similarity index 96% rename from Language/Symantic/Compiling/Int.hs rename to Language/Symantic/Lib/Int.hs index 4b2b6bb..315930a 100644 --- a/Language/Symantic/Compiling/Int.hs +++ b/Language/Symantic/Lib/Int.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=7 #-} -- | Symantic for 'Int'. -module Language.Symantic.Compiling.Int where +module Language.Symantic.Lib.Int where import Data.Proxy import qualified Data.Text as Text @@ -10,7 +10,7 @@ import Data.Type.Equality ((:~:)(Refl)) import Language.Symantic.Parsing import Language.Symantic.Typing -import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans diff --git a/Language/Symantic/Compiling/Integer.hs b/Language/Symantic/Lib/Integer.hs similarity index 97% rename from Language/Symantic/Compiling/Integer.hs rename to Language/Symantic/Lib/Integer.hs index 2d2d136..5093e0f 100644 --- a/Language/Symantic/Compiling/Integer.hs +++ b/Language/Symantic/Lib/Integer.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=6 #-} -- | Symantic for 'Integer'. -module Language.Symantic.Compiling.Integer where +module Language.Symantic.Lib.Integer where import Control.Applicative (Alternative(..)) import Data.Proxy @@ -12,7 +12,7 @@ import Data.Type.Equality ((:~:)(Refl)) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans diff --git a/Language/Symantic/Compiling/Integral.hs b/Language/Symantic/Lib/Integral.hs similarity index 98% rename from Language/Symantic/Compiling/Integral.hs rename to Language/Symantic/Lib/Integral.hs index 5ae5b56..36d51c8 100644 --- a/Language/Symantic/Compiling/Integral.hs +++ b/Language/Symantic/Lib/Integral.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=6 #-} -- | Symantic for 'Integral'. -module Language.Symantic.Compiling.Integral where +module Language.Symantic.Lib.Integral where import Control.Monad (liftM, liftM2) import qualified Data.Function as Fun @@ -15,10 +15,10 @@ import Prelude hiding (Integral(..)) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.Lambda +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans +import Language.Symantic.Lib.Lambda -- * Class 'Sym_Integral' class Sym_Integral term where diff --git a/Language/Symantic/Compiling/Lambda.hs b/Language/Symantic/Lib/Lambda.hs similarity index 98% rename from Language/Symantic/Compiling/Lambda.hs rename to Language/Symantic/Lib/Lambda.hs index 544892c..3611ac9 100644 --- a/Language/Symantic/Compiling/Lambda.hs +++ b/Language/Symantic/Lib/Lambda.hs @@ -3,7 +3,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Language.Symantic.Compiling.Lambda where +module Language.Symantic.Lib.Lambda where import qualified Data.Function as Fun import qualified Data.Kind as Kind @@ -16,10 +16,10 @@ import Prelude hiding ((^)) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans -import Language.Symantic.Compiling.Term -- * Class 'Sym_Lambda' class Sym_Lambda term where diff --git a/Language/Symantic/Compiling/List.hs b/Language/Symantic/Lib/List.hs similarity index 98% rename from Language/Symantic/Compiling/List.hs rename to Language/Symantic/Lib/List.hs index ab28bd0..65b5378 100644 --- a/Language/Symantic/Compiling/List.hs +++ b/Language/Symantic/Lib/List.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=9 #-} -- | Symantic for '[]'. -module Language.Symantic.Compiling.List where +module Language.Symantic.Lib.List where import Control.Monad (liftM, liftM2, liftM3) import qualified Data.Foldable as Foldable @@ -19,10 +19,10 @@ import Prelude hiding (zipWith) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.Lambda +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans +import Language.Symantic.Lib.Lambda -- * Class 'Sym_List' class Sym_List term where diff --git a/Language/Symantic/Compiling/Map.hs b/Language/Symantic/Lib/Map.hs similarity index 98% rename from Language/Symantic/Compiling/Map.hs rename to Language/Symantic/Lib/Map.hs index d35a7a9..3214d36 100644 --- a/Language/Symantic/Compiling/Map.hs +++ b/Language/Symantic/Lib/Map.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=12 #-} -- | Symantic for 'Map'. -module Language.Symantic.Compiling.Map where +module Language.Symantic.Lib.Map where import Control.Monad (liftM, liftM2, liftM3) import Data.Map.Strict (Map) @@ -14,10 +14,10 @@ import Prelude hiding (either) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.Lambda +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans +import Language.Symantic.Lib.Lambda -- * Class 'Sym_Map' class Sym_Map term where diff --git a/Language/Symantic/Compiling/Map/Test.hs b/Language/Symantic/Lib/Map/Test.hs similarity index 95% rename from Language/Symantic/Compiling/Map/Test.hs rename to Language/Symantic/Lib/Map/Test.hs index d2ce8d2..bb81b23 100644 --- a/Language/Symantic/Compiling/Map/Test.hs +++ b/Language/Symantic/Lib/Map/Test.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module Compiling.Map.Test where +module Lib.Map.Test where import Test.Tasty @@ -10,7 +10,6 @@ import Prelude hiding (zipWith) import Language.Symantic.Typing import Compiling.Term.Test -import Compiling.Bool.Test () type Ifaces = [ Proxy (->) diff --git a/Language/Symantic/Compiling/Maybe.hs b/Language/Symantic/Lib/Maybe.hs similarity index 97% rename from Language/Symantic/Compiling/Maybe.hs rename to Language/Symantic/Lib/Maybe.hs index 72b5965..2a77434 100644 --- a/Language/Symantic/Compiling/Maybe.hs +++ b/Language/Symantic/Lib/Maybe.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=7 #-} -- | Symantic for 'Maybe'. -module Language.Symantic.Compiling.Maybe where +module Language.Symantic.Lib.Maybe where import Control.Monad import qualified Data.Function as Fun @@ -14,10 +14,10 @@ import Prelude hiding (maybe) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.Lambda +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans +import Language.Symantic.Lib.Lambda -- * Class 'Sym_Maybe_Lam' class Sym_Maybe term where diff --git a/Language/Symantic/Compiling/Monad.hs b/Language/Symantic/Lib/Monad.hs similarity index 97% rename from Language/Symantic/Compiling/Monad.hs rename to Language/Symantic/Lib/Monad.hs index 88b90c9..f21618e 100644 --- a/Language/Symantic/Compiling/Monad.hs +++ b/Language/Symantic/Lib/Monad.hs @@ -1,7 +1,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Symantic for 'Monad'. -module Language.Symantic.Compiling.Monad where +module Language.Symantic.Lib.Monad where import Control.Monad (Monad) import qualified Control.Monad as Monad @@ -12,10 +12,10 @@ import Prelude hiding (Monad(..)) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.Applicative (Sym_Applicative) +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans +import Language.Symantic.Lib.Applicative (Sym_Applicative) -- * Class 'Sym_Monad' class Sym_Applicative term => Sym_Monad term where diff --git a/Language/Symantic/Compiling/MonoFoldable.hs b/Language/Symantic/Lib/MonoFoldable.hs similarity index 98% rename from Language/Symantic/Compiling/MonoFoldable.hs rename to Language/Symantic/Lib/MonoFoldable.hs index e38f656..a95f891 100644 --- a/Language/Symantic/Compiling/MonoFoldable.hs +++ b/Language/Symantic/Lib/MonoFoldable.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=9 #-} -- | Symantic for 'MonoFoldable'. -module Language.Symantic.Compiling.MonoFoldable where +module Language.Symantic.Lib.MonoFoldable where import Control.Monad (liftM, liftM2, liftM3) import Data.MonoTraversable (MonoFoldable) @@ -14,10 +14,10 @@ import Data.Type.Equality ((:~:)(Refl)) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.MonoFunctor +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans +import Language.Symantic.Lib.MonoFunctor -- * Class 'Sym_MonoFoldable' class Sym_MonoFunctor term => Sym_MonoFoldable term where diff --git a/Language/Symantic/Compiling/MonoFunctor.hs b/Language/Symantic/Lib/MonoFunctor.hs similarity index 98% rename from Language/Symantic/Compiling/MonoFunctor.hs rename to Language/Symantic/Lib/MonoFunctor.hs index 6d8f033..4479abd 100644 --- a/Language/Symantic/Compiling/MonoFunctor.hs +++ b/Language/Symantic/Lib/MonoFunctor.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=8 #-} -- | Symantic for 'MonoFunctor'. -module Language.Symantic.Compiling.MonoFunctor where +module Language.Symantic.Lib.MonoFunctor where import Control.Monad (liftM2) import Data.Map.Strict (Map) @@ -14,13 +14,13 @@ import Data.Type.Equality ((:~:)(Refl)) import GHC.Exts (Constraint) import qualified System.IO as IO +import Language.Symantic.Helper.Data.Type.List hiding (Map) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans -import Language.Symantic.Lib.Data.Type.List hiding (Map) -- * Class 'Sym_MonoFunctor' class Sym_MonoFunctor term where diff --git a/Language/Symantic/Lib/MonoFunctor/HLint.hs b/Language/Symantic/Lib/MonoFunctor/HLint.hs new file mode 120000 index 0000000..ab18269 --- /dev/null +++ b/Language/Symantic/Lib/MonoFunctor/HLint.hs @@ -0,0 +1 @@ +../HLint.hs \ No newline at end of file diff --git a/Language/Symantic/Compiling/MonoFunctor/Test.hs b/Language/Symantic/Lib/MonoFunctor/Test.hs similarity index 87% rename from Language/Symantic/Compiling/MonoFunctor/Test.hs rename to Language/Symantic/Lib/MonoFunctor/Test.hs index 21c58f2..ff966fe 100644 --- a/Language/Symantic/Compiling/MonoFunctor/Test.hs +++ b/Language/Symantic/Lib/MonoFunctor/Test.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module Compiling.MonoFunctor.Test where +module Lib.MonoFunctor.Test where import Test.Tasty @@ -8,9 +8,7 @@ import Data.Proxy (Proxy(..)) import Prelude hiding (zipWith) import Language.Symantic.Typing -import Language.Symantic.Compiling () import Compiling.Term.Test -import Compiling.Bool.Test () type Ifaces = [ Proxy (->) diff --git a/Language/Symantic/Compiling/Monoid.hs b/Language/Symantic/Lib/Monoid.hs similarity index 96% rename from Language/Symantic/Compiling/Monoid.hs rename to Language/Symantic/Lib/Monoid.hs index b016816..a24c7d2 100644 --- a/Language/Symantic/Compiling/Monoid.hs +++ b/Language/Symantic/Lib/Monoid.hs @@ -1,7 +1,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Symantic for 'Monoid'. -module Language.Symantic.Compiling.Monoid where +module Language.Symantic.Lib.Monoid where import Control.Monad import qualified Data.Function as Fun @@ -14,10 +14,10 @@ import Prelude hiding (Monoid(..)) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.Lambda +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans +import Language.Symantic.Lib.Lambda -- * Class 'Sym_Monoid' class Sym_Monoid term where diff --git a/Language/Symantic/Compiling/NonNull.hs b/Language/Symantic/Lib/NonNull.hs similarity index 98% rename from Language/Symantic/Compiling/NonNull.hs rename to Language/Symantic/Lib/NonNull.hs index 568eb5a..47f4b94 100644 --- a/Language/Symantic/Compiling/NonNull.hs +++ b/Language/Symantic/Lib/NonNull.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=9 #-} -- | Symantic for 'NonNull'. -module Language.Symantic.Compiling.NonNull where +module Language.Symantic.Lib.NonNull where import Control.Monad (liftM, liftM2) import Data.MonoTraversable (MonoFoldable) @@ -17,10 +17,10 @@ import Prelude hiding (head, init, last, tail) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.MonoFunctor +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans +import Language.Symantic.Lib.MonoFunctor -- * Class 'Sym_NonNull' class Sym_NonNull term where diff --git a/Language/Symantic/Compiling/Num.hs b/Language/Symantic/Lib/Num.hs similarity index 98% rename from Language/Symantic/Compiling/Num.hs rename to Language/Symantic/Lib/Num.hs index 414b113..2a03fb6 100644 --- a/Language/Symantic/Compiling/Num.hs +++ b/Language/Symantic/Lib/Num.hs @@ -1,7 +1,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Symantic for 'Num'. -module Language.Symantic.Compiling.Num where +module Language.Symantic.Lib.Num where import Control.Monad (liftM, liftM2) import qualified Data.Function as Fun @@ -14,10 +14,10 @@ import Prelude (Num) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.Lambda +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans +import Language.Symantic.Lib.Lambda -- * Class 'Sym_Num' class Sym_Num term where diff --git a/Language/Symantic/Lib/Num/HLint.hs b/Language/Symantic/Lib/Num/HLint.hs new file mode 120000 index 0000000..ab18269 --- /dev/null +++ b/Language/Symantic/Lib/Num/HLint.hs @@ -0,0 +1 @@ +../HLint.hs \ No newline at end of file diff --git a/Language/Symantic/Compiling/Num/Test.hs b/Language/Symantic/Lib/Num/Test.hs similarity index 98% rename from Language/Symantic/Compiling/Num/Test.hs rename to Language/Symantic/Lib/Num/Test.hs index f39f381..63cd85e 100644 --- a/Language/Symantic/Compiling/Num/Test.hs +++ b/Language/Symantic/Lib/Num/Test.hs @@ -2,22 +2,22 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE StandaloneDeriving #-} -module Compiling.Num.Test where +module Lib.Num.Test where import Test.Tasty -import Compiling.Bool.Test () -import Compiling.Term.Test import qualified Data.Monoid as Monoid import Data.Proxy (Proxy(..)) import Prelude (Num) import Prelude hiding (Num(..)) -import Language.Symantic.Compiling -import Language.Symantic.Interpreting import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing +import Language.Symantic.Compiling +import Language.Symantic.Interpreting +import Language.Symantic.Lib.Num +import Compiling.Term.Test -- * Tests type Ifaces = diff --git a/Language/Symantic/Compiling/Ord.hs b/Language/Symantic/Lib/Ord.hs similarity index 97% rename from Language/Symantic/Compiling/Ord.hs rename to Language/Symantic/Lib/Ord.hs index 1e3aeba..4837b1b 100644 --- a/Language/Symantic/Compiling/Ord.hs +++ b/Language/Symantic/Lib/Ord.hs @@ -1,7 +1,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Symantic for 'Ord'. -module Language.Symantic.Compiling.Ord where +module Language.Symantic.Lib.Ord where import Control.Monad import Data.Ord (Ord) @@ -14,11 +14,11 @@ import Prelude hiding (Ord(..)) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.Lambda -import Language.Symantic.Compiling.Eq (Sym_Eq) +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans +import Language.Symantic.Lib.Lambda +import Language.Symantic.Lib.Eq (Sym_Eq) -- * Class 'Sym_Ord' class Sym_Eq term => Sym_Ord term where diff --git a/Language/Symantic/Compiling/Sequences.hs b/Language/Symantic/Lib/Sequences.hs similarity index 98% rename from Language/Symantic/Compiling/Sequences.hs rename to Language/Symantic/Lib/Sequences.hs index dadd1f6..6152474 100644 --- a/Language/Symantic/Compiling/Sequences.hs +++ b/Language/Symantic/Lib/Sequences.hs @@ -1,7 +1,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Symantic for 'Sequences'. -module Language.Symantic.Compiling.Sequences where +module Language.Symantic.Lib.Sequences where import Control.Monad (liftM, liftM2) import qualified Data.MonoTraversable as MT @@ -15,10 +15,10 @@ import Prelude hiding (filter, reverse) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.MonoFunctor (Fam_MonoElement(..)) +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans +import Language.Symantic.Lib.MonoFunctor (Fam_MonoElement(..)) -- * Class 'Sym_SemiSequence' class Sym_SemiSequence term where diff --git a/Language/Symantic/Compiling/Show.hs b/Language/Symantic/Lib/Show.hs similarity index 96% rename from Language/Symantic/Compiling/Show.hs rename to Language/Symantic/Lib/Show.hs index c440e0c..270ad11 100644 --- a/Language/Symantic/Compiling/Show.hs +++ b/Language/Symantic/Lib/Show.hs @@ -1,7 +1,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Symantic for 'Show'. -module Language.Symantic.Compiling.Show where +module Language.Symantic.Lib.Show where import Control.Monad import Data.Proxy (Proxy(..)) @@ -13,10 +13,10 @@ import qualified Text.Show as Show import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.Lambda +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans +import Language.Symantic.Lib.Lambda -- * Class 'Sym_Show' class Sym_Show term where diff --git a/Language/Symantic/Compiling/Test.hs b/Language/Symantic/Lib/Test.hs similarity index 59% rename from Language/Symantic/Compiling/Test.hs rename to Language/Symantic/Lib/Test.hs index c6a3f3d..61eb078 100644 --- a/Language/Symantic/Compiling/Test.hs +++ b/Language/Symantic/Lib/Test.hs @@ -1,25 +1,25 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module Compiling.Test where +module Lib.Test where import Test.Tasty -import Language.Symantic.Compiling +import Language.Symantic.Lib -import qualified Compiling.Applicative.Test as Applicative -import qualified Compiling.Bool.Test as Bool -import qualified Compiling.Foldable.Test as Foldable -import qualified Compiling.Functor.Test as Functor -import qualified Compiling.Map.Test as Map -import qualified Compiling.MonoFunctor.Test as MonoFunctor -import qualified Compiling.Num.Test as Num -import qualified Compiling.Tuple2.Test as Tuple2 +import qualified Lib.Applicative.Test as Applicative +import qualified Lib.Bool.Test as Bool +import qualified Lib.Foldable.Test as Foldable +import qualified Lib.Functor.Test as Functor +import qualified Lib.Map.Test as Map +import qualified Lib.MonoFunctor.Test as MonoFunctor +import qualified Lib.Num.Test as Num +import qualified Lib.Tuple2.Test as Tuple2 import Prelude hiding ((&&), not, (||), (==), id) -- * Tests tests :: TestTree -tests = testGroup "Compiling" $ +tests = testGroup "Lib" $ [ Applicative.tests , Bool.tests , Foldable.tests diff --git a/Language/Symantic/Compiling/Text.hs b/Language/Symantic/Lib/Text.hs similarity index 96% rename from Language/Symantic/Compiling/Text.hs rename to Language/Symantic/Lib/Text.hs index b24ed00..b6599f4 100644 --- a/Language/Symantic/Compiling/Text.hs +++ b/Language/Symantic/Lib/Text.hs @@ -1,7 +1,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Symantic for 'Text'. -module Language.Symantic.Compiling.Text where +module Language.Symantic.Lib.Text where import Data.Proxy import Data.Text (Text) @@ -10,7 +10,7 @@ import Data.Type.Equality ((:~:)(Refl)) import Language.Symantic.Parsing import Language.Symantic.Typing -import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans diff --git a/Language/Symantic/Compiling/Traversable.hs b/Language/Symantic/Lib/Traversable.hs similarity index 95% rename from Language/Symantic/Compiling/Traversable.hs rename to Language/Symantic/Lib/Traversable.hs index d96c43e..f7fb75f 100644 --- a/Language/Symantic/Compiling/Traversable.hs +++ b/Language/Symantic/Lib/Traversable.hs @@ -1,7 +1,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Symantic for 'Traversable'. -module Language.Symantic.Compiling.Traversable where +module Language.Symantic.Lib.Traversable where import Control.Monad (liftM2) import Data.Proxy @@ -12,10 +12,10 @@ import Prelude hiding (traverse) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term -import Language.Symantic.Compiling.Applicative (Sym_Applicative) +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans +import Language.Symantic.Lib.Applicative (Sym_Applicative) -- * Class 'Sym_Traversable' class Sym_Applicative term => Sym_Traversable term where diff --git a/Language/Symantic/Compiling/Tuple2.hs b/Language/Symantic/Lib/Tuple2.hs similarity index 98% rename from Language/Symantic/Compiling/Tuple2.hs rename to Language/Symantic/Lib/Tuple2.hs index f3b9197..8960780 100644 --- a/Language/Symantic/Compiling/Tuple2.hs +++ b/Language/Symantic/Lib/Tuple2.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=11 #-} -- | Symantic for @(,)@. -module Language.Symantic.Compiling.Tuple2 where +module Language.Symantic.Lib.Tuple2 where import Control.Monad (liftM, liftM2) import Data.Monoid ((<>)) @@ -14,7 +14,7 @@ import Prelude hiding (fst, snd) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans diff --git a/Language/Symantic/Lib/Tuple2/HLint.hs b/Language/Symantic/Lib/Tuple2/HLint.hs new file mode 120000 index 0000000..ab18269 --- /dev/null +++ b/Language/Symantic/Lib/Tuple2/HLint.hs @@ -0,0 +1 @@ +../HLint.hs \ No newline at end of file diff --git a/Language/Symantic/Compiling/Tuple2/Test.hs b/Language/Symantic/Lib/Tuple2/Test.hs similarity index 91% rename from Language/Symantic/Compiling/Tuple2/Test.hs rename to Language/Symantic/Lib/Tuple2/Test.hs index 45a2ebd..c820bb2 100644 --- a/Language/Symantic/Compiling/Tuple2/Test.hs +++ b/Language/Symantic/Lib/Tuple2/Test.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module Compiling.Tuple2.Test where +module Lib.Tuple2.Test where import Test.Tasty @@ -8,7 +8,6 @@ import Prelude hiding ((&&), not, (||)) import Language.Symantic.Typing import Compiling.Term.Test -import Compiling.Bool.Test () type Ifaces = [ Proxy (->) diff --git a/Language/Symantic/Compiling/Unit.hs b/Language/Symantic/Lib/Unit.hs similarity index 97% rename from Language/Symantic/Compiling/Unit.hs rename to Language/Symantic/Lib/Unit.hs index a65ed0a..db8411a 100644 --- a/Language/Symantic/Compiling/Unit.hs +++ b/Language/Symantic/Lib/Unit.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=5 #-} -- | Symantic for '()'. -module Language.Symantic.Compiling.Unit where +module Language.Symantic.Lib.Unit where import qualified Data.Function as Fun import Data.Monoid @@ -13,7 +13,7 @@ import Prelude hiding ((&&), not, (||)) import Language.Symantic.Parsing import Language.Symantic.Parsing.Grammar as Gram import Language.Symantic.Typing -import Language.Symantic.Compiling.Term +import Language.Symantic.Compiling import Language.Symantic.Interpreting import Language.Symantic.Transforming.Trans diff --git a/Language/Symantic/Parsing/Token.hs b/Language/Symantic/Parsing/Token.hs index a19ad37..1d31e80 100644 --- a/Language/Symantic/Parsing/Token.hs +++ b/Language/Symantic/Parsing/Token.hs @@ -7,8 +7,8 @@ module Language.Symantic.Parsing.Token where import Data.Proxy (Proxy(..)) import Data.String (String) import Data.Type.Equality -import Language.Symantic.Lib.Data.Type.List -import Language.Symantic.Lib.Data.Type.Peano +import Language.Symantic.Helper.Data.Type.List +import Language.Symantic.Helper.Data.Type.Peano -- * Type 'Token' type Token meta ts = TokenR meta ts ts diff --git a/Language/Symantic/Test.hs b/Language/Symantic/Test.hs index a17b294..36cc5dd 100644 --- a/Language/Symantic/Test.hs +++ b/Language/Symantic/Test.hs @@ -3,14 +3,14 @@ module Test where import Test.Tasty import qualified Typing.Test as Typing -import qualified Compiling.Test as Compiling import qualified Parsing.Test as Parsing +import qualified Lib.Test as Lib main :: IO () main = defaultMain $ testGroup "Language.Symantic" [ Typing.tests - , Compiling.tests , Parsing.tests + , Lib.tests ] diff --git a/Language/Symantic/Typing/Constant.hs b/Language/Symantic/Typing/Constant.hs index eb08362..2cd31e8 100644 --- a/Language/Symantic/Typing/Constant.hs +++ b/Language/Symantic/Typing/Constant.hs @@ -13,8 +13,8 @@ import Data.Text (Text) import Data.Type.Equality import qualified System.IO as IO -import Language.Symantic.Lib.Data.Type.List -import Language.Symantic.Lib.Data.Type.Peano +import Language.Symantic.Helper.Data.Type.List +import Language.Symantic.Helper.Data.Type.Peano import Language.Symantic.Typing.Kind -- * Type 'Const' diff --git a/Language/Symantic/Typing/Test.hs b/Language/Symantic/Typing/Test.hs index c0f361f..12aa88c 100644 --- a/Language/Symantic/Typing/Test.hs +++ b/Language/Symantic/Typing/Test.hs @@ -13,10 +13,11 @@ import GHC.Exts (Constraint) import Prelude hiding (exp) import qualified Text.Megaparsec as P -import Language.Symantic.Lib.Data.Type.List import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing -import Language.Symantic.Compiling ((~>)) +import Language.Symantic.Lib () +import Language.Symantic.Lib.Lambda ((~>)) +import Language.Symantic.Helper.Data.Type.List import Parsing.Grammar.Test diff --git a/symantic.cabal b/symantic.cabal index 64a000b..2348a08 100644 --- a/symantic.cabal +++ b/symantic.cabal @@ -36,7 +36,8 @@ description: . Reading the boring @Test.hs@ files should give you enough examples to understand how to use this library, - and reading some of the repetitively boring and painfully repetitive @Compiling/*.hs@ files + and reading some of the repetitively boring + and painfully repetitive @Lib/*.hs@ files should give you some templates and the general pattern to let you extend this library with your own symantics. . @@ -160,7 +161,7 @@ description: or type arguments (for instance @return :: Monad m => a -> m a@ needs a type argument to check @Monad m@). * Study to which point error messages can be improved. - * A lot of common terms should be added in @Compiling.*@ modules. + * A lot of common terms should be added in @Lib.*@ modules. Maybe as separate packages to limit dependencies. * No transformation is implemented so far, maybe there should be some, at least as examples @@ -179,7 +180,7 @@ tested-with: GHC==8.0.1 -- PVP: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 4.0.0.20170124 +version: 4.0.0.20170202 Source-Repository head location: git://git.autogeree.net/symantic @@ -211,48 +212,49 @@ Library exposed-modules: Language.Symantic Language.Symantic.Compiling - Language.Symantic.Compiling.Alternative - Language.Symantic.Compiling.Applicative - Language.Symantic.Compiling.Bool - Language.Symantic.Compiling.Char - Language.Symantic.Compiling.Either - Language.Symantic.Compiling.Eq - Language.Symantic.Compiling.Foldable - Language.Symantic.Compiling.Functor - Language.Symantic.Compiling.IO - Language.Symantic.Compiling.If - Language.Symantic.Compiling.Int - Language.Symantic.Compiling.Integer - Language.Symantic.Compiling.Integral - Language.Symantic.Compiling.Lambda - Language.Symantic.Compiling.List - Language.Symantic.Compiling.Map - Language.Symantic.Compiling.Maybe - Language.Symantic.Compiling.Monad - Language.Symantic.Compiling.MonoFoldable - Language.Symantic.Compiling.MonoFunctor - Language.Symantic.Compiling.Monoid - Language.Symantic.Compiling.NonNull - Language.Symantic.Compiling.Num - Language.Symantic.Compiling.Ord - Language.Symantic.Compiling.Sequences - Language.Symantic.Compiling.Show Language.Symantic.Compiling.Term Language.Symantic.Compiling.Term.Grammar - Language.Symantic.Compiling.Text - Language.Symantic.Compiling.Traversable - Language.Symantic.Compiling.Tuple2 - Language.Symantic.Compiling.Unit + Language.Symantic.Helper.Data.Type.List + Language.Symantic.Helper.Data.Type.Peano Language.Symantic.Interpreting Language.Symantic.Interpreting.Dup Language.Symantic.Interpreting.Host Language.Symantic.Interpreting.Text - Language.Symantic.Lib.Data.Type.List - Language.Symantic.Lib.Data.Type.Peano + Language.Symantic.Lib + Language.Symantic.Lib.Alternative + Language.Symantic.Lib.Applicative + Language.Symantic.Lib.Bool + Language.Symantic.Lib.Char + Language.Symantic.Lib.Either + Language.Symantic.Lib.Eq + Language.Symantic.Lib.Foldable + Language.Symantic.Lib.Functor + Language.Symantic.Lib.IO + Language.Symantic.Lib.If + Language.Symantic.Lib.Int + Language.Symantic.Lib.Integer + Language.Symantic.Lib.Integral + Language.Symantic.Lib.Lambda + Language.Symantic.Lib.List + Language.Symantic.Lib.Map + Language.Symantic.Lib.Maybe + Language.Symantic.Lib.Monad + Language.Symantic.Lib.MonoFoldable + Language.Symantic.Lib.MonoFunctor + Language.Symantic.Lib.Monoid + Language.Symantic.Lib.NonNull + Language.Symantic.Lib.Num + Language.Symantic.Lib.Ord + Language.Symantic.Lib.Sequences + Language.Symantic.Lib.Show + Language.Symantic.Lib.Text + Language.Symantic.Lib.Traversable + Language.Symantic.Lib.Tuple2 + Language.Symantic.Lib.Unit Language.Symantic.Parsing - Language.Symantic.Parsing.Token - Language.Symantic.Parsing.Grammar Language.Symantic.Parsing.EBNF + Language.Symantic.Parsing.Grammar + Language.Symantic.Parsing.Token Language.Symantic.Transforming Language.Symantic.Transforming.Trans Language.Symantic.Typing @@ -295,16 +297,16 @@ Test-Suite symantic-test hs-source-dirs: Language/Symantic main-is: Test.hs other-modules: - Compiling.Applicative.Test - Compiling.Bool.Test - Compiling.Foldable.Test - Compiling.Functor.Test - Compiling.Map.Test - Compiling.MonoFunctor.Test - Compiling.Num.Test Compiling.Term.Test - Compiling.Test - Compiling.Tuple2.Test + Lib.Applicative.Test + Lib.Bool.Test + Lib.Foldable.Test + Lib.Functor.Test + Lib.Map.Test + Lib.MonoFunctor.Test + Lib.Num.Test + Lib.Test + Lib.Tuple2.Test Parsing.Grammar.Test Parsing.Test Typing.Test -- 2.47.2 From 08d9573c81b71a457cb72dfb6ea95fa8ddac9897 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Fri, 3 Feb 2017 04:34:56 +0100 Subject: [PATCH 08/16] Fix Lib.Text. --- Language/Symantic/Lib/Text.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Language/Symantic/Lib/Text.hs b/Language/Symantic/Lib/Text.hs index b6599f4..041dff7 100644 --- a/Language/Symantic/Lib/Text.hs +++ b/Language/Symantic/Lib/Text.hs @@ -72,6 +72,6 @@ instance -- CompileI case tok of Token_Term_Text i -> k (ty @Text) $ TermO $ \_c -> text i instance -- TokenizeT - -- Inj_Token meta ts Show => - TokenizeT meta ts (Proxy Show) -instance Gram_Term_AtomsT meta ts (Proxy Show) g -- TODO + -- Inj_Token meta ts Text => + TokenizeT meta ts (Proxy Text) +instance Gram_Term_AtomsT meta ts (Proxy Text) g -- TODO -- 2.47.2 From 391d38c9a32aecd8452a46341d1f25d7bee6f010 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Fri, 3 Feb 2017 07:18:28 +0100 Subject: [PATCH 09/16] Remove Alternative uses in grammars. --- Language/Symantic/Compiling/Term/Grammar.hs | 11 ++---- Language/Symantic/Lib/Alternative.hs | 2 +- Language/Symantic/Lib/Integer.hs | 2 - Language/Symantic/Parsing/EBNF.hs | 21 +++++----- Language/Symantic/Parsing/Grammar.hs | 43 +++++++++------------ Language/Symantic/Parsing/Grammar/Test.hs | 13 ++++--- Language/Symantic/Typing/Type.hs | 3 +- 7 files changed, 43 insertions(+), 52 deletions(-) diff --git a/Language/Symantic/Compiling/Term/Grammar.hs b/Language/Symantic/Compiling/Term/Grammar.hs index 4ed4378..15b62f3 100644 --- a/Language/Symantic/Compiling/Term/Grammar.hs +++ b/Language/Symantic/Compiling/Term/Grammar.hs @@ -7,7 +7,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Symantic.Compiling.Term.Grammar where -import Control.Applicative (Alternative(..)) import Control.Arrow (left) import Control.Monad (foldM, void, (=<<)) import qualified Data.Char as Char @@ -224,8 +223,7 @@ data Mod a = Mod Mod_Path a -- * Class 'Gram_Term_Name' class - ( Alternative g - , Alt g + ( Alt g , Alter g , Alter g , App g @@ -319,8 +317,7 @@ instance Gram_Term_Name RuleDef -- * Class 'Gram_Term_Type' class - ( Alternative g - , Alt g + ( Alt g , Alter g , App g , Gram_CF g @@ -364,8 +361,7 @@ data Error_Term_Gram -- * Class 'Gram_Term' class - ( Alternative g - , Alt g + ( Alt g , Alter g , App g , Gram_CF g @@ -538,6 +534,7 @@ instance class Gram_Term_AtomsT meta ts t g where term_atomsT :: Proxy t -> [CF g (ProTok meta ts)] term_atomsT _t = [] +instance Gram_Term_AtomsT meta ts t RuleDef gram_term :: forall g. diff --git a/Language/Symantic/Lib/Alternative.hs b/Language/Symantic/Lib/Alternative.hs index 54517ec..a2d80f6 100644 --- a/Language/Symantic/Lib/Alternative.hs +++ b/Language/Symantic/Lib/Alternative.hs @@ -12,7 +12,7 @@ import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (Functor(..), (<$>), id, const) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar +import Language.Symantic.Parsing.Grammar hiding (Alter(..)) import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Lib.Lambda diff --git a/Language/Symantic/Lib/Integer.hs b/Language/Symantic/Lib/Integer.hs index 5093e0f..c5f5bc9 100644 --- a/Language/Symantic/Lib/Integer.hs +++ b/Language/Symantic/Lib/Integer.hs @@ -4,7 +4,6 @@ -- | Symantic for 'Integer'. module Language.Symantic.Lib.Integer where -import Control.Applicative (Alternative(..)) import Data.Proxy import qualified Data.Text as Text import Data.Type.Equality ((:~:)(Refl)) @@ -85,7 +84,6 @@ instance -- TokenizeT instance -- Gram_Term_AtomsT ( Alt g , Alter g - , Alternative g , Gram_Rule g , Gram_Lexer g , Gram_Meta meta g diff --git a/Language/Symantic/Parsing/EBNF.hs b/Language/Symantic/Parsing/EBNF.hs index ed49038..eb3c6ab 100644 --- a/Language/Symantic/Parsing/EBNF.hs +++ b/Language/Symantic/Parsing/EBNF.hs @@ -7,7 +7,7 @@ {-# OPTIONS_GHC -fno-warn-tabs #-} module Language.Symantic.Parsing.EBNF where -import Control.Applicative (Applicative(..), Alternative(..)) +import Control.Applicative (Applicative(..)) import Control.Monad import Data.Bool as Bool import Data.Char as Char @@ -50,8 +50,12 @@ data RuleMode -- ** Type 'RuleDef' newtype RuleDef a = RuleDef { unRuleDef :: EBNF a } - deriving (Functor, Gram_Terminal, Applicative, App - , Alternative, Alter, Alt, Gram_RegL, Gram_RegR, Gram_CF) + deriving (Functor, Gram_Terminal, Applicative, App) +deriving instance Alter RuleDef +deriving instance Alt RuleDef +deriving instance Gram_RegL RuleDef +deriving instance Gram_RegR RuleDef +deriving instance Gram_CF RuleDef deriving instance Gram_RuleDef RuleDef deriving instance Gram_RuleDef g => Gram_RuleDef (RegR g) deriving instance Gram_RuleDef g => Gram_RuleDef (RegL g) @@ -124,23 +128,20 @@ instance Applicative EBNF where f bo (op, L) <> ", " <> x bo (op, R) where op = infixB L 10 instance App EBNF -instance Alternative EBNF where +instance Alter EBNF where empty = ebnf_const $ "\"\"" - EBNF g <|> EBNF q = EBNF $ \bo po -> infix_paren po op $ + EBNF g <+> EBNF q = EBNF $ \bo po -> infix_paren po op $ g bo (op, L) <> " | " <> q bo (op, R) where op = infixB L 2 - many (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}" where op = infixN0 - some (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}-" where op = infixN0 -instance Alter EBNF where - nil = ebnf_const $ "\"\"" choice [] = empty choice [g] = g choice l@(_:_) = EBNF $ \bo po -> infix_paren po op $ Text.intercalate " | " $ (unEBNF <$> l) <*> pure bo <*> pure (op, L) where op = infixB L 2 - star (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}" where op = infixN0 instance Alt EBNF where + many (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}" where op = infixN0 + some (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}-" where op = infixN0 option _x (EBNF g) = EBNF $ \rm _po -> "[" <> g rm (op, L) <> "]" where op = infixN0 instance Gram_Terminal EBNF where diff --git a/Language/Symantic/Parsing/Grammar.hs b/Language/Symantic/Parsing/Grammar.hs index f17dc14..b3a518f 100644 --- a/Language/Symantic/Parsing/Grammar.hs +++ b/Language/Symantic/Parsing/Grammar.hs @@ -10,7 +10,7 @@ -- with: @cabal test ebnf --show-details=always@. module Language.Symantic.Parsing.Grammar where -import Control.Applicative (Applicative(..), Alternative(..)) +import Control.Applicative (Applicative(..)) import Control.Monad import qualified Data.Bool as Bool import qualified Data.Char as Char @@ -104,7 +104,8 @@ unicode_categories c = -- * Type 'Reg' -- | Left or right regular grammar. newtype Reg (lr::LR) g a = Reg { unReg :: g a } - deriving (IsString, Functor, Gram_Terminal, Alter) + deriving (IsString, Functor, Gram_Terminal) +deriving instance Alter g => Alter (Reg lr g) deriving instance Gram_Rule g => Gram_Rule (Reg lr g) deriving instance (Functor g, Alter g, Gram_RegL g) => Gram_RegL (RegL g) deriving instance (Functor g, Alter g, Gram_RegR g) => Gram_RegR (RegR g) @@ -123,34 +124,23 @@ type RegR = Reg 'R -- ** Class 'Alter' -- | Like 'Alternative' but without the 'Applicative' super-class, -- because a regular grammar is not closed under 'Applicative'. +-- And also because the alternative operator has to backtrack +-- when the first alternative fails. class Alter g where - nil :: g a + empty :: g a (<+>) :: g a -> g a -> g a choice :: [g a] -> g a - star :: g a -> g [a] - default nil :: Alternative g => g a - default (<+>) :: Alternative g => g a -> g a -> g a - default choice :: Alternative g => [g a] -> g a - default star :: Alternative g => g a -> g [a] - nil = empty - (<+>) = (<|>) choice = foldr (<+>) empty - -- star g = (:) <$> g *> star g <+> nil - - star a = many_a - where - many_a = some_a <+> pure [] - some_a = ((:) <$> a) <*> many_a +deriving instance Alter p => Alter (Terminal p) infixl 3 <+> -deriving instance Alter p => Alter (Terminal p) -- ** Class 'Gram_RegR' -- | Symantics for right regular grammars. class (Functor g, Alter g) => Gram_RegR g where (.*>) :: Terminal g (a -> b) -> RegR g a -> RegR g b manyR :: Terminal g a -> RegR g [a] - manyR g = (:) <$> g .*> manyR g <+> nil + manyR g = (:) <$> g .*> manyR g <+> empty someR :: Terminal g a -> RegR g [a] someR g = (:) <$> g .*> manyR g infixl 4 .*> @@ -161,15 +151,19 @@ class (Functor g, Alter g) => Gram_RegL g where (<*.) :: RegL g (a -> b) -> Terminal g a -> RegL g b manyL :: Terminal g a -> RegL g [a] manyL g' = reverse <$> go g' - where go g = flip (:) <$> go g <*. g <+> nil + where go g = flip (:) <$> go g <*. g <+> empty someL :: Terminal g a -> RegL g [a] someL g = (\cs c -> cs ++ [c]) <$> manyL g <*. g infixl 4 <*. -- * Class 'Alt' -class (Alternative g, Alter g) => Alt g where +class (Alter g, Applicative g) => Alt g where option :: a -> g a -> g a option x g = g <+> pure x + many :: g a -> g [a] + many a = some a <+> pure [] + some :: g a -> g [a] + some a = (:) <$> a <*> many a skipMany :: g a -> g () skipMany = void . many --manyTill :: g a -> g end -> g [a] @@ -183,7 +177,9 @@ class Applicative g => App g where -- * Type 'CF' -- | Context-free grammar. newtype CF g a = CF { unCF :: g a } - deriving (IsString, Functor, Gram_Terminal, Applicative, App, Alternative, Alter, Alt) + deriving (IsString, Functor, Gram_Terminal, Applicative, App) +deriving instance Alter g => Alter (CF g) +deriving instance Alt g => Alt (CF g) deriving instance Gram_Rule g => Gram_Rule (CF g) deriving instance Gram_RegL g => Gram_RegL (CF g) deriving instance Gram_RegR g => Gram_RegR (CF g) @@ -218,7 +214,6 @@ instance Gram_Meta meta g => Gram_Meta meta (CF g) where class ( Alt g , Alter g - , Alternative g , App g , Gram_CF g , Gram_Rule g @@ -269,9 +264,9 @@ class in \case Just (in_, b) -> insert_infix nod_a in_ b Nothing -> Right nod_a) - <$> star preG + <$> many preG <*> aG - <*> star postG + <*> many postG <*> option Nothing (curry Just <$> inG <*> go aG preG inG postG) insert_unifix :: (Unifix, a -> a) -> OpTree a -> OpTree a diff --git a/Language/Symantic/Parsing/Grammar/Test.hs b/Language/Symantic/Parsing/Grammar/Test.hs index e992e8d..f9859be 100644 --- a/Language/Symantic/Parsing/Grammar/Test.hs +++ b/Language/Symantic/Parsing/Grammar/Test.hs @@ -8,7 +8,8 @@ module Parsing.Grammar.Test where import Test.Tasty import Test.Tasty.HUnit -import Control.Applicative (Applicative(..), Alternative(..)) +import Control.Applicative (Applicative(..)) +import qualified Control.Applicative as Alt import Control.Monad import Data.Monoid ((<>)) -- import Control.Comonad @@ -40,7 +41,8 @@ instance ParsecC e s => Gram_Terminal (P.ParsecT e s m) where range (l, h) = P.satisfy $ \c -> l <= c && c <= h but (Terminal f) (Terminal p) = Terminal $ P.notFollowedBy (P.try p) *> f instance ParsecC e s => Alter (P.ParsecT e s m) where - x <+> y = P.try x <|> y + empty = Alt.empty + x <+> y = P.try x Alt.<|> y instance ParsecC e s => Gram_RegR (P.ParsecT e s m) where Terminal f .*> Reg x = Reg $ f <*> x instance ParsecC e s => Gram_RegL (P.ParsecT e s m) where @@ -100,14 +102,13 @@ tests = testGroup "Grammar" ; infix 1 ==> in [ (<>) <$> string "0" <*> string "1" ==> "\"0\", \"1\"" , (<>) <$> string "0" <* string "X" <*> string "1" ==> "\"0\", \"X\", \"1\"" - , (<>) <$> (string "0" <|> string "1") <*> string "2" ==> "(\"0\" | \"1\"), \"2\"" , (<>) <$> (string "0" <+> string "1") <*> string "2" ==> "(\"0\" | \"1\"), \"2\"" , (<>) <$> string "0" <*> (string "1" <+> string "2") ==> "\"0\", (\"1\" | \"2\")" - , string "0" <|> string "1" <|> string "2" ==> "\"0\" | \"1\" | \"2\"" + , string "0" <+> string "1" <+> string "2" ==> "\"0\" | \"1\" | \"2\"" , choice [string "0", string "1", string "2"] ==> "\"0\" | \"1\" | \"2\"" , (<>) <$> choice [ (<>) <$> string "0" <*> string "1" - , string "2" <|> string "3" + , string "2" <+> string "3" , string "4" ] <*> string "5" ==> "(\"0\", \"1\" | \"2\" | \"3\" | \"4\"), \"5\"" , concat <$> many (string "0") ==> "{\"0\"}" @@ -119,7 +120,7 @@ tests = testGroup "Grammar" string "0" `minus` g0 `minus` g1 ==> "\"0\" - \"0\", {\"1\"}- - {\"1\"}-, \"0\"" , (<>) - <$> many (string "0" <|> string "1") + <$> many (string "0" <+> string "1") <*> some (string "2") ==> "{\"0\" | \"1\"}, {\"2\"}-" ] ] diff --git a/Language/Symantic/Typing/Type.hs b/Language/Symantic/Typing/Type.hs index 918ea74..fcd0f93 100644 --- a/Language/Symantic/Typing/Type.hs +++ b/Language/Symantic/Typing/Type.hs @@ -7,7 +7,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Symantic.Typing.Type where -import Control.Applicative (Applicative(..), Alternative(..)) +import Control.Applicative (Applicative(..)) import qualified Data.Char as Char import Data.Monoid ((<>)) import Data.Proxy @@ -322,7 +322,6 @@ type TokType meta = EToken meta '[Proxy Token_Type] class ( Alt p , Alter p - , Alternative p , App p , Gram_CF p , Gram_Rule p -- 2.47.2 From a16e0f7fb4f2ce20699bd142c8a8ea436b14eb67 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Fri, 3 Feb 2017 07:25:40 +0100 Subject: [PATCH 10/16] Use more TypeApplications. --- Language/Symantic/Compiling/Term/Test.hs | 5 ++--- Language/Symantic/Lib/Applicative/Test.hs | 2 +- Language/Symantic/Lib/Bool/Test.hs | 2 +- Language/Symantic/Lib/Foldable/Test.hs | 2 +- Language/Symantic/Lib/Functor/Test.hs | 2 +- Language/Symantic/Lib/Map/Test.hs | 2 +- Language/Symantic/Lib/MonoFunctor/Test.hs | 2 +- Language/Symantic/Lib/Num/Test.hs | 2 +- Language/Symantic/Lib/Tuple2/Test.hs | 2 +- 9 files changed, 10 insertions(+), 11 deletions(-) diff --git a/Language/Symantic/Compiling/Term/Test.hs b/Language/Symantic/Compiling/Term/Test.hs index 8077e93..d1e789e 100644 --- a/Language/Symantic/Compiling/Term/Test.hs +++ b/Language/Symantic/Compiling/Term/Test.hs @@ -98,14 +98,13 @@ test_compile , Inj_Tokens Meta is [Proxy (->), Proxy Integer] , Gram_Term is Meta (P.ParsecT P.Dec String (SS.StateT (Tokenizers Meta is) Identity)) , Tokenize Meta is - ) => Proxy is - -> String + ) => String -> Either ( Type (Consts_of_Ifaces is) h , Either (P.ParseError Char P.Dec) (Error_Term Meta is) ) (Type (Consts_of_Ifaces is) h, h, Text) -> TestTree -test_compile _is inp expected = +test_compile inp expected = testCase (elide inp) $ case test_tokenizer inp of Left err -> Left (Left err) @?= Pre.snd `Arrow.left` expected diff --git a/Language/Symantic/Lib/Applicative/Test.hs b/Language/Symantic/Lib/Applicative/Test.hs index cc9cbc6..2c0f56e 100644 --- a/Language/Symantic/Lib/Applicative/Test.hs +++ b/Language/Symantic/Lib/Applicative/Test.hs @@ -18,7 +18,7 @@ type Ifaces = , Proxy Functor , Proxy Applicative ] -(==>) = test_compile (Proxy::Proxy Ifaces) +(==>) = test_compile @Ifaces tests :: TestTree tests = testGroup "Applicative" diff --git a/Language/Symantic/Lib/Bool/Test.hs b/Language/Symantic/Lib/Bool/Test.hs index ddd0d78..7e6b5f7 100644 --- a/Language/Symantic/Lib/Bool/Test.hs +++ b/Language/Symantic/Lib/Bool/Test.hs @@ -19,7 +19,7 @@ type Ifaces = , Proxy (->) , Proxy Integer ] -(==>) = test_compile (Proxy::Proxy Ifaces) +(==>) = test_compile @Ifaces tests :: TestTree tests = testGroup "Bool" $ diff --git a/Language/Symantic/Lib/Foldable/Test.hs b/Language/Symantic/Lib/Foldable/Test.hs index 7c23c00..ea2e363 100644 --- a/Language/Symantic/Lib/Foldable/Test.hs +++ b/Language/Symantic/Lib/Foldable/Test.hs @@ -18,7 +18,7 @@ type Ifaces = , Proxy (,) , Proxy Foldable ] -(==>) = test_compile (Proxy::Proxy Ifaces) +(==>) = test_compile @Ifaces tests :: TestTree tests = testGroup "Foldable" diff --git a/Language/Symantic/Lib/Functor/Test.hs b/Language/Symantic/Lib/Functor/Test.hs index 5116934..085c3b6 100644 --- a/Language/Symantic/Lib/Functor/Test.hs +++ b/Language/Symantic/Lib/Functor/Test.hs @@ -16,7 +16,7 @@ type Ifaces = , Proxy Integer , Proxy Maybe ] -(==>) = test_compile (Proxy::Proxy Ifaces) +(==>) = test_compile @Ifaces tests :: TestTree tests = testGroup "Functor" diff --git a/Language/Symantic/Lib/Map/Test.hs b/Language/Symantic/Lib/Map/Test.hs index bb81b23..8fb92c3 100644 --- a/Language/Symantic/Lib/Map/Test.hs +++ b/Language/Symantic/Lib/Map/Test.hs @@ -22,7 +22,7 @@ type Ifaces = , Proxy Num , Proxy Monoid ] -(==>) = test_compile (Proxy::Proxy Ifaces) +(==>) = test_compile @Ifaces tests :: TestTree tests = testGroup "Map" diff --git a/Language/Symantic/Lib/MonoFunctor/Test.hs b/Language/Symantic/Lib/MonoFunctor/Test.hs index ff966fe..0807c34 100644 --- a/Language/Symantic/Lib/MonoFunctor/Test.hs +++ b/Language/Symantic/Lib/MonoFunctor/Test.hs @@ -19,7 +19,7 @@ type Ifaces = , Proxy MT.MonoFunctor , Proxy Maybe ] -(==>) = test_compile (Proxy::Proxy Ifaces) +(==>) = test_compile @Ifaces tests :: TestTree tests = testGroup "MonoFunctor" diff --git a/Language/Symantic/Lib/Num/Test.hs b/Language/Symantic/Lib/Num/Test.hs index 63cd85e..324ddf1 100644 --- a/Language/Symantic/Lib/Num/Test.hs +++ b/Language/Symantic/Lib/Num/Test.hs @@ -31,7 +31,7 @@ type Ifaces = , Proxy Traversable , Proxy [] ] -(==>) = test_compile (Proxy::Proxy Ifaces) +(==>) = test_compile @Ifaces tests :: TestTree tests = testGroup "Num" diff --git a/Language/Symantic/Lib/Tuple2/Test.hs b/Language/Symantic/Lib/Tuple2/Test.hs index c820bb2..a9a677e 100644 --- a/Language/Symantic/Lib/Tuple2/Test.hs +++ b/Language/Symantic/Lib/Tuple2/Test.hs @@ -15,7 +15,7 @@ type Ifaces = , Proxy () , Proxy (,) ] -(==>) = test_compile (Proxy::Proxy Ifaces) +(==>) = test_compile @Ifaces tests :: TestTree tests = testGroup "Tuple2" -- 2.47.2 From ef2a5094a0b92a3541fb289140cbe8832ed40fe1 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Sat, 4 Feb 2017 06:29:48 +0100 Subject: [PATCH 11/16] Fix module including. --- Language/Symantic.hs | 2 ++ Language/Symantic/Compiling/Term/Grammar.hs | 2 -- Language/Symantic/Lib/Alternative.hs | 5 ++--- Language/Symantic/Lib/Applicative.hs | 3 +-- Language/Symantic/Lib/Bool.hs | 3 +-- Language/Symantic/Lib/Char.hs | 5 ++--- Language/Symantic/Lib/Either.hs | 3 +-- Language/Symantic/Lib/Eq.hs | 3 +-- Language/Symantic/Lib/Foldable.hs | 5 ++--- Language/Symantic/Lib/Functor.hs | 3 +-- Language/Symantic/Lib/IO.hs | 3 +-- Language/Symantic/Lib/If.hs | 3 +-- Language/Symantic/Lib/Int.hs | 2 +- Language/Symantic/Lib/Integer.hs | 3 +-- Language/Symantic/Lib/Integral.hs | 3 +-- Language/Symantic/Lib/Lambda.hs | 3 +-- Language/Symantic/Lib/List.hs | 3 +-- Language/Symantic/Lib/Map.hs | 3 +-- Language/Symantic/Lib/Maybe.hs | 3 +-- Language/Symantic/Lib/Monad.hs | 3 +-- Language/Symantic/Lib/MonoFoldable.hs | 3 +-- Language/Symantic/Lib/MonoFunctor.hs | 3 +-- Language/Symantic/Lib/Monoid.hs | 3 +-- Language/Symantic/Lib/NonNull.hs | 3 +-- Language/Symantic/Lib/Num.hs | 3 +-- Language/Symantic/Lib/Num/Test.hs | 1 - Language/Symantic/Lib/Ord.hs | 3 +-- Language/Symantic/Lib/Sequences.hs | 3 +-- Language/Symantic/Lib/Show.hs | 3 +-- Language/Symantic/Lib/Text.hs | 2 +- Language/Symantic/Lib/Traversable.hs | 3 +-- Language/Symantic/Lib/Tuple2.hs | 3 +-- Language/Symantic/Lib/Unit.hs | 3 +-- Language/Symantic/Parsing.hs | 4 ++++ Language/Symantic/Parsing/EBNF/Print.hs | 3 +-- Language/Symantic/Typing/Type.hs | 2 -- 36 files changed, 40 insertions(+), 68 deletions(-) diff --git a/Language/Symantic.hs b/Language/Symantic.hs index 1456546..39fd21c 100644 --- a/Language/Symantic.hs +++ b/Language/Symantic.hs @@ -3,9 +3,11 @@ module Language.Symantic , module Language.Symantic.Typing , module Language.Symantic.Compiling , module Language.Symantic.Interpreting + , module Language.Symantic.Transforming ) where import Language.Symantic.Parsing import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting +import Language.Symantic.Transforming diff --git a/Language/Symantic/Compiling/Term/Grammar.hs b/Language/Symantic/Compiling/Term/Grammar.hs index 15b62f3..8c47c4f 100644 --- a/Language/Symantic/Compiling/Term/Grammar.hs +++ b/Language/Symantic/Compiling/Term/Grammar.hs @@ -21,8 +21,6 @@ import qualified Data.Text as Text import Prelude hiding (mod, not, any) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar -import Language.Symantic.Parsing.EBNF import Language.Symantic.Typing -- * Type 'Term_Name' diff --git a/Language/Symantic/Lib/Alternative.hs b/Language/Symantic/Lib/Alternative.hs index a2d80f6..5943410 100644 --- a/Language/Symantic/Lib/Alternative.hs +++ b/Language/Symantic/Lib/Alternative.hs @@ -11,14 +11,13 @@ import Data.Proxy import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (Functor(..), (<$>), id, const) -import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar hiding (Alter(..)) +import Language.Symantic.Parsing hiding (Alter(..)) import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Lib.Lambda import Language.Symantic.Lib.Functor (Sym_Functor(..)) import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming -- * Class 'Sym_Alternative' class Sym_Functor term => Sym_Alternative term where diff --git a/Language/Symantic/Lib/Applicative.hs b/Language/Symantic/Lib/Applicative.hs index 2825abf..3cf18f6 100644 --- a/Language/Symantic/Lib/Applicative.hs +++ b/Language/Symantic/Lib/Applicative.hs @@ -12,13 +12,12 @@ import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (Functor(..), (<$>), Applicative(..), id, const) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling.Term import Language.Symantic.Lib.Lambda import Language.Symantic.Lib.Functor (Sym_Functor(..), (<$>)) import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming -- * Class 'Sym_Applicative' class Sym_Functor term => Sym_Applicative term where diff --git a/Language/Symantic/Lib/Bool.hs b/Language/Symantic/Lib/Bool.hs index bee8db6..49b3706 100644 --- a/Language/Symantic/Lib/Bool.hs +++ b/Language/Symantic/Lib/Bool.hs @@ -11,11 +11,10 @@ import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding ((&&), not, (||)) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming import Language.Symantic.Lib.Lambda -- * Class 'Sym_Bool' diff --git a/Language/Symantic/Lib/Char.hs b/Language/Symantic/Lib/Char.hs index f0fdda6..ad4c6ce 100644 --- a/Language/Symantic/Lib/Char.hs +++ b/Language/Symantic/Lib/Char.hs @@ -9,13 +9,12 @@ import Data.Proxy import qualified Data.Text as Text import Data.Type.Equality ((:~:)(Refl)) -import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar hiding (char) +import Language.Symantic.Parsing hiding (char) import qualified Language.Symantic.Parsing.Grammar as Gram import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming import Language.Symantic.Lib.Lambda -- * Class 'Sym_Char' diff --git a/Language/Symantic/Lib/Either.hs b/Language/Symantic/Lib/Either.hs index c791477..afefedf 100644 --- a/Language/Symantic/Lib/Either.hs +++ b/Language/Symantic/Lib/Either.hs @@ -11,11 +11,10 @@ import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (either) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming import Language.Symantic.Lib.Lambda -- * Class 'Sym_Tuple' diff --git a/Language/Symantic/Lib/Eq.hs b/Language/Symantic/Lib/Eq.hs index 5c6e3ad..cb53220 100644 --- a/Language/Symantic/Lib/Eq.hs +++ b/Language/Symantic/Lib/Eq.hs @@ -9,11 +9,10 @@ import Data.Proxy (Proxy(..)) import Prelude hiding ((==), (/=)) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming import Language.Symantic.Lib.Lambda -- * Class 'Sym_Eq' diff --git a/Language/Symantic/Lib/Foldable.hs b/Language/Symantic/Lib/Foldable.hs index 00049c7..115325a 100644 --- a/Language/Symantic/Lib/Foldable.hs +++ b/Language/Symantic/Lib/Foldable.hs @@ -13,12 +13,11 @@ import Prelude hiding (Foldable(..) , all, and, any, concat, concatMap , mapM_, notElem, or, sequence, sequence_) -import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar hiding (any) +import Language.Symantic.Parsing hiding (any) import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming -- * Class 'Sym_Foldable' class Sym_Foldable term where diff --git a/Language/Symantic/Lib/Functor.hs b/Language/Symantic/Lib/Functor.hs index 2e3d709..dd74ee6 100644 --- a/Language/Symantic/Lib/Functor.hs +++ b/Language/Symantic/Lib/Functor.hs @@ -12,11 +12,10 @@ import Data.Type.Equality import Prelude hiding (Functor(..)) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming import Language.Symantic.Lib.Lambda -- * Class 'Sym_Functor' diff --git a/Language/Symantic/Lib/IO.hs b/Language/Symantic/Lib/IO.hs index aa9d689..11c375e 100644 --- a/Language/Symantic/Lib/IO.hs +++ b/Language/Symantic/Lib/IO.hs @@ -10,11 +10,10 @@ import Data.Type.Equality ((:~:)(Refl)) import qualified System.IO as IO import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming import Language.Symantic.Lib.Lambda -- * Class 'Sym_IO' diff --git a/Language/Symantic/Lib/If.hs b/Language/Symantic/Lib/If.hs index fe14dbe..53f9406 100644 --- a/Language/Symantic/Lib/If.hs +++ b/Language/Symantic/Lib/If.hs @@ -9,11 +9,10 @@ import qualified Data.Text as Text import Data.Type.Equality ((:~:)(Refl)) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming import Language.Symantic.Lib.Lambda -- * Class 'Sym_If' diff --git a/Language/Symantic/Lib/Int.hs b/Language/Symantic/Lib/Int.hs index 315930a..dbe9fe2 100644 --- a/Language/Symantic/Lib/Int.hs +++ b/Language/Symantic/Lib/Int.hs @@ -12,7 +12,7 @@ import Language.Symantic.Parsing import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming -- * Class 'Sym_Int' class Sym_Int term where diff --git a/Language/Symantic/Lib/Integer.hs b/Language/Symantic/Lib/Integer.hs index c5f5bc9..24f635c 100644 --- a/Language/Symantic/Lib/Integer.hs +++ b/Language/Symantic/Lib/Integer.hs @@ -9,11 +9,10 @@ import qualified Data.Text as Text import Data.Type.Equality ((:~:)(Refl)) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming -- * Class 'Sym_Integer' class Sym_Integer term where diff --git a/Language/Symantic/Lib/Integral.hs b/Language/Symantic/Lib/Integral.hs index 36d51c8..669718f 100644 --- a/Language/Symantic/Lib/Integral.hs +++ b/Language/Symantic/Lib/Integral.hs @@ -13,11 +13,10 @@ import Prelude (Integral) import Prelude hiding (Integral(..)) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming import Language.Symantic.Lib.Lambda -- * Class 'Sym_Integral' diff --git a/Language/Symantic/Lib/Lambda.hs b/Language/Symantic/Lib/Lambda.hs index 3611ac9..31af997 100644 --- a/Language/Symantic/Lib/Lambda.hs +++ b/Language/Symantic/Lib/Lambda.hs @@ -14,11 +14,10 @@ import Data.Type.Equality ((:~:)(..)) import Prelude hiding ((^)) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming -- * Class 'Sym_Lambda' diff --git a/Language/Symantic/Lib/List.hs b/Language/Symantic/Lib/List.hs index 65b5378..28100bf 100644 --- a/Language/Symantic/Lib/List.hs +++ b/Language/Symantic/Lib/List.hs @@ -17,11 +17,10 @@ import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (zipWith) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming import Language.Symantic.Lib.Lambda -- * Class 'Sym_List' diff --git a/Language/Symantic/Lib/Map.hs b/Language/Symantic/Lib/Map.hs index 3214d36..3a52481 100644 --- a/Language/Symantic/Lib/Map.hs +++ b/Language/Symantic/Lib/Map.hs @@ -12,11 +12,10 @@ import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (either) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming import Language.Symantic.Lib.Lambda -- * Class 'Sym_Map' diff --git a/Language/Symantic/Lib/Maybe.hs b/Language/Symantic/Lib/Maybe.hs index 2a77434..de4059e 100644 --- a/Language/Symantic/Lib/Maybe.hs +++ b/Language/Symantic/Lib/Maybe.hs @@ -12,11 +12,10 @@ import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (maybe) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming import Language.Symantic.Lib.Lambda -- * Class 'Sym_Maybe_Lam' diff --git a/Language/Symantic/Lib/Monad.hs b/Language/Symantic/Lib/Monad.hs index f21618e..b84c6d1 100644 --- a/Language/Symantic/Lib/Monad.hs +++ b/Language/Symantic/Lib/Monad.hs @@ -10,11 +10,10 @@ import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (Monad(..)) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming import Language.Symantic.Lib.Applicative (Sym_Applicative) -- * Class 'Sym_Monad' diff --git a/Language/Symantic/Lib/MonoFoldable.hs b/Language/Symantic/Lib/MonoFoldable.hs index a95f891..da69dbd 100644 --- a/Language/Symantic/Lib/MonoFoldable.hs +++ b/Language/Symantic/Lib/MonoFoldable.hs @@ -12,11 +12,10 @@ import Data.Text (Text) import Data.Type.Equality ((:~:)(Refl)) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming import Language.Symantic.Lib.MonoFunctor -- * Class 'Sym_MonoFoldable' diff --git a/Language/Symantic/Lib/MonoFunctor.hs b/Language/Symantic/Lib/MonoFunctor.hs index 4479abd..17e9a43 100644 --- a/Language/Symantic/Lib/MonoFunctor.hs +++ b/Language/Symantic/Lib/MonoFunctor.hs @@ -16,11 +16,10 @@ import qualified System.IO as IO import Language.Symantic.Helper.Data.Type.List hiding (Map) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming -- * Class 'Sym_MonoFunctor' class Sym_MonoFunctor term where diff --git a/Language/Symantic/Lib/Monoid.hs b/Language/Symantic/Lib/Monoid.hs index a24c7d2..619d669 100644 --- a/Language/Symantic/Lib/Monoid.hs +++ b/Language/Symantic/Lib/Monoid.hs @@ -12,11 +12,10 @@ import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (Monoid(..)) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming import Language.Symantic.Lib.Lambda -- * Class 'Sym_Monoid' diff --git a/Language/Symantic/Lib/NonNull.hs b/Language/Symantic/Lib/NonNull.hs index 47f4b94..980a5fe 100644 --- a/Language/Symantic/Lib/NonNull.hs +++ b/Language/Symantic/Lib/NonNull.hs @@ -15,11 +15,10 @@ import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (head, init, last, tail) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming import Language.Symantic.Lib.MonoFunctor -- * Class 'Sym_NonNull' diff --git a/Language/Symantic/Lib/Num.hs b/Language/Symantic/Lib/Num.hs index 2a03fb6..b5166bb 100644 --- a/Language/Symantic/Lib/Num.hs +++ b/Language/Symantic/Lib/Num.hs @@ -12,11 +12,10 @@ import Prelude hiding (Num(..)) import Prelude (Num) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming import Language.Symantic.Lib.Lambda -- * Class 'Sym_Num' diff --git a/Language/Symantic/Lib/Num/Test.hs b/Language/Symantic/Lib/Num/Test.hs index 324ddf1..06e1043 100644 --- a/Language/Symantic/Lib/Num/Test.hs +++ b/Language/Symantic/Lib/Num/Test.hs @@ -12,7 +12,6 @@ import Prelude (Num) import Prelude hiding (Num(..)) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting diff --git a/Language/Symantic/Lib/Ord.hs b/Language/Symantic/Lib/Ord.hs index 4837b1b..71b452c 100644 --- a/Language/Symantic/Lib/Ord.hs +++ b/Language/Symantic/Lib/Ord.hs @@ -12,11 +12,10 @@ import qualified Data.Kind as Kind import Prelude hiding (Ord(..)) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming import Language.Symantic.Lib.Lambda import Language.Symantic.Lib.Eq (Sym_Eq) diff --git a/Language/Symantic/Lib/Sequences.hs b/Language/Symantic/Lib/Sequences.hs index 6152474..a3350c7 100644 --- a/Language/Symantic/Lib/Sequences.hs +++ b/Language/Symantic/Lib/Sequences.hs @@ -13,11 +13,10 @@ import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (filter, reverse) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming import Language.Symantic.Lib.MonoFunctor (Fam_MonoElement(..)) -- * Class 'Sym_SemiSequence' diff --git a/Language/Symantic/Lib/Show.hs b/Language/Symantic/Lib/Show.hs index 270ad11..bf52801 100644 --- a/Language/Symantic/Lib/Show.hs +++ b/Language/Symantic/Lib/Show.hs @@ -11,11 +11,10 @@ import Text.Show (Show) import qualified Text.Show as Show import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming import Language.Symantic.Lib.Lambda -- * Class 'Sym_Show' diff --git a/Language/Symantic/Lib/Text.hs b/Language/Symantic/Lib/Text.hs index 041dff7..c85aeea 100644 --- a/Language/Symantic/Lib/Text.hs +++ b/Language/Symantic/Lib/Text.hs @@ -12,7 +12,7 @@ import Language.Symantic.Parsing import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming -- * Class 'Sym_Text' class Sym_Text term where diff --git a/Language/Symantic/Lib/Traversable.hs b/Language/Symantic/Lib/Traversable.hs index f7fb75f..01527d4 100644 --- a/Language/Symantic/Lib/Traversable.hs +++ b/Language/Symantic/Lib/Traversable.hs @@ -10,11 +10,10 @@ import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (traverse) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming import Language.Symantic.Lib.Applicative (Sym_Applicative) -- * Class 'Sym_Traversable' diff --git a/Language/Symantic/Lib/Tuple2.hs b/Language/Symantic/Lib/Tuple2.hs index 8960780..9644a9e 100644 --- a/Language/Symantic/Lib/Tuple2.hs +++ b/Language/Symantic/Lib/Tuple2.hs @@ -12,11 +12,10 @@ import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding (fst, snd) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming -- * Class 'Sym_Tuple2' class Sym_Tuple2 term where diff --git a/Language/Symantic/Lib/Unit.hs b/Language/Symantic/Lib/Unit.hs index db8411a..24a0925 100644 --- a/Language/Symantic/Lib/Unit.hs +++ b/Language/Symantic/Lib/Unit.hs @@ -11,11 +11,10 @@ import Data.Type.Equality ((:~:)(Refl)) import Prelude hiding ((&&), not, (||)) import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar as Gram import Language.Symantic.Typing import Language.Symantic.Compiling import Language.Symantic.Interpreting -import Language.Symantic.Transforming.Trans +import Language.Symantic.Transforming -- * Class 'Sym_Unit' class Sym_Unit term where diff --git a/Language/Symantic/Parsing.hs b/Language/Symantic/Parsing.hs index a206963..654d045 100644 --- a/Language/Symantic/Parsing.hs +++ b/Language/Symantic/Parsing.hs @@ -1,6 +1,10 @@ -- | Parsing terms. module Language.Symantic.Parsing ( module Language.Symantic.Parsing.Token + , module Language.Symantic.Parsing.Grammar + , module Language.Symantic.Parsing.EBNF ) where import Language.Symantic.Parsing.Token +import Language.Symantic.Parsing.Grammar +import Language.Symantic.Parsing.EBNF diff --git a/Language/Symantic/Parsing/EBNF/Print.hs b/Language/Symantic/Parsing/EBNF/Print.hs index 679f613..1879859 100644 --- a/Language/Symantic/Parsing/EBNF/Print.hs +++ b/Language/Symantic/Parsing/EBNF/Print.hs @@ -4,8 +4,7 @@ import Data.Text.IO as Text import Control.Monad import Language.Symantic.Typing -import Language.Symantic.Parsing.Grammar -import Language.Symantic.Parsing.EBNF +import Language.Symantic.Parsing import Language.Symantic.Compiling (gram_term) main :: IO () diff --git a/Language/Symantic/Typing/Type.hs b/Language/Symantic/Typing/Type.hs index fcd0f93..92774d0 100644 --- a/Language/Symantic/Typing/Type.hs +++ b/Language/Symantic/Typing/Type.hs @@ -20,8 +20,6 @@ import qualified Data.Kind as K import Language.Symantic.Typing.Kind import Language.Symantic.Typing.Constant import Language.Symantic.Parsing -import Language.Symantic.Parsing.Grammar as Gram -import Language.Symantic.Parsing.EBNF -- * Type 'Type' -- 2.47.2 From d7d7e26445545e879765a1173c7c2363a23f11d6 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Sat, 4 Feb 2017 08:10:18 +0100 Subject: [PATCH 12/16] Fix Lib.Ord : Ordering. --- Language/Symantic/Lib/Ord.hs | 84 ++++++++++++++++++++++++++++++------ 1 file changed, 70 insertions(+), 14 deletions(-) diff --git a/Language/Symantic/Lib/Ord.hs b/Language/Symantic/Lib/Ord.hs index 71b452c..22883c0 100644 --- a/Language/Symantic/Lib/Ord.hs +++ b/Language/Symantic/Lib/Ord.hs @@ -8,6 +8,7 @@ import Data.Ord (Ord) import qualified Data.Ord as Ord import Data.Proxy (Proxy(..)) import qualified Data.Text as Text +import Data.Type.Equality ((:~:)(Refl)) import qualified Data.Kind as Kind import Prelude hiding (Ord(..)) @@ -21,7 +22,6 @@ import Language.Symantic.Lib.Eq (Sym_Eq) -- * Class 'Sym_Ord' class Sym_Eq term => Sym_Ord term where - ordering :: Ordering -> term Ordering compare :: Ord a => term a -> term a -> term Ordering (<) :: Ord a => term a -> term a -> term Bool (<=) :: Ord a => term a -> term a -> term Bool @@ -30,7 +30,6 @@ class Sym_Eq term => Sym_Ord term where max :: Ord a => term a -> term a -> term a min :: Ord a => term a -> term a -> term a - default ordering :: Trans t term => Ordering -> t term Ordering default compare :: (Trans t term, Ord a) => t term a -> t term a -> t term Ordering default (<) :: (Trans t term, Ord a) => t term a -> t term a -> t term Bool default (<=) :: (Trans t term, Ord a) => t term a -> t term a -> t term Bool @@ -39,7 +38,6 @@ class Sym_Eq term => Sym_Ord term where default max :: (Trans t term, Ord a) => t term a -> t term a -> t term a default min :: (Trans t term, Ord a) => t term a -> t term a -> t term a - ordering = trans_lift . ordering compare = trans_map2 compare (<) = trans_map2 (<) (<=) = trans_map2 (<=) @@ -53,12 +51,26 @@ infix 4 <= infix 4 > infix 4 >= +-- * Class 'Sym_Ordering' +class Sym_Eq term => Sym_Ordering term where + ordering :: Ordering -> term Ordering + default ordering :: Trans t term => Ordering -> t term Ordering + ordering = trans_lift . ordering + type instance Sym_of_Iface (Proxy Ord) = Sym_Ord +type instance Sym_of_Iface (Proxy Ordering) = Sym_Ordering type instance Consts_of_Iface (Proxy Ord) = Proxy Ord ': Consts_imported_by Ord +type instance Consts_of_Iface (Proxy Ordering) = Proxy Ordering ': Consts_imported_by Ordering type instance Consts_imported_by Ord = '[] +type instance Consts_imported_by Ordering = + [ Proxy Bounded + , Proxy Enum + , Proxy Eq + , Proxy Ord + , Proxy Show + ] instance Sym_Ord HostI where - ordering = HostI compare = liftM2 Ord.compare (<) = liftM2 (Ord.<) (<=) = liftM2 (Ord.<=) @@ -66,9 +78,9 @@ instance Sym_Ord HostI where (>=) = liftM2 (Ord.>=) min = liftM2 Ord.min max = liftM2 Ord.max +instance Sym_Ordering HostI where + ordering = HostI instance Sym_Ord TextI where - ordering o = TextI $ \_p _v -> - Text.pack (show o) compare = textI2 "compare" (<) = textI_infix "<" (infixN 4) (<=) = textI_infix "<=" (infixN 4) @@ -76,8 +88,10 @@ instance Sym_Ord TextI where (>=) = textI_infix ">=" (infixN 4) min = textI2 "min" max = textI2 "max" +instance Sym_Ordering TextI where + ordering o = TextI $ \_p _v -> + Text.pack (show o) instance (Sym_Ord r1, Sym_Ord r2) => Sym_Ord (DupI r1 r2) where - ordering o = ordering o `DupI` ordering o compare = dupI2 (Proxy @Sym_Ord) compare (<) = dupI2 (Proxy @Sym_Ord) (<) (<=) = dupI2 (Proxy @Sym_Ord) (<=) @@ -85,6 +99,8 @@ instance (Sym_Ord r1, Sym_Ord r2) => Sym_Ord (DupI r1 r2) where (>=) = dupI2 (Proxy @Sym_Ord) (>=) min = dupI2 (Proxy @Sym_Ord) min max = dupI2 (Proxy @Sym_Ord) max +instance (Sym_Ordering r1, Sym_Ordering r2) => Sym_Ordering (DupI r1 r2) where + ordering o = ordering o `DupI` ordering o instance ( Read_TypeNameR Type_Name cs rs @@ -92,22 +108,49 @@ instance ) => Read_TypeNameR Type_Name cs (Proxy Ord ': rs) where read_typenameR _cs (Type_Name "Ord") k = k (ty @Ord) read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k +instance + ( Read_TypeNameR Type_Name cs rs + , Inj_Const cs Ordering + ) => Read_TypeNameR Type_Name cs (Proxy Ordering ': rs) where + read_typenameR _cs (Type_Name "Ordering") k = k (ty @Ordering) + read_typenameR _rs raw k = read_typenameR (Proxy @rs) raw k 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 Ordering ': cs) where + show_const ConstZ{} = "Ordering" + show_const (ConstS c) = show_const c instance Proj_ConC cs (Proxy Ord) +instance -- Proj_ConC + ( Proj_Const cs Ordering + , Proj_Consts cs (Consts_imported_by Ordering) + ) => Proj_ConC cs (Proxy Ordering) where + proj_conC _ (TyConst q :$ TyConst c) + | Just Refl <- eq_skind (kind_of_const c) SKiType + , Just Refl <- proj_const c (Proxy @Ordering) + = case () of + _ | Just Refl <- proj_const q (Proxy @Bounded) -> Just Con + | Just Refl <- proj_const q (Proxy @Enum) -> Just Con + | Just Refl <- proj_const q (Proxy @Eq) -> Just Con + | Just Refl <- proj_const q (Proxy @Ord) -> Just Con + | Just Refl <- proj_const q (Proxy @Show) -> Just Con + _ -> Nothing + proj_conC _c _q = Nothing data instance TokenT meta (ts::[*]) (Proxy Ord) - = Token_Term_Ordering Ordering - | Token_Term_Ord_compare (EToken meta ts) + = Token_Term_Ord_compare (EToken meta ts) | Token_Term_Ord_le (EToken meta ts) | Token_Term_Ord_lt (EToken meta ts) | Token_Term_Ord_ge (EToken meta ts) | Token_Term_Ord_gt (EToken meta ts) | Token_Term_Ord_min (EToken meta ts) | Token_Term_Ord_max (EToken meta ts) +data instance TokenT meta (ts::[*]) (Proxy Ordering) + = Token_Term_Ordering Ordering deriving instance Eq_Token meta ts => Eq (TokenT meta ts (Proxy Ord)) +deriving instance Eq_Token meta ts => Eq (TokenT meta ts (Proxy Ordering)) deriving instance Show_Token meta ts => Show (TokenT meta ts (Proxy Ord)) +deriving instance Show_Token meta ts => Show (TokenT meta ts (Proxy Ordering)) instance -- CompileI ( Inj_Const (Consts_of_Ifaces is) Bool , Inj_Const (Consts_of_Ifaces is) (->) @@ -122,7 +165,6 @@ instance -- CompileI -> CompileT meta ctx ret is ls (Proxy Ord ': rs) compileI tok ctx k = case tok of - Token_Term_Ordering o -> k (ty @Ordering) $ TermO $ \_c -> ordering o Token_Term_Ord_compare tok_a -> compare_from tok_a (ty @Ordering) compare Token_Term_Ord_le tok_a -> compare_from tok_a (ty @Bool) (<=) Token_Term_Ord_lt tok_a -> compare_from tok_a (ty @Bool) (<) @@ -155,19 +197,33 @@ instance -- CompileI check_con (At (Just tok_a) (ty @Ord :$ ty_a)) $ \Con -> k (ty_a ~> ty_a) $ TermO $ \c -> lam $ \y -> op (x c) y +instance -- CompileI + ( Inj_Const (Consts_of_Ifaces is) Ordering + ) => CompileI is (Proxy Ordering) where + compileI tok _ctx k = + case tok of + Token_Term_Ordering o -> k (ty @Ordering) $ TermO $ \_c -> ordering o instance -- TokenizeT Inj_Token meta ts Ord => TokenizeT meta ts (Proxy Ord) where tokenizeT _t = mempty { tokenizers_infix = tokenizeTMod [] - [ tokenize0 "LT" infixN5 $ Token_Term_Ordering LT - , tokenize0 "EQ" infixN5 $ Token_Term_Ordering EQ - , tokenize0 "GT" infixN5 $ Token_Term_Ordering GT - , tokenize1 "compare" infixN5 Token_Term_Ord_compare + [ tokenize1 "compare" infixN5 Token_Term_Ord_compare , tokenize1 "<" (infixN 4) Token_Term_Ord_lt , tokenize1 "<=" (infixN 4) Token_Term_Ord_le , tokenize1 ">" (infixN 4) Token_Term_Ord_gt , tokenize1 ">=" (infixN 4) Token_Term_Ord_ge ] } +instance -- TokenizeT + Inj_Token meta ts Ordering => + TokenizeT meta ts (Proxy Ordering) where + tokenizeT _t = mempty + { tokenizers_infix = tokenizeTMod [] + [ tokenize0 "LT" infixN5 $ Token_Term_Ordering LT + , tokenize0 "EQ" infixN5 $ Token_Term_Ordering EQ + , tokenize0 "GT" infixN5 $ Token_Term_Ordering GT + ] + } +instance Gram_Term_AtomsT meta ts (Proxy Ordering) g instance Gram_Term_AtomsT meta ts (Proxy Ord) g -- 2.47.2 From 9b093b7ee78dc7bb4b81639c85462b3841b6839e Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Mon, 6 Feb 2017 12:30:50 +0100 Subject: [PATCH 13/16] Update doc. --- symantic.cabal | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/symantic.cabal b/symantic.cabal index 2348a08..7212c31 100644 --- a/symantic.cabal +++ b/symantic.cabal @@ -17,7 +17,8 @@ description: Typical use cases: . * Enabling runtime users to enter some Haskell-like expressions - without using GHC at runtime (eg. by using ). + without using all the weight and slowness of GHC + at runtime (eg. by using ). * Limiting those expressions to be built only from well-controlled expressions. * Run some analyzes/optimizations on those well-controlled expressions. . -- 2.47.2 From ca8c01132af2d5dfee75431b9e2d5ef44a5b6301 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Mon, 6 Feb 2017 16:16:31 +0100 Subject: [PATCH 14/16] Add stack.yaml. --- stack.yaml | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 stack.yaml diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..7ae865d --- /dev/null +++ b/stack.yaml @@ -0,0 +1,8 @@ +resolver: nightly-2017-02-03 +flags: {} +packages: +- '.' +extra-deps: +- monad-classes-0.3.2.0 +- peano-0.1.0.1 +extra-package-dbs: [] -- 2.47.2 From 45a0e115b11e1f10e741ead47fb0ecba8682021e Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Wed, 8 Feb 2017 17:04:33 +0100 Subject: [PATCH 15/16] Add optional. --- Language/Symantic/Parsing/Grammar.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Language/Symantic/Parsing/Grammar.hs b/Language/Symantic/Parsing/Grammar.hs index b3a518f..372ea3e 100644 --- a/Language/Symantic/Parsing/Grammar.hs +++ b/Language/Symantic/Parsing/Grammar.hs @@ -160,6 +160,8 @@ infixl 4 <*. class (Alter g, Applicative g) => Alt g where option :: a -> g a -> g a option x g = g <+> pure x + optional :: g a -> g (Maybe a) + optional v = Just <$> v <+> pure Nothing many :: g a -> g [a] many a = some a <+> pure [] some :: g a -> g [a] -- 2.47.2 From a54ffd299db9646630dab2cd1d610c85ffbb5be9 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Wed, 8 Feb 2017 17:05:07 +0100 Subject: [PATCH 16/16] Polish doc. --- symantic.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/symantic.cabal b/symantic.cabal index 7212c31..4552644 100644 --- a/symantic.cabal +++ b/symantic.cabal @@ -12,14 +12,14 @@ description: according to some compile-time defined types. The idea being that the more complex logic shall remain coded in Haskell and then this library used to project an interface into a DSL - giving runtime users the flexibility to write simple programs suited to their needs. + giving runtime users the flexibility to write simpler programs suited to their needs. . Typical use cases: . * Enabling runtime users to enter some Haskell-like expressions without using all the weight and slowness of GHC at runtime (eg. by using ). - * Limiting those expressions to be built only from well-controlled expressions. + * Limiting those expressions to be built from well-controlled expressions only. * Run some analyzes/optimizations on those well-controlled expressions. . __Warning__ -- 2.47.2