{-# OPTIONS_HADDOCK hide #-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE UndecidableInstances #-}

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

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

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

import Cubix.Language.C.Parametric.Common.Types
import Cubix.Language.C.Parametric.Full
import Cubix.Language.Parametric.InjF
import Cubix.Language.Parametric.Semantics.SemanticProperties
import Cubix.Language.Parametric.Syntax

import Cubix.Sin.Compdata.Annotation ( annotateM )

import Unsafe.Coerce ( unsafeCoerce )

--------------------------------------------------------------------------

----------------------------------------------------------------
---------------------- Strictness  -----------------------------
----------------------------------------------------------------

instance {-# OVERLAPPING #-} (CBinaryOp :-<: gs) => GetStrictness' gs CExpression where
  getStrictness' :: forall l. CExpression (Term gs) l -> [Strictness]
getStrictness'   (CCond Term gs CExpressionL
_ Term gs (Maybe CExpressionL)
_ Term gs CExpressionL
_ Term gs ()
_)     = [Strictness
Strict, Place -> Strictness
GuardedBy (Int -> Place
Place Int
0), Place -> Strictness
GuardedBy (Int -> Place
NegPlace Int
0), Strictness
NoEval]
  getStrictness'   (CSizeofExpr Term gs CExpressionL
_ Term gs ()
_)   = [Strictness
NoEval, Strictness
NoEval]
  getStrictness' t :: CExpression (Term gs) l
t@(CBinary Term gs CBinaryOpL
op Term gs CExpressionL
_ Term gs CExpressionL
_ Term gs ()
_)  = case Term gs CBinaryOpL
op of
    Term gs CBinaryOpL
CLndOp' -> [Strictness
NoEval, Strictness
Strict, Place -> Strictness
GuardedBy (Int -> Place
Place Int
1), Strictness
NoEval]
    Term gs CBinaryOpL
CLorOp' -> [Strictness
NoEval, Strictness
Strict, Place -> Strictness
GuardedBy (Int -> Place
NegPlace Int
1), Strictness
NoEval]
    Term gs CBinaryOpL
_       -> CExpression (Term gs) l -> [Strictness]
forall (f :: (* -> *) -> * -> *) (e :: * -> *) l.
HFoldable f =>
f e l -> [Strictness]
defaultGetStrictness CExpression (Term gs) l
t
  getStrictness' CExpression (Term gs) l
x                     = CExpression (Term gs) l -> [Strictness]
forall (f :: (* -> *) -> * -> *) (e :: * -> *) l.
HFoldable f =>
f e l -> [Strictness]
defaultGetStrictness CExpression (Term gs) l
x


----------------------------------------------------------------
---------------------- Insertion  -----------------------------
----------------------------------------------------------------

