--------------------------------------------------------------------------------
-- Copyright © 2011 National Institute of Aerospace / Galois, Inc.
--------------------------------------------------------------------------------

-- | Sets a unique tags for each external array\/function\/struct call.

{-# 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)