{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GADTs #-}

module Data.Dynamic.Resolve.Util where

import Data.Dynamic
import Type.Reflection
import GHC.Base (Type)
import Control.Monad (join)
import Data.Foldable (foldrM)

-- * Utilities for working with Dynamics

-- | Cons a 'Dynamic' value to a 'Dynamic' list of values of the same type
dynCons :: Dynamic -- ^ value to cons
        -> Dynamic -- ^ list to cons to
        -> Maybe Dynamic
dynCons (Dynamic ta v) (Dynamic (App tl ta') vs)
  | Just HRefl <- typeRep @[] `eqTypeRep` tl
  , Just HRefl <- ta `eqTypeRep` ta'
  = pure $ Dynamic (App tl ta) $ (v:vs)
dynCons (Dynamic tl _) (Dynamic tr _) = Nothing

-- | Apply 'pure' to a value inside a 'Dynamic'
-- Note that the type of 'Applicative' you want to
-- return must be manually specified with visible type application
dynPure :: forall env. (Applicative env, Typeable env)
        => Dynamic -> Dynamic
dynPure (Dynamic ta v) = (Dynamic (App (typeRep @env) ta) (pure v))

-- | Apply 'join' to a value inside a 'Dynamic'
-- Note that the type of 'Monad' you want to
-- return must be manually specified with visible type application
dynJoin :: forall env. (Monad env, Typeable env)
        => Dynamic -> Maybe Dynamic
dynJoin (Dynamic (App tf (App tf' ta)) v)
  | Just HRefl <- typeRep @env `eqTypeRep` tf
  , Just HRefl <- tf `eqTypeRep` tf'
  = pure $ Dynamic (App tf ta) (join v)
dynJoin (Dynamic ta v) = Nothing

-- | Normalizes a 'Dynamic' value to an unnested monadic
-- value in the env monad via applications of 'join', 'pure',
-- or simply 'id' as needed.
-- Note that the type of 'Monad' you want to
-- return must be manually specified with visible type application
dynPureJoinId :: forall env. (Monad env, Typeable env)
              => Dynamic -> Dynamic
dynPureJoinId (Dynamic (App tf (App tf' ta)) v)
  | Just HRefl <- typeRep @env `eqTypeRep` tf
  , Just HRefl <- tf `eqTypeRep` tf'
  = dynPureJoinId @env $ Dynamic (App tf ta) (join v)
dynPureJoinId d@(Dynamic (App tf ta) v) = d
dynPureJoinId d = dynPure @env d

-- | Returns an empty list (wrapped in 'Dynamic') of the same type as the
-- value inside the given 'Dynamic'
dynEmptyList :: Dynamic -> Dynamic
dynEmptyList (Dynamic ta v) = Dynamic (App (typeRep @[]) ta) (tail [v])

-- | Turns a list of 'Dynamic' values into a 'Dynamic' list of values;
-- that is to say it embeds the list of items inside a single 'Dynamic'.
-- Fails if all values are not of the same type or an empty list is
-- provided.
dynMerge :: [Dynamic] -> Maybe Dynamic
dynMerge [] = Nothing
dynMerge (d:ds) = foldrM (dynCons) (dynEmptyList d) (d:ds)

-- | Turns a list of 'Dynamic' values into a 'Dynamic' list of values;
-- that is to say it embeds the list of items inside a single 'Dynamic'.
-- Fails if all values are not of the same type or an empty list is
-- provided. Takes a 'Monad' type
-- variable via visible type application to allow mixing wrapped and
-- unwrapped values—use 'dynMerge' if this is undesirable
dynMergeM :: forall f. (Monad f, Typeable f)
          => [Dynamic] -> Maybe Dynamic
dynMergeM [] = Nothing
dynMergeM ds = foldrM (dynCons) first normalized >>= dynSequence
  where
    tl = typeRep @[]
    tf = typeRep @f
    normalized@(n:_) = dynPureJoinId @f <$> ds
    first = dynEmptyList n
    dynSequence (Dynamic (App tl' (App tf' ta)) v)
      | Just HRefl <- typeRep @Type `eqTypeRep` typeRepKind ta
      , Just HRefl <- tl `eqTypeRep` tl'
      , Just HRefl <- tf `eqTypeRep` tf'
      = pure $ Dynamic (App tf' (App tl' ta)) $ sequence v
    dynSequence _ = Nothing

-- | 'fmap' lifted to work with a 'Dynamic' function and value. Fails if
-- 'fmap' would fail with the actual types of the function and value.
-- Requires the desired 'Functor' to be specified with visible type
-- application
dynFmap :: forall f. (Functor f, Typeable f)
        => Dynamic -- ^ function
        -> Dynamic -- ^ value
        -> Maybe Dynamic
dynFmap (Dynamic (Fun ta tr) f) (Dynamic (App tf ta') x)
  | Just HRefl <- typeRep @Type `eqTypeRep` typeRepKind ta
  , Just HRefl <- typeRep @Type `eqTypeRep` typeRepKind tr
  , Just HRefl <- ta `eqTypeRep` ta'
  , Just HRefl <- typeRep @f `eqTypeRep` tf
  = Just $ Dynamic (App tf tr) (f <$> x)
dynFmap _ _ = Nothing

-- | '<*>' lifted to work with a 'Dynamic' function and value. Fails if
-- '<*>' would fail with the actual types of the function and value.
-- Requires the desired 'Applicative' to be specified with visible type
-- application
dynAp :: forall f. (Applicative f, Typeable f)
      => Dynamic -- ^ function
      -> Dynamic -- ^ value
      -> Maybe Dynamic
dynAp (Dynamic (App tf (Fun ta tr)) f) (Dynamic (App tf' ta') x)
  | Just HRefl <- typeRep @Type `eqTypeRep` typeRepKind ta
  , Just HRefl <- typeRep @Type `eqTypeRep` typeRepKind tr
  , Just HRefl <- ta `eqTypeRep` ta'
  , Just HRefl <- typeRep @f `eqTypeRep` tf
  , Just HRefl <- tf `eqTypeRep` tf'
  = Just $ Dynamic (App tf tr) (f <*> x)

-- | Applies a 'Dynamic' function to a 'Dynamic' value, utilizing
-- 'fmap', 'pure', or '<*>' as needed if the function, the argument, or
-- both are wrapped in an 'Applicative'.
-- Requires the desired 'Applicative' to be specified with visible type
-- application
dynApplyFmapAp :: forall f. (Applicative f, Typeable f)
               => Dynamic -- ^ function
               -> Dynamic -- ^ value
               -> Maybe Dynamic
dynApplyFmapAp (Dynamic (App tf (Fun ta tr)) f) (Dynamic (App tf' ta') x)
  | Just HRefl <- typeRep @Type `eqTypeRep` typeRepKind ta
  , Just HRefl <- typeRep @Type `eqTypeRep` typeRepKind tr
  , Just HRefl <- ta `eqTypeRep` ta'
  , Just HRefl <- typeRep @f `eqTypeRep` tf
  , Just HRefl <- tf `eqTypeRep` tf'
  = Just $ Dynamic (App tf tr) (f <*> x)
dynApplyFmapAp (Dynamic (App tf (Fun ta tr)) f) (Dynamic ta' x)
  | Just HRefl <- typeRep @Type `eqTypeRep` typeRepKind ta
  , Just HRefl <- typeRep @Type `eqTypeRep` typeRepKind tr
  , Just HRefl <- ta `eqTypeRep` ta'
  , Just HRefl <- typeRep @f `eqTypeRep` tf
  = Just $ Dynamic (App tf tr) (f <*> (pure x))
dynApplyFmapAp (Dynamic (Fun ta tr) f) (Dynamic (App tf ta') x)
  | Just HRefl <- typeRep @Type `eqTypeRep` typeRepKind ta
  , Just HRefl <- typeRep @Type `eqTypeRep` typeRepKind tr
  , Just HRefl <- ta `eqTypeRep` ta'
  , Just HRefl <- typeRep @f `eqTypeRep` tf
  = Just $ Dynamic (App tf tr) (f <$> x)
dynApplyFmapAp f x = dynApply f x