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

{-# 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

import           Data.Singletons.Prelude.List
import           Data.Singletons.TypeLits

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 :: (forall b. t b -> f (t' b)) -> CoreOp t a -> f (CoreOp t' a)
htraverse forall b. t b -> f (t' b)
f (CoreOp Op (Length args) ok
op OpSpec ok args a
opr Rec t args
args) = Op (Length args) ok
-> OpSpec ok args a -> Rec t' args -> CoreOp t' a
forall (args :: [*]) (ok :: OpKind) result (t :: * -> *).
Op (Length args) ok
-> OpSpec ok args result -> Rec t args -> CoreOp t result
CoreOp Op (Length args) ok
op OpSpec ok args a
opr (Rec t' args -> CoreOp t' a) -> f (Rec t' args) -> f (CoreOp t' a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall b. t b -> f (t' b)) -> Rec t args -> f (Rec t' args)
forall u (h :: * -> *) (f :: u -> *) (g :: u -> *) (rs :: [u]).
Applicative h =>
(forall (x :: u). f x -> h (g x)) -> Rec f rs -> h (Rec g rs)
rtraverse forall b. t b -> f (t' b)
f Rec t args
args

instance (MonadEvalFortran r m) => HFoldableAt (Compose m CoreRepr) CoreOp where
  hfoldMap :: (forall b. t b -> Compose m CoreRepr b)
-> CoreOp t a -> Compose m CoreRepr a
hfoldMap = (CoreOp CoreRepr a -> m (CoreRepr a))
-> (forall b. t b -> Compose m CoreRepr b)
-> CoreOp t a
-> Compose m CoreRepr 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 ((CoreOp CoreRepr a -> m (CoreRepr a))
 -> (forall b. t b -> Compose m CoreRepr b)
 -> CoreOp t a
 -> Compose m CoreRepr a)
-> (CoreOp CoreRepr a -> m (CoreRepr a))
-> (forall b. t b -> Compose m CoreRepr b)
-> CoreOp t a
-> Compose m CoreRepr a
forall a b. (a -> b) -> a -> b
$ \(CoreOp Op (Length args) ok
op OpSpec ok args a
opr Rec CoreRepr args
args) -> Op (Length args) ok
-> OpSpec ok args a -> Rec CoreRepr args -> m (CoreRepr a)
forall r (m :: * -> *) (args :: [*]) (ok :: OpKind) result.
MonadEvalFortran r m =>
Op (Length args) ok
-> OpSpec ok args result
-> Rec CoreRepr args
-> m (CoreRepr result)
evalCoreOp Op (Length args) ok
op OpSpec ok args a
opr Rec CoreRepr args
args

instance (MonadEvalFortran r m) => HFoldableAt (Compose m HighRepr) CoreOp where
  hfoldMap :: (forall b. t b -> Compose m HighRepr b)
-> CoreOp t a -> Compose m HighRepr a
hfoldMap = (CoreOp HighRepr a -> m (HighRepr a))
-> (forall b. t b -> Compose m HighRepr b)
-> CoreOp 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 ((CoreOp HighRepr a -> m (HighRepr a))
 -> (forall b. t b -> Compose m HighRepr b)
 -> CoreOp t a
 -> Compose m HighRepr a)
-> (CoreOp HighRepr a -> m (HighRepr a))
-> (forall b. t b -> Compose m HighRepr b)
-> CoreOp t a
-> Compose m HighRepr a
forall a b. (a -> b) -> a -> b
$ (CoreRepr a -> HighRepr a) -> m (CoreRepr a) -> m (HighRepr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CoreRepr a -> HighRepr a
forall a. CoreRepr a -> HighRepr a
HRCore (m (CoreRepr a) -> m (HighRepr a))
-> (CoreOp HighRepr a -> m (CoreRepr a))
-> CoreOp HighRepr a
-> m (HighRepr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreOp CoreRepr a -> m (CoreRepr a)
forall k (f :: * -> *) (t :: k -> *) (h :: (k -> *) -> k -> *)
       (a :: k).
(HFoldableAt (Compose f t) h, Applicative f) =>
h t a -> f (t a)
hfoldA (CoreOp CoreRepr a -> m (CoreRepr a))
-> (CoreOp HighRepr a -> CoreOp CoreRepr a)
-> CoreOp HighRepr a
-> m (CoreRepr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (forall b. HighRepr b -> CoreRepr b)
-> CoreOp HighRepr a -> CoreOp CoreRepr a
forall u (h :: (u -> *) -> u -> *) (t :: u -> *) (t' :: u -> *)
       (a :: u).
HFunctor h =>
(forall (b :: u). t b -> t' b) -> h t a -> h t' a
hmap (\case
               HRCore x -> CoreRepr b
x
               HRHigh _ -> [Char] -> CoreRepr b
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible")

instance Pretty2 CoreOp where
  prettys2Prec :: Int -> CoreOp t a -> ShowS
prettys2Prec Int
p (CoreOp Op (Length args) ok
op OpSpec ok args a
opr Rec t args
args) = Int
-> OpSpec ok args a -> Op (Length args) ok -> Rec t args -> ShowS
forall (t :: * -> *) (ok :: OpKind) (args :: [*]) result.
Pretty1 t =>
Int
-> OpSpec ok args result
-> Op (Length args) ok
-> Rec t args
-> ShowS
prettysPrecOp Int
p OpSpec ok args a
opr Op (Length args) ok
op Rec t args
args

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

prettysPrecOp
  :: Pretty1 t
  => Int
  -> OpSpec ok args result
  -> Op (Length args) ok
  -> Rec t args -> ShowS
prettysPrecOp :: Int
-> OpSpec ok args result
-> Op (Length args) ok
-> Rec t args
-> ShowS
prettysPrecOp Int
p = \case
  OSLit Prim p k a
px a
x -> \case
    Op (Length args) ok
OpLit -> CurriedF t args ShowS -> Rec t args -> ShowS
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF t args ShowS -> Rec t args -> ShowS)
-> CurriedF t args ShowS -> Rec t args -> ShowS
forall a b. (a -> b) -> a -> b
$ Prim p k a -> a -> ShowS
forall (p :: Precision) (k :: BasicType) a.
Prim p k a -> a -> ShowS
showsPrim Prim p k a
px a
x
  OSNum1 NumericBasicType k1
_ Prim p1 k1 a
_ Prim p2 k2 b
_ -> \case
    Op (Length args) ok
OpNeg -> CurriedF t args ShowS -> Rec t args -> ShowS
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF t args ShowS -> Rec t args -> ShowS)
-> CurriedF t args ShowS -> Rec t args -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> Int -> t (PrimS a) -> ShowS
forall k (t :: k -> *) (a :: k).
Pretty1 t =>
Int -> [Char] -> Int -> t a -> ShowS
prettys1PrecUnop Int
8 [Char]
"-" Int
p
    Op (Length args) ok
OpPos -> CurriedF t args ShowS -> Rec t args -> ShowS
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF t args ShowS -> Rec t args -> ShowS)
-> CurriedF t args ShowS -> Rec t args -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> Int -> t (PrimS a) -> ShowS
forall k (t :: k -> *) (a :: k).
Pretty1 t =>
Int -> [Char] -> Int -> t a -> ShowS
prettys1PrecUnop Int
8 [Char]
"+" Int
p
  OSNum2 NumericBasicType k1
_ NumericBasicType k2
_ Prim p1 k1 a
_ Prim p2 k2 b
_ Prim (PrecMax p1 p2) (BasicTypeMax k1 k2) c
_ -> \case
    Op (Length args) ok
OpAdd -> CurriedF t args ShowS -> Rec t args -> ShowS
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF t args ShowS -> Rec t args -> ShowS)
-> CurriedF t args ShowS -> Rec t args -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> Int -> t (PrimS a) -> t (PrimS b) -> ShowS
forall k1 k2 (f :: k1 -> *) (g :: k2 -> *) (a :: k1) (b :: k2).
(Pretty1 f, Pretty1 g) =>
Int -> [Char] -> Int -> f a -> g b -> ShowS
prettys1PrecBinop Int
5 [Char]
" + " Int
p
    Op (Length args) ok
OpSub -> CurriedF t args ShowS -> Rec t args -> ShowS
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF t args ShowS -> Rec t args -> ShowS)
-> CurriedF t args ShowS -> Rec t args -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> Int -> t (PrimS a) -> t (PrimS b) -> ShowS
forall k1 k2 (f :: k1 -> *) (g :: k2 -> *) (a :: k1) (b :: k2).
(Pretty1 f, Pretty1 g) =>
Int -> [Char] -> Int -> f a -> g b -> ShowS
prettys1PrecBinop Int
5 [Char]
" - " Int
p
    Op (Length args) ok
OpMul -> CurriedF t args ShowS -> Rec t args -> ShowS
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF t args ShowS -> Rec t args -> ShowS)
-> CurriedF t args ShowS -> Rec t args -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> Int -> t (PrimS a) -> t (PrimS b) -> ShowS
forall k1 k2 (f :: k1 -> *) (g :: k2 -> *) (a :: k1) (b :: k2).
(Pretty1 f, Pretty1 g) =>
Int -> [Char] -> Int -> f a -> g b -> ShowS
prettys1PrecBinop Int
6 [Char]
" * " Int
p
    Op (Length args) ok
OpDiv -> CurriedF t args ShowS -> Rec t args -> ShowS
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF t args ShowS -> Rec t args -> ShowS)
-> CurriedF t args ShowS -> Rec t args -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> Int -> t (PrimS a) -> t (PrimS b) -> ShowS
forall k1 k2 (f :: k1 -> *) (g :: k2 -> *) (a :: k1) (b :: k2).
(Pretty1 f, Pretty1 g) =>
Int -> [Char] -> Int -> f a -> g b -> ShowS
prettys1PrecBinop Int
6 [Char]
" / " Int
p
  OSLogical1 Prim p1 'BTLogical a
_ Prim 'P8 'BTLogical b
_ -> \case
    Op (Length args) ok
OpNot -> CurriedF t args ShowS -> Rec t args -> ShowS
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF t args ShowS -> Rec t args -> ShowS)
-> CurriedF t args ShowS -> Rec t args -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> Int -> t (PrimS a) -> ShowS
forall k (t :: k -> *) (a :: k).
Pretty1 t =>
Int -> [Char] -> Int -> t a -> ShowS
prettys1PrecUnop Int
8 [Char]
"!" Int
p
  OSLogical2 Prim p1 'BTLogical a
_ Prim p2 'BTLogical b
_ Prim 'P8 'BTLogical c
_ -> \case
    Op (Length args) ok
OpAnd      -> CurriedF t args ShowS -> Rec t args -> ShowS
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF t args ShowS -> Rec t args -> ShowS)
-> CurriedF t args ShowS -> Rec t args -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> Int -> t (PrimS a) -> t (PrimS b) -> ShowS
forall k1 k2 (f :: k1 -> *) (g :: k2 -> *) (a :: k1) (b :: k2).
(Pretty1 f, Pretty1 g) =>
Int -> [Char] -> Int -> f a -> g b -> ShowS
prettys1PrecBinop Int
3 [Char]
" && " Int
p
    Op (Length args) ok
OpOr       -> CurriedF t args ShowS -> Rec t args -> ShowS
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF t args ShowS -> Rec t args -> ShowS)
-> CurriedF t args ShowS -> Rec t args -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> Int -> t (PrimS a) -> t (PrimS b) -> ShowS
forall k1 k2 (f :: k1 -> *) (g :: k2 -> *) (a :: k1) (b :: k2).
(Pretty1 f, Pretty1 g) =>
Int -> [Char] -> Int -> f a -> g b -> ShowS
prettys1PrecBinop Int
2 [Char]
" || " Int
p
    Op (Length args) ok
OpEquiv    -> CurriedF t args ShowS -> Rec t args -> ShowS
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF t args ShowS -> Rec t args -> ShowS)
-> CurriedF t args ShowS -> Rec t args -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> Int -> t (PrimS a) -> t (PrimS b) -> ShowS
forall k1 k2 (f :: k1 -> *) (g :: k2 -> *) (a :: k1) (b :: k2).
(Pretty1 f, Pretty1 g) =>
Int -> [Char] -> Int -> f a -> g b -> ShowS
prettys1PrecBinop Int
1 [Char]
" <=> " Int
p
    Op (Length args) ok
