{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE NoStarIsType #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-- | helper methods

module Predicate.Misc (
  -- ** useful type families

    AndT
  , OrT
  , NotT
  , RepeatT
  , IntersperseT
  , LenT
  , FlipT
  , IfT
  , SumT
  , MapT
  , ConsT
  , type (%%)
  , type (%&)
  , type (<%>)
  , ExtractAFromList
  , ExtractAFromTA
  , ExtractTFromTA
  , MaybeT
  , LeftT
  , RightT
  , ThisT
  , ThatT
  , TheseT
  , FnT
  , ApplyConstT
  , JoinT
  , FailWhenT
  , FailUnlessT
  , BetweenT

 -- ** extract values from the type level

  , GetBool(..)
  , GetLen(..)
  , GetThese(..)
  , getThese
  , GetOrdering(..)
  , OrderingP(..)
  , GetOrd(..)
  , nat
  , symb

 -- ** inductive tuples

  , ToITupleC(..)
  , FromITupleC(..)
  , ToITupleListC(..)
  , ReverseITupleC(..)
  , TupleC(..)

 -- ** extract from n-tuple

  , T4_1
  , T4_2
  , T4_3
  , T4_4
  , T5_1
  , T5_2
  , T5_3
  , T5_4
  , T5_5

 -- ** tuple classes

  , ExtractL1C(..)
  , ExtractL2C(..)
  , ExtractL3C(..)
  , ExtractL4C(..)
  , ExtractL5C(..)
  , ExtractL6C(..)
  , ExtractL7C(..)
  , ExtractL8C(..)

 -- ** primes

  , isPrime
  , primeStream
  , primeFactors

  -- ** regular expressions

  , compileRegex
  , ROpt(..)
  , GetROpts(..)
  , RReplace(..)
  , GetReplaceFnSub(..)
  , ReplaceFnSub(..)
  , displayROpts

  -- ** colors

  , SColor(..)
  , GetColor(..)

  -- ** styles

  , SStyle(..)
  , GetStyle(..)

 -- ** miscellaneous

  , SwapC(..)
  , showTK
  , showT
  , showThese
  , prettyOrd
  , unlessNull
  , unlessNullM
  , nullSpace
  , nullIf
  , pureTryTest
  , pureTryTestPred
  , (~>)
  , errorInProgram
  , drawTreeU
  , removeAnsi
  , _Id
  , sum'
  , product'
  , foldMapStrict
  , cycle'
  , cmpOf
  , ifM
  , AssocC(..)
  , simpleAlign
  ) where
import qualified GHC.TypeNats as GN
import GHC.TypeLits (Symbol,Nat,KnownSymbol,KnownNat,ErrorMessage((:$$:),(:<>:)))
import qualified GHC.TypeLits as GL
import Data.Proxy (Proxy(Proxy))
import Data.Typeable (Typeable, typeRep)
import System.Console.Pretty (Color(..), Style(..))
import GHC.Exts (Constraint)
import qualified Text.Regex.PCRE.Heavy as RH
import qualified Text.Regex.PCRE.Light as RL
import qualified Data.Text.Encoding as TE
import qualified Data.Text as T
import GHC.Word (Word8)
import Data.Sequence (Seq)
import Control.Applicative (ZipList)
import Data.Kind (Type)
import Data.These (These(..))
import Data.List.NonEmpty (NonEmpty(..))
import Data.ByteString (ByteString)
import GHC.Stack (HasCallStack)
import Data.Containers.ListUtils (nubOrd)
import Control.Arrow (Arrow((***)),ArrowChoice(left))
import Data.List (foldl', intercalate, unfoldr, isPrefixOf, isInfixOf)
import qualified Safe (headNote)
import Data.Char (isSpace)
import qualified Control.Exception as E
import Data.Tree (Tree(Node))
import Control.Lens
import qualified Data.Semigroup as SG
import Data.List.Lens (suffixed)
-- $setup

-- >>> :set -XDataKinds

-- >>> :set -XTypeApplications

-- >>> :set -XTypeOperators


-- | type level Between

type family BetweenT (s :: Symbol) (a :: Nat) (b :: Nat) (v :: Nat) :: Constraint where
  BetweenT s m n v =
     FailUnlessT (AndT (m GL.<=? v) (v GL.<=? n))
            ('GL.Text s
             ':<>: 'GL.Text " failed"
             ':$$: 'GL.ShowType v
             ':<>: 'GL.Text " is outside the range ["
             ':<>: 'GL.ShowType m
             ':<>: 'GL.Text ".."
             ':<>: 'GL.ShowType n
             ':<>: 'GL.Text "]")

-- | helper method that fails with a msg when True

type family FailWhenT (b :: Bool) (msg :: GL.ErrorMessage) :: Constraint where
  FailWhenT 'False _ = ()
  FailWhenT 'True e = GL.TypeError e

-- | helper method that fails with msg when False

type family FailUnlessT (b :: Bool) (msg :: GL.ErrorMessage) :: Constraint where
  FailUnlessT 'True _ = ()
  FailUnlessT 'False e = GL.TypeError e

-- | typelevel boolean And

type family AndT (b :: Bool) (b1 :: Bool) :: Bool where
  AndT 'False _ = 'False
  AndT 'True b1 = b1

-- | typelevel boolean Or

type family OrT (b :: Bool) (b1 :: Bool) :: Bool where
  OrT 'True _ = 'True
  OrT 'False b1 = b1

-- | typelevel boolean Not

type family NotT (b :: Bool) :: Bool where
  NotT 'True = 'False
  NotT 'False = 'True

-- | get the length of a typelevel container

--

-- >>> getLen @'["abc","def","g"]

-- 3

--

-- >>> getLen @'[]

-- 0

--

-- >>> getLen @(9 ':| '[1,2,3])

-- 4

--

-- >>> getLen @('These 9 "Asfs")

-- 1

--

-- >>> getLen @('This 1)

-- 0

--

class GetLen xs where
  getLen :: Int
instance GetLen '[] where
  getLen :: Int
getLen = Int
0
instance GetLen xs => GetLen (x ': xs) where
  getLen :: Int
getLen = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ GetLen xs => Int
forall k (xs :: k). GetLen xs => Int
getLen @xs
instance GetLen ('Just a) where
  getLen :: Int
getLen = Int
1
instance GetLen 'Nothing where
  getLen :: Int
getLen = Int
0
instance GetLen ('Left a) where
  getLen :: Int
getLen = Int
0
instance GetLen ('Right a) where
  getLen :: Int
getLen = Int
1
instance GetLen ('This a) where
  getLen :: Int
getLen = Int
0
instance GetLen ('That a) where
  getLen :: Int
getLen = Int
1
instance GetLen ('These a b) where
  getLen :: Int
getLen = Int
1
instance GetLen xs => GetLen (x ':| xs) where
  getLen :: Int
getLen = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ GetLen xs => Int
forall k (xs :: k). GetLen xs => Int
getLen @xs

-- | display constructor name for 'These'

showThese :: These a b -> String
showThese :: These a b -> String
showThese = \case
  This {} -> String
"This"
  That {} -> String
"That"
  These {} -> String
"These"

-- | get 'These' from the typelevel

class GetThese (th :: These a b) where
  getThese' :: These () ()
instance GetThese ('This x) where
  getThese' :: These () ()
getThese' = () -> These () ()
forall a b. a -> These a b
This ()
instance GetThese ('That y) where
  getThese' :: These () ()
getThese' = () -> These () ()
forall a b. b -> These a b
That ()
instance GetThese ('These x y) where
  getThese' :: These () ()
getThese' = () -> () -> These () ()
forall a b. a -> b -> These a b
These () ()

-- | get 'These' from the typelevel

getThese :: forall th . GetThese th => These () ()
getThese :: These () ()
getThese = GetThese th => These () ()
forall a b (th :: These a b). GetThese th => These () ()
getThese' @_ @_ @th

-- | get ordering from the typelevel

class GetOrdering (cmp :: Ordering) where
  getOrdering :: Ordering
instance GetOrdering 'LT where
  getOrdering :: Ordering
getOrdering = Ordering
LT
instance GetOrdering 'EQ where
  getOrdering :: Ordering
getOrdering = Ordering
EQ
instance GetOrdering 'GT where
  getOrdering :: Ordering
getOrdering = Ordering
GT

-- | all the ways to compare two values

data OrderingP = CGt | CGe | CEq | CLe | CLt | CNe
  deriving stock (ReadPrec [OrderingP]
ReadPrec OrderingP
Int -> ReadS OrderingP
ReadS [OrderingP]
(Int -> ReadS OrderingP)
-> ReadS [OrderingP]
-> ReadPrec OrderingP
-> ReadPrec [OrderingP]
-> Read OrderingP
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [OrderingP]
$creadListPrec :: ReadPrec [OrderingP]
readPrec :: ReadPrec OrderingP
$creadPrec :: ReadPrec OrderingP
readList :: ReadS [OrderingP]
$creadList :: ReadS [OrderingP]
readsPrec :: Int -> ReadS OrderingP
$creadsPrec :: Int -> ReadS OrderingP
Read, Int -> OrderingP -> ShowS
[OrderingP] -> ShowS
OrderingP -> String
(Int -> OrderingP -> ShowS)
-> (OrderingP -> String)
-> ([OrderingP] -> ShowS)
-> Show OrderingP
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OrderingP] -> ShowS
$cshowList :: [OrderingP] -> ShowS
show :: OrderingP -> String
$cshow :: OrderingP -> String
showsPrec :: Int -> OrderingP -> ShowS
$cshowsPrec :: Int -> OrderingP -> ShowS
Show, OrderingP -> OrderingP -> Bool
(OrderingP -> OrderingP -> Bool)
-> (OrderingP -> OrderingP -> Bool) -> Eq OrderingP
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OrderingP -> OrderingP -> Bool
$c/= :: OrderingP -> OrderingP -> Bool
== :: OrderingP -> OrderingP -> Bool
$c== :: OrderingP -> OrderingP -> Bool
Eq, Int -> OrderingP
OrderingP -> Int
OrderingP -> [OrderingP]
OrderingP -> OrderingP
OrderingP -> OrderingP -> [OrderingP]
OrderingP -> OrderingP -> OrderingP -> [OrderingP]
(OrderingP -> OrderingP)
-> (OrderingP -> OrderingP)
-> (Int -> OrderingP)
-> (OrderingP -> Int)
-> (OrderingP -> [OrderingP])
-> (OrderingP -> OrderingP -> [OrderingP])
-> (OrderingP -> OrderingP -> [OrderingP])
-> (OrderingP -> OrderingP -> OrderingP -> [OrderingP])
-> Enum OrderingP
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: OrderingP -> OrderingP -> OrderingP -> [OrderingP]
$cenumFromThenTo :: OrderingP -> OrderingP -> OrderingP -> [OrderingP]
enumFromTo :: OrderingP -> OrderingP -> [OrderingP]
$cenumFromTo :: OrderingP -> OrderingP -> [OrderingP]
enumFromThen :: OrderingP -> OrderingP -> [OrderingP]
$cenumFromThen :: OrderingP -> OrderingP -> [OrderingP]
enumFrom :: OrderingP -> [OrderingP]
$cenumFrom :: OrderingP -> [OrderingP]
fromEnum :: OrderingP -> Int
$cfromEnum :: OrderingP -> Int
toEnum :: Int -> OrderingP
$ctoEnum :: Int -> OrderingP
pred :: OrderingP -> OrderingP
$cpred :: OrderingP -> OrderingP
succ :: OrderingP -> OrderingP
$csucc :: OrderingP -> OrderingP
Enum, OrderingP
OrderingP -> OrderingP -> Bounded OrderingP
forall a. a -> a -> Bounded a
maxBound :: OrderingP
$cmaxBound :: OrderingP
minBound :: OrderingP
$cminBound :: OrderingP
Bounded)

-- | extract 'OrderingP' from the typelevel

class GetOrd (k :: OrderingP) where
  getOrd :: Ord a => (String, a -> a -> Bool)

instance GetOrd 'CGt where getOrd :: (String, a -> a -> Bool)
getOrd = (String
">", a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>))
instance GetOrd 'CGe where getOrd :: (String, a -> a -> Bool)
getOrd = (String
">=",a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>=))
instance GetOrd 'CEq where getOrd :: (String, a -> a -> Bool)
getOrd = (String
"==",a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==))
instance GetOrd 'CLe where getOrd :: (String, a -> a -> Bool)
getOrd = (String
"<=",a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<=))
instance GetOrd 'CLt where getOrd :: (String, a -> a -> Bool)
getOrd = (String
"<", a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<))
instance GetOrd 'CNe where getOrd :: (String, a -> a -> Bool)
getOrd = (String
"/=",a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(/=))

-- | show the type as a string

showT :: forall (t :: Type) . Typeable t => String
showT :: String
showT = TypeRep -> String
forall a. Show a => a -> String
show (Proxy t -> TypeRep
forall k (proxy :: k -> Type) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy t
forall k (t :: k). Proxy t
Proxy @t))

-- | Repeat an expression n times

type family RepeatT (n :: Nat) (p :: k) :: [k] where
  RepeatT 0 _p = GL.TypeError ('GL.Text "RepeatT is not defined for zero")
  RepeatT 1 p = p ': '[]
  RepeatT n p = p ': RepeatT (n GN.- 1) p

-- | type operator for appending a type level symbol

type s <%> t = GL.AppendSymbol s t
infixr 7 <%>

-- | Intersperse a symbol inside a list of symbols

type family IntersperseT (s :: Symbol) (xs :: [Symbol]) :: Symbol where
  IntersperseT _s '[] = ""
  IntersperseT _s '[x] = x
  IntersperseT s (x ': y ': xs) = x <%> s <%> IntersperseT s (y ': xs)

-- | length of a type level list

type family LenT (xs :: [k]) :: Nat where
  LenT '[] = 0
  LenT (_x ': xs) = 1 GN.+ LenT xs

-- | takes a flat n-tuple and creates an inductive tuple. see 'Predicate.Data.ReadShow.PrintT'

--

-- >>> toITupleC (123,'x',False,"abc")

-- (123,('x',(False,("abc",()))))

--

-- >>> toITupleC (123,'x')

-- (123,('x',()))

--

class ToITupleC x where
  type ToITupleP x
  toITupleC :: x -> ToITupleP x
instance (GL.TypeError ('GL.Text "ToITupleC: invalid empty tuple")) => ToITupleC () where
  type ToITupleP () = ()
  toITupleC :: () -> ToITupleP ()
toITupleC () = ()
instance ToITupleC (a,b) where
  type ToITupleP (a,b) = (a,(b,()))
  toITupleC :: (a, b) -> ToITupleP (a, b)
toITupleC (a
a,b
b) = (a
a,(b
b,()))
instance ToITupleC (a,b,c) where
  type ToITupleP (a,b,c) = (a,(b,(c,())))
  toITupleC :: (a, b, c) -> ToITupleP (a, b, c)
toITupleC (a
a,b
b,c
c) = (a
a,(b
b,(c
c,())))
instance ToITupleC (a,b,c,d) where
  type ToITupleP (a,b,c,d) = (a,(b,(c,(d,()))))
  toITupleC :: (a, b, c, d) -> ToITupleP (a, b, c, d)
toITupleC (a
a,b
b,c
c,d
d) = (a
a,(b
b,(c
c,(d
d,()))))
instance ToITupleC (a,b,c,d,e) where
  type ToITupleP (a,b,c,d,e) = (a,(b,(c,(d,(e,())))))
  toITupleC :: (a, b, c, d, e) -> ToITupleP (a, b, c, d, e)
toITupleC (a
a,b
b,c
c,d
d,e
e) = (a
a,(b
b,(c
c,(d
d,(e
e,())))))
instance ToITupleC (a,b,c,d,e,f) where
  type ToITupleP (a,b,c,d,e,f) = (a,(b,(c,(d,(e,(f,()))))))
  toITupleC :: (a, b, c, d, e, f) -> ToITupleP (a, b, c, d, e, f)
toITupleC (a
a,b
b,c
c,d
d,e
e,f
f) = (a
a,(b
b,(c
c,(d
d,(e
e,(f
f,()))))))
instance ToITupleC (a,b,c,d,e,f,g) where
  type ToITupleP (a,b,c,d,e,f,g) = (a,(b,(c,(d,(e,(f,(g,())))))))
  toITupleC :: (a, b, c, d, e, f, g) -> ToITupleP (a, b, c, d, e, f, g)
toITupleC (a
a,b
b,c
c,d
d,e
e,f
f,g
g) = (a
a,(b
b,(c
c,(d
d,(e
e,(f
f,(g
g,())))))))
instance ToITupleC (a,b,c,d,e,f,g,h) where
  type ToITupleP (a,b,c,d,e,f,g,h) = (a,(b,(c,(d,(e,(f,(g,(h,()))))))))
  toITupleC :: (a, b, c, d, e, f, g, h) -> ToITupleP (a, b, c, d, e, f, g, h)
toITupleC (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h) = (a
a,(b
b,(c
c,(d
d,(e
e,(f
f,(g
g,(h
h,()))))))))
instance ToITupleC (a,b,c,d,e,f,g,h,i) where
  type ToITupleP (a,b,c,d,e,f,g,h,i) = (a,(b,(c,(d,(e,(f,(g,(h,(i,())))))))))
  toITupleC :: (a, b, c, d, e, f, g, h, i)
-> ToITupleP (a, b, c, d, e, f, g, h, i)
toITupleC (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i) = (a
a,(b
b,(c
c,(d
d,(e
e,(f
f,(g
g,(h
h,(i
i,())))))))))
instance ToITupleC (a,b,c,d,e,f,g,h,i,j) where
  type ToITupleP (a,b,c,d,e,f,g,h,i,j) = (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,()))))))))))
  toITupleC :: (a, b, c, d, e, f, g, h, i, j)
-> ToITupleP (a, b, c, d, e, f, g, h, i, j)
toITupleC (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i,j
j) = (a
a,(b
b,(c
c,(d
d,(e
e,(f
f,(g
g,(h
h,(i
i,(j
j,()))))))))))
instance ToITupleC (a,b,c,d,e,f,g,h,i,j,k) where
  type ToITupleP (a,b,c,d,e,f,g,h,i,j,k) = (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,())))))))))))
  toITupleC :: (a, b, c, d, e, f, g, h, i, j, k)