instance {-# OVERLAPPING #-} InsertAt' MCSig BlockItemL CStatement 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 MCSig BlockItemL
-> (:&:) CStatement a (AnnTerm a MCSig) i
-> m (AnnTerm a MCSig i)
insertAt' NodeEvaluationPoint
EnterEvalPoint AnnTerm a MCSig BlockItemL
t (:&:) CStatement a (AnnTerm a MCSig) i
s =  (AnnTerm a MCSig CStatementL -> AnnTerm a MCSig i)
-> m (AnnTerm a MCSig CStatementL) -> m (AnnTerm a MCSig i)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM AnnTerm a MCSig CStatementL -> AnnTerm a MCSig i
forall a i j. AnnTerm a MCSig i -> AnnTerm a MCSig j
convertTerm (m (AnnTerm a MCSig CStatementL) -> m (AnnTerm a MCSig i))
-> m (AnnTerm a MCSig CStatementL) -> m (AnnTerm a MCSig i)
forall a b. (a -> b) -> a -> b
$ (Context (Sum MCSig :&: a) (AnnTerm a MCSig) CStatementL
 -> AnnTerm a MCSig CStatementL)
-> m (Context (Sum MCSig :&: a) (AnnTerm a MCSig) CStatementL)
-> m (AnnTerm a MCSig CStatementL)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Context (Sum MCSig :&: a) (AnnTerm a MCSig) CStatementL
-> AnnTerm a MCSig CStatementL
Context (Sum MCSig :&: a) (AnnTerm a MCSig) :-> AnnTerm a MCSig
forall (f :: (* -> *) -> * -> *) h (a :: * -> *).
HFunctor f =>
Context f (Cxt h f a) :-> Cxt h f a
appCxt (m (Context (Sum MCSig :&: a) (AnnTerm a MCSig) CStatementL)
 -> m (AnnTerm a MCSig CStatementL))
-> m (Context (Sum MCSig :&: a) (AnnTerm a MCSig) CStatementL)
-> m (AnnTerm a MCSig CStatementL)
forall a b. (a -> b) -> a -> b
$ Cxt Hole (Sum MCSig) (AnnTerm a MCSig) CStatementL
-> m (Context (Sum MCSig :&: a) (AnnTerm a MCSig) CStatementL)
CxtFunM m (Sum MCSig) (Sum MCSig :&: a)
forall (f :: (* -> *) -> * -> *) a (m :: * -> *).
(HTraversable f, MonadAnnotater a m) =>
CxtFunM m f (f :&: a)
annotateM Cxt Hole (Sum MCSig) (AnnTerm a MCSig) CStatementL
e
    where
      e :: ContextS MCSig (AnnTerm _ MCSig) CStatementL
      e :: Cxt Hole (Sum MCSig) (AnnTerm a MCSig) CStatementL
e = CxtS Hole MCSig (AnnTerm a MCSig) [IdentL]
-> CxtS Hole MCSig (AnnTerm a MCSig) BlockL
-> Cxt Hole (Sum MCSig) (AnnTerm a MCSig) CStatementL
forall h (fs :: Signature) (a :: * -> *) j.
(CLabeledBlock :-<: fs, InjF fs CStatementL j) =>
CxtS h fs a [IdentL] -> CxtS h fs a BlockL -> CxtS h fs a j
iCLabeledBlock CxtS Hole MCSig (AnnTerm a MCSig) [IdentL]
forall (f :: (* -> *) -> * -> *) l h (a :: * -> *).
(ListF :<: f, Typeable l, HFunctor f) =>
Cxt h f a [l]
NilF' (CxtS Hole MCSig (AnnTerm a MCSig) [BlockItemL]
-> CxtS Hole MCSig (AnnTerm a MCSig) BlockEndL
-> CxtS Hole MCSig (AnnTerm a MCSig) BlockL
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
iBlock ([Cxt Hole (Sum MCSig) (AnnTerm a MCSig) BlockItemL]
-> CxtS Hole MCSig (AnnTerm a MCSig) [BlockItemL]
forall l.
Typeable l =>
[Cxt Hole (Sum MCSig) (AnnTerm a MCSig) l]
-> Cxt Hole (Sum MCSig) (AnnTerm a MCSig) [l]
forall (f :: * -> *) (e :: * -> *) l.
(InsertF f e, Typeable l) =>
f (e l) -> e (f l)
insertF [AnnTerm a MCSig BlockItemL
-> Cxt Hole (Sum MCSig) (AnnTerm a MCSig) BlockItemL
forall (a :: * -> *) i (f :: (* -> *) -> * -> *).
a i -> Cxt Hole f a i
Hole AnnTerm a MCSig BlockItemL
t, Cxt Hole (Sum MCSig) (AnnTerm a MCSig) CStatementL
-> Cxt Hole (Sum MCSig) (AnnTerm a MCSig) 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 MCSig a CStatementL -> CxtS h MCSig a BlockItemL
injF ((AnnTerm a MCSig CStatementL
-> Cxt Hole (Sum MCSig) (AnnTerm a MCSig) CStatementL
forall (a :: * -> *) i (f :: (* -> *) -> * -> *).
a i -> Cxt Hole f a i
Hole (AnnTerm a MCSig CStatementL
 -> Cxt Hole (Sum MCSig) (AnnTerm a MCSig) CStatementL)
-> AnnTerm a MCSig CStatementL
-> Cxt Hole (Sum MCSig) (AnnTerm a MCSig) CStatementL
forall a b. (a -> b) -> a -> b
$ Maybe (AnnTerm a MCSig CStatementL) -> AnnTerm a MCSig CStatementL
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (AnnTerm a MCSig CStatementL)
 -> AnnTerm a MCSig CStatementL)
-> Maybe (AnnTerm a MCSig CStatementL)
-> AnnTerm a MCSig CStatementL
forall a b. (a -> b) -> a -> b
$ AnnTerm a MCSig i -> Maybe (AnnTerm a MCSig CStatementL)
forall (f :: * -> *) l l'. DynCase f l => f l' -> Maybe (f l)
dynProj (AnnTerm a MCSig i -> Maybe (AnnTerm a MCSig CStatementL))
-> AnnTerm a MCSig i -> Maybe (AnnTerm a MCSig CStatementL)
forall a b. (a -> b) -> a -> b
$ (:&:) CStatement a (AnnTerm a MCSig) i -> AnnTerm a MCSig i
(:&:) CStatement a (AnnTerm a MCSig) :-> AnnTerm a MCSig
forall (f :: (* -> *) -> * -> *) (g :: (* -> *) -> * -> *) p h
       (a :: * -> *).
(f :<: g) =>
(:&:) f p (Cxt h (g :&: p) a) :-> Cxt h (g :&: p) a
inject' (:&:) CStatement a (AnnTerm a MCSig) i
s) :: ContextS MCSig _ CStatementL)]) CxtS Hole MCSig (AnnTerm a MCSig) BlockEndL
forall h (f :: (* -> *) -> * -> *) (a :: * -> *) j.
(EmptyBlockEnd :<: f) =>
Cxt h f a BlockEndL
EmptyBlockEnd')

      convertTerm :: AnnTerm a MCSig i -> AnnTerm a MCSig j
      convertTerm :: forall a i j. AnnTerm a MCSig i -> AnnTerm a MCSig j
