diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,25 @@ +# Changelog for `holeyexp` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## [0.2.0.0] - 2026-08-28 +### Added + - New documentation and complete Haddock docs on all definitions. + - New cabal package. +### Changed + - Better naming of combinators. + - Data.HoleyExp.HExp.empty is now emptyExp + - Data.HoleyExp.HExp.hole is now empty + - Data.HoleyExp.HExp.plugHole is now plug + - Data.HoleyExp.HExp.fillHole is now update + - Data.HoleyExp.HExp.placeInHole is now place + - Moved template haskell and JSON out of this package and into their own packages. + +## [0.1.0.0] - 2026-08-14 + - First complete implementation. diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,26 @@ +Copyright 2026 Harley Eades III + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,16 @@ +# Holey Expression + +[![License BSD-3](https://img.shields.io/badge/license-BSD3-brightgreen.svg)](http://opensource.org/licenses/BSD-3-Clause) + +* [Documentation](#documentation) + +Holey expressions correspond to a monoid with two kinds of elements: i. chunks +and ii. holes. The former correspond to chunks of "text" which we leave +abstract, and the latter correspond to placeholders for values that will +eventually be translated into "text". + +# Documentation + +The API is well documented. Please see [hackage] for the complete documentation. + +[hackage]: https://hackage.haskell.org/package/holeyexp diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/holeyexp.cabal b/holeyexp.cabal new file mode 100644 --- /dev/null +++ b/holeyexp.cabal @@ -0,0 +1,111 @@ +cabal-version: 2.4 +name: holeyexp +version: 0.2.0.0 +license: BSD-3-Clause +license-file: LICENSE.md +maintainer: Harley Eades III +author: Harley Eades III + +tested-with: + GHC == 9.10.* + GHC == 9.12.* + GHC == 9.14.1 + +homepage: https://github.com/DevWKB/holey-expression +bug-reports: https://github.com/DevWKB/holey-expression/issues +synopsis: Add, fill, plug holes in monoids +description: + This is a library that allows you to add placeholders we call "holes" + to any monoid. Then these holes can be filled or plugged. + +category: Language +build-type: Simple + +extra-source-files: + README.md +extra-doc-files: + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/heades/holey-expression + +common depends + build-depends: + base >= 4.7 && < 5 + ,containers >= 0.7 && < 0.8 + ,extra >= 1.8.1 && < 1.9 + ,megaparsec >= 9.7.0 && < 9.9 + ,text >= 2.1.3 && < 2.2 + +common test-depends + build-depends: + QuickCheck > 2.15.0 && < 2.19 + ,hspec >= 2.11.17 && < 2.12 + ,quickcheck-instances >= 0.3.33 && < 0.5 + build-tool-depends: + hspec-discover:hspec-discover + +library + import: depends + + if impl(ghc >= 9.10.0) + buildable: True + else + buildable: False + + exposed-modules: + Data.HoleyExp.HExp + Data.HoleyExp.HExpInternal + Data.HoleyExp.Text + Data.NatMap + other-modules: + Paths_holeyexp + autogen-modules: + Paths_holeyexp + hs-source-dirs: + src + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wmissing-export-lists + -Wmissing-home-modules + -Wpartial-fields + -Wredundant-constraints + -Wno-name-shadowing + default-extensions: + ImportQualifiedPost + OverloadedStrings + InstanceSigs + LambdaCase + ViewPatterns + PatternSynonyms + GADTs + default-language: Haskell2010 + +test-suite holey-expression-test + import: depends, test-depends + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_holeyexp + Data.HoleyExp.HExpInternalSpec + Test.QuickCheck.HExp + Test.Helpers + autogen-modules: + Paths_holeyexp + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + default-extensions: + ImportQualifiedPost + OverloadedStrings + InstanceSigs + LambdaCase + ViewPatterns + GADTs + build-depends: + ,holeyexp + default-language: Haskell2010 diff --git a/src/Data/HoleyExp/HExp.hs b/src/Data/HoleyExp/HExp.hs new file mode 100644 --- /dev/null +++ b/src/Data/HoleyExp/HExp.hs @@ -0,0 +1,191 @@ +{-| +Module : HExp +Description : Holey Expressions +Copyright : (c) Harley Eades, 2026 + (c) W⋊B, 2026 +Maintainer : harley.eades@gmail.com + +Holey expressions correspond to a monoid with two kinds of elements: i. chunks +and ii. holes. The former correspond to chunks of "text" which we leave +abstract, and the latter correspond to placeholders for values that will +eventually be translated into "text". + +Suppose we have a monoid \((\mathsf{Txt},\otimes,\mathsf{e})\), where we call +elements of \(\mathsf{Txt}\) __text__. Furthermore, suppose we have a set +\(\mathsf{Fill}\) which we call its elements __fillings__. + +We define the collection of __holey expressions__ to be: + +\( \mathsf{HExp}(\mathsf{Txt},\mathsf{Fill}) = \Pi(\mathsf{Txt} + (\mathbb{N} \times \mathsf{Fill}_{\mathsf{?}})) \) + +We call elements of \( \mathbb{N} \times \mathsf{Fill}_{\mathsf{?}} \) +__holes__, and denote __filled holes__ by \($(i,f)\) and __empty holes__ by +\($(i,\mathsf{?})\). Lastly, composition of expressions, elements of +\(\mathsf{HExp}\), is concatenation of products denoted by +\(e_1 * \cdots * e_i \); +note that we leave injections implicit to make the expression more readable. + +__Chunks__ are the pieces of text that sit between holes. It's quite simple to +define the function +\(\mathsf{chunk}(t) = t : \mathsf{HExp}(\mathsf{Txt},\mathsf{Fill})\). We +will leave the application of \(\mathsf{chunk}\) implicit. + +Let's consider a few abstract example expressions: + +1. \( t_1 * $(1,\mathsf{?}) * t_2 * $(2,\mathsf{?}) \), has chunks + \(\{t_1,t_2\}\) and two empty holes indexed by \(1\) and \(2\). +2. \( t_1 * $(5,f_5) * $(3,\mathsf{?}) * t_2 * $(7,f_7) \), has chunks + \(\{t_1,t_2\}\) and one empty holes indexed by \(3\) and a filled hole index + by \(7\) whose filling is \(f_2\). + +Now if we choose some concrete sets for \(\mathsf{Txt}\) and \(\mathsf{Fill}\) +then we can create more interesting expressions: + +1. \(123 * $(1,?) * 456 * $(2,5) : \mathsf{HExp}(\mathbb{N},\mathbb{N})\), where + \((\mathbb{N},0,+)\) is the monoid for \(\mathsf{Txt}\) +2. \(\text{"Hi, my name is "} * $(1,?) : \mathsf{HExp}(\Sigma^*,\Sigma^*)\), where + \((\Sigma^*,\circ)\) is the monoid of words over the English alphabet. +3. \($(1,?) * \text{":"} * $(2,?) * \text{":"} * $(3,?) : \mathsf{HExp}(\Sigma^*,\mathbb{N})\), where + \((\Sigma^*,\circ)\) is the monoid of words over \(\Sigma = \mathbb{N} \cup \{\text{":"}\}\). + This could represent time. + +Holey expressions are ultimately meant to be translated into \(\mathsf{Txt}\) by +filling in all of their holes. This implies that we must require the existence +of a function \(p : \mathsf{Fill} \to \mathsf{Txt} \). There are two operations +on holes: i. plugging a hole (replacing it with a filling) and ii. filling a +hole (placing a filling inside the hole). + +Plugging a hole amounts to defining a function +\(\mathsf{plug} : \mathbb{N} \times \mathsf{Fill}_\mathsf{?} \to \mathsf{Fill}_\perp\) +that chooses which filling to replace the hole with; note that this is a partial +function, and is defined per-expression. Then plugging an expression corresponds to +the function: +\( \Pi(\mathsf{id} + (\mathsf{plug};p_\perp)) : \mathsf{HExp}(\mathsf{Txt},\mathsf{Fill}) \to \mathsf{Txt}_\perp \). +If the plug function is defined for all holes in the input expression, then the +above composition will indeed yield a text (an element of \(\mathsf{Txt}\)). + +Filling a hole is a bit more simple, and requires the definition of a function +\(\mathsf{place} : \mathsf{Fill}_\mathsf{?} \to \mathsf{Fill}_\mathsf{?}\) +that simply updates the filling in the hole. Then filling an expression corresponds to +the function: +\( \Pi(\mathsf{id} + (\mathsf{id} \times \mathsf{place})) : \mathsf{HExp}(\mathsf{Txt},\mathsf{Fill}) \to \mathsf{HExp}(\mathsf{Txt},\mathsf{Fill}) \). + +Each one of these concepts map to a corresponding item in this module. + +The holey expressions type, @exp :: t`HExp` text filling@, abstracts +over \(\mathsf{Txt}\) and \(\mathsf{Fill}\) using type variables @text@ and +@filling@. We enforce that @filling@ can be translated to @text@ using the type +class @`HoleFilling` text filling@. This requires that there is a function +@`fillingToText` :: filling -> text@. + +There are three main combinators for creating holey expressions: + +1. @`chunk` :: text -> t`HExp` text filling@ is a piece of @text@ that +sits between the holes in an expression; +2. An empty hole, @`empty` :: t`GHC.Num.Natural` -> t`HExp` text filling@, + informally denoted @$i()@, simply corresponds to a natural number that acts as its index; and +3. a filled hole, @`filled` :: t`GHC.Num.Natural` -> filling -> t`HExp` text filling@, are also indexed by a +natural number, but now contain a filling that /may/ replace the hole when it's +converted into a @text@. + +When @text@ is a monoid, then we can compose chunks and holes together using the +sequential composition @`(+>)` :: t`HExp` text filling -> t`HExp` text filling +-> t`HExp` text filling@. + +Concrete examples are more interesting when we actually instantiate @text@ and +@filling@. For several using t`Data.Text.Text` as the @text@, see +"Data.HoleyExp.Text". +-} + + + +module Data.HoleyExp.HExp (-- * Holey Expressions + HExp + ,TextLike(..) + ,HoleFilling(..) + ,ToHExp(..) + -- __ Holes + ,Hole + ,HoleProps + -- __* Patterns + -- | Patterns make it easier to decide if a hole is empty, filled, or neither. + -- For example: + -- + -- @ + -- holeIndex :: Hole f -> Maybe Natural + -- holeIndex (EmptyHole i _) = Just i + -- holeIndex (FilledHole i _) = Just i + -- holeIndex (UndefHole i _) = Nothing + -- @ + -- Each pattern uses the hole's properties + -- ('HoleProps') to decide if the hole's index is in + -- the required is location within the hole + -- properties, if not then it's considered + -- undefined. This prevents a lot of boilerplate + -- pattern matching. + ,pattern Empty + ,pattern Chunk + ,pattern Compose + -- __ Combinators + -- | The following combinators are the interface to + -- holey expressions. First, there are two + -- combinators for holes: + -- + -- 1. Empty holes: + -- + -- >>> empty 1 + -- + -- 2. Filled holes: + -- + -- >>> filled 1 f + -- + -- where @f@ is some hole filling of type @filling@. + -- There are no constraints on how many times a hole + -- index can occur. However, a hole is either filled + -- or empty, but not both. + -- + -- Secondly, we have a combinator for chunks of + -- @text@: + -- + -- >>> chunk t + -- + -- where @t@ is some element of @text@. + -- + -- Then we build larger expressions using + -- composition: + -- + -- >>> e1 +> e2 +> ... +> ei + -- + -- for some expressions @e1,e2,...,ei@. This + -- composition is associative, but non-commutative. + ,empty + ,filled + ,chunk + ,(+>) + -- __* Plugging Holes + -- | Holes can be either filled or plugged. The + -- former simply places a value of type @filling@ + -- into the hole, but doesn't replace the hole. The + -- latter, replaces the hole altogether with the + -- value. There are two combinators for filling a + -- hole: a destructive one @update@, and a + -- non-destructive one @place@. Finally, + -- @plugAll@ plugs every hole the function is defined for. + ,plug + ,plugAll + ,update + ,place + -- __* Hole Properties + ,unfilledHoles + ,filledHoles + ,numberOfUnfilledHoles + ,numberOfFilledHoles + -- __* Equality + ,(==>) + -- __* Useful Helpers + ,showAST + ,sepHExpsBy + ,betweenHExp + ,chunkToText) where + +import Data.HoleyExp.HExpInternal diff --git a/src/Data/HoleyExp/HExpInternal.hs b/src/Data/HoleyExp/HExpInternal.hs new file mode 100644 --- /dev/null +++ b/src/Data/HoleyExp/HExpInternal.hs @@ -0,0 +1,515 @@ +{-| +Module : HExpInternal +Description : Internal framework for creating holey expressions +Copyright : (c) Harley Eades, 2026 + (c) W⋊B, 2026 +Maintainer : harley.eades@gmail.com +-} +{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} +{-# LANGUAGE TypeAbstractions #-} +{-# LANGUAGE FlexibleContexts #-} +module Data.HoleyExp.HExpInternal where +import Prelude hiding (null) +import Data.Text (Text) +import Data.Text qualified as DT +import Data.Maybe (isNothing) +import Data.String (IsString (..)) +import Data.List qualified as L +import Data.NatMap (NatMap + ,Natural + ,(!?) + ,keys + ,insert + ,(!) + ,delete + ,singleton) +import Data.NatMap qualified as M + +-- | Holes are either empty or filled; thus, a hole's properties consists of a +-- pair of a list of natural numbers designating the set of empty holes and a +-- natural-number map (t'NatMap') that assigns fillings of type @f@ to hole +-- indices. +type HoleProps f = ([Natural],NatMap f) + +-- | A hole that can be filled with a filling of type @f@ is a natural number +-- and a set of hole properties (t`HoleProps`). +type Hole f = (Natural,HoleProps f) + +-- ** Hole Patterns + +-- | Pattern synonym for empty holes. +pattern EmptyHole :: Natural -> HoleProps f -> Hole f +pattern EmptyHole i hlsProps <- (decomposeEmptyHole -> Just (i,hlsProps)) + +-- | Pattern synonym for filled holes. +pattern FilledHole :: Natural -> f -> HoleProps f -> Hole f +pattern FilledHole i f hlsProps <- (decomposeFilledHole -> Just (i,Just f,hlsProps)) + +-- | Pattern synonym for undefined holes. These are holes which are not currently used +-- in the expression; and thus, are neither free nor empty. +pattern UndefHole :: Natural -> HoleProps f -> Hole f +pattern UndefHole i hlsProps <- (decomposeUndefHole -> Just (i,hlsProps)) + +-- | Determines if the input hole index @i@ is the index of an empty hole. +decomposeEmptyHole :: (Natural, HoleProps f) -> Maybe (Natural, HoleProps f) +decomposeEmptyHole h@(i,hlsProps) | emptyHole i hlsProps = Just h + | otherwise = Nothing + +-- | Determines if the input hole index @i@ is the index of a filled hole. +decomposeFilledHole :: Hole f -> Maybe (Natural, Maybe f, HoleProps f) +decomposeFilledHole (i,hlsProps@(_,fhls)) | filledHole i hlsProps = Just (i,fhls !? i,hlsProps) + | otherwise = Nothing + +-- | Determines if the input hole index @i@ is neither an empty hole or a filled +-- hole; thus, is undefined in the expression. +decomposeUndefHole :: Hole f -> Maybe (Hole f) +decomposeUndefHole h | isNothing (decomposeEmptyHole h) && isNothing (decomposeFilledHole h) = Just h + | otherwise = Nothing + +{-# COMPLETE EmptyHole, FilledHole, UndefHole #-} + +-- | Tests to see if a hole index exist in the given hole properties. +isFreshHoleIndex :: Natural -- ^ Hole index + -> HoleProps f -- ^ Hole properties + -> Bool +isFreshHoleIndex h holeProps = not $ filledHole h holeProps || emptyHole h holeProps + +-- | Decides if the given hole index is empty with respect to the given hole +-- properties. This returns `True` when the given index is in the set of +-- empty holes, but is not defined in the map of filled holes. +emptyHole :: Natural -> HoleProps f -> Bool +emptyHole i (hls,fhls) = i `elem` hls && not (i `elem` keys fhls) + +-- | Decides if the given hole index is filled with respect to the given hole +-- properties. This returns `True` when the given index is not in the set of +-- empty holes, but is defined in the map of filled holes. +filledHole :: Natural -> HoleProps f -> Bool +filledHole i (hls,fhls) = not (i `elem` hls) && i `elem` keys fhls + +-- | The hole properties with no defined holes. +emptyHoleProps :: HoleProps f +emptyHoleProps = ([], M.empty) + +-- | Adds a hole index and potential filling to the given hole properties. If +-- the given filling is @Nothing@ then the hole is assumed to be added as an +-- unfilled hole, otherwise it's added as a filled hole. The given index cannot +-- already exist in the hole properties. +updateFreshHolePropsWith + :: HoleProps text + -> (Natural,Maybe text) + -> HoleProps text +updateFreshHolePropsWith holeProps@(hls, fhls) (h, Nothing) | h `isFreshHoleIndex` holeProps = (h:hls,fhls) +updateFreshHolePropsWith holeProps@(hls, fhls) (h, (Just f)) | h `isFreshHoleIndex` holeProps = (hls,insert h f fhls) +updateFreshHolePropsWith holeProps (_,_) = holeProps + +-- | The underlying structure of t'HExp'. +data IHExp text where + IChunk :: text -> IHExp text + ICompose :: text -> Natural -> IHExp text -> IHExp text + +-- | An expression with pluggable holes. We do not expose the underlying +-- constructors in favor of the combinators. +data HExp text filling where + HExp :: IHExp text -- ^ Internal expression + -> HoleProps filling -- ^ Empty holes and hole-filling map + -> HExp text filling + +instance (TextLike text, HoleFilling text filling) => Show (HExp text filling) where + show :: HExp text filling -> String + show (HExp (IChunk t) _) = DT.unpack . toText $ t + show (HExp (ICompose prefix i rest) (emptyHoles, filledHoles)) + = (DT.unpack . toText $ prefix) + <> "$" <> show i <> "{" + <> (if i `elem` emptyHoles then "" else (DT.unpack . toText . (fillingToText @text) $ filledHoles ! i)) + <> "}" + <> show (HExp rest (emptyHoles, filledHoles)) + +-- * Combinators + +-- | Pattern synonym for the empty expression. +pattern Empty :: (Eq text, Monoid text) => HExp text filling +pattern Empty <- (null -> True) where + Empty = emptyExp + +-- | Decides if an expression corresponds to a chunk or not. +isChunk :: HExp text filling -> Maybe text +isChunk (HExp (IChunk s) ([],m)) | M.null m = Just s +isChunk _ = Nothing + +-- | Pattern synonym for expression chunk's. +pattern Chunk :: text -> HExp text filling +pattern Chunk s <- (isChunk -> Just s) + where + Chunk = chunk + +-- | Pattern synonym for the composition of holey expressions. +pattern Compose :: Monoid text => text -> (Natural,Maybe filling) -> HExp text filling -> HExp text filling +pattern Compose c h t <- (decompose -> Just (c, h, t)) + where + Compose = compose + +{-# COMPLETE Chunk, Compose #-} + +-- | Explicitly create a top-level composition expression. +compose :: Monoid text + => text -- ^ Prefix chunk + -> (Natural,Maybe filling) + -> HExp text filling -- ^ HExp branch + -> HExp text filling +compose c (i, Nothing) t = chunk c +> empty i +> t +compose c (i, Just f) t = chunk c +> filled i f +> t + +-- | Decompose an expression into the top-level compose. +decompose :: HExp text filling + -> Maybe (text, (Natural,Maybe filling), HExp text filling) +decompose (HExp (ICompose c i t') hlsProps) = + case (i,hlsProps) of + (EmptyHole _ (uh,fh)) -> Just (c, (i,Nothing), HExp t' (i `L.delete` uh,fh)) + (FilledHole _ f (uh,fh)) -> Just (c, (i,Just f), HExp t' (uh,i `delete` fh)) + (UndefHole _ _) -> Nothing +decompose _ = Nothing + +-- | Decide if an element of a monoid is the unit. +isUnit :: (Eq m, Monoid m) + => m + -> Bool +isUnit m | m == mempty = True + | otherwise = False + +-- | Test to see if an expression is empty. +null :: (Eq text, Monoid text) => HExp text filling -> Bool +null (HExp (IChunk c) ([],m)) | isUnit c && M.null m = True +null _ = False + +-- | Equality of t`IHExp`. Holes are ignored. +(>==>) :: Eq text + => IHExp text + -> IHExp text + -> Bool +(IChunk chk1) >==> (IChunk chk2) = chk1 == chk2 +(ICompose chk1 _ r1) >==> (ICompose chk2 _ r2) = chk1 == chk2 && r1 >==> r2 +_ >==> _ = False + +instance (Eq text, Eq filling) => Eq (HExp text filling) where + (==) :: HExp text filling -> HExp text filling -> Bool + (==) = (==>) + +-- | Equality of holey expressions. Two holey expressions are considered equivalent if and only +-- if they differ by hole labels only. The contents of filled holes are included +-- in the decision. +(==>) :: (Eq text,Eq filling) + => HExp text filling + -> HExp text filling + -> Bool +(HExp t1 (hls1,fhls1)) ==> (HExp t2 (hls2,fhls2)) = t1 >==> t2 && hls1 == hls2 && fhls1 == fhls2 + +-- | An empty hole. +empty :: Monoid text + => Natural -- ^ Hole index + -> HExp text filling +empty i = flip HExp ([i],M.empty) $ ICompose mempty i (IChunk mempty) + +-- | A hole with a filling. +filled :: Monoid text + => Natural -- ^ Hole index + -> filling -- ^ Hole filling + -> HExp text filling +filled i f + = flip HExp ([],singleton i f) $ (ICompose mempty i (IChunk mempty)) + +-- | A chunk is a constant; it's helpful to think of these as a piece of +-- subtext. +chunk :: text -- ^ Constant + -> HExp text filling +chunk = flip HExp ([],M.empty) . IChunk + +-- | The empty expression. +emptyExp :: Monoid text + => HExp text filling +emptyExp = chunk mempty + +-- | Composition of `IHExp`. +(>+>) :: Semigroup text + => IHExp text + -> IHExp text + -> IHExp text +(IChunk chk1) >+> (IChunk chk2) = IChunk $ chk1 <> chk2 +(IChunk chk) >+> (ICompose p h r) = ICompose (chk <> p) h r +(ICompose p h r) >+> t = ICompose p h $ r >+> t + +-- | Composition of holey expressions. +(+>) :: Semigroup text + => HExp text filling + -> HExp text filling + -> HExp text filling +(HExp t1 (ufhs1,fhs1)) +> (HExp t2 (ufhs2,fhs2)) + = HExp (t1 >+> t2) (ufhs1 `L.union` ufhs2,fhs1 `M.union` fhs2) + +instance Semigroup text => Semigroup (HExp text filling) where + (<>) :: HExp text filling -> HExp text filling -> HExp text filling + (<>) = (+>) + +instance Monoid text => Monoid (HExp text filling) where + mempty :: HExp text filling + mempty = emptyExp + + mconcat :: [HExp text filling] -> HExp text filling + mconcat = foldr (<>) emptyExp + +instance Functor (HExp text) where + fmap :: (filling1 -> filling2) -> HExp text filling1 -> HExp text filling2 + fmap f (HExp t (hls,fhls)) = HExp t $ (hls,M.map f fhls) + +instance IsString text => IsString (HExp text filling) where + fromString :: String -> HExp text filling + fromString = Chunk . fromString + +-- | A type is "text like" if it can be converted into t`Text`. +class TextLike text where + toText :: text -> Text + +instance TextLike Text where + toText :: Text -> Text + toText = id + +instance TextLike String where + toText :: String -> Text + toText = DT.pack + +instance TextLike Double where + toText :: Double -> Text + toText = DT.show + +instance TextLike Int where + toText :: Int -> Text + toText = DT.show + +instance TextLike Integer where + toText :: Integer -> Text + toText = DT.show + +-- | Convert a holey expression's AST into a `Text`. The `Show` instance for +-- t`HExp` is set to pretty print, but for debugging it is sometimes useful to +-- see the raw AST. +showAST :: (TextLike text, TextLike filling) => HExp text filling -> Text +showAST (HExp (IChunk x) _) = "IChunk " <> (toText x) +showAST (HExp (ICompose p i r) hls@(_,fhls)) = "ICompose " <> (toText p) <> " " <> (DT.show i) <> " (" <> (DT.show . (fmap toText) $ fhls !? i) <> ") (" <> (showAST (HExp r hls)) <> ")" + +-- | Get the list of unfilled-hole indices present in an expression. +-- Time complexity: \( \mathcal{O}(0) \) +unfilledHoles :: HExp text filling -- ^ HExp + -> [Natural] +unfilledHoles (HExp _ (hls,_)) = hls + +-- | Get the list of filled-hole indices present in an expression. +-- Time complexity: \( \mathcal{O}(n) \) +filledHoles :: HExp text filling -- ^ HExp + -> [Natural] +filledHoles (HExp _ (_,fhls)) = keys fhls + +-- | Get the filling of a hole. Returns @Nothing@ when the hole doesn't exist. +fillingInHole :: HExp text filling -- ^ HExp + -> Natural -- ^ Hole index + -> Maybe filling +fillingInHole (HExp _ (_,fhls)) h = fhls !? h + +-- | Get the number of unfilled holes in an expression. +-- Time complexity: \( \mathcal{O}(n) \) +numberOfUnfilledHoles :: HExp text filling -- ^ HExp + -> Int +numberOfUnfilledHoles (HExp _ (hls,_)) = length hls + +-- | Get the number of filled holes in an expression. +-- Time complexity: \( \mathcal{O}(n) \) +numberOfFilledHoles :: HExp text filling -- ^ HExp + -> Int +numberOfFilledHoles (HExp _ (_,fhls)) = M.size fhls + +-- | Decide if an expression is filled or not. +-- Time complexity: \(\mathcal{O}(n)\) +isFilled :: HExp text filling -> Bool +isFilled t = numberOfUnfilledHoles t == 0 + +-- | Convert an expression with no holes, a chunk, into a text. +-- Time complexity: \( \mathcal{O}(0) \) +chunkToText :: HExp text filling + -> Maybe text +chunkToText (HExp (IChunk c) ([],fhls)) | M.null fhls = Just c +chunkToText _ = Nothing + +-- | Like `update`, but doesn't update an already filled hole's value. +place :: HExp text filling + -> Natural -- ^ Hole index to plug + -> filling -- ^ Hole filling + -> Maybe (HExp text filling) +place t@(HExp it hlsProps) i c = + case (i,hlsProps) of + EmptyHole _ (hls,fhls) -> Just $ HExp it $ (i `L.delete` hls,insert i c fhls) + FilledHole _ _ _ -> Just $ t + UndefHole _ _ -> Nothing + +-- | Update a hole adding or removing a filling. If the hole is already filled, +-- then the filling is updated with the new value. Filling a hole doesn't +-- replace the hole, but simply puts the input @filling@ inside the hole. +-- Returns @Nothing@ if the hole doesn't exist. If the input filling is +-- `Nothing`, then the hole is emptied. The complexity of this operation +-- is \(\mathcal{O}(\max(n_0,\min(n_1,W)))\), where \(n_0\) is the number of +-- empty holes, and \(n_1\) is the number of filled holes with a max of \(W\) +-- the number of bits in an `Int` (32 or 64). +update :: HExp text filling + -> Natural -- ^ Hole index to fill + -> Maybe filling -- ^ Hole filling + -> Maybe (HExp text filling) +update (HExp t hlsProps) i Nothing = + case (i,hlsProps) of + EmptyHole _ _ -> Just $ HExp t hlsProps + FilledHole _ _ (hls,fhls) -> Just $ HExp t (i `L.insert` hls,delete i fhls) + UndefHole _ _ -> Nothing + +update (HExp t hlsProps) i (Just c) = + case (i,hlsProps) of + EmptyHole _ (hls,fhls) -> Just $ HExp t (i `L.delete` hls,insert i c fhls) + FilledHole _ _ (hls,fhls) -> Just $ HExp t (hls,insert i c fhls) + UndefHole _ _ -> Nothing + +-- | Plug an unfilled hole in an expression with some filling. Returns @Nothing@ when +-- the hole index doesn't exist in the expression or is filled, otherwise returns +-- an expression with the hole plugged. Plugging a hole replaces the hole with the +-- value unlike `update`. +plugHoleI :: Semigroup text + => (filling -> text) + -> IHExp text + -> [Natural] -- ^ List of unfilled holes + -> Natural -- ^ Hole index to plug + -> filling -- ^ Text to replace hole + -> Maybe (IHExp text) +plugHoleI toText (ICompose p h (IChunk s)) hls i c + | i == h && h `elem` hls = Just $ IChunk $ p <> toText c <> s +plugHoleI toText (ICompose p h r@(ICompose p' h' s)) hls i c + | i == h && h `elem` hls = Just $ ICompose (p <> toText c <> p') h' s + | otherwise = do r' <- plugHoleI toText r hls i c + Just $ ICompose p h r' +plugHoleI _ _ _ _ _ = Nothing + +-- | Plug an unfilled hole in an expression with some filling. Returns @Nothing@ when +-- the hole index doesn't exist in the expression or is filled, otherwise returns +-- an expression with the hole plugged. Plugging a hole replaces the hole with the +-- value unlike `update`. +plug :: HoleFilling text filling + => HExp text filling + -> Natural -- ^ Hole index to plug + -> filling -- ^ Text to replace hole + -> Maybe (HExp text filling) +plug (HExp t@(ICompose _ _ _) (hls,fhls)) i c | i `elem` hls = + do t' <- plugHoleI fillingToText t hls i c + pure $ HExp t' (i `L.delete` hls,fhls) +plug _ _ _ = Nothing + +-- | Plugs every hole in an expression with no filled holes using the given plug +-- function. If the plug function is defined for every hole in the input +-- expression, then this function guarantees an expression with no holes (a constant). +plugAllI + :: Semigroup text + => (filling -> text) + -> [Natural] + -> (Natural -> Maybe filling) -- ^ Plug function. + -> IHExp text -- ^ IHExp to plug. + -> Maybe (IHExp text) +plugAllI toText hls f (ICompose chk i r) | i `elem` hls = do + chk' <- f i + IChunk chk'' <- plugAllI toText hls f r + return . IChunk $ chk <> toText chk' <> chk'' +plugAllI _ _ _ (ICompose _ _ _) = Nothing +plugAllI _ _ _ t@(IChunk _) = return t + +-- | Plugs every hole in an expression with no filled holes using the given plug +-- function. If the plug function is defined for every hole in the input +-- expression, then this function guarantees an expression with no holes (a constant) is +-- returned. +plugAll :: HoleFilling text filling + => HExp text filling -- ^ HExp to plug + -> ([Natural] -> (Natural -> Maybe filling)) -- ^ Plug function + -> Maybe text +plugAll (HExp t (hls,fhls)) f | M.null fhls = + case plugAllI fillingToText hls (f hls) t of + Just (IChunk c) -> Just c + _ -> Nothing +plugAll _ _ = Nothing + +-- | In the simplest form, a type @filling@ is a hole filling if it +-- can be converted into @text@, because values of type @filling@ will +-- ultimately plug the hole they are filling. Optionally, a parser from t`Text` +-- into @filling@ can be declared as well. This makes it easier to plug a custom +-- parser in for @text@ making use of the existing parsers for the various +-- instances of t`HExp`. +class (Monoid text,Eq filling) => HoleFilling text filling where + fillingToText :: filling -> text + + parseFilling :: Maybe (Text -> Either Text filling) + parseFilling = Nothing + +instance HoleFilling Text String where + fillingToText :: String -> Text + fillingToText = DT.pack + + parseFilling :: Maybe(Text -> Either Text String) + parseFilling = Just $ Right . DT.unpack + +instance HoleFilling String Text where + fillingToText :: Text -> String + fillingToText = DT.unpack + + parseFilling :: Maybe(Text -> Either Text Text) + parseFilling = Just $ Right + +-- | This class is used to define generic combinators on holey expressions. Simply, this +-- is the class of types that can be converted into a t`HExp`. +class HoleFilling text filling => ToHExp text filling a where + toHExp :: a -> HExp text filling + +-- | Used to add `HoleFilling` constraints to functions that don't take in an +-- explicit t`HExp`. This is useful for writing generic functions. +data Proxy filling r = Proxy { + runProxy :: r +} + +instance (ToHExp text filling a) => ToHExp text filling (Either (HExp text filling) a) where + toHExp :: Either (HExp text filling) a -> HExp text filling + toHExp (Left t) = t + toHExp (Right a) = toHExp a + +instance Monoid text => HoleFilling text () where + fillingToText :: () -> text + fillingToText () = mempty + +-- | Translates a list into an expression list where each expression in the input +-- list is separated by the input expression. +sepHExpsBy :: (ToHExp text filling a) + => HExp text filling -- ^ Separator + -> [a] -- ^ List of holey expressions + -> HExp text filling +sepHExpsBy _ [] = chunk mempty +sepHExpsBy _ [v] = toHExp v +sepHExpsBy sep (v:vs) = toHExp v +> sep +> sepHExpsBy sep vs + +-- | Add a prefix and suffix holey expressions to the given value. +betweenHExp :: (ToHExp text filling a) + => HExp text filling -- ^ Prefix expression + -> HExp text filling -- ^ Suffice expression + -> a -- ^ Value to be converted into an expression + -> HExp text filling +betweenHExp b a (toHExp->t) = b +> t +> a diff --git a/src/Data/HoleyExp/Text.hs b/src/Data/HoleyExp/Text.hs new file mode 100644 --- /dev/null +++ b/src/Data/HoleyExp/Text.hs @@ -0,0 +1,326 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-| +Module : Text +Description : Holey Expressions in Text +Copyright : (c) Harley Eades, 2026 + (c) W⋊B, 2026 +Maintainer : harley.eades@gmail.com + +This is the library for working with holey expressions in "Data.Text". + +If you are new to this library, it is recommended to first read over the start +of the base module "Data.HoleyExp.HExp" for an introduction to how holey +expressions work. + +Here we give a number of example holey-expressions. + +A simple example: + +>>> let t = (chunk "Today's Temperature: ") +> (hole 1) +> (chunk " high/") +> (hole 2) +> (chunk " low") :: HExp Text Double +>>> t +Today's Temperature: $1{} high/$2{} low + +>>> plugAll t $ \_ -> \i -> if i == 1 then Just 91.2 else if i == 2 then Just 87.0 else Nothing +Just "Today's Temperature: 91.2 high/87.0 low" + +The above is an example of an expression of type @HExp Text Double@ where +the first type is the type of constants which is what we are ultimately constructing a value of when all +holes are plugged, and the second type is the type of the filling we place in +the holes. + +A second way we can write the same expression using @OverloadedStrings@ is: + +>>> let t'' = "Today's Temperature: " <> (hole 1) <> " high/" <> (hole 2) <> " low" :: HExp Text Double +>>> t ==> t'' +True + +We can also add a filling to holes in an expression: + +>>> "Today's Temperature: " <> (filled 1 92.2) <> " high/" <> (filled 2 91.2) <> " low" :: HExp Text Double +Today's Temperature: $1{92.2} high/$2{91.2} low + +-} +module Data.HoleyExp.Text +(-- * Holey Expressions + -- | This module reexports the holey-expression base. + module Data.HoleyExp.HExp + -- * Text Combinators + ,Data.Text.Text + ,bracketHExp + ,braceHExp + -- ** Parsing + ,Parser + ,TParseError + ,hExpParser + ,parseHExp + ,varParser + -- *** Helpers + ,maybeParser + ,doubleQuotedParser + ,runParsecT + -- * Text Helpers + ,between + ,braces + ,brackets + ,prettyList + ,doubleQuote + ,prettyDouble) where + +import Data.HoleyExp.HExp + +import Data.Text (Text) +import Data.Text qualified as DT +import Data.Void (Void) +import Data.NatMap (Natural) +import Data.String (IsString (fromString)) +import Data.Char (isAsciiLower + ,isAlphaNum + ,isAscii) +import Data.Maybe (isNothing) +import Text.Megaparsec (ShowErrorComponent (..) + ,Parsec + ,ParseErrorBundle + ,ParsecT + ,MonadParsec (..) + ,parse + ,errorBundlePretty + ,runParserT + ,many + ,choice + ,satisfy + ,customFailure + ,some + ,(<|>) + ,atEnd + ,skipCount) +import Text.Megaparsec.Char (string + ,digitChar + ,char + ,space) +import Text.Megaparsec.Byte.Lexer (symbol) +import Text.Megaparsec qualified as MT +import Data.List qualified as L + +-- | Combinator for running a `Parsec` parser with a `Text` input stream and +-- custom error messages. +runParsec :: ShowErrorComponent e => Parsec e Text b -> Text -> Either Text b +runParsec p s = case parse p "holey-expression" s of + Left bundle -> Left . DT.pack $ errorBundlePretty bundle + Right t -> Right t + +-- | Combinator for running a `ParsecT` parser with a `Text` input stream and +-- custom error messages. +runParsecT + :: (Monad m, ShowErrorComponent e) + => (m (Either (ParseErrorBundle Text e) a) -> (Either (ParseErrorBundle Text e) a)) + -> ParsecT e Text m a + -> Text + -> Either Text a +runParsecT eval p s = + case eval (runParserT p "" s) of + Left bundle -> Left . DT.pack $ errorBundlePretty bundle + Right t -> Right t + +instance HoleFilling Text Text where + fillingToText :: Text -> Text + fillingToText = id + + parseFilling :: Maybe (Text -> Either Text Text) + parseFilling = Just $ runParsec textFillingParser + where + textFillingParser = DT.pack <$> many charTextFillingParser + + charTextFillingParser :: Parsec TParseError Text Char + charTextFillingParser = choice [ + satisfy (\c -> c /= '{' && c /= '}' && c /= '\\'), + escapeCharTextFillingParser + ] + + escapeCharTextFillingParser :: Parsec TParseError Text Char + escapeCharTextFillingParser = do + skip (string "\\") + satisfy (`elem` ['{','}','\\']) + +instance HoleFilling Text Int where + fillingToText :: Int -> Text + fillingToText = DT.show + + parseFilling :: Maybe (Text -> Either Text Int) + parseFilling = Just . runParsec @Void $ read <$> many digitChar + +instance HoleFilling Text Double where + fillingToText :: Double -> Text + fillingToText = toText + + parseFilling :: Maybe (Text -> Either Text Double) + parseFilling = Just . runParsec @Void $ p + where + p :: Parsec Void Text Double + p = do d1 <- many digitChar + c <- string "." >>= pure . DT.unpack + d2 <- many digitChar + pure . read $ d1 <> c <> d2 + +-- | Parses a variable as a string. Variables must begin with a lower-case ascii +-- letter, and then contain ascii alpha-numeric characters. +varParser :: Parser String +varParser = do + -- Make sure we start with a lower-case ascii letter. + c <- maybeParser . lookAhead $ takeWhile1P Nothing isAsciiLower + if isNothing c + then customFailure $ HFExpParseError "variables must begin with a lower-case letter" + else DT.unpack <$> takeWhile1P Nothing (\c -> isAlphaNum c && isAscii c) + +-- | Add brackets `[]` around the input expressions. +bracketHExp :: (ToHExp Text filling a) => a -> HExp Text filling +bracketHExp = betweenHExp (chunk "[") (chunk "]") + +-- | Add braces `{}` around the input expressions. +braceHExp :: (ToHExp Text filling a) => a -> HExp Text filling +braceHExp = betweenHExp (chunk "{") (chunk "}") + +-- | Parse a holey expression in t`Text`. +parseHExp :: HoleFilling Text filling => Text -> Either Text (HExp Text filling) +parseHExp s = + case parse hExpParser "holey-expression" s of + Left bundle -> Left . DT.pack $ errorBundlePretty bundle + Right t -> Right t + +-- | Parse errors + +data TParseError + = HFExpParseError Text + deriving (Eq,Ord,Show) + +instance ShowErrorComponent TParseError where + showErrorComponent :: TParseError -> String + showErrorComponent err = "holy-expression-parser: " <> showErrorComponent' err + where + showErrorComponent' (HFExpParseError err) = DT.unpack err + +-- | Type of the parsers that operate on a stream of t`Text`. +type Parser = Parsec TParseError Text + +-- | Parse a hole index (`Natural`). +holeIndexParser :: Parser Natural +holeIndexParser = do + ds <- some digitChar + pure . read $ ds + +-- | Parser combinator that attempts to parse using the input parser, and if it +-- fails, returns @Nothing@. +maybeParser :: MonadParsec e s f => f a -> f (Maybe a) +maybeParser p = try (Just <$> p) <|> pure Nothing + +-- | Parse a hole's filling which must be escaped properly. +holeFillingParser :: HoleFilling Text filling => Parser (Maybe filling) +holeFillingParser = maybe n p (parseFilling @Text) + where + -- If there is no filling, then skip the braces. + n = (skip $ string "{}") >> pure Nothing + + p :: (Text -> Either Text filling) -> Parser (Maybe filling) + p expParser = do + f <- MT.between (char '{') (char '}') $ many $ hExpCharParser True + if L.null f + then pure Nothing + else do let e = expParser . DT.pack $ f + case e of + Left err -> customFailure $ HFExpParseError err + Right f' -> pure . Just $ f' + +-- | Parse a `Data.HExp.Hole`. That is, a pair of a hole index and a filling. +holeParser :: HoleFilling Text filling => Parser (Natural, Maybe filling) +holeParser = do + skip (string "$") + i <- holeIndexParser + f <- holeFillingParser + pure $ (i, f) + +-- | Parse a `Chunk`. +chunkParser :: IsString text => Parser text +chunkParser = fromString <$> many (hExpCharParser False) + +-- | Parse an expression either as a `Chunk` or a `Compose`. +hExpParser :: HoleFilling Text filling => Parser (HExp Text filling) +hExpParser = do + mc <- chunkParser + isEnd <- atEnd + if isEnd + then pure . Chunk $ mc + else do h <- holeParser + t <- hExpParser + pure $ Compose mc h t + +-- | Parse an expression character. These are any unicode character where the +-- characters +-- > ["$","{","}","\\"] +-- are escaped when parsing a hole's filling, +-- otherwise just @'$'@ needs to be escaped. +hExpCharParser :: Bool -> Parser Char +hExpCharParser filling = choice [ + satisfy (\c -> c /= '$' && c /= '\'' && (if filling then c /= '{' && c /= '}' else True) && c /= '\\'), + escapedHExpCharParser + ] + +-- | Parsed an escaped character; one of, +-- > ["\\$"","\\{"","\\}","\\\\"] +-- . +escapedHExpCharParser :: Parser Char +escapedHExpCharParser = do + skipCount 1 (char '\\') + satisfy (\c -> c == '$' || c == '{' || c == '}' || c == '\'') + +-- * Helper parsers + +-- | Parse a double-quoted output of the input parser. +doubleQuotedParser :: Ord e => Parsec e Text a -> Parsec e Text a +doubleQuotedParser = MT.between (string "\"") (tok "\"") + +-- * Textens + +-- | Parse a Texten (unicode character) +-- Consumes whitespace *after* the parsed Texten. +tok :: Ord e => Text -> Parsec e Text Text +tok = symbol space + +-- | Parse and throw away the symbol parsed by the input Texten +skip :: Parsec e Text Text -> Parsec e Text () +skip = skipCount 1 + +-- | Add a prefix and a suffix to the input text. +between :: Text -> Text -> Text -> Text +between b a t = b <> t <> a + +-- | Add braces around the input text. +braces :: Text -> Text +braces = between (DT.singleton '{') (DT.singleton '}') + +-- | Add brackets around the input text. +brackets :: Text -> Text +brackets = between (DT.singleton '[') (DT.singleton ']') + +-- | Convert the input list into a comma separated list in a human-readable +-- format. This is essentially `Data.Text.show`, but without the quoting of +-- literals. +prettyList :: (a -> Text) -> [a] -> Text +prettyList f = brackets . aux + where + aux [] = DT.Empty + aux [x] = f x + aux (x:xs) = f x <> ", " <> aux xs + +-- | Convert the input double into a human-readable format. This drops the +-- decimal point when the input is a whole number. +prettyDouble :: Double -> Text +prettyDouble (DT.show->n) = + case DT.break (=='.') n of + (ds,".0") -> ds + _ -> n + +-- | Double quote the input text. +doubleQuote :: DT.Text -> DT.Text +doubleQuote = between (DT.singleton '\"') (DT.singleton '\"') diff --git a/src/Data/NatMap.hs b/src/Data/NatMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/NatMap.hs @@ -0,0 +1,114 @@ +{-| +Module : NatMap +Description : Map with natural number keys +Copyright : (c) Harley Eades, 2026 + (c) W⋊B, 2026 +Maintainer : harley.eades@gmail.com + +This is a simple wrapper around `Data.IntMap.Lazy.IntMap` restricting the keys to the +natural numbers. +-} +module Data.NatMap (-- * Map type + NatMap + -- * Natural numbers + ,Natural + ,naturalToInt + ,intToNatural + -- * Construction + ,empty + ,singleton + -- ** From unordered lists + ,fromList + -- * Insertion + ,insert + -- * Deletion and updating + ,delete + -- * Query + -- ** Lookup + ,(!?) + ,(!) + -- ** Size + ,null + ,size + -- * Combine + -- ** Union + ,union + -- * Traversal + -- ** Map + ,Data.NatMap.map + -- * Conversion + ,keys) where + +import GHC.Natural (Natural) +import Data.IntMap.Lazy (IntMap) +import Data.IntMap.Lazy qualified as M +import Prelude hiding (null) + +-- | A map of natural numbers to values @f@. +type NatMap f = IntMap f + +-- | Convert a natural number into an integer (`Int`). +naturalToInt :: Natural -> Int +naturalToInt = fromInteger . toInteger + +-- | Convert an integer (`Int`) into a natural number. +intToNatural :: Int -> Natural +intToNatural = fromInteger . toInteger + +-- | Insert a new key/value pair in the map. If the key is already present in +-- the map, the associated value is replaced with the supplied value. See +-- `Data.IntMap.Lazy.insert`. +insert :: Natural -> f -> NatMap f -> NatMap f +insert (naturalToInt->k) = M.insert k + +-- | Find the value at a key. Returns Nothing when the element can not be found. +-- See `(Data.IntMap.Lazy.!?)`. +(!?) :: NatMap f -> Natural -> Maybe f +m !? (naturalToInt->k) = m M.!? k + +-- | Find the value at a key. Calls error when the element can not be found. See +-- `(Data.IntMap.Lazy.!)`. +(!) :: NatMap f -> Natural -> f +m ! (naturalToInt->k) = m M.! k + +-- | The empty map. +-- See `Data.IntMap.Lazy.empty`. +empty :: NatMap f +empty = M.empty + +-- | Is the map empty? +-- See `Data.IntMap.Lazy.null`. +null :: NatMap f -> Bool +null = M.null + +-- | A map of one element. See `Data.IntMap.Lazy.singleton`. +singleton :: Natural -> f -> NatMap f +singleton (naturalToInt->k)= M.singleton k + +-- | Delete a key and its value from the map. When the key is not a member of +-- the map, the original map is returned. See `Data.IntMap.Lazy.delete`. +delete :: Natural -> NatMap f -> NatMap f +delete (naturalToInt->k) = M.delete k + +-- | Return all keys of the map in ascending order. +keys :: NatMap f -> [Natural] +keys = M.foldrWithKey (\k _ r -> intToNatural k : r) [] + +-- | Create a map from a list of key/value pairs. +fromList :: [(Natural, a)] -> IntMap a +fromList = M.fromList . Prelude.map (\(k,v) -> (naturalToInt k,v)) + +-- | The (left-biased) union of two maps. It prefers the first map when +-- duplicate keys are encountered. +-- See `Data.IntMap.Lazy.union`. +union :: NatMap a -> NatMap a -> NatMap a +union = M.union + +-- | Map a function over all values in the map. +map :: (f1 -> f2) -> IntMap f1 -> IntMap f2 +map = M.map + +-- | Number of elements in the map. +-- See `Data.IntMap.Lazy.size`. +size :: NatMap f -> Int +size = M.size diff --git a/test/Data/HoleyExp/HExpInternalSpec.hs b/test/Data/HoleyExp/HExpInternalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/HoleyExp/HExpInternalSpec.hs @@ -0,0 +1,103 @@ +{-| +Module : HExpInternalSpec +Description : Testing spec for the holey expressions API +Copyright : (c) Harley Eades, 2026 + (c) W⋊B, 2026 +Maintainer : harley.eades@gmail.com + +Various properties of the holey-expressions API. +-} +module Data.HoleyExp.HExpInternalSpec (spec) where + +import Data.HoleyExp.HExpInternal +import Data.HoleyExp.Text +import Test.QuickCheck.HExp () + +import Test.Hspec +import Test.Helpers (parseTest) +import Test.QuickCheck (Property + ,Testable (property)) +import Test.Hspec.QuickCheck (prop) +import Test.Helpers (UnitTest(..) + ,test_case) + +spec :: Spec +spec = do + describe "QuickCheck properties:" $ do + describe "composition" $ do + prop "associativity" $ + prop_associativeCompose + prop "identity" $ + prop_identityCompose + describe "Unit Tests:" $ do + describe "Parsing:" $ do + describe "Holes:" $ do + test_case "no index" test_parseFail1 + test_case "negative index" test_parseFail2 + test_case "no opening brace" test_parseFail3 + test_case "no closing brace" test_parseFail4 + test_case "non-escaped curly brace" test_parseFail5 + test_case "non-escaped backslash" test_parseFail6 + test_case "filling in unit hole" test_parseFail7 + +prop_associativeCompose + :: HExp Text Text + -> HExp Text Text + -> HExp Text Text + -> Property +prop_associativeCompose t1 t2 t3 = property $ + t1 +> (t2 +> t3) == (t1 +> t2) +> t3 + +prop_identityCompose + :: HExp Text Text + -> Property +prop_identityCompose t = property $ + (emptyExp +> t) == t && (t +> emptyExp) == t + +testParseHExp :: Parser (HExp Text Text) +testParseHExp = hExpParser + +testParseUnitHExp :: Parser (HExp Text ()) +testParseUnitHExp = hExpParser + +test_parseFail1 :: UnitTest (Maybe (HExp Text Text)) +test_parseFail1 = UnitTest { + test_result=parseTest testParseHExp "foo${a}" + ,test_output=Nothing + } + +test_parseFail2 :: UnitTest (Maybe (HExp Text Text)) +test_parseFail2 = UnitTest { + test_result=parseTest testParseHExp "foo$-1{a}" + ,test_output=Nothing + } + +test_parseFail3 :: UnitTest (Maybe (HExp Text Text)) +test_parseFail3 = UnitTest { + test_result=parseTest testParseHExp "foo$1a}bar" + ,test_output=Nothing + } + +test_parseFail4 :: UnitTest (Maybe (HExp Text Text)) +test_parseFail4 = UnitTest { + test_result=parseTest testParseHExp "foo$1{abar" + ,test_output=Nothing + } + +test_parseFail5 :: UnitTest (Maybe (HExp Text Text)) +test_parseFail5 = UnitTest { + test_result=parseTest testParseHExp "foo$1{{a}bar" + ,test_output=Nothing + } + +test_parseFail6 :: UnitTest (Maybe (HExp Text Text)) +test_parseFail6 = UnitTest { + test_result=parseTest testParseHExp "foo$1{\\a}bar" + ,test_output=Nothing + } + +test_parseFail7 :: UnitTest (Maybe (HExp Text ())) +test_parseFail7 = UnitTest { + test_result=parseTest testParseUnitHExp "foo$1{aa}bar" + ,test_output=Nothing + } diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Test/Helpers.hs b/test/Test/Helpers.hs new file mode 100644 --- /dev/null +++ b/test/Test/Helpers.hs @@ -0,0 +1,53 @@ +{-| +Module : Helpers +Description : Useful helpers for unit testing +Copyright : (c) Harley Eades, 2026 + (c) W⋊B, 2026 +Maintainer : harley.eades@gmail.com + +-} +module Test.Helpers (UnitTest(..) + ,test_case + ,testParser + ,testParseFile + ,parseTest) where + +import Test.Hspec +import Text.Megaparsec (ParsecT + ,ParseErrorBundle + ,parse + ,Parsec) +import Data.Maybe (isJust) +import Data.Either.Extra (eitherToMaybe) + +-- | The type of a unit test corresponds to a pair of an output value and an +-- expected result. +data UnitTest a = UnitTest { + test_output :: a -- ^ Output of a computation + ,test_result :: a -- ^ Expected result of the test +} + +parseTest :: Parsec e t a -> t -> Maybe a +parseTest p = eitherToMaybe . flip parse "" p + +testParser :: (ParsecT e t m a -> t -> Either (ParseErrorBundle t e) a) + -> ParsecT e t m a + -> t + -> Maybe a +testParser runParser p = eitherToMaybe . runParser p + +-- | Simply, did it parse? +testParseFile :: (ParsecT e t m a -> t -> Either (ParseErrorBundle t e) a) + -> ParsecT e t m a + -> t + -> UnitTest Bool +testParseFile runParser p t = UnitTest { + test_output = isJust $ testParser runParser p t + ,test_result = True + } + +test_case :: (Show a, Eq a) + => String + -> UnitTest a + -> SpecWith () +test_case label t = it label $ (test_output t) `shouldBe` (test_result t) diff --git a/test/Test/QuickCheck/HExp.hs b/test/Test/QuickCheck/HExp.hs new file mode 100644 --- /dev/null +++ b/test/Test/QuickCheck/HExp.hs @@ -0,0 +1,58 @@ +{-| +Module : HExp +Description : Generation of random holey expressions +Copyright : (c) Harley Eades, 2026 + (c) W⋊B, 2026 +Maintainer : harley.eades@gmail.com + +Includes a generator for QuickCheck to randomly generate holey expressions to be +used for property-based testing. +-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeAbstractions #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +module Test.QuickCheck.HExp + (genHExp) where + +import GHC.TypeLits (Natural) +import Test.QuickCheck (Gen + ,Arbitrary (arbitrary) + ,generate + ,frequency + ,sized) +import Test.QuickCheck.Instances.Text () +import Test.QuickCheck.Instances.Natural () +import Data.Functor.Identity (Identity) + +import Data.HoleyExp.HExpInternal +import Data.Text (Text) +import qualified Data.IntMap as M +import Data.Maybe (isJust, isNothing) +import Data.IntMap (keys, IntMap) + +genChunk :: Arbitrary text => Gen (HExp text filling) +genChunk = chunk <$> arbitrary + +genHoleFilling :: Arbitrary filling => Gen (Maybe filling) +genHoleFilling @filling = sized $ \n -> + frequency + [ (1, pure Nothing), + (n, (arbitrary :: Gen filling) >>= (pure . Just)) + ] + +genHExpNat :: (Arbitrary text, Arbitrary filling) => Natural -> Gen (HExp text filling) +genHExpNat 0 = genChunk +genHExpNat @text n = do (HExp t holeProps) <- genHExpNat $ n - 1 + h <- arbitrary :: Gen Natural + f <- genHoleFilling + c <- arbitrary :: Gen text + let t' = ICompose c h t + pure $ HExp t' $ holeProps `updateFreshHolePropsWith` (h,f) + +genHExp :: (Arbitrary text, Arbitrary filling) => Gen (HExp text filling) +genHExp = arbitrary >>= genHExpNat + +instance (Arbitrary text, Arbitrary filling) => Arbitrary (HExp text filling) where + arbitrary :: Gen (HExp text filling) + arbitrary = genHExp