-> ToITupleP (a, b, c, d, e, f, g, h, i, j, k)
toITupleC (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i,j
j,k
k) = (a
a,(b
b,(c
c,(d
d,(e
e,(f
f,(g
g,(h
h,(i
i,(j
j,(k
k,())))))))))))
instance ToITupleC (a,b,c,d,e,f,g,h,i,j,k,l) where
  type ToITupleP (a,b,c,d,e,f,g,h,i,j,k,l) = (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,(l,()))))))))))))
  toITupleC :: (a, b, c, d, e, f, g, h, i, j, k, l)
-> ToITupleP (a, b, c, d, e, f, g, h, i, j, k, l)
toITupleC (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i,j
j,k
k,l
l) = (a
a,(b
b,(c
c,(d
d,(e
e,(f
f,(g
g,(h
h,(i
i,(j
j,(k
k,(l
l,()))))))))))))

-- | takes an inductive tuple and creates a flat n-tuple

--

-- >>> fromITupleC (123,('x',(False,("abc",()))))

-- (123,'x',False,"abc")

--

-- >>> fromITupleC (123,('x',()))

-- (123,'x')

--

class FromITupleC x where
  type FromITupleP x
  fromITupleC :: x -> FromITupleP x
instance FromITupleC () where
  type FromITupleP () = ()
  fromITupleC :: () -> FromITupleP ()
fromITupleC () = ()
instance FromITupleC (a,()) where
  type FromITupleP (a,()) = a
  fromITupleC :: (a, ()) -> FromITupleP (a, ())
fromITupleC (a
a,()) = a
FromITupleP (a, ())
a
instance FromITupleC (a,(b,())) where
  type FromITupleP (a,(b,())) = (a,b)
  fromITupleC :: (a, (b, ())) -> FromITupleP (a, (b, ()))
fromITupleC (a
a,(b
b,())) = (a
a,b
b)
instance FromITupleC (a,(b,(c,()))) where
  type FromITupleP (a,(b,(c,()))) = (a,b,c)
  fromITupleC :: (a, (b, (c, ()))) -> FromITupleP (a, (b, (c, ())))
fromITupleC (a
a,(b
b,(c
c,()))) = (a
a,b
b,c
c)
instance FromITupleC (a,(b,(c,(d,())))) where
  type FromITupleP (a,(b,(c,(d,())))) = (a,b,c,d)
  fromITupleC :: (a, (b, (c, (d, ())))) -> FromITupleP (a, (b, (c, (d, ()))))
fromITupleC (a
a,(b
b,(c
c,(d
d,())))) = (a
a,b
b,c
c,d
d)
instance FromITupleC (a,(b,(c,(d,(e,()))))) where
  type FromITupleP (a,(b,(c,(d,(e,()))))) = (a,b,c,d,e)
  fromITupleC :: (a, (b, (c, (d, (e, ())))))
-> FromITupleP (a, (b, (c, (d, (e, ())))))
fromITupleC (a
a,(b
b,(c
c,(d
d,(e
e,()))))) = (a
a,b
b,c
c,d
d,e
e)
instance FromITupleC (a,(b,(c,(d,(e,(f,())))))) where
  type FromITupleP (a,(b,(c,(d,(e,(f,())))))) = (a,b,c,d,e,f)
  fromITupleC :: (a, (b, (c, (d, (e, (f, ()))))))
-> FromITupleP (a, (b, (c, (d, (e, (f, ()))))))
fromITupleC (a
a,(b
b,(c
c,(d
d,(e
e,(f
f,())))))) = (a
a,b
b,c
c,d
d,e
e,f
f)
instance FromITupleC (a,(b,(c,(d,(e,(f,(g,()))))))) where
  type FromITupleP (a,(b,(c,(d,(e,(f,(g,()))))))) = (a,b,c,d,e,f,g)
  fromITupleC :: (a, (b, (c, (d, (e, (f, (g, ())))))))
-> FromITupleP (a, (b, (c, (d, (e, (f, (g, ())))))))
fromITupleC (a
a,(b
b,(c
c,(d
d,(e
e,(f
f,(g
g,()))))))) = (a
a,b
b,c
c,d
d,e
e,f
f,g
g)
instance FromITupleC (a,(b,(c,(d,(e,(f,(g,(h,())))))))) where
  type FromITupleP (a,(b,(c,(d,(e,(f,(g,(h,())))))))) = (a,b,c,d,e,f,g,h)
  fromITupleC :: (a, (b, (c, (d, (e, (f, (g, (h, ()))))))))
-> FromITupleP (a, (b, (c, (d, (e, (f, (g, (h, ()))))))))
fromITupleC (a
a,(b
b,(c
c,(d
d,(e
e,(f
f,(g
g,(h
h,())))))))) = (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h)
instance FromITupleC (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) where
  type FromITupleP (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) = (a,b,c,d,e,f,g,h,i)
  fromITupleC :: (a, (b, (c, (d, (e, (f, (g, (h, (i, ())))))))))
-> FromITupleP (a, (b, (c, (d, (e, (f, (g, (h, (i, ())))))))))
fromITupleC (a
a,(b
b,(c
c,(d
d,(e
e,(f
f,(g
g,(h
h,(i
i,()))))))))) = (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i)
instance FromITupleC (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) where
  type FromITupleP (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) = (a,b,c,d,e,f,g,h,i,j)
  fromITupleC :: (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, ()))))))))))
-> FromITupleP (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, ()))))))))))
fromITupleC (a
a,(b
b,(c
c,(d
d,(e
e,(f
f,(g
g,(h
h,(i
i,(j
j,())))))))))) = (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i,j
j)
instance FromITupleC (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,()))))))))))) where
  type FromITupleP (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,()))))))))))) = (a,b,c,d,e,f,g,h,i,j,k)
  fromITupleC :: (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, ())))))))))))
-> FromITupleP
     (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, ())))))))))))
fromITupleC (a
a,(b
b,(c
c,(d
d,(e
e,(f
f,(g
g,(h
h,(i
i,(j
j,(k
k,()))))))))))) = (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i,j
j,k
k)
instance FromITupleC (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,(l,())))))))))))) where
  type FromITupleP (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,(k,(l,())))))))))))) = (a,b,c,d,e,f,g,h,i,j,k,l)
  fromITupleC :: (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, ()))))))))))))
-> FromITupleP
     (a, (b, (c, (d, (e, (f, (g, (h, (i, (j, (k, (l, ()))))))))))))
fromITupleC (a
a,(b
b,(c
c,(d
d,(e
e,(f
f,(g
g,(h
h,(i
i,(j
j,(k
k,(l
l,())))))))))))) = (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i,j
j,k
k,l
l)

-- | takes a list of size @n@ and converts it to an inductive tuple. see 'Predicate.Data.ReadShow.PrintL'

--

-- >>> toITupleListC @4 [10,12,13,1]

-- Right (10,(12,(13,(1,()))))

--

-- >>> toITupleListC @2 ["ab","cc"]

-- Right ("ab",("cc",()))

--

-- >>> toITupleListC @10 [10,12,13,1]

-- Left "toITupleListC: expected exactly 10 values"

--

-- >>> toITupleListC @2 [10,12,13,1]

-- Left "toITupleListC: expected exactly 2 values"

--

class ToITupleListC (n :: Nat) (a :: Type) where
  type ToITupleListP n a
  toITupleListC :: [a] -> Either String (ToITupleListP n a)
