{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
module Data.Ten.Internal where
import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics ((:*:)(..))
import Data.Portray (Portrayal(..), infixr_)
data PathComponent
= NewtypeIso
| NamedField !Text !Text
showPathComponent :: PathComponent -> ShowS
showPathComponent :: PathComponent -> ShowS
showPathComponent PathComponent
NewtypeIso = String -> ShowS
showString String
"coerce"
showPathComponent (NamedField Text
selectorName Text
_lensName) =
String -> ShowS
showString (Text -> String
T.unpack Text
selectorName)
showsPath :: Int -> [PathComponent] -> ShowS
showsPath :: Int -> [PathComponent] -> ShowS
showsPath Int
p [PathComponent]
path = case [PathComponent] -> [PathComponent]
forall a. [a] -> [a]
reverse [PathComponent]
path of
[] -> String -> ShowS
showString String
"coerce"
[PathComponent
x] -> PathComponent -> ShowS
showPathComponent PathComponent
x
(PathComponent
x:[PathComponent]
xs) -> Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
PathComponent -> ShowS
showPathComponent PathComponent
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(String -> [PathComponent] -> String) -> [PathComponent] -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((PathComponent -> ShowS) -> String -> [PathComponent] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\PathComponent
y -> String -> ShowS
showString String
" . " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathComponent -> ShowS
showPathComponent PathComponent
y)) [PathComponent]
xs
portrayPathComponent :: PathComponent -> Portrayal
portrayPathComponent :: PathComponent -> Portrayal
portrayPathComponent PathComponent
NewtypeIso = Ident -> Portrayal
Name Ident
"coerce"
portrayPathComponent (NamedField Text
selectorName Text
_) =
Ident -> Portrayal
Name (String -> Ident
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
selectorName))
portrayPath :: [PathComponent] -> Portrayal
portrayPath :: [PathComponent] -> Portrayal
portrayPath [PathComponent]
path = [PathComponent] -> Portrayal
go ([PathComponent] -> Portrayal) -> [PathComponent] -> Portrayal
forall a b. (a -> b) -> a -> b
$ [PathComponent] -> [PathComponent]
forall a. [a] -> [a]
reverse [PathComponent]
path
where
go :: [PathComponent] -> Portrayal
go [] = Ident -> Portrayal
Name Ident
"coerce"
go [PathComponent
x] = PathComponent -> Portrayal
portrayPathComponent PathComponent
x
go (PathComponent
x:[PathComponent]
xs) =
Ident -> Infixity -> Portrayal -> Portrayal -> Portrayal
Binop Ident
"." (Rational -> Infixity
infixr_ Rational
9) (PathComponent -> Portrayal
portrayPathComponent PathComponent
x) (Portrayal -> Portrayal) -> Portrayal -> Portrayal
forall a b. (a -> b) -> a -> b
$
[PathComponent] -> Portrayal
go [PathComponent]
xs
dropUnderscore :: String -> String
dropUnderscore :: ShowS
dropUnderscore (Char
'_':String
x) = String
x
dropUnderscore String
x = String
x
starFst :: (f :*: g) m -> f m
starFst :: (:*:) f g m -> f m
starFst (f m
f :*: g m
_) = f m
f
starSnd :: (f :*: g) m -> g m
starSnd :: (:*:) f g m -> g m
starSnd (f m
_ :*: g m
g) = g m
g
mapStarFst :: (f m -> f m) -> (f :*: g) m -> (f :*: g) m
mapStarFst :: (f m -> f m) -> (:*:) f g m -> (:*:) f g m
mapStarFst f m -> f m
h (f m
f :*: g m
g) = f m -> f m
h f m
f f m -> g m -> (:*:) f g m
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g m
g
mapStarSnd :: (g m -> g m) -> (f :*: g) m -> (f :*: g) m
mapStarSnd :: (g m -> g m) -> (:*:) f g m -> (:*:) f g m
mapStarSnd g m -> g m
h (f m
f :*: g m
g) = f m
f f m -> g m -> (:*:) f g m
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g m -> g m
h g m
g