predicate-typed 0.1.0.4 → 0.2.0.0
raw patch · 23 files changed
+11211/−9922 lines, 23 files
Files
- doctests.hs +3/−7
- predicate-typed.cabal +11/−10
- src/Predicate.hs +13/−6598
- src/Predicate/Core.hs +620/−0
- src/Predicate/Prelude.hs +7456/−0
- src/Predicate/Refined.hs +419/−0
- src/Predicate/Refined3.hs +814/−0
- src/Predicate/Refined3Helper.hs +451/−0
- src/Predicate/TH_Orphans.hs +24/−0
- src/Predicate/Util.hs +1095/−0
- src/Predicate/Util_TH.hs +172/−0
- src/PredicateCore.hs +0/−583
- src/Refined.hs +0/−410
- src/Refined3.hs +0/−729
- src/Refined3Helper.hs +0/−297
- src/TH_Orphans.hs +0/−28
- src/UtilP.hs +0/−984
- src/UtilP_TH.hs +0/−168
- test/TastyExtras.hs +1/−1
- test/TestJson.hs +5/−5
- test/TestPredicate.hs +79/−92
- test/TestRefined.hs +4/−3
- test/TestRefined3.hs +44/−7
doctests.hs view
@@ -1,11 +1,7 @@ import Test.DocTest -- main = doctest ["src", "--verbose"] main :: IO () -main = doctest ["-isrc", "src", "-XDataKinds", "-XTypeApplications", "-XTypeOperators", "-XNoStarIsType"] - -{- -C:\haskell\predicate-typed>stack exec doctest -- "src/Predicate.hs" +main = doctest ["src"] --- just specify the directory -C:\haskell\predicate-typed>stack exec doctest -- src --}+-- stack exec doctest -- "src/Predicate.hs" +-- stack exec doctest -- src
predicate-typed.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.1.+-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack ----- hash: b124eaae809a099946ae43451fff6ad39559ef988b4c356e6f477f1632fdec22+-- hash: 9961ce22931302992ba8b3575d0e54df9b5f7496b264f0e8467ba27a6f182438 name: predicate-typed-version: 0.1.0.4+version: 0.2.0.0 synopsis: Predicates, Refinement types and Dsl description: Please see the README on GitHub at <https://github.com/gbwey/predicate-typed#readme> category: Data@@ -27,13 +27,14 @@ library exposed-modules: Predicate- PredicateCore- Refined- Refined3- Refined3Helper- TH_Orphans- UtilP- UtilP_TH+ Predicate.Core+ Predicate.Prelude+ Predicate.Refined+ Predicate.Refined3+ Predicate.Refined3Helper+ Predicate.TH_Orphans+ Predicate.Util+ Predicate.Util_TH other-modules: Paths_predicate_typed hs-source-dirs:
src/Predicate.hs view
@@ -1,6598 +1,13 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wcompat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE NoStarIsType #-} -{-# LANGUAGE OverloadedLists #-} -{- | -Module : Predicate -Description : Dsl for evaluating and displaying type level expressions -Copyright : (c) Grant Weyburne, 2019 -License : BSD-3 -Maintainer : gbwey9@gmail.com - -Most of this code contains instances of the class 'P' enabling evaluation of expressions at the type level. --} -module Predicate ( - module UtilP - , module PredicateCore - , module Predicate - ) where -import PredicateCore -import UtilP -import Safe -import GHC.TypeLits (Symbol,Nat,KnownSymbol,KnownNat,ErrorMessage((:$$:),(:<>:))) -import qualified GHC.TypeLits as GL -import Control.Lens hiding (strict,iall) ---import Control.Lens (Unwrapped, Wrapped, _Unwrapped', _Wrapped', Ixed, IxValue, Index, Reversing, Cons, Snoc, AsEmpty, FoldableWithIndex, allOf, (%~), (<&>), (^.), (^?), coerced, view, reversed, ix, cons, snoc, _Cons, _Snoc, (^?!), (.~), itoList, Identity(..), _Empty, has) -import Data.List -import qualified Data.Text.Lens as TL -import Data.Proxy -import Control.Applicative -import Data.Typeable -import Control.Monad.Except -import qualified Control.Exception as E -import Data.Kind (Type) -import qualified Text.Regex.PCRE.Heavy as RH -import Data.String -import Data.Foldable -import Data.Maybe -import Control.Arrow -import qualified Data.Semigroup as SG -import Numeric -import Data.Char -import Data.Function -import Data.These (These(..), these, partitionThese) -import qualified Data.Bifunctor.Swap as SW (Swap(..)) -import qualified Data.Bifunctor.Assoc as AS (Assoc(..)) -import Data.Ratio -import Data.Time -import Data.Coerce -import Data.Void -import qualified Data.Sequence as Seq -import Text.Printf -import System.Directory -import Control.Comonad -import System.IO -import System.Environment -import qualified GHC.Exts as Ge -import Data.Bool -import Data.Either -import qualified Data.Type.Equality as DE -import Data.Time.Calendar.WeekDate - --- | a type level predicate for a monotonic increasing list --- --- >>> pl @Asc "aaacdef" --- True --- TrueT --- --- >>> pl @Asc [1,2,3,4,5,5,7] --- True --- TrueT --- --- >>> pl @Asc' [1,2,3,4,5,5,7] --- False --- FalseT --- --- >>> pl @Asc "axacdef" --- False --- FalseT --- -type Asc = Ands (Map (Fst Id <= Snd Id) Pairs) --- | a type level predicate for a strictly increasing list -type Asc' = Ands (Map (Fst Id < Snd Id) Pairs) --- | a type level predicate for a monotonic decreasing list -type Desc = Ands (Map (Fst Id >= Snd Id) Pairs) --- | a type level predicate for a strictly decreasing list -type Desc' = Ands (Map (Fst Id > Snd Id) Pairs) - --- | A predicate that determines if the value is between \'p\' and \'q\' --- --- >>> pl @(Between' 5 8 Len) [1,2,3,4,5,5,7] --- True --- TrueT --- --- >>> pl @(Between 5 8) 6 --- True --- TrueT --- --- >>> pl @(Between 5 8) 9 --- False --- FalseT --- -type Between p q = Ge p && Le q --- | This is the same as 'Between' but where \'r\' is 'Id' -type Between' p q r = r >= p && r <= q - --- | a type level predicate for all positive elements in a list --- --- >>> pl @AllPositive [1,5,10,2,3] --- True --- TrueT --- --- >>> pl @AllPositive [0,1,5,10,2,3] --- False --- FalseT --- --- >>> pl @AllPositive [3,1,-5,10,2,3] --- False --- FalseT --- --- >>> pl @AllNegative [-1,-5,-10,-2,-3] --- True --- TrueT --- -type AllPositive = Ands (Map Positive Id) --- | a type level predicate for all negative elements in a list -type AllNegative = Ands (Map Negative Id) -type Positive = Gt 0 -type Negative = Lt 0 - -type AllPositive' = FoldMap SG.All (Map Positive Id) -type AllNegative' = FoldMap SG.All (Map Negative Id) - --- | similar to 'all' --- --- >>> pl @(All Even Id) [1,5,11,5,3] --- False --- FalseT --- --- >>> pl @(All Odd Id) [1,5,11,5,3] --- True --- TrueT --- --- >>> pl @(All Odd Id) [] --- True --- TrueT --- -type All x p = Ands (Map x p) --- | similar to 'any' --- --- >>> pl @(Any Even Id) [1,5,11,5,3] --- False --- FalseT --- --- >>> pl @(Any Even Id) [1,5,112,5,3] --- True --- TrueT --- --- >>> pl @(Any Even Id) [] --- False --- FalseT --- -type Any x p = Ors (Map x p) - --- | 'unzip' equivalent --- --- >>> pl @Unzip (zip [1..5] "abcd") --- Present ([1,2,3,4],"abcd") --- PresentT ([1,2,3,4],"abcd") --- -type Unzip = '(Map (Fst Id) Id, Map (Snd Id) Id) - --- | represents a predicate using a 'Symbol' as a regular expression --- evaluates 'Re' and returns True if there is a match --- --- >>> pl @(Re "^\\d{2}:\\d{2}:\\d{2}$" Id) "13:05:25" --- True --- TrueT --- -data Re' (rs :: [ROpt]) p q -type Re p q = Re' '[] p q - -instance (GetROpts rs - , PP p x ~ String - , PP q x ~ String - , P p x - , P q x - ) => P (Re' rs p q) x where - type PP (Re' rs p q) x = Bool - eval _ opts x = do - let msg0 = "Re" <> (if null rs then "' " <> show rs else "") - rs = getROpts @rs - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let msg1 = msg0 <> " (" <> p <> ")" - hhs = [hh pp, hh qq] - in case compileRegex @rs opts msg1 p hhs of - Left tta -> tta - Right regex -> - let b = q RH.=~ regex - in mkNodeB opts b [msg1 <> showLit1 opts " | " q] hhs - --- only way with rescan is to be explicit: no repeats! and useanchors but not (?m) --- or just use Re' but then we only get a bool ie doesnt capture groups --- rescan returns Right [] as an failure! --- [] is failure! - - --- | runs a regex matcher returning the original values and optionally any groups --- --- >>> pl @(Rescan "^(\\d{2}):(\\d{2}):(\\d{2})$" Id) "13:05:25" --- Present [("13:05:25",["13","05","25"])] --- PresentT [("13:05:25",["13","05","25"])] --- --- >>> pl @(Rescan (Snd Id) "13:05:25") ('a',"^(\\d{2}):(\\d{2}):(\\d{2})$") --- Present [("13:05:25",["13","05","25"])] --- PresentT [("13:05:25",["13","05","25"])] --- -data Rescan' (rs :: [ROpt]) p q -type Rescan p q = Rescan' '[] p q - -instance (GetROpts rs - , PP p x ~ String - , PP q x ~ String - , P p x - , P q x - ) => P (Rescan' rs p q) x where - type PP (Rescan' rs p q) x = [(String, [String])] - eval _ opts x = do - let msg0 = "Rescan" <> (if null rs then "' " <> show rs else "") - rs = getROpts @rs - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let msg1 = msg0 <> " (" <> p <> ")" - hhs = [hh pp, hh qq] - in case compileRegex @rs opts msg1 p hhs of - Left tta -> tta - Right regex -> - case splitAt _MX $ RH.scan regex q of - (b, _:_) -> mkNode opts (FailT "Regex looping") [msg1 <> " Looping? " <> show (take 10 b) <> "..." <> show1 opts " | " q] hhs - ([], _) -> -- this is a failure cos empty string returned: so reuse p? - mkNode opts (FailT "Regex no results") [msg1 <> " no match" <> show1 opts " | " q] [hh pp, hh qq] - (b, _) -> mkNode opts (PresentT b) [lit01 opts msg1 b q] [hh pp, hh qq] - - --- | similar to 'Rescan' but gives the column start and ending positions instead of values --- --- >>> pl @(RescanRanges "^(\\d{2}):(\\d{2}):(\\d{2})$" Id) "13:05:25" --- Present [((0,8),[(0,2),(3,5),(6,8)])] --- PresentT [((0,8),[(0,2),(3,5),(6,8)])] --- -data RescanRanges' (rs :: [ROpt]) p q -type RescanRanges p q = RescanRanges' '[] p q - -instance (GetROpts rs - , PP p x ~ String - , PP q x ~ String - , P p x - , P q x - ) => P (RescanRanges' rs p q) x where - type PP (RescanRanges' rs p q) x = [((Int,Int), [(Int,Int)])] - eval _ opts x = do - let msg0 = "RescanRanges" <> (if null rs then "' " <> show rs else "") - rs = getROpts @rs - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let msg1 = msg0 <> " (" <> p <> ")" - hhs = [hh pp, hh qq] - in case compileRegex @rs opts msg1 p hhs of - Left tta -> tta - Right regex -> - case splitAt _MX $ RH.scanRanges regex q of - (b, _:_) -> mkNode opts (FailT "Regex looping") [msg1 <> " Looping? " <> show (take 10 b) <> "..." <> show1 opts " | " q] hhs - ([], _) -> -- this is a failure cos empty string returned: so reuse p? - mkNode opts (FailT "Regex no results") [msg1 <> " no match" <> show1 opts " | " q] hhs - (b, _) -> mkNode opts (PresentT b) [lit01 opts msg1 b q] hhs - --- | splits a string on a regex delimiter --- --- >>> pl @(Resplit "\\." Id) "141.201.1.22" --- Present ["141","201","1","22"] --- PresentT ["141","201","1","22"] --- --- >>> pl @(Resplit (Singleton (Fst Id)) (Snd Id)) (':', "12:13:1") --- Present ["12","13","1"] --- PresentT ["12","13","1"] --- -data Resplit' (rs :: [ROpt]) p q -type Resplit p q = Resplit' '[] p q - -instance (GetROpts rs - , PP p x ~ String - , PP q x ~ String - , P p x - , P q x - ) => P (Resplit' rs p q) x where - type PP (Resplit' rs p q) x = [String] - eval _ opts x = do - let msg0 = "Resplit" <> (if null rs then "' " <> show rs else "") - rs = getROpts @rs - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let msg1 = msg0 <> " (" <> p <> ")" - hhs = [hh pp, hh qq] - in case compileRegex @rs opts msg1 p hhs of - Left tta -> tta - Right regex -> - case splitAt _MX $ RH.split regex q of - (b, _:_) -> mkNode opts (FailT "Regex looping") [msg1 <> " Looping? " <> show (take 10 b) <> "..." <> show1 opts " | " q] hhs - ([], _) -> -- this is a failure cos empty string returned: so reuse p? - mkNode opts (FailT "Regex no results") [msg1 <> " no match" <> show1 opts " | " q] hhs - (b, _) -> mkNode opts (PresentT b) [lit01 opts msg1 b q] hhs - -_MX :: Int -_MX = 100 - --- | replaces regex \'s\' with a string \'s1\' inside the value --- --- >>> pl @(ReplaceAllString "\\." ":" Id) "141.201.1.22" --- Present "141:201:1:22" --- PresentT "141:201:1:22" --- -data ReplaceImpl (alle :: Bool) (rs :: [ROpt]) p q r -type ReplaceAll' (rs :: [ROpt]) p q r = ReplaceImpl 'True rs p q r -type ReplaceAll p q r = ReplaceAll' '[] p q r -type ReplaceOne' (rs :: [ROpt]) p q r = ReplaceImpl 'False rs p q r -type ReplaceOne p q r = ReplaceOne' '[] p q r - -type ReplaceAllString' (rs :: [ROpt]) p q r = ReplaceAll' rs p (MakeRR q) r -type ReplaceAllString p q r = ReplaceAllString' '[] p q r - -type ReplaceOneString' (rs :: [ROpt]) p q r = ReplaceOne' rs p (MakeRR q) r -type ReplaceOneString p q r = ReplaceOneString' '[] p q r - --- | Simple replacement string: see 'ReplaceAllString' and 'ReplaceOneString' --- -data MakeRR p - -instance (PP p x ~ String - , P p x) => P (MakeRR p) x where - type PP (MakeRR p) x = RR - eval _ opts x = do - let msg0 = "MakeRR" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = RR p - in mkNode opts (PresentT b) [msg0 <> show1 opts " | " p] [hh pp] - --- | A replacement function (String -> [String] -> String) which returns the whole match and the groups --- Used by 'RH.sub' and 'RH.sub' --- Requires "Text.Show.Functions" --- -data MakeRR1 p - -instance (PP p x ~ (String -> [String] -> String) - , P p x) => P (MakeRR1 p) x where - type PP (MakeRR1 p) x = RR - eval _ opts x = do - let msg0 = "MakeRR1 (String -> [String] -> String)" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right f -> mkNode opts (PresentT (RR1 f)) [msg0] [hh pp] - --- | A replacement function (String -> String) that yields the whole match --- Used by 'RH.sub' and 'RH.sub' --- Requires "Text.Show.Functions" --- --- >>> :m + Text.Show.Functions --- >>> pl @(ReplaceAll "\\." (MakeRR2 (Fst Id)) (Snd Id)) (\x -> x <> ":" <> x, "141.201.1.22") --- Present "141.:.201.:.1.:.22" --- PresentT "141.:.201.:.1.:.22" --- -data MakeRR2 p - -instance (PP p x ~ (String -> String) - , P p x) => P (MakeRR2 p) x where - type PP (MakeRR2 p) x = RR - eval _ opts x = do - let msg0 = "MakeRR2 (String -> String)" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right f -> mkNode opts (PresentT (RR2 f)) [msg0] [hh pp] - --- | A replacement function ([String] -> String) which yields the groups --- Used by 'RH.sub' and 'RH.sub' --- Requires "Text.Show.Functions" --- --- >>> :m + Text.Show.Functions --- >>> pl @(ReplaceAll "^(\\d+)\\.(\\d+)\\.(\\d+)\\.(\\d+)$" (MakeRR3 (Fst Id)) (Snd Id)) (\ys -> intercalate " | " $ map (show . succ . read @Int) ys, "141.201.1.22") --- Present "142 | 202 | 2 | 23" --- PresentT "142 | 202 | 2 | 23" --- -data MakeRR3 p - -instance (PP p x ~ ([String] -> String) - , P p x) => P (MakeRR3 p) x where - type PP (MakeRR3 p) x = RR - eval _ opts x = do - let msg0 = "MakeRR3 ([String] -> String)" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right f -> mkNode opts (PresentT (RR3 f)) [msg0] [hh pp] - -instance (GetBool b - , GetROpts rs - , PP p x ~ String - , PP q x ~ RR - , PP r x ~ String - , P p x - , P q x - , P r x - ) => P (ReplaceImpl b rs p q r) x where - type PP (ReplaceImpl b rs p q r) x = String - eval _ opts x = do - let msg0 = "Replace" <> (if alle then "All" else "One") <> (if null rs then "' " <> show rs else "") - rs = getROpts @rs - alle = getBool @b - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x - case lr of - Left e -> pure e - Right (p,q,pp,qq) -> - let msg1 = msg0 <> " (" <> p <> ")" - hhs = [hh pp, hh qq] - in case compileRegex @rs opts msg1 p hhs of - Left tta -> pure tta - Right regex -> do - rr <- eval (Proxy @r) opts x - pure $ case getValueLR opts msg0 rr hhs of - Left e -> e - Right r -> - let ret :: String - ret = case q of - RR s -> (if alle then RH.gsub else RH.sub) regex s r - RR1 s -> (if alle then RH.gsub else RH.sub) regex s r - RR2 s -> (if alle then RH.gsub else RH.sub) regex s r - RR3 s -> (if alle then RH.gsub else RH.sub) regex s r - in mkNode opts (PresentT ret) [msg1 <> showLit0 opts " " r <> showLit1 opts " | " ret] (hhs <> [hh rr]) - --- | a predicate for determining if a string 'Data.Text.IsText' belongs to the given character set --- --- >>> import qualified Data.Text as T --- >>> pl @IsLower "abc" --- True --- TrueT --- --- >>> pl @IsLower "abcX" --- False --- FalseT --- --- >>> pl @IsLower (T.pack "abcX") --- False --- FalseT --- --- >>> pl @IsHexDigit "01efA" --- True --- TrueT --- --- >>> pl @IsHexDigit "01egfA" --- False --- FalseT --- -data IsCharSet (cs :: CharSet) - -data CharSet = CLower - | CUpper - | CNumber - | CSpace - | CPunctuation - | CControl - | CHexDigit - | COctDigit - | CSeparator - | CLatin1 - deriving Show - -class GetCharSet (cs :: CharSet) where - getCharSet :: (CharSet, Char -> Bool) -instance GetCharSet 'CLower where - getCharSet = (CLower, isLower) -instance GetCharSet 'CUpper where - getCharSet = (CUpper, isUpper) -instance GetCharSet 'CNumber where - getCharSet = (CNumber, isNumber) -instance GetCharSet 'CPunctuation where - getCharSet = (CPunctuation, isPunctuation) -instance GetCharSet 'CControl where - getCharSet = (CControl, isControl) -instance GetCharSet 'CHexDigit where - getCharSet = (CHexDigit, isHexDigit) -instance GetCharSet 'COctDigit where - getCharSet = (COctDigit, isOctDigit) -instance GetCharSet 'CSeparator where - getCharSet = (CSeparator, isSeparator) -instance GetCharSet 'CLatin1 where - getCharSet = (CLatin1, isLatin1) - --- | predicate for determining if a string is all lowercase --- >>> pl @IsLower "abcdef213" --- False --- FalseT --- --- >>> pl @IsLower "abcdef" --- True --- TrueT --- --- >>> pl @IsLower "" --- True --- TrueT --- --- >>> pl @IsLower "abcdefG" --- False --- FalseT --- -type IsLower = IsCharSet 'CLower -type IsUpper = IsCharSet 'CUpper --- | predicate for determining if the string is all digits --- >>> pl @IsNumber "213G" --- False --- FalseT --- --- >>> pl @IsNumber "929" --- True --- TrueT --- -type IsNumber = IsCharSet 'CNumber -type IsSpace = IsCharSet 'CSpace -type IsPunctuation = IsCharSet 'CPunctuation -type IsControl = IsCharSet 'CControl -type IsHexDigit = IsCharSet 'CHexDigit -type IsOctDigit = IsCharSet 'COctDigit -type IsSeparator = IsCharSet 'CSeparator -type IsLatin1 = IsCharSet 'CLatin1 - -instance (GetCharSet cs - , Show a - , TL.IsText a - ) => P (IsCharSet cs) a where - type PP (IsCharSet cs) a = Bool - eval _ opts as = - let b = allOf TL.text f as - msg0 = "IsCharSet " ++ show cs - (cs,f) = getCharSet @cs - in pure $ mkNodeB opts b [msg0 <> show1 opts " | " as] [] - - --- | converts a string 'Data.Text.Lens.IsText' value to lower case --- --- >>> pl @ToLower "HeLlO wOrld!" --- Present "hello world!" --- PresentT "hello world!" --- -data ToLower - -instance (Show a, TL.IsText a) => P ToLower a where - type PP ToLower a = a - eval _ opts as = - let msg0 = "ToLower" - xs = as & TL.text %~ toLower - in pure $ mkNode opts (PresentT xs) [show01 opts msg0 xs as] [] - --- | converts a string 'Data.Text.Lens.IsText' value to upper case --- --- >>> pl @ToUpper "HeLlO wOrld!" --- Present "HELLO WORLD!" --- PresentT "HELLO WORLD!" --- -data ToUpper - -instance (Show a, TL.IsText a) => P ToUpper a where - type PP ToUpper a = a - eval _ opts as = - let msg0 = "ToUpper" - xs = as & TL.text %~ toUpper - in pure $ mkNode opts (PresentT xs) [show01 opts msg0 xs as] [] - - --- | similar to 'Data.List.inits' --- --- >>> pl @Inits [4,8,3,9] --- Present [[],[4],[4,8],[4,8,3],[4,8,3,9]] --- PresentT [[],[4],[4,8],[4,8,3],[4,8,3,9]] --- --- >>> pl @Inits [] --- Present [[]] --- PresentT [[]] --- -data Inits - -instance Show a => P Inits [a] where - type PP Inits [a] = [[a]] - eval _ opts as = - let msg0 = "Inits" - xs = inits as - in pure $ mkNode opts (PresentT xs) [show01 opts msg0 xs as] [] - --- | similar to 'Data.List.tails' --- --- >>> pl @Tails [4,8,3,9] --- Present [[4,8,3,9],[8,3,9],[3,9],[9],[]] --- PresentT [[4,8,3,9],[8,3,9],[3,9],[9],[]] --- --- >>> pl @Tails [] --- Present [[]] --- PresentT [[]] --- -data Tails - -instance Show a => P Tails [a] where - type PP Tails [a] = [[a]] - eval _ opts as = - let msg0 = "Tails" - xs = tails as - in pure $ mkNode opts (PresentT xs) [show01 opts msg0 xs as] [] - --- | split a list into single values --- --- >>> pl @(Ones Id) [4,8,3,9] --- Present [[4],[8],[3],[9]] --- PresentT [[4],[8],[3],[9]] --- --- >>> pl @(Ones Id) [] --- Present [] --- PresentT [] --- -data Ones p - -instance ( PP p x ~ [a] - , P p x - , Show a - ) => P (Ones p) x where - type PP (Ones p) x = [PP p x] - eval _ opts x = do - let msg0 = "Ones" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = map (:[]) p - in mkNode opts (PresentT d) [show01 opts msg0 d p] [hh pp] - --- | similar to 'show' --- --- >>> pl @(ShowP Id) [4,8,3,9] --- Present "[4,8,3,9]" --- PresentT "[4,8,3,9]" --- --- >>> pl @(ShowP Id) 'x' --- Present "'x'" --- PresentT "'x'" --- --- >>> pl @(ShowP (42 %- 10)) 'x' --- Present "(-21) % 5" --- PresentT "(-21) % 5" --- -data ShowP p - -instance (Show (PP p x), P p x) => P (ShowP p) x where - type PP (ShowP p) x = String - eval _ opts x = do - let msg0 = "ShowP" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = show p - in mkNode opts (PresentT d) [msg0 <> showLit0 opts " " d <> show1 opts " | " p] [hh pp] - --- | type level expression representing a formatted time --- similar to 'Data.Time.formatTime' using a type level 'Symbol' to get the formatting string --- --- >>> pl @(FormatTimeP "%F %T" Id) (read "2019-05-24 05:19:59" :: LocalTime) --- Present "2019-05-24 05:19:59" --- PresentT "2019-05-24 05:19:59" --- --- >>> pl @(FormatTimeP (Fst Id) (Snd Id)) ("the date is %d/%m/%Y", read "2019-05-24" :: Day) --- Present "the date is 24/05/2019" --- PresentT "the date is 24/05/2019" --- -data FormatTimeP p q - -instance (PP p x ~ String - , FormatTime (PP q x) - , P p x - , Show (PP q x) - , P q x - ) => P (FormatTimeP p q) x where - type PP (FormatTimeP p q) x = String - eval _ opts x = do - let msg0 = "FormatTimeP" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let msg1 = msg0 <> " (" <> p <> ")" - b = formatTime defaultTimeLocale p q - in mkNode opts (PresentT b) [msg1 <> showLit0 opts " " b <> show1 opts " | " q] [hh pp, hh qq] - --- | similar to 'Data.Time.parseTimeM' where \'t\' is the 'Data.Time.ParseTime' type, \'p\' is the datetime format and \'q\' points to the content to parse --- --- >>> pl @(ParseTimeP LocalTime "%F %T" Id) "2019-05-24 05:19:59" --- Present 2019-05-24 05:19:59 --- PresentT 2019-05-24 05:19:59 --- --- >>> pl @(ParseTimeP LocalTime "%F %T" "2019-05-24 05:19:59") (Right "we ignore this using Symbol and not Id") --- Present 2019-05-24 05:19:59 --- PresentT 2019-05-24 05:19:59 --- --- keeping \'q\' as we might want to extract from a tuple -data ParseTimeP' t p q -type ParseTimeP (t :: Type) p q = ParseTimeP' (Hole t) p q - -instance (ParseTime (PP t a) - , Typeable (PP t a) - , Show (PP t a) - , P p a - , P q a - , PP p a ~ String - , PP q a ~ String - ) => P (ParseTimeP' t p q) a where - type PP (ParseTimeP' t p q) a = PP t a - eval _ opts a = do - let msg0 = "ParseTimeP " <> t - t = showT @(PP t a) - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let msg1 = msg0 <> " (" <> p <> ")" - hhs = [hh pp, hh qq] - in case parseTimeM @Maybe @(PP t a) True defaultTimeLocale p q of - Just b -> mkNode opts (PresentT b) [lit01' opts msg1 b "fmt=" p <> show1 opts " | " q] hhs - Nothing -> mkNode opts (FailT (msg1 <> " failed to parse")) [msg1 <> " failed"] hhs - --- | A convenience method to match against many different datetime formats to find a match --- --- >>> pl @(ParseTimes LocalTime '["%Y-%m-%d %H:%M:%S", "%m/%d/%y %H:%M:%S", "%B %d %Y %H:%M:%S", "%Y-%m-%dT%H:%M:%S"] "03/11/19 01:22:33") () --- Present 2019-03-11 01:22:33 --- PresentT 2019-03-11 01:22:33 --- --- >>> pl @(ParseTimes LocalTime (Fst Id) (Snd Id)) (["%Y-%m-%d %H:%M:%S", "%m/%d/%y %H:%M:%S", "%B %d %Y %H:%M:%S", "%Y-%m-%dT%H:%M:%S"], "03/11/19 01:22:33") --- Present 2019-03-11 01:22:33 --- PresentT 2019-03-11 01:22:33 --- -data ParseTimes' t p q -type ParseTimes (t :: Type) p q = ParseTimes' (Hole t) p q - -instance (ParseTime (PP t a) - , Typeable (PP t a) - , Show (PP t a) - , P p a - , P q a - , PP p a ~ [String] - , PP q a ~ String - ) => P (ParseTimes' t p q) a where - type PP (ParseTimes' t p q) a = PP t a - eval _ opts a = do - let msg0 = "ParseTimes " <> t - t = showT @(PP t a) - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let msg1 = msg0 - hhs = [hh pp, hh qq] - zs = map (\d -> (d,) <$> parseTimeM @Maybe @(PP t a) True defaultTimeLocale d q) p - in case catMaybes zs of - [] -> mkNode opts (FailT ("no match on [" ++ q ++ "]")) [msg1 <> " no match"] hhs - (d,b):_ -> mkNode opts (PresentT b) [lit01' opts msg1 b "fmt=" d <> show1 opts " | " q] hhs - --- | create a 'Day' from three int values passed in as year month and day --- --- >>> pl @MkDay (2019,12,30) --- Present Just (2019-12-30,1,1) --- PresentT (Just (2019-12-30,1,1)) --- --- >>> pl @(MkDay' (Fst Id) (Snd Id) (Thd Id)) (2019,99,99999) --- Present Nothing --- PresentT Nothing --- --- >>> pl @MkDay (1999,3,13) --- Present Just (1999-03-13,10,6) --- PresentT (Just (1999-03-13,10,6)) --- -data MkDay' p q r -type MkDay = MkDay' (Fst Id) (Snd Id) (Thd Id) - -instance (P p x - , P q x - , P r x - , PP p x ~ Int - , PP q x ~ Int - , PP r x ~ Int - ) => P (MkDay' p q r) x where - type PP (MkDay' p q r) x = Maybe (Day, Int, Int) - eval _ opts x = do - let msg0 = "MkDay" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x - case lr of - Left e -> pure e - Right (p,q,pp,qq) -> do - let hhs = [hh pp, hh qq] - rr <- eval (Proxy @r) opts x - pure $ case getValueLR opts msg0 rr hhs of - Left e -> e - Right r -> - let mday = fromGregorianValid (fromIntegral p) q r - b = mday <&> \day -> - let (_, week, dow) = toWeekDate day - in (day, week, dow) - in mkNode opts (PresentT b) [show01' opts msg0 b "(y,m,d)=" (p,q,r)] (hhs <> [hh rr]) - --- | uncreate a 'Day' returning year month and day --- --- >>> pl @(UnMkDay Id) (read "2019-12-30") --- Present (2019,12,30) --- PresentT (2019,12,30) --- -data UnMkDay p - -instance (PP p x ~ Day, P p x) => P (UnMkDay p) x where - type PP (UnMkDay p) x = (Int, Int, Int) - eval _ opts x = do - let msg0 = "UnMkDay" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let (fromIntegral -> y, m, d) = toGregorian p - b = (y, m, d) - in mkNode opts (PresentT b) [show01 opts msg0 b p] [] - --- | uses the 'Read' of the given type \'t\' and \'p\' which points to the content to read --- --- >>> pl @(ReadP Rational) "4 % 5" --- Present 4 % 5 --- PresentT (4 % 5) --- --- >>> pl @(ReadP' Day Id >> Between (ReadP' Day "2017-04-11") (ReadP' Day "2018-12-30")) "2018-10-12" --- True --- TrueT --- --- >>> pl @(ReadP' Day Id >> Between (ReadP' Day "2017-04-11") (ReadP' Day "2018-12-30")) "2016-10-12" --- False --- FalseT --- -data ReadP'' t p -type ReadP (t :: Type) = ReadP'' (Hole t) Id -type ReadP' (t :: Type) p = ReadP'' (Hole t) p - -instance (P p x - , PP p x ~ String - , Typeable (PP t x) - , Show (PP t x) - , Read (PP t x) - ) => P (ReadP'' t p) x where - type PP (ReadP'' t p) x = PP t x - eval _ opts x = do - let msg0 = "ReadP " <> t - t = showT @(PP t x) - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right s -> - let msg1 = msg0 <> " (" <> s <> ")" - in case reads @(PP t x) s of - [(b,"")] -> mkNode opts (PresentT b) [lit01 opts msg1 b s] [hh pp] - _ -> mkNode opts (FailT (msg1 <> " failed")) [msg1 <> " failed"] [hh pp] - --- | similar to 'minimum' --- --- >>> pl @Min [10,4,5,12,3,4] --- Present 3 --- PresentT 3 --- --- >>> pl @Min [] --- Error empty list --- FailT "empty list" --- -data Min - -instance (Ord a, Show a) => P Min [a] where - type PP Min [a] = a - eval _ opts as' = do - let msg0 = "Min" - pure $ case as' of - [] -> mkNode opts (FailT "empty list") [msg0 <> "(empty list)"] [] - as@(_:_) -> - let v = minimum as - in mkNode opts (PresentT v) [show01 opts msg0 v as] [] - --- | similar to 'maximum' --- --- >>> pl @Max [10,4,5,12,3,4] --- Present 12 --- PresentT 12 --- --- >>> pl @Max [] --- Error empty list --- FailT "empty list" --- - -data Max -type Max' t = FoldMap (SG.Max t) Id - -instance (Ord a, Show a) => P Max [a] where - type PP Max [a] = a - eval _ opts as' = do - let msg0 = "Max" - pure $ case as' of - [] -> mkNode opts (FailT "empty list") [msg0 <> "(empty list)"] [] - as@(_:_) -> - let v = maximum as - in mkNode opts (PresentT v) [show01 opts msg0 v as] [] - --- | sort a list --- --- >>> pl @(SortOn (Fst Id) Id) [(10,"abc"), (3,"def"), (4,"gg"), (10,"xyz"), (1,"z")] --- Present [(1,"z"),(3,"def"),(4,"gg"),(10,"abc"),(10,"xyz")] --- PresentT [(1,"z"),(3,"def"),(4,"gg"),(10,"abc"),(10,"xyz")] --- -data SortBy p q -type SortOn p q = SortBy (OrdA p) q -type SortOnDesc p q = SortBy (Swap >> OrdA p) q - -type SortByHelper p = Partition (p >> Id == 'GT) Id - -instance (P p (a,a) - , P q x - , Show a - , PP q x ~ [a] - , PP p (a,a) ~ Ordering - ) => P (SortBy p q) x where - type PP (SortBy p q) x = PP q x - eval _ opts x = do - let msg0 = "SortBy" - qq <- eval (Proxy @q) opts x - case getValueLR opts (msg0 <> " q failed") qq [] of - Left e -> pure e - Right as -> do - let ff :: MonadEval m => [a] -> m (TT [a]) - ff = \case - [] -> pure $ mkNode opts mempty [msg0 <> " empty"] [] - [w] -> pure $ mkNode opts (PresentT [w]) [msg0 <> " one element " <> show w] [] - w:ys@(_:_) -> do - pp <- (if oDebug opts >= 3 then - eval (Proxy @(SortByHelper p)) - else eval (Proxy @(Hide (SortByHelper p)))) opts (map (w,) ys) --- pp <- eval (Proxy @(Hide (Partition (p >> Id == 'GT) Id))) opts (map (w,) ys) --- too much output: dont need (Map (Snd Id) *** Map (Snd Id)) -- just do map snd in code --- pp <- eval (Proxy @(Partition (p >> (Id == 'GT)) Id >> (Map (Snd Id) *** Map (Snd Id)))) opts (map (w,) ys) - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right (ll', rr') -> do - lhs <- ff (map snd ll') - case getValueLR opts msg0 lhs [] of - Left _ -> pure lhs -- dont rewrap - Right ll -> do - rhs <- ff (map snd rr') - case getValueLR opts msg0 rhs [] of - Left _ -> pure rhs - Right rr -> do - pure $ mkNode opts (PresentT (ll ++ w : rr)) - [msg0 <> show0 opts " lhs=" ll <> " pivot " <> show w <> show0 opts " rhs=" rr] - (hh pp : [hh lhs | length ll > 1] ++ [hh rhs | length rr > 1]) - ret <- ff as - pure $ case getValueLR opts msg0 ret [hh qq] of - Left _e -> ret -- dont rewrap the error - Right xs -> mkNode opts (_tBool ret) [msg0 <> show0 opts " " xs] [hh qq, hh ret] - --- | similar to 'length' --- --- >>> pl @Len [10,4,5,12,3,4] --- Present 6 --- PresentT 6 --- --- >>> pl @Len [] --- Present 0 --- PresentT 0 --- -data Len -instance (Show a, as ~ [a]) => P Len as where - type PP Len as = Int - eval _ opts as = - let msg0 = "Len" - n = length as - in pure $ mkNode opts (PresentT n) [show01 opts msg0 n as] [] - --- | similar to 'length' for 'Foldable' instances --- --- >>> pl @(Length Id) (Left "aa") --- Present 0 --- PresentT 0 --- --- >>> pl @(Length Id) (Right "aa") --- Present 1 --- PresentT 1 --- --- >>> pl @(Length (Right' Id)) (Right "abcd") --- Present 4 --- PresentT 4 --- --- >>> pl @(Length (Thd (Snd Id))) (True,(23,'x',[10,9,1,3,4,2])) --- Present 6 --- PresentT 6 --- -data Length p - -instance (PP p x ~ t a - , P p x - , Show (t a) - , Foldable t) => P (Length p) x where - type PP (Length p) x = Int - eval _ opts x = do - let msg0 = "Length" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right as -> - let n = length as - in mkNode opts (PresentT n) [show01 opts msg0 n as] [] - --- | similar to 'fst' --- --- >>> pl @(Fst Id) (10,"Abc") --- Present 10 --- PresentT 10 --- --- >>> pl @(Fst Id) (10,"Abc",'x') --- Present 10 --- PresentT 10 --- --- >>> pl @(Fst Id) (10,"Abc",'x',False) --- Present 10 --- PresentT 10 --- -data L1 p -type Fst p = L1 p - -instance (Show (ExtractL1T (PP p x)) - , ExtractL1C (PP p x) - , P p x - , Show (PP p x) - ) => P (L1 p) x where - type PP (L1 p) x = ExtractL1T (PP p x) - eval _ opts x = do - let msg0 = "L1" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = extractL1C p - in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] - -class ExtractL1C tp where - type ExtractL1T tp - extractL1C :: tp -> ExtractL1T tp -instance ExtractL1C (a,b) where - type ExtractL1T (a,b) = a - extractL1C (a,_) = a -instance ExtractL1C (a,b,c) where - type ExtractL1T (a,b,c) = a - extractL1C (a,_,_) = a -instance ExtractL1C (a,b,c,d) where - type ExtractL1T (a,b,c,d) = a - extractL1C (a,_,_,_) = a -instance ExtractL1C (a,b,c,d,e) where - type ExtractL1T (a,b,c,d,e) = a - extractL1C (a,_,_,_,_) = a -instance ExtractL1C (a,b,c,d,e,f) where - type ExtractL1T (a,b,c,d,e,f) = a - extractL1C (a,_,_,_,_,_) = a - --- | similar to 'snd' --- --- >>> pl @(Snd Id) (10,"Abc") --- Present "Abc" --- PresentT "Abc" --- --- >>> pl @(Snd Id) (10,"Abc",True) --- Present "Abc" --- PresentT "Abc" --- -data L2 p -type Snd p = L2 p - -instance (Show (ExtractL2T (PP p x)) - , ExtractL2C (PP p x) - , P p x - , Show (PP p x) - ) => P (L2 p) x where - type PP (L2 p) x = ExtractL2T (PP p x) - eval _ opts x = do - let msg0 = "L2" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = extractL2C p - in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] - -class ExtractL2C tp where - type ExtractL2T tp - extractL2C :: tp -> ExtractL2T tp -instance ExtractL2C (a,b) where - type ExtractL2T (a,b) = b - extractL2C (_,b) = b -instance ExtractL2C (a,b,c) where - type ExtractL2T (a,b,c) = b - extractL2C (_,b,_) = b -instance ExtractL2C (a,b,c,d) where - type ExtractL2T (a,b,c,d) = b - extractL2C (_,b,_,_) = b -instance ExtractL2C (a,b,c,d,e) where - type ExtractL2T (a,b,c,d,e) = b - extractL2C (_,b,_,_,_) = b -instance ExtractL2C (a,b,c,d,e,f) where - type ExtractL2T (a,b,c,d,e,f) = b - extractL2C (_,b,_,_,_,_) = b - --- | similar to 3rd element in a n-tuple --- --- >>> pl @(Thd Id) (10,"Abc",133) --- Present 133 --- PresentT 133 --- --- >>> pl @(Thd Id) (10,"Abc",133,True) --- Present 133 --- PresentT 133 --- -data L3 p -type Thd p = L3 p - -instance (Show (ExtractL3T (PP p x)) - , ExtractL3C (PP p x) - , P p x - , Show (PP p x) - ) => P (L3 p) x where - type PP (L3 p) x = ExtractL3T (PP p x) - eval _ opts x = do - let msg0 = "L3" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = extractL3C p - in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] - -class ExtractL3C tp where - type ExtractL3T tp - extractL3C :: tp -> ExtractL3T tp -instance ExtractL3C (a,b) where - type ExtractL3T (a,b) = GL.TypeError ('GL.Text "L3 doesn't work for 2-tuples") - extractL3C _ = error "L3 doesn't work for 2-tuples" -instance ExtractL3C (a,b,c) where - type ExtractL3T (a,b,c) = c - extractL3C (_,_,c) = c -instance ExtractL3C (a,b,c,d) where - type ExtractL3T (a,b,c,d) = c - extractL3C (_,_,c,_) = c -instance ExtractL3C (a,b,c,d,e) where - type ExtractL3T (a,b,c,d,e) = c - extractL3C (_,_,c,_,_) = c -instance ExtractL3C (a,b,c,d,e,f) where - type ExtractL3T (a,b,c,d,e,f) = c - extractL3C (_,_,c,_,_,_) = c - --- | similar to 4th element in a n-tuple --- --- >>> pl @(L4 Id) (10,"Abc",'x',True) --- Present True --- PresentT True --- --- >>> pl @(L4 (Fst (Snd Id))) ('x',((10,"Abc",'x',999),"aa",1),9) --- Present 999 --- PresentT 999 --- -data L4 p - -instance (Show (ExtractL4T (PP p x)) - , ExtractL4C (PP p x) - , P p x - , Show (PP p x) - ) => P (L4 p) x where - type PP (L4 p) x = ExtractL4T (PP p x) - eval _ opts x = do - let msg0 = "L4" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = extractL4C p - in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] - -class ExtractL4C tp where - type ExtractL4T tp - extractL4C :: tp -> ExtractL4T tp -instance ExtractL4C (a,b) where - type ExtractL4T (a,b) = GL.TypeError ('GL.Text "L4 doesn't work for 2-tuples") - extractL4C _ = error "L4 doesn't work for 2-tuples" -instance ExtractL4C (a,b,c) where - type ExtractL4T (a,b,c) = GL.TypeError ('GL.Text "L4 doesn't work for 3-tuples") - extractL4C _ = error "L4 doesn't work for 3-tuples" -instance ExtractL4C (a,b,c,d) where - type ExtractL4T (a,b,c,d) = d - extractL4C (_,_,_,d) = d -instance ExtractL4C (a,b,c,d,e) where - type ExtractL4T (a,b,c,d,e) = d - extractL4C (_,_,_,d,_) = d -instance ExtractL4C (a,b,c,d,e,f) where - type ExtractL4T (a,b,c,d,e,f) = d - extractL4C (_,_,_,d,_,_) = d - --- | similar to 5th element in a n-tuple --- --- >>> pl @(L5 Id) (10,"Abc",'x',True,1) --- Present 1 --- PresentT 1 --- -data L5 p - -instance (Show (ExtractL5T (PP p x)) - , ExtractL5C (PP p x) - , P p x - , Show (PP p x) - ) => P (L5 p) x where - type PP (L5 p) x = ExtractL5T (PP p x) - eval _ opts x = do - let msg0 = "L5" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = extractL5C p - in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] - -class ExtractL5C tp where - type ExtractL5T tp - extractL5C :: tp -> ExtractL5T tp -instance ExtractL5C (a,b) where - type ExtractL5T (a,b) = GL.TypeError ('GL.Text "L5 doesn't work for 2-tuples") - extractL5C _ = error "L5 doesn't work for 2-tuples" -instance ExtractL5C (a,b,c) where - type ExtractL5T (a,b,c) = GL.TypeError ('GL.Text "L5 doesn't work for 3-tuples") - extractL5C _ = error "L5 doesn't work for 3-tuples" -instance ExtractL5C (a,b,c,d) where - type ExtractL5T (a,b,c,d) = GL.TypeError ('GL.Text "L5 doesn't work for 4-tuples") - extractL5C _ = error "L5 doesn't work for 4-tuples" -instance ExtractL5C (a,b,c,d,e) where - type ExtractL5T (a,b,c,d,e) = e - extractL5C (_,_,_,_,e) = e -instance ExtractL5C (a,b,c,d,e,f) where - type ExtractL5T (a,b,c,d,e,f) = e - extractL5C (_,_,_,_,e,_) = e - - --- | similar to 6th element in a n-tuple --- --- >>> pl @(L6 Id) (10,"Abc",'x',True,1,99) --- Present 99 --- PresentT 99 --- -data L6 p - -instance (Show (ExtractL6T (PP p x)) - , ExtractL6C (PP p x) - , P p x - , Show (PP p x) - ) => P (L6 p) x where - type PP (L6 p) x = ExtractL6T (PP p x) - eval _ opts x = do - let msg0 = "L6" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = extractL6C p - in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] - -class ExtractL6C tp where - type ExtractL6T tp - extractL6C :: tp -> ExtractL6T tp -instance ExtractL6C (a,b) where - type ExtractL6T (a,b) = GL.TypeError ('GL.Text "L6 doesn't work for 2-tuples") - extractL6C _ = error "L6 doesn't work for 2-tuples" -instance ExtractL6C (a,b,c) where - type ExtractL6T (a,b,c) = GL.TypeError ('GL.Text "L6 doesn't work for 3-tuples") - extractL6C _ = error "L6 doesn't work for 3-tuples" -instance ExtractL6C (a,b,c,d) where - type ExtractL6T (a,b,c,d) = GL.TypeError ('GL.Text "L6 doesn't work for 4-tuples") - extractL6C _ = error "L6 doesn't work for 4-tuples" -instance ExtractL6C (a,b,c,d,e) where - type ExtractL6T (a,b,c,d,e) = GL.TypeError ('GL.Text "L6 doesn't work for 5-tuples") - extractL6C _ = error "L6 doesn't work for 5-tuples" -instance ExtractL6C (a,b,c,d,e,f) where - type ExtractL6T (a,b,c,d,e,f) = f - extractL6C (_,_,_,_,_,f) = f - - --- | 'fromString' function where you need to provide the type \'t\' of the result --- --- >>> :set -XOverloadedStrings --- >>> pl @(FromStringP (Identity _) Id) "abc" --- Present Identity "abc" --- PresentT (Identity "abc") --- --- >>> pl @(FromStringP (Seq.Seq _) Id) "abc" --- Present fromList "abc" --- PresentT (fromList "abc") -data FromStringP' t s -type FromStringP (t :: Type) p = FromStringP' (Hole t) p - -instance (P s a - , PP s a ~ String - , Show (PP t a) - , IsString (PP t a) - ) => P (FromStringP' t s) a where - type PP (FromStringP' t s) a = PP t a - eval _ opts a = do - let msg0 = "FromStringP" - ss <- eval (Proxy @s) opts a - pure $ case getValueLR opts msg0 ss [] of - Left e -> e - Right s -> - let b = fromString @(PP t a) s - in mkNode opts (PresentT b) [msg0 <> show0 opts " " b] [hh ss] - - --- | 'fromInteger' function where you need to provide the type \'t\' of the result --- --- >>> pl @(FromInteger (SG.Sum _) Id) 23 --- Present Sum {getSum = 23} --- PresentT (Sum {getSum = 23}) -data FromInteger' t n -type FromInteger (t :: Type) p = FromInteger' (Hole t) p -type FromIntegerP n = FromInteger' Unproxy n - -instance (Num (PP t a) - , Integral (PP n a) - , P n a - , Show (PP t a) - ) => P (FromInteger' t n) a where - type PP (FromInteger' t n) a = PP t a - eval _ opts a = do - let msg0 = "FromInteger" - nn <- eval (Proxy @n) opts a - pure $ case getValueLR opts msg0 nn [] of - Left e -> e - Right n -> - let b = fromInteger (fromIntegral n) - in mkNode opts (PresentT b) [msg0 <> show0 opts " " b] [hh nn] - --- | 'fromIntegral' function where you need to provide the type \'t\' of the result --- --- >>> pl @(FromIntegral (SG.Sum _) Id) 23 --- Present Sum {getSum = 23} --- PresentT (Sum {getSum = 23}) -data FromIntegral' t n -type FromIntegral (t :: Type) p = FromIntegral' (Hole t) p - -instance (Num (PP t a) - , Integral (PP n a) - , P n a - , Show (PP t a) - , Show (PP n a) - ) => P (FromIntegral' t n) a where - type PP (FromIntegral' t n) a = PP t a - eval _ opts a = do - let msg0 = "FromIntegral" - nn <- eval (Proxy @n) opts a - pure $ case getValueLR opts msg0 nn [] of - Left e -> e - Right n -> - let b = fromIntegral n - in mkNode opts (PresentT b) [show01 opts msg0 b n] [hh nn] - --- | 'toRational' function --- --- >>> pl @(ToRational Id) 23.5 --- Present 47 % 2 --- PresentT (47 % 2) - -data ToRational p - -instance (a ~ PP p x - , Show a - , Real a - , P p x) - => P (ToRational p) x where - type PP (ToRational p) x = Rational - eval _ opts x = do - let msg0 = "ToRational" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right a -> - let r = (toRational a) - in mkNode opts (PresentT r) [show01 opts msg0 r a] [hh pp] - --- | 'fromRational' function where you need to provide the type \'t\' of the result --- --- >>> pl @(FromRational Rational Id) 23.5 --- Present 47 % 2 --- PresentT (47 % 2) -data FromRational' t r -type FromRational (t :: Type) p = FromRational' (Hole t) p - -instance (P r a - , PP r a ~ Rational - , Show (PP t a) - , Fractional (PP t a) - ) => P (FromRational' t r) a where - type PP (FromRational' t r) a = PP t a - eval _ opts a = do - let msg0 = "FromRational" - rr <- eval (Proxy @r) opts a - pure $ case getValueLR opts msg0 rr [] of - Left e -> e - Right r -> - let b = fromRational @(PP t a) r - in mkNode opts (PresentT b) [show01 opts msg0 b r] [hh rr] - --- | 'truncate' function where you need to provide the type \'t\' of the result --- --- >>> pl @(Truncate Int Id) (23 % 5) --- Present 4 --- PresentT 4 -data Truncate' t p -type Truncate (t :: Type) p = Truncate' (Hole t) p - -instance (Show (PP p x) - , P p x - , Show (PP t x) - , RealFrac (PP p x) - , Integral (PP t x) - ) => P (Truncate' t p) x where - type PP (Truncate' t p) x = PP t x - eval _ opts x = do - let msg0 = "Truncate" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = truncate p - in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] - --- | 'ceiling' function where you need to provide the type \'t\' of the result --- --- >>> pl @(Ceiling Int Id) (23 % 5) --- Present 5 --- PresentT 5 -data Ceiling' t p -type Ceiling (t :: Type) p = Ceiling' (Hole t) p - -instance (Show (PP p x) - , P p x - , Show (PP t x) - , RealFrac (PP p x) - , Integral (PP t x) - ) => P (Ceiling' t p) x where - type PP (Ceiling' t p) x = PP t x - eval _ opts x = do - let msg0 = "Ceiling" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = ceiling p - in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] - --- | 'floor' function where you need to provide the type \'t\' of the result --- --- >>> pl @(Floor Int Id) (23 % 5) --- Present 4 --- PresentT 4 -data Floor' t p -type Floor (t :: Type) p = Floor' (Hole t) p - -instance (Show (PP p x) - , P p x - , Show (PP t x) - , RealFrac (PP p x) - , Integral (PP t x) - ) => P (Floor' t p) x where - type PP (Floor' t p) x = PP t x - eval _ opts x = do - let msg0 = "Floor" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = floor p - in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] - --- | converts a value to a 'Proxy': the same as '\'Proxy' --- --- >>> pl @MkProxy 'x' --- Present Proxy --- PresentT Proxy --- -data MkProxy - -instance Show a => P MkProxy a where - type PP MkProxy a = Proxy a - eval _ opts a = - let msg0 = "MkProxy" - b = Proxy @a - in pure $ mkNode opts (PresentT b) [msg0 <> show1 opts " | " a] [] - -type family DoExpandT (ps :: [k]) :: Type where - DoExpandT '[] = GL.TypeError ('GL.Text "'[] invalid: requires at least one predicate in the list") - DoExpandT '[p] = Id >> p -- need this else fails cos 1 is nat and would mean that the result is nat not Type! - -- if p >> Id then turns TrueT to PresentT True - DoExpandT (p ': p1 ': ps) = p >> DoExpandT (p1 ': ps) - --- | processes a type level list predicates running each in sequence: see 'Predicate.>>' --- --- >>> pl @(Do [Pred Id, ShowP Id, Id &&& Len]) 9876543 --- Present ("9876542",7) --- PresentT ("9876542",7) --- --- >>> pl @(Do '[W 123, W "xyz", Len &&& Id, Pred Id *** Id<>Id]) () --- Present (2,"xyzxyz") --- PresentT (2,"xyzxyz") --- -data Do (ps :: [k]) -instance (P (DoExpandT ps) a) => P (Do ps) a where - type PP (Do ps) a = PP (DoExpandT ps) a - eval _ = eval (Proxy @(DoExpandT ps)) - --- | Convenient method to convert a value \'p\' to a 'Maybe' based on a predicate '\b\' --- if '\b\' then Just \'p'\ else Nothing --- --- >>> pl @(MaybeB (Id > 4) Id) 24 --- Present Just 24 --- PresentT (Just 24) --- --- >>> pl @(MaybeB (Id > 4) Id) (-5) --- Present Nothing --- PresentT Nothing --- -data MaybeB b p - -instance (Show (PP p a) - , P b a - , P p a - , PP b a ~ Bool - ) => P (MaybeB b p) a where - type PP (MaybeB b p) a = Maybe (PP p a) - eval _ opts z = do - let msg0 = "MaybeB" - bb <- evalBool (Proxy @b) opts z - case getValueLR opts (msg0 <> " b failed") bb [] of - Left e -> pure e - Right True -> do - pp <- eval (Proxy @p) opts z - pure $ case getValueLR opts (msg0 <> " p failed") pp [hh bb] of - Left e -> e - Right p -> mkNode opts (PresentT (Just p)) [msg0 <> "(False)" <> show0 opts " Just " p] [hh bb, hh pp] - Right False -> pure $ mkNode opts (PresentT Nothing) [msg0 <> "(True)"] [hh bb] - --- | Convenient method to convert a \'p\' or '\q'\ to a 'Either' based on a predicate '\b\' --- if \'b\' then Right \'p\' else Left '\q\' --- --- >>> pl @(EitherB (Fst Id > 4) (Snd Id >> Fst Id) (Snd Id >> Snd Id)) (24,(-1,999)) --- Present Right 999 --- PresentT (Right 999) --- --- >>> pl @(EitherB (Fst Id > 4) (Snd Id >> Fst Id) (Snd Id >> Snd Id)) (1,(-1,999)) --- Present Left (-1) --- PresentT (Left (-1)) --- -data EitherB b p q - -instance (Show (PP p a) - , P p a - , Show (PP q a) - , P q a - , P b a - , PP b a ~ Bool - ) => P (EitherB b p q) a where - type PP (EitherB b p q) a = Either (PP p a) (PP q a) - eval _ opts z = do - let msg0 = "EitherB" - bb <- evalBool (Proxy @b) opts z - case getValueLR opts (msg0 <> " b failed") bb [] of - Left e -> pure e - Right False -> do - pp <- eval (Proxy @p) opts z - pure $ case getValueLR opts (msg0 <> " p failed") pp [hh bb] of - Left e -> e - Right p -> mkNode opts (PresentT (Left p)) [msg0 <> "(False)" <> show0 opts " Left " p] [hh bb, hh pp] - Right True -> do - qq <- eval (Proxy @q) opts z - pure $ case getValueLR opts (msg0 <> " q failed") qq [hh bb] of - Left e -> e - Right q -> mkNode opts (PresentT (Right q)) [msg0 <> "(True)" <> show0 opts " Right " q] [hh bb, hh qq] - --- | create inductive tuples from a type level list of predicates --- --- >>> pl @(TupleI '[Id,ShowP Id,Pred Id,W "str", W 999]) 666 --- Present (666,("666",(665,("str",(999,()))))) --- PresentT (666,("666",(665,("str",(999,()))))) --- --- >>> pl @(TupleI '[W 999,W "somestring",W 'True, Id, ShowP (Pred Id)]) 23 --- Present (999,("somestring",(True,(23,("22",()))))) --- PresentT (999,("somestring",(True,(23,("22",()))))) --- -data TupleI (ps :: [k]) -- make it an inductive tuple - -instance P (TupleI ('[] :: [k])) a where - type PP (TupleI ('[] :: [k])) a = () - eval _ opts _ = pure $ mkNode opts (PresentT ()) ["TupleI(done)"] [] - -instance (P p a - , P (TupleI ps) a - , Show a - ) => P (TupleI (p ': ps)) a where - type PP (TupleI (p ': ps)) a = (PP p a, PP (TupleI ps) a) - eval _ opts a = do - pp <- eval (Proxy @p) opts a - let msg0 = "TupleI" -- "'[](" <> show len <> ")" - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right w -> do - qq <- eval (Proxy @(TupleI ps)) opts a - pure $ case getValueLR opts msg0 qq [hh pp] of - Left e -> e - -- only PresentP makes sense here (ie not TrueP/FalseP: ok in base case tho - Right ws -> mkNode opts (PresentT (w,ws)) [msg0 <> show0 opts " " a] [hh pp, hh qq] - -type Msg' prt p = Msg (Printf "[%s] " prt) p -- msg0 is in square brackets - --- | pad \'q\' with '\n'\ values from '\p'\ --- --- >>> pl @(PadL 5 999 Id) [12,13] --- Present [999,999,999,12,13] --- PresentT [999,999,999,12,13] --- --- >>> pl @(PadR 5 (Fst Id) '[12,13]) (999,'x') --- Present [12,13,999,999,999] --- PresentT [12,13,999,999,999] --- --- >>> pl @(PadR 2 (Fst Id) '[12,13,14]) (999,'x') --- Present [12,13,14] --- PresentT [12,13,14] --- -data Pad (left :: Bool) n p q -type PadL n p q = Pad 'True n p q -type PadR n p q = Pad 'False n p q - -instance (P n a - , GetBool left - , Integral (PP n a) - , [PP p a] ~ PP q a - , P p a - , P q a - , Show (PP p a) - ) => P (Pad left n p q) a where - type PP (Pad left n p q) a = PP q a - eval _ opts a = do - let msg0 = "Pad" <> (if lft then "L" else "R") - lft = getBool @left - lr <- runPQ msg0 (Proxy @n) (Proxy @p) opts a - case lr of - Left e -> pure e - Right (fromIntegral -> n,p,nn,pp) -> do - let msg1 = msg0 <> show0 opts " " n <> " pad=" <> show p - hhs = [hh nn, hh pp] - qq <- eval (Proxy @q) opts a - pure $ case getValueLR opts (msg1 <> " q failed") qq hhs of - Left e -> e - Right q -> - let l = length q - diff = if n<=l then 0 else n-l - bs = if lft - then (replicate diff p) <> q - else q <> (replicate diff p) - in mkNode opts (PresentT bs) [show01 opts msg1 bs q] (hhs <> [hh qq]) - --- | split a list \'p\' into parts using the lengths in the type level list \'ns\' --- --- >>> pl @(SplitAts '[2,3,1,1] Id) "hello world" --- Present ["he","llo"," ","w","orld"] --- PresentT ["he","llo"," ","w","orld"] --- --- >>> pl @(SplitAts '[2] Id) "hello world" --- Present ["he","llo world"] --- PresentT ["he","llo world"] --- --- >>> pl @(SplitAts '[10,1,1,5] Id) "hello world" --- Present ["hello worl","d","",""] --- PresentT ["hello worl","d","",""] --- -data SplitAts ns p -instance (P ns x - , P p x - , PP p x ~ [a] - , Show n - , Show a - , PP ns x ~ [n] - , Integral n - ) => P (SplitAts ns p) x where - type PP (SplitAts ns p) x = [PP p x] - eval _ opts x = do - let msg0 = "SplitAts" - lr <- runPQ msg0 (Proxy @ns) (Proxy @p) opts x - pure $ case lr of - Left e -> e - Right (ns,p,nn,pp) -> - let zs = foldr (\n k s -> let (a,b) = splitAt (fromIntegral n) s - in a:k b - ) (\as -> if null as then [] else [as]) ns p - in mkNode opts (PresentT zs) [show01' opts msg0 zs "ns=" ns <> show1 opts " | " p] [hh nn, hh pp] - --- | similar to 'splitAt' --- --- >>> pl @(SplitAt 4 Id) "hello world" --- Present ("hell","o world") --- PresentT ("hell","o world") --- --- >>> pl @(SplitAt 20 Id) "hello world" --- Present ("hello world","") --- PresentT ("hello world","") --- --- >>> pl @(SplitAt 0 Id) "hello world" --- Present ("","hello world") --- PresentT ("","hello world") --- --- >>> pl @(SplitAt (Snd Id) (Fst Id)) ("hello world",4) --- Present ("hell","o world") --- PresentT ("hell","o world") --- -data SplitAt n p -type Take n p = Fst (SplitAt n p) -type Drop n p = Snd (SplitAt n p) - -instance (PP p a ~ [b] - , P n a - , P p a - , Show b - , Integral (PP n a) - ) => P (SplitAt n p) a where - type PP (SplitAt n p) a = (PP p a, PP p a) - eval _ opts a = do - let msg0 = "SplitAt" - lr <- runPQ msg0 (Proxy @n) (Proxy @p) opts a - pure $ case lr of - Left e -> e -- (Left e, tt') - Right (fromIntegral -> n,p,pp,qq) -> - let msg1 = msg0 <> show0 opts " " n <> show0 opts " " p - (x,y) = splitAt n p - ret = (x,y) - in mkNode opts (PresentT ret) [show01' opts msg1 ret "n=" n <> show1 opts " | " p] [hh pp, hh qq] - -type Tail = Uncons >> 'Just (Snd Id) -type Head = Uncons >> 'Just (Fst Id) -type Init = Unsnoc >> 'Just (Fst Id) -type Last = Unsnoc >> 'Just (Snd Id) - --- | similar to 'Control.Arrow.&&&' -type p &&& q = W '(p, q) -infixr 3 &&& - --- | similar to 'Control.Arrow.***' --- --- >>> pl @(Pred Id *** ShowP Id) (13, True) --- Present (12,"True") --- PresentT (12,"True") --- -data (p :: k) *** (q :: k1) -type Star p q = p *** q -infixr 3 *** -type First p = Star p I -type Second q = Star I q - -instance (Show (PP p a) - , Show (PP q b) - , P p a - , P q b - , Show a - , Show b - ) => P (p *** q) (a,b) where - type PP (p *** q) (a,b) = (PP p a, PP q b) - eval _ opts (a,b) = do - let msg0 = "(***)" - pp <- eval (Proxy @p) opts a - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right a1 -> do - qq <- eval (Proxy @q) opts b - pure $ case getValueLR opts msg0 qq [hh pp] of - Left e -> e - Right b1 -> mkNode opts (PresentT (a1,b1)) [msg0 <> show0 opts " " (a1,b1) <> show1 opts " | " (a,b)] [hh pp, hh qq] - --- | similar 'Control.Arrow.|||' --- --- >>> pl @(Pred Id ||| Id) (Left 13) --- Present 12 --- PresentT 12 --- --- >>> pl @(ShowP Id ||| Id) (Right "hello") --- Present "hello" --- PresentT "hello" --- -data (|||) (p :: k) (q :: k1) -infixr 2 ||| -type EitherIn p q = p ||| q -type IsLeft = 'True ||| 'False -type IsRight = 'False ||| 'True - -instance (Show (PP p a) - , P p a - , P q b - , PP p a ~ PP q b - , Show a - , Show b - ) => P (p ||| q) (Either a b) where - type PP (p ||| q) (Either a b) = PP p a - eval _ opts lr = do - let msg0 = "|||" - case lr of - Left a -> do - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right a1 -> let msg1 = msg0 ++ " Left" - in mkNode opts (_tBool pp) [show01 opts msg1 a1 a] [hh pp] - Right a -> do - qq <- eval (Proxy @q) opts a - pure $ case getValueLR opts msg0 qq [] of - Left e -> e - Right a1 -> - let msg1 = msg0 ++ " Right" - in mkNode opts (_tBool qq) [show01 opts msg1 a1 a] [hh qq] - --- | similar 'Control.Arrow.+++' --- --- >>> pl @(Pred Id +++ Id) (Left 13) --- Present Left 12 --- PresentT (Left 12) --- --- >>> pl @(ShowP Id +++ Reverse) (Right "hello") --- Present Right "olleh" --- PresentT (Right "olleh") --- -data (+++) (p :: k) (q :: k1) -infixr 2 +++ - -instance (Show (PP p a) - , Show (PP q b) - , P p a - , P q b - , Show a - , Show b - ) => P (p +++ q) (Either a b) where - type PP (p +++ q) (Either a b) = Either (PP p a) (PP q b) - eval _ opts lr = do - let msg0 = "+++" - case lr of - Left a -> do - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right a1 -> - let msg1 = msg0 ++ " Left" - in mkNode opts (PresentT (Left a1)) [msg1 <> show0 opts " Left " a1 <> show1 opts " | " a] [hh pp] - Right a -> do - qq <- eval (Proxy @q) opts a - pure $ case getValueLR opts msg0 qq [] of - Left e -> e - Right a1 -> - let msg1 = msg0 ++ " Right" - in mkNode opts (PresentT (Right a1)) [msg1 <> show0 opts " Right" a1 <> show1 opts " | " a] [hh qq] - -type Dup = '(Id, Id) - -data BinOp = BMult | BSub | BAdd deriving (Show,Eq) - -type Mult p q = Bin 'BMult p q -type Add p q = Bin 'BAdd p q -type Sub p q = Bin 'BSub p q - -type p + q = Add p q -infixl 6 + -type p - q = Sub p q -infixl 6 - -type p * q = Mult p q -infixl 7 * - -type p > q = Cmp 'Cgt p q -infix 4 > -type p >= q = Cmp 'Cge p q -infix 4 >= -type p == q = Cmp 'Ceq p q -infix 4 == -type p /= q = Cmp 'Cne p q -infix 4 /= -type p <= q = Cmp 'Cle p q -infix 4 <= -type p < q = Cmp 'Clt p q -infix 4 < - -type p >? q = CmpI 'Cgt p q -infix 4 >? -type p >=? q = CmpI 'Cge p q -infix 4 >=? -type p ==? q = CmpI 'Ceq p q -infix 4 ==? -type p /=? q = CmpI 'Cne p q -infix 4 /=? -type p <=? q = CmpI 'Cle p q -infix 4 <=? -type p <? q = CmpI 'Clt p q -infix 4 <? - -class GetBinOp (k :: BinOp) where - getBinOp :: (Num a, a ~ b) => (String, a -> b -> a) - -instance GetBinOp 'BMult where - getBinOp = ("*",(*)) -instance GetBinOp 'BSub where - getBinOp = ("-",(-)) -instance GetBinOp 'BAdd where - getBinOp = ("+",(+)) - --- | addition, multiplication and subtraction --- --- >>> pl @(Fst Id * Snd Id) (13,5) --- Present 65 --- PresentT 65 --- --- >>> pl @(Fst Id + 4 * (Snd Id >> Len) - 4) (3,"hello") --- Present 19 --- PresentT 19 --- -data Bin (op :: BinOp) p q - -instance (GetBinOp op - , PP p a ~ PP q a - , P p a - , P q a - , Show (PP p a) - , Num (PP p a) - ) => P (Bin op p q) a where - type PP (Bin op p q) a = PP p a - eval _ opts a = do - let (s,f) = getBinOp @op - lr <- runPQ s (Proxy @p) (Proxy @q) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = p `f` q - in mkNode opts (PresentT d) [show p <> " " <> s <> " " <> show q <> " = " <> show d] [hh pp, hh qq] - --- | fractional division --- --- >>> pl @(Fst Id / Snd Id) (13,2) --- Present 6.5 --- PresentT 6.5 --- --- >>> pl @(ToRational 13 / Id) 0 --- Error DivF zero denominator --- FailT "DivF zero denominator" --- -data DivF p q -type p / q = DivF p q -infixl 7 / - -instance (PP p a ~ PP q a - , Eq (PP q a) - , P p a - , P q a - , Show (PP p a) - , Fractional (PP p a) - ) => P (DivF p q) a where - type PP (DivF p q) a = PP p a - eval _ opts a = do - let msg0 = "DivF" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) - | q == 0 -> let msg1 = msg0 <> " zero denominator" - in mkNode opts (FailT msg1) [msg1] [hh pp, hh qq] - | otherwise -> - let d = p / q - in mkNode opts (PresentT d) [show p <> " / " <> show q <> " = " <> show d] [hh pp, hh qq] - --- | creates a 'Rational' value --- --- >>> pl @(Id < 21 % 5) (-3.1) --- True --- TrueT --- --- >>> pl @(Id < 21 % 5) 4.5 --- False --- FalseT --- --- >>> pl @(Fst Id % Snd Id) (13,2) --- Present 13 % 2 --- PresentT (13 % 2) --- --- >>> pl @(13 % Id) 0 --- Error MkRatio zero denominator --- FailT "MkRatio zero denominator" --- --- >>> pl @(4 % 3 + 5 % 7) "asfd" --- Present 43 % 21 --- PresentT (43 % 21) --- --- >>> pl @(4 %- 7 * 5 %- 3) "asfd" --- Present 20 % 21 --- PresentT (20 % 21) --- --- >>> pl @(Negate (14 % 3)) () --- Present (-14) % 3 --- PresentT ((-14) % 3) --- --- >>> pl @(14 % 3) () --- Present 14 % 3 --- PresentT (14 % 3) --- --- >>> pl @(Negate (14 % 3) === FromIntegral _ (Negate 5)) () --- Present GT --- PresentT GT --- --- >>> pl @(14 -% 3 === 5 %- 1) "aa" --- Present GT --- PresentT GT --- --- >>> pl @(Negate (14 % 3) === Negate 5 % 2) () --- Present LT --- PresentT LT --- --- >>> pl @(14 -% 3 * 5 -% 1) () --- Present 70 % 3 --- PresentT (70 % 3) --- --- >>> pl @(14 % 3 === 5 % 1) () --- Present LT --- PresentT LT --- --- >>> pl @(15 % 3 / 4 % 2) () --- Present 5 % 2 --- PresentT (5 % 2) --- -data p % q -infixl 8 % - -type p %- q = Negate (p % q) -infixl 8 %- -type p -% q = Negate (p % q) -infixl 8 -% - -instance (Integral (PP p x) - , Integral (PP q x) - , Eq (PP q x) - , P p x - , P q x - , Show (PP p x) - , Show (PP q x) - ) => P (p % q) x where - type PP (p % q) x = Rational - eval _ opts x = do - let msg0 = "MkRatio" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) - | q == 0 -> let msg1 = msg0 <> " zero denominator" - in mkNode opts (FailT msg1) [msg1] [hh pp, hh qq] - | otherwise -> - let d = fromIntegral p % fromIntegral q - in mkNode opts (PresentT d) [show p <> " % " <> show q <> " = " <> show d] [hh pp, hh qq] - - --- | similar to 'negate' --- --- >>> pl @(Negate Id) 14 --- Present -14 --- PresentT (-14) --- --- >>> pl @(Negate (Fst Id * Snd Id)) (14,3) --- Present -42 --- PresentT (-42) --- --- >>> pl @(Negate (15 %- 4)) "abc" --- Present 15 % 4 --- PresentT (15 % 4) --- --- >>> pl @(Negate (15 % 3)) () --- Present (-5) % 1 --- PresentT ((-5) % 1) --- --- >>> pl @(Negate (Fst Id % Snd Id)) (14,3) --- Present (-14) % 3 --- PresentT ((-14) % 3) --- -data Negate p - -instance (Show (PP p x), Num (PP p x), P p x) => P (Negate p) x where - type PP (Negate p) x = PP p x - eval _ opts x = do - let msg0 = "Negate" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = negate p - in mkNode opts (PresentT d) [show01 opts msg0 d p] [hh pp] - - --- | similar to 'abs' --- --- >>> pl @(Abs Id) (-14) --- Present 14 --- PresentT 14 --- --- >>> pl @(Abs (Snd Id)) ("xx",14) --- Present 14 --- PresentT 14 --- --- >>> pl @(Abs Id) 0 --- Present 0 --- PresentT 0 --- --- >>> pl @(Abs (Negate 44)) "aaa" --- Present 44 --- PresentT 44 --- -data Abs p - -instance (Show (PP p x), Num (PP p x), P p x) => P (Abs p) x where - type PP (Abs p) x = PP p x - eval _ opts x = do - let msg0 = "Abs" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = abs p - in mkNode opts (PresentT d) [show01 opts msg0 d p] [hh pp] - - - --- | similar to 'signum' --- --- >>> pl @(Signum Id) (-14) --- Present -1 --- PresentT (-1) --- --- >>> pl @(Signum Id) 14 --- Present 1 --- PresentT 1 --- --- >>> pl @(Signum Id) 0 --- Present 0 --- PresentT 0 --- -data Signum p - -instance (Show (PP p x), Num (PP p x), P p x) => P (Signum p) x where - type PP (Signum p) x = PP p x - eval _ opts x = do - let msg0 = "Signum" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = signum p - in mkNode opts (PresentT d) [show01 opts msg0 d p] [hh pp] - --- | unwraps a value (see 'Control.Lens.Unwrapped') --- --- >>> pl @(Unwrap Id) (SG.Sum (-13)) --- Present -13 --- PresentT (-13) --- -data Unwrap p - -instance (PP p x ~ s - , P p x - , Show s - , Show (Unwrapped s) - , Wrapped s - ) => P (Unwrap p) x where - type PP (Unwrap p) x = Unwrapped (PP p x) - eval _ opts x = do - let msg0 = "Unwrap" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = p ^. _Wrapped' - in mkNode opts (PresentT d) [show01 opts msg0 d p] [hh pp] - --- | wraps a value (see 'Control.Lens.Wrapped' and 'Control.Lens.Unwrapped') --- --- >>> :m + Data.List.NonEmpty --- >>> pl @(Wrap (SG.Sum _) Id) (-13) --- Present Sum {getSum = -13} --- PresentT (Sum {getSum = -13}) --- --- >>> pl @(Wrap SG.Any (Ge 4)) 13 --- Present Any {getAny = True} --- PresentT (Any {getAny = True}) --- --- >>> pl @(Wrap (NonEmpty _) (Uncons >> 'Just Id)) "abcd" --- Present 'a' :| "bcd" --- PresentT ('a' :| "bcd") --- -data Wrap' t p -type Wrap (t :: Type) p = Wrap' (Hole t) p - -instance (Show (PP p x) - , P p x - , Unwrapped (PP s x) ~ PP p x - , Wrapped (PP s x) - , Show (PP s x) - ) => P (Wrap' s p) x where - type PP (Wrap' s p) x = PP s x - eval _ opts x = do - let msg0 = "Wrap" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = p ^. _Unwrapped' - in mkNode opts (PresentT d) [show01 opts msg0 d p] [hh pp] - --- | similar to 'coerce' --- --- >>> pl @(Coerce (SG.Sum Integer)) (Identity (-13)) --- Present Sum {getSum = -13} --- PresentT (Sum {getSum = -13}) --- -data Coerce (t :: k) - -instance (Show a - , Show t - , Coercible t a - ) => P (Coerce t) a where - type PP (Coerce t) a = t - eval _ opts a = - let msg0 = "Coerce" - d = a ^. coerced - in pure $ mkNode opts (PresentT d) [show01 opts msg0 d a] [] - --- can coerce over a functor: but need to provide type of 'a' and 't' explicitly - --- | see 'Coerce': coerce over a functor --- --- >>> pl @(Coerce2 (SG.Sum Integer)) [Identity (-13), Identity 4, Identity 99] --- Present [Sum {getSum = -13},Sum {getSum = 4},Sum {getSum = 99}] --- PresentT [Sum {getSum = -13},Sum {getSum = 4},Sum {getSum = 99}] --- --- >>> pl @(Coerce2 (SG.Sum Integer)) (Just (Identity (-13))) --- Present Just (Sum {getSum = -13}) --- PresentT (Just (Sum {getSum = -13})) --- --- >>> pl @(Coerce2 (SG.Sum Int)) (Nothing @(Identity Int)) --- Present Nothing --- PresentT Nothing --- -data Coerce2 (t :: k) -instance (Show (f a) - , Show (f t) - , Coercible t a - , Functor f - ) => P (Coerce2 t) (f a) where - type PP (Coerce2 t) (f a) = f t - eval _ opts fa = - let msg0 = "Coerce2" - d = view coerced <$> fa - in pure $ mkNode opts (PresentT d) [show01 opts msg0 d fa] [] - --- | lift mempty over a Functor --- --- >>> pl @(MEmptyT2 (SG.Product Int)) [Identity (-13), Identity 4, Identity 99] --- Present [Product {getProduct = 1},Product {getProduct = 1},Product {getProduct = 1}] --- PresentT [Product {getProduct = 1},Product {getProduct = 1},Product {getProduct = 1}] --- -data MEmptyT2' t -type MEmptyT2 t = MEmptyT2' (Hole t) - -instance (Show (f a) - , Show (f (PP t (f a))) - , Functor f - , Monoid (PP t (f a)) - ) => P (MEmptyT2' t) (f a) where - type PP (MEmptyT2' t) (f a) = f (PP t (f a)) - eval _ opts fa = - let msg0 = "MEmptyT2" - b = mempty <$> fa - in pure $ mkNode opts (PresentT b) [show01 opts msg0 b fa] [] - --- | lift pure over a Functor --- --- >>> pl @(Pure2 (Either String)) [1,2,4] --- Present [Right 1,Right 2,Right 4] --- PresentT [Right 1,Right 2,Right 4] --- -data Pure2 (t :: Type -> Type) -type Right t = Pure (Either t) Id -type Left t = Right t >> Swap - -instance (Show (f (t a)) - , Show (f a) - , Applicative t - , Functor f - ) => P (Pure2 t) (f a) where - type PP (Pure2 t) (f a) = f (t a) - eval _ opts fa = - let msg0 = "Pure2" - b = fmap pure fa - in pure $ mkNode opts (PresentT b) [show01 opts msg0 b fa] [] - --- | similar to 'reverse' --- --- >>> pl @Reverse [1,2,4] --- Present [4,2,1] --- PresentT [4,2,1] --- --- >>> pl @Reverse "AbcDeF" --- Present "FeDcbA" --- PresentT "FeDcbA" --- -data Reverse - -instance (Show a, as ~ [a]) => P Reverse as where - type PP Reverse as = as - eval _ opts as = - let msg0 = "Reverse" - d = reverse as - in pure $ mkNode opts (PresentT d) [show01 opts msg0 d as] [] - --- | reverses using 'reversing' --- --- >>> import Data.Text (Text) --- >>> pl @ReverseL ("AbcDeF" :: Text) --- Present "FeDcbA" --- PresentT "FeDcbA" --- --- >>> pl @ReverseL ("AbcDeF" :: String) --- Present "FeDcbA" --- PresentT "FeDcbA" --- -data ReverseL - -instance (Show t, Reversing t) => P ReverseL t where - type PP ReverseL t = t - eval _ opts as = - let msg0 = "ReverseL" - d = as ^. reversed - in pure $ mkNode opts (PresentT d) [show01 opts msg0 d as] [] - --- | swaps using 'SW.swap' --- --- >>> pl @Swap (Left 123) --- Present Right 123 --- PresentT (Right 123) --- --- >>> pl @Swap (Right 123) --- Present Left 123 --- PresentT (Left 123) --- --- >>> pl @Swap (These 'x' 123) --- Present These 123 'x' --- PresentT (These 123 'x') --- --- >>> pl @Swap (This 'x') --- Present That 'x' --- PresentT (That 'x') --- --- >>> pl @Swap (That 123) --- Present This 123 --- PresentT (This 123) --- --- >>> pl @Swap (123,'x') --- Present ('x',123) --- PresentT ('x',123) --- --- >>> pl @Swap (Left "abc") --- Present Right "abc" --- PresentT (Right "abc") --- --- >>> pl @Swap (Right 123) --- Present Left 123 --- PresentT (Left 123) --- -data Swap - -instance (Show (p a b) - , SW.Swap p - , Show (p b a) - ) => P Swap (p a b) where - type PP Swap (p a b) = p b a - eval _ opts pab = - let msg0 = "Swap" - d = SW.swap pab - in pure $ mkNode opts (PresentT d) [show01 opts msg0 d pab] [] - --- | assoc using 'AS.assoc' --- --- >>> pl @Assoc (This (These 123 'x')) --- Present These 123 (This 'x') --- PresentT (These 123 (This 'x')) --- --- >>> pl @Assoc ((99,'a'),True) --- Present (99,('a',True)) --- PresentT (99,('a',True)) --- --- >>> pl @Assoc ((99,'a'),True) --- Present (99,('a',True)) --- PresentT (99,('a',True)) --- --- >>> pl @Assoc (Right "Abc" :: Either (Either () ()) String) --- Present Right (Right "Abc") --- PresentT (Right (Right "Abc")) --- --- >>> pl @Assoc (Left (Left 'x')) --- Present Left 'x' --- PresentT (Left 'x') --- -data Assoc - -instance (Show (p (p a b) c) - , Show (p a (p b c)) - , AS.Assoc p - ) => P Assoc (p (p a b) c) where - type PP Assoc (p (p a b) c) = p a (p b c) - eval _ opts pabc = - let msg0 = "Assoc" - d = AS.assoc pabc - in pure $ mkNode opts (PresentT d) [show01 opts msg0 d pabc] [] - --- | unassoc using 'AS.unassoc' --- --- >>> pl @Unassoc (These 123 (This 'x')) --- Present This (These 123 'x') --- PresentT (This (These 123 'x')) --- --- >>> pl @Unassoc (99,('a',True)) --- Present ((99,'a'),True) --- PresentT ((99,'a'),True) --- --- >>> pl @Unassoc (This 10 :: These Int (These Bool ())) --- Present This (This 10) --- PresentT (This (This 10)) --- --- >>> pl @Unassoc (Right (Right 123)) --- Present Right 123 --- PresentT (Right 123) --- --- >>> pl @Unassoc (Left 'x' :: Either Char (Either Bool Double)) --- Present Left (Left 'x') --- PresentT (Left (Left 'x')) --- -data Unassoc - -instance (Show (p (p a b) c) - , Show (p a (p b c)) - , AS.Assoc p - ) => P Unassoc (p a (p b c)) where - type PP Unassoc (p a (p b c)) = p (p a b) c - eval _ opts pabc = - let msg0 = "Unassoc" - d = AS.unassoc pabc - in pure $ mkNode opts (PresentT d) [show01 opts msg0 d pabc] [] - --- | bounded 'succ' function --- --- >>> pl @(SuccB' Id) (13 :: Int) --- Present 14 --- PresentT 14 --- --- >>> pl @(SuccB' Id) LT --- Present EQ --- PresentT EQ --- --- >>> pl @(SuccB 'LT Id) GT --- Present LT --- PresentT LT --- --- >>> pl @(SuccB' Id) GT --- Error Succ bounded failed --- FailT "Succ bounded failed" --- -data SuccB p q -type SuccB' q = SuccB (Failp "Succ bounded failed") q - -instance (PP q x ~ a - , P q x - , P p (Proxy a) - , PP p (Proxy a) ~ a - , Show a - , Eq a - , Bounded a - , Enum a - ) => P (SuccB p q) x where - type PP (SuccB p q) x = PP q x - eval _ opts x = do - let msg0 = "SuccB" - qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> do - case succMay q of - Nothing -> do - let msg1 = msg0 <> " out of range" - pp <- eval (Proxy @p) opts (Proxy @a) - pure $ case getValueLR opts msg1 pp [hh qq] of - Left e -> e - Right _ -> mkNode opts (_tBool pp) [msg1] [hh qq, hh pp] - Just n -> pure $ mkNode opts (PresentT n) [show01 opts msg0 n q] [hh qq] - --- | bounded 'pred' function --- --- >>> pl @(PredB' Id) (13 :: Int) --- Present 12 --- PresentT 12 --- --- >>> pl @(PredB' Id) LT --- Error Pred bounded failed --- FailT "Pred bounded failed" --- -data PredB p q -type PredB' q = PredB (Failp "Pred bounded failed") q - -instance (PP q x ~ a - , P q x - , P p (Proxy a) - , PP p (Proxy a) ~ a - , Show a - , Eq a - , Bounded a - , Enum a - ) => P (PredB p q) x where - type PP (PredB p q) x = PP q x - eval _ opts x = do - let msg0 = "PredB" - qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> do - case predMay q of - Nothing -> do - let msg1 = msg0 <> " out of range" - pp <- eval (Proxy @p) opts (Proxy @a) - pure $ case getValueLR opts msg1 pp [hh qq] of - Left e -> e - Right _ -> mkNode opts (_tBool pp) [msg1] [hh qq, hh pp] - Just n -> pure $ mkNode opts (PresentT n) [show01 opts msg0 n q] [hh qq] - - --- | unbounded 'succ' function --- --- >>> pl @(Succ Id) 13 --- Present 14 --- PresentT 14 --- --- >>> pl @(Succ Id) LT --- Present EQ --- PresentT EQ --- --- >>> pl @(Succ Id) GT --- Error Succ IO e=Prelude.Enum.Ordering.succ: bad argument --- FailT "Succ IO e=Prelude.Enum.Ordering.succ: bad argument" --- -data Succ p - -instance (Show a - , Enum a - , PP p x ~ a - , P p x - ) => P (Succ p) x where - type PP (Succ p) x = PP p x - eval _ opts x = do - let msg0 = "Succ" - pp <- eval (Proxy @p) opts x - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right p -> do - lr <- catchit @_ @E.SomeException (succ p) - pure $ case lr of - Left e -> mkNode opts (FailT (msg0 <> " " <> e)) [msg0 <> show0 opts " " p] [hh pp] - Right n -> mkNode opts (PresentT n) [show01 opts msg0 n p] [hh pp] - - --- | unbounded 'pred' function --- --- >>> pl @(Pred Id) 13 --- Present 12 --- PresentT 12 --- --- >>> pl @(Pred Id) LT --- Error Pred IO e=Prelude.Enum.Ordering.pred: bad argument --- FailT "Pred IO e=Prelude.Enum.Ordering.pred: bad argument" --- - -data Pred p - -instance (Show a - , Enum a - , PP p x ~ a - , P p x - ) => P (Pred p) x where - type PP (Pred p) x = PP p x - eval _ opts x = do - let msg0 = "Pred" - pp <- eval (Proxy @p) opts x - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right p -> do - lr <- catchit @_ @E.SomeException (pred p) - pure $ case lr of - Left e -> mkNode opts (FailT (msg0 <> " " <> e)) [msg0 <> show0 opts " " p] [hh pp] - Right n -> mkNode opts (PresentT n) [show01 opts msg0 n p] [hh pp] - - --- | 'fromEnum' function --- --- >>> pl @(FromEnum Id) 'x' --- Present 120 --- PresentT 120 - - -data FromEnum p - -instance (Show a - , Enum a - , PP p x ~ a - , P p x - ) => P (FromEnum p) x where - type PP (FromEnum p) x = Int - eval _ opts x = do - let msg0 = "FromEnum" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let n = fromEnum p - in mkNode opts (PresentT n) [show01 opts msg0 n p] [hh pp] - --- | unsafe 'toEnum' function --- --- >>> pl @(ToEnum Char Id) 120 --- Present 'x' --- PresentT 'x' -data ToEnum' t p -type ToEnum (t :: Type) p = ToEnum' (Hole t) p - -instance (PP p x ~ a - , P p x - , Show a - , Enum (PP t x) - , Show (PP t x) - , Integral a - ) => P (ToEnum' t p) x where - type PP (ToEnum' t p) x = PP t x - eval _ opts x = do - let msg0 = "ToEnum" - pp <- eval (Proxy @p) opts x - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right p -> do - lr <- catchit @_ @E.SomeException (toEnum $! fromIntegral p) - pure $ case lr of - Left e -> mkNode opts (FailT (msg0 <> " " <> e)) [msg0 <> show0 opts " " p] [hh pp] - Right n -> mkNode opts (PresentT n) [show01 opts msg0 n p] [hh pp] - --- | bounded 'toEnum' function --- --- >>> pl @(ToEnumB Ordering LT) 2 --- Present GT --- PresentT GT --- --- >>> pl @(ToEnumB Ordering LT) 6 --- Present LT --- PresentT LT --- --- >>> pl @(ToEnumBF Ordering) 6 --- Error ToEnum bounded failed --- FailT "ToEnum bounded failed" --- -data ToEnumB' t def -type ToEnumB (t :: Type) def = ToEnumB' (Hole t) def -type ToEnumBF (t :: Type) = ToEnumB' (Hole t) (Failp "ToEnum bounded failed") - -instance (P def (Proxy (PP t a)) - , PP def (Proxy (PP t a)) ~ (PP t a) - , Show a - , Show (PP t a) - , Bounded (PP t a) - , Enum (PP t a) - , Integral a - ) => P (ToEnumB' t def) a where - type PP (ToEnumB' t def) a = PP t a - eval _ opts a = do - let msg0 = "ToEnumB" - case toEnumMay $ fromIntegral a of - Nothing -> do - let msg1 = msg0 <> " out of range" - pp <- eval (Proxy @def) opts (Proxy @(PP t a)) - pure $ case getValueLR opts msg1 pp [] of - Left e -> e - Right _ -> mkNode opts (_tBool pp) [msg1] [hh pp] - Just n -> pure $ mkNode opts (PresentT n) [show01 opts msg0 n a] [] - --- | a predicate on prime numbers --- --- >>> pl @(Prime Id) 2 --- True --- TrueT --- --- >>> pl @(Map '(Id,Prime Id) Id) [0..12] --- Present [(0,False),(1,False),(2,True),(3,True),(4,False),(5,True),(6,False),(7,True),(8,False),(9,False),(10,False),(11,True),(12,False)] --- PresentT [(0,False),(1,False),(2,True),(3,True),(4,False),(5,True),(6,False),(7,True),(8,False),(9,False),(10,False),(11,True),(12,False)] --- -data Prime p - -instance (PP p x ~ a - , P p x - , Show a - , Integral a - ) => P (Prime p) x where - type PP (Prime p) x = Bool - eval _ opts x = do - let msg0 = "Prime" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = isPrime $ fromIntegral p - in mkNodeB opts b [msg0 <> show1 opts " | " p] [] - - --- | 'not' function --- --- >>> pl @(Not Id) False --- True --- TrueT --- --- >>> pl @(Not Id) True --- False --- FalseT --- --- >>> pl @(Not (Fst Id)) (True,22) --- False --- FalseT --- -data Not p -instance (PP p x ~ Bool, P p x) => P (Not p) x where - type PP (Not p) x = Bool - eval _ opts x = do - let msg0 = "Not" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = not p - in mkNodeB opts b [msg0] [hh pp] - --- empty lists at the type level wont work here - --- | filters a list \'q\' keeping or removing those elements in \'p\' --- --- >>> pl @(Keep '[5] '[1,5,5,2,5,2]) () --- Present [5,5,5] --- PresentT [5,5,5] --- --- >>> pl @(Keep '[0,1,1,5] '[1,5,5,2,5,2]) () --- Present [1,5,5,5] --- PresentT [1,5,5,5] --- --- >>> pl @(Remove '[5] '[1,5,5,2,5,2]) () --- Present [1,2,2] --- PresentT [1,2,2] --- --- >>> pl @(Remove '[0,1,1,5] '[1,5,5,2,5,2]) () --- Present [2,2] --- PresentT [2,2] --- --- >>> pl @(Remove '[99] '[1,5,5,2,5,2]) () --- Present [1,5,5,2,5,2] --- PresentT [1,5,5,2,5,2] --- --- >>> pl @(Remove '[99,91] '[1,5,5,2,5,2]) () --- Present [1,5,5,2,5,2] --- PresentT [1,5,5,2,5,2] --- --- >>> pl @(Remove Id '[1,5,5,2,5,2]) [] --- Present [1,5,5,2,5,2] --- PresentT [1,5,5,2,5,2] --- --- >>> pl @(Remove '[] '[1,5,5,2,5,2]) 44 -- works if you make this a number! --- Present [1,5,5,2,5,2] --- PresentT [1,5,5,2,5,2] --- -data KeepImpl (keep :: Bool) p q -type Remove p q = KeepImpl 'False p q -type Keep p q = KeepImpl 'True p q - -instance (GetBool keep - , Eq a - , Show a - , P p x - , P q x - , PP p x ~ PP q x - , PP q x ~ [a] - ) => P (KeepImpl keep p q) x where - type PP (KeepImpl keep p q) x = PP q x - eval _ opts x = do - let msg0 = if keep then "Keep" else "Remove" - keep = getBool @keep - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let ret = filter (bool not id keep . (`elem` p)) q - in mkNode opts (PresentT ret) [show01' opts msg0 ret "p=" p <> show1 opts " | q=" q] [hh pp, hh qq] - --- | 'elem' function --- --- >>> pl @(Elem (Fst Id) (Snd Id)) ('x',"abcdxy") --- True --- TrueT --- --- >>> pl @(Elem (Fst Id) (Snd Id)) ('z',"abcdxy") --- False --- FalseT --- -data Elem p q - -instance ([PP p a] ~ PP q a - , P p a - , P q a - , Show (PP p a) - , Eq (PP p a) - ) => P (Elem p q) a where - type PP (Elem p q) a = Bool - eval _ opts a = do - let msg0 = "Elem" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let b = p `elem` q - in mkNodeB opts b [show p <> " `elem` " <> show q] [hh pp, hh qq] - -type Head' p = HeadFail "Head(empty)" p -type Tail' p = TailFail "Tail(empty)" p -type Last' p = LastFail "Last(empty)" p -type Init' p = InitFail "Init(empty)" p - --- | similar to fmap fst --- --- >>> pl @Fmap_1 (Just (13,"Asf")) --- Present Just 13 --- PresentT (Just 13) --- --- to make this work we grab the fst or snd out of the Maybe so it is a head or not/ is a tail or not etc! --- we still have access to the whole original list so we dont lose anything! -data Fmap_1 -instance Functor f => P Fmap_1 (f (a,x)) where - type PP Fmap_1 (f (a,x)) = f a - eval _ opts mb = pure $ mkNode opts (PresentT (fst <$> mb)) ["Fmap_1"] [] - --- | similar to fmap snd --- --- >>> pl @Fmap_2 (Just ("asf",13)) --- Present Just 13 --- PresentT (Just 13) --- -data Fmap_2 -instance Functor f => P Fmap_2 (f (x,a)) where - type PP Fmap_2 (f (x,a)) = f a - eval _ opts mb = pure $ mkNode opts (PresentT (snd <$> mb)) ["Fmap_2"] [] - -type HeadDef p q = GDef (Uncons >> Fmap_1) p q -type HeadP q = GProxy (Uncons >> Fmap_1) q -type HeadFail msg q = GFail (Uncons >> Fmap_1) msg q - -type TailDef p q = GDef (Uncons >> Fmap_2) p q -type TailP q = GProxy (Uncons >> Fmap_2) q -type TailFail msg q = GFail (Uncons >> Fmap_2) msg q - -type LastDef p q = GDef (Unsnoc >> Fmap_2) p q -type LastP q = GProxy (Unsnoc >> Fmap_2) q -type LastFail msg q = GFail (Unsnoc >> Fmap_2) msg q - -type InitDef p q = GDef (Unsnoc >> Fmap_1) p q -type InitP q = GProxy (Unsnoc >> Fmap_1) q -type InitFail msg q = GFail (Unsnoc >> Fmap_1) msg q - --- 'x' and 'a' for Just condition --- 'x' for Nothing condition --- (Snd Id) at the end says we only want to process the Maybe which is the rhs of &&& ie (Snd Id) -type GDef' z p q r = '(I, r >> z) >> MaybeXP (X >> p) q (Snd Id) -type JustDef' p q r = GDef' I p q r - --- access everything ie 'x' and Proxy a for Nothing condition --- 'x' and 'a' for Just condition -type GDef'' z p q r = '(I, r >> z) >> MaybeXP p q (Snd Id) -type JustDef'' p q r = GDef'' I p q r - -type PA = Snd I -- 'Proxy a' -- to distinguish from A -type A = Snd I -- 'a' -type X = Fst (Fst I) -- 'x' ie the whole original environment -type XA = I -- ie noop -type XPA = I -- ie noop - --- Nothing has access to 'x' only --- Just has access to (x,a) ---type GDef_X z p q r = (I &&& (r >> z)) >> MaybeXP (Fst Id >> Fst Id >> p) ((Fst Id *** I) >> q) (Snd Id) -type GDef_X z p q r = '(I, r >> z) >> MaybeXP (X >> p) ('(X,A) >> q) A -type JustDef''' p q r = GDef_X I p q r - --- Nothing has access to 'Proxy a' only --- Just has access to (x,a) -type GDef_PA z p q r = Hide % '(I, r >> z) >> MaybeXP (PA >> p) ('(X,A) >> q) A - --- Nothing case sees ((I,qz), Proxy a) -- hence the Fst Id >> Fst Id --- Just case sees (I,qz), a) -- hence the (Snd Id) to get the 'a' only -- if you want the 'x' then Fst Id >> Fst Id --- we have lost 'x' on the rhs: use GDef_X to access 'x' and 'a' for the Just condition -type GDef z p q = '(I, q >> z) >> MaybeXP (X >> p) A A -- Hide % immediately before MaybeXP -type GProxy z q = '(I, q >> z) >> MaybeXP (PA >> MEmptyP) A A -type GFail z msg q = '(I, q >> z) >> MaybeXP (Fail (PA >> Unproxy) (X >> msg)) A A - --- use these! -type LookupDef' x y p q = GDef (Lookup x y) p q -type LookupP' x y q = GProxy (Lookup x y) q -type LookupFail' msg x y q = GFail (Lookup x y) msg q - -type LookupDef x y p = LookupDef' x y p I -type LookupP x y = LookupP' x y I -type LookupFail msg x y = LookupFail' msg x y I - -type Just' p = JustFail "expected Just" p -type Left' p = LeftFail "expected Left" p -type Right' p = RightFail "expected Right" p -type This' p = ThisFail "expected This" p -type That' p = ThatFail "expected That" p -type TheseIn' p = TheseFail "expected These" p - -type JustDef p q = GDef I p q -type JustP q = GProxy I q -type JustFail msg q = GFail I msg q - -type LeftDef p q = GDef LeftToMaybe p q -type LeftP q = GProxy LeftToMaybe q -type LeftFail msg q = GFail LeftToMaybe msg q - -type RightDef p q = GDef RightToMaybe p q -type RightP q = GProxy RightToMaybe q -type RightFail msg q = GFail RightToMaybe msg q - -type ThisDef p q = GDef ThisToMaybe p q -type ThisP q = GProxy ThisToMaybe q -type ThisFail msg q = GFail ThisToMaybe msg q - -type ThatDef p q = GDef ThatToMaybe p q -type ThatP q = GProxy ThatToMaybe q -type ThatFail msg q = GFail ThatToMaybe msg q - -type TheseDef p q = GDef TheseToMaybe p q -type TheseP q = GProxy TheseToMaybe q -type TheseFail msg q = GFail TheseToMaybe msg q - --- tacks on a Proxy to Nothing side! but a Proxy a not Proxy of the final result --- this is for default use cases for either/these/head/tail/last/init etc -data MaybeXP p q r -type MaybeX p q r = MaybeXP (Fst Id >> p) q r - -instance (P r x - , P p (x, Proxy a) - , P q (x,a) - , PP r x ~ Maybe a - , PP p (x, Proxy a) ~ b - , PP q (x,a) ~ b - ) => P (MaybeXP p q r) x where - type PP (MaybeXP p q r) x = MaybeXPT (PP r x) x q - eval _ opts x = do - let msg0 = "MaybeXP" - rr <- eval (Proxy @r) opts x - case getValueLR opts msg0 rr [] of - Left e -> pure e - Right Nothing -> do - let msg1 = msg0 <> "(Nothing)" - pp <- eval (Proxy @p) opts (x, Proxy @a) - pure $ case getValueLR opts msg1 pp [hh rr] of - Left e -> e - Right _ -> mkNode opts (_tBool pp) [msg1] [hh rr, hh pp] - Right (Just a) -> do - let msg1 = msg0 <> "(Just)" - qq <- eval (Proxy @q) opts (x,a) - pure $ case getValueLR opts msg1 qq [hh rr] of - Left e -> e - Right _ -> mkNode opts (_tBool qq) [msg1] [hh rr, hh qq] - -type family MaybeXPT lr x q where - MaybeXPT (Maybe a) x q = PP q (x,a) - - --- | similar to either Just (const Nothing) --- --- >>> pl @LeftToMaybe (Left 13) --- Present Just 13 --- PresentT (Just 13) --- --- >>> pl @LeftToMaybe (Right 13) --- Present Nothing --- PresentT Nothing --- -data LeftToMaybe -instance P LeftToMaybe (Either a x) where - type PP LeftToMaybe (Either a x) = Maybe a - eval _ opts lr = pure $ mkNode opts (PresentT (either Just (const Nothing) lr)) ["LeftToMaybe"] [] - - --- | similar to either (const Nothing) Just --- --- >>> pl @RightToMaybe (Right 13) --- Present Just 13 --- PresentT (Just 13) --- --- >>> pl @RightToMaybe (Left 13) --- Present Nothing --- PresentT Nothing --- -data RightToMaybe -instance P RightToMaybe (Either x a) where - type PP RightToMaybe (Either x a) = Maybe a - eval _ opts lr = pure $ mkNode opts (PresentT (either (const Nothing) Just lr)) ["RightToMaybe"] [] - -data ThisToMaybe - -instance P ThisToMaybe (These a x) where - type PP ThisToMaybe (These a x) = Maybe a - eval _ opts th = pure $ mkNode opts (PresentT (these Just (const Nothing) (const . const Nothing) th)) ["ThisToMaybe"] [] - -data ThatToMaybe - -instance P ThatToMaybe (These x a) where - type PP ThatToMaybe (These x a) = Maybe a - eval _ opts th = pure $ mkNode opts (PresentT (these (const Nothing) Just (const . const Nothing) th)) ["ThatToMaybe"] [] - -data TheseToMaybe - -instance P TheseToMaybe (These a b) where - type PP TheseToMaybe (These a b) = Maybe (a,b) - eval _ opts th = pure $ mkNode opts (PresentT (these (const Nothing) (const Nothing) ((Just .) . (,)) th)) ["TheseToMaybe"] [] - --- | similar to 'Control.Arrow.|||' but additionally gives \'p\' and \'q\' the original input --- --- >>> pl @(EitherX (ShowP (Fst (Fst Id) + Snd Id)) (ShowP Id) (Snd Id)) (9,Left 123) --- Present "132" --- PresentT "132" --- --- >>> pl @(EitherX (ShowP (Fst (Fst Id) + Snd Id)) (ShowP Id) (Snd Id)) (9,Right 'x') --- Present "((9,Right 'x'),'x')" --- PresentT "((9,Right 'x'),'x')" --- --- >>> pl @(EitherX (ShowP Id) (ShowP (Second (Succ Id))) (Snd Id)) (9,Right 'x') --- Present "((9,Right 'x'),'y')" --- PresentT "((9,Right 'x'),'y')" --- -data EitherX p q r -instance (P r x - , P p (x,a) - , P q (x,b) - , PP r x ~ Either a b - , PP p (x,a) ~ c - , PP q (x,b) ~ c - ) => P (EitherX p q r) x where - type PP (EitherX p q r) x = EitherXT (PP r x) x p - eval _ opts x = do - let msg0 = "EitherX" - rr <- eval (Proxy @r) opts x - case getValueLR opts msg0 rr [] of - Left e -> pure e - Right (Left a) -> do - let msg1 = msg0 <> "(Left)" - pp <- eval (Proxy @p) opts (x,a) - pure $ case getValueLR opts msg1 pp [hh rr] of - Left e -> e - Right _ -> mkNode opts (_tBool pp) [msg1] [hh rr, hh pp] - Right (Right b) -> do - let msg1 = msg0 <> "(Right)" - qq <- eval (Proxy @q) opts (x,b) - pure $ case getValueLR opts msg1 qq [hh rr] of - Left e -> e - Right _ -> mkNode opts (_tBool qq) [msg1] [hh rr, hh qq] - -type family EitherXT lr x p where - EitherXT (Either a b) x p = PP p (x,a) - --- | similar to 'Data.These.mergeTheseWith' but additionally provides \'p\', '\q'\ and \'r\' the original input as the first element in the tuple --- --- >>> pl @(TheseX (((Fst Id >> Fst Id) + Snd Id) >> ShowP Id) (ShowP Id) (Snd (Snd Id)) (Snd Id)) (9,This 123) --- Present "132" --- PresentT "132" --- --- >>> pl @(TheseX '(Snd Id,"fromthis") '(Negate 99,Snd Id) (Snd Id) Id) (This 123) --- Present (123,"fromthis") --- PresentT (123,"fromthis") --- --- >>> pl @(TheseX '(Snd Id,"fromthis") '(Negate 99,Snd Id) (Snd Id) Id) (That "fromthat") --- Present (-99,"fromthat") --- PresentT (-99,"fromthat") --- --- >>> pl @(TheseX '(Snd Id,"fromthis") '(Negate 99,Snd Id) (Snd Id) Id) (These 123 "fromthese") --- Present (123,"fromthese") --- PresentT (123,"fromthese") --- -data TheseX p q r s - -instance (P s x - , P p (x,a) - , P q (x,b) - , P r (x,(a,b)) - , PP s x ~ These a b - , PP p (x,a) ~ c - , PP q (x,b) ~ c - , PP r (x,(a,b)) ~ c - ) => P (TheseX p q r s) x where - type PP (TheseX p q r s) x = TheseXT (PP s x) x p - eval _ opts x = do - let msg0 = "TheseX" - ss <- eval (Proxy @s) opts x - case getValueLR opts msg0 ss [] of - Left e -> pure e - Right (This a) -> do - let msg1 = msg0 <> "(This)" - pp <- eval (Proxy @p) opts (x,a) - pure $ case getValueLR opts msg1 pp [hh ss] of - Left e -> e - Right _ -> mkNode opts (_tBool pp) [msg1] [hh ss, hh pp] - Right (That b) -> do - let msg1 = msg0 <> "(That)" - qq <- eval (Proxy @q) opts (x,b) - pure $ case getValueLR opts msg1 qq [hh ss] of - Left e -> e - Right _ -> mkNode opts (_tBool qq) [msg1] [hh ss, hh qq] - Right (These a b) -> do - let msg1 = msg0 <> "(These)" - rr <- eval (Proxy @r) opts (x,(a,b)) - pure $ case getValueLR opts msg1 rr [hh ss] of - Left e -> e - Right _ -> mkNode opts (_tBool rr) [msg1] [hh ss, hh rr] - -type family TheseXT lr x p where - TheseXT (These a b) x p = PP p (x,a) - --- | similar to 'maybe' --- --- similar to 'MaybeX' but provides a Proxy to the result of \'q\' and does not provide the surrounding context --- --- >>> pl @(MaybeIn "foundnothing" (ShowP (Pred Id))) (Just 20) --- Present "19" --- PresentT "19" --- --- >>> pl @(MaybeIn "found nothing" (ShowP (Pred Id))) Nothing --- Present "found nothing" --- PresentT "found nothing" --- -data MaybeIn p q -type IsNothing = MaybeIn 'True 'False -type IsJust = MaybeIn 'False 'True - --- tricky: the nothing case is the proxy of PP q a: ie proxy of the final result!! --- this is different from MaybeXP which gives you a proxy of 'a' [you need both!] -instance (P q a - , Show a - , Show (PP q a) - , PP p (Proxy (PP q a)) ~ PP q a - , P p (Proxy (PP q a)) - ) => P (MaybeIn p q) (Maybe a) where - type PP (MaybeIn p q) (Maybe a) = PP q a - eval _ opts ma = do - let msg0 = "MaybeIn" - case ma of - Nothing -> do - let msg1 = msg0 <> "(Nothing)" - pp <- eval (Proxy @p) opts (Proxy @(PP q a)) - pure $ case getValueLR opts msg1 pp [] of - Left e -> e - Right b -> mkNode opts (_tBool pp) [msg1 <> show0 opts " " b <> " | Proxy"] [hh pp] - Just a -> do - let msg1 = msg0 <> "(Nothing)" - qq <- eval (Proxy @q) opts a - pure $ case getValueLR opts msg1 qq [] of - Left e -> e - Right b -> mkNode opts (_tBool qq) [show01 opts msg1 b a] [hh qq] - - --- | similar to 'SG.stimes' --- --- >>> pl @(STimes 4 Id) (SG.Sum 3) --- Present Sum {getSum = 12} --- PresentT (Sum {getSum = 12}) --- --- >>> pl @(STimes 4 Id) "ab" --- Present "abababab" --- PresentT "abababab" --- -data STimes n p -instance (P n a - , Integral (PP n a) - , Semigroup (PP p a) - , P p a - , Show (PP p a) - ) => P (STimes n p) a where - type PP (STimes n p) a = PP p a - eval _ opts a = do - let msg0 = "STimes" - lr <- runPQ msg0 (Proxy @n) (Proxy @p) opts a - pure $ case lr of - Left e -> e - Right (fromIntegral -> (n::Int),p,pp,qq) -> - let msg1 = msg0 <> show0 opts " " n <> " p=" <> show p - b = SG.stimes n p - in mkNode opts (PresentT b) [show01' opts msg1 b "n=" n <> show1 opts " | " p] [hh pp, hh qq] - - --- | similar to 'pure' --- --- >>> pl @(Pure Maybe Id) 4 --- Present Just 4 --- PresentT (Just 4) --- --- >>> pl @(Pure [] Id) 4 --- Present [4] --- PresentT [4] --- --- >>> pl @(Pure (Either String) (Fst Id)) (13,True) --- Present Right 13 --- PresentT (Right 13) --- -data Pure (t :: Type -> Type) p -instance (P p x - , Show (PP p x) - , Show (t (PP p x)) - , Applicative t - ) => P (Pure t p) x where - type PP (Pure t p) x = t (PP p x) - eval _ opts x = do - let msg0 = "Pure" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right a -> - let b = pure a - in mkNode opts (PresentT b) [show01 opts msg0 b a] [hh pp] - -type PMEmpty = MEmptyT' 'Proxy -- lifts 'a' to 'Proxy a' then we can use it with MEmptyP - --- | similar to 'mempty' --- --- >>> pl @(MEmptyT (SG.Sum Int)) () --- Present Sum {getSum = 0} --- PresentT (Sum {getSum = 0}) --- --- no Monoid for Maybe a unless a is also a monoid but can use empty! -data MEmptyT' t -type MEmptyT (t :: Type) = MEmptyT' (Hole t) -type MEmptyP = MEmptyT' Unproxy -- expects a proxy: so only some things work with this: eg Pad MaybeIn etc - -instance (Show (PP t a), Monoid (PP t a)) => P (MEmptyT' t) a where - type PP (MEmptyT' t) a = PP t a - eval _ opts _ = - let msg0 = "MEmptyT" - b = mempty @(PP t a) - in pure $ mkNode opts (PresentT b) [msg0 <> show0 opts " " b] [] - -data MEmptyProxy -instance Monoid a => P MEmptyProxy (Proxy (a :: Type)) where - type PP MEmptyProxy (Proxy a) = a - eval _ opts _pa = - let msg0 = "MEmptyProxy" - b = mempty @a - in pure $ mkNode opts (PresentT b) [msg0] [] - --- | similar to 'empty' --- --- >>> pl @(EmptyT Maybe Id) () --- Present Nothing --- PresentT Nothing --- --- >>> pl @(EmptyT [] Id) () --- Present [] --- PresentT [] --- --- >>> pl @(EmptyT [] (Char1 "x")) (13,True) --- Present "" --- PresentT "" --- --- >>> pl @(EmptyT (Either String) (Fst Id)) (13,True) --- Present Left "" --- PresentT (Left "") --- - -data EmptyT (t :: Type -> Type) p - -instance (P p x - , PP p x ~ a - , Show (t a) - , Show a - , Alternative t - ) => P (EmptyT t p) x where - type PP (EmptyT t p) x = t (PP p x) - eval _ opts x = do - let msg0 = "EmptyT" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = empty @t - in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] - -data MkNothing' t -- works always! MaybeB is a good alternative and then dont need the extra 't' -type MkNothing (t :: Type) = MkNothing' (Hole t) - --- for this to be useful has to have 't' else we end up with tons of problems -instance P (MkNothing' t) a where - type PP (MkNothing' t) a = Maybe (PP t a) - eval _ opts _ = - let msg0 = "MkNothing" - in pure $ mkNode opts (PresentT Nothing) [msg0] [] - --- | 'Just' constructor --- --- >>> pl @(MkJust Id) 44 --- Present Just 44 --- PresentT (Just 44) --- -data MkJust p -instance (PP p x ~ a, P p x, Show a) => P (MkJust p) x where - type PP (MkJust p) x = Maybe (PP p x) - eval _ opts x = do - let msg0 = "MkJust" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = Just p - in mkNode opts (PresentT d) [msg0 <> show0 opts " Just " p] [hh pp] - --- | 'Data.Either.Left' constructor --- --- >>> pl @(MkLeft _ Id) 44 --- Present Left 44 --- PresentT (Left 44) --- -data MkLeft' t p -type MkLeft (t :: Type) p = MkLeft' (Hole t) p - -instance (Show (PP p x), P p x) => P (MkLeft' t p) x where - type PP (MkLeft' t p) x = Either (PP p x) (PP t x) - eval _ opts x = do - let msg0 = "MkLeft" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = Left p - in mkNode opts (PresentT d) [msg0 <> show0 opts " Left " p] [hh pp] - --- | 'Data.Either.Right' constructor --- --- >>> pl @(MkRight _ Id) 44 --- Present Right 44 --- PresentT (Right 44) --- -data MkRight' t p -type MkRight (t :: Type) p = MkRight' (Hole t) p - -instance (Show (PP p x), P p x) => P (MkRight' t p) x where - type PP (MkRight' t p) x = Either (PP t x) (PP p x) - eval _ opts x = do - let msg0 = "MkRight" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = Right p - in mkNode opts (PresentT d) [msg0 <> show0 opts " Right " p] [hh pp] - --- | 'Data.These.This' constructor --- --- >>> pl @(MkThis _ Id) 44 --- Present This 44 --- PresentT (This 44) --- -data MkThis' t p -type MkThis (t :: Type) p = MkThis' (Hole t) p - -instance (Show (PP p x), P p x) => P (MkThis' t p) x where - type PP (MkThis' t p) x = These (PP p x) (PP t x) - eval _ opts x = do - let msg0 = "MkThis" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = This p - in mkNode opts (PresentT d) [msg0 <> show0 opts " This " p] [hh pp] - --- | 'Data.These.That' constructor --- --- >>> pl @(MkThat _ Id) 44 --- Present That 44 --- PresentT (That 44) --- -data MkThat' t p -type MkThat (t :: Type) p = MkThat' (Hole t) p - -instance (Show (PP p x), P p x) => P (MkThat' t p) x where - type PP (MkThat' t p) x = These (PP t x) (PP p x) - eval _ opts x = do - let msg0 = "MkThat" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let d = That p - in mkNode opts (PresentT d) [msg0 <> show0 opts " That " p] [hh pp] - ---type MkThat t p = MkThis t p >> Swap --- type MkThat' (t :: Type) = Pure (These t) Id -- t has to be a semigroup - --- | 'Data.These.These' constructor --- --- >>> pl @(MkThese (Fst Id) (Snd Id)) (44,'x') --- Present These 44 'x' --- PresentT (These 44 'x') --- -data MkThese p q -instance (P p a - , P q a - , Show (PP p a) - , Show (PP q a) - ) => P (MkThese p q) a where - type PP (MkThese p q) a = These (PP p a) (PP q a) - eval _ opts a = do - let msg0 = "MkThese" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = These p q - in mkNode opts (PresentT d) [msg0 <> show0 opts " " d] [hh pp, hh qq] - --- | similar to 'mconcat' --- --- >>> pl @(MConcat Id) [SG.Sum 44, SG.Sum 12, SG.Sum 3] --- Present Sum {getSum = 59} --- PresentT (Sum {getSum = 59}) --- -data MConcat p - - --- | similar to a limited form of 'foldMap' --- --- >>> pl @(FoldMap (SG.Sum _) Id) [44, 12, 3] --- Present 59 --- PresentT 59 --- --- >>> pl @(FoldMap (SG.Product _) Id) [44, 12, 3] --- Present 1584 --- PresentT 1584 --- - ---type FoldMap (t :: Type) p = Map (Wrap t Id) p >> MConcat Id >> Unwrap Id -type FoldMap (t :: Type) p = Map (Wrap t Id) p >> Unwrap (MConcat Id) - -type Sum (t :: Type) = FoldMap (SG.Sum t) Id -type Min' (t :: Type) = FoldMap (SG.Min t) Id -- requires t be Bounded for monoid instance - -instance (PP p x ~ [a] - , P p x - , Show a - , Monoid a - ) => P (MConcat p) x where - type PP (MConcat p) x = ExtractAFromTA (PP p x) - eval _ opts x = do - let msg0 = "MConcat" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = mconcat p - in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] - --- | similar to 'concat' --- --- >>> pl @(Concat Id) ["abc","D","eF","","G"] --- Present "abcDeFG" --- PresentT "abcDeFG" --- --- >>> pl @(Concat (Snd Id)) ('x',["abc","D","eF","","G"]) --- Present "abcDeFG" --- PresentT "abcDeFG" --- -data Concat p - -instance (Show a - , Show (t [a]) - , PP p x ~ (t [a]) - , P p x - , Foldable t - ) => P (Concat p) x where - type PP (Concat p) x = ExtractAFromTA (PP p x) - eval _ opts x = do - let msg0 = "Concat" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = concat p - in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] - -data ProxyT' t -type ProxyT (t :: Type) = ProxyT' (Hole t) - -instance Typeable t => P (ProxyT' (t :: Type)) a where - type PP (ProxyT' t) a = Proxy (PP t a) - eval _ opts _ = - let t = showT @t - in pure $ mkNode opts (PresentT Proxy) ["ProxyT(" <> show t ++ ")"] [] - --- | similar to 'Data.List.!!' --- --- >>> pl @(Ix 4 "not found") ["abc","D","eF","","G"] --- Present "G" --- PresentT "G" --- --- >>> pl @(Ix 40 "not found") ["abc","D","eF","","G"] --- Present "not found" --- PresentT "not found" --- -data Ix (n :: Nat) def -type Ix' (n :: Nat) = Ix n (Failp "Ix index not found") - -instance (P def (Proxy a) - , PP def (Proxy a) ~ a - , KnownNat n - , Show a - ) => P (Ix n def) [a] where - type PP (Ix n def) [a] = a - eval _ opts as = do - let n = nat @n - msg0 = "Ix " <> show n - case as ^? ix n of - Nothing -> do - let msg1 = msg0 <> " not found" - pp <- eval (Proxy @def) opts (Proxy @a) - pure $ case getValueLR opts msg1 pp [] of - Left e -> e - Right _ -> mkNode opts (_tBool pp) [msg1] [hh pp] - Just a -> pure $ mkNode opts (PresentT a) [msg0 <> show0 opts " " a] [] - --- | similar to 'Data.List.!!' leveraging 'Ixed' --- --- >>> import qualified Data.Map.Strict as M --- >>> pl @(Id !! 2) ["abc","D","eF","","G"] --- Present "eF" --- PresentT "eF" --- --- >>> pl @(Id !! 20) ["abc","D","eF","","G"] --- Error (!!) index not found --- FailT "(!!) index not found" --- --- >>> pl @(Id !! "eF") (M.fromList (flip zip [0..] ["abc","D","eF","","G"])) --- Present 2 --- PresentT 2 --- -data IxL p q def -- p is the big value and q is the index and def is the default -type p !! q = IxL p q (Failp "(!!) index not found") -instance (P q a - , P p a - , Show (PP p a) - , Ixed (PP p a) - , PP q a ~ Index (PP p a) - , Show (Index (PP p a)) - , Show (IxValue (PP p a)) - , P r (Proxy (IxValue (PP p a))) - , PP r (Proxy (IxValue (PP p a))) ~ IxValue (PP p a) - ) - => P (IxL p q r) a where - type PP (IxL p q r) a = IxValue (PP p a) - eval _ opts a = do - let msg0 = "IxL" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a - case lr of - Left e -> pure e - Right (p,q,pp,qq) -> - let msg1 = msg0 <> "(" <> show q <> ")" - in case p ^? ix q of - Nothing -> do - rr <- eval (Proxy @r) opts (Proxy @(IxValue (PP p a))) - pure $ case getValueLR opts msg1 rr [hh pp, hh qq] of - Left e -> e - Right _ -> mkNode opts (_tBool rr) [msg1 <> " index not found"] [hh pp, hh qq] - Just ret -> pure $ mkNode opts (PresentT ret) [show01' opts msg1 ret "p=" p <> show1 opts " | q=" q] [hh pp, hh qq] - --- | 'lookup' leveraging 'Ixed' --- --- >>> import qualified Data.Map.Strict as M --- >>> pl @(Id !!! 2) ["abc","D","eF","","G"] --- Present "eF" --- PresentT "eF" --- --- >>> pl @(Id !!! 20) ["abc","D","eF","","G"] --- Error index not found --- FailT "index not found" --- --- >>> pl @(Id !!! "eF") (M.fromList (flip zip [0..] ["abc","D","eF","","G"])) --- Present 2 --- PresentT 2 --- --- >>> pl @(Lookup Id 2) ["abc","D","eF","","G"] --- Present Just "eF" --- PresentT (Just "eF") --- --- >>> pl @(Lookup Id 20) ["abc","D","eF","","G"] --- Present Nothing --- PresentT Nothing --- -data Lookup p q -type p !!! q = Lookup p q >> MaybeIn (Failp "index not found") Id -- use !! --- Lookup' is interesting but just use Lookup or !! -type Lookup' (t :: Type) p q = q &&& Lookup p q >> If (Snd Id >> IsNothing) (ShowP (Fst Id) >> Fail (Hole t) (Printf "index(%s) not found" Id)) (Snd Id >> 'Just Id) - -instance (P q a - , P p a - , Show (PP p a) - , Ixed (PP p a) - , PP q a ~ Index (PP p a) - , Show (Index (PP p a)) - , Show (IxValue (PP p a)) - ) - => P (Lookup p q) a where - type PP (Lookup p q) a = Maybe (IxValue (PP p a)) - eval _ opts a = do - let msg0 = "Lookup" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let msg1 = msg0 <> "(" <> show q <> ")" - hhs = [hh pp, hh qq] - in case p ^? ix q of - Nothing -> mkNode opts (PresentT Nothing) [msg1 <> " not found"] hhs - Just ret -> mkNode opts (PresentT (Just ret)) [show01' opts msg1 ret "p=" p <> show1 opts " | q=" q] hhs - --- | 'Data.List.ands' --- --- >>> pl @(Ands Id) [True,True,True] --- True --- TrueT --- --- >>> pl @(Ands Id) [True,True,True,False] --- False --- FalseT --- --- >>> pl @(Ands Id) [] --- True --- TrueT --- -data Ands p -type Ands' p = FoldMap SG.All p - -instance (PP p x ~ t a - , P p x - , Show (t a) - , Foldable t - , a ~ Bool - ) => P (Ands p) x where - type PP (Ands p) x = Bool - eval _ opts x = do - let msg0 = "Ands" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = and p - in mkNodeB opts b [msg0 <> show1 opts " | " p] [hh pp] - --- | 'Data.List.ors' --- --- >>> pl @(Ors Id) [False,False,False] --- False --- FalseT --- --- >>> pl @(Ors Id) [True,True,True,False] --- True --- TrueT --- --- >>> pl @(Ors Id) [] --- False --- FalseT --- -data Ors p -type Ors' p = FoldMap SG.Any p - -instance (PP p x ~ t a - , P p x - , Show (t a) - , Foldable t - , a ~ Bool - ) => P (Ors p) x where - type PP (Ors p) x = Bool - eval _ opts x = do - let msg0 = "Ors" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = or p - in mkNodeB opts b [msg0 <> show1 opts " | " p] [hh pp] - --- cant directly create a singleton type using '[] since the type of '[] is unknown. instead use 'Singleton' or 'EmptyT' - --- | similar to cons --- --- >>> pl @(Fst Id :+ Snd Id) (99,[1,2,3,4]) --- Present [99,1,2,3,4] --- PresentT [99,1,2,3,4] --- --- >>> pl @(Snd Id :+ Fst Id) ([],5) --- Present [5] --- PresentT [5] --- --- >>> pl @(123 :+ EmptyList _) "somestuff" --- Present [123] --- PresentT [123] --- -data p :+ q -infixr 5 :+ -instance (P p x - , P q x - , Show (PP p x) - , Show (PP q x) - , Cons (PP q x) (PP q x) (PP p x) (PP p x) - ) => P (p :+ q) x where - type PP (p :+ q) x = PP q x - eval _ opts z = do - let msg0 = "(:+)" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts z - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let b = p `cons` q - in mkNode opts (PresentT b) [show01' opts msg0 b "p=" p <> show1 opts " | q=" q] [hh pp, hh qq] - --- | similar to snoc --- --- >>> pl @(Snd Id +: Fst Id) (99,[1,2,3,4]) --- Present [1,2,3,4,99] --- PresentT [1,2,3,4,99] --- --- >>> pl @(Fst Id +: Snd Id) ([],5) --- Present [5] --- PresentT [5] --- --- >>> pl @(EmptyT [] Id +: 5) 5 --- Present [5] --- PresentT [5] --- -data p +: q -infixl 5 +: - -instance (P p x - , P q x - , Show (PP q x) - , Show (PP p x) - , Snoc (PP p x) (PP p x) (PP q x) (PP q x) - ) => P (p +: q) x where - type PP (p +: q) x = PP p x - eval _ opts z = do - let msg0 = "(+:)" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts z - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let b = p `snoc` q - in mkNode opts (PresentT b) [show01' opts msg0 b "p=" p <> show1 opts " | q=" q] [hh pp, hh qq] - --- | 'Control.Lens.uncons' --- --- >>> pl @Uncons [1,2,3,4] --- Present Just (1,[2,3,4]) --- PresentT (Just (1,[2,3,4])) --- --- >>> pl @Uncons [] --- Present Nothing --- PresentT Nothing --- -data Uncons - -instance (Show (ConsT s) - , Show s - , Cons s s (ConsT s) (ConsT s) - ) => P Uncons s where - type PP Uncons s = Maybe (ConsT s,s) - eval _ opts as = - let msg0 = "Uncons" - b = as ^? _Cons - in pure $ mkNode opts (PresentT b) [show01 opts msg0 b as] [] - --- | 'Control.Lens.unsnoc' --- --- >>> pl @Unsnoc [1,2,3,4] --- Present Just ([1,2,3],4) --- PresentT (Just ([1,2,3],4)) --- --- >>> pl @Unsnoc [] --- Present Nothing --- PresentT Nothing --- -data Unsnoc - -instance (Show (ConsT s) - , Show s - , Snoc s s (ConsT s) (ConsT s) - ) => P Unsnoc s where - type PP Unsnoc s = Maybe (s,ConsT s) - eval _ opts as = - let msg0 = "Unsnoc" - b = as ^? _Snoc - in pure $ mkNode opts (PresentT b) [show01 opts msg0 b as] [] - --- | similar to 'null' using 'AsEmpty' --- --- >>> pl @IsEmpty [1,2,3,4] --- False --- FalseT --- --- >>> pl @IsEmpty [] --- True --- TrueT --- --- >>> pl @IsEmpty LT --- False --- FalseT --- --- >>> pl @IsEmpty EQ --- True --- TrueT --- -data IsEmpty - -instance (Show as, AsEmpty as) => P IsEmpty as where - type PP IsEmpty as = Bool - eval _ opts as = - let b = has _Empty as - in pure $ mkNodeB opts b ["IsEmpty" <> show1 opts " | " as] [] - --- | similar to 'null' using 'Foldable' --- --- >>> pl @Null [1,2,3,4] --- False --- FalseT --- --- >>> pl @Null [] --- True --- TrueT --- -data Null - -instance (Show (t a) - , Foldable t - , t a ~ as - ) => P Null as where - type PP Null as = Bool - eval _ opts as = - let b = null as - in pure $ mkNodeB opts b ["Null" <> show1 opts " | " as] [] - --- | similar to 'enumFromTo' --- --- >>> pl @(EnumFromTo 2 5) () --- Present [2,3,4,5] --- PresentT [2,3,4,5] --- --- >>> pl @(EnumFromTo LT GT) () --- Present [LT,EQ,GT] --- PresentT [LT,EQ,GT] --- - -data EnumFromTo p q -instance (P p x - , P q x - , PP p x ~ a - , Show a - , PP q x ~ a - , Enum a - ) => P (EnumFromTo p q) x where - type PP (EnumFromTo p q) x = [PP p x] - eval _ opts z = do - let msg0 = "EnumFromTo" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts z - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> mkNode opts (PresentT (enumFromTo p q)) [msg0 <> " [" <> show p <> " .. " <> show q <> "]"] [hh pp, hh qq] - -type MapMaybe p q = ConcatMap (p >> MaybeIn MEmptyP '[Id]) q -type CatMaybes q = MapMaybe Id q - --- | similar to 'partitionEithers' --- --- >>> pl @PartitionEithers [Left 'a',Right 2,Left 'c',Right 4,Right 99] --- Present ("ac",[2,4,99]) --- PresentT ("ac",[2,4,99]) --- -data PartitionEithers - -instance (Show a, Show b) => P PartitionEithers [Either a b] where - type PP PartitionEithers [Either a b] = ([a], [b]) - eval _ opts as = - let msg0 = "PartitionEithers" - b = partitionEithers as - in pure $ mkNode opts (PresentT b) [show01 opts msg0 b as] [] - --- | similar to 'partitionThese'. returns a 3-tuple with the results so use 'Fst' 'Snd' 'Thd' to extract --- --- >>> pl @PartitionThese [This 'a', That 2, This 'c', These 'z' 1, That 4, These 'a' 2, That 99] --- Present ("ac",[2,4,99],[('z',1),('a',2)]) --- PresentT ("ac",[2,4,99],[('z',1),('a',2)]) --- -data PartitionThese -instance (Show a, Show b) => P PartitionThese [These a b] where - type PP PartitionThese [These a b] = ([a], [b], [(a, b)]) - eval _ opts as = - let msg0 = "PartitionThese" - b = partitionThese as - in pure $ mkNode opts (PresentT b) [show01 opts msg0 b as] [] - -type Thiss = PartitionThese >> Fst Id -type Thats = PartitionThese >> Snd Id -type Theses = PartitionThese >> Thd Id - --- want to pass Proxy b to q but then we have no way to calculate 'b' - --- | similar to 'scanl' --- --- >>> pl @(Scanl (Snd Id :+ Fst Id) (Fst Id) (Snd Id)) ([99],[1..5]) --- Present [[99],[1,99],[2,1,99],[3,2,1,99],[4,3,2,1,99],[5,4,3,2,1,99]] --- PresentT [[99],[1,99],[2,1,99],[3,2,1,99],[4,3,2,1,99],[5,4,3,2,1,99]] --- --- >>> pl @(ScanN 4 Id (Succ Id)) 'c' --- Present "cdefg" --- PresentT "cdefg" --- --- >>> pl @(FoldN 4 Id (Succ Id)) 'c' --- Present 'g' --- PresentT 'g' --- - -data Scanl p q r --- scanr :: (a -> b -> b) -> b -> [a] -> [b] --- result is scanl but signature is flipped ((a,b) -> b) -> b -> [a] -> [b] - -type ScanN n p q = Scanl (Fst Id >> q) p (EnumFromTo 1 n) -- n times using q then run p -type ScanNA q = ScanN (Fst Id) (Snd Id) q - -type FoldN n p q = Last' (ScanN n p q) -type Foldl p q r = Last' (Scanl p q r) - -instance (PP p (b,a) ~ b - , PP q x ~ b - , PP r x ~ [a] - , P p (b,a) - , P q x - , P r x - , Show b - , Show a - ) - => P (Scanl p q r) x where - type PP (Scanl p q r) x = [PP q x] - eval _ opts z = do - let msg0 = "Scanl" - lr <- runPQ msg0 (Proxy @q) (Proxy @r) opts z - case lr of - Left e -> pure e - Right (q,r,qq,rr) -> do - let msg1 = msg0 -- <> show0 opts " " q <> show0 opts " " r - ff i b as' rs - | i >= _MX = pure (rs, Left $ mkNode opts (FailT (msg1 <> ":failed at i=" <> show i)) [msg1 <> " i=" <> show i <> " (b,as')=" <> show (b,as')] []) - | otherwise = - case as' of - [] -> pure (rs, Right ()) -- ++ [((i,q), mkNode opts (PresentT q) [msg1 <> "(done)"] [])], Right ()) - a:as -> do - pp :: TT b <- eval (Proxy @p) opts (b,a) - case getValueLR opts (msg1 <> " i=" <> show i <> " a=" <> show a) pp [] of - Left e -> pure (rs,Left e) - Right b' -> ff (i+1) b' as (rs ++ [((i,b), pp)]) - (ts,lrx) :: ([((Int, b), TT b)], Either (TT [b]) ()) <- ff 1 q r [] - pure $ case splitAndAlign opts [msg1] (((0,q), mkNode opts (PresentT q) [msg1 <> "(initial)"] []) : ts) of - Left _e -> error "cant happen!" - Right (vals,itts) -> - case lrx of - Left e -> mkNode opts (_tBool e) [msg1] (hh qq : hh rr : map (hh . fixit) itts ++ [hh e]) - Right () -> mkNode opts (PresentT vals) [show01' opts msg1 vals "b=" q <> show1 opts " | as=" r] (hh qq : hh rr : map (hh . fixit) itts) - -type family UnfoldT mbs where - UnfoldT (Maybe (b,s)) = b - --- | similar to 'unfoldr' --- --- >>> pl @(Unfoldr (MaybeB (Not Null) (SplitAt 2 Id)) Id) [1..5] --- Present [[1,2],[3,4],[5]] --- PresentT [[1,2],[3,4],[5]] --- --- >>> pl @(IterateN 4 (Succ Id)) 4 --- Present [4,5,6,7] --- PresentT [4,5,6,7] --- -data Unfoldr p q ---type IterateN (t :: Type) n f = Unfoldr (If (Fst Id == 0) (MkNothing t) (Snd Id &&& (Pred Id *** f) >> MkJust Id)) '(n, Id) -type IterateN n f = Unfoldr (MaybeB (Fst Id > 0) '(Snd Id, Pred Id *** f)) '(n, Id) -type IterateUntil p f = IterateWhile (Not p) f -type IterateWhile p f = Unfoldr (MaybeB p '(Id, f)) Id -type IterateNWhile n p f = '(n, Id) >> IterateWhile (Fst Id > 0 && (Snd Id >> p)) (Pred Id *** f) >> Map (Snd Id) Id -type IterateNUntil n p f = IterateNWhile n (Not p) f - -instance (PP q a ~ s - , PP p s ~ Maybe (b,s) - , P q a - , P p s - , Show s - , Show b - ) - => P (Unfoldr p q) a where - type PP (Unfoldr p q) a = [UnfoldT (PP p (PP q a))] - eval _ opts z = do - let msg0 = "Unfoldr" - qq <- eval (Proxy @q) opts z - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right q -> do - let msg1 = msg0 <> show0 opts " " q - ff i s rs | i >= _MX = pure (rs, Left $ mkNode opts (FailT (msg1 <> ":failed at i=" <> show i)) [msg1 <> " i=" <> show i <> " s=" <> show s] []) - | otherwise = do - pp :: TT (PP p s) <- eval (Proxy @p) opts s - case getValueLR opts (msg1 <> " i=" <> show i <> " s=" <> show s) pp [] of - Left e -> pure (rs, Left e) - Right Nothing -> pure (rs, Right ()) - Right w@(Just (_b,s')) -> ff (i+1) s' (rs ++ [((i,w), pp)]) - (ts,lr) :: ([((Int, PP p s), TT (PP p s))], Either (TT [b]) ()) <- ff 1 q [] - pure $ case splitAndAlign opts [msg1] ts of - Left _e -> error "cant happen" - Right (vals, itts) -> - case lr of - Left e -> mkNode opts (_tBool e) [msg1] (hh qq : map (hh . fixit) itts ++ [hh e]) - Right () -> - let ret = fst <$> catMaybes vals - in mkNode opts (PresentT ret) [show01' opts msg1 ret "s=" q ] (hh qq : map (hh . fixit) itts) - --- | similar to 'map' --- --- >>> pl @(Map (Pred Id) Id) [1..5] --- Present [0,1,2,3,4] --- PresentT [0,1,2,3,4] --- -data Map p q -type ConcatMap p q = Concat (Map p q) - -instance (Show (PP p a) - , P p a - , PP q x ~ f a - , P q x - , Show a - , Show (f a) - , Foldable f - ) => P (Map p q) x where - type PP (Map p q) x = [PP p (ExtractAFromTA (PP q x))] - eval _ opts x = do - let msg0 = "Map" - qq <- eval (Proxy @q) opts x - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right as -> do - ts <- zipWithM (\i a -> ((i, a),) <$> eval (Proxy @p) opts a) [0::Int ..] (toList as) - pure $ case splitAndAlign opts [msg0] ts of - Left e -> e - Right (vals, _) -> mkNode opts (PresentT vals) [show01 opts msg0 vals as] (hh qq : map (hh . fixit) ts) - --- | if p then run q else run r --- --- >>> pl @(If (Gt 4) "greater than 4" "less than or equal to 4" ) 10 --- Present "greater than 4" --- PresentT "greater than 4" --- --- >>> pl @(If (Gt 4) "greater than 4" "less than or equal to 4") 0 --- Present "less than or equal to 4" --- PresentT "less than or equal to 4" -data If p q r - -instance (Show (PP r a) - , P p a - , PP p a ~ Bool - , P q a - , P r a - , PP q a ~ PP r a - ) => P (If p q r) a where - type PP (If p q r) a = PP q a - eval _ opts a = do - let msg0 = "If" - pp <- evalBool (Proxy @p) opts a - case getValueLR opts (msg0 <> " condition failed") pp [] of - Left e -> pure e - Right b -> do - qqrr <- if b - then eval (Proxy @q) opts a - else eval (Proxy @r) opts a - pure $ case getValueLR opts (msg0 <> " [" <> show b <> "]") qqrr [hh pp, hh qqrr] of - Left e -> e - Right ret -> mkNode opts (_tBool qqrr) [msg0 <> " " <> if b then "(true cond)" else "(false cond)" <> show0 opts " " ret] [hh pp, hh qqrr] - --- | creates a list of overlapping pairs of elements. requires two or more elements --- --- >>> pl @Pairs [1,2,3,4] --- Present [(1,2),(2,3),(3,4)] --- PresentT [(1,2),(2,3),(3,4)] --- --- >>> pl @Pairs [] --- Error Pairs no data found --- FailT "Pairs no data found" --- --- >>> pl @Pairs [1] --- Error Pairs only one element found --- FailT "Pairs only one element found" --- -data Pairs -instance Show a => P Pairs [a] where - type PP Pairs [a] = [(a,a)] - eval _ opts as = - let msg0 = "Pairs" - lr = case as of - [] -> Left (msg0 <> " no data found") - [_] -> Left (msg0 <> " only one element found") - _:bs@(_:_) -> Right (zip as bs) - in pure $ case lr of - Left e -> mkNode opts (FailT e) [e] [] - Right zs -> mkNode opts (PresentT zs) [show01 opts msg0 zs as ] [] - - --- | similar to 'partition' --- --- >>> pl @(Partition (Ge 3) Id) [10,4,1,7,3,1,3,5] --- Present ([10,4,7,3,3,5],[1,1]) --- PresentT ([10,4,7,3,3,5],[1,1]) --- --- >>> pl @(Partition (Prime Id) Id) [10,4,1,7,3,1,3,5] --- Present ([7,3,3,5],[10,4,1,1]) --- PresentT ([7,3,3,5],[10,4,1,1]) --- --- >>> pl @(Partition (Ge 300) Id) [10,4,1,7,3,1,3,5] --- Present ([],[10,4,1,7,3,1,3,5]) --- PresentT ([],[10,4,1,7,3,1,3,5]) --- --- >>> pl @(Partition (Id < 300) Id) [10,4,1,7,3,1,3,5] --- Present ([10,4,1,7,3,1,3,5],[]) --- PresentT ([10,4,1,7,3,1,3,5],[]) --- -data Partition p q - -type FilterBy p q = Partition p q >> Fst Id - -instance (P p x - , Show x - , PP q a ~ [x] - , PP p x ~ Bool - , P q a - ) => P (Partition p q) a where - type PP (Partition p q) a = (PP q a, PP q a) - eval _ opts a' = do - let msg0 = "Partition" - qq <- eval (Proxy @q) opts a' - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right as -> do - ts <- zipWithM (\i a -> ((i, a),) <$> evalBool (Proxy @p) opts a) [0::Int ..] as - pure $ case splitAndAlign opts [msg0] ts of - Left e -> e - Right (vals, tfs) -> - let w0 = partition fst $ zip vals tfs - zz1 = (map (snd . fst . snd) *** map (snd . fst . snd)) w0 - in mkNode opts (PresentT zz1) [show01' opts msg0 zz1 "s=" as] (hh qq : map (hh . fixit) tfs) - - --- | similar to 'break' --- --- >>> pl @(Break (Ge 3) Id) [10,4,1,7,3,1,3,5] --- Present ([],[10,4,1,7,3,1,3,5]) --- PresentT ([],[10,4,1,7,3,1,3,5]) --- --- >>> pl @(Break (Lt 3) Id) [10,4,1,7,3,1,3,5] --- Present ([10,4],[1,7,3,1,3,5]) --- PresentT ([10,4],[1,7,3,1,3,5]) --- -data Break p q -type Span p q = Break (Not p) q --- only process up to the pivot! only process while Right False --- a predicate can return PresentP not just TrueP -instance (P p x - , PP q a ~ [x] - , PP p x ~ Bool - , P q a - ) => P (Break p q) a where - type PP (Break p q) a = (PP q a, PP q a) - eval _ opts a' = do - let msg0 = "Break" - qq <- eval (Proxy @q) opts a' - case getValueLR opts msg0 qq [] of - Left e -> pure e - Right as -> do - let ff [] zs = pure (zs, [], Nothing) -- [(ia,qq)] extras | the rest of the data | optional last pivot or error - ff ((i,a):ias) zs = do - pp <- evalBool (Proxy @p) opts a - let v = ((i,a), pp) - case getValueLR opts msg0 pp [hh qq] of - Right False -> ff ias (zs Seq.|> v) - Right True -> pure (zs,map snd ias,Just v) - Left _ -> pure (zs,map snd ias,Just v) - (ialls,rhs,mpivot) <- ff (zip [0::Int ..] as) Seq.empty - pure $ case mpivot of - Nothing -> - mkNode opts (PresentT (map (snd . fst) (toList ialls), rhs)) - ([msg0] <> ["cnt=" <> show (length ialls, length rhs)]) - (map (hh . fixit) (toList ialls)) - Just iall@(ia, tt) -> - case getValueLR opts (msg0 <> " predicate failed") tt (hh qq : map (hh . fixit) (toList (ialls Seq.|> iall))) of - Right True -> - mkNode opts (PresentT (map (snd . fst) (toList ialls), snd ia : rhs)) - ([msg0] <> ["cnt=" <> show (length ialls, 1+length rhs)]) - (hh qq : hh tt : map (hh . fixit) (toList (ialls Seq.|> iall))) - - Right False -> error "shouldnt happen" - Left e -> e - --- | Fails the computation with a message --- --- >>> pl @(Failt Int (Printf "value=%03d" Id)) 99 --- Error value=099 --- FailT "value=099" --- --- >>> pl @(FailS (Printf2 "value=%03d string=%s")) (99,"somedata") --- Error value=099 string=somedata --- FailT "value=099 string=somedata" --- -data Fail t prt -- t=output type prt=msg -type Failp s = Fail Unproxy s -type Failt (t :: Type) prt = Fail (Hole t) prt -type FailS s = Fail I s -type FailPrt (t :: Type) prt = Fail (Hole t)(Printf prt) -type FailPrt2 (t :: Type) prt = Fail (Hole t)(Printf2 prt) - -instance (P prt a - , PP prt a ~ String - ) => P (Fail t prt) a where - type PP (Fail t prt) a = PP t a - eval _ opts a = do - let msg0 = "Fail" - pp <- eval (Proxy @prt) opts a - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right s -> mkNode opts (FailT s) [msg0 <> " " <> s] [hh pp] - -data Hole (t :: Type) -type T (t :: Type) = Hole t -- easier to type - --- | Acts as a proxy in this dsl where you can explicitly set the Type. --- --- It is passed around as an argument to help the type checker when needed. --- see 'ReadP', 'ParseTimeP', 'ShowP' --- -instance Typeable t => P (Hole t) a where - type PP (Hole t) a = t -- can only be Type not Type -> Type (can use Proxy but then we go down the rabbithole) - eval _ opts _a = - let msg0 = "Hole(" <> showT @t <> ")" - in pure $ mkNode opts (FailT msg0) [msg0 <> " you probably meant to get access to the type of PP only and not evaluate"] [] - -data Unproxy - -instance Typeable a => P Unproxy (Proxy (a :: Type)) where - type PP Unproxy (Proxy a) = a - eval _ opts _a = - let msg0 = "Unproxy(" <> showT @a <> ")" - in pure $ mkNode opts (FailT msg0) [msg0 <> " you probably meant to get access to the type of PP only and not evaluate"] [] - --- | catch a failure --- --- >>> pl @(Catch (Succ Id) (Fst Id >> Second (ShowP Id) >> Printf2 "%s %s" >> 'LT)) GT --- Present LT --- PresentT LT --- --- >>> pl @(Catch' (Succ Id) (Second (ShowP Id) >> Printf2 "%s %s")) GT --- Error Succ IO e=Prelude.Enum.Ordering.succ: bad argument GT --- FailT "Succ IO e=Prelude.Enum.Ordering.succ: bad argument GT" --- --- >>> pl @(Catch' (Succ Id) (Second (ShowP Id) >> Printf2 "%s %s")) LT --- Present EQ --- PresentT EQ --- --- more flexible: takes a (String,x) and a proxy so we can still call 'False 'True --- now takes the FailT string and x so you can print more detail if you want --- need the proxy so we can fail without having to explicitly specify a type -data Catch p q -- catch p and if fails runs q only on failt -type Catch' p s = Catch p (FailCatch s) -- eg set eg s=Printf "%d" Id or Printf "%s" (ShowP Id) -type FailCatch s = Fail (Snd Id >> Unproxy) (Fst Id >> s) - -instance (P p x - , P q ((String, x) - , Proxy (PP p x)) - , PP p x ~ PP q ((String, x), Proxy (PP p x)) - ) => P (Catch p q) x where - type PP (Catch p q) x = PP p x - eval _ opts x = do - let msg0 = "Catch" - pp <- eval (Proxy @p) opts x - case getValueLR opts msg0 pp [] of - Left e -> do - let emsg = e ^?! tBool . _FailT -- extract the failt string a push back into the fail case - qq <- eval (Proxy @q) opts ((emsg, x), Proxy @(PP p x)) - pure $ case getValueLR opts (msg0 <> " default condition failed") qq [hh pp] of - Left e1 -> e1 - Right _ -> mkNode opts (_tBool qq) [msg0 <> " caught exception[" <> emsg <> "]"] [hh pp, hh qq] - Right _ -> pure $ mkNode opts (_tBool pp) [msg0 <> " did not fire"] [hh pp] - -type Even = Mod I 2 == 0 -type Odd = Mod I 2 == 1 -type Div' p q = Fst (DivMod p q) -type Mod' p q = Snd (DivMod p q) - --- | similar to 'div' --- --- >>> pl @(Div (Fst Id) (Snd Id)) (10,4) --- Present 2 --- PresentT 2 --- --- >>> pl @(Div (Fst Id) (Snd Id)) (10,0) --- Error Div zero denominator --- FailT "Div zero denominator" --- -data Div p q -instance (PP p a ~ PP q a - , P p a - , P q a - , Show (PP p a) - , Integral (PP p a) - ) => P (Div p q) a where - type PP (Div p q) a = PP p a - eval _ opts a = do - let msg0 = "Div" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let hhs = [hh pp, hh qq] - in case q of - 0 -> mkNode opts (FailT (msg0 <> " zero denominator")) [msg0 <> " zero denominator"] hhs - _ -> let d = p `div` q - in mkNode opts (PresentT d) [show p <> " `div` " <> show q <> " = " <> show d] hhs - - --- | similar to 'mod' --- --- >>> pl @(Mod (Fst Id) (Snd Id)) (10,3) --- Present 1 --- PresentT 1 --- --- >>> pl @(Mod (Fst Id) (Snd Id)) (10,0) --- Error Mod zero denominator --- FailT "Mod zero denominator" --- -data Mod p q -instance (PP p a ~ PP q a - , P p a - , P q a - , Show (PP p a) - , Integral (PP p a) - ) => P (Mod p q) a where - type PP (Mod p q) a = PP p a - eval _ opts a = do - let msg0 = "Mod" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let hhs = [hh pp, hh qq] - in case q of - 0 -> mkNode opts (FailT (msg0 <> " zero denominator")) [msg0 <> " zero denominator"] hhs - _ -> let d = p `mod` q - in mkNode opts (PresentT d) [show p <> " `mod` " <> show q <> " = " <> show d] hhs - --- | similar to 'divMod' --- --- >>> pl @(DivMod (Fst Id) (Snd Id)) (10,3) --- Present (3,1) --- PresentT (3,1) --- --- >>> pl @(DivMod (Fst Id) (Snd Id)) (10,-3) --- Present (-4,-2) --- PresentT (-4,-2) --- --- >>> pl @(DivMod (Fst Id) (Snd Id)) (-10,3) --- Present (-4,2) --- PresentT (-4,2) --- --- >>> pl @(DivMod (Fst Id) (Snd Id)) (-10,-3) --- Present (3,-1) --- PresentT (3,-1) --- --- >>> pl @(DivMod (Fst Id) (Snd Id)) (10,0) --- Error DivMod zero denominator --- FailT "DivMod zero denominator" --- -data DivMod p q - -instance (PP p a ~ PP q a - , P p a - , P q a - , Show (PP p a) - , Integral (PP p a) - ) => P (DivMod p q) a where - type PP (DivMod p q) a = (PP p a, PP p a) - eval _ opts a = do - let msg0 = "DivMod" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let hhs = [hh pp, hh qq] - in case q of - 0 -> mkNode opts (FailT (msg0 <> " zero denominator")) [msg0 <> " zero denominator"] hhs - _ -> let d = p `divMod` q - in mkNode opts (PresentT d) [show p <> " `divMod` " <> show q <> " = " <> show d] hhs - --- | similar to 'quotRem' --- --- >>> pl @(QuotRem (Fst Id) (Snd Id)) (10,3) --- Present (3,1) --- PresentT (3,1) --- --- >>> pl @(QuotRem (Fst Id) (Snd Id)) (10,-3) --- Present (-3,1) --- PresentT (-3,1) --- --- >>> pl @(QuotRem (Fst Id) (Snd Id)) (-10,-3) --- Present (3,-1) --- PresentT (3,-1) --- --- >>> pl @(QuotRem (Fst Id) (Snd Id)) (-10,3) --- Present (-3,-1) --- PresentT (-3,-1) --- --- >>> pl @(QuotRem (Fst Id) (Snd Id)) (10,0) --- Error QuotRem zero denominator --- FailT "QuotRem zero denominator" --- -data QuotRem p q - -instance (PP p a ~ PP q a - , P p a - , P q a - , Show (PP p a) - , Integral (PP p a) - ) => P (QuotRem p q) a where - type PP (QuotRem p q) a = (PP p a, PP p a) - eval _ opts a = do - let msg0 = "QuotRem" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let hhs = [hh pp, hh qq] - in case q of - 0 -> mkNode opts (FailT (msg0 <> " zero denominator")) [msg0 <> " zero denominator"] hhs - _ -> let d = p `quotRem` q - in mkNode opts (PresentT d) [show p <> " `quotRem` " <> show q <> " = " <> show d] hhs - -type Quot p q = Fst (QuotRem p q) -type Rem p q = Snd (QuotRem p q) - ---type OneP = Guard "expected list of length 1" (Len >> Same 1) >> Head' -type OneP = Guard (Printf "expected list of length 1 but found length=%d" Len) (Len >> Same 1) >> Head - -strictmsg :: forall strict . GetBool strict => String -strictmsg = if getBool @strict then "" else "Lax" - --- k or prt has access to (Int,a) where Int is the current guard position: hence need to use Printf2 --- todo: better explanation of how this works --- passthru but adds the length of ps (replaces LenT in the type synonym to avoid type synonyms being expanded out) - --- | Guards contain a type level list of tuples the action to run on failure of the predicate and the predicate itself --- Each tuple validating against the corresponding value in a value list --- --- >>> pl @(Guards '[ '("arg1 failed",Gt 4), '("arg2 failed", Same 4)]) [17,4] --- Present [17,4] --- PresentT [17,4] --- --- >>> pl @(Guards '[ '("arg1 failed",Gt 4), '("arg2 failed", Same 5)]) [17,4] --- Error arg2 failed --- FailT "arg2 failed" --- --- >>> pl @(Guards '[ '("arg1 failed",Gt 99), '("arg2 failed", Same 4)]) [17,4] --- Error arg1 failed --- FailT "arg1 failed" --- --- >>> pl @(Guards '[ '(Printf2 "arg %d failed with value %d",Gt 4), '(Printf2 "%d %d", Same 4)]) [17,3] --- Error 2 3 --- FailT "2 3" --- --- >>> pl @(GuardsQuick (Printf2 "arg %d failed with value %d") '[Gt 4, Ge 3, Same 4]) [17,3,5] --- Error arg 3 failed with value 5 --- FailT "arg 3 failed with value 5" --- --- >>> pl @(GuardsQuick (Printf2 "arg %d failed with value %d") '[Gt 4, Ge 3, Same 4]) [17,3,5,99] --- Error Guards: data elements(4) /= predicates(3) --- FailT "Guards: data elements(4) /= predicates(3)" --- -data GuardsImpl (n :: Nat) (strict :: Bool) (os :: [(k,k1)]) -type Guards (os :: [(k,k1)]) = GuardsImplW 'True os -type GuardsLax (os :: [(k,k1)]) = GuardsImplW 'False os -type GuardsQuick (prt :: k) (os :: [k1]) = Guards (ToGuardsT prt os) - -data GuardsImplW (strict :: Bool) (ps :: [(k,k1)]) -instance (GetBool strict, GetLen ps, P (GuardsImpl (LenT ps) strict ps) [a]) => P (GuardsImplW strict ps) [a] where - type PP (GuardsImplW strict ps) [a] = PP (GuardsImpl (LenT ps) strict ps) [a] - eval _ opts as = do - let strict = getBool @strict - msgbase0 = "Guards" <> strictmsg @strict - n = getLen @ps - if strict && n /= length as then - let xx = msgbase0 <> ": data elements(" <> show (length as) <> ") /= predicates(" <> show n <> ")" - in pure $ mkNode opts (FailT xx) [xx] [] - else eval (Proxy @(GuardsImpl (LenT ps) strict ps)) opts as - -instance (KnownNat n - , GetBool strict - , Show a - ) => P (GuardsImpl n strict ('[] :: [(k,k1)])) [a] where - type PP (GuardsImpl n strict ('[] :: [(k,k1)])) [a] = [a] - eval _ opts as = - let msg0 = "Guards" <> strictmsg @strict <> "(" <> show n <> ")" - n :: Int = nat @n - in pure $ mkNode opts (PresentT as) [msg0 <> " done!" <> if null as then "" else show1 opts " | leftovers=" as] [] - -instance (PP prt (Int, a) ~ String - , P prt (Int, a) - , KnownNat n - , GetBool strict - , GetLen ps - , P p a - , PP p a ~ Bool - , P (GuardsImpl n strict ps) [a] - , PP (GuardsImpl n strict ps) [a] ~ [a] - , Show a - ) => P (GuardsImpl n strict ('(prt,p) ': ps)) [a] where - type PP (GuardsImpl n strict ('(prt,p) ': ps)) [a] = [a] - eval _ opts as' = do - let msgbase0 = "Guards" <> strictmsg @strict <> "(" <> show (n-pos) <> ":" <> show n <> ")" - msgbase1 = "Guard" <> strictmsg @strict <> "(" <> show (n-pos) <> ")" - msgbase2 = "Guards" <> strictmsg @strict - n :: Int = nat @n - pos = getLen @ps - case as' of - [] -> pure $ mkNode opts mempty [msgbase0 <> " (ran out of data!!)"] [] - a:as -> do - pp <- evalBool (Proxy @p) opts a - case getValueLR opts (msgbase1 <> " p failed") pp [] of - Left e -> pure e - Right False -> do - qq <- eval (Proxy @prt) opts (n-pos,a) -- only run prt when predicate is False - pure $ case getValueLR opts (msgbase2 <> " False predicate and prt failed") qq [hh pp] of - Left e -> e - Right msgx -> mkNode opts (FailT msgx) [msgbase1 <> " failed [" <> msgx <> "]" <> show0 opts " " a] [hh pp, hh qq] - Right True -> do - ss <- eval (Proxy @(GuardsImpl n strict ps)) opts as - pure $ case getValueLRHide opts (msgbase1 <> " ok | rhs failed") ss [hh pp] of - Left e -> e -- shortcut else we get too compounding errors with the pp tree being added each time! - Right zs -> mkNode opts (PresentT (a:zs)) [msgbase1 <> show0 opts " " a] [hh pp, hh ss] - --- | \'p\' is the predicate and on failure of the predicate runs \'prt\' --- --- >>> pl @(Guard "expected > 3" (Gt 3)) 17 --- Present 17 --- PresentT 17 --- --- >>> pl @(Guard "expected > 3" (Gt 3)) 1 --- Error expected > 3 --- FailT "expected > 3" --- --- >>> pl @(Guard (Printf "%d not > 3" Id) (Gt 3)) (-99) --- Error -99 not > 3 --- FailT "-99 not > 3" --- -data Guard prt p -type Guard' p = Guard "Guard" p - -type ExitWhen prt p = Guard prt (Not p) -type ExitWhen' p = ExitWhen "ExitWhen" p - -instance (Show a - , P prt a - , PP prt a ~ String - , P p a - , PP p a ~ Bool - ) => P (Guard prt p) a where - type PP (Guard prt p) a = a - eval _ opts a = do - let msg0 = "Guard" - pp <- evalBool (Proxy @p) opts a - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right False -> do - qq <- eval (Proxy @prt) opts a - pure $ case getValueLR opts (msg0 <> " Msg") qq [hh pp] of - Left e -> e - Right msgx -> mkNode opts (FailT msgx) [msg0 <> "(failed) [" <> msgx <> "]" <> show0 opts " | " a] [hh pp, hh qq] - Right True -> pure $ mkNode opts (PresentT a) [msg0 <> "(ok)" <> show0 opts " | " a] [hh pp] -- dont show the guard message if successful - - --- | similar to 'Guard' but uses the root message of the False predicate case as the failure message --- --- >>> pl @(GuardSimple (Luhn Id)) [1..4] --- Error Luhn map=[4,6,2,2] sum=14 ret=4 | [1,2,3,4] --- FailT "Luhn map=[4,6,2,2] sum=14 ret=4 | [1,2,3,4]" --- --- >>> pl @(GuardSimple (Luhn Id)) [1,2,3,0] --- Present [1,2,3,0] --- PresentT [1,2,3,0] --- --- >>> pl @(GuardSimple (Len > 30)) [1,2,3,0] --- Error 4 > 30 --- FailT "4 > 30" --- -data GuardSimple p - -instance (Show a - , P p a - , PP p a ~ Bool - ) => P (GuardSimple p) a where - type PP (GuardSimple p) a = a - eval _ opts a = do - let msg0 = "GuardSimple" - b = oLite opts - pp <- evalBool (Proxy @p) (if b then o0 else opts) a -- to not lose the message in oLite mode we use non lite and then fix it up after - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right False -> - let msgx = fromMaybe msg0 $ pp ^? tStrings . ix 0 - in mkNode opts (FailT msgx) [msg0 <> "(failed) [" <> msgx <> "]" <> show0 opts " | " a] [hh pp] - Right True -> - mkNode opts (PresentT a) [msg0 <> "(ok)" <> show0 opts " | " a] [hh pp] - - --- | just run the effect but skip the value --- for example for use with Stdout so it doesnt interfere with the \'a\' on the rhs unless there is an error -data Skip p -type p |> q = Skip p >> q -infixr 1 |> -type p >| q = p >> Skip q -infixr 1 >| - -instance (Show (PP p a), P p a) => P (Skip p) a where - type PP (Skip p) a = a - eval _ opts a = do - let msg0 = "Skip" - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> mkNode opts (PresentT a) [msg0 <> show0 opts " " p] [hh pp] - --- advantage of (>>) over 'Do [k] is we can use different kinds for (>>) without having to wrap with 'W' - --- | This is composition for predicates --- --- >>> pl @(Fst Id >> Succ (Id !! 0)) ([11,12],'x') --- Present 12 --- PresentT 12 --- --- >>> pl @(Len *** Succ Id >> ShowP (First (Pred Id))) ([11,12],'x') --- Present "(1,'y')" --- PresentT "(1,'y')" --- - -data (p :: k) >> (q :: k1) -infixr 1 >> - -type (<<) p q = q >> p -infixl 1 << - -instance (Show (PP p a) - , Show (PP q (PP p a)) - , P p a - , P q (PP p a) - ) => P (p >> q) a where - type PP (p >> q) a = PP q (PP p a) - eval _ opts a = do - let msg0 = ">>" - pp <- eval (Proxy @p) opts a - case getValueLRHide opts "lhs failed >>" pp [] of - Left e -> pure e - Right p -> do - qq <- eval (Proxy @q) opts p - pure $ case getValueLRHide opts (show p <> " >> rhs failed") qq [hh pp] of - Left e -> e - Right q -> mkNode opts (_tBool qq) [show01 opts msg0 q p] [hh pp, hh qq] - --- | similar to 'Prelude.&&' --- --- >>> pl @(Fst Id && (Snd Id >> Len >> Ge 4)) (True,[11,12,13,14]) --- True --- TrueT --- --- >>> pl @(Fst Id && (Snd Id >> Len >> Same 4)) (True,[12,11,12,13,14]) --- False --- FalseT --- -data (&&) (p :: k) (q :: k1) -type And p q = p && q -infixr 3 && - -instance (P p a - , P q a - , PP p a ~ Bool - , PP q a ~ Bool - ) => P (p && q) a where - type PP (p && q) a = Bool - eval _ opts a = do - pp <- evalBool (Proxy @p) opts a - qq <- evalBool (Proxy @q) opts a - pure $ evalBinStrict opts "&&" (&&) pp qq - --- | similar to 'Prelude.||' --- --- >>> pl @(Fst Id || (Snd Id >> Len >> Ge 4)) (False,[11,12,13,14]) --- True --- TrueT --- --- >>> pl @((Not (Fst Id)) || (Snd Id >> Len >> Same 4)) (True,[12,11,12,13,14]) --- False --- FalseT --- -data (||) (p :: k) (q :: k1) -type OR p q = p || q -infixr 2 || - -instance (P p a - , P q a - , PP p a ~ Bool - , PP q a ~ Bool - ) => P (p || q) a where - type PP (p || q) a = Bool - eval _ opts a = do - pp <- evalBool (Proxy @p) opts a - qq <- evalBool (Proxy @q) opts a - pure $ evalBinStrict opts "||" (||) pp qq - --- | implication --- --- >>> pl @(Fst Id ~> (Snd Id >> Len >> Ge 4)) (True,[11,12,13,14]) --- True --- TrueT --- --- >>> pl @(Fst Id ~> (Snd Id >> Len >> Same 4)) (True,[12,11,12,13,14]) --- False --- FalseT --- --- >>> pl @(Fst Id ~> (Snd Id >> Len >> Same 4)) (False,[12,11,12,13,14]) --- True --- TrueT --- --- >>> pl @(Fst Id ~> (Snd Id >> Len >> Ge 4)) (False,[11,12,13,14]) --- True --- TrueT --- -data (~>) (p :: k) (q :: k1) -type Imply p q = p ~> q -infixr 1 ~> - -instance (P p a - , P q a - , PP p a ~ Bool - , PP q a ~ Bool - ) => P (p ~> q) a where - type PP (p ~> q) a = Bool - eval _ opts a = do - pp <- evalBool (Proxy @p) opts a - qq <- evalBool (Proxy @q) opts a - pure $ evalBinStrict opts "~>" imply pp qq - -data OrdP p q -type p === q = OrdP p q -infix 4 === - --- | similar to 'compare' --- --- >>> pl @(Fst Id === Snd Id) (10,9) --- Present GT --- PresentT GT --- --- >>> pl @(14 % 3 === Fst Id %- Snd Id) (-10,7) --- Present GT --- PresentT GT --- --- >>> pl @(Fst Id === Snd Id) (10,11) --- Present LT --- PresentT LT --- --- >>> pl @(Snd Id === (Fst Id >> Snd Id >> Head' Id)) (('x',[10,12,13]),10) --- Present EQ --- PresentT EQ --- --- >>> pl @(Snd Id === Head' (Snd (Fst Id))) (('x',[10,12,13]),10) --- Present EQ --- PresentT EQ --- - -type OrdA' p q = OrdP (Fst Id >> p) (Snd Id >> q) -type OrdA p = OrdA' p p - -instance (Ord (PP p a) - , PP p a ~ PP q a - , P p a - , Show (PP q a) - , P q a - ) => P (OrdP p q) a where - type PP (OrdP p q) a = Ordering - eval _ opts a = do - let msg0 = "OrdP" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = compare p q - in mkNode opts (PresentT d) [msg0 <> " " <> show p <> " " <> prettyOrd d <> show0 opts " " q] [hh pp, hh qq] - --- | compare two strings ignoring case --- --- >>> pl @(Fst Id ===? Snd Id) ("abC","aBc") --- Present EQ --- PresentT EQ --- --- >>> pl @(Fst Id ===? Snd Id) ("abC","DaBc") --- Present LT --- PresentT LT --- -data OrdI p q -type p ===? q = OrdI p q -infix 4 ===? - -instance (PP p a ~ String - , PP p a ~ PP q a - , P p a - , P q a - ) => P (OrdI p q) a where - type PP (OrdI p q) a = Ordering - eval _ opts a = do - let msg0 = "OrdI" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = on compare (map toLower) p q - in mkNode opts (PresentT d) [msg0 <> " " <> p <> " " <> prettyOrd d <> " " <> q] [hh pp, hh qq] - -data Cmp (o :: OrderingP) p q - -instance (GetOrd o - , Ord (PP p a) - , Show (PP p a) - , PP p a ~ PP q a - , P p a - , P q a - ) => P (Cmp o p q) a where - type PP (Cmp o p q) a = Bool - eval _ opts a = do - let (sfn, fn) = getOrd @o - lr <- runPQ sfn (Proxy @p) (Proxy @q) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let b = fn p q - in mkNodeB opts b [show p <> " " <> sfn <> show0 opts " " q] [hh pp, hh qq] - --- for strings -data CmpI (o :: OrderingP) p q - -instance (PP p a ~ String - , GetOrd o - , PP p a ~ PP q a - , P p a - , P q a - ) => P (CmpI o p q) a where - type PP (CmpI o p q) a = Bool - eval _ opts a = do - let (sfn, fn) = getOrd @o - lr <- runPQ sfn (Proxy @p) (Proxy @q) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let b = on fn (map toLower) p q - in mkNodeB opts b ["CmpI " <> p <> " " <> sfn <> " " <> q] [hh pp, hh qq] - -type Gt n = Cmp 'Cgt I n -type Ge n = Cmp 'Cge I n -type Same n = Cmp 'Ceq I n -type Le n = Cmp 'Cle I n -type Lt n = Cmp 'Clt I n -type Ne n = Cmp 'Cne I n - --- | similar to 'Control.Lens.itoList' --- --- >>> pl @(IToList _) ("aBc" :: String) --- Present [(0,'a'),(1,'B'),(2,'c')] --- PresentT [(0,'a'),(1,'B'),(2,'c')] --- -data IToList' t p -type IToList (t :: Type) = IToList' (Hole t) Id - -instance (Show x - , P p x - , Typeable (PP t (PP p x)) - , Show (PP t (PP p x)) - , FoldableWithIndex (PP t (PP p x)) f - , PP p x ~ f a - , Show a - ) => P (IToList' t p) x where - type PP (IToList' t p) x = [(PP t (PP p x), ExtractAFromTA (PP p x))] - eval _ opts x = do - let msg0 = "IToList" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = itoList p - t = showT @(PP t (PP p x)) - in mkNode opts (PresentT b) [msg0 <> "(" <> t <> ")" <> show0 opts " " b <> show1 opts " | " x] [hh pp] - --- | similar to 'toList' --- --- >>> pl @ToList ("aBc" :: String) --- Present "aBc" --- PresentT "aBc" --- --- >>> pl @ToList (Just 14) --- Present [14] --- PresentT [14] --- --- >>> pl @ToList Nothing --- Present [] --- PresentT [] --- --- >>> pl @ToList (Left "xx") --- Present [] --- PresentT [] --- --- >>> pl @ToList (These 12 "xx") --- Present ["xx"] --- PresentT ["xx"] --- -data ToList -instance (Show (t a) - , Foldable t - , Show a - ) => P ToList (t a) where - type PP ToList (t a) = [a] - eval _ opts as = - let msg0 = "ToList" - z = toList as - in pure $ mkNode opts (PresentT z) [show01 opts msg0 z as] [] - --- | similar to 'toList' --- --- >>> pl @(ToList' Id) ("aBc" :: String) --- Present "aBc" --- PresentT "aBc" --- --- >>> pl @(ToList' Id) (Just 14) --- Present [14] --- PresentT [14] --- --- >>> pl @(ToList' Id) Nothing --- Present [] --- PresentT [] --- --- >>> pl @(ToList' Id) (Left "xx") --- Present [] --- PresentT [] --- --- >>> pl @(ToList' Id) (These 12 "xx") --- Present ["xx"] --- PresentT ["xx"] --- -data ToList' p - -instance (PP p x ~ t a - , P p x - , Show (t a) - , Foldable t - , Show a - ) => P (ToList' p) x where - type PP (ToList' p) x = [ExtractAFromTA (PP p x)] -- extra layer of indirection means pe (ToList' Id) "abc" won't work without setting the type of "abc" unlike ToList - eval _ opts x = do - let msg0 = "ToList'" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let b = toList p - in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] - -data ToListExt - -instance (Show l - , Ge.IsList l - , Show (Ge.Item l) - ) => P ToListExt l where - type PP ToListExt l = [Ge.Item l] - eval _ opts as = - let msg0 = "ToListExt" - z = Ge.toList as - in pure $ mkNode opts (PresentT z) [show01 opts msg0 z as] [] - -data FromList (t :: Type) -- doesnt work with OverloadedLists unless you cast to [a] explicitly - -instance (a ~ Ge.Item t - , Show t - , Ge.IsList t - ) => P (FromList t) [a] where - type PP (FromList t) [a] = t - eval _ opts as = - let msg0 = "FromList" - z = Ge.fromList (as :: [Ge.Item t]) :: t - in pure $ mkNode opts (PresentT z) [msg0 <> show0 opts " " z] [] - -data FromListF (t :: Type) -- works only with overloadedlists --- l ~ l' is key -instance (Show l - , Ge.IsList l - , l ~ l' - ) => P (FromListF l') l where - type PP (FromListF l') l = l' - eval _ opts as = - let msg0 = "FromListF" - z = Ge.fromList (Ge.toList @l as) - in pure $ mkNode opts (PresentT z) [msg0 <> show0 opts " " z] [] - --- | predicate on 'These' --- --- >>> pl @(IsThis Id) (This "aBc") --- True --- TrueT --- --- >>> pl @(IsThis Id) (These 1 'a') --- False --- FalseT --- --- >>> pl @(IsThese Id) (These 1 'a') --- True --- TrueT --- -data IsTh (th :: These x y) p -- x y can be anything - -type IsThis p = IsTh ('This '()) p -type IsThat p = IsTh ('That '()) p -type IsThese p = IsTh ('These '() '()) p - --- trying to avoid show instance cos of ambiguities -instance (PP p x ~ These a b - , P p x - , Show a - , Show b - , GetThese th - ) => P (IsTh (th :: These x1 x2) p) x where - type PP (IsTh th p) x = Bool - eval _ opts x = do - let msg0 = "IsTh" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let (t,f) = getThese (Proxy @th) - b = f p - in mkNodeB opts b [msg0 <> " " <> t <> show1 opts " | " p] [] - --- | similar to 'these' --- --- >>> pl @(TheseIn Id Len (Fst Id + Length (Snd Id))) (This 13) --- Present 13 --- PresentT 13 --- --- >>> pl @(TheseIn Id Len (Fst Id + Length (Snd Id))) (That "this is a long string") --- Present 21 --- PresentT 21 --- --- >>> pl @(TheseIn Id Len (Fst Id + Length (Snd Id))) (These 20 "somedata") --- Present 28 --- PresentT 28 --- --- >>> pl @(TheseIn (Left _) (Right _) (If (Fst Id > Length (Snd Id)) (MkLeft _ (Fst Id)) (MkRight _ (Snd Id)))) (That "this is a long string") --- Present Right "this is a long string" --- PresentT (Right "this is a long string") --- --- >>> pl @(TheseIn (Left _) (Right _) (If (Fst Id > Length (Snd Id)) (MkLeft _ (Fst Id)) (MkRight _ (Snd Id)))) (These 1 "this is a long string") --- Present Right "this is a long string" --- PresentT (Right "this is a long string") --- --- >>> pl @(TheseIn (Left _) (Right _) (If (Fst Id > Length (Snd Id)) (MkLeft _ (Fst Id)) (MkRight _ (Snd Id)))) (These 100 "this is a long string") --- Present Left 100 --- PresentT (Left 100) --- -data TheseIn p q r -type Theseid p q = TheseIn '(I, p) '(q, I) I - -instance (Show a - , Show b - , Show (PP p a) - , P p a - , P q b - , P r (a,b) - , PP p a ~ PP q b - , PP p a ~ PP r (a,b) - , PP q b ~ PP r (a,b) - ) => P (TheseIn p q r) (These a b) where - type PP (TheseIn p q r) (These a b) = PP p a - eval _ opts = - \case - This a -> do - let msg0 = "This" - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts (msg0 <> " p failed") pp [] of - Left e -> e - Right c -> mkNode opts (PresentT c) [show01' opts msg0 c "This " a] [hh pp] - That b -> do - let msg0 = "That" - qq <- eval (Proxy @q) opts b - pure $ case getValueLR opts (msg0 <> " q failed") qq [] of - Left e -> e - Right c -> mkNode opts (PresentT c) [show01' opts msg0 c "That " b] [hh qq] - These a b -> do - let msg0 = "TheseIn" - rr <- eval (Proxy @r) opts (a,b) - pure $ case getValueLR opts (msg0 <> " r failed") rr [] of - Left e -> e - Right c -> mkNode opts (PresentT c) [show01 opts msg0 c (These a b)] [hh rr] - --- | creates an empty list of the given type --- --- >>> pl @(Id :+ EmptyList _) 99 --- Present [99] --- PresentT [99] --- -data EmptyList' t -type EmptyList (t :: Type) = EmptyList' (Hole t) - -instance P (EmptyList' t) x where - type PP (EmptyList' t) x = [PP t x] - eval _ opts _ = - pure $ mkNode opts (PresentT []) ["EmptyList"] [] - --- | creates a singleton from a value --- --- >>> pl @(Singleton (Char1 "aBc")) () --- Present "a" --- PresentT "a" --- --- >>> pl @(Singleton Id) False --- Present [False] --- PresentT [False] --- --- >>> pl @(Singleton (Snd Id)) (False,"hello") --- Present ["hello"] --- PresentT ["hello"] --- -type Singleton p = p :+ EmptyT [] p - --- | extracts the first character from a non empty 'Symbol' --- --- >>> pl @(Char1 "aBc") () --- Present 'a' --- PresentT 'a' --- -data Char1 (s :: Symbol) -- gets the first char from the Symbol [requires that Symbol is not empty] -instance (KnownSymbol s, NullT s ~ 'False) => P (Char1 s) a where - type PP (Char1 s) a = Char - eval _ opts _ = - let c = head $ symb @s - in pure $ mkNode opts (PresentT c) ["Char1" <> show0 opts " " c] [] - --- | similar to 'Data.Align.align' thats pads with 'Data.These.This' or 'Data.These.That' if one list is shorter than the other --- --- the key is that all information about both lists are preserved --- --- >>> pl @(ZipThese (Fst Id) (Snd Id)) ("aBc", [1..5]) --- Present [These 'a' 1,These 'B' 2,These 'c' 3,That 4,That 5] --- PresentT [These 'a' 1,These 'B' 2,These 'c' 3,That 4,That 5] --- --- >>> pl @(ZipThese (Fst Id) (Snd Id)) ("aBcDeF", [1..3]) --- Present [These 'a' 1,These 'B' 2,These 'c' 3,This 'D',This 'e',This 'F'] --- PresentT [These 'a' 1,These 'B' 2,These 'c' 3,This 'D',This 'e',This 'F'] --- -data ZipThese p q - -instance (PP p a ~ [x] - , PP q a ~ [y] - , P p a - , P q a - , Show x - , Show y - ) => P (ZipThese p q) a where - type PP (ZipThese p q) a = [These (ArrT (PP p a)) (ArrT (PP q a))] - eval _ opts a = do - let msg0 = "ZipThese" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = simpleAlign p q - in mkNode opts (PresentT d) [show01' opts msg0 d "p=" p <> show1 opts " | q=" q] [hh pp, hh qq] - -simpleAlign :: [a] -> [b] -> [These a b] -simpleAlign as [] = map This as -simpleAlign [] bs = map That bs -simpleAlign (a:as) (b:bs) = These a b : simpleAlign as bs - -type family ExtractAFromTA (ta :: Type) :: Type where - ExtractAFromTA (t a) = a - ExtractAFromTA ta = GL.TypeError ( - 'GL.Text "ExtractAFromTA: expected (t a) but found something else" - ':$$: 'GL.Text "t a = " - ':<>: 'GL.ShowType ta) - --- todo: get ArrT error to fire if wrong Type - --- | Zip two lists optionally cycling the one of the lists to match the size --- --- >>> pl @(Ziplc (Fst Id) (Snd Id)) ("abc", [1..5]) --- Present [('a',1),('b',2),('c',3),('a',4),('b',5)] --- PresentT [('a',1),('b',2),('c',3),('a',4),('b',5)] --- --- >>> pl @(Ziplc (Fst Id) (Snd Id)) ("abcdefg", [1..5]) --- Present [('a',1),('b',2),('c',3),('d',4),('e',5)] --- PresentT [('a',1),('b',2),('c',3),('d',4),('e',5)] --- --- >>> pl @(Ziprc (Fst Id) (Snd Id)) ("abcdefg", [1..5]) --- Present [('a',1),('b',2),('c',3),('d',4),('e',5),('f',1),('g',2)] --- PresentT [('a',1),('b',2),('c',3),('d',4),('e',5),('f',1),('g',2)] --- -data Zip (lc :: Bool) (rc :: Bool) p q -type Ziplc p q = Zip 'True 'False p q -type Ziprc p q = Zip 'False 'True p q -type Zipn p q = Zip 'False 'False p q - -instance (GetBool lc - , GetBool rc - , PP p a ~ [x] - , PP q a ~ [y] - , P p a - , P q a - , Show x - , Show y - ) => P (Zip lc rc p q) a where - type PP (Zip lc rc p q) a = [(ArrT (PP p a), ArrT (PP q a))] - eval _ opts a = do - let msg0 = "Zip" <> cyc - lc = getBool @lc - rc = getBool @rc - cyc = case (lc,rc) of - (True,False) -> "LC" - (False,True) -> "RC" - _ -> "" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = case (lc,rc) of - (True,False) -> zip (take (length q) (cycle p)) q - (False,True) -> zip p (take (length p) (cycle q)) - _ -> zip p q - in mkNode opts (PresentT d) [show01' opts msg0 d "p=" p <> show1 opts " | q=" q] [hh pp, hh qq] - --- | Luhn predicate check on last digit --- --- >>> pl @(Luhn Id) [1,2,3,0] --- True --- TrueT --- --- >>> pl @(Luhn Id) [1,2,3,4] --- False --- FalseT -data Luhn p - -instance (PP p x ~ [Int] - , P p x - ) => P (Luhn p) x where - type PP (Luhn p) x = Bool - eval _ opts x = do - let msg0 = "Luhn" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let xs = zipWith (*) (reverse p) (cycle [1,2]) - ys = map (\w -> if w>=10 then w-9 else w) xs - z = sum ys - ret = z `mod` 10 - hhs = [hh pp] - in if ret == 0 then mkNodeB opts True [msg0 <> show0 opts " | " p] hhs - else mkNodeB opts False [msg0 <> " map=" <> show ys <> " sum=" <> show z <> " ret=" <> show ret <> show1 opts " | " p] hhs - --- could get n::Nat as a predicate but it is fine as is! --- | Read a number base 2 via 36 --- --- >>> pl @(ReadBase Int 16) "00feD" --- Present 4077 --- PresentT 4077 --- --- >>> pl @(ReadBase Int 16) "-ff" --- Present -255 --- PresentT (-255) --- --- >>> pl @(ReadBase Int 2) "10010011" --- Present 147 --- PresentT 147 --- --- supports negative numbers unlike readInt -data ReadBase' t (n :: Nat) p -type ReadBase (t :: Type) (n :: Nat) = ReadBase' (Hole t) n Id -type ReadBaseInt (n :: Nat) = ReadBase' (Hole Int) n Id - - -instance (Typeable (PP t x) - , BetweenT 2 36 n - , Show (PP t x) - , Num (PP t x) - , KnownNat n - , PP p x ~ String - , P p x - ) => P (ReadBase' t n p) x where - type PP (ReadBase' t n p) x = PP t x - eval _ opts x = do - let n = nat @n - xs = getValidBase n - msg0 = "ReadBase(" <> t <> "," <> show n <> ")" - t = showT @(PP t x) - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let (ff,p1) = case p of - '-':q -> (negate,q) - _ -> (id,p) - in case readInt (fromIntegral n) - ((`elem` xs) . toLower) - (fromJust . (`elemIndex` xs) . toLower) - p1 of - [(b,"")] -> mkNode opts (PresentT (ff b)) [msg0 <> show0 opts " " (ff b) <> show1 opts " | " p] [hh pp] - o -> mkNode opts (FailT ("invalid base " <> show n)) [msg0 <> " as=" <> p <> " err=" <> show o] [hh pp] - -getValidBase :: Int -> String -getValidBase n = - let xs = ['0'..'9'] <> ['a'..'z'] - len = length xs - in if n > len || n < 2 then error $ "oops invalid base valid is 2 thru " ++ show len ++ " found " ++ show n - else take n xs - --- | Display a number at base 2 to 36, similar to 'showIntAtBase' but supports signed numbers --- --- >>> pl @(ShowBase 16) 4077 --- Present "fed" --- PresentT "fed" --- --- >>> pl @(ShowBase 16) (-255) --- Present "-ff" --- PresentT "-ff" --- --- >>> pl @(ShowBase 2) 147 --- Present "10010011" --- PresentT "10010011" --- --- >>> pl @(ShowBase' 2 (Negate 147)) "whatever" --- Present "-10010011" --- PresentT "-10010011" --- -data ShowBase' (n :: Nat) p -type ShowBase (n :: Nat) = ShowBase' n Id - -instance (PP p x ~ a - , P p x - , Show a - , 2 GL.<= n - , n GL.<= 36 - , KnownNat n - , Integral a - ) => P (ShowBase' n p) x where - type PP (ShowBase' n p) x = String - eval _ opts x = do - let n = nat @n - xs = getValidBase n - msg0 = "ShowBase " <> show n - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let (ff,a') = if p < 0 then (('-':), abs p) else (id,p) - b = showIntAtBase (fromIntegral n) (xs !!) a' "" - in mkNode opts (PresentT (ff b)) [msg0 <> showLit0 opts " " (ff b) <> show1 opts " | " p] [] - --- use Assoc and Unassoc ---type AssocL = '(I *** Fst I, Snd I >> Snd I) ---type AssocR = '(Fst I >> Fst I, Snd I *** I) - --- | Intercalate --- --- >>> pl @(Intercalate '["aB"] '["xxxx","yz","z","www","xyz"]) () --- Present ["xxxx","aB","yz","aB","z","aB","www","aB","xyz"] --- PresentT ["xxxx","aB","yz","aB","z","aB","www","aB","xyz"] --- -data Intercalate p q - -instance (PP p x ~ [a] - , PP q x ~ PP p x - , P p x - , P q x - , Show a - ) => P (Intercalate p q) x where - type PP (Intercalate p q) x = PP p x - eval _ opts x = do - let msg0 = "Intercalate" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = intercalate p (map (:[]) q) - in mkNode opts (PresentT d) [show01 opts msg0 d p <> show1 opts " | " q] [hh pp, hh qq] - -getStringPrefix :: String -> (String,String) -getStringPrefix = fix (\k z -> \case - [] -> (z,[]) - '%':x:xs | x == '%' -> k (z <> ['%']) xs - | otherwise -> (z,'%':x:xs) - x:xs -> k (z <> [x]) xs - ) [] - --- | uses Printf to format output --- --- >>> pl @(Printf "value=%03d" Id) 12 --- Present "value=012" --- PresentT "value=012" --- --- splits string into pieces before "%" that way we have a chance of catching any errors -data Printf s p - -instance (PrintfArg (PP p x) - , Show (PP p x) - , PP s x ~ String - , P s x - , P p x - ) => P (Printf s p) x where - type PP (Printf s p) x = String - eval _ opts x = do - let msg0 = "Printf" - lrx <- runPQ msg0 (Proxy @s) (Proxy @p) opts x - case lrx of - Left e -> pure e - Right (s,p,ss,pp) -> do - let msg1 = msg0 - lr <- catchitNF @_ @E.SomeException (printf s p) - pure $ case lr of - Left e -> mkNode opts (FailT (msg1 <> " (" <> e <> ")")) [msg1 <> show0 opts " " p <> " s=" <> s] [hh ss, hh pp] - Right ret -> mkNode opts (PresentT ret) [msg1 <> " [" <> showLit0 opts "" ret <> "]" <> show1 opts " | p=" p <> showLit1 opts " | s=" s] [hh ss, hh pp] - -type family GuardsT (ps :: [k]) where - GuardsT '[] = '[] - GuardsT (p ': ps) = Guard' p ': GuardsT ps - -type Guards' (ps :: [k]) = Para (GuardsT ps) - -type ToPara (os :: [k]) = Proxy (ParaImplW 'True os) - -type ToGuards (prt :: k) (os :: [k1]) = Proxy (Guards (ToGuardsT prt os)) - -type family ToGuardsT (prt :: k) (os :: [k1]) :: [(k,k1)] where --- ToGuardsT prt '[] = '[] -- error condition - ToGuardsT prt '[p] = '(prt,p) : '[] - ToGuardsT prt (p ': ps) = '(prt,p) ': ToGuardsT prt ps - --- | runs values in parallel unlike 'Do' --- --- >>> pl @(Para '[Id,Id + 1,Id * 4]) [10,20,30] --- Present [10,21,120] --- PresentT [10,21,120] --- -data ParaImpl (n :: Nat) (strict :: Bool) (os :: [k]) -type Para (os :: [k]) = ParaImplW 'True os -type ParaLax (os :: [k]) = ParaImplW 'False os - -data ParaImplW (strict :: Bool) (ps :: [k]) - -type family GuardsViaParaT prt ps where - GuardsViaParaT prt '[] = '[] - GuardsViaParaT prt (p ': ps) = Guard prt p ': GuardsViaParaT prt ps - -type GuardsViaPara prt ps = Para (GuardsViaParaT prt ps) - --- passthru but adds the length of ps (replaces LenT in the type synonym to avoid type synonyms being expanded out -instance (GetBool strict, GetLen ps, P (ParaImpl (LenT ps) strict ps) [a]) => P (ParaImplW strict ps) [a] where - type PP (ParaImplW strict ps) [a] = PP (ParaImpl (LenT ps) strict ps) [a] - eval _ opts as = do - let strict = getBool @strict - msgbase0 = "Para" <> strictmsg @strict - n = getLen @ps - if strict && n /= length as then - let xx = msgbase0 <> ": data elements(" <> show (length as) <> ") /= predicates(" <> show n <> ")" - in pure $ mkNode opts (FailT xx) [xx] [] - else eval (Proxy @(ParaImpl (LenT ps) strict ps)) opts as - --- only allow non empty lists! -instance GL.TypeError ('GL.Text "ParaImpl '[] invalid: requires at least one value in the list") - => P (ParaImpl n strict ('[] :: [k])) [a] where - type PP (ParaImpl n strict ('[] :: [k])) [a] = Void - eval _ _ _ = error "should not get this far" - --- forall k (p :: k) (n :: Nat) (strict :: Bool) a . -instance (Show (PP p a) - , KnownNat n - , GetBool strict - , Show a - , P p a - ) => P (ParaImpl n strict '[p]) [a] where - type PP (ParaImpl n strict '[p]) [a] = [PP p a] - eval _ opts as' = do - let strict = getBool @strict - msgbase0 = "Para" <> strictmsg @strict - msgbase1 = msgbase0 <> "(" <> show n <> ")" - n :: Int - n = nat @n - case as' of - [] -> pure $ mkNode opts mempty [msgbase1 <> " (ran out of data!!)"] [] - a:as -> do - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts msgbase1 pp [] of - Left e -> e - -- show1 opts " " [b] fails but using 'b' is ok and (b : []) also works! - -- Ge.List error - Right b -> mkNode opts (PresentT [b]) [msgbase1 <> (if null as then " done!" else " Truncated") <> show0 opts " " (b : []) <> show1 opts " | " a <> (if strict then "" else show1 opts " | leftovers=" as)] [hh pp] - -instance (KnownNat n - , GetBool strict - , GetLen ps - , P p a - , P (ParaImpl n strict (p1 ': ps)) [a] - , PP (ParaImpl n strict (p1 ': ps)) [a] ~ [PP p a] - , Show a - , Show (PP p a) - ) - => P (ParaImpl n strict (p ': p1 ': ps)) [a] where - type PP (ParaImpl n strict (p ': p1 ': ps)) [a] = [PP p a] - eval _ opts as' = do - let msgbase0 = msgbase2 <> "(" <> show (n-pos) <> " of " <> show n <> ")" - msgbase1 = msgbase2 <> "(" <> show (n-pos) <> ")" - msgbase2 = "Para" <> strictmsg @strict - n = nat @n - pos = 1 + getLen @ps -- cos p1! - case as' of - [] -> pure $ mkNode opts mempty [msgbase0 <> " (ran out of data!!)"] [] - a:as -> do - pp <- eval (Proxy @p) opts a - case getValueLR opts msgbase0 pp [] of - Left e -> pure e - Right b -> do - qq <- eval (Proxy @(ParaImpl n strict (p1 ': ps))) opts as - pure $ case getValueLRHide opts (msgbase1 <> " rhs failed " <> show b) qq [hh pp] of - Left e -> e - Right bs -> mkNode opts (PresentT (b:bs)) [msgbase1 <> show0 opts " " (b:bs) <> show1 opts " | " as'] [hh pp, hh qq] - --- | tries each predicate ps and on the first match runs the corresponding qs but if there is no match on ps then runs the fail case e --- --- >>> pl @(Case (FailS "asdf" >> Snd Id >> Unproxy ) '[Lt 4,Lt 10,Same 50] '[Printf "%d is lt4" Id, Printf "%d is lt10" Id, Printf "%d is same50" Id] Id) 50 --- Present "50 is same50" --- PresentT "50 is same50" --- --- >>> pl @(Case (FailS "asdf" >> Snd Id >> Unproxy ) '[Lt 4,Lt 10,Same 50] '[Printf "%d is lt4" Id, Printf "%d is lt10" Id, Printf "%d is same50" Id] Id) 9 --- Present "9 is lt10" --- PresentT "9 is lt10" --- --- >>> pl @(Case (FailS "asdf" >> Snd Id >> Unproxy ) '[Lt 4,Lt 10,Same 50] '[Printf "%d is lt4" Id, Printf "%d is lt10" Id, Printf "%d is same50" Id] Id) 3 --- Present "3 is lt4" --- PresentT "3 is lt4" --- --- >>> pl @(Case (FailS "asdf" >> Snd Id >> Unproxy ) '[Lt 4,Lt 10,Same 50] '[Printf "%d is lt4" Id, Printf "%d is lt10" Id, Printf "%d is same50" Id] Id) 99 --- Error asdf --- FailT "asdf" --- -data CaseImpl (n :: Nat) (e :: k0) (ps :: [k]) (qs :: [k1]) (r :: k2) --- ps = conditions --- qs = what to do [one to one --- r = the value --- e = otherwise -- leave til later -data Case (e :: k0) (ps :: [k]) (qs :: [k1]) (r :: k2) -type Case' (ps :: [k]) (qs :: [k1]) (r :: k2) = Case (Snd Id >> Failp "Case:no match") ps qs r -type Case'' s (ps :: [k]) (qs :: [k1]) (r :: k2) = Case (FailCase s) ps qs r -- eg s= Printf "%s" (ShowP Id) - -type FailCase p = Fail (Snd Id >> Unproxy) (Fst Id >> p) - - --- passthru but adds the length of ps (replaces LenT in the type synonym to avoid type synonyms being expanded out -instance (FailIfT (NotT (LenT ps DE.== LenT qs)) - ('GL.Text "lengths are not the same " - ':<>: 'GL.ShowType (LenT ps) - ':<>: 'GL.Text " vs " - ':<>: 'GL.ShowType (LenT qs)) - , P (CaseImpl (LenT ps) e ps qs r) x - ) => P (Case e ps qs r) x where - type PP (Case e ps qs r) x = PP (CaseImpl (LenT ps) e ps qs r) x - eval _ = eval (Proxy @(CaseImpl (LenT ps) e ps qs r)) - --- only allow non empty lists! -instance (GL.TypeError ('GL.Text "CaseImpl '[] invalid: lhs requires at least one value in the list")) - => P (CaseImpl n e ('[] :: [k]) (q ': qs) r) x where - type PP (CaseImpl n e ('[] :: [k]) (q ': qs) r) x = Void - eval _ _ _ = error "should not get this far" - -instance (GL.TypeError ('GL.Text "CaseImpl '[] invalid: rhs requires at least one value in the list")) - => P (CaseImpl n e (p ': ps) ('[] :: [k1]) r) x where - type PP (CaseImpl n e (p ': ps) ('[] :: [k1]) r) x = Void - eval _ _ _ = error "should not get this far" - -instance (GL.TypeError ('GL.Text "CaseImpl '[] invalid: lists are both empty")) - => P (CaseImpl n e ('[] :: [k]) ('[] :: [k1]) r) x where - type PP (CaseImpl n e ('[] :: [k]) ('[] :: [k1]) r) x = Void - eval _ _ _ = error "should not get this far" - -instance (P r x - , P q (PP r x) - , Show (PP q (PP r x)) - , P p (PP r x) - , PP p (PP r x) ~ Bool - , KnownNat n - , Show (PP r x) - , P e (PP r x, Proxy (PP q (PP r x))) - , PP e (PP r x, Proxy (PP q (PP r x))) ~ PP q (PP r x) - ) => P (CaseImpl n e '[p] '[q] r) x where - type PP (CaseImpl n e '[p] '[q] r) x = PP q (PP r x) - eval _ opts z = do - let msgbase0 = "Case" <> "(" <> show n <> ")" - n :: Int = nat @n - rr <- eval (Proxy @r) opts z - case getValueLR opts msgbase0 rr [] of - Left e -> pure e - Right a -> do - pp <- evalBool (Proxy @p) opts a - case getValueLR opts msgbase0 pp [hh rr] of - Left e -> pure e - Right True -> do - qq <- eval (Proxy @q) opts a - pure $ case getValueLR opts msgbase0 qq [hh rr, hh pp] of - Left e -> e - Right b -> mkNode opts (PresentT b) [show01 opts msgbase0 b a] [hh rr, hh pp, hh qq] - Right False -> do - ee <- eval (Proxy @e) opts (a, Proxy @(PP q (PP r x))) - pure $ case getValueLR opts (msgbase0 <> " otherwise failed") ee [hh rr, hh pp] of - Left e -> e - Right b -> mkNode opts (PresentT b) [show01 opts msgbase0 b a] [hh rr, hh pp, hh ee] - -instance (KnownNat n - , GetLen ps - , P r x - , P p (PP r x) - , P q (PP r x) - , PP p (PP r x) ~ Bool - , Show (PP q (PP r x)) - , Show (PP r x) - , P (CaseImpl n e (p1 ': ps) (q1 ': qs) r) x - , PP (CaseImpl n e (p1 ': ps) (q1 ': qs) r) x ~ PP q (PP r x) - ) - => P (CaseImpl n e (p ': p1 ': ps) (q ': q1 ': qs) r) x where - type PP (CaseImpl n e (p ': p1 ': ps) (q ': q1 ': qs) r) x = PP q (PP r x) - eval _ opts z = do - let msgbase0 = msgbase2 <> "(" <> show (n-pos) <> " of " <> show n <> ")" - msgbase1 = msgbase2 <> "(" <> show (n-pos) <> ")" - msgbase2 = "Case" - n = nat @n - pos = 1 + getLen @ps -- cos p1! - rr <- eval (Proxy @r) opts z - case getValueLR opts msgbase0 rr [] of - Left e -> pure e - Right a -> do - pp <- evalBool (Proxy @p) opts a - case getValueLR opts msgbase0 pp [hh rr] of - Left e -> pure e - Right True -> do - qq <- eval (Proxy @q) opts a - pure $ case getValueLR opts msgbase0 qq [hh rr] of - Left e -> e - Right b -> mkNode opts (PresentT b) [show01 opts msgbase0 b a] [hh rr, hh pp, hh qq] - Right False -> do - ww <- eval (Proxy @(CaseImpl n e (p1 ': ps) (q1 ': qs) r)) opts z - pure $ case getValueLR opts (msgbase1 <> " failed rhs") ww [hh rr, hh pp] of - Left e -> e - Right b -> mkNode opts (PresentT b) [show01 opts msgbase1 b a] [hh rr, hh pp, hh ww] - --- | similar to 'sequenceA' --- --- >>> pl @Sequence [Just 10, Just 20, Just 30] --- Present Just [10,20,30] --- PresentT (Just [10,20,30]) --- --- >>> pl @Sequence [Just 10, Just 20, Just 30, Nothing, Just 40] --- Present Nothing --- PresentT Nothing --- -data Sequence -type Traverse p q = Map p q >> Sequence - - -instance (Show (f (t a)) - , Show (t (f a)) - , Traversable t - , Applicative f - ) => P Sequence (t (f a)) where - type PP Sequence (t (f a)) = f (t a) - eval _ opts tfa = - let d = sequenceA tfa - in pure $ mkNode opts (PresentT d) ["Sequence" <> show0 opts " " d <> show1 opts " | " tfa] [] - -data Hide p -type H = Hide --- type H p = Hide p -- doesnt work with % -- unsaturated! - -instance P p x => P (Hide p) x where - type PP (Hide p) x = PP p x - eval _ opts x = do - tt <- eval (Proxy @(Msg "!" p)) opts x - pure $ tt & tForest .~ [] - --- | similar to 'readFile' --- --- >>> pl @(ReadFile ".ghci" >> 'Just Id >> Len >> Gt 0) () --- True --- TrueT --- --- >>> pl @(FileExists "xyzzy") () --- False --- FalseT --- -data ReadFile p -type FileExists p = ReadFile p >> IsJust - -instance (PP p x ~ String, P p x) => P (ReadFile p) x where - type PP (ReadFile p) x = Maybe String - eval _ opts x = do - let msg0 = "ReadFile" - pp <- eval (Proxy @p) opts x - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right p -> do - let msg1 = msg0 <> "[" <> p <> "]" - mb <- runIO $ do - b <- doesFileExist p - if b then Just <$> readFile p - else pure Nothing - pure $ case mb of - Nothing -> mkNode opts (FailT (msg1 <> " must run in IO")) [msg1 <> " must run in IO"] [] - Just Nothing -> mkNode opts (PresentT Nothing) [msg1 <> " does not exist"] [] - Just (Just b) -> mkNode opts (PresentT (Just b)) [msg1 <> " len=" <> show (length b) <> showLit0 opts " Just " b] [] - --- | does the directory exists --- --- >>> pl @(DirExists ".") () --- True --- TrueT --- -data ReadDir p -type DirExists p = ReadDir p >> IsJust - -instance (PP p x ~ String, P p x) => P (ReadDir p) x where - type PP (ReadDir p) x = Maybe [FilePath] - eval _ opts x = do - let msg0 = "ReadDir" - pp <- eval (Proxy @p) opts x - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right p -> do - let msg1 = msg0 <> "[" <> p <> "]" - mb <- runIO $ do - b <- doesDirectoryExist p - if b then Just <$> listDirectory p - else pure Nothing - pure $ case mb of - Nothing -> mkNode opts (FailT (msg1 <> " must run in IO")) [msg1 <> " must run in IO"] [] - Just Nothing -> mkNode opts (PresentT Nothing) [msg1 <> " does not exist"] [] - Just (Just b) -> mkNode opts (PresentT (Just b)) [msg1 <> " len=" <> show (length b) <> show0 opts " Just " b] [] - --- | does the directory exists --- --- >>> pl @(DirExists ".") () --- True --- TrueT --- -data ReadEnv p - -instance (PP p x ~ String, P p x) => P (ReadEnv p) x where - type PP (ReadEnv p) x = Maybe String - eval _ opts x = do - let msg0 = "ReadEnv" - pp <- eval (Proxy @p) opts x - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right p -> do - let msg1 = msg0 <> "[" <> p <> "]" - mb <- runIO $ lookupEnv p - pure $ case mb of - Nothing -> mkNode opts (FailT (msg1 <> " must run in IO")) [msg1 <> " must run in IO"] [] - Just Nothing -> mkNode opts (PresentT Nothing) [msg1 <> " does not exist"] [] - Just (Just v) -> mkNode opts (PresentT (Just v)) [msg1 <> showLit0 opts " " v] [] - -data ReadEnvAll - -instance P ReadEnvAll a where - type PP ReadEnvAll a = [(String,String)] - eval _ opts _ = do - let msg0 = "ReadEnvAll" - mb <- runIO $ getEnvironment - pure $ case mb of - Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) [msg0 <> " must run in IO"] [] - Just v -> mkNode opts (PresentT v) [msg0 <> " count=" <> show (length v)] [] - -data TimeU - -instance P TimeU a where - type PP TimeU a = UTCTime - eval _ opts _a = do - let msg0 = "TimeU" - mb <- runIO $ getCurrentTime - pure $ case mb of - Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) [msg0 <> " must run in IO"] [] - Just v -> mkNode opts (PresentT v) [msg0 <> show0 opts " " v] [] - -data TimeZ - -instance P TimeZ a where - type PP TimeZ a = ZonedTime - eval _ opts _a = do - let msg0 = "TimeZ" - mb <- runIO $ getZonedTime - pure $ case mb of - Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) [msg0 <> " must run in IO"] [] - Just v -> mkNode opts (PresentT v) [msg0 <> show0 opts " " v] [] - -data FHandle s = FStdout | FStderr | FOther s WFMode deriving Show - -class GetFHandle (x :: FHandle Symbol) where getFHandle :: FHandle String -instance GetFHandle 'FStdout where getFHandle = FStdout -instance GetFHandle 'FStderr where getFHandle = FStderr -instance (GetMode w, KnownSymbol s) => GetFHandle ('FOther s w) where getFHandle = FOther (symb @s) (getMode @w) - -data WFMode = WFAppend | WFWrite | WFWriteForce deriving (Show,Eq) - -class GetMode (x :: WFMode) where getMode :: WFMode -instance GetMode 'WFAppend where getMode = WFAppend -instance GetMode 'WFWriteForce where getMode = WFWriteForce -instance GetMode 'WFWrite where getMode = WFWrite - -data WritefileImpl (hh :: FHandle Symbol) p -type Appendfile (s :: Symbol) p = WritefileImpl ('FOther s 'WFAppend) p -type Writefile' (s :: Symbol) p = WritefileImpl ('FOther s 'WFWriteForce) p -type Writefile (s :: Symbol) p = WritefileImpl ('FOther s 'WFWrite) p -type Stdout p = WritefileImpl 'FStdout p -type Stderr p = WritefileImpl 'FStderr p - -instance (GetFHandle fh - , P p a - , PP p a ~ String - ) => P (WritefileImpl fh p) a where - type PP (WritefileImpl fh p) a = () - eval _ opts a = do - let fh = getFHandle @fh - msg0 = case fh of - FStdout -> "Stdout" - FStderr -> "Stderr" - FOther s w -> (<>("[" <> s <> "]")) $ case w of - WFAppend -> "Appendfile" - WFWrite -> "Writefile" - WFWriteForce -> "Writefile'" - pp <- eval (Proxy @p) opts a - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right ss -> do - mb <- runIO $ do - case fh of - FStdout -> fmap (left show) $ E.try @E.SomeException $ hPutStr stdout ss - FStderr -> fmap (left show) $ E.try @E.SomeException $ hPutStr stderr ss - FOther s w -> do - b <- doesFileExist s - if b && w == WFWrite then pure $ Left $ "file [" <> s <> "] already exists" - else do - let md = case w of - WFAppend -> AppendMode - _ -> WriteMode - fmap (left show) $ E.try @E.SomeException $ withFile s md (flip hPutStr ss) - pure $ case mb of - Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) [msg0 <> " must run in IO"] [hh pp] - Just (Left e) -> mkNode opts (FailT e) [msg0 <> " " <> e] [hh pp] - Just (Right ()) -> mkNode opts (PresentT ()) [msg0] [hh pp] - -data Stdin - -instance P Stdin a where - type PP Stdin a = String - eval _ opts _a = do - let msg0 = "Stdin" - mb <- runIO $ do - lr <- E.try $ hGetContents stdin - pure $ case lr of - Left (e :: E.SomeException) -> Left $ show e - Right ss -> Right ss - pure $ case mb of - Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) [msg0 <> " must run in IO"] [] - Just (Left e) -> mkNode opts (FailT e) [msg0 <> " " <> e] [] - Just (Right ss) -> mkNode opts (PresentT ss) [msg0 <> "[" <> showLit1 opts "" ss <> "]"] [] - ---type Just' = JustFail "expected Just" Id -type Nothing' = Guard "expected Nothing" IsNothing - --- | 'isInfixOf' 'isPrefixOf' 'isSuffixOf' equivalents --- --- >>> pl @(IsInfixI "abc" "axAbCd") () --- True --- TrueT --- --- >>> pl @(IsPrefixI "abc" "aBcbCd") () --- True --- TrueT --- --- >>> pl @(IsPrefix "abc" "aBcbCd") () --- False --- FalseT --- --- >>> pl @(IsSuffix "bCd" "aBcbCd") () --- True --- TrueT --- --- prefix infix suffix for strings -data IsFixImpl (cmp :: Ordering) (ignore :: Bool) p q - -type IsPrefix p q = IsFixImpl 'LT 'False p q -type IsInfix p q = IsFixImpl 'EQ 'False p q -type IsSuffix p q = IsFixImpl 'GT 'False p q - -type IsPrefixI p q = IsFixImpl 'LT 'True p q -type IsInfixI p q = IsFixImpl 'EQ 'True p q -type IsSuffixI p q = IsFixImpl 'GT 'True p q - -instance (GetBool ignore - , P p x - , P q x - , PP p x ~ String - , PP q x ~ String - , GetOrdering cmp - ) => P (IsFixImpl cmp ignore p q) x where - type PP (IsFixImpl cmp ignore p q) x = Bool - eval _ opts x = do - let cmp = getOrdering @cmp - ignore = getBool @ignore - lwr = if ignore then map toLower else id - (ff,msg0) = case cmp of - LT -> (isPrefixOf, "IsPrefix") - EQ -> (isInfixOf, "IsInfix") - GT -> (isSuffixOf, "IsSuffix") - pp <- eval (Proxy @p) opts x - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right s0 -> do - let msg1 = msg0 <> (if ignore then "I" else "") <> "(" <> s0 <> ")" - qq <- eval (Proxy @q) opts x - pure $ case getValueLR opts (msg1 <> " q failed") qq [hh pp] of - Left e -> e - Right s1 -> mkNodeB opts (on ff lwr s0 s1) [msg1 <> showLit0 opts " " s1] [hh pp, hh qq] - --- | similar to 'SG.<>' --- --- >>> pl @(Fst Id <> Snd Id) ("abc","def") --- Present "abcdef" --- PresentT "abcdef" --- --- >>> pl @("abcd" <> "ef" <> Id) "ghi" --- Present "abcdefghi" --- PresentT "abcdefghi" --- -data p <> q -infixr 6 <> -type Sapa' (t :: Type) = Wrap t (Fst Id) <> Wrap t (Snd Id) -type Sapa = Fst Id <> Snd Id - -instance (Semigroup (PP p x) - , PP p x ~ PP q x - , P p x - , Show (PP q x) - ,P q x - ) => P (p <> q) x where - type PP (p <> q) x = PP p x - eval _ opts x = do - let msg0 = "<>" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = p <> q - in mkNode opts (PresentT d) [show p <> " <> " <> show q <> " = " <> show d] [hh pp, hh qq] - - --- have to reverse the inductive tuples cos cant figure out how to reverse generically --- uses inductive tuples to replace variable args -class PrintC x where - prtC :: (PrintfArg a, PrintfType r) => String -> (a,x) -> r -instance PrintC () where - prtC s (a,()) = printf s a -instance (PrintfArg a, PrintC rs) => PrintC (a,rs) where - prtC s (a,rs) = prtC s rs a - -data TupleListImpl (strict :: Bool) (n :: Nat) -type TupleList (n :: Nat) = TupleListImpl 'True n -type TupleListLax (n :: Nat) = TupleListImpl 'False n - -instance (Show a - , KnownNat n - , GetBool strict - , TupleListD (ToN n) a - , Show (TupleListT (ToN n) a) - ) => P (TupleListImpl strict n) [a] where - type PP (TupleListImpl strict n) [a] = TupleListT (ToN n) a - eval _ opts as = do - let strict = getBool @strict - n :: Int - n = nat @n - msg0 = "TupleList" <> (if strict then "" else "Lax") <> "(" <> show n <> ")" - pure $ case tupleListD @(ToN n) @a strict as of - Left e -> mkNode opts (FailT (msg0 <> " " <> e)) [msg0 <> " " <> e] [] - Right ret -> mkNode opts (PresentT ret) [show01 opts msg0 ret as] [] - --- | reverses inductive tuples --- --- >>> pl @ReverseTupleN (1,('a',(True,("def",())))) --- Present ("def",(True,('a',(1,())))) --- PresentT ("def",(True,('a',(1,())))) --- --- >>> pl @ReverseTupleN (1,('a',())) --- Present ('a',(1,())) --- PresentT ('a',(1,())) --- --- >>> pl @ReverseTupleN (999,()) --- Present (999,()) --- PresentT (999,()) --- -data ReverseTupleN - -instance (ReverseTupleC tp - , Show (ReverseTupleP tp) - , Show tp - ) => P ReverseTupleN tp where - type PP ReverseTupleN tp = ReverseTupleP tp - eval _ opts tp = - let ret = reverseTupleC tp - in pure $ mkNode opts (PresentT ret) ["ReverseTupleN" <> show0 opts " " ret <> show1 opts " | " tp] [] - --- | Printfn prints an inductive tuple --- --- >>> pl @(Printfn "%s %s" Id) ("123",("def",())) --- Present "123 def" --- PresentT "123 def" --- --- >>> pl @(Printfn "s=%s d=%03d" Id) ("ab",(123,())) --- Present "s=ab d=123" --- PresentT "s=ab d=123" --- -data Printfn s p -type Printfnt (n :: Nat) s = Printfn s (TupleList n) -type PrintfntLax (n :: Nat) s = Printfn s (TupleListLax n) - --- | print a 2-tuple --- --- >>> pl @(Printf2 "fst=%s snd=%03d") ("ab",123) --- Present "fst=ab snd=123" --- PresentT "fst=ab snd=123" --- -type Printf2 (s :: Symbol) = Printfn s '(Fst Id,'(Snd Id, '())) --- | print a 3-tuple --- --- >>> pl @(Printf3 "fst=%s snd=%03d thd=%s") ("ab",123,"xx") --- Present "fst=ab snd=123 thd=xx" --- PresentT "fst=ab snd=123 thd=xx" --- -type Printf3 (s :: Symbol) = Printfn s '(Fst Id, '(Snd Id, '(Thd Id, '()))) -type Printf3' (s :: Symbol) = Printfn s (TupleI '[Fst Id, Snd Id, Thd Id]) - - -instance (KnownNat (TupleLenT as) - , PrintC bs - , (b,bs) ~ ReverseTupleP (a,as) - , ReverseTupleC (a,as) - , Show a - , Show as - , PrintfArg b - , PP s x ~ String - , PP p x ~ (a,as) - , P s x - , P p x - , CheckT (PP p x) ~ 'True - ) => P (Printfn s p) x where - type PP (Printfn s p) x = String - eval _ opts x = do - let msg0 = "Printfn" - lrx <- runPQ msg0 (Proxy @s) (Proxy @p) opts x - case lrx of - Left e -> pure e - Right (s,(a,as),ss,pp) -> do - let len :: Int = 1 + nat @(TupleLenT as) - msg1 = msg0 <> "(" <> show len <> ")" - hhs = [hh ss, hh pp] - lr <- catchitNF @_ @E.SomeException (prtC @bs s (reverseTupleC (a,as))) - pure $ case lr of - Left e -> mkNode opts (FailT (msg1 <> "(" <> e <> ")")) [msg1 <> show0 opts " " a <> " s=" <> s] hhs - Right ret -> mkNode opts (PresentT ret) [msg1 <> " [" <> showLit0 opts "" ret <> "]" <> show1 opts " | (a,as)=" (a,as) <> showLit0 opts " | s=" s] hhs - -type family CheckT (tp :: Type) :: Bool where - CheckT () = GL.TypeError ('GL.Text "Printfn: inductive tuple cannot be empty") - CheckT o = 'True - -type family ApplyConstT (ta :: Type) (b :: Type) :: Type where ---type family ApplyConstT ta b where -- less restrictive so allows ('Just Int) Bool through! - ApplyConstT (t a) b = t b - ApplyConstT ta b = GL.TypeError ( - 'GL.Text "ApplyConstT: (t a) b but found something else" - ':$$: 'GL.Text "t a = " - ':<>: 'GL.ShowType ta - ':$$: 'GL.Text "b = " - ':<>: 'GL.ShowType b) - --- | similar to 'Control.Applicative.<$' --- --- >>> pl @(Fst Id <$ Snd Id) ("abc",Just 20) --- Present Just "abc" --- PresentT (Just "abc") --- -data p <$ q -infixl 4 <$ - -instance (P p x - , P q x - , Show (PP p x) - , Functor t - , PP q x ~ t c - , ApplyConstT (PP q x) (PP p x) ~ t (PP p x) - ) => P (p <$ q) x where - type PP (p <$ q) x = ApplyConstT (PP q x) (PP p x) - eval _ opts x = do - let msg0 = "(<$)" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = p <$ q - in mkNode opts (PresentT d) [msg0 <> show0 opts " " p] [hh pp, hh qq] - -data p <* q -infixl 4 <* - --- | similar to 'Control.Applicative.<*' --- --- >>> pl @(Fst Id <* Snd Id) (Just "abc",Just 20) --- Present Just "abc" --- PresentT (Just "abc") --- -type p *> q = q <* p -infixl 4 *> - -instance (Show (t c) - , P p x - , P q x - , Show (t b) - , Applicative t - , t b ~ PP p x - , PP q x ~ t c - ) => P (p <* q) x where - type PP (p <* q) x = PP p x - eval _ opts x = do - let msg0 = "(<*)" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = p <* q - in mkNode opts (PresentT d) [show01' opts msg0 p "p=" p <> show1 opts " | q=" q] [hh pp, hh qq] - --- | similar to 'Control.Applicative.<|>' --- --- >>> pl @(Fst Id <|> Snd Id) (Nothing,Just 20) --- Present Just 20 --- PresentT (Just 20) --- --- >>> pl @(Fst Id <|> Snd Id) (Just 10,Just 20) --- Present Just 10 --- PresentT (Just 10) --- --- >>> pl @(Fst Id <|> Snd Id) (Nothing,Nothing) --- Present Nothing --- PresentT Nothing --- -data p <|> q -infixl 3 <|> - -instance (P p x - , P q x - , Show (t b) - , Alternative t - , t b ~ PP p x - , PP q x ~ t b - ) => P (p <|> q) x where - type PP (p <|> q) x = PP p x - eval _ opts x = do - let msg0 = "(<|>)" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = p <|> q - in mkNode opts (PresentT d) [show01' opts msg0 d "p=" p <> show1 opts " | q=" q] [hh pp, hh qq] - - --- | similar to 'Control.Comonad.extract' --- --- >>> pl @Extract (Nothing,Just 20) --- Present Just 20 --- PresentT (Just 20) --- --- >>> pl @Extract (Identity 20) --- Present 20 --- PresentT 20 --- -data Extract -instance (Show (t a) - , Show a - , Comonad t - ) => P Extract (t a) where - type PP Extract (t a) = a - eval _ opts ta = - let msg0 = "Extract" - d = extract ta - in pure $ mkNode opts (PresentT d) [show01 opts msg0 d ta] [] - --- | similar to 'Control.Comonad.duplicate' --- --- >>> pl @Duplicate (20,"abc") --- Present (20,(20,"abc")) --- PresentT (20,(20,"abc")) --- -data Duplicate - -instance (Show (t a) - , Show (t (t a)) - , Comonad t - ) => P Duplicate (t a) where - type PP Duplicate (t a) = t (t a) - eval _ opts ta = - let msg0 = "Duplicate" - d = duplicate ta - in pure $ mkNode opts (PresentT d) [show01 opts msg0 d ta] [] - --- | similar to 'Control.Monad.join' --- --- >>> pl @Join (Just (Just 20)) --- Present Just 20 --- PresentT (Just 20) --- --- >>> pl @Join ["ab","cd","","ef"] --- Present "abcdef" --- PresentT "abcdef" --- -data Join - -instance (Show (t (t a)) - , Show (t a) - , Monad t - ) => P Join (t (t a)) where - type PP Join (t (t a)) = t a - eval _ opts tta = - let msg0 = "Join" - d = join tta - in pure $ mkNode opts (PresentT d) [show01 opts msg0 d tta] [] - --- same as $ but shows 'a' and 'b' -data p $ q -infixl 0 $ - -instance (P p x - , P q x - , PP p x ~ (a -> b) - , FnT (PP p x) ~ b - , PP q x ~ a - , Show a - , Show b - ) => P (p $ q) x where - type PP (p $ q) x = FnT (PP p x) - eval _ opts x = do - let msg0 = "($)" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = p q - in mkNode opts (PresentT d) ["fn $ " <> show q <> " = " <> show d] [hh pp, hh qq] - --- reify this so we can combine (type synonyms dont work as well) -data q & p -- flips the args eg a & b & (,) = (b,a) -infixr 1 & - -instance (P p x - , P q x - , PP p x ~ (a -> b) - , FnT (PP p x) ~ b - , PP q x ~ a - , Show a - , Show b - ) => P (q & p) x where - type PP (q & p) x = FnT (PP p x) - eval _ opts x = do - let msg0 = "(&)" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = p q - in mkNode opts (PresentT d) ["fn & " <> show q <> " = " <> show d] [hh pp, hh qq] - -type family FnT ab :: Type where - FnT (a -> b) = b - FnT ab = GL.TypeError ( - 'GL.Text "FnT: expected Type -> Type but found a simple Type?" - ':$$: 'GL.Text "ab = " - ':<>: 'GL.ShowType ab) - -evalQuick :: forall p i . P p i => i -> Either String (PP p i) -evalQuick i = getValLRFromTT (runIdentity (eval (Proxy @p) o0 i)) - --- | similar to 'T.strip' 'T.stripStart' 'T.stripEnd' --- --- >>> pl @(Trim (Snd Id)) (20," abc " :: String) --- Present "abc" --- PresentT "abc" --- --- >>> import Data.Text (Text) --- >>> pl @(Trim (Snd Id)) (20," abc " :: Text) --- Present "abc" --- PresentT "abc" --- --- >>> pl @(TrimStart (Snd Id)) (20," abc ") --- Present "abc " --- PresentT "abc " --- --- >>> pl @(TrimEnd (Snd Id)) (20," abc ") --- Present " abc" --- PresentT " abc" --- --- >>> pl @(TrimEnd " abc ") () --- Present " abc" --- PresentT " abc" --- --- >>> pl @(TrimEnd "") () --- Present "" --- PresentT "" --- --- >>> pl @(Trim " ") () --- Present "" --- PresentT "" --- --- >>> pl @(Trim "") () --- Present "" --- PresentT "" --- -data Trim' (left :: Bool) (right :: Bool) p -type Trim p = Trim' 'True 'True p -type TrimStart p = Trim' 'True 'False p -type TrimEnd p = Trim' 'False 'True p - -instance (FailIfT (NotT (OrT l r)) - ('GL.Text "Trim': left and right cannot both be False") - , GetBool l - , GetBool r - , TL.IsText (PP p x) - , P p x - ) => P (Trim' l r p) x where - type PP (Trim' l r p) x = PP p x - eval _ opts x = do - let msg0 = "Trim" ++ (if l && r then "" else if l then "Start" else "End") - l = getBool @l - r = getBool @r - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right (view TL.unpacked -> p) -> - let fl = if l then dropWhile isSpace else id - fr = if r then dropWhileEnd isSpace else id - b = (fl . fr) p - in mkNode opts (PresentT (b ^. TL.packed)) [msg0 <> showLit0 opts "" b <> showLit1 opts " | " p] [hh pp] - --- | similar to 'T.stripLeft' 'T.stripRight' --- --- >>> pl @(StripLeft "xyz" Id) ("xyzHello" :: String) --- Present Just "Hello" --- PresentT (Just "Hello") --- --- >>> import Data.Text (Text) --- >>> pl @(StripLeft "xyz" Id) ("xyzHello" :: Text) --- Present Just "Hello" --- PresentT (Just "Hello") --- --- >>> pl @(StripLeft "xyz" Id) "xywHello" --- Present Nothing --- PresentT Nothing --- --- >>> pl @(StripRight "xyz" Id) "Hello xyz" --- Present Just "Hello " --- PresentT (Just "Hello ") --- --- >>> pl @(StripRight "xyz" Id) "xyzHelloxyw" --- Present Nothing --- PresentT Nothing --- --- >>> pl @(StripRight "xyz" Id) "" --- Present Nothing --- PresentT Nothing --- --- >>> pl @(StripRight "xyz" "xyz") () --- Present Just "" --- PresentT (Just "") --- -data StripLR (right :: Bool) p q -type StripRight p q = StripLR 'True p q -type StripLeft p q = StripLR 'False p q - -instance (GetBool r - , PP p x ~ String - , P p x - , TL.IsText (PP q x) - , P q x - ) => P (StripLR r p q) x where - type PP (StripLR r p q) x = Maybe (PP q x) - eval _ opts x = do - let msg0 = "Strip" ++ (if r then "Right" else "Left") - r = getBool @r - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x - pure $ case lr of - Left e -> e - Right (p,view TL.unpacked -> q,pp,qq) -> - let b = if r then - let (before,after) = splitAt (length q - length p) q - in if after == p then Just before else Nothing - else - let (before,after) = splitAt (length p) q - in if before == p then Just after else Nothing - in mkNode opts (PresentT (fmap (view TL.packed) b)) [msg0 <> show0 opts "" b <> showLit1 opts " | p=" p <> showLit1 opts " | q=" q] [hh pp, hh qq] - --- | leverages 'Para' for repeating predicates (passthrough method) --- --- >>> pl @(ParaNImpl 'True 4 (Succ Id)) [1..4] --- Present [2,3,4,5] --- PresentT [2,3,4,5] --- --- >>> pl @(ParaNLax 4 (Succ Id)) "azwxm" --- Present "b{xy" --- PresentT "b{xy" --- --- >>> pl @(ParaN 4 (Succ Id)) "azwxm" --- Error Para: data elements(5) /= predicates(4) --- FailT "Para: data elements(5) /= predicates(4)" --- --- >>> pl @(ParaN 4 (Succ Id)) "azwx" --- Present "b{xy" --- PresentT "b{xy" --- -data ParaNImpl (strict :: Bool) (n :: Nat) p -type ParaN (n :: Nat) p = ParaNImpl 'True n p -type ParaNLax (n :: Nat) p = ParaNImpl 'False n p - -instance ( P (ParaImpl (LenT (RepeatT n p)) strict (RepeatT n p)) [a] - , GetLen (RepeatT n p) - , GetBool strict - ) => P (ParaNImpl strict n p) [a] where - type PP (ParaNImpl strict n p) [a] = PP (ParaImplW strict (RepeatT n p)) [a] - eval _ opts as = - eval (Proxy @(ParaImplW strict (RepeatT n p))) opts as - --- | leverages 'GuardsQuick' for repeating predicates (passthrough method) --- --- >>> pl @(GuardsN (Printf2 "id=%d must be between 0 and 255, found %d") 4 (Between 0 255)) [121,33,7,256] --- Error id=4 must be between 0 and 255, found 256 --- FailT "id=4 must be between 0 and 255, found 256" --- --- >>> pl @(GuardsN (Printf2 "id=%d must be between 0 and 255, found %d") 4 (Between 0 255)) [121,33,7,44] --- Present [121,33,7,44] --- PresentT [121,33,7,44] --- -data GuardsNImpl (strict :: Bool) prt (n :: Nat) p -type GuardsN prt (n :: Nat) p = GuardsNImpl 'True prt n p -type GuardsNLax prt (n :: Nat) p = GuardsNImpl 'False prt n p - -instance ( GetBool strict - , GetLen (ToGuardsT prt (RepeatT n p)) - , P (GuardsImpl - (LenT (ToGuardsT prt (RepeatT n p))) - strict - (ToGuardsT prt (RepeatT n p))) - [a] - ) => P (GuardsNImpl strict prt n p) [a] where - type PP (GuardsNImpl strict prt n p) [a] = PP (GuardsImplW strict (ToGuardsT prt (RepeatT n p))) [a] - eval _ opts as = - eval (Proxy @(GuardsImplW strict (ToGuardsT prt (RepeatT n p)))) opts as - --- | creates a promoted list of predicates and then evaluates them into a list. see PP instance for '[k] --- --- >>> pl @(Repeat 4 (Succ Id)) 'c' --- Present "dddd" --- PresentT "dddd" --- --- >>> pl @(Repeat 4 "abc") () --- Present ["abc","abc","abc","abc"] --- PresentT ["abc","abc","abc","abc"] --- -data Repeat (n :: Nat) p -instance (P (RepeatT n p) a - ) => P (Repeat n p) a where - type PP (Repeat n p) a = PP (RepeatT n p) a - eval _ opts a = - eval (Proxy @(RepeatT n p)) opts a - --- \'DoN n p\' == \'FoldN n p Id\' but more efficient - --- | leverages 'Do' for repeating predicates (passthrough method) --- same as \'DoN n p\' == \'FoldN n p Id\' but more efficient --- --- >>> pl @(DoN 4 (Succ Id)) 'c' --- Present 'g' --- PresentT 'g' --- --- >>> pl @(DoN 4 (Id <> " | ")) "abc" --- Present "abc | | | | " --- PresentT "abc | | | | " --- --- >>> pl @(DoN 4 (Id <> "|" <> Id)) "abc" --- Present "abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc" --- PresentT "abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc" --- -data DoN (n :: Nat) p -instance (P (DoExpandT (RepeatT n p)) a - ) => P (DoN n p) a where - type PP (DoN n p) a = PP (Do (RepeatT n p)) a - eval _ opts a = - eval (Proxy @(Do (RepeatT n p))) opts a +{- | + Provides a type-level Dsl for refinement types + + To use refinement types you will need to also import 'Predicate.Refined' and/or 'Predicate.Refined3' +-} +module Predicate ( + module Predicate.Core + , module Predicate.Prelude + , module Predicate.Util + ) where +import Predicate.Core +import Predicate.Util +import Predicate.Prelude
+ src/Predicate/Core.hs view
@@ -0,0 +1,620 @@+{-# OPTIONS -Wall #-} +{-# OPTIONS -Wcompat #-} +{-# OPTIONS -Wincomplete-record-updates #-} +{-# OPTIONS -Wincomplete-uni-patterns #-} +{-# OPTIONS -Wredundant-constraints #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{- | + Dsl for evaluating and displaying type level expressions +-} +module Predicate.Core ( + P(..) + + -- ** basic types + , I + , Id + , IdT + , W + , Msg + + -- ** display evaluation tree + , pe + , pe2 + , pe2n + , pu + , pun + , pe3 + , pl + , plc + + -- ** evaluation methods + , runPQ + , evalBool + , evalQuick + ) where +import Predicate.Util +import GHC.TypeLits (Symbol,Nat,KnownSymbol,KnownNat) +import Control.Lens ((^.)) +import Data.Proxy +import Data.Typeable +import Data.Kind (Type) +import Data.These (These(..)) +import Data.Functor.Identity +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> :set -XTypeOperators +-- >>> :set -XNoStarIsType + +-- | This is the core class. Each instance of this class can be combined into a dsl using 'Main.>>' +class P p a where + type PP (p :: k) a :: Type -- PP is the output type + eval :: MonadEval m => Proxy p -> POpts -> a -> m (TT (PP p a)) -- ^ returns a tree of results + +-- | A specialised form of 'eval' that works only on predicates +evalBool :: (MonadEval m, P p a, PP p a ~ Bool) => Proxy p -> POpts -> a -> m (TT (PP p a)) +evalBool p opts a = fixBoolT <$> eval p opts a + +evalQuick :: forall p i . P p i => i -> Either String (PP p i) +evalQuick i = getValLRFromTT (runIdentity (eval (Proxy @p) o0 i)) + + +-- | identity function +-- +-- >>> pl @I 23 +-- Present 23 +-- PresentT 23 +data I +instance P I a where + type PP I a = a + eval _ opts a = + let msg0 = "I" + in pure $ mkNode opts (PresentT a) [msg0] [] + + +-- | identity function that displays the input unlike 'I' +-- +-- even more constraints than 'I' so we might need to add explicit type signatures +-- +-- >>> pl @Id 23 +-- Present 23 +-- PresentT 23 +data Id +instance Show a => P Id a where + type PP Id a = a + eval _ opts a = + let msg0 = "Id" + in pure $ mkNode opts (PresentT a) [msg0 <> show0 opts " " a] [] + + +-- even more constraints than 'Id' so we might need to explicitly add types (Typeable) +-- | identity function that also displays the type information for debugging +-- +-- >>> pl @IdT 23 +-- Present 23 +-- PresentT 23 +data IdT +instance (Typeable a, Show a) => P IdT a where + type PP IdT a = a + eval _ opts a = + let msg0 = "IdT(" <> t <> ")" + t = showT @a + in pure $ mkNode opts (PresentT a) [msg0 <> show0 opts " " a] [] + +-- | transparent predicate wrapper to make k of kind 'Type' so it can be in a promoted list (cant mix kinds) see 'Predicate.Do' +-- +-- >>> pl @'[W 123, Id] 99 +-- Present [123,99] +-- PresentT [123,99] +-- +-- >>> pl @'[W "abc", W "def", Id, Id] "ghi" +-- Present ["abc","def","ghi","ghi"] +-- PresentT ["abc","def","ghi","ghi"] +-- +data W (p :: k) +instance P p a => P (W p) a where + type PP (W p) a = PP p a + eval _ = eval (Proxy @(Msg "W" p)) + +-- | add a message to give more context to the evaluation tree +-- +-- >>> pe @(Msg "[somemessage] " Id) 999 +-- P [somemessage] Id 999 +-- PresentT 999 +-- +-- >>> pe @(Msg Id 999) "info message:" +-- P info message:'999 +-- PresentT 999 +-- +data Msg prt p + +instance (P prt a + , PP prt a ~ String + , P p a + ) => P (Msg prt p) a where + type PP (Msg prt p) a = PP p a + eval _ opts a = do + pp <- eval (Proxy @prt) opts a + case getValueLR opts "Msg" pp [] of + Left e -> pure e + Right msg -> prefixMsg msg <$> eval (Proxy @p) opts a + +-- | 'const' () function +-- +-- >>> pl @() "Asf" +-- Present () +-- PresentT () +-- +instance P () a where + type PP () a = () + eval _ opts _ = + let msg0 = "()" + in pure $ mkNode opts (PresentT ()) [msg0] [] + +instance P (Proxy t) a where + type PP (Proxy t) a = Proxy t + eval _ opts _ = + let msg0 = "Proxy" + in pure $ mkNode opts (PresentT Proxy) [msg0] [] + +-- Start non-Type kinds +----------------------- + +-- | pulls the type level 'Bool' to the value level +-- +-- >>> pl @'True "not used" +-- True +-- TrueT +-- +-- >>> pl @'False () +-- False +-- FalseT +instance GetBool b => P (b :: Bool) a where + type PP b a = Bool + eval _ opts _ = + let b = getBool @b + in pure $ mkNodeB opts b ["'" <> show b] [] + +-- | pulls the type level 'Symbol' to the value level as a 'GHC.Base.String' +-- +-- >>> pl @"hello world" () +-- Present "hello world" +-- PresentT "hello world" +instance KnownSymbol s => P (s :: Symbol) a where + type PP s a = String + eval _ opts _ = + let s = symb @s + in pure $ mkNode opts (PresentT s) ["'" <> showLit0 opts "" s] [] + +-- | run the predicates in a promoted 2-tuple; similar to 'Control.Arrow.&&&' +-- +-- >>> pl @'(Id, 4) "hello" +-- Present ("hello",4) +-- PresentT ("hello",4) +-- +instance (P p a, P q a) => P '(p,q) a where + type PP '(p,q) a = (PP p a, PP q a) + eval _ opts a = do + let msg = "'(,)" + lr <- runPQ msg (Proxy @p) (Proxy @q) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + mkNode opts (PresentT (p,q)) [msg] [hh pp, hh qq] + +-- | run the predicates in a promoted 3-tuple +-- +-- >>> pl @'(4, Id, "goodbye") "hello" +-- Present (4,"hello","goodbye") +-- PresentT (4,"hello","goodbye") +-- +instance (P p a + , P q a + , P r a + ) => P '(p,q,r) a where + type PP '(p,q,r) a = (PP p a, PP q a, PP r a) + eval _ opts a = do + let msg = "'(,,)" + lr <- runPQ msg (Proxy @p) (Proxy @q) opts a + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> do + let hhs = [hh pp, hh qq] + rr <- eval (Proxy @r) opts a + pure $ case getValueLR opts msg rr hhs of + Left e -> e + Right r -> mkNode opts (PresentT (p,q,r)) [msg] (hhs <> [hh rr]) + +-- | run the predicates in a promoted 4-tuple +-- +-- >>> pl @'(4, Id, "inj", 999) "hello" +-- Present (4,"hello","inj",999) +-- PresentT (4,"hello","inj",999) +-- +instance (P p a + , P q a + , P r a + , P s a + ) => P '(p,q,r,s) a where + type PP '(p,q,r,s) a = (PP p a, PP q a, PP r a, PP s a) + eval _ opts a = do + let msg = "'(,,)" + lr <- runPQ msg (Proxy @p) (Proxy @q) opts a + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> do + lr1 <- runPQ msg (Proxy @r) (Proxy @s) opts a + pure $ case lr1 of + Left e -> e + Right (r,s,rr,ss) -> + mkNode opts (PresentT (p,q,r,s)) [msg] [hh pp, hh qq, hh rr, hh ss] + +-- | extracts the value level representation of the promoted 'Ordering' +-- +-- >>> pl @'LT "not used" +-- Present LT +-- PresentT LT +-- +-- >>> pl @'EQ () +-- Present EQ +-- PresentT EQ +instance GetOrdering cmp => P (cmp :: Ordering) a where + type PP cmp a = Ordering + eval _ opts _a = + let cmp = getOrdering @cmp + msg = "'" <> show cmp + in pure $ mkNode opts (PresentT cmp) [msg] [] + +-- | extracts the value level representation of the type level 'Nat' +-- +-- >>> pl @123 () +-- Present 123 +-- PresentT 123 +instance KnownNat n => P (n :: Nat) a where + type PP n a = Int + eval _ opts _ = + let n = nat @n + in pure $ mkNode opts (PresentT n) ["'" <> show n] [] + +-- | extracts the value level representation of the type level \'() +-- +-- >>> pl @'() () +-- Present () +-- PresentT () +instance P '() a where + type PP '() a = () + eval _ opts _ = pure $ mkNode opts (PresentT ()) ["'()"] [] + +-- todo: the type has to be [a] so we still need type PP '[p] a = [PP p a] to keep the types in line + +-- | extracts the value level representation of the type level \'[] +-- +-- >>> pl @'[] False +-- Present [] +-- PresentT [] +instance P ('[] :: [k]) a where + type PP ('[] :: [k]) a = [a] + eval _ opts _ = pure $ mkNode opts (PresentT mempty) ["'[]"] [] + +-- | runs each predicate in turn from the promoted list +-- +-- >>> pl @'[1, 2, 3] 999 +-- Present [1,2,3] +-- PresentT [1,2,3] +-- +-- >>> pl @'[W 1, W 2, W 3, Id] 999 +-- Present [1,2,3,999] +-- PresentT [1,2,3,999] +-- +instance (Show (PP p a), Show a, P p a) => P '[p] a where + type PP '[p] a = [PP p a] + eval _ opts a = do + pp <- eval (Proxy @p) opts a + let msg0 = "" -- "'[](end)" + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right b -> mkNode opts (PresentT [b]) [show01 opts msg0 b a] [hh pp] -- <> show0 opts " " a <> show1 opts " b=" b]) [hh pp] + +instance (Show (PP p a) + , Show a + , P (p1 ': ps) a + , PP (p1 ': ps) a ~ [PP p1 a] + , P p a + , PP p a ~ PP p1 a + ) => P (p ': p1 ': ps) a where + type PP (p ': p1 ': ps) a = [PP p a] + eval _ opts a = do + let msg0 = "'(p':q)" + lr <- runPQ msg0 (Proxy @p) (Proxy @(p1 ': ps)) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let ret = p:q + -- no gap between ' and ret! + in mkNode opts (PresentT ret) ["'" <> show0 opts "" ret <> show1 opts " | " a] [hh pp, hh qq] + +-- | extracts the \'a\' from type level \'Maybe a\' if the value exists +-- +-- >>> pl @('Just Id) (Just 123) +-- Present 123 +-- PresentT 123 +-- +-- >>> pl @('Just Id) (Just True) +-- Present True +-- PresentT True +-- +-- >>> pl @('Just Id) Nothing +-- Error 'Just found Nothing +-- FailT "'Just found Nothing" +-- +instance (Show (PP p a) + , P p a + , Show a + ) => P ('Just p) (Maybe a) where + type PP ('Just p) (Maybe a) = PP p a + eval _ opts ma = do + let msg0 = "'Just" + case ma of + Just a -> do + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right b -> mkNode opts (PresentT b) [show01 opts msg0 b ma] [hh pp] + Nothing -> pure $ mkNode opts (FailT (msg0 <> " found Nothing")) [msg0 <> " found Nothing"] [] + +-- | expects Nothing otherwise it fails +-- if the value is Nothing then it returns \'Proxy a\' as this provides more information than '()' +-- +-- >>> pl @'Nothing Nothing +-- Present Proxy +-- PresentT Proxy +-- +-- >>> pl @'Nothing (Just True) +-- Error 'Nothing found Just +-- FailT "'Nothing found Just" +-- +instance P 'Nothing (Maybe a) where + type PP 'Nothing (Maybe a) = Proxy a -- () gives us less information + eval _ opts ma = + let msg0 = "'Nothing" + in pure $ case ma of + Nothing -> mkNode opts (PresentT Proxy) [msg0] [] + Just _ -> mkNode opts (FailT (msg0 <> " found Just")) [msg0 <> " found Just"] [] + +-- omitted Show x so we can have less ambiguity +-- | extracts the \'a\' from type level \'Either a b\' if the value exists +-- +-- >>> pl @('Left Id) (Left 123) +-- Present 123 +-- PresentT 123 +-- +-- >>> pl @('Left Id) (Right "aaa") +-- Error 'Left found Right +-- FailT "'Left found Right" +-- +instance (Show a + , Show (PP p a) + , P p a + ) => P ('Left p) (Either a x) where + type PP ('Left p) (Either a x) = PP p a + eval _ opts lr = + let msg0 = "'Left" + in case lr of + Right _ -> pure $ mkNode opts (FailT (msg0 <> " found Right")) [msg0 <> " found Right"] [] + Left a -> do + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right b -> mkNode opts (_tBool pp) [show01' opts msg0 b "Left " a] [hh pp] + +-- | extracts the \'b\' from type level \'Either a b\' if the value exists +-- +-- >>> pl @('Right Id) (Right 123) +-- Present 123 +-- PresentT 123 +-- +-- >>> pl @('Right Id) (Left "aaa") +-- Error 'Right found Left +-- FailT "'Right found Left" +-- +instance (Show a + , Show (PP p a) + , P p a + ) => P ('Right p) (Either x a) where + type PP ('Right p) (Either x a) = PP p a + eval _ opts lr = do + let msg0 = "'Right" + case lr of + Left _ -> pure $ mkNode opts (FailT (msg0 <> " found Left")) [msg0 <> " found Left"] [] + Right a -> do + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right b -> mkNode opts (_tBool pp) [show01' opts msg0 b "Right " a] [hh pp] + +-- removed Show x: else ambiguity errors in TestPredicate + +-- | extracts the \'a\' from type level \'These a b\' if the value exists +-- +-- >>> pl @('This Id) (This 123) +-- Present 123 +-- PresentT 123 +-- +-- >>> pl @('This Id) (That "aaa") +-- Error 'This found That +-- FailT "'This found That" +-- +-- >>> pl @('This Id) (These 999 "aaa") +-- Error 'This found These +-- FailT "'This found These" +-- +instance (Show a + , Show (PP p a) + , P p a + ) => P ('This p) (These a x) where + type PP ('This p) (These a x) = PP p a + eval _ opts th = do + let msg0 = "'This" + case th of + This a -> do + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right b -> mkNode opts (_tBool pp) [show01' opts msg0 b "This " a] [hh pp] + _ -> pure $ mkNode opts (FailT (msg0 <> " found " <> showThese th)) [msg0 <> " found " <> showThese th] [] + +-- | extracts the \'b\' from type level \'These a b\' if the value exists +-- +-- >>> pl @('That Id) (That 123) +-- Present 123 +-- PresentT 123 +-- +-- >>> pl @('That Id) (This "aaa") +-- Error 'That found This +-- FailT "'That found This" +-- +-- >>> pl @('That Id) (These 44 "aaa") +-- Error 'That found These +-- FailT "'That found These" +-- +instance (Show a + , Show (PP p a) + , P p a + ) => P ('That p) (These x a) where + type PP ('That p) (These x a) = PP p a + eval _ opts th = do + let msg0 = "'That" + case th of + That a -> do + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right b -> mkNode opts (_tBool pp) [show01' opts msg0 b "That " a] [hh pp] + _ -> pure $ mkNode opts (FailT (msg0 <> " found " <> showThese th)) [msg0 <> " found " <> showThese th] [] + + +-- | extracts the (a,b) from type level 'These a b' if the value exists +-- +-- >>> pl @('These Id Id) (These 123 "abc") +-- Present (123,"abc") +-- PresentT (123,"abc") +-- +-- >>> pl @('These Id 5) (These 123 "abcde") +-- Present (123,5) +-- PresentT (123,5) +-- +-- >>> pl @('These Id Id) (This "aaa") +-- Error 'These found This +-- FailT "'These found This" +-- +-- >>> pl @('These Id Id) (That "aaa") +-- Error 'These found That +-- FailT "'These found That" +-- +instance (Show a + , Show b + , P p a + , P q b + , Show (PP p a) + , Show (PP q b) + ) => P ('These p q) (These a b) where + type PP ('These p q) (These a b) = (PP p a, PP q b) + eval _ opts th = do + let msg0 = "'These" + case th of + These a b -> do + pp <- eval (Proxy @p) opts a + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right p -> do + qq <- eval (Proxy @q) opts b + pure $ case getValueLR opts (msg0 <> " q failed p=" <> show p) qq [hh pp] of + Left e -> e + Right q -> + let ret =(p,q) + in mkNode opts (PresentT ret) [show01 opts msg0 ret (These a b)] [hh pp, hh qq] + _ -> pure $ mkNode opts (FailT (msg0 <> " found " <> showThese th)) [msg0 <> " found " <> showThese th] [] + +-- | converts the value to the corresponding 'Proxy' +-- +-- >>> pl @'Proxy 'x' +-- Present Proxy +-- PresentT Proxy +-- +instance Show a => P 'Proxy a where + type PP 'Proxy a = Proxy a + eval _ opts a = + let b = Proxy @a + in pure $ mkNode opts (PresentT b) ["'Proxy" <> show1 opts " | " a] [] + +-- End non-Type kinds +----------------------- + +pe, pe2, pe2n, pu, pun, pe3, pl, plc :: forall p a . (Show (PP p a), P p a) => a -> IO (BoolT (PP p a)) +-- | displays the evaluation tree in plain text without colors +pe = peWith @p o0 +-- | displays the evaluation tree using colors +pe2 = peWith @p o2 +-- | same as 'pe2' but truncates the display tree horizontally: see 'o2n' +pe2n = peWith @p o2n +-- | same as 'pe2' but wider display +pe3 = peWith @p o3 +-- | skips the evaluation tree and just displays the end result +pl = peWith @p ol +-- | same as 'pl' but with colors +plc = peWith @p olc +-- | display the evaluation tree using unicode and colors +-- @ +-- pu @'(Id, "abc", 123) [1..4] +-- @ +pu = peWith @p ou +-- | same as 'pu' but truncates the display tree horizontally: see 'ou' +pun = peWith @p oun + +peWith :: forall p a + . (Show (PP p a), P p a) + => POpts + -> a + -> IO (BoolT (PP p a)) +peWith opts a = do + pp <- eval (Proxy @p) opts a + let r = pp ^. tBool + if oLite opts then + let f = colorMe opts (r ^. boolT2P) + in putStrLn $ case r of + FailT e -> f "Error" <> " " <> e + TrueT -> f "True" + FalseT -> f "False" + PresentT x -> f "Present" <> " " <> show x + else prtTree opts (fromTT pp) + return r + +runPQ :: (P p a, P q a, MonadEval m) + => String + -> Proxy p + -> Proxy q + -> POpts + -> a + -> m (Either (TT x) (PP p a, PP q a, TT (PP p a), TT (PP q a))) +runPQ msg0 proxyp proxyq opts a = do + pp <- eval proxyp opts a + case getValueLR opts msg0 pp [] of + Left e -> pure $ Left e + Right p -> do + qq <- eval proxyq opts a + pure $ case getValueLR opts msg0 qq [hh pp] of + Left e -> Left e + Right q -> Right (p, q, pp, qq) + +
+ src/Predicate/Prelude.hs view
@@ -0,0 +1,7456 @@+{-# OPTIONS -Wall #-} +{-# OPTIONS -Wcompat #-} +{-# OPTIONS -Wincomplete-record-updates #-} +{-# OPTIONS -Wincomplete-uni-patterns #-} +{-# OPTIONS -Wredundant-constraints #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE OverloadedLists #-} +{- | + Dsl for evaluating and displaying type level expressions + + Contains instances of the class 'P' for evaluating expressions at the type level. +-} +module Predicate.Prelude ( + -- ** boolean methods + type (&&) + , type (||) + , type (~>) + , Not + , Ands + , Ors + , Asc + , Asc' + , Desc + , Desc' + , Between + , type (<..>) + , Between' + , All + , Any + , AllPositive + , AllPositive' + , Positive + , AllNegative + , AllNegative' + , Negative + + -- ** regex methods + , Re + , Re' + , Rescan + , Rescan' + , RescanRanges + , RescanRanges' + , Resplit + , Resplit' + , ReplaceAll + , ReplaceAll' + , ReplaceOne + , ReplaceOne' + , ReplaceAllString + , ReplaceAllString' + , ReplaceOneString + , ReplaceOneString' + , MakeRR + , MakeRR1 + , MakeRR2 + , MakeRR3 + + -- ** tuple methods + , Fst + , Snd + , Thd + , L1 + , L2 + , L3 + , L4 + , L5 + , L6 + , Dup + , Swap + , Assoc + , Unassoc + , ReverseTupleN + , TupleI + , Pairs + + -- ** character methods + , CharSet(..) + , IsLower + , IsUpper + , IsNumber + , IsSpace + , IsPunctuation + , IsControl + , IsHexDigit + , IsOctDigit + , IsSeparator + , IsLatin1 + + -- ** date time methods + , FormatTimeP + , ParseTimeP + , ParseTimeP' + , ParseTimes + , ParseTimes' + , MkDay + , MkDay' + , UnMkDay + + -- ** numeric methods + , type (+) + , type (-) + , type (*) + , type (/) + + , type (%) + , type (%-) + , type (-%) + , Negate + , Abs + , Signum + , FromInteger + , FromInteger' + , FromIntegral + , FromIntegral' + , ToRational + , FromRational + , FromRational' + , Truncate + , Truncate' + , Ceiling + , Ceiling' + , Floor + , Floor' + , Even + , Odd + , Div + , Mod + , DivMod + , QuotRem + , Quot + , Rem + + -- ** proxy methods + , MkProxy + , ProxyT + , ProxyT' + , Unproxy + + -- ** read / show methods + , ShowP + , ReadP + , ReadP' + , ReadP'' + , ReadBase + , ReadBase' + , ReadBaseInt + , ShowBase + , ShowBase' + + -- ** arrow methods + , type (&&&) + , type (***) + , First + , Second + , type (|||) + , type (+++) + + -- ** compare methods + , type (>) + , type (>=) + , type (==) + , type (/=) + , type (<=) + , type (<) + , type (>~) + , type (>=~) + , type (==~) + , type (/=~) + , type (<=~) + , type (<~) + , Gt + , Ge + , Same + , Le + , Lt + , Ne + , OrdP + , type (==!) + , OrdA' + , OrdA + , OrdI + , type (===~) + , Cmp + , CmpI + + -- ** enum methods + , Succ + , Pred + , FromEnum + , ToEnum + , ToEnum' + , EnumFromTo + , SuccB + , SuccB' + , PredB + , PredB' + , ToEnumB + , ToEnumB' + , ToEnumBF + + -- ** wrap / unwrap methods + , Unwrap + , Wrap + , Wrap' + , Coerce + , Coerce2 + + -- ** list / foldable methods + , Map + , Concat + , ConcatMap + , Partition + , FilterBy + , Break + , Span + , Intercalate + , Elem + , Inits + , Tails + , Ones + , OneP + , Len + , Length + , PadL + , PadR + , SplitAts + , SplitAt + , Take + , Drop + , Head + , Tail + , Init + , Last + , Min + , Max + , Sum + , IsEmpty + , Null + , ToList + , ToList' + , IToList + , IToList' + , ToListExt + , FromList + , FromListExt + , EmptyList + , EmptyList' + , Singleton + , Reverse + , ReverseL + , SortBy + , SortOn + , SortOnDesc + , Remove + , Keep + , HeadDef + , HeadP + , HeadFail + , TailDef + , TailP + , TailFail + , LastDef + , LastP + , LastFail + , InitDef + , InitP + , InitFail + , Head' + , Tail' + , Last' + , Init' + + -- ** maybe methods + , MkNothing + , MkNothing' + , MkJust + , IsNothing + , IsJust + , MapMaybe + , CatMaybes + , Just' + , JustDef + , JustP + , JustFail + , MaybeX + , MaybeIn + , MaybeBool + , JustDef' + , JustDef'' + , JustDef''' + + -- ** either methods + , PartitionEithers + , IsLeft + , IsRight + , MkLeft + , MkLeft' + , MkRight + , MkRight' + , Left' + , Right' + , LeftDef + , LeftP + , LeftFail + , RightDef + , RightP + , RightFail + , EitherBool + , MkRightAlt + , MkLeftAlt + , EitherIn + + -- ** semigroup / monoid methods + , type (<>) + , MConcat + , STimes + , Ands' + , Ors' + , Min' + , Max' + , Sum' + , Sapa + , Sapa' + , MEmptyT + , MEmptyT' + , MEmptyP + , MEmptyT2 + , MEmptyT2' + + -- ** indexing methods + , Ix + , Ix' + , IxL + , type (!!) + , Lookup + , type (!!!) + , Lookup' + , LookupDef + , LookupDef' + , LookupP + , LookupP' + , LookupFail + , LookupFail' + + -- cons / uncons methods + , type (:+) + , type (+:) + , Uncons + , Unsnoc + + -- ** these methods + , PartitionThese + , Thiss + , Thats + , Theses + , This' + , That' + , IsThis + , IsThat + , IsThese + , MkThis + , MkThis' + , MkThat + , MkThat' + , MkThese + , ThisDef + , ThisP + , ThisFail + , ThatDef + , ThatP + , ThatFail + , TheseDef + , TheseP + , TheseFail + , TheseIn + , TheseIn' + , TheseId + , TheseX + + -- ** fold / unfold methods + , Scanl + , ScanN + , ScanNA + , FoldN + , Foldl + , Unfoldr + , IterateN + , IterateUntil + , IterateWhile + , IterateNWhile + , IterateNUntil + + -- ** failure methods + , Fail + , Failp + , Failt + , FailS + , FailPrt + , FailPrt2 + , Catch + , Catch' + + -- ** zip methods + , ZipThese + , ZipL + , ZipR + , ZipTrunc + , Unzip + + -- ** conditional methods + , If + , Case + , Case' + , Case'' + , Guards + , GuardsLax + , GuardsQuick + , GuardsQuickLax + , Guard + , Guard' + , ExitWhen + , ExitWhen' + , GuardSimple + , Guards' + , ToGuards + , GuardsN + , GuardsNLax + , GuardsDetail + +-- ** parallel methods + , ToPara + , Para + , ParaLax + , ParaN + , ParaNLax + , Repeat + + -- ** IO methods + , ReadFile + , FileExists + , ReadDir + , DirExists + , ReadEnv + , ReadEnvAll + , TimeUtc + , TimeZt + , AppendFile + , WriteFile + , WriteFile' + , Stdout + , Stderr + , Stdin + + -- ** string methods + , ToLower + , ToUpper + , Trim + , TrimStart + , TrimEnd + , StripLR + , StripRight + , StripLeft + , IsPrefix + , IsInfix + , IsSuffix + , IsPrefixI + , IsInfixI + , IsSuffixI + , FromStringP + , FromStringP' + + -- ** printf methods + , Printf + , Printfn + , Printfnt + , PrintfntLax + , Printf2 + , Printf3 + , Printf3' + + -- ** higher order methods + , Pure + , Pure2 + , FoldMap + , type (<$) + , type (<*) + , type (*>) + , Fmap_1 + , Fmap_2 + , Sequence + , Traverse + , Join + , EmptyT + , type (<|>) + , Extract + , Duplicate + + -- ** expression combinators + , type ($) + , type (&) + , Do + , type (>>) + , type (<<) + , DoN + + -- ** miscellaneous + , Prime + , Luhn + , Char1 + , Hide + , Hole + , H + , Skip + , type (|>) + , type (>|) + ) where +import Predicate.Core +import Predicate.Util +import Safe +import GHC.TypeLits (Symbol,Nat,KnownSymbol,KnownNat,ErrorMessage((:$$:),(:<>:))) +import qualified GHC.TypeLits as GL +import Control.Lens hiding (strict,iall) +--import Control.Lens (Unwrapped, Wrapped, _Unwrapped', _Wrapped', Ixed, IxValue, Index, Reversing, Cons, Snoc, AsEmpty, FoldableWithIndex, allOf, (%~), (<&>), (^.), (^?), coerced, view, reversed, ix, cons, snoc, _Cons, _Snoc, (^?!), (.~), itoList, Identity(..), _Empty, has) +import Data.List +import qualified Data.Text.Lens as TL +import Data.Proxy +import Control.Applicative +import Data.Typeable +import Control.Monad.Except +import qualified Control.Exception as E +import Data.Kind (Type) +import qualified Text.Regex.PCRE.Heavy as RH +import Data.String +import Data.Foldable +import Data.Maybe +import Control.Arrow +import qualified Data.Semigroup as SG +import Numeric +import Data.Char +import Data.Function +import Data.These (These(..), these, partitionThese) +import qualified Data.Bifunctor.Swap as SW (Swap(..)) +import qualified Data.Bifunctor.Assoc as AS (Assoc(..)) +import Data.Ratio +import Data.Time +import Data.Coerce +import Data.Void +import qualified Data.Sequence as Seq +import Text.Printf +import System.Directory +import Control.Comonad +import System.IO +import System.Environment +import qualified GHC.Exts as GE +import Data.Bool +import Data.Either +import qualified Data.Type.Equality as DE +import Data.Time.Calendar.WeekDate + +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> :set -XTypeOperators +-- >>> :set -XNoStarIsType +-- >>> :set -XOverloadedStrings +-- >>> :set -XNoOverloadedLists +-- >>> import qualified Data.Map.Strict as M +-- >>> import qualified Data.Text as T + +-- | a type level predicate for a monotonic increasing list +-- +-- >>> pl @Asc "aaacdef" +-- True +-- TrueT +-- +-- >>> pl @Asc [1,2,3,4,5,5,7] +-- True +-- TrueT +-- +-- >>> pl @Asc' [1,2,3,4,5,5,7] +-- False +-- FalseT +-- +-- >>> pl @Asc "axacdef" +-- False +-- FalseT +-- + + +-- | a type level predicate for a monotonic increasing list +type Asc = Ands (Map (Fst Id <= Snd Id) Pairs) +-- | a type level predicate for a strictly increasing list +type Asc' = Ands (Map (Fst Id < Snd Id) Pairs) +-- | a type level predicate for a monotonic decreasing list +type Desc = Ands (Map (Fst Id >= Snd Id) Pairs) +-- | a type level predicate for a strictly decreasing list +type Desc' = Ands (Map (Fst Id > Snd Id) Pairs) + +--type AscAlt = SortOn Id Id == Id +--type DescAlt = SortOnDesc Id Id == Id + +-- | A predicate that determines if the value is between \'p\' and \'q\' +-- +-- >>> pl @(Between' 5 8 Len) [1,2,3,4,5,5,7] +-- True +-- TrueT +-- +-- >>> pl @(Between 5 8) 6 +-- True +-- TrueT +-- +-- >>> pl @(Between 5 8) 9 +-- False +-- FalseT +-- +-- >>> pl @(10 % 4 <..> 40 % 5) 4 +-- True +-- TrueT +-- +-- >>> pl @(10 % 4 <..> 40 % 5) 33 +-- False +-- FalseT +-- +type Between p q = Ge p && Le q +type p <..> q = Ge p && Le q +infix 4 <..> + +-- | This is the same as 'Between' but where \'r\' is 'Id' +type Between' p q r = r >= p && r <= q + +-- | a type level predicate for all positive elements in a list +-- +-- >>> pl @AllPositive [1,5,10,2,3] +-- True +-- TrueT +-- +-- >>> pl @AllPositive [0,1,5,10,2,3] +-- False +-- FalseT +-- +-- >>> pl @AllPositive [3,1,-5,10,2,3] +-- False +-- FalseT +-- +-- >>> pl @AllNegative [-1,-5,-10,-2,-3] +-- True +-- TrueT +-- +type AllPositive = Ands (Map Positive Id) +-- | a type level predicate for all negative elements in a list +type AllNegative = Ands (Map Negative Id) +type Positive = Gt 0 +type Negative = Lt 0 + +type AllPositive' = FoldMap SG.All (Map Positive Id) +type AllNegative' = FoldMap SG.All (Map Negative Id) + +-- | similar to 'all' +-- +-- >>> pl @(All Even Id) [1,5,11,5,3] +-- False +-- FalseT +-- +-- >>> pl @(All Odd Id) [1,5,11,5,3] +-- True +-- TrueT +-- +-- >>> pl @(All Odd Id) [] +-- True +-- TrueT +-- +type All x p = Ands (Map x p) +-- | similar to 'any' +-- +-- >>> pl @(Any Even Id) [1,5,11,5,3] +-- False +-- FalseT +-- +-- >>> pl @(Any Even Id) [1,5,112,5,3] +-- True +-- TrueT +-- +-- >>> pl @(Any Even Id) [] +-- False +-- FalseT +-- +type Any x p = Ors (Map x p) + +-- | 'unzip' equivalent +-- +-- >>> pl @Unzip (zip [1..5] "abcd") +-- Present ([1,2,3,4],"abcd") +-- PresentT ([1,2,3,4],"abcd") +-- +type Unzip = '(Map (Fst Id) Id, Map (Snd Id) Id) + +-- | represents a predicate using a 'Symbol' as a regular expression +-- evaluates 'Re' and returns True if there is a match +-- +-- >>> pl @(Re "^\\d{2}:\\d{2}:\\d{2}$" Id) "13:05:25" +-- True +-- TrueT +-- +data Re' (rs :: [ROpt]) p q +type Re p q = Re' '[] p q + +instance (GetROpts rs + , PP p x ~ String + , PP q x ~ String + , P p x + , P q x + ) => P (Re' rs p q) x where + type PP (Re' rs p q) x = Bool + eval _ opts x = do + let msg0 = "Re" <> (if null rs then "' " <> show rs else "") + rs = getROpts @rs + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let msg1 = msg0 <> " (" <> p <> ")" + hhs = [hh pp, hh qq] + in case compileRegex @rs opts msg1 p hhs of + Left tta -> tta + Right regex -> + let b = q RH.=~ regex + in mkNodeB opts b [msg1 <> showLit1 opts " | " q] hhs + +-- only way with rescan is to be explicit: no repeats! and useanchors but not (?m) +-- or just use Re' but then we only get a bool ie doesnt capture groups +-- rescan returns Right [] as an failure! +-- [] is failure! + + +-- | runs a regex matcher returning the original values and optionally any groups +-- +-- >>> pl @(Rescan "^(\\d{2}):(\\d{2}):(\\d{2})$" Id) "13:05:25" +-- Present [("13:05:25",["13","05","25"])] +-- PresentT [("13:05:25",["13","05","25"])] +-- +-- >>> pl @(Rescan (Snd Id) "13:05:25") ('a',"^(\\d{2}):(\\d{2}):(\\d{2})$") +-- Present [("13:05:25",["13","05","25"])] +-- PresentT [("13:05:25",["13","05","25"])] +-- +data Rescan' (rs :: [ROpt]) p q +type Rescan p q = Rescan' '[] p q + +instance (GetROpts rs + , PP p x ~ String + , PP q x ~ String + , P p x + , P q x + ) => P (Rescan' rs p q) x where + type PP (Rescan' rs p q) x = [(String, [String])] + eval _ opts x = do + let msg0 = "Rescan" <> (if null rs then "' " <> show rs else "") + rs = getROpts @rs + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let msg1 = msg0 <> " (" <> p <> ")" + hhs = [hh pp, hh qq] + in case compileRegex @rs opts msg1 p hhs of + Left tta -> tta + Right regex -> + case splitAt _MX $ RH.scan regex q of + (b, _:_) -> mkNode opts (FailT "Regex looping") [msg1 <> " Looping? " <> show (take 10 b) <> "..." <> show1 opts " | " q] hhs + ([], _) -> -- this is a failure cos empty string returned: so reuse p? + mkNode opts (FailT "Regex no results") [msg1 <> " no match" <> show1 opts " | " q] [hh pp, hh qq] + (b, _) -> mkNode opts (PresentT b) [lit01 opts msg1 b q] [hh pp, hh qq] + + +-- | similar to 'Rescan' but gives the column start and ending positions instead of values +-- +-- >>> pl @(RescanRanges "^(\\d{2}):(\\d{2}):(\\d{2})$" Id) "13:05:25" +-- Present [((0,8),[(0,2),(3,5),(6,8)])] +-- PresentT [((0,8),[(0,2),(3,5),(6,8)])] +-- +data RescanRanges' (rs :: [ROpt]) p q +type RescanRanges p q = RescanRanges' '[] p q + +instance (GetROpts rs + , PP p x ~ String + , PP q x ~ String + , P p x + , P q x + ) => P (RescanRanges' rs p q) x where + type PP (RescanRanges' rs p q) x = [((Int,Int), [(Int,Int)])] + eval _ opts x = do + let msg0 = "RescanRanges" <> (if null rs then "' " <> show rs else "") + rs = getROpts @rs + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let msg1 = msg0 <> " (" <> p <> ")" + hhs = [hh pp, hh qq] + in case compileRegex @rs opts msg1 p hhs of + Left tta -> tta + Right regex -> + case splitAt _MX $ RH.scanRanges regex q of + (b, _:_) -> mkNode opts (FailT "Regex looping") [msg1 <> " Looping? " <> show (take 10 b) <> "..." <> show1 opts " | " q] hhs + ([], _) -> -- this is a failure cos empty string returned: so reuse p? + mkNode opts (FailT "Regex no results") [msg1 <> " no match" <> show1 opts " | " q] hhs + (b, _) -> mkNode opts (PresentT b) [lit01 opts msg1 b q] hhs + +-- | splits a string on a regex delimiter +-- +-- >>> pl @(Resplit "\\." Id) "141.201.1.22" +-- Present ["141","201","1","22"] +-- PresentT ["141","201","1","22"] +-- +-- >>> pl @(Resplit (Singleton (Fst Id)) (Snd Id)) (':', "12:13:1") +-- Present ["12","13","1"] +-- PresentT ["12","13","1"] +-- +data Resplit' (rs :: [ROpt]) p q +type Resplit p q = Resplit' '[] p q + +instance (GetROpts rs + , PP p x ~ String + , PP q x ~ String + , P p x + , P q x + ) => P (Resplit' rs p q) x where + type PP (Resplit' rs p q) x = [String] + eval _ opts x = do + let msg0 = "Resplit" <> (if null rs then "' " <> show rs else "") + rs = getROpts @rs + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let msg1 = msg0 <> " (" <> p <> ")" + hhs = [hh pp, hh qq] + in case compileRegex @rs opts msg1 p hhs of + Left tta -> tta + Right regex -> + case splitAt _MX $ RH.split regex q of + (b, _:_) -> mkNode opts (FailT "Regex looping") [msg1 <> " Looping? " <> show (take 10 b) <> "..." <> show1 opts " | " q] hhs + ([], _) -> -- this is a failure cos empty string returned: so reuse p? + mkNode opts (FailT "Regex no results") [msg1 <> " no match" <> show1 opts " | " q] hhs + (b, _) -> mkNode opts (PresentT b) [lit01 opts msg1 b q] hhs + +_MX :: Int +_MX = 100 + +-- | replaces regex \'s\' with a string \'s1\' inside the value +-- +-- >>> pl @(ReplaceAllString "\\." ":" Id) "141.201.1.22" +-- Present "141:201:1:22" +-- PresentT "141:201:1:22" +-- +data ReplaceImpl (alle :: Bool) (rs :: [ROpt]) p q r +type ReplaceAll' (rs :: [ROpt]) p q r = ReplaceImpl 'True rs p q r +type ReplaceAll p q r = ReplaceAll' '[] p q r +type ReplaceOne' (rs :: [ROpt]) p q r = ReplaceImpl 'False rs p q r +type ReplaceOne p q r = ReplaceOne' '[] p q r + +type ReplaceAllString' (rs :: [ROpt]) p q r = ReplaceAll' rs p (MakeRR q) r +type ReplaceAllString p q r = ReplaceAllString' '[] p q r + +type ReplaceOneString' (rs :: [ROpt]) p q r = ReplaceOne' rs p (MakeRR q) r +type ReplaceOneString p q r = ReplaceOneString' '[] p q r + +-- | Simple replacement string: see 'ReplaceAllString' and 'ReplaceOneString' +-- +data MakeRR p + +instance (PP p x ~ String + , P p x) => P (MakeRR p) x where + type PP (MakeRR p) x = RR + eval _ opts x = do + let msg0 = "MakeRR" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = RR p + in mkNode opts (PresentT b) [msg0 <> show1 opts " | " p] [hh pp] + +-- | A replacement function (String -> [String] -> String) which returns the whole match and the groups +-- Used by 'RH.sub' and 'RH.gsub' +-- +-- Requires "Text.Show.Functions" +-- +data MakeRR1 p + +instance (PP p x ~ (String -> [String] -> String) + , P p x) => P (MakeRR1 p) x where + type PP (MakeRR1 p) x = RR + eval _ opts x = do + let msg0 = "MakeRR1 (String -> [String] -> String)" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right f -> mkNode opts (PresentT (RR1 f)) [msg0] [hh pp] + +-- | A replacement function (String -> String) that yields the whole match +-- Used by 'RH.sub' and 'RH.gsub' +-- +-- Requires "Text.Show.Functions" +-- +-- >>> :m + Text.Show.Functions +-- >>> pl @(ReplaceAll "\\." (MakeRR2 (Fst Id)) (Snd Id)) (\x -> x <> ":" <> x, "141.201.1.22") +-- Present "141.:.201.:.1.:.22" +-- PresentT "141.:.201.:.1.:.22" +-- +data MakeRR2 p + +instance (PP p x ~ (String -> String) + , P p x) => P (MakeRR2 p) x where + type PP (MakeRR2 p) x = RR + eval _ opts x = do + let msg0 = "MakeRR2 (String -> String)" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right f -> mkNode opts (PresentT (RR2 f)) [msg0] [hh pp] + +-- | A replacement function ([String] -> String) which yields the groups +-- Used by 'RH.sub' and 'RH.gsub' +-- +-- Requires "Text.Show.Functions" +-- +-- >>> :m + Text.Show.Functions +-- >>> pl @(ReplaceAll "^(\\d+)\\.(\\d+)\\.(\\d+)\\.(\\d+)$" (MakeRR3 (Fst Id)) (Snd Id)) (\ys -> intercalate " | " $ map (show . succ . read @Int) ys, "141.201.1.22") +-- Present "142 | 202 | 2 | 23" +-- PresentT "142 | 202 | 2 | 23" +-- +data MakeRR3 p + +instance (PP p x ~ ([String] -> String) + , P p x) => P (MakeRR3 p) x where + type PP (MakeRR3 p) x = RR + eval _ opts x = do + let msg0 = "MakeRR3 ([String] -> String)" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right f -> mkNode opts (PresentT (RR3 f)) [msg0] [hh pp] + +instance (GetBool b + , GetROpts rs + , PP p x ~ String + , PP q x ~ RR + , PP r x ~ String + , P p x + , P q x + , P r x + ) => P (ReplaceImpl b rs p q r) x where + type PP (ReplaceImpl b rs p q r) x = String + eval _ opts x = do + let msg0 = "Replace" <> (if alle then "All" else "One") <> (if null rs then "' " <> show rs else "") + rs = getROpts @rs + alle = getBool @b + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> + let msg1 = msg0 <> " (" <> p <> ")" + hhs = [hh pp, hh qq] + in case compileRegex @rs opts msg1 p hhs of + Left tta -> pure tta + Right regex -> do + rr <- eval (Proxy @r) opts x + pure $ case getValueLR opts msg0 rr hhs of + Left e -> e + Right r -> + let ret :: String + ret = case q of + RR s -> (if alle then RH.gsub else RH.sub) regex s r + RR1 s -> (if alle then RH.gsub else RH.sub) regex s r + RR2 s -> (if alle then RH.gsub else RH.sub) regex s r + RR3 s -> (if alle then RH.gsub else RH.sub) regex s r + in mkNode opts (PresentT ret) [msg1 <> showLit0 opts " " r <> showLit1 opts " | " ret] (hhs <> [hh rr]) + +-- | a predicate for determining if a string 'Data.Text.IsText' belongs to the given character set +-- +-- >>> pl @IsLower "abc" +-- True +-- TrueT +-- +-- >>> pl @IsLower "abcX" +-- False +-- FalseT +-- +-- >>> pl @IsLower (T.pack "abcX") +-- False +-- FalseT +-- +-- >>> pl @IsHexDigit "01efA" +-- True +-- TrueT +-- +-- >>> pl @IsHexDigit "01egfA" +-- False +-- FalseT +-- +data IsCharSet (cs :: CharSet) + +data CharSet = CLower + | CUpper + | CNumber + | CSpace + | CPunctuation + | CControl + | CHexDigit + | COctDigit + | CSeparator + | CLatin1 + deriving Show + +class GetCharSet (cs :: CharSet) where + getCharSet :: (CharSet, Char -> Bool) +instance GetCharSet 'CLower where + getCharSet = (CLower, isLower) +instance GetCharSet 'CUpper where + getCharSet = (CUpper, isUpper) +instance GetCharSet 'CNumber where + getCharSet = (CNumber, isNumber) +instance GetCharSet 'CPunctuation where + getCharSet = (CPunctuation, isPunctuation) +instance GetCharSet 'CControl where + getCharSet = (CControl, isControl) +instance GetCharSet 'CHexDigit where + getCharSet = (CHexDigit, isHexDigit) +instance GetCharSet 'COctDigit where + getCharSet = (COctDigit, isOctDigit) +instance GetCharSet 'CSeparator where + getCharSet = (CSeparator, isSeparator) +instance GetCharSet 'CLatin1 where + getCharSet = (CLatin1, isLatin1) + +-- | predicate for determining if a string is all lowercase +-- >>> pl @IsLower "abcdef213" +-- False +-- FalseT +-- +-- >>> pl @IsLower "abcdef" +-- True +-- TrueT +-- +-- >>> pl @IsLower "" +-- True +-- TrueT +-- +-- >>> pl @IsLower "abcdefG" +-- False +-- FalseT +-- +type IsLower = IsCharSet 'CLower +type IsUpper = IsCharSet 'CUpper +-- | predicate for determining if the string is all digits +-- >>> pl @IsNumber "213G" +-- False +-- FalseT +-- +-- >>> pl @IsNumber "929" +-- True +-- TrueT +-- +type IsNumber = IsCharSet 'CNumber +type IsSpace = IsCharSet 'CSpace +type IsPunctuation = IsCharSet 'CPunctuation +type IsControl = IsCharSet 'CControl +type IsHexDigit = IsCharSet 'CHexDigit +type IsOctDigit = IsCharSet 'COctDigit +type IsSeparator = IsCharSet 'CSeparator +type IsLatin1 = IsCharSet 'CLatin1 + +instance (GetCharSet cs + , Show a + , TL.IsText a + ) => P (IsCharSet cs) a where + type PP (IsCharSet cs) a = Bool + eval _ opts as = + let b = allOf TL.text f as + msg0 = "IsCharSet " ++ show cs + (cs,f) = getCharSet @cs + in pure $ mkNodeB opts b [msg0 <> show1 opts " | " as] [] + + +-- | converts a string 'Data.Text.Lens.IsText' value to lower case +-- +-- >>> pl @ToLower "HeLlO wOrld!" +-- Present "hello world!" +-- PresentT "hello world!" +-- +data ToLower + +instance (Show a, TL.IsText a) => P ToLower a where + type PP ToLower a = a + eval _ opts as = + let msg0 = "ToLower" + xs = as & TL.text %~ toLower + in pure $ mkNode opts (PresentT xs) [show01 opts msg0 xs as] [] + +-- | converts a string 'Data.Text.Lens.IsText' value to upper case +-- +-- >>> pl @ToUpper "HeLlO wOrld!" +-- Present "HELLO WORLD!" +-- PresentT "HELLO WORLD!" +-- +data ToUpper + +instance (Show a, TL.IsText a) => P ToUpper a where + type PP ToUpper a = a + eval _ opts as = + let msg0 = "ToUpper" + xs = as & TL.text %~ toUpper + in pure $ mkNode opts (PresentT xs) [show01 opts msg0 xs as] [] + + +-- | similar to 'Data.List.inits' +-- +-- >>> pl @Inits [4,8,3,9] +-- Present [[],[4],[4,8],[4,8,3],[4,8,3,9]] +-- PresentT [[],[4],[4,8],[4,8,3],[4,8,3,9]] +-- +-- >>> pl @Inits [] +-- Present [[]] +-- PresentT [[]] +-- +data Inits + +instance Show a => P Inits [a] where + type PP Inits [a] = [[a]] + eval _ opts as = + let msg0 = "Inits" + xs = inits as + in pure $ mkNode opts (PresentT xs) [show01 opts msg0 xs as] [] + +-- | similar to 'Data.List.tails' +-- +-- >>> pl @Tails [4,8,3,9] +-- Present [[4,8,3,9],[8,3,9],[3,9],[9],[]] +-- PresentT [[4,8,3,9],[8,3,9],[3,9],[9],[]] +-- +-- >>> pl @Tails [] +-- Present [[]] +-- PresentT [[]] +-- +data Tails + +instance Show a => P Tails [a] where + type PP Tails [a] = [[a]] + eval _ opts as = + let msg0 = "Tails" + xs = tails as + in pure $ mkNode opts (PresentT xs) [show01 opts msg0 xs as] [] + +-- | split a list into single values +-- +-- >>> pl @(Ones Id) [4,8,3,9] +-- Present [[4],[8],[3],[9]] +-- PresentT [[4],[8],[3],[9]] +-- +-- >>> pl @(Ones Id) [] +-- Present [] +-- PresentT [] +-- +data Ones p + +instance ( PP p x ~ [a] + , P p x + , Show a + ) => P (Ones p) x where + type PP (Ones p) x = [PP p x] + eval _ opts x = do + let msg0 = "Ones" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = map (:[]) p + in mkNode opts (PresentT d) [show01 opts msg0 d p] [hh pp] + +-- | similar to 'show' +-- +-- >>> pl @(ShowP Id) [4,8,3,9] +-- Present "[4,8,3,9]" +-- PresentT "[4,8,3,9]" +-- +-- >>> pl @(ShowP Id) 'x' +-- Present "'x'" +-- PresentT "'x'" +-- +-- >>> pl @(ShowP (42 %- 10)) 'x' +-- Present "(-21) % 5" +-- PresentT "(-21) % 5" +-- +data ShowP p + +instance (Show (PP p x), P p x) => P (ShowP p) x where + type PP (ShowP p) x = String + eval _ opts x = do + let msg0 = "ShowP" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = show p + in mkNode opts (PresentT d) [msg0 <> showLit0 opts " " d <> show1 opts " | " p] [hh pp] + +-- | type level expression representing a formatted time +-- similar to 'Data.Time.formatTime' using a type level 'Symbol' to get the formatting string +-- +-- >>> pl @(FormatTimeP "%F %T" Id) (read "2019-05-24 05:19:59" :: LocalTime) +-- Present "2019-05-24 05:19:59" +-- PresentT "2019-05-24 05:19:59" +-- +-- >>> pl @(FormatTimeP (Fst Id) (Snd Id)) ("the date is %d/%m/%Y", read "2019-05-24" :: Day) +-- Present "the date is 24/05/2019" +-- PresentT "the date is 24/05/2019" +-- +data FormatTimeP p q + +instance (PP p x ~ String + , FormatTime (PP q x) + , P p x + , Show (PP q x) + , P q x + ) => P (FormatTimeP p q) x where + type PP (FormatTimeP p q) x = String + eval _ opts x = do + let msg0 = "FormatTimeP" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let msg1 = msg0 <> " (" <> p <> ")" + b = formatTime defaultTimeLocale p q + in mkNode opts (PresentT b) [msg1 <> showLit0 opts " " b <> show1 opts " | " q] [hh pp, hh qq] + +-- | similar to 'Data.Time.parseTimeM' where \'t\' is the 'Data.Time.ParseTime' type, \'p\' is the datetime format and \'q\' points to the content to parse +-- +-- >>> pl @(ParseTimeP LocalTime "%F %T" Id) "2019-05-24 05:19:59" +-- Present 2019-05-24 05:19:59 +-- PresentT 2019-05-24 05:19:59 +-- +-- >>> pl @(ParseTimeP LocalTime "%F %T" "2019-05-24 05:19:59") (Right "never used") +-- Present 2019-05-24 05:19:59 +-- PresentT 2019-05-24 05:19:59 +-- +-- keeping \'q\' as we might want to extract from a tuple +data ParseTimeP' t p q +type ParseTimeP (t :: Type) p q = ParseTimeP' (Hole t) p q + +instance (ParseTime (PP t a) + , Typeable (PP t a) + , Show (PP t a) + , P p a + , P q a + , PP p a ~ String + , PP q a ~ String + ) => P (ParseTimeP' t p q) a where + type PP (ParseTimeP' t p q) a = PP t a + eval _ opts a = do + let msg0 = "ParseTimeP " <> t + t = showT @(PP t a) + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let msg1 = msg0 <> " (" <> p <> ")" + hhs = [hh pp, hh qq] + in case parseTimeM @Maybe @(PP t a) True defaultTimeLocale p q of + Just b -> mkNode opts (PresentT b) [lit01' opts msg1 b "fmt=" p <> show1 opts " | " q] hhs + Nothing -> mkNode opts (FailT (msg1 <> " failed to parse")) [msg1 <> " failed"] hhs + +-- | A convenience method to match against many different datetime formats to find a match +-- +-- >>> pl @(ParseTimes LocalTime '["%Y-%m-%d %H:%M:%S", "%m/%d/%y %H:%M:%S", "%B %d %Y %H:%M:%S", "%Y-%m-%dT%H:%M:%S"] "03/11/19 01:22:33") () +-- Present 2019-03-11 01:22:33 +-- PresentT 2019-03-11 01:22:33 +-- +-- >>> pl @(ParseTimes LocalTime (Fst Id) (Snd Id)) (["%Y-%m-%d %H:%M:%S", "%m/%d/%y %H:%M:%S", "%B %d %Y %H:%M:%S", "%Y-%m-%dT%H:%M:%S"], "03/11/19 01:22:33") +-- Present 2019-03-11 01:22:33 +-- PresentT 2019-03-11 01:22:33 +-- +data ParseTimes' t p q +type ParseTimes (t :: Type) p q = ParseTimes' (Hole t) p q + +instance (ParseTime (PP t a) + , Typeable (PP t a) + , Show (PP t a) + , P p a + , P q a + , PP p a ~ [String] + , PP q a ~ String + ) => P (ParseTimes' t p q) a where + type PP (ParseTimes' t p q) a = PP t a + eval _ opts a = do + let msg0 = "ParseTimes " <> t + t = showT @(PP t a) + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let msg1 = msg0 + hhs = [hh pp, hh qq] + zs = map (\d -> (d,) <$> parseTimeM @Maybe @(PP t a) True defaultTimeLocale d q) p + in case catMaybes zs of + [] -> mkNode opts (FailT ("no match on [" ++ q ++ "]")) [msg1 <> " no match"] hhs + (d,b):_ -> mkNode opts (PresentT b) [lit01' opts msg1 b "fmt=" d <> show1 opts " | " q] hhs + +-- | create a 'Day' from three int values passed in as year month and day +-- +-- >>> pl @MkDay (2019,12,30) +-- Present Just (2019-12-30,1,1) +-- PresentT (Just (2019-12-30,1,1)) +-- +-- >>> pl @(MkDay' (Fst Id) (Snd Id) (Thd Id)) (2019,99,99999) +-- Present Nothing +-- PresentT Nothing +-- +-- >>> pl @MkDay (1999,3,13) +-- Present Just (1999-03-13,10,6) +-- PresentT (Just (1999-03-13,10,6)) +-- +data MkDay' p q r +type MkDay = MkDay' (Fst Id) (Snd Id) (Thd Id) + +instance (P p x + , P q x + , P r x + , PP p x ~ Int + , PP q x ~ Int + , PP r x ~ Int + ) => P (MkDay' p q r) x where + type PP (MkDay' p q r) x = Maybe (Day, Int, Int) + eval _ opts x = do + let msg0 = "MkDay" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> do + let hhs = [hh pp, hh qq] + rr <- eval (Proxy @r) opts x + pure $ case getValueLR opts msg0 rr hhs of + Left e -> e + Right r -> + let mday = fromGregorianValid (fromIntegral p) q r + b = mday <&> \day -> + let (_, week, dow) = toWeekDate day + in (day, week, dow) + in mkNode opts (PresentT b) [show01' opts msg0 b "(y,m,d)=" (p,q,r)] (hhs <> [hh rr]) + +-- | uncreate a 'Day' returning year month and day +-- +-- >>> pl @(UnMkDay Id) (read "2019-12-30") +-- Present (2019,12,30) +-- PresentT (2019,12,30) +-- +data UnMkDay p + +instance (PP p x ~ Day, P p x) => P (UnMkDay p) x where + type PP (UnMkDay p) x = (Int, Int, Int) + eval _ opts x = do + let msg0 = "UnMkDay" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let (fromIntegral -> y, m, d) = toGregorian p + b = (y, m, d) + in mkNode opts (PresentT b) [show01 opts msg0 b p] [] + +-- | uses the 'Read' of the given type \'t\' and \'p\' which points to the content to read +-- +-- >>> pl @(ReadP Rational) "4 % 5" +-- Present 4 % 5 +-- PresentT (4 % 5) +-- +-- >>> pl @(ReadP' Day Id >> Between (ReadP' Day "2017-04-11") (ReadP' Day "2018-12-30")) "2018-10-12" +-- True +-- TrueT +-- +-- >>> pl @(ReadP' Day Id >> Between (ReadP' Day "2017-04-11") (ReadP' Day "2018-12-30")) "2016-10-12" +-- False +-- FalseT +-- +data ReadP'' t p +type ReadP (t :: Type) = ReadP'' (Hole t) Id +type ReadP' (t :: Type) p = ReadP'' (Hole t) p + +instance (P p x + , PP p x ~ String + , Typeable (PP t x) + , Show (PP t x) + , Read (PP t x) + ) => P (ReadP'' t p) x where + type PP (ReadP'' t p) x = PP t x + eval _ opts x = do + let msg0 = "ReadP " <> t + t = showT @(PP t x) + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right s -> + let msg1 = msg0 <> " (" <> s <> ")" + in case reads @(PP t x) s of + [(b,"")] -> mkNode opts (PresentT b) [lit01 opts msg1 b s] [hh pp] + _ -> mkNode opts (FailT (msg1 <> " failed")) [msg1 <> " failed"] [hh pp] + +-- | similar to 'sum' +-- +-- >>> pl @Sum [10,4,5,12,3,4] +-- Present 38 +-- PresentT 38 +-- +-- >>> pl @Sum [] +-- Present 0 +-- PresentT 0 +-- +data Sum + +instance (Num a, Show a) => P Sum [a] where + type PP Sum [a] = a + eval _ opts as = + let msg0 = "Sum" + v = sum as + in pure $ mkNode opts (PresentT v) [show01 opts msg0 v as] [] + +-- | similar to 'minimum' +-- +-- >>> pl @Min [10,4,5,12,3,4] +-- Present 3 +-- PresentT 3 +-- +-- >>> pl @Min [] +-- Error empty list +-- FailT "empty list" +-- +data Min + +instance (Ord a, Show a) => P Min [a] where + type PP Min [a] = a + eval _ opts as' = do + let msg0 = "Min" + pure $ case as' of + [] -> mkNode opts (FailT "empty list") [msg0 <> "(empty list)"] [] + as@(_:_) -> + let v = minimum as + in mkNode opts (PresentT v) [show01 opts msg0 v as] [] + +-- | similar to 'maximum' +-- +-- >>> pl @Max [10,4,5,12,3,4] +-- Present 12 +-- PresentT 12 +-- +-- >>> pl @Max [] +-- Error empty list +-- FailT "empty list" +-- + +data Max +--type Max' t = FoldMap (SG.Max t) Id + +instance (Ord a, Show a) => P Max [a] where + type PP Max [a] = a + eval _ opts as' = do + let msg0 = "Max" + pure $ case as' of + [] -> mkNode opts (FailT "empty list") [msg0 <> "(empty list)"] [] + as@(_:_) -> + let v = maximum as + in mkNode opts (PresentT v) [show01 opts msg0 v as] [] + +-- | sort a list +-- +-- >>> pl @(SortOn (Fst Id) Id) [(10,"abc"), (3,"def"), (4,"gg"), (10,"xyz"), (1,"z")] +-- Present [(1,"z"),(3,"def"),(4,"gg"),(10,"abc"),(10,"xyz")] +-- PresentT [(1,"z"),(3,"def"),(4,"gg"),(10,"abc"),(10,"xyz")] +-- +-- >>> pl @(SortBy (OrdP (Snd Id) (Fst Id)) Id) [(10,"ab"),(4,"x"),(20,"bbb")] +-- Present [(20,"bbb"),(10,"ab"),(4,"x")] +-- PresentT [(20,"bbb"),(10,"ab"),(4,"x")] +-- +-- >>> pl @(SortBy 'LT Id) [1,5,2,4,7,0] +-- Present [1,5,2,4,7,0] +-- PresentT [1,5,2,4,7,0] +-- +-- >>> pl @(SortBy 'GT Id) [1,5,2,4,7,0] +-- Present [0,7,4,2,5,1] +-- PresentT [0,7,4,2,5,1] +-- +-- >>> pl @(SortBy ((Fst (Fst Id) ==! Fst (Snd Id)) <> (Snd (Fst Id) ==! Snd (Snd Id))) Id) [(10,"ab"),(4,"x"),(20,"bbb"),(4,"a"),(4,"y")] +-- Present [(4,"a"),(4,"x"),(4,"y"),(10,"ab"),(20,"bbb")] +-- PresentT [(4,"a"),(4,"x"),(4,"y"),(10,"ab"),(20,"bbb")] +-- +-- >>> pl @(SortBy ((Fst (Fst Id) ==! Fst (Snd Id)) <> (Snd (Snd Id) ==! Snd (Fst Id))) Id) [(10,"ab"),(4,"x"),(20,"bbb"),(4,"a"),(4,"y")] +-- Present [(4,"y"),(4,"x"),(4,"a"),(10,"ab"),(20,"bbb")] +-- PresentT [(4,"y"),(4,"x"),(4,"a"),(10,"ab"),(20,"bbb")] +-- +data SortBy p q +type SortOn p q = SortBy (OrdA p) q +type SortOnDesc p q = SortBy (Swap >> OrdA p) q + +type SortByHelper p = Partition (p == 'GT) Id + +instance (P p (a,a) + , P q x + , Show a + , PP q x ~ [a] + , PP p (a,a) ~ Ordering + ) => P (SortBy p q) x where + type PP (SortBy p q) x = PP q x + eval _ opts x = do + let msg0 = "SortBy" + qq <- eval (Proxy @q) opts x + case getValueLR opts (msg0 <> " q failed") qq [] of + Left e -> pure e + Right as -> do + let ff :: MonadEval m => [a] -> m (TT [a]) + ff = \case + [] -> pure $ mkNode opts (PresentT mempty) [msg0 <> " empty"] [] + [w] -> pure $ mkNode opts (PresentT [w]) [msg0 <> " one element " <> show w] [] + w:ys@(_:_) -> do + pp <- (if oDebug opts >= 3 then + eval (Proxy @(SortByHelper p)) + else eval (Proxy @(Hide (SortByHelper p)))) opts (map (w,) ys) +-- pp <- eval (Proxy @(Hide (Partition (p >> Id == 'GT) Id))) opts (map (w,) ys) +-- too much output: dont need (Map (Snd Id) *** Map (Snd Id)) -- just do map snd in code +-- pp <- eval (Proxy @(Partition (p >> (Id == 'GT)) Id >> (Map (Snd Id) *** Map (Snd Id)))) opts (map (w,) ys) + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right (ll', rr') -> do + lhs <- ff (map snd ll') + case getValueLR opts msg0 lhs [] of + Left _ -> pure lhs -- dont rewrap + Right ll -> do + rhs <- ff (map snd rr') + case getValueLR opts msg0 rhs [] of + Left _ -> pure rhs + Right rr -> do + pure $ mkNode opts (PresentT (ll ++ w : rr)) + [msg0 <> show0 opts " lhs=" ll <> " pivot " <> show w <> show0 opts " rhs=" rr] + (hh pp : [hh lhs | length ll > 1] ++ [hh rhs | length rr > 1]) + ret <- ff as + pure $ case getValueLR opts msg0 ret [hh qq] of + Left _e -> ret -- dont rewrap the error + Right xs -> mkNode opts (_tBool ret) [msg0 <> show0 opts " " xs] [hh qq, hh ret] + +-- | similar to 'length' +-- +-- >>> pl @Len [10,4,5,12,3,4] +-- Present 6 +-- PresentT 6 +-- +-- >>> pl @Len [] +-- Present 0 +-- PresentT 0 +-- +data Len +instance (Show a, as ~ [a]) => P Len as where + type PP Len as = Int + eval _ opts as = + let msg0 = "Len" + n = length as + in pure $ mkNode opts (PresentT n) [show01 opts msg0 n as] [] + +-- | similar to 'length' for 'Foldable' instances +-- +-- >>> pl @(Length Id) (Left "aa") +-- Present 0 +-- PresentT 0 +-- +-- >>> pl @(Length Id) (Right "aa") +-- Present 1 +-- PresentT 1 +-- +-- >>> pl @(Length (Right' Id)) (Right "abcd") +-- Present 4 +-- PresentT 4 +-- +-- >>> pl @(Length (Thd (Snd Id))) (True,(23,'x',[10,9,1,3,4,2])) +-- Present 6 +-- PresentT 6 +-- +data Length p + +instance (PP p x ~ t a + , P p x + , Show (t a) + , Foldable t) => P (Length p) x where + type PP (Length p) x = Int + eval _ opts x = do + let msg0 = "Length" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right as -> + let n = length as + in mkNode opts (PresentT n) [show01 opts msg0 n as] [] + +-- | similar to 'fst' +-- +-- >>> pl @(Fst Id) (10,"Abc") +-- Present 10 +-- PresentT 10 +-- +-- >>> pl @(Fst Id) (10,"Abc",'x') +-- Present 10 +-- PresentT 10 +-- +-- >>> pl @(Fst Id) (10,"Abc",'x',False) +-- Present 10 +-- PresentT 10 +-- +data Fst p +type L1 p = Fst p + +instance (Show (ExtractL1T (PP p x)) + , ExtractL1C (PP p x) + , P p x + , Show (PP p x) + ) => P (Fst p) x where + type PP (Fst p) x = ExtractL1T (PP p x) + eval _ opts x = do + let msg0 = "Fst" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = extractL1C p + in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] + +class ExtractL1C tp where + type ExtractL1T tp + extractL1C :: tp -> ExtractL1T tp +instance ExtractL1C (a,b) where + type ExtractL1T (a,b) = a + extractL1C (a,_) = a +instance ExtractL1C (a,b,c) where + type ExtractL1T (a,b,c) = a + extractL1C (a,_,_) = a +instance ExtractL1C (a,b,c,d) where + type ExtractL1T (a,b,c,d) = a + extractL1C (a,_,_,_) = a +instance ExtractL1C (a,b,c,d,e) where + type ExtractL1T (a,b,c,d,e) = a + extractL1C (a,_,_,_,_) = a +instance ExtractL1C (a,b,c,d,e,f) where + type ExtractL1T (a,b,c,d,e,f) = a + extractL1C (a,_,_,_,_,_) = a + +-- | similar to 'snd' +-- +-- >>> pl @(Snd Id) (10,"Abc") +-- Present "Abc" +-- PresentT "Abc" +-- +-- >>> pl @(Snd Id) (10,"Abc",True) +-- Present "Abc" +-- PresentT "Abc" +-- +data Snd p +type L2 p = Snd p + +instance (Show (ExtractL2T (PP p x)) + , ExtractL2C (PP p x) + , P p x + , Show (PP p x) + ) => P (Snd p) x where + type PP (Snd p) x = ExtractL2T (PP p x) + eval _ opts x = do + let msg0 = "Snd" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = extractL2C p + in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] + +class ExtractL2C tp where + type ExtractL2T tp + extractL2C :: tp -> ExtractL2T tp +instance ExtractL2C (a,b) where + type ExtractL2T (a,b) = b + extractL2C (_,b) = b +instance ExtractL2C (a,b,c) where + type ExtractL2T (a,b,c) = b + extractL2C (_,b,_) = b +instance ExtractL2C (a,b,c,d) where + type ExtractL2T (a,b,c,d) = b + extractL2C (_,b,_,_) = b +instance ExtractL2C (a,b,c,d,e) where + type ExtractL2T (a,b,c,d,e) = b + extractL2C (_,b,_,_,_) = b +instance ExtractL2C (a,b,c,d,e,f) where + type ExtractL2T (a,b,c,d,e,f) = b + extractL2C (_,b,_,_,_,_) = b + +-- | similar to 3rd element in a n-tuple +-- +-- >>> pl @(Thd Id) (10,"Abc",133) +-- Present 133 +-- PresentT 133 +-- +-- >>> pl @(Thd Id) (10,"Abc",133,True) +-- Present 133 +-- PresentT 133 +-- +data Thd p +type L3 p = Thd p + +instance (Show (ExtractL3T (PP p x)) + , ExtractL3C (PP p x) + , P p x + , Show (PP p x) + ) => P (Thd p) x where + type PP (Thd p) x = ExtractL3T (PP p x) + eval _ opts x = do + let msg0 = "Thd" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = extractL3C p + in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] + +class ExtractL3C tp where + type ExtractL3T tp + extractL3C :: tp -> ExtractL3T tp +instance ExtractL3C (a,b) where + type ExtractL3T (a,b) = GL.TypeError ('GL.Text "Thd doesn't work for 2-tuples") + extractL3C _ = error "Thd doesn't work for 2-tuples" +instance ExtractL3C (a,b,c) where + type ExtractL3T (a,b,c) = c + extractL3C (_,_,c) = c +instance ExtractL3C (a,b,c,d) where + type ExtractL3T (a,b,c,d) = c + extractL3C (_,_,c,_) = c +instance ExtractL3C (a,b,c,d,e) where + type ExtractL3T (a,b,c,d,e) = c + extractL3C (_,_,c,_,_) = c +instance ExtractL3C (a,b,c,d,e,f) where + type ExtractL3T (a,b,c,d,e,f) = c + extractL3C (_,_,c,_,_,_) = c + +-- | similar to 4th element in a n-tuple +-- +-- >>> pl @(L4 Id) (10,"Abc",'x',True) +-- Present True +-- PresentT True +-- +-- >>> pl @(L4 (Fst (Snd Id))) ('x',((10,"Abc",'x',999),"aa",1),9) +-- Present 999 +-- PresentT 999 +-- +data L4 p + +instance (Show (ExtractL4T (PP p x)) + , ExtractL4C (PP p x) + , P p x + , Show (PP p x) + ) => P (L4 p) x where + type PP (L4 p) x = ExtractL4T (PP p x) + eval _ opts x = do + let msg0 = "L4" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = extractL4C p + in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] + +class ExtractL4C tp where + type ExtractL4T tp + extractL4C :: tp -> ExtractL4T tp +instance ExtractL4C (a,b) where + type ExtractL4T (a,b) = GL.TypeError ('GL.Text "L4 doesn't work for 2-tuples") + extractL4C _ = error "L4 doesn't work for 2-tuples" +instance ExtractL4C (a,b,c) where + type ExtractL4T (a,b,c) = GL.TypeError ('GL.Text "L4 doesn't work for 3-tuples") + extractL4C _ = error "L4 doesn't work for 3-tuples" +instance ExtractL4C (a,b,c,d) where + type ExtractL4T (a,b,c,d) = d + extractL4C (_,_,_,d) = d +instance ExtractL4C (a,b,c,d,e) where + type ExtractL4T (a,b,c,d,e) = d + extractL4C (_,_,_,d,_) = d +instance ExtractL4C (a,b,c,d,e,f) where + type ExtractL4T (a,b,c,d,e,f) = d + extractL4C (_,_,_,d,_,_) = d + +-- | similar to 5th element in a n-tuple +-- +-- >>> pl @(L5 Id) (10,"Abc",'x',True,1) +-- Present 1 +-- PresentT 1 +-- +data L5 p + +instance (Show (ExtractL5T (PP p x)) + , ExtractL5C (PP p x) + , P p x + , Show (PP p x) + ) => P (L5 p) x where + type PP (L5 p) x = ExtractL5T (PP p x) + eval _ opts x = do + let msg0 = "L5" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = extractL5C p + in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] + +class ExtractL5C tp where + type ExtractL5T tp + extractL5C :: tp -> ExtractL5T tp +instance ExtractL5C (a,b) where + type ExtractL5T (a,b) = GL.TypeError ('GL.Text "L5 doesn't work for 2-tuples") + extractL5C _ = error "L5 doesn't work for 2-tuples" +instance ExtractL5C (a,b,c) where + type ExtractL5T (a,b,c) = GL.TypeError ('GL.Text "L5 doesn't work for 3-tuples") + extractL5C _ = error "L5 doesn't work for 3-tuples" +instance ExtractL5C (a,b,c,d) where + type ExtractL5T (a,b,c,d) = GL.TypeError ('GL.Text "L5 doesn't work for 4-tuples") + extractL5C _ = error "L5 doesn't work for 4-tuples" +instance ExtractL5C (a,b,c,d,e) where + type ExtractL5T (a,b,c,d,e) = e + extractL5C (_,_,_,_,e) = e +instance ExtractL5C (a,b,c,d,e,f) where + type ExtractL5T (a,b,c,d,e,f) = e + extractL5C (_,_,_,_,e,_) = e + + +-- | similar to 6th element in a n-tuple +-- +-- >>> pl @(L6 Id) (10,"Abc",'x',True,1,99) +-- Present 99 +-- PresentT 99 +-- +data L6 p + +instance (Show (ExtractL6T (PP p x)) + , ExtractL6C (PP p x) + , P p x + , Show (PP p x) + ) => P (L6 p) x where + type PP (L6 p) x = ExtractL6T (PP p x) + eval _ opts x = do + let msg0 = "L6" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = extractL6C p + in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] + +class ExtractL6C tp where + type ExtractL6T tp + extractL6C :: tp -> ExtractL6T tp +instance ExtractL6C (a,b) where + type ExtractL6T (a,b) = GL.TypeError ('GL.Text "L6 doesn't work for 2-tuples") + extractL6C _ = error "L6 doesn't work for 2-tuples" +instance ExtractL6C (a,b,c) where + type ExtractL6T (a,b,c) = GL.TypeError ('GL.Text "L6 doesn't work for 3-tuples") + extractL6C _ = error "L6 doesn't work for 3-tuples" +instance ExtractL6C (a,b,c,d) where + type ExtractL6T (a,b,c,d) = GL.TypeError ('GL.Text "L6 doesn't work for 4-tuples") + extractL6C _ = error "L6 doesn't work for 4-tuples" +instance ExtractL6C (a,b,c,d,e) where + type ExtractL6T (a,b,c,d,e) = GL.TypeError ('GL.Text "L6 doesn't work for 5-tuples") + extractL6C _ = error "L6 doesn't work for 5-tuples" +instance ExtractL6C (a,b,c,d,e,f) where + type ExtractL6T (a,b,c,d,e,f) = f + extractL6C (_,_,_,_,_,f) = f + + +-- | 'fromString' function where you need to provide the type \'t\' of the result +-- +-- >>> pl @(FromStringP (Identity _) Id) "abc" +-- Present Identity "abc" +-- PresentT (Identity "abc") +-- +-- >>> pl @(FromStringP (Seq.Seq _) Id) "abc" +-- Present fromList "abc" +-- PresentT (fromList "abc") +data FromStringP' t s +type FromStringP (t :: Type) p = FromStringP' (Hole t) p + +instance (P s a + , PP s a ~ String + , Show (PP t a) + , IsString (PP t a) + ) => P (FromStringP' t s) a where + type PP (FromStringP' t s) a = PP t a + eval _ opts a = do + let msg0 = "FromStringP" + ss <- eval (Proxy @s) opts a + pure $ case getValueLR opts msg0 ss [] of + Left e -> e + Right s -> + let b = fromString @(PP t a) s + in mkNode opts (PresentT b) [msg0 <> show0 opts " " b] [hh ss] + + +-- | 'fromInteger' function where you need to provide the type \'t\' of the result +-- +-- >>> pl @(FromInteger (SG.Sum _) Id) 23 +-- Present Sum {getSum = 23} +-- PresentT (Sum {getSum = 23}) +-- +-- >>> pl @(FromInteger Rational 44) 12 +-- Present 44 % 1 +-- PresentT (44 % 1) +-- +-- >>> pl @(FromInteger Rational Id) 12 +-- Present 12 % 1 +-- PresentT (12 % 1) +-- +data FromInteger' t n +type FromInteger (t :: Type) p = FromInteger' (Hole t) p +--type FromIntegerP n = FromInteger' Unproxy n + +instance (Num (PP t a) + , Integral (PP n a) + , P n a + , Show (PP t a) + ) => P (FromInteger' t n) a where + type PP (FromInteger' t n) a = PP t a + eval _ opts a = do + let msg0 = "FromInteger" + nn <- eval (Proxy @n) opts a + pure $ case getValueLR opts msg0 nn [] of + Left e -> e + Right n -> + let b = fromInteger (fromIntegral n) + in mkNode opts (PresentT b) [msg0 <> show0 opts " " b] [hh nn] + +-- | 'fromIntegral' function where you need to provide the type \'t\' of the result +-- +-- >>> pl @(FromIntegral (SG.Sum _) Id) 23 +-- Present Sum {getSum = 23} +-- PresentT (Sum {getSum = 23}) +data FromIntegral' t n +type FromIntegral (t :: Type) p = FromIntegral' (Hole t) p + +instance (Num (PP t a) + , Integral (PP n a) + , P n a + , Show (PP t a) + , Show (PP n a) + ) => P (FromIntegral' t n) a where + type PP (FromIntegral' t n) a = PP t a + eval _ opts a = do + let msg0 = "FromIntegral" + nn <- eval (Proxy @n) opts a + pure $ case getValueLR opts msg0 nn [] of + Left e -> e + Right n -> + let b = fromIntegral n + in mkNode opts (PresentT b) [show01 opts msg0 b n] [hh nn] + +-- | 'toRational' function +-- +-- >>> pl @(ToRational Id) 23.5 +-- Present 47 % 2 +-- PresentT (47 % 2) + +data ToRational p + +instance (a ~ PP p x + , Show a + , Real a + , P p x) + => P (ToRational p) x where + type PP (ToRational p) x = Rational + eval _ opts x = do + let msg0 = "ToRational" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right a -> + let r = (toRational a) + in mkNode opts (PresentT r) [show01 opts msg0 r a] [hh pp] + +-- | 'fromRational' function where you need to provide the type \'t\' of the result +-- +-- >>> pl @(FromRational Rational Id) 23.5 +-- Present 47 % 2 +-- PresentT (47 % 2) +data FromRational' t r +type FromRational (t :: Type) p = FromRational' (Hole t) p + +instance (P r a + , PP r a ~ Rational + , Show (PP t a) + , Fractional (PP t a) + ) => P (FromRational' t r) a where + type PP (FromRational' t r) a = PP t a + eval _ opts a = do + let msg0 = "FromRational" + rr <- eval (Proxy @r) opts a + pure $ case getValueLR opts msg0 rr [] of + Left e -> e + Right r -> + let b = fromRational @(PP t a) r + in mkNode opts (PresentT b) [show01 opts msg0 b r] [hh rr] + +-- | 'truncate' function where you need to provide the type \'t\' of the result +-- +-- >>> pl @(Truncate Int Id) (23 % 5) +-- Present 4 +-- PresentT 4 +data Truncate' t p +type Truncate (t :: Type) p = Truncate' (Hole t) p + +instance (Show (PP p x) + , P p x + , Show (PP t x) + , RealFrac (PP p x) + , Integral (PP t x) + ) => P (Truncate' t p) x where + type PP (Truncate' t p) x = PP t x + eval _ opts x = do + let msg0 = "Truncate" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = truncate p + in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] + +-- | 'ceiling' function where you need to provide the type \'t\' of the result +-- +-- >>> pl @(Ceiling Int Id) (23 % 5) +-- Present 5 +-- PresentT 5 +data Ceiling' t p +type Ceiling (t :: Type) p = Ceiling' (Hole t) p + +instance (Show (PP p x) + , P p x + , Show (PP t x) + , RealFrac (PP p x) + , Integral (PP t x) + ) => P (Ceiling' t p) x where + type PP (Ceiling' t p) x = PP t x + eval _ opts x = do + let msg0 = "Ceiling" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = ceiling p + in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] + +-- | 'floor' function where you need to provide the type \'t\' of the result +-- +-- >>> pl @(Floor Int Id) (23 % 5) +-- Present 4 +-- PresentT 4 +data Floor' t p +type Floor (t :: Type) p = Floor' (Hole t) p + +instance (Show (PP p x) + , P p x + , Show (PP t x) + , RealFrac (PP p x) + , Integral (PP t x) + ) => P (Floor' t p) x where + type PP (Floor' t p) x = PP t x + eval _ opts x = do + let msg0 = "Floor" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = floor p + in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] + +-- | converts a value to a 'Proxy': the same as '\'Proxy' +-- +-- >>> pl @MkProxy 'x' +-- Present Proxy +-- PresentT Proxy +-- +data MkProxy + +instance Show a => P MkProxy a where + type PP MkProxy a = Proxy a + eval _ opts a = + let msg0 = "MkProxy" + b = Proxy @a + in pure $ mkNode opts (PresentT b) [msg0 <> show1 opts " | " a] [] + +type family DoExpandT (ps :: [k]) :: Type where + DoExpandT '[] = GL.TypeError ('GL.Text "'[] invalid: requires at least one predicate in the list") + DoExpandT '[p] = Id >> p -- need this else fails cos 1 is nat and would mean that the result is nat not Type! + -- if p >> Id then turns TrueT to PresentT True + DoExpandT (p ': p1 ': ps) = p >> DoExpandT (p1 ': ps) + +-- | processes a type level list predicates running each in sequence: see 'Predicate.>>' +-- +-- >>> pl @(Do [Pred Id, ShowP Id, Id &&& Len]) 9876543 +-- Present ("9876542",7) +-- PresentT ("9876542",7) +-- +-- >>> pl @(Do '[W 123, W "xyz", Len &&& Id, Pred Id *** Id<>Id]) () +-- Present (2,"xyzxyz") +-- PresentT (2,"xyzxyz") +-- +data Do (ps :: [k]) +instance (P (DoExpandT ps) a) => P (Do ps) a where + type PP (Do ps) a = PP (DoExpandT ps) a + eval _ = eval (Proxy @(DoExpandT ps)) + +-- | Convenient method to convert a value \'p\' to a 'Maybe' based on a predicate '\b\' +-- if '\b\' then Just \'p'\ else Nothing +-- +-- >>> pl @(MaybeBool (Id > 4) Id) 24 +-- Present Just 24 +-- PresentT (Just 24) +-- +-- >>> pl @(MaybeBool (Id > 4) Id) (-5) +-- Present Nothing +-- PresentT Nothing +-- +data MaybeBool b p + +instance (Show (PP p a) + , P b a + , P p a + , PP b a ~ Bool + ) => P (MaybeBool b p) a where + type PP (MaybeBool b p) a = Maybe (PP p a) + eval _ opts z = do + let msg0 = "MaybeBool" + bb <- evalBool (Proxy @b) opts z + case getValueLR opts (msg0 <> " b failed") bb [] of + Left e -> pure e + Right True -> do + pp <- eval (Proxy @p) opts z + pure $ case getValueLR opts (msg0 <> " p failed") pp [hh bb] of + Left e -> e + Right p -> mkNode opts (PresentT (Just p)) [msg0 <> "(False)" <> show0 opts " Just " p] [hh bb, hh pp] + Right False -> pure $ mkNode opts (PresentT Nothing) [msg0 <> "(True)"] [hh bb] + +-- | Convenient method to convert a \'p\' or '\q'\ to a 'Either' based on a predicate '\b\' +-- if \'b\' then Right \'p\' else Left '\q\' +-- +-- >>> pl @(EitherBool (Fst Id > 4) (Snd Id >> Fst Id) (Snd Id >> Snd Id)) (24,(-1,999)) +-- Present Right 999 +-- PresentT (Right 999) +-- +-- >>> pl @(EitherBool (Fst Id > 4) (Fst (Snd Id)) (Snd (Snd Id))) (1,(-1,999)) +-- Present Left (-1) +-- PresentT (Left (-1)) +-- +data EitherBool b p q + +instance (Show (PP p a) + , P p a + , Show (PP q a) + , P q a + , P b a + , PP b a ~ Bool + ) => P (EitherBool b p q) a where + type PP (EitherBool b p q) a = Either (PP p a) (PP q a) + eval _ opts z = do + let msg0 = "EitherBool" + bb <- evalBool (Proxy @b) opts z + case getValueLR opts (msg0 <> " b failed") bb [] of + Left e -> pure e + Right False -> do + pp <- eval (Proxy @p) opts z + pure $ case getValueLR opts (msg0 <> " p failed") pp [hh bb] of + Left e -> e + Right p -> mkNode opts (PresentT (Left p)) [msg0 <> "(False)" <> show0 opts " Left " p] [hh bb, hh pp] + Right True -> do + qq <- eval (Proxy @q) opts z + pure $ case getValueLR opts (msg0 <> " q failed") qq [hh bb] of + Left e -> e + Right q -> mkNode opts (PresentT (Right q)) [msg0 <> "(True)" <> show0 opts " Right " q] [hh bb, hh qq] + +-- | create inductive tuples from a type level list of predicates +-- +-- >>> pl @(TupleI '[Id,ShowP Id,Pred Id,W "str", W 999]) 666 +-- Present (666,("666",(665,("str",(999,()))))) +-- PresentT (666,("666",(665,("str",(999,()))))) +-- +-- >>> pl @(TupleI '[W 999,W "somestring",W 'True, Id, ShowP (Pred Id)]) 23 +-- Present (999,("somestring",(True,(23,("22",()))))) +-- PresentT (999,("somestring",(True,(23,("22",()))))) +-- +data TupleI (ps :: [k]) -- make it an inductive tuple + +instance P (TupleI ('[] :: [k])) a where + type PP (TupleI ('[] :: [k])) a = () + eval _ opts _ = pure $ mkNode opts (PresentT ()) ["TupleI(done)"] [] + +instance (P p a + , P (TupleI ps) a + , Show a + ) => P (TupleI (p ': ps)) a where + type PP (TupleI (p ': ps)) a = (PP p a, PP (TupleI ps) a) + eval _ opts a = do + pp <- eval (Proxy @p) opts a + let msg0 = "TupleI" -- "'[](" <> show len <> ")" + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right w -> do + qq <- eval (Proxy @(TupleI ps)) opts a + pure $ case getValueLR opts msg0 qq [hh pp] of + Left e -> e + -- only PresentP makes sense here (ie not TrueP/FalseP: ok in base case tho + Right ws -> mkNode opts (PresentT (w,ws)) [msg0 <> show0 opts " " a] [hh pp, hh qq] + +--type Msg' prt p = Msg (Printf "[%s] " prt) p -- msg0 is in square brackets + +-- | pad \'q\' with '\n'\ values from '\p'\ +-- +-- >>> pl @(PadL 5 999 Id) [12,13] +-- Present [999,999,999,12,13] +-- PresentT [999,999,999,12,13] +-- +-- >>> pl @(PadR 5 (Fst Id) '[12,13]) (999,'x') +-- Present [12,13,999,999,999] +-- PresentT [12,13,999,999,999] +-- +-- >>> pl @(PadR 2 (Fst Id) '[12,13,14]) (999,'x') +-- Present [12,13,14] +-- PresentT [12,13,14] +-- +data Pad (left :: Bool) n p q +type PadL n p q = Pad 'True n p q +type PadR n p q = Pad 'False n p q + +instance (P n a + , GetBool left + , Integral (PP n a) + , [PP p a] ~ PP q a + , P p a + , P q a + , Show (PP p a) + ) => P (Pad left n p q) a where + type PP (Pad left n p q) a = PP q a + eval _ opts a = do + let msg0 = "Pad" <> (if lft then "L" else "R") + lft = getBool @left + lr <- runPQ msg0 (Proxy @n) (Proxy @p) opts a + case lr of + Left e -> pure e + Right (fromIntegral -> n,p,nn,pp) -> do + let msg1 = msg0 <> show0 opts " " n <> " pad=" <> show p + hhs = [hh nn, hh pp] + qq <- eval (Proxy @q) opts a + pure $ case getValueLR opts (msg1 <> " q failed") qq hhs of + Left e -> e + Right q -> + let l = length q + diff = if n<=l then 0 else n-l + bs = if lft + then (replicate diff p) <> q + else q <> (replicate diff p) + in mkNode opts (PresentT bs) [show01 opts msg1 bs q] (hhs <> [hh qq]) + +-- | split a list \'p\' into parts using the lengths in the type level list \'ns\' +-- +-- >>> pl @(SplitAts '[2,3,1,1] Id) "hello world" +-- Present ["he","llo"," ","w","orld"] +-- PresentT ["he","llo"," ","w","orld"] +-- +-- >>> pl @(SplitAts '[2] Id) "hello world" +-- Present ["he","llo world"] +-- PresentT ["he","llo world"] +-- +-- >>> pl @(SplitAts '[10,1,1,5] Id) "hello world" +-- Present ["hello worl","d","",""] +-- PresentT ["hello worl","d","",""] +-- +data SplitAts ns p +instance (P ns x + , P p x + , PP p x ~ [a] + , Show n + , Show a + , PP ns x ~ [n] + , Integral n + ) => P (SplitAts ns p) x where + type PP (SplitAts ns p) x = [PP p x] + eval _ opts x = do + let msg0 = "SplitAts" + lr <- runPQ msg0 (Proxy @ns) (Proxy @p) opts x + pure $ case lr of + Left e -> e + Right (ns,p,nn,pp) -> + let zs = foldr (\n k s -> let (a,b) = splitAt (fromIntegral n) s + in a:k b + ) (\as -> if null as then [] else [as]) ns p + in mkNode opts (PresentT zs) [show01' opts msg0 zs "ns=" ns <> show1 opts " | " p] [hh nn, hh pp] + +-- | similar to 'splitAt' +-- +-- >>> pl @(SplitAt 4 Id) "hello world" +-- Present ("hell","o world") +-- PresentT ("hell","o world") +-- +-- >>> pl @(SplitAt 20 Id) "hello world" +-- Present ("hello world","") +-- PresentT ("hello world","") +-- +-- >>> pl @(SplitAt 0 Id) "hello world" +-- Present ("","hello world") +-- PresentT ("","hello world") +-- +-- >>> pl @(SplitAt (Snd Id) (Fst Id)) ("hello world",4) +-- Present ("hell","o world") +-- PresentT ("hell","o world") +-- +data SplitAt n p +type Take n p = Fst (SplitAt n p) +type Drop n p = Snd (SplitAt n p) + +instance (PP p a ~ [b] + , P n a + , P p a + , Show b + , Integral (PP n a) + ) => P (SplitAt n p) a where + type PP (SplitAt n p) a = (PP p a, PP p a) + eval _ opts a = do + let msg0 = "SplitAt" + lr <- runPQ msg0 (Proxy @n) (Proxy @p) opts a + pure $ case lr of + Left e -> e -- (Left e, tt') + Right (fromIntegral -> n,p,pp,qq) -> + let msg1 = msg0 <> show0 opts " " n <> show0 opts " " p + (x,y) = splitAt n p + ret = (x,y) + in mkNode opts (PresentT ret) [show01' opts msg1 ret "n=" n <> show1 opts " | " p] [hh pp, hh qq] + +type Tail = Uncons >> 'Just (Snd Id) +type Head = Uncons >> 'Just (Fst Id) +type Init = Unsnoc >> 'Just (Fst Id) +type Last = Unsnoc >> 'Just (Snd Id) + +-- | similar to 'Control.Arrow.&&&' +type p &&& q = W '(p, q) +infixr 3 &&& + +-- | similar to 'Control.Arrow.***' +-- +-- >>> pl @(Pred Id *** ShowP Id) (13, True) +-- Present (12,"True") +-- PresentT (12,"True") +-- +data (p :: k) *** (q :: k1) +infixr 3 *** +type First p = p *** I +type Second q = I *** q + +instance (Show (PP p a) + , Show (PP q b) + , P p a + , P q b + , Show a + , Show b + ) => P (p *** q) (a,b) where + type PP (p *** q) (a,b) = (PP p a, PP q b) + eval _ opts (a,b) = do + let msg0 = "(***)" + pp <- eval (Proxy @p) opts a + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right a1 -> do + qq <- eval (Proxy @q) opts b + pure $ case getValueLR opts msg0 qq [hh pp] of + Left e -> e + Right b1 -> mkNode opts (PresentT (a1,b1)) [msg0 <> show0 opts " " (a1,b1) <> show1 opts " | " (a,b)] [hh pp, hh qq] + +-- | similar 'Control.Arrow.|||' +-- +-- >>> pl @(Pred Id ||| Id) (Left 13) +-- Present 12 +-- PresentT 12 +-- +-- >>> pl @(ShowP Id ||| Id) (Right "hello") +-- Present "hello" +-- PresentT "hello" +-- +data (|||) (p :: k) (q :: k1) +infixr 2 ||| +type EitherIn p q = p ||| q +type IsLeft = 'True ||| 'False +type IsRight = 'False ||| 'True + +instance (Show (PP p a) + , P p a + , P q b + , PP p a ~ PP q b + , Show a + , Show b + ) => P (p ||| q) (Either a b) where + type PP (p ||| q) (Either a b) = PP p a + eval _ opts lr = do + let msg0 = "|||" + case lr of + Left a -> do + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right a1 -> let msg1 = msg0 ++ " Left" + in mkNode opts (_tBool pp) [show01 opts msg1 a1 a] [hh pp] + Right a -> do + qq <- eval (Proxy @q) opts a + pure $ case getValueLR opts msg0 qq [] of + Left e -> e + Right a1 -> + let msg1 = msg0 ++ " Right" + in mkNode opts (_tBool qq) [show01 opts msg1 a1 a] [hh qq] + +-- | similar 'Control.Arrow.+++' +-- +-- >>> pl @(Pred Id +++ Id) (Left 13) +-- Present Left 12 +-- PresentT (Left 12) +-- +-- >>> pl @(ShowP Id +++ Reverse) (Right "hello") +-- Present Right "olleh" +-- PresentT (Right "olleh") +-- +data (+++) (p :: k) (q :: k1) +infixr 2 +++ + +instance (Show (PP p a) + , Show (PP q b) + , P p a + , P q b + , Show a + , Show b + ) => P (p +++ q) (Either a b) where + type PP (p +++ q) (Either a b) = Either (PP p a) (PP q b) + eval _ opts lr = do + let msg0 = "+++" + case lr of + Left a -> do + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right a1 -> + let msg1 = msg0 ++ " Left" + in mkNode opts (PresentT (Left a1)) [msg1 <> show0 opts " Left " a1 <> show1 opts " | " a] [hh pp] + Right a -> do + qq <- eval (Proxy @q) opts a + pure $ case getValueLR opts msg0 qq [] of + Left e -> e + Right a1 -> + let msg1 = msg0 ++ " Right" + in mkNode opts (PresentT (Right a1)) [msg1 <> show0 opts " Right" a1 <> show1 opts " | " a] [hh qq] + +type Dup = '(Id, Id) + +data BinOp = BMult | BSub | BAdd deriving (Show,Eq) + +type Mult p q = Bin 'BMult p q +type Add p q = Bin 'BAdd p q +type Sub p q = Bin 'BSub p q + +type p + q = Add p q +infixl 6 + +type p - q = Sub p q +infixl 6 - +type p * q = Mult p q +infixl 7 * + +type p > q = Cmp 'Cgt p q +infix 4 > +type p >= q = Cmp 'Cge p q +infix 4 >= +type p == q = Cmp 'Ceq p q +infix 4 == +type p /= q = Cmp 'Cne p q +infix 4 /= +type p <= q = Cmp 'Cle p q +infix 4 <= +type p < q = Cmp 'Clt p q +infix 4 < + +type Gt n = Cmp 'Cgt I n +type Ge n = Cmp 'Cge I n +type Same n = Cmp 'Ceq I n +type Le n = Cmp 'Cle I n +type Lt n = Cmp 'Clt I n +type Ne n = Cmp 'Cne I n + +type p >~ q = CmpI 'Cgt p q +infix 4 >~ +type p >=~ q = CmpI 'Cge p q +infix 4 >=~ +type p ==~ q = CmpI 'Ceq p q +infix 4 ==~ +type p /=~ q = CmpI 'Cne p q +infix 4 /=~ +type p <=~ q = CmpI 'Cle p q +infix 4 <=~ +type p <~ q = CmpI 'Clt p q +infix 4 <~ + +class GetBinOp (k :: BinOp) where + getBinOp :: (Num a, a ~ b) => (String, a -> b -> a) + +instance GetBinOp 'BMult where + getBinOp = ("*",(*)) +instance GetBinOp 'BSub where + getBinOp = ("-",(-)) +instance GetBinOp 'BAdd where + getBinOp = ("+",(+)) + +-- | addition, multiplication and subtraction +-- +-- >>> pl @(Fst Id * Snd Id) (13,5) +-- Present 65 +-- PresentT 65 +-- +-- >>> pl @(Fst Id + 4 * Length (Snd Id) - 4) (3,"hello") +-- Present 19 +-- PresentT 19 +-- +data Bin (op :: BinOp) p q + +instance (GetBinOp op + , PP p a ~ PP q a + , P p a + , P q a + , Show (PP p a) + , Num (PP p a) + ) => P (Bin op p q) a where + type PP (Bin op p q) a = PP p a + eval _ opts a = do + let (s,f) = getBinOp @op + lr <- runPQ s (Proxy @p) (Proxy @q) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = p `f` q + in mkNode opts (PresentT d) [show p <> " " <> s <> " " <> show q <> " = " <> show d] [hh pp, hh qq] + +-- | fractional division +-- +-- >>> pl @(Fst Id / Snd Id) (13,2) +-- Present 6.5 +-- PresentT 6.5 +-- +-- >>> pl @(ToRational 13 / Id) 0 +-- Error (/) zero denominator +-- FailT "(/) zero denominator" +-- +-- >>> pl @(12 % 7 / 14 % 5 + Id) 12.4 +-- Present 3188 % 245 +-- PresentT (3188 % 245) +-- +data p / q +infixl 7 / + +instance (PP p a ~ PP q a + , Eq (PP q a) + , P p a + , P q a + , Show (PP p a) + , Fractional (PP p a) + ) => P (p / q) a where + type PP (p / q) a = PP p a + eval _ opts a = do + let msg0 = "(/)" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) + | q == 0 -> let msg1 = msg0 <> " zero denominator" + in mkNode opts (FailT msg1) [msg1] [hh pp, hh qq] + | otherwise -> + let d = p / q + in mkNode opts (PresentT d) [show p <> " / " <> show q <> " = " <> show d] [hh pp, hh qq] + +-- | creates a 'Rational' value +-- +-- >>> pl @(Id < 21 % 5) (-3.1) +-- True +-- TrueT +-- +-- >>> pl @(Id < 21 % 5) 4.5 +-- False +-- FalseT +-- +-- >>> pl @(Fst Id % Snd Id) (13,2) +-- Present 13 % 2 +-- PresentT (13 % 2) +-- +-- >>> pl @(13 % Id) 0 +-- Error MkRatio zero denominator +-- FailT "MkRatio zero denominator" +-- +-- >>> pl @(4 % 3 + 5 % 7) "asfd" +-- Present 43 % 21 +-- PresentT (43 % 21) +-- +-- >>> pl @(4 %- 7 * 5 %- 3) "asfd" +-- Present 20 % 21 +-- PresentT (20 % 21) +-- +-- >>> pl @(Negate (14 % 3)) () +-- Present (-14) % 3 +-- PresentT ((-14) % 3) +-- +-- >>> pl @(14 % 3) () +-- Present 14 % 3 +-- PresentT (14 % 3) +-- +-- >>> pl @(Negate (14 % 3) ==! FromIntegral _ (Negate 5)) () +-- Present GT +-- PresentT GT +-- +-- >>> pl @(14 -% 3 ==! 5 %- 1) "aa" +-- Present GT +-- PresentT GT +-- +-- >>> pl @(Negate (14 % 3) ==! Negate 5 % 2) () +-- Present LT +-- PresentT LT +-- +-- >>> pl @(14 -% 3 * 5 -% 1) () +-- Present 70 % 3 +-- PresentT (70 % 3) +-- +-- >>> pl @(14 % 3 ==! 5 % 1) () +-- Present LT +-- PresentT LT +-- +-- >>> pl @(15 % 3 / 4 % 2) () +-- Present 5 % 2 +-- PresentT (5 % 2) +-- +data p % q +infixl 8 % + +type p %- q = Negate (p % q) +infixl 8 %- +type p -% q = Negate (p % q) +infixl 8 -% + +instance (Integral (PP p x) + , Integral (PP q x) + , Eq (PP q x) + , P p x + , P q x + , Show (PP p x) + , Show (PP q x) + ) => P (p % q) x where + type PP (p % q) x = Rational + eval _ opts x = do + let msg0 = "MkRatio" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) + | q == 0 -> let msg1 = msg0 <> " zero denominator" + in mkNode opts (FailT msg1) [msg1] [hh pp, hh qq] + | otherwise -> + let d = fromIntegral p % fromIntegral q + in mkNode opts (PresentT d) [show p <> " % " <> show q <> " = " <> show d] [hh pp, hh qq] + + +-- | similar to 'negate' +-- +-- >>> pl @(Negate Id) 14 +-- Present -14 +-- PresentT (-14) +-- +-- >>> pl @(Negate (Fst Id * Snd Id)) (14,3) +-- Present -42 +-- PresentT (-42) +-- +-- >>> pl @(Negate (15 %- 4)) "abc" +-- Present 15 % 4 +-- PresentT (15 % 4) +-- +-- >>> pl @(Negate (15 % 3)) () +-- Present (-5) % 1 +-- PresentT ((-5) % 1) +-- +-- >>> pl @(Negate (Fst Id % Snd Id)) (14,3) +-- Present (-14) % 3 +-- PresentT ((-14) % 3) +-- +data Negate p + +instance (Show (PP p x), Num (PP p x), P p x) => P (Negate p) x where + type PP (Negate p) x = PP p x + eval _ opts x = do + let msg0 = "Negate" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = negate p + in mkNode opts (PresentT d) [show01 opts msg0 d p] [hh pp] + + +-- | similar to 'abs' +-- +-- >>> pl @(Abs Id) (-14) +-- Present 14 +-- PresentT 14 +-- +-- >>> pl @(Abs (Snd Id)) ("xx",14) +-- Present 14 +-- PresentT 14 +-- +-- >>> pl @(Abs Id) 0 +-- Present 0 +-- PresentT 0 +-- +-- >>> pl @(Abs (Negate 44)) "aaa" +-- Present 44 +-- PresentT 44 +-- +data Abs p + +instance (Show (PP p x), Num (PP p x), P p x) => P (Abs p) x where + type PP (Abs p) x = PP p x + eval _ opts x = do + let msg0 = "Abs" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = abs p + in mkNode opts (PresentT d) [show01 opts msg0 d p] [hh pp] + + + +-- | similar to 'signum' +-- +-- >>> pl @(Signum Id) (-14) +-- Present -1 +-- PresentT (-1) +-- +-- >>> pl @(Signum Id) 14 +-- Present 1 +-- PresentT 1 +-- +-- >>> pl @(Signum Id) 0 +-- Present 0 +-- PresentT 0 +-- +data Signum p + +instance (Show (PP p x), Num (PP p x), P p x) => P (Signum p) x where + type PP (Signum p) x = PP p x + eval _ opts x = do + let msg0 = "Signum" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = signum p + in mkNode opts (PresentT d) [show01 opts msg0 d p] [hh pp] + +-- | unwraps a value (see 'Control.Lens.Unwrapped') +-- +-- >>> pl @(Unwrap Id) (SG.Sum (-13)) +-- Present -13 +-- PresentT (-13) +-- +data Unwrap p + +instance (PP p x ~ s + , P p x + , Show s + , Show (Unwrapped s) + , Wrapped s + ) => P (Unwrap p) x where + type PP (Unwrap p) x = Unwrapped (PP p x) + eval _ opts x = do + let msg0 = "Unwrap" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = p ^. _Wrapped' + in mkNode opts (PresentT d) [show01 opts msg0 d p] [hh pp] + +-- | wraps a value (see 'Control.Lens.Wrapped' and 'Control.Lens.Unwrapped') +-- +-- >>> :m + Data.List.NonEmpty +-- >>> pl @(Wrap (SG.Sum _) Id) (-13) +-- Present Sum {getSum = -13} +-- PresentT (Sum {getSum = -13}) +-- +-- >>> pl @(Wrap SG.Any (Ge 4)) 13 +-- Present Any {getAny = True} +-- PresentT (Any {getAny = True}) +-- +-- >>> pl @(Wrap (NonEmpty _) (Uncons >> 'Just Id)) "abcd" +-- Present 'a' :| "bcd" +-- PresentT ('a' :| "bcd") +-- +data Wrap' t p +type Wrap (t :: Type) p = Wrap' (Hole t) p + +instance (Show (PP p x) + , P p x + , Unwrapped (PP s x) ~ PP p x + , Wrapped (PP s x) + , Show (PP s x) + ) => P (Wrap' s p) x where + type PP (Wrap' s p) x = PP s x + eval _ opts x = do + let msg0 = "Wrap" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = p ^. _Unwrapped' + in mkNode opts (PresentT d) [show01 opts msg0 d p] [hh pp] + +-- | similar to 'coerce' +-- +-- >>> pl @(Coerce (SG.Sum Integer)) (Identity (-13)) +-- Present Sum {getSum = -13} +-- PresentT (Sum {getSum = -13}) +-- +data Coerce (t :: k) + +instance (Show a + , Show t + , Coercible t a + ) => P (Coerce t) a where + type PP (Coerce t) a = t + eval _ opts a = + let msg0 = "Coerce" + d = a ^. coerced + in pure $ mkNode opts (PresentT d) [show01 opts msg0 d a] [] + +-- can coerce over a functor: but need to provide type of 'a' and 't' explicitly + +-- | see 'Coerce': coerce over a functor +-- +-- >>> pl @(Coerce2 (SG.Sum Integer)) [Identity (-13), Identity 4, Identity 99] +-- Present [Sum {getSum = -13},Sum {getSum = 4},Sum {getSum = 99}] +-- PresentT [Sum {getSum = -13},Sum {getSum = 4},Sum {getSum = 99}] +-- +-- >>> pl @(Coerce2 (SG.Sum Integer)) (Just (Identity (-13))) +-- Present Just (Sum {getSum = -13}) +-- PresentT (Just (Sum {getSum = -13})) +-- +-- >>> pl @(Coerce2 (SG.Sum Int)) (Nothing @(Identity Int)) +-- Present Nothing +-- PresentT Nothing +-- +data Coerce2 (t :: k) +instance (Show (f a) + , Show (f t) + , Coercible t a + , Functor f + ) => P (Coerce2 t) (f a) where + type PP (Coerce2 t) (f a) = f t + eval _ opts fa = + let msg0 = "Coerce2" + d = view coerced <$> fa + in pure $ mkNode opts (PresentT d) [show01 opts msg0 d fa] [] + +-- | lift mempty over a Functor +-- +-- >>> pl @(MEmptyT2 (SG.Product Int)) [Identity (-13), Identity 4, Identity 99] +-- Present [Product {getProduct = 1},Product {getProduct = 1},Product {getProduct = 1}] +-- PresentT [Product {getProduct = 1},Product {getProduct = 1},Product {getProduct = 1}] +-- +data MEmptyT2' t +type MEmptyT2 t = MEmptyT2' (Hole t) + +instance (Show (f a) + , Show (f (PP t (f a))) + , Functor f + , Monoid (PP t (f a)) + ) => P (MEmptyT2' t) (f a) where + type PP (MEmptyT2' t) (f a) = f (PP t (f a)) + eval _ opts fa = + let msg0 = "MEmptyT2" + b = mempty <$> fa + in pure $ mkNode opts (PresentT b) [show01 opts msg0 b fa] [] + +-- | lift pure over a Functor +-- +-- >>> pl @(Pure2 (Either String)) [1,2,4] +-- Present [Right 1,Right 2,Right 4] +-- PresentT [Right 1,Right 2,Right 4] +-- +data Pure2 (t :: Type -> Type) +type MkRightAlt t p = Pure (Either t) p +type MkLeftAlt t p = MkRightAlt t p >> Swap + +instance (Show (f (t a)) + , Show (f a) + , Applicative t + , Functor f + ) => P (Pure2 t) (f a) where + type PP (Pure2 t) (f a) = f (t a) + eval _ opts fa = + let msg0 = "Pure2" + b = fmap pure fa + in pure $ mkNode opts (PresentT b) [show01 opts msg0 b fa] [] + +-- | similar to 'reverse' +-- +-- >>> pl @Reverse [1,2,4] +-- Present [4,2,1] +-- PresentT [4,2,1] +-- +-- >>> pl @Reverse "AbcDeF" +-- Present "FeDcbA" +-- PresentT "FeDcbA" +-- +data Reverse + +instance (Show a, as ~ [a]) => P Reverse as where + type PP Reverse as = as + eval _ opts as = + let msg0 = "Reverse" + d = reverse as + in pure $ mkNode opts (PresentT d) [show01 opts msg0 d as] [] + +-- | reverses using 'reversing' +-- +-- >>> pl @ReverseL (T.pack "AbcDeF") +-- Present "FeDcbA" +-- PresentT "FeDcbA" +-- +-- >>> pl @ReverseL ("AbcDeF" :: String) +-- Present "FeDcbA" +-- PresentT "FeDcbA" +-- +data ReverseL + +instance (Show t, Reversing t) => P ReverseL t where + type PP ReverseL t = t + eval _ opts as = + let msg0 = "ReverseL" + d = as ^. reversed + in pure $ mkNode opts (PresentT d) [show01 opts msg0 d as] [] + +-- | swaps using 'SW.swap' +-- +-- >>> pl @Swap (Left 123) +-- Present Right 123 +-- PresentT (Right 123) +-- +-- >>> pl @Swap (Right 123) +-- Present Left 123 +-- PresentT (Left 123) +-- +-- >>> pl @Swap (These 'x' 123) +-- Present These 123 'x' +-- PresentT (These 123 'x') +-- +-- >>> pl @Swap (This 'x') +-- Present That 'x' +-- PresentT (That 'x') +-- +-- >>> pl @Swap (That 123) +-- Present This 123 +-- PresentT (This 123) +-- +-- >>> pl @Swap (123,'x') +-- Present ('x',123) +-- PresentT ('x',123) +-- +-- >>> pl @Swap (Left "abc") +-- Present Right "abc" +-- PresentT (Right "abc") +-- +-- >>> pl @Swap (Right 123) +-- Present Left 123 +-- PresentT (Left 123) +-- +data Swap + +instance (Show (p a b) + , SW.Swap p + , Show (p b a) + ) => P Swap (p a b) where + type PP Swap (p a b) = p b a + eval _ opts pab = + let msg0 = "Swap" + d = SW.swap pab + in pure $ mkNode opts (PresentT d) [show01 opts msg0 d pab] [] + +-- | assoc using 'AS.assoc' +-- +-- >>> pl @Assoc (This (These 123 'x')) +-- Present These 123 (This 'x') +-- PresentT (These 123 (This 'x')) +-- +-- >>> pl @Assoc ((99,'a'),True) +-- Present (99,('a',True)) +-- PresentT (99,('a',True)) +-- +-- >>> pl @Assoc ((99,'a'),True) +-- Present (99,('a',True)) +-- PresentT (99,('a',True)) +-- +-- >>> pl @Assoc (Right "Abc" :: Either (Either () ()) String) +-- Present Right (Right "Abc") +-- PresentT (Right (Right "Abc")) +-- +-- >>> pl @Assoc (Left (Left 'x')) +-- Present Left 'x' +-- PresentT (Left 'x') +-- +data Assoc + +instance (Show (p (p a b) c) + , Show (p a (p b c)) + , AS.Assoc p + ) => P Assoc (p (p a b) c) where + type PP Assoc (p (p a b) c) = p a (p b c) + eval _ opts pabc = + let msg0 = "Assoc" + d = AS.assoc pabc + in pure $ mkNode opts (PresentT d) [show01 opts msg0 d pabc] [] + +-- | unassoc using 'AS.unassoc' +-- +-- >>> pl @Unassoc (These 123 (This 'x')) +-- Present This (These 123 'x') +-- PresentT (This (These 123 'x')) +-- +-- >>> pl @Unassoc (99,('a',True)) +-- Present ((99,'a'),True) +-- PresentT ((99,'a'),True) +-- +-- >>> pl @Unassoc (This 10 :: These Int (These Bool ())) +-- Present This (This 10) +-- PresentT (This (This 10)) +-- +-- >>> pl @Unassoc (Right (Right 123)) +-- Present Right 123 +-- PresentT (Right 123) +-- +-- >>> pl @Unassoc (Left 'x' :: Either Char (Either Bool Double)) +-- Present Left (Left 'x') +-- PresentT (Left (Left 'x')) +-- +data Unassoc + +instance (Show (p (p a b) c) + , Show (p a (p b c)) + , AS.Assoc p + ) => P Unassoc (p a (p b c)) where + type PP Unassoc (p a (p b c)) = p (p a b) c + eval _ opts pabc = + let msg0 = "Unassoc" + d = AS.unassoc pabc + in pure $ mkNode opts (PresentT d) [show01 opts msg0 d pabc] [] + +-- | bounded 'succ' function +-- +-- >>> pl @(SuccB' Id) (13 :: Int) +-- Present 14 +-- PresentT 14 +-- +-- >>> pl @(SuccB' Id) LT +-- Present EQ +-- PresentT EQ +-- +-- >>> pl @(SuccB 'LT Id) GT +-- Present LT +-- PresentT LT +-- +-- >>> pl @(SuccB' Id) GT +-- Error Succ bounded failed +-- FailT "Succ bounded failed" +-- +data SuccB p q +type SuccB' q = SuccB (Failp "Succ bounded failed") q + +instance (PP q x ~ a + , P q x + , P p (Proxy a) + , PP p (Proxy a) ~ a + , Show a + , Eq a + , Bounded a + , Enum a + ) => P (SuccB p q) x where + type PP (SuccB p q) x = PP q x + eval _ opts x = do + let msg0 = "SuccB" + qq <- eval (Proxy @q) opts x + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> do + case succMay q of + Nothing -> do + let msg1 = msg0 <> " out of range" + pp <- eval (Proxy @p) opts (Proxy @a) + pure $ case getValueLR opts msg1 pp [hh qq] of + Left e -> e + Right _ -> mkNode opts (_tBool pp) [msg1] [hh qq, hh pp] + Just n -> pure $ mkNode opts (PresentT n) [show01 opts msg0 n q] [hh qq] + +-- | bounded 'pred' function +-- +-- >>> pl @(PredB' Id) (13 :: Int) +-- Present 12 +-- PresentT 12 +-- +-- >>> pl @(PredB' Id) LT +-- Error Pred bounded failed +-- FailT "Pred bounded failed" +-- +data PredB p q +type PredB' q = PredB (Failp "Pred bounded failed") q + +instance (PP q x ~ a + , P q x + , P p (Proxy a) + , PP p (Proxy a) ~ a + , Show a + , Eq a + , Bounded a + , Enum a + ) => P (PredB p q) x where + type PP (PredB p q) x = PP q x + eval _ opts x = do + let msg0 = "PredB" + qq <- eval (Proxy @q) opts x + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> do + case predMay q of + Nothing -> do + let msg1 = msg0 <> " out of range" + pp <- eval (Proxy @p) opts (Proxy @a) + pure $ case getValueLR opts msg1 pp [hh qq] of + Left e -> e + Right _ -> mkNode opts (_tBool pp) [msg1] [hh qq, hh pp] + Just n -> pure $ mkNode opts (PresentT n) [show01 opts msg0 n q] [hh qq] + + +-- | unbounded 'succ' function +-- +-- >>> pl @(Succ Id) 13 +-- Present 14 +-- PresentT 14 +-- +-- >>> pl @(Succ Id) LT +-- Present EQ +-- PresentT EQ +-- +-- >>> pl @(Succ Id) GT +-- Error Succ IO e=Prelude.Enum.Ordering.succ: bad argument +-- FailT "Succ IO e=Prelude.Enum.Ordering.succ: bad argument" +-- +data Succ p + +instance (Show a + , Enum a + , PP p x ~ a + , P p x + ) => P (Succ p) x where + type PP (Succ p) x = PP p x + eval _ opts x = do + let msg0 = "Succ" + pp <- eval (Proxy @p) opts x + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right p -> do + lr <- catchit @_ @E.SomeException (succ p) + pure $ case lr of + Left e -> mkNode opts (FailT (msg0 <> " " <> e)) [msg0 <> show0 opts " " p] [hh pp] + Right n -> mkNode opts (PresentT n) [show01 opts msg0 n p] [hh pp] + + +-- | unbounded 'pred' function +-- +-- >>> pl @(Pred Id) 13 +-- Present 12 +-- PresentT 12 +-- +-- >>> pl @(Pred Id) LT +-- Error Pred IO e=Prelude.Enum.Ordering.pred: bad argument +-- FailT "Pred IO e=Prelude.Enum.Ordering.pred: bad argument" +-- + +data Pred p + +instance (Show a + , Enum a + , PP p x ~ a + , P p x + ) => P (Pred p) x where + type PP (Pred p) x = PP p x + eval _ opts x = do + let msg0 = "Pred" + pp <- eval (Proxy @p) opts x + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right p -> do + lr <- catchit @_ @E.SomeException (pred p) + pure $ case lr of + Left e -> mkNode opts (FailT (msg0 <> " " <> e)) [msg0 <> show0 opts " " p] [hh pp] + Right n -> mkNode opts (PresentT n) [show01 opts msg0 n p] [hh pp] + + +-- | 'fromEnum' function +-- +-- >>> pl @(FromEnum Id) 'x' +-- Present 120 +-- PresentT 120 + + +data FromEnum p + +instance (Show a + , Enum a + , PP p x ~ a + , P p x + ) => P (FromEnum p) x where + type PP (FromEnum p) x = Int + eval _ opts x = do + let msg0 = "FromEnum" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let n = fromEnum p + in mkNode opts (PresentT n) [show01 opts msg0 n p] [hh pp] + +-- | unsafe 'toEnum' function +-- +-- >>> pl @(ToEnum Char Id) 120 +-- Present 'x' +-- PresentT 'x' +data ToEnum' t p +type ToEnum (t :: Type) p = ToEnum' (Hole t) p + +instance (PP p x ~ a + , P p x + , Show a + , Enum (PP t x) + , Show (PP t x) + , Integral a + ) => P (ToEnum' t p) x where + type PP (ToEnum' t p) x = PP t x + eval _ opts x = do + let msg0 = "ToEnum" + pp <- eval (Proxy @p) opts x + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right p -> do + lr <- catchit @_ @E.SomeException (toEnum $! fromIntegral p) + pure $ case lr of + Left e -> mkNode opts (FailT (msg0 <> " " <> e)) [msg0 <> show0 opts " " p] [hh pp] + Right n -> mkNode opts (PresentT n) [show01 opts msg0 n p] [hh pp] + +-- | bounded 'toEnum' function +-- +-- >>> pl @(ToEnumB Ordering LT) 2 +-- Present GT +-- PresentT GT +-- +-- >>> pl @(ToEnumB Ordering LT) 6 +-- Present LT +-- PresentT LT +-- +-- >>> pl @(ToEnumBF Ordering) 6 +-- Error ToEnum bounded failed +-- FailT "ToEnum bounded failed" +-- +data ToEnumB' t def +type ToEnumB (t :: Type) def = ToEnumB' (Hole t) def +type ToEnumBF (t :: Type) = ToEnumB' (Hole t) (Failp "ToEnum bounded failed") + +instance (P def (Proxy (PP t a)) + , PP def (Proxy (PP t a)) ~ (PP t a) + , Show a + , Show (PP t a) + , Bounded (PP t a) + , Enum (PP t a) + , Integral a + ) => P (ToEnumB' t def) a where + type PP (ToEnumB' t def) a = PP t a + eval _ opts a = do + let msg0 = "ToEnumB" + case toEnumMay $ fromIntegral a of + Nothing -> do + let msg1 = msg0 <> " out of range" + pp <- eval (Proxy @def) opts (Proxy @(PP t a)) + pure $ case getValueLR opts msg1 pp [] of + Left e -> e + Right _ -> mkNode opts (_tBool pp) [msg1] [hh pp] + Just n -> pure $ mkNode opts (PresentT n) [show01 opts msg0 n a] [] + +-- | a predicate on prime numbers +-- +-- >>> pl @(Prime Id) 2 +-- True +-- TrueT +-- +-- >>> pl @(Map '(Id,Prime Id) Id) [0..12] +-- Present [(0,False),(1,False),(2,True),(3,True),(4,False),(5,True),(6,False),(7,True),(8,False),(9,False),(10,False),(11,True),(12,False)] +-- PresentT [(0,False),(1,False),(2,True),(3,True),(4,False),(5,True),(6,False),(7,True),(8,False),(9,False),(10,False),(11,True),(12,False)] +-- +data Prime p + +instance (PP p x ~ a + , P p x + , Show a + , Integral a + ) => P (Prime p) x where + type PP (Prime p) x = Bool + eval _ opts x = do + let msg0 = "Prime" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = isPrime $ fromIntegral p + in mkNodeB opts b [msg0 <> show1 opts " | " p] [] + +isPrime :: Integer -> Bool +isPrime n = n==2 || n>2 && all ((> 0).rem n) (2:[3,5 .. floor . sqrt @Double . fromIntegral $ n+1]) + +-- empty lists at the type level wont work here + +-- | filters a list \'q\' keeping or removing those elements in \'p\' +-- +-- >>> pl @(Keep '[5] '[1,5,5,2,5,2]) () +-- Present [5,5,5] +-- PresentT [5,5,5] +-- +-- >>> pl @(Keep '[0,1,1,5] '[1,5,5,2,5,2]) () +-- Present [1,5,5,5] +-- PresentT [1,5,5,5] +-- +-- >>> pl @(Remove '[5] '[1,5,5,2,5,2]) () +-- Present [1,2,2] +-- PresentT [1,2,2] +-- +-- >>> pl @(Remove '[0,1,1,5] '[1,5,5,2,5,2]) () +-- Present [2,2] +-- PresentT [2,2] +-- +-- >>> pl @(Remove '[99] '[1,5,5,2,5,2]) () +-- Present [1,5,5,2,5,2] +-- PresentT [1,5,5,2,5,2] +-- +-- >>> pl @(Remove '[99,91] '[1,5,5,2,5,2]) () +-- Present [1,5,5,2,5,2] +-- PresentT [1,5,5,2,5,2] +-- +-- >>> pl @(Remove Id '[1,5,5,2,5,2]) [] +-- Present [1,5,5,2,5,2] +-- PresentT [1,5,5,2,5,2] +-- +-- >>> pl @(Remove '[] '[1,5,5,2,5,2]) 44 -- works if you make this a number! +-- Present [1,5,5,2,5,2] +-- PresentT [1,5,5,2,5,2] +-- +data KeepImpl (keep :: Bool) p q +type Remove p q = KeepImpl 'False p q +type Keep p q = KeepImpl 'True p q + +instance (GetBool keep + , Eq a + , Show a + , P p x + , P q x + , PP p x ~ PP q x + , PP q x ~ [a] + ) => P (KeepImpl keep p q) x where + type PP (KeepImpl keep p q) x = PP q x + eval _ opts x = do + let msg0 = if keep then "Keep" else "Remove" + keep = getBool @keep + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let ret = filter (bool not id keep . (`elem` p)) q + in mkNode opts (PresentT ret) [show01' opts msg0 ret "p=" p <> show1 opts " | q=" q] [hh pp, hh qq] + +-- | 'elem' function +-- +-- >>> pl @(Elem (Fst Id) (Snd Id)) ('x',"abcdxy") +-- True +-- TrueT +-- +-- >>> pl @(Elem (Fst Id) (Snd Id)) ('z',"abcdxy") +-- False +-- FalseT +-- +data Elem p q + +instance ([PP p a] ~ PP q a + , P p a + , P q a + , Show (PP p a) + , Eq (PP p a) + ) => P (Elem p q) a where + type PP (Elem p q) a = Bool + eval _ opts a = do + let msg0 = "Elem" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let b = p `elem` q + in mkNodeB opts b [show p <> " `elem` " <> show q] [hh pp, hh qq] + +type Head' p = HeadFail "Head(empty)" p +type Tail' p = TailFail "Tail(empty)" p +type Last' p = LastFail "Last(empty)" p +type Init' p = InitFail "Init(empty)" p + +-- | similar to fmap fst +-- +-- >>> pl @Fmap_1 (Just (13,"Asf")) +-- Present Just 13 +-- PresentT (Just 13) +-- +-- to make this work we grab the fst or snd out of the Maybe so it is a head or not/ is a tail or not etc! +-- we still have access to the whole original list so we dont lose anything! +data Fmap_1 +instance Functor f => P Fmap_1 (f (a,x)) where + type PP Fmap_1 (f (a,x)) = f a + eval _ opts mb = pure $ mkNode opts (PresentT (fst <$> mb)) ["Fmap_1"] [] + +-- | similar to fmap snd +-- +-- >>> pl @Fmap_2 (Just ("asf",13)) +-- Present Just 13 +-- PresentT (Just 13) +-- +data Fmap_2 +instance Functor f => P Fmap_2 (f (x,a)) where + type PP Fmap_2 (f (x,a)) = f a + eval _ opts mb = pure $ mkNode opts (PresentT (snd <$> mb)) ["Fmap_2"] [] + +-- | takes the head or default of a list-like object +-- +-- see 'ConsT' for other supported types eg 'Seq.Seq' +-- +-- >>> pl @(HeadDef 444 Id) [] +-- Present 444 +-- PresentT 444 +-- +-- >>> pl @(HeadDef 444 Id) [1..5] +-- Present 1 +-- PresentT 1 +-- +-- >>> pl @(HeadDef 444 Id) [1..5] +-- Present 1 +-- PresentT 1 +-- +-- >>> pl @(HeadDef (Char1 "w") Id) (Seq.fromList "abcdef") +-- Present 'a' +-- PresentT 'a' +-- +-- >>> pl @(HeadDef (Char1 "w") Id) Seq.empty +-- Present 'w' +-- PresentT 'w' +-- +type HeadDef p q = GDef (Uncons >> Fmap_1) p q + + +-- | takes the head of a list or defaults to the monoid instance +-- +-- see 'ConsT' for other supported types eg 'Seq.Seq' +-- +-- >>> pl @(HeadP '[ "abc","def","asdfadf" ]) () +-- Present "abc" +-- PresentT "abc" +-- +-- >>> pl @(HeadP (Snd Id)) (123,[ "abc","def","asdfadf" ]) +-- Present "abc" +-- PresentT "abc" +-- +-- >>> pl @(HeadP (Snd Id)) (123,[]) +-- Present () +-- PresentT () +-- +type HeadP q = GProxy (Uncons >> Fmap_1) q +-- | takes the head of a list or fail +-- +-- see 'ConsT' for other supported types eg 'Seq.Seq' +-- +-- >>> pl @(HeadFail "dude" Id) [ "abc","def","asdfadf" ] +-- Present "abc" +-- PresentT "abc" +-- +-- >>> pl @(HeadFail "empty list" Id) [] +-- Error empty list +-- FailT "empty list" +-- + +type HeadFail msg q = GFail (Uncons >> Fmap_1) msg q + +type TailDef p q = GDef (Uncons >> Fmap_2) p q +type TailP q = GProxy (Uncons >> Fmap_2) q +type TailFail msg q = GFail (Uncons >> Fmap_2) msg q + +type LastDef p q = GDef (Unsnoc >> Fmap_2) p q +type LastP q = GProxy (Unsnoc >> Fmap_2) q +type LastFail msg q = GFail (Unsnoc >> Fmap_2) msg q + +type InitDef p q = GDef (Unsnoc >> Fmap_1) p q +type InitP q = GProxy (Unsnoc >> Fmap_1) q +type InitFail msg q = GFail (Unsnoc >> Fmap_1) msg q + +-- 'x' and 'a' for Just condition +-- 'x' for Nothing condition +-- (Snd Id) at the end says we only want to process the Maybe which is the rhs of &&& ie (Snd Id) +type GDef' z p q r = '(I, r >> z) >> MaybeXP (X >> p) q (Snd Id) +type JustDef' p q r = GDef' I p q r + +-- access everything ie 'x' and Proxy a for Nothing condition +-- 'x' and 'a' for Just condition +type GDef'' z p q r = '(I, r >> z) >> MaybeXP p q (Snd Id) +type JustDef'' p q r = GDef'' I p q r + +type PA = Snd I -- 'Proxy a' -- to distinguish from A +type A = Snd I -- 'a' +type X = Fst (Fst I) -- 'x' ie the whole original environment + +-- Nothing has access to 'x' only +-- Just has access to (x,a) +type GDef_X z p q r = '(I, r >> z) >> MaybeXP (X >> p) ('(X,A) >> q) A +type JustDef''' p q r = GDef_X I p q r + +-- Nothing case sees ((I,qz), Proxy a) -- hence the Fst Id >> Fst Id +-- Just case sees (I,qz), a) -- hence the (Snd Id) to get the 'a' only -- if you want the 'x' then Fst Id >> Fst Id +-- we have lost 'x' on the rhs: use GDef_X to access 'x' and 'a' for the Just condition +type GDef z p q = '(I, q >> z) >> MaybeXP (X >> p) A A -- Hide % immediately before MaybeXP +type GProxy z q = '(I, q >> z) >> MaybeXP (PA >> MEmptyP) A A +type GFail z msg q = '(I, q >> z) >> MaybeXP (Fail (PA >> Unproxy) (X >> msg)) A A + +-- use these! +type LookupDef' x y p q = GDef (Lookup x y) p q +type LookupP' x y q = GProxy (Lookup x y) q +type LookupFail' msg x y q = GFail (Lookup x y) msg q + +type LookupDef x y p = LookupDef' x y p I +type LookupP x y = LookupP' x y I +type LookupFail msg x y = LookupFail' msg x y I + +type Just' p = JustFail "expected Just" p +type Left' p = LeftFail "expected Left" p +type Right' p = RightFail "expected Right" p +type This' p = ThisFail "expected This" p +type That' p = ThatFail "expected That" p +type TheseIn' p = TheseFail "expected These" p + +type JustDef p q = GDef I p q +type JustP q = GProxy I q +type JustFail msg q = GFail I msg q + +type LeftDef p q = GDef LeftToMaybe p q +type LeftP q = GProxy LeftToMaybe q +type LeftFail msg q = GFail LeftToMaybe msg q + +type RightDef p q = GDef RightToMaybe p q +type RightP q = GProxy RightToMaybe q +type RightFail msg q = GFail RightToMaybe msg q + +type ThisDef p q = GDef ThisToMaybe p q +type ThisP q = GProxy ThisToMaybe q +type ThisFail msg q = GFail ThisToMaybe msg q + +type ThatDef p q = GDef ThatToMaybe p q +type ThatP q = GProxy ThatToMaybe q +type ThatFail msg q = GFail ThatToMaybe msg q + +type TheseDef p q = GDef TheseToMaybe p q +type TheseP q = GProxy TheseToMaybe q +type TheseFail msg q = GFail TheseToMaybe msg q + +-- tacks on a Proxy to Nothing side! but a Proxy a not Proxy of the final result +-- this is for default use cases for either/these/head/tail/last/init etc + +-- | MaybeXP combinator +-- +-- >>> pl @((Id &&& Snd Id) >> MaybeXP (Fst (Fst (Fst Id))) (Fst (Fst (Fst Id)) <> Snd Id) (Snd Id)) ("xx",Just "ya") +-- Present "xxya" +-- PresentT "xxya" +-- +-- >>> pl @((Id &&& Fst Id) >> MaybeXP (Snd (Fst (Fst Id))) (Snd (Fst (Fst Id)) <> Snd Id) (Snd Id)) (Just "ya","xx") +-- Present "xxya" +-- PresentT "xxya" +-- +-- >>> pl @((Id &&& Snd Id) >> MaybeXP (Fst (Fst (Fst Id))) (Fst (Fst (Fst Id)) <> Snd Id) (Snd Id)) ("xx",Nothing) +-- Present "xx" +-- PresentT "xx" +-- + +data MaybeXP p q r + +-- | MaybeX combinator +-- +-- >>> pl @(MaybeX (Fst Id) (Fst (Fst Id) +: Snd Id) (Snd Id)) ([1..5],Just 99) +-- Present [1,2,3,4,5,99] +-- PresentT [1,2,3,4,5,99] +-- +-- >>> pl @(MaybeX (Fst Id) (Fst (Fst Id) +: Snd Id) (Snd Id)) ([1..5],Nothing) +-- Present [1,2,3,4,5] +-- PresentT [1,2,3,4,5] + +type MaybeX p q r = MaybeXP (Fst Id >> p) q r + +instance (P r x + , P p (x, Proxy a) + , P q (x,a) + , PP r x ~ Maybe a + , PP p (x, Proxy a) ~ b + , PP q (x,a) ~ b + ) => P (MaybeXP p q r) x where + type PP (MaybeXP p q r) x = MaybeXPT (PP r x) x q + eval _ opts x = do + let msg0 = "MaybeXP" + rr <- eval (Proxy @r) opts x + case getValueLR opts msg0 rr [] of + Left e -> pure e + Right Nothing -> do + let msg1 = msg0 <> "(Nothing)" + pp <- eval (Proxy @p) opts (x, Proxy @a) + pure $ case getValueLR opts msg1 pp [hh rr] of + Left e -> e + Right _ -> mkNode opts (_tBool pp) [msg1] [hh rr, hh pp] + Right (Just a) -> do + let msg1 = msg0 <> "(Just)" + qq <- eval (Proxy @q) opts (x,a) + pure $ case getValueLR opts msg1 qq [hh rr] of + Left e -> e + Right _ -> mkNode opts (_tBool qq) [msg1] [hh rr, hh qq] + +type family MaybeXPT lr x q where + MaybeXPT (Maybe a) x q = PP q (x,a) + + +-- | similar to either Just (const Nothing) +-- +-- >>> pl @LeftToMaybe (Left 13) +-- Present Just 13 +-- PresentT (Just 13) +-- +-- >>> pl @LeftToMaybe (Right 13) +-- Present Nothing +-- PresentT Nothing +-- +data LeftToMaybe +instance P LeftToMaybe (Either a x) where + type PP LeftToMaybe (Either a x) = Maybe a + eval _ opts lr = pure $ mkNode opts (PresentT (either Just (const Nothing) lr)) ["LeftToMaybe"] [] + + +-- | similar to either (const Nothing) Just +-- +-- >>> pl @RightToMaybe (Right 13) +-- Present Just 13 +-- PresentT (Just 13) +-- +-- >>> pl @RightToMaybe (Left 13) +-- Present Nothing +-- PresentT Nothing +-- +data RightToMaybe +instance P RightToMaybe (Either x a) where + type PP RightToMaybe (Either x a) = Maybe a + eval _ opts lr = pure $ mkNode opts (PresentT (either (const Nothing) Just lr)) ["RightToMaybe"] [] + +data ThisToMaybe + +instance P ThisToMaybe (These a x) where + type PP ThisToMaybe (These a x) = Maybe a + eval _ opts th = pure $ mkNode opts (PresentT (these Just (const Nothing) (const . const Nothing) th)) ["ThisToMaybe"] [] + +data ThatToMaybe + +instance P ThatToMaybe (These x a) where + type PP ThatToMaybe (These x a) = Maybe a + eval _ opts th = pure $ mkNode opts (PresentT (these (const Nothing) Just (const . const Nothing) th)) ["ThatToMaybe"] [] + +data TheseToMaybe + +instance P TheseToMaybe (These a b) where + type PP TheseToMaybe (These a b) = Maybe (a,b) + eval _ opts th = pure $ mkNode opts (PresentT (these (const Nothing) (const Nothing) ((Just .) . (,)) th)) ["TheseToMaybe"] [] + +-- | similar to 'Control.Arrow.|||' but additionally gives \'p\' and \'q\' the original input +-- +-- >>> pl @(EitherX (ShowP (Fst (Fst Id) + Snd Id)) (ShowP Id) (Snd Id)) (9,Left 123) +-- Present "132" +-- PresentT "132" +-- +-- >>> pl @(EitherX (ShowP (Fst (Fst Id) + Snd Id)) (ShowP Id) (Snd Id)) (9,Right 'x') +-- Present "((9,Right 'x'),'x')" +-- PresentT "((9,Right 'x'),'x')" +-- +-- >>> pl @(EitherX (ShowP Id) (ShowP (Second (Succ Id))) (Snd Id)) (9,Right 'x') +-- Present "((9,Right 'x'),'y')" +-- PresentT "((9,Right 'x'),'y')" +-- +data EitherX p q r +instance (P r x + , P p (x,a) + , P q (x,b) + , PP r x ~ Either a b + , PP p (x,a) ~ c + , PP q (x,b) ~ c + ) => P (EitherX p q r) x where + type PP (EitherX p q r) x = EitherXT (PP r x) x p + eval _ opts x = do + let msg0 = "EitherX" + rr <- eval (Proxy @r) opts x + case getValueLR opts msg0 rr [] of + Left e -> pure e + Right (Left a) -> do + let msg1 = msg0 <> "(Left)" + pp <- eval (Proxy @p) opts (x,a) + pure $ case getValueLR opts msg1 pp [hh rr] of + Left e -> e + Right _ -> mkNode opts (_tBool pp) [msg1] [hh rr, hh pp] + Right (Right b) -> do + let msg1 = msg0 <> "(Right)" + qq <- eval (Proxy @q) opts (x,b) + pure $ case getValueLR opts msg1 qq [hh rr] of + Left e -> e + Right _ -> mkNode opts (_tBool qq) [msg1] [hh rr, hh qq] + +type family EitherXT lr x p where + EitherXT (Either a b) x p = PP p (x,a) + +-- | similar to 'Data.These.mergeTheseWith' but additionally provides \'p\', '\q'\ and \'r\' the original input as the first element in the tuple +-- +-- >>> pl @(TheseX ((Fst (Fst Id) + Snd Id) >> ShowP Id) (ShowP Id) (Snd (Snd Id)) (Snd Id)) (9,This 123) +-- Present "132" +-- PresentT "132" +-- +-- >>> pl @(TheseX '(Snd Id,"fromthis") '(Negate 99,Snd Id) (Snd Id) Id) (This 123) +-- Present (123,"fromthis") +-- PresentT (123,"fromthis") +-- +-- >>> pl @(TheseX '(Snd Id,"fromthis") '(Negate 99,Snd Id) (Snd Id) Id) (That "fromthat") +-- Present (-99,"fromthat") +-- PresentT (-99,"fromthat") +-- +-- >>> pl @(TheseX '(Snd Id,"fromthis") '(Negate 99,Snd Id) (Snd Id) Id) (These 123 "fromthese") +-- Present (123,"fromthese") +-- PresentT (123,"fromthese") +-- +data TheseX p q r s + +instance (P s x + , P p (x,a) + , P q (x,b) + , P r (x,(a,b)) + , PP s x ~ These a b + , PP p (x,a) ~ c + , PP q (x,b) ~ c + , PP r (x,(a,b)) ~ c + ) => P (TheseX p q r s) x where + type PP (TheseX p q r s) x = TheseXT (PP s x) x p + eval _ opts x = do + let msg0 = "TheseX" + ss <- eval (Proxy @s) opts x + case getValueLR opts msg0 ss [] of + Left e -> pure e + Right (This a) -> do + let msg1 = msg0 <> "(This)" + pp <- eval (Proxy @p) opts (x,a) + pure $ case getValueLR opts msg1 pp [hh ss] of + Left e -> e + Right _ -> mkNode opts (_tBool pp) [msg1] [hh ss, hh pp] + Right (That b) -> do + let msg1 = msg0 <> "(That)" + qq <- eval (Proxy @q) opts (x,b) + pure $ case getValueLR opts msg1 qq [hh ss] of + Left e -> e + Right _ -> mkNode opts (_tBool qq) [msg1] [hh ss, hh qq] + Right (These a b) -> do + let msg1 = msg0 <> "(These)" + rr <- eval (Proxy @r) opts (x,(a,b)) + pure $ case getValueLR opts msg1 rr [hh ss] of + Left e -> e + Right _ -> mkNode opts (_tBool rr) [msg1] [hh ss, hh rr] + +type family TheseXT lr x p where + TheseXT (These a b) x p = PP p (x,a) + +-- | similar to 'maybe' +-- +-- similar to 'MaybeX' but provides a Proxy to the result of \'q\' and does not provide the surrounding context +-- +-- >>> pl @(MaybeIn "foundnothing" (ShowP (Pred Id))) (Just 20) +-- Present "19" +-- PresentT "19" +-- +-- >>> pl @(MaybeIn "found nothing" (ShowP (Pred Id))) Nothing +-- Present "found nothing" +-- PresentT "found nothing" +-- +data MaybeIn p q +type IsNothing = MaybeIn 'True 'False +type IsJust = MaybeIn 'False 'True + +-- tricky: the nothing case is the proxy of PP q a: ie proxy of the final result!! +-- this is different from MaybeXP which gives you a proxy of 'a' [you need both!] +instance (P q a + , Show a + , Show (PP q a) + , PP p (Proxy (PP q a)) ~ PP q a + , P p (Proxy (PP q a)) + ) => P (MaybeIn p q) (Maybe a) where + type PP (MaybeIn p q) (Maybe a) = PP q a + eval _ opts ma = do + let msg0 = "MaybeIn" + case ma of + Nothing -> do + let msg1 = msg0 <> "(Nothing)" + pp <- eval (Proxy @p) opts (Proxy @(PP q a)) + pure $ case getValueLR opts msg1 pp [] of + Left e -> e + Right b -> mkNode opts (_tBool pp) [msg1 <> show0 opts " " b <> " | Proxy"] [hh pp] + Just a -> do + let msg1 = msg0 <> "(Nothing)" + qq <- eval (Proxy @q) opts a + pure $ case getValueLR opts msg1 qq [] of + Left e -> e + Right b -> mkNode opts (_tBool qq) [show01 opts msg1 b a] [hh qq] + + +-- | similar to 'SG.stimes' +-- +-- >>> pl @(STimes 4 Id) (SG.Sum 3) +-- Present Sum {getSum = 12} +-- PresentT (Sum {getSum = 12}) +-- +-- >>> pl @(STimes 4 Id) "ab" +-- Present "abababab" +-- PresentT "abababab" +-- +data STimes n p +instance (P n a + , Integral (PP n a) + , Semigroup (PP p a) + , P p a + , Show (PP p a) + ) => P (STimes n p) a where + type PP (STimes n p) a = PP p a + eval _ opts a = do + let msg0 = "STimes" + lr <- runPQ msg0 (Proxy @n) (Proxy @p) opts a + pure $ case lr of + Left e -> e + Right (fromIntegral -> (n::Int),p,pp,qq) -> + let msg1 = msg0 <> show0 opts " " n <> " p=" <> show p + b = SG.stimes n p + in mkNode opts (PresentT b) [show01' opts msg1 b "n=" n <> show1 opts " | " p] [hh pp, hh qq] + + +-- | similar to 'pure' +-- +-- >>> pl @(Pure Maybe Id) 4 +-- Present Just 4 +-- PresentT (Just 4) +-- +-- >>> pl @(Pure [] Id) 4 +-- Present [4] +-- PresentT [4] +-- +-- >>> pl @(Pure (Either String) (Fst Id)) (13,True) +-- Present Right 13 +-- PresentT (Right 13) +-- +data Pure (t :: Type -> Type) p +instance (P p x + , Show (PP p x) + , Show (t (PP p x)) + , Applicative t + ) => P (Pure t p) x where + type PP (Pure t p) x = t (PP p x) + eval _ opts x = do + let msg0 = "Pure" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right a -> + let b = pure a + in mkNode opts (PresentT b) [show01 opts msg0 b a] [hh pp] + +-- type PMEmpty = MEmptyT' 'Proxy -- lifts 'a' to 'Proxy a' then we can use it with MEmptyP + +-- | similar to 'mempty' +-- +-- >>> pl @(MEmptyT (SG.Sum Int)) () +-- Present Sum {getSum = 0} +-- PresentT (Sum {getSum = 0}) +-- +-- no Monoid for Maybe a unless a is also a monoid but can use empty! +data MEmptyT' t +type MEmptyT (t :: Type) = MEmptyT' (Hole t) +type MEmptyP = MEmptyT' Unproxy -- expects a proxy: so only some things work with this: eg Pad MaybeIn etc + +instance (Show (PP t a), Monoid (PP t a)) => P (MEmptyT' t) a where + type PP (MEmptyT' t) a = PP t a + eval _ opts _ = + let msg0 = "MEmptyT" + b = mempty @(PP t a) + in pure $ mkNode opts (PresentT b) [msg0 <> show0 opts " " b] [] +{- +data MEmptyProxy +instance Monoid a => P MEmptyProxy (Proxy (a :: Type)) where + type PP MEmptyProxy (Proxy a) = a + eval _ opts _pa = + let msg0 = "MEmptyProxy" + b = mempty @a + in pure $ mkNode opts (PresentT b) [msg0] [] +-} +-- | similar to 'empty' +-- +-- >>> pl @(EmptyT Maybe Id) () +-- Present Nothing +-- PresentT Nothing +-- +-- >>> pl @(EmptyT [] Id) () +-- Present [] +-- PresentT [] +-- +-- >>> pl @(EmptyT [] (Char1 "x")) (13,True) +-- Present "" +-- PresentT "" +-- +-- >>> pl @(EmptyT (Either String) (Fst Id)) (13,True) +-- Present Left "" +-- PresentT (Left "") +-- + +data EmptyT (t :: Type -> Type) p + +instance (P p x + , PP p x ~ a + , Show (t a) + , Show a + , Alternative t + ) => P (EmptyT t p) x where + type PP (EmptyT t p) x = t (PP p x) + eval _ opts x = do + let msg0 = "EmptyT" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = empty @t + in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] + +data MkNothing' t -- works always! MaybeBool is a good alternative and then dont need the extra 't' +type MkNothing (t :: Type) = MkNothing' (Hole t) + +-- for this to be useful has to have 't' else we end up with tons of problems +instance P (MkNothing' t) a where + type PP (MkNothing' t) a = Maybe (PP t a) + eval _ opts _ = + let msg0 = "MkNothing" + in pure $ mkNode opts (PresentT Nothing) [msg0] [] + +-- | 'Just' constructor +-- +-- >>> pl @(MkJust Id) 44 +-- Present Just 44 +-- PresentT (Just 44) +-- +data MkJust p +instance (PP p x ~ a, P p x, Show a) => P (MkJust p) x where + type PP (MkJust p) x = Maybe (PP p x) + eval _ opts x = do + let msg0 = "MkJust" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = Just p + in mkNode opts (PresentT d) [msg0 <> show0 opts " Just " p] [hh pp] + +-- | 'Data.Either.Left' constructor +-- +-- >>> pl @(MkLeft _ Id) 44 +-- Present Left 44 +-- PresentT (Left 44) +-- +data MkLeft' t p +type MkLeft (t :: Type) p = MkLeft' (Hole t) p + +instance (Show (PP p x), P p x) => P (MkLeft' t p) x where + type PP (MkLeft' t p) x = Either (PP p x) (PP t x) + eval _ opts x = do + let msg0 = "MkLeft" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = Left p + in mkNode opts (PresentT d) [msg0 <> show0 opts " Left " p] [hh pp] + +-- | 'Data.Either.Right' constructor +-- +-- >>> pl @(MkRight _ Id) 44 +-- Present Right 44 +-- PresentT (Right 44) +-- +data MkRight' t p +type MkRight (t :: Type) p = MkRight' (Hole t) p + +instance (Show (PP p x), P p x) => P (MkRight' t p) x where + type PP (MkRight' t p) x = Either (PP t x) (PP p x) + eval _ opts x = do + let msg0 = "MkRight" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = Right p + in mkNode opts (PresentT d) [msg0 <> show0 opts " Right " p] [hh pp] + +-- | 'Data.These.This' constructor +-- +-- >>> pl @(MkThis _ Id) 44 +-- Present This 44 +-- PresentT (This 44) +-- +data MkThis' t p +type MkThis (t :: Type) p = MkThis' (Hole t) p + +instance (Show (PP p x), P p x) => P (MkThis' t p) x where + type PP (MkThis' t p) x = These (PP p x) (PP t x) + eval _ opts x = do + let msg0 = "MkThis" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = This p + in mkNode opts (PresentT d) [msg0 <> show0 opts " This " p] [hh pp] + +-- | 'Data.These.That' constructor +-- +-- >>> pl @(MkThat _ Id) 44 +-- Present That 44 +-- PresentT (That 44) +-- +data MkThat' t p +type MkThat (t :: Type) p = MkThat' (Hole t) p + +instance (Show (PP p x), P p x) => P (MkThat' t p) x where + type PP (MkThat' t p) x = These (PP t x) (PP p x) + eval _ opts x = do + let msg0 = "MkThat" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let d = That p + in mkNode opts (PresentT d) [msg0 <> show0 opts " That " p] [hh pp] + +--type MkThat t p = MkThis t p >> Swap +-- type MkThat' (t :: Type) = Pure (These t) Id -- t has to be a semigroup + +-- | 'Data.These.These' constructor +-- +-- >>> pl @(MkThese (Fst Id) (Snd Id)) (44,'x') +-- Present These 44 'x' +-- PresentT (These 44 'x') +-- +data MkThese p q +instance (P p a + , P q a + , Show (PP p a) + , Show (PP q a) + ) => P (MkThese p q) a where + type PP (MkThese p q) a = These (PP p a) (PP q a) + eval _ opts a = do + let msg0 = "MkThese" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = These p q + in mkNode opts (PresentT d) [msg0 <> show0 opts " " d] [hh pp, hh qq] + +-- | similar to 'mconcat' +-- +-- >>> pl @(MConcat Id) [SG.Sum 44, SG.Sum 12, SG.Sum 3] +-- Present Sum {getSum = 59} +-- PresentT (Sum {getSum = 59}) +-- +data MConcat p + + +-- | similar to a limited form of 'foldMap' +-- +-- >>> pl @(FoldMap (SG.Sum _) Id) [44, 12, 3] +-- Present 59 +-- PresentT 59 +-- +-- >>> pl @(FoldMap (SG.Product _) Id) [44, 12, 3] +-- Present 1584 +-- PresentT 1584 +-- + +type FoldMap (t :: Type) p = Map (Wrap t Id) p >> Unwrap (MConcat Id) + +type Sum' (t :: Type) = FoldMap (SG.Sum t) Id +type Min' (t :: Type) = FoldMap (SG.Min t) Id -- requires t be Bounded for monoid instance +type Max' (t :: Type) = FoldMap (SG.Max t) Id -- requires t be Bounded for monoid instance + +instance (PP p x ~ [a] + , P p x + , Show a + , Monoid a + ) => P (MConcat p) x where + type PP (MConcat p) x = ExtractAFromTA (PP p x) + eval _ opts x = do + let msg0 = "MConcat" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = mconcat p + in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] + +-- | similar to 'concat' +-- +-- >>> pl @(Concat Id) ["abc","D","eF","","G"] +-- Present "abcDeFG" +-- PresentT "abcDeFG" +-- +-- >>> pl @(Concat (Snd Id)) ('x',["abc","D","eF","","G"]) +-- Present "abcDeFG" +-- PresentT "abcDeFG" +-- +data Concat p + +instance (Show a + , Show (t [a]) + , PP p x ~ (t [a]) + , P p x + , Foldable t + ) => P (Concat p) x where + type PP (Concat p) x = ExtractAFromTA (PP p x) + eval _ opts x = do + let msg0 = "Concat" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = concat p + in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] + +data ProxyT' t +type ProxyT (t :: Type) = ProxyT' (Hole t) + +instance Typeable t => P (ProxyT' (t :: Type)) a where + type PP (ProxyT' t) a = Proxy (PP t a) + eval _ opts _ = + let t = showT @t + in pure $ mkNode opts (PresentT Proxy) ["ProxyT(" <> show t ++ ")"] [] + +-- | similar to 'Data.List.!!' +-- +-- >>> pl @(Ix 4 "not found") ["abc","D","eF","","G"] +-- Present "G" +-- PresentT "G" +-- +-- >>> pl @(Ix 40 "not found") ["abc","D","eF","","G"] +-- Present "not found" +-- PresentT "not found" +-- +data Ix (n :: Nat) def +type Ix' (n :: Nat) = Ix n (Failp "Ix index not found") + +instance (P def (Proxy a) + , PP def (Proxy a) ~ a + , KnownNat n + , Show a + ) => P (Ix n def) [a] where + type PP (Ix n def) [a] = a + eval _ opts as = do + let n = nat @n + msg0 = "Ix " <> show n + case as ^? ix n of + Nothing -> do + let msg1 = msg0 <> " not found" + pp <- eval (Proxy @def) opts (Proxy @a) + pure $ case getValueLR opts msg1 pp [] of + Left e -> e + Right _ -> mkNode opts (_tBool pp) [msg1] [hh pp] + Just a -> pure $ mkNode opts (PresentT a) [msg0 <> show0 opts " " a] [] + +-- | similar to 'Data.List.!!' leveraging 'Ixed' +-- +-- >>> import qualified Data.Map.Strict as M +-- >>> pl @(Id !! 2) ["abc","D","eF","","G"] +-- Present "eF" +-- PresentT "eF" +-- +-- >>> pl @(Id !! 20) ["abc","D","eF","","G"] +-- Error (!!) index not found +-- FailT "(!!) index not found" +-- +-- >>> pl @(Id !! "eF") (M.fromList (flip zip [0..] ["abc","D","eF","","G"])) +-- Present 2 +-- PresentT 2 +-- +data IxL p q def -- p is the big value and q is the index and def is the default +type p !! q = IxL p q (Failp "(!!) index not found") +instance (P q a + , P p a + , Show (PP p a) + , Ixed (PP p a) + , PP q a ~ Index (PP p a) + , Show (Index (PP p a)) + , Show (IxValue (PP p a)) + , P r (Proxy (IxValue (PP p a))) + , PP r (Proxy (IxValue (PP p a))) ~ IxValue (PP p a) + ) + => P (IxL p q r) a where + type PP (IxL p q r) a = IxValue (PP p a) + eval _ opts a = do + let msg0 = "IxL" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a + case lr of + Left e -> pure e + Right (p,q,pp,qq) -> + let msg1 = msg0 <> "(" <> show q <> ")" + in case p ^? ix q of + Nothing -> do + rr <- eval (Proxy @r) opts (Proxy @(IxValue (PP p a))) + pure $ case getValueLR opts msg1 rr [hh pp, hh qq] of + Left e -> e + Right _ -> mkNode opts (_tBool rr) [msg1 <> " index not found"] [hh pp, hh qq] + Just ret -> pure $ mkNode opts (PresentT ret) [show01' opts msg1 ret "p=" p <> show1 opts " | q=" q] [hh pp, hh qq] + +-- | 'lookup' leveraging 'Ixed' +-- +-- >>> pl @(Id !!! 2) ["abc","D","eF","","G"] +-- Present "eF" +-- PresentT "eF" +-- +-- >>> pl @(Id !!! 20) ["abc","D","eF","","G"] +-- Error index not found +-- FailT "index not found" +-- +-- >>> pl @(Id !!! "eF") (M.fromList (flip zip [0..] ["abc","D","eF","","G"])) +-- Present 2 +-- PresentT 2 +-- +-- >>> pl @(Lookup Id 2) ["abc","D","eF","","G"] +-- Present Just "eF" +-- PresentT (Just "eF") +-- +-- >>> pl @(Lookup Id 20) ["abc","D","eF","","G"] +-- Present Nothing +-- PresentT Nothing +-- +data Lookup p q +type p !!! q = Lookup p q >> MaybeIn (Failp "index not found") Id -- use !! +-- Lookup' is interesting but just use Lookup or !! +type Lookup' (t :: Type) p q = q &&& Lookup p q >> If (Snd Id >> IsNothing) (ShowP (Fst Id) >> Fail (Hole t) (Printf "index(%s) not found" Id)) (Snd Id >> 'Just Id) + +instance (P q a + , P p a + , Show (PP p a) + , Ixed (PP p a) + , PP q a ~ Index (PP p a) + , Show (Index (PP p a)) + , Show (IxValue (PP p a)) + ) + => P (Lookup p q) a where + type PP (Lookup p q) a = Maybe (IxValue (PP p a)) + eval _ opts a = do + let msg0 = "Lookup" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let msg1 = msg0 <> "(" <> show q <> ")" + hhs = [hh pp, hh qq] + in case p ^? ix q of + Nothing -> mkNode opts (PresentT Nothing) [msg1 <> " not found"] hhs + Just ret -> mkNode opts (PresentT (Just ret)) [show01' opts msg1 ret "p=" p <> show1 opts " | q=" q] hhs + +-- | 'Data.List.ands' +-- +-- >>> pl @(Ands Id) [True,True,True] +-- True +-- TrueT +-- +-- >>> pl @(Ands Id) [True,True,True,False] +-- False +-- FalseT +-- +-- >>> pl @(Ands Id) [] +-- True +-- TrueT +-- +data Ands p +type Ands' p = FoldMap SG.All p + +instance (PP p x ~ t a + , P p x + , Show (t a) + , Foldable t + , a ~ Bool + ) => P (Ands p) x where + type PP (Ands p) x = Bool + eval _ opts x = do + let msg0 = "Ands" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = and p + in mkNodeB opts b [msg0 <> show1 opts " | " p] [hh pp] + +-- | 'Data.List.ors' +-- +-- >>> pl @(Ors Id) [False,False,False] +-- False +-- FalseT +-- +-- >>> pl @(Ors Id) [True,True,True,False] +-- True +-- TrueT +-- +-- >>> pl @(Ors Id) [] +-- False +-- FalseT +-- +data Ors p +type Ors' p = FoldMap SG.Any p + +instance (PP p x ~ t a + , P p x + , Show (t a) + , Foldable t + , a ~ Bool + ) => P (Ors p) x where + type PP (Ors p) x = Bool + eval _ opts x = do + let msg0 = "Ors" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = or p + in mkNodeB opts b [msg0 <> show1 opts " | " p] [hh pp] + +-- cant directly create a singleton type using '[] since the type of '[] is unknown. instead use 'Singleton' or 'EmptyT' + +-- | similar to cons +-- +-- >>> pl @(Fst Id :+ Snd Id) (99,[1,2,3,4]) +-- Present [99,1,2,3,4] +-- PresentT [99,1,2,3,4] +-- +-- >>> pl @(Snd Id :+ Fst Id) ([],5) +-- Present [5] +-- PresentT [5] +-- +-- >>> pl @(123 :+ EmptyList _) "somestuff" +-- Present [123] +-- PresentT [123] +-- +data p :+ q +infixr 5 :+ +instance (P p x + , P q x + , Show (PP p x) + , Show (PP q x) + , Cons (PP q x) (PP q x) (PP p x) (PP p x) + ) => P (p :+ q) x where + type PP (p :+ q) x = PP q x + eval _ opts z = do + let msg0 = "(:+)" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts z + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let b = p `cons` q + in mkNode opts (PresentT b) [show01' opts msg0 b "p=" p <> show1 opts " | q=" q] [hh pp, hh qq] + +-- | similar to snoc +-- +-- >>> pl @(Snd Id +: Fst Id) (99,[1,2,3,4]) +-- Present [1,2,3,4,99] +-- PresentT [1,2,3,4,99] +-- +-- >>> pl @(Fst Id +: Snd Id) ([],5) +-- Present [5] +-- PresentT [5] +-- +-- >>> pl @(EmptyT [] Id +: 5) 5 +-- Present [5] +-- PresentT [5] +-- +data p +: q +infixl 5 +: + +instance (P p x + , P q x + , Show (PP q x) + , Show (PP p x) + , Snoc (PP p x) (PP p x) (PP q x) (PP q x) + ) => P (p +: q) x where + type PP (p +: q) x = PP p x + eval _ opts z = do + let msg0 = "(+:)" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts z + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let b = p `snoc` q + in mkNode opts (PresentT b) [show01' opts msg0 b "p=" p <> show1 opts " | q=" q] [hh pp, hh qq] + +-- | 'Control.Lens.uncons' +-- +-- >>> pl @Uncons [1,2,3,4] +-- Present Just (1,[2,3,4]) +-- PresentT (Just (1,[2,3,4])) +-- +-- >>> pl @Uncons [] +-- Present Nothing +-- PresentT Nothing +-- +-- >>> pl @Uncons (Seq.fromList "abc") +-- Present Just ('a',fromList "bc") +-- PresentT (Just ('a',fromList "bc")) +-- +-- >>> pl @Uncons ("xyz" :: T.Text) +-- Present Just ('x',"yz") +-- PresentT (Just ('x',"yz")) +-- +data Uncons + +instance (Show (ConsT s) + , Show s + , Cons s s (ConsT s) (ConsT s) + ) => P Uncons s where + type PP Uncons s = Maybe (ConsT s,s) + eval _ opts as = + let msg0 = "Uncons" + b = as ^? _Cons + in pure $ mkNode opts (PresentT b) [show01 opts msg0 b as] [] + +-- | 'Control.Lens.unsnoc' +-- +-- >>> pl @Unsnoc [1,2,3,4] +-- Present Just ([1,2,3],4) +-- PresentT (Just ([1,2,3],4)) +-- +-- >>> pl @Unsnoc [] +-- Present Nothing +-- PresentT Nothing +-- +-- >>> pl @Unsnoc ("xyz" :: T.Text) +-- Present Just ("xy",'z') +-- PresentT (Just ("xy",'z')) +-- +data Unsnoc + +instance (Show (ConsT s) + , Show s + , Snoc s s (ConsT s) (ConsT s) + ) => P Unsnoc s where + type PP Unsnoc s = Maybe (s,ConsT s) + eval _ opts as = + let msg0 = "Unsnoc" + b = as ^? _Snoc + in pure $ mkNode opts (PresentT b) [show01 opts msg0 b as] [] + +-- | similar to 'null' using 'AsEmpty' +-- +-- >>> pl @IsEmpty [1,2,3,4] +-- False +-- FalseT +-- +-- >>> pl @IsEmpty [] +-- True +-- TrueT +-- +-- >>> pl @IsEmpty LT +-- False +-- FalseT +-- +-- >>> pl @IsEmpty EQ +-- True +-- TrueT +-- +data IsEmpty + +instance (Show as, AsEmpty as) => P IsEmpty as where + type PP IsEmpty as = Bool + eval _ opts as = + let b = has _Empty as + in pure $ mkNodeB opts b ["IsEmpty" <> show1 opts " | " as] [] + +-- | similar to 'null' using 'Foldable' +-- +-- >>> pl @Null [1,2,3,4] +-- False +-- FalseT +-- +-- >>> pl @Null [] +-- True +-- TrueT +-- +-- >>> pl @Null Nothing +-- True +-- TrueT +-- +data Null + +instance (Show (t a) + , Foldable t + , t a ~ as + ) => P Null as where + type PP Null as = Bool + eval _ opts as = + let b = null as + in pure $ mkNodeB opts b ["Null" <> show1 opts " | " as] [] + +-- | similar to 'enumFromTo' +-- +-- >>> pl @(EnumFromTo 2 5) () +-- Present [2,3,4,5] +-- PresentT [2,3,4,5] +-- +-- >>> pl @(EnumFromTo 'LT 'GT) () +-- Present [LT,EQ,GT] +-- PresentT [LT,EQ,GT] +-- +-- >>> pl @(EnumFromTo 'GT 'LT) () +-- Present [] +-- PresentT [] +-- +-- >>> pl @(EnumFromTo (Pred Id) (Succ Id)) (SG.Max 10) +-- Present [Max {getMax = 9},Max {getMax = 10},Max {getMax = 11}] +-- PresentT [Max {getMax = 9},Max {getMax = 10},Max {getMax = 11}] +-- + +data EnumFromTo p q +instance (P p x + , P q x + , PP p x ~ a + , Show a + , PP q x ~ a + , Enum a + ) => P (EnumFromTo p q) x where + type PP (EnumFromTo p q) x = [PP p x] + eval _ opts z = do + let msg0 = "EnumFromTo" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts z + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> mkNode opts (PresentT (enumFromTo p q)) [msg0 <> " [" <> show p <> " .. " <> show q <> "]"] [hh pp, hh qq] + +type MapMaybe p q = ConcatMap (p >> MaybeIn MEmptyP '[Id]) q +type CatMaybes q = MapMaybe Id q + +-- | similar to 'partitionEithers' +-- +-- >>> pl @PartitionEithers [Left 'a',Right 2,Left 'c',Right 4,Right 99] +-- Present ("ac",[2,4,99]) +-- PresentT ("ac",[2,4,99]) +-- +-- >>> pl @PartitionEithers [Right 2,Right 4,Right 99] +-- Present ([],[2,4,99]) +-- PresentT ([],[2,4,99]) +-- +-- >>> pl @PartitionEithers [Left 'a',Left 'c'] +-- Present ("ac",[]) +-- PresentT ("ac",[]) +-- +-- >>> pl @PartitionEithers ([] @(Either _ _)) +-- Present ([],[]) +-- PresentT ([],[]) +-- +data PartitionEithers + +instance (Show a, Show b) => P PartitionEithers [Either a b] where + type PP PartitionEithers [Either a b] = ([a], [b]) + eval _ opts as = + let msg0 = "PartitionEithers" + b = partitionEithers as + in pure $ mkNode opts (PresentT b) [show01 opts msg0 b as] [] + +-- | similar to 'partitionThese'. returns a 3-tuple with the results so use 'Fst' 'Snd' 'Thd' to extract +-- +-- >>> pl @PartitionThese [This 'a', That 2, This 'c', These 'z' 1, That 4, These 'a' 2, That 99] +-- Present ("ac",[2,4,99],[('z',1),('a',2)]) +-- PresentT ("ac",[2,4,99],[('z',1),('a',2)]) +-- +data PartitionThese +instance (Show a, Show b) => P PartitionThese [These a b] where + type PP PartitionThese [These a b] = ([a], [b], [(a, b)]) + eval _ opts as = + let msg0 = "PartitionThese" + b = partitionThese as + in pure $ mkNode opts (PresentT b) [show01 opts msg0 b as] [] + +type Thiss = Fst PartitionThese +type Thats = Snd PartitionThese +type Theses = Thd PartitionThese + +-- want to pass Proxy b to q but then we have no way to calculate 'b' + +-- | similar to 'scanl' +-- +-- >>> pl @(Scanl (Snd Id :+ Fst Id) (Fst Id) (Snd Id)) ([99],[1..5]) +-- Present [[99],[1,99],[2,1,99],[3,2,1,99],[4,3,2,1,99],[5,4,3,2,1,99]] +-- PresentT [[99],[1,99],[2,1,99],[3,2,1,99],[4,3,2,1,99],[5,4,3,2,1,99]] +-- +-- >>> pl @(ScanN 4 Id (Succ Id)) 'c' +-- Present "cdefg" +-- PresentT "cdefg" +-- +-- >>> pl @(FoldN 4 Id (Succ Id)) 'c' +-- Present 'g' +-- PresentT 'g' +-- + +data Scanl p q r +-- scanr :: (a -> b -> b) -> b -> [a] -> [b] +-- result is scanl but signature is flipped ((a,b) -> b) -> b -> [a] -> [b] + +type ScanN n p q = Scanl (Fst Id >> q) p (EnumFromTo 1 n) -- n times using q then run p +type ScanNA q = ScanN (Fst Id) (Snd Id) q + +type FoldN n p q = Last' (ScanN n p q) +type Foldl p q r = Last' (Scanl p q r) + +instance (PP p (b,a) ~ b + , PP q x ~ b + , PP r x ~ [a] + , P p (b,a) + , P q x + , P r x + , Show b + , Show a + ) + => P (Scanl p q r) x where + type PP (Scanl p q r) x = [PP q x] + eval _ opts z = do + let msg0 = "Scanl" + lr <- runPQ msg0 (Proxy @q) (Proxy @r) opts z + case lr of + Left e -> pure e + Right (q,r,qq,rr) -> do + let msg1 = msg0 -- <> show0 opts " " q <> show0 opts " " r + ff i b as' rs + | i >= _MX = pure (rs, Left $ mkNode opts (FailT (msg1 <> ":failed at i=" <> show i)) [msg1 <> " i=" <> show i <> " (b,as')=" <> show (b,as')] []) + | otherwise = + case as' of + [] -> pure (rs, Right ()) -- ++ [((i,q), mkNode opts (PresentT q) [msg1 <> "(done)"] [])], Right ()) + a:as -> do + pp :: TT b <- eval (Proxy @p) opts (b,a) + case getValueLR opts (msg1 <> " i=" <> show i <> " a=" <> show a) pp [] of + Left e -> pure (rs,Left e) + Right b' -> ff (i+1) b' as (rs ++ [((i,b), pp)]) + (ts,lrx) :: ([((Int, b), TT b)], Either (TT [b]) ()) <- ff 1 q r [] + pure $ case splitAndAlign opts [msg1] (((0,q), mkNode opts (PresentT q) [msg1 <> "(initial)"] []) : ts) of + Left _e -> error "cant happen!" + Right (vals,itts) -> + case lrx of + Left e -> mkNode opts (_tBool e) [msg1] (hh qq : hh rr : map (hh . fixit) itts ++ [hh e]) + Right () -> mkNode opts (PresentT vals) [show01' opts msg1 vals "b=" q <> show1 opts " | as=" r] (hh qq : hh rr : map (hh . fixit) itts) + +type family UnfoldT mbs where + UnfoldT (Maybe (b,s)) = b + +-- | similar to 'unfoldr' +-- +-- >>> pl @(Unfoldr (MaybeBool (Not Null) (SplitAt 2 Id)) Id) [1..5] +-- Present [[1,2],[3,4],[5]] +-- PresentT [[1,2],[3,4],[5]] +-- +-- >>> pl @(IterateN 4 (Succ Id)) 4 +-- Present [4,5,6,7] +-- PresentT [4,5,6,7] +-- +data Unfoldr p q +--type IterateN (t :: Type) n f = Unfoldr (If (Fst Id == 0) (MkNothing t) (Snd Id &&& (Pred Id *** f) >> MkJust Id)) '(n, Id) +type IterateN n f = Unfoldr (MaybeBool (Fst Id > 0) '(Snd Id, Pred Id *** f)) '(n, Id) +type IterateUntil p f = IterateWhile (Not p) f +type IterateWhile p f = Unfoldr (MaybeBool p '(Id, f)) Id +type IterateNWhile n p f = '(n, Id) >> IterateWhile (Fst Id > 0 && (Snd Id >> p)) (Pred Id *** f) >> Map (Snd Id) Id +type IterateNUntil n p f = IterateNWhile n (Not p) f + +instance (PP q a ~ s + , PP p s ~ Maybe (b,s) + , P q a + , P p s + , Show s + , Show b + ) + => P (Unfoldr p q) a where + type PP (Unfoldr p q) a = [UnfoldT (PP p (PP q a))] + eval _ opts z = do + let msg0 = "Unfoldr" + qq <- eval (Proxy @q) opts z + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right q -> do + let msg1 = msg0 <> show0 opts " " q + ff i s rs | i >= _MX = pure (rs, Left $ mkNode opts (FailT (msg1 <> ":failed at i=" <> show i)) [msg1 <> " i=" <> show i <> " s=" <> show s] []) + | otherwise = do + pp :: TT (PP p s) <- eval (Proxy @p) opts s + case getValueLR opts (msg1 <> " i=" <> show i <> " s=" <> show s) pp [] of + Left e -> pure (rs, Left e) + Right Nothing -> pure (rs, Right ()) + Right w@(Just (_b,s')) -> ff (i+1) s' (rs ++ [((i,w), pp)]) + (ts,lr) :: ([((Int, PP p s), TT (PP p s))], Either (TT [b]) ()) <- ff 1 q [] + pure $ case splitAndAlign opts [msg1] ts of + Left _e -> error "cant happen" + Right (vals, itts) -> + case lr of + Left e -> mkNode opts (_tBool e) [msg1] (hh qq : map (hh . fixit) itts ++ [hh e]) + Right () -> + let ret = fst <$> catMaybes vals + in mkNode opts (PresentT ret) [show01' opts msg1 ret "s=" q ] (hh qq : map (hh . fixit) itts) + +-- | similar to 'map' +-- +-- >>> pl @(Map (Pred Id) Id) [1..5] +-- Present [0,1,2,3,4] +-- PresentT [0,1,2,3,4] +-- +data Map p q +type ConcatMap p q = Concat (Map p q) + +instance (Show (PP p a) + , P p a + , PP q x ~ f a + , P q x + , Show a + , Show (f a) + , Foldable f + ) => P (Map p q) x where + type PP (Map p q) x = [PP p (ExtractAFromTA (PP q x))] + eval _ opts x = do + let msg0 = "Map" + qq <- eval (Proxy @q) opts x + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right as -> do + ts <- zipWithM (\i a -> ((i, a),) <$> eval (Proxy @p) opts a) [0::Int ..] (toList as) + pure $ case splitAndAlign opts [msg0] ts of + Left e -> e + Right (vals, _) -> mkNode opts (PresentT vals) [show01 opts msg0 vals as] (hh qq : map (hh . fixit) ts) + +-- | if p then run q else run r +-- +-- >>> pl @(If (Gt 4) "greater than 4" "less than or equal to 4" ) 10 +-- Present "greater than 4" +-- PresentT "greater than 4" +-- +-- >>> pl @(If (Gt 4) "greater than 4" "less than or equal to 4") 0 +-- Present "less than or equal to 4" +-- PresentT "less than or equal to 4" +data If p q r + +instance (Show (PP r a) + , P p a + , PP p a ~ Bool + , P q a + , P r a + , PP q a ~ PP r a + ) => P (If p q r) a where + type PP (If p q r) a = PP q a + eval _ opts a = do + let msg0 = "If" + pp <- evalBool (Proxy @p) opts a + case getValueLR opts (msg0 <> " condition failed") pp [] of + Left e -> pure e + Right b -> do + qqrr <- if b + then eval (Proxy @q) opts a + else eval (Proxy @r) opts a + pure $ case getValueLR opts (msg0 <> " [" <> show b <> "]") qqrr [hh pp, hh qqrr] of + Left e -> e + Right ret -> mkNode opts (_tBool qqrr) [msg0 <> " " <> if b then "(true cond)" else "(false cond)" <> show0 opts " " ret] [hh pp, hh qqrr] + +-- | creates a list of overlapping pairs of elements. requires two or more elements +-- +-- >>> pl @Pairs [1,2,3,4] +-- Present [(1,2),(2,3),(3,4)] +-- PresentT [(1,2),(2,3),(3,4)] +-- +-- >>> pl @Pairs [] +-- Error Pairs no data found +-- FailT "Pairs no data found" +-- +-- >>> pl @Pairs [1] +-- Error Pairs only one element found +-- FailT "Pairs only one element found" +-- +data Pairs +instance Show a => P Pairs [a] where + type PP Pairs [a] = [(a,a)] + eval _ opts as = + let msg0 = "Pairs" + lr = case as of + [] -> Left (msg0 <> " no data found") + [_] -> Left (msg0 <> " only one element found") + _:bs@(_:_) -> Right (zip as bs) + in pure $ case lr of + Left e -> mkNode opts (FailT e) [e] [] + Right zs -> mkNode opts (PresentT zs) [show01 opts msg0 zs as ] [] + + +-- | similar to 'partition' +-- +-- >>> pl @(Partition (Ge 3) Id) [10,4,1,7,3,1,3,5] +-- Present ([10,4,7,3,3,5],[1,1]) +-- PresentT ([10,4,7,3,3,5],[1,1]) +-- +-- >>> pl @(Partition (Prime Id) Id) [10,4,1,7,3,1,3,5] +-- Present ([7,3,3,5],[10,4,1,1]) +-- PresentT ([7,3,3,5],[10,4,1,1]) +-- +-- >>> pl @(Partition (Ge 300) Id) [10,4,1,7,3,1,3,5] +-- Present ([],[10,4,1,7,3,1,3,5]) +-- PresentT ([],[10,4,1,7,3,1,3,5]) +-- +-- >>> pl @(Partition (Id < 300) Id) [10,4,1,7,3,1,3,5] +-- Present ([10,4,1,7,3,1,3,5],[]) +-- PresentT ([10,4,1,7,3,1,3,5],[]) +-- +data Partition p q + +type FilterBy p q = Partition p q >> Fst Id + +instance (P p x + , Show x + , PP q a ~ [x] + , PP p x ~ Bool + , P q a + ) => P (Partition p q) a where + type PP (Partition p q) a = (PP q a, PP q a) + eval _ opts a' = do + let msg0 = "Partition" + qq <- eval (Proxy @q) opts a' + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right as -> do + ts <- zipWithM (\i a -> ((i, a),) <$> evalBool (Proxy @p) opts a) [0::Int ..] as + pure $ case splitAndAlign opts [msg0] ts of + Left e -> e + Right (vals, tfs) -> + let w0 = partition fst $ zip vals tfs + zz1 = (map (snd . fst . snd) *** map (snd . fst . snd)) w0 + in mkNode opts (PresentT zz1) [show01' opts msg0 zz1 "s=" as] (hh qq : map (hh . fixit) tfs) + + +-- | similar to 'break' +-- +-- >>> pl @(Break (Ge 3) Id) [10,4,1,7,3,1,3,5] +-- Present ([],[10,4,1,7,3,1,3,5]) +-- PresentT ([],[10,4,1,7,3,1,3,5]) +-- +-- >>> pl @(Break (Lt 3) Id) [10,4,1,7,3,1,3,5] +-- Present ([10,4],[1,7,3,1,3,5]) +-- PresentT ([10,4],[1,7,3,1,3,5]) +-- +data Break p q +type Span p q = Break (Not p) q +-- only process up to the pivot! only process while Right False +-- a predicate can return PresentP not just TrueP +instance (P p x + , PP q a ~ [x] + , PP p x ~ Bool + , P q a + ) => P (Break p q) a where + type PP (Break p q) a = (PP q a, PP q a) + eval _ opts a' = do + let msg0 = "Break" + qq <- eval (Proxy @q) opts a' + case getValueLR opts msg0 qq [] of + Left e -> pure e + Right as -> do + let ff [] zs = pure (zs, [], Nothing) -- [(ia,qq)] extras | the rest of the data | optional last pivot or error + ff ((i,a):ias) zs = do + pp <- evalBool (Proxy @p) opts a + let v = ((i,a), pp) + case getValueLR opts msg0 pp [hh qq] of + Right False -> ff ias (zs Seq.|> v) + Right True -> pure (zs,map snd ias,Just v) + Left _ -> pure (zs,map snd ias,Just v) + (ialls,rhs,mpivot) <- ff (zip [0::Int ..] as) Seq.empty + pure $ case mpivot of + Nothing -> + mkNode opts (PresentT (map (snd . fst) (toList ialls), rhs)) + ([msg0] <> ["cnt=" <> show (length ialls, length rhs)]) + (map (hh . fixit) (toList ialls)) + Just iall@(ia, tt) -> + case getValueLR opts (msg0 <> " predicate failed") tt (hh qq : map (hh . fixit) (toList (ialls Seq.|> iall))) of + Right True -> + mkNode opts (PresentT (map (snd . fst) (toList ialls), snd ia : rhs)) + ([msg0] <> ["cnt=" <> show (length ialls, 1+length rhs)]) + (hh qq : hh tt : map (hh . fixit) (toList (ialls Seq.|> iall))) + + Right False -> error "shouldnt happen" + Left e -> e + +-- | Fails the computation with a message +-- +-- >>> pl @(Failt Int (Printf "value=%03d" Id)) 99 +-- Error value=099 +-- FailT "value=099" +-- +-- >>> pl @(FailS (Printf2 "value=%03d string=%s")) (99,"somedata") +-- Error value=099 string=somedata +-- FailT "value=099 string=somedata" +-- +data Fail t prt -- t=output type prt=msg +type Failp s = Fail Unproxy s +type Failt (t :: Type) prt = Fail (Hole t) prt +type FailS s = Fail I s +type FailPrt (t :: Type) prt = Fail (Hole t)(Printf prt) +type FailPrt2 (t :: Type) prt = Fail (Hole t)(Printf2 prt) + +instance (P prt a + , PP prt a ~ String + ) => P (Fail t prt) a where + type PP (Fail t prt) a = PP t a + eval _ opts a = do + let msg0 = "Fail" + pp <- eval (Proxy @prt) opts a + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right s -> mkNode opts (FailT s) [msg0 <> " " <> s] [hh pp] + +data Hole (t :: Type) + +-- | Acts as a proxy in this dsl where you can explicitly set the Type. +-- +-- It is passed around as an argument to help the type checker when needed. +-- see 'ReadP', 'ParseTimeP', 'ShowP' +-- +instance Typeable t => P (Hole t) a where + type PP (Hole t) a = t -- can only be Type not Type -> Type (can use Proxy but then we go down the rabbithole) + eval _ opts _a = + let msg0 = "Hole(" <> showT @t <> ")" + in pure $ mkNode opts (FailT msg0) [msg0 <> " you probably meant to get access to the type of PP only and not evaluate"] [] + +data Unproxy + +instance Typeable a => P Unproxy (Proxy (a :: Type)) where + type PP Unproxy (Proxy a) = a + eval _ opts _a = + let msg0 = "Unproxy(" <> showT @a <> ")" + in pure $ mkNode opts (FailT msg0) [msg0 <> " you probably meant to get access to the type of PP only and not evaluate"] [] + +-- | catch a failure +-- +-- >>> pl @(Catch (Succ Id) (Fst Id >> Second (ShowP Id) >> Printf2 "%s %s" >> 'LT)) GT +-- Present LT +-- PresentT LT +-- +-- >>> pl @(Catch' (Succ Id) (Second (ShowP Id) >> Printf2 "%s %s")) GT +-- Error Succ IO e=Prelude.Enum.Ordering.succ: bad argument GT +-- FailT "Succ IO e=Prelude.Enum.Ordering.succ: bad argument GT" +-- +-- >>> pl @(Catch' (Succ Id) (Second (ShowP Id) >> Printf2 "%s %s")) LT +-- Present EQ +-- PresentT EQ +-- +-- more flexible: takes a (String,x) and a proxy so we can still call 'False 'True +-- now takes the FailT string and x so you can print more detail if you want +-- need the proxy so we can fail without having to explicitly specify a type +data Catch p q -- catch p and if fails runs q only on failt +type Catch' p s = Catch p (FailCatch s) -- eg set eg s=Printf "%d" Id or Printf "%s" (ShowP Id) +type FailCatch s = Fail (Snd Id >> Unproxy) (Fst Id >> s) + +instance (P p x + , P q ((String, x) + , Proxy (PP p x)) + , PP p x ~ PP q ((String, x), Proxy (PP p x)) + ) => P (Catch p q) x where + type PP (Catch p q) x = PP p x + eval _ opts x = do + let msg0 = "Catch" + pp <- eval (Proxy @p) opts x + case getValueLR opts msg0 pp [] of + Left e -> do + let emsg = e ^?! tBool . _FailT -- extract the failt string a push back into the fail case + qq <- eval (Proxy @q) opts ((emsg, x), Proxy @(PP p x)) + pure $ case getValueLR opts (msg0 <> " default condition failed") qq [hh pp] of + Left e1 -> e1 + Right _ -> mkNode opts (_tBool qq) [msg0 <> " caught exception[" <> emsg <> "]"] [hh pp, hh qq] + Right _ -> pure $ mkNode opts (_tBool pp) [msg0 <> " did not fire"] [hh pp] + +-- | similar to 'even' +-- +-- >>> pl @(Map Even Id) [9,-4,12,1,2,3] +-- Present [False,True,True,False,True,False] +-- PresentT [False,True,True,False,True,False] +-- +-- >>> pl @(Map '(Even,Odd) Id) [9,-4,12,1,2,3] +-- Present [(False,True),(True,False),(True,False),(False,True),(True,False),(False,True)] +-- PresentT [(False,True),(True,False),(True,False),(False,True),(True,False),(False,True)] +-- +type Even = Mod I 2 == 0 +type Odd = Mod I 2 == 1 +--type Div' p q = Fst (DivMod p q) +--type Mod' p q = Snd (DivMod p q) + +-- | similar to 'div' +-- +-- >>> pl @(Div (Fst Id) (Snd Id)) (10,4) +-- Present 2 +-- PresentT 2 +-- +-- >>> pl @(Div (Fst Id) (Snd Id)) (10,0) +-- Error Div zero denominator +-- FailT "Div zero denominator" +-- +data Div p q +instance (PP p a ~ PP q a + , P p a + , P q a + , Show (PP p a) + , Integral (PP p a) + ) => P (Div p q) a where + type PP (Div p q) a = PP p a + eval _ opts a = do + let msg0 = "Div" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let hhs = [hh pp, hh qq] + in case q of + 0 -> mkNode opts (FailT (msg0 <> " zero denominator")) [msg0 <> " zero denominator"] hhs + _ -> let d = p `div` q + in mkNode opts (PresentT d) [show p <> " `div` " <> show q <> " = " <> show d] hhs + + +-- | similar to 'mod' +-- +-- >>> pl @(Mod (Fst Id) (Snd Id)) (10,3) +-- Present 1 +-- PresentT 1 +-- +-- >>> pl @(Mod (Fst Id) (Snd Id)) (10,0) +-- Error Mod zero denominator +-- FailT "Mod zero denominator" +-- +data Mod p q +instance (PP p a ~ PP q a + , P p a + , P q a + , Show (PP p a) + , Integral (PP p a) + ) => P (Mod p q) a where + type PP (Mod p q) a = PP p a + eval _ opts a = do + let msg0 = "Mod" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let hhs = [hh pp, hh qq] + in case q of + 0 -> mkNode opts (FailT (msg0 <> " zero denominator")) [msg0 <> " zero denominator"] hhs + _ -> let d = p `mod` q + in mkNode opts (PresentT d) [show p <> " `mod` " <> show q <> " = " <> show d] hhs + +-- | similar to 'divMod' +-- +-- >>> pl @(DivMod (Fst Id) (Snd Id)) (10,3) +-- Present (3,1) +-- PresentT (3,1) +-- +-- >>> pl @(DivMod (Fst Id) (Snd Id)) (10,-3) +-- Present (-4,-2) +-- PresentT (-4,-2) +-- +-- >>> pl @(DivMod (Fst Id) (Snd Id)) (-10,3) +-- Present (-4,2) +-- PresentT (-4,2) +-- +-- >>> pl @(DivMod (Fst Id) (Snd Id)) (-10,-3) +-- Present (3,-1) +-- PresentT (3,-1) +-- +-- >>> pl @(DivMod (Fst Id) (Snd Id)) (10,0) +-- Error DivMod zero denominator +-- FailT "DivMod zero denominator" +-- +data DivMod p q + +instance (PP p a ~ PP q a + , P p a + , P q a + , Show (PP p a) + , Integral (PP p a) + ) => P (DivMod p q) a where + type PP (DivMod p q) a = (PP p a, PP p a) + eval _ opts a = do + let msg0 = "DivMod" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let hhs = [hh pp, hh qq] + in case q of + 0 -> mkNode opts (FailT (msg0 <> " zero denominator")) [msg0 <> " zero denominator"] hhs + _ -> let d = p `divMod` q + in mkNode opts (PresentT d) [show p <> " `divMod` " <> show q <> " = " <> show d] hhs + +-- | similar to 'quotRem' +-- +-- >>> pl @(QuotRem (Fst Id) (Snd Id)) (10,3) +-- Present (3,1) +-- PresentT (3,1) +-- +-- >>> pl @(QuotRem (Fst Id) (Snd Id)) (10,-3) +-- Present (-3,1) +-- PresentT (-3,1) +-- +-- >>> pl @(QuotRem (Fst Id) (Snd Id)) (-10,-3) +-- Present (3,-1) +-- PresentT (3,-1) +-- +-- >>> pl @(QuotRem (Fst Id) (Snd Id)) (-10,3) +-- Present (-3,-1) +-- PresentT (-3,-1) +-- +-- >>> pl @(QuotRem (Fst Id) (Snd Id)) (10,0) +-- Error QuotRem zero denominator +-- FailT "QuotRem zero denominator" +-- +data QuotRem p q + +instance (PP p a ~ PP q a + , P p a + , P q a + , Show (PP p a) + , Integral (PP p a) + ) => P (QuotRem p q) a where + type PP (QuotRem p q) a = (PP p a, PP p a) + eval _ opts a = do + let msg0 = "QuotRem" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let hhs = [hh pp, hh qq] + in case q of + 0 -> mkNode opts (FailT (msg0 <> " zero denominator")) [msg0 <> " zero denominator"] hhs + _ -> let d = p `quotRem` q + in mkNode opts (PresentT d) [show p <> " `quotRem` " <> show q <> " = " <> show d] hhs + +type Quot p q = Fst (QuotRem p q) +type Rem p q = Snd (QuotRem p q) + +--type OneP = Guard "expected list of length 1" (Len >> Same 1) >> Head' +type OneP = Guard (Printf "expected list of length 1 but found length=%d" Len) (Len == 1) >> Head + +strictmsg :: forall strict . GetBool strict => String +strictmsg = if getBool @strict then "" else "Lax" + +-- k or prt has access to (Int,a) where Int is the current guard position: hence need to use Printf2 +-- todo: better explanation of how this works +-- passthru but adds the length of ps (replaces LenT in the type synonym to avoid type synonyms being expanded out) + +-- | Guards contain a type level list of tuples the action to run on failure of the predicate and the predicate itself +-- Each tuple validating against the corresponding value in a value list +-- +-- >>> pl @(Guards '[ '("arg1 failed",Gt 4), '("arg2 failed", Same 4)]) [17,4] +-- Present [17,4] +-- PresentT [17,4] +-- +-- >>> pl @(Guards '[ '("arg1 failed",Gt 4), '("arg2 failed", Same 5)]) [17,4] +-- Error arg2 failed +-- FailT "arg2 failed" +-- +-- >>> pl @(Guards '[ '("arg1 failed",Gt 99), '("arg2 failed", Same 4)]) [17,4] +-- Error arg1 failed +-- FailT "arg1 failed" +-- +-- >>> pl @(Guards '[ '(Printf2 "arg %d failed with value %d",Gt 4), '(Printf2 "%d %d", Same 4)]) [17,3] +-- Error 2 3 +-- FailT "2 3" +-- +-- >>> pl @(GuardsQuick (Printf2 "arg %d failed with value %d") '[Gt 4, Ge 3, Same 4]) [17,3,5] +-- Error arg 3 failed with value 5 +-- FailT "arg 3 failed with value 5" +-- +-- >>> pl @(GuardsQuick (Printf2 "arg %d failed with value %d") '[Gt 4, Ge 3, Same 4]) [17,3,5,99] +-- Error Guards: data elements(4) /= predicates(3) +-- FailT "Guards: data elements(4) /= predicates(3)" +-- +data GuardsImpl (n :: Nat) (strict :: Bool) (os :: [(k,k1)]) +type Guards (os :: [(k,k1)]) = GuardsImplW 'True os +type GuardsLax (os :: [(k,k1)]) = GuardsImplW 'False os +type GuardsQuick (prt :: k) (os :: [k1]) = Guards (ToGuardsT prt os) +type GuardsQuickLax (prt :: k) (os :: [k1]) = GuardsLax (ToGuardsT prt os) + +data GuardsImplW (strict :: Bool) (ps :: [(k,k1)]) +instance (GetBool strict, GetLen ps, P (GuardsImpl (LenT ps) strict ps) [a]) => P (GuardsImplW strict ps) [a] where + type PP (GuardsImplW strict ps) [a] = PP (GuardsImpl (LenT ps) strict ps) [a] + eval _ opts as = do + let strict = getBool @strict + msgbase0 = "Guards" <> strictmsg @strict + n = getLen @ps + if strict && n /= length as then + let xx = msgbase0 <> ": data elements(" <> show (length as) <> ") /= predicates(" <> show n <> ")" + in pure $ mkNode opts (FailT xx) [xx] [] + else eval (Proxy @(GuardsImpl (LenT ps) strict ps)) opts as + +instance (KnownNat n + , GetBool strict + , Show a + ) => P (GuardsImpl n strict ('[] :: [(k,k1)])) [a] where + type PP (GuardsImpl n strict ('[] :: [(k,k1)])) [a] = [a] + eval _ opts as = + let msg0 = "Guards" <> strictmsg @strict <> "(" <> show n <> ")" + n :: Int = nat @n + in pure $ mkNode opts (PresentT as) [msg0 <> " done!" <> if null as then "" else show1 opts " | leftovers=" as] [] + +instance (PP prt (Int, a) ~ String + , P prt (Int, a) + , KnownNat n + , GetBool strict + , GetLen ps + , P p a + , PP p a ~ Bool + , P (GuardsImpl n strict ps) [a] + , PP (GuardsImpl n strict ps) [a] ~ [a] + , Show a + ) => P (GuardsImpl n strict ('(prt,p) ': ps)) [a] where + type PP (GuardsImpl n strict ('(prt,p) ': ps)) [a] = [a] + eval _ opts as' = do + let msgbase0 = "Guards" <> strictmsg @strict <> "(" <> show (n-pos) <> ":" <> show n <> ")" + msgbase1 = "Guard" <> strictmsg @strict <> "(" <> show (n-pos) <> ")" + msgbase2 = "Guards" <> strictmsg @strict + n :: Int = nat @n + pos = getLen @ps + case as' of + [] -> pure $ mkNode opts (PresentT mempty) [msgbase0 <> " (ran out of data!!)"] [] + a:as -> do + pp <- evalBool (Proxy @p) opts a + case getValueLR opts (msgbase1 <> " p failed") pp [] of + Left e -> pure e + Right False -> do + qq <- eval (Proxy @prt) opts (n-pos,a) -- only run prt when predicate is False + pure $ case getValueLR opts (msgbase2 <> " False predicate and prt failed") qq [hh pp] of + Left e -> e + Right msgx -> mkNode opts (FailT msgx) [msgbase1 <> " failed [" <> msgx <> "]" <> show0 opts " " a] [hh pp, hh qq] + Right True -> do + ss <- eval (Proxy @(GuardsImpl n strict ps)) opts as + pure $ case getValueLRHide opts (msgbase1 <> " ok | rhs failed") ss [hh pp] of + Left e -> e -- shortcut else we get too compounding errors with the pp tree being added each time! + Right zs -> mkNode opts (PresentT (a:zs)) [msgbase1 <> show0 opts " " a] [hh pp, hh ss] + + +-- | if a predicate fails then then the corresponding symbol and value will be passed to the print function +-- +-- >>> pl @(GuardsDetail "%s invalid: found %d" '[ '("hours", Between 0 23),'("minutes",Between 0 59),'("seconds",Between 0 59)]) [13,59,61] +-- Error seconds invalid: found 61 +-- FailT "seconds invalid: found 61" +-- +-- >>> pl @(GuardsDetail "%s invalid: found %d" '[ '("hours", Between 0 23),'("minutes",Between 0 59),'("seconds",Between 0 59)]) [27,59,12] +-- Error hours invalid: found 27 +-- FailT "hours invalid: found 27" +-- +-- >>> pl @(GuardsDetail "%s invalid: found %d" '[ '("hours", Between 0 23),'("minutes",Between 0 59),'("seconds",Between 0 59)]) [23,59,12] +-- Present [23,59,12] +-- PresentT [23,59,12] +-- +data GuardsImplX (n :: Nat) (strict :: Bool) (os :: [(k,k1)]) + +type GuardsDetail (prt :: Symbol) (os :: [(k0,k1)]) = GuardsImplXX 'True (ToGuardsDetailT prt os) + +type family ToGuardsDetailT (prt :: k1) (os :: [(k2,k3)]) :: [(Type,k3)] where + ToGuardsDetailT prt '[ '(s,p) ] = '(Printfn prt '(s,'(Id,'())), p) : '[] + ToGuardsDetailT prt ( '(s,p) ': ps) = '(Printfn prt '(s,'(Id,'())), p) ': ToGuardsDetailT prt ps + ToGuardsDetailT prt '[] = GL.TypeError ('GL.Text "ToGuardsDetailT cannot be empty") + +data GuardsImplXX (strict :: Bool) (ps :: [(k,k1)]) + +instance (GetBool strict, GetLen ps, P (GuardsImplX (LenT ps) strict ps) [a]) => P (GuardsImplXX strict ps) [a] where + type PP (GuardsImplXX strict ps) [a] = PP (GuardsImplX (LenT ps) strict ps) [a] + eval _ opts as = do + let strict = getBool @strict + msgbase0 = "Guards" <> strictmsg @strict + n = getLen @ps + if strict && n /= length as then + let xx = msgbase0 <> ": data elements(" <> show (length as) <> ") /= predicates(" <> show n <> ")" + in pure $ mkNode opts (FailT xx) [xx] [] + else eval (Proxy @(GuardsImplX (LenT ps) strict ps)) opts as + +instance (KnownNat n + , GetBool strict + , Show a + ) => P (GuardsImplX n strict ('[] :: [(k,k1)])) [a] where + type PP (GuardsImplX n strict ('[] :: [(k,k1)])) [a] = [a] + eval _ opts as = + let msg0 = "Guards" <> strictmsg @strict <> "(" <> show n <> ")" + n :: Int = nat @n + in pure $ mkNode opts (PresentT as) [msg0 <> " done!" <> if null as then "" else show1 opts " | leftovers=" as] [] + +instance (PP prt a ~ String + , P prt a + , KnownNat n + , GetBool strict + , GetLen ps + , P p a + , PP p a ~ Bool + , P (GuardsImplX n strict ps) [a] + , PP (GuardsImplX n strict ps) [a] ~ [a] + , Show a + ) => P (GuardsImplX n strict ('(prt,p) ': ps)) [a] where + type PP (GuardsImplX n strict ('(prt,p) ': ps)) [a] = [a] + eval _ opts as' = do + let msgbase0 = "Guards" <> strictmsg @strict <> "(" <> show (n-pos) <> ":" <> show n <> ")" + msgbase1 = "Guard" <> strictmsg @strict <> "(" <> show (n-pos) <> ")" + msgbase2 = "Guards" <> strictmsg @strict + n :: Int = nat @n + pos = getLen @ps + case as' of + [] -> pure $ mkNode opts (PresentT mempty) [msgbase0 <> " (ran out of data!!)"] [] + a:as -> do + pp <- evalBool (Proxy @p) opts a + case getValueLR opts (msgbase1 <> " p failed") pp [] of + Left e -> pure e + Right False -> do + qq <- eval (Proxy @prt) opts a -- only run prt when predicate is False + pure $ case getValueLR opts (msgbase2 <> " False predicate and prt failed") qq [hh pp] of + Left e -> e + Right msgx -> mkNode opts (FailT msgx) [msgbase1 <> " failed [" <> msgx <> "]" <> show0 opts " " a] [hh pp, hh qq] + Right True -> do + ss <- eval (Proxy @(GuardsImplX n strict ps)) opts as + pure $ case getValueLRHide opts (msgbase1 <> " ok | rhs failed") ss [hh pp] of + Left e -> e -- shortcut else we get too compounding errors with the pp tree being added each time! + Right zs -> mkNode opts (PresentT (a:zs)) [msgbase1 <> show0 opts " " a] [hh pp, hh ss] + +-- | leverages 'GuardsQuick' for repeating predicates (passthrough method) +-- +-- >>> pl @(GuardsN (Printf2 "id=%d must be between 0 and 255, found %d") 4 (Between 0 255)) [121,33,7,256] +-- Error id=4 must be between 0 and 255, found 256 +-- FailT "id=4 must be between 0 and 255, found 256" +-- +-- >>> pl @(GuardsN (Printf2 "id=%d must be between 0 and 255, found %d") 4 (Between 0 255)) [121,33,7,44] +-- Present [121,33,7,44] +-- PresentT [121,33,7,44] +-- +data GuardsNImpl (strict :: Bool) prt (n :: Nat) p +type GuardsN prt (n :: Nat) p = GuardsNImpl 'True prt n p +type GuardsNLax prt (n :: Nat) p = GuardsNImpl 'False prt n p + +instance ( GetBool strict + , GetLen (ToGuardsT prt (RepeatT n p)) + , P (GuardsImpl + (LenT (ToGuardsT prt (RepeatT n p))) + strict + (ToGuardsT prt (RepeatT n p))) + [a] + ) => P (GuardsNImpl strict prt n p) [a] where + type PP (GuardsNImpl strict prt n p) [a] = PP (GuardsImplW strict (ToGuardsT prt (RepeatT n p))) [a] + eval _ opts as = + eval (Proxy @(GuardsImplW strict (ToGuardsT prt (RepeatT n p)))) opts as + + +-- | \'p\' is the predicate and on failure of the predicate runs \'prt\' +-- +-- >>> pl @(Guard "expected > 3" (Gt 3)) 17 +-- Present 17 +-- PresentT 17 +-- +-- >>> pl @(Guard "expected > 3" (Gt 3)) 1 +-- Error expected > 3 +-- FailT "expected > 3" +-- +-- >>> pl @(Guard (Printf "%d not > 3" Id) (Gt 3)) (-99) +-- Error -99 not > 3 +-- FailT "-99 not > 3" +-- +data Guard prt p +type Guard' p = Guard "Guard" p + +type ExitWhen prt p = Guard prt (Not p) +type ExitWhen' p = ExitWhen "ExitWhen" p + +instance (Show a + , P prt a + , PP prt a ~ String + , P p a + , PP p a ~ Bool + ) => P (Guard prt p) a where + type PP (Guard prt p) a = a + eval _ opts a = do + let msg0 = "Guard" + pp <- evalBool (Proxy @p) opts a + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right False -> do + qq <- eval (Proxy @prt) opts a + pure $ case getValueLR opts (msg0 <> " Msg") qq [hh pp] of + Left e -> e + Right msgx -> mkNode opts (FailT msgx) [msg0 <> "(failed) [" <> msgx <> "]" <> show0 opts " | " a] [hh pp, hh qq] + Right True -> pure $ mkNode opts (PresentT a) [msg0 <> "(ok)" <> show0 opts " | " a] [hh pp] -- dont show the guard message if successful + + +-- | similar to 'Guard' but uses the root message of the False predicate case as the failure message +-- +-- >>> pl @(GuardSimple (Luhn Id)) [1..4] +-- Error Luhn map=[4,6,2,2] sum=14 ret=4 | [1,2,3,4] +-- FailT "Luhn map=[4,6,2,2] sum=14 ret=4 | [1,2,3,4]" +-- +-- >>> pl @(GuardSimple (Luhn Id)) [1,2,3,0] +-- Present [1,2,3,0] +-- PresentT [1,2,3,0] +-- +-- >>> pl @(GuardSimple (Len > 30)) [1,2,3,0] +-- Error 4 > 30 +-- FailT "4 > 30" +-- +data GuardSimple p + +instance (Show a + , P p a + , PP p a ~ Bool + ) => P (GuardSimple p) a where + type PP (GuardSimple p) a = a + eval _ opts a = do + let msg0 = "GuardSimple" + b = oLite opts + pp <- evalBool (Proxy @p) (if b then o0 else opts) a -- to not lose the message in oLite mode we use non lite and then fix it up after + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right False -> + let msgx = fromMaybe msg0 $ pp ^? tStrings . ix 0 + in mkNode opts (FailT msgx) [msg0 <> "(failed) [" <> msgx <> "]" <> show0 opts " | " a] [hh pp] + Right True -> + mkNode opts (PresentT a) [msg0 <> "(ok)" <> show0 opts " | " a] [hh pp] + + +-- | just run the effect but skip the value +-- for example for use with Stdout so it doesnt interfere with the \'a\' on the rhs unless there is an error +data Skip p +type p |> q = Skip p >> q +infixr 1 |> +type p >| q = p >> Skip q +infixr 1 >| + +instance (Show (PP p a), P p a) => P (Skip p) a where + type PP (Skip p) a = a + eval _ opts a = do + let msg0 = "Skip" + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> mkNode opts (PresentT a) [msg0 <> show0 opts " " p] [hh pp] + +-- advantage of (>>) over 'Do [k] is we can use different kinds for (>>) without having to wrap with 'W' + +-- | This is composition for predicates +-- +-- >>> pl @(Fst Id >> Succ (Id !! 0)) ([11,12],'x') +-- Present 12 +-- PresentT 12 +-- +-- >>> pl @(Len *** Succ Id >> ShowP (First (Pred Id))) ([11,12],'x') +-- Present "(1,'y')" +-- PresentT "(1,'y')" +-- + +data (p :: k) >> (q :: k1) +infixr 1 >> + +type (<<) p q = q >> p +infixl 1 << + +instance (Show (PP p a) + , Show (PP q (PP p a)) + , P p a + , P q (PP p a) + ) => P (p >> q) a where + type PP (p >> q) a = PP q (PP p a) + eval _ opts a = do + let msg0 = ">>" + pp <- eval (Proxy @p) opts a + case getValueLRHide opts "lhs failed >>" pp [] of + Left e -> pure e + Right p -> do + qq <- eval (Proxy @q) opts p + pure $ case getValueLRHide opts (show p <> " >> rhs failed") qq [hh pp] of + Left e -> e + Right q -> mkNode opts (_tBool qq) [show01 opts msg0 q p] [hh pp, hh qq] + +-- | similar to 'Prelude.&&' +-- +-- >>> pl @(Fst Id && Snd Id) (True, True) +-- True +-- TrueT +-- +-- >>> pl @(Id > 15 && Id < 17) 16 +-- True +-- TrueT +-- +-- >>> pl @(Id > 15 && Id < 17) 30 +-- False +-- FalseT +-- +-- >>> pl @(Fst Id && (Length (Snd Id) >= 4)) (True,[11,12,13,14]) +-- True +-- TrueT +-- +-- >>> pl @(Fst Id && (Length (Snd Id) == 4)) (True,[12,11,12,13,14]) +-- False +-- FalseT +-- +data (&&) (p :: k) (q :: k1) +infixr 3 && + +instance (P p a + , P q a + , PP p a ~ Bool + , PP q a ~ Bool + ) => P (p && q) a where + type PP (p && q) a = Bool + eval _ opts a = do + pp <- evalBool (Proxy @p) opts a + qq <- evalBool (Proxy @q) opts a + pure $ evalBinStrict opts "&&" (&&) pp qq + +-- | similar to 'Prelude.||' +-- +-- >>> pl @(Fst Id || (Length (Snd Id) >= 4)) (False,[11,12,13,14]) +-- True +-- TrueT +-- +-- >>> pl @(Not (Fst Id) || (Length (Snd Id) == 4)) (True,[12,11,12,13,14]) +-- False +-- FalseT +-- +data (||) (p :: k) (q :: k1) +infixr 2 || + +instance (P p a + , P q a + , PP p a ~ Bool + , PP q a ~ Bool + ) => P (p || q) a where + type PP (p || q) a = Bool + eval _ opts a = do + pp <- evalBool (Proxy @p) opts a + qq <- evalBool (Proxy @q) opts a + pure $ evalBinStrict opts "||" (||) pp qq + +-- | implication +-- +-- >>> pl @(Fst Id ~> (Length (Snd Id) >= 4)) (True,[11,12,13,14]) +-- True +-- TrueT +-- +-- >>> pl @(Fst Id ~> (Length (Snd Id) == 4)) (True,[12,11,12,13,14]) +-- False +-- FalseT +-- +-- >>> pl @(Fst Id ~> (Length (Snd Id) == 4)) (False,[12,11,12,13,14]) +-- True +-- TrueT +-- +-- >>> pl @(Fst Id ~> (Length (Snd Id) >= 4)) (False,[11,12,13,14]) +-- True +-- TrueT +-- +data (~>) (p :: k) (q :: k1) +infixr 1 ~> + +instance (P p a + , P q a + , PP p a ~ Bool + , PP q a ~ Bool + ) => P (p ~> q) a where + type PP (p ~> q) a = Bool + eval _ opts a = do + pp <- evalBool (Proxy @p) opts a + qq <- evalBool (Proxy @q) opts a + pure $ evalBinStrict opts "~>" imply pp qq + +-- | 'not' function +-- +-- >>> pl @(Not Id) False +-- True +-- TrueT +-- +-- >>> pl @(Not Id) True +-- False +-- FalseT +-- +-- >>> pl @(Not (Fst Id)) (True,22) +-- False +-- FalseT +-- +data Not p +instance (PP p x ~ Bool, P p x) => P (Not p) x where + type PP (Not p) x = Bool + eval _ opts x = do + let msg0 = "Not" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = not p + in mkNodeB opts b [msg0] [hh pp] + +data OrdP p q +type p ==! q = OrdP p q +infix 4 ==! + +-- | similar to 'compare' +-- +-- >>> pl @(Fst Id ==! Snd Id) (10,9) +-- Present GT +-- PresentT GT +-- +-- >>> pl @(14 % 3 ==! Fst Id %- Snd Id) (-10,7) +-- Present GT +-- PresentT GT +-- +-- >>> pl @(Fst Id ==! Snd Id) (10,11) +-- Present LT +-- PresentT LT +-- +-- >>> pl @(Snd Id ==! (Fst Id >> Snd Id >> Head' Id)) (('x',[10,12,13]),10) +-- Present EQ +-- PresentT EQ +-- +-- >>> pl @(Snd Id ==! Head' (Snd (Fst Id))) (('x',[10,12,13]),10) +-- Present EQ +-- PresentT EQ +-- +type OrdA' p q = OrdP (Fst Id >> p) (Snd Id >> q) +type OrdA p = OrdA' p p + +instance (Ord (PP p a) + , PP p a ~ PP q a + , P p a + , Show (PP q a) + , P q a + ) => P (OrdP p q) a where + type PP (OrdP p q) a = Ordering + eval _ opts a = do + let msg0 = "OrdP" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = compare p q + in mkNode opts (PresentT d) [msg0 <> " " <> show p <> " " <> prettyOrd d <> show0 opts " " q] [hh pp, hh qq] + +-- | compare two strings ignoring case +-- +-- >>> pl @(Fst Id ===~ Snd Id) ("abC","aBc") +-- Present EQ +-- PresentT EQ +-- +-- >>> pl @(Fst Id ===~ Snd Id) ("abC","DaBc") +-- Present LT +-- PresentT LT +-- +data OrdI p q +type p ===~ q = OrdI p q +infix 4 ===~ + +instance (PP p a ~ String + , PP p a ~ PP q a + , P p a + , P q a + ) => P (OrdI p q) a where + type PP (OrdI p q) a = Ordering + eval _ opts a = do + let msg0 = "OrdI" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = on compare (map toLower) p q + in mkNode opts (PresentT d) [msg0 <> " " <> p <> " " <> prettyOrd d <> " " <> q] [hh pp, hh qq] + +-- | compare two values using the given ordering \'o\' +data Cmp (o :: OrderingP) p q + +instance (GetOrd o + , Ord (PP p a) + , Show (PP p a) + , PP p a ~ PP q a + , P p a + , P q a + ) => P (Cmp o p q) a where + type PP (Cmp o p q) a = Bool + eval _ opts a = do + let (sfn, fn) = getOrd @o + lr <- runPQ sfn (Proxy @p) (Proxy @q) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let b = fn p q + in mkNodeB opts b [show p <> " " <> sfn <> show0 opts " " q] [hh pp, hh qq] + +-- | compare two strings ignoring case using the given ordering \'o\' +data CmpI (o :: OrderingP) p q + +instance (PP p a ~ String + , GetOrd o + , PP p a ~ PP q a + , P p a + , P q a + ) => P (CmpI o p q) a where + type PP (CmpI o p q) a = Bool + eval _ opts a = do + let (sfn, fn) = getOrd @o + lr <- runPQ sfn (Proxy @p) (Proxy @q) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let b = on fn (map toLower) p q + in mkNodeB opts b ["CmpI " <> p <> " " <> sfn <> " " <> q] [hh pp, hh qq] + + +-- | similar to 'Control.Lens.itoList' +-- +-- >>> pl @(IToList _) ("aBc" :: String) +-- Present [(0,'a'),(1,'B'),(2,'c')] +-- PresentT [(0,'a'),(1,'B'),(2,'c')] +-- +data IToList' t p +type IToList (t :: Type) = IToList' (Hole t) Id + +instance (Show x + , P p x + , Typeable (PP t (PP p x)) + , Show (PP t (PP p x)) + , FoldableWithIndex (PP t (PP p x)) f + , PP p x ~ f a + , Show a + ) => P (IToList' t p) x where + type PP (IToList' t p) x = [(PP t (PP p x), ExtractAFromTA (PP p x))] + eval _ opts x = do + let msg0 = "IToList" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = itoList p + t = showT @(PP t (PP p x)) + in mkNode opts (PresentT b) [msg0 <> "(" <> t <> ")" <> show0 opts " " b <> show1 opts " | " x] [hh pp] + +-- | similar to 'toList' +-- +-- >>> pl @ToList ("aBc" :: String) +-- Present "aBc" +-- PresentT "aBc" +-- +-- >>> pl @ToList (Just 14) +-- Present [14] +-- PresentT [14] +-- +-- >>> pl @ToList Nothing +-- Present [] +-- PresentT [] +-- +-- >>> pl @ToList (Left "xx") +-- Present [] +-- PresentT [] +-- +-- >>> pl @ToList (These 12 "xx") +-- Present ["xx"] +-- PresentT ["xx"] +-- +data ToList +instance (Show (t a) + , Foldable t + , Show a + ) => P ToList (t a) where + type PP ToList (t a) = [a] + eval _ opts as = + let msg0 = "ToList" + z = toList as + in pure $ mkNode opts (PresentT z) [show01 opts msg0 z as] [] + +-- | similar to 'toList' +-- +-- >>> pl @(ToList' Id) ("aBc" :: String) +-- Present "aBc" +-- PresentT "aBc" +-- +-- >>> pl @(ToList' Id) (Just 14) +-- Present [14] +-- PresentT [14] +-- +-- >>> pl @(ToList' Id) Nothing +-- Present [] +-- PresentT [] +-- +-- >>> pl @(ToList' Id) (Left "xx") +-- Present [] +-- PresentT [] +-- +-- >>> pl @(ToList' Id) (These 12 "xx") +-- Present ["xx"] +-- PresentT ["xx"] +-- +data ToList' p + +instance (PP p x ~ t a + , P p x + , Show (t a) + , Foldable t + , Show a + ) => P (ToList' p) x where + type PP (ToList' p) x = [ExtractAFromTA (PP p x)] -- extra layer of indirection means pe (ToList' Id) "abc" won't work without setting the type of "abc" unlike ToList + eval _ opts x = do + let msg0 = "ToList'" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = toList p + in mkNode opts (PresentT b) [show01 opts msg0 b p] [hh pp] + +-- | invokes 'GE.toList' +-- +-- >>> pl @ToListExt (M.fromList [(1,'x'),(4,'y')]) +-- Present [(1,'x'),(4,'y')] +-- PresentT [(1,'x'),(4,'y')] +-- +-- >>> pl @ToListExt (T.pack "abc") +-- Present "abc" +-- PresentT "abc" +-- +data ToListExt + +instance (Show l + , GE.IsList l + , Show (GE.Item l) + ) => P ToListExt l where + type PP ToListExt l = [GE.Item l] + eval _ opts as = + let msg0 = "ToListExt" + z = GE.toList as + in pure $ mkNode opts (PresentT z) [show01 opts msg0 z as] [] + +data FromList (t :: Type) -- doesnt work with OverloadedLists unless you cast to [a] explicitly + +instance (a ~ GE.Item t + , Show t + , GE.IsList t + ) => P (FromList t) [a] where + type PP (FromList t) [a] = t + eval _ opts as = + let msg0 = "FromList" + z = GE.fromList (as :: [GE.Item t]) :: t + in pure $ mkNode opts (PresentT z) [msg0 <> show0 opts " " z] [] + +-- | invokes 'GE.fromList' +-- +-- requires the OverloadedLists extension +-- +-- >>> :set -XOverloadedLists +-- >>> pl @(FromListExt (M.Map _ _)) [(4,"x"),(5,"dd")] +-- Present fromList [(4,"x"),(5,"dd")] +-- PresentT (fromList [(4,"x"),(5,"dd")]) +-- +data FromListExt (t :: Type) +-- l ~ l' is key +instance (Show l + , GE.IsList l + , l ~ l' + ) => P (FromListExt l') l where + type PP (FromListExt l') l = l' + eval _ opts as = + let msg0 = "FromListExt" + z = GE.fromList (GE.toList @l as) + in pure $ mkNode opts (PresentT z) [msg0 <> show0 opts " " z] [] + +-- | predicate on 'These' +-- +-- >>> pl @(IsThis Id) (This "aBc") +-- True +-- TrueT +-- +-- >>> pl @(IsThis Id) (These 1 'a') +-- False +-- FalseT +-- +-- >>> pl @(IsThese Id) (These 1 'a') +-- True +-- TrueT +-- +data IsTh (th :: These x y) p -- x y can be anything + +type IsThis p = IsTh ('This '()) p +type IsThat p = IsTh ('That '()) p +type IsThese p = IsTh ('These '() '()) p + +-- trying to avoid show instance cos of ambiguities +instance (PP p x ~ These a b + , P p x + , Show a + , Show b + , GetThese th + ) => P (IsTh (th :: These x1 x2) p) x where + type PP (IsTh th p) x = Bool + eval _ opts x = do + let msg0 = "IsTh" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let (t,f) = getThese (Proxy @th) + b = f p + in mkNodeB opts b [msg0 <> " " <> t <> show1 opts " | " p] [] + +-- | similar to 'these' +-- +-- >>> pl @(TheseIn Id Len (Fst Id + Length (Snd Id))) (This 13) +-- Present 13 +-- PresentT 13 +-- +-- >>> pl @(TheseIn Id Len (Fst Id + Length (Snd Id))) (That "this is a long string") +-- Present 21 +-- PresentT 21 +-- +-- >>> pl @(TheseIn Id Len (Fst Id + Length (Snd Id))) (These 20 "somedata") +-- Present 28 +-- PresentT 28 +-- +-- >>> pl @(TheseIn (MkLeftAlt _ Id) (MkRightAlt _ Id) (If (Fst Id > Length (Snd Id)) (MkLeft _ (Fst Id)) (MkRight _ (Snd Id)))) (That "this is a long string") +-- Present Right "this is a long string" +-- PresentT (Right "this is a long string") +-- +-- >>> pl @(TheseIn (MkLeftAlt _ Id) (MkRightAlt _ Id) (If (Fst Id > Length (Snd Id)) (MkLeft _ (Fst Id)) (MkRight _ (Snd Id)))) (These 1 "this is a long string") +-- Present Right "this is a long string" +-- PresentT (Right "this is a long string") +-- +-- >>> pl @(TheseIn (MkLeftAlt _ Id) (MkRightAlt _ Id) (If (Fst Id > Length (Snd Id)) (MkLeft _ (Fst Id)) (MkRight _ (Snd Id)))) (These 100 "this is a long string") +-- Present Left 100 +-- PresentT (Left 100) +-- +data TheseIn p q r +type TheseId p q = TheseIn '(I, p) '(q, I) I + +instance (Show a + , Show b + , Show (PP p a) + , P p a + , P q b + , P r (a,b) + , PP p a ~ PP q b + , PP p a ~ PP r (a,b) + , PP q b ~ PP r (a,b) + ) => P (TheseIn p q r) (These a b) where + type PP (TheseIn p q r) (These a b) = PP p a + eval _ opts = + \case + This a -> do + let msg0 = "This" + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts (msg0 <> " p failed") pp [] of + Left e -> e + Right c -> mkNode opts (PresentT c) [show01' opts msg0 c "This " a] [hh pp] + That b -> do + let msg0 = "That" + qq <- eval (Proxy @q) opts b + pure $ case getValueLR opts (msg0 <> " q failed") qq [] of + Left e -> e + Right c -> mkNode opts (PresentT c) [show01' opts msg0 c "That " b] [hh qq] + These a b -> do + let msg0 = "TheseIn" + rr <- eval (Proxy @r) opts (a,b) + pure $ case getValueLR opts (msg0 <> " r failed") rr [] of + Left e -> e + Right c -> mkNode opts (PresentT c) [show01 opts msg0 c (These a b)] [hh rr] + +-- | creates an empty list of the given type +-- +-- >>> pl @(Id :+ EmptyList _) 99 +-- Present [99] +-- PresentT [99] +-- +data EmptyList' t +type EmptyList (t :: Type) = EmptyList' (Hole t) + +instance P (EmptyList' t) x where + type PP (EmptyList' t) x = [PP t x] + eval _ opts _ = + pure $ mkNode opts (PresentT []) ["EmptyList"] [] + +-- | creates a singleton from a value +-- +-- >>> pl @(Singleton (Char1 "aBc")) () +-- Present "a" +-- PresentT "a" +-- +-- >>> pl @(Singleton Id) False +-- Present [False] +-- PresentT [False] +-- +-- >>> pl @(Singleton (Snd Id)) (False,"hello") +-- Present ["hello"] +-- PresentT ["hello"] +-- +type Singleton p = p :+ EmptyT [] p + +-- | extracts the first character from a non empty 'Symbol' +-- +-- >>> pl @(Char1 "aBc") () +-- Present 'a' +-- PresentT 'a' +-- +data Char1 (s :: Symbol) -- gets the first char from the Symbol [requires that Symbol is not empty] +instance (KnownSymbol s, NullT s ~ 'False) => P (Char1 s) a where + type PP (Char1 s) a = Char + eval _ opts _ = + let c = head $ symb @s + in pure $ mkNode opts (PresentT c) ["Char1" <> show0 opts " " c] [] + +-- | similar to 'Data.Align.align' thats pads with 'Data.These.This' or 'Data.These.That' if one list is shorter than the other +-- +-- the key is that all information about both lists are preserved +-- +-- >>> pl @(ZipThese (Fst Id) (Snd Id)) ("aBc", [1..5]) +-- Present [These 'a' 1,These 'B' 2,These 'c' 3,That 4,That 5] +-- PresentT [These 'a' 1,These 'B' 2,These 'c' 3,That 4,That 5] +-- +-- >>> pl @(ZipThese (Fst Id) (Snd Id)) ("aBcDeF", [1..3]) +-- Present [These 'a' 1,These 'B' 2,These 'c' 3,This 'D',This 'e',This 'F'] +-- PresentT [These 'a' 1,These 'B' 2,These 'c' 3,This 'D',This 'e',This 'F'] +-- +-- >>> pl @(ZipThese Id Reverse) "aBcDeF" +-- Present [These 'a' 'F',These 'B' 'e',These 'c' 'D',These 'D' 'c',These 'e' 'B',These 'F' 'a'] +-- PresentT [These 'a' 'F',These 'B' 'e',These 'c' 'D',These 'D' 'c',These 'e' 'B',These 'F' 'a'] +-- +-- >>> pl @(ZipThese Id '[]) "aBcDeF" +-- Present [This 'a',This 'B',This 'c',This 'D',This 'e',This 'F'] +-- PresentT [This 'a',This 'B',This 'c',This 'D',This 'e',This 'F'] +-- +-- >>> pl @(ZipThese '[] Id) "aBcDeF" +-- Present [That 'a',That 'B',That 'c',That 'D',That 'e',That 'F'] +-- PresentT [That 'a',That 'B',That 'c',That 'D',That 'e',That 'F'] +-- +data ZipThese p q + +instance (PP p a ~ [x] + , PP q a ~ [y] + , P p a + , P q a + , Show x + , Show y + ) => P (ZipThese p q) a where + type PP (ZipThese p q) a = [These (ExtractAFromList (PP p a)) (ExtractAFromList (PP q a))] + eval _ opts a = do + let msg0 = "ZipThese" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = simpleAlign p q + in mkNode opts (PresentT d) [show01' opts msg0 d "p=" p <> show1 opts " | q=" q] [hh pp, hh qq] + +simpleAlign :: [a] -> [b] -> [These a b] +simpleAlign as [] = map This as +simpleAlign [] bs = map That bs +simpleAlign (a:as) (b:bs) = These a b : simpleAlign as bs + +type family ExtractAFromTA (ta :: Type) :: Type where + ExtractAFromTA (t a) = a + ExtractAFromTA z = GL.TypeError ( + 'GL.Text "ExtractAFromTA: expected (t a) but found something else" + ':$$: 'GL.Text "t a = " + ':<>: 'GL.ShowType z) + +-- todo: get ExtractAFromList error to fire if wrong Type +-- | extract \'a\' from \'[a]\' which I need for type PP +type family ExtractAFromList (as :: Type) :: Type where + ExtractAFromList [a] = a + ExtractAFromList z = GL.TypeError ( + 'GL.Text "ExtractAFromList: expected [a] but found something else" + ':$$: 'GL.Text "as = " + ':<>: 'GL.ShowType z) + + +-- | Zip two lists optionally cycling the one of the lists to match the size +-- +-- >>> pl @(ZipL (Fst Id) (Snd Id)) ("abc", [1..5]) +-- Present [('a',1),('b',2),('c',3),('a',4),('b',5)] +-- PresentT [('a',1),('b',2),('c',3),('a',4),('b',5)] +-- +-- >>> pl @(ZipL (Fst Id) (Snd Id)) ("abcdefg", [1..5]) +-- Present [('a',1),('b',2),('c',3),('d',4),('e',5)] +-- PresentT [('a',1),('b',2),('c',3),('d',4),('e',5)] +-- +-- >>> pl @(ZipR (Fst Id) (Snd Id)) ("abcdefg", [1..5]) +-- Present [('a',1),('b',2),('c',3),('d',4),('e',5),('f',1),('g',2)] +-- PresentT [('a',1),('b',2),('c',3),('d',4),('e',5),('f',1),('g',2)] +-- +data Zip (lc :: Bool) (rc :: Bool) p q +type ZipL p q = Zip 'True 'False p q +type ZipR p q = Zip 'False 'True p q +type ZipTrunc p q = Zip 'False 'False p q +--type ZipWith r p q = ZipTrunc p q >> Map r Id + +instance (FailIfT (AndT lc rc) () + ('GL.Text "Zip': left and right cannot both be True") + , GetBool lc + , GetBool rc + , PP p a ~ [x] + , PP q a ~ [y] + , P p a + , P q a + , Show x + , Show y + ) => P (Zip lc rc p q) a where + type PP (Zip lc rc p q) a = [(ExtractAFromList (PP p a), ExtractAFromList (PP q a))] + eval _ opts a = do + let msg0 = "Zip" <> cyc + lc = getBool @lc + rc = getBool @rc + cyc = case (lc,rc) of + (True,False) -> "L" + (False,True) -> "R" + _ -> "" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = case (lc,rc) of + (True,False) -> zip (take (length q) (cycle p)) q + (False,True) -> zip p (take (length p) (cycle q)) + _ -> zip p q + in mkNode opts (PresentT d) [show01' opts msg0 d "p=" p <> show1 opts " | q=" q] [hh pp, hh qq] + +-- | Luhn predicate check on last digit +-- +-- >>> pl @(Luhn Id) [1,2,3,0] +-- True +-- TrueT +-- +-- >>> pl @(Luhn Id) [1,2,3,4] +-- False +-- FalseT +-- +-- >>> pl @(GuardSimple (Luhn Id)) [15,4,3,1,99] +-- Error Luhn map=[90,2,3,8,6] sum=109 ret=9 | [15,4,3,1,99] +-- FailT "Luhn map=[90,2,3,8,6] sum=109 ret=9 | [15,4,3,1,99]" +-- +data Luhn p + +instance (PP p x ~ [Int] + , P p x + ) => P (Luhn p) x where + type PP (Luhn p) x = Bool + eval _ opts x = do + let msg0 = "Luhn" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let xs = zipWith (*) (reverse p) (cycle [1,2]) + ys = map (\w -> if w>=10 then w-9 else w) xs + z = sum ys + ret = z `mod` 10 + hhs = [hh pp] + in if ret == 0 then mkNodeB opts True [msg0 <> show0 opts " | " p] hhs + else mkNodeB opts False [msg0 <> " map=" <> show ys <> " sum=" <> show z <> " ret=" <> show ret <> show1 opts " | " p] hhs + +-- | Read a number using base 2 through a maximum of 36 +-- +-- >>> pl @(ReadBase Int 16) "00feD" +-- Present 4077 +-- PresentT 4077 +-- +-- >>> pl @(ReadBase Int 16) "-ff" +-- Present -255 +-- PresentT (-255) +-- +-- >>> pl @(ReadBase Int 2) "10010011" +-- Present 147 +-- PresentT 147 +-- +-- >>> pl @(ReadBase Int 8) "Abff" +-- Error invalid base 8 +-- FailT "invalid base 8" +-- +-- supports negative numbers unlike readInt +data ReadBase' t (n :: Nat) p +type ReadBase (t :: Type) (n :: Nat) = ReadBase' (Hole t) n Id +type ReadBaseInt (n :: Nat) = ReadBase' (Hole Int) n Id + +instance (Typeable (PP t x) + , BetweenT 2 36 n + , Show (PP t x) + , Num (PP t x) + , KnownNat n + , PP p x ~ String + , P p x + ) => P (ReadBase' t n p) x where + type PP (ReadBase' t n p) x = PP t x + eval _ opts x = do + let n = nat @n + xs = getValidBase n + msg0 = "ReadBase(" <> t <> "," <> show n <> ")" + t = showT @(PP t x) + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let (ff,p1) = case p of + '-':q -> (negate,q) + _ -> (id,p) + in case readInt (fromIntegral n) + ((`elem` xs) . toLower) + (fromJust . (`elemIndex` xs) . toLower) + p1 of + [(b,"")] -> mkNode opts (PresentT (ff b)) [msg0 <> show0 opts " " (ff b) <> show1 opts " | " p] [hh pp] + o -> mkNode opts (FailT ("invalid base " <> show n)) [msg0 <> " as=" <> p <> " err=" <> show o] [hh pp] + +getValidBase :: Int -> String +getValidBase n = + let xs = ['0'..'9'] <> ['a'..'z'] + len = length xs + in if n > len || n < 2 then error $ "oops invalid base valid is 2 thru " ++ show len ++ " found " ++ show n + else take n xs + +-- | Display a number at base 2 to 36, similar to 'showIntAtBase' but supports signed numbers +-- +-- >>> pl @(ShowBase 16) 4077 +-- Present "fed" +-- PresentT "fed" +-- +-- >>> pl @(ShowBase 16) (-255) +-- Present "-ff" +-- PresentT "-ff" +-- +-- >>> pl @(ShowBase 2) 147 +-- Present "10010011" +-- PresentT "10010011" +-- +-- >>> pl @(ShowBase' 2 (Negate 147)) "whatever" +-- Present "-10010011" +-- PresentT "-10010011" +-- +data ShowBase' (n :: Nat) p +type ShowBase (n :: Nat) = ShowBase' n Id + +instance (PP p x ~ a + , P p x + , Show a + , 2 GL.<= n + , n GL.<= 36 + , KnownNat n + , Integral a + ) => P (ShowBase' n p) x where + type PP (ShowBase' n p) x = String + eval _ opts x = do + let n = nat @n + xs = getValidBase n + msg0 = "ShowBase " <> show n + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let (ff,a') = if p < 0 then (('-':), abs p) else (id,p) + b = showIntAtBase (fromIntegral n) (xs !!) a' "" + in mkNode opts (PresentT (ff b)) [msg0 <> showLit0 opts " " (ff b) <> show1 opts " | " p] [] + +-- | intercalate two lists +-- +-- >>> pl @(Intercalate '["aB"] '["xxxx","yz","z","www","xyz"]) () +-- Present ["xxxx","aB","yz","aB","z","aB","www","aB","xyz"] +-- PresentT ["xxxx","aB","yz","aB","z","aB","www","aB","xyz"] +-- +-- >>> pl @(Intercalate '[W 99,Negate 98] Id) [1..5] +-- Present [1,99,-98,2,99,-98,3,99,-98,4,99,-98,5] +-- PresentT [1,99,-98,2,99,-98,3,99,-98,4,99,-98,5] +-- +-- >>> pl @(Intercalate '[99,100] Id) [1..5] +-- Present [1,99,100,2,99,100,3,99,100,4,99,100,5] +--PresentT [1,99,100,2,99,100,3,99,100,4,99,100,5] +-- +data Intercalate p q + +instance (PP p x ~ [a] + , PP q x ~ PP p x + , P p x + , P q x + , Show a + ) => P (Intercalate p q) x where + type PP (Intercalate p q) x = PP p x + eval _ opts x = do + let msg0 = "Intercalate" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = intercalate p (map (:[]) q) + in mkNode opts (PresentT d) [show01 opts msg0 d p <> show1 opts " | " q] [hh pp, hh qq] + +-- | uses Printf to format output +-- +-- >>> pl @(Printf "value=%03d" Id) 12 +-- Present "value=012" +-- PresentT "value=012" +-- +-- >>> pl @(Printf "%s" (Fst Id)) ("abc",'x') +-- Present "abc" +-- PresentT "abc" +-- +-- >>> pl @(Printf "%d" (Fst Id)) ("abc",'x') +-- Error Printf (IO e=printf: bad formatting char 'd') +-- FailT "Printf (IO e=printf: bad formatting char 'd')" +-- +data Printf s p + +instance (PrintfArg (PP p x) + , Show (PP p x) + , PP s x ~ String + , P s x + , P p x + ) => P (Printf s p) x where + type PP (Printf s p) x = String + eval _ opts x = do + let msg0 = "Printf" + lrx <- runPQ msg0 (Proxy @s) (Proxy @p) opts x + case lrx of + Left e -> pure e + Right (s,p,ss,pp) -> do + let msg1 = msg0 + lr <- catchitNF @_ @E.SomeException (printf s p) + pure $ case lr of + Left e -> mkNode opts (FailT (msg1 <> " (" <> e <> ")")) [msg1 <> show0 opts " " p <> " s=" <> s] [hh ss, hh pp] + Right ret -> mkNode opts (PresentT ret) [msg1 <> " [" <> showLit0 opts "" ret <> "]" <> show1 opts " | p=" p <> showLit1 opts " | s=" s] [hh ss, hh pp] + +type family GuardsT (ps :: [k]) where + GuardsT '[] = '[] + GuardsT (p ': ps) = Guard' p ': GuardsT ps + +type Guards' (ps :: [k]) = Para (GuardsT ps) + +type ToGuards (prt :: k) (os :: [k1]) = Proxy (Guards (ToGuardsT prt os)) + +type family ToGuardsT (prt :: k) (os :: [k1]) :: [(k,k1)] where + ToGuardsT prt '[] = GL.TypeError ('GL.Text "ToGuardsT cannot be empty") + ToGuardsT prt '[p] = '(prt,p) : '[] + ToGuardsT prt (p ': ps) = '(prt,p) ': ToGuardsT prt ps + +-- | runs values in parallel unlike 'Do' which is serial +-- +-- >>> pl @(Para '[Id,Id + 1,Id * 4]) [10,20,30] +-- Present [10,21,120] +-- PresentT [10,21,120] +-- +-- >>> pl @(Para '[Id,Id + 1,Id * 4]) [10,20,30,40] +-- Error Para: data elements(4) /= predicates(3) +-- FailT "Para: data elements(4) /= predicates(3)" +-- +-- >>> pl @(ParaLax '[Id,Id + 1,Id * 4]) [10,20,30,40,50,20,1] +-- Present [10,21,120] +-- PresentT [10,21,120] +-- +-- >>> pl @(ParaLax '[Id,Id + 1,Id * 4,Id]) [10,20,30] +-- Present [10,21,120] +-- PresentT [10,21,120] +-- +data ParaImpl (n :: Nat) (strict :: Bool) (os :: [k]) +type Para (os :: [k]) = ParaImplW 'True os +type ParaLax (os :: [k]) = ParaImplW 'False os +type ToPara (os :: [k]) = Proxy (ParaImplW 'True os) + +data ParaImplW (strict :: Bool) (ps :: [k]) + +-- passthru but adds the length of ps (replaces LenT in the type synonym to avoid type synonyms being expanded out +instance (GetBool strict, GetLen ps, P (ParaImpl (LenT ps) strict ps) [a]) => P (ParaImplW strict ps) [a] where + type PP (ParaImplW strict ps) [a] = PP (ParaImpl (LenT ps) strict ps) [a] + eval _ opts as = do + let strict = getBool @strict + msgbase0 = "Para" <> strictmsg @strict + n = getLen @ps + if strict && n /= length as then + let xx = msgbase0 <> ": data elements(" <> show (length as) <> ") /= predicates(" <> show n <> ")" + in pure $ mkNode opts (FailT xx) [xx] [] + else eval (Proxy @(ParaImpl (LenT ps) strict ps)) opts as + +-- only allow non empty lists +instance GL.TypeError ('GL.Text "ParaImpl '[] invalid: requires at least one value in the list") + => P (ParaImpl n strict ('[] :: [k])) [a] where + type PP (ParaImpl n strict ('[] :: [k])) [a] = Void + eval _ _ _ = error "should not get this far" + +instance (Show (PP p a) + , KnownNat n + , GetBool strict + , Show a + , P p a + ) => P (ParaImpl n strict '[p]) [a] where + type PP (ParaImpl n strict '[p]) [a] = [PP p a] + eval _ opts as' = do + let strict = getBool @strict + msgbase0 = "Para" <> strictmsg @strict + msgbase1 = msgbase0 <> "(" <> show n <> ")" + n :: Int + n = nat @n + case as' of + [] -> pure $ mkNode opts (PresentT mempty) [msgbase1 <> " (ran out of data!!)"] [] + a:as -> do + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts msgbase1 pp [] of + Left e -> e + -- show1 opts " " [b] fails but using 'b' is ok and (b : []) also works! + -- GE.List error + Right b -> mkNode opts (PresentT [b]) [msgbase1 <> (if null as then " done!" else " Truncated") <> show0 opts " " (b : []) <> show1 opts " | " a <> (if strict then "" else show1 opts " | leftovers=" as)] [hh pp] + +instance (KnownNat n + , GetBool strict + , GetLen ps + , P p a + , P (ParaImpl n strict (p1 ': ps)) [a] + , PP (ParaImpl n strict (p1 ': ps)) [a] ~ [PP p a] + , Show a + , Show (PP p a) + ) + => P (ParaImpl n strict (p ': p1 ': ps)) [a] where + type PP (ParaImpl n strict (p ': p1 ': ps)) [a] = [PP p a] + eval _ opts as' = do + let msgbase0 = msgbase2 <> "(" <> show (n-pos) <> " of " <> show n <> ")" + msgbase1 = msgbase2 <> "(" <> show (n-pos) <> ")" + msgbase2 = "Para" <> strictmsg @strict + n = nat @n + pos = 1 + getLen @ps -- cos p1! + case as' of + [] -> pure $ mkNode opts (PresentT mempty) [msgbase0 <> " (ran out of data!!)"] [] + a:as -> do + pp <- eval (Proxy @p) opts a + case getValueLR opts msgbase0 pp [] of + Left e -> pure e + Right b -> do + qq <- eval (Proxy @(ParaImpl n strict (p1 ': ps))) opts as + pure $ case getValueLRHide opts (msgbase1 <> " rhs failed " <> show b) qq [hh pp] of + Left e -> e + Right bs -> mkNode opts (PresentT (b:bs)) [msgbase1 <> show0 opts " " (b:bs) <> show1 opts " | " as'] [hh pp, hh qq] + +-- | leverages 'Para' for repeating predicates (passthrough method) +-- +-- >>> pl @(ParaNImpl 'True 4 (Succ Id)) [1..4] +-- Present [2,3,4,5] +-- PresentT [2,3,4,5] +-- +-- >>> pl @(ParaNLax 4 (Succ Id)) "azwxm" +-- Present "b{xy" +-- PresentT "b{xy" +-- +-- >>> pl @(ParaN 4 (Succ Id)) "azwxm" +-- Error Para: data elements(5) /= predicates(4) +-- FailT "Para: data elements(5) /= predicates(4)" +-- +-- >>> pl @(ParaN 4 (Succ Id)) "azwx" +-- Present "b{xy" +-- PresentT "b{xy" +-- +-- >>> pl @(ParaNLax 4 (FromEnum Id)) "azwxs" +-- Present [97,122,119,120] +-- PresentT [97,122,119,120] +-- +data ParaNImpl (strict :: Bool) (n :: Nat) p +type ParaN (n :: Nat) p = ParaNImpl 'True n p +type ParaNLax (n :: Nat) p = ParaNImpl 'False n p + +instance ( P (ParaImpl (LenT (RepeatT n p)) strict (RepeatT n p)) [a] + , GetLen (RepeatT n p) + , GetBool strict + ) => P (ParaNImpl strict n p) [a] where + type PP (ParaNImpl strict n p) [a] = PP (ParaImplW strict (RepeatT n p)) [a] + eval _ opts as = + eval (Proxy @(ParaImplW strict (RepeatT n p))) opts as + +-- | tries each predicate ps and on the first match runs the corresponding qs but if there is no match on ps then runs the fail case e +-- +-- >>> pl @(Case (FailS "asdf" >> Snd Id >> Unproxy ) '[Lt 4,Lt 10,Same 50] '[Printf "%d is lt4" Id, Printf "%d is lt10" Id, Printf "%d is same50" Id] Id) 50 +-- Present "50 is same50" +-- PresentT "50 is same50" +-- +-- >>> pl @(Case (FailS "asdf" >> Snd Id >> Unproxy ) '[Lt 4,Lt 10,Same 50] '[Printf "%d is lt4" Id, Printf "%d is lt10" Id, Printf "%d is same50" Id] Id) 9 +-- Present "9 is lt10" +-- PresentT "9 is lt10" +-- +-- >>> pl @(Case (FailS "asdf" >> Snd Id >> Unproxy ) '[Lt 4,Lt 10,Same 50] '[Printf "%d is lt4" Id, Printf "%d is lt10" Id, Printf "%d is same50" Id] Id) 3 +-- Present "3 is lt4" +-- PresentT "3 is lt4" +-- +-- >>> pl @(Case (FailS "asdf" >> Snd Id >> Unproxy ) '[Lt 4,Lt 10,Same 50] '[Printf "%d is lt4" Id, Printf "%d is lt10" Id, Printf "%d is same50" Id] Id) 99 +-- Error asdf +-- FailT "asdf" +-- +data CaseImpl (n :: Nat) (e :: k0) (ps :: [k]) (qs :: [k1]) (r :: k2) +-- ps = conditions +-- qs = what to do [one to one +-- r = the value +-- e = otherwise -- leave til later +data Case (e :: k0) (ps :: [k]) (qs :: [k1]) (r :: k2) +type Case' (ps :: [k]) (qs :: [k1]) (r :: k2) = Case (Snd Id >> Failp "Case:no match") ps qs r +type Case'' s (ps :: [k]) (qs :: [k1]) (r :: k2) = Case (FailCase s) ps qs r -- eg s= Printf "%s" (ShowP Id) + +type FailCase p = Fail (Snd Id >> Unproxy) (Fst Id >> p) + +-- passthru but adds the length of ps (replaces LenT in the type synonym to avoid type synonyms being expanded out +instance (FailIfT (NotT (LenT ps DE.== LenT qs)) ((LenT ps DE.== LenT qs) ~ 'True) + ('GL.Text "lengths are not the same " + ':<>: 'GL.ShowType (LenT ps) + ':<>: 'GL.Text " vs " + ':<>: 'GL.ShowType (LenT qs)) + , P (CaseImpl (LenT ps) e ps qs r) x + ) => P (Case e ps qs r) x where + type PP (Case e ps qs r) x = PP (CaseImpl (LenT ps) e ps qs r) x + eval _ = eval (Proxy @(CaseImpl (LenT ps) e ps qs r)) + +-- only allow non empty lists! +instance (GL.TypeError ('GL.Text "CaseImpl '[] invalid: lhs requires at least one value in the list")) + => P (CaseImpl n e ('[] :: [k]) (q ': qs) r) x where + type PP (CaseImpl n e ('[] :: [k]) (q ': qs) r) x = Void + eval _ _ _ = error "should not get this far" + +instance (GL.TypeError ('GL.Text "CaseImpl '[] invalid: rhs requires at least one value in the list")) + => P (CaseImpl n e (p ': ps) ('[] :: [k1]) r) x where + type PP (CaseImpl n e (p ': ps) ('[] :: [k1]) r) x = Void + eval _ _ _ = error "should not get this far" + +instance (GL.TypeError ('GL.Text "CaseImpl '[] invalid: lists are both empty")) + => P (CaseImpl n e ('[] :: [k]) ('[] :: [k1]) r) x where + type PP (CaseImpl n e ('[] :: [k]) ('[] :: [k1]) r) x = Void + eval _ _ _ = error "should not get this far" + +instance (P r x + , P q (PP r x) + , Show (PP q (PP r x)) + , P p (PP r x) + , PP p (PP r x) ~ Bool + , KnownNat n + , Show (PP r x) + , P e (PP r x, Proxy (PP q (PP r x))) + , PP e (PP r x, Proxy (PP q (PP r x))) ~ PP q (PP r x) + ) => P (CaseImpl n e '[p] '[q] r) x where + type PP (CaseImpl n e '[p] '[q] r) x = PP q (PP r x) + eval _ opts z = do + let msgbase0 = "Case" <> "(" <> show n <> ")" + n :: Int = nat @n + rr <- eval (Proxy @r) opts z + case getValueLR opts msgbase0 rr [] of + Left e -> pure e + Right a -> do + pp <- evalBool (Proxy @p) opts a + case getValueLR opts msgbase0 pp [hh rr] of + Left e -> pure e + Right True -> do + qq <- eval (Proxy @q) opts a + pure $ case getValueLR opts msgbase0 qq [hh rr, hh pp] of + Left e -> e + Right b -> mkNode opts (PresentT b) [show01 opts msgbase0 b a] [hh rr, hh pp, hh qq] + Right False -> do + ee <- eval (Proxy @e) opts (a, Proxy @(PP q (PP r x))) + pure $ case getValueLR opts (msgbase0 <> " otherwise failed") ee [hh rr, hh pp] of + Left e -> e + Right b -> mkNode opts (PresentT b) [show01 opts msgbase0 b a] [hh rr, hh pp, hh ee] + +instance (KnownNat n + , GetLen ps + , P r x + , P p (PP r x) + , P q (PP r x) + , PP p (PP r x) ~ Bool + , Show (PP q (PP r x)) + , Show (PP r x) + , P (CaseImpl n e (p1 ': ps) (q1 ': qs) r) x + , PP (CaseImpl n e (p1 ': ps) (q1 ': qs) r) x ~ PP q (PP r x) + ) + => P (CaseImpl n e (p ': p1 ': ps) (q ': q1 ': qs) r) x where + type PP (CaseImpl n e (p ': p1 ': ps) (q ': q1 ': qs) r) x = PP q (PP r x) + eval _ opts z = do + let msgbase0 = msgbase2 <> "(" <> show (n-pos) <> " of " <> show n <> ")" + msgbase1 = msgbase2 <> "(" <> show (n-pos) <> ")" + msgbase2 = "Case" + n = nat @n + pos = 1 + getLen @ps -- cos p1! + rr <- eval (Proxy @r) opts z + case getValueLR opts msgbase0 rr [] of + Left e -> pure e + Right a -> do + pp <- evalBool (Proxy @p) opts a + case getValueLR opts msgbase0 pp [hh rr] of + Left e -> pure e + Right True -> do + qq <- eval (Proxy @q) opts a + pure $ case getValueLR opts msgbase0 qq [hh rr] of + Left e -> e + Right b -> mkNode opts (PresentT b) [show01 opts msgbase0 b a] [hh rr, hh pp, hh qq] + Right False -> do + ww <- eval (Proxy @(CaseImpl n e (p1 ': ps) (q1 ': qs) r)) opts z + pure $ case getValueLR opts (msgbase1 <> " failed rhs") ww [hh rr, hh pp] of + Left e -> e + Right b -> mkNode opts (PresentT b) [show01 opts msgbase1 b a] [hh rr, hh pp, hh ww] + +-- | similar to 'sequenceA' +-- +-- >>> pl @Sequence [Just 10, Just 20, Just 30] +-- Present Just [10,20,30] +-- PresentT (Just [10,20,30]) +-- +-- >>> pl @Sequence [Just 10, Just 20, Just 30, Nothing, Just 40] +-- Present Nothing +-- PresentT Nothing +-- +data Sequence +type Traverse p q = Map p q >> Sequence + + +instance (Show (f (t a)) + , Show (t (f a)) + , Traversable t + , Applicative f + ) => P Sequence (t (f a)) where + type PP Sequence (t (f a)) = f (t a) + eval _ opts tfa = + let d = sequenceA tfa + in pure $ mkNode opts (PresentT d) ["Sequence" <> show0 opts " " d <> show1 opts " | " tfa] [] + +data Hide p +type H = Hide +-- type H p = Hide p -- doesnt work with % -- unsaturated! + +instance P p x => P (Hide p) x where + type PP (Hide p) x = PP p x + eval _ opts x = do + tt <- eval (Proxy @(Msg "!" p)) opts x + pure $ tt & tForest .~ [] + +-- | similar to 'readFile' +-- +-- >>> pl @(ReadFile ".ghci" >> 'Just Id >> Len >> Gt 0) () +-- True +-- TrueT +-- +-- >>> pl @(FileExists "xyzzy") () +-- False +-- FalseT +-- +data ReadFile p +type FileExists p = ReadFile p >> IsJust + +instance (PP p x ~ String, P p x) => P (ReadFile p) x where + type PP (ReadFile p) x = Maybe String + eval _ opts x = do + let msg0 = "ReadFile" + pp <- eval (Proxy @p) opts x + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right p -> do + let msg1 = msg0 <> "[" <> p <> "]" + mb <- runIO $ do + b <- doesFileExist p + if b then Just <$> readFile p + else pure Nothing + pure $ case mb of + Nothing -> mkNode opts (FailT (msg1 <> " must run in IO")) [msg1 <> " must run in IO"] [] + Just Nothing -> mkNode opts (PresentT Nothing) [msg1 <> " does not exist"] [] + Just (Just b) -> mkNode opts (PresentT (Just b)) [msg1 <> " len=" <> show (length b) <> showLit0 opts " Just " b] [] + +-- | does the directory exists +-- +-- >>> pl @(DirExists ".") () +-- True +-- TrueT +-- +data ReadDir p +type DirExists p = ReadDir p >> IsJust + +instance (PP p x ~ String, P p x) => P (ReadDir p) x where + type PP (ReadDir p) x = Maybe [FilePath] + eval _ opts x = do + let msg0 = "ReadDir" + pp <- eval (Proxy @p) opts x + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right p -> do + let msg1 = msg0 <> "[" <> p <> "]" + mb <- runIO $ do + b <- doesDirectoryExist p + if b then Just <$> listDirectory p + else pure Nothing + pure $ case mb of + Nothing -> mkNode opts (FailT (msg1 <> " must run in IO")) [msg1 <> " must run in IO"] [] + Just Nothing -> mkNode opts (PresentT Nothing) [msg1 <> " does not exist"] [] + Just (Just b) -> mkNode opts (PresentT (Just b)) [msg1 <> " len=" <> show (length b) <> show0 opts " Just " b] [] + +-- | does the directory exists +-- +-- >>> pl @(ReadEnv "PATH" >> 'Just Id >> 'True) () +-- True +-- TrueT +-- +data ReadEnv p + +instance (PP p x ~ String, P p x) => P (ReadEnv p) x where + type PP (ReadEnv p) x = Maybe String + eval _ opts x = do + let msg0 = "ReadEnv" + pp <- eval (Proxy @p) opts x + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right p -> do + let msg1 = msg0 <> "[" <> p <> "]" + mb <- runIO $ lookupEnv p + pure $ case mb of + Nothing -> mkNode opts (FailT (msg1 <> " must run in IO")) [msg1 <> " must run in IO"] [] + Just Nothing -> mkNode opts (PresentT Nothing) [msg1 <> " does not exist"] [] + Just (Just v) -> mkNode opts (PresentT (Just v)) [msg1 <> showLit0 opts " " v] [] + +data ReadEnvAll + +instance P ReadEnvAll a where + type PP ReadEnvAll a = [(String,String)] + eval _ opts _ = do + let msg0 = "ReadEnvAll" + mb <- runIO $ getEnvironment + pure $ case mb of + Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) [msg0 <> " must run in IO"] [] + Just v -> mkNode opts (PresentT v) [msg0 <> " count=" <> show (length v)] [] + +data TimeUtc + +instance P TimeUtc a where + type PP TimeUtc a = UTCTime + eval _ opts _a = do + let msg0 = "TimeUtc" + mb <- runIO $ getCurrentTime + pure $ case mb of + Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) [msg0 <> " must run in IO"] [] + Just v -> mkNode opts (PresentT v) [msg0 <> show0 opts " " v] [] + +data TimeZt + +instance P TimeZt a where + type PP TimeZt a = ZonedTime + eval _ opts _a = do + let msg0 = "TimeZt" + mb <- runIO $ getZonedTime + pure $ case mb of + Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) [msg0 <> " must run in IO"] [] + Just v -> mkNode opts (PresentT v) [msg0 <> show0 opts " " v] [] + +data FHandle s = FStdout | FStderr | FOther s WFMode deriving Show + +class GetFHandle (x :: FHandle Symbol) where getFHandle :: FHandle String +instance GetFHandle 'FStdout where getFHandle = FStdout +instance GetFHandle 'FStderr where getFHandle = FStderr +instance (GetMode w, KnownSymbol s) => GetFHandle ('FOther s w) where getFHandle = FOther (symb @s) (getMode @w) + +data WFMode = WFAppend | WFWrite | WFWriteForce deriving (Show,Eq) + +class GetMode (x :: WFMode) where getMode :: WFMode +instance GetMode 'WFAppend where getMode = WFAppend +instance GetMode 'WFWriteForce where getMode = WFWriteForce +instance GetMode 'WFWrite where getMode = WFWrite + +data WriteFileImpl (hh :: FHandle Symbol) p +type AppendFile (s :: Symbol) p = WriteFileImpl ('FOther s 'WFAppend) p +type WriteFile' (s :: Symbol) p = WriteFileImpl ('FOther s 'WFWriteForce) p +type WriteFile (s :: Symbol) p = WriteFileImpl ('FOther s 'WFWrite) p +type Stdout p = WriteFileImpl 'FStdout p +type Stderr p = WriteFileImpl 'FStderr p + +instance (GetFHandle fh + , P p a + , PP p a ~ String + ) => P (WriteFileImpl fh p) a where + type PP (WriteFileImpl fh p) a = () + eval _ opts a = do + let fh = getFHandle @fh + msg0 = case fh of + FStdout -> "Stdout" + FStderr -> "Stderr" + FOther s w -> (<>("[" <> s <> "]")) $ case w of + WFAppend -> "AppendFile" + WFWrite -> "WriteFile" + WFWriteForce -> "WriteFile'" + pp <- eval (Proxy @p) opts a + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right ss -> do + mb <- runIO $ do + case fh of + FStdout -> fmap (left show) $ E.try @E.SomeException $ hPutStr stdout ss + FStderr -> fmap (left show) $ E.try @E.SomeException $ hPutStr stderr ss + FOther s w -> do + b <- doesFileExist s + if b && w == WFWrite then pure $ Left $ "file [" <> s <> "] already exists" + else do + let md = case w of + WFAppend -> AppendMode + _ -> WriteMode + fmap (left show) $ E.try @E.SomeException $ withFile s md (flip hPutStr ss) + pure $ case mb of + Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) [msg0 <> " must run in IO"] [hh pp] + Just (Left e) -> mkNode opts (FailT e) [msg0 <> " " <> e] [hh pp] + Just (Right ()) -> mkNode opts (PresentT ()) [msg0] [hh pp] + +data Stdin + +instance P Stdin a where + type PP Stdin a = String + eval _ opts _a = do + let msg0 = "Stdin" + mb <- runIO $ do + lr <- E.try $ hGetContents stdin + pure $ case lr of + Left (e :: E.SomeException) -> Left $ show e + Right ss -> Right ss + pure $ case mb of + Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) [msg0 <> " must run in IO"] [] + Just (Left e) -> mkNode opts (FailT e) [msg0 <> " " <> e] [] + Just (Right ss) -> mkNode opts (PresentT ss) [msg0 <> "[" <> showLit1 opts "" ss <> "]"] [] + +--type Just' = JustFail "expected Just" Id +--type Nothing' = Guard "expected Nothing" IsNothing + +-- | similar to 'isInfixOf' 'isPrefixOf' 'isSuffixOf' for strings only. +-- +-- The \'I\' suffixed versions work are case insensitive. +-- +-- >>> pl @(IsInfixI "abc" "axAbCd") () +-- True +-- TrueT +-- +-- >>> pl @(IsPrefixI "abc" "aBcbCd") () +-- True +-- TrueT +-- +-- >>> pl @(IsPrefix "abc" "aBcbCd") () +-- False +-- FalseT +-- +-- >>> pl @(IsSuffix "bCd" "aBcbCd") () +-- True +-- TrueT +-- +data IsFixImpl (cmp :: Ordering) (ignore :: Bool) p q + +type IsPrefix p q = IsFixImpl 'LT 'False p q +type IsInfix p q = IsFixImpl 'EQ 'False p q +type IsSuffix p q = IsFixImpl 'GT 'False p q + +type IsPrefixI p q = IsFixImpl 'LT 'True p q +type IsInfixI p q = IsFixImpl 'EQ 'True p q +type IsSuffixI p q = IsFixImpl 'GT 'True p q + +instance (GetBool ignore + , P p x + , P q x + , PP p x ~ String + , PP q x ~ String + , GetOrdering cmp + ) => P (IsFixImpl cmp ignore p q) x where + type PP (IsFixImpl cmp ignore p q) x = Bool + eval _ opts x = do + let cmp = getOrdering @cmp + ignore = getBool @ignore + lwr = if ignore then map toLower else id + (ff,msg0) = case cmp of + LT -> (isPrefixOf, "IsPrefix") + EQ -> (isInfixOf, "IsInfix") + GT -> (isSuffixOf, "IsSuffix") + pp <- eval (Proxy @p) opts x + case getValueLR opts msg0 pp [] of + Left e -> pure e + Right s0 -> do + let msg1 = msg0 <> (if ignore then "I" else "") <> "(" <> s0 <> ")" + qq <- eval (Proxy @q) opts x + pure $ case getValueLR opts (msg1 <> " q failed") qq [hh pp] of + Left e -> e + Right s1 -> mkNodeB opts (on ff lwr s0 s1) [msg1 <> showLit0 opts " " s1] [hh pp, hh qq] + +-- | similar to 'SG.<>' +-- +-- >>> pl @(Fst Id <> Snd Id) ("abc","def") +-- Present "abcdef" +-- PresentT "abcdef" +-- +-- >>> pl @("abcd" <> "ef" <> Id) "ghi" +-- Present "abcdefghi" +-- PresentT "abcdefghi" +-- +-- >>> pl @("abcd" <> "ef" <> Id) "ghi" +-- Present "abcdefghi" +-- PresentT "abcdefghi" +-- +-- >>> pl @(Wrap (SG.Sum _) Id <> FromInteger _ 10) 13 +-- Present Sum {getSum = 23} +-- PresentT (Sum {getSum = 23}) +-- +-- >>> pl @(Wrap (SG.Product _) Id <> FromInteger _ 10) 13 +-- Present Product {getProduct = 130} +-- PresentT (Product {getProduct = 130}) +-- +-- >>> pl @('(FromInteger _ 10,"def") <> Id) (SG.Sum 12, "_XYZ") +-- Present (Sum {getSum = 22},"def_XYZ") +-- PresentT (Sum {getSum = 22},"def_XYZ") +-- +data p <> q +infixr 6 <> +type Sapa' (t :: Type) = Wrap t (Fst Id) <> Wrap t (Snd Id) +type Sapa = Fst Id <> Snd Id + +instance (Semigroup (PP p x) + , PP p x ~ PP q x + , P p x + , Show (PP q x) + ,P q x + ) => P (p <> q) x where + type PP (p <> q) x = PP p x + eval _ opts x = do + let msg0 = "<>" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = p <> q + in mkNode opts (PresentT d) [show p <> " <> " <> show q <> " = " <> show d] [hh pp, hh qq] + + +-- | uses inductive tuples to replace variable arguments +-- +class PrintC x where + prtC :: (PrintfArg a, PrintfType r) => String -> (a,x) -> r +instance PrintC () where + prtC s (a,()) = printf s a +instance (PrintfArg a, PrintC rs) => PrintC (a,rs) where + prtC s (a,rs) = prtC s rs a + +data TupleListImpl (strict :: Bool) (n :: Nat) +type TupleList (n :: Nat) = TupleListImpl 'True n +type TupleListLax (n :: Nat) = TupleListImpl 'False n + +instance (Show a + , KnownNat n + , GetBool strict + , TupleListD (ToN n) a + , Show (TupleListT (ToN n) a) + ) => P (TupleListImpl strict n) [a] where + type PP (TupleListImpl strict n) [a] = TupleListT (ToN n) a + eval _ opts as = do + let strict = getBool @strict + n :: Int + n = nat @n + msg0 = "TupleList" <> (if strict then "" else "Lax") <> "(" <> show n <> ")" + pure $ case tupleListD @(ToN n) @a strict as of + Left e -> mkNode opts (FailT (msg0 <> " " <> e)) [msg0 <> " " <> e] [] + Right ret -> mkNode opts (PresentT ret) [show01 opts msg0 ret as] [] + +-- | reverses inductive tuples +-- +-- >>> pl @ReverseTupleN (1,('a',(True,("def",())))) +-- Present ("def",(True,('a',(1,())))) +-- PresentT ("def",(True,('a',(1,())))) +-- +-- >>> pl @ReverseTupleN (1,('a',())) +-- Present ('a',(1,())) +-- PresentT ('a',(1,())) +-- +-- >>> pl @ReverseTupleN (999,()) +-- Present (999,()) +-- PresentT (999,()) +-- +data ReverseTupleN + +instance (ReverseTupleC tp + , Show (ReverseTupleP tp) + , Show tp + ) => P ReverseTupleN tp where + type PP ReverseTupleN tp = ReverseTupleP tp + eval _ opts tp = + let ret = reverseTupleC tp + in pure $ mkNode opts (PresentT ret) ["ReverseTupleN" <> show0 opts " " ret <> show1 opts " | " tp] [] + +-- | Printfn prints an inductive tuple +-- +-- >>> pl @(Printfn "%s %s" Id) ("123",("def",())) +-- Present "123 def" +-- PresentT "123 def" +-- +-- >>> pl @(Printfn "s=%s d=%03d" Id) ("ab",(123,())) +-- Present "s=ab d=123" +-- PresentT "s=ab d=123" +-- +data Printfn s p +type Printfnt (n :: Nat) s = Printfn s (TupleList n) +type PrintfntLax (n :: Nat) s = Printfn s (TupleListLax n) + +-- | print a 2-tuple +-- +-- >>> pl @(Printf2 "fst=%s snd=%03d") ("ab",123) +-- Present "fst=ab snd=123" +-- PresentT "fst=ab snd=123" +-- +type Printf2 s = Printfn s '(Fst Id,'(Snd Id, '())) +-- | print a 3-tuple +-- +-- >>> pl @(Printf3 "fst=%s snd=%03d thd=%s") ("ab",123,"xx") +-- Present "fst=ab snd=123 thd=xx" +-- PresentT "fst=ab snd=123 thd=xx" +-- +type Printf3 s = Printfn s '(Fst Id, '(Snd Id, '(Thd Id, '()))) +type Printf3' s = Printfn s (TupleI '[Fst Id, Snd Id, Thd Id]) + + +instance (KnownNat (TupleLenT as) + , PrintC bs + , (b,bs) ~ ReverseTupleP (a,as) + , ReverseTupleC (a,as) + , Show a + , Show as + , PrintfArg b + , PP s x ~ String + , PP p x ~ (a,as) + , P s x + , P p x + , CheckT (PP p x) ~ 'True + ) => P (Printfn s p) x where + type PP (Printfn s p) x = String + eval _ opts x = do + let msg0 = "Printfn" + lrx <- runPQ msg0 (Proxy @s) (Proxy @p) opts x + case lrx of + Left e -> pure e + Right (s,(a,as),ss,pp) -> do + let len :: Int = 1 + nat @(TupleLenT as) + msg1 = msg0 <> "(" <> show len <> ")" + hhs = [hh ss, hh pp] + lr <- catchitNF @_ @E.SomeException (prtC @bs s (reverseTupleC (a,as))) + pure $ case lr of + Left e -> mkNode opts (FailT (msg1 <> "(" <> e <> ")")) [msg1 <> show0 opts " " a <> " s=" <> s] hhs + Right ret -> mkNode opts (PresentT ret) [msg1 <> " [" <> showLit0 opts "" ret <> "]" <> show1 opts " | (a,as)=" (a,as) <> showLit0 opts " | s=" s] hhs + +type family CheckT (tp :: Type) :: Bool where + CheckT () = GL.TypeError ('GL.Text "Printfn: inductive tuple cannot be empty") + CheckT o = 'True + +type family ApplyConstT (ta :: Type) (b :: Type) :: Type where +--type family ApplyConstT ta b where -- less restrictive so allows ('Just Int) Bool through! + ApplyConstT (t a) b = t b + ApplyConstT ta b = GL.TypeError ( + 'GL.Text "ApplyConstT: (t a) b but found something else" + ':$$: 'GL.Text "t a = " + ':<>: 'GL.ShowType ta + ':$$: 'GL.Text "b = " + ':<>: 'GL.ShowType b) + +-- | similar to 'Control.Applicative.<$' +-- +-- >>> pl @(Fst Id <$ Snd Id) ("abc",Just 20) +-- Present Just "abc" +-- PresentT (Just "abc") +-- +data p <$ q +infixl 4 <$ + +instance (P p x + , P q x + , Show (PP p x) + , Functor t + , PP q x ~ t c + , ApplyConstT (PP q x) (PP p x) ~ t (PP p x) + ) => P (p <$ q) x where + type PP (p <$ q) x = ApplyConstT (PP q x) (PP p x) + eval _ opts x = do + let msg0 = "(<$)" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = p <$ q + in mkNode opts (PresentT d) [msg0 <> show0 opts " " p] [hh pp, hh qq] + +data p <* q +infixl 4 <* + +-- | similar to 'Control.Applicative.<*' +-- +-- >>> pl @(Fst Id <* Snd Id) (Just "abc",Just 20) +-- Present Just "abc" +-- PresentT (Just "abc") +-- +type p *> q = q <* p +infixl 4 *> + +instance (Show (t c) + , P p x + , P q x + , Show (t b) + , Applicative t + , t b ~ PP p x + , PP q x ~ t c + ) => P (p <* q) x where + type PP (p <* q) x = PP p x + eval _ opts x = do + let msg0 = "(<*)" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = p <* q + in mkNode opts (PresentT d) [show01' opts msg0 p "p=" p <> show1 opts " | q=" q] [hh pp, hh qq] + +-- | similar to 'Control.Applicative.<|>' +-- +-- >>> pl @(Fst Id <|> Snd Id) (Nothing,Just 20) +-- Present Just 20 +-- PresentT (Just 20) +-- +-- >>> pl @(Fst Id <|> Snd Id) (Just 10,Just 20) +-- Present Just 10 +-- PresentT (Just 10) +-- +-- >>> pl @(Fst Id <|> Snd Id) (Nothing,Nothing) +-- Present Nothing +-- PresentT Nothing +-- +data p <|> q +infixl 3 <|> + +instance (P p x + , P q x + , Show (t b) + , Alternative t + , t b ~ PP p x + , PP q x ~ t b + ) => P (p <|> q) x where + type PP (p <|> q) x = PP p x + eval _ opts x = do + let msg0 = "(<|>)" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = p <|> q + in mkNode opts (PresentT d) [show01' opts msg0 d "p=" p <> show1 opts " | q=" q] [hh pp, hh qq] + + +-- | similar to 'Control.Comonad.extract' +-- +-- >>> pl @Extract (Nothing,Just 20) +-- Present Just 20 +-- PresentT (Just 20) +-- +-- >>> pl @Extract (Identity 20) +-- Present 20 +-- PresentT 20 +-- +data Extract +instance (Show (t a) + , Show a + , Comonad t + ) => P Extract (t a) where + type PP Extract (t a) = a + eval _ opts ta = + let msg0 = "Extract" + d = extract ta + in pure $ mkNode opts (PresentT d) [show01 opts msg0 d ta] [] + +-- | similar to 'Control.Comonad.duplicate' +-- +-- >>> pl @Duplicate (20,"abc") +-- Present (20,(20,"abc")) +-- PresentT (20,(20,"abc")) +-- +data Duplicate + +instance (Show (t a) + , Show (t (t a)) + , Comonad t + ) => P Duplicate (t a) where + type PP Duplicate (t a) = t (t a) + eval _ opts ta = + let msg0 = "Duplicate" + d = duplicate ta + in pure $ mkNode opts (PresentT d) [show01 opts msg0 d ta] [] + +-- | similar to 'Control.Monad.join' +-- +-- >>> pl @Join (Just (Just 20)) +-- Present Just 20 +-- PresentT (Just 20) +-- +-- >>> pl @Join ["ab","cd","","ef"] +-- Present "abcdef" +-- PresentT "abcdef" +-- +data Join + +instance (Show (t (t a)) + , Show (t a) + , Monad t + ) => P Join (t (t a)) where + type PP Join (t (t a)) = t a + eval _ opts tta = + let msg0 = "Join" + d = join tta + in pure $ mkNode opts (PresentT d) [show01 opts msg0 d tta] [] + +-- same as $ but shows 'a' and 'b' +data p $ q +infixl 0 $ + +instance (P p x + , P q x + , PP p x ~ (a -> b) + , FnT (PP p x) ~ b + , PP q x ~ a + , Show a + , Show b + ) => P (p $ q) x where + type PP (p $ q) x = FnT (PP p x) + eval _ opts x = do + let msg0 = "($)" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = p q + in mkNode opts (PresentT d) ["fn $ " <> show q <> " = " <> show d] [hh pp, hh qq] + +-- reify this so we can combine (type synonyms dont work as well) +data q & p -- flips the args eg a & b & (,) = (b,a) +infixr 1 & + +instance (P p x + , P q x + , PP p x ~ (a -> b) + , FnT (PP p x) ~ b + , PP q x ~ a + , Show a + , Show b + ) => P (q & p) x where + type PP (q & p) x = FnT (PP p x) + eval _ opts x = do + let msg0 = "(&)" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = p q + in mkNode opts (PresentT d) ["fn & " <> show q <> " = " <> show d] [hh pp, hh qq] + +type family FnT ab :: Type where + FnT (a -> b) = b + FnT ab = GL.TypeError ( + 'GL.Text "FnT: expected Type -> Type but found a simple Type?" + ':$$: 'GL.Text "ab = " + ':<>: 'GL.ShowType ab) + +-- | similar to 'T.strip' 'T.stripStart' 'T.stripEnd' +-- +-- >>> pl @(Trim (Snd Id)) (20," abc " :: String) +-- Present "abc" +-- PresentT "abc" +-- +-- >>> pl @(Trim (Snd Id)) (20,T.pack " abc ") +-- Present "abc" +-- PresentT "abc" +-- +-- >>> pl @(TrimStart (Snd Id)) (20," abc ") +-- Present "abc " +-- PresentT "abc " +-- +-- >>> pl @(TrimEnd (Snd Id)) (20," abc ") +-- Present " abc" +-- PresentT " abc" +-- +-- >>> pl @(TrimEnd " abc ") () +-- Present " abc" +-- PresentT " abc" +-- +-- >>> pl @(TrimEnd "") () +-- Present "" +-- PresentT "" +-- +-- >>> pl @(Trim " ") () +-- Present "" +-- PresentT "" +-- +-- >>> pl @(Trim "") () +-- Present "" +-- PresentT "" +-- +data Trim' (left :: Bool) (right :: Bool) p +type Trim p = Trim' 'True 'True p +type TrimStart p = Trim' 'True 'False p +type TrimEnd p = Trim' 'False 'True p + +instance (FailIfT (NotT (OrT l r)) () + ('GL.Text "Trim': left and right cannot both be False") + , GetBool l + , GetBool r + , TL.IsText (PP p x) + , P p x + ) => P (Trim' l r p) x where + type PP (Trim' l r p) x = PP p x + eval _ opts x = do + let msg0 = "Trim" ++ (if l && r then "" else if l then "Start" else "End") + l = getBool @l + r = getBool @r + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right (view TL.unpacked -> p) -> + let fl = if l then dropWhile isSpace else id + fr = if r then dropWhileEnd isSpace else id + b = (fl . fr) p + in mkNode opts (PresentT (b ^. TL.packed)) [msg0 <> showLit0 opts "" b <> showLit1 opts " | " p] [hh pp] + +-- | similar to 'T.stripLeft' 'T.stripRight' +-- +-- >>> pl @(StripLeft "xyz" Id) ("xyzHello" :: String) +-- Present Just "Hello" +-- PresentT (Just "Hello") +-- +-- >>> pl @(StripLeft "xyz" Id) (T.pack "xyzHello") +-- Present Just "Hello" +-- PresentT (Just "Hello") +-- +-- >>> pl @(StripLeft "xyz" Id) "xywHello" +-- Present Nothing +-- PresentT Nothing +-- +-- >>> pl @(StripRight "xyz" Id) "Hello xyz" +-- Present Just "Hello " +-- PresentT (Just "Hello ") +-- +-- >>> pl @(StripRight "xyz" Id) "xyzHelloxyw" +-- Present Nothing +-- PresentT Nothing +-- +-- >>> pl @(StripRight "xyz" Id) "" +-- Present Nothing +-- PresentT Nothing +-- +-- >>> pl @(StripRight "xyz" "xyz") () +-- Present Just "" +-- PresentT (Just "") +-- +data StripLR (right :: Bool) p q +type StripRight p q = StripLR 'True p q +type StripLeft p q = StripLR 'False p q + +instance (GetBool r + , PP p x ~ String + , P p x + , TL.IsText (PP q x) + , P q x + ) => P (StripLR r p q) x where + type PP (StripLR r p q) x = Maybe (PP q x) + eval _ opts x = do + let msg0 = "Strip" ++ (if r then "Right" else "Left") + r = getBool @r + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts x + pure $ case lr of + Left e -> e + Right (p,view TL.unpacked -> q,pp,qq) -> + let b = if r then + let (before,after) = splitAt (length q - length p) q + in if after == p then Just before else Nothing + else + let (before,after) = splitAt (length p) q + in if before == p then Just after else Nothing + in mkNode opts (PresentT (fmap (view TL.packed) b)) [msg0 <> show0 opts "" b <> showLit1 opts " | p=" p <> showLit1 opts " | q=" q] [hh pp, hh qq] + +-- | creates a promoted list of predicates and then evaluates them into a list. see PP instance for '[k] +-- +-- >>> pl @(Repeat 4 (Succ Id)) 'c' +-- Present "dddd" +-- PresentT "dddd" +-- +-- >>> pl @(Repeat 4 "abc") () +-- Present ["abc","abc","abc","abc"] +-- PresentT ["abc","abc","abc","abc"] +-- +data Repeat (n :: Nat) p +instance (P (RepeatT n p) a + ) => P (Repeat n p) a where + type PP (Repeat n p) a = PP (RepeatT n p) a + eval _ opts a = + eval (Proxy @(RepeatT n p)) opts a + +-- | leverages 'Do' for repeating predicates (passthrough method) +-- same as @DoN n p == FoldN n p Id@ but more efficient +-- +-- >>> pl @(DoN 4 (Succ Id)) 'c' +-- Present 'g' +-- PresentT 'g' +-- +-- >>> pl @(DoN 4 (Id <> " | ")) "abc" +-- Present "abc | | | | " +-- PresentT "abc | | | | " +-- +-- >>> pl @(DoN 4 (Id <> "|" <> Id)) "abc" +-- Present "abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc" +-- PresentT "abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc|abc" +-- +data DoN (n :: Nat) p +instance (P (DoExpandT (RepeatT n p)) a + ) => P (DoN n p) a where + type PP (DoN n p) a = PP (Do (RepeatT n p)) a + eval _ opts a = + eval (Proxy @(Do (RepeatT n p))) opts a +
+ src/Predicate/Refined.hs view
@@ -0,0 +1,419 @@+{-# OPTIONS -Wall #-} +{-# OPTIONS -Wcompat #-} +{-# OPTIONS -Wincomplete-record-updates #-} +{-# OPTIONS -Wincomplete-uni-patterns #-} +{-# OPTIONS -Wredundant-constraints #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveLift #-} +{- | + Simple refinement type with only one type and a predicate +-} +module Predicate.Refined ( + -- ** Refined + Refined(unRefined) + , RefinedC + , newRefined + , RefinedT(..) + -- ** print methods + , prtRefinedIO + , prtRefinedTIO + , prtRefinedT + -- ** create Refined + , withRefinedT + , withRefinedTIO + , newRefinedT + , newRefinedTIO + -- ** QuickCheck method + , arbRefined + -- ** manipulate RefinedT values + , convertRefinedT + , unRavelT + , unRavelTIO + , unRavelTI + , rapply + , rapply0 + , rapply1 + -- ** create Refined unsafely + , unsafeRefined + , unsafeRefined' + ) where +import Predicate.Core +import Predicate.Util +import Control.Lens ((^.)) +import Data.Functor.Identity (Identity(..)) +import Data.Proxy +import Control.Monad.Except +import Control.Monad.Writer (WriterT(..), runWriterT, MonadWriter, tell) +import Control.Monad.Cont +import Data.Aeson +import GHC.Generics (Generic) +import qualified Language.Haskell.TH.Syntax as TH +import System.Console.Pretty +import Test.QuickCheck +import qualified GHC.Read as GR +import qualified Text.ParserCombinators.ReadPrec as PCR +import qualified Text.Read.Lex as RL +import qualified Data.Binary as B +import Data.Binary (Binary) +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> :set -XTypeOperators +-- >>> :set -XNoStarIsType +-- >>> :set -XOverloadedStrings +-- >>> :m + Predicate.Prelude + +-- | a simple refinement type that ensures the predicate \'p\' holds for the type \'a\' +-- +-- >>> prtRefinedIO @(Between 10 14) ol 13 +-- Right (Refined {unRefined = 13}) +-- +-- >>> prtRefinedIO @(Between 10 14) ol 99 +-- Left FalseP +-- +-- >>> prtRefinedIO @(Last >> Len == 4) ol ["one","two","three","four"] +-- Right (Refined {unRefined = ["one","two","three","four"]}) +-- +-- >>> prtRefinedIO @(Re "^\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}$" Id) ol "141.213.1.99" +-- Right (Refined {unRefined = "141.213.1.99"}) +-- +-- >>> prtRefinedIO @(Re "^\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}$" Id) ol "141.213.1" +-- Left FalseP +-- +-- >>> prtRefinedIO @(Map (ReadP Int) (Resplit "\\." Id) >> Guard (Printf "bad length: found %d" Len) (Len == 4) >> 'True) ol "141.213.1" +-- Left (FailP "bad length: found 3") +-- +-- >>> prtRefinedIO @(Map (ReadP Int) (Resplit "\\." Id) >> Guard (Printf "bad length: found %d" Len) (Len == 4) >> GuardsN (Printf2 "octet %d out of range %d") 4 (Between 0 255) >> 'True) ol "141.213.1.444" +-- Left (FailP "octet 4 out of range 444") +-- +-- >>> prtRefinedIO @(Map (ReadP Int) (Resplit "\\." Id) >> Guard (Printf "bad length: found %d" Len) (Len == 4) >> GuardsN (Printf2 "octet %d out of range %d") 4 (Between 0 255) >> 'True) ol "141.213.1x34.444" +-- Left (FailP "ReadP Int (1x34) failed") +-- +-- >>> prtRefinedIO @(Map ('[Id] >> ReadP Int) Id >> Luhn Id) ol "12344" +-- Right (Refined {unRefined = "12344"}) +-- +-- >>> prtRefinedIO @(Map ('[Id] >> ReadP Int) Id >> Luhn Id) ol "12340" +-- Left FalseP +-- +-- >>> prtRefinedIO @(Any (Prime Id) Id) ol [11,13,17,18] +-- Right (Refined {unRefined = [11,13,17,18]}) +-- +-- >>> prtRefinedIO @(All (Prime Id) Id) ol [11,13,17,18] +-- Left FalseP +-- +-- >>> prtRefinedIO @(Snd Id !! Fst Id >> Len > 5) ol (2,["abc","defghij","xyzxyazsfd"]) +-- Right (Refined {unRefined = (2,["abc","defghij","xyzxyazsfd"])}) +-- +-- >>> prtRefinedIO @(Snd Id !! Fst Id >> Len > 5) ol (27,["abc","defghij","xyzxyazsfd"]) +-- Left (FailP "(!!) index not found") +-- +-- >>> prtRefinedIO @(Snd Id !! Fst Id >> Len <= 5) ol (2,["abc","defghij","xyzxyazsfd"]) +-- Left FalseP +newtype Refined p a = Refined { unRefined :: a } deriving (Show, Eq, Generic, TH.Lift) + +-- | 'Read' instance for 'Refined' +-- +-- >>> reads @(Refined (Between 0 255) Int) "Refined {unRefined = 254}" +-- [(Refined {unRefined = 254},"")] +-- +-- >>> reads @(Refined (Between 0 255) Int) "Refined {unRefined = 300}" +-- [] +-- +instance (RefinedC p a, Read a) => Read (Refined p a) where + readPrec + = GR.parens + (PCR.prec + 11 + (do GR.expectP (RL.Ident "Refined") + GR.expectP (RL.Punc "{") + fld0 <- GR.readField + "unRefined" + (PCR.reset GR.readPrec) + GR.expectP (RL.Punc "}") + let (_,mr) = runIdentity $ newRefined @p ol fld0 + case mr of + Nothing -> fail "" + Just _r -> pure (Refined fld0) + )) + readList = GR.readListDefault + readListPrec = GR.readListPrecDefault + +-- | the constraints that 'Refined' must adhere to +type RefinedC p a = (PP p a ~ Bool, P p a) + +-- | 'ToJSON' instance for 'Refined' +instance ToJSON a => ToJSON (Refined p a) where + toJSON = toJSON . unRefined + +-- | 'FromJSON' instance for 'Refined' +-- +-- >>> :set -XOverloadedStrings +-- >>> eitherDecode' @(Refined (Between 10 14) Int) "13" +-- Right (Refined {unRefined = 13}) +-- +-- >>> removeAnsi $ eitherDecode' @(Refined (Between 10 14) Int) "16" +-- Error in $: Refined:FalseP +-- False True && False +-- | +-- +- True 16 >= 10 +-- | | +-- | +- P I +-- | | +-- | `- P '10 +-- | +-- `- False 16 <= 14 +-- | +-- +- P I +-- | +-- `- P '14 +-- <BLANKLINE> +-- +instance (RefinedC p a, FromJSON a) => FromJSON (Refined p a) where + parseJSON z = do + a <- parseJSON z + let ((bp,e),mr) = runIdentity $ newRefined @p o2 a + case mr of + Nothing -> fail $ "Refined:" ++ show bp ++ "\n" ++ e + Just r -> return r + +-- | 'Binary' instance for 'Refined' +-- +-- >>> import Data.Time +-- >>> import Control.Lens +-- >>> import Control.Arrow ((+++)) +-- >>> type K1 = Refined (ReadP Day >> 'True) String +-- >>> type K2 = Refined (ReadP Day >> Between (ReadP' Day "2019-03-30") (ReadP' Day "2019-06-01")) String +-- >>> type K3 = Refined (ReadP Day >> Between (ReadP' Day "2019-05-30") (ReadP' Day "2019-06-01")) String +-- >>> r = unsafeRefined' ol "2019-04-23" :: K1 +-- >>> removeAnsi $ (view _3 +++ view _3) $ B.decodeOrFail @K1 (B.encode r) +-- Refined {unRefined = "2019-04-23"} +-- +-- >>> removeAnsi $ (view _3 +++ view _3) $ B.decodeOrFail @K2 (B.encode r) +-- Refined {unRefined = "2019-04-23"} +-- +-- >>> removeAnsi $ (view _3 +++ view _3) $ B.decodeOrFail @K3 (B.encode r) +-- Refined:FalseP +-- False >> False | 2019-04-23 +-- | +-- +- P ReadP Day (2019-04-23) 2019-04-23 | 2019-04-23 +-- | | +-- | `- P Id "2019-04-23" +-- | +-- `- False False && True +-- | +-- +- False 2019-04-23 >= 2019-05-30 +-- | | +-- | +- P I +-- | | +-- | `- P ReadP Day (2019-05-30) 2019-05-30 | 2019-05-30 +-- | | +-- | `- P '2019-05-30 +-- | +-- `- True 2019-04-23 <= 2019-06-01 +-- | +-- +- P I +-- | +-- `- P ReadP Day (2019-06-01) 2019-06-01 | 2019-06-01 +-- | +-- `- P '2019-06-01 +-- <BLANKLINE> +-- +instance (RefinedC p a, Binary a) => Binary (Refined p a) where + get = do + fld0 <- B.get @a + let ((bp,e),mr) = runIdentity $ newRefined @p o2 fld0 + case mr of + Nothing -> fail $ "Refined:" ++ show bp ++ "\n" ++ e + Just r -> return r + put (Refined r) = B.put @a r + +-- | 'arbitrary' value for 'Refined' +arbRefined :: forall p a. + ( Arbitrary a + , RefinedC p a + ) => POpts -> Gen (Refined p a) +arbRefined opts = suchThatMap (arbitrary @a) (snd . runIdentity . newRefined @p opts) + +-- | binary operation applied to two 'RefinedT' values +rapply :: forall m p a . (RefinedC p a, Monad m) + => POpts + -> (a -> a -> a) + -> RefinedT m (Refined p a) + -> RefinedT m (Refined p a) + -> RefinedT m (Refined p a) +rapply opts f ma mb = do + tell [bgColor Blue "=== a ==="] + Refined x <- ma + tell [bgColor Blue "=== b ==="] + Refined y <- mb + tell [bgColor Blue "=== a `op` b ==="] + newRefinedT opts (f x y) + +-- | takes two values and lifts them into 'RefinedT' and then applies the binary operation +rapply0 :: forall p a m . (RefinedC p a, Monad m) + => POpts + -> (a -> a -> a) + -> a + -> a + -> RefinedT m (Refined p a) +rapply0 opts f a b = rapply opts f (newRefinedT opts a) (newRefinedT opts b) + +-- | same as 'rapply' except we already have valid 'Refined' values as input +rapply1 :: forall m p a . (RefinedC p a, Monad m) + => POpts + -> (a -> a -> a) + -> Refined p a + -> Refined p a + -> RefinedT m (Refined p a) +rapply1 opts f (Refined a) (Refined b) = newRefinedT opts (f a b) + +-- | attempts to lift a refinement type to another refinement type by way of transformation function +-- you can control both the predicate and the type +convertRefinedT :: forall m p p1 a a1 + . ( RefinedC p1 a1 + , Monad m) + => POpts + -> (a -> a1) + -> RefinedT m (Refined p a) + -> RefinedT m (Refined p1 a1) +convertRefinedT opts f ma = do + Refined a <- ma -- you already got a refined in there so no need to check RefinedC + newRefinedT @p1 opts (f a) + +-- | invokes the callback with the 'Refined' value if \'a\' is valid for the predicate \'p\' +withRefinedT :: forall p m a b + . (Monad m, RefinedC p a) + => POpts + -> a + -> (Refined p a -> RefinedT m b) + -> RefinedT m b +withRefinedT opts a k = newRefinedT @p opts a >>= k + +withRefinedTIO :: forall p m a b + . (MonadIO m, RefinedC p a) + => POpts + -> a + -> (Refined p a -> RefinedT m b) + -> RefinedT m b +withRefinedTIO opts a k = newRefinedTIO @p opts a >>= k + +-- | same as 'newRefined' but prints the results +prtRefinedIO :: forall p a + . RefinedC p a + => POpts + -> a + -> IO (Either BoolP (Refined p a)) +prtRefinedIO opts a = do + tt <- evalBool (Proxy @p) opts a + let msg = (_tBool tt ^. boolT2P, prtTreePure opts (fromTT tt)) + unless (oLite opts) $ putStrLn $ snd msg + pure $ case getValueLR opts "" tt [] of + Right True -> Right (Refined a) + _ -> Left (fst msg) + +-- | returns a 'Refined' value if \'a\' is valid for the predicate \'p\' +newRefined :: forall p a m . (MonadEval m, RefinedC p a) + => POpts + -> a + -> m ((BoolP, String), Maybe (Refined p a)) +newRefined opts a = do + tt <- evalBool (Proxy @p) opts a + let msg = (_tBool tt ^. boolT2P, prtTreePure opts (fromTT tt)) + pure $ (msg,) $ case getValueLR opts "" tt [] of + Right True -> Just (Refined a) + _ -> Nothing + +newRefinedTImpl :: forall p a n m . (RefinedC p a, Monad m, MonadEval n) + => (forall x . n x -> RefinedT m x) + -> POpts + -> a + -> RefinedT m (Refined p a) +newRefinedTImpl f opts a = do + tt <- f $ evalBool (Proxy @p) opts a + let msg = prtTreePure opts (fromTT tt) + tell [msg] + case getValueLR opts "" tt [] of + Right True -> return (Refined a) -- FalseP is also a failure! + _ -> let rc = show (_tBool tt ^. boolT2P) + in throwError rc -- RefinedT $ ExceptT $ WriterT $ return (Left rc, []) + +-- | returns a wrapper 'RefinedT' around a possible 'Refined' value if \'a\' is valid for the predicate \'p\' +newRefinedT :: forall p a m + . ( RefinedC p a + , Monad m) + => POpts + -> a + -> RefinedT m (Refined p a) +newRefinedT = newRefinedTImpl (return . runIdentity) + +newRefinedTIO :: forall p a m + . ( RefinedC p a + , MonadIO m) + => POpts + -> a + -> RefinedT m (Refined p a) +newRefinedTIO = newRefinedTImpl liftIO + +newtype RefinedT m a = RefinedT { unRefinedT :: ExceptT String (WriterT [String] m) a } + deriving (Functor, Applicative, Monad, MonadCont, MonadWriter [String], Show, MonadIO) + deriving MonadTrans via RefinedT + +instance Monad m => MonadError String (RefinedT m) where + throwError e = RefinedT $ ExceptT $ WriterT $ return (Left e,[]) + catchError (RefinedT (ExceptT (WriterT ma))) ema = + RefinedT $ ExceptT $ WriterT $ do + (lr,ss) <- ma + case lr of + Left e -> unRavelT (tell ss >> ema e) -- keep the old messages?? + Right _ -> ma + +unRavelT :: RefinedT m a -> m (Either String a, [String]) +unRavelT = runWriterT . runExceptT . unRefinedT + +unRavelTIO :: RefinedT IO a -> IO (Either String a, [String]) +unRavelTIO = runWriterT . runExceptT . unRefinedT + +unRavelTI :: RefinedT Identity a -> (Either String a, [String]) +unRavelTI = runIdentity . runWriterT . runExceptT . unRefinedT + +prtRefinedTImpl :: forall n m a . (MonadIO n, Show a) => (forall x . m x -> n x) -> RefinedT m a -> n () +prtRefinedTImpl f rt = do + (lr,ws) <- f $ unRavelT rt + liftIO $ do + forM_ (zip [1::Int ..] ws) $ \(_,y) -> unless (null y) $ putStrLn y + case lr of + Left e -> putStrLn $ "failure msg[" <> e <> "]" + Right a -> print a + +prtRefinedTIO :: (MonadIO m, Show a) => RefinedT m a -> m () +prtRefinedTIO = prtRefinedTImpl id + +prtRefinedT :: (MonadIO m, Show a) => RefinedT Identity a -> m () +prtRefinedT = prtRefinedTImpl (return . runIdentity) + +-- | a way to unsafely create a 'Refined' value +unsafeRefined :: forall p a . a -> Refined p a +unsafeRefined = Refined + +-- | a way to unsafely create a 'Refined' value but run the predicate +unsafeRefined' :: forall p a . RefinedC p a => POpts -> a -> Refined p a +unsafeRefined' opts a = + let tt = runIdentity $ evalBool (Proxy @p) opts a + in case getValueLR opts "" tt [] of + Right True -> Refined a + _ -> error $ prtTreePure opts (fromTT tt)
+ src/Predicate/Refined3.hs view
@@ -0,0 +1,814 @@+{-# OPTIONS -Wall #-} +{-# OPTIONS -Wcompat #-} +{-# OPTIONS -Wincomplete-record-updates #-} +{-# OPTIONS -Wincomplete-uni-patterns #-} +{-# OPTIONS -Wno-redundant-constraints #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE DeriveLift #-} +{- | + Refinement type allowing the external type to differ from the internal type + see 'Refined3' +-} +module Predicate.Refined3 ( + -- ** Refined3 + Refined3(r3In,r3Out) + , Refined3C + , RefinedEmulate + + -- ** display results + , prtEval3P + , prtEval3PIO + , prtEval3 + , prt3IO + , prt3 + , prt3Impl + , Msg3 (..) + , Results (..) + , RResults (..) + + -- ** evaluation methods + , eval3P + , eval3 + , eval3M + , eval3PX + , eval3X + + -- ** proxy methods + , mkProxy3 + , mkProxy3' + , mkProxy3P + , mkProxy3P' + , MkProxy3T + , MakeR3 + + -- ** create or combine Refined3 values + , withRefined3TIO + , withRefined3T + , withRefined3TP + , newRefined3T + , newRefined3TP + , newRefined3TPIO + , convertRefined3TP + , rapply3 + , rapply3P + + -- ** QuickCheck methods + , arbRefined3 + , arbRefined3With + + -- ** unsafe methods for creating Refined3 + , unsafeRefined3 + , unsafeRefined3' + ) where +import Predicate.Refined +import Predicate.Core +import Predicate.Util +import Data.Functor.Identity (Identity(..)) +import Data.Tree +import Data.Proxy +import Control.Monad.Except +import Control.Monad.Writer (tell) +import Data.Aeson +import qualified Language.Haskell.TH.Syntax as TH +import System.Console.Pretty +import Test.QuickCheck +import qualified GHC.Read as GR +import qualified Text.ParserCombinators.ReadPrec as PCR +import qualified Text.Read.Lex as RL +import qualified Data.Binary as B +import Data.Binary (Binary) +import Data.Maybe (fromMaybe) + +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> :set -XTypeOperators +-- >>> :set -XNoStarIsType +-- >>> :set -XOverloadedStrings +-- >>> :m + Predicate.Prelude + +-- | Refinement type that differentiates the input from output +-- +-- * __i__ is the input type +-- * __ip__ converts @i@ to @PP ip i@ which is the internal type +-- * __op__ validates that internal type using @PP op (PP ip i) ~ Bool@ +-- * __fmt__ outputs the internal type @PP fmt (PP ip i) ~ i@ +-- * __PP fmt (PP ip i)__ should be valid as input for Refined3 +-- +-- Setting __ip__ to @Id@ and __fmt__ to @Id@ makes it equivalent to 'Refined.Refined': see 'RefinedEmulate' +-- +-- Setting the input type __i__ to 'GHC.Base.String' resembles the corresponding Read/Show instances but with an additional predicate on the read value +-- +-- * __read__ a string into an internal type and store in 'r3In' +-- * __validate__ 'r3In' using the predicate __op__ +-- * __show__ 'r3In' and store that formatted result in 'r3Out' +-- +-- Although the most common scenario is String as input, you are free to choose any input type you like +-- +-- >>> prtEval3 @(ReadBase Int 16) @(Lt 255) @(Printf "%x" Id) ol "00fe" +-- Right (Refined3 {r3In = 254, r3Out = "fe"}) +-- +-- >>> prtEval3 @(ReadBase Int 16) @(Lt 253) @(Printf "%x" Id) ol "00fe" +-- Left Step 2. False Boolean Check(op) | FalseP +-- +-- >>> prtEval3 @(ReadBase Int 16) @(Lt 255) @(Printf "%x" Id) ol "00fg" +-- Left Step 1. Initial Conversion(ip) Failed | invalid base 16 +-- +-- >>> prtEval3 @(Map (ReadP Int) (Resplit "\\." Id)) @(Guard (Printf "found length=%d" Len) (Len >> Id == 4) >> 'True) @(Printfnt 4 "%03d.%03d.%03d.%03d") ol "198.162.3.1.5" +-- Left Step 2. Failed Boolean Check(op) | found length=5 +-- +-- >>> prtEval3 @(Map (ReadP Int) (Resplit "\\." Id)) @(Guard (Printf "found length=%d" Len) (Len >> Id == 4) >> 'True) @(Printfnt 4 "%03d.%03d.%03d.%03d") ol "198.162.3.1" +-- Right (Refined3 {r3In = [198,162,3,1], r3Out = "198.162.003.001"}) +-- +-- >>> :m + Data.Time.Calendar.WeekDate +-- >>> prtEval3 @(MkDay >> 'Just Id) @(Guard "expected a Sunday" (Thd Id == 7) >> 'True) @(UnMkDay (Fst Id)) ol (2019,10,13) +-- Right (Refined3 {r3In = (2019-10-13,41,7), r3Out = (2019,10,13)}) +-- +-- >>> prtEval3 @(MkDay' (Fst Id) (Snd Id) (Thd Id) >> 'Just Id) @(Guard "expected a Sunday" (Thd Id == 7) >> 'True) @(UnMkDay (Fst Id)) ol (2019,10,12) +-- Left Step 2. Failed Boolean Check(op) | expected a Sunday +-- +-- >>> type T4 k = '(MkDay >> 'Just Id, Guard "expected a Sunday" (Thd Id == 7) >> 'True, UnMkDay (Fst Id), k) +-- >>> prtEval3P (Proxy @(T4 _)) ol (2019,10,12) +-- Left Step 2. Failed Boolean Check(op) | expected a Sunday +-- +-- >>> prtEval3P (Proxy @(T4 _)) ol (2019,10,13) +-- Right (Refined3 {r3In = (2019-10-13,41,7), r3Out = (2019,10,13)}) +-- +data Refined3 ip op fmt i = Refined3 { r3In :: PP ip i, r3Out :: PP fmt (PP ip i) } + +-- | directly load values into 'Refined3'. It still checks to see that those values are valid +unsafeRefined3' :: forall ip op fmt i + . (Show i, Show (PP ip i), Refined3C ip op fmt i) + => POpts + -> i + -> Refined3 ip op fmt i +unsafeRefined3' opts i = + let (ret,mr) = eval3 @ip @op @fmt opts i + in fromMaybe (error $ show (prt3Impl opts ret)) mr + +-- | directly load values into 'Refined3' without any checking +unsafeRefined3 :: forall ip op fmt i . PP ip i -> PP fmt (PP ip i) -> Refined3 ip op fmt i +unsafeRefined3 = Refined3 + + +-- | Provides the constraints on Refined3 +type Refined3C ip op fmt i = + ( P ip i + , P op (PP ip i) + , PP op (PP ip i) ~ Bool -- the internal value needs to pass the predicate check + , P fmt (PP ip i) + , PP fmt (PP ip i) ~ i -- the output type must match the original input type + ) + +deriving instance (Show i, Show (PP ip i), Show (PP fmt (PP ip i))) => Show (Refined3 ip op fmt i) +deriving instance (Eq i, Eq (PP ip i), Eq (PP fmt (PP ip i))) => Eq (Refined3 ip op fmt i) +deriving instance (TH.Lift (PP ip i), TH.Lift (PP fmt (PP ip i))) => TH.Lift (Refined3 ip op fmt i) + +-- read instance from -ddump-deriv +-- | 'Read' instance for 'Refined3' +-- +-- >>> reads @(Refined3 (ReadBase Int 16) (Between 0 255) (ShowBase 16) String) "Refined3 {r3In = 254, r3Out = \"fe\"}" +-- [(Refined3 {r3In = 254, r3Out = "fe"},"")] +-- +-- >>> reads @(Refined3 (ReadBase Int 16) (Between 0 255) (ShowBase 16) String) "Refined3 {r3In = 300, r3Out = \"12c\"}" +-- [] +-- +-- >>> reads @(Refined3 (ReadBase Int 16) (Id < 0) (ShowBase 16) String) "Refined3 {r3In = -1234, r3Out = \"-4d2\"}" +-- [(Refined3 {r3In = -1234, r3Out = "-4d2"},"")] +-- +-- >>> reads @(Refined3 (Map (ReadP Int) (Resplit "\\." Id)) (Guard "len/=4" (Len == 4) >> 'True) (Printfnt 4 "%d.%d.%d.%d") String) "Refined3 {r3In = [192,168,0,1], r3Out = \"192.168.0.1\"}" +-- [(Refined3 {r3In = [192,168,0,1], r3Out = "192.168.0.1"},"")] +-- +instance ( Eq i + , Show i + , Show (PP ip i) + , Refined3C ip op fmt i + , Read (PP ip i) + , Read (PP fmt (PP ip i)) + ) => Read (Refined3 ip op fmt i) where + readPrec + = GR.parens + (PCR.prec + 11 + (do GR.expectP (RL.Ident "Refined3") + GR.expectP (RL.Punc "{") + fld1 <- GR.readField + "r3In" (PCR.reset GR.readPrec) + GR.expectP (RL.Punc ",") + fld2 <- GR.readField + "r3Out" (PCR.reset GR.readPrec) + GR.expectP (RL.Punc "}") + + let (_ret,mr) = runIdentity $ eval3MSkip @_ @ip @op @fmt o2 fld1 + case mr of + Nothing -> fail "" -- show (prt3Impl o2 _ret) + Just (Refined3 _r1 r2) | r2 == fld2 -> pure (Refined3 fld1 fld2) + | otherwise -> fail "" -- "mismatch on r3Out fmt: found (" ++ show fld2 ++ ") but expected(" ++ show r2 ++ ")" + )) + readList = GR.readListDefault + readListPrec = GR.readListPrecDefault + +-- | 'ToJSON' instance for 'Refined3' +-- +-- >>> encode (unsafeRefined3 @(ReadBase Int 16) @(Between 0 255) @(ShowBase 16) 254 "fe") +-- "\"fe\"" +-- +-- >>> encode (unsafeRefined3 @Id @'True @Id 123 123) +-- "123" +-- +instance ToJSON (PP fmt (PP ip i)) => ToJSON (Refined3 ip op fmt i) where + toJSON = toJSON . r3Out + + +-- | 'FromJSON' instance for 'Refined3' +-- +-- >>> eitherDecode' @(Refined3 (ReadBase Int 16) (Id > 10 && Id < 256) (ShowBase 16) String) "\"00fe\"" +-- Right (Refined3 {r3In = 254, r3Out = "fe"}) +-- +-- >>> removeAnsi $ eitherDecode' @(Refined3 (ReadBase Int 16) (Id > 10 && Id < 256) (ShowBase 16) String) "\"00fe443a\"" +-- Error in $: Refined3:Step 2. False Boolean Check(op) | FalseP +-- <BLANKLINE> +-- *** Step 1. Success Initial Conversion(ip) [16663610] *** +-- <BLANKLINE> +-- P ReadBase(Int,16) 16663610 | "00fe443a" +-- | +-- `- P Id "00fe443a" +-- <BLANKLINE> +-- *** Step 2. False Boolean Check(op) *** +-- <BLANKLINE> +-- False True && False +-- | +-- +- True 16663610 > 10 +-- | | +-- | +- P Id 16663610 +-- | | +-- | `- P '10 +-- | +-- `- False 16663610 < 256 +-- | +-- +- P Id 16663610 +-- | +-- `- P '256 +-- <BLANKLINE> +-- +instance (Show ( PP fmt (PP ip i)) + , Show (PP ip i) + , Refined3C ip op fmt i + , FromJSON i + ) => FromJSON (Refined3 ip op fmt i) where + parseJSON z = do + i <- parseJSON @i z + let (ret,mr) = eval3 @ip @op @fmt o2 i + case mr of + Nothing -> fail $ "Refined3:" ++ show (prt3Impl o2 ret) + Just r -> return r + +{- +instance (Arbitrary (PP ip i) + , Show (PP ip i) + , Show i + , Refined3C ip op fmt i + ) => Arbitrary (Refined3 ip op fmt i) where + arbitrary = suchThatMap (arbitrary @(PP ip i)) $ eval3MQuickIdentity @ip @op @fmt o2 +-} +arbRefined3 :: forall ip op fmt i . + ( Arbitrary (PP ip i) + , Refined3C ip op fmt i + ) => Proxy '(ip,op,fmt,i) + -> POpts + -> Gen (Refined3 ip op fmt i) +arbRefined3 _ = suchThatMap (arbitrary @(PP ip i)) . eval3MQuickIdentity @ip @op @fmt + +-- help things along a little +arbRefined3With :: + forall ip op fmt i + . (Arbitrary (PP ip i) + , Refined3C ip op fmt i) + => Proxy '(ip,op,fmt,i) + -> POpts + -> (PP ip i -> PP ip i) + -> Gen (Refined3 ip op fmt i) +arbRefined3With _ opts f = + suchThatMap (f <$> arbitrary @(PP ip i)) $ eval3MQuickIdentity @ip @op @fmt opts + +-- | 'Binary' instance for 'Refined3' +-- +-- >>> import Control.Arrow ((+++)) +-- >>> import Control.Lens +-- >>> import Data.Time +-- >>> type K1 = MakeR3 '(ReadP Day, 'True, ShowP Id, String) +-- >>> type K2 = MakeR3 '(ReadP Day, Between (ReadP' Day "2019-03-30") (ReadP' Day "2019-06-01"), ShowP Id, String) +-- >>> type K3 = MakeR3 '(ReadP Day, Between (ReadP' Day "2019-05-30") (ReadP' Day "2019-06-01"), ShowP Id, String) +-- >>> r = unsafeRefined3' ol "2019-04-23" :: K1 +-- >>> removeAnsi $ (view _3 +++ view _3) $ B.decodeOrFail @K1 (B.encode r) +-- Refined3 {r3In = 2019-04-23, r3Out = "2019-04-23"} +-- +-- >>> removeAnsi $ (view _3 +++ view _3) $ B.decodeOrFail @K2 (B.encode r) +-- Refined3 {r3In = 2019-04-23, r3Out = "2019-04-23"} +-- +-- >>> removeAnsi $ (view _3 +++ view _3) $ B.decodeOrFail @K3 (B.encode r) +-- Refined3:Step 2. False Boolean Check(op) | FalseP +-- <BLANKLINE> +-- *** Step 1. Success Initial Conversion(ip) [2019-04-23] *** +-- <BLANKLINE> +-- P ReadP Day (2019-04-23) 2019-04-23 | 2019-04-23 +-- | +-- `- P Id "2019-04-23" +-- <BLANKLINE> +-- *** Step 2. False Boolean Check(op) *** +-- <BLANKLINE> +-- False False && True +-- | +-- +- False 2019-04-23 >= 2019-05-30 +-- | | +-- | +- P I +-- | | +-- | `- P ReadP Day (2019-05-30) 2019-05-30 | 2019-05-30 +-- | | +-- | `- P '2019-05-30 +-- | +-- `- True 2019-04-23 <= 2019-06-01 +-- | +-- +- P I +-- | +-- `- P ReadP Day (2019-06-01) 2019-06-01 | 2019-06-01 +-- | +-- `- P '2019-06-01 +-- <BLANKLINE> +-- +instance ( Show (PP fmt (PP ip i)) + , Show (PP ip i) + , Refined3C ip op fmt i + , Binary i + ) => Binary (Refined3 ip op fmt i) where + get = do + i <- B.get @i + let (ret,mr) = eval3 @ip @op @fmt o2 i + case mr of + Nothing -> fail $ "Refined3:" ++ show (prt3Impl o2 ret) + Just r -> return r + put (Refined3 _ r) = B.put @i r + +-- | wraps the parameters for 'Refined3' in a 4-tuple +-- +-- useful for methods such as 'withRefined3TP' and 'newRefined3TP' +mkProxy3 :: forall ip op fmt i . Proxy '(ip,op,fmt,i) +mkProxy3 = Proxy + +-- | same as 'mkProxy3' but checks to make sure the proxy is consistent with the Refined3C constraint +mkProxy3' :: forall ip op fmt i . Refined3C ip op fmt i => Proxy '(ip,op,fmt,i) +mkProxy3' = Proxy + +-- | use type application to set the parameters which then will be wrapped into a 4-tuple +-- +-- useful for passing into 'eval3P' / 'prtEval3P' +mkProxy3P :: forall z ip op fmt i . z ~ '(ip,op,fmt,i) => Proxy '(ip,op,fmt,i) +mkProxy3P = Proxy + +-- | same as 'mkProxy3P' but checks to make sure the proxy is consistent with the Refined3C constraint +mkProxy3P' :: forall z ip op fmt i . (z ~ '(ip,op,fmt,i), Refined3C ip op fmt i) => Proxy '(ip,op,fmt,i) +mkProxy3P' = Proxy + +-- | convenience type family for converting from a 4-tuple '(ip,op,fmt,i) to a 'Refined3' signature +type family MakeR3 p where + MakeR3 '(ip,op,fmt,i) = Refined3 ip op fmt i + +-- | convenience type family for converting from a 4-tuple '(ip,op,fmt,i) to a Proxy +type family MkProxy3T p where + MkProxy3T '(ip,op,fmt,i) = Proxy '(ip,op,fmt,i) + +withRefined3TIO :: forall ip op fmt i m b + . (MonadIO m, Refined3C ip op fmt i, Show (PP ip i), Show i) + => POpts + -> i + -> (Refined3 ip op fmt i -> RefinedT m b) + -> RefinedT m b +withRefined3TIO opts = (>>=) . newRefined3TPIO (Proxy @'(ip,op,fmt,i)) opts + +-- | create a 'Refined3' value and pass it to a continuation to be processed +-- +-- This first example reads a hex string and makes sure it is between 100 and 200 and then +-- reads a binary string and adds the values together +-- +-- >>> :set -XPolyKinds +-- >>> type Base n p = '(ReadBase Int n, p, ShowBase 16, String) +-- >>> base16 = Proxy @(Base 16 (Between 100 200)) +-- >>> base2 = Proxy @(Base 2 'True) +-- >>> prtRefinedTIO $ withRefined3TP base16 ol "a3" $ \x -> withRefined3TP base2 ol "1001110111" $ \y -> pure (r3In x + r3In y) +-- 794 +-- +-- this example fails as the the hex value is out of range +-- +-- >>> prtRefinedTIO $ withRefined3TP base16 o0 "a388" $ \x -> withRefined3TP base2 o0 "1001110111" $ \y -> pure (x,y) +-- <BLANKLINE> +-- *** Step 1. Success Initial Conversion(ip) [41864] *** +-- <BLANKLINE> +-- P ReadBase(Int,16) 41864 | "a388" +-- | +-- `- P Id "a388" +-- <BLANKLINE> +-- *** Step 2. False Boolean Check(op) *** +-- <BLANKLINE> +-- False True && False +-- | +-- +- True 41864 >= 100 +-- | | +-- | +- P I +-- | | +-- | `- P '100 +-- | +-- `- False 41864 <= 200 +-- | +-- +- P I +-- | +-- `- P '200 +-- <BLANKLINE> +-- failure msg[Step 2. False Boolean Check(op) | FalseP] +-- +withRefined3T :: forall ip op fmt i m b + . (Monad m, Refined3C ip op fmt i, Show (PP ip i), Show i) + => POpts + -> i + -> (Refined3 ip op fmt i -> RefinedT m b) + -> RefinedT m b +withRefined3T opts = (>>=) . newRefined3TP (Proxy @'(ip,op,fmt,i)) opts + +withRefined3TP :: forall m ip op fmt i b proxy + . (Monad m, Refined3C ip op fmt i, Show (PP ip i), Show i) + => proxy '(ip,op,fmt,i) + -> POpts + -> i + -> (Refined3 ip op fmt i -> RefinedT m b) + -> RefinedT m b +withRefined3TP p opts = (>>=) . newRefined3TP p opts + +newRefined3T :: forall m ip op fmt i . (Refined3C ip op fmt i, Monad m, Show (PP ip i), Show i) + => POpts + -> i + -> RefinedT m (Refined3 ip op fmt i) +newRefined3T = newRefined3TP (Proxy @'(ip,op,fmt,i)) + +-- | create a wrapped 'Refined3' type +-- +-- >>> prtRefinedTIO $ newRefined3TP (Proxy @'(MkDay >> JustFail "asfd" Id, GuardSimple (Thd Id == 5) >> 'True, UnMkDay (Fst Id), (Int,Int,Int))) ol (2019,11,1) +-- Refined3 {r3In = (2019-11-01,44,5), r3Out = (2019,11,1)} +-- +newRefined3TP :: forall m ip op fmt i proxy + . (Refined3C ip op fmt i, Monad m, Show (PP ip i), Show i) + => proxy '(ip,op,fmt,i) + -> POpts + -> i + -> RefinedT m (Refined3 ip op fmt i) +newRefined3TP = newRefined3TPImpl (return . runIdentity) + +newRefined3TPIO :: forall m ip op fmt i proxy + . (Refined3C ip op fmt i + , MonadIO m + , Show (PP ip i) + , Show i) + => proxy '(ip,op,fmt,i) + -> POpts + -> i + -> RefinedT m (Refined3 ip op fmt i) +newRefined3TPIO = newRefined3TPImpl liftIO + +-- we call this cos we need to do the bool check and get fmt value +-- eval (PP op i) ~ True and eval (PP fmt i) to get the other value +-- input is set to @Id meaning that PP fmt (PP ip i) /= i doesnt hold +newRefined3TPImpl :: forall n m ip op fmt i proxy + . (Refined3C ip op fmt i + , Monad m + , MonadEval n + , Show (PP ip i) + , Show (PP fmt (PP ip i))) + => (forall x . n x -> RefinedT m x) + -> proxy '(ip,op,fmt,i) + -> POpts + -> i + -> RefinedT m (Refined3 ip op fmt i) +newRefined3TPImpl f _ opts i = do + (ret,mr) <- f $ eval3M opts i + let m3 = prt3Impl opts ret + tell [m3Long m3] + case mr of + Nothing -> throwError $ m3Desc m3 <> " | " <> m3Short m3 + Just r -> return r + +newRefined3TPSkipIPImpl :: forall n m ip op fmt i proxy + . (Refined3C ip op fmt i + , Monad m + , MonadEval n + , Show (PP ip i) + , Show (PP fmt (PP ip i))) + => (forall x . n x -> RefinedT m x) + -> proxy '(ip,op,fmt,i) + -> POpts + -> PP ip i + -> RefinedT m (Refined3 ip op fmt i) +newRefined3TPSkipIPImpl f _ opts a = do + (ret,mr) <- f $ eval3MSkip opts a + let m3 = prt3Impl opts ret + tell [m3Long m3] + case mr of + Nothing -> throwError $ m3Desc m3 <> " | " <> m3Short m3 + Just r -> return r + +-- | attempts to cast a wrapped 'Refined3' to another 'Refined3' with different predicates +convertRefined3TP :: forall m ip op fmt i ip1 op1 fmt1 i1 . + ( Refined3C ip1 op1 fmt1 i1 + , Monad m + , Show (PP ip i) + , PP ip i ~ PP ip1 i1 + , Show i1) + => Proxy '(ip, op, fmt, i) + -> Proxy '(ip1, op1, fmt1, i1) + -> POpts + -> RefinedT m (Refined3 ip op fmt i) + -> RefinedT m (Refined3 ip1 op1 fmt1 i1) +convertRefined3TP _ _ opts ma = do + Refined3 x _ <- ma + -- we skip the input value @Id and go straight to the internal value so PP fmt (PP ip i) /= i for this call + Refined3 a b <- newRefined3TPSkipIPImpl (return . runIdentity) (Proxy @'(ip1, op1, fmt1, i1)) opts x + return (Refined3 a b) + +-- | applies a binary operation to two wrapped 'Refined3' parameters +rapply3 :: forall m ip op fmt i . + ( Refined3C ip op fmt i + , Monad m + , Show (PP ip i) + , Show i) + => POpts + -> (PP ip i -> PP ip i -> PP ip i) + -> RefinedT m (Refined3 ip op fmt i) + -> RefinedT m (Refined3 ip op fmt i) + -> RefinedT m (Refined3 ip op fmt i) +rapply3 = rapply3P (Proxy @'(ip,op,fmt,i)) + +-- this is the most generic +-- prtRefinedT $ rapply3P base16 (+) (newRefined3TP Proxy "ff") (newRefined3TP Proxy "22") + +-- | same as 'rapply3' but uses a 4-tuple proxy instead +rapply3P :: forall m ip op fmt i proxy . + ( Refined3C ip op fmt i + , Monad m + , Show (PP ip i) + , Show i) + => proxy '(ip,op,fmt,i) + -> POpts + -> (PP ip i -> PP ip i -> PP ip i) + -> RefinedT m (Refined3 ip op fmt i) + -> RefinedT m (Refined3 ip op fmt i) + -> RefinedT m (Refined3 ip op fmt i) +rapply3P p opts f ma mb = do + tell [bgColor Blue "=== a ==="] + Refined3 x _ <- ma + tell [bgColor Blue "=== b ==="] + Refined3 y _ <- mb + -- we skip the input value @Id and go straight to the internal value so PP fmt (PP ip i) /= i for this call + tell [bgColor Blue "=== a `op` b ==="] + Refined3 a b <- newRefined3TPSkipIPImpl (return . runIdentity) p opts (f x y) + return (Refined3 a b) + +data Results a b = + XF String -- Left e + | XTF a String -- Right a + Left e + | XTFalse a -- Right a + Right False + | XTTrueF a String -- Right a + Right True + Left e + | XTTrueT a b -- Right a + Right True + Right b + deriving (Show,Eq) + +data RResults a b = + RF String (Tree PE) -- Left e + | RTF a (Tree PE) String (Tree PE) -- Right a + Left e + | RTFalse a (Tree PE) (Tree PE) -- Right a + Right False + | RTTrueF a (Tree PE) (Tree PE) String (Tree PE) -- Right a + Right True + Left e + | RTTrueT a (Tree PE) (Tree PE) b (Tree PE) -- Right a + Right True + Right b + deriving Show + +prtEval3PIO :: forall ip op fmt i proxy + . ( Refined3C ip op fmt i + , Show (PP ip i) + , Show i) + => proxy '(ip,op,fmt,i) + -> POpts + -> i + -> IO (Either String (Refined3 ip op fmt i)) +prtEval3PIO _ opts i = do + x <- eval3M opts i + prt3IO opts x + +prtEval3 :: forall ip op fmt i + . ( Refined3C ip op fmt i + , Show (PP ip i) + , Show i) + => POpts + -> i + -> Either Msg3 (Refined3 ip op fmt i) +prtEval3 opts i = + let x = eval3 opts i + in prt3 opts x + +prtEval3P :: forall ip op fmt i proxy + . ( Refined3C ip op fmt i + , Show (PP ip i) + , Show i) + => proxy '(ip,op,fmt,i) + -> POpts + -> i + -> Either Msg3 (Refined3 ip op fmt i) +prtEval3P _ opts i = + let x = eval3 opts i + in prt3 opts x + + +-- pass in a proxy (use mkProxy to package all the types together as a 4-tuple) +-- ip converts input 'i' to format used for op and fmt +-- op is a boolean predicate [has to be True to continue] (uses P ip i as input) +-- fmt formats the output (can be anything ie not just String) (uses P ip i as input) +eval3P :: forall ip op fmt i proxy . Refined3C ip op fmt i + => proxy '(ip,op,fmt,i) + -> POpts + -> i + -> (RResults (PP ip i) (PP fmt (PP ip i)), Maybe (Refined3 ip op fmt i)) +eval3P _ opts = runIdentity . eval3M opts + +-- same as eval3P but can just pass in ip op fmt separately +-- with eval3P we have to specify 'i' but in eval3 we dont cos gets it from context +eval3 :: forall ip op fmt i . Refined3C ip op fmt i + => POpts + -> i + -> (RResults (PP ip i) (PP fmt (PP ip i)), Maybe (Refined3 ip op fmt i)) +eval3 opts = runIdentity . eval3M opts + +eval3M :: forall m ip op fmt i . (MonadEval m, Refined3C ip op fmt i) + => POpts + -> i + -> m (RResults (PP ip i) (PP fmt (PP ip i)), Maybe (Refined3 ip op fmt i)) +eval3M opts i = do + ll@(fromTT -> t1) <- eval (Proxy @ip) opts i + case getValLR (_tBool ll) of + Right a -> do + rr@(fromTT -> t2) <- evalBool (Proxy @op) opts a + case getValLR (_tBool rr) of + Right True -> do + ss@(fromTT -> t3) <- eval (Proxy @fmt) opts a + pure $ case getValLR (_tBool ss) of + Right b -> (RTTrueT a t1 t2 b t3, Just (Refined3 a b)) + Left e -> (RTTrueF a t1 t2 e t3, Nothing) + Right False -> pure (RTFalse a t1 t2, Nothing) + Left e -> pure (RTF a t1 e t2, Nothing) + Left e -> pure (RF e t1, Nothing) + +-- skip ip conversion: ie uses internal value +eval3MSkip :: forall m ip op fmt i . (MonadEval m, Refined3C ip op fmt i) + => POpts + -> PP ip i + -> m (RResults (PP ip i) (PP fmt (PP ip i)), Maybe (Refined3 ip op fmt i)) +eval3MSkip opts a = do + rr@(fromTT -> t2) <- evalBool (Proxy @op) opts a + case getValLR (_tBool rr) of + Right True -> do + ss@(fromTT -> t3) <- eval (Proxy @fmt) opts a + pure $ case getValLR (_tBool ss) of + Right b -> (RTTrueT a mkNodeSkipP t2 b t3, Just (Refined3 a b)) + Left e -> (RTTrueF a mkNodeSkipP t2 e t3, Nothing) + Right False -> pure (RTFalse a mkNodeSkipP t2, Nothing) + Left e -> pure (RTF a mkNodeSkipP e t2, Nothing) + +-- calculates from internal value +eval3MQuickIdentity :: forall ip op fmt i . Refined3C ip op fmt i + => POpts + -> PP ip i + -> Maybe (Refined3 ip op fmt i) +eval3MQuickIdentity opts = runIdentity . eval3MQuick opts + +-- from PP ip i +eval3MQuick :: forall m ip op fmt i . (MonadEval m, Refined3C ip op fmt i) + => POpts + -> PP ip i + -> m (Maybe (Refined3 ip op fmt i)) +eval3MQuick opts a = do + rr <- evalBool (Proxy @op) opts a + case getValLR (_tBool rr) of + Right True -> do + ss <- eval (Proxy @fmt) opts a + pure $ case getValLR (_tBool ss) of + Right b -> Just (Refined3 a b) + _ -> Nothing + _ -> pure Nothing + +prt3IO :: (Show a, Show b) => POpts -> (RResults a b, Maybe r) -> IO (Either String r) +prt3IO opts (ret,mr) = do + let m3 = prt3Impl opts ret + unless (oLite opts) $ putStrLn $ m3Long m3 + return $ maybe (Left (m3Desc m3 <> " | " <> m3Short m3)) Right mr + +prt3 :: (Show a, Show b) => POpts -> (RResults a b, Maybe r) -> Either Msg3 r +prt3 opts (ret,mr) = maybe (Left $ prt3Impl opts ret) Right mr + +data Msg3 = Msg3 { m3Desc :: String, m3Short :: String, m3Long :: String } deriving Eq +instance Show Msg3 where + show (Msg3 a b c) = a <> " | " <> b <> (if null c then "" else "\n" <> c) + +prt3Impl :: (Show a, Show b) + => POpts + -> RResults a b + -> Msg3 +prt3Impl opts v = + let outmsg msg = "\n*** " <> msg <> " ***\n\n" + msg1 a = outmsg ("Step 1. Success Initial Conversion(ip) [" ++ show a ++ "]") + mkMsg3 m n r | oLite opts = Msg3 m n "" + | otherwise = Msg3 m n r + in case v of + RF e t1 -> + let (m,n) = ("Step 1. Initial Conversion(ip) Failed", e) + r = outmsg m + <> prtTreePure opts t1 + in mkMsg3 m n r + RTF a t1 e t2 -> + let (m,n) = ("Step 2. Failed Boolean Check(op)", e) + r = msg1 a + <> fixLite opts a t1 + <> outmsg m + <> prtTreePure opts t2 + in mkMsg3 m n r + RTFalse a t1 t2 -> + let (m,n) = ("Step 2. False Boolean Check(op)", "FalseP") + r = msg1 a + <> fixLite opts a t1 + <> outmsg m + <> prtTreePure opts t2 + in mkMsg3 m n r + RTTrueF a t1 t2 e t3 -> + let (m,n) = ("Step 3. Failed Output Conversion(fmt)", e) + r = msg1 a + <> fixLite opts a t1 + <> outmsg "Step 2. Success Boolean Check(op)" + <> prtTreePure opts t2 + <> outmsg m + <> prtTreePure opts t3 + in mkMsg3 m n r + RTTrueT a t1 t2 b t3 -> + let (m,n) = ("Step 3. Success Output Conversion(fmt)", show b) + r = msg1 a + <> fixLite opts a t1 + <> outmsg "Step 2. Success Boolean Check(op)" + <> prtTreePure opts t2 + <> outmsg m + <> fixLite opts b t3 + in mkMsg3 m n r + + +-- | emulates 'Refined3' but uses 'Refined.Refined' +-- reuses the mkProxy3 but returns Refined vs Refined3 +-- using plain Refined to emulate Refined3 sort of +-- we just output fmt instead of embedding it in Refined3 +-- so \'ip\' predicate gets us started: we store that \'PP ip i\' in Refined +-- then we run the boolean predicate \'op\' which is successful if true +-- then we run \'fmt\' against '\PP ip i\' and output both the Refined (PP p i) and the PP fmt (PP (ip i)) ie \'fmt\' run against PP ip i +-- if any of the three steps fails the process stops immediately and dumps out RResults +eval3PX :: forall ip op fmt i proxy . Refined3C ip op fmt i + => proxy '(ip,op,fmt,i) + -> POpts + -> i + -> (RResults (PP ip i) (PP fmt (PP ip i)), Maybe (Refined op (PP ip i), PP fmt (PP ip i))) +eval3PX _ = eval3X @ip @op @fmt + +eval3X :: forall ip op fmt i . Refined3C ip op fmt i + => POpts + -> i + -> (RResults (PP ip i) (PP fmt (PP ip i)), Maybe (Refined op (PP ip i), PP fmt (PP ip i))) +eval3X opts i = runIdentity $ do + ll@(fromTT -> t1) <- eval (Proxy @ip) opts i + case getValLR (_tBool ll) of + Right a -> do + rr@(fromTT -> t2) <- evalBool (Proxy @op) opts a + case getValLR (_tBool rr) of + Right True -> do + ss@(fromTT -> t3) <- eval (Proxy @fmt) opts a + pure $ case getValLR (_tBool ss) of + Right b -> (RTTrueT a t1 t2 b t3, Just (unsafeRefined a, b)) + Left e -> (RTTrueF a t1 t2 e t3, Nothing) + Right False -> pure (RTFalse a t1 t2, Nothing) + Left e -> pure (RTF a t1 e t2, Nothing) + Left e -> pure (RF e t1, Nothing) + +-- | emulates 'Refined.Refined' using 'Refined3' ie the input conversion and output formatting are noops +type RefinedEmulate p a = Refined3 Id p Id a
+ src/Predicate/Refined3Helper.hs view
@@ -0,0 +1,451 @@+{-# OPTIONS -Wall #-} +{-# OPTIONS -Wcompat #-} +{-# OPTIONS -Wincomplete-record-updates #-} +{-# OPTIONS -Wincomplete-uni-patterns #-} +{-# OPTIONS -Wredundant-constraints #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE TypeApplications #-} +{- | + Contains prepackaged 4-tuples to use with 'Refined3' +-} +module Predicate.Refined3Helper ( + -- ** date time checkers + datetime1 + , DateTime1 + , hms + , Hms + , HmsRE + , Hmsip + , Hmsop + , Hmsfmt + , DateFmts + , DateN + , DateTimeFmts + , DateTimeN + , daten + , datetimen + + -- ** credit cards + , ccn + , cc11 + , Ccn + , CC11 + , LuhnR + , LuhnT + + -- ** ssn + , ssn + , Ssn + + -- ** ipv4 + , ip + , Ip + , OctetRE + , Ip4StrictRE + + -- ** base n + , basen + , base16 + , basen' + , BaseN + , BaseN' + , BaseIJ + , BaseIJ' + + -- ** read / show + , readshow + , ReadShow + , ReadShowR + , readshow' + , ReadShow' + , ReadShowR' + + -- ** between + , between + , BetweenR + , BetweenN + + -- ** miscellaneous + , ok + , Ok + , OkR + , oknot + , OkNot + , OkNotR + ) where +import Predicate.Refined3 +import Predicate.Core +import Predicate.Prelude +import Predicate.Util +import Data.Proxy +import GHC.TypeLits (AppendSymbol,Nat) +import Data.Kind (Type) +import Data.Time + +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> :set -XTypeOperators +-- >>> :set -XNoStarIsType + +-- | credit card with luhn algorithm +-- +-- >>> prtEval3P cc11 ol "1234-5678-901" +-- Left Step 2. False Boolean Check(op) | FalseP +-- +-- >>> prtEval3P cc11 ol "1234-5678-903" +-- Right (Refined3 {r3In = [1,2,3,4,5,6,7,8,9,0,3], r3Out = "1234-5678-903"}) +-- +-- >>> pl @(Ccip >> Ccop 11) "79927398713" +-- True +-- TrueT +-- +-- >>> pl @(Ccip >> Ccop 10) "79927398713" +-- Error expected 10 digits but found 11 +-- FailT "expected 10 digits but found 11" +-- +type Ccip = Map (ReadP Int) (Ones (Remove "-" Id)) +type Ccop (n :: Nat) = Guard ('(n,Len) >> Printf2 "expected %d digits but found %d") (Len >> Same n) >> Luhn Id +type Ccfmt (ns :: [Nat]) = ConcatMap (ShowP Id) Id >> SplitAts ns Id >> Concat (Intercalate '["-"] Id) + +type Ccn (ns :: [Nat]) = '(Ccip, Ccop (SumT ns), Ccfmt ns, String) + +type CC11 = Ccn '[4,4,3] + +-- not great for the general case: but specific case is easier +ccn :: Proxy (Ccn ns) +ccn = mkProxy3 + +cc11 :: Proxy (Ccn '[4,4,3]) -- or Proxy CC11 +cc11 = mkProxy3P + +-- | read in a valid datetime +-- +-- >>> prtEval3P (datetime1 @LocalTime) ol "2018-09-14 02:57:04" +-- Right (Refined3 {r3In = 2018-09-14 02:57:04, r3Out = "2018-09-14 02:57:04"}) +-- +-- >>> prtEval3P (datetime1 @LocalTime) ol "2018-09-14 99:98:97" +-- Left Step 2. Failed Boolean Check(op) | hours invalid: found 99 +-- +-- >>> prtEval3P (datetime1 @LocalTime) ol "2018-09-14 23:01:97" +-- Left Step 2. Failed Boolean Check(op) | seconds invalid: found 97 +-- +-- >>> prtEval3P (Proxy @(DateTime1 UTCTime)) ol "2018-09-14 99:98:97" +-- Right (Refined3 {r3In = 2018-09-18 04:39:37 UTC, r3Out = "2018-09-18 04:39:37"}) +-- +datetime1 :: Proxy (DateTime1 t) +datetime1 = mkProxy3P + +type DateTime1 (t :: Type) = '(Dtip t, Dtop, Dtfmt, String) +type Dtip t = ParseTimeP t "%F %T" Id + +-- extra check to validate the time as parseTime doesnt validate the time component +-- ZonedTime LocalTime and TimeOfDay don't do validation and allow invalid stuff through : eg 99:98:97 is valid +-- UTCTime will do the same but any overages get tacked on to the day and time as necessary: makes the time valid! 99:98:97 becomes 04:39:37 +-- 2018-09-14 99:00:96 becomes 2018-09-18 03:01:36 +{- +type Dtop' = + Map (ReadP Int) (FormatTimeP "%H %M %S" Id >> Resplit "\\s+" Id) + >> Guards '[ '(Printf2 "guard %d invalid hours %d", Between 0 23) + , '(Printf2 "guard %d invalid minutes %d", Between 0 59) + , '(Printf2 "guard %d invalid seconds %d", Between 0 59) + ] >> 'True +-} +type Dtop = + Map (ReadP Int) (FormatTimeP "%H %M %S" Id >> Resplit "\\s+" Id) + >> GuardsDetail "%s invalid: found %d" + '[ '("hours", Between 0 23) + , '("minutes",Between 0 59) + , '("seconds",Between 0 59) + ] >> 'True + +type Dtfmt = FormatTimeP "%F %T" Id + +ssn :: Proxy Ssn +ssn = mkProxy3 + +-- | read in an ssn +-- +-- >>> prtEval3P ssn ol "134-01-2211" +-- Right (Refined3 {r3In = [134,1,2211], r3Out = "134-01-2211"}) +-- +-- >>> prtEval3P ssn ol "666-01-2211" +-- Left Step 2. Failed Boolean Check(op) | number for group 1 invalid: found 666 +-- +-- >>> prtEval3P ssn ol "666-01-2211" +-- Left Step 2. Failed Boolean Check(op) | number for group 1 invalid: found 666 +-- +-- >>> prtEval3P ssn ol "667-00-2211" +-- Left Step 2. Failed Boolean Check(op) | number for group 2 invalid: found 0 +-- +-- >>> prtEval3P ssn ol "666-01-2211" +-- Left Step 2. Failed Boolean Check(op) | number for group 1 invalid: found 666 +-- +-- >>> prtEval3P ssn ol "991-22-9999" +-- Left Step 2. Failed Boolean Check(op) | number for group 1 invalid: found 991 +-- +type Ssn = '(Ssnip, Ssnop, Ssnfmt, String) + +type Ssnip = Map (ReadP Int) (Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" Id >> Snd OneP) +type Ssnop = GuardsQuick (Printf2 "number for group %d invalid: found %d") + '[Between 1 899 && Id /= 666, Between 1 99, Between 1 9999] + >> 'True +{- +type Ssnop' = GuardsDetail "%s invalid: found %d" + '[ '("first", Between 1 899 && Id /= 666) + , '("second", Between 1 99) + , '("third" , Between 1 9999) + ] >> 'True +-} +type Ssnfmt = Printfnt 3 "%03d-%02d-%04d" + +-- | read in a time and validate it +-- +-- >>> prtEval3P hms ol "23:13:59" +-- Right (Refined3 {r3In = [23,13,59], r3Out = "23:13:59"}) +-- +-- >>> prtEval3P hms ol "23:13:60" +-- Left Step 2. Failed Boolean Check(op) | seconds invalid: found 60 +-- +-- >>> prtEval3P hms ol "26:13:59" +-- Left Step 2. Failed Boolean Check(op) | hours invalid: found 26 +-- +hms :: Proxy Hms +hms = mkProxy3 + +type Hms = '(Hmsip, Hmsop >> 'True, Hmsfmt, String) + +type Hmsip = Map (ReadP Int) (Resplit ":" Id) + +type Hmsop = GuardsDetail "%s invalid: found %d" '[ '("hours", Between 0 23),'("minutes",Between 0 59),'("seconds",Between 0 59)] +{- +type Hmsop = Guard (Printf "expected len 3 but found %d" Len) (Length Id == 3) + >> Guards '[ '(Printf2 "guard(%d) %d hours is out of range", Between 0 23) + , '(Printf2 "guard(%d) %d mins is out of range", Between 0 59) + , '(Printf2 "guard(%d) %d secs is out of range", Between 0 59)] +-} +type Hmsfmt = Printfnt 3 "%02d:%02d:%02d" + +-- | read in an ipv4 address and validate it +-- +-- >>> prtEval3P ip ol "001.223.14.1" +-- Right (Refined3 {r3In = [1,223,14,1], r3Out = "001.223.014.001"}) +-- +-- >>> prtEval3P ip ol "001.223.14.999" +-- Left Step 2. Failed Boolean Check(op) | guard(4) octet out of range 0-255 found 999 +-- +-- >>> prtEval3P ip ol "001.223.14.999.1" +-- Left Step 1. Initial Conversion(ip) Failed | Regex no results +-- +-- >>> prtEval3P ip ol "001.257.14.1" +-- Left Step 2. Failed Boolean Check(op) | guard(2) octet out of range 0-255 found 257 +-- +type Ip = '(Ipip, Ipop, Ipfmt, String) + +ip :: Proxy Ip +ip = mkProxy3 + +type Ipip = Map (ReadP Int) (Rescan "^(\\d{1,3}).(\\d{1,3}).(\\d{1,3}).(\\d{1,3})$" Id >> OneP >> Snd Id) +-- RepeatT is a type family so it expands everything! replace RepeatT with a type class +type Ipop = GuardsN (Printf2 "guard(%d) octet out of range 0-255 found %d") 4 (Between 0 255) >> 'True +type Ipfmt = Printfnt 4 "%03d.%03d.%03d.%03d" + +type HmsRE = "^([0-1][0-9]|2[0-3]):([0-5][0-9]):([0-5][0-9])$" -- strict validation should only be done in 'op' not 'ip' + +type OctetRE = "(25[0-5]|2[0..4][0-9]|1[0-9][0-9]|[1-9][0-9]|[0-9])" -- no padded numbers allowed +--type Ip4StrictRE = "^" `AppendSymbol` OctetRE `AppendSymbol` "\\." `AppendSymbol` OctetRE `AppendSymbol` "\\." `AppendSymbol` OctetRE `AppendSymbol` "\\." `AppendSymbol` OctetRE `AppendSymbol` "$" +type Ip4StrictRE = "^" `AppendSymbol` IntersperseT "\\." (RepeatT 4 OctetRE) `AppendSymbol` "$" + +-- valid dates for for DateFmts are "2001-01-01" "Jan 24 2009" and "03/29/07" +type DateFmts = '["%Y-%m-%d", "%m/%d/%y", "%B %d %Y"] +type DateN = '(ParseTimes Day DateFmts Id, 'True, FormatTimeP "%Y-%m-%d" Id, String) + +type DateTimeFmts = '["%Y-%m-%d %H:%M:%S", "%m/%d/%y %H:%M:%S", "%B %d %Y %H:%M:%S", "%Y-%m-%dT%H:%M:%S"] +type DateTimeN = '(ParseTimes UTCTime DateTimeFmts Id, 'True, FormatTimeP "%Y-%m-%d %H:%M:%S" Id, String) + +-- | convert a string from a given base \'i\' and store it internally as an base 10 integer +-- +-- >>> prtEval3P base16 ol "00fe" +-- Right (Refined3 {r3In = 254, r3Out = "fe"}) +-- +-- >>> prtEval3P (basen' @16 @(Between 100 400)) ol "00fe" +-- Right (Refined3 {r3In = 254, r3Out = "fe"}) +-- +-- >>> prtEval3P (basen' @16 @(GuardSimple (Id < 400) >> 'True)) ol "f0fe" +-- Left Step 2. Failed Boolean Check(op) | 61694 < 400 +-- +type BaseN (n :: Nat) = BaseN' n 'True +type BaseN' (n :: Nat) p = '(ReadBase Int n, p, ShowBase n, String) + +base16 :: Proxy (BaseN 16) +base16 = basen @16 + +-- replace with BetweenT 2 36 n +--basen :: forall n . (KnownNat n, (n GN.<=? 36) ~ 'True, (2 GN.<=? n) ~ 'True) => Proxy (BaseN n) +--basen = mkProxy3 + +basen :: Proxy (BaseN n) +basen = mkProxy3 + +basen' :: Proxy (BaseN' n p) +basen' = mkProxy3 + +{- +basen' :: forall n p + . (P p Int + , PP p Int ~ Bool + , KnownNat n + , (n GN.<=? 36) ~ 'True + , (2 GN.<=? n) ~ 'True + ) => Proxy (BaseN' n p) +basen' = mkProxy3 +-} +daten :: Proxy DateN +daten = mkProxy3 + +datetimen :: Proxy DateTimeN +datetimen = mkProxy3 + +-- | ensures that two numbers are in a given range (emulates 'Refined.Refined') +-- +-- >>> prtEval3P (between @10 @16) ol 14 +-- Right (Refined3 {r3In = 14, r3Out = 14}) +-- +-- >>> prtEval3P (between @10 @16) ol 17 +-- Left Step 2. False Boolean Check(op) | FalseP +-- +-- >>> prtEval3P (between @10 @16) o0 17 +-- Left Step 2. False Boolean Check(op) | FalseP +-- <BLANKLINE> +-- *** Step 1. Success Initial Conversion(ip) [17] *** +-- <BLANKLINE> +-- P Id 17 +-- <BLANKLINE> +-- *** Step 2. False Boolean Check(op) *** +-- <BLANKLINE> +-- False True && False +-- | +-- +- True 17 >= 10 +-- | | +-- | +- P I +-- | | +-- | `- P '10 +-- | +-- `- False 17 <= 16 +-- | +-- +- P I +-- | +-- `- P '16 +-- <BLANKLINE> +-- +between :: Proxy (BetweenN m n) +between = mkProxy3 + +type BetweenN m n = '(Id, Between m n, Id, Int) +type BetweenR m n = RefinedEmulate (Between m n) Int + +type LuhnR (n :: Nat) = MakeR3 (LuhnT n) + +-- | Luhn check +-- +-- >>> prtEval3P (Proxy @(LuhnT 4)) ol "1230" +-- Right (Refined3 {r3In = [1,2,3,0], r3Out = "1230"}) +-- +-- >>> prtEval3P (Proxy @(LuhnT 4)) ol "1234" +-- Left Step 2. Failed Boolean Check(op) | Luhn map=[4,6,2,2] sum=14 ret=4 | [1,2,3,4] + +-- | uses builtin 'Luhn' +type LuhnT (n :: Nat) = + '(Map (ReadP Int) (Ones Id) + , Guard (Printfn "incorrect number of digits found %d but expected %d in [%s]" (TupleI '[Len, W n, ShowP Id])) + (Len >> Same n) + >> GuardSimple (Luhn Id) >> 'True + , ConcatMap (ShowP Id) Id + , String) + +-- | noop true +type Ok (t :: Type) = '(Id, 'True, Id, t) +type OkR (t :: Type) = MakeR3 (Ok t) + +ok :: Proxy (Ok t) +ok = mkProxy3 + +-- | noop false +type OkNot (t :: Type) = '(Id, 'False, Id, t) +type OkNotR (t :: Type) = MakeR3 (OkNot t) + +oknot :: Proxy (OkNot t) +oknot = mkProxy3 + +-- | convert a string from a given base \'i\' and store it internally as a base \'j\' string +-- +-- >>> prtEval3P (Proxy @(BaseIJ 16 2)) ol "fe" +-- Right (Refined3 {r3In = "11111110", r3Out = "fe"}) +-- +-- >>> prtEval3P (Proxy @(BaseIJ 16 2)) ol "fge" +-- Left Step 1. Initial Conversion(ip) Failed | invalid base 16 +-- +-- >>> prtEval3P (Proxy @(BaseIJ' 16 2 (GuardSimple (ReadBase Int 2 < 1000) >> 'True))) ol "ffe" +-- Left Step 2. Failed Boolean Check(op) | 4094 < 1000 +-- +type BaseIJ (i :: Nat) (j :: Nat) = BaseIJ' i j 'True +type BaseIJ' (i :: Nat) (j :: Nat) p = '(ReadBase Int i >> ShowBase j, p, ReadBase Int j >> ShowBase i, String) + +-- | take any valid Read/Show instance and turn it into a valid 'Refined3' +-- +-- >>> :m + Data.Ratio +-- >>> prtEval3P (readshow @Rational) ol "13 % 3" +-- Right (Refined3 {r3In = 13 % 3, r3Out = "13 % 3"}) +-- +-- >>> prtEval3P (readshow @Rational) ol "13x % 3" +-- Left Step 1. Initial Conversion(ip) Failed | ReadP Ratio Integer (13x % 3) failed +-- +-- >>> prtEval3P (readshow' @Rational @(Between (3 % 1) (5 % 1))) ol "13 % 3" +-- Right (Refined3 {r3In = 13 % 3, r3Out = "13 % 3"}) +-- +-- >>> prtEval3P (Proxy @(ReadShow' Rational (Between (11 %- 2) (3 %- 1)))) ol "-13 % 3" +-- Right (Refined3 {r3In = (-13) % 3, r3Out = "(-13) % 3"}) +-- +-- >>> prtEval3P (Proxy @(ReadShow' Rational (Id > (15 % 1)))) ol "13 % 3" +-- Left Step 2. False Boolean Check(op) | FalseP +-- +-- >>> prtEval3P (Proxy @(ReadShow' Rational (Guard (Printf "invalid=%3.2f" (FromRational Double Id)) (Id > (15 % 1)) >> 'True))) ol "13 % 3" +-- Left Step 2. Failed Boolean Check(op) | invalid=4.33 +-- +-- >>> prtEval3P (Proxy @(ReadShow' Rational (Id > (11 % 1)))) ol "13 % 3" +-- Left Step 2. False Boolean Check(op) | FalseP +-- +-- >>> let tmString = "2018-10-19 14:53:11.5121359 UTC" +-- >>> let tm = read tmString :: UTCTime +-- >>> prtEval3P (readshow @UTCTime) ol tmString +-- Right (Refined3 {r3In = 2018-10-19 14:53:11.5121359 UTC, r3Out = "2018-10-19 14:53:11.5121359 UTC"}) +-- +-- >>> :m + Data.Aeson +-- >>> prtEval3P (readshow @Value) ol "String \"jsonstring\"" +-- Right (Refined3 {r3In = String "jsonstring", r3Out = "String \"jsonstring\""}) +-- +-- >>> prtEval3P (readshow @Value) ol "Number 123.4" +-- Right (Refined3 {r3In = Number 123.4, r3Out = "Number 123.4"}) +-- +type ReadShow (t :: Type) = '(ReadP t, 'True, ShowP Id, String) +type ReadShowR (t :: Type) = MakeR3 (ReadShow t) + +type ReadShow' (t :: Type) p = '(ReadP t, p, ShowP Id, String) +type ReadShowR' (t :: Type) p = MakeR3 (ReadShow' t p) + +readshow :: Proxy (ReadShow t) +readshow = mkProxy3 + +readshow' :: Proxy (ReadShow' t p) +readshow' = mkProxy3
+ src/Predicate/TH_Orphans.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS -Wall #-} +{-# OPTIONS -Wno-orphans #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PackageImports #-} +{- | + Mainly contains useful Template Haskell Lift instances for Date Time +-} +module Predicate.TH_Orphans where +import qualified Language.Haskell.TH.Syntax as TH +import qualified Language.Haskell.TH.Lift as TL +import Data.Time +import Data.Fixed + +deriving instance TH.Lift Day +deriving instance TH.Lift LocalTime +deriving instance TH.Lift TimeOfDay +deriving instance TH.Lift (Fixed a) + +deriving instance TH.Lift UTCTime + +$(TL.deriveLift ''DiffTime) +
+ src/Predicate/Util.hs view
@@ -0,0 +1,1095 @@+{-# OPTIONS -Wall #-} +{-# OPTIONS -Wcompat #-} +{-# OPTIONS -Wincomplete-record-updates #-} +{-# OPTIONS -Wincomplete-uni-patterns #-} +{-# OPTIONS -Wredundant-constraints #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{- | + Utility methods for Predicate / methods for displaying the evaluation tree ... +-} +module Predicate.Util ( + -- ** TT + TT(..) + , tBool + , tStrings + , tForest + , fixBoolT + + -- ** BoolT + , BoolT(..) + , _FailT + , _PresentT + , _FalseT + , _TrueT + + -- ** BoolP + , boolT2P + , BoolP + , PE(PE) + + -- ** create tree functions + , mkNode + , mkNodeB + , mkNodeSkipP + + -- ** tree manipulation + , getValLRFromTT + , getValLR + , fromTT + , getValueLR + , getValueLRHide + , fixLite + , fixit + , prefixMsg + , splitAndAlign + + -- ** display options + , POpts(..) + , defOpts + , ol + , olc + , o0 + , o2 + , o2n + , o3 + , ou + , oun + , setw + , setd + , setu + , setc + , color0 + , color1 + , color2 + , color3 + , color4 + , colorMe + , lite + , unicode + , normal + +-- ** formatting functions + , show01 + , lit01 + , show01' + , lit01' + , showLit0 + , showLit1 + , show0 + , show3 + , show1 + + -- ** Regex + , ROpt(..) + , compileRegex + , GetROpts(..) + , RR(..) + + -- ** useful type families + , BetweenT + , NullT + , FailIfT + , AndT + , OrT + , NotT + , RepeatT + , IntersperseT + , LenT + , ReverseTupleC(..) + , TupleListT + , TupleListD(..) + , TupleLenT + , FlipT + , IfT + , SumT + , MapT + , ConsT + , type (%%) + , type (%&) + + -- ** extract values from the type level + , nat + , symb + , GetNats(..) + , GetSymbs(..) + , getLen + , GetLen(..) + , showThese + , GetThese(..) + , GetOrdering(..) + , GetBool(..) + , ToN + , OrderingP(..) + , GetOrd(..) + + -- ** printing methods + , prtTTIO + , prtTT + , prtTree + , prtImpl + , prtTreePure + , prettyRational + + -- ** boolean methods + , imply + , evalBinStrict + + -- ** miscellaneous + , hh + , showT + , prettyOrd + , removeAnsi + , MonadEval(..) + ) where +import qualified GHC.TypeNats as GN +import Data.Ratio +import GHC.TypeLits (Symbol,Nat,KnownSymbol,KnownNat,ErrorMessage((:$$:),(:<>:))) +import qualified GHC.TypeLits as GL +import Control.Lens +import Control.Arrow +import Data.List +import qualified Data.Tree.View as TV +import Data.Tree +import Data.Tree.Lens +import Data.Proxy +import Data.Char +import Data.Data +import System.Console.Pretty +import GHC.Exts (Constraint) +import qualified Text.Regex.PCRE.Heavy as RH +import qualified Text.Regex.PCRE.Light as RL +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Text as T +import Data.ByteString (ByteString) +import GHC.Word (Word8) +import Data.Sequence (Seq) +import Control.Applicative (ZipList) +import Data.Kind (Type) +import Data.These +import Data.These.Combinators +import qualified Control.Exception as E +import Control.DeepSeq +import System.IO.Unsafe (unsafePerformIO) +import Data.Bool +import Data.Foldable +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as N +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> :set -XTypeOperators +-- >>> :set -XNoStarIsType + +-- | represents the evaluation tree for predicates +data TT a = TT { _tBool :: BoolT a -- ^ the value at this root node + , _tStrings :: [String] -- ^ detailed information eg input and output and text + , _tForest :: Forest PE } -- ^ the child nodes + deriving Show + +-- | contains the typed result from evaluating the expression tree +-- +data BoolT a where + FailT :: String -> BoolT a -- ^ failure with string + FalseT :: BoolT Bool -- ^ false predicate + TrueT :: BoolT Bool -- ^ true predicate + PresentT :: a -> BoolT a -- ^ non predicate value + +deriving instance Show a => Show (BoolT a) +deriving instance Eq a => Eq (BoolT a) + +-- | lens for accessing 'BoolT' in 'TT' +tBool :: Lens (TT a) (TT b) (BoolT a) (BoolT b) +tBool afb s = (\b -> s { _tBool = b }) <$> afb (_tBool s) + +tStrings :: Lens' (TT a) [String] +tStrings afb s = (\b -> s { _tStrings = b }) <$> afb (_tStrings s) + +tForest :: Lens' (TT a) (Forest PE) +tForest afb s = (\b -> s { _tForest = b }) <$> afb (_tForest s) + +-- | a lens from typed 'BoolT' to the untyped 'BoolP' +boolT2P :: Lens' (BoolT a) BoolP +boolT2P afb = \case + FailT e -> FailT e <$ afb (FailP e) + TrueT -> TrueT <$ afb TrueP + FalseT -> FalseT <$ afb FalseP + PresentT a -> PresentT a <$ afb PresentP + +-- | contains the untyped result from evaluating the expression tree +data BoolP = + FailP String -- ^ fails the entire evaluation + | FalseP -- ^ False predicate + | TrueP -- ^ True predicate + | PresentP -- ^ Any value + deriving (Show, Eq) + +data PE = PE { _pBool :: BoolP -- ^ holds the result of running the predicate + , _pStrings :: [String] -- ^ optional strings to include in the results + } deriving Show + +pBool :: Lens' PE BoolP +pBool afb (PE x y) = flip PE y <$> afb x + +-- | creates a Node for the evaluation tree +mkNode :: POpts -> BoolT a -> [String] -> [Holder] -> TT a +mkNode opts bt ss hs + | oLite opts = TT bt [] [] + | otherwise = TT bt ss (map fromTTH hs) + +-- | creates a Boolean node for a predicate type +mkNodeB :: POpts -> Bool -> [String] -> [Holder] -> TT Bool +mkNodeB opts b = mkNode opts (bool FalseT TrueT b) + +mkNodeSkipP :: Tree PE +mkNodeSkipP = Node (PE TrueP ["skipped PP ip i = Id"]) [] + +partitionTTExtended :: (w, TT a) -> ([((w, TT x), String)], [(w, TT a)]) +partitionTTExtended z@(_, t) = + case _tBool t of + FailT e -> ([(z & _2 . tBool .~ FailT e, e)], []) + _ -> ([], [z]) + +getValLRFromTT :: TT a -> Either String a +getValLRFromTT = getValLR . _tBool + +-- | get the value from BoolT or fail +getValLR :: BoolT a -> Either String a +getValLR = \case + FailT e -> Left e + TrueT -> Right True + FalseT -> Right False + PresentT a -> Right a + +-- | converts a typed tree to an untyped on for display +fromTT :: TT a -> Tree PE +fromTT (TT bt ss tt) = Node (PE (bt ^. boolT2P) ss) tt + +-- | a monomorphic container of trees +data Holder = forall w . Holder (TT w) + +-- | converts a typed tree into an untyped one +fromTTH :: Holder -> Tree PE +fromTTH (Holder x) = fromTT x + +-- | convenience method to wrap a typed tree +hh :: TT w -> Holder +hh = Holder + +-- | see 'getValueLRImpl' : add more detail to the tree if there are errors +getValueLR :: POpts -> String -> TT a -> [Holder] -> Either (TT x) a +getValueLR = getValueLRImpl True + +-- | see 'getValueLRImpl' : add less detail to the tree if there are errors +getValueLRHide :: POpts -> String -> TT a -> [Holder] -> Either (TT x) a +getValueLRHide = getValueLRImpl False + +-- elide FailT msg in tStrings[0] if showError is False +-- | a helper method to add extra context on failure to the tree or extract the value at the root of the tree +getValueLRImpl :: Bool -> POpts -> String -> TT a -> [Holder] -> Either (TT x) a +getValueLRImpl showError opts msg0 tt hs = + let tt' = hs ++ [hh tt] + in left (\e -> mkNode + opts + (FailT e) + [msg0 <> if showError then (if null msg0 then "" else " ") <> "[" <> e <> "]" + else ""] + tt' + ) + (getValLRFromTT tt) + +-- | the color palette for displaying the expression tree +newtype PColor = PColor (BoolP -> String -> String) + +-- | customizable options +data POpts = POpts { oWidth :: Int -- ^ length of data to display for 'showLitImpl' + , oDebug :: !Int -- ^ debug level + , oDisp :: Disp -- ^ display the tree using the normal tree or unicode + , oHide :: !Int -- ^ hides one layer of a tree + , oColor :: !(String, PColor) -- ^ color palette used + , oLite :: !Bool -- ^ skip the tree entirely and display the end result + } + +-- | display format for the tree +data Disp = NormalDisp -- ^ draw normal tree + | Unicode -- ^ use unicode + deriving (Show, Eq) + +instance Show POpts where + show opts = + "POpts: showA=" <> show (oWidth opts) + <> " debug=" <> show (oDebug opts) + <> " disp=" <> show (oDisp opts) + <> " hide=" <> show (oHide opts) + <> " color=" <> show (fst (oColor opts)) + <> " lite=" <> show (oLite opts) + +defOpts :: POpts +defOpts = POpts + { oWidth = 200 + , oDebug = 2 + , oDisp = NormalDisp + , oHide = 0 + , oColor = color1 + , oLite = False + } + +-- | skip colors and just return the summary +ol :: POpts +ol = defOpts { oColor = color0, oLite = True } + +-- | skip the detail and just return the summary but keep the colors +olc :: POpts +olc = ol { oColor = color1 } + +-- | displays the detailed evaluation tree without colors. +o0 :: POpts +o0 = defOpts { oColor = color0 } + +-- | displays the detailed evaluation tree using colors. +o2 :: POpts +o2 = defOpts { oDebug = 2 } + +-- | same as 'o2' but for a narrow display +o2n :: POpts +o2n = o2 { oWidth = 120 } + +-- | same as 'o2' for a wider display and more lenient debug mode setting +o3 :: POpts +o3 = defOpts { oDebug = 3, oWidth = 400 } + +-- | displays the detailed evaluation tree using unicode and colors. ('o2' works better on Windows) +ou :: POpts +ou = defOpts { oDisp = Unicode } + +-- | same as 'ou' but for a narrow display +oun :: POpts +oun = ou { oWidth = 120 } + +-- | helper method to limit the width of the tree +setw :: Int -> POpts -> POpts +setw w o = o { oWidth = w } + +-- | helper method to set the debug level +setd :: Int -> POpts -> POpts +setd v o = o { oDebug = v } + +-- | set display to unicode and colors +setu :: POpts -> POpts +setu o = o { oDisp = Unicode } + +-- | set a color palette +setc :: (String, PColor) -> POpts -> POpts +setc pc o = o { oColor = pc } + +-- | color palettes +-- +-- italics dont work but underline does +color0, color1, color2, color3, color4 :: (String, PColor) + +-- | no colors are displayed +color0 = ("color0", PColor $ flip const) + +-- | default color palette +color1 = + ("color1",) $ PColor $ \case + FailP {} -> bgColor Magenta + FalseP -> bgColor Red + TrueP -> bgColor Green + PresentP -> bgColor Yellow + +color2 = + ("color2",) $ PColor $ \case + FailP {} -> bgColor Magenta + FalseP -> bgColor Red + TrueP -> bgColor White + PresentP -> bgColor Yellow + +color3 = + ("color3",) $ PColor $ \case + FailP {} -> bgColor Blue + FalseP -> color Red + TrueP -> color White + PresentP -> bgColor Yellow + +color4 = + ("color4",) $ PColor $ \case + FailP {} -> bgColor Cyan + FalseP -> color Red + TrueP -> color Green + PresentP -> bgColor Yellow + +-- | fix PresentT Bool to TrueT or FalseT +fixBoolT :: TT Bool -> TT Bool +fixBoolT t = + case t ^? tBool . _PresentT of + Nothing -> t + Just b -> t & tBool .~ _boolT # b + +show01 :: (Show a1, Show a2) => POpts -> String -> a1 -> a2 -> String +show01 opts msg0 ret as = lit01 opts msg0 ret (show as) + +lit01 :: Show a1 => POpts -> String -> a1 -> String -> String +lit01 opts msg0 ret as = lit01' opts msg0 ret "" as + +show01' :: (Show a1, Show a2) => POpts -> String -> a1 -> String -> a2 -> String +show01' opts msg0 ret fmt as = lit01' opts msg0 ret fmt (show as) + +lit01' :: Show a1 => POpts -> String -> a1 -> String -> String -> String +lit01' opts msg0 ret fmt as = msg0 <> show0 opts " " ret <> showLit1 opts (" | " ++ fmt) as + +-- | display all data regardless of debug level +showLit0 :: POpts -> String -> String -> String +showLit0 o s a = showLitImpl o 0 s a + +-- | more restrictive: only display data at debug level 1 or less +showLit1 :: POpts -> String -> String -> String +showLit1 o s a = showLitImpl o 1 s a + +showLitImpl :: POpts -> Int -> String -> String -> String +showLitImpl o i s a = + if oDebug o >= i then + let f n = let ss = take n a + in ss <> (if length ss==n then " ..." else "") + in s <> f (oWidth o) + else "" + +show0 :: Show a => POpts -> String -> a -> String +show0 o s a = showAImpl o 0 s a + +show3 :: Show a => POpts -> String -> a -> String +show3 o s a = showAImpl o 3 s a + +show1 :: Show a => POpts -> String -> a -> String +show1 o s a = showAImpl o 1 s a + +showAImpl :: Show a => POpts -> Int -> String -> a -> String +showAImpl o i s a = showLitImpl o i s (show a) + +-- | Regex options for Rescan Resplit Re etc +data ROpt = + Anchored -- ^ Force pattern anchoring + | Auto_callout -- ^ Compile automatic callouts +-- | Bsr_anycrlf -- \R matches only CR, LF, or CrlF +-- | Bsr_unicode -- ^ \R matches all Unicode line endings + | Caseless -- ^ Do caseless matching + | Dollar_endonly -- ^ dollar not to match newline at end + | Dotall -- ^ matches anything including NL + | Dupnames -- ^ Allow duplicate names for subpatterns + | Extended -- ^ Ignore whitespace and # comments + | Extra -- ^ PCRE extra features (not much use currently) + | Firstline -- ^ Force matching to be before newline + | Multiline -- ^ caret and dollar match newlines within data +-- | Newline_any -- ^ Recognize any Unicode newline sequence +-- | Newline_anycrlf -- ^ Recognize CR, LF, and CrlF as newline sequences + | Newline_cr -- ^ Set CR as the newline sequence + | Newline_crlf -- ^ Set CrlF as the newline sequence + | Newline_lf -- ^ Set LF as the newline sequence + | No_auto_capture -- ^ Disable numbered capturing parentheses (named ones available) + | Ungreedy -- ^ Invert greediness of quantifiers + | Utf8 -- ^ Run in UTF--8 mode + | No_utf8_check -- ^ Do not check the pattern for UTF-8 validity + deriving (Show,Eq,Ord,Enum,Bounded) + +-- | compile a regex using the type level symbol +compileRegex :: forall rs a . GetROpts rs + => POpts -> String -> String -> [Holder] -> Either (TT a) RH.Regex +compileRegex opts nm s hhs = + let rs = getROpts @rs + mm = nm <> " " <> show rs + in flip left (RH.compileM (B8.pack s) rs) + $ \e -> mkNode opts (FailT "Regex failed to compile") [mm <> " compile failed with regex msg[" <> e <> "]"] hhs + +-- | extract the regex options from the type level list +class GetROpts (os :: [ROpt]) where + getROpts :: [RL.PCREOption] +instance GetROpts '[] where + getROpts = [] +instance (GetROpt r, GetROpts rs) => GetROpts (r ': rs) where + getROpts = getROpt @r : getROpts @rs + +-- | convert type level regex option to the value level +class GetROpt (o :: ROpt) where + getROpt :: RL.PCREOption +instance GetROpt 'Anchored where getROpt = RL.anchored +instance GetROpt 'Auto_callout where getROpt = RL.auto_callout +--instance GetROpt 'Bsr_anycrlf where getROpt = RL.bsr_anycrlf +--instance GetROpt 'Bsr_unicode where getROpt = RL.bsr_unicode +instance GetROpt 'Caseless where getROpt = RL.caseless +instance GetROpt 'Dollar_endonly where getROpt = RL.dollar_endonly +instance GetROpt 'Dotall where getROpt = RL.dotall +instance GetROpt 'Dupnames where getROpt = RL.dupnames +instance GetROpt 'Extended where getROpt = RL.extended +instance GetROpt 'Extra where getROpt = RL.extra +instance GetROpt 'Firstline where getROpt = RL.firstline +instance GetROpt 'Multiline where getROpt = RL.multiline +--instance GetROpt 'Newline_any where getROpt = RL.newline_any +--instance GetROpt 'Newline_anycrlf where getROpt = RL.newline_anycrlf +instance GetROpt 'Newline_cr where getROpt = RL.newline_cr +instance GetROpt 'Newline_crlf where getROpt = RL.newline_crlf +instance GetROpt 'Newline_lf where getROpt = RL.newline_lf +instance GetROpt 'No_auto_capture where getROpt = RL.no_auto_capture +instance GetROpt 'Ungreedy where getROpt = RL.ungreedy +instance GetROpt 'Utf8 where getROpt = RL.utf8 +instance GetROpt 'No_utf8_check where getROpt = RL.no_utf8_check + +-- | used by 'Predicate.ReplaceImpl' and 'RH.sub' and 'RH.gsub' to allow more flexible replacement +-- These parallel the RegexReplacement (not exported) class in "Text.Regex.PCRE.Heavy" but have overlappable instances which is problematic for this code so I use 'RR' +data RR = + RR String + | RR1 (String -> [String] -> String) + | RR2 (String -> String) + | RR3 ([String] -> String) + +instance Show RR where + show = \case + RR s -> "RR " ++ s + RR1 {} -> "RR1 <fn>" + RR2 {} -> "RR2 <fn>" + RR3 {} -> "RR3 <fn>" + +-- | extract values from the trees or if there are errors returned a tree with added context +splitAndAlign :: Show x => + POpts + -> [String] + -> [((Int, x), TT a)] + -> Either (TT w) + ([a] + ,[((Int, x), TT a)] + ) +splitAndAlign opts msgs ts = + case mconcat $ map partitionTTExtended ts of + (excs@(e:_), _) -> + Left $ mkNode opts + (FailT (groupErrors (map snd excs))) + (msgs <> ["excs=" <> show (length excs) <> " " <> formatList opts [fst e]]) + (map (hh . snd) ts) + ([], tfs) -> Right (valsFromTTs (map snd ts), tfs) + +formatList :: forall x z . Show x => POpts -> [((Int, x), z)] -> String +formatList opts = unwords . map (\((i, a), _) -> "(i=" <> show i <> showAImpl opts 0 ", a=" a <> ")") + +-- | extract all root values from a list of trees +valsFromTTs :: [TT a] -> [a] +valsFromTTs = concatMap toList + +instance Foldable TT where + foldMap am = foldMap am . _tBool + +instance Foldable BoolT where + foldMap am = either (const mempty) am . getValLR + +-- cant use: is / isn't / has as only FailT will be False: use Fold +-- this is more specific to TrueP FalseP +-- | prism from BoolT to Bool +_boolT :: Prism' (BoolT Bool) Bool +_boolT = prism' (bool FalseT TrueT) + $ \case + PresentT a -> Just a + TrueT -> Just True + FalseT -> Just False + FailT {} -> Nothing + +groupErrors :: [String] -> String +groupErrors = + intercalate " | " + . map (\xs@(x :| _) -> x <> (if length xs > 1 then "(" <> show (length xs) <> ")" else "")) + . N.group + +_FailT :: Prism' (BoolT a) String +_FailT = prism' FailT $ \case + FailT s -> Just s + _ -> Nothing + +_PresentT :: Prism' (BoolT a) a +_PresentT = prism' PresentT $ \case + PresentT a -> Just a + _ -> Nothing + +_FalseT :: Prism' (BoolT Bool) () +_FalseT = prism' (const FalseT) $ + \case + FalseT -> Just () + _ -> Nothing + +_TrueT :: Prism' (BoolT Bool) () +_TrueT = prism' (const TrueT) $ + \case + TrueT -> Just () + _ -> Nothing + +-- | boolean implication +-- +-- >>> True `imply` False +-- False +-- +-- >>> True `imply` True +-- True +-- +-- >>> False `imply` False +-- True +-- +-- >>> False `imply` True +-- True + +imply :: Bool -> Bool -> Bool +imply p q = not p || q + +-- msg is only used for an exception: up to the calling programs to deal with ading msg to good and bad +-- | applies a boolean binary operation against the values from two boolean trees +evalBinStrict :: POpts + -> String + -> (Bool -> Bool -> Bool) + -> TT Bool + -> TT Bool + -> TT Bool +evalBinStrict opts s fn ll rr = + case getValueLR opts (s <> " p") ll [Holder rr] of + Left e -> e + Right a -> + case getValueLR opts (s <> " q") rr [hh ll] of + Left e -> e + Right b -> + let z = fn a b + in mkNodeB opts z [show a <> " " <> s <> " " <> show b] [hh ll, hh rr] + +-- | type level Between +type family BetweenT (a :: Nat) (b :: Nat) (v :: Nat) :: Constraint where + BetweenT m n v = + FailIfT (NotT (AndT (m GL.<=? v) (v GL.<=? n))) + ((m GL.<=? v) ~ 'True, (v GL.<=? n) ~ 'True) + ('GL.Text "BetweenT failure" + ':$$: 'GL.ShowType v + ':$$: 'GL.Text " is outside of " + ':$$: 'GL.ShowType m + ':<>: 'GL.Text " and " + ':<>: 'GL.ShowType n) + +-- | typelevel Null on Symbol +type family NullT (x :: Symbol) :: Bool where + NullT ("" :: Symbol) = 'True + NullT _ = 'False + +-- todo: constraint \'c\' is not passed on properly +-- | helper method to fail with an error if the True +type family FailIfT (b :: Bool) (c :: Constraint) (msg :: GL.ErrorMessage) :: Constraint where + FailIfT 'False c _ = c + FailIfT 'True _ e = GL.TypeError e + +-- | typelevel And +type family AndT (b :: Bool) (b1 :: Bool) :: Bool where + AndT 'False _ = 'False + AndT 'True b1 = b1 + +-- | typelevel Or +type family OrT (b :: Bool) (b1 :: Bool) :: Bool where + OrT 'True _ = 'True + OrT 'False b1 = b1 + +-- | typelevel Not +type family NotT (b :: Bool) :: Bool where + NotT 'True = 'False + NotT 'False = 'True + +-- | get a Nat from the typelevel +-- +-- >>> nat @14 +-- 14 +-- +nat :: forall n a . (KnownNat n, Num a) => a +nat = fromIntegral (GL.natVal (Proxy @n)) + +-- | gets the Symbol from the typelevel +-- >>> symb @"abc" +-- "abc" +-- +symb :: forall s . KnownSymbol s => String +symb = GL.symbolVal (Proxy @s) + +-- | get a list of Nats from the typelevel +-- +-- >>> getNats @'[10,12,1] +-- [10,12,1] +class GetNats as where + getNats :: [Int] +instance GetNats '[] where + getNats = [] +instance (KnownNat n, GetNats ns) => GetNats (n ': ns) where + getNats = nat @n : getNats @ns + +-- | get a list of Symbols from the typelevel +-- +-- >>> getSymbs @'["abc","def","g"] +-- ["abc","def","g"] +-- +class GetSymbs ns where + getSymbs :: [String] +instance GetSymbs '[] where + getSymbs = [] +instance (KnownSymbol s, GetSymbs ss) => GetSymbs (s ': ss) where + getSymbs = symb @s : getSymbs @ss + +-- | get the length of a typelevel list +-- +-- >>> getLen @'["abc","def","g"] +-- 3 +-- +getLen :: forall xs . GetLen xs => Int +getLen = getLenP (Proxy @xs) + +-- really need a proxy for this to work +-- | gets length of a typelevel list +class GetLen (xs :: [k]) where -- defaults to xs :: k (how to make it [k]) cos is not free + getLenP :: Proxy (xs :: [k]) -> Int +instance GetLen '[] where + getLenP _ = 0 +instance GetLen xs => GetLen (x ': xs) where + getLenP _ = 1 + getLenP (Proxy @xs) + +showThese :: These a b -> String +showThese = these (const "This") (const "That") (const (const "These")) + +-- hard without a Proxy +class GetThese (th :: These x y) where + getThese :: Proxy th -> (String, These w v -> Bool) +instance GetThese ('This x) where + getThese _ = ("This", isThis) +instance GetThese ('That y) where + getThese _ = ("That", isThat) +instance GetThese ('These x y) where + getThese _ = ("These", isThese) + +-- | get ordering from the typelevel +class GetOrdering (cmp :: Ordering) where + getOrdering :: Ordering +instance GetOrdering 'LT where + getOrdering = LT +instance GetOrdering 'EQ where + getOrdering = EQ +instance GetOrdering 'GT where + getOrdering = GT + +-- | get bool from the typelevel +class GetBool (a :: Bool) where + getBool :: Bool +instance GetBool 'True where + getBool = True +instance GetBool 'False where + getBool = False + +data N = S N | Z + +-- a shim for TupleListImpl used mainly by Printfn +-- | inductive numbers +type family ToN (n :: Nat) :: N where + ToN 0 = 'Z + ToN n = 'S (ToN (n GL.- 1)) +{- +-- | converts an inductive number to Nat +type family FromN (n :: N) :: Nat where + FromN 'Z = 0 + FromN ('S n) = 1 GL.+ FromN n + +-- | extract N from the type level to Int +class GetNatN (n :: N) where + getNatN :: Int +instance GetNatN 'Z where + getNatN = 0 +instance GetNatN n => GetNatN ('S n) where + getNatN = 1 + getNatN @n + +getN :: Typeable t => Proxy (t :: N) -> Int +getN p = length (show (typeRep p)) `div` 5 +-} + +data OrderingP = Cgt | Cge | Ceq | Cle | Clt | Cne deriving (Show, Eq, Enum, Bounded) + +class GetOrd (k :: OrderingP) where + getOrd :: Ord a => (String, a -> a -> Bool) + +instance GetOrd 'Cgt where getOrd = (">", (>)) +instance GetOrd 'Cge where getOrd = (">=",(>=)) +instance GetOrd 'Ceq where getOrd = ("==",(==)) +instance GetOrd 'Cle where getOrd = ("<=",(<=)) +instance GetOrd 'Clt where getOrd = ("<", (<)) +instance GetOrd 'Cne where getOrd = ("/=",(/=)) + +toNodeString :: POpts -> PE -> String +toNodeString opts bpe + | oLite opts = error $ "shouldnt be calling this if we are going lite: toNodeString oLite " ++ show bpe + | otherwise = showBoolP opts (_pBool bpe) <> " " <> displayMessages (_pStrings bpe) + +nullSpace :: String -> String +nullSpace s | null s = "" + | otherwise = " " <> s + +showBoolP :: POpts -> BoolP -> String +showBoolP o = + \case + b@(FailP e) -> "[" <> colorMe o b "Error" <> nullSpace e <> "]" + b@PresentP -> colorMe o b "P" + b@TrueP -> colorMe o b "True " + b@FalseP -> colorMe o b "False" + +displayMessages :: [String] -> String +displayMessages es = + case filter (not . all isSpace) es of + [] -> "" + z -> intercalate " | " z + +-- | colors the result of the predicate based on the current color palette +colorMe :: POpts -> BoolP -> String -> String +colorMe o b s = + let (_, PColor f) = oColor o + in f b s + +prtTTIO :: POpts -> IO (TT a) -> IO () +prtTTIO = prtTT' + +prtTT :: POpts -> Identity (TT a) -> IO () +prtTT = prtTT' + +prtTT' :: MonadEval m => POpts -> m (TT a) -> IO () +prtTT' o y = liftEval y >>= prtTree o . fromTT + +prtTree :: POpts -> Tree PE -> IO () +prtTree o = prtImpl o . fmap (toNodeString o) + +prtImpl :: POpts -> Tree String -> IO () +prtImpl = (putStr .) . showImpl + +fixLite :: forall a . Show a => POpts -> a -> Tree PE -> String +fixLite opts a t + | oLite opts = fixPresentP opts (t ^. root . pBool) a <> "\n" + | otherwise = prtTreePure opts t + +fixPresentP :: Show a => POpts -> BoolP -> a -> String +fixPresentP opts bp a = + case bp of + PresentP -> colorMe opts PresentP "Present" <> " " <> show a + _ -> showBoolP opts bp + +prtTreePure :: POpts -> Tree PE -> String +prtTreePure opts t + | oLite opts = showBoolP opts (t ^. root . pBool) + | otherwise = showImpl opts $ fmap (toNodeString opts) t + +showImpl :: POpts -> Tree String -> String +showImpl o = + case oDisp o of + Unicode -> TV.showTree + NormalDisp -> drawTree -- to drop the last newline else we have to make sure that everywhere else has that newline: eg fixLite + +-- | skip displaying the tree and just output the result +lite :: POpts -> POpts +lite o = o { oLite = True } + +-- | display in unicode (non-Windows) +unicode :: POpts -> POpts +unicode o = o { oDisp = Unicode } + +-- | normal display +normal :: POpts -> POpts +normal o = o { oDisp = NormalDisp } + +prettyRational :: Rational -> String +prettyRational (numerator &&& denominator -> (n,d)) = + if | n == 0 -> "0" + | d == 1 -> show n + | otherwise -> show n <> " / " <> show d + +fixit :: ((Int, x), TT a) -> TT a +fixit ((i, _), t) = prefixMsg ("i=" <> show i <> ":") t + +prefixMsg :: String -> TT a -> TT a +prefixMsg msg t = + t & tStrings . ix 0 %~ (msg <>) + +showT :: forall (t :: Type) . Typeable t => String +showT = show (typeRep (Proxy @t)) + +prettyOrd :: Ordering -> String +prettyOrd = \case + LT -> "<" + EQ -> "=" + GT -> ">" + +type family RepeatT (n :: Nat) (p :: k) :: [k] where + RepeatT 0 p = GL.TypeError ('GL.Text "RepeatT is not defined for zero") + RepeatT 1 p = p ': '[] + RepeatT n p = p ': RepeatT (n GN.- 1) p + +type family IntersperseT (s :: Symbol) (xs :: [Symbol]) :: Symbol where + IntersperseT s '[] = "" + IntersperseT s '[x] = x + IntersperseT s (x ': y ': xs) = x `GL.AppendSymbol` s `GL.AppendSymbol` IntersperseT s (y ': xs) + +type family LenT (xs :: [k]) :: Nat where + LenT '[] = 0 + LenT (x ': xs) = 1 GN.+ LenT xs + +type family TupleListT (n :: N) a where + TupleListT 'Z a = () + TupleListT ('S n) a = (a, TupleListT n a) + +class TupleListD (n :: N) a where + tupleListD :: Bool -> [a] -> Either String (TupleListT n a) + +instance TupleListD 'Z a where + tupleListD isStrict = \case + z@(_:_) | isStrict -> + let len = length z + in Left $ "is strict and has " <> show len <> " extra element" <> (if len == 1 then "" else "s") + _ -> Right () + +instance (TupleListD n a) => TupleListD ('S n) a where + tupleListD isStrict = \case + [] -> Left "no data left" -- nothing i can do here even if not strict + a:as -> (a,) <$> tupleListD @n @a isStrict as + +-- up to 12 +class ReverseTupleC x where + type ReverseTupleP x + reverseTupleC :: x -> ReverseTupleP x +instance (GL.TypeError ('GL.Text "ReverseTupleC: inductive tuple cannot be empty")) => ReverseTupleC () where + type ReverseTupleP () = () + reverseTupleC () = () +instance ReverseTupleC (a,()) where + type ReverseTupleP (a,()) = (a,()) + reverseTupleC (a,()) = (a,()) +instance ReverseTupleC (a,(b,())) where + type ReverseTupleP (a,(b,())) = (b,(a,())) + reverseTupleC (a,(b,())) = (b,(a,())) +instance ReverseTupleC (a,(b,(c,()))) where + type ReverseTupleP (a,(b,(c,()))) = (c,(b,(a,()))) + reverseTupleC (a,(b,(c,()))) = (c,(b,(a,()))) +instance ReverseTupleC (a,(b,(c,(d,())))) where + type ReverseTupleP (a,(b,(c,(d,())))) = (d,(c,(b,(a,())))) + reverseTupleC (a,(b,(c,(d,())))) = (d,(c,(b,(a,())))) +instance ReverseTupleC (a,(b,(c,(d,(e,()))))) where + type ReverseTupleP (a,(b,(c,(d,(e,()))))) = (e,(d,(c,(b,(a,()))))) + reverseTupleC (a,(b,(c,(d,(e,()))))) = (e,(d,(c,(b,(a,()))))) +instance ReverseTupleC (a,(b,(c,(d,(e,(f,())))))) where + type ReverseTupleP (a,(b,(c,(d,(e,(f,())))))) = (f,(e,(d,(c,(b,(a,())))))) + reverseTupleC (a,(b,(c,(d,(e,(f,())))))) = (f,(e,(d,(c,(b,(a,())))))) +instance ReverseTupleC (a,(b,(c,(d,(e,(f,(g,()))))))) where + type ReverseTupleP (a,(b,(c,(d,(e,(f,(g,()))))))) = (g,(f,(e,(d,(c,(b,(a,()))))))) + reverseTupleC (a,(b,(c,(d,(e,(f,(g,()))))))) = (g,(f,(e,(d,(c,(b,(a,()))))))) +instance ReverseTupleC (a,(b,(c,(d,(e,(f,(g,(h,())))))))) where + type ReverseTupleP (a,(b,(c,(d,(e,(f,(g,(h,())))))))) = (h,(g,(f,(e,(d,(c,(b,(a,())))))))) + reverseTupleC (a,(b,(c,(d,(e,(f,(g,(h,())))))))) = (h,(g,(f,(e,(d,(c,(b,(a,())))))))) +instance ReverseTupleC (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) where + type ReverseTupleP (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) = (i,(h,(g,(f,(e,(d,(c,(b,(a,()))))))))) + reverseTupleC (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) = (i,(h,(g,(f,(e,(d,(c,(b,(a,()))))))))) +instance ReverseTupleC (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) where + type ReverseTupleP (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) = (j,(i,(h,(g,(f,(e,(d,(c,(b,(a,())))))))))) + reverseTupleC (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) = (j,(i,(h,(g,(f,(e,(d,(c,(b,(a,())))))))))) +instance ReverseTupleC (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,()))))))))))) where + type ReverseTupleP (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,()))))))))))) = (k,(j,(i,(h,(g,(f,(e,(d,(c,(b,(a,()))))))))))) + reverseTupleC (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,()))))))))))) = (k,(j,(i,(h,(g,(f,(e,(d,(c,(b,(a,()))))))))))) +instance ReverseTupleC (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,(l,())))))))))))) where + type ReverseTupleP (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,(l,())))))))))))) = (l,(k,(j,(i,(h,(g,(f,(e,(d,(c,(b,(a,())))))))))))) + reverseTupleC (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,(l,())))))))))))) = (l,(k,(j,(i,(h,(g,(f,(e,(d,(c,(b,(a,())))))))))))) + +type family TupleLenT (t :: Type) :: Nat where + TupleLenT () = 0 + TupleLenT (_,ts) = 1 GN.+ TupleLenT ts + TupleLenT t = GL.TypeError ( + 'GL.Text "TupleLenT: expected a valid inductive tuple" + ':$$: 'GL.Text "t = " + ':<>: 'GL.ShowType t) + +-- partially apply the 2nd arg to an ADT -- $ and & work with functions only +-- doesnt apply more than once because we need to eval it +type family (p :: k -> k1) %% (q :: k) :: k1 where + p %% q = p q + +infixl 9 %% + +type family (p :: k) %& (q :: k -> k1) :: k1 where + p %& q = q p + +infixr 9 %& + +type family FlipT (d :: k1 -> k -> k2) (p :: k) (q :: k1) :: k2 where + FlipT d p q = d q p + +type family IfT (b :: Bool) (t :: k) (f :: k) :: k where + IfT 'True t f = t + IfT 'False t f = f + +type family SumT (ns :: [Nat]) :: Nat where + SumT '[] = 0 + SumT (n ': ns) = n GL.+ SumT ns + +-- only works if you use ADTs not type synonyms +type family MapT (f :: k -> k1) (xs :: [k]) :: [k1] where + MapT f '[] = '[] + MapT f (x ': xs) = f x ': MapT f xs + +-- | Extract \'a\' from a list like container +type family ConsT s where + ConsT [a] = a + ConsT (ZipList a) = a + ConsT T.Text = Char + ConsT ByteString = Word8 + ConsT (Seq a) = a + ConsT s = GL.TypeError ( + 'GL.Text "invalid ConsT instance" + ':$$: 'GL.Text "s = " + ':<>: 'GL.ShowType s) + +-- | a typeclass for choosing which monad to run in +class Monad m => MonadEval m where + runIO :: IO a -> m (Maybe a) + catchit :: E.Exception e => a -> m (Either String a) + catchitNF :: (E.Exception e, NFData a) => a -> m (Either String a) + liftEval :: m a -> IO a + +instance MonadEval Identity where + runIO _ = Identity Nothing + catchit v = Identity $ unsafePerformIO $ catchit @IO @E.SomeException v + catchitNF v = Identity $ unsafePerformIO $ catchitNF @IO @E.SomeException v + liftEval = return . runIdentity + +instance MonadEval IO where + runIO ioa = Just <$> ioa + catchit v = E.evaluate (Right $! v) `E.catch` (\(E.SomeException e) -> pure $ Left ("IO e=" <> show e)) + catchitNF v = E.evaluate (Right $!! v) `E.catch` (\(E.SomeException e) -> pure $ Left ("IO e=" <> show e)) + liftEval = id + +-- | strip ansi characters from a string +removeAnsi :: Show a => Either String a -> IO () +removeAnsi = + \case + Left e -> let esc = '\x1b' + f :: String -> Maybe (String, String) + f = \case + [] -> Nothing + c:cs | c == esc -> case break (=='m') cs of + (_,'m':s) -> Just ("",s) + _ -> Nothing + | otherwise -> Just $ break (==esc) (c:cs) + in putStrLn $ concat $ unfoldr f e + Right a -> print a +
+ src/Predicate/Util_TH.hs view
@@ -0,0 +1,172 @@+{-# OPTIONS -Wall #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE PolyKinds #-} +{- | + Template Haskell methods for creating Refined and Refined3 refinement types +-} +module Predicate.Util_TH + ( + -- ** Refined + refinedTH + , refinedTH' + + -- ** Refined3 + , refined3TH + , refined3TH' + ) where +import Predicate.Refined3 +import Predicate.Refined +import Predicate.Core +import Predicate.Util +import qualified Language.Haskell.TH.Syntax as TH +import Data.Functor.Identity + +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> :set -XTypeOperators +-- >>> :set -XNoStarIsType + +-- | creates a 'Refined.Refined' refinement type with terse output +-- +-- @ +-- >$$(refinedTH 123) :: Refined (Between 100 125) Int +-- Refined {unRefined = 123} +-- it :: Refined (Between 100 125) Int +-- @ +-- +-- @ +-- >$$(refinedTH 99) :: Refined (Between 100 125) Int +-- +-- <interactive>:8:4: error: +-- * refinedTH: predicate failed with FalseP +-- * In the Template Haskell splice $$(refinedTH 99) +-- In the expression: +-- $$(refinedTH 99) :: Refined (Between 100 125) Int +-- In an equation for \'it\': +-- it = $$(refinedTH 99) :: Refined (Between 100 125) Int +-- @ +-- +refinedTH :: forall p i + . (Show i, TH.Lift i, RefinedC p i) + => i + -> TH.Q (TH.TExp (Refined p i)) +refinedTH = refinedTH' ol + +-- | creates a 'Refined.Refined' refinement type +-- +-- allows you to specify display options (eg 'ou' for unicode / 'o2' for ansi) +-- +-- @ +-- >$$(refinedTH' o2 123) :: Refined (Between 100 125) Int +-- Refined {unRefined = 123} +-- it :: Refined (Between 100 125) Int +-- @ +-- +-- @ +-- >$$(refinedTH' o2 99) :: Refined (FailS "asdf" >> Between 100 125) Int +-- +-- <interactive>:116:4: error: +-- * +-- [Error asdf] lhs failed >> +-- | +-- `- [Error asdf] Fail asdf +-- | +-- `- P 'asdf +-- +-- refinedTH: predicate failed with FailP "asdf" +-- * In the Template Haskell splice $$(refinedTH' o0 99) +-- In the expression: +-- $$(refinedTH' o2 99) :: +-- Refined (FailS "asdf" >> Between 100 125) Int +-- @ +-- +refinedTH' :: forall p i + . (Show i, TH.Lift i, RefinedC p i) + => POpts + -> i + -> TH.Q (TH.TExp (Refined p i)) +refinedTH' opts i = do + let msg0 = "refinedTH" + let ((bp,e),mr) = runIdentity $ newRefined @p opts i + case mr of + Nothing -> + let msg1 = if oLite opts then "" else ("\n" ++ e ++ "\n") + in fail $ msg1 ++ msg0 ++ ": predicate failed with " ++ show bp -- ++ "\n" ++ e + Just r -> TH.TExp <$> TH.lift r + +-- | creates a 'Refined3.Refined3' refinement type with terse output +-- +-- @ +-- >$$(refined3TH 100) :: Refined3 Id (Between 100 125) Id Int +-- Refined3 {r3In = 100, r3Out = 100} +-- @ +-- +refined3TH :: forall ip op fmt i + . (Show i, Show (PP ip i), TH.Lift i, TH.Lift (PP ip i), Refined3C ip op fmt i) + => i + -> TH.Q (TH.TExp (Refined3 ip op fmt i)) +refined3TH = refined3TH' ol + +-- | creates a 'Refined3.Refined3' refinement type +-- +-- allows you to specify display options (eg 'ou' for unicode / 'o2' for ansi) +-- +-- @ +-- >$$(refined3TH' o2 100) :: Refined3 Id (Between 100 125) Id Int +-- Refined3 {r3In = 100, r3Out = 100} +-- @ +-- +-- @ +-- >$$(refined3TH' o2 99) :: Refined3 Id (Between 100 125) Id Int +-- +-- <interactive>:127:4: error: +-- * +-- *** Step 1. Success Initial Conversion(ip) [99] *** +-- +-- P Id 99 +-- +-- *** Step 2. False Boolean Check(op) *** +-- +-- False False && True +-- | +-- +- False 99 >= 100 +-- | | +-- | +- P I +-- | | +-- | `- P '100 +-- | +-- `- True 99 <= 125 +-- | +-- +- P I +-- | +-- `- P '125 +-- +-- refined3TH: predicate failed with Step 2. False Boolean Check(op) | FalseP +-- * In the Template Haskell splice $$(refined3TH' o2 99) +-- In the expression: +-- $$(refined3TH' o2 99) :: Refined3 Id (Between 100 125) Id Int +-- In an equation for \'it\': +-- it = $$(refined3TH' o2 99) :: Refined3 Id (Between 100 125) Id Int +-- @ +-- +refined3TH' :: forall ip op fmt i + . (Show i, Show (PP ip i), TH.Lift i, TH.Lift (PP ip i), Refined3C ip op fmt i) + => POpts + -> i + -> TH.Q (TH.TExp (Refined3 ip op fmt i)) +refined3TH' opts i = do + let msg0 = "refined3TH" + (ret,mr) = eval3 @ip @op @fmt opts i + m3 = prt3Impl opts ret + case mr of + Nothing -> + let msg1 = if oLite opts then "" else (m3Long m3 ++ "\n") + in fail $ msg1 ++ msg0 ++ ": predicate failed with " ++ (m3Desc m3 <> " | " <> m3Short m3) + Just r -> TH.TExp <$> TH.lift r +
− src/PredicateCore.hs
@@ -1,583 +0,0 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wcompat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{- | -Module : PredicateCore -Description : Dsl for evaluating and displaying type level expressions -Copyright : (c) Grant Weyburne, 2019 -License : BSD-3 -Maintainer : gbwey9@gmail.com - -class P is the main class. Contains a minimal set of instances of P to prevent orphans --} -module PredicateCore where -import UtilP -import GHC.TypeLits (Symbol,Nat,KnownSymbol,KnownNat) -import Control.Lens ((^.)) -import Data.Proxy -import Data.Typeable -import Data.Kind (Type) -import Data.These (These(..)) - --- | This is the core class. Each instance of this class can be combined into a dsl using 'Main.>>' -class P p a where - type PP (p :: k) a :: Type -- PP is the output type - eval :: MonadEval m => Proxy p -> POpts -> a -> m (TT (PP p a)) -- ^ returns a tree of results - --- | A specialised form of 'eval' that works only on predicates -evalBool :: (MonadEval m, P p a, PP p a ~ Bool) => Proxy p -> POpts -> a -> m (TT (PP p a)) -evalBool p opts a = fixBoolT <$> eval p opts a - --- | identity function --- --- >>> pl @I 23 --- Present 23 --- PresentT 23 -data I -instance P I a where - type PP I a = a - eval _ opts a = - let msg0 = "I" - in pure $ mkNode opts (PresentT a) [msg0] [] - - --- | identity function that displays the input unlike 'I' --- --- even more constraints than 'I' so we might need to add explicit type signatures --- --- >>> pl @Id 23 --- Present 23 --- PresentT 23 -data Id -instance Show a => P Id a where - type PP Id a = a - eval _ opts a = - let msg0 = "Id" - in pure $ mkNode opts (PresentT a) [msg0 <> show0 opts " " a] [] - - --- even more constraints than 'Id' so we might need to explicitly add types (Typeable) --- | identity function that also displays the type information for debugging --- --- >>> pl @IdT 23 --- Present 23 --- PresentT 23 -data IdT -instance (Typeable a, Show a) => P IdT a where - type PP IdT a = a - eval _ opts a = - let msg0 = "IdT(" <> t <> ")" - t = showT @a - in pure $ mkNode opts (PresentT a) [msg0 <> show0 opts " " a] [] - --- | transparent predicate wrapper to make k of kind 'Type' so it can be in a promoted list (cant mix kinds) see 'Predicate.Do' --- --- >>> pl @'[W 123, Id] 99 --- Present [123,99] --- PresentT [123,99] --- -data W (p :: k) -instance P p a => P (W p) a where - type PP (W p) a = PP p a - eval _ = eval (Proxy @(Msg "W" p)) - --- | add a message to give more context to the evaluation tree --- --- >>> pe @(Msg "[somemessage] " Id) 999 --- P [somemessage] Id 999 --- PresentT 999 --- -data Msg prt p - -instance (P prt a - , PP prt a ~ String - , P p a - ) => P (Msg prt p) a where - type PP (Msg prt p) a = PP p a - eval _ opts a = do - pp <- eval (Proxy @prt) opts a - case getValueLR opts "Msg" pp [] of - Left e -> pure e - Right msg -> prefixMsg msg <$> eval (Proxy @p) opts a - --- | 'const' () function --- --- >>> pl @() "Asf" --- Present () --- PresentT () --- -instance Show a => P () a where - type PP () a = () - eval _ opts a = - let msg0 = "()" - in pure $ mkNode opts (PresentT ()) [msg0 <> show0 opts " " a] [] - -instance P (Proxy t) a where - type PP (Proxy t) a = Proxy t - eval _ opts _ = - let msg0 = "Proxy" - in pure $ mkNode opts (PresentT Proxy) [msg0] [] - --- Start non-Type kinds ------------------------ - --- | pulls the type level 'Bool' to the value level --- --- >>> pl @'True "ignore this" --- True --- TrueT --- --- >>> pl @'False () --- False --- FalseT -instance GetBool b => P (b :: Bool) a where - type PP b a = Bool - eval _ opts _ = - let b = getBool @b - in pure $ mkNodeB opts b ["'" <> show b] [] - --- | pulls the type level 'Symbol' to the value level --- --- >>> pl @"hello world" () --- Present "hello world" --- PresentT "hello world" -instance KnownSymbol s => P (s :: Symbol) a where - type PP s a = String - eval _ opts _ = - let s = symb @s - in pure $ mkNode opts (PresentT s) ["'" <> showLit0 opts "" s] [] - --- | run the predicates in a promoted 2-tuple; similar to 'Control.Arrow.&&&' --- --- >>> pl @'(Id, 4) "hello" --- Present ("hello",4) --- PresentT ("hello",4) --- -instance (P p a, P q a) => P '(p,q) a where - type PP '(p,q) a = (PP p a, PP q a) - eval _ opts a = do - let msg = "'(,)" - lr <- runPQ msg (Proxy @p) (Proxy @q) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - mkNode opts (PresentT (p,q)) [msg] [hh pp, hh qq] - --- | run the predicates in a promoted 3-tuple --- --- >>> pl @'(4, Id, "goodbye") "hello" --- Present (4,"hello","goodbye") --- PresentT (4,"hello","goodbye") --- -instance (P p a - , P q a - , P r a - ) => P '(p,q,r) a where - type PP '(p,q,r) a = (PP p a, PP q a, PP r a) - eval _ opts a = do - let msg = "'(,,)" - lr <- runPQ msg (Proxy @p) (Proxy @q) opts a - case lr of - Left e -> pure e - Right (p,q,pp,qq) -> do - let hhs = [hh pp, hh qq] - rr <- eval (Proxy @r) opts a - pure $ case getValueLR opts msg rr hhs of - Left e -> e - Right r -> mkNode opts (PresentT (p,q,r)) [msg] (hhs <> [hh rr]) - --- | run the predicates in a promoted 4-tuple --- --- >>> pl @'(4, Id, "inj", 999) "hello" --- Present (4,"hello","inj",999) --- PresentT (4,"hello","inj",999) --- -instance (P p a - , P q a - , P r a - , P s a - ) => P '(p,q,r,s) a where - type PP '(p,q,r,s) a = (PP p a, PP q a, PP r a, PP s a) - eval _ opts a = do - let msg = "'(,,)" - lr <- runPQ msg (Proxy @p) (Proxy @q) opts a - case lr of - Left e -> pure e - Right (p,q,pp,qq) -> do - lr1 <- runPQ msg (Proxy @r) (Proxy @s) opts a - pure $ case lr1 of - Left e -> e - Right (r,s,rr,ss) -> - mkNode opts (PresentT (p,q,r,s)) [msg] [hh pp, hh qq, hh rr, hh ss] - --- | extracts the value level representation of the promoted 'Ordering' --- --- >>> pl @'LT "not used" --- Present LT --- PresentT LT --- --- >>> pl @'EQ () --- Present EQ --- PresentT EQ -instance GetOrdering cmp => P (cmp :: Ordering) a where - type PP cmp a = Ordering - eval _ opts _a = - let cmp = getOrdering @cmp - msg = "'" <> show cmp - in pure $ mkNode opts (PresentT cmp) [msg] [] - --- | extracts the value level representation of the type level 'Nat' --- --- >>> pl @123 () --- Present 123 --- PresentT 123 -instance KnownNat n => P (n :: Nat) a where - type PP n a = Int - eval _ opts _ = - let n = nat @n - in pure $ mkNode opts (PresentT n) ["'" <> show n] [] - --- | extracts the value level representation of the type level \'() --- --- >>> pl @'() () --- Present () --- PresentT () -instance P '() a where - type PP '() a = () - eval _ opts _ = pure $ mkNode opts (PresentT ()) ["'()"] [] - --- todo: the type has to be [a] so we still need type PP '[p] a = [PP p a] to keep the types in line - --- | extracts the value level representation of the type level \'[] --- --- >>> pl @'[] False --- Present [] --- PresentT [] -instance P ('[] :: [k]) a where - type PP ('[] :: [k]) a = [a] - eval _ opts _ = pure $ mkNode opts mempty ["'[]"] [] - --- | runs each predicate in turn from the promoted list --- --- >>> pl @'[1, 2, 3] 999 --- Present [1,2,3] --- PresentT [1,2,3] --- --- >>> pl @'[W 1, W 2, W 3, Id] 999 --- Present [1,2,3,999] --- PresentT [1,2,3,999] --- -instance (Show (PP p a), Show a, P p a) => P '[p] a where - type PP '[p] a = [PP p a] - eval _ opts a = do - pp <- eval (Proxy @p) opts a - let msg0 = "" -- "'[](end)" - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right b -> mkNode opts (PresentT [b]) [show01 opts msg0 b a] [hh pp] -- <> show0 opts " " a <> show1 opts " b=" b]) [hh pp] - -instance (Show (PP p a) - , Show a - , P (p1 ': ps) a - , PP (p1 ': ps) a ~ [PP p1 a] - , P p a - , PP p a ~ PP p1 a - ) => P (p ': p1 ': ps) a where - type PP (p ': p1 ': ps) a = [PP p a] - eval _ opts a = do - let msg0 = "'(p':q)" - lr <- runPQ msg0 (Proxy @p) (Proxy @(p1 ': ps)) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let ret = p:q - -- no gap between ' and ret! - in mkNode opts (PresentT ret) ["'" <> show0 opts "" ret <> show1 opts " | " a] [hh pp, hh qq] - --- | extracts the \'a\' from type level \'Maybe a\' if the value exists --- --- >>> pl @('Just Id) (Just 123) --- Present 123 --- PresentT 123 --- --- >>> pl @('Just Id) (Just True) --- Present True --- PresentT True --- --- >>> pl @('Just Id) Nothing --- Error 'Just found Nothing --- FailT "'Just found Nothing" --- -instance (Show (PP p a) - , P p a - , Show a - ) => P ('Just p) (Maybe a) where - type PP ('Just p) (Maybe a) = PP p a - eval _ opts ma = do - let msg0 = "'Just" - case ma of - Just a -> do - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right b -> mkNode opts (PresentT b) [show01 opts msg0 b ma] [hh pp] - Nothing -> pure $ mkNode opts (FailT (msg0 <> " found Nothing")) [msg0 <> " found Nothing"] [] - --- | expects Nothing otherwise it fails --- if the value is Nothing then it returns \'Proxy a\' as this provides more information than '()' --- --- >>> pl @'Nothing Nothing --- Present Proxy --- PresentT Proxy --- --- >>> pl @'Nothing (Just True) --- Error 'Nothing found Just --- FailT "'Nothing found Just" --- -instance P 'Nothing (Maybe a) where - type PP 'Nothing (Maybe a) = Proxy a -- () gives us less information - eval _ opts ma = - let msg0 = "'Nothing" - in pure $ case ma of - Nothing -> mkNode opts (PresentT Proxy) [msg0] [] - Just _ -> mkNode opts (FailT (msg0 <> " found Just")) [msg0 <> " found Just"] [] - --- omitted Show x so we can have less ambiguity --- | extracts the \'a\' from type level \'Either a b\' if the value exists --- --- >>> pl @('Left Id) (Left 123) --- Present 123 --- PresentT 123 --- --- >>> pl @('Left Id) (Right "aaa") --- Error 'Left found Right --- FailT "'Left found Right" --- -instance (Show a - , Show (PP p a) - , P p a - ) => P ('Left p) (Either a x) where - type PP ('Left p) (Either a x) = PP p a - eval _ opts lr = - let msg0 = "'Left" - in case lr of - Right _ -> pure $ mkNode opts (FailT (msg0 <> " found Right")) [msg0 <> " found Right"] [] - Left a -> do - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right b -> mkNode opts (_tBool pp) [show01' opts msg0 b "Left " a] [hh pp] - --- | extracts the \'b\' from type level \'Either a b\' if the value exists --- --- >>> pl @('Right Id) (Right 123) --- Present 123 --- PresentT 123 --- --- >>> pl @('Right Id) (Left "aaa") --- Error 'Right found Left --- FailT "'Right found Left" --- -instance (Show a - , Show (PP p a) - , P p a - ) => P ('Right p) (Either x a) where - type PP ('Right p) (Either x a) = PP p a - eval _ opts lr = do - let msg0 = "'Right" - case lr of - Left _ -> pure $ mkNode opts (FailT (msg0 <> " found Left")) [msg0 <> " found Left"] [] - Right a -> do - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right b -> mkNode opts (_tBool pp) [show01' opts msg0 b "Right " a] [hh pp] - --- removed Show x: else ambiguity errors in TestPredicate - --- | extracts the \'a\' from type level \'These a b\' if the value exists --- --- >>> pl @('This Id) (This 123) --- Present 123 --- PresentT 123 --- --- >>> pl @('This Id) (That "aaa") --- Error 'This found That --- FailT "'This found That" --- --- >>> pl @('This Id) (These 999 "aaa") --- Error 'This found These --- FailT "'This found These" --- -instance (Show a - , Show (PP p a) - , P p a - ) => P ('This p) (These a x) where - type PP ('This p) (These a x) = PP p a - eval _ opts th = do - let msg0 = "'This" - case th of - This a -> do - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right b -> mkNode opts (_tBool pp) [show01' opts msg0 b "This " a] [hh pp] - _ -> pure $ mkNode opts (FailT (msg0 <> " found " <> showThese th)) [msg0 <> " found " <> showThese th] [] - --- | extracts the \'b\' from type level \'These a b\' if the value exists --- --- >>> pl @('That Id) (That 123) --- Present 123 --- PresentT 123 --- --- >>> pl @('That Id) (This "aaa") --- Error 'That found This --- FailT "'That found This" --- --- >>> pl @('That Id) (These 44 "aaa") --- Error 'That found These --- FailT "'That found These" --- -instance (Show a - , Show (PP p a) - , P p a - ) => P ('That p) (These x a) where - type PP ('That p) (These x a) = PP p a - eval _ opts th = do - let msg0 = "'That" - case th of - That a -> do - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right b -> mkNode opts (_tBool pp) [show01' opts msg0 b "That " a] [hh pp] - _ -> pure $ mkNode opts (FailT (msg0 <> " found " <> showThese th)) [msg0 <> " found " <> showThese th] [] - - --- | extracts the (a,b) from type level 'These a b' if the value exists --- --- >>> pl @('These Id Id) (These 123 "abc") --- Present (123,"abc") --- PresentT (123,"abc") --- --- >>> pl @('These Id 5) (These 123 "abcde") --- Present (123,5) --- PresentT (123,5) --- --- >>> pl @('These Id Id) (This "aaa") --- Error 'These found This --- FailT "'These found This" --- --- >>> pl @('These Id Id) (That "aaa") --- Error 'These found That --- FailT "'These found That" --- -instance (Show a - , Show b - , P p a - , P q b - , Show (PP p a) - , Show (PP q b) - ) => P ('These p q) (These a b) where - type PP ('These p q) (These a b) = (PP p a, PP q b) - eval _ opts th = do - let msg0 = "'These" - case th of - These a b -> do - pp <- eval (Proxy @p) opts a - case getValueLR opts msg0 pp [] of - Left e -> pure e - Right p -> do - qq <- eval (Proxy @q) opts b - pure $ case getValueLR opts (msg0 <> " q failed p=" <> show p) qq [hh pp] of - Left e -> e - Right q -> - let ret =(p,q) - in mkNode opts (PresentT ret) [show01 opts msg0 ret (These a b)] [hh pp, hh qq] - _ -> pure $ mkNode opts (FailT (msg0 <> " found " <> showThese th)) [msg0 <> " found " <> showThese th] [] - --- | converts the value to the corresponding 'Proxy' --- --- >>> pl @'Proxy 'x' --- Present Proxy --- PresentT Proxy --- -instance Show a => P 'Proxy a where - type PP 'Proxy a = Proxy a - eval _ opts a = - let b = Proxy @a - in pure $ mkNode opts (PresentT b) ["'Proxy" <> show1 opts " | " a] [] - --- End non-Type kinds ------------------------ - -pe, pe2, pe2n, pu, pun, pe3, pl, plc :: forall p a . (Show (PP p a), P p a) => a -> IO (BoolT (PP p a)) --- | displays the evaluation tree in plain text without colors -pe = peWith @p o0 --- | displays the evaluation tree using colors -pe2 = peWith @p o2 --- | same as 'pe2' but truncates the display tree horizontally: see 'o2n' -pe2n = peWith @p o2n -pe3 = peWith @p o3 --- | skips the evaluation tree and just displays the end result -pl = peWith @p ol --- | same as 'pl' but with colors -plc = peWith @p olc --- | display the evaluation tree using unicode and colors --- @ --- pu @'(Id, "abc", 123) [1..4] --- @ -pu = peWith @p ou --- | same as 'pu' but truncates the display tree horizontally: see 'ou' -pun = peWith @p oun - -peWith :: forall p a - . (Show (PP p a), P p a) - => POpts - -> a - -> IO (BoolT (PP p a)) -peWith opts a = do - pp <- eval (Proxy @p) opts a - let r = pp ^. tBool - if oLite opts then - let f = colorMe opts (r ^. boolT2P) - in putStrLn $ case r of - FailT e -> f "Error" <> " " <> e - TrueT -> f "True" - FalseT -> f "False" - PresentT x -> f "Present" <> " " <> show x - else prtTree opts (fromTT pp) - return r - -runPQ :: (P p a, P q a, MonadEval m) - => String - -> Proxy p - -> Proxy q - -> POpts - -> a - -> m (Either (TT x) (PP p a, PP q a, TT (PP p a), TT (PP q a))) -runPQ msg0 proxyp proxyq opts a = do - pp <- eval proxyp opts a - case getValueLR opts msg0 pp [] of - Left e -> pure $ Left e - Right p -> do - qq <- eval proxyq opts a - pure $ case getValueLR opts msg0 qq [hh pp] of - Left e -> Left e - Right q -> Right (p, q, pp, qq) - -
− src/Refined.hs
@@ -1,410 +0,0 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wcompat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NoStarIsType #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE DeriveLift #-} --- | --- Module : Refined --- Description : Simple refinement type with only one type and a predicate --- Copyright : (c) Grant Weyburne, 2019 --- License : BSD-3 --- Maintainer : gbwey9@gmail.com --- -module Refined ( - Refined(unRefined) - , RefinedC - , arbRefined - , rapply - , rapply0 - , rapply1 - , convertRefinedT - , withRefinedT - , withRefinedTIO - , newRefined - , prtRefinedIO - , newRefinedT - , newRefinedTIO - , RefinedT(..) - , prtRefinedTIO - , prtRefinedT - , unRavelT - , unRavelTIO - , unRavelTI - , unsafeRefined - , unsafeRefined' - ) where -import Predicate -import Control.Lens ((^.)) -import Data.Functor.Identity (Identity(..)) -import Data.Proxy -import Control.Monad.Except -import Control.Monad.Writer (WriterT(..), runWriterT, MonadWriter, tell) -import Control.Monad.Cont -import Data.Aeson -import GHC.Generics (Generic) -import qualified Language.Haskell.TH.Syntax as TH -import System.Console.Pretty -import Test.QuickCheck -import qualified GHC.Read as GR -import qualified Text.ParserCombinators.ReadPrec as PCR -import qualified Text.Read.Lex as RL -import qualified Data.Binary as B -import Data.Binary (Binary) --- | a simple refinement type that ensures the predicate \'p\' holds for the type \'a\' --- --- >>> :m + Data.Time.Calendar.WeekDate --- >>> prtRefinedIO @(Between 10 14) ol 13 --- Right (Refined {unRefined = 13}) --- --- >>> prtRefinedIO @(Between 10 14) ol 99 --- Left FalseP --- --- >>> prtRefinedIO @(Last >> Len == 4) ol ["one","two","three","four"] --- Right (Refined {unRefined = ["one","two","three","four"]}) --- --- >>> prtRefinedIO @(Re "^\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}$" Id) ol "141.213.1.99" --- Right (Refined {unRefined = "141.213.1.99"}) --- --- >>> prtRefinedIO @(Re "^\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}$" Id) ol "141.213.1" --- Left FalseP --- --- >>> prtRefinedIO @(Map (ReadP Int) (Resplit "\\." Id) >> Guard (Printf "bad length: found %d" Len) (Len == 4) >> 'True) ol "141.213.1" --- Left (FailP "bad length: found 3") --- --- >>> prtRefinedIO @(Map (ReadP Int) (Resplit "\\." Id) >> Guard (Printf "bad length: found %d" Len) (Len == 4) >> GuardsN (Printf2 "octet %d out of range %d") 4 (Between 0 255) >> 'True) ol "141.213.1.444" --- Left (FailP "octet 4 out of range 444") --- --- >>> prtRefinedIO @(Map (ReadP Int) (Resplit "\\." Id) >> Guard (Printf "bad length: found %d" Len) (Len == 4) >> GuardsN (Printf2 "octet %d out of range %d") 4 (Between 0 255) >> 'True) ol "141.213.1x34.444" --- Left (FailP "ReadP Int (1x34) failed") --- --- >>> prtRefinedIO @(Map ('[Id] >> ReadP Int) Id >> Luhn Id) ol "12344" --- Right (Refined {unRefined = "12344"}) --- --- >>> prtRefinedIO @(Map ('[Id] >> ReadP Int) Id >> Luhn Id) ol "12340" --- Left FalseP --- --- >>> prtRefinedIO @(Any (Prime Id) Id) ol [11,13,17,18] --- Right (Refined {unRefined = [11,13,17,18]}) --- --- >>> prtRefinedIO @(All (Prime Id) Id) ol [11,13,17,18] --- Left FalseP --- --- >>> prtRefinedIO @(Snd Id !! Fst Id >> Len > 5) ol (2,["abc","defghij","xyzxyazsfd"]) --- Right (Refined {unRefined = (2,["abc","defghij","xyzxyazsfd"])}) --- --- >>> prtRefinedIO @(Snd Id !! Fst Id >> Len > 5) ol (27,["abc","defghij","xyzxyazsfd"]) --- Left (FailP "(!!) index not found") --- --- >>> prtRefinedIO @(Snd Id !! Fst Id >> Len <= 5) ol (2,["abc","defghij","xyzxyazsfd"]) --- Left FalseP -newtype Refined p a = Refined { unRefined :: a } deriving (Show, Eq, Generic, TH.Lift) - --- | 'Read' instance for 'Refined' --- --- >>> :set -XOverloadedStrings --- >>> reads @(Refined (Between 0 255) Int) "Refined {unRefined = 254}" --- [(Refined {unRefined = 254},"")] --- --- >>> reads @(Refined (Between 0 255) Int) "Refined {unRefined = 300}" --- [] --- -instance (RefinedC p a, Read a) => Read (Refined p a) where - readPrec - = GR.parens - (PCR.prec - 11 - (do GR.expectP (RL.Ident "Refined") - GR.expectP (RL.Punc "{") - fld0 <- GR.readField - "unRefined" - (PCR.reset GR.readPrec) - GR.expectP (RL.Punc "}") - let (_,mr) = runIdentity $ newRefined @p ol fld0 - case mr of - Nothing -> fail "" - Just _r -> pure (Refined fld0) - )) - readList = GR.readListDefault - readListPrec = GR.readListPrecDefault - --- | the constraints that 'Refined' must adhere to -type RefinedC p a = (PP p a ~ Bool, P p a) - --- | 'ToJSON' instance for 'Refined' -instance ToJSON a => ToJSON (Refined p a) where - toJSON = toJSON . unRefined - --- | 'FromJSON' instance for 'Refined' --- --- >>> :set -XOverloadedStrings --- >>> eitherDecode' @(Refined (Between 10 14) Int) "13" --- Right (Refined {unRefined = 13}) --- --- >>> removeAnsiForDocTest $ eitherDecode' @(Refined (Between 10 14) Int) "16" --- Error in $: Refined:FalseP --- False True && False --- | --- +- True 16 >= 10 --- | | --- | +- P I --- | | --- | `- P '10 --- | --- `- False 16 <= 14 --- | --- +- P I --- | --- `- P '14 --- <BLANKLINE> --- -instance (RefinedC p a, FromJSON a) => FromJSON (Refined p a) where - parseJSON z = do - a <- parseJSON z - let ((bp,e),mr) = runIdentity $ newRefined @p o2 a - case mr of - Nothing -> fail $ "Refined:" ++ show bp ++ "\n" ++ e - Just r -> return r - --- | 'Binary' instance for 'Refined' --- --- >>> import Data.Time --- >>> import Control.Lens --- >>> import Control.Arrow ((+++)) --- >>> type K1 = Refined (ReadP Day >> 'True) String --- >>> type K2 = Refined (ReadP Day >> Between (ReadP' Day "2019-03-30") (ReadP' Day "2019-06-01")) String --- >>> type K3 = Refined (ReadP Day >> Between (ReadP' Day "2019-05-30") (ReadP' Day "2019-06-01")) String --- >>> r = unsafeRefined' ol "2019-04-23" :: K1 --- >>> removeAnsiForDocTest $ (view _3 +++ view _3) $ B.decodeOrFail @K1 (B.encode r) --- Refined {unRefined = "2019-04-23"} --- --- >>> removeAnsiForDocTest $ (view _3 +++ view _3) $ B.decodeOrFail @K2 (B.encode r) --- Refined {unRefined = "2019-04-23"} --- --- >>> removeAnsiForDocTest $ (view _3 +++ view _3) $ B.decodeOrFail @K3 (B.encode r) --- Refined:FalseP --- False >> False | 2019-04-23 --- | --- +- P ReadP Day (2019-04-23) 2019-04-23 | 2019-04-23 --- | | --- | `- P Id "2019-04-23" --- | --- `- False False && True --- | --- +- False 2019-04-23 >= 2019-05-30 --- | | --- | +- P I --- | | --- | `- P ReadP Day (2019-05-30) 2019-05-30 | 2019-05-30 --- | | --- | `- P '2019-05-30 --- | --- `- True 2019-04-23 <= 2019-06-01 --- | --- +- P I --- | --- `- P ReadP Day (2019-06-01) 2019-06-01 | 2019-06-01 --- | --- `- P '2019-06-01 --- <BLANKLINE> --- -instance (RefinedC p a, Binary a) => Binary (Refined p a) where - get = do - fld0 <- B.get @a - let ((bp,e),mr) = runIdentity $ newRefined @p o2 fld0 - case mr of - Nothing -> fail $ "Refined:" ++ show bp ++ "\n" ++ e - Just r -> return r - put (Refined r) = B.put @a r - --- | 'arbitrary' value for 'Refined' -arbRefined :: forall p a. - ( Arbitrary a - , RefinedC p a - ) => POpts -> Gen (Refined p a) -arbRefined opts = suchThatMap (arbitrary @a) (snd . runIdentity . newRefined @p opts) - --- | binary operation applied to two 'RefinedT' values -rapply :: forall m p a . (RefinedC p a, Monad m) - => POpts - -> (a -> a -> a) - -> RefinedT m (Refined p a) - -> RefinedT m (Refined p a) - -> RefinedT m (Refined p a) -rapply opts f ma mb = do - tell [bgColor Blue "=== a ==="] - Refined x <- ma - tell [bgColor Blue "=== b ==="] - Refined y <- mb - tell [bgColor Blue "=== a `op` b ==="] - newRefinedT opts (f x y) - --- | takes two values and lifts them into 'RefinedT' and then applies the binary operation -rapply0 :: forall p a m . (RefinedC p a, Monad m) - => POpts - -> (a -> a -> a) - -> a - -> a - -> RefinedT m (Refined p a) -rapply0 opts f a b = rapply opts f (newRefinedT opts a) (newRefinedT opts b) - --- | same as 'rapply' except we already have valid 'Refined' values as input -rapply1 :: forall m p a . (RefinedC p a, Monad m) - => POpts - -> (a -> a -> a) - -> Refined p a - -> Refined p a - -> RefinedT m (Refined p a) -rapply1 opts f (Refined a) (Refined b) = newRefinedT opts (f a b) - --- | attempts to lift a refinement type to another refinement type by way of transformation function --- you can control both the predicate and the type -convertRefinedT :: forall m p p1 a a1 - . ( RefinedC p1 a1 - , Monad m) - => POpts - -> (a -> a1) - -> RefinedT m (Refined p a) - -> RefinedT m (Refined p1 a1) -convertRefinedT opts f ma = do - Refined a <- ma -- you already got a refined in there so no need to check RefinedC - newRefinedT @p1 opts (f a) - --- | invokes the callback with the 'Refined' value if \'a\' is valid for the predicate \'p\' -withRefinedT :: forall p m a b - . (Monad m, RefinedC p a) - => POpts - -> a - -> (Refined p a -> RefinedT m b) - -> RefinedT m b -withRefinedT opts a k = newRefinedT @p opts a >>= k - -withRefinedTIO :: forall p m a b - . (MonadIO m, RefinedC p a) - => POpts - -> a - -> (Refined p a -> RefinedT m b) - -> RefinedT m b -withRefinedTIO opts a k = newRefinedTIO @p opts a >>= k - --- | same as 'newRefined' but prints the results -prtRefinedIO :: forall p a - . RefinedC p a - => POpts - -> a - -> IO (Either BoolP (Refined p a)) -prtRefinedIO opts a = do - tt <- evalBool (Proxy @p) opts a - let msg = (_tBool tt ^. boolT2P, prtTreePure opts (fromTT tt)) - unless (oLite opts) $ putStrLn $ snd msg - pure $ case getValueLR opts "" tt [] of - Right True -> Right (Refined a) - _ -> Left (fst msg) - --- | returns a 'Refined' value if \'a\' is valid for the predicate \'p\' -newRefined :: forall p a m . (MonadEval m, RefinedC p a) - => POpts - -> a - -> m ((BoolP, String), Maybe (Refined p a)) -newRefined opts a = do - tt <- evalBool (Proxy @p) opts a - let msg = (_tBool tt ^. boolT2P, prtTreePure opts (fromTT tt)) - pure $ (msg,) $ case getValueLR opts "" tt [] of - Right True -> Just (Refined a) - _ -> Nothing - -newRefinedTImpl :: forall p a n m . (RefinedC p a, Monad m, MonadEval n) - => (forall x . n x -> RefinedT m x) - -> POpts - -> a - -> RefinedT m (Refined p a) -newRefinedTImpl f opts a = do - tt <- f $ evalBool (Proxy @p) opts a - let msg = prtTreePure opts (fromTT tt) - tell [msg] - case getValueLR opts "" tt [] of - Right True -> return (Refined a) -- FalseP is also a failure! - _ -> let rc = show (_tBool tt ^. boolT2P) - in throwError rc -- RefinedT $ ExceptT $ WriterT $ return (Left rc, []) - --- | returns a wrapper 'RefinedT' around a possible 'Refined' value if \'a\' is valid for the predicate \'p\' -newRefinedT :: forall p a m - . ( RefinedC p a - , Monad m) - => POpts - -> a - -> RefinedT m (Refined p a) -newRefinedT = newRefinedTImpl (return . runIdentity) - -newRefinedTIO :: forall p a m - . ( RefinedC p a - , MonadIO m) - => POpts - -> a - -> RefinedT m (Refined p a) -newRefinedTIO = newRefinedTImpl liftIO - -newtype RefinedT m a = RefinedT { unRefinedT :: ExceptT String (WriterT [String] m) a } - deriving (Functor, Applicative, Monad, MonadCont, MonadWriter [String], Show, MonadIO) - deriving MonadTrans via RefinedT - -instance Monad m => MonadError String (RefinedT m) where - throwError e = RefinedT $ ExceptT $ WriterT $ return (Left e,[]) - catchError (RefinedT (ExceptT (WriterT ma))) ema = - RefinedT $ ExceptT $ WriterT $ do - (lr,ss) <- ma - case lr of - Left e -> unRavelT (tell ss >> ema e) -- keep the old messages?? - Right _ -> ma - -unRavelT :: RefinedT m a -> m (Either String a, [String]) -unRavelT = runWriterT . runExceptT . unRefinedT - -unRavelTIO :: RefinedT IO a -> IO (Either String a, [String]) -unRavelTIO = runWriterT . runExceptT . unRefinedT - -unRavelTI :: RefinedT Identity a -> (Either String a, [String]) -unRavelTI = runIdentity . runWriterT . runExceptT . unRefinedT - -prtRefinedTImpl :: forall n m a . (MonadIO n, Show a) => (forall x . m x -> n x) -> RefinedT m a -> n () -prtRefinedTImpl f rt = do - (lr,ws) <- f $ unRavelT rt - liftIO $ do - forM_ (zip [1::Int ..] ws) $ \(_,y) -> putStrLn y - case lr of - Left e -> putStrLn $ "failure msg[" <> e <> "]" - Right a -> print a - -prtRefinedTIO :: (MonadIO m, Show a) => RefinedT m a -> m () -prtRefinedTIO = prtRefinedTImpl id - -prtRefinedT :: (MonadIO m, Show a) => RefinedT Identity a -> m () -prtRefinedT = prtRefinedTImpl (return . runIdentity) - --- | a way to unsafely create a 'Refined' value -unsafeRefined :: forall p a . a -> Refined p a -unsafeRefined = Refined - --- | a way to unsafely create a 'Refined' value but run the predicate -unsafeRefined' :: forall p a . RefinedC p a => POpts -> a -> Refined p a -unsafeRefined' opts a = - let tt = runIdentity $ evalBool (Proxy @p) opts a - in case getValueLR opts "" tt [] of - Right True -> Refined a - _ -> error $ prtTreePure opts (fromTT tt)
− src/Refined3.hs
@@ -1,729 +0,0 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wcompat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wno-redundant-constraints #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE NoStarIsType #-} -{-# LANGUAGE DeriveLift #-} -{- | -Module : Refined3 -Description : Refinement type allowing the external type to differ from the internal type -Copyright : (c) Grant Weyburne, 2019 -License : BSD-3 -Maintainer : gbwey9@gmail.com - -see 'Refined3' -contains Json and Read instances and arbitrary functions --} -module Refined3 ( - Refined3(r3In,r3Out) - , Refined3C - , mkProxy3 - , mkProxy3P - , MkProxy3T - , withRefined3TIO - , withRefined3T - , withRefined3TP - , newRefined3T - , newRefined3TP - , newRefined3TPIO - , convertRefined3T - , convertRefined3TP - , rapply3 - , rapply3P - , prtEval3P - , prtEval3PIO - , prtEval3 - , eval3P - , eval3 - , eval3M - , eval3PX - , eval3X - , prt3IO - , prt3 - , arbRefined3 - , arbRefined3With - , Msg3 (..) - , prt3Impl - , MakeR3 - , Results (..) - , RResults (..) - , unsafeRefined3 - , unsafeRefined3' - ) where -import Refined -import Predicate -import Data.Functor.Identity (Identity(..)) -import Data.Tree -import Data.Proxy -import Control.Monad.Except -import Control.Monad.Writer (tell) -import Data.Aeson -import qualified Language.Haskell.TH.Syntax as TH -import System.Console.Pretty -import Test.QuickCheck -import qualified GHC.Read as GR -import qualified Text.ParserCombinators.ReadPrec as PCR -import qualified Text.Read.Lex as RL -import qualified Data.Binary as B -import Data.Binary (Binary) -import Data.Maybe (fromMaybe) --- | Refinement type that differentiates the input type from output type --- --- @ --- \'i\' is the input type --- \'ip\' converts i to PP ip i which is the internal type --- \'op\' validates that internal type using PP op (PP ip i) ~ Bool --- \'fmt\' outputs the internal type PP fmt (PP ip i) ~ i --- PP fmt (PP ip i) should be valid input to Refined3 --- @ --- --- If we fix the input type to String then it looks similar to: --- 1. read into an internal type --- 2. validate internal type with a predicate function --- 3. show/format the internal type --- --- Although the most common scenario is String as input, you are free to choose any input type you like --- --- >>> :m + Data.Time.Calendar.WeekDate --- >>> prtEval3 @(ReadBase Int 16) @(Lt 255) @(Printf "%x" Id) ol "00fe" --- Right (Refined3 {r3In = 254, r3Out = "fe"}) --- --- >>> prtEval3 @(ReadBase Int 16) @(Lt 253) @(Printf "%x" Id) ol "00fe" --- Left Step 2. False Boolean Check(op) | FalseP --- --- >>> prtEval3 @(ReadBase Int 16) @(Lt 255) @(Printf "%x" Id) ol "00fg" --- Left Step 1. Initial Conversion(ip) Failed | invalid base 16 --- --- >>> prtEval3 @(Map (ReadP Int) (Resplit "\\." Id)) @(Guard (Printf "found length=%d" Len) (Len >> Id == 4) >> 'True) @(Printfnt 4 "%03d.%03d.%03d.%03d") ol "198.162.3.1.5" --- Left Step 2. Failed Boolean Check(op) | found length=5 --- --- >>> prtEval3 @(Map (ReadP Int) (Resplit "\\." Id)) @(Guard (Printf "found length=%d" Len) (Len >> Id == 4) >> 'True) @(Printfnt 4 "%03d.%03d.%03d.%03d") ol "198.162.3.1" --- Right (Refined3 {r3In = [198,162,3,1], r3Out = "198.162.003.001"}) --- --- >>> prtEval3 @(MkDay >> 'Just Id) @(Guard "expected a Sunday" (Thd Id == 7) >> 'True) @(UnMkDay (Fst Id)) ol (2019,10,13) --- Right (Refined3 {r3In = (2019-10-13,41,7), r3Out = (2019,10,13)}) --- --- >>> prtEval3 @(MkDay' (Fst Id) (Snd Id) (Thd Id) >> 'Just Id) @(Guard "expected a Sunday" (Thd Id == 7) >> 'True) @(UnMkDay (Fst Id)) ol (2019,10,12) --- Left Step 2. Failed Boolean Check(op) | expected a Sunday --- --- >>> type T4 k = '(MkDay >> 'Just Id, Guard "expected a Sunday" (Thd Id == 7) >> 'True, UnMkDay (Fst Id), k) --- >>> prtEval3P (Proxy @(T4 _)) ol (2019,10,12) --- Left Step 2. Failed Boolean Check(op) | expected a Sunday --- --- >>> prtEval3P (Proxy @(T4 _)) ol (2019,10,13) --- Right (Refined3 {r3In = (2019-10-13,41,7), r3Out = (2019,10,13)}) --- -data Refined3 ip op fmt i = Refined3 { r3In :: PP ip i, r3Out :: PP fmt (PP ip i) } - --- | directly load values into 'Refined3'. It still checks to see that those values are valid -unsafeRefined3' :: forall ip op fmt i - . (Show i, Show (PP ip i), Refined3C ip op fmt i) - => POpts - -> i - -> Refined3 ip op fmt i -unsafeRefined3' opts i = - let (ret,mr) = eval3 @ip @op @fmt opts i - in fromMaybe (error $ show (prt3Impl opts ret)) mr - --- | directly load values into 'Refined3' without any checking -unsafeRefined3 :: forall ip op fmt i . PP ip i -> PP fmt (PP ip i) -> Refined3 ip op fmt i -unsafeRefined3 = Refined3 - - --- | Provides the constraints on Refined3 -type Refined3C ip op fmt i = - ( P ip i - , P op (PP ip i) - , PP op (PP ip i) ~ Bool -- the internal value needs to pass the predicate check - , P fmt (PP ip i) - , PP fmt (PP ip i) ~ i -- the output type must match the original input type - ) - -deriving instance (Show i, Show (PP ip i), Show (PP fmt (PP ip i))) => Show (Refined3 ip op fmt i) -deriving instance (Eq i, Eq (PP ip i), Eq (PP fmt (PP ip i))) => Eq (Refined3 ip op fmt i) -deriving instance (TH.Lift (PP ip i), TH.Lift (PP fmt (PP ip i))) => TH.Lift (Refined3 ip op fmt i) - --- read instance from -ddump-deriv --- | 'Read' instance for 'Refined3' --- --- >>> :set -XOverloadedStrings --- >>> reads @(Refined3 (ReadBase Int 16) (Between 0 255) (ShowBase 16) String) "Refined3 {r3In = 254, r3Out = \"fe\"}" --- [(Refined3 {r3In = 254, r3Out = "fe"},"")] --- --- >>> reads @(Refined3 (ReadBase Int 16) (Between 0 255) (ShowBase 16) String) "Refined3 {r3In = 300, r3Out = \"12c\"}" --- [] --- --- >>> reads @(Refined3 (ReadBase Int 16) (Id < 0) (ShowBase 16) String) "Refined3 {r3In = -1234, r3Out = \"-4d2\"}" --- [(Refined3 {r3In = -1234, r3Out = "-4d2"},"")] --- --- >>> reads @(Refined3 (Map (ReadP Int) (Resplit "\\." Id)) (Guard "len/=4" (Len == 4) >> 'True) (Printfnt 4 "%d.%d.%d.%d") String) "Refined3 {r3In = [192,168,0,1], r3Out = \"192.168.0.1\"}" --- [(Refined3 {r3In = [192,168,0,1], r3Out = "192.168.0.1"},"")] --- -instance (Eq i, Show i, Show (PP ip i), Refined3C ip op fmt i, Read (PP ip i), Read (PP fmt (PP ip i))) => Read (Refined3 ip op fmt i) where - readPrec - = GR.parens - (PCR.prec - 11 - (do GR.expectP (RL.Ident "Refined3") - GR.expectP (RL.Punc "{") - fld1 <- GR.readField - "r3In" (PCR.reset GR.readPrec) - GR.expectP (RL.Punc ",") - fld2 <- GR.readField - "r3Out" (PCR.reset GR.readPrec) - GR.expectP (RL.Punc "}") - - let (_ret,mr) = runIdentity $ eval3MSkip @_ @ip @op @fmt o2 fld1 - case mr of - Nothing -> fail "" -- show (prt3Impl o2 _ret) - Just (Refined3 _r1 r2) | r2 == fld2 -> pure (Refined3 fld1 fld2) - | otherwise -> fail "" -- "mismatch on r3Out fmt: found (" ++ show fld2 ++ ") but expected(" ++ show r2 ++ ")" - )) - readList = GR.readListDefault - readListPrec = GR.readListPrecDefault - --- | 'ToJSON' instance for 'Refined3' --- --- >>> :set -XOverloadedStrings --- >>> encode (unsafeRefined3 @(ReadBase Int 16) @(Between 0 255) @(ShowBase 16) 254 "fe") --- "\"fe\"" --- --- >>> encode (unsafeRefined3 @Id @'True @Id 123 123) --- "123" --- -instance ToJSON (PP fmt (PP ip i)) => ToJSON (Refined3 ip op fmt i) where - toJSON = toJSON . r3Out - - --- | 'FromJSON' instance for 'Refined3' --- --- >>> :set -XOverloadedStrings --- >>> eitherDecode' @(Refined3 (ReadBase Int 16) (Id > 10 && Id < 256) (ShowBase 16) String) "\"00fe\"" --- Right (Refined3 {r3In = 254, r3Out = "fe"}) --- --- >>> removeAnsiForDocTest $ eitherDecode' @(Refined3 (ReadBase Int 16) (Id > 10 && Id < 256) (ShowBase 16) String) "\"00fe443a\"" --- Error in $: Refined3:Step 2. False Boolean Check(op) | FalseP --- <BLANKLINE> --- *** Step 1. Success Initial Conversion(ip) [16663610] *** --- <BLANKLINE> --- P ReadBase(Int,16) 16663610 | "00fe443a" --- | --- `- P Id "00fe443a" --- <BLANKLINE> --- *** Step 2. False Boolean Check(op) *** --- <BLANKLINE> --- False True && False --- | --- +- True 16663610 > 10 --- | | --- | +- P Id 16663610 --- | | --- | `- P '10 --- | --- `- False 16663610 < 256 --- | --- +- P Id 16663610 --- | --- `- P '256 --- <BLANKLINE> --- -instance (Show (PP fmt (PP ip i)), Show (PP ip i), Refined3C ip op fmt i, FromJSON i) => FromJSON (Refined3 ip op fmt i) where - parseJSON z = do - i <- parseJSON @i z - let (ret,mr) = eval3 @ip @op @fmt o2 i - case mr of - Nothing -> fail $ "Refined3:" ++ show (prt3Impl o2 ret) - Just r -> return r - -{- -instance (Arbitrary (PP ip i) - , Show (PP ip i) - , Show i - , Refined3C ip op fmt i - ) => Arbitrary (Refined3 ip op fmt i) where - arbitrary = suchThatMap (arbitrary @(PP ip i)) $ eval3MQuickIdentity @ip @op @fmt o2 --} -arbRefined3 :: forall ip op fmt i . - ( Arbitrary (PP ip i) - , Refined3C ip op fmt i - ) => Proxy '(ip,op,fmt,i) -> POpts -> Gen (Refined3 ip op fmt i) -arbRefined3 _ = suchThatMap (arbitrary @(PP ip i)) . eval3MQuickIdentity @ip @op @fmt - --- help things along a little -arbRefined3With :: - forall ip op fmt i - . (Arbitrary (PP ip i) - , Refined3C ip op fmt i) - => Proxy '(ip,op,fmt,i) - -> POpts - -> (PP ip i -> PP ip i) - -> Gen (Refined3 ip op fmt i) -arbRefined3With _ opts f = - suchThatMap (f <$> arbitrary @(PP ip i)) $ eval3MQuickIdentity @ip @op @fmt opts - --- | 'Binary' instance for 'Refined3' --- --- >>> import Control.Arrow ((+++)) --- >>> import Control.Lens --- >>> import Data.Time --- >>> type K1 = MakeR3 '(ReadP Day, 'True, ShowP Id, String) --- >>> type K2 = MakeR3 '(ReadP Day, Between (ReadP' Day "2019-03-30") (ReadP' Day "2019-06-01"), ShowP Id, String) --- >>> type K3 = MakeR3 '(ReadP Day, Between (ReadP' Day "2019-05-30") (ReadP' Day "2019-06-01"), ShowP Id, String) --- >>> r = unsafeRefined3' ol "2019-04-23" :: K1 --- >>> removeAnsiForDocTest $ (view _3 +++ view _3) $ B.decodeOrFail @K1 (B.encode r) --- Refined3 {r3In = 2019-04-23, r3Out = "2019-04-23"} --- --- >>> removeAnsiForDocTest $ (view _3 +++ view _3) $ B.decodeOrFail @K2 (B.encode r) --- Refined3 {r3In = 2019-04-23, r3Out = "2019-04-23"} --- --- >>> removeAnsiForDocTest $ (view _3 +++ view _3) $ B.decodeOrFail @K3 (B.encode r) --- Refined3:Step 2. False Boolean Check(op) | FalseP --- <BLANKLINE> --- *** Step 1. Success Initial Conversion(ip) [2019-04-23] *** --- <BLANKLINE> --- P ReadP Day (2019-04-23) 2019-04-23 | 2019-04-23 --- | --- `- P Id "2019-04-23" --- <BLANKLINE> --- *** Step 2. False Boolean Check(op) *** --- <BLANKLINE> --- False False && True --- | --- +- False 2019-04-23 >= 2019-05-30 --- | | --- | +- P I --- | | --- | `- P ReadP Day (2019-05-30) 2019-05-30 | 2019-05-30 --- | | --- | `- P '2019-05-30 --- | --- `- True 2019-04-23 <= 2019-06-01 --- | --- +- P I --- | --- `- P ReadP Day (2019-06-01) 2019-06-01 | 2019-06-01 --- | --- `- P '2019-06-01 --- <BLANKLINE> --- -instance (Show (PP fmt (PP ip i)), Show (PP ip i), Refined3C ip op fmt i, Binary i) => Binary (Refined3 ip op fmt i) where - get = do - i <- B.get @i - let (ret,mr) = eval3 @ip @op @fmt o2 i - case mr of - Nothing -> fail $ "Refined3:" ++ show (prt3Impl o2 ret) - Just r -> return r - put (Refined3 _ r) = B.put @i r - --- | wraps the parameters for 'Refined3' in a 4-tuple for use with methods such as 'withRefined3TP' and 'newRefined3TP' -mkProxy3 :: forall ip op fmt i . Refined3C ip op fmt i => Proxy '(ip,op,fmt,i) -mkProxy3 = Proxy - --- | use type application to set the parameters then it will be wrapped into a 4-tuple --- checks to make sure the proxy is consistent with Refined3C --- use for passing into eval3P you can pass in a promoted 4 tuple to other methods -mkProxy3P :: forall z ip op fmt i . (z ~ '(ip,op,fmt,i), Refined3C ip op fmt i) => Proxy '(ip,op,fmt,i) -mkProxy3P = Proxy - --- | convenience type family for converting from a 4-tuple '(ip,op,fmt,i) to a 'Refined3' signature -type family MakeR3 p where - MakeR3 '(ip,op,fmt,i) = Refined3 ip op fmt i - --- | convenience type family for converting from a 4-tuple '(ip,op,fmt,i) to a Proxy -type family MkProxy3T p where - MkProxy3T '(ip,op,fmt,i) = Proxy '(ip,op,fmt,i) - -withRefined3TIO :: forall ip op fmt i m b - . (MonadIO m, Refined3C ip op fmt i, Show (PP ip i), Show i) - => POpts - -> i - -> (Refined3 ip op fmt i -> RefinedT m b) - -> RefinedT m b -withRefined3TIO opts = (>>=) . newRefined3TPIO (Proxy @'(ip,op,fmt,i)) opts - -withRefined3T :: forall ip op fmt i m b - . (Monad m, Refined3C ip op fmt i, Show (PP ip i), Show i) - => POpts - -> i - -> (Refined3 ip op fmt i -> RefinedT m b) - -> RefinedT m b -withRefined3T opts = (>>=) . newRefined3TP (Proxy @'(ip,op,fmt,i)) opts - -withRefined3TP :: forall ip op fmt i m b proxy - . (Monad m, Refined3C ip op fmt i, Show (PP ip i), Show i) - => proxy '(ip,op,fmt,i) - -> POpts - -> i - -> (Refined3 ip op fmt i -> RefinedT m b) - -> RefinedT m b -withRefined3TP p opts = (>>=) . newRefined3TP p opts - -newRefined3T :: forall m ip op fmt i . (Refined3C ip op fmt i, Monad m, Show (PP ip i), Show i) - => POpts - -> i - -> RefinedT m (Refined3 ip op fmt i) -newRefined3T = newRefined3TP (Proxy @'(ip,op,fmt,i)) - -newRefined3TP :: forall m ip op fmt i proxy - . (Refined3C ip op fmt i, Monad m, Show (PP ip i), Show i) - => proxy '(ip,op,fmt,i) - -> POpts - -> i - -> RefinedT m (Refined3 ip op fmt i) -newRefined3TP = newRefined3TPImpl (return . runIdentity) - -newRefined3TPIO :: forall m ip op fmt i proxy - . (Refined3C ip op fmt i, MonadIO m, Show (PP ip i), Show i) - => proxy '(ip,op,fmt,i) - -> POpts - -> i - -> RefinedT m (Refined3 ip op fmt i) -newRefined3TPIO = newRefined3TPImpl liftIO - --- we call this cos we need to do the bool check and get fmt value --- eval (PP op i) ~ True and eval (PP fmt i) to get the other value --- input is set to @Id meaning that PP fmt (PP ip i) /= i doesnt hold -newRefined3TPImpl :: forall n m ip op fmt i proxy - . (Refined3C ip op fmt i, Monad m, MonadEval n, Show (PP ip i), Show (PP fmt (PP ip i))) - => (forall x . n x -> RefinedT m x) - -> proxy '(ip,op,fmt,i) - -> POpts - -> i - -> RefinedT m (Refined3 ip op fmt i) -newRefined3TPImpl f _ opts i = do - (ret,mr) <- f $ eval3M opts i - let m3 = prt3Impl opts ret - tell [m3Long m3] - case mr of - Nothing -> throwError $ m3Desc m3 <> " | " <> m3Short m3 - Just r -> return r - -newRefined3TPSkipIPImpl :: forall n m ip op fmt i proxy - . (Refined3C ip op fmt i - , Monad m - , MonadEval n - , Show (PP ip i) - , Show (PP fmt (PP ip i))) - => (forall x . n x -> RefinedT m x) - -> proxy '(ip,op,fmt,i) - -> POpts - -> PP ip i - -> RefinedT m (Refined3 ip op fmt i) -newRefined3TPSkipIPImpl f _ opts a = do - (ret,mr) <- f $ eval3MSkip opts a - let m3 = prt3Impl opts ret - tell [m3Long m3] - case mr of - Nothing -> throwError $ m3Desc m3 <> " | " <> m3Short m3 - Just r -> return r - --- optional Refined3C ip op fmt i [not required!] -convertRefined3T :: forall m ip op fmt i ip1 op1 fmt1 i1 . - ( Refined3C ip1 op1 fmt1 i1 - , Monad m - , Show (PP ip i) - , PP ip i ~ PP ip1 i1 - , Show i1) - => POpts - -> RefinedT m (Refined3 ip op fmt i) - -> RefinedT m (Refined3 ip1 op1 fmt1 i1) -convertRefined3T opts ma = do - Refined3 x _ <- ma - -- we skip the input value @Id and go straight to the internal value so PP fmt (PP ip i) /= i for this call - Refined3 a b <- newRefined3TPSkipIPImpl (return . runIdentity) (Proxy @'(ip1, op1, fmt1, i1)) opts x - return (Refined3 a b) - -convertRefined3TP :: forall m ip op fmt i ip1 op1 fmt1 i1 . - ( Refined3C ip1 op1 fmt1 i1 - , Monad m - , Show (PP ip i) - , PP ip i ~ PP ip1 i1 - , Show i1) - => Proxy '(ip, op, fmt, i) - -> Proxy '(ip1, op1, fmt1, i1) - -> POpts - -> RefinedT m (Refined3 ip op fmt i) - -> RefinedT m (Refined3 ip1 op1 fmt1 i1) -convertRefined3TP _ _ opts ma = do - Refined3 x _ <- ma - -- we skip the input value @Id and go straight to the internal value so PP fmt (PP ip i) /= i for this call - Refined3 a b <- newRefined3TPSkipIPImpl (return . runIdentity) (Proxy @'(ip1, op1, fmt1, i1)) opts x - return (Refined3 a b) - -rapply3 :: forall m ip op fmt i . - ( Refined3C ip op fmt i - , Monad m - , Show (PP ip i) - , Show i) - => POpts - -> (PP ip i -> PP ip i -> PP ip i) - -> RefinedT m (Refined3 ip op fmt i) - -> RefinedT m (Refined3 ip op fmt i) - -> RefinedT m (Refined3 ip op fmt i) -rapply3 = rapply3P (Proxy @'(ip,op,fmt,i)) - --- this is the most generic --- prtRefinedT $ rapply3P base16 (+) (newRefined3TP Proxy "ff") (newRefined3TP Proxy "22") -rapply3P :: forall m ip op fmt i proxy . - ( Refined3C ip op fmt i - , Monad m - , Show (PP ip i) - , Show i) - => proxy '(ip,op,fmt,i) - -> POpts - -> (PP ip i -> PP ip i -> PP ip i) - -> RefinedT m (Refined3 ip op fmt i) - -> RefinedT m (Refined3 ip op fmt i) - -> RefinedT m (Refined3 ip op fmt i) -rapply3P p opts f ma mb = do - tell [bgColor Blue "=== a ==="] - Refined3 x _ <- ma - tell [bgColor Blue "=== b ==="] - Refined3 y _ <- mb - -- we skip the input value @Id and go straight to the internal value so PP fmt (PP ip i) /= i for this call - tell [bgColor Blue "=== a `op` b ==="] - Refined3 a b <- newRefined3TPSkipIPImpl (return . runIdentity) p opts (f x y) - return (Refined3 a b) - -data Results a b = - XF String -- Left e - | XTF a String -- Right a + Left e - | XTFalse a -- Right a + Right False - | XTTrueF a String -- Right a + Right True + Left e - | XTTrueT a b -- Right a + Right True + Right b - deriving (Show,Eq) - -data RResults a b = - RF String (Tree PE) -- Left e - | RTF a (Tree PE) String (Tree PE) -- Right a + Left e - | RTFalse a (Tree PE) (Tree PE) -- Right a + Right False - | RTTrueF a (Tree PE) (Tree PE) String (Tree PE) -- Right a + Right True + Left e - | RTTrueT a (Tree PE) (Tree PE) b (Tree PE) -- Right a + Right True + Right b - deriving Show - -prtEval3PIO :: forall ip op fmt i proxy - . ( Refined3C ip op fmt i - , Show (PP ip i) - , Show i) - => proxy '(ip,op,fmt,i) - -> POpts - -> i - -> IO (Either String (Refined3 ip op fmt i)) -prtEval3PIO _ opts i = do - x <- eval3M opts i - prt3IO opts x - -prtEval3 :: forall ip op fmt i - . ( Refined3C ip op fmt i - , Show (PP ip i) - , Show i) - => POpts - -> i - -> Either Msg3 (Refined3 ip op fmt i) -prtEval3 opts i = - let x = eval3 opts i - in prt3 opts x - -prtEval3P :: forall ip op fmt i proxy - . ( Refined3C ip op fmt i - , Show (PP ip i) - , Show i) - => proxy '(ip,op,fmt,i) - -> POpts - -> i - -> Either Msg3 (Refined3 ip op fmt i) -prtEval3P _ opts i = - let x = eval3 opts i - in prt3 opts x - - --- pass in a proxy (use mkProxy to package all the types together as a 4-tuple) --- ip converts input 'i' to format used for op and fmt --- op is a boolean predicate [has to be True to continue] (uses P ip i as input) --- fmt formats the output (can be anything ie not just String) (uses P ip i as input) -eval3P :: forall ip op fmt i proxy . Refined3C ip op fmt i - => proxy '(ip,op,fmt,i) - -> POpts - -> i - -> (RResults (PP ip i) (PP fmt (PP ip i)), Maybe (Refined3 ip op fmt i)) -eval3P _ opts = runIdentity . eval3M opts - --- same as eval3P but can just pass in ip op fmt separately --- with eval3P we have to specify 'i' but in eval3 we dont cos gets it from context -eval3 :: forall ip op fmt i . Refined3C ip op fmt i - => POpts - -> i - -> (RResults (PP ip i) (PP fmt (PP ip i)), Maybe (Refined3 ip op fmt i)) -eval3 opts = runIdentity . eval3M opts - -eval3M :: forall m ip op fmt i . (MonadEval m, Refined3C ip op fmt i) - => POpts - -> i - -> m (RResults (PP ip i) (PP fmt (PP ip i)), Maybe (Refined3 ip op fmt i)) -eval3M opts i = do - ll@(fromTT -> t1) <- eval (Proxy @ip) opts i - case getValLR (_tBool ll) of - Right a -> do - rr@(fromTT -> t2) <- evalBool (Proxy @op) opts a - case getValLR (_tBool rr) of - Right True -> do - ss@(fromTT -> t3) <- eval (Proxy @fmt) opts a - pure $ case getValLR (_tBool ss) of - Right b -> (RTTrueT a t1 t2 b t3, Just (Refined3 a b)) - Left e -> (RTTrueF a t1 t2 e t3, Nothing) - Right False -> pure (RTFalse a t1 t2, Nothing) - Left e -> pure (RTF a t1 e t2, Nothing) - Left e -> pure (RF e t1, Nothing) - --- skip ip conversion: ie uses internal value -eval3MSkip :: forall m ip op fmt i . (MonadEval m, Refined3C ip op fmt i) - => POpts - -> PP ip i - -> m (RResults (PP ip i) (PP fmt (PP ip i)), Maybe (Refined3 ip op fmt i)) -eval3MSkip opts a = do - let t1 = Node (PE TrueP ["skipped PP ip i = Id"]) [] - rr@(fromTT -> t2) <- evalBool (Proxy @op) opts a - case getValLR (_tBool rr) of - Right True -> do - ss@(fromTT -> t3) <- eval (Proxy @fmt) opts a - pure $ case getValLR (_tBool ss) of - Right b -> (RTTrueT a t1 t2 b t3, Just (Refined3 a b)) - Left e -> (RTTrueF a t1 t2 e t3, Nothing) - Right False -> pure (RTFalse a t1 t2, Nothing) - Left e -> pure (RTF a t1 e t2, Nothing) - --- calculates from internal value -eval3MQuickIdentity :: forall ip op fmt i . Refined3C ip op fmt i - => POpts - -> PP ip i - -> Maybe (Refined3 ip op fmt i) -eval3MQuickIdentity opts = runIdentity . eval3MQuick opts - --- from PP ip i -eval3MQuick :: forall m ip op fmt i . (MonadEval m, Refined3C ip op fmt i) - => POpts - -> PP ip i - -> m (Maybe (Refined3 ip op fmt i)) -eval3MQuick opts a = do - rr <- evalBool (Proxy @op) opts a - case getValLR (_tBool rr) of - Right True -> do - ss <- eval (Proxy @fmt) opts a - pure $ case getValLR (_tBool ss) of - Right b -> Just (Refined3 a b) - _ -> Nothing - _ -> pure Nothing - -prt3IO :: (Show a, Show b) => POpts -> (RResults a b, Maybe r) -> IO (Either String r) -prt3IO opts (ret,mr) = do - let m3 = prt3Impl opts ret - unless (oLite opts) $ putStrLn $ m3Long m3 - return $ maybe (Left (m3Desc m3 <> " | " <> m3Short m3)) Right mr - -prt3 :: (Show a, Show b) => POpts -> (RResults a b, Maybe r) -> Either Msg3 r -prt3 opts (ret,mr) = maybe (Left $ prt3Impl opts ret) Right mr - -data Msg3 = Msg3 { m3Desc :: String, m3Short :: String, m3Long :: String } deriving Eq -instance Show Msg3 where - show (Msg3 a b c) = a <> " | " <> b <> (if null c then "" else "\n" <> c) - -prt3Impl :: (Show a, Show b) - => POpts - -> RResults a b - -> Msg3 -prt3Impl opts v = - let outmsg msg = "\n*** " <> msg <> " ***\n\n" - msg1 a = outmsg ("Step 1. Success Initial Conversion(ip) [" ++ show a ++ "]") - mkMsg3 m n r | oLite opts = Msg3 m n "" - | otherwise = Msg3 m n r - in case v of - RF e t1 -> - let (m,n) = ("Step 1. Initial Conversion(ip) Failed", e) - r = outmsg m - <> prtTreePure opts t1 - in mkMsg3 m n r - RTF a t1 e t2 -> - let (m,n) = ("Step 2. Failed Boolean Check(op)", e) - r = msg1 a - <> fixLite opts a t1 - <> outmsg m - <> prtTreePure opts t2 - in mkMsg3 m n r - RTFalse a t1 t2 -> - let (m,n) = ("Step 2. False Boolean Check(op)", "FalseP") - r = msg1 a - <> fixLite opts a t1 - <> outmsg m - <> prtTreePure opts t2 - in mkMsg3 m n r - RTTrueF a t1 t2 e t3 -> - let (m,n) = ("Step 3. Failed Output Conversion(fmt)", e) - r = msg1 a - <> fixLite opts a t1 - <> outmsg "Step 2. Success Boolean Check(op)" - <> prtTreePure opts t2 - <> outmsg m - <> prtTreePure opts t3 - in mkMsg3 m n r - RTTrueT a t1 t2 b t3 -> - let (m,n) = ("Step 3. Success Output Conversion(fmt)", show b) - r = msg1 a - <> fixLite opts a t1 - <> outmsg "Step 2. Success Boolean Check(op)" - <> prtTreePure opts t2 - <> outmsg m - <> fixLite opts b t3 - in mkMsg3 m n r - - --- | emulates 'Refined3' but uses 'Refined' --- reuses the mkProxy3 but returns Refined vs Refined3 --- using plain Refined to emulate Refined3 sort of --- we just output fmt instead of embedding it in Refined3 --- so \'ip\' predicate gets us started: we store that \'PP ip i\' in Refined --- then we run the boolean predicate \'op\' which is successful if true --- then we run \'fmt\' against '\PP ip i\' and output both the Refined (PP p i) and the PP fmt (PP (ip i)) ie \'fmt\' run against PP ip i --- if any of the three steps fails the process stops immediately and dumps out RResults -eval3PX :: forall ip op fmt i proxy . Refined3C ip op fmt i - => proxy '(ip,op,fmt,i) - -> POpts - -> i - -> (RResults (PP ip i) (PP fmt (PP ip i)), Maybe (Refined op (PP ip i), PP fmt (PP ip i))) -eval3PX _ = eval3X @ip @op @fmt - -eval3X :: forall ip op fmt i . Refined3C ip op fmt i - => POpts - -> i - -> (RResults (PP ip i) (PP fmt (PP ip i)), Maybe (Refined op (PP ip i), PP fmt (PP ip i))) -eval3X opts i = runIdentity $ do - ll@(fromTT -> t1) <- eval (Proxy @ip) opts i - case getValLR (_tBool ll) of - Right a -> do - rr@(fromTT -> t2) <- evalBool (Proxy @op) opts a - case getValLR (_tBool rr) of - Right True -> do - ss@(fromTT -> t3) <- eval (Proxy @fmt) opts a - pure $ case getValLR (_tBool ss) of - Right b -> (RTTrueT a t1 t2 b t3, Just (unsafeRefined a, b)) - Left e -> (RTTrueF a t1 t2 e t3, Nothing) - Right False -> pure (RTFalse a t1 t2, Nothing) - Left e -> pure (RTF a t1 e t2, Nothing) - Left e -> pure (RF e t1, Nothing)
− src/Refined3Helper.hs
@@ -1,297 +0,0 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wcompat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE NoStarIsType #-} --- | --- Module : Refined3Helper --- Description : Contains convenient prepackaged 4-tuples to use with Refined3 --- Copyright : (c) Grant Weyburne, 2019 --- License : BSD-3 --- Maintainer : gbwey9@gmail.com --- --- Prepackaged proxies for use with 'Refined3.Refined3' --- -module Refined3Helper where -import Refined3 -import Predicate -import Data.Proxy -import GHC.TypeLits (AppendSymbol,Nat,KnownNat) -import Data.Kind (Type) -import Data.Time -import qualified Data.Semigroup as SG - --- | credit card with luhn algorithm --- --- >>> prtEval3P cc11 ol "1234-5678-901" --- Left Step 2. False Boolean Check(op) | FalseP --- --- >>> prtEval3P cc11 ol "1234-5678-903" --- Right (Refined3 {r3In = [1,2,3,4,5,6,7,8,9,0,3], r3Out = "1234-5678-903"}) --- -type Ccip = Map (ReadP Int) (Ones (Remove "-" Id)) -type Ccop (n :: Nat) = Guard ('(n,Len) >> Printf2 "expected %d digits but found %d") (Len >> Same n) >> Luhn Id -type Ccfmt (ns :: [Nat]) = ConcatMap (ShowP Id) Id >> SplitAts ns Id >> Concat (Intercalate '["-"] Id) - -type Ccn (ns :: [Nat]) = '(Ccip, Ccop (SumT ns), Ccfmt ns, String) - -type CC11 = Ccn '[4,4,3] - --- not great for the general case: but specific case is easier -ccn :: forall (ns :: [Nat]) . (KnownNat (SumT ns), P ns String, PP ns String ~ [Integer]) => Proxy (Ccn ns) -ccn = mkProxy3 - -cc11 :: Proxy (Ccn '[4,4,3]) -- or Proxy CC11 -cc11 = mkProxy3P - --- | read in a datetime --- --- >>> prtEval3P (Proxy @(DateTime1 UTCTime)) ol "2018-09-14 02:57:04" --- Right (Refined3 {r3In = 2018-09-14 02:57:04 UTC, r3Out = "2018-09-14 02:57:04"}) --- -type DateTime1 (t :: Type) = '(Dtip1 t, Dtop1, Dtfmt1, String) -type Dtip1 t = ParseTimeP t "%F %T" Id - --- extra check to validate the time as parseTime doesnt validate the time component -type Dtop1 = - Map (ReadP Int) (FormatTimeP "%H %M %S" Id >> Resplit "\\s+" Id) - >> Guards '[ '(Printf2 "guard %d invalid hours %d", Between 0 23) - , '(Printf2 "guard %d invalid minutes %d", Between 0 59) - , '(Printf2 "guard %d invalid seconds %d", Between 0 59) - ] >> 'True -type Dtfmt1 = FormatTimeP "%F %T" Id - -ssn :: Proxy Ssn -ssn = mkProxy3 - --- | read in an ssn --- --- >>> prtEval3P ssn ol "134-01-2211" --- Right (Refined3 {r3In = [134,1,2211], r3Out = "134-01-2211"}) --- --- >>> prtEval3P ssn ol "666-01-2211" --- Left Step 2. Failed Boolean Check(op) | number for group 1 invalid: found 666 --- --- >>> prtEval3P ssn ol "666-01-2211" --- Left Step 2. Failed Boolean Check(op) | number for group 1 invalid: found 666 --- --- >>> prtEval3P ssn ol "667-00-2211" --- Left Step 2. Failed Boolean Check(op) | number for group 2 invalid: found 0 --- --- >>> prtEval3P ssn ol "666-01-2211" --- Left Step 2. Failed Boolean Check(op) | number for group 1 invalid: found 666 --- --- >>> prtEval3P ssn ol "991-22-9999" --- Left Step 2. Failed Boolean Check(op) | number for group 1 invalid: found 991 --- -type Ssn = '(Ssnip, Ssnop, Ssnfmt, String) - -type Ssnip = Map (ReadP Int) (Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" Id >> Snd OneP) -type Ssnop = GuardsQuick (Printf2 "number for group %d invalid: found %d") - '[Between 1 899 && Id /= 666, Between 1 99, Between 1 9999] - >> 'True -type Ssnop' = Guards '[ '(Printf2 "guard %d invalid: found %d", Between 1 899 && Id /= 666) - , '(Printf2 "group %d invalid: found %d", Between 1 99) - , '(Printf2 "group %d invalid: found %d", Between 1 9999) - ] >> 'True -type Ssnfmt = Printfnt 3 "%03d-%02d-%04d" - --- | read in a time and validate it --- --- >>> prtEval3P hms ol "23:13:59" --- Right (Refined3 {r3In = [23,13,59], r3Out = "23:13:59"}) --- --- >>> prtEval3P hms ol "23:13:60" --- Left Step 2. Failed Boolean Check(op) | guard(3) 60 secs is out of range --- --- >>> prtEval3P hms ol "26:13:59" --- Left Step 2. Failed Boolean Check(op) | guard(1) 26 hours is out of range --- -hms :: Proxy Hms -hms = mkProxy3 - -type Hms = '(Hmsip, Hmsop >> 'True, Hmsfmt, String) - -type Hmsip = Map (ReadP Int) (Resplit ":" Id) -type Hmsop = Guard (Printf "expected len 3 but found %d" Len) (Len >> Same 3) - >> Guards '[ '(Printf2 "guard(%d) %d hours is out of range", Between 0 23) - , '(Printf2 "guard(%d) %d mins is out of range", Between 0 59) - , '(Printf2 "guard(%d) %d secs is out of range", Between 0 59)] -type Hmsfmt = Printfnt 3 "%02d:%02d:%02d" - --- | read in an ipv4 address and validate it --- --- >>> prtEval3P ip ol "001.223.14.1" --- Right (Refined3 {r3In = [1,223,14,1], r3Out = "001.223.014.001"}) --- --- >>> prtEval3P ip ol "001.223.14.999" --- Left Step 2. Failed Boolean Check(op) | guard(4) octet out of range 0-255 found 999 --- --- >>> prtEval3P ip ol "001.223.14.999.1" --- Left Step 1. Initial Conversion(ip) Failed | Regex no results --- --- >>> prtEval3P ip ol "001.257.14.1" --- Left Step 2. Failed Boolean Check(op) | guard(2) octet out of range 0-255 found 257 --- -type Ip = '(Ipip, Ipop, Ipfmt, String) - -ip :: Proxy Ip -ip = mkProxy3 - -type Ipip = Map (ReadP Int) (Rescan "^(\\d{1,3}).(\\d{1,3}).(\\d{1,3}).(\\d{1,3})$" Id >> OneP >> Snd Id) --- RepeatT is a type family so it expands everything! replace RepeatT with a type class -type Ipop = GuardsN (Printf2 "guard(%d) octet out of range 0-255 found %d") 4 (Between 0 255) >> 'True -type Ipfmt = Printfnt 4 "%03d.%03d.%03d.%03d" - -type HmsRE = "^([0-1][0-9]|2[0-3]):([0-5][0-9]):([0-5][0-9])$" -- padded only -- dumb because strict validation should not be done twice: ie in ip and op! -type Hmsconv = Do '[Rescan HmsRE Id, Head, (Snd Id), Map (ReadBaseInt 10) Id] -type Hmsval = GuardsQuick (Printf2 "guard(%d) %d is out of range") '[Between 0 23, Between 0 59, Between 0 59] - -type Hms4 = '(Hmsconv, Hmsval >> 'True, Hmsfmt, String) - -hms4 :: Proxy Hms4 -hms4 = mkProxy3 - -type OctetRE = "(25[0-5]|2[0..4][0-9]|1[0-9][0-9]|[1-9][0-9]|[0-9])" -- no padded numbers allowed ---type Ip4StrictRE = "^" `AppendSymbol` OctetRE `AppendSymbol` "\\." `AppendSymbol` OctetRE `AppendSymbol` "\\." `AppendSymbol` OctetRE `AppendSymbol` "\\." `AppendSymbol` OctetRE `AppendSymbol` "$" -type Ip4StrictRE = "^" `AppendSymbol` IntersperseT "\\." (RepeatT 4 OctetRE) `AppendSymbol` "$" - --- valid dates for for DateFmts are "2001-01-01" "Jan 24 2009" and "03/29/07" -type DateFmts = '["%Y-%m-%d", "%m/%d/%y", "%B %d %Y"] -type DateN = '(ParseTimes Day DateFmts Id, 'True, FormatTimeP "%Y-%m-%d" Id, String) - -type DateTimeFmts = '["%Y-%m-%d %H:%M:%S", "%m/%d/%y %H:%M:%S", "%B %d %Y %H:%M:%S", "%Y-%m-%dT%H:%M:%S"] -type DateTimeN = '(ParseTimes UTCTime DateTimeFmts Id, 'True, FormatTimeP "%Y-%m-%d %H:%M:%S" Id, String) - --- | convert a string from the given base \'i\' but stores it internally as a string of base \'j\' --- --- >>> prtEval3P (Proxy @(BaseN 16)) ol "00fe" --- Right (Refined3 {r3In = 254, r3Out = "fe"}) --- -type BaseN (n :: Nat) = '(ReadBase Integer n, 'True, ShowBase n, String) - -base16 :: Proxy (BaseN 16) -base16 = mkProxy3 - -daten :: Proxy DateN -daten = mkProxy3 - -datetimen :: Proxy DateTimeN -datetimen = mkProxy3 - -type BetweenR m n = Refined3 Id (Between m n) Id Int - -type LuhnR (n :: Nat) = MakeR3 (LuhnY n) -type LuhnR' (n :: Nat) = MakeR3 (LuhnX n) - --- uses builtin Luhn vs long winded version LuhnX -type LuhnY (n :: Nat) = - '(Map (ReadP Int) (Ones Id) - , Guard (Printfn "incorrect number of digits found %d but expected %d in [%s]" (TupleI '[Len, W n, ShowP Id])) - (Len >> Same n) - >> GuardSimple (Luhn Id) >> 'True - , ConcatMap (ShowP Id) Id - , String) - -type LuhnX (n :: Nat) = - '(Map (ReadP Int) (Ones Id) - , Luhn'' n >> 'True - , ConcatMap (ShowP Id) Id - , String) - -type Luhn'' (n :: Nat) = - Guard (Printfn "incorrect number of digits found %d but expected %d in [%s]" (TupleI '[Len, W n, ShowP Id])) (Len >> Same n) - >> Do '[ - Reverse - ,Ziplc [1,2] Id - ,Map (Fst Id * Snd Id >> If (Id >= 10) (Id - 9) Id) Id - ,FoldMap (SG.Sum Int) Id - ] - >> Guard (Printfn "expected %d mod 10 = 0 but found %d" (TupleI '[Id, Id `Mod` 10])) (Mod Id 10 >> Same 0) - -type Luhn' (n :: Nat) = - Msg "Luhn'" (Do - '[Guard (Printfn "incorrect number of digits found %d but expected %d in [%s]" (TupleI '[Len, W n, Id])) (Len >> Same n) - ,Do - '[Ones Id - ,Map (ReadP Int) Id - ,Reverse - ,Ziplc [1,2] Id - ,Map (Fst Id * Snd Id >> If (Id >= 10) (Id - 9) Id) Id - ,FoldMap (SG.Sum Int) Id - ] - ,Guard (Printfn "expected %d mod 10 = 0 but found %d" (TupleI '[Id, Id `Mod` 10])) (Mod Id 10 >> Same 0) - ]) - --- noop true -type Ok (t :: Type) = '(Id, 'True, Id, t) -type OkR (t :: Type) = MakeR3 (Ok t) - --- noop false -type OkNot (t :: Type) = '(Id, 'False, Id, t) -type OkNotR (t :: Type) = MakeR3 (OkNot t) - --- | convert a string from the given base \'i\' but stores it internally as a string of base \'j\' --- --- >>> prtEval3P (Proxy @(BaseIJ 16 2)) ol "fe" --- Right (Refined3 {r3In = "11111110", r3Out = "fe"}) --- --- >>> prtEval3P (Proxy @(BaseIJ 16 2)) ol "fge" --- Left Step 1. Initial Conversion(ip) Failed | invalid base 16 --- -type BaseIJ (i :: Nat) (j :: Nat) = BaseIJ' i j 'True -type BaseIJ' (i :: Nat) (j :: Nat) p = '(ReadBase Int i >> ShowBase j, p, ReadBase Int j >> ShowBase i, String) - --- | take any valid Read/Show instance and turn it into a valid Refined3 --- --- >>> :m + Data.Ratio --- >>> prtEval3P (Proxy @(ReadShow Rational)) ol "13 % 3" --- Right (Refined3 {r3In = 13 % 3, r3Out = "13 % 3"}) --- --- >>> prtEval3P (Proxy @(ReadShow Rational)) ol "13x % 3" --- Left Step 1. Initial Conversion(ip) Failed | ReadP Ratio Integer (13x % 3) failed --- --- >>> prtEval3P (Proxy @(ReadShow' Rational (Between (3 % 1) (5 % 1)))) ol "13 % 3" --- Right (Refined3 {r3In = 13 % 3, r3Out = "13 % 3"}) --- --- >>> prtEval3P (Proxy @(ReadShow' Rational (Between (11 %- 2) (3 %- 1)))) ol "-13 % 3" --- Right (Refined3 {r3In = (-13) % 3, r3Out = "(-13) % 3"}) --- --- >>> prtEval3P (Proxy @(ReadShow' Rational (Id > (15 % 1)))) ol "13 % 3" --- Left Step 2. False Boolean Check(op) | FalseP --- --- >>> prtEval3P (Proxy @(ReadShow' Rational (Guard (Printf "invalid=%3.2f" (FromRational Double Id)) (Id > (15 % 1)) >> 'True))) ol "13 % 3" --- Left Step 2. Failed Boolean Check(op) | invalid=4.33 --- --- >>> prtEval3P (Proxy @(ReadShow' Rational (Id > (11 % 1)))) ol "13 % 3" --- Left Step 2. False Boolean Check(op) | FalseP --- --- >>> let tmString = "2018-10-19 14:53:11.5121359 UTC" --- >>> let tm = read tmString :: UTCTime --- >>> prtEval3P (Proxy @(ReadShow UTCTime)) ol tmString --- Right (Refined3 {r3In = 2018-10-19 14:53:11.5121359 UTC, r3Out = "2018-10-19 14:53:11.5121359 UTC"}) --- --- >>> :m + Data.Aeson --- >>> prtEval3P (Proxy @(ReadShow Value)) ol "String \"jsonstring\"" --- Right (Refined3 {r3In = String "jsonstring", r3Out = "String \"jsonstring\""}) --- --- >>> prtEval3P (Proxy @(ReadShow Value)) ol "Number 123.4" --- Right (Refined3 {r3In = Number 123.4, r3Out = "Number 123.4"}) --- -type ReadShow (t :: Type) = '(ReadP t, 'True, ShowP Id, String) -type ReadShowR (t :: Type) = MakeR3 (ReadShow t) - -type ReadShow' (t :: Type) p = '(ReadP t, p, ShowP Id, String) -type ReadShowR' (t :: Type) p = MakeR3 (ReadShow' t p)
− src/TH_Orphans.hs
@@ -1,28 +0,0 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wno-orphans #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE PackageImports #-} --- | --- Module : TH_Orphans --- Description : Mainly contains useful Template Haskell Lift instances for Date Time --- Copyright : (c) Grant Weyburne, 2019 --- License : BSD-3 --- Maintainer : gbwey9@gmail.com --- -module TH_Orphans where -import qualified Language.Haskell.TH.Syntax as TH -import qualified Language.Haskell.TH.Lift as TL -import Data.Time -import Data.Fixed - -deriving instance TH.Lift Day -deriving instance TH.Lift LocalTime -deriving instance TH.Lift TimeOfDay -deriving instance TH.Lift (Fixed a) - -deriving instance TH.Lift UTCTime - -$(TL.deriveLift ''DiffTime) -
− src/UtilP.hs
@@ -1,984 +0,0 @@-{-# OPTIONS -Wall #-} -{-# OPTIONS -Wcompat #-} -{-# OPTIONS -Wincomplete-record-updates #-} -{-# OPTIONS -Wincomplete-uni-patterns #-} -{-# OPTIONS -Wredundant-constraints #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} --- | --- Module : UtilP --- Description : Utility methods for Predicate / methods for displaying the evaluation tree ... --- Copyright : (c) Grant Weyburne, 2019 --- License : BSD-3 --- Maintainer : gbwey9@gmail.com --- -module UtilP where -import qualified GHC.TypeNats as GN -import Data.Ratio -import GHC.TypeLits (Symbol,Nat,KnownSymbol,KnownNat,ErrorMessage((:$$:),(:<>:))) -import qualified GHC.TypeLits as GL -import Control.Lens -import Control.Arrow -import Data.List -import qualified Data.Tree.View as TV -import Data.Tree -import Data.Tree.Lens -import Data.Proxy -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Char -import Data.Data -import System.Console.Pretty -import qualified Data.Type.Equality as DE -import GHC.Exts (Constraint) -import qualified Text.Regex.PCRE.Heavy as RH -import qualified Text.Regex.PCRE.Light as RL -import qualified Data.ByteString.Char8 as B8 -import qualified Data.Text as T -import Data.ByteString (ByteString) -import GHC.Word (Word8) -import Data.Sequence (Seq) -import Control.Applicative (ZipList) -import Data.Kind (Type) -import Data.Either -import Data.These -import Data.These.Combinators -import qualified Control.Exception as E -import Control.DeepSeq -import System.IO.Unsafe (unsafePerformIO) -import Data.Bool -import Data.Foldable - --- | describes the evaluation tree for predicates -data TT a = TT { _tBool :: BoolT a -- ^ the value at this root node - , _tStrings :: [String] -- ^ detailed information eg input and output and text - , _tForest :: Forest PE } -- ^ the child nodes - deriving Show - --- | contains the typed result from evaluating the expression tree to this point -data BoolT a where - FailT :: String -> BoolT a -- ^ failure with string - FalseT :: BoolT Bool -- ^ false predicate - TrueT :: BoolT Bool -- ^ true predicate - PresentT :: a -> BoolT a -- ^ non predicate value - -deriving instance Show a => Show (BoolT a) -deriving instance Eq a => Eq (BoolT a) - -tBool :: Lens (TT a) (TT b) (BoolT a) (BoolT b) -tBool afb s = (\b -> s { _tBool = b }) <$> afb (_tBool s) - -tStrings :: Lens' (TT a) [String] -tStrings afb s = (\b -> s { _tStrings = b }) <$> afb (_tStrings s) - -tForest :: Lens' (TT a) (Forest PE) -tForest afb s = (\b -> s { _tForest = b }) <$> afb (_tForest s) - -pStrings :: Lens' PE [String] -pStrings afb s = (\b -> s { _pStrings = b }) <$> afb (_pStrings s) - --- | a lens from typed BoolT to the untyped BoolP -boolT2P :: Lens' (BoolT a) BoolP -boolT2P afb = \case - FailT e -> FailT e <$ afb (FailP e) - TrueT -> TrueT <$ afb TrueP - FalseT -> FalseT <$ afb FalseP - PresentT a -> PresentT a <$ afb PresentP - --- | contains the untyped result from evaluating the expression tree to this point -data BoolP = - FailP String - | FalseP - | TrueP - | PresentP - deriving (Show, Eq) - --- need a semigroup constraint else we have to throw away one of the PresentT a ie First or Last -instance Semigroup a => Semigroup (BoolT a) where - FailT e <> FailT e1 = FailT (e <> e1) - o@FailT {} <> _ = o - _ <> o@FailT {} = o - o@TrueT <> TrueT = o - o@FalseT <> _ = o - _ <> o@FalseT = o - -- cant pattern match on PresentT True on lhs (hence PresentT a) but can use 'a' as a Bool on rhs! - PresentT a <> TrueT = review _boolT a - TrueT <> PresentT a = review _boolT a - PresentT a <> PresentT a1 = PresentT (a <> a1) - -instance Monoid a => Monoid (BoolT a) where - mempty = PresentT mempty - -data PE = PE { _pBool :: BoolP -- ^ holds the result of running the predicate - , _pStrings :: [String] -- ^ optional strings to include in the results - } deriving Show - -pBool :: Lens' PE BoolP -pBool afb (PE x y) = flip PE y <$> afb x - --- | creates a Node for the evaluation tree -mkNode :: POpts -> BoolT a -> [String] -> [Holder] -> TT a -mkNode opts bt ss hs - | oLite opts = TT bt [] [] - | otherwise = TT bt ss (map fromTTH hs) - --- | creates a Boolean node for a predicate type -mkNodeB :: POpts -> Bool -> [String] -> [Holder] -> TT Bool -mkNodeB opts b = mkNode opts (bool FalseT TrueT b) - --- | partition a tree into failures and non failures -partitionTTs :: [TT a] -> ([TT x], [TT a]) -partitionTTs = partitionEithers . map getTTLR - -getTTLR :: TT a -> Either (TT x) (TT a) -getTTLR t = - case _tBool t of - FailT e -> Left $ t & tBool .~ FailT e - _ -> Right t - -partitionTTExtended :: (w, TT a) -> ([((w, TT x), String)], [(w, TT a)]) -partitionTTExtended z@(_, t) = - case _tBool t of - FailT e -> ([(z & _2 . tBool .~ FailT e, e)], []) - _ -> ([], [z]) - -getValLRFromTT :: TT a -> Either String a -getValLRFromTT = getValLR . _tBool - --- | get the value from BoolT or fail -getValLR :: BoolT a -> Either String a -getValLR = \case - FailT e -> Left e - TrueT -> Right True - FalseT -> Right False - PresentT a -> Right a - -shortTT :: BoolT Bool -> Either String String -shortTT z = case z of - FailT e -> Left $ "FailT " <> e - TrueT -> Right $ show z - FalseT -> Left $ show z - PresentT True -> Right $ show z - PresentT False -> Left $ show z - --- | converts a typed tree to an untyped on for display -fromTT :: TT a -> Tree PE -fromTT (TT bt ss tt) = Node (PE (bt ^. boolT2P) ss) tt - --- | a monomorphic container of trees -data Holder = forall w . Holder { unHolder :: TT w } - --- | converts a typed tree into an untyped one -fromTTH :: Holder -> Tree PE -fromTTH (Holder x) = fromTT x - --- | convenience method to wrap a typed tree -hh :: TT w -> Holder -hh = Holder - --- | see 'getValueLRImpl' : add more detail to the tree if there are errors -getValueLR :: POpts -> String -> TT a -> [Holder] -> Either (TT x) a -getValueLR = getValueLRImpl True - --- | see 'getValueLRImpl' : add less detail to the tree if there are errors -getValueLRHide :: POpts -> String -> TT a -> [Holder] -> Either (TT x) a -getValueLRHide = getValueLRImpl False - --- elide FailT msg in tStrings[0] if showError is False --- | a helper method to add extra context on failure to the tree or extract the value at the root of the tree -getValueLRImpl :: Bool -> POpts -> String -> TT a -> [Holder] -> Either (TT x) a -getValueLRImpl showError opts msg0 tt hs = - let tt' = hs ++ [hh tt] - in left (\e -> mkNode - opts - (FailT e) - [msg0 <> if showError then (if null msg0 then "" else " ") <> "[" <> e <> "]" - else ""] - tt' - ) - (getValLRFromTT tt) - --- | the color palette for displaying the expression tree -newtype PColor = PColor { unPColor :: BoolP -> String -> String } - --- | customizable options -data POpts = POpts { oWidth :: Maybe Int -- ^ length of data to display for 'showLitImpl' - , oDebug :: !Int -- ^ debug level - , oDisp :: Disp -- ^ display the tree using the normal tree or unicode - , oHide :: !Int -- ^ hides one layer of a tree - , oColor :: !(String, PColor) -- ^ color palette used - , oLite :: !Bool -- ^ skip the tree entirely and display the end result - } - --- | display format for the tree -data Disp = NormalDisp -- ^ draw horizontal tree - | Unicode -- ^ use unicode - deriving (Show, Eq) - -instance Show POpts where - show opts = - "POpts: showA=" <> show (oWidth opts) - <> " debug=" <> show (oDebug opts) - <> " disp=" <> show (oDisp opts) - <> " hide=" <> show (oHide opts) - <> " color=" <> show (fst (oColor opts)) - <> " lite=" <> show (oLite opts) - -defOpts :: POpts -defOpts = POpts - { oWidth = Just 200 - , oDebug = 2 - , oDisp = NormalDisp - , oHide = 0 - , oColor = color1 - , oLite = False - } - --- | skip colors and just return the summary -ol :: POpts -ol = defOpts { oColor = color0, oLite = True } - --- | skip the detail and just return the summary but keep the colors -olc :: POpts -olc = ol { oColor = color1 } - --- | displays the detailed evaluation tree without colors. -o0 :: POpts -o0 = defOpts { oColor = color0 } - --- | displays the detailed evaluation tree using colors. -o2 :: POpts -o2 = defOpts { oDebug = 2 } - --- | same as 'o2' but for narrower display width -o2n :: POpts -o2n = o2 { oWidth = Just 120 } - --- | same as 'o2' but for larger display width -o3 :: POpts -o3 = defOpts { oDebug = 3, oWidth = Just 400 } - --- | displays the detailed evaluation tree using unicode and colors. ('o2' works better on Windows) -ou :: POpts -ou = defOpts { oDisp = Unicode } - --- | same as 'ou' but for narrower display width -oun :: POpts -oun = ou { oWidth = Just 120 } - --- | helper method to limit the width of the tree -setw :: Int -> POpts -> POpts -setw w o = o { oWidth = Just w } - --- | helper method to set the debug level -setd :: Int -> POpts -> POpts -setd v o = o { oDebug = v } - --- | set display to unicode and colors -setu :: POpts -> POpts -setu o = o { oDisp = Unicode } - --- | set a color palette -setc :: (String, PColor) -> POpts -> POpts -setc pc o = o { oColor = pc } - -setc0, setc1, setc2, setc3, setc4 :: POpts -> POpts -setc0 o = o { oColor = color0 } -setc1 o = o { oColor = color1 } -setc2 o = o { oColor = color2 } -setc3 o = o { oColor = color3 } -setc4 o = o { oColor = color4 } - --- | color palettes --- --- italics dont work but underline does -color0, color1, color2, color3, color4 :: (String, PColor) - --- | no colors are displayed -color0 = ("color0", PColor $ flip const) - --- | default color palette -color1 = - ("color1",) $ PColor $ \case - FailP {} -> bgColor Magenta - FalseP -> bgColor Red - TrueP -> bgColor Green - PresentP -> bgColor Yellow - -color2 = - ("color2",) $ PColor $ \case - FailP {} -> bgColor Magenta - FalseP -> bgColor Red - TrueP -> bgColor White - PresentP -> bgColor Yellow - -color3 = - ("color3",) $ PColor $ \case - FailP {} -> bgColor Blue - FalseP -> color Red - TrueP -> color White - PresentP -> bgColor Yellow - -color4 = - ("color4",) $ PColor $ \case - FailP {} -> bgColor Cyan - FalseP -> color Red - TrueP -> color Green - PresentP -> bgColor Yellow - --- | fix PresentT Bool to TrueT or FalseT -fixBoolT :: TT Bool -> TT Bool -fixBoolT t = - case t ^? tBool . _PresentT of - Nothing -> t - Just b -> t & tBool .~ _boolT # b - -show01 :: (Show a1, Show a2) => POpts -> String -> a1 -> a2 -> String -show01 opts msg0 ret as = lit01 opts msg0 ret (show as) - -lit01 :: Show a1 => POpts -> String -> a1 -> String -> String -lit01 opts msg0 ret as = lit01' opts msg0 ret "" as - -show01' :: (Show a1, Show a2) => POpts -> String -> a1 -> String -> a2 -> String -show01' opts msg0 ret fmt as = lit01' opts msg0 ret fmt (show as) - -lit01' :: Show a1 => POpts -> String -> a1 -> String -> String -> String -lit01' opts msg0 ret fmt as = msg0 <> show0 opts " " ret <> showLit1 opts (" | " ++ fmt) as - --- | display all data regardless of debug level -showLit0 :: POpts -> String -> String -> String -showLit0 o s a = showLitImpl o 0 s a - --- | more restrictive: only display data at debug level 1 or less -showLit1 :: POpts -> String -> String -> String -showLit1 o s a = showLitImpl o 1 s a - -showLitImpl :: POpts -> Int -> String -> String -> String -showLitImpl o i s a = - if oDebug o >= i then - let f n = let ss = take n a - in ss <> (if length ss==n then " ..." else "") - in maybe "" (\n -> s <> f n) (oWidth o) - else "" - -show0 :: Show a => POpts -> String -> a -> String -show0 o s a = showAImpl o 0 s a - -show3 :: Show a => POpts -> String -> a -> String -show3 o s a = showAImpl o 3 s a - -show1 :: Show a => POpts -> String -> a -> String -show1 o s a = showAImpl o 1 s a - -showAImpl :: Show a => POpts -> Int -> String -> a -> String -showAImpl o i s a = showLitImpl o i s (show a) - --- | Regex options for Rescan Resplit Re etc -data ROpt = - Anchored -- ^ Force pattern anchoring - | Auto_callout -- ^ Compile automatic callouts --- | Bsr_anycrlf -- \R matches only CR, LF, or CrlF --- | Bsr_unicode -- ^ \R matches all Unicode line endings - | Caseless -- ^ Do caseless matching - | Dollar_endonly -- ^ dollar not to match newline at end - | Dotall -- ^ matches anything including NL - | Dupnames -- ^ Allow duplicate names for subpatterns - | Extended -- ^ Ignore whitespace and # comments - | Extra -- ^ PCRE extra features (not much use currently) - | Firstline -- ^ Force matching to be before newline - | Multiline -- ^ caret and dollar match newlines within data --- | Newline_any -- ^ Recognize any Unicode newline sequence --- | Newline_anycrlf -- ^ Recognize CR, LF, and CrlF as newline sequences - | Newline_cr -- ^ Set CR as the newline sequence - | Newline_crlf -- ^ Set CrlF as the newline sequence - | Newline_lf -- ^ Set LF as the newline sequence - | No_auto_capture -- ^ Disable numbered capturing parentheses (named ones available) - | Ungreedy -- ^ Invert greediness of quantifiers - | Utf8 -- ^ Run in UTF--8 mode - | No_utf8_check -- ^ Do not check the pattern for UTF-8 validity - deriving (Show,Eq,Ord,Enum,Bounded) - --- | compile a regex using the type level symbol -compileRegex :: forall rs a . GetROpts rs - => POpts -> String -> String -> [Holder] -> Either (TT a) RH.Regex -compileRegex opts nm s hhs = - let rs = getROpts @rs - mm = nm <> " " <> show rs - in flip left (RH.compileM (B8.pack s) rs) - $ \e -> mkNode opts (FailT "Regex failed to compile") [mm <> " compile failed with regex msg[" <> e <> "]"] hhs - --- | extract the regex options from the type level list -class GetROpts (os :: [ROpt]) where - getROpts :: [RL.PCREOption] -instance GetROpts '[] where - getROpts = [] -instance (GetROpt r, GetROpts rs) => GetROpts (r ': rs) where - getROpts = getROpt @r : getROpts @rs - --- | convert type level regex option to the value level -class GetROpt (o :: ROpt) where - getROpt :: RL.PCREOption -instance GetROpt 'Anchored where getROpt = RL.anchored -instance GetROpt 'Auto_callout where getROpt = RL.auto_callout ---instance GetROpt 'Bsr_anycrlf where getROpt = RL.bsr_anycrlf ---instance GetROpt 'Bsr_unicode where getROpt = RL.bsr_unicode -instance GetROpt 'Caseless where getROpt = RL.caseless -instance GetROpt 'Dollar_endonly where getROpt = RL.dollar_endonly -instance GetROpt 'Dotall where getROpt = RL.dotall -instance GetROpt 'Dupnames where getROpt = RL.dupnames -instance GetROpt 'Extended where getROpt = RL.extended -instance GetROpt 'Extra where getROpt = RL.extra -instance GetROpt 'Firstline where getROpt = RL.firstline -instance GetROpt 'Multiline where getROpt = RL.multiline ---instance GetROpt 'Newline_any where getROpt = RL.newline_any ---instance GetROpt 'Newline_anycrlf where getROpt = RL.newline_anycrlf -instance GetROpt 'Newline_cr where getROpt = RL.newline_cr -instance GetROpt 'Newline_crlf where getROpt = RL.newline_crlf -instance GetROpt 'Newline_lf where getROpt = RL.newline_lf -instance GetROpt 'No_auto_capture where getROpt = RL.no_auto_capture -instance GetROpt 'Ungreedy where getROpt = RL.ungreedy -instance GetROpt 'Utf8 where getROpt = RL.utf8 -instance GetROpt 'No_utf8_check where getROpt = RL.no_utf8_check - --- | used by 'Predicate.ReplaceImpl' and 'RH.sub' and 'RH.gsub' to allow more flexible replacement --- These parallel the RegexReplacement (not exported) class in "Text.Regex.PCRE.Heavy" but have overlappable instances which is problematic for this code so I use 'RR' -data RR = - RR String - | RR1 (String -> [String] -> String) - | RR2 (String -> String) - | RR3 ([String] -> String) - -instance Show RR where - show = \case - RR s -> "RR " ++ s - RR1 {} -> "RR1 <fn>" - RR2 {} -> "RR2 <fn>" - RR3 {} -> "RR3 <fn>" - --- | extract values from the trees or if there are errors returned a tree with added context -splitAndAlign :: Show x => - POpts - -> [String] - -> [((Int, x), TT a)] - -> Either (TT w) - ([a] - ,[((Int, x), TT a)] - ) -splitAndAlign opts msgs ts = - case mconcat $ map partitionTTExtended ts of - (excs@(e:_), _) -> - Left $ mkNode opts - (FailT (groupErrors (map snd excs))) - (msgs <> ["excs=" <> show (length excs) <> " " <> formatList opts [fst e]]) - (map (hh . snd) ts) - ([], tfs) -> Right (valsFromTTs (map snd ts), tfs) - -formatList :: forall x z . Show x => POpts -> [((Int, x), z)] -> String -formatList opts = unwords . map (\((i, a), _) -> "(i=" <> show i <> showAImpl opts 0 ", a=" a <> ")") - --- | extract all root values from a list of trees -valsFromTTs :: [TT a] -> [a] -valsFromTTs = concatMap toList - -instance Foldable TT where - foldMap am = foldMap am . _tBool - -instance Foldable BoolT where - foldMap am = either (const mempty) am . getValLR - -isTrue :: BoolT Bool -> Bool -isTrue = and ---isTrue = or - --- cant use: is / isn't / has cos only FailT will be False: use Fold --- this is more specific to TrueP FalseP --- | prism from BoolT to Bool -_boolT :: Prism' (BoolT Bool) Bool -_boolT = prism' (bool FalseT TrueT) - $ \case - PresentT a -> Just a - TrueT -> Just True - FalseT -> Just False - FailT {} -> Nothing - -groupErrors :: [String] -> String -groupErrors = intercalate " | " . map (\xs -> head xs <> (if length xs > 1 then "(" <> show (length xs) <> ")" else "")) . group - -_FailT :: Prism' (BoolT a) String -_FailT = prism' FailT $ \case - FailT s -> Just s - _ -> Nothing - -_PresentT :: Prism' (BoolT a) a -_PresentT = prism' PresentT $ \case - PresentT a -> Just a - _ -> Nothing - -_FalseT :: Prism' (BoolT Bool) () -_FalseT = prism' (const FalseT) $ - \case - FalseT -> Just () - _ -> Nothing - -_TrueT :: Prism' (BoolT Bool) () -_TrueT = prism' (const TrueT) $ - \case - TrueT -> Just () - _ -> Nothing - -imply :: Bool -> Bool -> Bool -imply p q = not p || q - --- msg is only used for an exception: up to the calling programs to deal with ading msg to good and bad --- | applies a boolean binary operation against the values from two boolean trees -evalBinStrict :: POpts - -> String - -> (Bool -> Bool -> Bool) - -> TT Bool - -> TT Bool - -> TT Bool -evalBinStrict opts s fn ll rr = - case getValueLR opts (s <> " p") ll [Holder rr] of - Left e -> e - Right a -> - case getValueLR opts (s <> " q") rr [hh ll] of - Left e -> e - Right b -> - let z = fn a b - in mkNodeB opts z [show a <> " " <> s <> " " <> show b] [hh ll, hh rr] - --- | type level Between -type family BetweenT (a :: Nat) (b :: Nat) (v :: Nat) :: Constraint where - BetweenT m n v = - FailIfT (NotT (AndT (m GL.<=? v) (v GL.<=? n))) - ('GL.Text "BetweenT failure" - ':$$: 'GL.ShowType v - ':$$: 'GL.Text " is outside of " - ':$$: 'GL.ShowType m - ':<>: 'GL.Text " and " - ':<>: 'GL.ShowType n) - --- | makes zero invalid at the type level -type NotZeroT v = FailIfT (v DE.== 0) ('GL.Text "found zero value") - --- | typelevel Null on Symbol -type family NullT (x :: Symbol) :: Bool where - NullT ("" :: Symbol) = 'True - NullT _ = 'False - --- | helper method to fail with an error if the True -type family FailIfT (b :: Bool) (msg :: GL.ErrorMessage) :: Constraint where - FailIfT 'False _ = () - FailIfT 'True e = GL.TypeError e - --- | typelevel And -type family AndT (b :: Bool) (b1 :: Bool) :: Bool where - AndT 'False _ = 'False - AndT 'True b1 = b1 - --- | typelevel Or -type family OrT (b :: Bool) (b1 :: Bool) :: Bool where - OrT 'True _ = 'True - OrT 'False b1 = b1 - --- | typelevel Not -type family NotT (b :: Bool) :: Bool where - NotT 'True = 'False - NotT 'False = 'True - --- | get a Nat from the typelevel -nat :: forall n a . (KnownNat n, Num a) => a -nat = fromIntegral (GL.natVal (Proxy @n)) - --- | gets the Symbol from the typelevel -symb :: forall s . KnownSymbol s => String -symb = GL.symbolVal (Proxy @s) - --- | get a list of Nats from the typelevel -class GetNats as where - getNats :: [Int] -instance GetNats '[] where - getNats = [] -instance (KnownNat n, GetNats ns) => GetNats (n ': ns) where - getNats = nat @n : getNats @ns - --- | get a list of Symbols from the typelevel -class GetSymbs ns where - getSymbs :: [String] -instance GetSymbs '[] where - getSymbs = [] -instance (KnownSymbol s, GetSymbs ss) => GetSymbs (s ': ss) where - getSymbs = symb @s : getSymbs @ss - -getLen :: forall xs . GetLen xs => Int -getLen = getLenP (Proxy @xs) - --- really need a proxy for this to work --- | gets length of a typelevel list -class GetLen (xs :: [k]) where -- defaults to xs :: k (how to make it [k]) cos is not free - getLenP :: Proxy (xs :: [k]) -> Int -instance GetLen '[] where - getLenP _ = 0 -instance GetLen xs => GetLen (x ': xs) where - getLenP _ = 1 + getLenP (Proxy @xs) - -showThese :: These a b -> String -showThese = these (const "This") (const "That") (const (const "These")) - --- hard without a Proxy -class GetThese (th :: These x y) where - getThese :: Proxy th -> (String, These w v -> Bool) -instance GetThese ('This x) where - getThese _ = ("This", isThis) -instance GetThese ('That y) where - getThese _ = ("That", isThat) -instance GetThese ('These x y) where - getThese _ = ("These", isThese) - --- | get ordering from the typelevel -class GetOrdering (cmp :: Ordering) where - getOrdering :: Ordering -instance GetOrdering 'LT where - getOrdering = LT -instance GetOrdering 'EQ where - getOrdering = EQ -instance GetOrdering 'GT where - getOrdering = GT - --- | get bool from the typelevel -class GetBool (a :: Bool) where - getBool :: Bool -instance GetBool 'True where - getBool = True -instance GetBool 'False where - getBool = False - -data N = S N | Z - --- a shim for TupleListImpl used mainly by Printfn --- | inductive numbers -type family ToN (n :: Nat) :: N where - ToN 0 = 'Z - ToN n = 'S (ToN (n GL.- 1)) - --- | converts an inductive number to Nat -type family FromN (n :: N) :: Nat where - FromN 'Z = 0 - FromN ('S n) = 1 GL.+ FromN n - --- | extract N from the type level to Int -class GetNatN (n :: N) where - getNatN :: Int -instance GetNatN 'Z where - getNatN = 0 -instance GetNatN n => GetNatN ('S n) where - getNatN = 1 + getNatN @n - -getN :: Typeable t => Proxy (t :: N) -> Int -getN p = length (show (typeRep p)) `div` 5 - -data OrderingP = Cgt | Cge | Ceq | Cle | Clt | Cne deriving (Show, Eq, Enum, Bounded) - -class GetOrd (k :: OrderingP) where - getOrd :: Ord a => (String, a -> a -> Bool) - -instance GetOrd 'Cgt where getOrd = (">", (>)) -instance GetOrd 'Cge where getOrd = (">=",(>=)) -instance GetOrd 'Ceq where getOrd = ("==",(==)) -instance GetOrd 'Cle where getOrd = ("<=",(<=)) -instance GetOrd 'Clt where getOrd = ("<", (<)) -instance GetOrd 'Cne where getOrd = ("/=",(/=)) - --- only hides BoolP part! not sure of the point -toNodeString :: POpts -> PE -> String -toNodeString opts bpe - | oLite opts = error $ "shouldnt be calling this if we are going lite: toNodeString oLite " ++ show bpe - | otherwise = showBoolP opts (_pBool bpe) <> " " <> displayMessages (_pStrings bpe) - -nullSpace :: String -> String -nullSpace s | null s = "" - | otherwise = " " <> s - -showBoolP :: POpts -> BoolP -> String -showBoolP o = - \case - b@(FailP e) -> "[" <> colorMe o b "Error" <> nullSpace e <> "]" - b@PresentP -> colorMe o b "P" - b@TrueP -> colorMe o b "True " - b@FalseP -> colorMe o b "False" - -displayMessages :: [String] -> String -displayMessages es = - case filter (not . all isSpace) es of - [] -> "" - z -> intercalate " | " z - --- | colors the result of the predicate based on the current color palette -colorMe :: POpts -> BoolP -> String -> String -colorMe o b s = - let (_, PColor f) = oColor o - in f b s - -prtTTIO :: POpts -> IO (TT a) -> IO () -prtTTIO = prtTT' - -prtTT :: POpts -> Identity (TT a) -> IO () -prtTT = prtTT' - -prtTT' :: MonadEval m => POpts -> m (TT a) -> IO () -prtTT' o y = liftEval y >>= prtTree o . fromTT - -prtTree :: POpts -> Tree PE -> IO () -prtTree o = prtImpl o . fmap (toNodeString o) - -prtImpl :: POpts -> Tree String -> IO () -prtImpl = (putStr .) . showImpl - -fixLite :: forall a . Show a => POpts -> a -> Tree PE -> String -fixLite opts a t - | oLite opts = fixPresentP opts (t ^. root . pBool) a <> "\n" - | otherwise = prtTreePure opts t - -fixPresentP :: Show a => POpts -> BoolP -> a -> String -fixPresentP opts bp a = - case bp of - PresentP -> colorMe opts PresentP "Present" <> " " <> show a - _ -> showBoolP opts bp - -prtTreePure :: POpts -> Tree PE -> String -prtTreePure opts t - | oLite opts = showBoolP opts (t ^. root . pBool) - | otherwise = showImpl opts $ fmap (toNodeString opts) t - -showImpl :: POpts -> Tree String -> String -showImpl o = - case oDisp o of - Unicode -> TV.showTree - NormalDisp -> drawTree -- to drop the last newline else we have to make sure that everywhere else has that newline: eg fixLite - -lite :: POpts -> POpts -lite o = o { oLite = True } - -unicode :: POpts -> POpts -unicode o = o { oDisp = Unicode } - -horizontal :: POpts -> POpts -horizontal o = o { oDisp = NormalDisp } - -prettyRational :: Rational -> String -prettyRational (numerator &&& denominator -> (n,d)) = - if | n == 0 -> "0" - | d == 1 -> show n - | otherwise -> show n <> " / " <> show d - -fixit :: ((Int, x), TT a) -> TT a -fixit ((i, _), t) = prefixMsg ("i=" <> show i <> ":") t - -prefixMsg :: String -> TT a -> TT a -prefixMsg msg t = - t & tStrings . ix 0 %~ (msg <>) - -showNat :: forall n . KnownNat n => String -showNat = show (nat @n :: Integer) - -showT :: forall (t :: Type) . Typeable t => String -showT = show (typeRep (Proxy @t)) - -showTProxy :: forall p . Typeable (Proxy p) => String -showTProxy = drop 8 $ show (typeOf (Proxy @p)) - -prettyOrd :: Ordering -> String -prettyOrd = \case - LT -> "<" - EQ -> "=" - GT -> ">" - -type family RepeatT (n :: Nat) (p :: k) :: [k] where - RepeatT 0 p = GL.TypeError ('GL.Text "RepeatT is not defined for zero") - RepeatT 1 p = p ': '[] - RepeatT n p = p ': RepeatT (n GN.- 1) p - -type family IntersperseT (s :: Symbol) (xs :: [Symbol]) :: Symbol where - IntersperseT s '[] = "" - IntersperseT s '[x] = x - IntersperseT s (x ': y ': xs) = x `GL.AppendSymbol` s `GL.AppendSymbol` IntersperseT s (y ': xs) - -type family LenT (xs :: [k]) :: Nat where - LenT '[] = 0 - LenT (x ': xs) = 1 GN.+ LenT xs - - -type NEmptyT k = ('[] ':| '[] :: NonEmpty [k]) - -isPrime :: Integer -> Bool -isPrime n = n==2 || n>2 && all ((> 0).rem n) (2:[3,5 .. floor . sqrt @Double . fromIntegral $ n+1]) - -type family TupleListT (n :: N) a where - TupleListT 'Z a = () - TupleListT ('S n) a = (a, TupleListT n a) - -class TupleListD (n :: N) a where - tupleListD :: Bool -> [a] -> Either String (TupleListT n a) - -instance TupleListD 'Z a where - tupleListD isStrict = \case - z@(_:_) | isStrict -> - let len = length z - in Left $ "is strict and has " <> show len <> " extra element" <> (if len == 1 then "" else "s") - _ -> Right () - -instance (TupleListD n a) => TupleListD ('S n) a where - tupleListD isStrict = \case - [] -> Left "no data left" -- nothing i can do here even if not strict - a:as -> (a,) <$> tupleListD @n @a isStrict as - --- up to 12 -class ReverseTupleC x where - type ReverseTupleP x - reverseTupleC :: x -> ReverseTupleP x -instance (GL.TypeError ('GL.Text "ReverseTupleC: inductive tuple cannot be empty")) => ReverseTupleC () where - type ReverseTupleP () = () - reverseTupleC () = () -instance ReverseTupleC (a,()) where - type ReverseTupleP (a,()) = (a,()) - reverseTupleC (a,()) = (a,()) -instance ReverseTupleC (a,(b,())) where - type ReverseTupleP (a,(b,())) = (b,(a,())) - reverseTupleC (a,(b,())) = (b,(a,())) -instance ReverseTupleC (a,(b,(c,()))) where - type ReverseTupleP (a,(b,(c,()))) = (c,(b,(a,()))) - reverseTupleC (a,(b,(c,()))) = (c,(b,(a,()))) -instance ReverseTupleC (a,(b,(c,(d,())))) where - type ReverseTupleP (a,(b,(c,(d,())))) = (d,(c,(b,(a,())))) - reverseTupleC (a,(b,(c,(d,())))) = (d,(c,(b,(a,())))) -instance ReverseTupleC (a,(b,(c,(d,(e,()))))) where - type ReverseTupleP (a,(b,(c,(d,(e,()))))) = (e,(d,(c,(b,(a,()))))) - reverseTupleC (a,(b,(c,(d,(e,()))))) = (e,(d,(c,(b,(a,()))))) -instance ReverseTupleC (a,(b,(c,(d,(e,(f,())))))) where - type ReverseTupleP (a,(b,(c,(d,(e,(f,())))))) = (f,(e,(d,(c,(b,(a,())))))) - reverseTupleC (a,(b,(c,(d,(e,(f,())))))) = (f,(e,(d,(c,(b,(a,())))))) -instance ReverseTupleC (a,(b,(c,(d,(e,(f,(g,()))))))) where - type ReverseTupleP (a,(b,(c,(d,(e,(f,(g,()))))))) = (g,(f,(e,(d,(c,(b,(a,()))))))) - reverseTupleC (a,(b,(c,(d,(e,(f,(g,()))))))) = (g,(f,(e,(d,(c,(b,(a,()))))))) -instance ReverseTupleC (a,(b,(c,(d,(e,(f,(g,(h,())))))))) where - type ReverseTupleP (a,(b,(c,(d,(e,(f,(g,(h,())))))))) = (h,(g,(f,(e,(d,(c,(b,(a,())))))))) - reverseTupleC (a,(b,(c,(d,(e,(f,(g,(h,())))))))) = (h,(g,(f,(e,(d,(c,(b,(a,())))))))) -instance ReverseTupleC (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) where - type ReverseTupleP (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) = (i,(h,(g,(f,(e,(d,(c,(b,(a,()))))))))) - reverseTupleC (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) = (i,(h,(g,(f,(e,(d,(c,(b,(a,()))))))))) -instance ReverseTupleC (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) where - type ReverseTupleP (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) = (j,(i,(h,(g,(f,(e,(d,(c,(b,(a,())))))))))) - reverseTupleC (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) = (j,(i,(h,(g,(f,(e,(d,(c,(b,(a,())))))))))) -instance ReverseTupleC (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,()))))))))))) where - type ReverseTupleP (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,()))))))))))) = (k,(j,(i,(h,(g,(f,(e,(d,(c,(b,(a,()))))))))))) - reverseTupleC (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,()))))))))))) = (k,(j,(i,(h,(g,(f,(e,(d,(c,(b,(a,()))))))))))) -instance ReverseTupleC (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,(l,())))))))))))) where - type ReverseTupleP (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,(l,())))))))))))) = (l,(k,(j,(i,(h,(g,(f,(e,(d,(c,(b,(a,())))))))))))) - reverseTupleC (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,(l,())))))))))))) = (l,(k,(j,(i,(h,(g,(f,(e,(d,(c,(b,(a,())))))))))))) - --- a hack to get 'a' from '[a]' which I need for type PP -type family ArrT (as :: Type) :: Type where - ArrT [a] = a - ArrT as = GL.TypeError ( - 'GL.Text "ArrT: expected [a] but found something else" - ':$$: 'GL.Text "as = " - ':<>: 'GL.ShowType as) - -type family TupleLenT (t :: Type) :: Nat where - TupleLenT () = 0 - TupleLenT (_,ts) = 1 GN.+ TupleLenT ts - TupleLenT t = GL.TypeError ( - 'GL.Text "TupleLenT: expected a valid inductive tuple" - ':$$: 'GL.Text "t = " - ':<>: 'GL.ShowType t) - --- partially apply the 2nd arg to an ADT -- $ and & work with functions only --- doesnt apply more than once because we need to eval it -type family (p :: k -> k1) %% (q :: k) :: k1 where - p %% q = p q - -infixl 9 %% - -type family (p :: k) %& (q :: k -> k1) :: k1 where - p %& q = q p - -infixr 9 %& - -type family FlipT (d :: k1 -> k -> k2) (p :: k) (q :: k1) :: k2 where - FlipT d p q = d q p - -type family IfT (b :: Bool) (t :: k) (f :: k) :: k where - IfT 'True t f = t - IfT 'False t f = f - -type family SumT (ns :: [Nat]) :: Nat where - SumT '[] = 0 - SumT (n ': ns) = n GL.+ SumT ns - --- only works if you use ADTs not type synonyms -type family MapT (f :: k -> k1) (xs :: [k]) :: [k1] where - MapT f '[] = '[] - MapT f (x ': xs) = f x ': MapT f xs - -type family ConsT s where - ConsT [a] = a - ConsT (ZipList a) = a - ConsT T.Text = Char - ConsT ByteString = Word8 - ConsT (Seq a) = a - ConsT s = GL.TypeError ( - 'GL.Text "ConsT: not a valid ConsT" - ':$$: 'GL.Text "s = " - ':<>: 'GL.ShowType s) - -class Monad m => MonadEval m where - runIO :: IO a -> m (Maybe a) - catchit :: E.Exception e => a -> m (Either String a) - catchitNF :: (E.Exception e, NFData a) => a -> m (Either String a) - liftEval :: m a -> IO a - -instance MonadEval Identity where - runIO _ = Identity Nothing - catchit v = Identity $ unsafePerformIO $ catchit @IO @E.SomeException v - catchitNF v = Identity $ unsafePerformIO $ catchitNF @IO @E.SomeException v - liftEval = return . runIdentity - -instance MonadEval IO where - runIO ioa = Just <$> ioa - catchit v = E.evaluate (Right $! v) `E.catch` (\(E.SomeException e) -> pure $ Left ("IO e=" <> show e)) - catchitNF v = E.evaluate (Right $!! v) `E.catch` (\(E.SomeException e) -> pure $ Left ("IO e=" <> show e)) - liftEval = id - -removeAnsiForDocTest :: Show a => Either String a -> IO () -removeAnsiForDocTest = - \case - Left e -> let esc = '\x1b' - f :: String -> Maybe (String, String) - f = \case - [] -> Nothing - c:cs | c == esc -> case break (=='m') cs of - (_,'m':s) -> Just ("",s) - _ -> Nothing - | otherwise -> Just $ break (==esc) (c:cs) - in putStrLn $ concat $ unfoldr f e - Right a -> print a -
− src/UtilP_TH.hs
@@ -1,168 +0,0 @@-{-# OPTIONS -Wall #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE PolyKinds #-} --- | --- Module : UtilP_TH --- Description : Template Haskell methods for creating Refined and Refined3 refinement types --- Copyright : (c) Grant Weyburne, 2019 --- License : BSD-3 --- Maintainer : gbwey9@gmail.com --- --- Template Haskell methods for creating Refined and Refined3 refinement types --- -module UtilP_TH - ( refined3TH - , refined3TH' - , refinedTH - , refinedTH' - ) where -import Refined3 -import Refined -import PredicateCore -import qualified Language.Haskell.TH.Syntax as TH -import Data.Functor.Identity -import UtilP - --- | creates a 'Refined.Refined' refinement type with terse output --- --- @ --- >$$(refinedTH 123) :: Refined (Between 100 125) Int --- Refined {unRefined = 123} --- it :: Refined (Between 100 125) Int --- @ --- --- @ --- >$$(refinedTH 99) :: Refined (Between 100 125) Int --- --- <interactive>:8:4: error: --- * refinedTH: predicate failed with FalseP --- * In the Template Haskell splice $$(refinedTH 99) --- In the expression: --- $$(refinedTH 99) :: Refined (Between 100 125) Int --- In an equation for \'it\': --- it = $$(refinedTH 99) :: Refined (Between 100 125) Int --- @ --- -refinedTH :: forall p i - . (Show i, TH.Lift i, RefinedC p i) - => i - -> TH.Q (TH.TExp (Refined p i)) -refinedTH = refinedTH' ol - --- | creates a 'Refined.Refined' refinement type --- --- allows you to specify display options (eg 'ou' for unicode / 'o2' for ansi) --- --- @ --- >$$(refinedTH' o2 123) :: Refined (Between 100 125) Int --- Refined {unRefined = 123} --- it :: Refined (Between 100 125) Int --- @ --- --- @ --- >$$(refinedTH' o2 99) :: Refined (FailS "asdf" >> Between 100 125) Int --- --- <interactive>:116:4: error: --- * --- [Error asdf] lhs failed >> --- | --- `- [Error asdf] Fail asdf --- | --- `- P 'asdf --- --- refinedTH: predicate failed with FailP "asdf" --- * In the Template Haskell splice $$(refinedTH' o0 99) --- In the expression: --- $$(refinedTH' o2 99) :: --- Refined (FailS "asdf" >> Between 100 125) Int --- @ --- -refinedTH' :: forall p i - . (Show i, TH.Lift i, RefinedC p i) - => POpts - -> i - -> TH.Q (TH.TExp (Refined p i)) -refinedTH' opts i = do - let msg0 = "refinedTH" - let ((bp,e),mr) = runIdentity $ newRefined @p opts i - case mr of - Nothing -> - let msg1 = if oLite opts then "" else ("\n" ++ e ++ "\n") - in fail $ msg1 ++ msg0 ++ ": predicate failed with " ++ show bp -- ++ "\n" ++ e - Just r -> TH.TExp <$> TH.lift r - --- | creates a 'Refined3.Refined3' refinement type with terse output --- --- @ --- >$$(refined3TH 100) :: Refined3 Id (Between 100 125) Id Int --- Refined3 {r3In = 100, r3Out = 100} --- @ --- -refined3TH :: forall ip op fmt i - . (Show i, Show (PP ip i), TH.Lift i, TH.Lift (PP ip i), Refined3C ip op fmt i) - => i - -> TH.Q (TH.TExp (Refined3 ip op fmt i)) -refined3TH = refined3TH' ol - --- | creates a 'Refined3.Refined3' refinement type --- --- allows you to specify display options (eg 'ou' for unicode / 'o2' for ansi) --- --- @ --- >$$(refined3TH' o2 100) :: Refined3 Id (Between 100 125) Id Int --- Refined3 {r3In = 100, r3Out = 100} --- @ --- --- @ --- >$$(refined3TH' o2 99) :: Refined3 Id (Between 100 125) Id Int --- --- <interactive>:127:4: error: --- * --- *** Step 1. Success Initial Conversion(ip) [99] *** --- --- P Id 99 --- --- *** Step 2. False Boolean Check(op) *** --- --- False False && True --- | --- +- False 99 >= 100 --- | | --- | +- P I --- | | --- | `- P '100 --- | --- `- True 99 <= 125 --- | --- +- P I --- | --- `- P '125 --- --- refined3TH: predicate failed with Step 2. False Boolean Check(op) | FalseP --- * In the Template Haskell splice $$(refined3TH' o2 99) --- In the expression: --- $$(refined3TH' o2 99) :: Refined3 Id (Between 100 125) Id Int --- In an equation for \'it\': --- it = $$(refined3TH' o2 99) :: Refined3 Id (Between 100 125) Id Int --- @ --- -refined3TH' :: forall ip op fmt i - . (Show i, Show (PP ip i), TH.Lift i, TH.Lift (PP ip i), Refined3C ip op fmt i) - => POpts - -> i - -> TH.Q (TH.TExp (Refined3 ip op fmt i)) -refined3TH' opts i = do - let msg0 = "refined3TH" - (ret,mr) = eval3 @ip @op @fmt opts i - m3 = prt3Impl opts ret - case mr of - Nothing -> - let msg1 = if oLite opts then "" else (m3Long m3 ++ "\n") - in fail $ msg1 ++ msg0 ++ ": predicate failed with " ++ (m3Desc m3 <> " | " <> m3Short m3) - Just r -> TH.TExp <$> TH.lift r -
test/TastyExtras.hs view
@@ -18,7 +18,7 @@ module TastyExtras where import Test.Tasty import Test.Tasty.HUnit -import UtilP +import Predicate.Util import Data.Aeson import Data.List import Text.Show.Functions ()
test/TestJson.hs view
@@ -19,9 +19,9 @@ import Test.Tasty import Test.Tasty.HUnit import Predicate -import Refined -import Refined3 -import Refined3Helper +import Predicate.Refined +import Predicate.Refined3 +import Predicate.Refined3Helper import GHC.Generics (Generic) import Data.Text (Text) import Data.Aeson @@ -75,8 +75,8 @@ type Name1 = Uncons >> 'Just Id - >> Guard (Printf "not upper first(%c)" (Fst Id)) (Fst Id >> '[Id] >> IsCharSet 'CUpper) - >> Guard (Printf "not lower rest(%s)" (Snd Id)) (Snd Id >> IsCharSet 'CLower) + >> Guard (Printf "not upper first(%c)" (Fst Id)) (Fst Id >> '[Id] >> IsUpper) + >> Guard (Printf "not lower rest(%s)" (Snd Id)) (Snd Id >> IsLower) type AgeR = Refined (Between 10 60) Int
test/TestPredicate.hs view
@@ -23,9 +23,9 @@ import TestRefined import TestRefined3 import Predicate -import Refined -import Refined3 -import Refined3Helper +import Predicate.Refined +import Predicate.Refined3 +import Predicate.Refined3Helper import Data.Ratio import Data.Typeable @@ -45,8 +45,8 @@ allTests :: [IO ()] allTests = - [expectPE (PresentT LT) $ pl @("aa" === Id) "aaaa" - , expectPE FalseT $ pl @(FromEnum ("aa" === Id) >> Same 1) "aaaa" + [expectPE (PresentT LT) $ pl @("aa" ==! Id) "aaaa" + , expectPE FalseT $ pl @(FromEnum ("aa" ==! Id) >> Same 1) "aaaa" , expectPE (PresentT (Right 1)) $ pl @(HeadDef 'False Id +++ Id) (Right @[Bool] 1) -- need @[Bool] cos we said 'False! , expectPE (PresentT (Left True)) $ pl @(HeadDef 'False Id +++ Id) (Left @_ @Int [True,False]) -- need @[Bool] cos we said 'False! , expectPE (PresentT (Right True)) $ pl @(Not Id +++ Id) (Right True) @@ -63,9 +63,9 @@ , expectPE (FailT "Head(empty)") $ pl @(Head' (Fst Id) >> Le 6) ([] @Int, True) , expectPE FalseT $ pl @(HeadDef 10 (Fst Id) >> Le 6) ([],True) , expectPE (FailT "zz") $ pl @(HeadFail "zz" (Fst Id) >> Le 6) ([],True) - , expectPE (FailT "failed1") $ pl @((HeadFail "failed1" (Fst Id) >> Le 6) `OR` 'False) ([],True) - , expectPE TrueT $ pl @((Fst Id >> HeadFail "failed2" Id >> Le (6 %- 1)) `OR` 'False) ([-9],True) - , expectPE (FailT "failed3") $ pl @((Fst Id >> Failt _ "failed3" >> Le (6 %- 1)) `OR` 'False) ([-5],True) + , expectPE (FailT "failed1") $ pl @((HeadFail "failed1" (Fst Id) >> Le 6) || 'False) ([],True) + , expectPE TrueT $ pl @((Fst Id >> HeadFail "failed2" Id >> Le (6 %- 1)) || 'False) ([-9],True) + , expectPE (FailT "failed3") $ pl @((Fst Id >> Failt _ "failed3" >> Le (6 %- 1)) || 'False) ([-5],True) , expectPE TrueT $ pl @(MaybeIn 'True Id) (Nothing @Bool) -- need @() else breaks , expectPE (PresentT 10) $ pl @(MaybeIn (Failt _ "failed4") Id) (Just 10) , expectPE (PresentT 10) $ pl @(Just' Id) (Just 10) @@ -76,16 +76,16 @@ , expectPE TrueT $ pl @(Ors (Map (Gt 3) (Fst Id))) ([10,12,3,5],"ss") , expectPE FalseT $ pl @(Ands (Map (Gt 3) (Fst Id))) ([10,12,3,5],"ss") , expectPE (PresentT [False,False,False,True]) $ pl @(Map (Mod Id 3) (Fst Id) >> Map (Gt 1) Id) ([10,12,3,5],"ss") - , expectPE (PresentT (12,5)) $ pl @(Fst Id >> Dup >> Star (Ix 1 (Failp "failed5")) (Ix 3 (Failp "failed5")) >> Id) ([10,12,3,5],"ss") - , expectPE FalseT $ pl @(Fst Id >> Dup >> Star (Ix 1 (Failp "failed5")) (Ix 3 (Failp "failed5")) >> Fst Id < Snd Id) ([10,12,3,5],"ss") - , expectPE TrueT $ pl @(Fst Id >> Dup >> Star (Ix 1 (Failp "failed5")) (Ix 3 (Failp "failed5")) >> Fst Id > Snd Id) ([10,12,3,5],"ss") + , expectPE (PresentT (12,5)) $ pl @(Fst Id >> Dup >> (Ix 1 (Failp "failed5") *** Ix 3 (Failp "failed5")) >> Id) ([10,12,3,5],"ss") + , expectPE FalseT $ pl @(Fst Id >> Dup >> (Ix 1 (Failp "failed5") *** Ix 3 (Failp "failed5")) >> Fst Id < Snd Id) ([10,12,3,5],"ss") + , expectPE TrueT $ pl @(Fst Id >> Dup >> (Ix 1 (Failp "failed5") *** Ix 3 (Failp "failed5")) >> Fst Id > Snd Id) ([10,12,3,5],"ss") , expectPE TrueT $ pl @(Fst Id > Snd Id) (True,False) , expectPE FalseT $ pl @(Fst Id == Snd Id) (True,False) - , expectPE TrueT $ pl @(Star (Not Id) Id >> Fst Id == Snd Id) (True,False) + , expectPE TrueT $ pl @(Not Id*** Id >> Fst Id == Snd Id) (True,False) , expectPE FalseT $ pl @(Snd Id >> Len &&& Ix 3 (Failp "someval1") >> Fst Id == Snd Id) ('x',[1..5]) , expectPE FalseT $ pl @(Snd Id >> Len &&& Ix 3 (Failp "someval2") >> Fst Id < Snd Id) ('x',[1..5]) , expectPE TrueT $ pl @(Snd Id >> Len &&& Ix 3 (Failp "someval3") >> Fst Id > Snd Id) ('x',[1..5]) - , expectPE FalseT $ pl @(Snd Id >> SplitAt 2 Id >> Star Len Len >> Fst Id > Snd Id) ('x',[1..5]) + , expectPE FalseT $ pl @(Snd Id >> SplitAt 2 Id >> Len *** Len >> Fst Id > Snd Id) ('x',[1..5]) , expectPE FalseT $ pl @(Ors (Map (Same 2) Id)) [1,4,5] , expectPE TrueT $ pl @(Ors (Map (Same 2) Id)) [1,4,5,2,1] , expectPE TrueT $ pl @(Elem Id '[2,3,4]) 2 @@ -129,7 +129,7 @@ , expectPE (FailT "Succ IO e=Prelude.Enum.Bool.succ: bad argument") $ pl @(Succ Id) True -- captures the exception , expectPE (PresentT ([4,5,6,7,8,9,10],[1,2,3])) $ pl @(Partition (Gt 3) Id) [1..10] , expectPE (PresentT ([2,4,6],[1,3,5])) $ pl @(Partition Even Id) [1..6] - , expectPE TrueT $ pl @(Partition Even Id >> Star Null (Len >> Gt 4) >> Fst Id == Snd Id) [1..6] + , expectPE TrueT $ pl @(Partition Even Id >> Null *** (Len >> Gt 4) >> Fst Id == Snd Id) [1..6] , expectPE (PresentT 5) $ pl @(Snd Id >> Snd Id >> Snd Id >> Snd Id >> Id) (9,(1,(2,(3,5)))) , expectPE (FailT "ExitWhen") $ pl @(HeadFail "failedn" Id &&& (Len >> Same 1 >> ExitWhen' Id) >> Fst Id) [3] , expectPE (PresentT 3) $ pl @(HeadFail "failedn" Id &&& (Len >> Same 1 >> Not Id >> ExitWhen' Id) >> Fst Id) [3] @@ -140,7 +140,7 @@ , expectPE FalseT $ pl @(ExitWhen' (Len >> Ne 1) >> HeadFail "failedn" Id >> Gt (20 %- 1 )) [-23] , expectPE (PresentT (-1.0)) $ pl @(Negate Id >> Dup >> First (Succ Id) >> Swap >> Fst Id - Snd Id) 4 , expectPE (PresentT (Right 12)) $ pl @(Not Id +++ Id) (Right @Bool 12) - , expectPE (PresentT Cgt) $ pl @(FromEnum ("aa" === Id) >> ToEnum OrderingP Id) "aaaa" + , expectPE (PresentT Cgt) $ pl @(FromEnum ("aa" ==! Id) >> ToEnum OrderingP Id) "aaaa" , expectPE (PresentT False) $ pl @(Msg "someval4" (Gt 4 >> Id)) 4 , expectPE (PresentT ()) $ pl @(Snd Id >> Snd Id >> Snd Id >> Snd Id >> Id) (1,('a',(3,(True,())))) , expectPE TrueT $ pl @(Re "\\d{4}-\\d{3}" Id) "1234-123" @@ -161,7 +161,7 @@ , expectPE (PresentT [False,False,True,True,True]) $ pl @(Map (ExitWhen' (Gt 10) >> Gt 2) Id) [1..5] , expectPE (PresentT ([1,2],[3,4,5,6,7,8,9,10,11])) $ pl @(Break (Gt 2) Id) [1..11] , expectPE (PresentT ([1,2,3],[4,5,6,7,8,9,10,11])) $ pl @(Span (Lt 4) Id) [1..11] - , expectPE (PresentT [GT,GT,LT,EQ]) $ pl @(Pairs >> Map (First (Succ Id >> Succ Id) >> Fst Id === Snd Id) Id) [1,2,3,6,8] + , expectPE (PresentT [GT,GT,LT,EQ]) $ pl @(Pairs >> Map (First (Succ Id >> Succ Id) >> Fst Id ==! Snd Id) Id) [1,2,3,6,8] , expectPE TrueT $ pl @(Re "^\\d{1,3}(?:\\.\\d{1,3}){3}$" Id) "123.1.1.21" , expectPE (PresentT [("123.",["."]),("8.",["."]),("99.",["."]),("21",[])]) $ pl @(Rescan "\\d{1,3}(\\.)?" Id) "123.8.99.21" , expectPE (PresentT 117) $ pl @(MaybeIn (Failp "err") (Succ Id)) (Just 116) @@ -169,8 +169,8 @@ , expectPE (FailT "someval") $ pl @(MaybeIn (Failp "someval") (Succ Id)) (Nothing @()) , expectPE TrueT $ pl @(MaybeIn 'True 'False) (Nothing @()) , expectPE FalseT $ pl @(MaybeIn 'True 'False) (Just "aa") - , expectPE (PresentT LT) $ pl @(MaybeIn MEmptyP (Fst Id === Snd Id)) (Just ('x','z')) - , expectPE (PresentT EQ) $ pl @(MaybeIn MEmptyP (Fst Id === Snd Id)) (Nothing @(Char,Char)) + , expectPE (PresentT LT) $ pl @(MaybeIn MEmptyP (Fst Id ==! Snd Id)) (Just ('x','z')) + , expectPE (PresentT EQ) $ pl @(MaybeIn MEmptyP (Fst Id ==! Snd Id)) (Nothing @(Char,Char)) , expectPE TrueT $ pl @('True ||| 'False) (Left @_ @() "someval") , expectPE FalseT $ pl @('True ||| 'False) (Right @() "someval") , expectPE (PresentT 123) $ pl @('Left Id) (Left 123) @@ -188,8 +188,8 @@ , expectPE (PresentT []) $ pl @(MEmptyT _ ||| Ones Id) (Left @_ @[String] ["ab"]) , expectPE (PresentT ["a","b"]) $ pl @(MaybeIn MEmptyP (Ones Id)) (Just @String "ab") , expectPE (PresentT []) $ pl @(MaybeIn MEmptyP (Ones Id)) (Nothing @String) - , expectPE (PresentT (True, 13)) $ pl @(Not IsNothing &&& (Just' Id >> Add Id 12)) (Just 1) - , expectPE (FailT "expected Just") $ pl @(Not IsNothing &&& (Just' Id >> Add Id 12)) Nothing + , expectPE (PresentT (True, 13)) $ pl @(Not IsNothing &&& (Just' Id >> Id + 12)) (Just 1) + , expectPE (FailT "expected Just") $ pl @(Not IsNothing &&& (Just' Id >> Id + 12)) Nothing , expectPE (PresentT True) $ pl @(Thd Id >> Fst Id) (1,2,(True,4)) , expectPE (PresentT True) $ pl @(Fst (Thd Id)) (1,2,(True,4)) , expectPE (PresentT 'd') $ pl @(Id !! 3) ("asfd" :: T.Text) @@ -204,7 +204,7 @@ , expectPE FalseT $ pl @IsEmpty ("failed11" :: T.Text) , expectPE TrueT $ pl @IsEmpty ("" :: T.Text) , expectPE (PresentT 14) $ pl @(Unwrap Id >> Succ Id) (SG.Sum 13) - , expectPE (PresentT 4) $ pl @(MEmptyT (SG.Sum _) >> Unwrap Id >> Add Id 4) () + , expectPE (PresentT 4) $ pl @(MEmptyT (SG.Sum _) >> Unwrap Id >> Id + 4) () , expectPE (PresentT (SG.Sum 13)) $ pl @(Wrap (SG.Sum _) Id) 13 , expectPE (PresentT "a") $ pl @(Id !! MEmptyT _) (Just "a") , expectPE (FailT "(!!) index not found") $ pl @(Id !! MEmptyT _) (Nothing @()) -- had to add @() to keep this happy: ghci is fine @@ -225,7 +225,7 @@ , expectPE (PresentT LT) $ pl @(FoldN 0 Id (Succ Id)) LT , expectPE (PresentT LT) $ pl @(FoldN 2 Id (Succ Id) >> FoldN 2 Id (Pred Id)) LT , expectPE (PresentT ["2","2"]) $ pl @(Map (Fst Id) (Rescan "." (ShowP Id)) >> FilterBy (Same "2") Id) 12324 - , expectPE (PresentT [LT,LT,LT,GT,EQ,LT]) $ pl @((Ones Id << ShowP Id) >> Map (Fst Id === Snd Id) Pairs) 1234223 + , expectPE (PresentT [LT,LT,LT,GT,EQ,LT]) $ pl @((Ones Id << ShowP Id) >> Map (Fst Id ==! Snd Id) Pairs) 1234223 , expectPE (PresentT [(0,'a'),(1,'b'),(2,'c'),(3,'d')]) $ pl @(IToList _) ("abcd" :: String) , expectPE (PresentT "abcd") $ pl @ToList (M.fromList $ zip [0..] "abcd") , expectPE (PresentT [123]) $ pl @ToList (Just 123) @@ -234,11 +234,11 @@ , expectPE (FailT "err") $ pl @(MaybeIn (Failp "err") Id) (Nothing @Int) , expectPE (FailT "err") $ pl @(MaybeIn (Failp "err") Id) (Nothing @()) , expectPE (PresentT [(0,'a'),(1,'b'),(2,'c'),(3,'d')]) $ pl @(IToList _) (M.fromList $ itoList ("abcd" :: String)) - , expectPE (PresentT [('a',1),('b',2),('c',3),('d',4),('a',5),('b',6),('c',7)]) $ pl @(Ziplc "abcd" Id) [1..7] - , expectPE (PresentT [('a',1),('b',2),('c',3),('d',4)]) $ pl @(Zipn "abcd" Id) [1..7] - , expectPE (PresentT []) $ pl @(Zipn "" Id) [1..7] - , expectPE (PresentT [(1 % 1,'a'),(2 % 1,'b'),(3 % 1,'c'),(1 % 1,'d')]) $ pl @(Ziplc '[1 % 1 , 2 % 1 , 3 % 1 ] Id) "abcd" - , expectPE (PresentT []) $ pl @(Ziprc (EmptyT _ Id) Id) "abcd" + , expectPE (PresentT [('a',1),('b',2),('c',3),('d',4),('a',5),('b',6),('c',7)]) $ pl @(ZipL "abcd" Id) [1..7] + , expectPE (PresentT [('a',1),('b',2),('c',3),('d',4)]) $ pl @(ZipTrunc "abcd" Id) [1..7] + , expectPE (PresentT []) $ pl @(ZipTrunc "" Id) [1..7] + , expectPE (PresentT [(1 % 1,'a'),(2 % 1,'b'),(3 % 1,'c'),(1 % 1,'d')]) $ pl @(ZipL '[1 % 1 , 2 % 1 , 3 % 1 ] Id) "abcd" + , expectPE (PresentT []) $ pl @(ZipR (EmptyT _ Id) Id) "abcd" , expectPE (PresentT [9,2,7,4]) $ pl @ToList (M.fromList (zip ['a'..] [9,2,7,4])) , expectPE (PresentT [(0,9),(1,2),(2,7),(3,4)]) $ pl @(IToList _) [9,2,7,4] , expectPE (PresentT [('a',9),('b',2),('c',7),('d',4)]) $ pl @(IToList _) (M.fromList (zip ['a'..] [9,2,7,4])) @@ -328,9 +328,9 @@ , expectPE (FailT "invalid base 22") $ pl @(ReadBaseInt 22) "zzz" , expectPE (PresentT ("ffe0","fFe0")) $ pl @((ReadBaseInt 16 &&& Id) >> First (ShowBase 16)) "fFe0" , expectPE FalseT $ pl @(Id == "Abc") "abc" - , expectPE TrueT $ pl @("Abc" ==? Id) "abc" - , expectPE (PresentT LT) $ pl @("Abc" === Id) "abc" - , expectPE (PresentT EQ) $ pl @("Abc" ===? Id) "abc" + , expectPE TrueT $ pl @("Abc" ==~ Id) "abc" + , expectPE (PresentT LT) $ pl @("Abc" ==! Id) "abc" + , expectPE (PresentT EQ) $ pl @("Abc" ===~ Id) "abc" , expectPE (PresentT 'd') $ pl @(Id !! 3) ('a','b','c','d','e') , expectPE (PresentT 99) $ pl @(Id !! "s") $ M.fromList [("t",1), ("s", 20), ("s", 99)] , expectPE (PresentT 1) $ pl @(Head' Id) [1,2,3] @@ -338,7 +338,7 @@ , expectPE (PresentT (Just ([1,2,3,4],5))) $ pl @Unsnoc [1..5] , expectPE (PresentT [(0,1),(1,2),(2,3),(3,4),(4,5)]) $ pl @(IToList _) [1..5] , expectPE (PresentT [(0,'a'),(1,'b'),(2,'c')]) $ pl @(IToList _) ['a','b','c'] - , expectPE (PresentT [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(5,'e')]) $ pl @(Zipn (Fst Id) (Snd Id)) ([1..5],['a'..'z']) + , expectPE (PresentT [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(5,'e')]) $ pl @(ZipTrunc (Fst Id) (Snd Id)) ([1..5],['a'..'z']) , expectPE (PresentT [1,2,3,8,8]) $ pl @(PadR 5 8 Id) [1..3] , expectPE (PresentT [1,2,3,4,5]) $ pl @(PadR 5 0 Id) [1..5] , expectPE (PresentT [1,2,3,4,5,6]) $ pl @(PadR 5 0 Id) [1..6] @@ -395,13 +395,13 @@ , expectPE (PresentT "hhhhh") $ pl @(Do '["abc", "Def", "ggg", "hhhhh"]) () , expectPE (PresentT GT) $ pl @(Do '[ 'LT, 'EQ, 'GT ]) () , expectPE (PresentT (-3 % 1)) $ pl @(Do '[4 % 4,22 % 1 ,12 %- 4]) () - , expectPE (PresentT [10,2,5,8]) $ pl @(GuardsLax (ToGuardsT (Printf2 "guard(%d) %d is out of range") '[Between 0 11, Between 1 4,Between 3 5])) [10::Int,2,5,8] + , expectPE (PresentT [10,2,5,8]) $ pl @(GuardsQuickLax (Printf2 "guard(%d) %d is out of range") '[Between 0 11, Between 1 4,Between 3 5]) [10::Int,2,5,8] , expectPE (PresentT [31,11,1999]) $ pl @(Rescan DdmmyyyyRE Id >> OneP >> Map (ReadBaseInt 10) (Snd Id) >> Ddmmyyyyval) "31-11-1999" - , expectPE (PresentT [31,11,1999]) $ pl @(Guards (ToGuardsT (Printf2 "guard(%d) %d is out of range") '[Between 1 31, Between 1 12, Between 1990 2050])) [31,11,1999::Int] - , expectPE (PresentT [31,11,1999,123,44]) $ pl @(GuardsLax (ToGuardsT (Printf2 "guard(%d) %d is out of range") '[Between 1 31, Between 1 12, Between 1990 2050])) [31,11,1999,123,44::Int] - , expectPE (FailT "Guards: data elements(2) /= predicates(3)") $ pl @(Guards (ToGuardsT (Printf2 "guard(%d) %d is out of range") '[Between 1 31, Between 1 12, Between 1990 2050])) [31,11::Int] - , expectPE (FailT "guard(2) 13 is out of range") $ pl @(Guards (ToGuardsT (Printf2 "guard(%d) %d is out of range") '[Between 1 31, Between 1 12, Between 1990 2050])) [31,13,1999::Int] - , expectPE (FailT "guard(1) 0 is out of range") $ pl @(Guards (ToGuardsT (Printf2 "guard(%d) %d is out of range") '[Between 1 31, Between 1 12, Between 1990 2050])) [0,44,1999::Int] + , expectPE (PresentT [31,11,1999]) $ pl @(GuardsQuick (Printf2 "guard(%d) %d is out of range") '[Between 1 31, Between 1 12, Between 1990 2050]) [31,11,1999::Int] + , expectPE (PresentT [31,11,1999,123,44]) $ pl @(GuardsQuickLax (Printf2 "guard(%d) %d is out of range") '[Between 1 31, Between 1 12, Between 1990 2050]) [31,11,1999,123,44::Int] + , expectPE (FailT "Guards: data elements(2) /= predicates(3)") $ pl @(GuardsQuick (Printf2 "guard(%d) %d is out of range") '[Between 1 31, Between 1 12, Between 1990 2050]) [31,11::Int] + , expectPE (FailT "guard(2) 13 is out of range") $ pl @(GuardsQuick (Printf2 "guard(%d) %d is out of range") '[Between 1 31, Between 1 12, Between 1990 2050]) [31,13,1999::Int] + , expectPE (FailT "guard(1) 0 is out of range") $ pl @(GuardsQuick (Printf2 "guard(%d) %d is out of range") '[Between 1 31, Between 1 12, Between 1990 2050]) [0,44,1999::Int] , expectPE (PresentT (fromGregorian 1999 11 30)) $ pl @(ReadP Day) "1999-11-30" , expectPE (FailT "ReadP Day (1999-02-29) failed") $ pl @(ReadP Day) "1999-02-29" , expectPE (PresentT (TimeOfDay 14 59 20)) $ pl @(ReadP TimeOfDay) "14:59:20" @@ -409,8 +409,8 @@ , expectPE (FailT "ParseTimeP TimeOfDay (%H:%M%S) failed to parse") $ pl @(ParseTimeP TimeOfDay "%H:%M%S" Id) "14:04:61" , expectPE (PresentT (TimeOfDay 23 13 59)) $ pl @(Guard "hh:mm:ss regex failed" (Re HmsRE Id) >> ReadP TimeOfDay) "23:13:59" , expectPE (FailT "hh:mm:ss regex failed") $ pl @(Guard "hh:mm:ss regex failed" (Re HmsRE Id) >> ReadP TimeOfDay) "23:13:60" - , expectPE (FailT "Guards: data elements(5) /= predicates(3)") $ pl @(Guards (ToGuardsT (Printf2 "guard(%d) %d is out of range") '[Between 1 31, Between 1 12, Between 1990 2050])) [31,11,2000,1,2::Int] - , expectPE (PresentT [31,11,2000,1,2]) $ pl @(GuardsLax (ToGuardsT (Printf2 "guard(%d) %d is out of range") '[Between 1 31, Between 1 12, Between 1990 2050])) [31,11,2000,1,2::Int] + , expectPE (FailT "Guards: data elements(5) /= predicates(3)") $ pl @(GuardsQuick (Printf2 "guard(%d) %d is out of range") '[Between 1 31, Between 1 12, Between 1990 2050]) [31,11,2000,1,2::Int] + , expectPE (PresentT [31,11,2000,1,2]) $ pl @(GuardsQuickLax (Printf2 "guard(%d) %d is out of range") '[Between 1 31, Between 1 12, Between 1990 2050]) [31,11,2000,1,2::Int] , expectPE (PresentT [0,0,0,0,0,0,0,1,2,3]) $ pl @(PadL 10 0 Id) [1..3] , expectPE (PresentT (124,["1","2","2"])) $ pl @('Left Id >> (Succ Id &&& (Pred Id >> ShowP Id >> Ones Id))) (Left 123) , expectPE (PresentT [1,2,3,4]) $ pl @(GuardsN (Printf2 "guard(%d) %d is out of range") 4 (Between 0 255)) [1,2,3,4::Int] @@ -423,9 +423,9 @@ , expectPE (PresentT 0) $ pl @(LastDef 0 Id) [] , expectPE (PresentT (1,("asdf",True))) $ pl @'(1,'("asdf",'True)) () , expectPE (PresentT (1,("asdf",(True,())))) $ pl @(TupleI '[W 1,W "asdf",W 'True]) () - , expectPE (PresentT ("abc", True)) $ pl @(Theseid 'True "xyz") (This "abc") - , expectPE (PresentT ("xyz", False)) $ pl @(Theseid 'True "xyz") (That False) - , expectPE (PresentT ("abc", False)) $ pl @(Theseid 'True "xyz") (These "abc" False) + , expectPE (PresentT ("abc", True)) $ pl @(TheseId 'True "xyz") (This "abc") + , expectPE (PresentT ("xyz", False)) $ pl @(TheseId 'True "xyz") (That False) + , expectPE (PresentT ("abc", False)) $ pl @(TheseId 'True "xyz") (These "abc" False) , expectPE (PresentT ("xyz", True)) $ pl @(TheseDef '("xyz",'True) Id) (This "abc") , expectPE (PresentT ("xyz", True)) $ pl @(TheseDef '("xyz",'True) Id) (That False) , expectPE (PresentT ("abc", False)) $ pl @(TheseDef '("xyz",'True) Id) (These "abc" False) @@ -445,8 +445,6 @@ , expectPE (PresentT 3) $ pl @(Id !! FromStringP _ "d") (M.fromList $ zip (map T.singleton "abcd") [0 ..]) , expectPE (PresentT [7,9,9,2,7,3,9,8,7,1,3]) $ pl @(Map (ReadP Int) (Ones Id) >> Guard "checkdigit fail" (Luhn Id)) "79927398713" , expectPE (FailT "checkdigit fail") $ pl @(Map (ReadP Int) (Ones Id) >> Guard "checkdigit fail" (Luhn Id)) "79927398714" - , expectPE TrueT $ pl @(Ccip >> Ccop 11) "79927398713" - , expectPE (FailT "expected 10 digits but found 11") $ pl @(Ccip >> Ccop 10) "79927398713" , expectPE (PresentT [10,14,15,9]) $ pl @(MM1 16 >> MM2 16) "aef9" , expectPE (FailT "invalid base 16") $ pl @(MM1 16 >> MM2 16) "aef9g" , expectPE (FailT "found empty") $ pl @(MM1 16 >> MM2 16) "" @@ -477,7 +475,7 @@ , (@?=) (Just ()) ((_TrueT # ()) ^? _TrueT) , (@?=) (Just ()) ((_FalseT # ()) ^? _FalseT) , (@?=) (Just 'x') ((_PresentT # 'x') ^? _PresentT) - , expectPE (PresentT (111,'b')) $ pl @('(123,Char1 "c") >> (Sub Id 12 *** Pred Id)) () + , expectPE (PresentT (111,'b')) $ pl @('(123,Char1 "c") >> (Id - 12 *** Pred Id)) () , expectPE (PresentT (SG.Min 19)) $ pl @((FromInteger _ 12 &&& Id) >> Fst Id + Snd Id) (SG.Min 7) , expectPE (PresentT (SG.Product 84)) $ pl @((FromInteger _ 12 &&& Id) >> Sapa) (SG.Product 7) , expectPE (PresentT (123,((),()))) $ pl @(TupleI '[W 123,()]) 99 @@ -489,10 +487,8 @@ , expectPE (PresentT (concat (replicate 4 "abc"))) $ pl @(STimes (Fst Id) (Snd Id)) (4,"abc") , expectPE (PresentT (concat (replicate 4 "abc"))) $ pl @(STimes 4 Id) "abc" , expectPE (PresentT "abcd") $ pl @(Map (FromEnum Id) Id >> Map (ToEnum Char Id) Id) ("abcd" :: String) - , expectPE (FailT "ToEnum IO e=Prelude.Enum.Ordering.toEnum: bad argument(2)") $ pl @(Map (FromEnum Id) Id >> Map (Sub Id 97 >> ToEnum Ordering Id) Id) ("abcde" :: String) + , expectPE (FailT "ToEnum IO e=Prelude.Enum.Ordering.toEnum: bad argument(2)") $ pl @(Map (FromEnum Id) Id >> Map (Id - 97 >> ToEnum Ordering Id) Id) ("abcde" :: String) , expectPE (PresentT ([2,3,5,7,11,13], [1,4,6,8,9,10,12,14,15])) $ pl @(Partition (Prime Id) Id) [1..15] - , expectPE (PresentT Nothing) $ pl @Nothing' (Nothing @Int) - , expectPE (FailT "expected Nothing") $ pl @Nothing' (Just 10) , expectPE (FailT "'Nothing found Just") $ pl @'Nothing (Just 12) , expectPE (PresentT (Just 10,((),()))) $ pl @(Id &&& '() &&& ()) (Just 10) , expectPE (PresentT [(-999) % 1,10 % 1,20 % 1,(-999) % 1,30 % 1]) $ pl @(Map (Wrap (MM.First _) Id &&& (Pure Maybe (999 %- 1 ) >> Wrap (MM.First _) Id)) Id >> Map Sapa Id >> Map (Just' (Unwrap Id)) Id) [Nothing,Just 10,Just 20,Nothing,Just 30] @@ -521,11 +517,11 @@ , expectPE (PresentT [Just 1,Just 2,Just 3,Just 4]) $ pl @Sequence (Just [1..4]) , expectPE (PresentT (Just (SG.Sum 20))) $ pl @(Pure2 SG.Sum) (Just 20) , expectPE (PresentT Nothing) $ pl @(Traverse (If (Gt 3) (Pure Maybe Id) (EmptyT Maybe Id)) Id) [1..5] - , expectPE (PresentT Nothing) $ pl @(Traverse (MaybeB (Le 3) Id) Id) [1..5] + , expectPE (PresentT Nothing) $ pl @(Traverse (MaybeBool (Le 3) Id) Id) [1..5] , expectPE (PresentT (Just [1,2,3,4,5])) $ pl @(Traverse (If (Gt 0) (Pure Maybe Id) (EmptyT Maybe Id)) Id) [1..5] , expectPE (PresentT (Just [1,2,3,4,5])) $ pl @(Traverse (If (Gt 0) (Pure Maybe Id) (MkNothing _)) Id) [1..5] - , expectPE (PresentT (Just [1,2,3,4,5])) $ pl @(Traverse (MaybeB (Id >= 0) Id) Id) [1..5] - , expectPE (PresentT Nothing) $ pl @(Traverse (MaybeB (Id <= 3) Id) Id) [1..5] + , expectPE (PresentT (Just [1,2,3,4,5])) $ pl @(Traverse (MaybeBool (Id >= 0) Id) Id) [1..5] + , expectPE (PresentT Nothing) $ pl @(Traverse (MaybeBool (Id <= 3) Id) Id) [1..5] , expectPE (FailT "Printf (IO e=printf: bad formatting char 's')") $ pl @(Printf "%-6s" Id) (1234 :: Int) , expectPE (PresentT "0004d2") $ pl @(Printf "%06x" Id) (1234 :: Int) @@ -555,44 +551,44 @@ , expectPE (PresentT [1 % 1,(-3) % 2,(-3) % 1]) $ pl @'[1 % 1 ,3 %- 2,3 %- 1 ] () , expectPE (PresentT [4, 7, 8, 9]) $ pl @'[4,7,8,9] () , expectPE (PresentT ["aa","b","","ddd"]) $ pl @'["aa","b","","ddd"] () - , expectPE (PresentT 17) $ pl @(DoN 4 (Add Id 4)) 1 + , expectPE (PresentT 17) $ pl @(DoN 4 (Id + 4)) 1 , expectPE (PresentT 24) $ pl @((Id <> Id) >> Unwrap Id) (SG.Sum 12) , expectPE (PresentT "abcdef") $ pl @(Fst Id <> (Snd Id >> Fst Id)) ("abc",("def",12)) , expectPE (PresentT (SG.Sum 25)) $ pl @(Wrap _ 13 <> Id) (SG.Sum @Int 12) - , expectPE (PresentT 23) $ pl @(Add (Fst Id) (Last' (Snd Id))) (10,[12,13]) - , expectPE (PresentT (-1,12)) $ pl @(DivMod (Sub 9 (Fst Id)) (Last' (Snd Id))) (10,[12,13]) + , expectPE (PresentT 23) $ pl @(Fst Id + Last' (Snd Id)) (10,[12,13]) + , expectPE (PresentT (-1,12)) $ pl @(DivMod (9 - Fst Id) (Last' (Snd Id))) (10,[12,13]) , expectPE (PresentT [True,False,False,True]) $ pl @(Para '[ W 'True, Ge 12, W 'False, Lt 2 ]) [1,2,-99,-999] , expectPE (FailT "Para: data elements(3) /= predicates(4)") $ pl @(Para '[ W 'True, Ge 12, W 'False, Lt 2 ]) [1,2,-99] , expectPE (PresentT [True, False, False]) $ pl @(ParaLax '[ W 'True, Ge 12, W 'False, Lt 2 ]) [1,2,-99] , expectPE (FailT "Para: data elements(7) /= predicates(4)") $ pl @(Para '[ W 'True, Ge 12, W 'False, Lt 2 ]) [1,2,-99,-999,1,1,2] - , expectPE (FailT "guard(2) err 002") $ pl @(Guards (ToGuardsT (Printf2 "guard(%d) err %03d") '[ W 'True, Ge 12, W 'False, Lt 2 ])) [1,2,-99,-999] - , expectPE (FailT "Guards: data elements(3) /= predicates(4)") $ pl @(Guards (ToGuardsT (Printf2 "guard(%d) err %03d") '[ W 'True, Ge 12, W 'False, Lt 2 ])) [1,2,-99] - , expectPE (FailT "Guards: data elements(7) /= predicates(4)") $ pl @(Guards (ToGuardsT (Printf2 "guard(%d) err %03d") '[ W 'True, Ge 12, W 'True, Lt 2 ])) [1,22,-99,-999,1,1,2] - , expectPE (PresentT [1,22,-99,-999,1,1,2]) $ pl @(GuardsLax (ToGuardsT (Printf2 "guard(%d) err %03d") '[ W 'True, Ge 12, W 'True, Lt 2 ])) [1,22,-99,-999,1,1,2] - , expectPE (PresentT [1,22]) $ pl @(GuardsLax (ToGuardsT (Printf2 "guard(%d) err %03d") '[ W 'True, Ge 12, W 'True, Lt 2 ])) [1,22] - , expectPE (PresentT [1,22,-99,-999]) $ pl @(Guards (ToGuardsT (Printf2 "guard(%d) err %03d") '[ W 'True, Ge 12, W 'True, Lt 2 ])) [1,22,-99,-999] + , expectPE (FailT "guard(2) err 002") $ pl @(GuardsQuick (Printf2 "guard(%d) err %03d") '[ W 'True, Ge 12, W 'False, Lt 2 ]) [1,2,-99,-999] + , expectPE (FailT "Guards: data elements(3) /= predicates(4)") $ pl @(GuardsQuick (Printf2 "guard(%d) err %03d") '[ W 'True, Ge 12, W 'False, Lt 2 ]) [1,2,-99] + , expectPE (FailT "Guards: data elements(7) /= predicates(4)") $ pl @(GuardsQuick (Printf2 "guard(%d) err %03d") '[ W 'True, Ge 12, W 'True, Lt 2 ]) [1,22,-99,-999,1,1,2] + , expectPE (PresentT [1,22,-99,-999,1,1,2]) $ pl @(GuardsQuickLax (Printf2 "guard(%d) err %03d") '[ W 'True, Ge 12, W 'True, Lt 2 ]) [1,22,-99,-999,1,1,2] + , expectPE (PresentT [1,22]) $ pl @(GuardsQuickLax (Printf2 "guard(%d) err %03d") '[ W 'True, Ge 12, W 'True, Lt 2 ]) [1,22] + , expectPE (PresentT [1,22,-99,-999]) $ pl @(GuardsQuickLax (Printf2 "guard(%d) err %03d") '[ W 'True, Ge 12, W 'True, Lt 2 ]) [1,22,-99,-999] , expectPE TrueT $ pl @(Fst Id /= Snd Id) ("ab","xyzabw") , expectPE FalseT $ pl @(Fst Id == Snd Id) ("ab","xyzabw") , expectPE (PresentT 157) $ pl @(Fst Id * (Snd Id >> Fst Id) + (Snd Id >> Snd Id) `Div` 2) (12,(13,3)) , expectPE TrueT $ pl @(Fst Id >= Snd Id || Snd Id > 23 || 12 %- 5 <= ToRational (Fst Id)) (12,13) - , expectPE (PresentT LT) $ pl @(Fst Id === Snd Id) (3,12) - , expectPE TrueT $ pl @(Fst Id ==? Snd Id) ("aBc","AbC") - , expectPE (PresentT EQ) $ pl @(Fst Id ===? Snd Id) ("aBc","AbC") + , expectPE (PresentT LT) $ pl @(Fst Id ==! Snd Id) (3,12) + , expectPE TrueT $ pl @(Fst Id ==~ Snd Id) ("aBc","AbC") + , expectPE (PresentT EQ) $ pl @(Fst Id ===~ Snd Id) ("aBc","AbC") , expectPE FalseT $ pl @(Fst Id == Snd Id) ("aBc","AbC") - , expectPE (PresentT GT) $ pl @(Fst Id === Snd Id) ("aBc","AbC") - , expectPE (PresentT LT) $ pl @(Snd Id === Fst Id) ("aBc","AbC") - , expectPE TrueT $ pl @(Fst Id ==? Snd Id && Fst Id == Snd Id) ("Abc","Abc") - , expectPE (PresentT (EQ,EQ)) $ pl @(Fst Id ===? Snd Id &&& Fst Id === Snd Id) ("abc","abc") + , expectPE (PresentT GT) $ pl @(Fst Id ==! Snd Id) ("aBc","AbC") + , expectPE (PresentT LT) $ pl @(Snd Id ==! Fst Id) ("aBc","AbC") + , expectPE TrueT $ pl @(Fst Id ==~ Snd Id && Fst Id == Snd Id) ("Abc","Abc") + , expectPE (PresentT (EQ,EQ)) $ pl @(Fst Id ===~ Snd Id &&& Fst Id ==! Snd Id) ("abc","abc") , expectPE (PresentT "ask%dfas%kef00035 hey %") $ pl @(Printf "ask%%dfas%%kef%05d hey %%" Id) (35 :: Int) , expectPE (PresentT 100) $ pl @(Id !! 2 !! 0) [[1..5],[10..14],[100..110]] , expectPE (FailT "(!!) index not found") $ pl @(Id !! 1 !! 7) [[1..5],[10..14],[100..110]] , expectPE (PresentT '2') $ pl @(IxL Id 1 (Char1 "x")) ("123" :: T.Text) , expectPE (PresentT 'x') $ pl @(IxL Id 15 (Char1 "x")) ("123" :: T.Text) , expectPE (FailT "someval int=45") $ pl @(Fail () (Printf "someval int=%d" Id)) (45 :: Int) - , expectPE (FailT "failing with 45") $ pl @(If (Gt 4) (Fail (T _) (Printf "failing with %d" Id)) ()) 45 - , expectPE (PresentT 21) $ pl @(If (Gt 4) (Fail (T _) (Printf "failing with %d" Id)) (Id * 7)) 3 - , expectPE (PresentT ["2","1"]) $ pl @(If (Gt 4) (Fail (T _) (Printf "failing with %d" Id)) (Id * 7 >> ShowP Id >> Ones Id)) 3 - , expectPE (FailT "failing with 19") $ pl @(If (Gt 4) (Fail (T _) (Printf "failing with %d" Id)) (ShowP (Id * 7) >> Ones Id)) 19 + , expectPE (FailT "failing with 45") $ pl @(If (Gt 4) (Fail (Hole _) (Printf "failing with %d" Id)) ()) 45 + , expectPE (PresentT 21) $ pl @(If (Gt 4) (Fail (Hole _) (Printf "failing with %d" Id)) (Id * 7)) 3 + , expectPE (PresentT ["2","1"]) $ pl @(If (Gt 4) (Fail (Hole _) (Printf "failing with %d" Id)) (Id * 7 >> ShowP Id >> Ones Id)) 3 + , expectPE (FailT "failing with 19") $ pl @(If (Gt 4) (Fail (Hole _) (Printf "failing with %d" Id)) (ShowP (Id * 7) >> Ones Id)) 19 , expectPE (PresentT 31) $ pl @(DoN 4 (Id + 7)) 3 , expectPE (PresentT 9) $ pl @(DoN 4 9) () , expectPE (PresentT 3) $ pl @(Do '[1,2,3]) () @@ -662,8 +658,6 @@ , expectPE (PresentT "hello") $ pl @Extract (10,"hello") , expectPE (PresentT (M.fromList [(4,"x"),(5,"dd")])) $ pl @(FromList (M.Map _ _)) [(4,"x"),(5,"dd")] , expectPE (PresentT False) $ pl @(FromList (M.Map _ _) >> I !! Char1 "y") [('x',True),('y',False)] - -- FromListF works only if OverloadedLists is on --- , expectPE (PresentT (M.fromList [(4,"x"),(5,"dd")])) $ pl @(FromListF (M.Map _ _)) [(4,"x"),(5,"dd")] , expectPE (PresentT (Just False)) $ pl @(FromList (M.Map _ _) >> Lookup Id (Char1 "y")) [('x',True),('y',False)] , expectPE (PresentT Nothing) $ pl @(FromList (M.Map _ _) >> Lookup Id (Char1 "z")) [('x',True),('y',False)] , expectPE (FailT "index('z') not found") $ pl @(FromList (M.Map _ _) >> (Char1 "z" &&& Lookup Id (Char1 "z")) >> If (Snd Id >> IsNothing) (ShowP (Fst Id) >> Fail I (Printf "index(%s) not found" Id) >> 'False) (Snd Id >> 'Just Id)) [('x',True),('y',False)] @@ -671,13 +665,13 @@ , expectPE (FailT "index('z') not found") $ pl @(FromList (M.Map _ _) >> Lookup' _ Id (Char1 "z")) [('x',True),('y',False)] , expectPE (PresentT ["abc","bcd","cde","def","efg","fgh","ghi","hi","i"]) $ pl @(Unfoldr (If Null (MkNothing _) ('(Take 3 Id, Drop 1 Id) >> MkJust Id)) Id) "abcdefghi" , expectPE (PresentT [[1,2],[3,4],[5]]) $ pl @(Unfoldr (If Null (MkNothing _) (Pure _ (SplitAt 2 Id))) Id) [1..5] - , expectPE (PresentT [[1,2],[3,4],[5]]) $ pl @(Unfoldr (MaybeB (Not Null) (SplitAt 2 Id)) Id) [1..5] + , expectPE (PresentT [[1,2],[3,4],[5]]) $ pl @(Unfoldr (MaybeBool (Not Null) (SplitAt 2 Id)) Id) [1..5] , expectPE (PresentT [99,1,2,3,4,5]) $ pl @(FlipT (:+) (Fst Id) (Snd Id)) ([1..5],99) , expectPE (PresentT [99,1,2,3,4,5]) $ pl @(Fst Id :+ Snd Id) (99,[1..5]) , expectPE (PresentT [[99],[1,99],[2,1,99],[3,2,1,99],[4,3,2,1,99],[5,4,3,2,1,99]]) $ pl @(Scanl (Snd Id :+ Fst Id) (Fst Id) (Snd Id)) ([99],[1..5]) , expectPE (PresentT [[99]]) $ pl @(Scanl (Snd Id :+ Fst Id) (Fst Id) (Snd Id)) ([99],[]) , expectPE (FailT "yy") $ pl @(Unfoldr (If Null (MkNothing _) (Guard "yy" (Len < 3) >> Pure _ (SplitAt 2 Id))) Id) [1..5] - , expectPE (FailT "yy") $ pl @(Unfoldr (MaybeB (Not Null) (Guard "yy" (Len < 3) >> SplitAt 2 Id)) Id) [1..5] + , expectPE (FailT "yy") $ pl @(Unfoldr (MaybeBool (Not Null) (Guard "yy" (Len < 3) >> SplitAt 2 Id)) Id) [1..5] , expectPE (PresentT [4,1,2,3]) $ pl @(4 :+ '[1,2,3]) () , expectPE (PresentT [1,2,3,4]) $ pl @('[1,2,3] +: 4) () , expectPE (PresentT [4,1,2,3]) $ pl @(Fst Id :+ Snd Id) (4,[1,2,3]) @@ -721,7 +715,7 @@ , expectPE (PresentT (-5 % 3)) $ pl @(5 % 1 / 3 %- 1 ) 'x' , expectPE (PresentT (-5 % 3)) $ pl @(5 %- 1 / Fst Id) (3,'x') , expectPE (PresentT (-5 % 3)) $ pl @(Snd Id / Fst Id) (-3,5) - , expectPE (FailT "DivF zero denominator") $ pl @(Snd Id / Fst Id) (0,5) + , expectPE (FailT "(/) zero denominator") $ pl @(Snd Id / Fst Id) (0,5) , expectPE (PresentT 16) $ pl @(Foldl (Guard "someval" (Fst Id < Snd Id) >> Snd Id) (Head' Id) Tail) [1,4,7,9,16] , expectPE (FailT "7 not less than 6") $ pl @(Foldl (Guard (Printf2 "%d not less than %d") (Fst Id < Snd Id) >> Snd Id) (Head' Id) Tail) [1,4,7,6,16::Int] , expectPE (PresentT (True,16)) $ pl @(Foldl (If ((Fst Id >> Fst Id) && (Snd Id > Snd (Fst Id))) '( 'True, Snd Id ) '( 'False, Snd (Fst Id) )) '( 'True, Head' Id ) Tail) [1,4,7,9,16] @@ -746,8 +740,8 @@ , expectPE (PresentT (Nothing @(SG.Sum _))) $ pl @(MEmptyT' Id) (Just (SG.Sum 12)) , expectPE (PresentT ([4,99],"xy")) $ pl @PartitionEithers [Left 4, Right 'x', Right 'y',Left 99] , expectPE (PresentT ([4,99],"xy",[(3,'b'),(5,'x')])) $ pl @PartitionThese [This 4, That 'x', That 'y',These 3 'b', This 99, These 5 'x'] - , expectPE (PresentT [1,2,3]) $ pl @(MapMaybe (MaybeB (Le 3) Id) Id) [1..5] - , expectPE (PresentT [4,5]) $ pl @(MapMaybe (MaybeB (Gt 3) Id) Id) [1..5] + , expectPE (PresentT [1,2,3]) $ pl @(MapMaybe (MaybeBool (Le 3) Id) Id) [1..5] + , expectPE (PresentT [4,5]) $ pl @(MapMaybe (MaybeBool (Gt 3) Id) Id) [1..5] , expectPE (PresentT [94,93,92,91]) $ pl @(IterateWhile (Id > 90) (Pred Id)) 94 , expectPE (PresentT [94,93,92,91,90]) $ pl @(IterateUntil (Id < 90) (Pred Id)) 94 , expectPE (PresentT [95,94,93,92,91]) $ pl @(IterateNWhile 10 (Id > 90) (Pred Id)) 95 @@ -757,8 +751,6 @@ -- check for infinite loops , expectPE (FailT "Unfoldr (9999,1):failed at i=100") $ pl @(IterateNUntil 9999 'False I) 1 , expectPE (FailT "Scanl:failed at i=100") $ pl @(Foldl (Fst Id) '() (EnumFromTo 1 9999)) () - , expectPE (PresentT [1,2,3,4,5,99]) $ pl @(MaybeX (Fst Id) (Fst (Fst Id) +: Snd Id) (Snd Id)) ([1..5],Just 99) - , expectPE (PresentT [1,2,3,4,5]) $ pl @(MaybeX (Fst Id) (Fst (Fst Id) +: Snd Id) (Snd Id)) ([1..5],Nothing) , expectPE (PresentT "a=9 b=rhs") $ pl @(TheseX (Printf "a=%d" (Succ (Snd Id))) ("b=" <> Snd Id) (Snd Id >> Printf2 "a=%d b=%s") Id) (These @Int 9 "rhs") , expectPE (PresentT "a=10") $ pl @(TheseX (Printf "a=%d" (Succ (Snd Id))) ("b=" <> Snd Id) (Snd Id >> Printf2 "a=%d b=%s") Id) (This @Int 9) , expectPE (PresentT "b=rhs") $ pl @(TheseX (Printf "a=%d" (Succ (Snd Id))) ("b=" <> Snd Id) (Snd Id >> Printf2 "a=%d b=%s") Id) (That @Int "rhs") @@ -782,7 +774,7 @@ , expectPE (FailT "char=x") $ pl @(LookupFail (Printf "char=%c" (Snd Id)) (Fst Id) 49) (map SG.Min [1::Int ..10],'x') , expectPE (FailT "someval=13") $ pl @(LeftFail (Printf "someval=%d" (Fst Id)) (Snd Id)) (13::Int,Right @(SG.Sum Int) "abc") , expectPE (FailT "someval=Right \"abc\"") $ pl @(LeftFail (Printf "someval=%s" (ShowP Id)) Id) (Right @(SG.Sum Int) "abc") - , expectPE (FailT "msg=(\"ASfd\",[]) Asdf") $ pl @(GFail Uncons (Printf "msg=%s Asdf" (ShowP Id)) (Snd Id)) ("ASfd",[]::[Int]) + , expectPE (FailT "msg=Abc def") $ pl @(HeadFail (Printf "msg=%s def" (Fst Id)) (Snd Id)) ("Abc" :: String,[]::[Int]) , expectPE (PresentT 'c') $ pl @(LookupDef' (Fst Id) (Snd Id) (Char1 "xx") Id) (['a'..'e'],2) , expectPE (PresentT 'x') $ pl @(LookupDef' (Fst Id) (Snd Id) (Char1 "xx") Id) (['a'..'e'],999) , expectPE (PresentT 'x') $ pl @(LookupDef' (Fst Id) (Snd Id) (Char1 "xx") Id) ([],2) @@ -823,11 +815,6 @@ , expectPE (PresentT "dd") $ pl @(JustDef' "dd" (Snd (Fst (Fst Id)) <> Snd Id) (Fst Id)) (Nothing,"xx") , expectPE (PresentT "xx") $ pl @(JustDef' (Snd Id) (Snd (Fst (Fst Id)) <> Snd Id) (Fst Id)) (Nothing,"xx") - , expectPE (PresentT "xxya") $ pl @((Id &&& Snd Id) >> MaybeXP (Fst (Fst (Fst Id))) (Fst (Fst (Fst Id)) <> Snd Id) (Snd Id)) ("xx",Just "ya") - , expectPE (PresentT "xxya") $ pl @((Id &&& Fst Id) >> MaybeXP (Snd (Fst (Fst Id))) (Snd (Fst (Fst Id)) <> Snd Id) (Snd Id)) (Just "ya","xx") - - , expectPE (PresentT "xx") $ pl @((Id &&& Snd Id) >> MaybeXP (Fst (Fst (Fst Id))) (Fst (Fst (Fst Id)) <> Snd Id) (Snd Id)) ("xx",Nothing) - , expectPE (PresentT "aabb") $ pl @(JustDef''' (Fst Id) (Fst (Fst Id) <> Snd Id) (Snd Id)) ("aa", Just "bb") , expectPE (PresentT "aa") $ pl @(JustDef''' (Fst Id) (Fst (Fst Id) <> Snd Id) (Snd Id)) ("aa", Nothing) , expectPE (PresentT "ssbb") $ pl @(JustDef''' (Fst Id) ("ss" <> Snd Id) (Snd Id)) ("aa", Just "bb") @@ -868,17 +855,17 @@ , expectPE (FailT "no match") $ pl @(Case (Snd Id >> Failp "no match") '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 15 , expectPE (FailT "no match for 015") $ pl @(Case (Fail (Snd Id >> Unproxy) (Printf "no match for %03d" (Fst Id))) '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 15 - , expectPE (FailT "no match for 015") $ pl @(Case (FailCase (Printf "no match for %03d" Id)) '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 15 , expectPE (FailT "no match for 015") $ pl @(Case'' (Printf "no match for %03d" Id) '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 15 + , expectPE (FailT "no match for 015") $ pl @(Case'' (Printf "no match for %03d" Id) '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 15 , expectPE (PresentT "other") $ pl @(Case "other" '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 15 , expectPE (PresentT "151515") $ pl @(Case (ShowP (Fst Id) >> Id <> Id <> Id) '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 15 , expectPE (FailT "Case:no match") $ pl @(Case' '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 15 - , expectPE (FailT "no match for -012") $ pl @(Case (FailCase (Printf "no match for %04d" Id)) '[Between 0 5, Same 6, Between 7 10] '[ 'LT, 'EQ, 'GT] Id) (-12) + , expectPE (FailT "no match for -012") $ pl @(Case'' (Printf "no match for %04d" Id) '[Between 0 5, Same 6, Between 7 10] '[ 'LT, 'EQ, 'GT] Id) (-12) , expectPE (PresentT [Left 1,Left 2,Right "fizz",Left 4,Right "buzz",Right "fizz",Left 7,Left 8,Right "fizz",Right "buzz",Left 11,Right "fizz",Left 13,Left 14,Right "fizzbuzz"]) $ pl @(Map Fizzbuzznew Id) [1..15] - , expectPE (PresentT (Left 'x')) $ pl @(EitherB (Fst Id > 10) (Snd Id >> Fst Id) (Snd Id >> Snd Id)) (7,('x',99)) - , expectPE (PresentT (Right 99)) $ pl @(EitherB (Fst Id > 10) (Snd Id >> Fst Id) (Snd Id >> Snd Id)) (11,('x',99)) - , expectPE (PresentT (Right 99)) $ pl @(EitherB (Gt 10) "found left" 99) 12 - , expectPE (PresentT (Left "found left")) $ pl @(EitherB (Gt 10) "found left" 99) 7 + , expectPE (PresentT (Left 'x')) $ pl @(EitherBool (Fst Id > 10) (Snd Id >> Fst Id) (Snd Id >> Snd Id)) (7,('x',99)) + , expectPE (PresentT (Right 99)) $ pl @(EitherBool (Fst Id > 10) (Snd Id >> Fst Id) (Snd Id >> Snd Id)) (11,('x',99)) + , expectPE (PresentT (Right 99)) $ pl @(EitherBool (Gt 10) "found left" 99) 12 + , expectPE (PresentT (Left "found left")) $ pl @(EitherBool (Gt 10) "found left" 99) 7 , expectPE (FailT "msg=someval caught(044)") $ pl @(Catch' (Failt Int "someval") (Printf2 "msg=%s caught(%03d)")) (44 :: Int) , expectPE (FailT "msg=expected list of length 1 but found length=3 caught([10,12,13])") $ pl @(Catch' OneP (Second (ShowP Id) >> Printf2 "msg=%s caught(%s)")) [10,12,13]
test/TestRefined.hs view
@@ -24,13 +24,14 @@ import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck + import Predicate -import Refined -import UtilP_TH +import Predicate.Refined +import Predicate.Util_TH +import Predicate.TH_Orphans () -- need this else refined*TH' fails for dates import Control.Lens import Data.Aeson -import TH_Orphans () -- need this else refined*TH' fails for dates import Control.Monad.Cont import Text.Show.Functions () import GHC.TypeNats (Nat)
test/TestRefined3.hs view
@@ -26,21 +26,24 @@ import Test.Tasty.QuickCheck import Predicate import TestRefined hiding (namedTests,unnamedTests,allProps) -import Refined -import Refined3 -import Refined3Helper -import UtilP_TH -import Data.Ratio +import Predicate.Refined +import Predicate.Refined3 +import Predicate.Refined3Helper +import Predicate.Util_TH +import Predicate.TH_Orphans () -- need this else refined*TH' fails for dates +import Data.Ratio import Data.Typeable import Control.Lens import Data.Time import GHC.Generics (Generic) import Data.Aeson -import TH_Orphans () -- need this else refined*TH' fails for dates import Control.Monad.Cont import Text.Show.Functions () import Data.Tree +import Test.QuickCheck ((===)) +import qualified Data.Semigroup as SG +import GHC.TypeLits (Nat) suite :: IO () suite = defaultMain $ testGroup "TestRefined3" (namedTests <> orderTests unnamedTests <> allProps) @@ -221,10 +224,13 @@ type Ipz2 = '(Id, Ip4A, Ip4B, String) -- skips fmt and just uses the original input type Ipz3 = '(Ip4A, Ip4B, Id, String) + -- need to add 'True to make it a predicate -- guards checks also that there are exactly 3 entries! +type Hmsconv = Do '[Rescan HmsRE Id, Head, (Snd Id), Map (ReadBaseInt 10) Id] + type Hmsz1 = '(Hmsconv &&& ParseTimeP TimeOfDay "%H:%M:%S" Id - , Fst Id >> Hmsval >> 'True + , Fst Id >> Hmsop >> 'True , Snd Id , String) @@ -388,3 +394,34 @@ expect3 lhs (rhs,mr) = do (@?=) lhs $ maybe (Left $ toRResults3 rhs) Right mr +type LuhnR' (n :: Nat) = MakeR3 (LuhnX n) + +type LuhnX (n :: Nat) = + '(Map (ReadP Int) (Ones Id) + , Luhn'' n >> 'True + , ConcatMap (ShowP Id) Id + , String) + +type Luhn'' (n :: Nat) = + Guard (Printfn "incorrect number of digits found %d but expected %d in [%s]" (TupleI '[Len, W n, ShowP Id])) (Len >> Same n) + >> Do '[ + Reverse + ,ZipL [1,2] Id + ,Map (Fst Id * Snd Id >> If (Id >= 10) (Id - 9) Id) Id + ,FoldMap (SG.Sum Int) Id + ] + >> Guard (Printfn "expected %d mod 10 = 0 but found %d" (TupleI '[Id, Id `Mod` 10])) (Mod Id 10 >> Same 0) + +type Luhn' (n :: Nat) = + Msg "Luhn'" (Do + '[Guard (Printfn "incorrect number of digits found %d but expected %d in [%s]" (TupleI '[Len, W n, Id])) (Len >> Same n) + ,Do + '[Ones Id + ,Map (ReadP Int) Id + ,Reverse + ,ZipL [1,2] Id + ,Map (Fst Id * Snd Id >> If (Id >= 10) (Id - 9) Id) Id + ,FoldMap (SG.Sum Int) Id + ] + ,Guard (Printfn "expected %d mod 10 = 0 but found %d" (TupleI '[Id, Id `Mod` 10])) (Mod Id 10 >> Same 0) + ])