-- Copyright 2018-2021 Google LLC
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

-- | Internal utilities used by multiple modules.

{-# 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_)

-- | The names of a lens and field selector, or @coerce@/@_Wrapped@.
--
-- Used in deriving 'Show'/'Text.PrettyPrint.HughesPJClass.Pretty' instances
-- for field selector newtypes.
data PathComponent
  = NewtypeIso
    -- ^ Zooming in on the contents of a newtype with @coerce@ or @_Wrapped@.
  | NamedField !Text !Text
    -- ^ Zooming in on a record field with the given named selector/lens.

-- | Convert a 'PathComponent' to a 'String', with a suffix.
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)

-- | Convert a list of 'PathComponent's to a 'String', a la 'showsPrec'.
showsPath :: Int -> [PathComponent] -> ShowS
showsPath :: Int -> [PathComponent] -> ShowS
showsPath Int
p [PathComponent]
path = case [PathComponent] -> [PathComponent]
forall a. [a] -> [a]
reverse [PathComponent]
path of
  -- If the path ends up empty, that means either there's a bug, or we've added
  -- support to GHC for a new Generics representation type equivalent to Ap10,
  -- and we're looking at it as a standalone GFieldPaths00 instance.  Since
  -- that'll be a newtype, we'll represent it as "coerce", since that should
  -- work regardless of what it ends up being called.
  []     -> 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

-- | Pretty-print a 'PathComponent'.
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))

-- | Pretty-print a field path.
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

-- | Guess the name of the lens corresponding to a field.
dropUnderscore :: String -> String
dropUnderscore :: ShowS
dropUnderscore (Char
'_':String
x) = String
x
dropUnderscore String
x = String
x

-- | Access the left side of a (':*:').
starFst :: (f :*: g) m -> f m
starFst :: (:*:) f g m -> f m
starFst (f m
f :*: g m
_) = f m
f

-- | Access the right side of a (':*:').
starSnd :: (f :*: g) m -> g m
starSnd :: (:*:) f g m -> g m
starSnd (f m
_ :*: g m
g) = g m
g

-- | Modify the left side of a (':*:').
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

-- | Modify the right side of a (':*:').
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