convertTerm = AnnTerm a MCSig i -> AnnTerm a MCSig j
forall a b. a -> b
unsafeCoerce
  insertAt' NodeEvaluationPoint
_ AnnTerm a MCSig BlockItemL
_ (:&:) CStatement a (AnnTerm a MCSig) i
s = AnnTerm a MCSig i -> m (AnnTerm a MCSig i)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnnTerm a MCSig i -> m (AnnTerm a MCSig i))
-> AnnTerm a MCSig i -> m (AnnTerm a MCSig i)
forall a b. (a -> b) -> a -> b
$ (:&:) CStatement a (AnnTerm a MCSig) i -> AnnTerm a MCSig i
(:&:) CStatement a (AnnTerm a MCSig) :-> AnnTerm a MCSig
forall (f :: (* -> *) -> * -> *) (g :: (* -> *) -> * -> *) p h
       (a :: * -> *).
(f :<: g) =>
(:&:) f p (Cxt h (g :&: p) a) :-> Cxt h (g :&: p) a
inject' (:&:) CStatement a (AnnTerm a MCSig) i
s

  canInsertAt' :: forall a i.
NodeEvaluationPoint
-> Proxy BlockItemL
-> (:&:) CStatement a (AnnTerm a MCSig) i
-> Bool
canInsertAt' NodeEvaluationPoint
EnterEvalPoint Proxy BlockItemL
_ (:&:) CStatement a (AnnTerm a MCSig) i
_ = Bool
True
  canInsertAt' NodeEvaluationPoint
_              Proxy BlockItemL
_ (:&:) CStatement a (AnnTerm a MCSig) i
_ = Bool
False

#endif