{-# LANGUAGE Safe #-}
module Copilot.Core.MakeTags
{-# DEPRECATED "This module is deprecated in Copilot 3.3." #-}
(makeTags)
where
import Copilot.Core.Expr
import Copilot.Core.Spec
import Control.Monad.State
import Prelude hiding (id)
next :: State Int Int
next :: State Int Int
next = do
Int
k <- State Int Int
forall s (m :: * -> *). MonadState s m => m s
get
Int -> StateT Int Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int -> Int
forall a. Enum a => a -> a
succ Int
k)
Int -> State Int Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
k
makeTags :: Spec -> Spec
makeTags :: Spec -> Spec
makeTags Spec
spec = State Int Spec -> Int -> Spec
forall s a. State s a -> s -> a
evalState (Spec -> State Int Spec
mkTagsSpec Spec
spec) Int
0
mkTagsSpec :: Spec -> State Int Spec
mkTagsSpec :: Spec -> State Int Spec
mkTagsSpec
Spec
{ specStreams :: Spec -> [Stream]
specStreams = [Stream]
strms
, specObservers :: Spec -> [Observer]
specObservers = [Observer]
obsvs
, specTriggers :: Spec -> [Trigger]
specTriggers = [Trigger]
trigs
, specProperties :: Spec -> [Property]
specProperties = [Property]
props
} =
([Stream] -> [Observer] -> [Trigger] -> [Property] -> Spec)
-> StateT Int Identity [Stream]
-> StateT Int Identity [Observer]
-> StateT Int Identity [Trigger]
-> StateT Int Identity [Property]
-> State Int Spec
forall (m :: * -> *) a1 a2 a3 a4 r.
Monad m =>
(a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
liftM4 [Stream] -> [Observer] -> [Trigger] -> [Property] -> Spec
Spec
([Stream] -> StateT Int Identity [Stream]
mkTagsStrms [Stream]
strms)
([Observer] -> StateT Int Identity [Observer]
mkTagsObsvs [Observer]
obsvs)
([Trigger] -> StateT Int Identity [Trigger]
mkTagsTrigs [Trigger]
trigs)
([Property] -> StateT Int Identity [Property]
mkTagsProps [Property]
props)
mkTagsStrms :: [Stream] -> State Int [Stream]
mkTagsStrms :: [Stream] -> StateT Int Identity [Stream]
mkTagsStrms = (Stream -> StateT Int Identity Stream)
-> [Stream] -> StateT Int Identity [Stream]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Stream -> StateT Int Identity Stream
mkTagsStrm
where
mkTagsStrm :: Stream -> StateT Int Identity Stream
mkTagsStrm Stream
{ streamId :: Stream -> Int
streamId = Int
id
, streamBuffer :: ()
streamBuffer = [a]
xs
, streamExpr :: ()
streamExpr = Expr a
e
, streamExprType :: ()
streamExprType = Type a
t } =
do
Expr a
e' <- Expr a -> State Int (Expr a)
forall a. Expr a -> State Int (Expr a)
mkTagsExpr Expr a
e
Stream -> StateT Int Identity Stream
forall (m :: * -> *) a. Monad m => a -> m a
return (Stream -> StateT Int Identity Stream)
-> Stream -> StateT Int Identity Stream
forall a b. (a -> b) -> a -> b
$ Stream :: forall a.
(Typeable a, Typed a) =>
Int -> [a] -> Expr a -> Type a -> Stream
Stream
{ streamId :: Int
streamId = Int
id
, streamBuffer :: [a]
streamBuffer = [a]
xs
, streamExpr :: Expr a
streamExpr = Expr a
e'
, streamExprType :: Type a
streamExprType = Type a
t }
mkTagsObsvs :: [Observer] -> State Int [Observer]
mkTagsObsvs :: [Observer] -> StateT Int Identity [Observer]
mkTagsObsvs = (Observer -> StateT Int Identity Observer)
-> [Observer] -> StateT Int Identity [Observer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Observer -> StateT Int Identity Observer
mkTagsObsv
where
mkTagsObsv :: Observer -> StateT Int Identity Observer
mkTagsObsv Observer
{ observerName :: Observer -> Name
observerName = Name
name
, observerExpr :: ()
observerExpr = Expr a
e
, observerExprType :: ()
observerExprType = Type a
t } =
do
Expr a
e' <- Expr a -> State Int (Expr a)
forall a. Expr a -> State Int (Expr a)
mkTagsExpr Expr a
e
Observer -> StateT Int Identity Observer
forall (m :: * -> *) a. Monad m => a -> m a
return (Observer -> StateT Int Identity Observer)
-> Observer -> StateT Int Identity Observer
forall a b. (a -> b) -> a -> b
$ Observer :: forall a. Typeable a => Name -> Expr a -> Type a -> Observer
Observer
{ observerName :: Name
observerName = Name
name
, observerExpr :: Expr a
observerExpr = Expr a
e'
, observerExprType :: Type a
observerExprType = Type a
t }
mkTagsTrigs :: [Trigger] -> State Int [Trigger]
mkTagsTrigs :: [Trigger] -> StateT Int Identity [Trigger]
mkTagsTrigs = (Trigger -> StateT Int Identity Trigger)
-> [Trigger] -> StateT Int Identity [Trigger]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Trigger -> StateT Int Identity Trigger
mkTagsTrig
where
mkTagsTrig :: Trigger -> StateT Int Identity Trigger
mkTagsTrig Trigger
{ triggerName :: Trigger -> Name
triggerName = Name
name
, triggerGuard :: Trigger -> Expr Bool
triggerGuard = Expr Bool
g
, triggerArgs :: Trigger -> [UExpr]
triggerArgs = [UExpr]
args } =
do
Expr Bool
g' <- Expr Bool -> State Int (Expr Bool)
forall a. Expr a -> State Int (Expr a)
mkTagsExpr Expr Bool
g
[UExpr]
args' <- (UExpr -> StateT Int Identity UExpr)
-> [UExpr] -> StateT Int Identity [UExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM UExpr -> StateT Int Identity UExpr
mkTagsUExpr [UExpr]
args
Trigger -> StateT Int Identity Trigger
forall (m :: * -> *) a. Monad m => a -> m a
return (Trigger -> StateT Int Identity Trigger)
-> Trigger -> StateT Int Identity Trigger
forall a b. (a -> b) -> a -> b
$ Trigger :: Name -> Expr Bool -> [UExpr] -> Trigger
Trigger
{ triggerName :: Name
triggerName = Name
name
, triggerGuard :: Expr Bool
triggerGuard = Expr Bool
g'
, triggerArgs :: [UExpr]
triggerArgs = [UExpr]
args' }
mkTagsProps :: [Property] -> State Int [Property]
mkTagsProps :: [Property] -> StateT Int Identity [Property]
mkTagsProps = (Property -> StateT Int Identity Property)
-> [Property] -> StateT Int Identity [Property]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Property -> StateT Int Identity Property
mkTagsProp
where mkTagsProp :: Property -> StateT Int Identity Property
mkTagsProp Property
p = do
Expr Bool
e' <- Expr Bool -> State Int (Expr Bool)
forall a. Expr a -> State Int (Expr a)
mkTagsExpr (Property -> Expr Bool
propertyExpr Property
p)
Property -> StateT Int Identity Property
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> StateT Int Identity Property)
-> Property -> StateT Int Identity Property
forall a b. (a -> b) -> a -> b
$ Property
p { propertyExpr :: Expr Bool
propertyExpr = Expr Bool
e' }
mkTagsUExpr :: UExpr -> State Int UExpr
mkTagsUExpr :: UExpr -> StateT Int Identity UExpr
mkTagsUExpr UExpr { uExprExpr :: ()
uExprExpr = Expr a
e, uExprType :: ()
uExprType = Type a
t } =
do
Expr a
e' <- Expr a -> State Int (Expr a)
forall a. Expr a -> State Int (Expr a)
mkTagsExpr Expr a
e
UExpr -> StateT Int Identity UExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (UExpr -> StateT Int Identity UExpr)
-> UExpr -> StateT Int Identity UExpr
forall a b. (a -> b) -> a -> b
$ UExpr :: forall a. Typeable a => Type a -> Expr a -> UExpr
UExpr { uExprExpr :: Expr a
uExprExpr = Expr a
e', uExprType :: Type a
uExprType = Type a
t }
mkTagsExpr :: Expr a -> State Int (Expr a)
mkTagsExpr :: Expr a -> State Int (Expr a)
mkTagsExpr Expr a
e0 = case Expr a
e0 of
Const Type a
t a
x -> Expr a -> State Int (Expr a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr a -> State Int (Expr a)) -> Expr a -> State Int (Expr a)
forall a b. (a -> b) -> a -> b
$ Type a -> a -> Expr a
forall a. Typeable a => Type a -> a -> Expr a
Const Type a
t a
x
Drop Type a
t DropIdx
k Int
id -> Expr a -> State Int (Expr a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr a -> State Int (Expr a)) -> Expr a -> State Int (Expr a)
forall a b. (a -> b) -> a -> b
$ Type a -> DropIdx -> Int -> Expr a
forall a. Typeable a => Type a -> DropIdx -> Int -> Expr a
Drop Type a
t DropIdx
k Int
id
Local Type a
t1 Type a
t2 Name
name Expr a
e1 Expr a
e2 -> (Expr a -> Expr a -> Expr a)
-> StateT Int Identity (Expr a)
-> State Int (Expr a)
-> State Int (Expr a)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (Type a -> Type a -> Name -> Expr a -> Expr a -> Expr a
forall a b.
Typeable a =>
Type a -> Type b -> Name -> Expr a -> Expr b -> Expr b
Local Type a
t1 Type a
t2 Name
name) (Expr a -> StateT Int Identity (Expr a)
forall a. Expr a -> State Int (Expr a)
mkTagsExpr Expr a
e1) (Expr a -> State Int (Expr a)
forall a. Expr a -> State Int (Expr a)
mkTagsExpr Expr a
e2)
Var Type a
t Name
name -> Expr a -> State Int (Expr a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr a -> State Int (Expr a)) -> Expr a -> State Int (Expr a)
forall a b. (a -> b) -> a -> b
$ Type a -> Name -> Expr a
forall a. Typeable a => Type a -> Name -> Expr a
Var Type a
t Name
name
ExternVar Type a
t Name
name Maybe [a]
e -> Expr a -> State Int (Expr a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr a -> State Int (Expr a)) -> Expr a -> State Int (Expr a)
forall a b. (a -> b) -> a -> b
$ Type a -> Name -> Maybe [a] -> Expr a
forall a. Typeable a => Type a -> Name -> Maybe [a] -> Expr a
ExternVar Type a
t Name
name Maybe [a]
e
Op1 Op1 a a
op Expr a
e -> (Expr a -> Expr a)
-> StateT Int Identity (Expr a) -> State Int (Expr a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Op1 a a -> Expr a -> Expr a
forall a b. Typeable a => Op1 a b -> Expr a -> Expr b
Op1 Op1 a a
op) (Expr a -> StateT Int Identity (Expr a)
forall a. Expr a -> State Int (Expr a)
mkTagsExpr Expr a
e)
Op2 Op2 a b a
op Expr a
e1 Expr b
e2 -> (Expr a -> Expr b -> Expr a)
-> StateT Int Identity (Expr a)
-> StateT Int Identity (Expr b)
-> State Int (Expr a)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (Op2 a b a -> Expr a -> Expr b -> Expr a
forall a b c.
(Typeable a, Typeable b) =>
Op2 a b c -> Expr a -> Expr b -> Expr c
Op2 Op2 a b a
op) (Expr a -> StateT Int Identity (Expr a)
forall a. Expr a -> State Int (Expr a)
mkTagsExpr Expr a
e1) (Expr b -> StateT Int Identity (Expr b)
forall a. Expr a -> State Int (Expr a)
mkTagsExpr Expr b
e2)
Op3 Op3 a b c a
op Expr a
e1 Expr b
e2 Expr c
e3 -> (Expr a -> Expr b -> Expr c -> Expr a)
-> StateT Int Identity (Expr a)
-> StateT Int Identity (Expr b)
-> StateT Int Identity (Expr c)
-> State Int (Expr a)
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (Op3 a b c a -> Expr a -> Expr b -> Expr c -> Expr a
forall a b c d.
(Typeable a, Typeable b, Typeable c) =>
Op3 a b c d -> Expr a -> Expr b -> Expr c -> Expr d
Op3 Op3 a b c a
op) (Expr a -> StateT Int Identity (Expr a)
forall a. Expr a -> State Int (Expr a)
mkTagsExpr Expr a
e1) (Expr b -> StateT Int Identity (Expr b)
forall a. Expr a -> State Int (Expr a)
mkTagsExpr Expr b
e2) (Expr c -> StateT Int Identity (Expr c)
forall a. Expr a -> State Int (Expr a)
mkTagsExpr Expr c
e3)
Label Type a
t Name
s Expr a
e -> (Expr a -> Expr a) -> State Int (Expr a) -> State Int (Expr a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Type a -> Name -> Expr a -> Expr a
forall a. Typeable a => Type a -> Name -> Expr a -> Expr a
Label Type a
t Name
s) (Expr a -> State Int (Expr a)
forall a. Expr a -> State Int (Expr a)
mkTagsExpr Expr a
e)