OpNotEquiv -> CurriedF t args ShowS -> Rec t args -> ShowS
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF t args ShowS -> Rec t args -> ShowS)
-> CurriedF t args ShowS -> Rec t args -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> Int -> t (PrimS a) -> t (PrimS b) -> ShowS
forall k1 k2 (f :: k1 -> *) (g :: k2 -> *) (a :: k1) (b :: k2).
(Pretty1 f, Pretty1 g) =>
Int -> [Char] -> Int -> f a -> g b -> ShowS
prettys1PrecBinop Int
1 [Char]
" </=> " Int
p
  OSEq ComparableBasicTypes k1 k2
_ Prim p1 k1 a
_ Prim p2 k2 b
_ Prim 'P8 'BTLogical c
_ -> \case
    Op (Length args) ok
OpEq -> CurriedF t args ShowS -> Rec t args -> ShowS
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF t args ShowS -> Rec t args -> ShowS)
-> CurriedF t args ShowS -> Rec t args -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> Int -> t (PrimS a) -> t (PrimS b) -> ShowS
forall k1 k2 (f :: k1 -> *) (g :: k2 -> *) (a :: k1) (b :: k2).
(Pretty1 f, Pretty1 g) =>
Int -> [Char] -> Int -> f a -> g b -> ShowS
prettys1PrecBinop Int
4 [Char]
" = " Int
p
    Op (Length args) ok