instance (GL.TypeError ('GL.Text "ToITupleListC: inductive tuple cannot be empty")) => ToITupleListC 0 a where
  type ToITupleListP 0 a = ()
  toITupleListC :: [a] -> Either String (ToITupleListP 0 a)
toITupleListC [a]
_ = String -> Either String ()
forall a b. a -> Either a b
Left String
"ToITupleListC 0: shouldnt be called"
instance ToITupleListC 1 a where
  type ToITupleListP 1 a = (a,())
  toITupleListC :: [a] -> Either String (ToITupleListP 1 a)
toITupleListC [a
a] = (a, ()) -> Either String (a, ())
forall a b. b -> Either a b
Right (a
a,())
  toITupleListC [a]
_ = String -> Either String (a, ())
forall a b. a -> Either a b
Left String
"toITupleListC: expected exactly 1 value"
instance ToITupleListC 2 a where
  type ToITupleListP 2 a = (a,(a,()))
  toITupleListC :: [a] -> Either String (ToITupleListP 2 a)
toITupleListC [a
a,a
b] = (a, (a, ())) -> Either String (a, (a, ()))
forall a b. b -> Either a b
Right (a
a,(a
b,()))
  toITupleListC [a]
_ = String -> Either String (a, (a, ()))
forall a b. a -> Either a b
Left String
"toITupleListC: expected exactly 2 values"
instance ToITupleListC 3 a where
  type ToITupleListP 3 a = (a,(a,(a,())))
  toITupleListC :: [a] -> Either String (ToITupleListP 3 a)
toITupleListC [a
a,a
b,a
c] = (a, (a, (a, ()))) -> Either String (a, (a, (a, ())))
forall a b. b -> Either a b
Right (a
a,(a
b,(a
c,())))
  toITupleListC [a]
_ = String -> Either String (a, (a, (a, ())))
forall a b. a -> Either a b
Left String
"toITupleListC: expected exactly 3 values"
instance ToITupleListC 4 a where
  type ToITupleListP 4 a = (a,(a,(a,(a,()))))
  toITupleListC :: [a] -> Either String (ToITupleListP 4 a)
toITupleListC [a
a,a
b,a
c,a
d] = (a, (a, (a, (a, ())))) -> Either String (a, (a, (a, (a, ()))))
forall a b. b -> Either a b
Right (a
a,(a
b,(a
c,(a
d,()))))
  toITupleListC [a]
_ = String -> Either String (a, (a, (a, (a, ()))))
forall a b. a -> Either a b
Left String
"toITupleListC: expected exactly 4 values"
instance ToITupleListC 5 a where
  type ToITupleListP 5 a = (a,(a,(a,(a,(a,())))))
  toITupleListC :: [a] -> Either String (ToITupleListP 5 a)
toITupleListC [a
a,a
b,a
c,a
d,a
e] = (a, (a, (a, (a, (a, ())))))
-> Either String (a, (a, (a, (a, (a, ())))))
forall a b. b -> Either a b
Right (a
a,(a
b,(a
c,(a
d,(a
e,())))))
  toITupleListC [a]
_ = String -> Either String (a, (a, (a, (a, (a, ())))))
forall a b. a -> Either a b
Left String
"toITupleListC: expected exactly 5 values"
instance ToITupleListC 6 a where
  type ToITupleListP 6 a = (a,(a,(a,(a,(a,(a,()))))))
  toITupleListC :: [a] -> Either String (ToITupleListP 6 a)
toITupleListC [a
a,a
b,a
c,a
d,a
e,a
f] = (a, (a, (a, (a, (a, (a, ()))))))
-> Either String (a, (a, (a, (a, (a, (a, ()))))))
forall a b. b -> Either a b
Right (a
a,(a
b,(a
c,(a
d,(a
e,(a
f,()))))))
  toITupleListC [a]
_ = String -> Either String (a, (a, (a, (a, (a, (a, ()))))))
forall a b. a -> Either a b
Left String
"toITupleListC: expected exactly 6 values"
instance ToITupleListC 7 a where
  type ToITupleListP 7 a = (a,(a,(a,(a,(a,(a,(a,())))))))
  toITupleListC :: [a] -> Either String (ToITupleListP 7 a)
toITupleListC [a
a,a
b,a
c,a
d,a
e,a
f,a
g] = (a, (a, (a, (a, (a, (a, (a, ())))))))
-> Either String (a, (a, (a, (a, (a, (a, (a, ())))))))
forall a b. b -> Either a b
Right (a
a,(a
b,(a
c,(a
d,(a
e,(a
f,(a
g,())))))))
  toITupleListC [a]
_ = String -> Either String (a, (a, (a, (a, (a, (a, (a, ())))))))
forall a b. a -> Either a b
Left String
"toITupleListC: expected exactly 7 values"
instance ToITupleListC 8 a where
  type ToITupleListP 8 a = (a,(a,(a,(a,(a,(a,(a,(a,()))))))))
  toITupleListC :: [a] -> Either String (ToITupleListP 8 a)
toITupleListC [a
a,a
b,a
c,a
d,a
e,a
f,a
g,a
h] = (a, (a, (a, (a, (a, (a, (a, (a, ()))))))))
-> Either String (a, (a, (a, (a, (a, (a, (a, (a, ()))))))))
forall a b. b -> Either a b
Right (a
a,(a
b,(a
c,(a
d,(a
e,(a
f,(a
g,(a
h,()))))))))
  toITupleListC [a]
_ = String -> Either String (a, (a, (a, (a, (a, (a, (a, (a, ()))))))))
forall a b. a -> Either a b
Left String
"toITupleListC: expected exactly 8 values"
instance ToITupleListC 9 a where
  type ToITupleListP 9 a = (a,(a,(a,(a,(a,(a,(a,(a,(a,())))))))))
  toITupleListC :: [a] -> Either String (ToITupleListP 9 a)
toITupleListC [a
a,a
b,a
c,a
d,a
e,a
f,a
g,a
h,a
i] = (a, (a, (a, (a, (a, (a, (a, (a, (a, ())))))))))
-> Either String (a, (a, (a, (a, (a, (a, (a, (a, (a, ())))))))))
forall a b. b -> Either a b
Right (a
a,(a
b,(a
c,(a
d,(a
e,(a
f,(a
g,(a
h,(a
i,())))))))))
  toITupleListC [a]
_ = String
-> Either String (a, (a, (a, (a, (a, (a, (a, (a, (a, ())))))))))
forall a b. a -> Either a b
Left String
"toITupleListC: expected exactly 9 values"
instance ToITupleListC 10 a where
  type ToITupleListP 10 a = (a,(a,(a,(a,(a,(a,(a,(a,(a,(a,()))))))))))
  toITupleListC :: [a] -> Either String (ToITupleListP 10 a)
toITupleListC [a
a,a
b,a
c,a
d,a
e,a
f,a
g,a
h,a
i,a
j] = (a, (a, (a, (a, (a, (a, (a, (a, (a, (a, ()))))))))))
-> Either
     String (a, (a, (a, (a, (a, (a, (a, (a, (a, (a, ()))))))))))
forall a b. b -> Either a b
Right (a
a,(a
b,(a
c,(a
d,(a
e,(a
f,(a
g,(a
h,(a
i,(a
j,()))))))))))
  toITupleListC [a]
_ = String
-> Either
     String (a, (a, (a, (a, (a, (a, (a, (a, (a, (a, ()))))))))))
forall a b. a -> Either a b
Left String
"toITupleListC: expected exactly 10 values"
instance ToITupleListC 11 a where
  type ToITupleListP 11 a = (a,(a,(a,(a,(a,(a,(a,(a,(a,(a,(a,())))))))))))
  toITupleListC :: [a] -> Either String (ToITupleListP 11 a)
toITupleListC [a
a,a
b,a
c,a
d,a
e,a
f,a
g,a
h,a
i,a
j,a
k] = (a, (a, (a, (a, (a, (a, (a, (a, (a, (a, (a, ())))))))))))
-> Either
     String (a, (a, (a, (a, (a, (a, (a, (a, (a, (a, (a, ())))))))))))
forall a b. b -> Either a b
Right (a
a,(a
b,(a
c,(a
d,(a
e,(a
f,(a
g,(a
h,(a
i,(a
j,(a
k,())))))))))))
  toITupleListC [a]
_ = String
-> Either
     String (a, (a, (a, (a, (a, (a, (a, (a, (a, (a, (a, ())))))))))))
forall a b. a -> Either a b
Left String
"toITupleListC: expected exactly 11 values"
instance ToITupleListC 12 a where
  type ToITupleListP 12 a = (a,(a,(a,(a,(a,(a,(a,(a,(a,(a,(a,(a,()))))))))))))
  toITupleListC :: [a] -> Either String (ToITupleListP 12 a)
toITupleListC [a
a,a
b,a
c,a
d,a
e,a
f,a
g,a
h,a
i,a
j,a
k,a
l] = (a, (a, (a, (a, (a, (a, (a, (a, (a, (a, (a, (a, ()))))))))))))
-> Either
     String
     (a, (a, (a, (a, (a, (a, (a, (a, (a, (a, (a, (a, ()))))))))))))
forall a b. b -> Either a b
Right (a
a,(a
b,(a
c,(a
d,(a
e,(a
f,(a
g,(a
h,(a
i,(a
j,(a
k,(a
l,()))))))))))))
  toITupleListC [a]
_ = String
-> Either
     String
     (a, (a, (a, (a, (a, (a, (a, (a, (a, (a, (a, (a, ()))))))))))))
forall a b. a -> Either a b
Left String
"toITupleListC: expected exactly 12 values"

-- | reverse an inductive tuple

class ReverseITupleC (x :: Type) (xs :: Type) (ys :: Type) where
  type ReverseITupleT x xs ys
  reverseITupleC :: x -> xs -> ys -> ReverseITupleT x xs ys
instance ReverseITupleC x () ys  where
  type ReverseITupleT x () ys = (x,ys)
  reverseITupleC :: x -> () -> ys -> ReverseITupleT x () ys
reverseITupleC x
x () ys
ys = (x
x,ys
ys)
instance ReverseITupleC w ws (x, ys) => ReverseITupleC x (w,ws) ys  where
  type ReverseITupleT x (w,ws) ys = (ReverseITupleT w ws (x,ys))
  reverseITupleC :: x -> (w, ws) -> ys -> ReverseITupleT x (w, ws) ys
reverseITupleC x
x (w
w,ws
ws) ys
ys = w -> ws -> (x, ys) -> ReverseITupleT w ws (x, ys)
forall x xs ys.
ReverseITupleC x xs ys =>
x -> xs -> ys -> ReverseITupleT x xs ys
reverseITupleC w
w ws
ws (x
x,ys
ys)

-- | type level application: see 'Predicate.Core.$' which works for type level functions

type family (p :: k -> k1) %% (q :: k) :: k1 where
  p %% q = p q

infixl 9 %%

-- | reverse type level application: see 'Predicate.Core.&' which works for type level functions

type family (p :: k) %& (q :: k -> k1) :: k1 where
  p %& q = q p

infixr 9 %&

-- | 'flip' at the type level

type family FlipT (d :: k1 -> k -> k2) (p :: k) (q :: k1) :: k2 where
  FlipT d p q = d q p

-- | 'if' at the type level

type family IfT (b :: Bool) (t :: k) (f :: k) :: k where
  IfT 'True t _f = t
  IfT 'False _t f = f

-- | 'sum' at the type level for a list of 'Nat'

type family SumT (ns :: [Nat]) :: Nat where
  SumT '[] = 0
  SumT (n ': ns) = n GL.+ SumT ns

-- only works if you use ADTs not type synonyms

-- | 'map' at the type level

type family MapT (f :: k -> k1) (xs :: [k]) :: [k1] where
  MapT _f '[] = '[]
  MapT f (x ': xs) = f x ': MapT f xs

-- | Extract @a@ from a list-like container

type family ConsT s where
  ConsT [a] = a
  ConsT (ZipList a) = a
  ConsT T.Text = Char
  ConsT ByteString = Word8
  ConsT (Seq a) = a
  ConsT s  = GL.TypeError (
      'GL.Text "invalid ConsT instance"
      ':$$: 'GL.Text "s = "
      ':<>: 'GL.ShowType s)

-- | extract @opts@ part of 4 tuple from the type level for use with 'Predicate.Refined2.Refined2'

type family T4_1 x where
  T4_1 '(opts,_,_,_) = opts
-- | extract @ip@ part of 4 tuple from the type level for use with 'Predicate.Refined2.Refined2'

type family T4_2 x where
  T4_2 '(_,ip,_,_) = ip
-- | extract @op@ part of 4 tuple from the type level for use with 'Predicate.Refined2.Refined2'

type family T4_3 x where
  T4_3 '(_,_,op,_) = op
-- | extract @i@ part of 4 tuple from the type level for use with 'Predicate.Refined2.Refined2'

type family T4_4 x where
  T4_4 '(_,_,_,i) = i

-- | extract @opts@ part of 5 tuple from the type level for use with 'Predicate.Refined3.Refined3'

type family T5_1 x where
  T5_1 '(opts,_,_,_,_) = opts
-- | extract @ip@ part of 5 tuple from the type level for use with 'Predicate.Refined3.Refined3'

type family T5_2 x where
  T5_2 '(_,ip,_,_,_) = ip
-- | extract @op@ part of 5 tuple from the type level for use with 'Predicate.Refined3.Refined3'

type family T5_3 x where
  T5_3 '(_,_,op,_,_) = op
-- | extract @fmt@ part of 5 tuple from the type level for use with 'Predicate.Refined3.Refined3'

type family T5_4 x where
  T5_4 '(_,_,_,fmt,_) = fmt
-- | extract @i@ part of 5 tuple from the type level for use with 'Predicate.Refined3.Refined3'

type family T5_5 x where
  T5_5 '(_,_,_,_,i) = i

-- | type family to extract @a@ from @t a@

type family ExtractAFromTA (ta :: Type) :: Type where
  ExtractAFromTA (_t a) = a
  ExtractAFromTA z = GL.TypeError (
      'GL.Text "ExtractAFromTA: expected (t a) but found something else"
      ':$$: 'GL.Text "t a = "
      ':<>: 'GL.ShowType z)

-- | type family to extract @t@ from @t a@

type family ExtractTFromTA (ta :: Type) :: (Type -> Type) where
  ExtractTFromTA (t _a) = t
  ExtractTFromTA z = GL.TypeError (
      'GL.Text "ExtractTFromTA: expected (t a) but found something else"
      ':$$: 'GL.Text "t a = "
      ':<>: 'GL.ShowType z)

-- | type family to extract @a@ from a list of @a@

type family ExtractAFromList (as :: Type) :: Type where
  ExtractAFromList [a] = a
  ExtractAFromList z = GL.TypeError (
      'GL.Text "ExtractAFromList: expected [a] but found something else"
      ':$$: 'GL.Text "as = "
      ':<>: 'GL.ShowType z)

-- | extract @a@ from a Maybe container

type family MaybeT mb where
  MaybeT (Maybe a) = a
  MaybeT o = GL.TypeError (
      'GL.Text "MaybeT: expected 'Maybe a' "
      ':$$: 'GL.Text "o = "
      ':<>: 'GL.ShowType o)

-- | extract @a@ from a Either container

type family LeftT lr where
  LeftT (Either a _) = a
  LeftT o = GL.TypeError (
      'GL.Text "LeftT: expected 'Either a b' "
      ':$$: 'GL.Text "o = "
      ':<>: 'GL.ShowType o)

-- | extract @b@ from a Either container

type family RightT lr where
  RightT (Either _a b) = b
  RightT o = GL.TypeError (
      'GL.Text "RightT: expected 'Either a b' "
      ':$$: 'GL.Text "o = "
      ':<>: 'GL.ShowType o)

-- | extract @a@ from a These container

type family ThisT lr where
  ThisT (These a _b) = a
  ThisT o = GL.TypeError (
      'GL.Text "ThisT: expected 'These a b' "
      ':$$: 'GL.Text "o = "
      ':<>: 'GL.ShowType o)

-- | extract @b@ from a These container

type family ThatT lr where
  ThatT (These _a b) = b
  ThatT o = GL.TypeError (
      'GL.Text "ThatT: expected 'These a b' "
      ':$$: 'GL.Text "o = "
      ':<>: 'GL.ShowType o)

-- | extract @a@ and @b@ from a These container

type family TheseT lr where
  TheseT (These a b) = (a,b)
  TheseT o = GL.TypeError (
      'GL.Text "TheseT: expected 'These a b' "
      ':$$: 'GL.Text "o = "
      ':<>: 'GL.ShowType o)

-- | extract @b@ from an arrow type

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)

-- | combine two containers

type family JoinT x y where
  JoinT (t a) (t b) = t (a, b)
  JoinT ta tb = GL.TypeError (
       'GL.Text "JoinT: expected (t a) (t b) but found something else"
       ':$$: 'GL.Text "t a = "
       ':<>: 'GL.ShowType ta
       ':$$: 'GL.Text "t b = "
       ':<>: 'GL.ShowType tb)

-- | replace the type inside a container using @b@

type family ApplyConstT (ta :: Type) (b :: Type) :: Type where
  ApplyConstT (t _) 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)

-- | fail with a programmer error

errorInProgram :: HasCallStack => String -> x
errorInProgram :: String -> x
errorInProgram String
s = String -> x
forall a. HasCallStack => String -> a
error (String -> x) -> String -> x
forall a b. (a -> b) -> a -> b
$ String
"programmer error:" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s

-- | boolean implication

--

-- >>> True ~> False

-- False

--

-- >>> True ~> True

-- True

--

-- >>> False ~> False

-- True

--

-- >>> False ~> True

-- True

--

(~>) :: Bool -> Bool -> Bool
Bool
p ~> :: Bool -> Bool -> Bool
~> Bool
q = Bool -> Bool
not Bool
p Bool -> Bool -> Bool
|| Bool
q
infixr 1 ~>

-- | extract element 1 from a n-tuple

class ExtractL1C (tp :: Type) where
  type ExtractL1T tp
  extractL1C :: tp -> ExtractL1T tp
instance ExtractL1C (a,b) where
  type ExtractL1T (a,b) = a
  extractL1C :: (a, b) -> ExtractL1T (a, b)
extractL1C (a
a,b
_) = a
ExtractL1T (a, b)
a
instance ExtractL1C (a,b,c) where
  type ExtractL1T (a,b,c) = a
  extractL1C :: (a, b, c) -> ExtractL1T (a, b, c)
extractL1C (a
a,b
_,c
_) = a
ExtractL1T (a, b, c)
a
instance ExtractL1C (a,b,c,d) where
  type ExtractL1T (a,b,c,d) = a
  extractL1C :: (a, b, c, d) -> ExtractL1T (a, b, c, d)
extractL1C (a
a,b
_,c
_,d
_) = a
ExtractL1T (a, b, c, d)
a
instance ExtractL1C (a,b,c,d,e) where
  type ExtractL1T (a,b,c,d,e) = a
  extractL1C :: (a, b, c, d, e) -> ExtractL1T (a, b, c, d, e)
extractL1C (a
a,b
_,c
_,d
_,e
_) = a
ExtractL1T (a, b, c, d, e)
a
instance ExtractL1C (a,b,c,d,e,f) where
  type ExtractL1T (a,b,c,d,e,f) = a
  extractL1C :: (a, b, c, d, e, f) -> ExtractL1T (a, b, c, d, e, f)
extractL1C (a
a,b
_,c
_,d
_,e
_,f
_) = a
ExtractL1T (a, b, c, d, e, f)
a
instance ExtractL1C (a,b,c,d,e,f,g) where
  type ExtractL1T (a,b,c,d,e,f,g) = a
  extractL1C :: (a, b, c, d, e, f, g) -> ExtractL1T (a, b, c, d, e, f, g)
extractL1C (a
a,b
_,c
_,d
_,e
_,f
_,g
_) = a
ExtractL1T (a, b, c, d, e, f, g)
a
instance ExtractL1C (a,b,c,d,e,f,g,h) where
  type ExtractL1T (a,b,c,d,e,f,g,h) = a
  extractL1C :: (a, b, c, d, e, f, g, h) -> ExtractL1T (a, b, c, d, e, f, g, h)
extractL1C (a
a,b
_,c
_,d
_,e
_,f
_,g
_,h
_) = a
ExtractL1T (a, b, c, d, e, f, g, h)
a

-- | extract element 2 from a n-tuple

class ExtractL2C (tp :: Type) where
  type ExtractL2T tp
  extractL2C :: tp -> ExtractL2T tp
instance ExtractL2C (a,b) where
  type ExtractL2T (a,b) = b
  extractL2C :: (a, b) -> ExtractL2T (a, b)
extractL2C (a
_,b
b) = b
ExtractL2T (a, b)
b
instance ExtractL2C (a,b,c) where
  type ExtractL2T (a,b,c) = b
  extractL2C :: (a, b, c) -> ExtractL2T (a, b, c)
extractL2C (a
_,b
b,c
_) = b
ExtractL2T (a, b, c)
b
instance ExtractL2C (a,b,c,d) where
  type ExtractL2T (a,b,c,d) = b
  extractL2C :: (a, b, c, d) -> ExtractL2T (a, b, c, d)
extractL2C (a
_,b
b,c
_,d
_) = b
ExtractL2T (a, b, c, d)
b
instance ExtractL2C (a,b,c,d,e) where
  type ExtractL2T (a,b,c,d,e) = b
  extractL2C :: (a, b, c, d, e) -> ExtractL2T (a, b, c, d, e)
extractL2C (a
_,b
b,c
_,d
_,e
_) = b
ExtractL2T (a, b, c, d, e)
b
instance ExtractL2C (a,b,c,d,e,f) where
  type ExtractL2T (a,b,c,d,e,f) = b
  extractL2C :: (a, b, c, d, e, f) -> ExtractL2T (a, b, c, d, e, f)
extractL2C (a
_,b
b,c
_,d
_,e
_,f
_) = b
ExtractL2T (a, b, c, d, e, f)
b
instance ExtractL2C (a,b,c,d,e,f,g) where
  type ExtractL2T (a,b,c,d,e,f,g) = b
  extractL2C :: (a, b, c, d, e, f, g) -> ExtractL2T (a, b, c, d, e, f, g)
extractL2C (a
_,b
b,c
_,d
_,e
_,f
_,g
_) = b
ExtractL2T (a, b, c, d, e, f, g)
b
instance ExtractL2C (a,b,c,d,e,f,g,h) where
  type ExtractL2T (a,b,c,d,e,f,g,h) = b
  extractL2C :: (a, b, c, d, e, f, g, h) -> ExtractL2T (a, b, c, d, e, f, g, h)
extractL2C (a
_,b
b,c
_,d
_,e
_,f
_,g
_,h
_) = b
ExtractL2T (a, b, c, d, e, f, g, h)
b

-- | extract element 3 from a n-tuple

class ExtractL3C (tp :: Type) where
  type ExtractL3T tp
  extractL3C :: tp -> ExtractL3T tp
instance ExtractL3C (a,b) where
  type ExtractL3T (a,b) = GL.TypeError ('GL.Text "L3 invalid for 2-tuples")
  extractL3C :: (a, b) -> ExtractL3T (a, b)
extractL3C (a, b)
_ = String -> (TypeError ...)
forall x. HasCallStack => String -> x
errorInProgram String
"L3 invalid for 2-tuples"
instance ExtractL3C (a,b,c) where
  type ExtractL3T (a,b,c) = c
  extractL3C :: (a, b, c) -> ExtractL3T (a, b, c)
extractL3C (a
_,b
_,c
c) = c
ExtractL3T (a, b, c)
c
instance ExtractL3C (a,b,c,d) where
  type ExtractL3T (a,b,c,d) = c
  extractL3C :: (a, b, c, d) -> ExtractL3T (a, b, c, d)
extractL3C (a
_,b
_,c
c,d
_) = c
ExtractL3T (a, b, c, d)
c
instance ExtractL3C (a,b,c,d,e) where
  type ExtractL3T (a,b,c,d,e) = c
  extractL3C :: (a, b, c, d, e) -> ExtractL3T (a, b, c, d, e)
extractL3C (a
_,b
_,c
c,d
_,e
_) = c
ExtractL3T (a, b, c, d, e)
c
instance ExtractL3C (a,b,c,d,e,f) where
  type ExtractL3T (a,b,c,d,e,f) = c
  extractL3C :: (a, b, c, d, e, f) -> ExtractL3T (a, b, c, d, e, f)
extractL3C (a
_,b
_,c
c,d
_,e
_,f
_) = c
ExtractL3T (a, b, c, d, e, f)
c
instance ExtractL3C (a,b,c,d,e,f,g) where
  type ExtractL3T (a,b,c,d,e,f,g) = c
  extractL3C :: (a, b, c, d, e, f, g) -> ExtractL3T (a, b, c, d, e, f, g)
extractL3C (a
_,b
_,c
c,d
_,e
_,f
_,g
_) = c
ExtractL3T (a, b, c, d, e, f, g)
c
instance ExtractL3C (a,b,c,d,e,f,g,h) where
  type ExtractL3T (a,b,c,d,e,f,g,h) = c
  extractL3C :: (a, b, c, d, e, f, g, h) -> ExtractL3T (a, b, c, d, e, f, g, h)
extractL3C (a
_,b
_,c
c,d
_,e
_,f
_,g
_,h
_) = c
ExtractL3T (a, b, c, d, e, f, g, h)
c

-- | extract element 4 from a n-tuple

class ExtractL4C (tp :: Type) where
  type ExtractL4T tp
  extractL4C :: tp -> ExtractL4T tp
instance ExtractL4C (a,b) where
  type ExtractL4T (a,b) = GL.TypeError ('GL.Text "L4 invalid for 2-tuples")
  extractL4C :: (a, b) -> ExtractL4T (a, b)
extractL4C (a, b)
_ = String -> (TypeError ...)
forall x. HasCallStack => String -> x
errorInProgram String
"L4 invalid for 2-tuples"
instance ExtractL4C (a,b,c) where
  type ExtractL4T (a,b,c) = GL.TypeError ('GL.Text "L4 invalid for 3-tuples")
  extractL4C :: (a, b, c) -> ExtractL4T (a, b, c)
extractL4C (a, b, c)
_ = String -> (TypeError ...)
forall x. HasCallStack => String -> x
errorInProgram String
"L4 invalid for 3-tuples"
instance ExtractL4C (a,b,c,d) where
  type ExtractL4T (a,b,c,d) = d
  extractL4C :: (a, b, c, d) -> ExtractL4T (a, b, c, d)
extractL4C (a
_,b
_,c
_,d
d) = d
ExtractL4T (a, b, c, d)
d
instance ExtractL4C (a,b,c,d,e) where
  type ExtractL4T (a,b,c,d,e) = d
  extractL4C :: (a, b, c, d, e) -> ExtractL4T (a, b, c, d, e)
extractL4C (a
_,b
_,c
_,d
d,e
_) = d
ExtractL4T (a, b, c, d, e)
d
instance ExtractL4C (a,b,c,d,e,f) where
  type ExtractL4T (a,b,c,d,e,f) = d
  extractL4C :: (a, b, c, d, e, f) -> ExtractL4T (a, b, c, d, e, f)
extractL4C (a
_,b
_,c
_,d
d,e
_,f
_) = d
ExtractL4T (a, b, c, d, e, f)
d
instance ExtractL4C (a,b,c,d,e,f,g) where
  type ExtractL4T (a,b,c,d,e,f,g) = d
  extractL4C :: (a, b, c, d, e, f, g) -> ExtractL4T (a, b, c, d, e, f, g)
extractL4C (a
_,b
_,c
_,d
d,e
_,f
_,g
_) = d
ExtractL4T (a, b, c, d, e, f, g)
d
instance ExtractL4C (a,b,c,d,e,f,g,h) where
  type ExtractL4T (a,b,c,d,e,f,g,h) = d
  extractL4C :: (a, b, c, d, e, f, g, h) -> ExtractL4T (a, b, c, d, e, f, g, h)
extractL4C (a
_,b
_,c
_,d
d,e
_,f
_,g
_,h
_) = d
ExtractL4T (a, b, c, d, e, f, g, h)
d

-- | extract element 5 from a n-tuple

class ExtractL5C (tp :: Type) where
  type ExtractL5T tp
  extractL5C :: tp -> ExtractL5T tp
instance ExtractL5C (a,b) where
  type ExtractL5T (a,b) = GL.TypeError ('GL.Text "L5 invalid for 2-tuples")
  extractL5C :: (a, b) -> ExtractL5T (a, b)
extractL5C (a, b)
_ = String -> (TypeError ...)
forall x. HasCallStack => String -> x
errorInProgram String
"L5 invalid for 2-tuples"
instance ExtractL5C (a,b,c) where
  type ExtractL5T (a,b,c) = GL.TypeError ('GL.Text "L5 invalid for 3-tuples")
  extractL5C :: (a, b, c) -> ExtractL5T (a, b, c)
extractL5C (a, b, c)
_ = String -> (TypeError ...)
forall x. HasCallStack => String -> x
errorInProgram String
"L5 invalid for 3-tuples"
instance ExtractL5C (a,b,c,d) where
  type ExtractL5T (a,b,c,d) = GL.TypeError ('GL.Text "L5 invalid for 4-tuples")
  extractL5C :: (a, b, c, d) -> ExtractL5T (a, b, c, d)
extractL5C (a, b, c, d)
_ = String -> (TypeError ...)
forall x. HasCallStack => String -> x
errorInProgram String
"L5 invalid for 4-tuples"
instance ExtractL5C (a,b,c,d,e) where
  type ExtractL5T (a,b,c,d,e) = e
  extractL5C :: (a, b, c, d, e) -> ExtractL5T (a, b, c, d, e)
extractL5C (a
_,b
_,c
_,d
_,e
e) = e
ExtractL5T (a, b, c, d, e)
e
instance ExtractL5C (a,b,c,d,e,f) where
  type ExtractL5T (a,b,c,d,e,f) = e
  extractL5C :: (a, b, c, d, e, f) -> ExtractL5T (a, b, c, d, e, f)
extractL5C (a
_,b
_,c
_,d
_,e
e,f
_) = e
ExtractL5T (a, b, c, d, e, f)
e
instance ExtractL5C (a,b,c,d,e,f,g) where
  type ExtractL5T (a,b,c,d,e,f,g) = e
  extractL5C :: (a, b, c, d, e, f, g) -> ExtractL5T (a, b, c, d, e, f, g)
extractL5C (a
_,b
_,c
_,d
_,e
e,f
_,g
_) = e
ExtractL5T (a, b, c, d, e, f, g)
e
instance ExtractL5C (a,b,c,d,e,f,g,h) where
  type ExtractL5T (a,b,c,d,e,f,g,h) = e
  extractL5C :: (a, b, c, d, e, f, g, h) -> ExtractL5T (a, b, c, d, e, f, g, h)
extractL5C (a
_,b
_,c
_,d
_,e
e,f
_,g
_,h
_) = e
ExtractL5T (a, b, c, d, e, f, g, h)
e

-- | extract element 6 from a n-tuple

class ExtractL6C (tp :: Type) where
  type ExtractL6T tp
  extractL6C :: tp -> ExtractL6T tp
instance ExtractL6C (a,b) where
  type ExtractL6T (a,b) = GL.TypeError ('GL.Text "L6 invalid for 2-tuples")
  extractL6C :: (a, b) -> ExtractL6T (a, b)
extractL6C (a, b)
_ = String -> (TypeError ...)
forall x. HasCallStack => String -> x
errorInProgram String
"L6 invalid for 2-tuples"
instance ExtractL6C (a,b,c) where
  type ExtractL6T (a,b,c) = GL.TypeError ('GL.Text "L6 invalid for 3-tuples")
  extractL6C :: (a, b, c) -> ExtractL6T (a, b, c)
extractL6C (a, b, c)
_ = String -> (TypeError ...)
forall x. HasCallStack => String -> x
errorInProgram String
"L6 invalid for 3-tuples"
instance ExtractL6C (a,b,c,d) where
  type ExtractL6T (a,b,c,d) = GL.TypeError ('GL.Text "L6 invalid for 4-tuples")
  extractL6C :: (a, b, c, d) -> ExtractL6T (a, b, c, d)
extractL6C (a, b, c, d)
_ = String -> (TypeError ...)
forall x. HasCallStack => String -> x
errorInProgram String
"L6 invalid for 4-tuples"
instance ExtractL6C (a,b,c,d,e) where
  type ExtractL6T (a,b,c,d,e) = GL.TypeError ('GL.Text "L6 invalid for 5-tuples")
  extractL6C :: (a, b, c, d, e) -> ExtractL6T (a, b, c, d, e)
extractL6C (a, b, c, d, e)
_ = String -> (TypeError ...)
forall x. HasCallStack => String -> x
errorInProgram String
"L6 invalid for 5-tuples"
instance ExtractL6C (a,b,c,d,e,f) where
  type ExtractL6T (a,b,c,d,e,f) = f
  extractL6C :: (a, b, c, d, e, f) -> ExtractL6T (a, b, c, d, e, f)
extractL6C (a
_,b
_,c
_,d
_,e
_,f
f) = f
ExtractL6T (a, b, c, d, e, f)
f
instance ExtractL6C (a,b,c,d,e,f,g) where
  type ExtractL6T (a,b,c,d,e,f,g) = f
  extractL6C :: (a, b, c, d, e, f, g) -> ExtractL6T (a, b, c, d, e, f, g)
extractL6C (a
_,b
_,c
_,d
_,e
_,f
f,g
_) = f
ExtractL6T (a, b, c, d, e, f, g)
f
instance ExtractL6C (a,b,c,d,e,f,g,h) where
  type ExtractL6T (a,b,c,d,e,f,g,h) = f
  extractL6C :: (a, b, c, d, e, f, g, h) -> ExtractL6T (a, b, c, d, e, f, g, h)
extractL6C (a
_,b
_,c
_,d
_,e
_,f
f,g
_,h
_) = f
ExtractL6T (a, b, c, d, e, f, g, h)
f

-- | extract element 7 from a n-tuple

class ExtractL7C (tp :: Type) where
  type ExtractL7T tp
  extractL7C :: tp -> ExtractL7T tp
instance ExtractL7C (a,b) where
  type ExtractL7T (a,b) = GL.TypeError ('GL.Text "L7 invalid for 2-tuples")
  extractL7C :: (a, b) -> ExtractL7T (a, b)
extractL7C (a, b)
_ = String -> (TypeError ...)
forall x. HasCallStack => String -> x
errorInProgram String
"L7 invalid for 2-tuples"
instance ExtractL7C (a,b,c) where
  type ExtractL7T (a,b,c) = GL.TypeError ('GL.Text "L7 invalid for 3-tuples")
  extractL7C :: (a, b, c) -> ExtractL7T (a, b, c)
extractL7C (a, b, c)
_ = String -> (TypeError ...)
forall x. HasCallStack => String -> x
errorInProgram String
"L7 invalid for 3-tuples"
instance ExtractL7C (a,b,c,d) where
  type ExtractL7T (a,b,c,d) = GL.TypeError ('GL.Text "L7 invalid for 4-tuples")
  extractL7C :: (a, b, c, d) -> ExtractL7T (a, b, c, d)
extractL7C (a, b, c, d)
_ = String -> (TypeError ...)
forall x. HasCallStack => String -> x
errorInProgram String
"L7 invalid for 4-tuples"
instance ExtractL7C (a,b,c,d,e) where
  type ExtractL7T (a,b,c,d,e) = GL.TypeError ('GL.Text "L7 invalid for 5-tuples")
  extractL7C :: (a, b, c, d, e) -> ExtractL7T (a, b, c, d, e)
extractL7C (a, b, c, d, e)
_ = String -> (TypeError ...)
forall x. HasCallStack => String -> x
errorInProgram String
"L7 invalid for 5-tuples"
instance ExtractL7C (a,b,c,d,e,f) where
  type ExtractL7T (a,b,c,d,e,f) = GL.TypeError ('GL.Text "L7 invalid for 6-tuples")
  extractL7C :: (a, b, c, d, e, f) -> ExtractL7T (a, b, c, d, e, f)
extractL7C (a, b, c, d, e, f)
_ = String -> (TypeError ...)
forall x. HasCallStack => String -> x
errorInProgram String
"L7 invalid for 6-tuples"
instance ExtractL7C (a,b,c,d,e,f,g) where
  type ExtractL7T (a,b,c,d,e,f,g) = g
  extractL7C :: (a, b, c, d, e, f, g) -> ExtractL7T (a, b, c, d, e, f, g)
extractL7C (a
_,b
_,c
_,d
_,e
_,f
_,g
g) = g
ExtractL7T (a, b, c, d, e, f, g)
g
instance ExtractL7C (a,b,c,d,e,f,g,h) where
  type ExtractL7T (a,b,c,d,e,f,g,h) = g
  extractL7C :: (a, b, c, d, e, f, g, h) -> ExtractL7T (a, b, c, d, e, f, g, h)
extractL7C (a
_,b
_,c
_,d
_,e
_,f
_,g
g,h
_) = g
ExtractL7T (a, b, c, d, e, f, g, h)
g

-- | extract element 8 from a n-tuple

class ExtractL8C (tp :: Type) where
  type ExtractL8T tp
  extractL8C :: tp -> ExtractL8T tp
instance ExtractL8C (a,b) where
  type ExtractL8T (a,b) = GL.TypeError ('GL.Text "L8 invalid for 2-tuples")
  extractL8C :: (a, b) -> ExtractL8T (a, b)
extractL8C (a, b)
_ = String -> (TypeError ...)
forall x. HasCallStack => String -> x
errorInProgram String
"L8 invalid for 2-tuples"
instance ExtractL8C (a,b,c) where
  type ExtractL8T (a,b,c) = GL.TypeError ('GL.Text "L8 invalid for 3-tuples")
  extractL8C :: (a, b, c) -> ExtractL8T (a, b, c)
extractL8C (a, b, c)
_ = String -> (TypeError ...)
forall x. HasCallStack => String -> x
errorInProgram String
"L8 invalid for 3-tuples"
instance ExtractL8C (a,b,c,d) where
  type ExtractL8T (a,b,c,d) = GL.TypeError ('GL.Text "L8 invalid for 4-tuples")
  extractL8C :: (a, b, c, d) -> ExtractL8T (a, b, c, d)
extractL8C (a, b, c, d)
_ = String -> (TypeError ...)
forall x. HasCallStack => String -> x
errorInProgram String
"L8 invalid for 4-tuples"
instance ExtractL8C (a,b,c,d,e) where
  type ExtractL8T (a,b,c,d,e) = GL.TypeError ('GL.Text "L8 invalid for 5-tuples")
  extractL8C :: (a, b, c, d, e) -> ExtractL8T (a, b, c, d, e)
extractL8C (a, b, c, d, e)
_ = String -> (TypeError ...)
forall x. HasCallStack => String -> x
errorInProgram String
"L8 invalid for 5-tuples"
instance ExtractL8C (a,b,c,d,e,f) where
  type ExtractL8T (a,b,c,d,e,f) = GL.TypeError ('GL.Text "L8 invalid for 6-tuples")
  extractL8C :: (a, b, c, d, e, f) -> ExtractL8T (a, b, c, d, e, f)
extractL8C (a, b, c, d, e, f)
_ = String -> (TypeError ...)
forall x. HasCallStack => String -> x
errorInProgram String
"L8 invalid for 6-tuples"
instance ExtractL8C (a,b,c,d,e,f,g) where
  type ExtractL8T (a,b,c,d,e,f,g) = GL.TypeError ('GL.Text "L8 invalid for 7-tuples")
  extractL8C :: (a, b, c, d, e, f, g) -> ExtractL8T (a, b, c, d, e, f, g)
extractL8C (a, b, c, d, e, f, g)
_ = String -> (TypeError ...)
forall x. HasCallStack => String -> x
errorInProgram String
"L8 invalid for 7-tuples"
instance ExtractL8C (a,b,c,d,e,f,g,h) where
  type ExtractL8T (a,b,c,d,e,f,g,h) = h
  extractL8C :: (a, b, c, d, e, f, g, h) -> ExtractL8T (a, b, c, d, e, f, g, h)
extractL8C (a
_,b
_,c
_,d
_,e
_,f
_,g
_,h
h) = h
ExtractL8T (a, b, c, d, e, f, g, h)
h

-- | try to convert a list to a n-tuple

class TupleC (n :: Nat) (a :: Type) where
  type TupleT n a
  getTupleC :: [a] -> Maybe (TupleT n a)

-- | convert a list of at least 2 elements to a 2-tuple

instance TupleC 2 a where
  type TupleT 2 a = (a,a)
  getTupleC :: [a] -> Maybe (TupleT 2 a)
getTupleC = \case
                a
a:a
b:[a]
_ -> (a, a) -> Maybe (a, a)
forall a. a -> Maybe a
Just (a
a,a
b)
                [a]
_ -> Maybe (TupleT 2 a)
forall a. Maybe a
Nothing

-- | convert a list of at least 3 elements to a 3-tuple

instance TupleC 3 a where
  type TupleT 3 a = (a,a,a)
  getTupleC :: [a] -> Maybe (TupleT 3 a)
getTupleC = \case
                a
a:a
b:a
c:[a]
_ -> (a, a, a) -> Maybe (a, a, a)
forall a. a -> Maybe a
Just (a
a,a
b,a
c)
                [a]
_ -> Maybe (TupleT 3 a)
forall a. Maybe a
Nothing

-- | convert a list of at least 4 elements to a 4-tuple

instance TupleC 4 a where
  type TupleT 4 a = (a,a,a,a)
  getTupleC :: [a] -> Maybe (TupleT 4 a)
getTupleC = \case
                a
a:a
b:a
c:a
d:[a]
_ -> (a, a, a, a) -> Maybe (a, a, a, a)
forall a. a -> Maybe a
Just (a
a,a
b,a
c,a
d)
                [a]
_ -> Maybe (TupleT 4 a)
forall a. Maybe a
Nothing

-- | convert a list of at least 5 elements to a 5-tuple

instance TupleC 5 a where
  type TupleT 5 a = (a,a,a,a,a)
  getTupleC :: [a] -> Maybe (TupleT 5 a)
getTupleC = \case
                a
a:a
b:a
c:a
d:a
e:[a]
_ -> (a, a, a, a, a) -> Maybe (a, a, a, a, a)
forall a. a -> Maybe a
Just (a
a,a
b,a
c,a
d,a
e)
                [a]
_ -> Maybe (TupleT 5 a)
forall a. Maybe a
Nothing

-- | convert a list of at least 6 elements to a 6-tuple

instance TupleC 6 a where
  type TupleT 6 a = (a,a,a,a,a,a)
  getTupleC :: [a] -> Maybe (TupleT 6 a)
getTupleC = \case
                a
a:a
b:a
c:a
d:a
e:a
f:[a]
_ -> (a, a, a, a, a, a) -> Maybe (a, a, a, a, a, a)
forall a. a -> Maybe a
Just (a
a,a
b,a
c,a
d,a
e,a
f)
                [a]
_ -> Maybe (TupleT 6 a)
forall a. Maybe a
Nothing

-- | convert a list of at least 7 elements to a 7-tuple

instance TupleC 7 a where
  type TupleT 7 a = (a,a,a,a,a,a,a)
  getTupleC :: [a] -> Maybe (TupleT 7 a)
getTupleC = \case
                a
a:a
b:a
c:a
d:a
e:a
f:a
g:[a]
_ -> (a, a, a, a, a, a, a) -> Maybe (a, a, a, a, a, a, a)
forall a. a -> Maybe a
Just (a
a,a
b,a
c,a
d,a
e,a
f,a
g)
                [a]
_ -> Maybe (TupleT 7 a)
forall a. Maybe a
Nothing

-- | convert a list of at least 8 elements to a 8-tuple

instance TupleC 8 a where
  type TupleT 8 a = (a,a,a,a,a,a,a,a)
  getTupleC :: [a] -> Maybe (TupleT 8 a)
getTupleC = \case
                a
a:a
b:a
c:a
d:a
e:a
f:a
g:a
h:[a]
_ -> (a, a, a, a, a, a, a, a) -> Maybe (a, a, a, a, a, a, a, a)
forall a. a -> Maybe a
Just (a
a,a
b,a
c,a
d,a
e,a
f,a
g,a
h)
                [a]
_ -> Maybe (TupleT 8 a)
forall a. Maybe a
Nothing

-- | convert a list of at least 9 elements to a 9-tuple

instance TupleC 9 a where
  type TupleT 9 a = (a,a,a,a,a,a,a,a,a)
  getTupleC :: [a] -> Maybe (TupleT 9 a)
getTupleC = \case
                a
a:a
b:a
c:a
d:a
e:a
f:a
g:a
h:a
i:[a]
_ -> (a, a, a, a, a, a, a, a, a) -> Maybe (a, a, a, a, a, a, a, a, a)
forall a. a -> Maybe a
Just (a
a,a
b,a
c,a
d,a
e,a
f,a
g,a
h,a
i)
                [a]
_ -> Maybe (TupleT 9 a)
forall a. Maybe a
Nothing

-- | convert a list of at least 10 elements to a 10-tuple

instance TupleC 10 a where
  type TupleT 10 a = (a,a,a,a,a,a,a,a,a,a)
  getTupleC :: [a] -> Maybe (TupleT 10 a)
getTupleC = \case
                a
a:a
b:a
c:a
d:a
e:a
f:a
g:a
h:a
i:a
j:[a]
_ -> (a, a, a, a, a, a, a, a, a, a)
-> Maybe (a, a, a, a, a, a, a, a, a, a)
forall a. a -> Maybe a
Just (a
a,a
b,a
c,a
d,a
e,a
f,a
g,a
h,a
i,a
j)
                [a]
_ -> Maybe (TupleT 10 a)
forall a. Maybe a
Nothing

-- | convert a list of at least 11 elements to a 11-tuple

instance TupleC 11 a where
  type TupleT 11 a = (a,a,a,a,a,a,a,a,a,a,a)
  getTupleC :: [a] -> Maybe (TupleT 11 a)
getTupleC = \case
                a
a:a
b:a
c:a
d:a
e:a
f:a
g:a
h:a
i:a
j:a
k:[a]
_ -> (a, a, a, a, a, a, a, a, a, a, a)
-> Maybe (a, a, a, a, a, a, a, a, a, a, a)
forall a. a -> Maybe a
Just (a
a,a
b,a
c,a
d,a
e,a
f,a
g,a
h,a
i,a
j,a
k)
                [a]
_ -> Maybe (TupleT 11 a)
forall a. Maybe a
Nothing

-- | convert a list of at least 12 elements to a 12-tuple

instance TupleC 12 a where
  type TupleT 12 a = (a,a,a,a,a,a,a,a,a,a,a,a)
  getTupleC :: [a] -> Maybe (TupleT 12 a)
getTupleC = \case
                a
a:a
b:a
c:a
d:a
e:a
f:a
g:a
h:a
i:a
j:a
k:a
l:[a]
_ -> (a, a, a, a, a, a, a, a, a, a, a, a)
-> Maybe (a, a, a, a, a, a, a, a, a, a, a, a)
forall a. a -> Maybe a
Just (a
a,a
b,a
c,a
d,a
e,a
f,a
g,a
h,a
i,a
j,a
k,a
l)
                [a]
_ -> Maybe (TupleT 12 a)
forall a. Maybe a
Nothing

-- | prime predicate

--

-- >>> isPrime 7

-- True

--

-- >>> isPrime 6

-- False

--

isPrime :: Int -> Bool
isPrime :: Int -> Bool
isPrime Int
n = Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2 Bool -> Bool -> Bool
&& (Int -> Bool) -> [Int] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Int -> Bool) -> (Int -> Int) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Int
n) (Int
2Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int
3,Int
5 .. Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Int) -> (Int -> Double) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Floating Double => Double -> Double
forall a. Floating a => a -> a
sqrt @Double (Double -> Double) -> (Int -> Double) -> Int -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1])

-- | prime factors

--

-- >>> primeFactors 100

-- [2,2,5,5]

--

-- >>> primeFactors 123

-- [3,41]

--

primeFactors :: Integer -> [Integer]
primeFactors :: Integer -> [Integer]
primeFactors Integer
n =
  case [Integer]
factors of
    [] -> [Integer
n]
    [Integer]
_  -> [Integer]
factors [Integer] -> [Integer] -> [Integer]
forall a. [a] -> [a] -> [a]
++ Integer -> [Integer]
primeFactors (Integer
n Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` String -> [Integer] -> Integer
forall a. HasCallStack => String -> [a] -> a
Safe.headNote String
"primeFactors" [Integer]
factors)
  where factors :: [Integer]
factors = Int -> [Integer] -> [Integer]
forall a. Int -> [a] -> [a]
take Int
1 ([Integer] -> [Integer]) -> [Integer] -> [Integer]
forall a b. (a -> b) -> a -> b
$ (Integer -> Bool) -> [Integer] -> [Integer]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Integer
x -> (Integer
n Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
x) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0) [Integer
2 .. Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1]

-- | primes stream

--

-- >>> take 10 primeStream

-- [2,3,5,7,11,13,17,19,23,29]

--

primeStream :: [Integer]
primeStream :: [Integer]
primeStream = Integer
2 Integer -> [Integer] -> [Integer]
forall a. a -> [a] -> [a]
: Integer
3 Integer -> [Integer] -> [Integer]
forall a. a -> [a] -> [a]
: Integer
5 Integer -> [Integer] -> [Integer]
forall a. a -> [a] -> [a]
: [Integer]
primes'
  where
    isPrime' :: [t] -> t -> Bool
isPrime' [] t
_ = String -> Bool
forall x. HasCallStack => String -> x
errorInProgram String
"primes is empty"
    isPrime' (t
p:[t]
ps) t
n = t
pt -> t -> t
forall a. Num a => a -> a -> a
*t
p t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> t
n Bool -> Bool -> Bool
|| t
n t -> t -> t
forall a. Integral a => a -> a -> a
`rem` t
p t -> t -> Bool
forall a. Eq a => a -> a -> Bool
/= t
0 Bool -> Bool -> Bool
&& [t] -> t -> Bool
isPrime' [t]
ps t
n
    primes' :: [Integer]
primes' = Integer
7 Integer -> [Integer] -> [Integer]
forall a. a -> [a] -> [a]
: (Integer -> Bool) -> [Integer] -> [Integer]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Integer] -> Integer -> Bool
forall t. Integral t => [t] -> t -> Bool
isPrime' [Integer]
primes') ((Integer -> Integer -> Integer)
-> Integer -> [Integer] -> [Integer]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+) Integer
11 ([Integer] -> [Integer]) -> [Integer] -> [Integer]
forall a b. (a -> b) -> a -> b
$ [Integer] -> [Integer]
forall a. [a] -> [a]
cycle' [Integer
2,Integer
4,Integer
2,Integer
4,Integer
6,Integer
2,Integer
6,Integer
4])

-- | similar to 'cycle' but if the list is empty will return an empty list

cycle' :: [a] -> [a]
cycle' :: [a] -> [a]
cycle' [] = []
cycle' [a]
xs = [a]
xs' where xs' :: [a]
xs' = [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
xs'

-- | pretty print 'Ordering'

prettyOrd :: Ordering -> String
prettyOrd :: Ordering -> String
prettyOrd = \case
              Ordering
LT -> String
"<"
              Ordering
EQ -> String
"="
              Ordering
GT -> String
">"

-- | show the kind as a string

showTK :: forall r . Typeable r => String
showTK :: String
showTK = TypeRep -> String
forall a. Show a => a -> String
show (Proxy r -> TypeRep
forall k (proxy :: k -> Type) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy r
forall k (t :: k). Proxy t
Proxy @r))

-- | get a Nat from the typelevel

--

-- >>> nat @14

-- 14

--

nat :: forall n a
  . ( KnownNat n
    , Num a
    ) => a
nat :: a
nat = Integer -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Integer
GL.natVal (Proxy n
forall k (t :: k). Proxy t
Proxy @n))

-- | gets the Symbol from the typelevel

--

-- >>> symb @"abc"

-- "abc"

--

symb :: forall s . KnownSymbol s => String
symb :: String
symb = Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> Type).
KnownSymbol n =>
proxy n -> String
GL.symbolVal (Proxy s
forall k (t :: k). Proxy t
Proxy @s)

-- | get a list of Nats from the typelevel

--

-- >>> getNats @'[10,12,1]

-- [10,12,1]

class GetNats (as :: [Nat]) where
  getNats :: [Int]
instance GetNats '[] where
  getNats :: [Int]
getNats = []
instance ( KnownNat n
         , GetNats ns
         ) => GetNats (n ': ns) where
  getNats :: [Int]
getNats = forall a. (KnownNat n, Num a) => a
forall (n :: Nat) a. (KnownNat n, Num a) => a
nat @n Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: GetNats ns => [Int]
forall (as :: [Nat]). GetNats as => [Int]
getNats @ns

-- | get a list of Symbols from the typelevel

--

-- >>> getSymbs @'["abc","def","g"]

-- ["abc","def","g"]

--

class GetSymbs (ns :: [Symbol]) where
  getSymbs :: [String]
instance GetSymbs '[] where
  getSymbs :: [String]
getSymbs = []
instance ( KnownSymbol s
         , GetSymbs ss
         ) => GetSymbs (s ': ss) where
  getSymbs :: [String]
getSymbs = KnownSymbol s => String
forall (s :: Symbol). KnownSymbol s => String
symb @s String -> [String] -> [String]
forall a. a -> [a] -> [a]
: GetSymbs ss => [String]
forall (ns :: [Symbol]). GetSymbs ns => [String]
getSymbs @ss

-- | get 'Bool' from the typelevel

class GetBool (a :: Bool) where
  getBool :: Bool
instance GetBool 'True where
  getBool :: Bool
getBool = Bool
True
instance GetBool 'False where
  getBool :: Bool
getBool = Bool
False

-- | compile a regex using type level options

compileRegex :: forall rs . GetROpts rs
  => String
  -> String
  -> Either (String, String) RH.Regex
compileRegex :: String -> String -> Either (String, String) Regex
compileRegex String
nm String
s
  | String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
s = (String, String) -> Either (String, String) Regex
forall a b. a -> Either a b
Left (String
"Regex cannot be empty",String
nm)
  | Bool
otherwise =
      let rs :: ([String], [PCREOption])
rs = GetROpts rs => ([String], [PCREOption])
forall (os :: [ROpt]). GetROpts os => ([String], [PCREOption])
getROpts @rs
          mm :: String
mm = String
nm String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ([String], [PCREOption]) -> String
forall a. Show a => a -> String
show ([String], [PCREOption])
rs
          f :: String -> (String, String)
f String
e = (String
"Regex failed to compile", String
mm String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
e)
      in (String -> (String, String))
-> Either String Regex -> Either (String, String) Regex
forall (a :: Type -> Type -> Type) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left String -> (String, String)
f (ByteString -> [PCREOption] -> Either String Regex
RH.compileM (Text -> ByteString
TE.encodeUtf8 (String -> Text
T.pack String
s)) (([String], [PCREOption]) -> [PCREOption]
forall a b. (a, b) -> b
snd ([String], [PCREOption])
rs))

-- | Regex options for Rescan Resplit Re etc

data ROpt =
    Anchored -- ^ Force pattern anchoring

  | AutoCallout -- ^ Compile automatic callouts

{-
  | BsrAnycrlf -- ^ \R matches only CR, LF, or CrlF
  | BsrUnicode -- ^ \R matches all Unicode line endings
-}
  | Caseless -- ^ Do caseless matching

  | DollarEndonly -- ^ dollar not to match newline at end

  | Dotall -- ^ matches anything including NL

  | Dupnames -- ^ Allow duplicate names for subpatterns

  | Extended -- ^ Ignore whitespace and # comments

  | Extra -- ^ PCRE extra features (not much use currently)

  | Firstline -- ^ Force matching to be before newline

  | Multiline -- ^ caret and dollar match newlines within data

{-
  | NewlineAny -- ^ Recognize any Unicode newline sequence
  | NewlineAnycrlf -- ^ Recognize CR, LF, and CrlF as newline sequences
-}
  | NewlineCr -- ^ Set CR as the newline sequence

  | NewlineCrlf -- ^ Set CrlF as the newline sequence

  | NewlineLf -- ^ Set LF as the newline sequence

  | NoAutoCapture -- ^ Disable numbered capturing parentheses (named ones available)

  | Ungreedy -- ^ Invert greediness of quantifiers

  | Utf8 -- ^ Run in UTF--8 mode

  | NoUtf8Check -- ^ Do not check the pattern for UTF-8 validity

  deriving stock (ReadPrec [ROpt]
ReadPrec ROpt
Int -> ReadS ROpt
ReadS [ROpt]
(Int -> ReadS ROpt)
-> ReadS [ROpt] -> ReadPrec ROpt -> ReadPrec [ROpt] -> Read ROpt
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ROpt]
$creadListPrec :: ReadPrec [ROpt]
readPrec :: ReadPrec ROpt
$creadPrec :: ReadPrec ROpt
readList :: ReadS [ROpt]
$creadList :: ReadS [ROpt]
readsPrec :: Int -> ReadS ROpt
$creadsPrec :: Int -> ReadS ROpt
Read, Int -> ROpt -> ShowS
[ROpt] -> ShowS
ROpt -> String
(Int -> ROpt -> ShowS)
-> (ROpt -> String) -> ([ROpt] -> ShowS) -> Show ROpt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ROpt] -> ShowS
$cshowList :: [ROpt] -> ShowS
show :: ROpt -> String
$cshow :: ROpt -> String
showsPrec :: Int -> ROpt -> ShowS
$cshowsPrec :: Int -> ROpt -> ShowS
Show, ROpt -> ROpt -> Bool
(ROpt -> ROpt -> Bool) -> (ROpt -> ROpt -> Bool) -> Eq ROpt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ROpt -> ROpt -> Bool
$c/= :: ROpt -> ROpt -> Bool
== :: ROpt -> ROpt -> Bool
$c== :: ROpt -> ROpt -> Bool
Eq, Eq ROpt
Eq ROpt
-> (ROpt -> ROpt -> Ordering)
-> (ROpt -> ROpt -> Bool)
-> (ROpt -> ROpt -> Bool)
-> (ROpt -> ROpt -> Bool)
-> (ROpt -> ROpt -> Bool)
-> (ROpt -> ROpt -> ROpt)
-> (ROpt -> ROpt -> ROpt)
-> Ord ROpt
ROpt -> ROpt -> Bool
ROpt -> ROpt -> Ordering
ROpt -> ROpt -> ROpt
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ROpt -> ROpt -> ROpt
$cmin :: ROpt -> ROpt -> ROpt
max :: ROpt -> ROpt -> ROpt
$cmax :: ROpt -> ROpt -> ROpt
>= :: ROpt -> ROpt -> Bool
$c>= :: ROpt -> ROpt -> Bool
> :: ROpt -> ROpt -> Bool
$c> :: ROpt -> ROpt -> Bool
<= :: ROpt -> ROpt -> Bool
$c<= :: ROpt -> ROpt -> Bool
< :: ROpt -> ROpt -> Bool
$c< :: ROpt -> ROpt -> Bool
compare :: ROpt -> ROpt -> Ordering
$ccompare :: ROpt -> ROpt -> Ordering
$cp1Ord :: Eq ROpt
Ord, Int -> ROpt
ROpt -> Int
ROpt -> [ROpt]
ROpt -> ROpt
ROpt -> ROpt -> [ROpt]
ROpt -> ROpt -> ROpt -> [ROpt]
(ROpt -> ROpt)
-> (ROpt -> ROpt)
-> (Int -> ROpt)
-> (ROpt -> Int)
-> (ROpt -> [ROpt])
-> (ROpt -> ROpt -> [ROpt])
-> (ROpt -> ROpt -> [ROpt])
-> (ROpt -> ROpt -> ROpt -> [ROpt])
-> Enum ROpt
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ROpt -> ROpt -> ROpt -> [ROpt]
$cenumFromThenTo :: ROpt -> ROpt -> ROpt -> [ROpt]
enumFromTo :: ROpt -> ROpt -> [ROpt]
$cenumFromTo :: ROpt -> ROpt -> [ROpt]
enumFromThen :: ROpt -> ROpt -> [ROpt]
$cenumFromThen :: ROpt -> ROpt -> [ROpt]
enumFrom :: ROpt -> [ROpt]
$cenumFrom :: ROpt -> [ROpt]
fromEnum :: ROpt -> Int
$cfromEnum :: ROpt -> Int
toEnum :: Int -> ROpt
$ctoEnum :: Int -> ROpt
pred :: ROpt -> ROpt
$cpred :: ROpt -> ROpt
succ :: ROpt -> ROpt
$csucc :: ROpt -> ROpt
Enum, ROpt
ROpt -> ROpt -> Bounded ROpt
forall a. a -> a -> Bounded a
maxBound :: ROpt
$cmaxBound :: ROpt
minBound :: ROpt
$cminBound :: ROpt
Bounded)

-- | extract the regex options from the type level list

class GetROpts (os :: [ROpt]) where
  getROpts :: ([String], [RL.PCREOption])
instance GetROpts '[] where
  getROpts :: ([String], [PCREOption])
getROpts = ([], [])
instance ( Typeable r
         , GetROpt r
         , GetROpts rs
         ) => GetROpts (r ': rs) where
  getROpts :: ([String], [PCREOption])
getROpts = ((Typeable r => String
forall k (r :: k). Typeable r => String
showTK @r String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([String] -> [String])
-> ([PCREOption] -> [PCREOption])
-> ([String], [PCREOption])
-> ([String], [PCREOption])
forall (a :: Type -> Type -> Type) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (GetROpt r => PCREOption
forall (o :: ROpt). GetROpt o => PCREOption
getROpt @r PCREOption -> [PCREOption] -> [PCREOption]
forall a. a -> [a] -> [a]
:)) (GetROpts rs => ([String], [PCREOption])
forall (os :: [ROpt]). GetROpts os => ([String], [PCREOption])
getROpts @rs)

-- | display regex options

displayROpts :: [String] -> String
displayROpts :: [String] -> String
displayROpts [String]
xs = String
"[" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd [String]
xs) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"]"

-- | convert type level regex option to the value level

class GetROpt (o :: ROpt) where
  getROpt :: RL.PCREOption
instance GetROpt 'Anchored where getROpt :: PCREOption
getROpt = PCREOption
RL.anchored
instance GetROpt 'AutoCallout where getROpt :: PCREOption
getROpt = PCREOption
RL.auto_callout
--instance GetROpt 'BsrAnycrlf where getROpt = RL.bsr_anycrlf

--instance GetROpt 'BsrUnicode where getROpt = RL.bsr_unicode

instance GetROpt 'Caseless where getROpt :: PCREOption
getROpt = PCREOption
RL.caseless
instance GetROpt 'DollarEndonly where getROpt :: PCREOption
getROpt = PCREOption
RL.dollar_endonly
instance GetROpt 'Dotall where getROpt :: PCREOption
getROpt = PCREOption
RL.dotall
instance GetROpt 'Dupnames where getROpt :: PCREOption
getROpt = PCREOption
RL.dupnames
instance GetROpt 'Extended where getROpt :: PCREOption
getROpt = PCREOption
RL.extended
instance GetROpt 'Extra where getROpt :: PCREOption
getROpt = PCREOption
RL.extra
instance GetROpt 'Firstline where getROpt :: PCREOption
getROpt = PCREOption
RL.firstline
instance GetROpt 'Multiline where getROpt :: PCREOption
getROpt = PCREOption
RL.multiline
--instance GetROpt 'NewlineAny where getROpt = RL.newline_any

--instance GetROpt 'NewlineAnycrlf where getROpt = RL.newline_anycrlf

instance GetROpt 'NewlineCr where getROpt :: PCREOption
getROpt = PCREOption
RL.newline_cr
instance GetROpt 'NewlineCrlf where getROpt :: PCREOption
getROpt = PCREOption
RL.newline_crlf
instance GetROpt 'NewlineLf where getROpt :: PCREOption
getROpt = PCREOption
RL.newline_lf
instance GetROpt 'NoAutoCapture where getROpt :: PCREOption
getROpt = PCREOption
RL.no_auto_capture
instance GetROpt 'Ungreedy where getROpt :: PCREOption
getROpt = PCREOption
RL.ungreedy
instance GetROpt 'Utf8 where getROpt :: PCREOption
getROpt = PCREOption
RL.utf8
instance GetROpt 'NoUtf8Check where getROpt :: PCREOption
getROpt = PCREOption
RL.no_utf8_check

-- | simple regex string replacement options

data ReplaceFnSub =
    RPrepend
  | ROverWrite
  | RAppend
  deriving stock (ReadPrec [ReplaceFnSub]
ReadPrec ReplaceFnSub
Int -> ReadS ReplaceFnSub
ReadS [ReplaceFnSub]
(Int -> ReadS ReplaceFnSub)
-> ReadS [ReplaceFnSub]
-> ReadPrec ReplaceFnSub
-> ReadPrec [ReplaceFnSub]
-> Read ReplaceFnSub
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ReplaceFnSub]
$creadListPrec :: ReadPrec [ReplaceFnSub]
readPrec :: ReadPrec ReplaceFnSub
$creadPrec :: ReadPrec ReplaceFnSub
readList :: ReadS [ReplaceFnSub]
$creadList :: ReadS [ReplaceFnSub]
readsPrec :: Int -> ReadS ReplaceFnSub
$creadsPrec :: Int -> ReadS ReplaceFnSub
Read, Int -> ReplaceFnSub -> ShowS
[ReplaceFnSub] -> ShowS
ReplaceFnSub -> String
(Int -> ReplaceFnSub -> ShowS)
-> (ReplaceFnSub -> String)
-> ([ReplaceFnSub] -> ShowS)
-> Show ReplaceFnSub
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReplaceFnSub] -> ShowS
$cshowList :: [ReplaceFnSub] -> ShowS
show :: ReplaceFnSub -> String
$cshow :: ReplaceFnSub -> String
showsPrec :: Int -> ReplaceFnSub -> ShowS
$cshowsPrec :: Int -> ReplaceFnSub -> ShowS
Show, ReplaceFnSub -> ReplaceFnSub -> Bool
(ReplaceFnSub -> ReplaceFnSub -> Bool)
-> (ReplaceFnSub -> ReplaceFnSub -> Bool) -> Eq ReplaceFnSub
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReplaceFnSub -> ReplaceFnSub -> Bool
$c/= :: ReplaceFnSub -> ReplaceFnSub -> Bool
== :: ReplaceFnSub -> ReplaceFnSub -> Bool
$c== :: ReplaceFnSub -> ReplaceFnSub -> Bool
Eq, ReplaceFnSub
ReplaceFnSub -> ReplaceFnSub -> Bounded ReplaceFnSub
forall a. a -> a -> Bounded a
maxBound :: ReplaceFnSub
$cmaxBound :: ReplaceFnSub
minBound :: ReplaceFnSub
$cminBound :: ReplaceFnSub
Bounded, Int -> ReplaceFnSub
ReplaceFnSub -> Int
ReplaceFnSub -> [ReplaceFnSub]
ReplaceFnSub -> ReplaceFnSub
ReplaceFnSub -> ReplaceFnSub -> [ReplaceFnSub]
ReplaceFnSub -> ReplaceFnSub -> ReplaceFnSub -> [ReplaceFnSub]
(ReplaceFnSub -> ReplaceFnSub)
-> (ReplaceFnSub -> ReplaceFnSub)
-> (Int -> ReplaceFnSub)
-> (ReplaceFnSub -> Int)
-> (ReplaceFnSub -> [ReplaceFnSub])
-> (ReplaceFnSub -> ReplaceFnSub -> [ReplaceFnSub])
-> (ReplaceFnSub -> ReplaceFnSub -> [ReplaceFnSub])
-> (ReplaceFnSub -> ReplaceFnSub -> ReplaceFnSub -> [ReplaceFnSub])
-> Enum ReplaceFnSub
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ReplaceFnSub -> ReplaceFnSub -> ReplaceFnSub -> [ReplaceFnSub]
$cenumFromThenTo :: ReplaceFnSub -> ReplaceFnSub -> ReplaceFnSub -> [ReplaceFnSub]
enumFromTo :: ReplaceFnSub -> ReplaceFnSub -> [ReplaceFnSub]
$cenumFromTo :: ReplaceFnSub -> ReplaceFnSub -> [ReplaceFnSub]
enumFromThen :: ReplaceFnSub -> ReplaceFnSub -> [ReplaceFnSub]
$cenumFromThen :: ReplaceFnSub -> ReplaceFnSub -> [ReplaceFnSub]
enumFrom :: ReplaceFnSub -> [ReplaceFnSub]
$cenumFrom :: ReplaceFnSub -> [ReplaceFnSub]
fromEnum :: ReplaceFnSub -> Int
$cfromEnum :: ReplaceFnSub -> Int
toEnum :: Int -> ReplaceFnSub
$ctoEnum :: Int -> ReplaceFnSub
pred :: ReplaceFnSub -> ReplaceFnSub
$cpred :: ReplaceFnSub -> ReplaceFnSub
succ :: ReplaceFnSub -> ReplaceFnSub
$csucc :: ReplaceFnSub -> ReplaceFnSub
Enum)

-- | extract replacement options from typelevel

class GetReplaceFnSub (k :: ReplaceFnSub) where
  getReplaceFnSub :: ReplaceFnSub
instance GetReplaceFnSub 'RPrepend where getReplaceFnSub :: ReplaceFnSub
getReplaceFnSub = ReplaceFnSub
RPrepend
instance GetReplaceFnSub 'ROverWrite where getReplaceFnSub :: ReplaceFnSub
getReplaceFnSub = ReplaceFnSub
ROverWrite
instance GetReplaceFnSub 'RAppend where getReplaceFnSub :: ReplaceFnSub
getReplaceFnSub = ReplaceFnSub
RAppend

-- | used by 'Predicate.ReplaceImpl' and 'RH.sub' and 'RH.gsub' to allow more flexible replacement

--   These parallel the RegexReplacement (not exported) class in "Text.Regex.PCRE.Heavy" but have overlappable instances which is problematic for this code so I use 'RReplace'

data RReplace =
     RReplace !ReplaceFnSub !String
   | RReplace1 !(String -> [String] -> String)
   | RReplace2 !(String -> String)
   | RReplace3 !([String] -> String)

instance Show RReplace where
  show :: RReplace -> String
show = \case
           RReplace ReplaceFnSub
o String
s -> String
"RReplace " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ReplaceFnSub -> String
forall a. Show a => a -> String
show ReplaceFnSub
o String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
           RReplace1 {} -> String
"RReplace1 <fn>"
           RReplace2 {} -> String
"RReplace2 <fn>"
           RReplace3 {} -> String
"RReplace3 <fn>"

-- | wrapper for a Show instance around 'Color'

newtype SColor = SColor Color
  deriving newtype Int -> SColor
SColor -> Int
SColor -> [SColor]
SColor -> SColor
SColor -> SColor -> [SColor]
SColor -> SColor -> SColor -> [SColor]
(SColor -> SColor)
-> (SColor -> SColor)
-> (Int -> SColor)
-> (SColor -> Int)
-> (SColor -> [SColor])
-> (SColor -> SColor -> [SColor])
-> (SColor -> SColor -> [SColor])
-> (SColor -> SColor -> SColor -> [SColor])
-> Enum SColor
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: SColor -> SColor -> SColor -> [SColor]
$cenumFromThenTo :: SColor -> SColor -> SColor -> [SColor]
enumFromTo :: SColor -> SColor -> [SColor]
$cenumFromTo :: SColor -> SColor -> [SColor]
enumFromThen :: SColor -> SColor -> [SColor]
$cenumFromThen :: SColor -> SColor -> [SColor]
enumFrom :: SColor -> [SColor]
$cenumFrom :: SColor -> [SColor]
fromEnum :: SColor -> Int
$cfromEnum :: SColor -> Int
toEnum :: Int -> SColor
$ctoEnum :: Int -> SColor
pred :: SColor -> SColor
$cpred :: SColor -> SColor
succ :: SColor -> SColor
$csucc :: SColor -> SColor
Enum
instance Bounded SColor where
  minBound :: SColor
minBound = Color -> SColor
SColor Color
Black
  maxBound :: SColor
maxBound = Color -> SColor
SColor Color
Default

instance Show SColor where
  show :: SColor -> String
show (SColor Color
c) =
    case Color
c of
      Color
Black -> String
"Black"
      Color
Red -> String
"Red"
      Color
Green -> String
"Green"
      Color
Yellow -> String
"Yellow"
      Color
Blue -> String
"Blue"
      Color
Magenta -> String
"Magenta"
      Color
Cyan -> String
"Cyan"
      Color
White -> String
"White"
      Color
Default -> String
"Default"

-- | get 'Color' from the typelevel

class GetColor (a :: Color) where
  getColor :: Color
instance GetColor 'Black where
  getColor :: Color
getColor = Color
Black
instance GetColor 'Red where
  getColor :: Color
getColor = Color
Red
instance GetColor 'Green where
  getColor :: Color
getColor = Color
Green
instance GetColor 'Yellow where
  getColor :: Color
getColor = Color
Yellow
instance GetColor 'Blue where
  getColor :: Color
getColor = Color
Blue
instance GetColor 'Magenta where
  getColor :: Color
getColor = Color
Magenta
instance GetColor 'Cyan where
  getColor :: Color
getColor = Color
Cyan
instance GetColor 'White where
  getColor :: Color
getColor = Color
White
instance GetColor 'Default where
  getColor :: Color
getColor = Color
Default

-- | wrapper for a Show instance around 'Color'

newtype SStyle = SStyle Style
  deriving newtype Int -> SStyle
SStyle -> Int
SStyle -> [SStyle]
SStyle -> SStyle
SStyle -> SStyle -> [SStyle]
SStyle -> SStyle -> SStyle -> [SStyle]
(SStyle -> SStyle)
-> (SStyle -> SStyle)
-> (Int -> SStyle)
-> (SStyle -> Int)
-> (SStyle -> [SStyle])
-> (SStyle -> SStyle -> [SStyle])
-> (SStyle -> SStyle -> [SStyle])
-> (SStyle -> SStyle -> SStyle -> [SStyle])
-> Enum SStyle
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: SStyle -> SStyle -> SStyle -> [SStyle]
$cenumFromThenTo :: SStyle -> SStyle -> SStyle -> [SStyle]
enumFromTo :: SStyle -> SStyle -> [SStyle]
$cenumFromTo :: SStyle -> SStyle -> [SStyle]
enumFromThen :: SStyle -> SStyle -> [SStyle]
$cenumFromThen :: SStyle -> SStyle -> [SStyle]
enumFrom :: SStyle -> [SStyle]
$cenumFrom :: SStyle -> [SStyle]
fromEnum :: SStyle -> Int
$cfromEnum :: SStyle -> Int
toEnum :: Int -> SStyle
$ctoEnum :: Int -> SStyle
pred :: SStyle -> SStyle
$cpred :: SStyle -> SStyle
succ :: SStyle -> SStyle
$csucc :: SStyle -> SStyle
Enum
instance Bounded SStyle where
  minBound :: SStyle
minBound = Style -> SStyle
SStyle Style
Normal
  maxBound :: SStyle
maxBound = Style -> SStyle
SStyle Style
Reverse

instance Show SStyle where
  show :: SStyle -> String
show (SStyle Style
c) =
    case Style
c of
      Style
Normal -> String
"Normal"
      Style
Bold -> String
"Bold"
      Style
Faint -> String
"Faint"
      Style
Italic -> String
"Italic"
      Style
Underline -> String
"Underline"
      Style
SlowBlink -> String
"SlowBlink"
      Style
ColoredNormal -> String
"ColoredNormal"
      Style
Reverse -> String
"Reverse"

-- | get 'Style' from the typelevel

class GetStyle (a :: Style) where
  getStyle :: Style
instance GetStyle 'Normal where
  getStyle :: Style
getStyle = Style
Normal
instance GetStyle 'Bold where
  getStyle :: Style
getStyle = Style
Bold
instance GetStyle 'Faint where
  getStyle :: Style
getStyle = Style
Faint
instance GetStyle 'Italic where
  getStyle :: Style
getStyle = Style
Italic
instance GetStyle 'Underline where
  getStyle :: Style
getStyle = Style
Underline
instance GetStyle 'SlowBlink where
  getStyle :: Style
getStyle = Style
SlowBlink
instance GetStyle 'ColoredNormal where
  getStyle :: Style
getStyle = Style
ColoredNormal
instance GetStyle 'Reverse where
  getStyle :: Style
getStyle = Style
Reverse

-- | return the second value if the first is not empty

unlessNull :: (AsEmpty t, Monoid m) => t -> m -> m
unlessNull :: t -> m -> m
unlessNull t
t m
m | Getting Any t () -> t -> Bool
forall s a. Getting Any s a -> s -> Bool
has Getting Any t ()
forall a. AsEmpty a => Prism' a ()
_Empty t
t = m
forall a. Monoid a => a
mempty
               | Bool
otherwise = m
m

-- | return the result of the second value if the first is not empty

unlessNullM :: (AsEmpty t, Applicative m) => t -> (t -> m ()) -> m ()
unlessNullM :: t -> (t -> m ()) -> m ()
unlessNullM t
t t -> m ()
f
  | Getting Any t () -> t -> Bool
forall s a. Getting Any s a -> s -> Bool
has Getting Any t ()
forall a. AsEmpty a => Prism' a ()
_Empty t
t = () -> m ()
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise = t -> m ()
f t
t

-- | append a space if the given value is not empty

nullSpace :: String -> String
nullSpace :: ShowS
nullSpace = String -> ShowS
nullIf String
" "

-- | combine the two values if the first is not empty

nullIf :: String -> String -> String
nullIf :: String -> ShowS
nullIf String
s String
t
  | (Char -> Bool) -> String -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
t = String
""
  | Bool
otherwise = String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
t

-- | catch an exception: for use in testing

pureTryTest :: a -> IO (Either () a)
pureTryTest :: a -> IO (Either () a)
pureTryTest = (Either SomeException a -> Either () a)
-> IO (Either SomeException a) -> IO (Either () a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SomeException -> ()) -> Either SomeException a -> Either () a
forall (a :: Type -> Type -> Type) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (() -> SomeException -> ()
forall a b. a -> b -> a
const ())) (IO (Either SomeException a) -> IO (Either () a))
-> (a -> IO (Either SomeException a)) -> a -> IO (Either () a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
Exception SomeException =>
IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
E.try @E.SomeException (IO a -> IO (Either SomeException a))
-> (a -> IO a) -> a -> IO (Either SomeException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO a
forall a. a -> IO a
E.evaluate

-- | catch an exception and the use a predicate to determine if it is the one we want: for use in testing

pureTryTestPred :: (String -> Bool)
                -> a
                -> IO (Either String (Either () a))
pureTryTestPred :: (String -> Bool) -> a -> IO (Either String (Either () a))
pureTryTestPred String -> Bool
p a
a = do
  Either String a
lr <- (SomeException -> String)
-> Either SomeException a -> Either String a
forall (a :: Type -> Type -> Type) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left SomeException -> String
forall e. Exception e => e -> String
E.displayException (Either SomeException a -> Either String a)
-> IO (Either SomeException a) -> IO (Either String a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
E.try @E.SomeException (a -> IO a
forall a. a -> IO a
E.evaluate a
a)
  Either String (Either () a) -> IO (Either String (Either () a))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Either String (Either () a) -> IO (Either String (Either () a)))
-> Either String (Either () a) -> IO (Either String (Either () a))
forall a b. (a -> b) -> a -> b
$ case Either String a
lr of
    Left String
e | String -> Bool
p String
e -> Either () a -> Either String (Either () a)
forall a b. b -> Either a b
Right (() -> Either () a
forall a b. a -> Either a b
Left ())
           | Bool
otherwise -> String -> Either String (Either () a)
forall a b. a -> Either a b
Left (String
"no match found: e=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e)
    Right a
r -> Either () a -> Either String (Either () a)
forall a b. b -> Either a b
Right (a -> Either () a
forall a b. b -> Either a b
Right a
r)

-- https://github.com/haskell/containers/pull/344

-- | draw a tree using unicode

drawTreeU :: Tree String -> String
drawTreeU :: Tree String -> String
drawTreeU  = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String)
-> (Tree String -> [String]) -> Tree String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree String -> [String]
drawU

drawU :: Tree String -> [String]
drawU :: Tree String -> [String]
drawU (Node String
x Forest String
ts0) = String
x String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Forest String -> [String]
drawSubTrees Forest String
ts0
  where
    drawSubTrees :: Forest String -> [String]
drawSubTrees [] = []
    drawSubTrees [Tree String
t] =
        String -> String -> [String] -> [String]
forall a. [a] -> [a] -> [[a]] -> [[a]]
shift String
"\x2514\x2500" String
"  " (Tree String -> [String]
drawU Tree String
t)
    drawSubTrees (Tree String
t:Forest String
ts) =
        String -> String -> [String] -> [String]
forall a. [a] -> [a] -> [[a]] -> [[a]]
shift String
"\x251c\x2500" String
"\x2502 " (Tree String -> [String]
drawU Tree String
t) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Forest String -> [String]
drawSubTrees Forest String
ts

    shift :: [a] -> [a] -> [[a]] -> [[a]]
shift [a]
one [a]
other = ([a] -> [a] -> [a]) -> [[a]] -> [[a]] -> [[a]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) ([a]
one [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [[a]]
forall a. a -> [a]
repeat [a]
other)

-- | strip ansi characters from a string and print it (for doctests)

removeAnsi :: Show a => Either String a -> IO ()
removeAnsi :: Either String a -> IO ()
removeAnsi = String -> IO ()
putStrLn (String -> IO ())
-> (Either String a -> String) -> Either String a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String a -> String
forall a. Show a => Either String a -> String
removeAnsiImpl

removeAnsiImpl :: Show a => Either String a -> String
removeAnsiImpl :: Either String a -> String
removeAnsiImpl =
  \case
     Left String
e -> let esc :: Char
esc = Char
'\x1b'
                   f :: String -> Maybe (String, String)
                   f :: String -> Maybe (String, String)
f = \case
                          [] -> Maybe (String, String)
forall a. Maybe a
Nothing
                          Char
c:String
cs | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
esc -> case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'm') String
cs of
                                                  (String
_,Char
'm':String
s) -> (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
"",String
s)
                                                  (String, String)
_ -> Maybe (String, String)
forall a. Maybe a
Nothing
                               | Bool
otherwise -> (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just ((String, String) -> Maybe (String, String))
-> (String, String) -> Maybe (String, String)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
esc) (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
cs)
               in [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> Maybe (String, String)) -> String -> [String]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr String -> Maybe (String, String)
f String
e
     Right a
a -> a -> String
forall a. Show a => a -> String
show a
a

-- | 'Identity' lens

_Id :: Lens (Identity a) (Identity b) a b
_Id :: (a -> f b) -> Identity a -> f (Identity b)
_Id a -> f b
afb (Identity a
a) = b -> Identity b
forall a. a -> Identity a
Identity (b -> Identity b) -> f b -> f (Identity b)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
afb a
a

-- | swap values in a bifunctor

class Bifunctor p => SwapC p where
  swapC :: p a b -> p b a
instance SwapC Either where
  swapC :: Either a b -> Either b a
swapC (Left a
a) = a -> Either b a
forall a b. b -> Either a b
Right a
a
  swapC (Right b
a) = b -> Either b a
forall a b. a -> Either a b
Left b
a
instance SwapC These where
  swapC :: These a b -> These b a
swapC (This a
a) = a -> These b a
forall a b. b -> These a b
That a
a
  swapC (That b
b) = b -> These b a
forall a b. a -> These a b
This b
b
  swapC (These a
a b
b) = b -> a -> These b a
forall a b. a -> b -> These a b
These b
b a
a
instance SwapC SG.Arg where
  swapC :: Arg a b -> Arg b a
swapC (SG.Arg a
a b
b) = b -> a -> Arg b a
forall a b. a -> b -> Arg a b
SG.Arg b
b a
a
instance SwapC (,) where
  swapC :: (a, b) -> (b, a)
swapC (a
a,b
b) = (b
b,a
a)
instance SwapC ((,,) a) where
  swapC :: (a, a, b) -> (a, b, a)
swapC (a
a,a
b,b
c) = (a
a,b
c,a
b)
instance SwapC ((,,,) a b) where
  swapC :: (a, b, a, b) -> (a, b, b, a)
swapC (a
a,b
b,a
c,b
d) = (a
a,b
b,b
d,a
c)
instance SwapC ((,,,,) a b c) where
  swapC :: (a, b, c, a, b) -> (a, b, c, b, a)
swapC (a
a,b
b,c
c,a
d,b
e) = (a
a,b
b,c
c,b
e,a
d)
instance SwapC ((,,,,,) a b c d) where
  swapC :: (a, b, c, d, a, b) -> (a, b, c, d, b, a)
swapC (a
a,b
b,c
c,d
d,a
e,b
f) = (a
a,b
b,c
c,d
d,b
f,a
e)
instance SwapC ((,,,,,,) a b c d e) where
  swapC :: (a, b, c, d, e, a, b) -> (a, b, c, d, e, b, a)
swapC (a
a,b
b,c
c,d
d,e
e,a
f,b
g) = (a
a,b
b,c
c,d
d,e
e,b
g,a
f)

-- | strict version of 'sum'

sum' :: (Foldable t, Num a) => t a -> a
sum' :: t a -> a
sum' = (a -> a -> a) -> a -> t a -> a
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' a -> a -> a
forall a. Num a => a -> a -> a
(+) a
0

-- | strict version of 'product'

product' :: (Foldable t, Num a) => t a -> a
product' :: t a -> a
product' = (a -> a -> a) -> a -> t a -> a
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' a -> a -> a
forall a. Num a => a -> a -> a
(*) a
1

-- | strict version of 'Data.Foldable.foldMap': replace with Data.Foldable.foldMap' when more generally available

foldMapStrict :: (Foldable t, Monoid m) => (a -> m) -> t a -> m
foldMapStrict :: (a -> m) -> t a -> m
foldMapStrict a -> m
f = (m -> a -> m) -> m -> t a -> m
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\m
z a
a -> m
z m -> m -> m
forall a. Semigroup a => a -> a -> a
<> a -> m
f a
a) m
forall a. Monoid a => a
mempty

-- | return a function that compares two lists based on the Ordering parameter

cmpOf :: Eq a => Ordering -> ([a] -> [a] -> Bool, String)
cmpOf :: Ordering -> ([a] -> [a] -> Bool, String)
cmpOf = \case
           Ordering
LT -> ([a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf, String
"IsPrefix")
           Ordering
EQ -> ([a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf, String
"IsInfix")
           Ordering
GT -> (Getting Any [a] [a] -> [a] -> Bool
forall s a. Getting Any s a -> s -> Bool
has (Getting Any [a] [a] -> [a] -> Bool)
-> ([a] -> Getting Any [a] [a]) -> [a] -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Getting Any [a] [a]
forall a. Eq a => [a] -> Prism' [a] [a]
suffixed, String
"IsSuffix")

-- | lifted if statement

ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM :: m Bool -> m a -> m a -> m a
ifM m Bool
mb m a
mt m a
mf = do
  Bool
b <- m Bool
mb
  if Bool
b then m a
mt else m a
mf

-- | associate and unassociate certain two parameter types

class AssocC p where
  assoc :: p (p a b) c -> p a (p b c)
  unassoc :: p a (p b c) -> p (p a b) c

instance AssocC Either where
  assoc :: Either (Either a b) c -> Either a (Either b c)
assoc (Left (Left a
a)) = a -> Either a (Either b c)
forall a b. a -> Either a b
Left a
a
  assoc (Left (Right b
b)) = Either b c -> Either a (Either b c)
forall a b. b -> Either a b
Right (b -> Either b c
forall a b. a -> Either a b
Left b
b)
  assoc (Right c
b) = Either b c -> Either a (Either b c)
forall a b. b -> Either a b
Right (c -> Either b c
forall a b. b -> Either a b
Right c
b)

  unassoc :: Either a (Either b c) -> Either (Either a b) c
unassoc (Left a
a) = Either a b -> Either (Either a b) c
forall a b. a -> Either a b
Left (a -> Either a b
forall a b. a -> Either a b
Left a
a)
  unassoc (Right (Left b
b)) = Either a b -> Either (Either a b) c
forall a b. a -> Either a b
Left (b -> Either a b
forall a b. b -> Either a b
Right b
b)
  unassoc (Right (Right c
b)) = c -> Either (Either a b) c
forall a b. b -> Either a b
Right c
b

instance AssocC These where
  assoc :: These (These a b) c -> These a (These b c)
assoc (This (This a
a)) = a -> These a (These b c)
forall a b. a -> These a b
This a
a
  assoc (This (That b
b)) = These b c -> These a (These b c)
forall a b. b -> These a b
That (b -> These b c
forall a b. a -> These a b
This b
b)
  assoc (This (These a
a b
b)) = a -> These b c -> These a (These b c)
forall a b. a -> b -> These a b
These a
a (b -> These b c
forall a b. a -> These a b
This b
b)
  assoc (That c
c) = These b c -> These a (These b c)
forall a b. b -> These a b
That (c -> These b c
forall a b. b -> These a b
That c
c)
  assoc (These (This a
a) c
c) = a -> These b c -> These a (These b c)
forall a b. a -> b -> These a b
These a
a (c -> These b c
forall a b. b -> These a b
That c
c)
  assoc (These (That b
b) c
c) = These b c -> These a (These b c)
forall a b. b -> These a b
That (b -> c -> These b c
forall a b. a -> b -> These a b
These b
b c
c)
  assoc (These (These a
a b
b) c
c) = a -> These b c -> These a (These b c)
forall a b. a -> b -> These a b
These a
a (b -> c -> These b c
forall a b. a -> b -> These a b
These b
b c
c)

  unassoc :: These a (These b c) -> These (These a b) c
unassoc (This a
a) = These a b -> These (These a b) c
forall a b. a -> These a b
This (a -> These a b
forall a b. a -> These a b
This a
a)
  unassoc (That (This b
b)) = These a b -> These (These a b) c
forall a b. a -> These a b
This (b -> These a b
forall a b. b -> These a b
That b
b)
  unassoc (That (That c
c)) = c -> These (These a b) c
forall a b. b -> These a b
That c
c
  unassoc (That (These b
b c
c)) = These a b -> c -> These (These a b) c
forall a b. a -> b -> These a b
These (b -> These a b
forall a b. b -> These a b
That b
b) c
c
  unassoc (These a
a (This b
b)) = These a b -> These (These a b) c
forall a b. a -> These a b
This (a -> b -> These a b
forall a b. a -> b -> These a b
These a
a b
b)
  unassoc (These a
a (That c
c)) = These a b -> c -> These (These a b) c
forall a b. a -> b -> These a b
These (a -> These a b
forall a b. a -> These a b
This a
a) c
c
  unassoc (These a
a (These b
b c
c)) = These a b -> c -> These (These a b) c
forall a b. a -> b -> These a b
These (a -> b -> These a b
forall a b. a -> b -> These a b
These a
a b
b) c
c

instance AssocC (,) where
  assoc :: ((a, b), c) -> (a, (b, c))
assoc ((a
a,b
b),c
c) = (a
a,(b
b,c
c))
  unassoc :: (a, (b, c)) -> ((a, b), c)
unassoc (a
a,(b
b,c
c)) = ((a
a,b
b),c
c)

-- | zip two lists using These

--

-- >>> simpleAlign "ab" ""

-- [This 'a',This 'b']

--

-- >>> simpleAlign "" "ab"

-- [That 'a',That 'b']

--

-- >>> simpleAlign [1] "ab"

-- [These 1 'a',That 'b']

--

-- >>> simpleAlign [] []

-- []

--

-- >>> simpleAlign [1,2] "ab"

-- [These 1 'a',These 2 'b']

--

simpleAlign :: [a] -> [b] -> [These a b]
simpleAlign :: [a] -> [b] -> [These a b]
simpleAlign [a]
as [] = (a -> These a b) -> [a] -> [These a b]
forall a b. (a -> b) -> [a] -> [b]
map a -> These a b
forall a b. a -> These a b
This [a]
as
simpleAlign [] [b]
bs = (b -> These a b) -> [b] -> [These a b]
forall a b. (a -> b) -> [a] -> [b]
map b -> These a b
forall a b. b -> These a b
That [b]
bs
simpleAlign (a
a:[a]
as) (b
b:[b]
bs) = a -> b -> These a b
forall a b. a -> b -> These a b
These a
a b
b These a b -> [These a b] -> [These a b]
forall a. a -> [a] -> [a]
: [a] -> [b] -> [These a b]
forall a b. [a] -> [b] -> [These a b]
simpleAlign [a]
as [b]
bs