{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE UndecidableInstances,
             CPP #-}
#if __GLASGOW_HASKELL__ >= 810
{-# LANGUAGE StandaloneKindSignatures #-}
#endif
module Parsley.Internal.Common.Utils (WQ(..), Code, Quapplicative(..), intercalate, intercalateDiff) where

import Data.List (intersperse)
import Data.String (IsString(..))

#if __GLASGOW_HASKELL__ >= 810
import Data.Kind    (Type)
import GHC.Exts    (TYPE, RuntimeRep)
#endif

#if __GLASGOW_HASKELL__ < 900
import Language.Haskell.TH (TExp, Q)
#else
import qualified Language.Haskell.TH as TH (Code, Q)
#endif

{-|
A type alias for typed template haskell code, which represents the Haskell AST for a given value.

@since 0.1.0.0
-}
#if __GLASGOW_HASKELL__ >= 810
type Code :: forall (r :: RuntimeRep). TYPE r -> Type
#endif
#if __GLASGOW_HASKELL__ < 900
type Code a = Q (TExp a)
#else
type Code a = TH.Code TH.Q a
#endif

{-|
Pronounced \"with code\", this datatype is the representation for user-land values. It pairs
a value up with its representation as Haskell @Code@. It should be manipulated using
`Quapplicative`.

@since 0.1.0.0
-}
data WQ a = WQ { WQ a -> a
__val :: a, WQ a -> Code a
__code :: Code a }

{-|
This class is used to manipulate the representations of both user-land values and defunctionalised
representations. It can be used to construct these values as well as extract their underlying value
and code representation on demand.

It is named after the @Applicative@ class, with the @Q@ standing for \"code\". The @(`>*<`)@ operator
is analogous to @(\<*>)@ and `makeQ` analogous to @pure@.

@since 0.1.0.0
-}
class Quapplicative q where
  {-|
  Combines a value with its representation to build one of the representation types.

  @since 0.1.0.0
  -}
  makeQ :: a -> Code a -> q a

  {-|
  Extracts the regular value out of the representation.

  @since 0.1.0.0
  -}
  _val :: q a -> a

  {-|
  Extracts the representation of the value as code.

  @since 0.1.0.0
  -}
  _code :: q a -> Code a

  {-|
  Pronounced \"quapp\", this can be used to combine the code of a function with the code of a value.

  > const5 = makeQ const [||const||] >*< makeQ 5 [||5||]

  is the same as saying

  > const5 = makeQ (const 5) [||const 5||]

  It is more idiomatically found as the output to the @IdiomsPlugin@.

  @since 0.1.0.0
  -}
  (>*<) :: q (a -> b) -> q a -> q b
  q (a -> b)
f >*< q a
x = b -> Code b -> q b
forall (q :: Type -> Type) a. Quapplicative q => a -> Code a -> q a
makeQ ((q (a -> b) -> a -> b
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val q (a -> b)
f) (q a -> a
forall (q :: Type -> Type) a. Quapplicative q => q a -> a
_val q a
x)) [||$$(_code f) $$(_code x)||]
infixl 9 >*<

{-|
This instance is used to manipulate values of `WQ`.

@since 0.1.0.0
-}
instance Quapplicative WQ where
  makeQ :: a -> Code a -> WQ a
makeQ = a -> Code a -> WQ a
forall a. a -> Code a -> WQ a
WQ
  _code :: WQ a -> Code a
_code = WQ a -> Code a
forall a. WQ a -> Code a
__code
  _val :: WQ a -> a
_val = WQ a -> a
forall a. WQ a -> a
__val

intercalate :: Monoid w => w -> [w] -> w
intercalate :: w -> [w] -> w
intercalate w
xs [w]
xss = [w] -> w
forall a. Monoid a => [a] -> a
mconcat (w -> [w] -> [w]
forall a. a -> [a] -> [a]
intersperse w
xs [w]
xss)

instance IsString (String -> String) where
  fromString :: String -> String -> String
fromString = String -> String -> String
showString

newtype Id a = Id {Id a -> a -> a
unId :: a -> a}
instance Semigroup (Id a) where Id a
f <> :: Id a -> Id a -> Id a
<> Id a
g = (a -> a) -> Id a
forall a. (a -> a) -> Id a
Id ((a -> a) -> Id a) -> (a -> a) -> Id a
forall a b. (a -> b) -> a -> b
$ Id a -> a -> a
forall a. Id a -> a -> a
unId Id a
f (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id a -> a -> a
forall a. Id a -> a -> a
unId Id a
g
instance Monoid (Id a) where mempty :: Id a
mempty = (a -> a) -> Id a
forall a. (a -> a) -> Id a
Id ((a -> a) -> Id a) -> (a -> a) -> Id a
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. a -> a
id

intercalateDiff :: (a -> a) -> [(a -> a)] -> a -> a
intercalateDiff :: (a -> a) -> [a -> a] -> a -> a
intercalateDiff a -> a
sep [a -> a]
xs = Id a -> a -> a
forall a. Id a -> a -> a
unId (Id a -> a -> a) -> Id a -> a -> a
forall a b. (a -> b) -> a -> b
$ Id a -> [Id a] -> Id a
forall w. Monoid w => w -> [w] -> w
intercalate ((a -> a) -> Id a
forall a. (a -> a) -> Id a
Id a -> a
sep) (((a -> a) -> Id a) -> [a -> a] -> [Id a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> a) -> Id a
forall a. (a -> a) -> Id a
Id [a -> a]
xs)