OpNE -> CurriedF t args ShowS -> Rec t args -> ShowS
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF t args ShowS -> Rec t args -> ShowS)
-> CurriedF t args ShowS -> Rec t args -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> Int -> t (PrimS a) -> t (PrimS b) -> ShowS
forall k1 k2 (f :: k1 -> *) (g :: k2 -> *) (a :: k1) (b :: k2).
(Pretty1 f, Pretty1 g) =>
Int -> [Char] -> Int -> f a -> g b -> ShowS
prettys1PrecBinop Int
4 [Char]
" /= " Int
p
  OSRel ComparableBasicTypes k1 k2
_ Prim p1 k1 a
_ Prim p2 k2 b
_ Prim 'P8 'BTLogical c
_ -> \case
    Op (Length args) ok
OpLT -> CurriedF t args ShowS -> Rec t args -> ShowS
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF t args ShowS -> Rec t args -> ShowS)
-> CurriedF t args ShowS -> Rec t args -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> Int -> t (PrimS a) -> t (PrimS b) -> ShowS
forall k1 k2 (f :: k1 -> *) (g :: k2 -> *) (a :: k1) (b :: k2).
(Pretty1 f, Pretty1 g) =>
Int -> [Char] -> Int -> f a -> g b -> ShowS
prettys1PrecBinop Int
4 [Char]
" < " Int
p
    Op (Length args) ok
