{-# OPTIONS_HADDOCK hide #-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# 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' :: forall l. Exp (Term gs) l -> [Strictness]
getStrictness'   (Cond Term gs ExpL
_ Term gs ExpL
_ Term gs ExpL
_)   = [Strictness
Strict, Place -> Strictness
GuardedBy (Int -> Place
Place Int
0), Place -> Strictness
GuardedBy (Int -> Place
NegPlace Int
0)]
  getStrictness' t :: Exp (Term gs) l
t@(BinOp Term gs ExpL
_ Term gs OpL
op Term gs ExpL
_) = case Term gs OpL
op of
    Term gs OpL
CAnd' -> [Strictness
Strict, Strictness
NoEval, Place -> Strictness
GuardedBy (Int -> Place
Place Int
0)]
    Term gs OpL
COr'  -> [Strictness
Strict, Strictness
NoEval, Place -> Strictness
GuardedBy (Int -> Place
NegPlace Int
0)]
    Term gs OpL
_     -> Exp (Term gs) l -> [Strictness]
forall (f :: (* -> *) -> * -> *) (e :: * -> *) l.
HFoldable f =>
f e l -> [Strictness]
defaultGetStrictness Exp (Term gs) l
t
  getStrictness' 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' :: forall a (m :: * -> *) i.
MonadAnnotater a m =>
NodeEvaluationPoint
-> AnnTerm a MJavaSig BlockItemL
-> (:&:) Stmt a (AnnTerm a MJavaSig) i
-> m (AnnTerm a MJavaSig i)
insertAt' NodeEvaluationPoint
EnterEvalPoint AnnTerm a MJavaSig BlockItemL
t (:&:) 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
Context (Sum MJavaSig :&: a) (AnnTerm a MJavaSig)
:-> AnnTerm a MJavaSig
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)
CxtFunM m (Sum MJavaSig) (Sum MJavaSig :&: a)
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 :: Signature) (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 l.
Typeable l =>
[Cxt Hole (Sum MJavaSig) (AnnTerm a MJavaSig) l]
-> Cxt Hole (Sum MJavaSig) (AnnTerm a MJavaSig) [l]
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 :: Signature) l l' h (a :: * -> *).
InjF fs l l' =>
CxtS h fs a l -> CxtS h fs a l'
forall h (a :: * -> *).
CxtS h MJavaSig a StmtL -> CxtS h MJavaSig a BlockItemL
injF ((AnnTerm a MJavaSig StmtL -> Cxt Hole w (AnnTerm a MJavaSig) StmtL
forall (a :: * -> *) i (f :: (* -> *) -> * -> *).
a i -> Cxt Hole f a i
Hole (AnnTerm a MJavaSig StmtL -> Cxt Hole w (AnnTerm a MJavaSig) StmtL)
-> AnnTerm a MJavaSig StmtL
-> Cxt Hole w (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
(:&:) Stmt a (AnnTerm a MJavaSig) :-> AnnTerm a MJavaSig
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 h (f :: (* -> *) -> * -> *) (a :: * -> *) j.
(EmptyBlockEnd :<: f) =>
Cxt h f a BlockEndL
EmptyBlockEnd'

      convertTerm :: AnnTerm a MJavaSig i -> AnnTerm a MJavaSig j
      convertTerm :: forall a i j. AnnTerm a MJavaSig i -> AnnTerm a MJavaSig j
convertTerm = AnnTerm a MJavaSig i -> AnnTerm a MJavaSig j
forall a b. a -> b
unsafeCoerce
  insertAt' NodeEvaluationPoint
_ AnnTerm a MJavaSig BlockItemL
_ (:&:) Stmt a (AnnTerm a MJavaSig) i
t = AnnTerm a MJavaSig i -> m (AnnTerm a MJavaSig i)
forall a. a -> m a
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
(:&:) Stmt a (AnnTerm a MJavaSig) :-> AnnTerm a MJavaSig
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' :: forall a i.
NodeEvaluationPoint
-> Proxy BlockItemL -> (:&:) Stmt a (AnnTerm a MJavaSig) i -> Bool
canInsertAt' NodeEvaluationPoint
EnterEvalPoint Proxy BlockItemL
_ (:&:) Stmt a (AnnTerm a MJavaSig) i
_ = Bool
True
  canInsertAt' NodeEvaluationPoint
_              Proxy BlockItemL
_ (:&:) Stmt a (AnnTerm a MJavaSig) i
_ = Bool
False

#endif