{-# OPTIONS_HADDOCK hide #-}

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

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

import Data.Type.Equality ( (:~:)(..), gcastWith )
import Data.Proxy ( Proxy(..) )

import Data.Comp.Multi ( (:-<:), project, inject')
import Data.Comp.Multi.Strategy.Classification ( KDynCase(..), kIsSort )

import Cubix.Language.Lua.Parametric.Common.Types
import Cubix.Language.Lua.Parametric.Full
import Cubix.Language.Parametric.Semantics.SemanticProperties
import Cubix.Language.Parametric.Syntax

import Cubix.Sin.Compdata.Annotation ( annM )

instance {-# OVERLAPPING #-} (Binop :-<: gs) => GetStrictness' gs Exp where
  getStrictness' :: Exp (Term gs) l -> [Strictness]
getStrictness' t :: Exp (Term gs) l
t@(Binop op :: Term gs BinopL
op _ _) = case Term gs BinopL -> Maybe (Binop (Term gs) BinopL)
forall (g :: (* -> *) -> * -> *) (f :: (* -> *) -> * -> *) h
       (a :: * -> *).
(g :<: f) =>
NatM Maybe (Cxt h f a) (g (Cxt h f a))
project Term gs BinopL
op of
    Just And -> [Strictness
NoEval, Strictness
Strict, Place -> Strictness
GuardedBy (Int -> Place
Place 1)]
    Just Or  -> [Strictness
NoEval, Strictness
Strict, Place -> Strictness
GuardedBy (Int -> Place
NegPlace 1)]
    _           -> 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

-- Special casing functions so we don't put stuff at top level b/c looks weird even though correct
instance {-# OVERLAPPING #-} InsertAt' MLuaSig BlockItemL ListF where
  insertAt' :: NodeEvaluationPoint
-> AnnTerm a MLuaSig BlockItemL
-> (:&:) ListF a (AnnTerm a MLuaSig) i
-> m (AnnTerm a MLuaSig i)
insertAt' EnterEvalPoint e :: AnnTerm a MLuaSig BlockItemL
e t :: (:&:) ListF a (AnnTerm a MLuaSig) i
t = case (:&:) ListF a (AnnTerm a MLuaSig) i -> Maybe (i :~: [BlockItemL])
forall (f :: (* -> *) -> * -> *) a (e :: * -> *) b.
KDynCase f a =>
f e b -> Maybe (b :~: a)
kdyncase (:&:) ListF a (AnnTerm a MLuaSig) i
t :: Maybe (_ :~: [BlockItemL]) of
                                     Nothing -> AnnTerm a MLuaSig i -> m (AnnTerm a MLuaSig i)
forall (m :: * -> *) a. Monad m => a -> m a
return (AnnTerm a MLuaSig i -> m (AnnTerm a MLuaSig i))
-> AnnTerm a MLuaSig i -> m (AnnTerm a MLuaSig i)
forall a b. (a -> b) -> a -> b
$ (:&:) ListF a (AnnTerm a MLuaSig) i -> AnnTerm a MLuaSig i
forall (f :: (* -> *) -> * -> *) (g :: (* -> *) -> * -> *) p h
       (a :: * -> *).
(f :<: g) =>
(:&:) f p (Cxt h (g :&: p) a) :-> Cxt h (g :&: p) a
inject' (:&:) ListF a (AnnTerm a MLuaSig) i
t
                                     Just p :: i :~: [BlockItemL]
p  -> (i :~: [BlockItemL])
-> ((i ~ [BlockItemL]) => m (AnnTerm a MLuaSig i))
-> m (AnnTerm a MLuaSig i)
forall k (a :: k) (b :: k) r. (a :~: b) -> ((a ~ b) => r) -> r
gcastWith i :~: [BlockItemL]
p (((i ~ [BlockItemL]) => m (AnnTerm a MLuaSig i))
 -> m (AnnTerm a MLuaSig i))
-> ((i ~ [BlockItemL]) => m (AnnTerm a MLuaSig i))
-> m (AnnTerm a MLuaSig i)
forall a b. (a -> b) -> a -> b
$ (:&:) ListF a (AnnTerm a MLuaSig) [BlockItemL]
-> Cxt NoHole (Sum MLuaSig :&: a) (K ()) [BlockItemL]
forall (f :: (* -> *) -> * -> *) (g :: (* -> *) -> * -> *) p h
       (a :: * -> *).
(f :<: g) =>
(:&:) f p (Cxt h (g :&: p) a) :-> Cxt h (g :&: p) a
inject' ((:&:) ListF a (AnnTerm a MLuaSig) [BlockItemL]
 -> Cxt NoHole (Sum MLuaSig :&: a) (K ()) [BlockItemL])
-> m ((:&:) ListF a (AnnTerm a MLuaSig) [BlockItemL])
-> m (Cxt NoHole (Sum MLuaSig :&: a) (K ()) [BlockItemL])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ListF (AnnTerm a MLuaSig) [BlockItemL]
-> m ((:&:) ListF a (AnnTerm a MLuaSig) [BlockItemL])
forall a (m :: * -> *) (f :: (* -> *) -> * -> *) (e :: * -> *) l.
MonadAnnotater a m =>
f e l -> m ((:&:) f a e l)
annM (AnnTerm a MLuaSig BlockItemL
-> Cxt NoHole (Sum MLuaSig :&: a) (K ()) [BlockItemL]
-> ListF (AnnTerm a MLuaSig) [BlockItemL]
forall l (e :: * -> *). Typeable l => e l -> e [l] -> ListF e [l]
ConsF AnnTerm a MLuaSig BlockItemL
e ((:&:) ListF a (AnnTerm a MLuaSig) i -> AnnTerm a MLuaSig i
forall (f :: (* -> *) -> * -> *) (g :: (* -> *) -> * -> *) p h
       (a :: * -> *).
(f :<: g) =>
(:&:) f p (Cxt h (g :&: p) a) :-> Cxt h (g :&: p) a
inject' (:&:) ListF a (AnnTerm a MLuaSig) i
t))
  insertAt' _              _ t :: (:&:) ListF a (AnnTerm a MLuaSig) i
t = AnnTerm a MLuaSig i -> m (AnnTerm a MLuaSig i)
forall (m :: * -> *) a. Monad m => a -> m a
return (AnnTerm a MLuaSig i -> m (AnnTerm a MLuaSig i))
-> AnnTerm a MLuaSig i -> m (AnnTerm a MLuaSig i)
forall a b. (a -> b) -> a -> b
$ (:&:) ListF a (AnnTerm a MLuaSig) i -> AnnTerm a MLuaSig i
forall (f :: (* -> *) -> * -> *) (g :: (* -> *) -> * -> *) p h
       (a :: * -> *).
(f :<: g) =>
(:&:) f p (Cxt h (g :&: p) a) :-> Cxt h (g :&: p) a
inject' (:&:) ListF a (AnnTerm a MLuaSig) i
t

  canInsertAt' :: NodeEvaluationPoint
-> Proxy BlockItemL -> (:&:) ListF a (AnnTerm a MLuaSig) i -> Bool
canInsertAt' EnterEvalPoint _ = Proxy [BlockItemL]
-> forall i (e :: * -> *). (:&:) ListF a e i -> Bool
forall (f :: (* -> *) -> * -> *) l.
KDynCase f l =>
Proxy l -> forall i (e :: * -> *). f e i -> Bool
kIsSort (Proxy [BlockItemL]
forall k (t :: k). Proxy t
Proxy :: Proxy [BlockItemL])
  canInsertAt' _              _ = Bool -> (:&:) ListF a (AnnTerm a MLuaSig) i -> Bool
forall a b. a -> b -> a
const Bool
False