OpLE -> CurriedF t args ShowS -> Rec t args -> ShowS
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF t args ShowS -> Rec t args -> ShowS)
-> CurriedF t args ShowS -> Rec t args -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> Int -> t (PrimS a) -> t (PrimS b) -> ShowS
forall k1 k2 (f :: k1 -> *) (g :: k2 -> *) (a :: k1) (b :: k2).
(Pretty1 f, Pretty1 g) =>
Int -> [Char] -> Int -> f a -> g b -> ShowS
prettys1PrecBinop Int
4 [Char]
" <= " Int
p
    Op (Length args) ok
OpGT -> CurriedF t args ShowS -> Rec t args -> ShowS
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF t args ShowS -> Rec t args -> ShowS)
-> CurriedF t args ShowS -> Rec t args -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> Int -> t (PrimS a) -> t (PrimS b) -> ShowS
forall k1 k2 (f :: k1 -> *) (g :: k2 -> *) (a :: k1) (b :: k2).
(Pretty1 f, Pretty1 g) =>
Int -> [Char] -> Int -> f a -> g b -> ShowS
prettys1PrecBinop Int
4 [Char]
" > " Int
p
    Op (Length args) ok
OpGE -> CurriedF t args ShowS -> Rec t args -> ShowS
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF t args ShowS -> Rec t args -> ShowS)
-> CurriedF t args ShowS -> Rec t args -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> Int -> t (PrimS a) -> t (PrimS b) -> ShowS
forall k1 k2 (f :: k1 -> *) (g :: k2 -> *) (a :: k1) (b :: k2).
(Pretty1 f, Pretty1 g) =>
Int -> [Char] -> Int -> f a -> g b -> ShowS
prettys1PrecBinop Int
4 [Char]
" >= " Int
p
  OSLookup D (Array i result)
_ -> \case
    Op (Length args) ok
OpLookup ->
      CurriedF t args ShowS -> Rec t args -> ShowS
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF t args ShowS -> Rec t args -> ShowS)
-> CurriedF t args ShowS -> Rec t args -> ShowS
forall a b. (a -> b) -> a -> b
$ \t (Array i result)
arr t i
i ->
      Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> t (Array i result) -> ShowS
forall k (t :: k -> *) (a :: k). Pretty1 t => Int -> t a -> ShowS
prettys1Prec Int
10 t (Array i result)
arr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          [Char] -> ShowS
showString [Char]
"[" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> t i -> ShowS
forall k (t :: k -> *) (a :: k). Pretty1 t => Int -> t a -> ShowS
prettys1Prec Int
0 t i
i ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          [Char] -> ShowS
showString [Char]
"]"
  OSDeref D (Record rname fields)
_ SSymbol fname
fname -> \case
    Op (Length args) ok
OpDeref -> CurriedF t args ShowS -> Rec t args -> ShowS
forall u (f :: u -> *) (ts :: [u]) a.
CurriedF f ts a -> Rec f ts -> a
runcurry (CurriedF t args ShowS -> Rec t args -> ShowS)
-> CurriedF t args ShowS -> Rec t args -> ShowS
forall a b. (a -> b) -> a -> b
$ \t (Record rname fields)
r ->
      Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> t (Record rname fields) -> ShowS
forall k (t :: k -> *) (a :: k). Pretty1 t => Int -> t a -> ShowS
prettys1Prec Int
10 t (Record rname fields)
r ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      [Char] -> ShowS
showString [Char]
"%" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      [Char] -> ShowS
showString (Sing fname -> (KnownSymbol fname => [Char]) -> [Char]
forall (n :: Symbol) r. Sing n -> (KnownSymbol n => r) -> r
withKnownSymbol Sing fname
SSymbol fname
fname (SSymbol fname -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal SSymbol fname
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