{-# 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 :: (forall b. t b -> f (t' b)) -> HighOp t a -> f (HighOp t' a)
htraverse forall b. t b -> f (t' b)
f = \case
    HopLift LiftDOp t a
x -> LiftDOp t' a -> HighOp t' a
forall (t :: * -> *) a. LiftDOp t a -> HighOp t a
HopLift (LiftDOp t' a -> HighOp t' a)
-> f (LiftDOp t' a) -> f (HighOp t' a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall b. t b -> f (t' b)) -> LiftDOp t a -> f (LiftDOp t' a)
forall u (h :: (u -> *) -> u -> *) (f :: * -> *) (t :: u -> *)
       (t' :: u -> *) (a :: u).
(HTraversable h, Applicative f) =>
(forall (b :: u). t b -> f (t' b)) -> h t a -> f (h t' a)
htraverse forall b. t b -> f (t' b)
f LiftDOp t a
x

instance (MonadReader r m, HasPrimReprHandlers r) => HFoldableAt (Compose m HighRepr) HighOp where
  hfoldMap :: (forall b. t b -> Compose m HighRepr b)
-> HighOp t a -> Compose m HighRepr a
hfoldMap forall b. t b -> Compose m HighRepr b
f = \case
    HopLift LiftDOp t a
x -> (forall b. t b -> Compose m HighRepr b)
-> LiftDOp t a -> Compose m HighRepr a
forall k (k1 :: k -> *) (h :: (k -> *) -> k -> *) (t :: k -> *)
       (a :: k).
HFoldableAt k1 h =>
(forall (b :: k). t b -> k1 b) -> h t a -> k1 a
hfoldMap forall b. t b -> Compose m HighRepr b
f LiftDOp t a
x

instance Pretty2 HighOp where
  prettys2Prec :: Int -> HighOp t a -> ShowS
prettys2Prec Int
p (HopLift LiftDOp t a
x) = Int -> LiftDOp t a -> ShowS
forall k k1 (op :: (k -> *) -> k1 -> *) (t :: k -> *) (a :: k1).
(Pretty2 op, Pretty1 t) =>
Int -> op t a -> ShowS
prettys2Prec Int
p LiftDOp t a
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 :: (forall b. t b -> f (t' b)) -> LiftDOp t a -> f (LiftDOp t' a)
htraverse forall b. t b -> f (t' b)
f = \case
    LiftDOp t b
x -> t' b -> LiftDOp t' a
forall b a (t :: * -> *). LiftD b a => t b -> LiftDOp t a
LiftDOp (t' b -> LiftDOp t' a) -> f (t' b) -> f (LiftDOp t' a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t b -> f (t' b)
forall b. t b -> f (t' b)
f t b
x

instance (MonadReader r m, HasPrimReprHandlers r
         ) => HFoldableAt (Compose m HighRepr) LiftDOp where
  hfoldMap :: (forall b. t b -> Compose m HighRepr b)
-> LiftDOp t a -> Compose m HighRepr a
hfoldMap = (LiftDOp HighRepr a -> m (HighRepr a))
-> (forall b. t b -> Compose m HighRepr b)
-> LiftDOp t a
-> Compose m HighRepr a
forall k1 (h :: (k1 -> *) -> k1 -> *) (m :: * -> *) (k :: k1 -> *)
       (a :: k1) (t :: k1 -> *).
(HTraversable h, Monad m) =>
(h k a -> m (k a))
-> (forall (b :: k1). t b -> Compose m k b)
-> h t a
-> Compose m k a
implHfoldMapCompose ((LiftDOp HighRepr a -> m (HighRepr a))
 -> (forall b. t b -> Compose m HighRepr b)
 -> LiftDOp t a
 -> Compose m HighRepr a)
-> (LiftDOp HighRepr a -> m (HighRepr a))
-> (forall b. t b -> Compose m HighRepr b)
-> LiftDOp t a
-> Compose m HighRepr a
forall a b. (a -> b) -> a -> b
$ \case
    LiftDOp HighRepr b
x -> do
      PrimReprHandlers
env <- (r -> PrimReprHandlers) -> m PrimReprHandlers
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks r -> PrimReprHandlers
forall r. HasPrimReprHandlers r => r -> PrimReprHandlers
primReprHandlers
      HighRepr a -> m (HighRepr a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HighRepr a -> m (HighRepr a)) -> HighRepr a -> m (HighRepr a)
forall a b. (a -> b) -> a -> b
$ PrimReprHandlers -> HighRepr b -> HighRepr a
forall b a.
LiftD b a =>
PrimReprHandlers -> HighRepr b -> HighRepr a
liftDRepr PrimReprHandlers
env HighRepr b
x

instance Pretty2 LiftDOp where
  prettys2Prec :: Int -> LiftDOp t a -> ShowS
prettys2Prec Int
p = \case
    -- TODO: Consider adding printed evidence of the lifting
    LiftDOp t b
x -> Int -> t b -> ShowS
forall k (t :: k -> *) (a :: k). Pretty1 t => Int -> t a -> ShowS
prettys1Prec Int
p t b
x