{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# 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 )

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

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' :: NodeEvaluationPoint
-> AnnTerm a MCSig BlockItemL
-> (:&:) CStatement a (AnnTerm a MCSig) i
-> m (AnnTerm a MCSig i)
insertAt' EnterEvalPoint t :: AnnTerm a MCSig BlockItemL
t s :: (:&:) 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
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)
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 :: [(* -> *) -> * -> *]) (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 :: [(* -> *) -> * -> *]) (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 (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 :: [(* -> *) -> * -> *]) l l' h (a :: * -> *).
InjF fs l l' =>
CxtS h fs a l -> CxtS h fs a l'
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
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 (fs :: [(* -> *) -> * -> *]) h (a :: * -> *).
(EmptyBlockEnd :-<: fs, All HFunctor fs) =>
CxtS h fs a BlockEndL
EmptyBlockEnd')

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

#endif