diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for diff-loc + +## 0.1.0.0 -- 2022-12-10 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2022 Li-yao Xia + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,81 @@ +# *diff-loc*: Map file locations across diffs [![Hackage](https://img.shields.io/hackage/v/diff-loc.svg)](https://hackage.haskell.org/package/diff-loc) + +## Example + +You have a diff between two versions of a file. Given a source span +in one version, find the corresponding span in the other version. + +For example, here is a diff `d` between a source string `"abcdefgh"` and a target +string `"appcfgzzh"`, with deletions and insertions in the middle: + +``` + ab cdefg h +- b de ++ pp zz + appc fgzzh +``` + +Diffs are represented by the type `Diff`. +Only locations and lengths are recorded, not the actual characters. + +``` +import DiffLoc +import DiffLoc.Unsafe (offset) + +d :: Diff N +d = addDiff (Replace 1 (offset 1) (offset 2)) -- at location 1, replace "b" (length 1) with "pp" (length 2) + $ addDiff (Replace 3 (offset 2) (offset 0)) -- at location 3, replace "de" with "" + $ addDiff (Replace 7 (offset 0) (offset 2)) -- at location 7, replace "" with "zz" + $ emptyDiff +-- N.B.: replacements should be inserted right to left, starting from 'emptyDiff'. +``` + +The span `s` of `"fg"` in the first string is an interval that starts at +location 5 and has length 2. + +``` +s :: Interval N +s = 5 :.. offset 2 +``` + +Illustration of the span: + +``` + a b c d e f g h +0 1 2 3 4 5 6 7 8 + ^f+g+ length 2 + ^ + start 5 +``` + +After applying the diff, the span has been shifted to location 4. + +``` +>>> mapDiff d (5 :.. offset 2) +Just (4 :.. offset 2) +``` + +``` + a p p c f g q q h +0 1 2 3 4 5 6 7 8 9 + ^f+g+ length 2 + ^ + start 4 +``` + +Conversely, we can map spans from the target string to the source string of the diff: + +``` +>>> comapDiff d (4 :.. offset 2) +Just (5 :.. offset 2) +``` + +If part of the input span is modified by the diff, there is no +corresponding output span. + +``` +>>> mapDiff d (1 :.. offset 2) -- "bc" contains "b" which is edited by the diff +Nothing +``` + +See the API documentation in [`DiffLoc`](https://hackage.haskell.org/package/diff-loc/docs/DiffLoc.html). diff --git a/diff-loc.cabal b/diff-loc.cabal new file mode 100644 --- /dev/null +++ b/diff-loc.cabal @@ -0,0 +1,46 @@ +cabal-version: 3.0 +name: diff-loc +version: 0.1.0.0 +synopsis: Map file locations across diffs +description: See "DiffLoc". +homepage: https://gitlab.com/lysxia/diff-loc +license: MIT +license-file: LICENSE +author: Li-yao Xia +maintainer: lysxia@gmail.com +copyright: 2022 Li-yao Xia +category: Data +build-type: Simple +extra-doc-files: CHANGELOG.md README.md + +common warnings + ghc-options: -Wall + +flag test + description: Enable test module. + default: False + manual: True + +library + import: warnings + exposed-modules: + DiffLoc + DiffLoc.Colline + DiffLoc.Diff + DiffLoc.Index + DiffLoc.Interval + DiffLoc.Shift + DiffLoc.Starter + DiffLoc.Unsafe + build-depends: + fingertree, + show-combinators, + base >=4.14 && < 4.18 + hs-source-dirs: src + default-language: Haskell2010 + if flag(test) + exposed-modules: + DiffLoc.Test + build-depends: + QuickCheck, + quickcheck-higherorder diff --git a/src/DiffLoc.hs b/src/DiffLoc.hs new file mode 100644 --- /dev/null +++ b/src/DiffLoc.hs @@ -0,0 +1,159 @@ +-- | +-- = Example +-- +-- You have a diff between two versions of a file. Given a source location +-- in one version, find the corresponding location in the other version. +-- +-- For example, here is a diff @d@ between a source string "abcdefgh" and a target +-- string "appcfgzzh", with deletions and insertions in the middle: +-- +-- > ab cdefg h +-- > - b de +-- > + pp zz +-- > appc fgzzh +-- +-- Diffs are represented by the type 'Diff'. +-- Only locations and lengths are recorded, not the actual characters. +-- +-- >>> :{ +-- let d :: Diff N +-- d = addDiff (Replace 1 (offset 1) (offset 2)) -- at location 1, replace "b" (length 1) with "pp" (length 2) +-- $ addDiff (Replace 3 (offset 2) (offset 0)) -- at location 3, replace "de" with "" +-- $ addDiff (Replace 7 (offset 0) (offset 2)) -- at location 7, replace "" with "zz" +-- $ emptyDiff +-- -- N.B.: replacements should be inserted right to left, starting from 'emptyDiff'. +-- :} +-- +-- The span @s@ of "fg" in the first string starts at location 5 and has length 2. +-- +-- >>> let s = 5 :.. offset 2 :: Interval N +-- +-- > a b c d e f g h +-- > 0 1 2 3 4 5 6 7 8 +-- > ^f+g+ length 2 +-- > ^ +-- > start 5 +-- +-- After applying the diff, the resulting span has been shifted to location 4. +-- +-- >>> mapDiff d (5 :.. offset 2) +-- Just (4 :.. offset 2) +-- +-- > a p p c f g q q h +-- > 0 1 2 3 4 5 6 7 8 9 +-- > ^f+g+ length 2 +-- > ^ +-- > start 4 +-- +-- Conversely, we can map spans from the target string to the source string of the diff: +-- +-- >>> comapDiff d (4 :.. offset 2) +-- Just (5 :.. offset 2) +-- +-- If part of the input span is modified by the diff, there is no +-- corresponding output span. +-- +-- >>> mapDiff d (1 :.. offset 2) -- "bc" contains "b" which is edited by the diff +-- Nothing +module DiffLoc + ( -- * API + + -- ** Overview + + -- | + -- @ + -- "DiffLoc.Diff" + -- +------------------------------------------------+ + -- | data 'Diff' r | + -- | 'addDiff' :: r -> Diff r -> Diff r | + -- | 'mapDiff' :: Diff r -> Block r -> Block r | + -- +------------------------------------------------+ + -- | requires + -- v "DiffLoc.Shift" + -- ********************************************************************** + -- * class 'Shift' r * + -- * type 'Block' r * + -- * 'src', 'tgt' :: r -> Block r * + -- * 'shiftBlock', 'coshiftBlock' :: r -> Block r -> Maybe (Block r) * + -- * 'shiftR', 'coshiftR' :: r -> r -> Maybe r * + -- ********************************************************************** + -- ^ + -- | implements with + -- | r = 'Replace' p + -- | 'Block' r = 'Interval' p + -- | + -- | + -- | "DiffLoc.Interval" + -- +-------------------+ + -- | data 'Interval' p | + -- | data 'Replace' p | + -- +-------------------+ + -- | requires + -- v "DiffLoc.Shift" + -- ************************************************* + -- * class 'Amor' p * + -- * type 'Trans' p * + -- * class Ord p * + -- * class Ord ('Trans' p) * + -- * class Monoid ('Trans' p) *<---+ + -- * ('.+') :: p -> Trans p -> p * | + -- * ('.-.?') :: p -> p -> Maybe (Trans p) * | + -- ************************************************* | + -- ^ ^ | + -- | implements with | | requires from + -- | p = 'Plain' a | | l as p + -- | or p = 'IndexFrom' n a | | and c as p + -- | 'Trans' p = 'Offset' a | | + -- | | | + -- | | | "DiffLoc.Colline" + -- | "DiffLoc.Index" | +---------------------+ + -- +--------------------------+ | | data 'Colline' l c | + -- | newtype 'Plain' a | |_______| data 'Vallee' l' c' | + -- | newtype 'IndexFrom' n a | +---------------------+ + -- | newtype 'Offset' a | implements with + -- +--------------------------+ p = 'Colline' l c + -- | requires 'Trans' p = 'Vallee' ('Trans' l) ('Trans' c) + -- v + -- ***************** + -- * class Num a * + -- * class Ord a * + -- ***************** + -- @ + + -- ** Diffs + module DiffLoc.Diff + + -- ** Interfaces + -- + -- - 'Shift', 'BlockOrder' + -- - 'Amor', 'Origin' + , module DiffLoc.Shift + + -- ** Intervals and replacements + , module DiffLoc.Interval + + -- ** Plain indices + , module DiffLoc.Index + + -- ** Lines and columns + , module DiffLoc.Colline + + -- ** Basic configurations to get started + , module DiffLoc.Starter + + -- $unsafe + ) where + +import DiffLoc.Colline +import DiffLoc.Diff +import DiffLoc.Index +import DiffLoc.Interval +import DiffLoc.Shift +import DiffLoc.Starter + +-- $unsafe +-- The module "DiffLoc.Unsafe" is not reexported here. +-- You can import it separately. + +-- $setup +-- >>> import DiffLoc.Unsafe diff --git a/src/DiffLoc/Colline.hs b/src/DiffLoc/Colline.hs new file mode 100644 --- /dev/null +++ b/src/DiffLoc/Colline.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE + GeneralizedNewtypeDeriving, + TypeFamilies #-} + +-- | Line-column locations and its offset monoid. +module DiffLoc.Colline + ( Colline(..) + , Vallee(..) + , Vallée + ) where + +import Data.Functor ((<&>)) +import DiffLoc.Shift + +-- $setup +-- >>> import Test.QuickCheck +-- >>> import DiffLoc +-- >>> import DiffLoc.Test +-- >>> import DiffLoc.Unsafe ((.-.)) + +-- | Line and column coordinates. +-- +-- The generalization over types of line and column numbers +-- frees us from any specific indexing scheme, notably whether +-- columns are zero- or one-indexed. +-- +-- === Example +-- +-- > abc +-- > de +-- > fgh +-- +-- Assuming the lines and columns are both 1-indexed, @"b"@ is at location +-- @(Colline 1 2)@ and @"h"@ is at location @(Colline 3 3)@. +data Colline l c = Colline !l !c + deriving (Eq, Ord, Show) + +-- | The space between two 'Colline's. +-- +-- This type represents offsets between text locations @x <= y@ +-- as the number of newlines inbetween and the number of characters +-- from the last new line to @y@, if there is at least one newline, +-- or the number of characters from @x@ to @y@. +-- +-- === Example +-- +-- > abc +-- > de +-- > fgh +-- +-- - The offset from @"b"@ to @"h"@ is @Vallee 2 2@ (two newlines to reach line 3, +-- and from the beginning of that line, advance two characters to reach h). +-- - The offset from @"b"@ to @"c"@ is @Vallee 0 1@ (advance one character). +-- +-- The offset from @"b"@ to @"h"@ is actually the same as from @"a"@ to @"h"@ +-- and from @"c"@ to @"h"@. Line-column offsets are thus not invertible. +-- This was one of the main constraints in the design of the 'Amor' class. +data Vallee dl dc = Vallee !dl !dc + deriving (Eq, Ord, Show) + +-- | Sans commentaire. +type Vallée = Vallee + +-- $hidden +-- prop> (x <> y) <> z === x <> (y <> z :: Vallee (Offset Int) (Offset Int)) + +traversee :: + Eq dl => + dl -> + (l -> dl -> l) -> + (c -> dc -> c) -> + (dc -> c) -> + Colline l c -> Vallee dl dc -> Colline l c +traversee zero actL actC fromO (Colline l c) (Vallee l' c') + | l' == zero = Colline l (c `actC` c') + | otherwise = Colline (l `actL` l') (fromO c') + +instance (Monoid l, Eq l, Semigroup c) => Semigroup (Vallee l c) where + x <> y = descente (traversee mempty (<>) (<>) id (montee x) y) + where + montee :: Vallee l c -> Colline l c + montee (Vallee l c) = Colline l c + + descente :: Colline l c -> Vallee l c + descente (Colline l c) = Vallee l c + +instance (Monoid l, Eq l, Monoid c) => Monoid (Vallee l c) where + mempty = Vallee mempty mempty + +-- $hidden +-- prop> (i .+ r) .+ s === (i .+ (r <> s) :: Colline N N') +-- prop> i <= j ==> (i .+ (j .-. i)) === (j :: Colline N N') +-- prop> (i .+ r) .-. (i :: Colline N N') === r + +instance (Amor l, Origin c) => Amor (Colline l c) where + type Trans (Colline l c) = Vallee (Trans l) (Trans c) + + (.+) = traversee mempty (.+) (.+) ofOrigin + + Colline l c .-.? Colline l' c' = case compare l l' of + LT -> Nothing + EQ | c' <= c -> Vallee mempty <$> (c .-.? c') + | otherwise -> Nothing + GT -> (l .-.? l') <&> \dl -> Vallee dl (fromOrigin c) + +instance (Origin l, Origin c) => Origin (Colline l c) where + origin = Colline origin origin diff --git a/src/DiffLoc/Diff.hs b/src/DiffLoc/Diff.hs new file mode 100644 --- /dev/null +++ b/src/DiffLoc/Diff.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE + AllowAmbiguousTypes, + DerivingStrategies, + FlexibleContexts, + FlexibleInstances, + GeneralizedNewtypeDeriving, + MultiParamTypeClasses, + ScopedTypeVariables, + StandaloneDeriving, + TypeApplications, + TypeFamilies, + UndecidableInstances #-} + +-- | Mapping intervals across diffs +module DiffLoc.Diff + ( -- * Types + ADiff() + + -- * Operations + , emptyDiff + , addDiff + , mapDiff + , comapDiff + , listToDiff + ) where + +import Data.Coerce +import Data.Foldable (toList) +import Data.Maybe (fromMaybe) +import Data.FingerTree (FingerTree) +import Text.Show.Combinators (showCon, (@|)) +import qualified Data.FingerTree as FT + +import DiffLoc.Shift + +-- $setup +-- >>> import Control.Monad ((<=<)) +-- >>> import Test.QuickCheck +-- >>> import Test.QuickCheck.HigherOrder +-- >>> import DiffLoc +-- >>> import DiffLoc.Unsafe +-- >>> import DiffLoc.Test +-- >>> type NN' = Colline N N' +-- >>> quickCheck = quickCheckWith' stdArgs{maxSuccess=3000} + +-- | A diff represents a transformation from one file to another. +-- +-- Example diff between "abcdefgh" and "appcfgzzh": +-- +-- > source ab cdefg h +-- > - b de +-- > + pp zz +-- > target appc fgzzh +-- +-- It consists of three replacements: +-- +-- 1. replace "b" with "pp" at location 1, @mkReplace 1 1 2@; +-- 2. replace "de" with "" at location 3, @mkReplace 3 2 0@; +-- 3. replace "" with "zz" at location 7, @mkReplace 7 0 2@. +-- +-- >>> :{ +-- let d :: Diff N +-- d = addDiff (Replace 1 (offset 1) (offset 2)) -- at location 1, replace "b" (length 1) with "pp" (length 2) +-- $ addDiff (Replace 3 (offset 2) (offset 0)) -- at location 3, replace "de" with "" +-- $ addDiff (Replace 7 (offset 0) (offset 2)) -- at location 7, replace "" with "zz" +-- $ emptyDiff +-- -- N.B.: replacements should be inserted right to left. +-- :} +-- +-- 'ADiff' is an abstract representation to be instantiated with +-- a concrete representation of atomic replacements. +-- +-- == __Internal details__ +-- +-- Internally, a diff is a sequence of /disjoint/ and /nonempty/ replacements, +-- /ordered/ by their source locations. +-- The monoid annotation in the fingertree gives the endpoints of the replacements. +newtype ADiff r = ADiff (FingerTree (Maybe r) (R r)) + deriving Eq + +instance Show r => Show (ADiff r) where + showsPrec = flip $ \d -> showCon "listToDiff" @| diffToList d + +-- | The empty diff. +emptyDiff :: Semigroup r => ADiff r +emptyDiff = ADiff FT.empty + +-- | A newtype to carry a 'FT.Measured' instance. +newtype R r = R r + deriving newtype (Eq, Show) + +instance Semigroup r => FT.Measured (Maybe r) (R r) where + measure (R r) = Just r + +coshiftR' :: Shift r => Maybe r -> r -> r +coshiftR' Nothing = id +coshiftR' (Just r) = fromMaybe (error "failed to shift disjoint intervals") . coshiftR r + +addDiffL :: forall r. Shift r => r -> ADiff r -> ADiff r +addDiffL r (ADiff d0) = case FT.viewl d0 of + FT.EmptyL -> ADiff (FT.singleton (R r)) + R s FT.:< d | src r `distantlyPrecedes` src s -> ADiff (R r FT.<| d0) + | otherwise -> addDiffL (r <> s) (ADiff d) + +-- | Add a replacement to a diff. The replacement is performed /after/ the diff. +-- +-- === Properties +-- +-- prop> not (isZeroLength x) ==> mapDiff (addDiff r d) x == (shiftBlock r <=< mapDiff (d :: Diff N)) x +-- prop> not (isZeroLength x) ==> comapDiff (addDiff r d) x == (comapDiff d <=< coshiftBlock (r :: Replace N)) x +addDiff :: forall r. Shift r => r -> ADiff r -> ADiff r +addDiff r (ADiff d) = case FT.search (\r1 _-> r1 `notPrecedes_` r) d of + FT.Position d1 s d2 -> coerce (d1 <>) (addDiffL (coshiftR' (FT.measure d1) r) (ADiff (s FT.<| d2))) + FT.OnLeft -> addDiffL r (ADiff d) + FT.OnRight -> ADiff (d FT.|> R (coshiftR' (FT.measure d) r)) + FT.Nowhere -> error "Broken invariant" + where + notPrecedes_ Nothing _ = False + notPrecedes_ (Just r1) i = not (tgt r1 `distantlyPrecedes` tgt i) + -- Using distantlyPrecedes here and in addDiffL lets us merge adjacent intervals. + +-- $hidden +-- prop> not (isZeroLength x) ==> mapDiff (addDiff r d) x == (shiftBlock r <=< mapDiff (d :: Diff NN')) x +-- prop> not (isZeroLength x) ==> comapDiff (addDiff r d) x == (comapDiff d <=< coshiftBlock (r :: Replace NN')) x + +-- | Translate a span in the source of a diff to a span in its target. +-- @Nothing@ if the span overlaps with a replacement. +-- +-- For exaple, given the following 'ADiff' (or 'DiffLoc.Interval.Replace') from "aAacCc" to "aAabbbcCc": +-- +-- > source aAa cCc +-- > - +-- > + bbb +-- > target aAabbbcCc +-- +-- >>> r0 = Replace 3 (offset 0) (offset 3) :: Replace N +-- >>> d0 = addDiff r0 emptyDiff +-- +-- The span of \"A\" remains unchanged. +-- +-- >>> mapDiff d0 (1 :.. offset 1) +-- Just (1 :.. offset 1) +-- >>> shiftBlock r0 (1 :.. offset 1) +-- Just (1 :.. offset 1) +-- >>> comapDiff d0 (1 :.. offset 1) +-- Just (1 :.. offset 1) +-- >>> coshiftBlock r0 (1 :.. offset 1) +-- Just (1 :.. offset 1) +-- +-- The span of \"C\" is shifted by 3 characters. +-- +-- >>> mapDiff d0 (4 :.. offset 1) +-- Just (7 :.. offset 1) +-- >>> shiftBlock r0 (4 :.. offset 1) +-- Just (7 :.. offset 1) +-- >>> comapDiff d0 (7 :.. offset 1) +-- Just (4 :.. offset 1) +-- >>> coshiftBlock r0 (7 :.. offset 1) +-- Just (4 :.. offset 1) +-- +-- The span of "ac" overlaps with the replacement, so the mapping is undefined. +-- +-- >>> mapDiff d0 (2 :.. offset 2) +-- Nothing +-- >>> shiftBlock r0 (2 :.. offset 2) +-- Nothing +-- >>> comapDiff d0 (2 :.. offset 5) +-- Nothing +-- >>> coshiftBlock r0 (2 :.. offset 5) +-- Nothing +-- +-- === Properties +-- +-- prop> \(FSN d s) -> not (isZeroLength s) ==> partialSemiInverse (mapDiff d) (comapDiff d) s +-- prop> \(FSN d s) -> not (isZeroLength s) ==> partialSemiInverse (comapDiff d) (mapDiff d) s +-- +-- where @partialSemiInverse f g x@ is the property +-- +-- > if f x == Just y -- for some y +-- > then g y == Just x +mapDiff :: Shift r => ADiff r -> Block r -> Maybe (Block r) +mapDiff = mapDiff_ Cov + +-- $hidden +-- +-- prop> \(FSV d s) -> not (isZeroLength s) ==> partialSemiInverse (mapDiff d) (comapDiff d) s +-- prop> \(FSV d s) -> not (isZeroLength s) ==> partialSemiInverse (comapDiff d) (mapDiff d) s + +-- | Translate a span in the target of a diff to a span in its source. +-- @Nothing@ if the span overlaps with a replacement. +-- +-- See also 'mapDiff'. +comapDiff :: Shift r => ADiff r -> Block r -> Maybe (Block r) +comapDiff = mapDiff_ Contrav + +data Variance = Cov | Contrav + +srcV :: Shift r => Variance -> r -> Block r +srcV Cov = src +srcV Contrav = tgt + +shiftBlockV' :: Shift r => Variance -> Maybe r -> Block r -> Block r +shiftBlockV' _ Nothing = id +shiftBlockV' Cov (Just r) = fromMaybe (error "failed to shift disjoint intervals") . shiftBlock r +shiftBlockV' Contrav (Just r) = fromMaybe (error "failed to shift disjoint intervals") . coshiftBlock r + +mapDiff_ :: forall r. Shift r => Variance -> ADiff r -> Block r -> Maybe (Block r) +mapDiff_ v (ADiff d) i = case FT.search (\r1 _ -> r1 `notPrecedes_` i) d of + FT.Position d1 (R s) _ + | j `precedes` (srcV v s) -> Just i' + | otherwise -> Nothing + where i' = shiftBlockV' v (FT.measure d1) i + j = case v of Cov -> i ; Contrav -> i' + FT.OnLeft -> Just i + FT.OnRight -> Just (shiftBlockV' v (FT.measure d) i) + FT.Nowhere -> error "Broken invariant" + where + notPrecedes_ Nothing _ = False + notPrecedes_ (Just r1) i1 = not (srcV v r1 `precedes` i1) + +-- | +-- +-- @ +-- 'listToDiff' = foldr 'addDiff' 'emptyDiff' +-- @ +listToDiff :: Shift r => [r] -> ADiff r +listToDiff = foldr addDiff emptyDiff + +diffToList :: ADiff r -> [r] +diffToList (ADiff d) = coerce (toList d) diff --git a/src/DiffLoc/Index.hs b/src/DiffLoc/Index.hs new file mode 100644 --- /dev/null +++ b/src/DiffLoc/Index.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE + AllowAmbiguousTypes, + DataKinds, + DerivingStrategies, + DerivingVia, + GeneralizedNewtypeDeriving, + ScopedTypeVariables, + TypeApplications, + TypeFamilies #-} + +-- | Indices and offsets. +module DiffLoc.Index + ( -- * One-dimensional indices + -- ** Unbounded indices + Plain(..) + + -- ** Indices bounded by an origin + , IndexFrom() + , indexFromM + , indexFromM0 + , indexFromM1 + , fromIndex + , fromIndex0 + , fromIndex1 + , zeroIndex + , oneIndex + + -- ** Offsets + , Offset() + , offsetM + , fromOffset + ) where + +import Data.Monoid (Sum(..)) +import Data.Proxy (Proxy(..)) +import GHC.TypeNats (KnownNat, Nat, natVal) +import Text.Show.Combinators (showCon, (@|)) +import DiffLoc.Shift + +-- | One-dimensional indices. +newtype Plain a = Plain a + deriving (Eq, Ord, Show) + +instance (Num a, Ord a) => Amor (Plain a) where + type Trans (Plain a) = Offset a + Plain y .+ Offset x = Plain (x Prelude.+ y) + Plain x .-.? Plain y | y <= x = Just (Offset (x - y)) + | otherwise = Nothing + +-- + +-- | One-dimensional indices with an origin (an initial index). +-- Indices must be greater than the origin, hence the constructor is hidden. +-- +-- Use 'indexFromM' to construct indices, with @TypeApplications@ to make the +-- indexing scheme explicit, and 'fromIndex' to destruct them. +-- +-- @ +-- (origin :: IndexFrom n a) <= i -- for all i +-- @ +newtype IndexFrom (n :: Nat) a = IndexFrom a + deriving (Eq, Ord) + deriving Amor via (Plain a) + +instance Show a => Show (IndexFrom n a) where + showsPrec = flip $ \(IndexFrom i) -> showCon "indexFrom" @| i + +instance (Num a, Ord a, KnownNat n) => Origin (IndexFrom n a) where + origin = IndexFrom (knownNum @n) + +-- | Reify a 'KnownNat'. +-- +-- @ +-- knownNum @42 = 42 +-- @ +knownNum :: forall n a. (KnownNat n, Num a) => a +knownNum = fromIntegral (natVal @n Proxy) + +-- | Constructor for 'IndexFrom'. +-- +-- See also 'DiffLoc.Unsafe.indexFrom' in "DiffLoc.Unsafe", a variant of 'indexFromM' that +-- throws errors instead of using @Maybe@. +indexFromM :: forall n a. (KnownNat n, Num a, Ord a) => a -> Maybe (IndexFrom n a) +indexFromM i | knownNum @n <= i = Just (IndexFrom i) + | otherwise = Nothing + +-- | 'indexFromM' specialized to 0-indexing. +indexFromM0 :: forall a. (Num a, Ord a) => a -> Maybe (IndexFrom 0 a) +indexFromM0 = indexFromM + +-- | 'indexFromM' specialized to 1-indexing. +indexFromM1 :: forall a. (Num a, Ord a) => a -> Maybe (IndexFrom 1 a) +indexFromM1 = indexFromM + +-- | Destructor for 'IndexFrom'. +fromIndex :: forall n a. IndexFrom n a -> a +fromIndex (IndexFrom i) = i + +-- | 'fromIndex' specialized to 0-indexing. +fromIndex0 :: IndexFrom 0 a -> a +fromIndex0 = fromIndex + +-- | 'fromIndex' specialized to 1-indexing. +fromIndex1 :: IndexFrom 1 a -> a +fromIndex1 = fromIndex + +-- | Convert from zero-indexing to one-indexing. +oneIndex :: Num a => IndexFrom 0 a -> IndexFrom 1 a +oneIndex (IndexFrom i) = IndexFrom (i Prelude.+ 1) + +-- | Convert from one-indexing to zero-indexing. +zeroIndex :: Num a => IndexFrom 1 a -> IndexFrom 0 a +zeroIndex (IndexFrom i) = IndexFrom (i - 1) + +-- | Type of nonnegative offsets. +newtype Offset a = Offset a + deriving (Eq, Ord) + deriving (Semigroup, Monoid) via (Sum a) + +instance Show a => Show (Offset a) where + showsPrec = flip $ \(Offset i) -> showCon "offset" @| i + +-- | Construct a nonnegative 'Offset'. +-- +-- See also 'DiffLoc.Unsafe.offset' in "DiffLoc.Unsafe", a variant of 'offsetM' that +-- throws errors instead of using @Maybe@. +offsetM :: (Num a, Ord a) => a -> Maybe (Offset a) +offsetM i | 0 <= i = Just (Offset i) + | otherwise = Nothing + +-- | Unwrap 'Offset'. +fromOffset :: Offset a -> a +fromOffset (Offset i) = i diff --git a/src/DiffLoc/Interval.hs b/src/DiffLoc/Interval.hs new file mode 100644 --- /dev/null +++ b/src/DiffLoc/Interval.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE + FlexibleContexts, + StandaloneDeriving, + TypeFamilies, + UndecidableInstances #-} + +-- | 'Interval' implements 'Shift'. +module DiffLoc.Interval + ( Interval(..) + , isZeroLength + , Replace(..) + ) where + +import Prelude hiding ((+)) +import DiffLoc.Shift +import DiffLoc.Unsafe ((.-.)) + +-- $setup +-- >>> import DiffLoc +-- >>> import DiffLoc.Test +-- >>> import Test.QuickCheck + +-- Nicer looking formulas this way. + +infixl 6 + +(+) :: Semigroup a => a -> a -> a +(+) = (<>) + +-- | @(i ':..' n)@ represents a span of text between index @i@ and index @i+n@. +-- +-- The type of indices @p@ is expected to be an instance of 'Amor'. +-- +-- The length @n@ in an interval @(i :.. n)@ may be zero. +-- +-- The elements of the interval can be thought of as indexing the interstices +-- /between/ characters. A span of length zero is a single interstice between +-- two characters, where some chunk of text may be inserted. +-- +-- Example: drawing of @1 :.. 2@ in "abcde". +-- +-- > a b c d e +-- > 0 1 2 3 4 5 +-- > ^b+c+ length = 2 +-- > ^ +-- > ^ start = 1 +data Interval p = !p :.. !(Trans p) + +infixl 3 :.. + +-- | Does the interval have length zero? +isZeroLength :: (Eq (Trans p), Monoid (Trans p)) => Interval p -> Bool +isZeroLength (_ :.. n) = n == mempty + +deriving instance (Eq p, Eq (Trans p)) => Eq (Interval p) +deriving instance (Show p, Show (Trans p)) => Show (Interval p) + +instance Amor p => BlockOrder (Interval p) where + precedes (i :.. n) (j :.. _) = i .+ n <= j + distantlyPrecedes (i :.. n) (j :.. _) = i .+ n < j + +-- | A minimalistic representation of text replacements. +-- +-- A replacement @'Replace' i n m@ is given by a start location @i@, the length +-- @n@ of the interval to replace (source) and the length @m@ of its +-- replacement (target). +-- This representation does not keep track of the actual data being inserted. +-- +-- This may overapproximate the underlying text replacement, +-- with intervals being wider than necessary. +-- For example, the transformation from "abc" to "ac" could be represented +-- by @mkReplace 1 1 0@ (replace "b" with "" at location 1), and also by +-- @mkReplace 0 2 1@ (replace "ab" with "a" at location 0). +-- +-- > source abc abc +-- > - b ab +-- > + a +-- > target a c a c +-- +-- Insertions are replacements with source intervals of length zero. +-- Deletions are replacements with target intervals of length zero. +data Replace p = Replace !p !(Trans p) !(Trans p) + +deriving instance (Eq p, Eq (Trans p)) => Eq (Replace p) +deriving instance (Show p, Show (Trans p)) => Show (Replace p) + +-- | The composition of two replacements @l <> r@ represents the replacement @r@ +-- followed by @l@, as one replacement of an span that contains both @r@ and @l@. +-- +-- The right-to-left order of composition has the nice property that when +-- @l `'precedes` r@, @l <> r@ can also be viewed intuitively as performing @l@ and +-- @r@ simultaneously. +-- +-- === Properties +-- +-- prop> (x <> y) <> z === x <> (y <> z :: Replace (Plain Int)) +instance Amor p => Semigroup (Replace p) where + Replace li ln lm <> Replace ri rn rm + | li .+ ln <= ri + -- Disjoint, l on the left. + -- + -- Before: + -- > |---l---| |---r---| + -- > li li+ln ri ri+rn + -- + -- After both replacements (r first), + -- with ld = lm-ln + -- + -- > |---l---| |---r---| + -- > li li+lm ri+ld ri+rm+ld + -- + = Replace li ((ri .+ rn) .-. li) (lm + (ri .-. (li .+ ln)) + rm) + + | li <= ri + -- l straddles the left end of r + -- + -- Note that the indices in l should be interpreted + -- as indices after r. + -- After replacing r, the replaced span r and the to-be-replaced + -- span l look like this: + -- + -- > |------r----| + -- > |----l-----| + -- > li ri li+ln ri+rm + -- + -- or this: + -- + -- > |--r--| + -- > |-------l----------| + -- > li ri ri+rm li+ln + -- + = let (n, m) = if li .+ ln < ri .+ rm + then ((ri .+ rn) .-. li, lm + ((ri .+ rm) .-. (li .+ ln))) + else ((ri .-. li) + rn + ((li .+ ln) .-. (ri .+ rm)), lm) + in Replace li n m + + | li < ri .+ rm + -- r straddles the left end of l + -- + -- > |----r-----| + -- > |------l----| + -- > ri li ri+rm li+ln + -- + -- or + -- + -- > |-------r----------| + -- > |--l--| + -- > ri li li+ln ri+rm + -- + = let (n, m) = if ri .+ rm < li .+ ln + then (rn + ((li .+ ln) .-. (ri .+ rm)), (li .+ lm) .-. ri) + else (rn, (li .-. ri) + lm + ((ri .+ rm) .-. (li .+ ln))) + in Replace ri n m + + | otherwise + -- + -- > |---r---| |---l---| + -- > ri rm li ln + -- + = Replace ri (rn + (li .-. (ri .+ rm)) + ln) ((li .+ lm) .-. ri) + +instance Amor p => Shift (Replace p) where + type Block (Replace p) = Interval p + dual (Replace i n m) = Replace i m n + + src (Replace i n _) = i :.. n + + shiftBlock (Replace i n m) jp@(j :.. p) + | j .+ p <= i = Just jp + | i .+ n <= j = Just (i .+ (m + (j .-. (i .+ n))) :.. p) + | otherwise = Nothing + + shiftR (Replace i n m) jpq@(Replace j p q) + | j .+ p <= i = Just jpq + | i .+ n <= j = Just (Replace (i .+ (m + (j .-. (i .+ n)))) p q) + | otherwise = Nothing diff --git a/src/DiffLoc/Shift.hs b/src/DiffLoc/Shift.hs new file mode 100644 --- /dev/null +++ b/src/DiffLoc/Shift.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE + FlexibleContexts, + TypeFamilies #-} + +-- | Interfaces of structures used to implement 'DiffLoc.ADiff'. +module DiffLoc.Shift + ( -- * Interfaces + -- ** Replacement + Shift(..) + , BlockOrder(..) + + -- ** Indices and offsets + , Amor(..) + , Origin(..) + , fromOrigin + , ofOrigin + ) where + +import Data.Kind (Type) +import Data.Maybe (fromMaybe) +import GHC.Stack (HasCallStack) + +-- $setup +-- >>> import Control.Monad ((<=<)) +-- >>> import Test.QuickCheck +-- >>> import DiffLoc +-- >>> import DiffLoc.Unsafe ((.-.)) +-- >>> import DiffLoc.Test +-- >>> type N = Plain Int + +-- | Partial ordering of interval-like things. +class BlockOrder b where + precedes :: b -> b -> Bool + + -- | Precedes but not adjacent, provided you have a notion of adjacence. + -- Otherwise it's fine to equate this with precedes. + distantlyPrecedes :: b -> b -> Bool + +-- | Shift algebra. +-- +-- __Laws:__ +-- +-- @ +-- 'src' \<$> 'shiftR' r s = 'shiftBlock' r ('src' s) +-- 'tgt' \<$> 'shiftR' r s = 'shiftBlock' r ('tgt' s) +-- 'src' \<$> 'coshiftR' r s = 'coshiftBlock' r ('src' s) +-- 'tgt' \<$> 'coshiftR' r s = 'coshiftBlock' r ('tgt' s) +-- +-- 'shiftBlock' r b = Just d \<==> 'coshiftBlock' r d = Just b +-- 'shiftR' r s = Just z \<==> 'coshiftR' r z = Just s +-- +-- 'shiftR' r s = Just z && 'shiftR' s r = Just q ==> +-- z '<>' r = q '<>' s +-- +-- 'coshiftR' r s = Just z && 'coshiftR' s r = Just q ==> +-- r '<>' z = s '<>' q +-- @ +-- +-- __Duality laws:__ +-- +-- @ +-- src = tgt . 'dual' +-- tgt = src . 'dual' +-- shiftBlock = coshiftBlock . 'dual' +-- coshiftBlock = shiftBlock . 'dual' +-- coshiftR = shiftR . 'dual' +-- shiftR = coshiftR . 'dual' +-- @ +class (Semigroup r, BlockOrder (Block r)) => Shift r where + type Block r :: Type + src :: r -> Block r + tgt :: r -> Block r + + shiftBlock :: r -> Block r -> Maybe (Block r) + coshiftBlock :: r -> Block r -> Maybe (Block r) + + shiftR :: r -> r -> Maybe r + coshiftR :: r -> r -> Maybe r + + dual :: r -> r + + src = tgt . dual + tgt = src . dual + shiftBlock = coshiftBlock . dual + coshiftBlock = shiftBlock . dual + coshiftR = shiftR . dual + shiftR = coshiftR . dual + +-- | /Action d'un Monoïde Ordonné./ Ordered monoid actions. +-- +-- - An ordered set of points @Ord p@. +-- - An ordered monoid of translations (or "vectors") @(Ord (Trans p), Monoid ('Trans' p))@. +-- +-- In addition to the 'Ord' and 'Monoid' laws, ordered monoids must +-- have a monotone @('<>')@: +-- +-- @ +-- v \<= v' ==> w \<= w' => (v '<>' w) \<= (v' '<>' w') +-- @ +-- +-- - Points can be translated along vectors using @('.+')@. +-- - Given two ordered points @i <= j@, @j '.-.?' i@ finds a vector @n@ +-- such that @i + n = j@. +-- +-- In other words, we only require the existence of "positive" translations +-- (this is unlike affine spaces, where translations exist between any two points). +-- This makes it possible to implement this class for line-column locations +-- ("DiffLoc.Colline"), where translations are not invertible. +-- +-- @('.-.?')@ is not part of a standard definition of ordered monoid actions. +-- Feel free to suggest a better name for this structure or a way to not +-- depend on this operation. +-- +-- __Laws:__ +-- +-- @ +-- (x '.+' v) '.+' w = x '.+' (v '<>' w) +-- x '<=' y ==> x '.+' (y 'DiffLoc.Unsafe..-.' x) = y +-- (x '.+' v) 'DiffLoc.Unsafe..-.' x = x +-- @ +class (Ord p, Ord (Trans p), Monoid (Trans p)) => Amor p where + -- | Type of translations between points of @p@. + type Trans p :: Type + + infixr 6 .+ + + -- | Translate a point. + (.+) :: p -> Trans p -> p + + -- | Translation between two points. + -- @j .-.? i@ must be defined ('Just') if @i <= j@, + -- + -- There is an unsafe wrapper @('DiffLoc.Unsafe..-.')@ in "DiffLoc.Unsafe". + (.-.?) :: p -> p -> Maybe (Trans p) + +-- $hidden +-- prop> (x .+ v) .+ w === (x .+ (v <> w) :: Plain Int) +-- prop> x <= y ==> x .+ (y .-. x) === (y :: Plain Int) +-- prop> (x .+ v) .-. (x :: Plain Int) === v + +infixl 6 .-. + +-- | An unsafe variant of @('.-.?')@. This will be redefined in "DiffLoc.Unsafe". +(.-.) :: HasCallStack => Amor p => p -> p -> Trans p +i .-. j = fromMaybe (error "undefined vector") (i .-.? j) + +-- | Extend 'Amor' with an "origin" point from which vectors can be drawn to +-- all points. To make the interface slightly more general, only the partial +-- application @(origin .-.)@ needs to be supplied. +-- +-- __Laws:__ +-- +-- @ +-- 'origin' <= x +-- @ +class Amor p => Origin p where + origin :: p + +-- | Translate the origin along a vector. +-- +-- @ +-- x \<= y <=> ofOrigin x \<= ofOrigin y +-- +-- 'ofOrigin' x '.+' v = 'ofOrigin' (x '.+' v) +-- 'ofOrigin' x 'DiffLoc.Unsafe..-.' 'ofOrigin' y = x 'DiffLoc.Unsafe..-.' y +-- @ +ofOrigin :: Origin p => Trans p -> p +ofOrigin v = origin .+ v + +-- | Find the vector from the origin to this point. +-- +-- @ +-- x \<= y <=> fromOrigin x \<= fromOrigin y +-- +-- 'ofOrigin' ('fromOrigin' x) = x +-- 'fromOrigin' ('ofOrigin' v) = v +-- +-- 'fromOrigin' (x .+ v) = 'fromOrigin' x <> v +-- @ +fromOrigin :: Origin p => p -> Trans p +fromOrigin p = p .-. origin diff --git a/src/DiffLoc/Starter.hs b/src/DiffLoc/Starter.hs new file mode 100644 --- /dev/null +++ b/src/DiffLoc/Starter.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE + DataKinds, + DerivingVia, + FlexibleInstances, + StandaloneDeriving, + TypeOperators #-} + +-- | Basic configurations to get started. +module DiffLoc.Starter + ( -- * The heavy lifter + Diff + + -- * Basic index types + , Z + , N + , N' + + -- * Under the hood + , (:$:)(..) + ) where + +import GHC.TypeNats (KnownNat) +import DiffLoc.Diff +import DiffLoc.Interval +import DiffLoc.Index +import DiffLoc.Shift +import DiffLoc.Unsafe + +-- $setup +-- >>> import DiffLoc +-- >>> import DiffLoc.Unsafe + +-- | A shorthand for the common use case of 'Diff'. +type Diff p = ADiff (Replace p) + +-- | A trick to reduce noise by hiding newtype wrapper constructors. +-- This makes the documentation more palatable. +-- +-- >>> show (NoShow (Plain 3) :: Plain :$: Int) +-- "3" +-- >>> show (Colline 4 2 :.. Vallee (offset 3) (offset 3) :: Interval (Colline N N)) +-- "Colline 4 2 :.. Vallee (offset 3) (offset 3)" +newtype f :$: x = NoShow (f x) + deriving (Eq, Ord) + deriving (Semigroup, Monoid, Amor, Origin) via (f x) + +instance Show a => Show (Plain :$: a) where + show (NoShow (Plain i)) = show i + +instance Show a => Show (IndexFrom n :$: a) where + show (NoShow i) = show (fromIndex i) + +instance Show a => Show (Offset :$: a) where + show (NoShow i) = show (fromOffset i) + +instance Num a => Num (Plain :$: a) where + fromInteger n = NoShow (Plain (fromInteger n)) + (+) = undefined ; (-) = undefined ; (*) = undefined ; abs = undefined ; signum = undefined + +instance (Num a, Ord a, KnownNat n) => Num (IndexFrom n :$: a) where + fromInteger n = NoShow (indexFrom (fromInteger n)) + (+) = undefined ; (-) = undefined ; (*) = undefined ; abs = undefined ; signum = undefined + +instance (Num a, Ord a) => Num (Offset :$: a) where + fromInteger n = NoShow (offset (fromInteger n)) + (+) = undefined ; (-) = undefined ; (*) = undefined ; abs = undefined ; signum = undefined + +-- | Integers. +type Z = Plain :$: Int + +-- | Natural numbers. +type N = IndexFrom 0 :$: Int + +-- | Positive numbers. +type N' = IndexFrom 1 :$: Int diff --git a/src/DiffLoc/Test.hs b/src/DiffLoc/Test.hs new file mode 100644 --- /dev/null +++ b/src/DiffLoc/Test.hs @@ -0,0 +1,134 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE + DerivingVia, + FlexibleContexts, + FlexibleInstances, + PatternSynonyms, + ScopedTypeVariables, + StandaloneDeriving, + TypeApplications, + TypeFamilies, + TypeOperators, + UndecidableInstances #-} +module DiffLoc.Test + ( (=.=) + , partialSemiInverse + , GoodSpan(.., GSN, GSV) + , FairSpan(.., FSN, FSV) + ) where + +import Data.List (sort) +import Data.Proxy (Proxy(..)) +import GHC.TypeNats (KnownNat, natVal) +import Test.QuickCheck +import Test.QuickCheck.HigherOrder + +import DiffLoc +import DiffLoc.Unsafe + +-- $setup +-- >>> import Data.Maybe +-- >>> import DiffLoc +-- >>> import Test.QuickCheck +-- >>> quickCheck = quickCheckWith stdArgs{maxSuccess=3000} + +infix 1 =.= + +(=.=) :: (Arbitrary a, Show a, Eq b, Show b) => (a -> b) -> (a -> b) -> Property +f =.= g = property (\x -> f x === g x) + +whenJust :: Testable prop => Maybe a -> (a -> prop) -> Property +whenJust Nothing _ = discard +whenJust (Just x) f = property (f x) + +partialSemiInverse :: (Arbitrary a, Eq a, Show a) => (a -> Maybe b) -> (b -> Maybe a) -> a -> Property +partialSemiInverse f g x = f x `whenJust` \y -> g y === Just x + +instance (Arbitrary p, Arbitrary (Trans p)) => Arbitrary (Interval p) where + arbitrary = do + (i, n) <- arbitrary + pure (i :.. n) + shrink (i :.. n) = [ i' :.. n' | (i', n') <- shrink (i, n) ] + +instance (Arbitrary p, Arbitrary (Trans p)) => Arbitrary (Replace p) where + arbitrary = do + (i, n, m) <- arbitrary + pure (Replace i n m) + shrink (Replace i n m) = + [ Replace i' n' m' | (i', n', m') <- shrink (i, n, m) ] + +instance (Arbitrary p, Show p, Arbitrary (Trans p), Show (Trans p)) => Constructible (Interval p) where + type Repr (Interval p) = Interval p + fromRepr = id + +instance (Arbitrary p, Show p, Arbitrary (Trans p), Show (Trans p)) => Constructible (Replace p) where + type Repr (Replace p) = Replace p + fromRepr = id + +instance (Shift r, Arbitrary r, Show r) => Constructible (ADiff r) where + type Repr (ADiff r) = [r] + fromRepr = listToDiff + +-- | Generate GoodSpan most of the time, but also some completely arbitrary ones once in a while. +data FairSpan p = FS (Diff p) (Interval p) + +-- | A Diff and a non-conflicting Span +data GoodSpan p = GS (Diff p) (Interval p) + +deriving instance (Show p, Show (Trans p)) => Show (FairSpan p) +deriving instance (Show p, Show (Trans p)) => Show (GoodSpan p) + +pattern FSN :: Diff N -> Interval N -> FairSpan N +pattern FSN d s = FS d s + +pattern GSN :: Diff N -> Interval N -> GoodSpan N +pattern GSN d s = GS d s + +pattern FSV :: Diff (Colline N N) -> Interval (Colline N N) -> FairSpan (Colline N N) +pattern FSV d s = FS d s + +pattern GSV :: Diff (Colline N N) -> Interval (Colline N N) -> GoodSpan (Colline N N) +pattern GSV d s = GS d s + +instance (Amor p, Arbitrary p, Arbitrary (Trans p)) => Arbitrary (FairSpan p) where + arbitrary = frequency [(10, (\(GS d s) -> FS d s) <$> arbitrary), (1, arbitrary)] + +instance (Amor p, Arbitrary p, Arbitrary (Trans p), Show p, Show (Trans p)) => Constructible (FairSpan p) where + type Repr (FairSpan p) = FairSpan p + fromRepr = id + +-- | +-- prop> \(GSN d s) -> isJust (mapDiff d s) +-- prop> \(GSV d s) -> isJust (mapDiff d s) +instance (Amor p, Arbitrary p, Arbitrary (Trans p)) => Arbitrary (GoodSpan p) where + arbitrary = do + let pairs (x : y : xs) | x == y = pairs (x : xs) + | otherwise = (x, y) : pairs xs + pairs _ = [] + ts <- scale (* 2) (pairs <$> sort <$> arbitrary) `suchThat` (not . null) + i <- choose (0, length ts-1) + let (s, ts') = case splitAt i ts of + (pre, (x, y) : suf) -> (x :.. (y .-. x), pre ++ suf) + _ -> error "should not happen" + d <- listToDiff <$> traverse (\(x, y) -> Replace x (y .-. x) <$> arbitrary) ts' + pure (GS d s) + +instance (Arbitrary l, Arbitrary c) => Arbitrary (Colline l c) where + arbitrary = Colline <$> arbitrary <*> arbitrary + +instance (Arbitrary l, Arbitrary c) => Arbitrary (Vallee l c) where + arbitrary = Vallee <$> arbitrary <*> arbitrary + +deriving via a instance Arbitrary a => Arbitrary (Plain a) +deriving via (f a) instance Arbitrary (f a) => Arbitrary (f :$: a) + +genLowerBound :: (Arbitrary a, Num a, Ord a) => a -> Gen a +genLowerBound n = do + NonNegative i <- arbitrary + pure (if n <= n + i then n + i else n) -- catches overflow + +instance (Arbitrary a, Num a, Ord a, KnownNat n) => Arbitrary (IndexFrom n a) where + arbitrary = indexFrom <$> genLowerBound (fromIntegral (natVal @n Proxy)) + +instance (Arbitrary a, Num a, Ord a) => Arbitrary (Offset a) where + arbitrary = offset <$> genLowerBound 0 diff --git a/src/DiffLoc/Unsafe.hs b/src/DiffLoc/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/DiffLoc/Unsafe.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE + DataKinds, + ScopedTypeVariables, + TypeApplications #-} +-- | Unsafe functions that will throw errors if misused. +module DiffLoc.Unsafe + ( -- ** Inverting monoid actions + (.-.) + + -- ** Smart constructors for 'IndexFrom' + , indexFrom + , indexFrom0 + , indexFrom1 + + -- ** Smart constructor for 'Offset' + , offset + ) where + +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy(..)) +import GHC.Stack (HasCallStack) +import GHC.TypeNats (KnownNat, natVal) +import DiffLoc.Shift (Amor(Trans, (.-.?))) +import DiffLoc.Index (IndexFrom, Offset, indexFromM, offsetM) + +infixl 6 .-. + +-- | An unsafe variant of @('.-.?')@ which throws an exception on @Nothing@. +-- This operator may appear in class laws, imposing an implicit requirement +-- that its operands must be ordered. +(.-.) :: HasCallStack => Amor p => p -> p -> Trans p +i .-. j = fromMaybe (error "undefined vector") (i .-.? j) + +-- | Constructor for 'IndexFrom'. The index must be greater than the origin, +-- otherwise an error is raised. +-- +-- @ +-- origin <= indexFrom i +-- @ +indexFrom :: forall n a. (HasCallStack, KnownNat n, Num a, Ord a) => a -> IndexFrom n a +indexFrom i = fromMaybe err (indexFromM i) + where err = error ("IndexFrom must not be less than origin " <> show (natVal @n Proxy)) + +-- | 'indexFrom' specialized to 0-indexing. +indexFrom0 :: (HasCallStack, Num a, Ord a) => a -> IndexFrom 0 a +indexFrom0 = indexFrom + +-- | 'indexFrom' specialized to 1-indexing. +indexFrom1 :: (HasCallStack, Num a, Ord a) => a -> IndexFrom 1 a +indexFrom1 = indexFrom + +-- | Construct an 'Offset'. The offset must be nonnegative, otherwise +-- an error is raised. +offset :: (HasCallStack, Num a, Ord a) => a -> Offset a +offset i = fromMaybe (error "Offset must not be negative") (offsetM i)