{-# OPTIONS_HADDOCK hide #-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Cubix.Language.Java.Parametric.Common.Semantics () where

#ifndef ONLY_ONE_LANGUAGE
import Control.Monad ( liftM )
import Data.Maybe ( fromJust )

import Data.Comp.Multi ( project, appCxt, Context, Cxt(..), AnnTerm, inject', (:-<:), ContextS )
import Data.Comp.Multi.Strategy.Classification ( dynProj )

import Cubix.Language.Java.Parametric.Common.Types
import Cubix.Language.Java.Parametric.Full
import Cubix.Language.Parametric.InjF
import Cubix.Language.Parametric.Semantics.SemanticProperties
import Cubix.Language.Parametric.Syntax.Functor
import Cubix.Language.Parametric.Syntax.VarDecl as V

import Cubix.Sin.Compdata.Annotation ( annotateM )

import Unsafe.Coerce ( unsafeCoerce )

instance {-# OVERLAPPING #-} (Op :-<: gs) => GetStrictness' gs Exp where
  getStrictness' :: Exp (Term gs) l -> [Strictness]
getStrictness'   (Cond _ _ _)   = [Strictness
Strict, Place -> Strictness
GuardedBy (Int -> Place
Place 0), Place -> Strictness
GuardedBy (Int -> Place
NegPlace 0)]
  getStrictness' t :: Exp (Term gs) l
t@(BinOp _ op :: Term gs OpL
op _) = case Term gs OpL -> Maybe (Op (Term gs) OpL)
forall (g :: (* -> *) -> * -> *) (f :: (* -> *) -> * -> *) h
       (a :: * -> *).
(g :<: f) =>
NatM Maybe (Cxt h f a) (g (Cxt h f a))
project Term gs OpL
op of
    Just CAnd -> [Strictness
Strict, Strictness
NoEval, Place -> Strictness
GuardedBy (Int -> Place
Place 0)]
    Just COr  -> [Strictness
Strict, Strictness
NoEval, Place -> Strictness
GuardedBy (Int -> Place
NegPlace 0)]
    _           -> Exp (Term gs) l -> [Strictness]
forall (f :: (* -> *) -> * -> *) (e :: * -> *) l.
HFoldable f =>
f e l -> [Strictness]
defaultGetStrictness Exp (Term gs) l
t
  getStrictness' x :: Exp (Term gs) l
x              = Exp (Term gs) l -> [Strictness]
forall (f :: (* -> *) -> * -> *) (e :: * -> *) l.
HFoldable f =>
f e l -> [Strictness]
defaultGetStrictness Exp (Term gs) l
x

instance {-# OVERLAPPING #-} InsertAt' MJavaSig BlockItemL Stmt where
  -- I swear I remember writing something that could safely e.g.:
  -- cast a (CStatement e i) to (CStatement e CStatementL)
  insertAt' :: NodeEvaluationPoint
-> AnnTerm a MJavaSig BlockItemL
-> (:&:) Stmt a (AnnTerm a MJavaSig) i
-> m (AnnTerm a MJavaSig i)
insertAt' EnterEvalPoint t :: AnnTerm a MJavaSig BlockItemL
t s :: (:&:) Stmt a (AnnTerm a MJavaSig) i
s =  (AnnTerm a MJavaSig StmtL -> AnnTerm a MJavaSig i)
-> m (AnnTerm a MJavaSig StmtL) -> m (AnnTerm a MJavaSig i)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM AnnTerm a MJavaSig StmtL -> AnnTerm a MJavaSig i
forall a i j. AnnTerm a MJavaSig i -> AnnTerm a MJavaSig j
convertTerm (m (AnnTerm a MJavaSig StmtL) -> m (AnnTerm a MJavaSig i))
-> m (AnnTerm a MJavaSig StmtL) -> m (AnnTerm a MJavaSig i)
forall a b. (a -> b) -> a -> b
$ (Context (Sum MJavaSig :&: a) (AnnTerm a MJavaSig) StmtL
 -> AnnTerm a MJavaSig StmtL)
-> m (Context (Sum MJavaSig :&: a) (AnnTerm a MJavaSig) StmtL)
-> m (AnnTerm a MJavaSig StmtL)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Context (Sum MJavaSig :&: a) (AnnTerm a MJavaSig) StmtL
-> AnnTerm a MJavaSig StmtL
forall (f :: (* -> *) -> * -> *) h (a :: * -> *).
HFunctor f =>
Context f (Cxt h f a) :-> Cxt h f a
appCxt (m (Context (Sum MJavaSig :&: a) (AnnTerm a MJavaSig) StmtL)
 -> m (AnnTerm a MJavaSig StmtL))
-> m (Context (Sum MJavaSig :&: a) (AnnTerm a MJavaSig) StmtL)
-> m (AnnTerm a MJavaSig StmtL)
forall a b. (a -> b) -> a -> b
$ Cxt Hole (Sum MJavaSig) (AnnTerm a MJavaSig) StmtL
-> m (Context (Sum MJavaSig :&: a) (AnnTerm a MJavaSig) StmtL)
forall (f :: (* -> *) -> * -> *) a (m :: * -> *).
(HTraversable f, MonadAnnotater a m) =>
CxtFunM m f (f :&: a)
annotateM Cxt Hole (Sum MJavaSig) (AnnTerm a MJavaSig) StmtL
e
    where
      e :: ContextS MJavaSig (AnnTerm _ MJavaSig) StmtL
      e :: Cxt Hole (Sum MJavaSig) (AnnTerm a MJavaSig) StmtL
e = CxtS Hole MJavaSig (AnnTerm a MJavaSig) [BlockItemL]
-> CxtS Hole MJavaSig (AnnTerm a MJavaSig) BlockEndL
-> Cxt Hole (Sum MJavaSig) (AnnTerm a MJavaSig) StmtL
forall h (fs :: [(* -> *) -> * -> *]) (a :: * -> *) j.
(Block :-<: fs, InjF fs BlockL j) =>
CxtS h fs a [BlockItemL] -> CxtS h fs a BlockEndL -> CxtS h fs a j
V.iBlock ([Cxt Hole (Sum MJavaSig) (AnnTerm a MJavaSig) BlockItemL]
-> CxtS Hole MJavaSig (AnnTerm a MJavaSig) [BlockItemL]
forall (f :: * -> *) (e :: * -> *) l.
(InsertF f e, Typeable l) =>
f (e l) -> e (f l)
insertF [AnnTerm a MJavaSig BlockItemL
-> Cxt Hole (Sum MJavaSig) (AnnTerm a MJavaSig) BlockItemL
forall (a :: * -> *) i (f :: (* -> *) -> * -> *).
a i -> Cxt Hole f a i
Hole AnnTerm a MJavaSig BlockItemL
t, Cxt Hole (Sum MJavaSig) (AnnTerm a MJavaSig) StmtL
-> Cxt Hole (Sum MJavaSig) (AnnTerm a MJavaSig) BlockItemL
forall (fs :: [(* -> *) -> * -> *]) l l' h (a :: * -> *).
InjF fs l l' =>
CxtS h fs a l -> CxtS h fs a l'
injF ((AnnTerm a MJavaSig StmtL -> Context _ (AnnTerm a MJavaSig) StmtL
forall (a :: * -> *) i (f :: (* -> *) -> * -> *).
a i -> Cxt Hole f a i
Hole (AnnTerm a MJavaSig StmtL -> Context _ (AnnTerm a MJavaSig) StmtL)
-> AnnTerm a MJavaSig StmtL -> Context _ (AnnTerm a MJavaSig) StmtL
forall a b. (a -> b) -> a -> b
$ Maybe (AnnTerm a MJavaSig StmtL) -> AnnTerm a MJavaSig StmtL
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (AnnTerm a MJavaSig StmtL) -> AnnTerm a MJavaSig StmtL)
-> Maybe (AnnTerm a MJavaSig StmtL) -> AnnTerm a MJavaSig StmtL
forall a b. (a -> b) -> a -> b
$ AnnTerm a MJavaSig i -> Maybe (AnnTerm a MJavaSig StmtL)
forall (f :: * -> *) l l'. DynCase f l => f l' -> Maybe (f l)
dynProj (AnnTerm a MJavaSig i -> Maybe (AnnTerm a MJavaSig StmtL))
-> AnnTerm a MJavaSig i -> Maybe (AnnTerm a MJavaSig StmtL)
forall a b. (a -> b) -> a -> b
$ (:&:) Stmt a (AnnTerm a MJavaSig) i -> AnnTerm a MJavaSig i
forall (f :: (* -> *) -> * -> *) (g :: (* -> *) -> * -> *) p h
       (a :: * -> *).
(f :<: g) =>
(:&:) f p (Cxt h (g :&: p) a) :-> Cxt h (g :&: p) a
inject' (:&:) Stmt a (AnnTerm a MJavaSig) i
s) :: Context _ _ StmtL)]) CxtS Hole MJavaSig (AnnTerm a MJavaSig) BlockEndL
forall (fs :: [(* -> *) -> * -> *]) h (a :: * -> *).
(EmptyBlockEnd :-<: fs, All HFunctor fs) =>
CxtS h fs a BlockEndL
EmptyBlockEnd'

      convertTerm :: AnnTerm a MJavaSig i -> AnnTerm a MJavaSig j
      convertTerm :: AnnTerm a MJavaSig i -> AnnTerm a MJavaSig j
convertTerm = AnnTerm a MJavaSig i -> AnnTerm a MJavaSig j
forall a b. a -> b
unsafeCoerce
  insertAt' _ _ t :: (:&:) Stmt a (AnnTerm a MJavaSig) i
t = AnnTerm a MJavaSig i -> m (AnnTerm a MJavaSig i)
forall (m :: * -> *) a. Monad m => a -> m a
return (AnnTerm a MJavaSig i -> m (AnnTerm a MJavaSig i))
-> AnnTerm a MJavaSig i -> m (AnnTerm a MJavaSig i)
forall a b. (a -> b) -> a -> b
$ (:&:) Stmt a (AnnTerm a MJavaSig) i -> AnnTerm a MJavaSig i
forall (f :: (* -> *) -> * -> *) (g :: (* -> *) -> * -> *) p h
       (a :: * -> *).
(f :<: g) =>
(:&:) f p (Cxt h (g :&: p) a) :-> Cxt h (g :&: p) a
inject' (:&:) Stmt a (AnnTerm a MJavaSig) i
t

  -- While's always start their own basic block. Kinda correct, but kinda not
  -- We're disabling this disablement as a workaround for a bug
  --canInsertAt' EnterEvalPoint _ (While _ _ :&: _) = False
  canInsertAt' :: NodeEvaluationPoint
-> Proxy BlockItemL -> (:&:) Stmt a (AnnTerm a MJavaSig) i -> Bool
canInsertAt' EnterEvalPoint _ _ = Bool
True
  canInsertAt' _              _ _ = Bool
False

#endif