Core.hs

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

{-# OPTIONS_GHC -Wall #-}

{-|
Actual Fortran language operators. For expressions over normal Fortran values
that are actually representable in Fortran.

+, -, *, /, read array, etc...
-}
module Language.Fortran.Model.Op.Core
  (
    CoreOp(..)
  , Op(..)
  , OpKind(..)
  , OpSpec(..)
  ) where

import           Data.Functor.Compose

#if MIN_VERSION_singletons(3,0,0)
import           Data.List.Singletons
import           GHC.TypeLits.Singletons
#else
import           Data.Singletons.Prelude.List
import           Data.Singletons.TypeLits
#endif

import           Data.Vinyl
import           Data.Vinyl.Curry

import           Language.Expression
import           Language.Expression.Pretty

import           Language.Fortran.Model.Repr
import           Language.Fortran.Model.Op.Core.Core
import           Language.Fortran.Model.Op.Core.Eval
import           Language.Fortran.Model.Singletons
import           Language.Fortran.Model.Types


data CoreOp t a where
  CoreOp
    :: Op (Length args) ok
    -> OpSpec ok args result
    -> Rec t args
    -> CoreOp t result

instance HFunctor CoreOp where
instance HTraversable CoreOp where
  htraverse f (CoreOp op opr args) = CoreOp op opr <$> rtraverse f args

instance (MonadEvalFortran r m) => HFoldableAt (Compose m CoreRepr) CoreOp where
  hfoldMap = implHfoldMapCompose $ \(CoreOp op opr args) -> evalCoreOp op opr args

instance (MonadEvalFortran r m) => HFoldableAt (Compose m HighRepr) CoreOp where
  hfoldMap = implHfoldMapCompose $ fmap HRCore . hfoldA .
    hmap (\case
               HRCore x -> x
               HRHigh _ -> error "impossible")

instance Pretty2 CoreOp where
  prettys2Prec p (CoreOp op opr args) = prettysPrecOp p opr op args

showsPrim :: Prim p k a -> a -> ShowS
showsPrim = \case
  PInt8   -> shows
  PInt16  -> shows
  PInt32  -> shows
  PInt64  -> shows
  PBool8  -> shows
  PBool16 -> shows
  PBool32 -> shows
  PBool64 -> shows
  PFloat  -> shows
  PDouble -> shows
  PChar   -> shows

prettysPrecOp
  :: Pretty1 t
  => Int
  -> OpSpec ok args result
  -> Op (Length args) ok
  -> Rec t args -> ShowS
prettysPrecOp p = \case
  OSLit px x -> \case
    OpLit -> runcurry $ showsPrim px x
  OSNum1 _ _ _ -> \case
    OpNeg -> runcurry $ prettys1PrecUnop 8 "-" p
    OpPos -> runcurry $ prettys1PrecUnop 8 "+" p
  OSNum2 _ _ _ _ _ -> \case
    OpAdd -> runcurry $ prettys1PrecBinop 5 " + " p
    OpSub -> runcurry $ prettys1PrecBinop 5 " - " p
    OpMul -> runcurry $ prettys1PrecBinop 6 " * " p
    OpDiv -> runcurry $ prettys1PrecBinop 6 " / " p
  OSLogical1 _ _ -> \case
    OpNot -> runcurry $ prettys1PrecUnop 8 "!" p
  OSLogical2 _ _ _ -> \case
    OpAnd      -> runcurry $ prettys1PrecBinop 3 " && " p
    OpOr       -> runcurry $ prettys1PrecBinop 2 " || " p
    OpEquiv    -> runcurry $ prettys1PrecBinop 1 " <=> " p
    OpNotEquiv -> runcurry $ prettys1PrecBinop 1 " </=> " p
  OSEq _ _ _ _ -> \case
    OpEq -> runcurry $ prettys1PrecBinop 4 " = " p
    OpNE -> runcurry $ prettys1PrecBinop 4 " /= " p
  OSRel _ _ _ _ -> \case
    OpLT -> runcurry $ prettys1PrecBinop 4 " < " p
    OpLE -> runcurry $ prettys1PrecBinop 4 " <= " p
    OpGT -> runcurry $ prettys1PrecBinop 4 " > " p
    OpGE -> runcurry $ prettys1PrecBinop 4 " >= " p
  OSLookup _ -> \case
    OpLookup ->
      runcurry $ \arr i ->
      showParen (p > 9) $ prettys1Prec 10 arr .
                          showString "[" . prettys1Prec 0 i .
                          showString "]"
  OSDeref _ fname -> \case
    OpDeref -> runcurry $ \r ->
      showParen (p > 9) $ prettys1Prec 10 r .
      showString "%" .
      showString (withKnownSymbol fname (symbolVal fname))

-- TODO: HEq instance

-- instance HEq CoreOp where
--   liftHEq he le (CoreOp op1 opr1 args1) (CoreOp op2 opr2 args2) =
--     eqOp op1 op2 &&
--     eqOpR opr1 opr2 &&
--     liftEqRec (he _) args1 args2