predicate-typed 0.1.0.0 → 0.1.0.1
raw patch · 12 files changed
+7795/−7207 lines, 12 filesdep −discriminationdep −pretty-tree
Dependencies removed: discrimination, pretty-tree
Files
- ChangeLog.md +0/−1
- README.md +5/−4
- predicate-typed.cabal +8/−15
- src/Predicate.hs +7240/−6618
- src/Refined.hs +10/−10
- src/Refined3.hs +10/−10
- src/Refined3Helper.hs +35/−45
- src/UtilP.hs +16/−37
- test/TestJson.hs +3/−4
- test/TestPredicate.hs +412/−411
- test/TestRefined.hs +12/−12
- test/TestRefined3.hs +44/−40
ChangeLog.md view
@@ -1,3 +1,2 @@ # Changelog for predicate-typed -## Unreleased changes
README.md view
@@ -65,7 +65,8 @@ ### Testing out predicates When using _Refined_ the expression in _p_ must result in a True/False\ _pe2_ does not have that restriction so you can run the whole thing or the individual pieces\ -(for less detail use _pl_) +for less detail use _pl_\ +if using a unicode-supported OS then _pu_ gives you nicer rendering than _pe2_\ ```haskell >pe2 @(Resplit ":" Id >> Map (ReadP Int) Id >> Len == 3) "12:01:05" @@ -174,13 +175,13 @@ #### This example is successful as it is a valid hexadecimal and is in the range 10 though 256 ```haskell ->eitherDecode' @(Refined3 (ReadBase Int 16) (Id > 10 && Id < 256) ShowP String) "\"00fe\"" +>eitherDecode' @(Refined3 (ReadBase Int 16) (Id > 10 && Id < 256) (ShowP Id) String) "\"00fe\"" Right (Refined3 {in3 = 254, out3 = "254"}) ``` #### This example fails as the value is not a valid hexadecimal string ```haskell ->either putStrLn print $ eitherDecode' @(Refined3 (ReadBase Int 16) 'True ShowP String) "\"00feg\"" +>either putStrLn print $ eitherDecode' @(Refined3 (ReadBase Int 16) 'True (ShowP Id) String) "\"00feg\"" Error in $: Refined3:Step 1. Initial Conversion(ip) Failed | invalid base 16 ***Step 1. Initial Conversion(ip) Failed *** @@ -193,7 +194,7 @@ #### This example fails as the hexadecimal value is valid but is not between 10 and 256 ```haskell ->either putStrLn print $ eitherDecode' @(Refined3 (ReadBase Int 16) (Id > 10 && Id < 256) ShowP String) "\"00fe443a\"" +>either putStrLn print $ eitherDecode' @(Refined3 (ReadBase Int 16) (Id > 10 && Id < 256) (ShowP Id) String) "\"00fe443a\"" Error in $: Refined3:Step 2. False Boolean Check(op) | FalseP ***Step 1. Success Initial Conversion(ip) [16663610] ***
predicate-typed.cabal view
@@ -4,17 +4,17 @@ -- -- see: https://github.com/sol/hpack ----- hash: 9a478dac9f97bf4a987d2f412413056ea9656a469275286e14b91c4c1744b6e7+-- hash: cb51a770f8c870d3cd94c86e5b26c9d8d35fbc6a8b0362de9966a9e140b86421 name: predicate-typed-version: 0.1.0.0+version: 0.1.0.1 synopsis: Predicates, Refinement types and Dsl description: Please see the README on GitHub at <https://github.com/gbwey/predicate-typed#readme>-homepage: https://github.com/github.com/gbwey#readme-bug-reports: https://github.com/github.com/gbwey/issues-author: Grant Weyburne-maintainer: gbwey9@gmail.com-copyright: 2019 gbwey+homepage: https://github.com/gbwey/predicate-typed#readme+bug-reports: https://github.com/gbwey/predicate-typed/issues+author: Grant Weyburne <gbwey9@gmail.com>+maintainer: Grant Weyburne <gbwey9@gmail.com>+copyright: Copyright 2019, Grant Weyburne license: BSD3 license-file: LICENSE build-type: Simple@@ -24,8 +24,7 @@ source-repository head type: git- location: https://github.com/github.com/gbwey- subdir: predicate-typed+ location: https://github.com/gbwey/predicate-typed library exposed-modules:@@ -51,7 +50,6 @@ , containers , deepseq , directory- , discrimination , ghc-prim , lens , mtl@@ -59,7 +57,6 @@ , pcre-light , pretty , pretty-terminal- , pretty-tree , safe , semialign , template-haskell@@ -89,7 +86,6 @@ , containers , deepseq , directory- , discrimination , doctest , ghc-prim , lens@@ -99,7 +95,6 @@ , predicate-typed , pretty , pretty-terminal- , pretty-tree , safe , semialign , template-haskell@@ -135,7 +130,6 @@ , containers , deepseq , directory- , discrimination , ghc-prim , lens , mtl@@ -144,7 +138,6 @@ , predicate-typed , pretty , pretty-terminal- , pretty-tree , safe , semialign , stm
src/Predicate.hs view
@@ -1,6618 +1,7240 @@-{-# 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 MultiWayIf #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# 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 - -class P is the main class. Most of this code contains instances of this class -that evaluation of expressions at the type level. --} -module Predicate where -import UtilP -import Safe -import GHC.TypeLits (Symbol,Nat,KnownSymbol,KnownNat,ErrorMessage((:$$:),(:<>:))) -import qualified GHC.TypeLits as GL -import qualified GHC.TypeNats as GN -import Control.Lens hiding (strict,iall) -import Data.List -import Data.Text.Lens -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 -import Data.These.Lens () -import qualified Data.Align as TA -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 - --- | 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 - --- | a type level predicate for a monotonic increasing list -type Asc = Map (Fst <= Snd) Pairs >> Ands --- | a type level predicate for a strictly increasing list -type Asc' = Map (Fst < Snd) Pairs >> Ands --- | a type level predicate for a monotonic decreasing list -type Desc = Map (Fst >= Snd) Pairs >> Ands --- | a type level predicate for a strictly decreasing list -type Desc' = Map (Fst > Snd) Pairs >> Ands - --- | A predicate that determines if the value is between \'p\' and \'q\' --- The values can be rational numbers using 'Rat' or plain Natural numbers -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 -type AllPositive = Map Positive >> Ands --- | a type level predicate for all negative elements in a list -type AllNegative = Map Negative >> Ands -type Positive = Ge 0 -type Negative = Le 0 - -type AllPositive' = FoldMap SG.All (Map Positive Id) -type AllNegative' = FoldMap SG.All (Map Negative Id) - -type All x = Map x Id >> Ands -type Any x = Map x Id >> Ors - --- | 'unzip' equivalent -type Unzip = (Map Fst Id, Map Snd Id) - --- | represents a predicate using a 'Symbol' as a regular expression --- evaluates 'Re' and returns True if there is a match --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 <> showLit 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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"])] --- -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) <> "..." <> showA opts " | " q] hhs - ([], _) -> -- this is a failure cos empty string returned: so reuse p? - mkNode opts (FailT "Regex no results") [msg1 <> " no match" <> showA opts " | " q] [hh pp, hh qq] - (b, _) -> mkNode opts (PresentT b) [msg1 <> show0 opts " " b <> showLit opts " | " q] [hh pp, hh qq] - - --- | similar to 'Rescan' but gives the column start and ending positions instead of values --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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) <> "..." <> showA opts " | " q] hhs - ([], _) -> -- this is a failure cos empty string returned: so reuse p? - mkNode opts (FailT "Regex no results") [msg1 <> " no match" <> showA opts " | " q] hhs - (b, _) -> mkNode opts (PresentT b) [msg1 <> show0 opts " " b <> showLit opts " | " q] hhs - --- | splits a string on a regex delimiter --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Resplit "\\." Id) "141.201.1.22" --- Present ["141","201","1","22"] --- PresentT ["141","201","1","22"] --- -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) <> "..." <> showA opts " | " q] hhs - ([], _) -> -- this is a failure cos empty string returned: so reuse p? - mkNode opts (FailT "Regex no results") [msg1 <> " no match" <> showA opts " | " q] hhs - (b, _) -> mkNode opts (PresentT b) [msg1 <> show0 opts " " b <> showLit opts " | " q] hhs - -_MX :: Int -_MX = 100 - --- | replaces regex \'s\' with a string \'s1\' inside the value --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 as -> - let b = RR as - in mkNode opts (PresentT b) [msg0 <> showA opts " | " as] [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) Snd) (\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) Snd) (\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 <> showLit opts " " r <> showLit opts " | " ret] (hhs <> [hh rr]) - --- | a predicate for determining if a string 'Data.Text.IsText' belongs to the given character set --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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) - -type IsLower = IsCharSet 'CLower -type IsUpper = IsCharSet 'CUpper -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 - , IsText a - ) => P (IsCharSet cs) a where - type PP (IsCharSet cs) a = Bool - eval _ opts as = - let b = allOf text f as - msg0 = "IsCharSet " ++ show cs - (cs,f) = getCharSet @cs - in pure $ mkNodeB opts b [msg0 <> showA opts " | " as] [] - - --- | converts a string 'Data.Text.Lens.IsText' value to lower case --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @ToLower "HeLlO wOrld!" --- Present "hello world!" --- PresentT "hello world!" --- -data ToLower - -instance (Show a, IsText a) => P ToLower a where - type PP ToLower a = a - eval _ opts as = - let xs = as & text %~ toLower - in pure $ mkNode opts (PresentT xs) ["ToLower" <> show0 opts " " xs <> showA opts " | " as] [] - --- | converts a string 'Data.Text.Lens.IsText' value to upper case --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @ToUpper "HeLlO wOrld!" --- Present "HELLO WORLD!" --- PresentT "HELLO WORLD!" --- -data ToUpper - -instance (Show a, IsText a) => P ToUpper a where - type PP ToUpper a = a - eval _ opts as = - let xs = as & text %~ toUpper - in pure $ mkNode opts (PresentT xs) ["ToUpper" <> show0 opts " " xs <> showA opts " | " as] [] - - --- | similar to 'Data.List.inits' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 xs = inits as - in pure $ mkNode opts (PresentT xs) ["Inits" <> show0 opts " " xs <> showA opts " | " as] [] - --- | similar to 'Data.List.tails' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 xs = tails as - in pure $ mkNode opts (PresentT xs) ["Tails" <> show0 opts " " xs <> showA opts " | " as] [] - --- | split a list into single values --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @Ones [4,8,3,9] --- Present [[4],[8],[3],[9]] --- PresentT [[4],[8],[3],[9]] --- --- >>> pl @Ones [] --- Present [] --- PresentT [] --- -data Ones - -instance (as ~ [a], Show a) => P Ones as where - type PP Ones as = [as] - eval _ opts as = - let xs = map (:[]) as - in pure $ mkNode opts (PresentT xs) ["Ones" <> show0 opts " " xs <> showA opts " | " as] [] - --- | similar to 'show' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @ShowP [4,8,3,9] --- Present "[4,8,3,9]" --- PresentT "[4,8,3,9]" --- --- >>> pl @ShowP 'x' --- Present "'x'" --- PresentT "'x'" --- -data ShowP - -instance Show as => P ShowP as where - type PP ShowP as = String - eval _ opts as = - let x = show as - in pure $ mkNode opts (PresentT x) ["ShowP" <> showLit0 opts " " x <> showA opts " | " as] [] - --- | type level expression representing a formatted time --- similar to 'Data.Time.formatTime' using a type level 'Symbol' to get the formatting string --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 Snd) ("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 <> showA 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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) [msg1 <> show0 opts " " b <> showLit0 opts " | fmt=" p <> showA 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 Snd) (["%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) [msg1 <> show0 opts " " b <> showLit0 opts " | fmt=" d <> showA opts " | " q] hhs - --- | create a 'Day' from three int values passed in as year month and day --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> :set -XTypeOperators --- >>> pl @(MkDay Fst (Snd >> Fst) (Snd >> Snd)) (2019,(12,30)) --- Present Just (2019-12-30,(1,1)) --- PresentT (Just (2019-12-30,(1,1))) --- --- >>> pl @(MkDay Fst (Snd >> Fst) (Snd >> Snd)) (2019,(99,99999)) --- Present Nothing --- PresentT Nothing --- --- >>> pl @(MkDay Fst (Snd >> Fst) (Snd >> Snd)) (1999,(3,13)) --- Present Just (1999-03-13,(10,6)) --- PresentT (Just (1999-03-13,(10,6))) --- -data MkDay p q r -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) [msg0 <> show0 opts " " b <> showA opts " | (y,m,d)=" (p,q,r)] (hhs <> [hh rr]) - --- | uncreate a 'Day' returning year month and day --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @UnMkDay (read "2019-12-30") --- Present (2019,(12,30)) --- PresentT (2019,(12,30)) --- -data UnMkDay -instance a ~ Day => P UnMkDay a where - type PP UnMkDay a = (Int, (Int, Int)) - eval _ opts day = - let msg0 = "UnMkDay" - (y,m,d) = toGregorian day - b = (fromIntegral y,(m,d)) - in pure $ mkNode opts (PresentT b) [msg0 <> show0 opts " " b <> showA opts " | " day] [] - --- | uses the 'Read' of the given type \'t\' and \'p\' which points to the content to read --- --- >>> :set -XTypeApplications --- >>> :set -XTypeOperators --- >>> :set -XDataKinds --- >>> 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) [msg1 <> show0 opts " " b <> showLit opts " | " s] [hh pp] - _ -> mkNode opts (FailT (msg1 <> " failed")) [msg1 <> " failed"] [hh pp] - --- | similar to 'minimum' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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' = - pure $ case as' of - [] -> mkNode opts (FailT "empty list") ["Min(empty list)"] [] - as@(_:_) -> - let v = minimum as - in mkNode opts (PresentT v) ["Min" <> show0 opts " " v <> showA opts " | " as] [] - --- | similar to 'maximum' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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' = - pure $ case as' of - [] -> mkNode opts (FailT "empty list") ["Max(empty list)"] [] - as@(_:_) -> - let v = maximum as - in mkNode opts (PresentT v) ["Max" <> show0 opts " " v <> showA opts " | " as] [] - --- | sort a list --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(SortOn Fst 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 *** Map Snd) -- just do map snd in code --- pp <- eval (Proxy @(Partition (p >> (Id == 'GT)) Id >> (Map Snd *** Map Snd))) 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' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 n = length as - in pure $ mkNode opts (PresentT n) ["Len" <> show0 opts " " n <> showA opts " | " as] [] - --- | similar to 'length' for 'Foldable' instances --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 --- -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) [msg0 <> show0 opts " " n <> showA opts " | " as] [] - --- | similar to 'Control.Lens._1' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(FstL _ Id) (10,"Abc") --- Present 10 --- PresentT 10 --- -data FstL' t p -type FstL (t :: Type) p = FstL' (Hole t) p - -instance (PP p x ~ s - , P p x - , Show s - , Field1 s s (PP t x) (PP t x) - , Show (PP t x) - ) => P (FstL' t p) x where - type PP (FstL' t p) x = PP t x - eval _ opts x = do - let msg0 = "FstL" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let a = p ^. _1 - in mkNode opts (PresentT a) [msg0 <> show0 opts " " a <> showA opts " | " p] [hh pp] - --- | similar to 'Control.Lens._2' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(SndL _ Id) (10,"Abc") --- Present "Abc" --- PresentT "Abc" --- -data SndL' t p -type SndL (t :: Type) p = SndL' (Hole t) p - -instance (PP p x ~ s - , P p x - , Show s - , Field2 s s (PP t x) (PP t x) - , Show (PP t x) - ) => P (SndL' t p) x where - type PP (SndL' t p) x = PP t x - eval _ opts x = do - let msg0 = "SndL" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let a = p ^. _2 - in mkNode opts (PresentT a) [msg0 <> show0 opts " " a <> showA opts " s=" p] [hh pp] - --- | similar to 'Control.Lens._3' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(ThdL _ Id) (10,"Abc",'x') --- Present 'x' --- PresentT 'x' --- -data ThdL' t p -type ThdL (t :: Type) p = ThdL' (Hole t) p - -instance (PP p x ~ s - , P p x - , Show s - , Field3 s s (PP t x) (PP t x) - , Show (PP t x) - ) => P (ThdL' t p) x where - type PP (ThdL' t p) x = PP t x - eval _ opts x = do - let msg0 = "ThdL" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let a = p ^. _3 - in mkNode opts (PresentT a) [msg0 <> show0 opts " " a <> showA opts " | " p] [hh pp] - --- since we support '(,,,) so have to support Field4 to be able to retrieve those values - --- | similar to 'Control.Lens._4' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(FthL _ Id) (10,"Abc",'x',True) --- Present True --- PresentT True --- -data FthL' t p -type FthL (t :: Type) p = FthL' (Hole t) p - -instance (PP p x ~ s - , P p x - , Show s - , Field4 s s (PP t x) (PP t x) - , Show (PP t x) - ) => P (FthL' t p) x where - type PP (FthL' t p) x = PP t x - eval _ opts x = do - let msg0 = "FthL" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts msg0 pp [] of - Left e -> e - Right p -> - let a = p ^. _4 - in mkNode opts (PresentT a) [msg0 <> show0 opts " " a <> showA opts " | " p] [hh pp] - --- | similar to 'fst' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @Fst (10,"Abc") --- Present 10 --- PresentT 10 --- -data Fst - -instance (Show x, Show a) => P Fst (a,x) where - type PP Fst (a,x) = a - eval _ opts (a,x) = - pure $ mkNode opts (PresentT a) ["Fst" <> show0 opts " " a <> showA opts " | " (a,x)] [] - --- | similar to 'snd' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @Snd (10,"Abc") --- Present "Abc" --- PresentT "Abc" --- -data Snd - -instance (Show x, Show b) => P Snd (x,b) where - type PP Snd (x,b) = b - eval _ opts (x,b) = - pure $ mkNode opts (PresentT b) ["Snd" <> show0 opts " " b <> showA opts " | " (x,b)] [] - - --- | 'fst' for a 3-tuple --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @Fst3 (10,"Abc",True) --- Present 10 --- PresentT 10 --- -data Fst3 - -instance (Show x, Show y, Show a) => P Fst3 (a,x,y) where - type PP Fst3 (a,x,y) = a - eval _ opts (a,x,y) = - pure $ mkNode opts (PresentT a) ["Fst3" <> show0 opts " " a <> showA opts " | " (a,x,y)] [] - --- | 'snd' for a 3-tuple --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @Snd3 (10,"Abc",True) --- Present "Abc" --- PresentT "Abc" --- -data Snd3 - -instance (Show x, Show y, Show b) => P Snd3 (x,b,y) where - type PP Snd3 (x,b,y) = b - eval _ opts (x,b,y) = - pure $ mkNode opts (PresentT b) ["Snd3" <> show0 opts " " b <> showA opts " | " (x,b,y)] [] - --- | access to third element in a 3-tuple --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @Thd3 (10,True,"Abc") --- Present "Abc" --- PresentT "Abc" --- -data Thd3 - -instance (Show x, Show y, Show b) => P Thd3 (x,y,b) where - type PP Thd3 (x,y,b) = b - eval _ opts (x,y,b) = - pure $ mkNode opts (PresentT b) ["Thd3" <> show0 opts " " b <> showA opts " | " (x,y,b)] [] - --- | identity function --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @I 23 --- Present 23 --- PresentT 23 -data I -instance P I a where - type PP I a = a - eval _ opts a = - pure $ mkNode opts (PresentT a) ["I"] [] - - --- | identity function that displays the input --- --- even more constraints than 'I' so we might need to add explicit type signatures --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @Id 23 --- Present 23 --- PresentT 23 -data Id -- showable version of I -instance Show a => P Id a where - type PP Id a = a - eval _ opts a = pure $ mkNode opts (PresentT a) ["Id" <> show0 opts " " a] [] - - --- | identity function that also displays the type information for debugging --- --- even more constraints than 'Id' so we might need to explicitly add types (Typeable) --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 t = showT @a - in pure $ mkNode opts (PresentT a) ["IdT(" <> t <> ")" <> show0 opts " " a] [] - --- | 'fromString' function --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> :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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | " n] [hh nn] - --- | 'toRational' function --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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) [msg0 <> show0 opts " " r <> showA opts " | " a] [hh pp] - --- | 'fromRational' function --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | " r] [hh rr] - --- | 'truncate' function --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | " p] [hh pp] - --- | 'ceiling' function --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | " p] [hh pp] - --- | 'floor' function --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | " p] [hh pp] - --- Start non-Type kinds ------------------------ ------------------------ ------------------------ - --- | pulls the type level 'Bool' to the value level --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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.&&&' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @'(Snd, Fst) ("helo",123) --- Present (123,"helo") --- PresentT (123,"helo") --- --- >>> :set -XTypeOperators --- >>> pl @'(Len, Id <> "|" <> Reverse) "helo" --- Present (4,"helo|oleh") --- PresentT (4,"helo|oleh") -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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @'(Len, Id, Reverse) "helo" --- Present (4,"helo","oleh") --- PresentT (4,"helo","oleh") -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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @'(Len, Id, "inj", 999) "helo" --- Present (4,"helo","inj",999) --- PresentT (4,"helo","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' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 \'() --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 \'[] --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> :set -XNoStarIsType --- >>> 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] --- --- >>> pl @'[W 1, W 2, W 3, Id * 4, Pred] 999 --- Present [1,2,3,3996,998] --- PresentT [1,2,3,3996,998] --- --- >>> :set -XTypeOperators --- >>> pl @'[Id * 4, Pred] 999 --- Present [3996,998] --- PresentT [3996,998] -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 msg = "" -- "'[](end)" - pure $ case getValueLR opts msg pp [] of - Left e -> e - Right b -> mkNode opts (PresentT [b]) [msg <> show0 opts " " b <> showA opts " | " a] [hh pp] -- <> show0 opts " " a <> showA 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 msg = "'" - -- len = 2 + getLen @ps - lr <- runPQ msg (Proxy @p) (Proxy @(p1 ': ps)) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - mkNode opts (PresentT (p:q)) [msg <> show0 opts "" (p:q) <> showA opts " | " a] [hh pp, hh qq] - --- | extracts the \'a\' from type level \'Maybe a\' if the value exists --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @('Just Id) (Just 123) --- Present 123 --- PresentT 123 --- --- >>> pl @('Just Not) (Just True) --- Present False --- PresentT False --- --- >>> 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 msg = "'Just" - case ma of - Just a -> do - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts msg pp [] of - Left e -> e - Right b -> mkNode opts (PresentT b) [msg <> show0 opts " " b <> showA opts " | " ma] [hh pp] - Nothing -> pure $ mkNode opts (FailT (msg <> " found Nothing")) [msg <> " found Nothing"] [] - --- | expects Nothing otherwise it fails --- if the value is Nothing then it returns \'Proxy a\' as this provides more information than '()' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 msg = "'Nothing" - in pure $ case ma of - Nothing -> mkNode opts (PresentT Proxy) [msg] [] - Just _ -> mkNode opts (FailT (msg <> " found Just")) [msg <> " found Just"] [] - --- omitted Show x so we can have less ambiguity --- | extracts the \'a\' from type level \'Either a b\' if the value exists --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 msg = "'Left" - in case lr of - Right _ -> pure $ mkNode opts (FailT (msg <> " found Right")) [msg <> " found Right"] [] - Left a -> do - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts msg pp [] of - Left e -> e - Right b -> mkNode opts (_tBool pp) [msg <> show0 opts " " b <> showA opts " | Left " a] [hh pp] - --- | extracts the \'b\' from type level \'Either a b\' if the value exists --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 msg = "'Right" - case lr of - Left _ -> pure $ mkNode opts (FailT (msg <> " found Left")) [msg <> " found Left"] [] - Right a -> do - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts msg pp [] of - Left e -> e - Right b -> mkNode opts (_tBool pp) [msg <> show0 opts " " b <> showA opts " | 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 msg = "'This" - case th of - This a -> do - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts msg pp [] of - Left e -> e - Right b -> mkNode opts (_tBool pp) [msg <> show0 opts " " b <> showA opts " | This " a] [hh pp] - _ -> pure $ mkNode opts (FailT (msg <> " found " <> showThese th)) [msg <> " found " <> showThese th] [] - --- | extracts the \'b\' from type level \'These a b\' if the value exists --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 msg = "'That" - case th of - That a -> do - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts msg pp [] of - Left e -> e - Right b -> mkNode opts (_tBool pp) [msg <> show0 opts " " b <> showA opts " | That " a] [hh pp] - _ -> pure $ mkNode opts (FailT (msg <> " found " <> showThese th)) [msg <> " found " <> showThese th] [] - - --- | extracts the (a,b) from type level 'These a b' if the value exists --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @('These Id Id) (These 123 "abc") --- Present (123,"abc") --- PresentT (123,"abc") --- --- >>> pl @('These Pred Len) (These 123 "abcde") --- Present (122,5) --- PresentT (122,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 msg = "'These" - case th of - These a b -> do - pp <- eval (Proxy @p) opts a - case getValueLR opts msg pp [] of - Left e -> pure e - Right p -> do - qq <- eval (Proxy @q) opts b - pure $ case getValueLR opts (msg <> " q failed p=" <> show p) qq [hh pp] of - Left e -> e - Right q -> mkNode opts (PresentT (p,q)) [msg <> show0 opts " " (p,q) <> showA opts " | " (These a b)] [hh pp, hh qq] - _ -> pure $ mkNode opts (FailT (msg <> " found " <> showThese th)) [msg <> " found " <> showThese th] [] - --- | converts the value to the corresponding 'Proxy' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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" <> showA opts " | " a] [] - --- End non-Type kinds ------------------------ ------------------------ ------------------------ - --- | converts a value to a 'Proxy': the same as '\'Proxy' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 b = Proxy @a - in pure $ mkNode opts (PresentT b) ["MkProxy" <> showA 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.>>' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Do [Pred, ShowP, Id &&& Len]) 9876543 --- Present ("9876542",7) --- PresentT ("9876542",7) --- -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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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\' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(EitherB (Fst > 4) (Snd >> Fst) (Snd >> Snd)) (24,(-1,999)) --- Present Right 999 --- PresentT (Right 999) --- --- >>> pl @(EitherB (Fst > 4) (Snd >> Fst) (Snd >> Snd)) (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 <> " p 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(TupleI '[Id,ShowP,Pred,W "str", W 999]) 666 --- Present (666,("666",(665,("str",(999,()))))) --- PresentT (666,("666",(665,("str",(999,()))))) --- -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 msg = "TupleI" -- "'[](" <> show len <> ")" - case getValueLR opts msg pp [] of - Left e -> pure e - Right w -> do - qq <- eval (Proxy @(TupleI ps)) opts a - pure $ case getValueLR opts msg 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)) [msg <> show0 opts " " a] [hh pp, hh qq] - --- | type level representation of signed rational numbers/integers --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> :set -XNoStarIsType --- >>> pl @(NegR 14 3) () --- Present (-14) % 3 --- PresentT ((-14) % 3) --- --- >>> pl @(PosR 14 3) () --- Present 14 % 3 --- PresentT (14 % 3) --- --- >>> pl @(CmpRat (NegR 14 3) (Neg 5)) () --- Present GT --- PresentT GT --- --- >>> pl @(NegR 14 3 * Neg 5) () --- Present 70 % 3 --- PresentT (70 % 3) --- --- >>> pl @(NegR 14 3 - Pos 5) () --- Present (-29) % 3 --- PresentT ((-29) % 3) --- --- >>> pl @(CmpRat (PosR 14 3) 5) () --- Present LT --- PresentT LT - -data Rat (pos :: Bool) (num :: Nat) (den :: Nat) --- | constructs a positive integer as a rational number 'Rat' -type Pos (n :: Nat) = Rat 'True n 1 --- | constructs a negative integer as a rational number 'Rat' -type Neg (n :: Nat) = Rat 'False n 1 - --- | constructs a valid positive rational number 'Rat' -type family PosR (n :: Nat) (d :: Nat) where - PosR n 0 = GL.TypeError ('GL.Text "PosR has a 0 denominator where numerator=" ':<>: 'GL.ShowType n) - PosR n d = Rat 'True n d - --- | constructs a valid negative rational number 'Rat' -type family NegR (n :: Nat) (d :: Nat) where - NegR n 0 = GL.TypeError ('GL.Text "NegR has a 0 denominator where numerator=" ':<>: 'GL.ShowType n) - NegR n d = Rat 'False n d - -instance (GetBool pos - , KnownNat num - , KnownNat den - , NotZeroT den - ) => P (Rat pos num den) a where - type PP (Rat pos num den) a = Rational - eval _ opts _ = - let pos = getBool @pos - num = nat @num - den = nat @den - msg = "Rat " <> show r - r = (if pos then id else negate) (num % den) - in pure $ mkNode opts (PresentT r) [msg] [] - --- | compares 2 numbers where the numbers are type level signed rationals or Nats -type family CmpRat (m :: k) (n :: k1) :: Ordering where - CmpRat (Rat x n 0) z = GL.TypeError ('GL.Text "CmpRat: lhs has 0 denominator" ':$$: 'GL.ShowType (Rat x n 0) ':<>: 'GL.Text " `CmpRat` " ':<>: 'GL.ShowType z) - CmpRat z (Rat x n 0) = GL.TypeError ('GL.Text "CmpRat: rhs has 0 denominator" ':$$: 'GL.ShowType z ':<>: 'GL.Text " `CmpRat` " ':<>: 'GL.ShowType (Rat x n 0)) - CmpRat (m :: Nat) (n :: Nat) = GN.CmpNat m n - CmpRat (Rat x n d) (w :: Nat) = CmpRat (Rat x n d) (Pos w) - CmpRat (w :: Nat) (Rat x n d) = CmpRat (Pos w) (Rat x n d) - CmpRat (Rat x 0 d) (Rat x1 0 d1) = 'EQ - CmpRat (Rat 'True n d) (Rat 'False n1 d1) = 'GT - CmpRat (Rat 'False n d) (Rat 'True n1 d1) = 'LT - CmpRat (Rat 'False n d) (Rat 'False n1 d1) = - CmpRat (Rat 'True n1 d1) (Rat 'True n d) - CmpRat (Rat 'True n d) (Rat 'True n1 d1) = - IfT (GN.CmpNat (GN.Div n d) (GN.Div n1 d1) DE.== 'EQ) - (GN.CmpNat (n GN.* d1) (n1 GN.* d)) - (GN.CmpNat (GN.Div n d) (GN.Div n1 d1)) - --- | get a list of 'Rational's from the type level -class GetRats as where - getRats :: [Rational] -instance GetRats '[] where - getRats = [] -instance (GetRat n, GetRats ns) => GetRats (n ': ns) where - getRats = getRat @n : getRats @ns - --- | get a 'Rational' from the type level -class GetRat a where - getRat :: Rational -instance KnownNat n => GetRat (n :: Nat) where - getRat = nat @n -instance (GetBool pos, KnownNat num, KnownNat den, NotZeroT den) => GetRat (Rat (pos :: Bool) (num :: Nat) (den :: Nat)) where - getRat = let s = getBool @pos - n = nat @num - d = nat @den - in (if s then 1 else (-1)) * n % d - --- | add a message to give more context to the evaluation tree --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pe @(Msg' "somemessage" Id) 999 --- P [somemessage] Id 999 --- PresentT 999 --- -data Msg prt p -type Msg' prt p = Msg (Printf "[%s] " prt) p -- put msg in square brackets - -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 - --- | pad \'q\' with '\n'\ values from '\p'\ --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(PadL 5 999 Id) [12,13] --- Present [999,999,999,12,13] --- PresentT [999,999,999,12,13] --- --- >>> pl @(PadR 5 Fst '[12,13]) (999,'x') --- Present [12,13,999,999,999] --- PresentT [12,13,999,999,999] --- --- >>> pl @(PadR 2 Fst '[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) [msg1 <> show0 opts " " bs <> showA opts " | " q] (hhs <> [hh qq]) - --- | split a list \'p\' into parts using the lengths in the type level list \'ns\' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 msg = "SplitAts" - lr <- runPQ msg (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) [msg <> show0 opts " " zs <> showA opts " | ns=" ns <> showA opts " | " p] [hh nn, hh pp] - --- | similar to 'splitAt' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 Fst) ("hello world",4) --- Present ("hell","o world") --- PresentT ("hell","o world") --- -data SplitAt n p -type Take n p = SplitAt n p >> Fst -type Drop n p = SplitAt n p >> Snd - -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 - in mkNode opts (PresentT (x,y)) [msg1 <> show0 opts " " (x,y) <> showA opts " | n=" n <> showA opts " | " p] [hh pp, hh qq] - -type Tail = Uncons >> 'Just Snd -type Head = Uncons >> 'Just Fst -type Init = Unsnoc >> 'Just Fst -type Last = Unsnoc >> 'Just Snd - --- | similar to 'Control.Arrow.&&&' -type p &&& q = W '(p, q) -infixr 3 &&& - --- | similar to 'Control.Arrow.***' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Pred *** ShowP) (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 msg = "(***)" - pp <- eval (Proxy @p) opts a - case getValueLR opts msg pp [] of - Left e -> pure e - Right a1 -> do - qq <- eval (Proxy @q) opts b - pure $ case getValueLR opts msg qq [hh pp] of - Left e -> e - Right b1 -> mkNode opts (PresentT (a1,b1)) [msg <> show0 opts " " (a1,b1) <> showA opts " | " (a,b)] [hh pp, hh qq] - --- | similar 'Control.Arrow.|||' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Pred ||| Id) (Left 13) --- Present 12 --- PresentT 12 --- --- >>> pl @(ShowP ||| 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 (Left a) = do - let msg = "|||" - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts msg pp [] of - Left e -> e - Right a1 -> mkNode opts (_tBool pp) ["Left" <> show0 opts " " a1 <> showA opts " | " a] [hh pp] - eval _ opts (Right a) = do - let msg = "|||" - qq <- eval (Proxy @q) opts a - pure $ case getValueLR opts msg qq [] of - Left e -> e - Right a1 -> mkNode opts (_tBool qq) ["Right" <> show0 opts " " a1 <> showA opts " | " a] [hh qq] - --- | similar 'Control.Arrow.+++' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Pred +++ Id) (Left 13) --- Present Left 12 --- PresentT (Left 12) --- --- >>> pl @(ShowP +++ 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 (Left a) = do - let msg = "+++" - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts msg pp [] of - Left e -> e - Right a1 -> mkNode opts (PresentT (Left a1)) ["(+++) Left" <> show0 opts " Left " a1 <> showA opts " | " a] [hh pp] - eval _ opts (Right a) = do - let msg = "+++" - qq <- eval (Proxy @q) opts a - pure $ case getValueLR opts msg qq [] of - Left e -> e - Right a1 -> mkNode opts (PresentT (Right a1)) ["(+++) Right" <> show0 opts " Right" a1 <> showA 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> :set -XNoStarIsType --- >>> pl @(Fst * Snd) (13,5) --- Present 65 --- PresentT 65 --- --- >>> pl @(Fst + 4 * (Snd >> 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Fst / Snd) (13,2) --- Present 6.5 --- PresentT 6.5 --- --- >>> pl @(Pos 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 msg = "DivF" - lr <- runPQ msg (Proxy @p) (Proxy @q) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) - | q == 0 -> let msg1 = msg <> " 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] - --- | similar to 'negate' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @Negate 14 --- Present -14 --- PresentT (-14) --- -data Negate - -instance (Show a, Num a) => P Negate a where - type PP Negate a = a - eval _ opts a = - let d = negate a - in pure $ mkNode opts (PresentT d) ["Negate" <> show0 opts " " d <> showA opts " | " a] [] - --- | similar to 'abs' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @Abs (-14) --- Present 14 --- PresentT 14 --- --- >>> pl @Abs 14 --- Present 14 --- PresentT 14 --- --- >>> pl @Abs 0 --- Present 0 --- PresentT 0 --- -data Abs - -instance (Show a, Num a) => P Abs a where - type PP Abs a = a - eval _ opts a = - let d = abs a - in pure $ mkNode opts (PresentT d) ["Abs" <> show0 opts " " d <> showA opts " | " a] [] - --- | similar to 'signum' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @Signum (-14) --- Present -1 --- PresentT (-1) --- --- >>> pl @Signum 14 --- Present 1 --- PresentT 1 --- --- >>> pl @Signum 0 --- Present 0 --- PresentT 0 --- -data Signum - -instance (Show a, Num a) => P Signum a where - type PP Signum a = a - eval _ opts a = - let d = signum a - in pure $ mkNode opts (PresentT d) ["Signum" <> show0 opts " " d <> showA opts " | " a] [] - --- | unwraps a value (see 'Control.Lens.Unwrapped') --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @Unwrap (SG.Sum (-13)) --- Present -13 --- PresentT (-13) --- -data Unwrap - -instance (Show s - , Show (Unwrapped s) - , Wrapped s - ) => P Unwrap s where - type PP Unwrap s = Unwrapped s - eval _ opts as = - let d = as ^. _Wrapped' - in pure $ mkNode opts (PresentT d) ["Unwrap" <> show0 opts " " d <> showA opts " | " as] [] - --- | wraps a value (see 'Control.Lens.Wrapped' and 'Control.Lens.Unwrapped') --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> :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) ["Wrap" <> show0 opts " " d <> showA opts " | " p] [hh pp] - --- | similar to 'coerce' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 d = a ^. coerced - in pure $ mkNode opts (PresentT d) ["Coerce" <> show0 opts " " d <> showA opts " | " a] [] - --- can coerce over a functor: but need to provide type of 'a' and 't' explicitly - --- | see 'Coerce': coerce over a functor --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 d = view coerced <$> fa - in pure $ mkNode opts (PresentT d) ["Coerce2" <> show0 opts " " d <> showA opts " | " fa] [] - --- | lift mempty over a Functor --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 b = mempty <$> fa - in pure $ mkNode opts (PresentT b) ["MemptyT2" <> show0 opts " " b <> showA opts " | " fa] [] - --- | lift pure over a Functor --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 b = fmap pure fa - in pure $ mkNode opts (PresentT b) ["Pure2" <> show0 opts " " b <> showA opts " | " fa] [] - --- | similar to 'reverse' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 d = reverse as - in pure $ mkNode opts (PresentT d) ["Reverse" <> show0 opts " " d <> showA opts " | " as] [] - --- | reverses using 'reversing' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> import Data.Text (Text) --- >>> pl @ReverseL ("AbcDeF" :: Text) --- Present "FeDcbA" --- PresentT "FeDcbA" --- -data ReverseL - -instance (Show t, Reversing t) => P ReverseL t where - type PP ReverseL t = t - eval _ opts as = - let d = as ^. reversed - in pure $ mkNode opts (PresentT d) ["ReverseL" <> show0 opts " " d <> showA opts " | " as] [] - --- | swaps using 'swapped' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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) --- -data Swap - -instance (Show (p a b) - , Swapped p - , Show (p b a) - ) => P Swap (p a b) where - type PP Swap (p a b) = p b a - eval _ opts pab = - let d = pab ^. swapped - in pure $ mkNode opts (PresentT d) ["Swap" <> show0 opts " " d <> showA opts " | " pab] [] - --- | bounded 'succ' function --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @SuccB' (13 :: Int) --- Present 14 --- PresentT 14 --- --- >>> pl @SuccB' LT --- Present EQ --- PresentT EQ --- --- >>> pl @(SuccB 'LT) GT --- Present LT --- PresentT LT --- --- >>> pl @SuccB' GT --- Error Succ bounded failed --- FailT "Succ bounded failed" --- -data SuccB def -type SuccB' = SuccB (Failp "Succ bounded failed") - -instance (P def (Proxy a) - , PP def (Proxy a) ~ a - , Show a - , Eq a - , Bounded a - , Enum a - ) => P (SuccB def) a where - type PP (SuccB def) a = a - eval _ opts a = do - let msg0 = "SuccB" - case succMay a of - Nothing -> do - let msg1 = msg0 <> " out of range" - 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 n -> pure $ mkNode opts (PresentT n) [msg0 <> show0 opts " " n <> showA opts " | " a] [] - --- | bounded 'pred' function --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @PredB' (13 :: Int) --- Present 12 --- PresentT 12 -data PredB def -type PredB' = PredB (Failp "Pred bounded failed") - -instance (P def (Proxy a) - , PP def (Proxy a) ~ a - , Show a - , Eq a - , Bounded a - , Enum a - ) => P (PredB def) a where - type PP (PredB def) a = a - eval _ opts a = do - let msg0 = "PredB" - case predMay a of - Nothing -> do - let msg1 = msg0 <> " out of range" - 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 n -> pure $ mkNode opts (PresentT n) [msg0 <> show0 opts " " n <> showA opts " | " a] [] - --- | unbounded 'succ' function --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @Succ 13 --- Present 14 --- PresentT 14 --- --- >>> pl @Succ LT --- Present EQ --- PresentT EQ --- --- >>> pl @Succ GT --- Error Succ IO e=Prelude.Enum.Ordering.succ: bad argument --- FailT "Succ IO e=Prelude.Enum.Ordering.succ: bad argument" --- -data Succ -instance (Show a, Enum a) => P Succ a where - type PP Succ a = a - eval _ opts a = do - let msg = "Succ" - lr <- catchit @_ @E.SomeException (succ a) - pure $ case lr of - Left e -> mkNode opts (FailT (msg <> " " <> e)) [msg <> show0 opts " " a] [] - Right n -> mkNode opts (PresentT n) [msg <> show0 opts " " n <> showA opts " | " a] [] - - --- | unbounded 'pred' function --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @Pred 13 --- Present 12 --- PresentT 12 -data Pred -instance (Show a, Enum a) => P Pred a where - type PP Pred a = a - eval _ opts a = do - let msg = "Pred" - lr <- catchit @_ @E.SomeException (pred a) - pure $ case lr of - Left e -> mkNode opts (FailT (msg <> " " <> e)) [msg <> show0 opts " " a] [] - Right n -> mkNode opts (PresentT n) [msg <> show0 opts " " n <> showA opts " | " a] [] - - --- | 'fromEnum' function --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @FromEnum 'x' --- Present 120 --- PresentT 120 -data FromEnum -instance (Show a, Enum a) => P FromEnum a where - type PP FromEnum a = Int - eval _ opts a = - let n = fromEnum a - in pure $ mkNode opts (PresentT n) ["FromEnum" <> show0 opts " " n <> showA opts " | " a] [] - --- | unsafe 'toEnum' function --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(ToEnum Char) 120 --- Present 'x' --- PresentT 'x' -data ToEnum' t -type ToEnum (t :: Type) = ToEnum' (Hole t) - -instance (Show a - , Enum (PP t a) - , Show (PP t a) - , Integral a - ) => P (ToEnum' t) a where - type PP (ToEnum' t) a = PP t a - eval _ opts a = do - let msg = "ToEnum" - lr <- catchit @_ @E.SomeException (toEnum $! fromIntegral a) - pure $ case lr of - Left e -> mkNode opts (FailT (msg <> " " <> e)) [msg <> show0 opts " " a] [] - Right n -> mkNode opts (PresentT n) [msg <> show0 opts " " n <> showA opts " | " a] [] - --- | bounded 'toEnum' function --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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) [msg0 <> show0 opts " " n <> showA opts " | " a] [] - --- | a predicate on prime numbers --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @Prime 2 --- True --- TrueT --- --- >>> pl @(Map '(Id,Prime) 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 - -instance (Show a, Integral a) => P Prime a where - type PP Prime a = Bool - eval _ opts a = - let b = isPrime $ fromIntegral a - in pure $ mkNodeB opts b ["Prime" <> showA opts " | " a] [] - - --- | 'not' function --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @Not False --- True --- TrueT --- --- >>> pl @Not True --- False --- FalseT --- -data Not -instance a ~ Bool => P Not a where - type PP Not a = Bool - eval _ opts a = - let b = not a - in pure $ mkNodeB opts b ["Not"] [] -- already has FalseT TrueT so no need to add confusing data - - --- empty lists at the type level wont work here - --- | filters a list \'q\' keeping or removing those elements in \'p\' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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) [msg0 <> show0 opts " " ret <> showA opts " | p=" p <> showA opts " | q=" q] [hh pp, hh qq] - --- | 'elem' function --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Elem Fst Snd) ('x',"abcdxy") --- True --- TrueT --- --- >>> pl @(Elem Fst Snd) ('z',"abcdxy") --- False --- FalseT --- -data Elem p q -type ElemAll p q = Any (Elem I 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] - --- | 'const' () function --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @() "Asf" --- Present () --- PresentT () --- -instance Show a => P () a where - type PP () a = () - eval _ opts a = pure $ mkNode opts (PresentT ()) ["()" <> show0 opts " " a] [] - -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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 at the end says we only want to process the Maybe which is the rhs of &&& ie Snd -type GDef' z p q r = '(I, r >> z) >> MaybeXP (X >> p) q Snd -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 -type JustDef'' p q r = GDef'' I p q r - -type PA = Snd -- 'Proxy a' -- to distinguish from A -type A = Snd -- 'a' -type X = Fst >> Fst -- '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 >> Fst >> p) ((Fst *** I) >> q) Snd -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 >> Fst --- Just case sees (I,qz), a) -- hence the Snd to get the 'a' only -- if you want the 'x' then Fst >> Fst --- 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 >> 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) --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(EitherX (((Fst >> Fst) + Snd) >> ShowP) ShowP Snd) (9,Left 123) --- Present "132" --- PresentT "132" --- --- >>> pl @(EitherX (((Fst >> Fst) + Snd) >> ShowP) ShowP Snd) (9,Right 'x') --- Present "((9,Right 'x'),'x')" --- PresentT "((9,Right 'x'),'x')" --- --- >>> pl @(EitherX ShowP (Second Succ >> ShowP) Snd) (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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(TheseX (((Fst >> Fst) + Snd) >> ShowP) ShowP (Snd >> Snd) Snd) (9,This 123) --- Present "132" --- PresentT "132" --- --- >>> pl @(TheseX '(Snd,"fromthis") '(99 >> Negate,Snd) Snd Id) (This 123) --- Present (123,"fromthis") --- PresentT (123,"fromthis") --- --- >>> pl @(TheseX '(Snd,"fromthis") '(99 >> Negate,Snd) Snd Id) (That "fromthat") --- Present (-99,"fromthat") --- PresentT (-99,"fromthat") --- --- >>> pl @(TheseX '(Snd,"fromthis") '(99 >> Negate,Snd) Snd 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(MaybeIn "foundnothing" (Pred >> ShowP)) (Just 20) --- Present "19" --- PresentT "19" --- --- >>> pl @(MaybeIn "found nothing" (Pred >> ShowP)) 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) [msg1 <> show0 opts " " b <> showA opts " | " a] [hh qq] - - --- | similar to 'SG.stimes' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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) [msg1 <> show0 opts " " b <> showA opts " | n=" n <> showA opts " | " p] [hh pp, hh qq] - - --- | similar to 'pure' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Pure Maybe Id) 4 --- Present Just 4 --- PresentT (Just 4) --- --- >>> pl @(Pure [] Id) 4 --- Present [4] --- PresentT [4] --- -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) [msg0 <> show0 opts " " b <> showA opts " | " a] [hh pp] - -type PMempty = MemptyT' 'Proxy -- lifts 'a' to 'Proxy a' then we can use it with MemptyP - --- | similar to 'mempty' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 b = mempty @(PP t a) - in pure $ mkNode opts (PresentT b) ["MemptyT" <> show0 opts " " b] [] - -data MemptyProxy -instance Monoid a => P MemptyProxy (Proxy (a :: Type)) where - type PP MemptyProxy (Proxy a) = a - eval _ opts _pa = - let b = mempty @a - in pure $ mkNode opts (PresentT b) ["MemptyProxy"] [] - --- | similar to 'empty' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(EmptyT Maybe) () --- Present Nothing --- PresentT Nothing --- -data EmptyT (t :: Type -> Type) -type MkNothing'' = EmptyT Maybe -- works if a->Maybe a: MkNothing will always work cos can override the output type - -instance (Show (t a), Alternative t) => P (EmptyT t) a where - type PP (EmptyT t) a = t a - eval _ opts _ = - let b = empty @t - in pure $ mkNode opts (PresentT b) ["EmptyT" <> show0 opts " " b] [] - -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 msg = "MkNothing" - in pure $ mkNode opts (PresentT Nothing) [msg] [] - --- | 'Just' constructor --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @MkJust 44 --- Present Just 44 --- PresentT (Just 44) --- -data MkJust -instance Show a => P MkJust a where - type PP MkJust a = Maybe a - eval _ opts a = - let msg0 = "MkJust" - d = Just a - in pure $ mkNode opts (PresentT d) [msg0 <> show0 opts " Just " a] [] - --- | 'Data.Either.Left' constructor --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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] [] - --- | 'Data.Either.Right' constructor --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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] [] - --- | 'Data.These.This' constructor --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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] [] - --- | 'Data.These.That' constructor --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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] [] - ---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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(MkThese Fst Snd) (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' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @MConcat [SG.Sum 44, SG.Sum 12, SG.Sum 3] --- Present Sum {getSum = 59} --- PresentT (Sum {getSum = 59}) --- -data MConcat -type FoldMap (t :: Type) p = Map (Wrap t Id) p >> MConcat >> Unwrap - -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 (Show a, Monoid a) => P MConcat [a] where - type PP MConcat [a] = a - eval _ opts a = - let b = mconcat a - in pure $ mkNode opts (PresentT b) ["MConcat" <> show0 opts " " b <> showA opts " | " a] [] - --- | similar to 'concat' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Concat Id) ["abc","D","eF","","G"] --- Present "abcDeFG" --- PresentT "abcDeFG" --- --- >>> pl @(Concat Snd) ('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 = MapTX (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 as -> - let b = concat as - in mkNode opts (PresentT b) ["Concat" <> show0 opts " " b <> showA opts " | " as] [hh pp] - -instance P (Proxy t) a where - type PP (Proxy t) a = Proxy t - eval _ opts _ = - pure $ mkNode opts (PresentT Proxy) ["Proxy"] [] - -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.!!' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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) [msg1 <> show0 opts " " ret <> showA opts " | p=" p <> showA opts " | q=" q] [hh pp, hh qq] - --- | 'lookup' leveraging 'Ixed' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 >> IsNothing) (Fst >> ShowP >> Fail (Hole t) (Printf "index(%s) not found" Id)) (Snd >> '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)) [msg1 <> show0 opts " " ret <> showA opts " | p=" p <> showA opts " | q=" q] hhs - --- | 'Data.List.ands' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @Ands [True,True,True] --- True --- TrueT --- --- >>> pl @Ands [True,True,True,False] --- False --- FalseT --- --- >>> pl @Ands [] --- True --- TrueT --- -data Ands -type Ands' = FoldMap SG.All Id - -instance (as ~ t a - , Show (t a) - , Foldable t - , a ~ Bool - ) => P Ands as where - type PP Ands as = Bool - eval _ opts as = - let b = and as - in pure $ mkNodeB opts b ["Ands" <> showA opts " | " as] [] - --- | 'Data.List.ors' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @Ors [False,False,False] --- False --- FalseT --- --- >>> pl @Ors [True,True,True,False] --- True --- TrueT --- --- >>> pl @Ors [] --- False --- FalseT --- -data Ors -type Ors' = FoldMap SG.Any Id - -instance (as ~ t a - , Show (t a) - , Foldable t - , a ~ Bool - ) => P Ors as where - type PP Ors as = Bool - eval _ opts as = - let b = or as - in pure $ mkNodeB opts b ["Ors" <> showA opts " | " as] [] - --- | similar to cons --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Fst :+ Snd) (99,[1,2,3,4]) --- Present [99,1,2,3,4] --- PresentT [99,1,2,3,4] --- -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) [msg0 <> show0 opts " " b <> showA opts " | p=" p <> showA opts " | q=" q] [hh pp, hh qq] - --- | similar to snoc --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Snd +: Fst) (99,[1,2,3,4]) --- Present [1,2,3,4,99] --- PresentT [1,2,3,4,99] --- -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) [msg0 <> show0 opts " " b <> showA opts " | p=" p <> showA opts " | q=" q] [hh pp, hh qq] - --- | 'Control.Lens.uncons' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 b = as ^? _Cons - in pure $ mkNode opts (PresentT b) ["Uncons" <> show0 opts " " b <> showA opts " | " as] [] - --- | 'Control.Lens.unsnoc' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 b = as ^? _Snoc - in pure $ mkNode opts (PresentT b) ["Unsnoc" <> show0 opts " " b <> showA opts " | " as] [] - --- | similar to 'null' using 'AsEmpty' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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" <> showA opts " | " as] [] - --- | similar to 'null' using 'Foldable' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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" <> showA opts " | " as] [] - --- | similar to 'enumFromTo' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 b = partitionEithers as - in pure $ mkNode opts (PresentT b) ["PartitionEithers" <> show0 opts " " b <> showA opts " | " as] [] - --- | similar to 'partitionThese' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 (x,y,z) = partitionThese as - b = ((x,y),z) - in pure $ mkNode opts (PresentT b) ["PartitionThese" <> show0 opts " " b <> showA opts " | " as] [] - -type Thiss = PartitionThese >> Fst >> Fst -type Thats = PartitionThese >> Fst >> Snd -type Theses = PartitionThese >> Snd - -type CatMaybesa t = Foldl (Fst <> (Snd >> MaybeIn MemptyP '[Id])) (MemptyT t) Id -type CatMaybesx t = Foldl (JustDef' Fst ((Fst >> Fst >> Fst) +: Snd) Snd) (MemptyT [t]) Id -type CatMaybesy t = Foldl (JustDef'' (Fst >> Fst >> Fst) ((Fst >> Fst >> Fst) +: Snd) Snd) (MemptyT [t]) Id -type CatMaybesz t = Foldl (JustDef''' Fst ((Fst >> Fst) +: Snd) Snd) (MemptyT [t]) Id - --- want to pass Proxy b to q but then we have no way to calculate 'b' - --- | similar to 'scanl' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Scanl (Snd :+ Fst) Fst Snd) ([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]] --- -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 >> q) p (EnumFromTo 1 n) -- n times using q then run p -type ScanNA q = ScanN Fst Snd q -type Repeat 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) [msg1 <> show0 opts " " vals <> showA opts " | b=" q <> showA opts " | as=" r] (hh qq : hh rr : map (hh . fixit) itts) - -type family UnfoldT mbs where - UnfoldT (Maybe (b,s)) = b - --- | similar to 'unfoldr' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Unfoldr (MaybeB (Null >> Not) (SplitAt 2 Id)) Id) [1..5] --- Present [[1,2],[3,4],[5]] --- PresentT [[1,2],[3,4],[5]] --- -data Unfoldr p q ---type Iteraten (t :: Type) n f = Unfoldr (If (Fst == 0) (MkNothing t) (Snd &&& (Pred *** f) >> MkJust)) '(n, Id) -type IterateN n f = Unfoldr (MaybeB (Fst > 0) '(Snd, Pred *** f)) '(n, Id) -type IterateUntil p f = IterateWhile (p >> Not) f -type IterateWhile p f = Unfoldr (MaybeB p '(Id, f)) Id -type IterateNWhile n p f = '(n, Id) >> IterateWhile (Fst > 0 && (Snd >> p)) (Pred *** f) >> Map Snd Id -type IterateNUntil n p f = IterateNWhile n (p >> Not) 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) [msg1 <> show0 opts " " ret <> showA opts " | s=" q ] (hh qq : map (hh . fixit) itts) - --- | similar to 'map' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Map Pred 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 (MapTX (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) [msg0 <> show0 opts " " vals <> showA opts " | " as] (hh qq : map (hh . fixit) ts) - -type family MapTX ta where - MapTX (t a) = a - --- | if p then run q else run r --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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) [msg0 <> show0 opts " " zs <> showA opts " | " as ] [] - - --- | similar to 'partition' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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]) --- -data Partition p q -type FilterBy p q = Partition p q >> Fst - -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) [msg0 <> show0 opts " " zz1 <> showA opts " | s=" as] (hh qq : map (hh . fixit) tfs) - - --- | similar to 'break' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 (p >> Not) 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 :> 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 :> 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 :> iall))) - - Right False -> error "shouldnt happen" - Left e -> e - --- | Fails the computation with a message --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 msg = "Fail" - pp <- eval (Proxy @prt) opts a - pure $ case getValueLR opts msg pp [] of - Left e -> e - Right s -> mkNode opts (FailT s) [msg <> " " <> 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 msg = "Hole(" <> showT @t <> ")" - in pure $ mkNode opts (FailT msg) [msg <> " 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 msg = "Unproxy(" <> showT @a <> ")" - in pure $ mkNode opts (FailT msg) [msg <> " you probably meant to get access to the type of PP only and not evaluate"] [] - --- | transparent predicate wrapper to make k of kind Type so it can be in a promoted list (cant mix kinds) see 'Do' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Do '[W 123, W "xyz", Len &&& Id, Pred *** Id<>Id]) () --- Present (2,"xyzxyz") --- PresentT (2,"xyzxyz") --- --- --- >>> pl @(TupleI '[W 999,W "somestring",W 'True, Id, Pred >> ShowP]) 23 --- Present (999,("somestring",(True,(23,("22",()))))) --- PresentT (999,("somestring",(True,(23,("22",()))))) --- -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)) - --- | catch a failure --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Catch Succ (Fst >> Second ShowP >> Printf2 "%s %s" >> 'LT)) GT --- Present LT --- PresentT LT --- --- >>> pl @(Catch' Succ (Second ShowP >> 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 (Second ShowP >> 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 -type FailCatch s = Fail (Snd >> Unproxy) (Fst >> 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 >> Same 0 -type Odd = Mod I 2 >> Same 1 -type Div' p q = DivMod p q >> Fst -type Mod' p q = DivMod p q >> Snd - --- | similar to 'div' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Div Fst Snd) (10,4) --- Present 2 --- PresentT 2 --- --- >>> pl @(Div Fst Snd) (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 msg = "Div" - lr <- runPQ msg (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 (msg <> " zero denominator")) [msg <> " zero denominator"] hhs - _ -> let d = p `div` q - in mkNode opts (PresentT d) [show p <> " `div` " <> show q <> " = " <> show d] hhs - - --- | similar to 'mod' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Mod Fst Snd) (10,3) --- Present 1 --- PresentT 1 --- --- >>> pl @(Mod Fst Snd) (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 msg = "Mod" - lr <- runPQ msg (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 (msg <> " zero denominator")) [msg <> " zero denominator"] hhs - _ -> let d = p `mod` q - in mkNode opts (PresentT d) [show p <> " `mod` " <> show q <> " = " <> show d] hhs - --- | similar to 'divMod' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(DivMod Fst Snd) (10,3) --- Present (3,1) --- PresentT (3,1) --- --- >>> pl @(DivMod Fst Snd) (10,-3) --- Present (-4,-2) --- PresentT (-4,-2) --- --- >>> pl @(DivMod Fst Snd) (-10,3) --- Present (-4,2) --- PresentT (-4,2) --- --- >>> pl @(DivMod Fst Snd) (-10,-3) --- Present (3,-1) --- PresentT (3,-1) --- --- >>> pl @(DivMod Fst Snd) (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 msg = "DivMod" - lr <- runPQ msg (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 (msg <> " zero denominator")) [msg <> " zero denominator"] hhs - _ -> let d = p `divMod` q - in mkNode opts (PresentT d) [show p <> " `divMod` " <> show q <> " = " <> show d] hhs - --- | similar to 'quotRem' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(QuotRem Fst Snd) (10,3) --- Present (3,1) --- PresentT (3,1) --- --- >>> pl @(QuotRem Fst Snd) (10,-3) --- Present (-3,1) --- PresentT (-3,1) --- --- >>> pl @(QuotRem Fst Snd) (-10,-3) --- Present (3,-1) --- PresentT (3,-1) --- --- >>> pl @(QuotRem Fst Snd) (-10,3) --- Present (-3,-1) --- PresentT (-3,-1) --- --- >>> pl @(QuotRem Fst Snd) (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 msg = "QuotRem" - lr <- runPQ msg (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 (msg <> " zero denominator")) [msg <> " 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 = QuotRem p q >> Fst -type Rem p q = QuotRem p q >> Snd - ---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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 1 3 --- FailT "1 3" --- --- >>> pl @(GuardsQuick (Printf2 "arg %d failed with value %d") '[Gt 4, Ge 3, Same 4]) [17,3,5] --- Error arg 2 failed with value 5 --- FailT "arg 2 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 msg = "Guards" <> strictmsg @strict <> "(" <> show n <> ")" - n :: Int = nat @n - in pure $ mkNode opts (PresentT as) [msg <> " done!" <> if null as then "" else showA 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-1,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\' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 (p >> Not) -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 <> " p failed") 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 - --- just run the effect but skip the value: eg use for Stdout so doesnt interfere with 'a' 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 <> " p failed") 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 in W - --- | This is composition for predicates --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Fst >> Id !! 0 >> Succ) ([11,12],'x') --- Present 12 --- PresentT 12 --- --- >>> pl @(Len *** Succ >> First Pred >> ShowP) ([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 msg = ">>" - 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) [msg <> show0 opts " " q <> showA opts " | " p] [hh pp, hh qq] - --- | similar to 'Prelude.&&' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Fst && (Snd >> Len >> Ge 4)) (True,[11,12,13,14]) --- True --- TrueT --- --- >>> pl @(Fst && (Snd >> 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.||' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Fst || (Snd >> Len >> Ge 4)) (False,[11,12,13,14]) --- True --- TrueT --- --- >>> pl @((Fst >> Not) || (Snd >> 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Fst ~> (Snd >> Len >> Ge 4)) (True,[11,12,13,14]) --- True --- TrueT --- --- >>> pl @(Fst ~> (Snd >> Len >> Same 4)) (True,[12,11,12,13,14]) --- False --- FalseT --- --- >>> pl @(Fst ~> (Snd >> Len >> Same 4)) (False,[12,11,12,13,14]) --- True --- TrueT --- --- >>> pl @(Fst ~> (Snd >> 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' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(OrdP Fst Snd) (10,9) --- Present GT --- PresentT GT --- --- >>> pl @(OrdP Fst Snd) (10,10) --- Present EQ --- PresentT EQ --- --- >>> pl @(OrdP Fst Snd) (10,11) --- Present LT --- PresentT LT --- -type OrdA' p q = OrdP (Fst >> p) (Snd >> 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Fst ===? Snd) ("abC","aBc") --- Present EQ --- PresentT EQ --- --- >>> pl @(Fst ===? Snd) ("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' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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), UnIToListT (PP p x))] - eval _ opts x = do - let msg0 = "IToList" - pp <- eval (Proxy @p) opts x - pure $ case getValueLR opts (msg0 <> " p failed") 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 <> showA opts " | " x] [hh pp] - -type family UnIToListT fa where - UnIToListT (f a) = a - --- | similar to 'toList' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @ToList "aBc" --- Present "aBc" --- PresentT "aBc" --- -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 z = toList as - in pure $ mkNode opts (PresentT z) ["ToList" <> show0 opts " " z <> showA opts " | " as] [] - -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 z = Ge.toList as - in pure $ mkNode opts (PresentT z) ["ToListExt" <> show0 opts " " z <> showA opts " | " 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 z = Ge.fromList (as :: [Ge.Item t]) :: t - in pure $ mkNode opts (PresentT z) ["FromList" <> 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 z = Ge.fromList (Ge.toList @l as) - in pure $ mkNode opts (PresentT z) ["FromListF" <> show0 opts " " z] [] - --- | predicate on 'These' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @IsThis (This "aBc") --- True --- TrueT --- --- >>> pl @IsThis (These 1 'a') --- False --- FalseT --- --- >>> pl @IsThese (These 1 'a') --- True --- TrueT --- -data IsTh (th :: These x y) -- x y can be anything - -type IsThis = IsTh ('This '()) -type IsThat = IsTh ('That '()) -type IsThese = IsTh ('These '() '()) - --- trying to avoid show instance cos of ambiguities -instance (Show a - , Show b - , GetThese th - ) => P (IsTh (th :: These x y)) (These a b) where - type PP (IsTh th) (These a b) = Bool - eval _ opts th = - let (t,f) = getThese (Proxy @th) - b = f th - in pure $ mkNodeB opts b ["IsTh '" <> t <> showA opts " | " th] [] - --- | similar to 'these' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(TheseIn Id Len (Fst + Length Snd)) (This 13) --- Present 13 --- PresentT 13 --- --- >>> pl @(TheseIn Id Len (Fst + Length Snd)) (That "this is a long string") --- Present 21 --- PresentT 21 --- --- >>> pl @(TheseIn Id Len (Fst + Length Snd)) (These 20 "somedata") --- Present 28 --- PresentT 28 --- --- >>> pl @(TheseIn (Left _) (Right _) (If (Fst > Length Snd) (MkLeft _ Fst) (MkRight _ Snd))) (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 > Length Snd) (MkLeft _ Fst) (MkRight _ Snd))) (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 > Length Snd) (MkLeft _ Fst) (MkRight _ Snd))) (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 msg = "This" - pp <- eval (Proxy @p) opts a - pure $ case getValueLR opts (msg <> " p failed") pp [] of - Left e -> e - Right c -> mkNode opts (PresentT c) [msg <> show0 opts " " c <> showA opts " | This " a] [hh pp] - That b -> do - let msg = "That" - qq <- eval (Proxy @q) opts b - pure $ case getValueLR opts (msg <> " q failed") qq [] of - Left e -> e - Right c -> mkNode opts (PresentT c) [msg <> show0 opts " " c <> showA opts " | That " b] [hh qq] - These a b -> do - let msg = "TheseIn" - rr <- eval (Proxy @r) opts (a,b) - pure $ case getValueLR opts (msg <> " r failed") rr [] of - Left e -> e - Right c -> mkNode opts (PresentT c) [msg <> show0 opts " " c <> showA opts " | " (These a b)] [hh rr] - --- | extracts the first character from a non empty 'Symbol' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(ZipThese Fst Snd) ("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 Snd) ("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 = TA.align p q - in mkNode opts (PresentT d) [msg0 <> show0 opts " " d <> showA opts " | p=" p <> showA opts " | q=" q] [hh pp, hh qq] - -data ZipTheseF p q - -instance (Show (f y) - , PP p a ~ f x - , PP q a ~ f y - , ExtractT (f x) ~ x - , ExtractT (f y) ~ y - , Show (f x) - , TA.Align f - , Show (f (These x y)) - , P p a - , P q a) - => P (ZipTheseF p q) a where - type PP (ZipTheseF p q) a = ApplyConstT (PP p a) (These (ExtractT (PP p a)) (ExtractT (PP q a))) - eval _ opts a = do - let msg0 = "ZipTheseF" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = TA.align p q - in mkNode opts (PresentT d) [msg0 <> show0 opts " " d <> showA opts " | p=" p <> showA opts " | q=" q] [hh pp, hh qq] - -type family ExtractT (ta :: Type) :: Type where - ExtractT (t a) = a - ExtractT ta = GL.TypeError ( - 'GL.Text "ExtractT: 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Ziplc Fst Snd) ("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 Snd) ("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 Snd) ("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) [msg0 <> show0 opts " " d <> showA opts " | p=" p <> showA opts " | q=" q] [hh pp, hh qq] - --- | Luhn predicate check on last digit --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @Luhn [1,2,3,0] --- True --- TrueT --- --- >>> pl @Luhn [1,2,3,4] --- False --- FalseT -data Luhn - - -instance a ~ [Int] => P Luhn a where - type PP Luhn a = Bool - eval _ opts as = - let xs = zipWith (*) (reverse as) (cycle [1,2]) - ys = map (\x -> if x>=10 then x-9 else x) xs - z = sum ys - ret = z `mod` 10 - msg = "Luhn" - in pure $ if ret == 0 then mkNode opts TrueT [msg <> show0 opts " | " as] [] - else mkNode opts FalseT [msg <> " map=" <> show ys <> " sum=" <> show z <> " ret=" <> show ret <> showA opts " | as=" as] [] - -pe0, pe, pe1, pe2, pex, pe3, pl, plc :: forall p a . (Show (PP p a), P p a) => a -> IO (BoolT (PP p a)) -pe0 = peWith @p o0 -pe = peWith @p o02 -pex = peWith @p o03 -pe1 = peWith @p o1 -pe2 = peWith @p o2 -pe3 = peWith @p o3 -pl = peWith @p ol -plc = peWith @p olc - -peWith :: forall p a . (Show (PP p a), P p a) => -- Typeable (Proxy p), - 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 - --- could get n::Nat as a predicate but it is fine as is! --- | Read a number base 2 via 36 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 <> " p failed") 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) <> showA 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 = take n (['0'..'9'] <> ['a'..'z']) - --- | Display a number at base 2 to 36 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(ShowBase 16) 4077 --- Present "fed" --- PresentT "fed" --- --- >>> pl @(ShowBase 16) (-255) --- Present "-ff" --- PresentT "-ff" --- --- >>> pl @(ShowBase 2) 147 --- Present "10010011" --- PresentT "10010011" --- --- supports negative numbers unlike showIntAtBase -data ShowBase (n :: Nat) - -instance (Show a - , 2 GL.<= n - , n GL.<= 36 - , KnownNat n - , Integral a - ) => P (ShowBase n) a where - type PP (ShowBase n) a = String - eval _ opts a = - let n = nat @n - xs = getValidBase n - msg = "ShowBase " <> show n - (ff,a') = if a < 0 then (('-':), abs a) else (id,a) - b = showIntAtBase (fromIntegral n) (xs !!) a' "" - in pure $ mkNode opts (PresentT (ff b)) [msg <> showLit0 opts " " (ff b) <> showA opts " | " a] [] - -type Assocl = '(I *** Fst, Snd >> Snd) -type Assocr = '(Fst >> Fst, Snd *** I) ---type Assocl = (I *** Fst) &&& (Snd >> Snd) ---type Assocr = (Fst >> Fst) &&& (Snd *** I) - --- | Intercalate --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 a ~ [x] - , PP q a ~ PP p a - , P p a - , P q a - , Show x - ) => P (Intercalate p q) a where - type PP (Intercalate p q) a = PP p a - eval _ opts a = do - let msg0 = "Intercalate" - lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a - pure $ case lr of - Left e -> e - Right (p,q,pp,qq) -> - let d = intercalate p (map (:[]) q) - in mkNode opts (PresentT d) [msg0 <> show0 opts " " d <> showA opts " | " p <> showA 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 <> "]" <> showA opts " | p=" p <> showLit 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' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 - -- showA 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 : []) <> showA opts " | " a <> (if strict then "" else showA 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) <> showA 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Case (FailS "asdf" >> Snd >> 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 >> 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 >> 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 >> 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 >> 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 - -type FailCase p = Fail (Snd >> Unproxy) (Fst >> 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) [msgbase0 <> show0 opts " " b <> showA opts " | " 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) [msgbase0 <> show0 opts " " b <> showA opts " | " 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) [msgbase0 <> show0 opts " " b <> showA opts " | " 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) [msgbase1 <> show0 opts " " b <> showA opts " | " a] [hh rr, hh pp, hh ww] - --- | similar to 'sequenceA' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 <> showA opts " | " tfa] [] - -data Hide p -type H = Hide --- type H p = Hide p -- doesnt work with % -- unsaturated! - -instance P p a => P (Hide p) a where - type PP (Hide p) a = PP p a - eval _ opts a = do - tt <- eval (Proxy @(Msg "!" p)) opts a - pure $ tt & tForest .~ [] - --- | similar to 'readFile' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 msg = "TimeU" - mb <- runIO $ getCurrentTime - pure $ case mb of - Nothing -> mkNode opts (FailT (msg <> " must run in IO")) [msg <> " must run in IO"] [] - Just v -> mkNode opts (PresentT v) [msg <> show0 opts " " v] [] - -data TimeZ - -instance P TimeZ a where - type PP TimeZ a = ZonedTime - eval _ opts _a = do - let msg = "TimeZ" - mb <- runIO $ getZonedTime - pure $ case mb of - Nothing -> mkNode opts (FailT (msg <> " must run in IO")) [msg <> " must run in IO"] [] - Just v -> mkNode opts (PresentT v) [msg <> 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 - msg = 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 msg 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 (msg <> " must run in IO")) [msg <> " must run in IO"] [hh pp] - Just (Left e) -> mkNode opts (FailT e) [msg <> " " <> e] [hh pp] - Just (Right ()) -> mkNode opts (PresentT ()) [msg] [hh pp] - -data Stdin - -instance P Stdin a where - type PP Stdin a = String - eval _ opts _a = do - let msg = "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 (msg <> " must run in IO")) [msg <> " must run in IO"] [] - Just (Left e) -> mkNode opts (FailT e) [msg <> " " <> e] [] - Just (Right ss) -> mkNode opts (PresentT ss) [msg <> "[" <> showLit opts "" ss <> "]"] [] - ---type Just' = JustFail "expected Just" Id -type Nothing' = Guard "expected Nothing" IsNothing - --- | 'isInfixOf' 'isPrefixOf' 'isSuffixOf' equivalents --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(IsInfixI "abc" "axAbCd") () --- True --- TrueT --- --- >>> pl @(IsPrefixI "abc" "aBcbCd") () --- True --- TrueT --- --- >>> pl @(IsPrefix "abc" "aBcbCd") () --- False --- FalseT --- --- 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 a - , P q a - , PP p a ~ String - , PP q a ~ String - , GetOrdering cmp - ) => P (IsFixImpl cmp ignore p q) a where - type PP (IsFixImpl cmp ignore p q) a = Bool - eval _ opts a = 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 a - case getValueLR opts (msg0 <> " p failed") pp [] of - Left e -> pure e - Right s0 -> do - let msg1 = msg0 <> (if ignore then "I" else "") <> "(" <> s0 <> ")" - qq <- eval (Proxy @q) opts a - 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.<>' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Fst <> Snd) ("abc","def") --- Present "abcdef" --- PresentT "abcdef" --- -data p <> q -infixr 6 <> -type Sapa' (t :: Type) = Wrap t Fst <> Wrap t Snd -type Sapa = Fst <> Snd - -instance (Semigroup (PP p a) - , PP p a ~ PP q a - , P p a - , Show (PP q a) - ,P q 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) -> - let d = p <> q - in mkNode opts (PresentT d) [show p <> " <> " <> show q <> " = " <> show d] [hh pp, hh qq] - -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) - - --- 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 = nat @n - msg = "TupleList" <> (if strict then "" else "Lax") <> "(" <> show n <> ")" - pure $ case tupleListD @(ToN n) @a strict as of - Left e -> mkNode opts (FailT (msg <> " " <> e)) [msg <> " " <> e] [] - Right ret -> mkNode opts (PresentT ret) [msg <> show0 opts " " ret <> showA opts " | " as] [] - -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 <> showA opts " | " tp] [] - --- | Printfn prints --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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) - -type Printf2 (s :: Symbol) = Printfn s '(Fst,'(Snd, '())) --- Printf3/Printf3' expected format is (a, (b,c)) : we dont support (a,b,c) ever! -type Printf3 (s :: Symbol) = Printfn s '(Fst, '(Snd >> Fst, '(Snd >> Snd, '()))) -type Printf3' (s :: Symbol) = Printfn s (TupleI '[Fst, Snd >> Fst, Snd >> Snd]) - -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 <> "]" <> showA 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.<$' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Fst <$ Snd) ("abc",Just 20) --- Present Just "abc" --- PresentT (Just "abc") --- -data p <$ q -infixl 4 <$ - -instance (P p a - , P q a - , Show (PP p a) - , Functor t - , PP q a ~ t c - , ApplyConstT (PP q a) (PP p a) ~ t (PP p a) - ) => P (p <$ q) a where - type PP (p <$ q) a = ApplyConstT (PP 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) -> - 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.<*' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Fst <* Snd) (Just "abc",Just 20) --- Present Just "abc" --- PresentT (Just "abc") --- -type p *> q = q <* p -infixl 4 *> - -instance (Show (t c) - , P p a - , P q a - , Show (t b) - , Applicative t - , t b ~ PP p a - , PP q a ~ t c - ) => 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) -> - let d = p <* q - in mkNode opts (PresentT d) [msg0 <> show0 opts " " p <> showA opts " | p=" p <> showA opts " | q=" q] [hh pp, hh qq] - --- | similar to 'Control.Applicative.<|>' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Fst <|> Snd) (Nothing,Just 20) --- Present Just 20 --- PresentT (Just 20) --- --- >>> pl @(Fst <|> Snd) (Just 10,Just 20) --- Present Just 10 --- PresentT (Just 10) --- --- >>> pl @(Fst <|> Snd) (Nothing,Nothing) --- Present Nothing --- PresentT Nothing --- -data p <|> q -infixl 3 <|> - -instance (P p a - , P q a - , Show (t b) - , Alternative t - , t b ~ PP p a - , PP q a ~ t b - ) => 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) -> - let d = p <|> q - in mkNode opts (PresentT d) [msg0 <> show0 opts " " d <> showA opts " | p=" p <> showA opts " | q=" q] [hh pp, hh qq] - - --- | similar to 'Control.Comonad.extract' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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) [msg0 <> show0 opts " " d <> showA opts " | " ta] [] - --- | similar to 'Control.Comonad.duplicate' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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) [msg0 <> show0 opts " " d <> showA opts " | " ta] [] - --- | similar to 'Control.Monad.join' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @Join (Just (Just 20)) --- Present Just 20 --- PresentT (Just 20) --- -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) [msg0 <> show0 opts " " d <> showA opts " | " tta] [] - --- same as $ but shows 'a' and 'b' -data p $ q -infixl 0 $ - -type p & q = 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 (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] - -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' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> pl @(Trim Snd) (20," abc " :: String) --- Present "abc" --- PresentT "abc" --- --- >>> import Data.Text (Text) --- >>> pl @(Trim Snd) (20," abc " :: Text) --- Present "abc" --- PresentT "abc" --- --- >>> pl @(TrimStart Snd) (20," abc ") --- Present "abc " --- PresentT "abc " --- --- >>> pl @(TrimEnd Snd) (20," abc ") --- Present " abc" --- PresentT " abc" --- --- todo: make it work for 'Data.Text.Lens.IsText' -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 - , 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 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 ^. packed)) [msg0 <> showLit0 opts "" b <> showLit opts " | " p] [hh pp] - --- | similar to 'T.stripLeft' 'T.stripRight' --- --- >>> :set -XTypeApplications --- >>> :set -XDataKinds --- >>> 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 --- -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 - , 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 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 packed) b)) [msg0 <> show0 opts "" b <> showLit opts " | p=" p <> showLit opts " | q=" q] [hh pp, hh qq] - - --- PP is k -> * -> * but we need [k]: need to unwrap into [k] -data RepeatP (n :: Nat) p -instance (P (RepeatT n p) x) => P (RepeatP n p) x where - type PP (RepeatP n p) x = PP (RepeatT n p) x - eval _ opts x = - eval (Proxy @(RepeatT n p)) opts x - +-- guard : grab part of the root msg as part of the failure reason if just false +{-# 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 MultiWayIf #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# 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 + +class P is the main class. Most of this code contains instances of this class +that evaluation of expressions at the type level. +-} +module Predicate where +import UtilP +import Safe +import GHC.TypeLits (Symbol,Nat,KnownSymbol,KnownNat,ErrorMessage((:$$:),(:<>:))) +import qualified GHC.TypeLits as GL +--import qualified GHC.TypeNats as GN +import Control.Lens hiding (strict,iall) +import Data.List +import Data.Text.Lens +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 +import qualified Data.Align as TA +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 +import Data.These.Lens () + +-- | 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 + +-- | 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) + +-- | A predicate that determines if the value is between \'p\' and \'q\' +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 +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) + +type All x p = Ands (Map x p) +type Any x p = Ors (Map x p) + +-- | 'unzip' equivalent +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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 <> showLit 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) <> "..." <> showA opts " | " q] hhs + ([], _) -> -- this is a failure cos empty string returned: so reuse p? + mkNode opts (FailT "Regex no results") [msg1 <> " no match" <> showA opts " | " q] [hh pp, hh qq] + (b, _) -> mkNode opts (PresentT b) [msg1 <> show0 opts " " b <> showLit opts " | " q] [hh pp, hh qq] + + +-- | similar to 'Rescan' but gives the column start and ending positions instead of values +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) <> "..." <> showA opts " | " q] hhs + ([], _) -> -- this is a failure cos empty string returned: so reuse p? + mkNode opts (FailT "Regex no results") [msg1 <> " no match" <> showA opts " | " q] hhs + (b, _) -> mkNode opts (PresentT b) [msg1 <> show0 opts " " b <> showLit opts " | " q] hhs + +-- | splits a string on a regex delimiter +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) <> "..." <> showA opts " | " q] hhs + ([], _) -> -- this is a failure cos empty string returned: so reuse p? + mkNode opts (FailT "Regex no results") [msg1 <> " no match" <> showA opts " | " q] hhs + (b, _) -> mkNode opts (PresentT b) [msg1 <> show0 opts " " b <> showLit opts " | " q] hhs + +_MX :: Int +_MX = 100 + +-- | replaces regex \'s\' with a string \'s1\' inside the value +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 <> showA 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 <> showLit opts " " r <> showLit opts " | " ret] (hhs <> [hh rr]) + +-- | a predicate for determining if a string 'Data.Text.IsText' belongs to the given character set +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) + +type IsLower = IsCharSet 'CLower +type IsUpper = IsCharSet 'CUpper +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 + , IsText a + ) => P (IsCharSet cs) a where + type PP (IsCharSet cs) a = Bool + eval _ opts as = + let b = allOf text f as + msg0 = "IsCharSet " ++ show cs + (cs,f) = getCharSet @cs + in pure $ mkNodeB opts b [msg0 <> showA opts " | " as] [] + + +-- | converts a string 'Data.Text.Lens.IsText' value to lower case +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @ToLower "HeLlO wOrld!" +-- Present "hello world!" +-- PresentT "hello world!" +-- +data ToLower + +instance (Show a, IsText a) => P ToLower a where + type PP ToLower a = a + eval _ opts as = + let xs = as & text %~ toLower + in pure $ mkNode opts (PresentT xs) ["ToLower" <> show0 opts " " xs <> showA opts " | " as] [] + +-- | converts a string 'Data.Text.Lens.IsText' value to upper case +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @ToUpper "HeLlO wOrld!" +-- Present "HELLO WORLD!" +-- PresentT "HELLO WORLD!" +-- +data ToUpper + +instance (Show a, IsText a) => P ToUpper a where + type PP ToUpper a = a + eval _ opts as = + let xs = as & text %~ toUpper + in pure $ mkNode opts (PresentT xs) ["ToUpper" <> show0 opts " " xs <> showA opts " | " as] [] + + +-- | similar to 'Data.List.inits' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 xs = inits as + in pure $ mkNode opts (PresentT xs) ["Inits" <> show0 opts " " xs <> showA opts " | " as] [] + +-- | similar to 'Data.List.tails' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 xs = tails as + in pure $ mkNode opts (PresentT xs) ["Tails" <> show0 opts " " xs <> showA opts " | " as] [] + +-- | split a list into single values +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " d <> showA opts " | " p] [hh pp] + +-- | similar to 'show' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 <> showA 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 <> showA 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg1 <> show0 opts " " b <> showLit0 opts " | fmt=" p <> showA 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg1 <> show0 opts " " b <> showLit0 opts " | fmt=" d <> showA opts " | " q] hhs + +-- | create a 'Day' from three int values passed in as year month and day +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | (y,m,d)=" (p,q,r)] (hhs <> [hh rr]) + +-- | uncreate a 'Day' returning year month and day +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | " p] [] + +-- | uses the 'Read' of the given type \'t\' and \'p\' which points to the content to read +-- +-- >>> :set -XTypeApplications +-- >>> :set -XTypeOperators +-- >>> :set -XDataKinds +-- >>> 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) [msg1 <> show0 opts " " b <> showLit opts " | " s] [hh pp] + _ -> mkNode opts (FailT (msg1 <> " failed")) [msg1 <> " failed"] [hh pp] + +-- | similar to 'minimum' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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' = + pure $ case as' of + [] -> mkNode opts (FailT "empty list") ["Min(empty list)"] [] + as@(_:_) -> + let v = minimum as + in mkNode opts (PresentT v) ["Min" <> show0 opts " " v <> showA opts " | " as] [] + +-- | similar to 'maximum' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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' = + pure $ case as' of + [] -> mkNode opts (FailT "empty list") ["Max(empty list)"] [] + as@(_:_) -> + let v = maximum as + in mkNode opts (PresentT v) ["Max" <> show0 opts " " v <> showA opts " | " as] [] + +-- | sort a list +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 n = length as + in pure $ mkNode opts (PresentT n) ["Len" <> show0 opts " " n <> showA opts " | " as] [] + +-- | similar to 'length' for 'Foldable' instances +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 +-- +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) [msg0 <> show0 opts " " n <> showA opts " | " as] [] + +-- | similar to 'fst' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | " 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' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | " 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | " 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 "dude" +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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | " 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 "dude" +instance ExtractL4C (a,b,c) where + type ExtractL4T (a,b,c) = GL.TypeError ('GL.Text "L4 doesn't work for 3-tuples") + extractL4C _ = error "dude" +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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | " 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 "dude" +instance ExtractL5C (a,b,c) where + type ExtractL5T (a,b,c) = GL.TypeError ('GL.Text "L5 doesn't work for 3-tuples") + extractL5C _ = error "dude" +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 "dude" +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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | " 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 "dude" +instance ExtractL6C (a,b,c) where + type ExtractL6T (a,b,c) = GL.TypeError ('GL.Text "L6 doesn't work for 3-tuples") + extractL6C _ = error "dude" +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 "dude" +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 "dude" +instance ExtractL6C (a,b,c,d,e,f) where + type ExtractL6T (a,b,c,d,e,f) = f + extractL6C (_,_,_,_,_,f) = f + + +-- | identity function +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @I 23 +-- Present 23 +-- PresentT 23 +data I +instance P I a where + type PP I a = a + eval _ opts a = + pure $ mkNode opts (PresentT a) ["I"] [] + + +-- | identity function that displays the input +-- +-- even more constraints than 'I' so we might need to add explicit type signatures +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @Id 23 +-- Present 23 +-- PresentT 23 +data Id -- showable version of I +instance Show a => P Id a where + type PP Id a = a + eval _ opts a = pure $ mkNode opts (PresentT a) ["Id" <> show0 opts " " a] [] + + +-- | identity function that also displays the type information for debugging +-- +-- even more constraints than 'Id' so we might need to explicitly add types (Typeable) +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 t = showT @a + in pure $ mkNode opts (PresentT a) ["IdT(" <> t <> ")" <> show0 opts " " a] [] + +-- | 'fromString' function +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> :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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | " n] [hh nn] + +-- | 'toRational' function +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " r <> showA opts " | " a] [hh pp] + +-- | 'fromRational' function +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | " r] [hh rr] + +-- | 'truncate' function +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | " p] [hh pp] + +-- | 'ceiling' function +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | " p] [hh pp] + +-- | 'floor' function +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | " p] [hh pp] + +-- Start non-Type kinds +----------------------- +----------------------- +----------------------- + +-- | pulls the type level 'Bool' to the value level +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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.&&&' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @'(Snd Id, Fst Id) ("helo",123) +-- Present (123,"helo") +-- PresentT (123,"helo") +-- +-- >>> :set -XTypeOperators +-- >>> pl @'(Len, Id <> "|" <> Reverse) "helo" +-- Present (4,"helo|oleh") +-- PresentT (4,"helo|oleh") +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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @'(Len, Id, Reverse) "helo" +-- Present (4,"helo","oleh") +-- PresentT (4,"helo","oleh") +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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @'(Len, Id, "inj", 999) "helo" +-- Present (4,"helo","inj",999) +-- PresentT (4,"helo","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' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 \'() +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 \'[] +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> :set -XNoStarIsType +-- >>> 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] +-- +-- >>> pl @'[W 1, W 2, W 3, Id * 4, Pred Id] 999 +-- Present [1,2,3,3996,998] +-- PresentT [1,2,3,3996,998] +-- +-- >>> :set -XTypeOperators +-- >>> pl @'[Id * 4, Pred Id] 999 +-- Present [3996,998] +-- PresentT [3996,998] +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 msg = "" -- "'[](end)" + pure $ case getValueLR opts msg pp [] of + Left e -> e + Right b -> mkNode opts (PresentT [b]) [msg <> show0 opts " " b <> showA opts " | " a] [hh pp] -- <> show0 opts " " a <> showA 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 msg = "'" + -- len = 2 + getLen @ps + lr <- runPQ msg (Proxy @p) (Proxy @(p1 ': ps)) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + mkNode opts (PresentT (p:q)) [msg <> show0 opts "" (p:q) <> showA opts " | " a] [hh pp, hh qq] + +-- | extracts the \'a\' from type level \'Maybe a\' if the value exists +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @('Just Id) (Just 123) +-- Present 123 +-- PresentT 123 +-- +-- >>> pl @('Just (Not Id)) (Just True) +-- Present False +-- PresentT False +-- +-- >>> 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 msg = "'Just" + case ma of + Just a -> do + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts msg pp [] of + Left e -> e + Right b -> mkNode opts (PresentT b) [msg <> show0 opts " " b <> showA opts " | " ma] [hh pp] + Nothing -> pure $ mkNode opts (FailT (msg <> " found Nothing")) [msg <> " found Nothing"] [] + +-- | expects Nothing otherwise it fails +-- if the value is Nothing then it returns \'Proxy a\' as this provides more information than '()' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 msg = "'Nothing" + in pure $ case ma of + Nothing -> mkNode opts (PresentT Proxy) [msg] [] + Just _ -> mkNode opts (FailT (msg <> " found Just")) [msg <> " found Just"] [] + +-- omitted Show x so we can have less ambiguity +-- | extracts the \'a\' from type level \'Either a b\' if the value exists +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 msg = "'Left" + in case lr of + Right _ -> pure $ mkNode opts (FailT (msg <> " found Right")) [msg <> " found Right"] [] + Left a -> do + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts msg pp [] of + Left e -> e + Right b -> mkNode opts (_tBool pp) [msg <> show0 opts " " b <> showA opts " | Left " a] [hh pp] + +-- | extracts the \'b\' from type level \'Either a b\' if the value exists +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 msg = "'Right" + case lr of + Left _ -> pure $ mkNode opts (FailT (msg <> " found Left")) [msg <> " found Left"] [] + Right a -> do + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts msg pp [] of + Left e -> e + Right b -> mkNode opts (_tBool pp) [msg <> show0 opts " " b <> showA opts " | 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 msg = "'This" + case th of + This a -> do + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts msg pp [] of + Left e -> e + Right b -> mkNode opts (_tBool pp) [msg <> show0 opts " " b <> showA opts " | This " a] [hh pp] + _ -> pure $ mkNode opts (FailT (msg <> " found " <> showThese th)) [msg <> " found " <> showThese th] [] + +-- | extracts the \'b\' from type level \'These a b\' if the value exists +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 msg = "'That" + case th of + That a -> do + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts msg pp [] of + Left e -> e + Right b -> mkNode opts (_tBool pp) [msg <> show0 opts " " b <> showA opts " | That " a] [hh pp] + _ -> pure $ mkNode opts (FailT (msg <> " found " <> showThese th)) [msg <> " found " <> showThese th] [] + + +-- | extracts the (a,b) from type level 'These a b' if the value exists +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @('These Id Id) (These 123 "abc") +-- Present (123,"abc") +-- PresentT (123,"abc") +-- +-- >>> pl @('These (Pred Id) Len) (These 123 "abcde") +-- Present (122,5) +-- PresentT (122,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 msg = "'These" + case th of + These a b -> do + pp <- eval (Proxy @p) opts a + case getValueLR opts msg pp [] of + Left e -> pure e + Right p -> do + qq <- eval (Proxy @q) opts b + pure $ case getValueLR opts (msg <> " q failed p=" <> show p) qq [hh pp] of + Left e -> e + Right q -> mkNode opts (PresentT (p,q)) [msg <> show0 opts " " (p,q) <> showA opts " | " (These a b)] [hh pp, hh qq] + _ -> pure $ mkNode opts (FailT (msg <> " found " <> showThese th)) [msg <> " found " <> showThese th] [] + +-- | converts the value to the corresponding 'Proxy' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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" <> showA opts " | " a] [] + +-- End non-Type kinds +----------------------- +----------------------- +----------------------- + +-- | converts a value to a 'Proxy': the same as '\'Proxy' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 b = Proxy @a + in pure $ mkNode opts (PresentT b) ["MkProxy" <> showA 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.>>' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @(Do [Pred Id, ShowP Id, Id &&& Len]) 9876543 +-- Present ("9876542",7) +-- PresentT ("9876542",7) +-- +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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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\' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @(TupleI '[Id,ShowP Id,Pred Id,W "str", W 999]) 666 +-- Present (666,("666",(665,("str",(999,()))))) +-- PresentT (666,("666",(665,("str",(999,()))))) +-- +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 msg = "TupleI" -- "'[](" <> show len <> ")" + case getValueLR opts msg pp [] of + Left e -> pure e + Right w -> do + qq <- eval (Proxy @(TupleI ps)) opts a + pure $ case getValueLR opts msg 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)) [msg <> show0 opts " " a] [hh pp, hh qq] + +-- | add a message to give more context to the evaluation tree +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pe @(Msg' "somemessage" Id) 999 +-- P [somemessage] Id 999 +-- PresentT 999 +-- +data Msg prt p +type Msg' prt p = Msg (Printf "[%s] " prt) p -- put msg in square brackets + +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 + +-- | pad \'q\' with '\n'\ values from '\p'\ +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg1 <> show0 opts " " bs <> showA opts " | " q] (hhs <> [hh qq]) + +-- | split a list \'p\' into parts using the lengths in the type level list \'ns\' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 msg = "SplitAts" + lr <- runPQ msg (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) [msg <> show0 opts " " zs <> showA opts " | ns=" ns <> showA opts " | " p] [hh nn, hh pp] + +-- | similar to 'splitAt' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 = SplitAt n p >> Fst Id +type Drop n p = SplitAt n p >> (Snd Id) + +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 + in mkNode opts (PresentT (x,y)) [msg1 <> show0 opts " " (x,y) <> showA opts " | n=" n <> showA 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.***' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 msg = "(***)" + pp <- eval (Proxy @p) opts a + case getValueLR opts msg pp [] of + Left e -> pure e + Right a1 -> do + qq <- eval (Proxy @q) opts b + pure $ case getValueLR opts msg qq [hh pp] of + Left e -> e + Right b1 -> mkNode opts (PresentT (a1,b1)) [msg <> show0 opts " " (a1,b1) <> showA opts " | " (a,b)] [hh pp, hh qq] + +-- | similar 'Control.Arrow.|||' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 (Left a) = do + let msg = "|||" + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts msg pp [] of + Left e -> e + Right a1 -> mkNode opts (_tBool pp) ["Left" <> show0 opts " " a1 <> showA opts " | " a] [hh pp] + eval _ opts (Right a) = do + let msg = "|||" + qq <- eval (Proxy @q) opts a + pure $ case getValueLR opts msg qq [] of + Left e -> e + Right a1 -> mkNode opts (_tBool qq) ["Right" <> show0 opts " " a1 <> showA opts " | " a] [hh qq] + +-- | similar 'Control.Arrow.+++' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 (Left a) = do + let msg = "+++" + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts msg pp [] of + Left e -> e + Right a1 -> mkNode opts (PresentT (Left a1)) ["(+++) Left" <> show0 opts " Left " a1 <> showA opts " | " a] [hh pp] + eval _ opts (Right a) = do + let msg = "+++" + qq <- eval (Proxy @q) opts a + pure $ case getValueLR opts msg qq [] of + Left e -> e + Right a1 -> mkNode opts (PresentT (Right a1)) ["(+++) Right" <> show0 opts " Right" a1 <> showA 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> :set -XNoStarIsType +-- >>> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 msg = "DivF" + lr <- runPQ msg (Proxy @p) (Proxy @q) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) + | q == 0 -> let msg1 = msg <> " 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 'Ratio' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> :set -XNoStarIsType +-- >>> 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' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> :set -XTypeOperators +-- >>> 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) [msg0 <> show0 opts " " d <> showA opts " | " p] [hh pp] + + +-- | similar to 'abs' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " d <> showA opts " | " p] [hh pp] + + + +-- | similar to 'signum' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " d <> showA opts " | " p] [hh pp] + +-- | unwraps a value (see 'Control.Lens.Unwrapped') +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) ["Unwrap" <> show0 opts " " d <> showA opts " | " p] [hh pp] + +-- | wraps a value (see 'Control.Lens.Wrapped' and 'Control.Lens.Unwrapped') +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> :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) ["Wrap" <> show0 opts " " d <> showA opts " | " p] [hh pp] + +-- | similar to 'coerce' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 d = a ^. coerced + in pure $ mkNode opts (PresentT d) ["Coerce" <> show0 opts " " d <> showA opts " | " a] [] + +-- can coerce over a functor: but need to provide type of 'a' and 't' explicitly + +-- | see 'Coerce': coerce over a functor +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 d = view coerced <$> fa + in pure $ mkNode opts (PresentT d) ["Coerce2" <> show0 opts " " d <> showA opts " | " fa] [] + +-- | lift mempty over a Functor +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 b = mempty <$> fa + in pure $ mkNode opts (PresentT b) ["MEmptyT2" <> show0 opts " " b <> showA opts " | " fa] [] + +-- | lift pure over a Functor +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 b = fmap pure fa + in pure $ mkNode opts (PresentT b) ["Pure2" <> show0 opts " " b <> showA opts " | " fa] [] + +-- | similar to 'reverse' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 d = reverse as + in pure $ mkNode opts (PresentT d) ["Reverse" <> show0 opts " " d <> showA opts " | " as] [] + +-- | reverses using 'reversing' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> import Data.Text (Text) +-- >>> pl @ReverseL ("AbcDeF" :: Text) +-- Present "FeDcbA" +-- PresentT "FeDcbA" +-- +data ReverseL + +instance (Show t, Reversing t) => P ReverseL t where + type PP ReverseL t = t + eval _ opts as = + let d = as ^. reversed + in pure $ mkNode opts (PresentT d) ["ReverseL" <> show0 opts " " d <> showA opts " | " as] [] + +-- | swaps using 'swapped' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) +-- +data Swap + +instance (Show (p a b) + , Swapped p + , Show (p b a) + ) => P Swap (p a b) where + type PP Swap (p a b) = p b a + eval _ opts pab = + let d = pab ^. swapped + in pure $ mkNode opts (PresentT d) ["Swap" <> show0 opts " " d <> showA opts " | " pab] [] + +-- | bounded 'succ' function +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " n <> showA opts " | " q] [hh qq] + +-- | bounded 'pred' function +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @(PredB' Id) (13 :: Int) +-- Present 12 +-- PresentT 12 + +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) [msg0 <> show0 opts " " n <> showA opts " | " q] [hh qq] + + +-- | unbounded 'succ' function +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " n <> showA opts " | " p] [hh pp] + + +-- | unbounded 'pred' function +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @(Pred Id) 13 +-- Present 12 +-- PresentT 12 + +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) [msg0 <> show0 opts " " n <> showA opts " | " p] [hh pp] + + +-- | 'fromEnum' function +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) ["FromEnum" <> show0 opts " " n <> showA opts " | " p] [hh pp] + +-- | unsafe 'toEnum' function +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " n <> showA opts " | " p] [hh pp] + +-- | bounded 'toEnum' function +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " n <> showA opts " | " a] [] + +-- | a predicate on prime numbers +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 <> showA opts " | " p] [] + + +-- | 'not' function +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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\' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " ret <> showA opts " | p=" p <> showA opts " | q=" q] [hh pp, hh qq] + +-- | 'elem' function +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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] + +-- | 'const' () function +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @() "Asf" +-- Present () +-- PresentT () +-- +instance Show a => P () a where + type PP () a = () + eval _ opts a = pure $ mkNode opts (PresentT ()) ["()" <> show0 opts " " a] [] + +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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 Id) -- 'Proxy a' -- to distinguish from A +type A = (Snd Id) -- 'a' +type X = Fst Id >> Fst Id -- '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) +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @(EitherX (ShowP ((Fst Id >> Fst Id) + (Snd Id))) (ShowP Id) (Snd Id)) (9,Left 123) +-- Present "132" +-- PresentT "132" +-- +-- >>> pl @(EitherX (ShowP ((Fst Id >> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @(TheseX (((Fst Id >> Fst Id) + (Snd Id)) >> ShowP Id) (ShowP Id) (Snd Id >> (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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg1 <> show0 opts " " b <> showA opts " | " a] [hh qq] + + +-- | similar to 'SG.stimes' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg1 <> show0 opts " " b <> showA opts " | n=" n <> showA opts " | " p] [hh pp, hh qq] + + +-- | similar to 'pure' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | " a] [hh pp] + +type PMEmpty = MEmptyT' 'Proxy -- lifts 'a' to 'Proxy a' then we can use it with MEmptyP + +-- | similar to 'mempty' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 b = mempty @(PP t a) + in pure $ mkNode opts (PresentT b) ["MEmptyT" <> show0 opts " " b] [] + +data MEmptyProxy +instance Monoid a => P MEmptyProxy (Proxy (a :: Type)) where + type PP MEmptyProxy (Proxy a) = a + eval _ opts _pa = + let b = mempty @a + in pure $ mkNode opts (PresentT b) ["MEmptyProxy"] [] + +-- | similar to 'empty' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | " 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 msg = "MkNothing" + in pure $ mkNode opts (PresentT Nothing) [msg] [] + +-- | 'Just' constructor +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) ["MConcat" <> show0 opts " " b <> showA opts " | " p] [hh pp] + +-- | similar to 'concat' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) ["Concat" <> show0 opts " " b <> showA opts " | " p] [hh pp] + +instance P (Proxy t) a where + type PP (Proxy t) a = Proxy t + eval _ opts _ = + pure $ mkNode opts (PresentT Proxy) ["Proxy"] [] + +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.!!' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg1 <> show0 opts " " ret <> showA opts " | p=" p <> showA opts " | q=" q] [hh pp, hh qq] + +-- | 'lookup' leveraging 'Ixed' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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)) [msg1 <> show0 opts " " ret <> showA opts " | p=" p <> showA opts " | q=" q] hhs + +-- | 'Data.List.ands' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 <> showA opts " | " p] [hh pp] + +-- | 'Data.List.ors' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 <> showA 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | p=" p <> showA opts " | q=" q] [hh pp, hh qq] + +-- | similar to snoc +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | p=" p <> showA opts " | q=" q] [hh pp, hh qq] + +-- | 'Control.Lens.uncons' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 b = as ^? _Cons + in pure $ mkNode opts (PresentT b) ["Uncons" <> show0 opts " " b <> showA opts " | " as] [] + +-- | 'Control.Lens.unsnoc' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 b = as ^? _Snoc + in pure $ mkNode opts (PresentT b) ["Unsnoc" <> show0 opts " " b <> showA opts " | " as] [] + +-- | similar to 'null' using 'AsEmpty' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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" <> showA opts " | " as] [] + +-- | similar to 'null' using 'Foldable' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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" <> showA opts " | " as] [] + +-- | similar to 'enumFromTo' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 b = partitionEithers as + in pure $ mkNode opts (PresentT b) ["PartitionEithers" <> show0 opts " " b <> showA opts " | " as] [] + +-- | similar to 'partitionThese'. returns a 3-tuple with the results so use 'Fst' 'Snd' 'Thd' to extract +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 b = partitionThese as + in pure $ mkNode opts (PresentT b) ["PartitionThese" <> show0 opts " " b <> showA opts " | " 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' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg1 <> show0 opts " " vals <> showA opts " | b=" q <> showA opts " | as=" r] (hh qq : hh rr : map (hh . fixit) itts) + +type family UnfoldT mbs where + UnfoldT (Maybe (b,s)) = b + +-- | similar to 'unfoldr' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg1 <> show0 opts " " ret <> showA opts " | s=" q ] (hh qq : map (hh . fixit) itts) + +-- | similar to 'map' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " vals <> showA opts " | " as] (hh qq : map (hh . fixit) ts) + +-- | if p then run q else run r +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " zs <> showA opts " | " as ] [] + + +-- | similar to 'partition' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " zz1 <> showA opts " | s=" as] (hh qq : map (hh . fixit) tfs) + + +-- | similar to 'break' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 :> 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 :> 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 :> iall))) + + Right False -> error "shouldnt happen" + Left e -> e + +-- | Fails the computation with a message +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 msg = "Fail" + pp <- eval (Proxy @prt) opts a + pure $ case getValueLR opts msg pp [] of + Left e -> e + Right s -> mkNode opts (FailT s) [msg <> " " <> 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 msg = "Hole(" <> showT @t <> ")" + in pure $ mkNode opts (FailT msg) [msg <> " 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 msg = "Unproxy(" <> showT @a <> ")" + in pure $ mkNode opts (FailT msg) [msg <> " you probably meant to get access to the type of PP only and not evaluate"] [] + +-- | transparent predicate wrapper to make k of kind Type so it can be in a promoted list (cant mix kinds) see 'Do' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @(Do '[W 123, W "xyz", Len &&& Id, Pred Id *** Id<>Id]) () +-- Present (2,"xyzxyz") +-- PresentT (2,"xyzxyz") +-- +-- +-- >>> 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 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)) + +-- | catch a failure +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 >> Same 0 +type Odd = Mod I 2 >> Same 1 +type Div' p q = DivMod p q >> Fst Id +type Mod' p q = DivMod p q >> (Snd Id) + +-- | similar to 'div' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 msg = "Div" + lr <- runPQ msg (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 (msg <> " zero denominator")) [msg <> " zero denominator"] hhs + _ -> let d = p `div` q + in mkNode opts (PresentT d) [show p <> " `div` " <> show q <> " = " <> show d] hhs + + +-- | similar to 'mod' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 msg = "Mod" + lr <- runPQ msg (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 (msg <> " zero denominator")) [msg <> " zero denominator"] hhs + _ -> let d = p `mod` q + in mkNode opts (PresentT d) [show p <> " `mod` " <> show q <> " = " <> show d] hhs + +-- | similar to 'divMod' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 msg = "DivMod" + lr <- runPQ msg (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 (msg <> " zero denominator")) [msg <> " zero denominator"] hhs + _ -> let d = p `divMod` q + in mkNode opts (PresentT d) [show p <> " `divMod` " <> show q <> " = " <> show d] hhs + +-- | similar to 'quotRem' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 msg = "QuotRem" + lr <- runPQ msg (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 (msg <> " zero denominator")) [msg <> " 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 = QuotRem p q >> Fst Id +type Rem p q = QuotRem p q >> (Snd Id) + +--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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 msg = "Guards" <> strictmsg @strict <> "(" <> show n <> ")" + n :: Int = nat @n + in pure $ mkNode opts (PresentT as) [msg <> " done!" <> if null as then "" else showA 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\' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 o02 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 msg = ">>" + 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) [msg <> show0 opts " " q <> showA opts " | " p] [hh pp, hh qq] + +-- | similar to 'Prelude.&&' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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.||' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 <> showA opts " | " x] [hh pp] + +-- | similar to 'toList' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 z = toList as + in pure $ mkNode opts (PresentT z) ["ToList" <> show0 opts " " z <> showA opts " | " as] [] + +-- | similar to 'toList' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " b <> showA opts " | " 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 z = Ge.toList as + in pure $ mkNode opts (PresentT z) ["ToListExt" <> show0 opts " " z <> showA opts " | " 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 z = Ge.fromList (as :: [Ge.Item t]) :: t + in pure $ mkNode opts (PresentT z) ["FromList" <> 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 z = Ge.fromList (Ge.toList @l as) + in pure $ mkNode opts (PresentT z) ["FromListF" <> show0 opts " " z] [] + +-- | predicate on 'These' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 <> showA opts " | " p] [] + +-- | similar to 'these' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 msg = "This" + pp <- eval (Proxy @p) opts a + pure $ case getValueLR opts (msg <> " p failed") pp [] of + Left e -> e + Right c -> mkNode opts (PresentT c) [msg <> show0 opts " " c <> showA opts " | This " a] [hh pp] + That b -> do + let msg = "That" + qq <- eval (Proxy @q) opts b + pure $ case getValueLR opts (msg <> " q failed") qq [] of + Left e -> e + Right c -> mkNode opts (PresentT c) [msg <> show0 opts " " c <> showA opts " | That " b] [hh qq] + These a b -> do + let msg = "TheseIn" + rr <- eval (Proxy @r) opts (a,b) + pure $ case getValueLR opts (msg <> " r failed") rr [] of + Left e -> e + Right c -> mkNode opts (PresentT c) [msg <> show0 opts " " c <> showA opts " | " (These a b)] [hh rr] + +-- | creates an empty list of the given type +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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"] [] + +type Singleton p = p :+ EmptyT [] p + +-- | creates a singleton from a value +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @(Singleton (Char1 "aBc")) () +-- Present "a" +-- PresentT "a" +-- +-- >>> pl @(Singleton Id) False +-- Present [False] +-- PresentT [False] +-- +{- +data Singleton p +instance (P p x, Show (PP p x)) + => P (Singleton p) x where + type PP (Singleton p) x = [PP p x] + eval _ opts x = do + let msg0 = "Singleton" + pp <- eval (Proxy @p) opts x + pure $ case getValueLR opts msg0 pp [] of + Left e -> e + Right p -> + let b = [p] + in mkNode opts (PresentT b) [msg0 <> show0 opts " " p <> showA opts " | " p] [hh pp] +-} + +-- | extracts the first character from a non empty 'Symbol' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 = TA.align p q + in mkNode opts (PresentT d) [msg0 <> show0 opts " " d <> showA opts " | p=" p <> showA opts " | q=" q] [hh pp, hh qq] + +data ZipTheseF p q + +instance (Show (f y) + , PP p a ~ f x + , PP q a ~ f y + , ExtractAFromTA (f x) ~ x + , ExtractAFromTA (f y) ~ y + , Show (f x) + , TA.Align f + , Show (f (These x y)) + , P p a + , P q a) + => P (ZipTheseF p q) a where + type PP (ZipTheseF p q) a = ApplyConstT (PP p a) (These (ExtractAFromTA (PP p a)) (ExtractAFromTA (PP q a))) + eval _ opts a = do + let msg0 = "ZipTheseF" + lr <- runPQ msg0 (Proxy @p) (Proxy @q) opts a + pure $ case lr of + Left e -> e + Right (p,q,pp,qq) -> + let d = TA.align p q + in mkNode opts (PresentT d) [msg0 <> show0 opts " " d <> showA opts " | p=" p <> showA opts " | q=" q] [hh pp, hh qq] + +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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " d <> showA opts " | p=" p <> showA opts " | q=" q] [hh pp, hh qq] + +-- | Luhn predicate check on last digit +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 <> showA opts " | " p] hhs + +pe0, pe, pe1, pe2, pu, pex, pe3, pl, plc :: forall p a . (Show (PP p a), P p a) => a -> IO (BoolT (PP p a)) +pe0 = peWith @p o0 +pe = peWith @p o02 +pex = peWith @p o03 +pe1 = peWith @p o1 +pe2 = peWith @p o2 +pe3 = peWith @p o3 +pl = peWith @p ol +plc = peWith @p olc +pu = peWith @p o2 { oDisp = Unicode } + +peWith :: forall p a . (Show (PP p a), P p a) => -- Typeable (Proxy p), + 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 + +-- could get n::Nat as a predicate but it is fine as is! +-- | Read a number base 2 via 36 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) <> showA 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 = take n (['0'..'9'] <> ['a'..'z']) + +-- | Display a number at base 2 to 36 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @(ShowBase 16) 4077 +-- Present "fed" +-- PresentT "fed" +-- +-- >>> pl @(ShowBase 16) (-255) +-- Present "-ff" +-- PresentT "-ff" +-- +-- >>> pl @(ShowBase 2) 147 +-- Present "10010011" +-- PresentT "10010011" +-- +-- supports negative numbers unlike showIntAtBase +data ShowBase (n :: Nat) + +instance (Show a + , 2 GL.<= n + , n GL.<= 36 + , KnownNat n + , Integral a + ) => P (ShowBase n) a where + type PP (ShowBase n) a = String + eval _ opts a = + let n = nat @n + xs = getValidBase n + msg = "ShowBase " <> show n + (ff,a') = if a < 0 then (('-':), abs a) else (id,a) + b = showIntAtBase (fromIntegral n) (xs !!) a' "" + in pure $ mkNode opts (PresentT (ff b)) [msg <> showLit0 opts " " (ff b) <> showA opts " | " a] [] + +type Assocl = '(I *** Fst Id, (Snd Id) >> (Snd Id)) +type Assocr = '(Fst Id >> Fst Id, (Snd Id) *** I) +--type Assocl = (I *** Fst Id) &&& (Snd Id >> (Snd Id)) +--type Assocr = (Fst Id >> Fst Id) &&& (Snd Id *** I) + +-- | Intercalate +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " d <> showA opts " | " p <> showA 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 <> "]" <> showA opts " | p=" p <> showLit 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' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 + -- showA 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 : []) <> showA opts " | " a <> (if strict then "" else showA 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) <> showA 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msgbase0 <> show0 opts " " b <> showA opts " | " 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) [msgbase0 <> show0 opts " " b <> showA opts " | " 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) [msgbase0 <> show0 opts " " b <> showA opts " | " 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) [msgbase1 <> show0 opts " " b <> showA opts " | " a] [hh rr, hh pp, hh ww] + +-- | similar to 'sequenceA' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 <> showA 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' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 msg = "TimeU" + mb <- runIO $ getCurrentTime + pure $ case mb of + Nothing -> mkNode opts (FailT (msg <> " must run in IO")) [msg <> " must run in IO"] [] + Just v -> mkNode opts (PresentT v) [msg <> show0 opts " " v] [] + +data TimeZ + +instance P TimeZ a where + type PP TimeZ a = ZonedTime + eval _ opts _a = do + let msg = "TimeZ" + mb <- runIO $ getZonedTime + pure $ case mb of + Nothing -> mkNode opts (FailT (msg <> " must run in IO")) [msg <> " must run in IO"] [] + Just v -> mkNode opts (PresentT v) [msg <> 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 + msg = 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 msg 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 (msg <> " must run in IO")) [msg <> " must run in IO"] [hh pp] + Just (Left e) -> mkNode opts (FailT e) [msg <> " " <> e] [hh pp] + Just (Right ()) -> mkNode opts (PresentT ()) [msg] [hh pp] + +data Stdin + +instance P Stdin a where + type PP Stdin a = String + eval _ opts _a = do + let msg = "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 (msg <> " must run in IO")) [msg <> " must run in IO"] [] + Just (Left e) -> mkNode opts (FailT e) [msg <> " " <> e] [] + Just (Right ss) -> mkNode opts (PresentT ss) [msg <> "[" <> showLit opts "" ss <> "]"] [] + +--type Just' = JustFail "expected Just" Id +type Nothing' = Guard "expected Nothing" IsNothing + +-- | 'isInfixOf' 'isPrefixOf' 'isSuffixOf' equivalents +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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.<>' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @(Fst Id <> (Snd Id)) ("abc","def") +-- Present "abcdef" +-- PresentT "abcdef" +-- +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] + +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) + + +-- 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 = nat @n + msg = "TupleList" <> (if strict then "" else "Lax") <> "(" <> show n <> ")" + pure $ case tupleListD @(ToN n) @a strict as of + Left e -> mkNode opts (FailT (msg <> " " <> e)) [msg <> " " <> e] [] + Right ret -> mkNode opts (PresentT ret) [msg <> show0 opts " " ret <> showA opts " | " as] [] + +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 <> showA opts " | " tp] [] + +-- | Printfn prints +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) + +type Printf2 (s :: Symbol) = Printfn s '(Fst Id,'(Snd Id, '())) +-- Printf3/Printf3' expected format is (a, (b,c)) : we dont support (a,b,c) ever! +type Printf3 (s :: Symbol) = Printfn s '(Fst Id, '(Snd Id >> Fst Id, '(Snd Id >> (Snd Id), '()))) +type Printf3' (s :: Symbol) = Printfn s (TupleI '[Fst Id, (Snd Id) >> Fst Id, (Snd Id) >> (Snd 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 <> "]" <> showA 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.<$' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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.<*' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " p <> showA opts " | p=" p <> showA opts " | q=" q] [hh pp, hh qq] + +-- | similar to 'Control.Applicative.<|>' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " d <> showA opts " | p=" p <> showA opts " | q=" q] [hh pp, hh qq] + + +-- | similar to 'Control.Comonad.extract' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " d <> showA opts " | " ta] [] + +-- | similar to 'Control.Comonad.duplicate' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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) [msg0 <> show0 opts " " d <> showA opts " | " ta] [] + +-- | similar to 'Control.Monad.join' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @Join (Just (Just 20)) +-- Present Just 20 +-- PresentT (Just 20) +-- +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) [msg0 <> show0 opts " " d <> showA opts " | " tta] [] + +-- same as $ but shows 'a' and 'b' +data p $ q +infixl 0 $ + +type p & q = 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 (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] + +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' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 + , 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 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 ^. packed)) [msg0 <> showLit0 opts "" b <> showLit opts " | " p] [hh pp] + +-- | similar to 'T.stripLeft' 'T.stripRight' +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 + , 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 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 packed) b)) [msg0 <> show0 opts "" b <> showLit opts " | p=" p <> showLit opts " | q=" q] [hh pp, hh qq] + +-- | leverages 'Para' for repeating predicates (passthrough method) +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> pl @(ParaImplN 'True 4 (Succ Id)) [1..4] +-- Present [2,3,4,5] +-- PresentT [2,3,4,5] +-- +-- >>> pl @(ParaLaxN 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 ParaImplN (strict :: Bool) (n :: Nat) p +type ParaN (n :: Nat) p = ParaImplN 'True n p +type ParaLaxN (n :: Nat) p = ParaImplN 'False n p + +instance ( P (ParaImpl (LenT (RepeatT n p)) strict (RepeatT n p)) [a] + , GetLen (RepeatT n p) + , GetBool strict + ) => P (ParaImplN strict n p) [a] where + type PP (ParaImplN 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) +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 GuardsImplN (strict :: Bool) prt (n :: Nat) p +type GuardsN prt (n :: Nat) p = GuardsImplN 'True prt n p +type GuardsLaxN prt (n :: Nat) p = GuardsImplN '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 (GuardsImplN strict prt n p) [a] where + type PP (GuardsImplN 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] +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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 +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- >>> 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/Refined.hs view
@@ -99,31 +99,31 @@ -- >>> 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) >> GuardsQuick (Printf2 "octet %d out of range %d") (RepeatT 4 (Between 0 255)) >> 'True) ol "141.213.1.444" --- Left (FailP "octet 3 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.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) >> GuardsQuick (Printf2 "octet %d out of range %d") (RepeatT 4 (Between 0 255)) >> 'True) ol "141.213.1x34.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) ol "12344" +-- >>> prtRefinedIO @(Map ('[Id] >> ReadP Int) Id >> Luhn Id) ol "12344" -- Right (Refined {unRefined = "12344"}) -- --- >>> prtRefinedIO @(Map ('[Id] >> ReadP Int) Id >> Luhn) ol "12340" +-- >>> prtRefinedIO @(Map ('[Id] >> ReadP Int) Id >> Luhn Id) ol "12340" -- Left FalseP -- --- >>> prtRefinedIO @(Any Prime) ol [11,13,17,18] +-- >>> prtRefinedIO @(Any (Prime Id) Id) ol [11,13,17,18] -- Right (Refined {unRefined = [11,13,17,18]}) -- --- >>> prtRefinedIO @(All Prime) ol [11,13,17,18] +-- >>> prtRefinedIO @(All (Prime Id) Id) ol [11,13,17,18] -- Left FalseP -- --- >>> prtRefinedIO @(Snd !! Fst >> Len > 5) ol (2,["abc","defghij","xyzxyazsfd"]) +-- >>> prtRefinedIO @(Snd Id !! Fst Id >> Len > 5) ol (2,["abc","defghij","xyzxyazsfd"]) -- Right (Refined {unRefined = (2,["abc","defghij","xyzxyazsfd"])}) -- --- >>> prtRefinedIO @(Snd !! Fst >> Len > 5) ol (27,["abc","defghij","xyzxyazsfd"]) +-- >>> prtRefinedIO @(Snd Id !! Fst Id >> Len > 5) ol (27,["abc","defghij","xyzxyazsfd"]) -- Left (FailP "(!!) index not found") -- --- >>> prtRefinedIO @(Snd !! Fst >> Len <= 5) ol (2,["abc","defghij","xyzxyazsfd"]) +-- >>> 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)
src/Refined3.hs view
@@ -123,18 +123,18 @@ -- >>> 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 Fst (Snd >> Fst) (Snd >> Snd) >> 'Just Id) @(Guard "expected a Sunday" (Snd >> Snd == 7) >> 'True) @(Fst >> UnMkDay) ol (2019,(10,13)) --- Right (Refined3 {r3In = (2019-10-13,(41,7)), r3Out = (2019,(10,13))}) +-- >>> 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 (Snd >> Fst) (Snd >> Snd) >> 'Just Id) @(Guard "expected a Sunday" (Snd >> Snd == 7) >> 'True) @(Fst >> UnMkDay) ol (2019,(10,12)) +-- >>> 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 Fst (Snd >> Fst) (Snd >> Snd) >> 'Just Id, Guard "expected a Sunday" (Snd >> Snd == 7) >> 'True, Fst >> UnMkDay, k) --- >>> prtEval3P (Proxy @(T4 _)) ol (2019,(10,12)) +-- >>> 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))}) +-- >>> 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) } @@ -297,9 +297,9 @@ -- >>> :set -XDataKinds -- >>> import Control.Arrow ((+++)) -- >>> import Data.Time --- >>> type K1 = MakeR3 '(ReadP Day, 'True, ShowP, String) --- >>> type K2 = MakeR3 '(ReadP Day, Between (ReadP' Day "2019-03-30") (ReadP' Day "2019-06-01"), ShowP, String) --- >>> type K3 = MakeR3 '(ReadP Day, Between (ReadP' Day "2019-05-30") (ReadP' Day "2019-06-01"), ShowP, String) +-- >>> 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"}
src/Refined3Helper.hs view
@@ -53,9 +53,9 @@ -- >>> 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) (Remove "-" Id >> Ones) -type Ccop (n :: Nat) = Guard ('(n,Len) >> Printf2 "expected %d digits but found %d") (Len >> Same n) >> Luhn -type Ccfmt (ns :: [Nat]) = ConcatMap ShowP Id >> SplitAts ns Id >> Concat (Intercalate '["-"] Id) +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) @@ -98,23 +98,23 @@ -- 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 0 invalid: found 666 +-- 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 0 invalid: found 666 +-- 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 1 invalid: found 0 +-- 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 0 invalid: found 666 +-- 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 0 invalid: found 991 +-- 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 >> OneP >> Snd) +type Ssnip = Map (ReadP Int) (Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" Id >> OneP >> (Snd Id)) type Ssnop = GuardsQuick (Printf2 "number for group %d invalid: found %d") '[Between 1 899 && Id /= 666, Between 1 99, Between 1 9999] >> 'True @@ -132,10 +132,10 @@ -- Right (Refined3 {r3In = [23,13,59], r3Out = "23:13:59"}) -- -- >>> prtEval3P hms ol "23:13:60" --- Left Step 2. Failed Boolean Check(op) | guard(2) 60 secs is out of range +-- 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(0) 26 hours is out of range +-- Left Step 2. Failed Boolean Check(op) | guard(1) 26 hours is out of range -- hms :: Proxy Hms hms = mkProxy3 @@ -157,36 +157,26 @@ -- 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(3) octet out of range 0-255 found 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(1) octet out of range 0-255 found 257 +-- Left Step 2. Failed Boolean Check(op) | guard(2) octet out of range 0-255 found 257 -- type Ip = '(Ipip, Ipop, Ipfmt, String) -type Ip1 = '(Ipip, Ipop', Ipfmt, String) ip :: Proxy Ip ip = mkProxy3 -ip1 :: Proxy Ip1 -ip1 = mkProxy3 - -type Ipip = Map (ReadP Int) (Rescan "^(\\d{1,3}).(\\d{1,3}).(\\d{1,3}).(\\d{1,3})$" Id >> OneP >> Snd) +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 = GuardsQuick (Printf2 "guard(%d) octet out of range 0-255 found %d") (RepeatT 4 (Between 0 255)) >> 'True -type Ipop' = Guards '[ - '(Printf2 "octet %d out of range 0-255 found %d", Between 0 255) - , '(Printf2 "octet %d out of range 0-255 found %d", Between 0 255) - , '(Printf2 "octet %d out of range 0-255 found %d", Between 0 255) - , '(Printf2 "octet %d out of range 0-255 found %d", Between 0 255) - ] >> 'True +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, Map (ReadBaseInt 10) Id] +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) @@ -195,8 +185,8 @@ 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` "$" +--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"] @@ -230,25 +220,25 @@ -- uses builtin Luhn vs long winded version LuhnX type LuhnY (n :: Nat) = - '(Map (ReadP Int) Ones - , Guard (Printfn "incorrect number of digits found %d but expected %d in [%s]" (TupleI '[Len, W n, ShowP])) + '(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) - >> Guard ("luhn check failed") Luhn >> 'True - , ConcatMap ShowP Id + >> GuardSimple (Luhn Id) >> 'True + , ConcatMap (ShowP Id) Id , String) type LuhnX (n :: Nat) = - '(Map (ReadP Int) Ones + '(Map (ReadP Int) (Ones Id) , Luhn'' n >> 'True - , ConcatMap ShowP Id + , 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])) (Len >> Same n) + 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 * Snd >> If (Id >= 10) (Id - 9) Id) 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) @@ -257,11 +247,11 @@ 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 + '[Ones Id ,Map (ReadP Int) Id ,Reverse ,Ziplc [1,2] Id - ,Map (Fst * Snd >> If (Id >= 10) (Id - 9) Id) 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) @@ -300,19 +290,19 @@ -- >>> 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 (Pos 3) (Pos 5)))) ol "13 % 3" +-- >>> 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 (NegR 11 2) (Neg 3)))) ol "-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 > Pos 15))) ol "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 > Pos 15) >> 'True))) ol "13 % 3" +-- >>> 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 > Pos 11))) ol "13 % 3" +-- >>> 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" @@ -327,8 +317,8 @@ -- >>> 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, String) +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, String) +type ReadShow' (t :: Type) p = '(ReadP t, p, ShowP Id, String) type ReadShowR' (t :: Type) p = MakeR3 (ReadShow' t p)
src/UtilP.hs view
@@ -44,19 +44,16 @@ import qualified Data.Tree.View as TV import Data.Tree import Data.Tree.Lens -import Data.Tree.Pretty import Data.Proxy import Data.List.NonEmpty (NonEmpty(..)) import Data.Char import Data.Data import System.Console.Pretty -import qualified Text.PrettyPrint as PP 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.Discrimination as D import qualified Data.Text as T import Data.ByteString (ByteString) import GHC.Word (Word8) @@ -235,9 +232,7 @@ -- | display format for the tree data Disp = NormalDisp -- ^ draw horizontal tree - | Vertical !Int -- ^ draw vertical tree | Unicode -- ^ use unicode - | PPTree -- ^ pretty printer tree deriving (Show, Eq) instance Show POpts where @@ -288,15 +283,14 @@ o3 :: POpts o3 = defOpts { oDebug = 3, oShowA = Just 400 } +ou :: POpts +ou = o2 { oDisp = Unicode } + -- | helper method to set the width of data to be shown in the tree seta :: Int -> POpts -> POpts seta w o = o { oShowA = Just w } --- | helper method to display the tree vertically -setv :: Int -> POpts -> POpts -setv w o = o { oDisp = Vertical w } - -- | helper method to set the debug level setd :: Int -> POpts -> POpts setd v o = o { oDebug = v } @@ -347,14 +341,10 @@ TrueP -> color Green PresentP -> bgColor Yellow -defh, defv, defu :: POpts +defh, defu :: POpts defh = o1 -defv = defv' defaultGap defu = setu o1 -defv' :: Width -> POpts -defv' w = setv w o1 - -- | fix PresentT Bool to TrueT or FalseT fixBoolT :: TT Bool -> TT Bool fixBoolT t = @@ -466,6 +456,13 @@ | 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 @@ -513,7 +510,7 @@ FailT {} -> Nothing groupErrors :: [String] -> String -groupErrors = intercalate " | " . map (\xs -> head xs <> (if length xs > 1 then "(" <> show (length xs) <> ")" else "")) . D.group +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 @@ -766,8 +763,6 @@ 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 - Vertical w -> drawVerticalTreeWith w - PPTree -> (<>"\n") . PP.render . ppTree PP.text -- no newlines! lite :: POpts -> POpts lite o = o { oLite = True } @@ -778,22 +773,6 @@ horizontal :: POpts -> POpts horizontal o = o { oDisp = NormalDisp } -vertical :: POpts -> POpts -vertical = vertical' defaultGap - -vertical' :: Width -> POpts -> POpts -vertical' w o = o { oDisp = Vertical w } - - --- | display in document in tree format -ppTree :: (a -> PP.Doc) -> Tree a -> PP.Doc -ppTree pp = ppT - where - ppT (Node x []) = pp x - ppT (Node x xs) = PP.parens $ PP.hang (pp x) 2 $ - PP.sep $ map ppT xs - - prettyRational :: Rational -> String prettyRational (numerator &&& denominator -> (n,d)) = if | n == 0 -> "0" @@ -805,7 +784,7 @@ prefixMsg :: String -> TT a -> TT a prefixMsg msg t = - t & tStrings .ix 0 %~ (msg <>) + t & tStrings . ix 0 %~ (msg <>) showNat :: forall n . KnownNat n => String showNat = show (nat @n :: Integer) @@ -923,10 +902,10 @@ -- 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 +type family (p :: k -> k1) %% (q :: k) :: k1 where + p %% q = p q -infixl 9 % +infixl 9 %% type family (p :: k) %& (q :: k -> k1) :: k1 where p %& q = q p
test/TestJson.hs view
@@ -25,7 +25,6 @@ import Refined import Refined3 import Refined3Helper -import UtilP import GHC.Generics (Generic) import Data.Text (Text) import Data.Aeson @@ -79,8 +78,8 @@ type Name1 = Uncons >> 'Just Id - >> Guard (Printf "not upper first(%c)" Fst) (Fst >> '[Id] >> IsCharSet 'CUpper) - >> Guard (Printf "not lower rest(%s)" Snd) (Snd >> IsCharSet 'CLower) + >> 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) type AgeR = Refined (Between 10 60) Int @@ -88,7 +87,7 @@ type Ip4ip = Map (ReadP Int) (Resplit "\\." Id) type Ip4op = Guard (Printf "expected length 4 found %d" Len) (Len >> Same 4) - >> GuardsQuick (Printf2 "guard(%d): expected between 0 and 255 found %d") (RepeatT 4 (Between 0 255)) + >> GuardsN (Printf2 "guard(%d): expected between 0 and 255 found %d") 4 (Between 0 255) type Ip4fmt = Printfnt 4 "%03d.%03d.%03d.%03d" type DateTimeNR = MakeR3 DateTimeN
test/TestPredicate.hs view
@@ -52,26 +52,26 @@ allTests :: [IO ()] allTests = [expectPE (PresentT LT) $ pl @("aa" === Id) "aaaa" - , expectPE FalseT $ pl @("aa" === Id >> FromEnum >> Same 1) "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) (Right True) + , expectPE (PresentT (Right True)) $ pl @(Not Id +++ Id) (Right True) , expectPE (PresentT (4,4)) $ pl @(Dup >> Id) 4 - , expectPE (PresentT (Right 12)) $ pl @(Not +++ Id) (Right 12) + , expectPE (PresentT (Right 12)) $ pl @(Not Id +++ Id) (Right 12) , expectPE (PresentT (Right 1)) $ pl @(HeadDef () Id +++ Id) (Right @[()] 1) -- breaks otherwise: Id says () -> () so has to be a list of [()] , expectPE (PresentT (Right 1)) $ pl @(HeadDef () Id +++ Id) (Right @[()] 1) -- this breaks! cos Left doesnt have a type - , expectPE FalseT $ pl @(Fst >> Len >> Le 6 >> Not) ([2..7],True) - , expectPE TrueT $ pl @(Fst >> Len >> Le 6) ([2..7],True) - , expectPE TrueT $ pl @(Length Fst <= 6) ([2..7],True) - , expectPE TrueT $ pl @(Fst >> (Len >> Le 6)) ([2..7],True) - , expectPE FalseT $ pl @(HeadDef 12 Fst >> Le 6) ([],True) - , expectPE TrueT $ pl @(HeadDef 1 Fst >> Le 6) ([],True) - , expectPE (FailT "Head(empty)") $ pl @(Head' Fst >> Le 6) ([] @Int, True) - , expectPE FalseT $ pl @(HeadDef 10 Fst >> Le 6) ([],True) - , expectPE (FailT "zz") $ pl @(HeadFail "zz" Fst >> Le 6) ([],True) - , expectPE (FailT "failed1") $ pl @((HeadFail "failed1" Fst >> Le 6) `OR` 'False) ([],True) - , expectPE TrueT $ pl @((Fst >> HeadFail "failed2" Id >> Le (Neg 6)) `OR` 'False) ([-9],True) - , expectPE (FailT "failed3") $ pl @((Fst >> Failt _ "failed3" >> Le (Neg 6)) `OR` 'False) ([-5],True) + , expectPE FalseT $ pl @(Not (Fst Id >> Len >> Le 6)) ([2..7],True) + , expectPE TrueT $ pl @(Fst Id >> Len >> Le 6) ([2..7],True) + , expectPE TrueT $ pl @(Length (Fst Id) <= 6) ([2..7],True) + , expectPE TrueT $ pl @(Fst Id >> (Len >> Le 6)) ([2..7],True) + , expectPE FalseT $ pl @(HeadDef 12 (Fst Id) >> Le 6) ([],True) + , expectPE TrueT $ pl @(HeadDef 1 (Fst Id) >> Le 6) ([],True) + , 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 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) @@ -79,39 +79,39 @@ , expectPE FalseT $ pl @(Id > "xx") "abc" , expectPE TrueT $ pl @(Id > "aa") "abc" , expectPE TrueT $ pl @(Gt 4) 5 - , expectPE TrueT $ pl @(Map (Gt 3) Fst >> Ors) ([10,12,3,5],"ss") - , expectPE FalseT $ pl @(Map (Gt 3) Fst >> Ands) ([10,12,3,5],"ss") - , expectPE (PresentT [False,False,False,True]) $ pl @(Map (Mod Id 3) Fst >> Map (Gt 1) Id) ([10,12,3,5],"ss") - , expectPE (PresentT (12,5)) $ pl @(Fst >> Dup >> Star (Ix 1 (Failp "failed5")) (Ix 3 (Failp "failed5")) >> Id) ([10,12,3,5],"ss") - , expectPE FalseT $ pl @(Fst >> Dup >> Star (Ix 1 (Failp "failed5")) (Ix 3 (Failp "failed5")) >> Fst < Snd) ([10,12,3,5],"ss") - , expectPE TrueT $ pl @(Fst >> Dup >> Star (Ix 1 (Failp "failed5")) (Ix 3 (Failp "failed5")) >> Fst > Snd) ([10,12,3,5],"ss") - , expectPE TrueT $ pl @(Fst > Snd) (True,False) - , expectPE FalseT $ pl @(Fst == Snd) (True,False) - , expectPE TrueT $ pl @(Star Not Id >> Fst == Snd) (True,False) - , expectPE FalseT $ pl @(Snd >> Len &&& Ix 3 (Failp "someval1") >> Fst == Snd) ('x',[1..5]) - , expectPE FalseT $ pl @(Snd >> Len &&& Ix 3 (Failp "someval2") >> Fst < Snd) ('x',[1..5]) - , expectPE TrueT $ pl @(Snd >> Len &&& Ix 3 (Failp "someval3") >> Fst > Snd) ('x',[1..5]) - , expectPE FalseT $ pl @(Snd >> SplitAt 2 Id >> Star Len Len >> Fst > Snd) ('x',[1..5]) - , expectPE FalseT $ pl @(Map (Same 2) Id >> Ors) [1,4,5] - , expectPE TrueT $ pl @(Map (Same 2) Id >> Ors) [1,4,5,2,1] + , 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 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 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 @(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 , expectPE FalseT $ pl @(Elem Id '[2,3,4]) 6 - , expectPE TrueT $ pl @(Elem Id '[PosR 13 2]) 6.5 - , expectPE TrueT $ pl @(Elem Id '[PosR 13 2, Pos 12]) 6.5 - , expectPE FalseT $ pl @(Elem Id '[PosR 13 2, Pos 12]) 6 - , expectPE (FailT "lhs") $ pl @(Map Len Id >> (Ix 3 (Failp "lhs")) &&& (Ix 0 5) >> Fst == Snd) [[1..4],[4..5]] - , expectPE FalseT $ pl @(Map Len Id >> (Ix 0 (Failp "lhs")) &&& (Ix 1 5) >> Fst == Snd) [[1..4],[4..5]] - , expectPE (FailT "rhs") $ pl @(Map Len Id >> (Ix 1 (Failp "lhs")) &&& (Ix 3 (Failp "rhs")) >> Fst == Snd) [[1..4],[4..5]] - , expectPE (FailT "lhs") $ pl @(Map Len Id >> (Ix 10 (Failp "lhs")) &&& (Ix 1 (Failp "rhs")) >> Fst == Snd) [[1..4],[4..5]] - , expectPE (FailT "rhs") $ pl @(Map Len Id >> (Ix 0 (Failp "lhs")) &&& (Ix 10 (Failp "rhs")) >> Fst == Snd) [[1..4],[4..5]] - , expectPE FalseT $ pl @(Map Len Id >> (Ix 10 3) &&& (Ix 1 (Failp "rhs")) >> Fst == Snd) [[1..4],[4..5]] - , expectPE FalseT $ pl @(Map Len Id >> (Ix 3 3) &&& (Ix 1 4) >> Fst == Snd) [[1..4],[4..5]] - , expectPE FalseT $ pl @(Map Len Id >> (Ix 10 3) &&& (Ix 1 4) >> Fst == Snd) [[1..4],[4..5]] - , expectPE FalseT $ pl @(Map Len Id >> (Ix 10 5) &&& (Ix 1 4) >> Fst == Snd) [[1..4],[4..5]] - , expectPE TrueT $ pl @(Map Len Id >> (Ix 10 2) &&& (Ix 1 4) >> Fst == Snd) [[1..4],[4..5]] + , expectPE TrueT $ pl @(Elem Id '[13 % 2]) 6.5 + , expectPE TrueT $ pl @(Elem Id '[13 % 2, 12 % 1]) 6.5 + , expectPE FalseT $ pl @(Elem Id '[13 % 2, 12 % 1]) 6 + , expectPE (FailT "lhs") $ pl @(Map Len Id >> (Ix 3 (Failp "lhs")) &&& (Ix 0 5) >> Fst Id == Snd Id) [[1..4],[4..5]] + , expectPE FalseT $ pl @(Map Len Id >> (Ix 0 (Failp "lhs")) &&& (Ix 1 5) >> Fst Id == Snd Id) [[1..4],[4..5]] + , expectPE (FailT "rhs") $ pl @(Map Len Id >> (Ix 1 (Failp "lhs")) &&& (Ix 3 (Failp "rhs")) >> Fst Id == Snd Id) [[1..4],[4..5]] + , expectPE (FailT "lhs") $ pl @(Map Len Id >> (Ix 10 (Failp "lhs")) &&& (Ix 1 (Failp "rhs")) >> Fst Id == Snd Id) [[1..4],[4..5]] + , expectPE (FailT "rhs") $ pl @(Map Len Id >> (Ix 0 (Failp "lhs")) &&& (Ix 10 (Failp "rhs")) >> Fst Id == Snd Id) [[1..4],[4..5]] + , expectPE FalseT $ pl @(Map Len Id >> (Ix 10 3) &&& (Ix 1 (Failp "rhs")) >> Fst Id == Snd Id) [[1..4],[4..5]] + , expectPE FalseT $ pl @(Map Len Id >> (Ix 3 3) &&& (Ix 1 4) >> Fst Id == Snd Id) [[1..4],[4..5]] + , expectPE FalseT $ pl @(Map Len Id >> (Ix 10 3) &&& (Ix 1 4) >> Fst Id == Snd Id) [[1..4],[4..5]] + , expectPE FalseT $ pl @(Map Len Id >> (Ix 10 5) &&& (Ix 1 4) >> Fst Id == Snd Id) [[1..4],[4..5]] + , expectPE TrueT $ pl @(Map Len Id >> (Ix 10 2) &&& (Ix 1 4) >> Fst Id == Snd Id) [[1..4],[4..5]] , expectPE (PresentT ([1],[2,3,4,5])) $ pl @(Partition (Lt 2) Id >> Id) [1,2,3,4,5] - , expectPE (PresentT [1,2,3]) $ pl @(MaybeIn MemptyP Id) (Just [1,2,3]) - , expectPE (PresentT []) $ pl @(MaybeIn MemptyP Id) (Nothing @[Int]) + , expectPE (PresentT [1,2,3]) $ pl @(MaybeIn MEmptyP Id) (Just [1,2,3]) + , expectPE (PresentT []) $ pl @(MaybeIn MEmptyP Id) (Nothing @[Int]) , expectPE (FailT "'Just found Nothing") $ pl @('Just (FailS "someval")) (Nothing @()) -- breaks otherwise , expectPE (PresentT (4,4)) $ pl @Dup 4 , expectPE (PresentT 3) $ pl @(Last' Id) [1,2,3] @@ -119,36 +119,36 @@ , expectPE (FailT "Asdf") $ pl @(HeadFail "Asdf" Id) ([] @()) -- breaks otherwise , expectPE (FailT "Head(empty)") $ pl @(Head' Id) ([] @Int) , expectPE (FailT "Head(empty)") $ pl @(Head' Id) ([] @Double) - , expectPE (FailT "Succ bounded failed") $ pl @SuccB' GT - , expectPE (PresentT LT) $ pl @(SuccB 'LT) GT - , expectPE (PresentT EQ) $ pl @(SuccB 'GT) LT - , expectPE (PresentT EQ) $ pl @SuccB' LT - , expectPE (FailT "Pred bounded failed") $ pl @PredB' LT - , expectPE (PresentT GT) $ pl @(PredB 'GT) LT - , expectPE (PresentT EQ) $ pl @(PredB 'LT) GT - , expectPE (PresentT EQ) $ pl @PredB' GT + , expectPE (FailT "Succ bounded failed") $ pl @(SuccB' Id) GT + , expectPE (PresentT LT) $ pl @(SuccB 'LT Id) GT + , expectPE (PresentT EQ) $ pl @(SuccB 'GT Id) LT + , expectPE (PresentT EQ) $ pl @(SuccB' Id) LT + , expectPE (FailT "Pred bounded failed") $ pl @(PredB' Id) LT + , expectPE (PresentT GT) $ pl @(PredB 'GT Id) LT + , expectPE (PresentT EQ) $ pl @(PredB 'LT Id) GT + , expectPE (PresentT EQ) $ pl @(PredB' Id) GT , expectPE (FailT "ToEnum bounded failed") $ pl @(ToEnumBF Ordering) 44 , expectPE (PresentT LT) $ pl @(ToEnumB Ordering 'LT) 123 , expectPE (PresentT EQ) $ pl @(ToEnumB Ordering 'GT) 1 , expectPE (PresentT EQ) $ pl @(ToEnumBF Ordering) 1 - , expectPE (PresentT 11) $ pl @Succ 10 - , expectPE (FailT "Succ IO e=Prelude.Enum.Bool.succ: bad argument") $ pl @Succ True -- captures the exception + , expectPE (PresentT 11) $ pl @(Succ Id) 10 + , 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 == Snd) [1..6] - , expectPE (PresentT 5) $ pl @(Snd >> Snd >> Snd >> Snd >> Id) (9,(1,(2,(3,5)))) - , expectPE (FailT "ExitWhen") $ pl @((HeadFail "failedn" Id) &&& (Len >> Same 1 >> ExitWhen' Id) >> Fst) [3] - , expectPE (PresentT 3) $ pl @((HeadFail "failedn" Id) &&& (Len >> Same 1 >> Not >> ExitWhen' Id) >> Fst) [3] - , expectPE (PresentT 3) $ pl @((HeadFail "failedn" Id) &&& (Len >> Same 1 >> ExitWhen' Not) >> Fst) [3] + , expectPE TrueT $ pl @(Partition Even Id >> Star 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] + , expectPE (PresentT 3) $ pl @((HeadFail "failedn" Id) &&& (Len >> Same 1 >> ExitWhen' (Not Id)) >> Fst Id) [3] , expectPE (FailT "ExitWhen") $ pl @(ExitWhen' (Len >> Ne 1) >> HeadFail "failedn" Id) [3,1] , expectPE (PresentT 3) $ pl @(ExitWhen' (Len >> Ne 1) >> HeadFail "failedn" Id) [3] - , expectPE TrueT $ pl @(ExitWhen' (Len >> Ne 1) >> HeadFail "failedn" Id >> Gt (Neg 20)) [3] - , expectPE FalseT $ pl @(ExitWhen' (Len >> Ne 1) >> HeadFail "failedn" Id >> Gt (Neg 20)) [-23] - , expectPE (PresentT (-1.0)) $ pl @(Negate >> Dup >> First Succ >> Swap >> Fst - Snd) 4 - , expectPE (PresentT (Right 12)) $ pl @(Not +++ Id) (Right @Bool 12) - , expectPE (PresentT Cgt) $ pl @("aa" === Id >> FromEnum >> ToEnum OrderingP) "aaaa" + , expectPE TrueT $ pl @(ExitWhen' (Len >> Ne 1) >> HeadFail "failedn" Id >> Gt (20 %- 1 )) [3] + , 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 False) $ pl @(Msg "someval4" (Gt 4 >> Id)) 4 - , expectPE (PresentT ()) $ pl @(Snd >> Snd >> Snd >> Snd >> Id) (1,('a',(3,(True,())))) + , 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" , expectPE FalseT $ pl @(Re "\\d{4}-\\d{3}" Id) "1234-1x3" , expectPE TrueT $ pl @(Re' '[ 'Caseless, 'Dotall ] "ab" Id) "aB" @@ -159,45 +159,45 @@ , expectPE (PresentT [("aB",["B"]),("cd",["d"])]) $ pl @(Rescan ".(.)" Id) "aBcd" , expectPE (PresentT [14,12,10,4,2]) $ pl @(SortOnDesc Id Id) [10,4,2,12,14] , expectPE (PresentT [2,4,10,12,14]) $ pl @(SortOn Id Id) [10,4,2,12,14] - , expectPE (PresentT [14,12,10,4,2]) $ pl @(SortOn Negate Id) [10,4,2,12,14] - , expectPE (PresentT [('a',4),('a',14),('b',2),('c',10),('d',12),('z',1)]) $ pl @(SortOn Fst Id) (zip "cabdaz" [10,4,2,12,14,1]) + , expectPE (PresentT [14,12,10,4,2]) $ pl @(SortOn (Negate Id) Id) [10,4,2,12,14] + , expectPE (PresentT [('a',4),('a',14),('b',2),('c',10),('d',12),('z',1)]) $ pl @(SortOn (Fst Id) Id) (zip "cabdaz" [10,4,2,12,14,1]) , expectPE (FailT "asdf(4)") $ pl @(SortOn (FailS "asdf") Id) [10,4,2,12,14] - , expectPE TrueT $ pl @(Min &&& Max >> Id >> Fst < Snd) [10,4,2,12,14] + , expectPE TrueT $ pl @(Min &&& Max >> Id >> Fst Id < Snd Id) [10,4,2,12,14] , expectPE (FailT "ExitWhen") $ pl @(Partition (ExitWhen' (Gt 10) >> Gt 2) Id) [1..11] , 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 >> Succ) >> Fst === Snd) 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) (Just 116) - , expectPE (PresentT 99) $ pl @(MaybeIn 99 Succ) (Nothing @Int) - , expectPE (FailT "someval") $ pl @(MaybeIn (Failp "someval") Succ) (Nothing @()) + , expectPE (PresentT 117) $ pl @(MaybeIn (Failp "err") (Succ Id)) (Just 116) + , expectPE (PresentT 99) $ pl @(MaybeIn 99 (Succ Id)) (Nothing @Int) + , 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 === Snd)) (Just ('x','z')) - , expectPE (PresentT EQ) $ pl @(MaybeIn MemptyP (Fst === Snd)) (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) , expectPE (FailT "'Left found Right") $ pl @('Left Id) (Right @() 123) , expectPE (PresentT 123) $ pl @('Right Id) (Right 123) , expectPE (FailT "'Right found Left") $ pl @('Right Id) (Left @_ @() 123) - , expectPE (PresentT ["1","2","3"]) $ pl @(MaybeIn MemptyP (ShowP >> Ones)) (Just 123) - , expectPE (PresentT []) $ pl @(MaybeIn MemptyP (ShowP >> Ones)) (Nothing @String) - , expectPE (PresentT "124") $ pl @((Succ >> ShowP) ||| ShowP ) (Left @_ @() 123) - , expectPE (PresentT "True") $ pl @((Succ >> ShowP) ||| ShowP ) (Right @Int True) + , expectPE (PresentT ["1","2","3"]) $ pl @(MaybeIn MEmptyP (Ones (ShowP Id))) (Just 123) + , expectPE (PresentT []) $ pl @(MaybeIn MEmptyP (Ones (ShowP Id))) (Nothing @String) + , expectPE (PresentT "124") $ pl @((ShowP (Succ Id)) ||| ShowP Id ) (Left @_ @() 123) + , expectPE (PresentT "True") $ pl @((ShowP (Succ Id)) ||| ShowP Id) (Right @Int True) , expectPE (PresentT (123 % 4)) $ pl @(ReadP Rational) "123 % 4" , expectPE (FailT "ReadP Ratio Integer (x123 % 4) failed") $ pl @(ReadP Rational) "x123 % 4" - , expectPE (PresentT "") $ pl @('Proxy >> MemptyP) "abc" - , expectPE (PresentT ["a","b","c"]) $ pl @(MemptyT _ ||| Ones) (Right @() "abc") - , expectPE (PresentT []) $ pl @(MemptyT _ ||| Ones) (Left @_ @[String] ["ab"]) - , expectPE (PresentT ["a","b"]) $ pl @(MaybeIn MemptyP Ones) (Just @String "ab") - , expectPE (PresentT []) $ pl @(MaybeIn MemptyP Ones) (Nothing @String) - , expectPE (PresentT (True, 13)) $ pl @((IsNothing >> Not) &&& (Just' Id >> Add Id 12)) (Just 1) - , expectPE (FailT "expected Just") $ pl @((IsNothing >> Not) &&& (Just' Id >> Add Id 12)) Nothing - , expectPE (PresentT True) $ pl @(ThdL _ Id >> FstL _ Id) (1,2,(True,4)) - , expectPE (PresentT True) $ pl @(FstL _ (ThdL _ Id)) (1,2,(True,4)) + , expectPE (PresentT "") $ pl @('Proxy >> MEmptyP) "abc" + , expectPE (PresentT ["a","b","c"]) $ pl @(MEmptyT _ ||| Ones Id) (Right @() "abc") + , 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) $ 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) , expectPE (FailT "(!!) index not found") $ pl @(Id !! 4) ("asfd" :: T.Text) , expectPE (PresentT "dfsa") $ pl @ReverseL ("asfd" :: T.Text) @@ -209,29 +209,29 @@ , expectPE (PresentT Nothing) $ pl @Unsnoc ("" :: T.Text) , expectPE FalseT $ pl @IsEmpty ("failed11" :: T.Text) , expectPE TrueT $ pl @IsEmpty ("" :: T.Text) - , expectPE (PresentT 14) $ pl @(Unwrap >> Succ) (SG.Sum 13) - , expectPE (PresentT 4) $ pl @(MemptyT (SG.Sum _) >> Unwrap >> Add Id 4) () + , 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 (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 + , 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 , expectPE (PresentT 'a') $ pl @(Id !! 0) ('a','b','c') , expectPE (FailT "err") $ pl @(Id !! Failt _ "err") ('a','b','c') , expectPE (PresentT 3) $ pl @(Id !! "d") (M.fromList $ zip (map (:[]) "abcd") [0 ..]) , expectPE (PresentT 3) $ pl @(Id !! (HeadFail "failedn" "d")) (M.fromList $ zip "abcd" [0 ..]) -- had to String (instead of _) to keep this happy: ghci is fine , expectPE (PresentT ()) $ pl @(Id !! (HeadFail "failedn" "d")) (S.fromList "abcd") -- had to String (instead of _) to keep this happy: ghci is fine , expectPE (FailT "(!!) index not found") $ pl @(Id !! (HeadFail "failedn" "e")) (S.fromList "abcd") -- had to String (instead of _) to keep this happy: ghci is fine - , expectPE (PresentT 13.345) $ pl @(ExitWhen' (Re "^\\d+(?:\\.\\d+)?$" Id >> Not) >> ReadP Double) "13.345" - , expectPE (PresentT 13) $ pl @(ExitWhen' (Re "^\\d+(?:\\.\\d+)?$" Id >> Not) >> ReadP Double) "13" - , expectPE (FailT "regex failed") $ pl @(ExitWhen "regex failed" (Re "^\\d+(?:\\.\\d+)?$" Id >> Not) >> ReadP Double) "-13.4" - , expectPE (PresentT GT) $ pl @(Repeat 2 Id Succ) LT - , expectPE (FailT "Succ IO e=Prelude.Enum.Ordering.succ: bad argument") $ pl @(Repeat 30 Id Succ) LT - , expectPE (PresentT 'g') $ pl @(Repeat 6 Id Succ) 'a' - , expectPE (PresentT '[') $ pl @(Repeat 6 Id Pred) 'a' + , expectPE (PresentT 13.345) $ pl @(ExitWhen' (Re "^\\d+(?:\\.\\d+)?$" Id >> Not Id) >> ReadP Double) "13.345" + , expectPE (PresentT 13) $ pl @(ExitWhen' (Re "^\\d+(?:\\.\\d+)?$" Id >> Not Id) >> ReadP Double) "13" + , expectPE (FailT "regex failed") $ pl @(ExitWhen "regex failed" (Not (Re "^\\d+(?:\\.\\d+)?$" Id)) >> ReadP Double) "-13.4" + , expectPE (PresentT GT) $ pl @(FoldN 2 Id (Succ Id)) LT + , expectPE (FailT "Succ IO e=Prelude.Enum.Ordering.succ: bad argument") $ pl @(FoldN 30 Id (Succ Id)) LT + , expectPE (PresentT 'g') $ pl @(FoldN 6 Id (Succ Id)) 'a' + , expectPE (PresentT '[') $ pl @(FoldN 6 Id (Pred Id)) 'a' , expectPE (FailT "Regex failed to compile") $ pl @(Re "\\d{4}\\" Id) "ayx" - , expectPE (PresentT LT) $ pl @(Repeat 0 Id Succ) LT - , expectPE (PresentT LT) $ pl @(Repeat 2 Id Succ >> Repeat 2 Id Pred) LT - , expectPE (PresentT ["2","2"]) $ pl @(Map Fst (ShowP >> Rescan "." Id) >> FilterBy (Same "2") Id) 12324 - , expectPE (PresentT [LT,LT,LT,GT,EQ,LT]) $ pl @((Ones << Id << ShowP) >> Map (Fst === Snd) Pairs) 1234223 + , 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 [(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) @@ -243,20 +243,20 @@ , 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 '[Pos 1, Pos 2, Pos 3] Id) ("abcd" ) - , expectPE (PresentT []) $ pl @(Ziprc (EmptyT _) Id) "abcd" + , 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 [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])) , expectPE (PresentT [((),234)]) $ pl @(IToList _) (Just 234) , expectPE (PresentT []) $ pl @(IToList _) (Nothing @Double) - , expectPE (PresentT (-4,5)) $ pl @(DivMod Negate 7) 23 - , expectPE (PresentT (-3,-2)) $ pl @(QuotRem Negate 7) 23 - , expectPE (PresentT (True,3.4)) $ pl @(ThdL _ Id >> SndL _ Id >> FstL _ Id) (1,'a',('x',((True,3.4),999))) - , expectPE (PresentT (True,3.4)) $ pl @(FstL _ (SndL _ (ThdL _ Id))) (1,'a',('x',((True,3.4),999))) - , expectPE (PresentT 7) $ pl @(FstL _ Id) (7,999.12) - , expectPE (PresentT (M.fromList [(1,'a')])) $ pl @(MaybeIn MemptyP Id) (Just (M.fromList [(1,'a')])) - , expectPE (PresentT (M.fromList [])) $ pl @(MaybeIn MemptyP Id) (Nothing @(M.Map () ())) + , expectPE (PresentT (-4,5)) $ pl @(DivMod (Negate Id) 7) 23 + , expectPE (PresentT (-3,-2)) $ pl @(QuotRem (Negate Id) 7) 23 + , expectPE (PresentT (True,3.4)) $ pl @(Thd Id >> Snd Id >> Fst Id) (1,'a',('x',((True,3.4),999))) + , expectPE (PresentT (True,3.4)) $ pl @(Fst (Snd (Thd Id))) (1,'a',('x',((True,3.4),999))) + , expectPE (PresentT 7) $ pl @(Fst Id) (7,999.12) + , expectPE (PresentT (M.fromList [(1,'a')])) $ pl @(MaybeIn MEmptyP Id) (Just (M.fromList [(1,'a')])) + , expectPE (PresentT (M.fromList [])) $ pl @(MaybeIn MEmptyP Id) (Nothing @(M.Map () ())) , expectPE (PresentT [("1",["1"]),("2",["2"]),("3",["3"]),("4",["4"])]) $ pl @(Rescan "(\\d)+?" Id) "1234" , expectPE (PresentT [("1234",["4"])]) $ pl @(Rescan "(\\d)+" Id) "1234" , expectPE (PresentT [("1.2",["1",".2","2"]),("3.4",["3",".4","4"])]) $ pl @(Rescan "(\\d{1,3})(\\.(\\d{1,3}))+?" Id) "1.2.3.4" -- overcapturing @@ -265,34 +265,34 @@ , expectPE (PresentT ["123","2","3","5","6"]) $ pl @(Resplit "\\." Id) "123.2.3.5.6" , expectPE (PresentT [("1.2",["1","2"]),("3.4",["3","4"])]) $ pl @(Rescan "(\\d{1,3})(?:\\.(\\d{1,3}))+?" Id) "1.2.3.4" -- bizzare! , expectPE (PresentT [("1.2.3.4",["1","2","3","4"])]) $ pl @(Rescan "^(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})$" Id) "1.2.3.4" -- this is good! - , expectPE (PresentT [13,16,17]) $ pl @(Guard "err" (Len >> Gt 2) >> Map Succ Id) [12,15,16] - , expectPE (FailT "err found len=3") $ pl @(Guard (Printf "err found len=%d" Len) (Len >> Gt 5) >> Map Succ Id) [12,15,16] + , expectPE (PresentT [13,16,17]) $ pl @(Guard "err" (Len >> Gt 2) >> Map (Succ Id) Id) [12,15,16] + , expectPE (FailT "err found len=3") $ pl @(Guard (Printf "err found len=%d" Len) (Len >> Gt 5) >> Map (Succ Id) Id) [12,15,16] , expectPE (FailT "Printf (IO e=printf: bad formatting char 'd')") $ pl @(Printf "someval %d" Id) ("!23"::String) - , expectPE (PresentT [12,0,1,13,0,1,14,0,1,15,0,1,16]) $ pl @(Intercalate Fst Snd) ([0,1], [12,13,14,15,16]) - , expectPE (PresentT [12,-5,13,-5,14,-5,15,-5,16]) $ pl @(((Pure [] (Len >> Negate)) &&& Id) >> Intercalate Fst Snd) [12,13,14,15,16] - , expectPE (PresentT [13,16,17]) $ pl @(If (Len >> Gt 2) (Map Succ Id) (FailS "someval")) [12,15,16] - , expectPE (PresentT [13,16,17]) $ pl @(Guard' (Len >> Gt 2) >> Map Succ Id) [12,15,16] - , expectPE (FailT "err") $ pl @(ExitWhen "err" (Len >> Gt 2) >> Map Succ Id) [12,15,16] - , expectPE (PresentT [13]) $ pl @(ExitWhen "err" (Len >> Gt 2) >> Map Succ Id) [12] - , expectPE (FailT "err") $ pl @(Guard "err" (Len >> Gt 2) >> Map Succ Id) [12] + , expectPE (PresentT [12,0,1,13,0,1,14,0,1,15,0,1,16]) $ pl @(Intercalate (Fst Id) (Snd Id)) ([0,1], [12,13,14,15,16]) + , expectPE (PresentT [12,-5,13,-5,14,-5,15,-5,16]) $ pl @(((Pure [] (Negate Len)) &&& Id) >> Intercalate (Fst Id) (Snd Id)) [12,13,14,15,16] + , expectPE (PresentT [13,16,17]) $ pl @(If (Len >> Gt 2) (Map (Succ Id) Id) (FailS "someval")) [12,15,16] + , expectPE (PresentT [13,16,17]) $ pl @(Guard' (Len >> Gt 2) >> Map (Succ Id) Id) [12,15,16] + , expectPE (FailT "err") $ pl @(ExitWhen "err" (Len >> Gt 2) >> Map (Succ Id) Id) [12,15,16] + , expectPE (PresentT [13]) $ pl @(ExitWhen "err" (Len >> Gt 2) >> Map (Succ Id) Id) [12] + , expectPE (FailT "err") $ pl @(Guard "err" (Len >> Gt 2) >> Map (Succ Id) Id) [12] , expectPE (PresentT 12) $ pl @OneP [12] , expectPE (FailT "expected list of length 1 but found length=5") $ pl @OneP [1..5] , expectPE (FailT "expected list of length 1 but found length=0") $ pl @OneP ([] @()) , expectPE (FailT "err(8)") $ pl @(Map (If (Lt 3) 'True (Failt _ "err")) Id) [1..10] , expectPE (FailT "someval(8)") $ pl @(Map (If (Lt 3) 'True (Failt _ "someval")) Id) [1..10] -- use Guard ie Guard , expectPE (PresentT [True,True,False,False,False]) $ pl @(Map (If (Lt 3) 'True 'False) Id) [1..5] - , expectPE (PresentT ["a","b","c"]) $ pl @(MaybeIn MemptyP Ones) (Just @String "abc") - , expectPE (FailT "someval") $ pl @(Guard "someval" (Len == 2) >> (ShowP &&& Id)) ([] @Int) - , expectPE (PresentT ([2,3],"[2,3]")) $ pl @(Guard "someval" (Len == 2) >> (Id &&& ShowP)) [2,3] - , expectPE (FailT "someval") $ pl @(Guard "someval" (Len == 2) >> (ShowP &&& Id)) [2,3,4] - , expectPE (PresentT 55) $ pl @(Map (Wrap (SG.Sum _) Id) Id >> MConcat >> Unwrap) [1..10] - , expectPE (PresentT True) $ pl @(EitherIn Not Id) (Right @Bool True) - , expectPE FalseT $ pl @(EitherIn Not Id) (Left @_ @Bool True) + , expectPE (PresentT ["a","b","c"]) $ pl @(MaybeIn MEmptyP (Ones Id)) (Just @String "abc") + , expectPE (FailT "someval") $ pl @(Guard "someval" (Len == 2) >> (ShowP Id &&& Id)) ([] @Int) + , expectPE (PresentT ([2,3],"[2,3]")) $ pl @(Guard "someval" (Len == 2) >> (Id &&& ShowP Id)) [2,3] + , expectPE (FailT "someval") $ pl @(Guard "someval" (Len == 2) >> (ShowP Id &&& Id)) [2,3,4] + , expectPE (PresentT 55) $ pl @(Map (Wrap (SG.Sum _) Id) Id >> MConcat Id >> Unwrap Id) [1..10] + , expectPE (PresentT True) $ pl @(EitherIn (Not Id) Id) (Right @Bool True) + , expectPE FalseT $ pl @(EitherIn (Not Id) Id) (Left @_ @Bool True) , expectPE FalseT $ pl @(Re "^\\d+$" Id) "123\nx" , expectPE TrueT $ pl @(Re "(?m)^\\d+$" Id) "123\nx" -- (?m) anchors match beginning/end of line instead of whole string , expectPE (PresentT (Just 'x')) $ pl @(Pure Maybe Id) 'x' , expectPE (PresentT (Right @() 'x')) $ pl @(Pure (Either _) Id) 'x' - , expectPE (PresentT Nothing) $ pl @(MemptyT (Maybe ())) 'x' + , expectPE (PresentT Nothing) $ pl @(MEmptyT (Maybe ())) 'x' , expectPE (PresentT (Left @_ @() 'x')) $ pl @(Pure (Either _) Id >> Swap) 'x' , expectPE (PresentT (Left 'x')) $ pl @(Pure (Either ()) Id >> Swap) 'x' , expectPE (PresentT (SG.Sum 52)) $ pl @(STimes 4 Id) (SG.Sum 13) @@ -302,30 +302,30 @@ , expectPE FalseT $ pl @(Catch (Re "\\d+(" Id) 'False) "123" , expectPE TrueT $ pl @(Catch (Re "\\d+" Id) 'False) "123" , expectPE (PresentT 3) $ pl @(Id !! (Head' "d")) (M.fromList $ zip "abcd" [0 ..]) -- use Char1 "d" instead of "d" >> Head' - , expectPE (PresentT 10) $ pl @(Id !! MemptyT _) (Just 10) - , expectPE (FailT "(!!) index not found") $ pl @(Id !! MemptyT _) (Nothing @()) + , expectPE (PresentT 10) $ pl @(Id !! MEmptyT _) (Just 10) + , expectPE (FailT "(!!) index not found") $ pl @(Id !! MEmptyT _) (Nothing @()) , expectPE TrueT $ pl @((Len >> (Elem Id '[4,7,1] || (Mod Id 3 >> Same 0))) || (FoldMap (SG.Sum _) Id >> Gt 200)) [1..20] , expectPE FalseT $ pl @((Len >> (Elem Id '[4,7,1] || (Mod Id 3 >> Same 0))) || (FoldMap (SG.Sum _) Id >> Gt 200)) [1..19] , expectPE TrueT $ pl @((Len >> (Elem Id '[4,7,1] || (Mod Id 3 >> Same 0))) || (FoldMap (SG.Sum _) Id >> Gt 200)) [] , expectPE (PresentT (False, 210)) $ pl @((Len >> (Elem Id '[4,7,1] || (Mod Id 3 >> Same 0))) &&& FoldMap (SG.Sum _) Id) [1..20] , expectPE (PresentT 'g') $ pl @(Id !! 6) ['a'..'z'] - , expectPE (PresentT ([141,214,125,1,2,3333],(False,False))) $ pl @(Map (ReadP Int) (Resplit "\\." Id) >> '(Id, '(Len == 4, All (Between 0 255)))) "141.214.125.1.2.3333" - , expectPE (PresentT ([141,214,125,1,2,6],(False,True))) $ pl @(Map (ReadP Int) (Resplit "\\." Id) >> Id &&& ((Len == 4) &&& All (Between 0 255))) "141.214.125.1.2.6" - , expectPE (FailT "ReadP Int () failed") $ pl @(Resplit "\\." Id >> Map (ReadP Int) Id >> Id &&& ((Len >> Same 4) &&& All (Between 0 255))) "141.214.125." - , expectPE (PresentT 9) $ pl @((Wrap _ Id *** Wrap (SG.Sum _) Id) >> Sapa >> Unwrap) (4,5) + , expectPE (PresentT ([141,214,125,1,2,3333],(False,False))) $ pl @(Map (ReadP Int) (Resplit "\\." Id) >> '(Id, '(Len == 4, All (Between 0 255) Id))) "141.214.125.1.2.3333" + , expectPE (PresentT ([141,214,125,1,2,6],(False,True))) $ pl @(Map (ReadP Int) (Resplit "\\." Id) >> Id &&& ((Len == 4) &&& All (Between 0 255) Id)) "141.214.125.1.2.6" + , expectPE (FailT "ReadP Int () failed") $ pl @(Resplit "\\." Id >> Map (ReadP Int) Id >> Id &&& ((Len >> Same 4) &&& All (Between 0 255) Id)) "141.214.125." + , expectPE (PresentT 9) $ pl @((Wrap _ Id *** Wrap (SG.Sum _) Id) >> Sapa >> Unwrap Id) (4,5) , expectPE (PresentT (SG.Sum 9)) $ pl @((Wrap _ Id *** Wrap _ Id) >> Sapa) (4,5) - , expectPE (PresentT 9) $ pl @(Sapa' (SG.Sum _) >> Unwrap) (4,5) - , expectPE (PresentT "abcde") $ pl @(ScanNA Succ) (4,'a') + , expectPE (PresentT 9) $ pl @(Sapa' (SG.Sum _) >> Unwrap Id) (4,5) + , expectPE (PresentT "abcde") $ pl @(ScanNA (Succ Id)) (4,'a') , expectPE (PresentT ["abcd","bcd","cd","d",""]) $ pl @(ScanNA Tail) (4,"abcd" :: String) , expectPE (PresentT ["abcd","bcd","cd","d",""]) $ pl @(Len &&& Id >> ScanNA Tail) "abcd" , expectPE (PresentT ["abcd","bcd","cd","d",""]) $ pl @Tails ("abcd" :: String) - , expectPE (PresentT (-4,-2)) $ pl @(DivMod Fst Snd) (10,-3) - , expectPE (PresentT (-3,1)) $ pl @(QuotRem Fst Snd) (10,-3) - , expectPE (FailT "DivMod zero denominator") $ pl @(DivMod Fst Snd) (10,0) - , expectPE (PresentT 'd') $ pl @(Snd !! Fst) (3,"abcde" :: String) - , expectPE (FailT "(!!) index not found") $ pl @(Snd !! Fst) (4,[9,8]) - , expectPE (PresentT 'c') $ pl @(2 &&& Id >> Snd !! Fst) ("abcdef" :: String) - , expectPE (PresentT 'f') $ pl @((Len >> Pred) &&& Id >> Snd !! Fst) "abcdef" + , expectPE (PresentT (-4,-2)) $ pl @(DivMod (Fst Id) (Snd Id)) (10,-3) + , expectPE (PresentT (-3,1)) $ pl @(QuotRem (Fst Id) (Snd Id)) (10,-3) + , expectPE (FailT "DivMod zero denominator") $ pl @(DivMod (Fst Id) (Snd Id)) (10,0) + , expectPE (PresentT 'd') $ pl @(Snd Id !! (Fst Id)) (3,"abcde" :: String) + , expectPE (FailT "(!!) index not found") $ pl @(Snd Id !! (Fst Id)) (4,[9,8]) + , expectPE (PresentT 'c') $ pl @(2 &&& Id >> Snd Id !! (Fst Id)) ("abcdef" :: String) + , expectPE (PresentT 'f') $ pl @((Len >> (Pred Id)) &&& Id >> Snd Id !! (Fst Id)) "abcdef" , expectPE (FailT "len is bad") $ pl @Ip6 "FE80::203:Baff:FE77:326FF" , expectPE (FailT "not a hex") $ pl @Ip6 "FE80::203:Baff:GE77:326F" , expectPE (FailT "count is bad") $ pl @Ip6 "FE80::203:Baff:FE77:326F:::::" @@ -344,32 +344,33 @@ , 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 Snd) ([1..5],['a'..'z']) + , 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,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] , expectPE (PresentT [0,0,1,2,3]) $ pl @(PadL 5 0 Id) [1..3] - , expectPE (PresentT []) $ pl @(Catch (Resplit "\\d+(" Id) (Snd >> MemptyP)) "123" + , expectPE (PresentT []) $ pl @(Catch (Resplit "\\d+(" Id) (Snd Id >> MEmptyP)) "123" , expectPE (FailT "someval(8)") $ pl @(Map (Guard "someval" (Lt 3) >> 'True) Id) [1::Int ..10] - , expectPE (PresentT [True,True,True,True,True,True,True,True,True,True]) $ pl @(Map (Guard "someval" (Ge 1) >> 'True) Id) [1::Int ..10] - , expectPE (PresentT [4,5,6]) $ pl @(ScanN 2 Id Succ) 4 + , expectPE (FailT "3 < 3 | 4 < 3 | 5 < 3 | 6 < 3 | 7 < 3 | 8 < 3 | 9 < 3 | 10 < 3") $ pl @(Map (GuardSimple (Lt 3) >> 'True) Id) [1::Int ..10] + , expectPE (PresentT [True,True,True,True,True,True,True,True,True,True]) $ pl @(Map (GuardSimple (Ge 1) >> 'True) Id) [1::Int ..10] + , expectPE (PresentT [4,5,6]) $ pl @(ScanN 2 Id (Succ Id)) 4 , expectPE (PresentT [4,4,4,4,4,4]) $ pl @(ScanN 5 Id Id) 4 - , expectPE (PresentT [1,2,3,244]) $ pl @(Rescan Ip4RE Id >> OneP >> Map (ReadBaseInt 10) Snd >> Ip4guard) "1.2.3.244" - , expectPE (FailT "0-255") $ pl @(Rescan Ip4RE Id >> OneP >> Map (ReadBaseInt 10) Snd >> Ip4guard) "1.256.3.244" - , expectPE (FailT "0-255") $ pl @(Rescan "(\\d+)\\.?" Id >> ConcatMap Snd Id >> Map (ReadBaseInt 10) Id >> Ip4guard) "1.22.312.66" - , expectPE (FailT "4octets") $ pl @(Rescan "(\\d+)\\.?" Id >> ConcatMap Snd Id >> Map (ReadBaseInt 10) Id >> Ip4guard) "1.22.244.66.77" - , expectPE (PresentT [1,23,43,214]) $ pl @(Rescan "(\\d+)\\.?" Id >> ConcatMap Snd Id >> Map (ReadBaseInt 10) Id >> Ip4guard) "1.23.43.214" + , expectPE (PresentT [1,2,3,244]) $ pl @(Rescan Ip4RE Id >> OneP >> Map (ReadBaseInt 10) (Snd Id) >> Ip4guard) "1.2.3.244" + , expectPE (FailT "0-255") $ pl @(Rescan Ip4RE Id >> OneP >> Map (ReadBaseInt 10) (Snd Id) >> Ip4guard) "1.256.3.244" + , expectPE (FailT "0-255") $ pl @(Rescan "(\\d+)\\.?" Id >> ConcatMap (Snd Id) Id >> Map (ReadBaseInt 10) Id >> Ip4guard) "1.22.312.66" + , expectPE (FailT "4octets") $ pl @(Rescan "(\\d+)\\.?" Id >> ConcatMap (Snd Id) Id >> Map (ReadBaseInt 10) Id >> Ip4guard) "1.22.244.66.77" + , expectPE (PresentT [1,23,43,214]) $ pl @(Rescan "(\\d+)\\.?" Id >> ConcatMap (Snd Id) Id >> Map (ReadBaseInt 10) Id >> Ip4guard) "1.23.43.214" , expectPE (PresentT (SG.Sum 123)) $ pl @(JustP Id) (Just (SG.Sum 123)) , expectPE (PresentT (SG.Sum 0)) $ pl @(JustP Id) (Nothing @(SG.Sum _)) - , expectPE (PresentT (636 % 5)) $ pl @((ToRational 123 &&& Id) >> Fst + Snd) 4.2 - , expectPE (PresentT 127) $ pl @((123 &&& Id) >> Fst + Snd) 4 - , expectPE (PresentT 256) $ pl @(Rescan "(?i)^\\\\x([0-9a-f]{2})$" Id >> OneP >> Snd >> OneP >> ReadBaseInt 16 >> Succ) "\\xfF" - , expectPE (PresentT 256) $ pl @(Rescan "(?i)^\\\\x(.{2})$" Id >> OneP >> Snd >> OneP >> ReadBaseInt 16 >> Succ) "\\xfF" - , expectPE (PresentT (("fF",(255,"ff")),False)) $ pl @(Rescan "(?i)^\\\\x([0-9a-f]{2})$" Id >> OneP >> Snd >> OneP >> (Id &&& (ReadBaseInt 16 >> (Id &&& ShowBase 16))) >> (Id &&& ((Id *** Snd) >> Fst == Snd))) "\\xfF" - , expectPE (PresentT [1,2,4,0]) $ pl @(Do '[Succ,Id,ShowP,Ones,Map (ReadBaseInt 8) Id]) 1239 - , expectPE (FailT "invalid base 8") $ pl @(Do '[Pred,Id,ShowP,Ones,Map (ReadBaseInt 8) Id]) 1239 + , expectPE (PresentT (636 % 5)) $ pl @((ToRational 123 &&& Id) >> Fst Id + Snd Id) 4.2 + , expectPE (PresentT 127) $ pl @((123 &&& Id) >> Fst Id + Snd Id) 4 + , expectPE (PresentT 256) $ pl @(Rescan "(?i)^\\\\x([0-9a-f]{2})$" Id >> OneP >> Snd Id >> OneP >> ReadBaseInt 16 >> (Succ Id)) "\\xfF" + , expectPE (PresentT 256) $ pl @(Rescan "(?i)^\\\\x(.{2})$" Id >> OneP >> Snd Id >> OneP >> ReadBaseInt 16 >> (Succ Id)) "\\xfF" + , expectPE (PresentT (("fF",(255,"ff")),False)) $ pl @(Rescan "(?i)^\\\\x([0-9a-f]{2})$" Id >> OneP >> Snd Id >> OneP >> (Id &&& (ReadBaseInt 16 >> (Id &&& ShowBase 16))) >> (Id &&& ((Id *** Snd Id) >> Fst Id == Snd Id))) "\\xfF" + , expectPE (PresentT [1,2,4,0]) $ pl @(Do '[Succ Id,Id,ShowP Id,Ones Id,Map (ReadBaseInt 8) Id]) 1239 + , expectPE (FailT "invalid base 8") $ pl @(Do '[Pred Id,Id,ShowP Id,Ones Id,Map (ReadBaseInt 8) Id]) 1239 , expectPE (PresentT 47) $ pl @(ReadBaseInt 2) "101111" - , expectPE (PresentT [LT,EQ,GT,EQ,EQ,EQ,EQ,EQ,EQ,EQ]) $ pl @(ScanN 2 Id Succ >> PadR 10 (MemptyT Ordering) Id) LT + , expectPE (PresentT [LT,EQ,GT,EQ,EQ,EQ,EQ,EQ,EQ,EQ]) $ pl @(ScanN 2 Id (Succ Id) >> PadR 10 (MEmptyT Ordering) Id) LT , expectPE (PresentT 12) $ pl @('This Id) (This 12) , expectPE (FailT "'This found That") $ pl @('This Id) (That @() 12) , expectPE (PresentT (SG.Sum 12)) $ pl @(ThisP Id) (This @_ @() (SG.Sum 12)) @@ -378,18 +379,18 @@ , expectPE (FailT "sdf") $ pl @(ThisFail "sdf" Id) (That @() (SG.Sum 12)) , expectPE (FailT "sdf") $ pl @(ThisFail "sdf" Id) (That @Int 12) , expectPE (PresentT "this") $ pl @(TheseIn "this" "that" "these") (This @_ @() (SG.Sum 12)) - , expectPE FalseT $ pl @IsThese (That @() (SG.Sum 12)) - , expectPE TrueT $ pl @IsThese (These 1 (SG.Sum 12)) + , expectPE FalseT $ pl @(IsThese Id) (That @() (SG.Sum 12)) + , expectPE TrueT $ pl @(IsThese Id) (These 1 (SG.Sum 12)) , expectPE (PresentT ("Ab",13)) $ pl @(TheseIn (Id &&& 999) ("no value" &&& Id) Id) (These "Ab" 13) , expectPE (PresentT ("Ab",999)) $ pl @(TheseIn (Id &&& 999) ("no value" &&& Id) Id) (This "Ab") , expectPE (PresentT ("no value",13)) $ pl @(TheseIn (Id &&& 999) ("no value" &&& Id) Id) (That 13) - , expectPE (PresentT "wxydef") $ pl @(ZipThese Fst Snd >> Map (TheseIn Id Id Fst) Id) (['w'..'y'],['a'..'f']) + , expectPE (PresentT "wxydef") $ pl @(ZipThese (Fst Id) (Snd Id) >> Map (TheseIn Id Id (Fst Id)) Id) (['w'..'y'],['a'..'f']) , expectPE (PresentT [("fe",["fe"]),("b1",["b1"]),("2a",["2a"])]) $ pl @(Rescan "([[:xdigit:]]{2})" Id) "wfeb12az" -- anchored means it has to start at the beginning: can have junk on the end which we cant detect but at least we know it starts at beginning , expectPE (FailT "Regex no results") $ pl @(Rescan' '[ 'Anchored ] "([[:xdigit:]]{2})" Id) "wfeb12az" - , expectPE (PresentT [('s',1),('d',2),('f',3),('x',4),('x',5)]) $ pl @(("sdf" &&& Id) >> ZipThese Fst Snd >> Map (TheseIn (Id &&& 0) ((Head' "x") &&& Id) Id) Id) [1..5] + , expectPE (PresentT [('s',1),('d',2),('f',3),('x',4),('x',5)]) $ pl @(("sdf" &&& Id) >> ZipThese (Fst Id) (Snd Id) >> Map (TheseIn (Id &&& 0) ((Head' "x") &&& Id) Id) Id) [1..5] , expectPE (PresentT "abc") $ pl @"abc" () - , expectPE FalseT $ pl @('True >> Not) () + , expectPE FalseT $ pl @(Not 'True) () , expectPE TrueT $ pl @'True () , expectPE FalseT $ pl @'False () , expectPE (PresentT LT) $ pl @'LT () @@ -399,14 +400,14 @@ , expectPE (PresentT 6) $ pl @(Do '[4,5,6]) () , expectPE (PresentT "hhhhh") $ pl @(Do '["abc", "Def", "ggg", "hhhhh"]) () , expectPE (PresentT GT) $ pl @(Do '[ 'LT, 'EQ, 'GT ]) () - , expectPE (PresentT (-3 % 1)) $ pl @(Do '[Rat 'True 4 4,Pos 22,NegR 12 4]) () + , 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 [31,11,1999]) $ pl @(Rescan DdmmyyyyRE Id >> OneP >> Map (ReadBaseInt 10) Snd >> Ddmmyyyyval) "31-11-1999" + , 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(1) 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(0) 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 (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 (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" @@ -417,10 +418,10 @@ , 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 (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 &&& (Pred >> ShowP >> Ones))) (Left 123) - , expectPE (PresentT [1,2,3,4]) $ pl @(Guards (ToGuardsT (Printf2 "guard(%d) %d is out of range") (RepeatT 4 (Between 0 255)))) [1,2,3,4::Int] - , expectPE (FailT "Guards: data elements(5) /= predicates(4)") $ pl @(Guards (ToGuardsT (Printf2 "guard(%d) %d is out of range") (RepeatT 4 (Between 0 255)))) [1,2,3,4,5::Int] - , expectPE (FailT "Guards: data elements(3) /= predicates(4)") $ pl @(Guards (ToGuardsT (Printf2 "guard(%d) %d is out of range") (RepeatT 4 (Between 0 255)))) [1,2,3::Int] + , 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] + , expectPE (FailT "Guards: data elements(5) /= predicates(4)") $ pl @(GuardsN (Printf2 "guard(%d) %d is out of range") 4 (Between 0 255)) [1,2,3,4,5::Int] + , expectPE (FailT "Guards: data elements(3) /= predicates(4)") $ pl @(GuardsN (Printf2 "guard(%d) %d is out of range") 4 (Between 0 255)) [1,2,3::Int] , expectPE (PresentT (read "1999-01-01 12:12:12 Utc")) $ pl @(ParseTimeP UTCTime "%F %T" Id) "1999-01-01 12:12:12" , expectPE (PresentT 123) $ pl @(JustDef 0 Id) (Just 123) , expectPE (PresentT 0) $ pl @(JustDef 0 Id) Nothing @@ -435,21 +436,21 @@ , expectPE (PresentT ("xyz", True)) $ pl @(TheseDef '("xyz",'True) Id) (That False) , expectPE (PresentT ("abc", False)) $ pl @(TheseDef '("xyz",'True) Id) (These "abc" False) , expectPE (PresentT 3) $ pl @(Id !! Char1 "d") (M.fromList $ zip "abcd" [0 ..]) - , expectPE (PresentT (12, False)) $ pl @('These Id Not) (These 12 True) + , expectPE (PresentT (12, False)) $ pl @('These Id (Not Id)) (These 12 True) , expectPE (PresentT (SG.Any True)) $ pl @(Coerce SG.Any) True , expectPE (PresentT True) $ pl @(Coerce Bool) (SG.Any True) - , expectPE (PresentT (3, SG.Any True)) $ pl @(Id !! (FromStringP _ "d") &&& (Map (Snd >> Gt 3 >> Coerce SG.Any) (IToList _) >> MConcat ) ) (M.fromList $ zip (map T.singleton "abcdefgh") [0 ..]) - , expectPE (PresentT (3, True)) $ pl @(Id !! (FromStringP _ "d") &&& (Map (Snd >> Gt 3 >> Wrap SG.Any Id) (IToList _) >> MConcat >> Unwrap) ) (M.fromList $ zip (map T.singleton "abcdefgh") [0 ..]) + , expectPE (PresentT (3, SG.Any True)) $ pl @(Id !! (FromStringP _ "d") &&& (Map (Snd Id >> Gt 3 >> Coerce SG.Any) (IToList _) >> MConcat Id) ) (M.fromList $ zip (map T.singleton "abcdefgh") [0 ..]) + , expectPE (PresentT (3, True)) $ pl @(Id !! (FromStringP _ "d") &&& (Map (Snd Id >> Gt 3 >> Wrap SG.Any Id) (IToList _) >> MConcat Id >> Unwrap Id) ) (M.fromList $ zip (map T.singleton "abcdefgh") [0 ..]) --- have to wrap with W cos different kinds --- , expectPE TrueT $ pl @(Do '[ W ('PresentT I), W 'FalseT, Not]) False +-- , expectPE TrueT $ pl @(Do '[ W ('PresentT I), W 'FalseT, Not Id]) False -- , expectPE FalseT $ pl @(Do '[ W ('PresentT Id), W 'FalseT ]) True -- have to wrap them cos BoolT a vs BoolT Bool ie different types --- , expectPE TrueT $ pl @('PresentT I >> 'FalseT >> Not) False +-- , expectPE TrueT $ pl @('PresentT I >> Not 'FalseT) False -- IxL "d" doesnt work cos is Text not String , expectPE (PresentT 3) $ pl @(Id !! FromStringP _ "d") (M.fromList $ zip (map T.singleton "abcd") [0 ..]) -- use Fromstring , 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 >> Guard "checkdigit fail" Luhn) "79927398713" - , expectPE (FailT "checkdigit fail") $ pl @(Map (ReadP Int) Ones >> Guard "checkdigit fail" Luhn) "79927398714" + , 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" @@ -462,71 +463,71 @@ , expectPE (FailT "expected 71 mod 10 = 0 but found 1") $ pl @(Luhn' 11) "79927398714" -- works but way to difficult: use Guard to do all the work --- >pl @(((Rescan "([[:xdigit:]])" >> Map Snd >> (Id &&& Len)) &&& Len) >> Guard "notallmatched" ((Snd *** Id) >> Fst == Snd)) "134F" +-- >pl @(((Rescan "([[:xdigit:]])" >> Map (Snd Id) >> (Id &&& Len)) &&& Len) >> Guard "notallmatched" ((Snd Id *** Id) >> Fst Id == Snd Id)) "134F" -- have to check the length of the match vs input to see that are the same - , expectPE (PresentT [1,3,4,15]) $ pl @(((Rescan "([[:xdigit:]])" Id >> Map (Snd >> OneP >> ReadBase Int 16) Id) &&& Id) >> Guard "notallmatched" ((Len *** Len) >> Fst == Snd) >> Fst) "134F" - , expectPE (FailT "notallmatched") $ pl @(((Rescan "([[:xdigit:]])" Id >> Map (Snd >> OneP >> ReadBase Int 16) Id) &&& Id) >> Guard "notallmatched" ((Len *** Len) >> Fst == Snd) >> Fst) "134g" + , expectPE (PresentT [1,3,4,15]) $ pl @(((Rescan "([[:xdigit:]])" Id >> Map (Snd Id >> OneP >> ReadBase Int 16) Id) &&& Id) >> Guard "notallmatched" ((Len *** Len) >> Fst Id == Snd Id) >> Fst Id) "134F" + , expectPE (FailT "notallmatched") $ pl @(((Rescan "([[:xdigit:]])" Id >> Map (Snd Id >> OneP >> ReadBase Int 16) Id) &&& Id) >> Guard "notallmatched" ((Len *** Len) >> Fst Id == Snd Id) >> Fst Id) "134g" , expectPE (PresentT True) $ pl @(FoldMap SG.Any Id) [False,False,True,False] , expectPE (PresentT False) $ pl @(FoldMap SG.All Id) [False,False,True,False] - , expectPE TrueT $ pl @(Map (ReadP _) Ones >> Luhn) "12345678903" - , expectPE FalseT $ pl @(Map (ReadP _) Ones >> Luhn) "12345678904" + , expectPE TrueT $ pl @(Map (ReadP _) (Ones Id) >> Luhn Id) "12345678903" + , expectPE FalseT $ pl @(Map (ReadP _) (Ones Id) >> Luhn Id) "12345678904" , expectPE (FailT "incorrect number of digits found 10 but expected 11 in [1234567890]") $ pl @(Luhn' 11) "1234567890" , expectPE (PresentT ([1,2],[3,4,5,6,7,8])) $ pl @(Break (If (Gt 2) 'True (If (Gt 4) (Failt _ "ASfd") 'False)) Id) [1..8] , expectPE (PresentT ([1,2],[3,4,5,6,7,8])) $ pl @(Break (Case 'False '[Gt 2,Gt 4] '[ W 'True, Failt _ "ASfd"] Id) Id) [1..8] -- case version , expectPE (FailT "ASfd") $ pl @(Break (If (Gt 2) (Failt _ "ASfd") 'False) Id) [1..8] - , expectPE (PresentT ([(1,False),(2,False),(3,False)],[(4,True),(5,True),(6,False)])) $ pl @(Break Snd Id) (zip [1..] [False,False,False,True,True,False]) - , expectPE (PresentT ([(1,False),(2,False),(3,False),(4,False)],[])) $ pl @(Break Snd Id) (zip [1..] [False,False,False,False]) - , expectPE (PresentT ([],[(1,True),(2,True),(3,True),(4,True)])) $ pl @(Break Snd Id) (zip [1..] [True,True,True,True]) + , expectPE (PresentT ([(1,False),(2,False),(3,False)],[(4,True),(5,True),(6,False)])) $ pl @(Break (Snd Id) Id) (zip [1..] [False,False,False,True,True,False]) + , expectPE (PresentT ([(1,False),(2,False),(3,False),(4,False)],[])) $ pl @(Break (Snd Id) Id) (zip [1..] [False,False,False,False]) + , expectPE (PresentT ([],[(1,True),(2,True),(3,True),(4,True)])) $ pl @(Break (Snd Id) Id) (zip [1..] [True,True,True,True]) , (@?=) (Just "abc") ((_FailT # "abc") ^? _FailT) , (@?=) (Just ()) ((_TrueT # ()) ^? _TrueT) , (@?=) (Just ()) ((_FalseT # ()) ^? _FalseT) , (@?=) (Just 'x') ((_PresentT # 'x') ^? _PresentT) - , expectPE (PresentT (111,'b')) $ pl @('(123,Char1 "c") >> (Sub Id 12 *** Pred)) () - , expectPE (PresentT (SG.Min 19)) $ pl @((FromInteger _ 12 &&& Id) >> Fst + Snd) (SG.Min 7) + , expectPE (PresentT (111,'b')) $ pl @('(123,Char1 "c") >> (Sub 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 , expectPE (PresentT (4,(5,(6,(7,()))))) $ pl @(TupleI '[4,5,6,7]) 99 - , expectPE (PresentT ("ss",(4,(SG.Min 9223372036854775807,())))) $ pl @(TupleI '[W "ss",W 4,MemptyT (SG.Min Int)]) 99 - , expectPE (PresentT ("ss",(4,(SG.Sum 0,())))) $ pl @(TupleI '[W "ss",W 4,MemptyT (SG.Sum _)]) 99 - , expectPE (PresentT "xyxyxyxy") $ pl @(STimes Fst Snd) (4,['x','y']) - , expectPE (PresentT (concat (replicate 16 "abc"))) $ pl @(Repeat 4 Id ((Id &&& Id) >> Sapa)) "abc" - , expectPE (PresentT (concat (replicate 4 "abc"))) $ pl @(STimes Fst Snd) (4,"abc") + , expectPE (PresentT ("ss",(4,(SG.Min 9223372036854775807,())))) $ pl @(TupleI '[W "ss",W 4,MEmptyT (SG.Min Int)]) 99 + , expectPE (PresentT ("ss",(4,(SG.Sum 0,())))) $ pl @(TupleI '[W "ss",W 4,MEmptyT (SG.Sum _)]) 99 + , expectPE (PresentT "xyxyxyxy") $ pl @(STimes (Fst Id) (Snd Id)) (4,['x','y']) + , expectPE (PresentT (concat (replicate 16 "abc"))) $ pl @(FoldN 4 Id ((Id &&& Id) >> Sapa)) "abc" + , 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 >> Map (ToEnum Char) Id) ("abcd" :: String) - , expectPE (FailT "ToEnum IO e=Prelude.Enum.Ordering.toEnum: bad argument(2)") $ pl @(Map FromEnum Id >> Map (Sub Id 97 >> ToEnum Ordering) Id) ("abcde" :: String) - , expectPE (PresentT ([2,3,5,7,11,13], [1,4,6,8,9,10,12,14,15])) $ pl @(Partition Prime Id) [1..15] + , 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 (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 (Neg 999) >> Wrap (MM.First _) Id)) Id >> Map Sapa Id >> Map (Just' Unwrap) Id) [Nothing,Just 10,Just 20,Nothing,Just 30] + , 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] , expectPE (PresentT 12) $ pl @(MaybeIn 99 Id) (Just 12) , expectPE (PresentT 12) $ pl @(JustDef 99 Id) (Just 12) , expectPE (PresentT 99) $ pl @(MaybeIn 99 Id) Nothing , expectPE (PresentT 99) $ pl @(JustDef 99 Id) Nothing - , expectPE (PresentT (-99)) $ pl @(MaybeIn (Neg 99) Id) Nothing - , expectPE (PresentT (-99)) $ pl @(JustDef (Neg 99) Id) Nothing - , expectPE (PresentT [1,2,3,4,12]) $ pl @(Para (RepeatT 5 (Guard "0-255" (Between 0 255)))) [1,2,3,4,12] - , expectPE (FailT "0-255") $ pl @(Para (RepeatT 5 (Guard "0-255" (Between 0 255)))) [1,2,3,400,12] - , expectPE (PresentT ["141","021","003","000"]) $ pl @(Para (RepeatT 4 (Printf "%03d" Id))) [141,21,3,0::Int] - , expect3 (Right (unsafeRefined3 [1,2,3,4] "001.002.003.004")) $ eval3 @Ip4A @Ip4B @(Para (RepeatT 4 (Printf "%03d" Id)) >> Concat (Intercalate '["."] Id)) ol "1.2.3.4" + , expectPE (PresentT (-99)) $ pl @(MaybeIn (99 %- 1 ) Id) Nothing + , expectPE (PresentT (-99)) $ pl @(JustDef (99 %- 1 ) Id) Nothing + , expectPE (PresentT [1,2,3,4,12]) $ pl @(ParaN 5 (Guard "0-255" (Between 0 255))) [1,2,3,4,12] + , expectPE (FailT "0-255") $ pl @(ParaN 5 (Guard "0-255" (Between 0 255))) [1,2,3,400,12] + , expectPE (PresentT ["141","021","003","000"]) $ pl @(ParaN 4 (Printf "%03d" Id)) [141,21,3,0::Int] + , expect3 (Right (unsafeRefined3 [1,2,3,4] "001.002.003.004")) $ eval3 @Ip4A @Ip4B @(ParaN 4 (Printf "%03d" Id) >> Concat (Intercalate '["."] Id)) ol "1.2.3.4" , expect3 (Right (unsafeRefined3 [1,2,3,4] "abc__002__3__zzz")) $ eval3 @Ip4A @Ip4B @(Para '[W "abc",Printf "%03d" Id,Printf "%d" Id,W "zzz"] >> Concat (Intercalate '["__"] Id)) ol "1.2.3.4" - , expect3 (Right (unsafeRefined [1,2,3,4], "001.002.003.004")) $ eval3PX (Proxy @'(Ip4A, Ip4B, Para (RepeatT 4 (Printf "%03d" Id)) >> Concat (Intercalate '["."] Id), _)) ol "1.2.3.4" - , expect3 (Right (unsafeRefined [1,2,3,4], "001.002.003.004")) $ eval3PX (mkProxy3 @Ip4A @Ip4B @(Para (RepeatT 4 (Printf "%03d" Id)) >> Concat (Intercalate '["."] Id))) ol "1.2.3.4" + , expect3 (Right (unsafeRefined [1,2,3,4], "001.002.003.004")) $ eval3PX (Proxy @'(Ip4A, Ip4B, ParaN 4 (Printf "%03d" Id) >> Concat (Intercalate '["."] Id), _)) ol "1.2.3.4" + , expect3 (Right (unsafeRefined [1,2,3,4], "001.002.003.004")) $ eval3PX (mkProxy3 @Ip4A @Ip4B @(ParaN 4 (Printf "%03d" Id) >> Concat (Intercalate '["."] Id))) ol "1.2.3.4" -- keep the original value - , expect3 (Right $ unsafeRefined3 ("1.2.3.4", [1,2,3,4]) "001.002.003.004") $ eval3 @(Id &&& Ip4A) @(Snd >> Ip4B) @(Snd >> Para (RepeatT 4 (Printf "%03d" Id)) >> Concat (Intercalate '["."] Id)) ol "1.2.3.4" + , expect3 (Right $ unsafeRefined3 ("1.2.3.4", [1,2,3,4]) "001.002.003.004") $ eval3 @(Id &&& Ip4A) @(Snd Id >> Ip4B) @(Snd Id >> ParaN 4 (Printf "%03d" Id) >> Concat (Intercalate '["."] Id)) ol "1.2.3.4" -- need to fill in the types for both even in ghci , expectPE (PresentT (Just (SG.Sum 10))) $ pl @(Coerce2 (SG.Sum Int)) (Just (10 :: Int)) - , expectPE (PresentT (Just (SG.Sum 0))) $ pl @(MemptyT2 (SG.Sum _)) (Just ()) + , expectPE (PresentT (Just (SG.Sum 0))) $ pl @(MEmptyT2 (SG.Sum _)) (Just ()) , expectPE (PresentT 13) $ pl @(FoldMap (SG.Sum _) Id) (Just 13) , expectPE (PresentT 55) $ pl @(FoldMap (SG.Sum _) Id) [1..10] , 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) [1..5] + , 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 (Just [1,2,3,4,5])) $ pl @(Traverse (If (Gt 0) (Pure Maybe Id) (EmptyT Maybe)) 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] @@ -534,11 +535,11 @@ , 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) , expectPE (PresentT (Left 123)) $ pl @(Pure (Either String) Id >> Swap) 123 - , expectPE (PresentT [13,2,1999]) $ pl @(Rescan DdmmyyyyRE Id >> OneP >> Map (ReadP Int) Snd) "13-02-1999" - , expectPE (PresentT [3,2,1999]) $ pl @(Rescan DdmmyyyyRE Id >> OneP >> Map (ReadP Int) Snd >> Ddmmyyyyval) "03-02-1999" - , expectPE (FailT "guard(1) month 13 is out of range") $ pl @(Rescan DdmmyyyyRE Id >> OneP >> Map (ReadP Int) Snd >> Ddmmyyyyval) "12-13-1999" + , expectPE (PresentT [13,2,1999]) $ pl @(Rescan DdmmyyyyRE Id >> OneP >> Map (ReadP Int) (Snd Id)) "13-02-1999" + , expectPE (PresentT [3,2,1999]) $ pl @(Rescan DdmmyyyyRE Id >> OneP >> Map (ReadP Int) (Snd Id) >> Ddmmyyyyval) "03-02-1999" + , expectPE (FailT "guard(2) month 13 is out of range") $ pl @(Rescan DdmmyyyyRE Id >> OneP >> Map (ReadP Int) (Snd Id) >> Ddmmyyyyval) "12-13-1999" , expectPE (PresentT [[1],[2,3,4],[5,6,7,8],[9,10,11,12]]) $ pl @(SplitAts '[1,3,4] Id) [1..12] - , expectPE (PresentT [[1,2,3],[4]]) $ pl @(SplitAts '[3,1,1,1] Id >> FilterBy (Null >> Not) Id) [1..4] + , expectPE (PresentT [[1,2,3],[4]]) $ pl @(SplitAts '[3,1,1,1] Id >> FilterBy (Not Null) Id) [1..4] , expectPE (PresentT 1) $ pl @(Msg (Printf "digits=%d" Len) (Head' Id)) [1..4] , expectPE (PresentT 10) $ pl @(Luhn' 4) "1230" , expectPE (FailT "expected 14 mod 10 = 0 but found 4") $ pl @(Luhn' 4) "1234" @@ -555,38 +556,38 @@ , expectPE FalseT $ pl @(IsPrefix "ab" Id) "xyzbaw" , expectPE TrueT $ pl @(IsSuffix "bw" Id) "xyzabw" , expectPE FalseT $ pl @(IsSuffix "bw" Id) "xyzbaw" - , expectPE TrueT $ pl @(IsInfix Fst Snd) ("ab","xyzabw") - , expectPE (PresentT [1 % 1,(-3) % 2,(-3) % 1]) $ pl @'[Pos 1,NegR 3 2,Neg 3] () + , expectPE TrueT $ pl @(IsInfix (Fst Id) (Snd Id)) ("ab","xyzabw") + , 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 @(Do (RepeatT 4 (Add Id 4))) 1 - , expectPE (PresentT 24) $ pl @((Id <> Id) >> Unwrap) (SG.Sum 12) - , expectPE (PresentT "abcdef") $ pl @(Fst <> (Snd >> Fst)) ("abc",("def",12)) + , expectPE (PresentT 17) $ pl @(DoN 4 (Add 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 (Last' Snd)) (10,[12,13]) - , expectPE (PresentT (-1,12)) $ pl @(DivMod (Sub 9 Fst) (Last' Snd)) (10,[12,13]) + , 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 [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(1) err 002") $ pl @(Guards (ToGuardsT (Printf2 "guard(%d) err %03d") '[ W 'True, Ge 12, W 'False, Lt 2 ])) [1,2,-99,-999] + , 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 TrueT $ pl @(Fst /= Snd) ("ab","xyzabw") - , expectPE FalseT $ pl @(Fst == Snd) ("ab","xyzabw") - , expectPE (PresentT 157) $ pl @(Fst * (Snd >> Fst) + (Snd >> Snd) `Div` 2) (12,(13,3)) - , expectPE TrueT $ pl @(Fst >= Snd || Snd > 23 || NegR 12 5 <= ToRational Fst) (12,13) - , expectPE (PresentT LT) $ pl @(Fst === Snd) (3,12) - , expectPE TrueT $ pl @(Fst ==? Snd) ("aBc","AbC") - , expectPE (PresentT EQ) $ pl @(Fst ===? Snd) ("aBc","AbC") - , expectPE FalseT $ pl @(Fst == Snd) ("aBc","AbC") - , expectPE (PresentT GT) $ pl @(Fst === Snd) ("aBc","AbC") - , expectPE (PresentT LT) $ pl @(Snd === Fst) ("aBc","AbC") - , expectPE TrueT $ pl @(Fst ==? Snd && Fst == Snd) ("Abc","Abc") - , expectPE (PresentT (EQ,EQ)) $ pl @(Fst ===? Snd &&& Fst === Snd) ("abc","abc") + , 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 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 "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]] @@ -595,30 +596,30 @@ , 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 >> Ones)) 3 - , expectPE (FailT "failing with 19") $ pl @(If (Gt 4) (Fail (T _) (Printf "failing with %d" Id)) (Id * 7 >> ShowP >> Ones)) 19 - , expectPE (PresentT 31) $ pl @(Do (RepeatT 4 (Id + 7))) 3 - , expectPE (PresentT 9) $ pl @(Do (RepeatT 4 9)) () + , 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 (PresentT 31) $ pl @(DoN 4 (Id + 7)) 3 + , expectPE (PresentT 9) $ pl @(DoN 4 9) () , expectPE (PresentT 3) $ pl @(Do '[1,2,3]) () - , expectPE (PresentT "xy") $ pl @(Do (RepeatT 4 "xy")) 3 - , expectPE (PresentT ["xy","xy","xy","xy"]) $ pl @(RepeatT 4 "xy") 3 + , expectPE (PresentT "xy") $ pl @(DoN 4 "xy") 3 + , expectPE (PresentT ["xy","xy","xy","xy"]) $ pl @(Repeat 4 "xy") 3 , expectPE (PresentT (Proxy @'["xy","xy","xy","xy"])) $ pl @(Proxy (RepeatT 4 "xy")) 3 , expectPE (PresentT (This @_ @() 'x')) $ pl @(MkThis () Id) 'x' - , expectPE (PresentT (This @_ @() 'x')) $ pl @(MkThis () Fst) ('x',True) + , expectPE (PresentT (This @_ @() 'x')) $ pl @(MkThis () (Fst Id)) ('x',True) , expectPE (PresentT (That 'x')) $ pl @(MkThat () Id) 'x' , expectPE (PresentT (These 'x' True)) $ pl @(MkThese Id 'True) 'x' , expectPE (PresentT 123) $ pl @(MaybeIn 123 Id) (Nothing @Int) , expectPE (PresentT 9) $ pl @(MaybeIn 123 Id) (Just 9) , expectPE (PresentT [1,2,3]) $ pl @(Just' Id) (Just [1,2,3]) , expectPE (FailT "expected Just") $ pl @(Just' Id) (Nothing @[Int]) - , expectPE (PresentT (66788,26232)) $ pl @(Last' Id >> Id * 123 >> Dup >> (Pred *** (ShowP >> Rescan "(\\d{2})" Id >> Concat (ConcatMap Snd Id) >> ReadBase Int 16))) [12,13,543::Int] + , expectPE (PresentT (66788,26232)) $ pl @(Last' Id >> Id * 123 >> Dup >> (Pred Id *** (ShowP Id >> Rescan "(\\d{2})" Id >> Concat (ConcatMap (Snd Id) Id) >> ReadBase Int 16))) [12,13,543::Int] , expectPE (PresentT "d=009 s=ab") $ pl @(Printfn "d=%03d s=%s" Id) (9::Int,("ab"::String,())) , expectPE (PresentT "d=009 s=ab c=x f=1.54") $ pl @(Printfn "d=%03d s=%s c=%c f=%4.2f" Id) (9::Int,("ab"::String,('x',(1.54::Float,())))) , expectPE (FailT "Printfn(4)(IO e=printf: formatting string ended prematurely)") $ pl @(Printfn "d=%03d s=%s" Id) (9::Int,("ab"::String,('x',(1.54::Float,())))) , expectPE (PresentT "lhs = 123 rhs = asdf c=120") $ pl @(Printf3 "lhs = %d rhs = %s c=%d") (123::Int,("asdf"::String,'x')) - , expectPE (PresentT (1,('x',(True,())))) $ pl @(FstL Int Id &&& SndL Char Id &&& ThdL Bool Id &&& ()) (1,'x',True) - , expectPE (PresentT (1,('x',(True,())))) $ pl @(FstL _ Id &&& SndL _ Id &&& ThdL _ Id &&& ()) (1,'x',True) - , expectPE (PresentT (1,(1.4,("aaa",())))) $ pl @(FstL _ Id &&& SndL _ Id &&& ThdL _ Id &&& ()) (1,1.4,"aaa") + , expectPE (PresentT (1,('x',(True,())))) $ pl @(Fst Id &&& Snd Id &&& Thd Id &&& ()) (1,'x',True) + , expectPE (PresentT (1,('x',(True,())))) $ pl @(Fst Id &&& Snd Id &&& Thd Id &&& ()) (1,'x',True) + , expectPE (PresentT (1,(1.4,("aaa",())))) $ pl @(Fst Id &&& Snd Id &&& Thd Id &&& ()) (1,1.4,"aaa") , (@?=) ("xx",(True,('x',(1,())))) (reverseTupleC (1,('x',(True,("xx",()))))) , expectPE (PresentT "hello d=12 z someval") $ pl @(TupleI '[W 12, Char1 "z", W "someval"] >> Printfn "hello d=%d %c %s" Id) () , expectPE (PresentT "ipaddress 001.002.003.004") $ pl @(TupleI '[1,2,3,4] >> Printfn "ipaddress %03d.%03d.%03d.%03d" Id) () @@ -640,28 +641,28 @@ , expectPE (PresentT [(1,2),(2,3),(3,4)]) $ pl @Pairs [1,2,3,4] , expectPE (PresentT "1 2 3 004") $ pl @(PrintfntLax 4 "%d %4d %-d %03d") [1..10::Int] , expectPE (PresentT "2019-08-17") $ pl @(FormatTimeP "%Y-%m-%d" Id) (read "2019-08-17" :: Day) - , expectPE (PresentT (20,20)) $ pl @(Dup << Fst * Snd) (4,5) - , expectPE (PresentT (20,20)) $ pl @(Fst * Snd >> Dup) (4,5) - , expectPE (PresentT (These "xxx" 4)) $ pl @(Fst <$ Snd) (4,These "xxx" 'a') - , expectPE (PresentT (This 'a')) $ pl @(Fst <$ Snd) (4,This @_ @String 'a') - , expectPE (PresentT (Just 4)) $ pl @(Fst <$ Snd) (4,Just 'a') - , expectPE (PresentT Nothing) $ pl @(Fst <$ Snd) (4,Nothing @Int) - , expectPE (PresentT (Just 4)) $ pl @(Fst <* Snd) (Just 4,Just 'a') - , expectPE (PresentT (Just 'a')) $ pl @(Fst *> Snd) (Just 4,Just 'a') + , expectPE (PresentT (20,20)) $ pl @(Dup << Fst Id * Snd Id) (4,5) + , expectPE (PresentT (20,20)) $ pl @(Fst Id * Snd Id >> Dup) (4,5) + , expectPE (PresentT (These "xxx" 4)) $ pl @(Fst Id <$ Snd Id) (4,These "xxx" 'a') + , expectPE (PresentT (This 'a')) $ pl @(Fst Id <$ Snd Id) (4,This @_ @String 'a') + , expectPE (PresentT (Just 4)) $ pl @(Fst Id <$ Snd Id) (4,Just 'a') + , expectPE (PresentT Nothing) $ pl @(Fst Id <$ Snd Id) (4,Nothing @Int) + , expectPE (PresentT (Just 4)) $ pl @(Fst Id <* Snd Id) (Just 4,Just 'a') + , expectPE (PresentT (Just 'a')) $ pl @(Fst Id *> Snd Id) (Just 4,Just 'a') , expectPE (PresentT ('x',('x',"someval"))) $ pl @Duplicate ('x',"someval") , expectPE (PresentT "someval") $ pl @Extract ('x',"someval") - , expectPE (PresentT (Just "cdef")) $ pl @(Fst <|> Snd) (Just "cdef",Just "ab") - , expectPE (PresentT "cdefab") $ pl @(Fst <|> Snd) ("cdef","ab"::String) + , expectPE (PresentT (Just "cdef")) $ pl @(Fst Id <|> Snd Id) (Just "cdef",Just "ab") + , expectPE (PresentT "cdefab") $ pl @(Fst Id <|> Snd Id) ("cdef","ab"::String) , expectPE (PresentT (9,"abc")) $ pl @(I $ 9 $ "abc") (,) , expectPE (PresentT ("abc",9)) $ pl @(9 & "abc" & I) (,) - , expectPE (PresentT "28") $ pl @(Fst $ Snd) (show . (7*),4) - , expectPE (PresentT (12,"12")) $ pl @(Fst $ Snd $ (Snd >> ShowP)) ((,),12) - , expectPE (PresentT (Just (This [1,2,3,4]))) $ pl @(ZipTheseF Fst Snd) (Just [1..4],Nothing @()) - , expectPE (PresentT [These 1 'a',These 2 'b',These 3 'c',This 4]) $ pl @(ZipTheseF Fst Snd) ([1..4],['a'..'c']) + , expectPE (PresentT "28") $ pl @(Fst Id $ Snd Id) (show . (7*),4) + , expectPE (PresentT (12,"12")) $ pl @(Fst Id $ (Snd Id) $ (Snd Id >> ShowP Id)) ((,),12) + , expectPE (PresentT (Just (This [1,2,3,4]))) $ pl @(ZipTheseF (Fst Id) (Snd Id)) (Just [1..4],Nothing @()) + , expectPE (PresentT [These 1 'a',These 2 'b',These 3 'c',This 4]) $ pl @(ZipTheseF (Fst Id) (Snd Id)) ([1..4],['a'..'c']) , expectPE (PresentT [True,True,True,True]) $ pl @('True <$ Id) [1..4] , expectPE (PresentT (Compose (Just "aaaa"))) $ pl @(Char1 "ab" <$ Id) (Compose $ Just [1..4]) - , expectPE (PresentT (4,("aa",'x'))) $ pl @'(4,'(Fst,Snd)) ("aa",'x') - , expectPE (PresentT (4,"aa",'x')) $ pl @'(4,Fst,Snd) ("aa",'x') + , expectPE (PresentT (4,("aa",'x'))) $ pl @'(4,'(Fst Id,Snd Id)) ("aa",'x') + , expectPE (PresentT (4,"aa",'x')) $ pl @'(4,(Fst Id),Snd Id) ("aa",'x') , expectPE (PresentT (Just [10])) $ pl @(Pure2 []) (Just 10) , expectPE (PresentT "hello") $ pl @Extract (10,"hello") , expectPE (PresentT (M.fromList [(4,"x"),(5,"dd")])) $ pl @(FromList (M.Map _ _)) [(4,"x"),(5,"dd")] @@ -670,40 +671,40 @@ -- , 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 >> IsNothing) (Fst >> ShowP >> Fail I (Printf "index(%s) not found" Id) >> 'False) (Snd >> 'Just Id)) [('x',True),('y',False)] - , expectPE (PresentT True) $ pl @(FromList (M.Map _ _) >> (Char1 "z" &&& Lookup Id (Char1 "x")) >> If (Snd >> IsNothing) (Fst >> ShowP >> Fail I (Printf "index(%s) not found" Id) >> 'False) (Snd >> 'Just Id)) [('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)] + , expectPE (PresentT True) $ pl @(FromList (M.Map _ _) >> (Char1 "z" &&& Lookup Id (Char1 "x")) >> If (Snd Id >> IsNothing) (ShowP (Fst Id) >> Fail I (Printf "index(%s) not found" Id) >> 'False) (Snd Id >> 'Just Id)) [('x',True),('y',False)] , 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) "abcdefghi" + , 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 (Null >> Not) (SplitAt 2 Id)) Id) [1..5] - , expectPE (PresentT [99,1,2,3,4,5]) $ pl @(FlipT (:+) Fst Snd) ([1..5],99) - , expectPE (PresentT [99,1,2,3,4,5]) $ pl @(Fst :+ Snd) (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 :+ Fst) Fst Snd) ([99],[1..5]) - , expectPE (PresentT [[99]]) $ pl @(Scanl (Snd :+ Fst) Fst Snd) ([99],[]) + , expectPE (PresentT [[1,2],[3,4],[5]]) $ pl @(Unfoldr (MaybeB (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 (Null >> Not) (Guard "yy" (Len < 3) >> 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 (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 :+ Snd) (4,[1,2,3]) - , expectPE (PresentT [1,2,3,4]) $ pl @(Snd +: Fst) (4,[1,2,3]) + , expectPE (PresentT [4,1,2,3]) $ pl @(Fst Id :+ Snd Id) (4,[1,2,3]) + , expectPE (PresentT [1,2,3,4]) $ pl @(Snd Id +: Fst Id) (4,[1,2,3]) , expectPE (PresentT "abcx") $ pl @("abc" +: Char1 "x") () - , expectPE (PresentT "abcx") $ pl @(Fst +: Snd) ("abc" :: T.Text,'x') + , expectPE (PresentT "abcx") $ pl @(Fst Id +: Snd Id) ("abc" :: T.Text,'x') , expectPE (PresentT [5,1,2,3]) $ pl @(FlipT (:+) '[1,2,3] 5) () - , expectPE (PresentT (map ModifiedJulianDay [0,1,2,3,4,5])) $ pl @(EnumFromTo Fst Snd) (ModifiedJulianDay 0, ModifiedJulianDay 5) - , expectPE (PresentT (map ModifiedJulianDay [0,1,2,3,4,5])) $ pl @((ToEnum Day *** ToEnum Day) >> EnumFromTo Fst Snd) (0,5) + , expectPE (PresentT (map ModifiedJulianDay [0,1,2,3,4,5])) $ pl @(EnumFromTo (Fst Id) (Snd Id)) (ModifiedJulianDay 0, ModifiedJulianDay 5) + , expectPE (PresentT (map ModifiedJulianDay [0,1,2,3,4,5])) $ pl @((ToEnum Day Id *** ToEnum Day Id) >> EnumFromTo (Fst Id) (Snd Id)) (0,5) , expectPE (FailT "xx") $ pl @(Unfoldr (Guard "xx" (Len > 4) >> Uncons) Id) [1..10] , expectPE (PresentT [1,2,3,4,5,6,7,8,9,10]) $ pl @(Unfoldr Uncons Id) [1..10] - , expectPE (PresentT [99,98,97,96]) $ pl @(IterateN 4 Pred) 99 - , expectPE (PresentT (4,'x')) $ pl @('(,) 4 % Char1 "x") () - , expectPE (PresentT (Just False)) $ pl @(FromList (M.Map _ _) >> Lookup Id % Char1 "y") [('x',True),('y',False)] - , expectPE (PresentT (4,"abc")) $ pl @('(,) % 4 % "abc") () + , expectPE (PresentT [99,98,97,96]) $ pl @(IterateN 4 (Pred Id)) 99 + , expectPE (PresentT (4,'x')) $ pl @('(,) 4 %% Char1 "x") () + , expectPE (PresentT (Just False)) $ pl @(FromList (M.Map _ _) >> Lookup Id %% Char1 "y") [('x',True),('y',False)] + , expectPE (PresentT (4,"abc")) $ pl @('(,) %% 4 %% "abc") () , expectPE (PresentT ("abc",4)) $ pl @(4 %& "abc" %& '(,)) () , expectPE (PresentT ("abc",4)) $ pl @(FlipT '(,) 4 "abc") () - , expectPE (PresentT (1,[])) $ pl @(Uncons >> MaybeIn '(1,MemptyT _) Id) [] + , expectPE (PresentT (1,[])) $ pl @(Uncons >> MaybeIn '(1,MEmptyT _) Id) [] , expectPE (PresentT []) $ pl @'[] 4 - , expectPE (PresentT (SG.Sum 3)) $ pl @(FromInteger (SG.Sum _) Fst) (3,"A") + , expectPE (PresentT (SG.Sum 3)) $ pl @(FromInteger (SG.Sum _) (Fst Id)) (3,"A") , expectPE (PresentT (123 :: DiffTime)) $ pl @(FromInteger DiffTime 123) 'x' - , expectPE (PresentT (0.8 :: Float)) $ pl @(FromRational Float (PosR 4 5)) () + , expectPE (PresentT (0.8 :: Float)) $ pl @(FromRational Float (4 % 5)) () , expectPE (PresentT (14 % 1)) $ pl @(ToRational 14) () , expectPE (PresentT ('y',3)) $ pl @(Id !! 1) [('x',14),('y',3),('z',5)] , expectPE (PresentT ('y',3)) $ pl @(Id !!! 1) [('x',14),('y',3),('z',5)] @@ -711,130 +712,130 @@ , expectPE (PresentT Nothing) $ pl @(Lookup Id 14) [('x',14),('y',3),('z',5)] , expectPE (PresentT ('y',3)) $ pl @(Lookup' _ Id 1) [('x',14),('y',3),('z',5)] , expectPE (FailT "index(14) not found") $ pl @(Lookup' _ Id 14) [('x',14),('y',3),('z',5)] - , expectPE (PresentT 99) $ pl @(FstL _ Id) (99,'a',False,"someval","abc",1.3) - , expectPE (PresentT 'a') $ pl @(SndL _ Id) (99,'a',False,"someval","abc",1.3) - , expectPE (PresentT False) $ pl @(ThdL _ Id) (99,'a',False,"someval","abc",1.3) - , expectPE (PresentT "someval") $ pl @(FthL _ Id) (99,'a',False,"someval","abc",1.3) - , expectPE (PresentT [1,-5,5,-1]) $ pl @('[Pos 1,Negate << PosR 33 7, PosR 21 4,NegR 7 5 >> Signum] >> Map (Floor _ Id) Id) () - , expectPE (PresentT [1,-4,6,-1]) $ pl @('[Pos 1,Negate << PosR 33 7, PosR 21 4,NegR 7 5 >> Signum] >> Map (Ceiling _ Id) Id) () - , expectPE (PresentT [1,-4,5,-1]) $ pl @('[Pos 1,Negate << PosR 33 7, PosR 21 4,NegR 7 5 >> Signum] >> Map (Truncate _ Id) Id) () - , expectPE (PresentT @Integer 2) $ pl @(Truncate' (Fst >> Unproxy ) Snd) (Proxy @Integer,2.3) - , expectPE (PresentT @Int 2) $ pl @(Truncate' Fst Snd) (1::Int,2.3) - , expectPE (PresentT @Float 0.4) $ pl @(FromRational' Fst Snd) (1::Float,2 % 5) + , expectPE (PresentT 99) $ pl @(Fst Id) (99,'a',False,1.3) + , expectPE (PresentT 'a') $ pl @(Snd Id) (99,'a',False,1.3) + , expectPE (PresentT False) $ pl @(Thd Id) (99,'a',False,1.3) + , expectPE (PresentT "someval") $ pl @(L4 Id) (99,'a',False,"someval") + , expectPE (PresentT [1,-5,5,-1]) $ pl @('[1 % 1 ,Negate (33 % 7), 21 % 4,Signum (7 %- 5)] >> Map (Floor _ Id) Id) () + , expectPE (PresentT [1,-4,6,-1]) $ pl @('[1 % 1 ,Negate (33 % 7), 21 % 4,Signum (7 %- 5)] >> Map (Ceiling _ Id) Id) () + , expectPE (PresentT [1,-4,5,-1]) $ pl @('[1 % 1 ,Negate (33 % 7), 21 % 4,Signum (7 %- 5)] >> Map (Truncate _ Id) Id) () + , expectPE (PresentT @Integer 2) $ pl @(Truncate' (Fst Id >> Unproxy ) (Snd Id)) (Proxy @Integer,2.3) + , expectPE (PresentT @Int 2) $ pl @(Truncate' (Fst Id) (Snd Id)) (1::Int,2.3) + , expectPE (PresentT @Float 0.4) $ pl @(FromRational' (Fst Id) (Snd Id)) (1::Float,2 % 5) , expectPE (PresentT (5 % 3)) $ pl @((ToRational 5) / (ToRational 3)) 'x' - , expectPE (PresentT (-5 % 3)) $ pl @(Pos 5 / Neg 3) 'x' - , expectPE (PresentT (-5 % 3)) $ pl @(Neg 5 / Fst) (3,'x') - , expectPE (PresentT (-5 % 3)) $ pl @(Snd / Fst) (-3,5) - , expectPE (FailT "DivF zero denominator") $ pl @(Snd / Fst) (0,5) - , expectPE (PresentT 16) $ pl @(Foldl (Guard "someval" (Fst < Snd) >> Snd) (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 < Snd) >> Snd) (Head' Id) Tail) [1,4,7,6,16::Int] - , expectPE (PresentT (True,16)) $ pl @(Foldl (If ((Fst >> Fst) && (Snd > (Fst >> Snd))) '( 'True, Snd ) '( 'False, Fst >> Snd )) '( 'True, Head' Id ) Tail) [1,4,7,9,16] - , expectPE (PresentT (False,16)) $ pl @(Foldl (If ((Fst >> Fst) && (Snd > (Fst >> Snd))) '( 'True, Snd ) '( 'False, Fst >> Snd )) '( 'True, Head' Id ) Tail) [1,4,7,9,16,2] + , 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 (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 > (Fst Id >> Snd Id))) '( 'True, (Snd Id) ) '( 'False, (Fst Id) >> Snd Id )) '( 'True, Head' Id ) Tail) [1,4,7,9,16] + , expectPE (PresentT (False,16)) $ pl @(Foldl (If ((Fst Id >> Fst Id) && (Snd Id > (Fst Id >> Snd Id))) '( 'True, (Snd Id) ) '( 'False, (Fst Id) >> Snd Id )) '( 'True, Head' Id ) Tail) [1,4,7,9,16,2] , expectPE (PresentT (False,7)) - $ pl @(Foldl (If (Fst >> Fst) - (If (Snd > (Fst >> Snd)) - '( 'True, Snd ) - '( 'False, Fst >> Snd ) - ) Fst) + $ pl @(Foldl (If (Fst Id >> Fst Id) + (If (Snd Id > (Fst Id >> Snd Id)) + '( 'True, (Snd Id) ) + '( 'False, (Fst Id) >> Snd Id ) + ) (Fst Id)) '( 'True, Head' Id) Tail) [1,4,7,6,16] , expectPE (PresentT [1,2,3,4]) $ pl @(Init' Id) [1..5] , expectPE (FailT "Init(empty)") $ pl @(Init' Id) ([] @()) , expectPE (PresentT [2,3,4,5]) $ pl @(Tail' Id) [1..5] , expectPE (FailT "Tail(empty)") $ pl @(Tail' Id) ([] @()) , expectPE (PresentT [10,12,13]) $ pl @(CatMaybes Id) [Just 10, Just 12, Nothing, Just 13] - , expectPE (PresentT [5,4,3,2,1]) $ pl @(Foldl (Snd :+ Fst) (MemptyT [_]) Id) [1..5] + , expectPE (PresentT [5,4,3,2,1]) $ pl @(Foldl (Snd Id :+ (Fst Id)) (MEmptyT [_]) Id) [1..5] , expectPE (PresentT (map SG.Min [9,10,11,12,13])) $ pl @(EnumFromTo (Pure SG.Min 9) (Pure _ 13)) () , expectPE (PresentT (map SG.Min [9,10,11,12,13])) $ pl @(EnumFromTo (Wrap (SG.Min _) 9) (Wrap _ 13)) () --- , expectPE (PresentT (Just 'x')) $ pl @(Purex Fst Snd) (Just 10,'x') - , expectPE (PresentT (Just 'x')) $ pl @(Snd <$ Fst) (Just 10,'x') - , expectPE (PresentT (Nothing @(SG.Sum _))) $ pl @(MemptyT' Id) (Just (SG.Sum 12)) +-- , expectPE (PresentT (Just 'x')) $ pl @(Purex (Fst Id) (Snd Id)) (Just 10,'x') + , expectPE (PresentT (Just 'x')) $ pl @(Snd Id <$ (Fst Id)) (Just 10,'x') + , 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 ([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 [94,93,92,91]) $ pl @(IterateWhile (Id > 90) Pred) 94 - , expectPE (PresentT [94,93,92,91,90]) $ pl @(IterateUntil (Id < 90) Pred) 94 - , expectPE (PresentT [95,94,93,92,91]) $ pl @(IterateNWhile 10 (Id > 90) Pred) 95 - , expectPE (PresentT [95,94,93]) $ pl @(IterateNWhile 3 (Id > 90) Pred) 95 - , expectPE (PresentT [95,94,93,92,91]) $ pl @(IterateNUntil 10 (Id <= 90) Pred) 95 - , expectPE (PresentT [95,94,93]) $ pl @(IterateNUntil 3 (Id <= 90) Pred) 95 + , 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 + , expectPE (PresentT [95,94,93]) $ pl @(IterateNWhile 3 (Id > 90) (Pred Id)) 95 + , expectPE (PresentT [95,94,93,92,91]) $ pl @(IterateNUntil 10 (Id <= 90) (Pred Id)) 95 + , expectPE (PresentT [95,94,93]) $ pl @(IterateNUntil 3 (Id <= 90) (Pred Id)) 95 -- 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 '() (EnumFromTo 1 9999)) () - , expectPE (PresentT [1,2,3,4,5,99]) $ pl @(MaybeX Fst ((Fst >> Fst) +: Snd) Snd) ([1..5],Just 99) - , expectPE (PresentT [1,2,3,4,5]) $ pl @(MaybeX Fst ((Fst >> Fst) +: Snd) Snd) ([1..5],Nothing) - , expectPE (PresentT "a=9 b=rhs") $ pl @(TheseX (Printf "a=%d" (Snd >> Succ)) ("b=" <> Snd) (Snd >> Printf2 "a=%d b=%s") Id) (These @Int 9 "rhs") - , expectPE (PresentT "a=10") $ pl @(TheseX (Printf "a=%d" (Snd >> Succ)) ("b=" <> Snd) (Snd >> Printf2 "a=%d b=%s") Id) (This @Int 9) - , expectPE (PresentT "b=rhs") $ pl @(TheseX (Printf "a=%d" (Snd >> Succ)) ("b=" <> Snd) (Snd >> Printf2 "a=%d b=%s") Id) (That @Int "rhs") + , 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 Id >> Fst Id) +: Snd Id) (Snd Id)) ([1..5],Just 99) + , expectPE (PresentT [1,2,3,4,5]) $ pl @(MaybeX (Fst Id) ((Fst Id >> 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") , expectPE (PresentT ([] @Int)) $ pl @(HeadP Id) (map (:[]) ([] @Int)) , expectPE (PresentT ([10] :: [Int])) $ pl @(HeadP Id) (map (:[]) ([10..14] :: [Int])) - , expectPE (PresentT 10) $ pl @(HeadDef Fst Snd) (99,[10..14]) - , expectPE (PresentT 99) $ pl @(HeadDef Fst Snd) (99,[] @Int) - , expectPE (PresentT 43) $ pl @(HeadDef 43 Snd) (99,[] @Int) + , expectPE (PresentT 10) $ pl @(HeadDef (Fst Id) (Snd Id)) (99,[10..14]) + , expectPE (PresentT 99) $ pl @(HeadDef (Fst Id) (Snd Id)) (99,[] @Int) + , expectPE (PresentT 43) $ pl @(HeadDef 43 (Snd Id)) (99,[] @Int) , expectPE (PresentT (Just 'd')) $ pl @(Lookup "abcdef" 3) () , expectPE (PresentT (Just 5)) $ pl @(Lookup '[1,2,3,4,5,6] 4) () , expectPE (PresentT 5) $ pl @(LookupDef '[1,2,3,4,5,6] 4 Id) 23 - , expectPE (PresentT 5) $ pl @(LookupDef '[1,2,3,4,5,6] 4 Fst) (23,'x') + , expectPE (PresentT 5) $ pl @(LookupDef '[1,2,3,4,5,6] 4 (Fst Id)) (23,'x') , expectPE (PresentT 23) $ pl @(LookupDef '[1,2,3,4,5,6] 99 Id) 23 - , expectPE (PresentT 23) $ pl @(LookupDef '[1,2,3,4,5,6] 99 Fst) (23,'x') + , expectPE (PresentT 23) $ pl @(LookupDef '[1,2,3,4,5,6] 99 (Fst Id)) (23,'x') , expectPE (PresentT 5) $ pl @(LookupDef '[1,2,3,4,5,6] 4 999) (23,'x') , expectPE (PresentT 999) $ pl @(LookupDef '[1,2,3,4,5,6] 40 999) (23,'x') - , expectPE (PresentT (SG.Min 5)) $ pl @(LookupP Fst 4) (map SG.Min [1::Int .. 10],'x') - , expectPE (PresentT (mempty @(SG.Min _))) $ pl @(LookupP Fst 999) (map SG.Min [1::Int .. 10],'x') - , expectPE (FailT "someval") $ pl @(LookupFail "someval" Fst 999) (map SG.Min [1::Int .. 10],'x') - , expectPE (FailT "abcsomeval") $ pl @(Fail (Snd >> Unproxy) (Fst <> "someval")) ("abc",Proxy @Int) - , expectPE (FailT "char=x") $ pl @(LookupFail (Printf "char=%c" Snd) Fst 49) (map SG.Min [1::Int ..10],'x') - , expectPE (FailT "someval=13") $ pl @(LeftFail (Printf "someval=%d" Fst) Snd) (13::Int,Right @(SG.Sum Int) "abc") - , expectPE (FailT "someval=Right \"abc\"") $ pl @(LeftFail (Printf "someval=%s" ShowP) Id) (Right @(SG.Sum Int) "abc") - , expectPE (FailT "msg=(\"ASfd\",[]) Asdf") $ pl @(GFail Uncons (Printf "msg=%s Asdf" ShowP) Snd) ("ASfd",[]::[Int]) - , expectPE (PresentT 'c') $ pl @(LookupDef' Fst Snd (Char1 "xx") Id) (['a'..'e'],2) - , expectPE (PresentT 'x') $ pl @(LookupDef' Fst Snd (Char1 "xx") Id) (['a'..'e'],999) - , expectPE (PresentT 'x') $ pl @(LookupDef' Fst Snd (Char1 "xx") Id) ([],2) - , expectPE (PresentT 'x') $ pl @(LookupDef' Fst Snd (Char1 "xx") Snd) ('w',([],2)) - , expectPE (PresentT 'c') $ pl @(LookupDef' Fst Snd Fst Snd) ('x',(['a'..'e'],2)) - , expectPE (PresentT(SG.Min 13)) $ pl @(LookupP' Fst Snd Snd) ('x',(map SG.Min [10..15::Int], 3)) + , expectPE (PresentT (SG.Min 5)) $ pl @(LookupP (Fst Id) 4) (map SG.Min [1::Int .. 10],'x') + , expectPE (PresentT (mempty @(SG.Min _))) $ pl @(LookupP (Fst Id) 999) (map SG.Min [1::Int .. 10],'x') + , expectPE (FailT "someval") $ pl @(LookupFail "someval" (Fst Id) 999) (map SG.Min [1::Int .. 10],'x') + , expectPE (FailT "abcsomeval") $ pl @(Fail (Snd Id >> Unproxy) (Fst Id <> "someval")) ("abc",Proxy @Int) + , 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 (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) + , expectPE (PresentT 'x') $ pl @(LookupDef' (Fst Id) (Snd Id) (Char1 "xx") (Snd Id)) ('w',([],2)) + , expectPE (PresentT 'c') $ pl @(LookupDef' (Fst Id) (Snd Id) (Fst Id) (Snd Id)) ('x',(['a'..'e'],2)) + , expectPE (PresentT(SG.Min 13)) $ pl @(LookupP' (Fst Id) (Snd Id) (Snd Id)) ('x',(map SG.Min [10..15::Int], 3)) - , expectPE (PresentT 9) $ pl @(HeadDef 9 Fst) ([],True) - , expectPE (PresentT 1) $ pl @(HeadDef 9 Fst) ([1..5],True) - , expectPE (PresentT 10) $ pl @(HeadDef 3 Fst) ([10..15],True) + , expectPE (PresentT 9) $ pl @(HeadDef 9 (Fst Id)) ([],True) + , expectPE (PresentT 1) $ pl @(HeadDef 9 (Fst Id)) ([1..5],True) + , expectPE (PresentT 10) $ pl @(HeadDef 3 (Fst Id)) ([10..15],True) - , expectPE (PresentT 9) $ pl @(LastDef 9 Fst) ([],True) - , expectPE (PresentT 5) $ pl @(LastDef 9 Fst) ([1..5],True) - , expectPE (PresentT 15) $ pl @(LastDef 3 Fst) ([10..15],True) + , expectPE (PresentT 9) $ pl @(LastDef 9 (Fst Id)) ([],True) + , expectPE (PresentT 5) $ pl @(LastDef 9 (Fst Id)) ([1..5],True) + , expectPE (PresentT 15) $ pl @(LastDef 3 (Fst Id)) ([10..15],True) - , expectPE (PresentT [9,7]) $ pl @(InitDef '[9,7] Fst) ([],True) - , expectPE (PresentT [1,2,3,4]) $ pl @(InitDef '[9,7] Fst) ([1..5],True) - , expectPE (PresentT [10,11,12,13,14]) $ pl @(InitDef '[3] Fst) ([10..15],True) - , expectPE (PresentT [10,11,12,13,14]) $ pl @(InitP Fst) ([10..15],True) - , expectPE (PresentT []) $ pl @(InitP Fst) ([] @Int,True) + , expectPE (PresentT [9,7]) $ pl @(InitDef '[9,7] (Fst Id)) ([],True) + , expectPE (PresentT [1,2,3,4]) $ pl @(InitDef '[9,7] (Fst Id)) ([1..5],True) + , expectPE (PresentT [10,11,12,13,14]) $ pl @(InitDef '[3] (Fst Id)) ([10..15],True) + , expectPE (PresentT [10,11,12,13,14]) $ pl @(InitP (Fst Id)) ([10..15],True) + , expectPE (PresentT []) $ pl @(InitP (Fst Id)) ([] @Int,True) - , expectPE (PresentT [9,7]) $ pl @(TailDef '[9,7] Fst) ([],True) - , expectPE (PresentT [2,3,4,5]) $ pl @(TailDef '[9,7] Fst) ([1..5],True) - , expectPE (PresentT [11,12,13,14,15]) $ pl @(TailDef '[3] Fst) ([10..15],True) - , expectPE (PresentT [11,12,13,14,15]) $ pl @(TailP Fst) ([10..15],True) - , expectPE (PresentT []) $ pl @(TailP Fst) ([] @Int,True) + , expectPE (PresentT [9,7]) $ pl @(TailDef '[9,7] (Fst Id)) ([],True) + , expectPE (PresentT [2,3,4,5]) $ pl @(TailDef '[9,7] (Fst Id)) ([1..5],True) + , expectPE (PresentT [11,12,13,14,15]) $ pl @(TailDef '[3] (Fst Id)) ([10..15],True) + , expectPE (PresentT [11,12,13,14,15]) $ pl @(TailP (Fst Id)) ([10..15],True) + , expectPE (PresentT []) $ pl @(TailP (Fst Id)) ([] @Int,True) - , expectPE (FailT "a=4 b=someval") $ pl @(TailFail (Snd >> Printf2 "a=%d b=%s") Fst) ([]::[()],(4::Int,"someval" :: String)) - , expectPE (PresentT 3) $ pl @(JustDef' 44 (Fst >> Fst >> Fst) Snd) (3,Just 20) - , expectPE (PresentT 999) $ pl @(JustDef' 44 999 Snd) ("xxx",Just 20) - , expectPE (PresentT "xxabcd") $ pl @(JustDef' "dd" ((Fst >> Fst >> Fst) <> Snd) Snd) ("xx",Just "abcd") - , expectPE (PresentT "dd") $ pl @(JustDef' "dd" ((Fst >> Fst >> Fst) <> Snd) Snd) ("xx",Nothing) - , expectPE (PresentT "xx") $ pl @(JustDef' Fst ((Fst >> Fst >> Fst) <> Snd) Snd) ("xx",Nothing) + , expectPE (FailT "a=4 b=someval") $ pl @(TailFail (Snd Id >> Printf2 "a=%d b=%s") (Fst Id)) ([]::[()],(4::Int,"someval" :: String)) + , expectPE (PresentT 3) $ pl @(JustDef' 44 (Fst Id >> Fst Id >> Fst Id) (Snd Id)) (3,Just 20) + , expectPE (PresentT 999) $ pl @(JustDef' 44 999 (Snd Id)) ("xxx",Just 20) + , expectPE (PresentT "xxabcd") $ pl @(JustDef' "dd" ((Fst Id >> Fst Id >> Fst Id) <> (Snd Id)) (Snd Id)) ("xx",Just "abcd") + , expectPE (PresentT "dd") $ pl @(JustDef' "dd" ((Fst Id >> Fst Id >> Fst Id) <> (Snd Id)) (Snd Id)) ("xx",Nothing) + , expectPE (PresentT "xx") $ pl @(JustDef' (Fst Id) ((Fst Id >> Fst Id >> Fst Id) <> (Snd Id)) (Snd Id)) ("xx",Nothing) - , expectPE (PresentT 3) $ pl @(JustDef' 44 (Fst >> Fst >> Snd) Fst) (Just 20,3) - , expectPE (PresentT 999) $ pl @(JustDef' 44 999 Fst) (Just 20,"xxx") - , expectPE (PresentT "xxabcd") $ pl @(JustDef' "dd" ((Fst >> Fst >> Snd) <> Snd) Fst) (Just "abcd","xx") - , expectPE (PresentT "dd") $ pl @(JustDef' "dd" ((Fst >> Fst >> Snd) <> Snd) Fst) (Nothing,"xx") - , expectPE (PresentT "xx") $ pl @(JustDef' Snd ((Fst >> Fst >> Snd) <> Snd) Fst) (Nothing,"xx") + , expectPE (PresentT 3) $ pl @(JustDef' 44 (Fst Id >> Fst Id >> Snd Id) (Fst Id)) (Just 20,3) + , expectPE (PresentT 999) $ pl @(JustDef' 44 999 (Fst Id)) (Just 20,"xxx") + , expectPE (PresentT "xxabcd") $ pl @(JustDef' "dd" ((Fst Id >> Fst Id >> Snd Id) <> (Snd Id)) (Fst Id)) (Just "abcd","xx") + , expectPE (PresentT "dd") $ pl @(JustDef' "dd" ((Fst Id >> Fst Id >> Snd Id) <> (Snd Id)) (Fst Id)) (Nothing,"xx") + , expectPE (PresentT "xx") $ pl @(JustDef' (Snd Id) ((Fst Id >> Fst Id >> Snd Id) <> (Snd Id)) (Fst Id)) (Nothing,"xx") - , expectPE (PresentT "xxya") $ pl @((Id &&& Snd) >> MaybeXP (Fst >> Fst >> Fst) ((Fst >> Fst >> Fst) <> Snd) Snd) ("xx",Just "ya") - , expectPE (PresentT "xxya") $ pl @((Id &&& Fst) >> MaybeXP (Fst >> Fst >> Snd) ((Fst >> Fst >> Snd) <> Snd) Snd) (Just "ya","xx") + , expectPE (PresentT "xxya") $ pl @((Id &&& (Snd Id)) >> MaybeXP (Fst Id >> Fst Id >> Fst Id) ((Fst Id >> Fst Id >> Fst Id) <> (Snd Id)) (Snd Id)) ("xx",Just "ya") + , expectPE (PresentT "xxya") $ pl @((Id &&& (Fst Id)) >> MaybeXP (Fst Id >> Fst Id >> Snd Id) ((Fst Id >> Fst Id >> Snd Id) <> (Snd Id)) (Snd Id)) (Just "ya","xx") - , expectPE (PresentT "xx") $ pl @((Id &&& Snd) >> MaybeXP (Fst >> Fst >> Fst) ((Fst >> Fst >> Fst) <> Snd) Snd) ("xx",Nothing) + , expectPE (PresentT "xx") $ pl @((Id &&& (Snd Id)) >> MaybeXP (Fst Id >> Fst Id >> Fst Id) ((Fst Id >> Fst Id >> Fst Id) <> (Snd Id)) (Snd Id)) ("xx",Nothing) - , expectPE (PresentT "aabb") $ pl @(JustDef''' Fst ((Fst >> Fst) <> Snd) Snd) ("aa", Just "bb") - , expectPE (PresentT "aa") $ pl @(JustDef''' Fst ((Fst >> Fst) <> Snd) Snd) ("aa", Nothing) - , expectPE (PresentT "ssbb") $ pl @(JustDef''' Fst ("ss" <> Snd) Snd) ("aa", Just "bb") + , expectPE (PresentT "aabb") $ pl @(JustDef''' (Fst Id) ((Fst Id >> Fst Id) <> (Snd Id)) (Snd Id)) ("aa", Just "bb") + , expectPE (PresentT "aa") $ pl @(JustDef''' (Fst Id) ((Fst Id >> Fst Id) <> (Snd Id)) (Snd Id)) ("aa", Nothing) + , expectPE (PresentT "ssbb") $ pl @(JustDef''' (Fst Id) ("ss" <> (Snd Id)) (Snd Id)) ("aa", Just "bb") , expectPE (PresentT (Just 1)) $ pl @Fmap_1 (Just (1,'x')) , expectPE (PresentT (Just 'x')) $ pl @Fmap_2 (Just (1,'x')) @@ -846,48 +847,48 @@ , expectPE (PresentT [1,10,99]) $ pl @Thiss [This 1, This 10,That 'x', This 99, That 'y'] , expectPE (PresentT "xy") $ pl @Thats [This 1, This 10,That 'x', This 99, That 'y'] , expectPE (PresentT ("xabz",[1,10])) $ pl @PartitionEithers [Left 'x', Right 1,Left 'a', Left 'b',Left 'z', Right 10] - , expectPE (FailT "found rhs=Right 10") $ pl @(LeftFail (Printf "found rhs=%s" ShowP) Id) (Right @String 10) - , expectPE (FailT "found rhs=23") $ pl @(LeftFail (Printf "found rhs=%d" (Snd >> Snd)) (Snd >> Fst)) ('x',(Right @() 10,23::Int)) - , expectPE (PresentT "abc") $ pl @(LeftFail (Printf "found rhs=%d" (Snd >> Snd)) (Snd >> Fst)) ('x',(Left @_ @() "abc",23::Int)) - , expectPE (PresentT (([1,4,10],"xy"),[(9,'z'),(8,'y')])) $ pl @PartitionThese [This 1,That 'x',This 4,That 'y',These 9 'z',This 10,These 8 'y'] - , expectPE (PresentT [('a',1),('a',10),('z',14),('m',22)]) $ pl @(SortOn Snd Snd) ((),[('z',14),('a',10),('m',22),('a',1)]) - , expectPE (PresentT [('z',1),('m',22),('a',10)]) $ pl @(SortOnDesc Fst Snd) ((),[('z',1),('a',10),('m',22)]) - , expectPE (PresentT [('a',10),('m',22),('z',1)]) $ pl @(SortOn Fst Snd) ((),[('z',1),('a',10),('m',22)]) - , expectPE (PresentT [('z',1),('m',22),('a',10)]) $ pl @(SortBy (Swap >> OrdA Fst) Snd) ((),[('z',1),('a',10),('m',22)]) + , expectPE (FailT "found rhs=Right 10") $ pl @(LeftFail (Printf "found rhs=%s" (ShowP Id)) Id) (Right @String 10) + , expectPE (FailT "found rhs=23") $ pl @(LeftFail (Printf "found rhs=%d" (Snd Id >> Snd Id)) (Snd Id >> Fst Id)) ('x',(Right @() 10,23::Int)) + , expectPE (PresentT "abc") $ pl @(LeftFail (Printf "found rhs=%d" (Snd Id >> Snd Id)) (Snd Id >> Fst Id)) ('x',(Left @_ @() "abc",23::Int)) + , expectPE (PresentT ([1,4,10],"xy",[(9,'z'),(8,'y')])) $ pl @PartitionThese [This 1,That 'x',This 4,That 'y',These 9 'z',This 10,These 8 'y'] + , expectPE (PresentT [('a',1),('a',10),('z',14),('m',22)]) $ pl @(SortOn (Snd Id) (Snd Id)) ((),[('z',14),('a',10),('m',22),('a',1)]) + , expectPE (PresentT [('z',1),('m',22),('a',10)]) $ pl @(SortOnDesc (Fst Id) (Snd Id)) ((),[('z',1),('a',10),('m',22)]) + , expectPE (PresentT [('a',10),('m',22),('z',1)]) $ pl @(SortOn (Fst Id) (Snd Id)) ((),[('z',1),('a',10),('m',22)]) + , expectPE (PresentT [('z',1),('m',22),('a',10)]) $ pl @(SortBy (Swap >> OrdA (Fst Id)) (Snd Id)) ((),[('z',1),('a',10),('m',22)]) , expectPE (PresentT ["aa","cx","by","az"]) $ pl @(SortBy (OrdA Reverse) Id) ["az","by","cx","aa"] - , expectPE (PresentT [('a',10),('a',9),('m',22),('m',10),('z',1)]) $ pl @(SortOn Fst Id) [('z',1),('a',10),('m',22),('a',9),('m',10)] + , expectPE (PresentT [('a',10),('a',9),('m',22),('m',10),('z',1)]) $ pl @(SortOn (Fst Id) Id) [('z',1),('a',10),('m',22),('a',9),('m',10)] , expectPE (PresentT [('a',9),('a',10),('m',10),('m',22),('z',1)]) $ pl @(SortOn Id Id) [('z',1),('a',10),('m',22),('a',9),('m',10)] - , expectPE (PresentT (False,9)) $ pl @(Just' Uncons >> Foldl (If (Fst>>Fst) (If ((Fst>>Snd) < Snd) '( 'True,Snd ) '( 'False,Snd)) Fst) '( 'True,Fst) Snd) [-10,-2,2,3,4,10,9,11] - , expectPE (PresentT (True,11)) $ pl @(Just' Uncons >> Foldl (If (Fst>>Fst) (If ((Fst>>Snd) < Snd) '( 'True,Snd ) '( 'False,Snd)) Fst) '( 'True,Fst) Snd) [-10,2,3,4,10,11] - , expectPE (FailT "pivot=5 value=3(2)") $ pl @(SortBy (If (Fst==5 && Snd==3) (FailPrt2 _ "pivot=%d value=%d") 'GT) Snd) ((), [5,7,3,1,6,2,1,3]) - , expectPE (PresentT [1,1,2,3,3,5,6,7]) $ pl @(SortBy (If (Fst==50 && Snd==3) (FailPrt2 _ "pivot=%d value=%d") (OrdA Id)) Snd) ((), [5,7,3,1,6,2,1,3]) - , expectPE TrueT $ pl @(Between' (Fst >> Fst) (Fst >> Snd) Snd) ((1,4),3) - , expectPE FalseT $ pl @(Between' (Fst >> Fst) (Fst >> Snd) Snd) ((1,4),10) + , expectPE (PresentT (False,9)) $ pl @(Just' Uncons >> Foldl (If (Fst Id>>(Fst Id)) (If ((Fst Id>>(Snd Id)) < (Snd Id)) '( 'True,(Snd Id) ) '( 'False,(Snd Id))) (Fst Id)) '( 'True,(Fst Id)) (Snd Id)) [-10,-2,2,3,4,10,9,11] + , expectPE (PresentT (True,11)) $ pl @(Just' Uncons >> Foldl (If (Fst Id>>(Fst Id)) (If ((Fst Id>>(Snd Id)) < (Snd Id)) '( 'True,(Snd Id) ) '( 'False,(Snd Id))) (Fst Id)) '( 'True,(Fst Id)) (Snd Id)) [-10,2,3,4,10,11] + , expectPE (FailT "pivot=5 value=3(2)") $ pl @(SortBy (If (Fst Id==5 && (Snd Id)==3) (FailPrt2 _ "pivot=%d value=%d") 'GT) (Snd Id)) ((), [5,7,3,1,6,2,1,3]) + , expectPE (PresentT [1,1,2,3,3,5,6,7]) $ pl @(SortBy (If (Fst Id==50 && (Snd Id)==3) (FailPrt2 _ "pivot=%d value=%d") (OrdA Id)) (Snd Id)) ((), [5,7,3,1,6,2,1,3]) + , expectPE TrueT $ pl @(Between' (Fst Id >> Fst Id) (Fst Id >> Snd Id) (Snd Id)) ((1,4),3) + , expectPE FalseT $ pl @(Between' (Fst Id >> Fst Id) (Fst Id >> Snd Id) (Snd Id)) ((1,4),10) , expectPE (FailT "no match on [03/29/0x7]") $ pl @(Map (ParseTimes Day '["%Y-%m-%d", "%m/%d/%y", "%b %d %Y"] Id) Id) ["2001-01-01", "Jan 24 2009", "03/29/0x7"] , expectPE (PresentT [read @Day "2001-01-01", read @Day "2009-01-24", read @Day "2007-03-29"]) $ pl @(Map (ParseTimes Day '["%Y-%m-%d", "%m/%d/%y", "%b %d %Y"] Id) Id) ["2001-01-01", "Jan 24 2009", "03/29/07"] - , expectPE (PresentT "gt3") $ pl @(Case (Snd >> Failp "xx") '[Gt 3, Lt 2, Same 3] '["gt3","lt2","eq3"] Id) 15 - , expectPE (PresentT "lt2") $ pl @(Case (Snd >> Failp "xx") '[Gt 3, Lt 2, Same 3] '["gt3","lt2","eq3"] Id) 1 - , expectPE (PresentT "eq3") $ pl @(Case (Snd >> Failp "xx") '[Gt 3, Lt 2, Same 3] '["gt3","lt2","eq3"] Id) 3 + , expectPE (PresentT "gt3") $ pl @(Case (Snd Id >> Failp "xx") '[Gt 3, Lt 2, Same 3] '["gt3","lt2","eq3"] Id) 15 + , expectPE (PresentT "lt2") $ pl @(Case (Snd Id >> Failp "xx") '[Gt 3, Lt 2, Same 3] '["gt3","lt2","eq3"] Id) 1 + , expectPE (PresentT "eq3") $ pl @(Case (Snd Id >> Failp "xx") '[Gt 3, Lt 2, Same 3] '["gt3","lt2","eq3"] Id) 3 - , expectPE (FailT "no match") $ pl @(Case (Snd >> Failp "no match") '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 15 - , expectPE (FailT "no match for 015") $ pl @(Case (Fail (Snd >> Unproxy) (Printf "no match for %03d" Fst)) '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 15 + , 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 (PresentT "other") $ pl @(Case "other" '[Same 1, Same 2, Same 3] '["eq1","eq2","eq3"] Id) 15 - , expectPE (PresentT "151515") $ pl @(Case (Fst >> ShowP >> Id <> Id <> Id) '[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 (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 > 10) (Snd >> Fst) (Snd >> Snd)) (7,('x',99)) - , expectPE (PresentT (Right 99)) $ pl @(EitherB (Fst > 10) (Snd >> Fst) (Snd >> Snd)) (11,('x',99)) + , 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 (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 >> Printf2 "msg=%s caught(%s)")) [10,12,13] - , expectPE (PresentT 10) $ pl @(Catch' OneP (Second ShowP >> Printf2 "msg=%s caught(%s)")) [10] - , expectPE (FailT "msg=expected list of length 1 but found length=2 err s=[10,11]") $ pl @(Catch' OneP (Second ShowP >> Printf2 "msg=%s err s=%s")) [10,11] + , 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] + , expectPE (PresentT 10) $ pl @(Catch' OneP (Second (ShowP Id) >> Printf2 "msg=%s caught(%s)")) [10] + , expectPE (FailT "msg=expected list of length 1 but found length=2 err s=[10,11]") $ pl @(Catch' OneP (Second (ShowP Id) >> Printf2 "msg=%s err s=%s")) [10,11] , expectPE (PresentT 99) $ pl @(Catch OneP 99) [10,11] , expectPE (PresentT 10) $ pl @(Catch OneP 99) [10] , expectPE (PresentT False) $ pl @(Catch OneP 'True) [False] -- cant know that this is FalseT cos is driven by type of the list not the 'True part @@ -897,23 +898,23 @@ , expectPE (PresentT 255) $ pl @(ReadBase Int 16) "ff" , expectPE (PresentT "-7b") $ pl @(ShowBase 16) (-123) , expectPE (PresentT "7b") $ pl @(ShowBase 16) 123 - , expectPE (PresentT "abc") $ pl @(Fst3 >> Snd >> Thd3) (('x',(13,False,"abc")),True,'y') - , expectPE (PresentT 9.3) $ pl @(Thd3 >> Snd3 >> Fst) ('x',True,(13,(9.3,False),"def")) + , expectPE (PresentT "abc") $ pl @(Thd (Snd (Fst Id))) (('x',(13,False,"abc")),True,'y') + , expectPE (PresentT 9.3) $ pl @(Fst (Snd (Thd Id))) ('x',True,(13,(9.3,False),"def")) ] type Fizzbuzz = Id &&& If (Id `Mod` 3==0) "fizz" "" <> If (Id `Mod` 5==0) "buzz" "" type Fizzbuzz' = Id &&& Case "" '[Id `Mod` 15 == 0, Id `Mod` 3 == 0, Id `Mod` 5 == 0] '["fizzbuzz", "fizz", "buzz"] Id -type Fizzbuzz'' t t1 = Case (MkLeft t Fst) '[Id `Mod` 15 == 0, Id `Mod` 3 == 0, Id `Mod` 5 == 0] '[ MkRight t1 "fizzbuzz", MkRight t1 "fizz", MkRight t1 "buzz"] Id ---type Fizzbuzz''' = Case (MkLeft' (Snd >> Proxyfabb >> Unproxy) Fst) '[Id `Mod` 15 == 0, Id `Mod` 3 == 0, Id `Mod` 5 == 0] '[ MkRight Int "fizzbuzz", MkRight Int "fizz", MkRight Int "buzz"] Id -type Fizzbuzz'''' = Case (MkLeft String Fst) '[Id `Mod` 15 == 0, Id `Mod` 3 == 0, Id `Mod` 5 == 0] '[ MkRight Int "fizzbuzz", MkRight Int "fizz", MkRight Int "buzz"] Id +type Fizzbuzz'' t t1 = Case (MkLeft t (Fst Id)) '[Id `Mod` 15 == 0, Id `Mod` 3 == 0, Id `Mod` 5 == 0] '[ MkRight t1 "fizzbuzz", MkRight t1 "fizz", MkRight t1 "buzz"] Id +--type Fizzbuzz''' = Case (MkLeft' (Snd Id >> Proxyfabb >> Unproxy) (Fst Id)) '[Id `Mod` 15 == 0, Id `Mod` 3 == 0, Id `Mod` 5 == 0] '[ MkRight Int "fizzbuzz", MkRight Int "fizz", MkRight Int "buzz"] Id +type Fizzbuzz'''' = Case (MkLeft String (Fst Id)) '[Id `Mod` 15 == 0, Id `Mod` 3 == 0, Id `Mod` 5 == 0] '[ MkRight Int "fizzbuzz", MkRight Int "fizz", MkRight Int "buzz"] Id -- this is also good: makes use of type family MapT which does the apply on ADTs: so type synonyms dont work -type Fizzbuzznew = Case (MkLeft String Fst) '[Id `Mod` 15 == 0, Id `Mod` 3 == 0, Id `Mod` 5 == 0] (MapT (MkRight' (Hole Int)) '[ "fizzbuzz", "fizz", "buzz"]) Id +type Fizzbuzznew = Case (MkLeft String (Fst Id)) '[Id `Mod` 15 == 0, Id `Mod` 3 == 0, Id `Mod` 5 == 0] (MapT (MkRight' (Hole Int)) '[ "fizzbuzz", "fizz", "buzz"]) Id type Fizzbuzzalt = '(Id, If (Id `Mod` 3==0) "fizz" "" <> If (Id `Mod` 5==0) "buzz" "") type Fizzbuzzs = Map Fizzbuzz Id -type Fizzbuzzs1 t t1 = Map (Fizzbuzz >> If (Snd >> Null) (MkLeft t Fst) (MkRight t1 Snd)) Id -type Fizzbuzzs2 = Map (Fizzbuzz >> If (Snd >> Null) (MkLeft String Fst) (MkRight Int Snd)) Id +type Fizzbuzzs1 t t1 = Map (Fizzbuzz >> If (Snd Id >> Null) (MkLeft t (Fst Id)) (MkRight t1 (Snd Id))) Id +type Fizzbuzzs2 = Map (Fizzbuzz >> If (Snd Id >> Null) (MkLeft String (Fst Id)) (MkRight Int (Snd Id))) Id -- best one cos leverages type info to determine Either a b -type Fizzbuzzs3 = Map (Fizzbuzz >> If (Snd == "") (MkLeft' Snd Fst) (MkRight' Fst Snd)) Id +type Fizzbuzzs3 = Map (Fizzbuzz >> If (Snd Id == "") (MkLeft' (Snd Id) (Fst Id)) (MkRight' (Fst Id) (Snd Id))) Id
test/TestRefined.hs view
@@ -49,8 +49,8 @@ unnamedTests :: [IO ()] unnamedTests = [ (@?=) (unsafeRefined @'True ("1.2.3.4" :: String)) $$(refinedTH "1.2.3.4") - , (@?=) (unsafeRefined @((Len >> Same 4) && Luhn) [1,2,3,0]) $$(refinedTH [1,2,3,0]) - , (@?=) (unsafeRefined @((Len >> Same 4) && Luhn >> Not) [1,2,3,1]) $$(refinedTH [1,2,3,1]) + , (@?=) (unsafeRefined @((Len >> Same 4) && Luhn Id) [1,2,3,0]) $$(refinedTH [1,2,3,0]) + , (@?=) (unsafeRefined @(Not ((Len >> Same 4) && Luhn Id)) [1,2,3,1]) $$(refinedTH [1,2,3,1]) , (@?=) [(unsafeRefined 7, "")] (reads @(Refined (Between 2 10) Int) "Refined {unRefined = 7}") , (@?=) [] (reads @(Refined (Between 2 10) Int) "Refined {unRefined = 0}") @@ -77,20 +77,20 @@ type Ip4RE = "^(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})$" -type Ip4 = Rescan Ip4RE Id >> OneP >> Map (ReadBaseInt 10) Snd >> Ip4guard +type Ip4 = Rescan Ip4RE Id >> OneP >> Map (ReadBaseInt 10) (Snd Id) >> Ip4guard -type Ip4guard = Guard "4octets" (Len >> Same 4) >> Guard "0-255" (All (Between 0 255)) +type Ip4guard = Guard "4octets" (Len >> Same 4) >> Guard "0-255" (All (Between 0 255) Id) type Ip6 = Resplit ":" Id - >> Guard "count is bad" (Len >> Between 0 8) - >> Guard "not a hex" (All (All (Elem Id "abcdefABCDEF0123456789"))) - >> Guard "len is bad" (All (Len >> Le 4)) + >> Guard "count is bad" (Between' 0 8 Len) + >> Guard "not a hex" (All (All (Elem Id "abcdefABCDEF0123456789") Id) Id) + >> Guard "len is bad" (All (Len >> Le 4) Id) type Ip6A = Map (If (Id == "") "0" Id) (Resplit ":" Id) >> Map (ReadBaseInt 16) Id type Ip6B = Guard "count is bad" (Len >> Between 0 8) - >> Guard "out of bounds" (All (Between 0 65535)) + >> Guard "out of bounds" (All (Between 0 65535) Id) >> 'True type Ip6A' = Resplit ":" Id @@ -101,20 +101,20 @@ type Ip6A'' = Map (If (Id == "") 0 (ReadBaseInt 16)) (Resplit ":" Id) >> PadL 8 0 Id type Ip6B' = Guard "count is bad" (Len >> Same 8) - >> Guard "out of bounds" (All (Between 0 65535)) + >> Guard "out of bounds" (All (Between 0 65535) Id) >> 'True type Ip4A = Map (ReadBaseInt 10) (Resplit "\\." Id) type Ip4B = Guard "expected 4 numbers" (Len >> Same 4) - >> Guard "each number must be between 0 and 255" (All (Between 0 255)) + >> Guard "each number must be between 0 and 255" (All (Between 0 255) Id) >> 'True type Ip4C = Printfnt 4 "%03d.%03d.%03d.%03d" -- base n number of length x and then convert to a list of length x of (0 to (n-1)) -- checks that each digit is between 0 and n-1 -type MM1 (n :: Nat) = Map (ReadBase Int n) Ones -type MM2 (n :: Nat) = ExitWhen "found empty" IsEmpty >> Guard "0<=x<n" (All (Ge 0 && Lt n)) +type MM1 (n :: Nat) = Map (ReadBase Int n) (Ones Id) +type MM2 (n :: Nat) = ExitWhen "found empty" IsEmpty >> Guard "0<=x<n" (All (Ge 0 && Lt n) Id) -- prtRefinedT tst1 tst1 :: Monad m => POpts -> Int -> Int -> RefinedT m (Int,Int)
test/TestRefined3.hs view
@@ -85,33 +85,33 @@ , expectRight (testRefined3P (Proxy @(Ccn '[1,2,1])) ol "1-23-0") , expect3 (Left $ XF "Regex no results") - $ eval3 @(Rescan Ip4RE Id >> HeadFail "failedn" Id >> Map (ReadP Int) Snd) - @((Len >> Same 4) && All (Between 0 255)) + $ eval3 @(Rescan Ip4RE Id >> HeadFail "failedn" Id >> Map (ReadP Int) (Snd Id)) + @((Len >> Same 4) && All (Between 0 255) Id) @(Printfnt 4 "%03d.%03d.%03d.%03d") ol "1.21.x31.4" , expect3 (Right $ unsafeRefined3 [1,21,31,4] "001.021.031.004") - $ eval3 @(Rescan Ip4RE Id >> HeadFail "failedn" Id >> Map (ReadP Int) Snd) - @((Len >> Same 4) && All (Between 0 255)) + $ eval3 @(Rescan Ip4RE Id >> HeadFail "failedn" Id >> Map (ReadP Int) (Snd Id)) + @((Len >> Same 4) && All (Between 0 255) Id) @(Printfnt 4 "%03d.%03d.%03d.%03d") ol "1.21.31.4" , expect3 (Left $ XTFalse (-6.3)) $ eval3 @(ReadP Double) - @(Cmp 'Cgt (ToRational Id) (NegR 7 3)) + @(Cmp 'Cgt (ToRational Id) (7 %- 3)) @(Printf "%5.3f" Id) ol "-6.3" , expect3 (Right $ unsafeRefined3 4.123 "") - $ eval3 @(ReadP Double) @(Cmp 'Cgt (ToRational Id) (NegR 7 3)) @"" + $ eval3 @(ReadP Double) @(Cmp 'Cgt (ToRational Id) (7 %- 3)) @"" ol "4.123" , expect3 (Right $ unsafeRefined3 4.123 (4123 % 1000)) - $ eval3 @Id @(Gt (NegR 7 3)) @(PosR 4123 1000) + $ eval3 @Id @(Gt (7 %- 3)) @(4123 % 1000) ol 4.123 , expect3 (Right $ unsafeRefined3 [1,2,3,4] "") - $ eval3 @(Map (ReadP Int) (Resplit "\\." Id)) @(All (Between 0 255) && (Len >> Same 4)) @"" + $ eval3 @(Map (ReadP Int) (Resplit "\\." Id)) @(All (Between 0 255) Id && (Len >> Same 4)) @"" ol "1.2.3.4" , expect3 (Left $ XTF [291,1048319,4387,17,1] "out of bounds") @@ -124,7 +124,7 @@ , expect3 (Right $ unsafeRefined3 [123,45,6789] "def") $ eval3 - @(Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" Id >> OneP >> Map (ReadBaseInt 10) Snd) + @(Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" Id >> OneP >> Map (ReadBaseInt 10) (Snd Id)) @(Guard "expected 3" (Len >> Same 3) >> Guard "3 digits" (Ix' 0 >> Between 0 999) >> Guard "2 digits" (Ix' 1 >> Between 0 99) @@ -135,8 +135,8 @@ , expect3 (Right $ unsafeRefined3 [123,45,6789] "xyz") $ eval3 - @(Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" Id >> OneP >> Map (ReadBaseInt 10) Snd) - @(Guards (ToGuardsT (Printf2 "guard(%d) %d is out of range") '[Between 0 999, Between 0 99, Between 0 9999]) >> 'True) + @(Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" Id >> OneP >> Map (ReadBaseInt 10) (Snd Id)) + @(GuardsQuick (Printf2 "guard(%d) %d is out of range") '[Between 0 999, Between 0 99, Between 0 9999] >> 'True) @"xyz" ol "123-45-6789" @@ -153,13 +153,13 @@ ol "123::Ffff:::11" , expect3 (Right $ unsafeRefined3 [31,11,1999] "xyz") - $ eval3 @(Rescan DdmmyyyyRE Id >> OneP >> Map (ReadBaseInt 10) Snd) + $ eval3 @(Rescan DdmmyyyyRE Id >> OneP >> Map (ReadBaseInt 10) (Snd Id)) @(Ddmmyyyyval >> 'True) @"xyz" ol "31-11-1999" , expect3 (Right $ unsafeRefined3 [123,45,6789] "xyz") $ eval3 - @(Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" Id >> OneP >> Map (ReadBaseInt 10) Snd) - @(Guards (ToGuardsT (Printf2 "guard(%d) %d is out of range") '[Between 0 999, Between 0 99, Between 0 9999]) >> 'True) + @(Rescan "^(\\d{3})-(\\d{2})-(\\d{4})$" Id >> OneP >> Map (ReadBaseInt 10) (Snd Id)) + @(GuardsQuick (Printf2 "guard(%d) %d is out of range") '[Between 0 999, Between 0 99, Between 0 9999] >> 'True) @"xyz" ol "123-45-6789" @@ -169,7 +169,7 @@ , expect3 (Left $ XTF [1,2,300,4] "each number must be between 0 and 255") $ eval3P ip4 ol "1.2.300.4" , expect3 (Right $ unsafeRefined3 [1,2,3,4,5,6,7,8,9,0,3] "1234-5678-903") $ eval3P cc ol "12345678903" , expect3 (Left $ XTFalse [1,2,3,4,5,6,7,8,9,0,1]) $ eval3P cc ol "12345678901" --- , expect3 (Right $ unsafeRefined3 True ["T","r","ue","Tr","ue"]) $ eval3P (Proxy @'(Id, Id, Do '[ShowP, Dup, Sapa, SplitAts '[1,1,2,2]], Bool)) True +-- , expect3 (Right $ unsafeRefined3 True ["T","r","ue","Tr","ue"]) $ eval3P (Proxy @'(Id, Id, Do '[ShowP Id, Dup, Sapa, SplitAts '[1,1,2,2]], Bool)) True , expect3 (Right $ unsafeRefined3 ([12,13,14],TimeOfDay 12 13 14) "12:13:14") $ eval3P hms2E ol "12:13:14" , expect3 (Left (XTF ([12,13,99], TimeOfDay 12 13 99) "guard(2) 99 secs is out of range")) $ eval3P hms2E ol "12:13:99" ] @@ -183,7 +183,7 @@ ] type HexLtR3 = Refined3 (ReadBase Int 16) (Id < 500) (ShowBase 16) String -type IntLtR3 = Refined3 (ReadP Int) (Id < 10) ShowP String +type IntLtR3 = Refined3 (ReadP Int) (Id < 10) (ShowP Id) String -- printf breaks with negative numbers! type Tst1 = '(ReadP Int, Between 1 7, Printf "someval val=%03d" Id, String) @@ -206,7 +206,7 @@ -- this works but ParseTimeP is easier type DdmmyyyyRE = "^(\\d{2})-(\\d{2})-(\\d{4})$" -type Ddmmyyyyval' = Guards (ToGuardsT (Printf2 "guard(%d) %d is out of range") '[Between 1 31, Between 1 12, Between 1990 2050]) +type Ddmmyyyyval' = GuardsQuick (Printf2 "guard(%d) %d is out of range") '[Between 1 31, Between 1 12, Between 1990 2050] type Ddmmyyyyval = Guards '[ '(Printf2 "guard(%d) day %d is out of range", Between 1 31) , '(Printf2 "guard(%d) month %d is out of range", Between 1 12) @@ -216,8 +216,8 @@ cc = mkProxy3 type Ipz1 = '(Id &&& Ip4A - , Snd >> Ip4B - , Snd >> Para (RepeatT 4 (Printf "%03d" Id)) >> Intercalate '["."] Id >> Concat + , (Snd Id) >> Ip4B + , (Snd Id) >> Para (RepeatT 4 (Printf "%03d" Id)) >> Intercalate '["."] Id >> Concat , String) type Ipz2 = '(Id, Ip4A, Ip4B, String) -- skips fmt and just uses the original input type Ipz3 = '(Ip4A, Ip4B, Id, String) @@ -225,64 +225,68 @@ -- need to add 'True to make it a predicate -- guards checks also that there are exactly 3 entries! type Hmsz1 = '(Hmsconv &&& ParseTimeP TimeOfDay "%H:%M:%S" Id - , Fst >> Hmsval >> 'True - , Snd + , Fst Id >> Hmsval >> 'True + , (Snd Id) , String) -- better error messages cos doesnt do a strict regex match type Hmsz2 = '(Hmsip &&& ParseTimeP TimeOfDay "%H:%M:%S" Id - , Fst >> Hmsop >> 'True - , Snd + , Fst Id >> Hmsop >> 'True + , (Snd Id) , String) type Hmsip2 = Hmsip &&& ParseTimeP TimeOfDay "%H:%M:%S" Id -type Hmsop2 = Fst >> Hmsop >> 'True +type Hmsop2 = Fst Id >> Hmsop >> 'True --- >mkProxy3 @Hmsip2 @Hmsop2 @(Snd >> FormatTimeP "%F %T" Id) @String -hms2E :: Proxy '(Hmsip2, Hmsop2, Snd >> FormatTimeP "%T" Id, String) +-- >mkProxy3 @Hmsip2 @Hmsop2 @((Snd Id) >> FormatTimeP "%F %T" Id) @String +hms2E :: Proxy '(Hmsip2, Hmsop2, (Snd Id) >> FormatTimeP "%T" Id, String) hms2E = mkProxy3P -- better to use Guard for op boolean check cos we get better errormessages -- 1. packaged up as a promoted tuple -type Tst3 = '(Map (ReadP Int) (Resplit "\\." Id), (Len >> Same 4) && All (Between 0 255), ConcatMap (Printf "%03d" Id) Id, String) +type Tst3 = '(Map (ReadP Int) (Resplit "\\." Id), (Len >> Same 4) && All (Between 0 255) Id, ConcatMap (Printf "%03d" Id) Id, String) www1, www2 :: String -> Either Msg3 (MakeR3 Tst3) -www1 = prt3 o2 . eval3P (Proxy :: MkProxy3T Tst3) o2 -www2 = prt3 o2 . eval3P tst3 o2 +www1 = prtEval3P (Proxy :: MkProxy3T Tst3) o2 +www2 = prtEval3P tst3 o2 -- just pass in an ipaddress as a string: eg 1.2.3.4 or 1.2.3.4.5 (invalid) 1.2.3.400 (invalid) -ww1 = prtEval3P (Proxy :: MkProxy3T Tst3) o2 -- 2. packaged as a proxy tst3 :: Proxy '(Map (ReadP Int) (Resplit "\\." Id) - ,(Len >> Same 4) && All (Between 0 255) + ,(Len >> Same 4) && All (Between 0 255) Id ,ConcatMap (Printf "%03d" Id) Id ,String) tst3 = mkProxy3 -ww2 = prtEval3P tst3 o2 --- 3. direct (has the advantage that we dont need to specify String - +-- 3. direct +ww3 :: String -> Either Msg3 (Refined3 + (Map (ReadP Int) (Resplit "\\." Id)) + ((Len >> Same 4) && All (Between 0 255) Id) + (ConcatMap (Printf "%03d" Id) Id) + String) +ww3 = prtEval3 o2 +{- ww3 = prtEval3 @(Map (ReadP Int) (Resplit "\\." Id)) @((Len >> Same 4) && All (Between 0 255)) @(ConcatMap (Printf "%03d" Id) Id) o2 - +-} data G4 = G4 { g4Age :: MakeR3 Age , g4Ip :: MakeR3 Ip9 } deriving (Show,Generic,Eq) -type MyAge = Refined3 (ReadP Int) (Gt 4) ShowP String +type MyAge = Refined3 (ReadP Int) (Gt 4) (ShowP Id) String -type Age = '(ReadP Int, Gt 4, ShowP, String) +type Age = '(ReadP Int, Gt 4, ShowP Id, String) type Ip9 = '( Map (ReadP Int) (Resplit "\\." Id) -- split String on "." then convert to [Int] - ,(Len >> Same 4) && All (Between 0 255) -- process [Int] and make sure length==4 and each octet is between 0 and 255 + ,(Len >> Same 4) && All (Between 0 255) Id -- process [Int] and make sure length==4 and each octet is between 0 and 255 ,Printfnt 4 "%03d.%03d.%03d.%03d" -- printf [Int] ,String -- input type is string which is also the output type ) @@ -299,13 +303,13 @@ -- prtRefinedT tst1a tst1a :: Monad m => POpts -> RefinedT m ((Int,String),(Int,String)) tst1a opts = withRefined3T @(ReadBase Int 16) @(Between 100 200) @(ShowBase 16) @String opts "a3" - $ \r1 -> withRefined3T @(ReadP Int) @'True @ShowP @String opts "12" + $ \r1 -> withRefined3T @(ReadP Int) @'True @(ShowP Id) @String opts "12" $ \r2 -> return ((r3In r1, r3Out r1), (r3In r2, r3Out r2)) -- prtRefinedTIO tst2a tst2a :: MonadIO m => POpts -> RefinedT m ((Int,String),(Int,String)) tst2a opts = withRefined3TIO @(ReadBase Int 16) @(Stderr "start" |> Between 100 200 >| Stdout "end") @(ShowBase 16) @String opts "a3" - $ \r1 -> withRefined3TIO @(ReadP Int) @'True @ShowP @String opts "12" + $ \r1 -> withRefined3TIO @(ReadP Int) @'True @(ShowP Id) @String opts "12" $ \r2 -> return ((r3In r1, r3Out r1), (r3In r2, r3Out r2)) -- have to use 'i' as we dont hold onto the input