{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE EmptyCase              #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE KindSignatures         #-}
{-# LANGUAGE LambdaCase             #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE PolyKinds              #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE UndecidableInstances   #-}

{-# OPTIONS_GHC -Wall #-}

{-|
Operators for expressions over lifted values

- Lifting Fortran types to higher-level representations
- Folds over arrays (sum, product)
- High-level mathematical functions (factorial...)
-}

module Language.Fortran.Model.Op.High where


import           Control.Monad.Reader.Class       (MonadReader, asks)
import           Data.Functor.Compose

import           Language.Expression
import           Language.Expression.Pretty

import           Language.Fortran.Model.Repr
import           Language.Fortran.Model.Repr.Prim

--------------------------------------------------------------------------------
--  High-level Operations
--------------------------------------------------------------------------------

data HighOp t a where
  HopLift :: LiftDOp t a -> HighOp t a


instance HFunctor HighOp
instance HTraversable HighOp where
  htraverse f = \case
    HopLift x -> HopLift <$> htraverse f x

instance (MonadReader r m, HasPrimReprHandlers r) => HFoldableAt (Compose m HighRepr) HighOp where
  hfoldMap f = \case
    HopLift x -> hfoldMap f x

instance Pretty2 HighOp where
  prettys2Prec p (HopLift x) = prettys2Prec p x

--------------------------------------------------------------------------------
--  Lifting Fortran values
--------------------------------------------------------------------------------

data LiftDOp t a where
  LiftDOp :: LiftD b a => t b -> LiftDOp t a

instance HFunctor LiftDOp where
instance HTraversable LiftDOp where
  htraverse f = \case
    LiftDOp x -> LiftDOp <$> f x

instance (MonadReader r m, HasPrimReprHandlers r
         ) => HFoldableAt (Compose m HighRepr) LiftDOp where
  hfoldMap = implHfoldMapCompose $ \case
    LiftDOp x -> do
      env <- asks primReprHandlers
      pure $ liftDRepr env x

instance Pretty2 LiftDOp where
  prettys2Prec p = \case
    -- TODO: Consider adding printed evidence of the lifting
    LiftDOp x -> prettys1Prec p x