diff --git a/.ghci b/.ghci new file mode 100644 index 00000000..0102ea8b --- /dev/null +++ b/.ghci @@ -0,0 +1,3 @@ +:set -XOverloadedStrings +:set -XDataKinds +import qualified Language.SOAS.Impl as SOAS diff --git a/haskell/free-foil/ChangeLog.md b/haskell/free-foil/ChangeLog.md index dad669b9..8a6a02b1 100644 --- a/haskell/free-foil/ChangeLog.md +++ b/haskell/free-foil/ChangeLog.md @@ -1,5 +1,11 @@ # CHANGELOG for `free-foil` +# 0.2.0 — 2024-10-27 + +- Generate [`COMPLETE` pragma](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/pragmas.html#complete-pragmas) in `mkPatternSynonyms` (see [#26](https://github.com/fizruk/free-foil/pull/26)) +- Polykind `ZipMatchK` class with default generic implementation via [`kind-generics`](https://hackage.haskell.org/package/kind-generics) (see [#27](https://github.com/fizruk/free-foil/pull/27)) +- New experimental TH generation for Free Foil with support for rich syntax in `Control.Monad.Free.Foil.TH.MkFreeFoil` (see [#28](https://github.com/fizruk/free-foil/pull/28)) + # 0.1.0 — 2024-08-18 - Generalize functions for binders, support general patterns (see [#16](https://github.com/fizruk/free-foil/pull/16)) diff --git a/haskell/free-foil/free-foil.cabal b/haskell/free-foil/free-foil.cabal index 9c0e1886..65ebc84e 100644 --- a/haskell/free-foil/free-foil.cabal +++ b/haskell/free-foil/free-foil.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: free-foil -version: 0.1.0 +version: 0.2.0 synopsis: Efficient Type-Safe Capture-Avoiding Substitution for Free (Scoped Monads) description: Please see the README on GitHub at category: Parsing diff --git a/haskell/free-foil/package.yaml b/haskell/free-foil/package.yaml index 3b96c0ba..2de57a4e 100644 --- a/haskell/free-foil/package.yaml +++ b/haskell/free-foil/package.yaml @@ -1,5 +1,5 @@ name: free-foil -version: 0.1.0 +version: 0.2.0 github: "fizruk/free-foil" license: BSD3 author: "Nikolai Kudasov" diff --git a/haskell/free-foil/src/Control/Monad/Free/Foil/TH/MkFreeFoil.hs b/haskell/free-foil/src/Control/Monad/Free/Foil/TH/MkFreeFoil.hs index 4ce823e7..fa924ba6 100644 --- a/haskell/free-foil/src/Control/Monad/Free/Foil/TH/MkFreeFoil.hs +++ b/haskell/free-foil/src/Control/Monad/Free/Foil/TH/MkFreeFoil.hs @@ -521,10 +521,10 @@ termConToPatQuantified config@FreeFoilConfig{..} = go ForallC _params _ctx con -> go con RecGadtC conNames argTypes retType -> go (GadtC conNames (map removeName argTypes) retType) -mkPatternSynonym :: Name -> FreeFoilConfig -> FreeFoilTermConfig -> Type -> Con -> Q [Dec] +mkPatternSynonym :: Name -> FreeFoilConfig -> FreeFoilTermConfig -> Type -> Con -> Q [(Name, [Dec])] mkPatternSynonym rawTypeName config termConfig@FreeFoilTermConfig{..} rawRetType = go where - go :: Con -> Q [Dec] + go :: Con -> Q [(Name, [Dec])] go = \case GadtC conNames rawArgTypes _rawRetType -> concat <$> do forM (conNames \\ [rawVarConName]) $ \conName -> do @@ -537,10 +537,10 @@ mkPatternSynonym rawTypeName config termConfig@FreeFoilTermConfig{..} rawRetType [(vars, pat, _, _)] <- termConToPat rawTypeName config termConfig (GadtC [conName] rawArgTypes rawRetType) -- FIXME: unsafe matching! addModFinalizer $ putDoc (DeclDoc patName) ("/Generated/ with '" ++ show 'mkFreeFoil ++ "'. Pattern synonym for an '" ++ show ''Foil.AST ++ "' node of type '" ++ show conName ++ "'.") - return + return [(patName, [ PatSynSigD patName (toFreeFoilType SortTerm config outerScope innerScope rawConType) , PatSynD patName (PrefixPatSyn vars) ImplBidir pat - ] + ])] NormalC conName types -> go (GadtC [conName] types rawRetType) RecC conName types -> go (NormalC conName (map removeName types)) @@ -624,7 +624,11 @@ mkFreeFoil config@FreeFoilConfig{..} = concat <$> sequence mkPatternSynonyms' FreeFoilTermConfig{..} rawName = do (tvars, cons) <- reifyDataOrNewtype rawName let rawRetType = PeelConT rawName (map (VarT . tvarName) tvars) - concat <$> mapM (mkPatternSynonym rawName config FreeFoilTermConfig{..} rawRetType) cons + (unzip -> (patNames, decls)) <- concat <$> mapM (mkPatternSynonym rawName config FreeFoilTermConfig{..} rawRetType) cons + let completeDecl + | rawName == rawTermName = PragmaD (CompleteP ('Foil.Var : patNames) Nothing) + | otherwise = PragmaD (CompleteP patNames Nothing) + return (concat decls ++ [completeDecl]) mkQuantifiedType rawName = do (tvars, cons) <- reifyDataOrNewtype rawName diff --git a/haskell/lambda-pi/lambda-pi.cabal b/haskell/lambda-pi/lambda-pi.cabal index ac85364a..bb7a8f11 100644 --- a/haskell/lambda-pi/lambda-pi.cabal +++ b/haskell/lambda-pi/lambda-pi.cabal @@ -5,7 +5,7 @@ cabal-version: 1.24 -- see: https://github.com/sol/hpack name: lambda-pi -version: 0.1.0 +version: 0.2.0 synopsis: λΠ-calculus implemented in a few different ways. description: Please see the README on GitHub at category: Language @@ -60,7 +60,7 @@ library , bifunctors , containers , deepseq - , free-foil >=0.1.0 + , free-foil >=0.2.0 , kind-generics-th , template-haskell , text >=1.2.3.1 @@ -84,7 +84,7 @@ executable lambda-pi , bifunctors , containers , deepseq - , free-foil >=0.1.0 + , free-foil >=0.2.0 , kind-generics-th , lambda-pi , template-haskell @@ -110,7 +110,7 @@ test-suite doctests , containers , deepseq , doctest-parallel - , free-foil >=0.1.0 + , free-foil >=0.2.0 , kind-generics-th , lambda-pi , template-haskell @@ -139,7 +139,7 @@ test-suite spec , bifunctors , containers , deepseq - , free-foil >=0.1.0 + , free-foil >=0.2.0 , hspec , hspec-discover , kind-generics-th diff --git a/haskell/lambda-pi/package.yaml b/haskell/lambda-pi/package.yaml index 4e859df6..759bc858 100644 --- a/haskell/lambda-pi/package.yaml +++ b/haskell/lambda-pi/package.yaml @@ -1,5 +1,5 @@ name: lambda-pi -version: 0.1.0 +version: 0.2.0 github: "fizruk/free-foil" license: BSD3 author: "Nikolai Kudasov" @@ -39,7 +39,7 @@ dependencies: bifunctors: template-haskell: deepseq: - free-foil: ">= 0.1.0" + free-foil: ">= 0.2.0" kind-generics-th: ghc-options: diff --git a/haskell/soas/package.yaml b/haskell/soas/package.yaml index 1688c7f9..713ac354 100644 --- a/haskell/soas/package.yaml +++ b/haskell/soas/package.yaml @@ -1,5 +1,5 @@ name: soas -version: 0.1.0 +version: 0.2.0 github: "fizruk/free-foil" license: BSD3 author: "Nikolai Kudasov" @@ -39,7 +39,7 @@ dependencies: bifunctors: template-haskell: deepseq: - free-foil: ">= 0.1.0" + free-foil: ">= 0.2.0" kind-generics-th: ghc-options: diff --git a/haskell/soas/soas.cabal b/haskell/soas/soas.cabal index 94563f1c..f1528c7f 100644 --- a/haskell/soas/soas.cabal +++ b/haskell/soas/soas.cabal @@ -5,7 +5,7 @@ cabal-version: 1.24 -- see: https://github.com/sol/hpack name: soas -version: 0.1.0 +version: 0.2.0 synopsis: Second-Order Abstract Syntax implemented via Free Foil (a version of SOAS). description: Please see the README on GitHub at category: Language @@ -58,7 +58,7 @@ library , bifunctors , containers , deepseq - , free-foil >=0.1.0 + , free-foil >=0.2.0 , kind-generics-th , template-haskell , text >=1.2.3.1 @@ -82,7 +82,7 @@ executable soas , bifunctors , containers , deepseq - , free-foil >=0.1.0 + , free-foil >=0.2.0 , kind-generics-th , soas , template-haskell @@ -108,7 +108,7 @@ test-suite doctests , containers , deepseq , doctest-parallel - , free-foil >=0.1.0 + , free-foil >=0.2.0 , kind-generics-th , soas , template-haskell @@ -135,7 +135,7 @@ test-suite spec , bifunctors , containers , deepseq - , free-foil >=0.1.0 + , free-foil >=0.2.0 , hspec , hspec-discover , kind-generics-th diff --git a/haskell/soas/src/Language/SOAS/Impl.hs b/haskell/soas/src/Language/SOAS/Impl.hs index a0d30a61..f6f06298 100644 --- a/haskell/soas/src/Language/SOAS/Impl.hs +++ b/haskell/soas/src/Language/SOAS/Impl.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wno-orphans -Wno-redundant-constraints -ddump-splices #-} +{-# OPTIONS_GHC -Wno-orphans -Wno-redundant-constraints #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -17,6 +17,7 @@ -- represented using scope-safe Haskell types (via Free Foil). module Language.SOAS.Impl where + import Data.List (find) import Data.Bifunctor import qualified Control.Monad.Foil as Foil @@ -68,6 +69,7 @@ applySubsts scope substs term = MetaVar _loc m args | Just (Subst _ _ binders body) <- lookupSubst m substs -> substitutePattern scope Foil.voidSubst binders args body Var{} -> term + -- NOTE: generic recursive processing! Node node -> Node (bimap goScoped (applySubsts scope substs) node) where goScoped (ScopedAST binders body) =